BioPerl-1.6.923000755000765000024 012254227337 13306 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/.travis.yml000444000765000024 341712254227334 15556 0ustar00cjfieldsstaff000000000000language: perl perl: - "5.18" - "5.16" - "5.14" - "5.12" - "5.10" env: PERL_CPANM_OPT="--notest --force --skip-satisfied" install: #This should solve problem installing Perl's DB_File & GraphViz - "sudo apt-get install libdb-dev graphviz libgd2-xpm-dev libxml2-dev 2>&1 | tail -n 4" #These are recommended or required Perl libraries: - "cpanm GD 2>&1 | tail -n 1" - "cpanm HTML::TableExtract DBI Data::Stag DB_File 2>&1 | tail -n 1" - "cpanm DBD::mysql DBD::Pg DBD::SQLite 2>&1 | tail -n 1" - "cpanm Algorithm::Munkres Array::Compare Convert::Binary::C Error 2>&1 | tail -n 1" - "cpanm Graph SVG SVG::Graph GraphViz 2>&1 | tail -n 1" - "cpanm XML::DOM::XPath XML::Parser XML::Parser::PerlSAX 2>&1 | tail -n 1" - "cpanm XML::SAX XML::SAX::Writer XML::Simple XML::LibXML XML::Twig XML::Writer 2>&1 | tail -n 1" - "cpanm PostScript::TextBlock Set::Scalar Sort::Naturally YAML | tail -n 1" - "cpanm Math::Random SOAP::Lite Spreadsheet::ParseExcel | tail -n 1" - "cpanm Bio::ASN1::EntrezGene | tail -n 1" - "cpanm Bio::Phylo | tail -n 1" #for some reason tests and deps aren't skipped here. Will have to look into it more... #git repos, seems to only work for simple checkouts, so pure perl only (TODO: look into before_script for more detail) #- "git clone https://github.com/bioperl/Bio-Root.git; export PERL5LIB=$( pwd )/Bio-Root/lib:$PERL5LIB" #This installs BioPerl itself: - "perl ./Build.PL --accept" script: - "./Build test" #TODO - send emails to bioperl-guts-l notifications: email: recipients: - bioperl-guts-l@lists.open-bio.org - cjfields1@gmail.com on_success: change on_failure: change # whitelist branches branches: only: - master - v1.6.x - topic/1.6-cherry BioPerl-1.6.923/AUTHORS000444000765000024 1440712254227324 14535 0ustar00cjfieldsstaff000000000000=head1 PRIMARY AUTHORS AND MAJOR CONTRIBUTORS TO BIOPERL =head2 Releases co-ordinated and submitted by bioperl core devs. =over =item * Sendu Bala =item * Chris Dagdigian =item * Christopher Fields =item * Mark Jensen =item * Hilmar Lapp =item * Heikki Lehväslaiho =item * Aaron Mackey =item * Brian Osborne =item * Jason Stajich =item * Lincoln Stein =back =head2 Previous Bioperl Coordinators: =over =item * Ewan Birney =item * Steven Brenner =item * Georg Fuellen =item * Steve Chervitz =back =head2 Major Contributors (Feel free to add descriptions of which modules you are responsible for if you see fit) =over =item * Richard Adams =item * Shuly Avraham - Bio::Graphics::Glyph =item * Peter Blaiklock =item * Benjamin Berman =item * Matthew Betts =item * David Block =item * Kris Boulez =item * Tim Bunce - code optimizations =item * Scott Cain - Bio::Graphics::Glyph, Bio::DB::GFF::Adaptor::dbi::pg, GFF related tools and scripts =item * Yee Man Chan - Bio::Tools::dpAlign =item * Brad Chapman =item * Roy R. Chaudhuri - Bio::SeqUtils Bio::Align::Utilities =item * Michele Clamp =item * Malcolm Cook =item * Tony Cox =item * James Cuff =item * Andrew Dalke =item * Allen Day =item * Jared Fox - Bio::SeqIO::interpro =item * Brian O'Connor - Bio::TreeIO::svggraph =item * James Diggans =item * Peter Dimitrov - Bio::Ontology =item * Rich Dobson - Bio::PopGen::IO::hapmap,phase =item * Paul Edlefsen =item * Rob Edwards - Bio::Restriction =item * Arne Elofsson =item * David Evans =item * Mark Fiers =item * The Fugu Team =item * Luc Gauthier =item * James Gilbert =item * Nat Goodman =item * Ed Green =item * Matthew Hahn =item * Roger Hall =item * Todd Harris - SVG support in Bio::Graphics =item * Mauricio Herrera Cuadra =item * Ian Holmes =item * Shawn Hoon =item * Robert Hubley =item * Joseph Insana - Bio::LiveSeq =item * Donald Jackson - SiRNA =item * Keith James - Bio::Tools::Geneid =item * Mark A. Jensen - Bio::DB::HIVQuery, Bio::Search::Tiling =item * Nicolas Joly =item * Ian Korf =item * Dan Kortschak =item * Arek Kasprzyk =item * Andreas Kähäri =item * Charles C. Kim =item * Stefan Kirov - Bio::Matrix::PSM =item * Balamurugan Kumarasamy =item * Josh Lauricha - Bio::SeqIO::tigr =item * Eckhard Lehmann =item * Catherine Letondal =item * Philip Lijnzaad =item * Brad Marshall =item * Chad Matsalla =item * Andrew Macgregor =item * Sheldon McKay =item * Dave Messina - Deobfuscator, judicious meddling =item * Chase Miller - Bio::Nexml and related IO modules =item * Juha Muilu =item * Chris Mungall =item * Giri Narasimhan =item * Xiaokang Pan - Bio::Graphics::Glyph =item * Jong Park =item * Matthew Pocock =item * Lorenz Pollack -- BPlite porting =item * Richard Resnick -- original Bio::Seq =item * Todd Richmond =item * Peter Schattner =item * Torsten Seemann -- Bio::Tools::Run::StandaloneBlast =item * Martin Senger -- Bio::Biblio =item * Nigam Shah =item * Shengqiang Shu - Bio::Graphics::Glyph =item * Allen Smith -- Bio::Matrix and Bio::SimpleAlign fixes =item * Marc Sohrmann =item * Robson Francisco de Souza - Bio::Assembly =item * Mark Southern =item * Will Spooner =item * Arne Stabenau =item * Elia Stupka =item * Gert Thijs =item * James Thompson - Bio::Matrix::PSM protein-related modules. =item * Charles Tilford =item * Anthony Underwood =item * Paul-Christophe Varoutas =item * Andrew G. Walsh =item * Kai Wang =item * Gary Williams =item * Mark Wilkinson =item * Helge Weissig =item * Juguang Xiao =item * Alex Zelensky - Bioperl-DB =item * Peili Zhang =item * Christian M. Zmasek - Bio::Phenotype & Bio::Ontology =back BioPerl-1.6.923/BioPerl.pm000444000765000024 2174112254227323 15355 0ustar00cjfieldsstaff000000000000package BioPerl; use strict; # At some future point, when we break the current core into more maintainable # bits, this will have a direct VERSION number, but for now we will be using # the root version for everything use Bio::Root::Version; our $VERSION = $Bio::Root::Version::VERSION; eval $VERSION; 1; __END__ =head1 NAME BioPerl - Perl Modules for Biology =head1 SYNOPSIS If you're new to BioPerl, you should start reading the BioPerl tutorial, an overview of the BioPerl toolkit: L =head2 Current Overview Core Bioperl documentation has been split up into the following sections: =over 3 =item * bioperl BioPerl overview (this document) =back We may add more documents in the future, including: =over 3 =item * biodatabases How to use databases with BioPerl =item * biodesign A guide for authoring a BioPerl module =item * bioscripts Description and overview of BioPerl scripts (in the I directory) =back =head2 Tutorials =over 3 =item * BioPerl tutorial for beginners L =item * Institut Pasteur BioPerl tutorial (note: for older versions of BioPerl) L =back =head2 References for Individual Modules For ease of maintenance and coordination amongst contributors, BioPerl code is maintained in a modular form, as is the documentation. Refer to the documentation for individual modules by using perldoc, i.e. C to get documentation for the Bio::Seq object. =head1 DESCRIPTION BioPerl is the product of a community effort to produce Perl code which is useful in biology. Examples include Sequence objects, Alignment objects and database searching objects. These objects not only do what they are advertised to do in the documentation, but they also interact - Alignment objects are made from the Sequence objects, Sequence objects have access to Annotation and SeqFeature objects and databases, Blast objects can be converted to Alignment objects, and so on. This means that the objects provide a coordinated and extensible framework to do computational biology. BioPerl development focuses on Perl classes, or code that is used to create objects representing biological entities. There are scripts provided in the scripts/ and examples/ directories but scripts are not the main focus of the BioPerl developers. Of course, as the objects do most of the hard work for you, all you have to do is combine a number of objects together sensibly to make useful scripts. The intent of the BioPerl development effort is to make reusable tools that aid people in creating their own sites or job-specific applications. The BioPerl website at L also attempts to maintain links and archives of standalone bio-related Perl tools that are not affiliated or related to the core BioPerl effort. Check the site for useful code ideas and contribute your own if possible. =head1 DOCUMENTATION The Bio::Perl module (not this document) is designed to flatten the learning curve for newcomers to Perl/Bioperl. This is a good place to start if you want some simple functionality. We have a cookbook tutorial on-line: L which has embedded documentation. Start there if learning-by-example suits you most, or examine the BioPerl online course at: L Make sure to check the documentation in the modules as well - there are over 900 modules in BioPerl, and counting, and there's detail in the modules' documentation that will not appear in the general documentation. =head1 INSTALLATION The BioPerl modules are distributed as a tar file that expands into a standard perl CPAN distribution. Detailed installation directions can be found in the distribution INSTALL file. Installing on windows using ActiveState Perl is covered in the INSTALL.WIN file. We highly suggest reading the installation instructions on the BioPerl website: L =for TODO: Do we want to add biodesign and biodatabases back in? The BioPerl modules can interact with local flat file and relational databases. To learn how to set this up, look at the biodatabases.pod documentation ('perldoc biodatabases.pod' should work once BioPerl has been installed). Some BioPerl-related distributions such as Bio::Graphics, BioPerl-db, BioPerl-run, BioPerl-gui, corba-server, BioPerl-ext, BioPerl-pipeline, BioPerl-microarray and corba-client packages are installed separately from BioPerl. Please refer to their respective documentation for more information. Note that only the following are supported at this time with the current API: =over 3 =item BioPerl-db =item BioPerl-network =item BioPerl-run =item BioPerl-pedigree =item Bio::Graphics =back =head1 GETTING STARTED A good place to start is by reading the tutorial : L The distribution I directory has working scripts for use with BioPerl, check the self-described I directory as well. You are more than welcome to contribute your script! =for TODO Should we add bioscripts back to the distributions? A list and brief description of all these scripts is found in bioscripts.pod. If you have installed BioPerl in the standard way, as detailed in the INSTALL in the distribution, these scripts should work by just running them. If you have not installed it in a standard way you will have to change the 'use lib' to point to your installation (see INSTALL for details). =head1 GETTING INVOLVED BioPerl is a completely open community of developers. We are not funded and we don't have a mission statement. We encourage collaborative code, in particular in Perl. You can help us in many different ways, from just a simple statement about how you have used BioPerl to doing something interesting to contributing a whole new object hierarchy. See L for more information. Here are some ways of helping us: =head2 Asking questions and telling us you used it We are very interested to hear how you experienced using BioPerl. Did it install cleanly? Did you understand the documentation? Could you get the objects to do what you wanted them to do? If BioPerl was useless we want to know why, and if it was great - that too. Post a message to B, the BioPerl mailing list, where all the developers are. Only by getting people's feedback do we know whether we are providing anything useful. =head2 Writing a script that uses it By writing a good script that uses BioPerl you both show that BioPerl is useful and probably save someone elsewhere writing it. If you contribute it to the 'script central' at L then other people can view and use it. Don't be nervous if you've never done this sort of work, advice is freely given and all are welcome! =head2 Find bugs! We know that there are bugs in this code. If you find something which you are pretty sure is a problem, post a bug report using our Bugzilla tracking system: L Please read the main bug tracking (L) for an overview of what we expect in a bug report. Specifically, having a code and data example where appropriate helps tremendously. We gladly accept all patches after a quick code review. =head2 Suggest new functionality You can suggest areas where the objects are not ideally written and could be done better. The best way is to find the main developer of the module (each module was written principally by one person, except for Seq.pm). Talk to him or her and suggest changes. =head2 Make your own objects If you can make a useful object we will happily include it into the core. Probably you will want to read a lot of the documentation in L and talk to people on the BioPerl mailing list, B. =for TODO Add biodesign.pod back? biodesign.pod provides documentation on the conventions and ideas used in BioPerl, it's definitely worth a read if you would like to be a BioPerl developer. =head2 Writing documentation We appreciate good documentation. It's what tells the world what's in BioPerl, it's what instructs the user, it's what describes the rationale and inner workings of the package. Feel free to contribute. =head1 ACKNOWLEDGEMENTS For a more detailed history of the BioPerl project, we recommend the History of BioPerl: L =head1 COPYRIGHT Copyright (c) 1996-2009 Georg Fuellen, Richard Resnick, Steven E. Brenner, Chris Dagdigian, Steve Chervitz, Ewan Birney, James Gilbert, Elia Stupka, and others. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/BUGS000444000765000024 1255212254227337 14153 0ustar00cjfieldsstaff000000000000# $Id: BUGS,v 1.7 2006-11-16 10:51:50 sendu Exp $ Known Bugs Bugs are tracked at this URL: https://redmine.open-bio.org/projects/bioperl/ Bioperl 1.6 series ============= Though a stable release, some bugs and enhancements remain for this series that will be addressed in future point releases. For a full list please see: https://redmine.open-bio.org/projects/bioperl/ Bug Summary (additional info) 2247 Have Bio::SearchIO::blast methods available for other BLAST parsers (enhancement request) 2332 Software for analysis of redundant fragments of affys human mitochip v2 (API hasn't stabilized, may appear in a 1.6 point release) 2439 multiple results HTMLResultWriter.pm and non-redundant entries in SearchIO (partially implemented) 2463 bp_seqconvert.pl & Bio::SeqIO code cleanup and user friendly interface (enhancement request) 2476 "Undefined sub-sequence" when processing tblastx output (related to HSP tiling) 2482 paml4 mlc file fails to parse (may require refactoring Bio::Tools::Phylo::PAML) 2492 Method "pi" in package Bio::PopGen::Statistics (awaiting comment from Jason) 2513 creating a Bio::SeqFeature::Annotation object downloads the entire so.obo (should allow local copies) 2594 Bio::Species memory leak (fix implemented, but additional leaks likely remain) 2673 original fields not inherited by seq objects in alignment slices (request for bequest/bequeath behavior for attribute carryover) 2686 WU-BLAST XML support (partially implemented, but issues remain) 2691 Bio::Microarray::Tools::ReseqChip depends on CPAN module Statistics::Frequency (related to bug 2332 above) 2696 global verbosity does not propagate to new objects post-set (requires more specific implementation details) 2700 Refactor Build.PL (some of the behind-the-scenes stuff is a little klunky) 2702 Scripts recopied upon each call to './Build test' (minor bug) 2703 Bio::Tools::GuessSeqFormat guesses SELEX as PHYLIP (minor bug that mistakes format) 2707 Bio::Tools::Run::StandAloneBlast does not quote shell metacharacters in filenames, but Bio::SearchIO::blast does (bug within StandAloneBlast) 2715 LocatableSeq symbols are globally set (bug related to sequence symbol issues; rarely surfaces but needs addressing) Bioperl 1.5.2 ============= There are no known installation bugs in 1.5.2 per se, but issues with external programs may cause problems. See the following URL for details: http://www.bioperl.org/wiki/Release_1.5.2#Notes Bioperl 1.2 =========== * The StandAloneBlast.t test is failing on cygwin installations (and nowhere else). We suspect something to do with temporary file opening. Fixed in 1.4 (set TMPDIR). Bioperl 0.9.0 ============= * Bio::Tools::Blast continues to cause problems for some people. As it is not actively maintained there are a slew of reported bugs for it that have not been fixed. * Bio::Tools::Run::Alignment::TCoffee - t_coffee binary does not get all parameters it needs when aligning (two) two DNA sequences (jitterbug #966). * Bio::Tools::Run::ClustalW and t/ClustalW will report errors for clustalw versions 1.8x due to a bug in clustalw. * Bio::DB::GenBank continues to have intermittent errors. Bio::DB::GDB is also unreliable at times and one can safely ignore errors from these during a make test. Bio::DB::GenBank is unable to download whole contig files as well as NCBI ref seqs like NT_* numbers unless the -format flag is passed in and specified as 'fasta' in the constructor. get_Stream_by_batch() also has intermittent errors which are being tracked down. Bioperl 0.7.2 ============= * NCBI has changed some of the cgi scripts for retrieving sequences online which as resulted in some of the DB methods from not working consistently. We are addressing these in the 0.9.x and 1.0 series of releases. We recommend using the Bio::DB::EMBL object that is part of the later releases. Additionally RefSeq Contigs are not properly downloaded, please see the bioperl list archives for information about potential workarounds and ongoing development effort to address these. Bioperl 0.7.1 ============= * Bio::Tools::BPlite does not parse and set frame properly for tblastx reports (Jitterbug bug # 978). * Bio::Tools::BPlite interface needs to be updated to fix parsing more than bl2seq report report (Jitterbug bug #940), this has been fixed on the main code trunk and will be part of the next major bioperl release. * If File::Temp is not installed, tempdirs are not cleaned up properly. This is fixed on main code trunk with the introduction of rmtree method in Bio::Root::IO, however, it is best to install File::Temp when running 0.7 branch code. * Bio::Tools::Blast does not allow users to run blast, instead use Bio::Tools::Run::StandAloneBlast to run local blasts. To submit jobs to a remote blast server like NCBI a module Bio::Tools::Run::RemoteBlast has been written but is part of the main trunk code and must be obtained through CVS until the next major bioperl release. Bioperl 0.7 =========== * Bio::Tools::BPlite doc error lists code synopsis code as my $parser = new BPlite(\*FH); should be my $parser = new Bio::Tools::BPlite(\*FH); BioPerl-1.6.923/Build.PL000444000765000024 4125612254227327 14766 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # This is a Module::Build script for Bioperl installation. # See http://search.cpan.org/~kwilliams/Module-Build/lib/Module/Build.pm # Uses a custom subclass of Module::Build called Bio::Root::Build # In the future developers may need to alter the requires and recommends # sections of Bio::Root::Build->new() below, but otherwise nothing else here is # likely to need changing. use strict; use lib '.'; use Bio::Root::Build; # XML::SAX::RTF doesn't work with BioPerl, at all, nada, zilch. # # Since we're running into this now on CPAN Testers, catch it up front and # deal with it. # # See: https://rt.cpan.org/Ticket/Display.html?id=5943 # https://redmine.open-bio.org/issues/2975 { eval { require XML::SAX; 1; }; unless ($@) { if (grep {$_->{Name} =~ 'XML::SAX::RTF'} @{XML::SAX->parsers()}) { warn < [0, # 'Access of ACeDB database/Bio::DB::Ace,Bio::DB::GFF::Adaptor::ace'], 'Algorithm::Munkres' => [0, 'Phylogenetic Networks/Bio::PhyloNetwork'], 'Array::Compare' => [0, 'Phylogenetic Networks/Bio::PhyloNetwork'], # this won't actually install due to circular dep, but we have no way of # doing a post-install the [circular dependency!] specifies it is only # installed on explicit request for this specific module, not when simply # choosing to install 'all' modules #'Bio::ASN1::EntrezGene' => [0, # 'Parsing entrezgene/Bio::SeqIO::entrezgene [circular dependency!]'], 'Clone' => [0, 'Cloning objects/Bio::Root::Root,Bio::Tools::Primer3'], 'Convert::Binary::C' => [0, 'Strider functionality/Bio::SeqIO::strider'], 'Error' => [0, 'OO-based exception handling (very optional)/Bio::Root::Exception'], 'GD' => [0, 'Alignment graphic output/Bio::Align::Graphics'], 'Graph' => [0.50, 'Phylogenetic Networks, ontology engine implementation, contig analysis'. '/Bio::PhyloNetwork,Bio::Ontology::SimpleGOEngine::GraphAdaptor,'. 'Bio::Assembly::Tools::ContigSpectrum'], 'GraphViz' => [0, 'Phylogenetic Network Visulization/Bio::PhyloNetwork::GraphViz'], 'HTML::Entities' => [0, 'Remote analysis POST submissions/Bio::SearchIO::blastxml'], 'HTML::HeadParser' => [3, 'Parsing section of HTML docs/Bio::Tools::Analysis::DNA::ESEfinder'], 'HTML::TableExtract' => [0, 'Parsing HTML tables/Bio::DB::SeqVersion::gi'], 'HTTP::Request::Common' => [0, 'GenBank+GenPept sequence retrieval, remote http Blast jobs'. '/Bio::DB::*,Bio::Tools::Run::RemoteBlast,'. 'Bio::Tools::Analysis::Protein*,Bio::Tools::Analysis::DNA*'], 'List::MoreUtils' => [0, 'Back- or reverse-translation of sequences/'. 'Bio::Tools::SeqPattern,Bio::Tools::SeqPattern::BackTranslate'], 'LWP::UserAgent' => [0, 'Remote access/Bio::DB::*,Bio::Tools::Run::RemoteBlast,Bio::WebAgent'], 'PostScript::TextBlock' => [0, 'EPS output/Bio::Tree::Draw::Cladogram'], 'Set::Scalar' => [0, 'Proper operation/Bio::Tree::Compatible'], 'SOAP::Lite' => [0, 'Bibliographic queries/Bio::DB::Biblio::soap'], 'Sort::Naturally' => [0, 'Sort lexically, but sort numeral parts numerically/'. 'Bio::Assembly::IO::ace,Bio::Assembly::IO::tigr'], 'Spreadsheet::ParseExcel' => [0, 'Parsing Excel files/Bio::SeqIO::excel'], 'Storable' => [2.05, 'Storing sequence objects in local file cache/'. 'Bio::DB::FileCache,Bio::SeqFeature::Collection,Bio::PopGen::HtSNP,'. 'Bio::PopGen::TagHaplotype,Bio::DB::GFF::Adaptor::berkeleydb,Bio::Root::Root'], 'SVG' => [2.26, 'Creating SVG images/Bio::Draw::Pictogram'], 'SVG::Graph' => [0.01, 'Creating SVG images/Bio::TreeIO::svggraph'], 'Text::ParseWords' => [0, 'Test scripts/Bio::DB::SeqFeature::Store::FeatureFileLoader'], 'XML::Parser' => [0, 'parsing xml/Bio::Biblio::IO::medlinexml'], 'XML::Parser::PerlSAX' => [0, 'Parsing XML/Bio::SeqIO::tinyseq,Bio::SeqIO::game::gameSubs,', 'Bio::OntologyIO::InterProParser,Bio::ClusterIO::dbsnp'], 'XML::SAX' => [0.15, 'Parsing XML/Bio::SearchIO::blastxml,Bio::SeqIO::tigrxml,Bio::SeqIO::bsml_sax'], 'XML::SAX::Writer' => [0, 'Writing XML/Bio::SeqIO::tigrxml'], 'XML::Simple' => [0, 'Reading custom XML/Bio::Tools::EUtilities,Bio::DB::HIV,Bio::DB::Query::HIVQuery'], 'XML::Twig' => [0, 'Parsing XML/Bio::Variation::IO::xml,Bio::DB::Taxonomy::entrez,'. 'Bio::DB::Biblio::eutils'], 'XML::Writer' => [0.4, 'Parsing and writing XML/Bio::SeqIO::agave,Bio::SeqIO::game::gameWriter,'. 'Bio::SeqIO::chadoxml,Bio::SeqIO::tinyseq,Bio::Variation::IO::xml,'. 'Bio::SearchIO::Writer::BSMLResultWriter'], 'YAML' => [0, 'GenBank->GFF3/bp_genbank2gff3.pl'], ); my $mysql_ok = 0; my @drivers = available_drivers(); # Set up the Bio::Root::Build object my $build = Bio::Root::Build->new( module_name => 'Bio', dist_name => 'BioPerl', dist_version_from => 'Bio/Root/Version.pm', dist_author => 'BioPerl Team ', dist_abstract => 'Bioinformatics Toolkit', license => 'perl', no_index => {'x_dir' => [qw(examples/root/lib)]}, requires => { 'perl' => '5.6.1', 'IO::String' => 0, # why is this required? 'DB_File' => 0, # why is this required? 'Data::Stag' => 0.11, # Bio::SeqIO::swiss, we can change to 'recommend' if needed 'Scalar::Util' => 0, # not in Perl 5.6.1, arrived in core in 5.7.3 'ExtUtils::Manifest' => '1.52', # allows spaces in file names }, build_requires => { 'CPAN' => 1.81, 'Module::Build' => 0.2805, 'Test::Harness' => 2.62, 'Test::Most' => 0, 'URI::Escape' => 0 }, recommends => { # reverted to a simple Module::Build-compatible hash, but we keep # additional data in the %recommends hash above. May be converted to # something simpler if there aren't complaints down the line. map {$_ => $recommends{$_}[0]} sort keys %recommends }, get_options => { accept => { }, network => { } # say 'perl Build.PL --network' to manually request network tests }, auto_features => { 'EntrezGene' => { description => "Presence of Bio::ASN1::EntrezGene", requires => { 'Bio::ASN1::EntrezGene' => 0 } # feature_requires is like requires, except that it doesn't trigger installation }, 'DB_File Tests' => { description => "BDB tests for Bio::DB::SeqFeature::Store", requires => { 'DB_File' => 0 } # feature_requires is like requires, except that it doesn't trigger installation }, 'Bio::DB::GFF Tests' => { description => "Bio::DB::GFF database tests (will need to answer questions before really enabling)", requires => { 'DBI' => 0 }, }, 'MySQL Tests' => { description => "MySQL-related tests for Bio::DB::SeqFeature::Store", requires => { 'DBI' => 0, 'DBD::mysql' => 0 }, }, 'Pg Tests' => { description => "PostgreSQL-related tests for Bio::DB::SeqFeature::Store", requires => { 'DBI' => 0, 'DBD::Pg' => 0}, }, 'SQLite Tests' => { description => "SQLite-related tests for Bio::DB::SeqFeature::Store", requires => { 'DBI' => 0, 'DBD::SQLite' => 0}, }, 'Network Tests' => { description => "Enable tests that need an internet connection", requires => { 'LWP::UserAgent' => 0 }, } }, dynamic_config => 1, #create_makefile_pl => 'passthrough', recursive_test_files => 1, # Extra files needed for BioPerl modules xml_files => {'./Bio/DB/HIV/lanl-schema.xml' => 'lib/Bio/DB/HIV/lanl-schema.xml'}, #pm_files => {} # modules in Bio are treated as if they were in lib and auto-installed #script_files => [] # scripts in scripts directory are installed on-demand ); my $accept = $build->args('accept'); # how much do I hate this? Let me count the ways..... #if (!$build->feature('EntrezGene')) { # warn <feature('Bio::DB::GFF') || $build->feature('MySQL Tests') || $build->feature('Pg Tests') || $build->feature('SQLite Tests'); # Handle auto features if ($proceed && $build->feature('DB_File Tests')) { # will return without doing anything if user chose not to run tests during make_bdb_test(); } if ($proceed && ($build->feature('MySQL Tests') || $build->feature('Pg Tests') || $build->feature('SQLite Tests'))) { make_dbi_test(); } # Ask questions $build->choose_scripts($accept); if ($build->args('network')) { if ($build->feature('Network Tests')) { $build->notes(network => 1); $build->log_info(" - will run internet-requiring tests\n"); } else { $build->notes(network => 0); $build->log_info(" - Missing LWP::UserAgent, can't run network tests\n"); } } else { $build->prompt_for_network($accept) if $build->feature('Network Tests'); } # Add additional files here $build->add_build_element('xml'); # Create the build script and exit $build->create_build_script; exit; ########################## Helper subs ########################## sub make_bdb_test { my $path0 = File::Spec->catfile('t', 'LocalDB', 'SeqFeature.t'); my $path = File::Spec->catfile('t', 'LocalDB','SeqFeature_BDB.t'); unlink($path) if (-e $path); open(my $F, ">", $path) || die "Can't create test file\n"; print $F <add_to_cleanup($path); #$build->add_to_manifest_skip($path); } sub available_drivers { eval {require DBI; 1;}; # if not installed, this sub won't actually be called return if $@; @drivers = DBI->available_drivers; unless (grep {/mysql|Pg|SQLite/i} @drivers) { $mysql_ok = 0; return "Only MySQL, Postgres and SQLite DBI drivers supported for Bio::DB::SeqFeature RDMS tests"; } $mysql_ok = 1; return @drivers; } sub make_dbi_test { my $dsn = $build->notes('test_dsn') || return; my $path0 = File::Spec->catfile('t', 'LocalDB', 'SeqFeature.t'); my $driver = $build->notes('dbd_driver'); my $path = File::Spec->catfile('t', 'LocalDB', ($driver eq 'mysql') ? 'SeqFeature_mysql.t' : ($driver eq 'SQLite') ? 'SeqFeature_SQLite.t' : 'SeqFeature_Pg.t'); my $test_db = $build->notes('test_db'); my $user = $build->notes('test_user'); my $pass = $build->notes('test_pass'); open my $F,">$path"; my $str = "$path0 -adaptor DBI::$driver -create 1 -temp 1 -dsn \"$dsn\""; $str .= " -user $user" if $user; $str .= " -password $pass" if $pass; print $F <add_to_cleanup($path); $build->add_to_cleanup($test_db) if $driver eq 'SQLite'; #$build->add_to_manifest_skip($path); } sub test_biodbgff { eval {require DBI;}; # if not installed, this sub won't actually be called return if $@; @drivers = DBI->available_drivers; unless (grep {/mysql|Pg|Oracle/i} @drivers) { return "MySQL, Pg nor Oracle DBI drivers are installed"; } return; } sub prompt_for_biodb { my $accept = shift; my $proceed = $accept ? 0 : $build->y_n("Do you want to run the Bio::DB::GFF or ". "Bio::DB::SeqFeature::Store live database tests? ". "y/n", 'n'); if ($proceed) { my @driver_choices; foreach my $poss ('SQLite', 'mysql', 'Pg', 'Oracle') { if (grep {/$poss/i} @drivers) { my $choice = $poss; $choice =~ s/^(.)/[$1]/; push(@driver_choices, $choice); } } my $driver; if (@driver_choices > 1) { my ($default) = $driver_choices[0] =~ /\[(.)/; $driver = $build->prompt("Which database driver should be used? ".join(" ", @driver_choices), $default); } else { ($driver) = $driver_choices[0] =~ /\[(.)/; } if ($driver =~ /^[mM]/) { $driver = 'mysql'; } elsif ($driver =~ /^[pP]/) { $driver = 'Pg'; } elsif ($driver =~ /^[oO]/) { $driver = 'Oracle'; } elsif ($driver =~ /^[sS]/) { $driver = 'SQLite'; } my $test_db = $build->prompt("Which database should I use for testing the $driver driver?\n". "This database should already be present but doesn't have to ". "be preloaded for any schema", 'test'); my $test_host = $build->prompt("On which host is database '$test_db' running (hostname, ip address or host:port)", 'localhost'); my $test_user = $build->prompt("User name for connecting to database '$test_db'?", 'undef'); my $test_pass = $build->prompt("Password for connecting to database '$test_db'?", 'undef'); my $use_host = 1; if ($test_host eq 'undef' || $test_host eq 'localhost') { $use_host = 0; } my $test_dsn; if ($driver eq 'Pg' || $driver eq 'SQLite') { $test_dsn = "dbi:$driver:dbname=$test_db"; $mysql_ok = 0; } else { $test_dsn = "dbi:$driver:database=$test_db"; $mysql_ok = 0; } if ($use_host) { $test_dsn .= ";host=$test_host"; } $build->notes(dbd_driver => $driver); $build->notes(test_db => $test_db); $build->notes(test_host => $test_host); $build->notes(test_user => $test_user eq 'undef' ? undef : $test_user); $build->notes(test_pass => $test_pass eq 'undef' ? undef : $test_pass); $build->notes(test_dsn => $test_dsn); $build->log_info(" - will run tests with database driver '$driver' and these settings:\n", " Database $test_db\n", " Host $test_host\n", " DSN $test_dsn\n", " User $test_user\n", " Password $test_pass\n"); $build->log_info(" - will not run the BioDBSeqFeature live ". "database tests (requires MySQL or Pg driver)\n") unless ($driver eq 'mysql' or $driver eq 'Pg'); } else { $build->log_info(" - will not run the BioDBGFF or BioDBSeqFeature live database tests\n"); } $build->log_info("\n"); return $proceed; } BioPerl-1.6.923/Changes000444000765000024 21736612254227332 15010 0ustar00cjfieldsstaff000000000000--------------------------------------------------------- Revision history for BioPerl core modules --------------------------------------------------------- The comprehensive history and ongoing development of BioPerl: http://github.com/bioperl/bioperl-live Some of that history is also highlighted on our wiki: http://www.bioperl.org/wiki/Change_log http://www.bioperl.org/wiki/History_of_BioPerl Bugs and requested features list: https://redmine.open-bio.org/projects/bioperl CPAN releases are branched from 'master'. --------------------------------------------------------- 1.6.923 * Major Windows support updates! [fjossandon] * MAKER update to allow for stricter standard codon table [cjfields] * Better support for circular sequences [fjossandon] * Fixes for some complex location types [fjossandon] * Address CONTIG bug in GenBank format, bug #3448 [cjfields] * Fix bug #2978 related to BLAST report type [fjossandon] * Deobfuscator fixes [DaveMessina] 1.6.922 * Address CPAN test failures [cjfields] * Add BIOPROJECT support for Genbank files [hyphaltip] * Better regex support for HMMER3 output [bosborne] 1.6.921 * Minor update to address CPAN test failures 1.6.920 * Remove Bio::Biblio and related files [carandraug] - this cause version clashes with an independently-released version of Bio::Biblio 1.6.910 [New features] * Hash randomization fixes for perl 5.18.x - Note: at least one module (Bio::Map::Physical) still has a failing test; this is documented in bug #3446 and has been TODO'd; we will be pulling Bio::Map and similar modules out of core into separate distributions in the 1.7.x release series [cjfields] [New features] * Bio::Seq::SimulatedRead - New module to represent reads taken from other sequences [fangly] * Bio::Root::Root - Support of Clone::Fast as a faster cloning alternative [fangly] * Bio::Root::IO - Moved the format() and variant() methods from Bio::*IO modules to Bio::Root::IO [fangly] - Can now use format() to get the type of IO format in use [fangly] * Bio::Tools::IUPAC - New regexp() method to create regular expressions from IUPAC sequences [fangly] * Bio::SeqFeature::Primer and Bio::Seq::PrimedSeq: - Code refresh [fangly] * Bio::DB::Taxonomy - Added support for the Greengenes and Silva taxonomies [fangly] * Bio::Tree::TreeFunctionsI - get_lineage_string() represents a lineage as a string [fangly] - add_trait() returns instead of reporting an error when the column number is exceeded in add_trait() [fangly] - Option to support tree leaves without trait [fangly] - Allow ID of 0 in trait files [fangly] * Bio::DB::Taxonomy::list - Misc optimizations [fangly] - Option -names of get_taxon() to help with ambiguous taxa [fangly] * Bio::DB::Taxonomy::* - get_num_taxa() returns the number of taxa in the database [fangly] * Bio::DB::Fasta and Bio::DB::Qual - support indexing an arbitrary list of files [fangly] - user can supply an arbitrary index file name [fangly] - new option to remove index file at the end [fangly] * Bio::DB::Fasta - now handles IUPAC degenerate residues [fangly] * Bio::PrimarySeq and Bio::PrimarySeqI - speed improvements for large sequences [Ben Woodcroft, fangly] * Bio::PrimaryQual - tightened and optimized quality string validation [fangly] * Bio::SeqIO::fasta - new method and option 'block', to create FASTA output with space intervaled blocks (similar to genbank or EMBL) has been implemented. - package variables $WIDTH and $DEFAULT_SEQ_ID_TYPE have been removed in favour of the methods 'width' and 'preferred_id_type` respectively. * Bio::FeatureIO::* - moved from bioperl-live into the separate distribution Bio-FeatureIO * Bio::SeqFeature::Annotated - moved from bioperl-live into the separate distribution Bio-FeatureIO * Bio::Cluster::SequenceFamily - improved performance when using get_members with overlapping multiple criteria * Bio::SearchIO::hmmer3 - now supports nhmmer [bosborne] [Bug fixes] * [3302] Fixes bug in Bio::SearchIO::hmmer2.pm to correctly parse multi-query hmmer output [Francisco J. Ossandon, Paul Cantalupo] * [3421] Fixes bug in Bio::SearchIO::hmmer2.pm to correctly parse an HSP with a line full of dashes [Francisco J. Ossandon, Paul Cantalupo] * [3298] Fix bug in Bio::SearchIO::blast.pm where algorithm version information was lost in a multi-result blast file [Paul Cantalupo] * [3343] Fix bug in Bio::SearchIO::blasttable.pm to correctly calculate total gaps [Paul Cantalupo] * [3375] Fix DBLINK parsing bug in Bio::SeqIO::genbank.pm [Paul Cantalupo] * [3376] Fix bug in Bio::SearchIO::hmmer2.pm to correctly handle case when end of domain indicator is split across lines [Paul Cantalupo] * [3240] Bio::AlignIO::stockholm now parses simple sequences [Bernd Web, cjfields] * [3237] Bio::DB::Fasta now allows blank lines between sequences, catches instances where blank lines are within sequences [cjfields] * Bio::DB::Fasta reports correct alphabet for files with multiple sequence types [fangly] * Bio::DB::Fasta rev-comps sequences other than DNA properly [fangly] * [3238] Fixes for Bio::DB::SeqFeature::Store::DBI::Pg [Thomas Burkhard, cjfields] * Various fixes for Stockholm file indexing and processing [bosborne] * Fix edge case in FASTQ parsing where sequence of length 1 and qual of 0 breaks parsing [cjfields] * Fix case where Bio::Seq::Meta* objects with no meta information could not be reverse-complemented [fangly] * Fix bug for fields without aliases in Bio::DB::Query::HIVQuery [fangly] * Fix Bio::PopGen::IO::phase: sort values lexically instead of numerically when unsure that values will be numerical [fangly] * Fix undef warnings in Bio::SeqIO::embl [fangly] * Fix undef warnings in Bio::DB::Fasta and Bio::DB::Qual [fangly] * Fix Bio::Tools::IUPAC should accept any sequence object [fangly] * Fix for 'Inappropriate ioctl' in Bio::DB::Store::berkeleydb3 [Olivier Sallou] * Bio::SeqFeature::Generic SeqfeatureI compliance: methods primary_tag, source_tag and display_name must return a string, not undef [fangly] * Bio::SimpleAlign and Bio::Seq compliance with Bio::FeatureHolderI add_SeqFeature takes a single argument [fangly] * Use cross-platform filenames and temporary directory in Bio::DB::Taxonomy::flatfile [fangly] * Fix bug in Bio::DB::Taxonomy::list where taxa with no ancestors were not properly identified as existing taxa in the database [fangly] * Fix issue where a Bio::DB::Taxonomy::list object could not be created without also passing a lineage to store [fangly] * Prevent passing a directory to the gi2taxid option (-g) of bp_classify_hits_kingdom.pl and remove an 'earlier declaration' warning [fangly] * Fixed bp_genbank2gff3.pl crash when missing source feature date [fangly] * Bio::PrimarySeq constructor -direct works for -seq or -ref_to_seq [fangly] * Bio::Cluster::SequenceFamily - checks if the sequence has a Bio::Species object before trying to access, and no longer returns repeated sequences. 1.6.901 May 18, 2011 [Notes] * Use of AcePerl is deprecated; Ace.pm isn't actively maintained, and modules using Ace will also be deprecated [lds, cjfields] * Minor bug fix release * Bio::SeqIO::gbxml tests require XML::SAX [hartzell] * Address Build.PL issues when DBI is not present [hartzell] * Skip gbxml.t and Interpro tests when modules not installed [cjfields] * Remove deprecated code for perl 5.14.0 compat [cjfields] * Due to schema changes and lack of support for older versions, support for NeXML 0.9 is only (very) partially implemented. See: https://redmine.open-bio.org/issues/3207 [Bug fixes] * [3205] - small fix to Bio::Perl blast_sequence() to make compliant with docs [genehack, cjfields] * $VERSION for CPAN/cpanm-based installs was broken; force setting of module version from dist_version (probably not the best way to do this, but it seems to work) [rbuels, cjfields] 1.6.900 April 14, 201 [Notes] * This will probably be the last release to add significant features to core modules; subsequent releases will be for bug fixes alone. We are planning on a restructuring of core for summer 2011, potentially as part of the Google Summer of Code. This may become BioPerl 2.0. * Version bump represents 'just prior to v 1.7'. We may have point releases to deal with bugs, with increments of 1.6.901, 1.6.902, etc. This code essentially is what is on the github master branch. [New features] * Core code updated for perl 5.12.x [cjfields, Charle Tilford] * Bio::Tree refactor - major overhaul of Bio::Tree code by Greg Jordan, fixes several bugs - removal of Scalar::Util::weaken code, which was causing odd headaches with premature GC, memory leaks with perl 5.10.0, etc [cjfields] * Bio::DB::SeqFeature bug fixes for GBrowse2 compatibility [lds, scottcain, many others] * Bio::SeqIO::msout, Bio::SeqIO::mbsout - parsers for ms and mbs [Warren Kretzschmar] * Bio::SeqIO::gbxml - bug 2515 - new contribution [Ryan Golhar, jhannah] * Bio::Assembly::IO - support for reading Maq, Sam and Bowtie files [maj] - support for reading 454 GS Assembler (Newbler) ACE files [fangly] - bug 2483: support for writing ACE files [Joshua Udall, fangly] - bug 2599: support DBLINK annotation in GenBank files [cjfields] - bug 2726: reading/writing granularity: whole scaffold or one contig at a time [Joshua Udall, fangly] * Bio::OntologyIO - Added parsing of xrefs to OBO files, which are stored as secondary dbxrefs of the cvterm [Naama Menda] - General Interpro-related code refactors [dukeleto, rbuels, cjfields] * PAML code updated to work with PAML 4.4d [DaveMessina] [Bug fixes] * [3198] - sort tabular BLAST hits by score [DaveMessina] * [3196] - fix invalid metadata produced by latest Module::Build [cjfields] * [3190] - RemoteBlast GAPCOSTS regex fix [Ali Walsh, cjfields] * [3185] - Bio::Tools::SeqStats->get_mol_wt now gives correct MW [cjfields] * [3178] - fix tr/// issue in Bio::Range [Andrew Conley, cjfields] * [3172] - Bio::DB::Fasta - catch possibly bad FASTA files [cjfields] * [3164] - TreeFunctionsI syntax bug [gjuggler] * [3163] - AssemblyIO speedup [fangly] * [3160] - Bio::SearchIO::Writer::TextResultWriter output [Paul Cantalupo, hyphaltip] * [3159] - add SwissPfam support to bp_index.PLS [hyphaltip] * [3158] - fix EMBL file mis-parsing [cjfields] * [3157] - Bio::Restriction::Analysis 'sizes' method fixed [Marc Perry, cjfields] * [3153] - fix SeqIO::swiss TagTree issues [Charles Tilford, cjfields] * [3148] - URL change for UniProt [cjfields] * [3145] - AXT off-by-1 error [Aaron Goodman, cjfields] * [3136] - HMMer3 parser fixes [kblin] * [3126] - catch description [Toshihiko Akiba] * [3122] - Catch instances where non-seekable filehandles were being seek'd w/o checking for status [Stefan Kirov, Roy Chaudhuri] * [3121] - Bio::OntologyIO cannot parse the full InterPro XML file [dukeleto, rbuels, cjfields] * [3120] - bp_seqfeature_gff3.pl round-trip fixes [genehack, David Breimann, jhannah] * [3116,3117] - perl 5.12.x warnings fixed [cjfields, Charles Tilford] * [3110] - Better 'namespace' support for bp_seqfeature_load.PLS [dbolser, cjfields] * [3107] - BLAST alignment column_from_residue_number() [cjfields] * [3104] - Bio::Species single node hierarchies [Charles Tilford, cjfields] * [3092, 3090] - parsing of BLAST HSP stats [Razi Khaja, cjfields] * [3089] - HSPTableWriter missing methods [Robson de Souza, cjfields] * [3086] - EMBL misparsing long tags [kblin, cjfields] * [3085] - CommandExts and array of files [maj, hyphaltip] * [3077] - Bio::SimpleAlign slice() now correctly computes seq coordinates for alignment slices [Ha X. Dang, cjfields] * [3076] - XMFA alignment strand wrong [Ha X., cjfields] * [3073] - fix parsing of GenBank files from RDP [cjfields] * [3068] - FASTQ parse failure with trailing 0 [cjfields] * [3064] - All-gap midline BLAST report issues [cjfields] * [3063] - BLASt report RID [Razi Khaja, cjfields] * [3058] - SearchIO::fasta parsing [DaveMessina, cjfields] * [3053] - LOCUS line formatting [M. Wayne, cjfields] * [3039] - correct Newick output root node branch length [gjuggler, DaveMessina] * [3038] - SELEX alignment error [Bernd, cjfields] * [3033] - PrimarySeq ID setting [Bernd, maj] * [3032] - Fgenesh errors [Wes Barris, hyphaltip] * [3034] - AlignIO::clustal output [Bernd, DaveMessina] * [3031] - Parse algorithm ref for BLAST [Razi Khaja, cjfields] * [3028] - Bio::TreeIO::nexus and FigTree compat [Kevin Balbi, cjfields] * [3025] - Bio::SeqIO::embl infinite loop [Adam Sjøgren, cjfields] * [3040, 3023, 2974, 2921, 2753, 2636, 2482] - PAML parser fixed, works with PAML 4.4d [DaveMessina] * [3015, 3022] - Bio::Restriction withrefm regexp [Emmanuel Quevillon, DaveMessina] * [3020] - GFF3Loader alias attribute [Nathan Weeks, cjfields] * [3018, 3019, 3021] - gmap_f9 parsing [Kiran Mukhyala, cjfields] * [3017] - using threads with Bio::DB::GenBank [cjfields] * [3012] - Bio::Root::HTTPget fixes [maj, cjfields] * [3011] - namespace support for SF::Store::DBI::Pg [Adam Witney, cjfields] * [3002] - Bio::DB::EUtilities NCBI policy updates [cjfields] * [3001] - seq identifier '0' dropped with FASTA [Michael Kuhn, maj] * [2984] - let LocatableSeq decide on length of phylip aln [Adam Witney, cjfields] * [2983] - fix score/percent ID mixup [Alexie Papanicolaou] * [2977] - TreeIO issues [DaveMessina] * [2959] - Bio::SeqUtils->revcom_with_features [Roy Chaudhuri, maj] * [2944] - Bio::Tools::GFF score [cjfields] * [2942] - correct MapTiling output [maj] * [2939] - PDB residue insertion codes [John May, maj] * [2930] - PrimarySeqI term symbol [Adam Sjøgren, maj] * [2928] - GuessSeqFormat raw [maj] * [2926] - Bio:Tools::TandemRepeatsFinder seq_id [takadonet, cjfields] * [2922] - open() directive issue [cjfields] * [2915] - GenBank parser infinite loop [Francisco Ossandon, cjfields] * [2901] - DNAStatistics div by zero error [Janet Young, cjfields] * [2899] - SeqFeature::Store host issues [lstein, dbolser] * [2897] - Add a "mask_below_threshold" method to Seq::Quality [dbolser, cjfields] * [2881] - .scf files don't' roundtrip [Adam Sjøgren, cjfields] * [2876] - CDD search with RemoteBlast [Malcolm Cook] * [2863] - Root::IO::_initialize_io causes crash [rbuels, maj, DaveMessina] * [2845] - Bio::Seq::Quality gives seq with no ID [Tristan Lefebure, cjfields] * [2843] - FeatureIO BED to GFF fails w/ no phase [cassjm cjfields] * [2773] - Bio::Tree::Node premature GC [Morgan Price, cjfields] * [2764] - add ID Tracker helper for SwissProt [heikki, cjfields] * [2758] - Bio::AssemblyIO ace problems [fangly] * [2744] - Bio::LocatableSeq::end [Bernd, cjfields] * [2726] - ace file IO [Josh, fangly] * [2700] - Refactor Build.PL [cjfields] * [2673] - addition of simple Root-based clone() method [cjfields] * [2648] - Bio::Assembly::Scaffold->get_all_seq_ids [dbolser, fangly] * [2599] - support for DBLINK annotation in GenBank files [cjfields] * [2594] - Bio::Species memory leak [cjfields] * [2515] - GenBank XML parser [jhannah] * [2499] - Method "pi" in package Bio::PopGen::Statistics [hyphaltip] * [2483] - Bio::Assembly::IO::ace write_assembly implemented [fangly] * [2350] - ID consistency btwn Bio::SeqI, Bio::Align::AlignI [fangly, cjfields] * [1572] - no docs Bio::Location::Simple/Atomic::trunc [hyphaltip] [Deprecated] * Bio::Expression modules - these were originally designed to go with the bioperl-microarray suite of tools, however they have never been completed and so have been removed from the distribution. The original code has been moved into the inactive bioperl-microarray suite. [cjfields] [Other] * Repository moved from Subversion (SVN) to http://github.com/bioperl/bioperl-live [cjfields] * Bug database has moved to Redmine (https://redmine.open-bio.org) * Bio::Micrarray - the tools developed for ReSeq chip analysis by Marian Thieme have been moved to their own distribution (Bio-Microarray). [cjfields] 1.6.1 Sept. 29, 2009 (point release) * No change from last alpha except VERSION and doc updates [cjfields] 1.6.0_6 Sept. 27, 2009 (sixth 1.6.1 alpha) * Fix for silent OBDA bug related to FASTA validation [cjfields] 1.6.0_5 Sept. 27, 2009 (fifth 1.6.1 alpha) * Possible fix for RT 49950 (Strawberry Perl installation) [cjfields] * [RT 50048] - removed redundant VERSION, which was borking CPANPLUS [cjfields] * BioPerl.pod -> BioPerl.pm (Perl Best Practices) [cjfields] 1.6.0_4 Sept. 25, 2009 (fourth 1.6.1 alpha) * WinXP test fixes [cjfields, maj] * BioPerl.pod added for descriptive information, fixes CPAN indexing [cjfields] * Minor doc fixes [cjfields] 1.6.0_3 Sept. 22, 2009 (third 1.6.1 alpha) * Fix tests failing due to merging issues [cjfields] * More documentation updates for POD parsing [cjfields] 1.6.0_2 Sept. 22, 2009 (second 1.6.1 alpha) * Bio::Root::Build - fix YAML meta data generation [cjfields] 1.6.0_1 Sept. 15, 2009 (first 1.6.1 alpha) * Bio::Align::DNAStatistics - fix divide by zero problem [jason] * Bio::AlignIO::* - bug 2813 - fix faulty logic to detect end-of-stream [cjfields] * Bio::AlignIO::stockholm - bug 2796 - fix faulty logic to detect end-of-stream [cjfields] * Bio::Assembly::Tools::ContigSpectrum - function to score contig spectrum [fangly] * Bio::DB::EUtilities - small updates [cjfields] * Bio::DB::Fasta - berkeleydb database now autoindexes wig files and locks correctly [lstein] * Bio::DB::HIV - various small updates for stability; tracking changes to LANL database interface [maj] * Bio::DB::SeqFeature (lots of updates and changes) - add Pg, SQLite, and faster BerkeleyDB implementations [lstein, scain] - bug 2835 - patch [Dan Bolser] - bug RT 44535 - patch FeatureFileLoader [Cathy Gresham] * Bio::DB::SwissProt - bug 2764 - idtracker() method [cjfields, courtesy Neil Saunders] * Bio::Factory::FTLocationFactory - mailing list bug fix [cjfields] * Bio::LocatableSeq - performance work on column_from_residue_number [hartzell] * Bio::Matrix::IO::phylip - bug 2800 - patch to fix phylip parsing [Wei Zou] * Bio::Nexml - Google Summer of Code project from Chase Miller - parsers for Nexml file format [maj, chmille4] * Bio::PopGen - Make Individual, Population, Marker objects AnnotatableI [maj] - simplify LD code [jason] * Bio::RangeI - deal with empty intersection [jason] * Bio::Restriction - significant overhaul of Bio::Restriction system: complete support for external and non-palindromic cutters. [maj] * Bio::Root::Build - CPANPLUS support, no automatic installation [sendu] * Bio::Root::IO - allow IO::String (regression fix) [cjfields] - catch unintentional undef values [cjfields] - throw if non-fh is passed to -fh [maj] * Bio::Root::Root/RootI - small debugging and core fixes [cjfields] * Bio::Root::Test - bug RT 48813 - fix for Strawberry Perl bug [kmx] * Bio::Root::Utilities - bug 2737 - better warnings [cjfields] * Bio::Search - tiling completely refactored, HOWTO added [maj] NOTE : Bio::Search::Hit::* classes do not use this code directly; we will deprecate usage of the older tiling code in the next BioPerl release - small fixes [cjfields] * Bio::SearchIO - Infernal 1.0 output now parsed [cjfields] - new parser for gmap -f9 output [hartzell] - bug 2852 - fix infinite loop in some output [cjfields] - blastxml output now passes all TODO tests [cjfields] - bug 2346, 2850 - psl and exonerate parsing fixes [rbuels, jhannah, bvecchi, YAPC hackathon] - RT 44782 - GbrowseGFF writer now catches evalues [Allen Day] - bug 2575 - add two columns of additional output to HSPTableWriter [cjfields] * Bio::Seq::LargePrimarySeq - delete tempdirs [cjfields] - bug fixes [rbuels, jhannah, bvecchi, YAPC hackathon] * Bio::Seq::Quality - extract regions based on quality threshold value [Dan Bolser, heikki] - bug 2847 - resolve threshold issue (rbuels, jhannah, bvecchi) * Bio::SeqFeature::Lite - various Bio::DB::SeqFeature-related fixes [lstein] * Bio::SeqFeature::Tools::TypeMapper - additional terms for GenBank to SO map [scain] * Bio::SeqIO::chadoxml - bug 2785 - patch to get this working for bp_seqconvert [cjfields] * Bio::SeqIO::embl - support for CDS records [dave_messina, Sylvia] * Bio::SeqIO::fastq - complete refactoring to handle all FASTQ variants, perform validation, write output. API now conforms with other Bio* parsers and the rest of Bio::SeqIO (e.g. write_seq() creates fastq output, not fasta output). [cjfields] * Bio::SeqIO::genbank - bug 2784 - fix DBSOURCE issue [Phillip Garland] - bug RT 44536 - support for UniProt/UniProtKB tests [cjfields] * Bio::SeqIO::largefasta - parser returns a Bio::Seq::LargePrimarySeq [jhannah] * Bio::SeqIO::raw - add option for 'single' and 'multiple' * Bio::SeqIO::scf - bug 2881 - fix scf round-tripping [Adam Søgren] * Bio::SeqUtils - bug 2766, 2810 - copy over tags from features, doc fixes [David Jackson] * Bio::SimpleAlign - bug 2793 - patch for add_seq index issue [jhannah, maj] - bug 2801 - throw if args are required [cjfields] - bug 2805 - uniq_seq returns SimpleAlign and hash ref of sequence types [Tristan Lefebure, maj] - bug fixes from YAPC hackathon [rbuels, jhannah, bvecchi] - fix POD and add get_SeqFeatures filter [maj] * Bio::Tools::dpAlign - add support for LocatableSeq [ymc] - to be moved to a separate distribution [cjfields, rbuels] * Bio::Tools::EUtilities - fix for two bugs from mail list [Adam Whitney, cjfields] - add generic ItemContainerI interface for containing same methods [cjfields] * Bio::Tools::HMM - fix up code, add more warnings [cjfields] - to be moved to a separate distribution [cjfields, rbuels] * Bio::Tools::Primer3 - bug 2862 - fenceposting issue fixed [maj] * Bio::Tools::Run::RemoteBlast - tests for remote RPS-BLAST [mcook] * Bio::Tools::SeqPattern - bug 2844 - backtranslate method [rbuels, jhannah, bvecchi] * Bio::Tools::tRNAscanSE - use 'gene' and 'exon' for proper SO, ensure ID is unique [jason] * Bio::Tree::* - bug 2456 - fix reroot_tree(), added create_node_on_branch() [maj] * Bio::Tree::Statistics - several methods for calculating Fitch-based score, internal trait values, statratio(), sum of leaf distances [heikki] * Bio::Tree::Tree - bug 2869 - add docs indicating edge case where nodes can be prematurely garbage-collected [cjfields] - add as_text() function to create Tree as a string in specified format [maj] * Bio::Tree::TreeFunctionsI - bug 2877 - fix bug where bootstrap assigned to the wrong node [Tristan Lefebure, maj] * Bio::TreeIO::newick - fix small semicolon issue [cjfields] * scripts - update to bp_seqfeature_load for SQLite [lstein] - hivq.pl - commmand-line interface to Bio::DB::HIV [maj] - fastam9_to_table - fix for MPI output [jason] - gccalc - total stats [jason] * General Stuff - POD cleanup re: FEEDBACK section [maj, cjfields] - cleanup or fix dead links [cjfields] - Use of no_* methods (indicating 'number of something') is deprecated in favor of num_* [cjfields] - lots of new tests for the above bugs and refactors [everyone!] - new template for Komodo text editor [cjfields] 1.6.0 Winter 2009 * Feature/Annotation rollback - Problematic changes introduced prior to the 1.5 release have been rolled back. These changes led to subtle bugs involving operator overloading and interface methods. - Behavior is very similar to that for BioPerl 1.4, with tag values being stored generically as simple scalars. Results in a modest speedup. * Bio::Graphics - Split into a separate distribution on CPAN, primarily so development isn't reliant on a complete BioPerl release. - Bio::Graphics::Pictogram has been renamed to Bio::Draw::Pictogram but is only available via Subversion (via bioperl-live main trunk) * Bio::Root::Test - Common test bed for all BioPerl modules * Bio::Root::Build - Common Module::Build-based subclass for all BioPerl modules * Bio::DB::EUtilities - Complete refactoring to split up parsing (Bio::Tools::EUtilities), parameter handling (Bio::Tools::EUtilities::EUtilParameters), and user agent request posting and retrieval * Test implementation and reorganization - Tests have been reorganized into groups based on classes or use cases. - Automated test coverage is now online: http://www.bioperl.org/wiki/Test_Coverage - After this release, untested modules will be moved into a separate developer distribution until tests can be derived. Also, new modules to be added are expected to have a test suite and adequate test coverage. 1.5.2 Developer release Full details of changes since 1.5.1 are available online at: http://www.bioperl.org/wiki/Change_log The following represents a brief overview of the most important changes. o Bio::Map - Overhaul. Brand new system fully allows markers to have multiple positions on multiple maps, and to have relative positions. Should be backward compatible. o Bio::Taxonomy - This module and all the modules in the Taxonomy directory now deprecated in favour of Bio::Taxon and Bio::Tree::Tree o Bio::DB::Taxonomy - Taxonomy.pm * get_Taxonomy_Node() eventually to be deprecated, renamed get_taxon(). * New methods ancestor(), each_Descendent() and _handle_internal_id(). * Allows for different database modules to create Bio::Taxon objects with the same internal id when the same taxon is requested from each. - flatfile.pm * get_Children_Taxids() is deprecated, superceded by each_Descendent(). * No longer includes the fake root node 'root'; there are multiple roots now (10239, 12884, 12908, 29384 and 131567). Consistent with entrez.pm - entrez.pm * get_node() has new option -full * Caches data retrieved from website o Bio::Species - Now a Bio::Taxon. Carries out the species name -> specific name munging that Bio::DB::Taxonomy modules and SeqIO modules used to do, for backward compatability in species() method. o Bio::Search and Bio::SearchIO - Overhaul. The existing system has been sped up via some minor changes (mostly gain-of-function to the API). Bio::PullParserI is introduced as a potential eventual replacment for the existing system, though as yet only a Hmmpfam parser exists written using it. 1.5.1 Developer release o Major problem with how Annotations were written out with Bio::Seq is fixed by reverting to old behavior for Bio::Annotation objects. o Bio::SeqIO - genbank.pm * bug #1871; REFLOOP' parsing loop, I changed the pattern to expect at l east 9 spaces at the beginning of a line to indicate line wrapping. * Treat multi-line SOURCE sections correctly, this defect broke both common_name() and classification() * parse swissprot fields in genpept file * parse WGS genbank records - embl.pm * Changed regexp for ID line. The capturing parentheses are the same, the difference is an optional repeated-not-semi- colon expression following the captured \S+. This means the regexp works when the division looks like /PRO;/ or when the division looks like /ANG ;/ - the latter is from EMBL repbase * fix ID line parsing: the molecule string can have spaces in it. Like: "genomic DNA" - swiss.pm: bugs #1727, #1734 - entrezgene.pm * Added parser for entrezgene ASN1 (text format) files. Uses Bio::ASN1::EntrezGene as a low level parser (get it from CPAN) o Bio::AlignIO - maf.pm coordinate problem fixed o Bio::Taxonomy and Bio::DB::Taxonomy - Parse NCBI XML now so that nearly all the taxonomy up-and-down can be done via Web without downloading all the sequence. o Bio::Tools::Run::RemoteBlast supports more options and complies to changes to the NCBI interface. It is reccomended that you retrieve the data in XML instead of plain-text BLAST report to insure proper parsing and retrieval of all information as NCBI fully expects to change things in the future. o Bio::Tree and Bio::TreeIO - Fixes so that re-rooting a tree works properly - Writing out nhx format from a newick/nexus file will properly output bootstrap information. The use must move the internal node labels over to bootstraps. for my $node ( grep { ! $_->is_Leaf } $tree->get_nodes ) { $node->bootstrap($node->id); $node->id(''); } - Nexus parsing is much more flexible now, does not care about LF. - Cladogram drawing module in Bio::Tree::Draw - Node height and depth now properly calculated - fix tree pruning algorithm so that node with 1 child gets merged o Graphics tweaks. Glyph::xyplot improved. Many other small-medium sized bugs and improvements were added, see Gbrowse mailing list for most of these. o Bio::DB::GFF partially supports GFF3. See information about gff3_munge flag in scripts/Bio-DB-GFF/bulk_load_gff.pl. o Better location parsing in Bio::Factory::FTLocationFactory - this is part of the engine for parsing EMBL/GenBank feature table locations. Nested join/order-by/complement are allowed now o Bio::PrimarySeqI->translate now takes named parameters o Bio::Tools::Phylo::PAML - parsing RST (ancestral sequence reconstruction) is now supported. Parsing different models and branch specific parametes are now supported. o Bio::Factory::FTLocationFactory - parse hierarchical locations (joins of joins) o Bio::Matrix::DistanceMatrix returns arrayrefs instead of arrays for getter/setter functions o Bio::SearchIO - blast bug #1739; match scientific notation in score and possible e+ values - blast.pm reads more WU-BLAST parameters and parameters, match a full database pathname, - Handle NCBI WEB and newer BLAST formats specifically (Query|Sbjct:) match in alignment blocks can now be (Query|Sbjct). - psl off-by-one error fixed - exonerate parsing much improved, CIGAR and VULGAR can be parsed and HSPs can be constructed from them. - HSPs query/hit now have a seqdesc field filled out (this was always available via $hit->description and $result->query_description - hmmer.pm can parse -A0 hmmpfam files - Writer::GbrowseGFF more customizeable. o Bio::Tools::Hmmpfam make e-value default score displayed in gff, rather than raw score allow parse of multiple records 1.5 Developer release o Bio::Align::DNAStatistics and Bio::Align::ProteinStatistics provide Jukes-Cantor and Kimura pairwise distance methods, respectively. o Bio::AlignIO support for "po" format of POA, and "maf"; Bio::AlignIO::largemultifasta is a new alternative to Bio::AlignIO::fasta for temporary file-based manipulation of particularly large multiple sequence alignments. o Bio::Assembly::Singlet allows orphan, unassembled sequences to be treated similarly as an assembled contig. o Bio::CodonUsage provides new rare_codon() and probable_codons() methods for identifying particular codons that encode a given amino acid. o Bio::Coordinate::Utils provides new from_align() method to build a Bio::Coordinate pair directly from a Bio::Align::AlignI-conforming object. o Bio::DB::Biblio::eutils is a class for querying NCBI's Eutils. Send a Pubmed, Pubmed Central, Entrez, or other query to NCBI's web service using standard Pubmed query syntax, and retrieve results as XML. o Bio::DB::GFF has various sundry bug fixes. o Bio::FeatureIO is a new SeqIO-style subsystem for writing/reading genomic features to/from files. I/O classes exist for BED, GTF (aka GFF v2.5), and GFF v3. Bio::FeatureIO classes only read/write Bio::SeqFeature::Annotated objects. Notably, the GFF v3 class requires features to be typed into the Sequence Ontology. o Bio::Graph namespace contains new modules for manipulation and analysis of protein interaction graphs. o Bio::Graphics has many bug fixes and shiny new glyphs. o Bio::Index::Hmmer and Bio::Index::Qual provide multiple-file indexing for HMMER reports and FASTA qual files, respectively. o Bio::Map::Clone, Bio::Map::Contig, and Bio::Map::FPCMarker are new objects that can be placed within a Bio::Map::MapI-compliant genetic/physical map; Bio::Map::Physical provides a new physical map type; Bio::MapIO::fpc provides finger-printed clone mapping import. o Bio::Matrix::PSM provide new support for postion-specific (scoring) matrices (e.g. profiles, or "possums"). o Bio::Ontology::Ontology and Bio::Ontology::Term objects can now be instantiated without explicitly using Bio::OntologyIO. This is possible through changes to Bio::Ontology::OntologyStore to download ontology files from the web as necessary. Locations of ontology files are hard-coded into Bio::Ontology::DocumentRegistry. o Bio::PopGen includes many new methods and data types for population genetics analyses. o New constructor to Bio::Range, unions(). Given a list of ranges, returns another list of "flattened" ranges -- overlapping ranges are merged into a single range with the mininum and maximum coordinates of the entire overlapping group. o Bio::Root::IO now supports -url, in addition to -file and -fh. The new -url argument allows one to specify the network address of a file for input. -url currently only works for GET requests, and thus is read-only. o Bio::SearchIO::hmmer now returns individual Hit objects for each domain alignment (thus containing only one HSP); previously separate alignments would be merged into one hit if the domain involved in the alignments was the same, but this only worked when the repeated domain occured without interruption by any other domain, leading to a confusing mixture of Hit and HSP objects. o Bio::Search::Result::ResultI-compliant report objects now implement the "get_statistics" method to access Bio::Search::StatisticsI objects that encapsulate any statistical parameters associated with the search (e.g. Karlin's lambda for BLAST/FASTA). o Bio::Seq::LargeLocatableSeq combines the functionality already found in Bio::Seq::LargeSeq and Bio::LocatableSeq. o Bio::SeqFeature::Annotated is a replacement for Bio::SeqFeature::Generic. It breaks compliance with the Bio::SeqFeatureI interface because the author was sick of dealing with untyped annotation tags. All Bio::SeqFeature::Annotated annotations are Bio::AnnotationI compliant, and accessible through Bio::Annotation::Collection. o Bio::SeqFeature::Primer implements a Tm() method for primer melting point predictions. o Bio::SeqIO now supports AGAVE, BSML (via SAX), CHAOS-XML, InterProScan-XML, TIGR-XML, and NCBI TinySeq formats. o Bio::Taxonomy::Node now implements the methods necessary for Bio::Species interoperability. o Bio::Tools::CodonTable has new reverse_translate_all() and make_iupac_string() methods. o Bio::Tools::dpAlign now provides sequence profile alignments. o Bio::Tools::GFF now parses GFF version 2.5 (a.k.a. GTF). o Bio::Tools::Fgenesh, Bio::Tools::tRNAscanSE are new report parsers. o Bio::Tools::SiRNA includes two new rulesets (Saigo and Tuschl) for designing small inhibitory RNA. o Bio::Tree::DistanceFactory provides NJ and UPGMA tree-building methods based on a distance matrix. o Bio::Tree::Statistics provides an assess_bootstrap() method to calculate bootstrap support values on a guide tree topology, based on provided bootstrap tree topologies. o Bio::TreeIO now supports the Pagel (PAG) tree format. 1.4 branch 1.4.1 o Improvements to Bio::AlignIO::nexus for parsing TreeBase nexus files o Bio::Graphics will work with gd1 or gd2 o Bio::SearchIO - hmmer.pm Better hmmpfam parsing, fix bug for small number of alignment outputs (RF lines alone) - blast.pm Parse multi-line query fields properly - small speed improvements to blasttable.pm and others o Bio::DB::Taxonomy has better support for hierarchy traversal so that Bio::Taxonomy::Node can be as simple as Bio::Species object while still supporting more complex queries 1.4. Stable major release Since initial 1.2.0, 3000 separate changes have been made to make this release. o installable scripts o global module version from Bio::Root:Version o Bio::Graphics - major improvements; SVG support o Bio::Popgen - population genetics - support several population genetics types of questions. - Tests for statistical neutrality of mutations (Fu and Li's D/F, Tajima's D) are in Bio::PopGen::Statistics. Tests of population structure (Wright's F-statistic: Fst) is in Bio::PopGen::PopStats. Calculating composite linkage disequilibrium (LD) is available in Bio::PopGen::Statistics as well. - Bio::PopGen::IO for reading in prettybase (SeattleSNPs) and csv (comma delimited formatted) data. - a directory for implementing population simulations has been added Bio::PopGen::Simulation and 2 simulations - a Coalescent and a simple single-locus multi-allele genetic drift simulation have been provided. This replaces the code in Bio::Tree::RandomTree which has been deprecated until proper methods for generating random phylogenetic trees are implemented. o Bio::Restriction - new restrion analysis modules o Bio::Tools::Analysis - web based DNA and Protein analysis framework and several implementations o Bio::Seq::Meta - per residue annotable sequences o Bio::Matrix - Bio::Matrix::PSM - Position Scoring Matrix - Bio::Matrix::IO has been added for generalized parsing of matrix data. Matrix::IO::scoring and Matrix::IO::phylip are initial implementations for parsing BLOSUM/PAM and Phylip Distance matricies respectively. A generic matrix implementation for general use was added in Bio::Matrix::Generic. o Bio::Ontology - major changes o Bio:Tree o Bio::Tools::SiRNA, Bio::SeqFeature::SiRNA - small inhibitory RNA o Bio::SeqFeature::Tools - seqFeature mapping tools - Bio::SeqFeature::Tools::Unflattener.pm -- deal with mapping GenBank feature collections into Chado/GFF3 processable feature sets (with SO term mappings) o Bio::Tools::dpAlign - pure perl dynamic programming sequence alignment - needs Bioperl-ext o new Bio::SearchIO formats - axt and psl: UCSC formats. - blasttable: NCBI -m 8 or -m 9 format from blastall o new Bio::SeqIO formats - chado, tab, kegg, tigr, game - important fixes for old modules o Bio::AlignIO: maf o improved Bio::Tools::Genewise o Bio::SeqIO now can recongnize sequence formats automatically from stream o new parsers in Bio::Tools: Blat, Geneid, Lagan, Mdust, Promoterwise, PrositeScan, o Bio::DB::Registry bugs fixed - BerkeleyDB-indexed flat files can be used by the OBDA system - Multiple seqdatabase.ini locations in OBDA_SEARCH_PATH are all used by the OBDA system o several new HOWTOs - SimpleWebAnalysis, Trees, Feature Annotation, OBDA Access, Flat Databases o hundreds of new and improved files o o Bio::Tree::AlleleNode has been updated to be a container of an Bio::PopGen::Individual object for use in the Coalescent simulations. 1.2 Branch 1.2.3 Stable release update o Bug #1475 - Fix and add speedup to spliced_seq for remote location handling. o Bug #1477 - Sel --> Sec abbreviation fixed o Fix bug #1487 where paring in-between locations when end < start caused the FTLocationFactory logic to fail. o Fix bug #1489 which was not dealing with keywords as an arrayref properly (this is fixed on the main trunk because keywords returns a string and the array is accessible via get_keywords). o Bio::Tree::Tree memory leak (bug #1480) fixed Added a new initialization option -nodelete which won't try and cleanup the containing nodes if this is true. o Bug with parsing labeled nodes with Bio::TreeIO::newick fixed this was only present on the branch for the 1.2.1 and 1.2.2 series - Also merged main trunk changes to the branch which make newick -> nhx round tripping more effective (storing branch length and bootstrap values in same locate for NodeNHX and Node implementations.) Fixes to TreeIO parsing for labeled internal also required small changes to TreeIO::nhx. Improved tests for this module as well. o Bio::SearchIO - Fixed bugs in BLAST parsing which couldn't parse NCBI gapped blast properly (was losing hit significance values due to the extra unexpeted column). - Parsing of blastcl3 (netblast from NCBI) now can handle case of integer overflow (# of letters in nt seq dbs is > MAX_INT) although doesn't try to correct it - will get the negative number for you. Added a test for this as well. - Fixed HMMER parsing bug which prevented parsing when a hmmpfam report has no top-level family classification scores but does have scores and alignments for individual domains. - Parsing FASTA reports where ungapped percent ID is < 10 and the regular expression to match the line was missing the possibility of an extra space. This is rare, which is why we probably did not catch it before. - BLAST parsing picks up more of the statistics/parameter fields at the bottom of reports. Still not fully complete. - SearchIO::Writer::HTMLResultWriter and TextResultWriter were fixed to include many improvements and added flexiblity in outputting the files. Bug #1495 was also fixed in the process. o Bio::DB::GFF - Update for GFF3 compatibility. - Added scripts for importing from UCSC and GenBank. - Added a 1.2003 version number. o Bio::Graphics - Updated tutorial. - Added a 1.2003 version number. o SeqIO::swiss Bug #1504 fixed with swiss writing which was not properly writing keywords out. o Bio::SeqIO::genbank - Fixed bug/enhancement #1513 where dates of the form D-MMM-YYYY were not parsed. Even though this is invalid format we can handle it - and also cleanup the date string so it is properly formatted. - Bug/enhancement #1517 fixed so that SEGMENT line can be parsed and written with Genbank format. Similarly bug #1515 is fixed to parse in the ORIGIN text. o Bio::SeqIO::fasta, a new method called preferred_id_type allows you to specify the ID type, one of (accession accession.version display primary). See Bio::SeqIO::preferred_id_type method documentation for more information. o Unigene parsing updated to handle file format changes by NCBI 1.2.2 Stable release update o A series of bug fixes of the Bio::OntologyIO dagflat-related parsers: - auto-discover ontology name - bug in parsing relationships when certain characters are in the term - fixed hard-coded prefix for term identifiers - various smaller issues o Fixed bug in Bio::Annotation::OntologyTerm of not implementing all of Bio::Ontology::TermI o brought the OBDA Registry code up to latest specs o Bio::DB::GenBank - eutils URL change - accession number retrieval fixed o Bio::SearchIO::blast - fix bug #1443 (missing last hits), parse megablast o Bio::SearchIO::Writer::(HTML|Text)ResultWriter fix bugs #1458, #1459 which now properly report alignment start/end info for translated BLAST/FASTA searches. o Bio::TreeIO::newick can parse labeled internal nodes o Bio::Tools::BPbl2seq can properly report strand info for HSPs for BLASTX if if you provide -report_type => 'BLASTX' when initializing a BPbl2seq object. Bioperl 1.3 will have better support for bl2seq in the SearchIO system. o Bio::Root::IO support a -noclose boolean flag which will not close a filehandle upon object cleanup - useful when sharing a filehandle among objects. Additionally code added s.t. STDOUT/STDIN/STDERR will never be closed by Root::IO cleanup. o Bio::Tools::Genemark bug #1435 fixed which was missing last prediction o Bio::SeqIO::genbank - bug #1456 fixed which generated extra sequence lines - write moltype correctly for genpept 1.2.1 Stable release update o Inclusion of WrapperBase, a needed component for StandAloneBlast o Addition from main trunk of Ontology objects, principly to allow BioSQL releases against 1.2.1 o Fixes and cleanup of Bio::Coordinate modules o A fix to Bio::Index::EMBL allowing retrieval of entries using the primary accession number o Other bug fixes, including bpindex GenBank fix o Bio::SeqIO::genbank bug #1389 fixed 1.2 Stable major release o More functionality added to Bio::Perl, the newbie module o Bug fixes in Bio::TreeIO::newick fixes bug introduced in 1.0.2 Support for New Hampshire Extended (NHX) format parsing. o Bio::Tools added support for parsing Genomewise, Pseudowise, Est2Genome, Tmhmm, SignalP, Seg, RepeatMasker, FootPrinter, and a lightweight Hmmpfam parser. o New ontology parsing Bio::Ontology o Bug fixes in Bio::SearchIO for HMMer parsing, support for multi-report (mlib) fasta reports, support for waba and exonerate. o Bio::ClusterIO for parsing Unigene clusters o Bio::Assembly added for representing phrap and ace assembly clusters. o Rudimentary support for writing Chado XML (see GMOD project: www.gmod.org for more information) o Bio::Coordinate for mapping between different coordinate systems such as protein -> cDNA -> Exon -> DNA and back. Useful for mapping features into different coordinate systems. o Bio::DB::GenBank/Bio::DB::GenPept now support Entrez queries with the get_Stream_by_query method and supports the latest NCBI eutils interface. o Bugs fixed in Bio::SeqFeature::Collection an in-memory fast object for extracting subsets of features : currently only supports extraction by location. 1.1.1 Developer release o Deprecated modules are now listed in the DEPRECATED file o New HowTo documents located in doc/howto describing a domain of Bioperl. o Note that bugs are now stored at redmine.open-bio.org/projects/bioperl/ and all old bugs are searchable through the bugzilla interface. o Several reported bugs in Bio::Tools::Sigcleave and Bio::SimpleAlign have been addressed. o Support for Genewise parsing in Bio::Tools::Genewise o Start of Ontology framework with Bio::Ontology o Speedup to the Bio::Root::Root object method _rearrange. A global _load_module method was implemented to simplify the dynamic loading of modules ala Bio::SeqIO::genbank. This method is now used by all the XXIO (AlignIO,TreeIO,SearchIO,SeqIO, etc). o Several performance improvements to sequence parsing in Bio::SeqIO. Attempt to speedup by reducing object creation overhead. o Bio::DB::GenBank and Bio::DB::GenPept use the NCBI's approved method for sequence retrieval with their E-utils CGI scripts. More work to support Entrez queries to their fullest is planned before 1.2 release. o Numerous fixes to Bio::SearchIO and sequence parsing (swissprot) 1.1 Developer release o Bio::Tools::Run has been broken off into a new pkg bioperl-run, this separation removes some of the complexity in our test suite and separates the core modules in bioperl from those that need external programs to run. o With latest ExtUtils::MakeMaker module installed SGI/IRIX should not run into trouble running the makefile o Bio::Location and Bio::SeqIO::FTHelper are fixed to properly read,create,and write locations for grouped/split locations (like mRNA features on genomic sequence). o Bio::Tools::Phlyo added for wrappers for parsing Molphy (protml) and PAML (codeml,aaml, etc) parsing. o Bio::Tree:: objects expanded to handle testing monophyly, paraphyly, least common ancestor, etc. o Bio::Coordinate for mapping locations from different coordinate spaces o Bio::SearchIO::waba added for parsing WABA, Bio::SearchIO::hmmer added for parsing hmmpfam and hmmsearch output. o Bio::SearchIO::Writer::TextResultWriter for outputting a pseudo-blast textfile format 1.0.2 Bug fix release o Note: The modules Bio::DB::GenBank and Bio::DB::GenPept provided in this release will not work after December 2002 when NCBI shuts off the old Entrez cgi scripts. We have already fixed on our main development branch and the functionality will be available in the next stable bioperl release (1.2) slated for Fall 2002. o Numerous parsing bugs in Bio::SearchIO::fasta found through testset by Robin Emig. These were fixed as was the get_aln method in Bio::Search::HSP::GenericHSP to handle the extra context sequence that is provided with a FastA alignment. o Migrating differences between Bio::Search::XX::BlastXX to Bio::Search::XX::GenericXX objects. This included mechanism to retrieve whole list of HSPs from Hits and whole list of Hits from Results in addition to the current next_XX iterator methods that are available. Added seq_inds() method to GenericHSP which identifies indexes in the query or hit sequences where conserved,identical,gaps, or mismatch residues are located (adapted from Steve Chervitz's implementation in BlastHSP). o Bio::DB::GFF bugs fixed and are necessary for latest GBrowse release. Bio::DB::GFF::RelSegment is now Bio::SeqI compliant. o Bio::Graphics glyph set improved and extended for GBrowse release o Bio::Tree::Tree get_nodes implementation improvement thanks to Howard Ross notice performance problem when writing out unbalanced trees. o Bio::Location::Fuzzy::new named parameter -loc_type became -location_type, Bio::Location::Simple::new named parameter -seqid becamse -seq_id. o Fixed major Bio::AlignIO::emboss parsing bug on needle output, was mis-detecting that gaps should be placed at the beginning of the alignment when the best alignment starts internally in the sequence. 1.0.1 Bug fix release o Minor bug fixes to Bio::DB:GFF. Glyph sets improved. o Parser fixes in SearchIO blast, fasta for more complete WU BLAST and mixed (3.3 - 3.4) versions of FASTA. o Small API change to add methods for completeness across implementations of Bio::Search objects. These new methods in the interface are implemented by the GenericXX object as well as the BlastXX objects. * Bio::Search::Result::ResultI - hits() method returns list of all Hits (next_hit is an iterator method) * Bio::Search::Hit::HitI - hsps() method returns list of all HSPs (next_hsp is an iterator method) o The Bio::SearchIO::Writer classes have been fixed to handle results created from either psiblast (Search::BlastXX objects) or blast|fasta|blastxml objects (Search::GenericXX objects). More work has to be done here to make it work properly and will nee major API changes. o Bugs in Bio::Tools::HMMER fixed, including * #1178 - Root::IO destructor wasn't being called * #1034 - filter_on_cutoff now behaves properly o Bio::SeqFeature::Computation initialization args fixed and tests added. o Tests are somewhat cleaner, flat.t now properly cleans up after itsself, o Updated FAQ with more example based answers to typical questions o Bug #1202 was fixed which would improperly join together qual values parsed by Bio::SeqIO::qual when a trailing space was not present before the newline. 1.0.0 Major Stable Release This represents a major release of bioperl with significant improvements over the 0.7.x series of releases. o Bio::Tools::Blast is officially deprecated. Please see Bio::SearchIO for BLAST and FastA parsing. o The methods trunc() and subseq() in Bio::PrimarySeqI now accepts Bio::LocationI objects as well as start/end. o Bio::Biblio contains modules for Bibliographic data. Bio::DB::Biblio contains the query modules. Additionally one can parse medlinexml from the ebi bibliographic query service (BQS) system and Pubmed xml from NCBI. See Martin Senger's documentation in Bio::Biblio for more information. o Bio::DB::Registry is a sequence database registry part of Open Bioinformatics Database Access. See http://obda.open-bio.org for more information. o File-based and In-Memory Sequence caching is provided by Bio::DB::InMemoryCache and Bio::DB::FileCache which acts like a local database. o Bio::Graphics for rendering sequences as PNG,JPG, or GIFs has been added by Lincoln Stein. o XEMBL SOAP service access in provided in Bio::DB::XEMBL. o A FAQ has been started and is included in the release to provide a starting point for frequent questions and issues. 0.9.3 Developer's release o Event based parsing system improved (SearchIO). With parsers for XML Blast (blastxml), Text Blast (blast), and FASTA results (fasta). Additionally a lazy parsing system for text and html blast reports was added and is called psiblast (name subject to change in future releases). o Bio::Search objects improved and standardized with associated Interfaces written. The concept of a search "Hit" was standardized to be called "hit" consistently and the use of "subject" was deprecated in all active modules. o Bio::Structure added (since 0.9.1) for Protein structure objects and PDB parser to retrieve and write these structures from data files. o Several important Bio::DB::GFF bug fixes for handling features that are mapped to multiple reference points. Updated mysql adaptor so as to be able to store large (>100 megabase) chunks of DNA into Bio::DB::GFF databases. 0.9.2 Developer's release o Bio::Search and Bio::SearchIO system introduced for event based parsing of Blast,Fasta reports Bio::SearchIO supports ncbi BLAST in text and XML and FASTA reports in standard output format. o Bio::Tree and Bio::TreeIO for phylogenetic trees. A Random tree generator is included in Bio::TreeIO::RandomTrees and a statistics module for evaluating. o Bio::DB::GFF, Lincoln Stein's GFF database suitable as a DB server for DAS servers. o Bio::Tools::BPlite is provides more robust parsing of BLAST files. The entire BPlite system migrated to using Bio::Root::IO for the data stream. o Bio::Tools::Alignment for Consed and sequence Trimming functionality. o Bio::Structure for Protein structure information and parsing o Bio::DB::GenBank/Bio::DB::GenPept updated to new NCBI Entrez cgi-bin entry point which should be more reliable. o Bio::Map and Bio::MapIO for biological map navigation and a framework afor parsing them in. Only preliminary work here. o Interface for executing EMBOSS programs locally in Bio::Factory::EMBOSS Future work will integrate Pise and allow submission of analysis on remote servers. o Bio::AnnotationCollectionI and Bio::Annotation::Collection introduced as new objects for handling Sequence Annotation information (dblinks, references, etc) and is more robust that previous system. o Bio::Tools::FASTAParser introduced. o Scripts from the bioperl script submission project and new scripts from bioperl authors are included in "scripts" directory. o Factory objects and interfaces are being introduced and are more strictly enforced. o Bio::Root::Root introduced as the base object while Bio::Root::RootI is now simply an interface. o Bio::DB::RefSeq provides database access to copy of the NCBI RefSeq database using the EBI dbfetch script. 0.9.0 Developer's release o perl version at least 5.005 is now required instead of perl 5.004 o Bio::Tools::Run::RemoteBlast is available for running remote blast jobs at NCBI. o Bio::Tools::BPbl2seq was fixed to handle multiple HSPs. o Bio::SeqFeature::GeneStructure migrated to Bio::SeqFeature::Gene. Also added are related modules UTR3, UTR5, Exon, Intron, Promotor, PolyA and Transcript. o Speedup of translate method in PrimarySeq o Bio::SimpleAlign has new methods: location_from_column(), slice(), select(), dot(), get_seq_by_pos(), column_from_residue_number() o Various fixes to Variation toolkit o Bio::DB::EMBL provides database access to EMBL sequence data. Bio::DB::Universal provides a central way to point to indexes and dbs in a single interface. o Bio::DB::GFF - a database suitable for running DAS servers locally. o Bio::Factory::EMBOSS is still in design phase as is Bio::Factory::ApplicationFactoryI o Dia models for bioperl design are provided in the models/ directory 0.7.2 Bug fix release o documentation fixes in many modules - SYNOPSIS code verified to be runnable in many (but not all modules) o corrected MANIFEST file from 0.7.1 release o Bug fix in Bio::SeqIO::FTHelper to properly handle split locations o Bio::SeqIO::genbank * Correct parsing and writing of genbank format with protein data * moltype and molecule separation o Bio::SeqIO::largefasta fix to avoid inifinite loops o Bio::SimpleAlign fixed to correctly handle consensus sequence calculation o Bio::Tools::HMMER supports hmmer 2.2g o Bio::Tools::BPlite to support report type specific parsing. Most major changes are not on the 0.7 branch. o Bio::Tools::Run::StandAloneBlast exists_blast() fixed and works with File::Spec o Bio::Variation::AAChange/RNAChange corrected labels and mutated alleles in several types of mutations: 1.) AA level: deletion, complex 2.) AA level: complex, inframe 3.) RNA level: silent o BPbl2seq parsing of empty reports will not die, but will return a valid, empty, Bio::SeqFeature::SimilarityFeature for $report->query() and $report->subject() methods. So an easy way to test if report was empty is to see if $report->query->seqname is undefined. 0.7.1 Bug fix release o Better parsing of genbank/EMBL files especially fixing bugs related to Feature table parsing and locations on remote sequences. Additionally, species name parsing was better. o Bio::SeqIO::genbank can parse now NCBI produced genbank database which include a number of header lines. o More strict genbank and EMBL format writing (corrected number of spaces where appropriate). o Bio::Tools::BPlite can better parse BLASTX reports - see BUGS for related BPlite BUGS that are unresolved in this release. o Bio::DB::GenBank, Bio::DB::GenPept have less problems downloading sequences from NCBI via HTTP. Bio::DB::SwissProt can use expasy mirrors or EBI dbfetch cgi-script. o A moderate number of documentation improvements were made as well to provide a better code synopsis in each module. 0.7 Large number of changes, including refactoring of the Object system, new parsers, new functionality and all round better system. Highlights are: o Refactored root of inheritance: moved to a lightweight Bio::Root::RootI; Bio::Root::IO for I/O and file/handle capabilities. o Imported BPlite modules from Ian Korf for BLAST parsing. This is considered the supported BLAST parser; Bio::Tools::Blast.pm will eventually phase out due to lack of support. o Improved Sequence Feature model. Added complete location modelling (with fuzzy and compound locations). See Bio::LocationI and the modules under Bio/Location. Added support in Genbank/EMBL format parsing to completely parse feature tables for complex locations. o Moved special support for databanks etc to specialized modules under Bio/Seq/. One of these supports very large sequences through a temporary file as a backend. o Explicit Gene, Transcript and Exon SeqFeature objects, supporting CDS retrieval and exon shuffling. o More parsers: Sim4, Genscan, MZEF, ESTScan, BPbl2seq, GFF o Refactored Bio/DB/GenBank+GenPept. There is now also DB/SwissProt and DB/GDB (the latter has platform-specific limitations). o New analysis parser framework for HT sequence annotation (see Bio::SeqAnalysisParserI and Bio::Factory::SeqAnalysisParserFactory) o New Alignment IO framework o New Index modules (Swissprot) o New modules for running Blast within perl (Bio::Tools::Run::StandAloneBlast). Added modules for running Multiple Sequence Alignment tools ClustalW and TCoffee (Bio::Tools::Run::Alignment). o New Cookbook-style tutorial (see bptutorial.pl). Improved documentation across the package. o Much improved cross platform support. Many known incompatibilities have been fixed; however, NT and Mac do not work across the entire setup (see PLATFORMS). o Many bug fixes, code restructuring, etc. Overall stability and maintainability benefit a lot. o A total of 957 automatic tests 0.6.2 There are very few functionality changes but a large number of software improvements/bug fixes across the package. o The EMBL/GenBank parsing are improved. o The Swissprot reading is improved. Swissprot writing is disabled as it doesn't work at all. This needs to wait for 0.7 release o BLAST reports with no hits are correctly parsed. o Several other bugs of the BLAST parser (regular expressions, ...) fixed. o Old syntax calls have been replaced with more modern syntax o Modules that did not work at all, in particular the Sim4 set have been removed o Bio::SeqFeature::Generic and Bio::SeqFeature::FeaturePair have improved compliance with interface specs and documentation o Mailing list documentation updated throughout the distribution o Most minor bug fixes have happened. o The scripts in /examples now work and have the modern syntax rather than the deprecated syntax 0.6.1 Sun April 2 2000 o Sequences can have Sequence Features attached to them - The sequence features can be read from or written to EMBL and GenBank style flat files o Objects for Annotation, including References (but not full medline abstracts), Database links and Comments are provided o A Species object to represent nodes on a taxonomy tree is provided o The ability to parse HMMER and Sim4 output has been added o The Blast parsing has been improved, with better PSI-BLAST support and better overall behaviour. o Flat file indexed databases provide both random access and sequential access to their component sequences. o A CodonTable object has been written with all known CodonTables accessible. o A number of new lightweight analysis tools have been added, such as molecular weight determination. The 0.6 release also has improved software engineering o The sequence objects have been rewritten, providing more maintainable and easier to implement objects. These objects are backwardly compatible with the 0.05.1 objects o Many objects are defined in terms of interfaces and then a Perl implementation has been provided. The interfaces are found in the 'I' files (module names ending in 'I'). This means that it is possible to wrap C/CORBA/SQL access as true "bioperl" objects, compatible with the rest of bioperl. o The SeqIO system has been overhauled to provide better processing and perl-like automatic interpretation of <> over arguments. o Many more tests have been added (a total of 172 automatic tests are now run before release). 0.05.1 Tue Jun 29 05:30:44 1999 - Central distribution now requires Perl 5.004. This was done to get around 5.003-based problems in Bio/Index/* and SimpleAlign. - Various bug fixes in the Bio::Tools::Blast modules including better exception handling and PSI-Blast support. See Bio/Tools/Blast/CHANGES for more. - Fixed the Parse mechanism in Seq.pm to use readseq. Follow the instructions in README for how to install it (basically, you have to edit Parse.pm). - Improved documentation of Seq.pm, indicating where objects are returned and where strings are returned. - Fixed uninitialized warnings in Bio::Root::Object.pm and Bio::Tools::SeqPattern.pm. - Bug fixes for PR#s: 30,31,33-35,41,42,44,45,47-50,52. 0.05 Sun Apr 25 01:14:11 1999 - Bio::Tools::Blast modules have less memory problems and faster parsing. Webblast uses LWP and supports more functionality. See Bio/Tools/Blast/CHANGES for more. - The Bio::SeqIO system has been started, moving the sequence reformatting code out of the sequence object - The Bio::Index:: system has been started, providing generic index capabilities and specifically works for Fasta formatted databases and EMBL .dat formatted databases - The Bio::DB:: system started, providing access to databases, both via flat file + index (see above) and via http to NCBI - The scripts/ directory, where industrial strength scripts are put has been started. - Many changes - a better distribution all round. 0.04.4 Wed Feb 17 02:20:13 1999 - Bug fixes in the Bio::Tools::Blast modules and postclient.pl (see Bio::Tools::Blast::CHANGES). - Fixed a bug in Bio::Tools::Fasta::num_seqs(). - Beefed up the t/Fasta.t test script. - Small fix in Bio::Seq::type() (now always returns a string). - Changed Bio::Root::Utilities::get_newline_char() to get_newline() since it could return more than one char. - Added $NEWLINE and $TIMEOUT_SECS to Bio::Root::Global. - Changed default timeout to 20 seconds (was 3). - Moved lengthy modification notes to the bottom of some files. - Fixed SimpleAlign write_fasta bug. - Beefed up SimpleAlign.t test 0.04.3 Thu Feb 4 07:48:53 1999 - Bio::Root::Object.pm and Global.pm now detect when script is run as a CGI and suppress output that is only appropriate when running interactively. - Bio::Root::Err::_set_context() adds name of script ($0). - Added comments in Bio::Tools::WWW.pm and Bio::Root::Utilities.pm regarding the use of the static objects via the qw(:obj) tag. - Fixed the ambiguous reverse calls in Seq.pm and UnivAln.pm to CORE::reverse, avoiding Perl warnings. - Bug fixes in Bio::Tools::Blast modules (version 0.074) and example scripts (see Bio::Tools::Blast::CHANGES). - examples/seq/seqtools.pl no longer always warns about using -prot or -nucl command-line arguments; only when using the -debug argument. - Methods added to Bio::Root::Utilities: create_filehandle(), get_newline_char(), and taste_file() to generalize filehandle creation and autodetect newline characters in files/streams (see bug report #19). - Bio::Root::IOManager::read() now handles timeouts and uses Utilities::create_filehandle(). - Bio::Tools::Fasta.pm uses Utilities::get_newline_char() instead of hardwiring in "\n". - Bug fixes in the Bio::SimpleAlign and Bio::Tools::pSW 0.04.2 Wed Dec 30 02:27:36 1998 - Bug fixes in Bio::Tools::Blast modules, version 0.073 (see Bio::Tools::Blast::CHANGES). - Changed reverse calls in Bio/Seq.pm and Bio/UnivAln.pm to CORE::reverse (prevents ambiguous warnings with 5.005). - Appending '.tmp.bioperl' to temporary files created by Bio::Root::Utilities::compress() or uncompress() to make it easy to identify & cleanup these files as needed. - Developers: Created CVS branch release-0-04-bug from release-0-04-1. Before making bug fixes to the 0.04.1 release, be sure to cvs checkout this branch into a clean area. 0.04.1 Wed Dec 16 05:39:15 1998 - Bug fixes in Bio::Tools::Blast modules, version 0.072 (see Bio::Tools::Blast::CHANGES). - Compile/SW/Makefile.PL now removes *.o and *.a files with make clean. 0.04 Tue Dec 8 07:49:19 1998 - Lots of new modules added including: * Ewan Birney's Bio::SimpleAlign.pm, Bio::Tools::AlignFactory.pm, and Bio/Compile directory containing XS-linked C code for creating Smith-Waterman sequence alignments from within Perl. * Steve Chervitz's Blast distribution has been incorporated. * Georg Fuellen's Bio::UnivAln.pm for multiple alignment objects. - Bio/examples directory for demo scripts for all included modules. - Bio/t directory containing test suit for all included modules. - For changes specific to the Blast-related modules prior to incorporation in this central distribution, see the CHANGES file in the Bio/Tools/Blast directory. 0.01 Tue Sep 8 14:23:22 1998 - original version from central CVS tree; created by h2xs 1.18 BioPerl-1.6.923/DEPENDENCIES000444000765000024 13153712254227333 15262 0ustar00cjfieldsstaff000000000000BioPerl Dependencies NOTE : This file was auto-generated by the helper script maintenance/dependencies.pl. Do not edit directly! The following packages are used by BioPerl. While not all are required for BioPerl to operate properly, some functionality will be missing without them. You can easily choose to install all of these during the normal installation process. Note that the PPM version of the BioPerl packages always tries to install all dependencies. The DBD::mysql, DB_File and XML::Parser modules require other applications or databases: MySQL, Berkeley DB, and expat respectively. NB: This list of packages is not authoritative. See the 'requires', 'build_requires' and 'recommends' sections of Build.PL instead. ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | AcePerl | * Ace - Interface to ACEDB (Popular | None | | | Genome DB) | | | | * Ace::Sequence::Homol - NA | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::Ace - Ace | | * Bio::DB::GFF::Adaptor::ace - Ace | | * Bio::DB::GFF::Adaptor::dbi::mysqlace - Ace::Sequence::Homol | | * Bio::DB::GFF::Adaptor::dbi::oracleace - Ace::Sequence::Homol | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Algorithm-Munkres | * Algorithm::Munkres - Solution to | None | | | classical Assignment Problem | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::PhyloNetwork - Algorithm::Munkres | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Archive-Tar | * Archive::Tar - Read, write and | None | | | manipulate tar files | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Root::Build - Archive::Tar | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Array-Compare | * Array::Compare - Class to compare | None | | | two arrays | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::PhyloNetwork - Array::Compare | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Bio-ASN1-EntrezGene | * Bio::ASN1::EntrezGene - Parser | None | | | for NCBI Entrez Gene (ASN.1- | | | | format) | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::SeqIO::entrezgene - Bio::ASN1::EntrezGene | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Compress-Zlib | * Compress::Zlib - Interface to | None | | | zlib compression library | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::SeqFeature::Store - Compress::Zlib | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Convert-Binary-C | * Convert::Binary::C - Binary Data | None | | | Conversion using C Types | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::SeqIO::strider - Convert::Binary::C | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | DBI | * DBI - Generic Database Interface | None | | | (see DBD modules) | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::GFF::Adaptor::dbi - DBI | | * Bio::DB::GFF::Adaptor::dbi::caching_handle - DBI | | * Bio::DB::SeqFeature::Store::DBI::mysql - DBI | | * Bio::DB::SeqFeature::Store::DBI::Pg - DBI | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Data-Stag | * Data::Stag - NA | None | | | * Data::Stag::XMLWriter - NA | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Annotation::TagTree - Data::Stag | | * Bio::SeqIO::chaosxml - Data::Stag::XMLWriter | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Graph | * Graph::Directed - NA | None | | | * Graph::Undirected - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::PhyloNetwork - Graph::Directed | | * Bio::Ontology::SimpleGOEngine::GraphAdaptor - Graph::Directed | | * Bio::Assembly::Tools::ContigSpectrum - Graph::Undirected | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | HTML-Parser | * HTML::HeadParser - Parse | None | | | section of HTML documents | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Tools::Analysis::DNA::ESEfinder - HTML::HeadParser | | * Bio::Tools::Analysis::Protein::ELM - HTML::HeadParser | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | IO-String | * IO::String - IO::File interface | None | | | for in-core strings | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::PhyloNetwork - IO::String | | * Bio::DB::CUTG - IO::String | | * Bio::DB::SeqHound - IO::String | | * Bio::DB::WebDBSeqI - IO::String | | * Bio::Index::Blast - IO::String | | * Bio::Index::BlastTable - IO::String | | * Bio::Index::Hmmer - IO::String | | * Bio::SearchIO::Writer::BSMLResultWriter - IO::String | | * Bio::SeqIO::game::gameWriter - IO::String | | * Bio::Tools::Analysis::DNA::ESEfinder - IO::String | | * Bio::Tools::Analysis::Protein::Domcut - IO::String | | * Bio::Tools::Analysis::Protein::ELM - IO::String | | * Bio::Tools::Analysis::Protein::GOR4 - IO::String | | * Bio::Tools::Analysis::Protein::HNN - IO::String | | * Bio::Tools::Analysis::Protein::Mitoprot - IO::String | | * Bio::Tools::Analysis::Protein::NetPhos - IO::String | | * Bio::Tools::Analysis::Protein::Scansite - IO::String | | * Bio::Tools::Analysis::Protein::Sopma - IO::String | | * Bio::Tools::Phylo::Molphy - IO::String | | * Bio::Tools::Phylo::PAML - IO::String | | * Bio::Tools::Run::RemoteBlast - IO::String | | * Bio::TreeIO::cluster - IO::String | | * Bio::TreeIO::nexus - IO::String | | * Bio::Variation::IO::xml - IO::String | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Math-Random | * Math::Random - Random Number | None | | | Generators | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::PhyloNetwork::RandomFactory - Math::Random | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Memoize | * Memoize - Automatically cache | None | | | results of functions | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::SeqFeature::Store::DBI::mysql - Memoize | | * Bio::DB::SeqFeature::Store::DBI::Pg - Memoize | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Module-Build | * Module::Build - Build, test, and | 0.2805 | | | install Perl modules | | | | * Module::Build::PPMMaker - NA | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Root::Build - Module::Build | | * Bio::Root::Test - Module::Build | | * Bio::Root::Build - Module::Build::PPMMaker | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | PostScript | * PostScript::TextBlock - Objects | None | | | used by PS::Document | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Tree::Draw::Cladogram - PostScript::TextBlock | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | SVG | * SVG - Generate SVG images and | 2.26 | | | files | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Draw::Pictogram - SVG | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | SVG-Graph | * SVG::Graph - Series of Modules to | None | | | produce SVG graphs | | | | * SVG::Graph::Data - NA | | | | * SVG::Graph::Data::Node - NA | | | | * SVG::Graph::Data::Tree - NA | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::TreeIO::svggraph - SVG::Graph | | * Bio::TreeIO::svggraph - SVG::Graph::Data | | * Bio::TreeIO::svggraph - SVG::Graph::Data::Node | | * Bio::TreeIO::svggraph - SVG::Graph::Data::Tree | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Set-Scalar | * Set::Scalar - Set of scalars (inc | None | | | references) | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Tree::Compatible - Set::Scalar | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Spreadsheet-ParseExcel | * Spreadsheet::ParseExcel - Get | None | | | information from Excel file | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Microarray::Tools::MitoChipV2Parser - Spreadsheet::ParseExcel | | * Bio::Microarray::Tools::ReseqChip - Spreadsheet::ParseExcel | | * Bio::SeqIO::excel - Spreadsheet::ParseExcel | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Spreadsheet-WriteExcel | * Spreadsheet::WriteExcel - Write | None | | | cross-platform Excel binary file. | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Microarray::Tools::ReseqChip - Spreadsheet::WriteExcel | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Statistics-Frequency | * Statistics::Frequency - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Microarray::Tools::ReseqChip - Statistics::Frequency | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Storable | * Storable - Persistent data | None | | | structure mechanism | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::SeqFeature::Store - Storable | | * Bio::Restriction::Enzyme - Storable | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Test-Exception | * Test::Exception - Functions for | None | | | testing exception-based code | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Root::Test - Test::Exception | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Test-Simple | * Test::Builder - NA | None | | | * Test::More - More functions for | | | | writing tests | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Root::Test::Warn - Test::Builder | | * Bio::Root::Test - Test::More | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Test-Warn | * Test::Warn - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Root::Test - Test::Warn | | * Bio::Root::Test::Warn - Test::Warn | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Tie-Cacher | * Tie::Cacher - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::SeqFeature::Store - Tie::Cacher | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Time-HiRes | * Time::HiRes - High resolution | None | | | time, sleep, and alarm | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::SeqFeature::Store::Loader - Time::HiRes | | * Bio::DB::SeqFeature::Store::DBI::mysql - Time::HiRes | | * Bio::DB::SeqFeature::Store::DBI::Pg - Time::HiRes | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Tree-DAG_Node | * Tree::DAG_Node - base class for | None | | | trees | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::TreeIO::svggraph - Tree::DAG_Node | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | URI | * URI - NA | None | | | * URI::Escape - General URI | | | | escaping/unescaping functions | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::NCBIHelper - URI | | * Bio::DB::Query::WebQuery - URI | | * Bio::Tools::EUtilities::EUtilParameters - URI | | * Bio::DB::CUTG - URI::Escape | | * Bio::DB::Biblio::eutils - URI::Escape | | * Bio::FeatureIO::gff - URI::Escape | | * Bio::FeatureIO::interpro - URI::Escape | | * Bio::SeqFeature::Annotated - URI::Escape | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | WWW-Mechanize | * WWW::Mechanize - Automates web | None | | | page form & link interaction | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::MeSH - WWW::Mechanize | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | Win32 | * Win32 - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::Fasta - Win32 | | * Bio::DB::GFF - Win32 | | * Bio::DB::Qual - Win32 | | * Bio::Root::IO - Win32 | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-DOM | * XML::DOM - Implements Level 1 of | None | | | W3's DOM | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::FeatureIO::interpro - XML::DOM | | * Bio::SeqIO::bsml - XML::DOM | | * Bio::SeqIO::interpro - XML::DOM | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-DOM-XPath | * XML::DOM::XPath - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::FeatureIO::interpro - XML::DOM::XPath | | * Bio::SeqIO::interpro - XML::DOM::XPath | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-LibXML | * XML::LibXML - Interface to the | None | | | libxml library | | | | * XML::LibXML::Reader - NA | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::TreeIO::phyloxml - XML::LibXML | | * Bio::TreeIO::phyloxml - XML::LibXML::Reader | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-Parser | * XML::Parser - Flexible fast | None | | | parser with plug-in styles | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Biblio::IO::medlinexml - XML::Parser | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-SAX | * XML::SAX - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::ClusterIO::dbsnp - XML::SAX | | * Bio::SearchIO::blastxml - XML::SAX | | * Bio::SeqIO::bsml_sax - XML::SAX | | * Bio::SeqIO::tigrxml - XML::SAX | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-SAX-Writer | * XML::SAX::Writer - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::SeqIO::tigrxml - XML::SAX::Writer | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-Simple | * XML::Simple - Easy API to | None | | | maintain XML (esp config files) | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::HIV::HIVQueryHelper - XML::Simple | | * Bio::DB::Query::HIVQuery - XML::Simple | | * Bio::Tools::EUtilities - XML::Simple | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-Twig | * XML::Twig - A module for easy | None | | | processing of XML | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::Biblio::eutils - XML::Twig | | * Bio::DB::Taxonomy::entrez - XML::Twig | | * Bio::Variation::IO::xml - XML::Twig | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | XML-Writer | * XML::Writer - Module for writing | 0.4 | | | XML documents | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::SearchIO::Writer::BSMLResultWriter - XML::Writer | | * Bio::SeqIO::agave - XML::Writer | | * Bio::SeqIO::chadoxml - XML::Writer | | * Bio::SeqIO::tinyseq - XML::Writer | | * Bio::SeqIO::game::gameWriter - XML::Writer | | * Bio::Variation::IO::xml - XML::Writer | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | bioperl-ext | * Bio::Ext::Align - NA | None | | | * Bio::SeqIO::staden::read - NA | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::SearchDist - Bio::Ext::Align | | * Bio::Tools::AlignFactory - Bio::Ext::Align | | * Bio::Tools::dpAlign - Bio::Ext::Align | | * Bio::Tools::pSW - Bio::Ext::Align | | * Bio::SeqIO::abi - Bio::SeqIO::staden::read | | * Bio::SeqIO::alf - Bio::SeqIO::staden::read | | * Bio::SeqIO::ctf - Bio::SeqIO::staden::read | | * Bio::SeqIO::exp - Bio::SeqIO::staden::read | | * Bio::SeqIO::pln - Bio::SeqIO::staden::read | | * Bio::SeqIO::ztr - Bio::SeqIO::staden::read | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | libwww-perl | * HTTP::Request - Class | 5.64 | | | encapsulating HTTP Requests | | | | * HTTP::Request::Common - Functions | | | | that generate HTTP::Requests | | | | * HTTP::Response - Class | | | | encapsulating HTTP Responses | | | | * LWP - Libwww-perl | | | | * LWP::Simple - Simple procedural | | | | interface to libwww-perl | | | | * LWP::UserAgent - A WWW UserAgent | | | | class | | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::Tools::EUtilities::EUtilParameters - HTTP::Request | | * Bio::DB::DBFetch - HTTP::Request::Common | | * Bio::DB::HIV - HTTP::Request::Common | | * Bio::DB::NCBIHelper - HTTP::Request::Common | | * Bio::DB::SwissProt - HTTP::Request::Common | | * Bio::DB::WebDBSeqI - HTTP::Request::Common | | * Bio::DB::Query::WebQuery - HTTP::Request::Common | | * Bio::Tools::Run::RemoteBlast - HTTP::Request::Common | | * Bio::DB::WebDBSeqI - HTTP::Response | | * Bio::Tools::Protparam - LWP | | * Bio::Tools::Run::RemoteBlast - LWP | | * Bio::DB::Biblio::eutils - LWP::Simple | | * Bio::Root::IO - LWP::Simple | | * Bio::DB::GenericWebAgent - LWP::UserAgent | | * Bio::DB::MeSH - LWP::UserAgent | | * Bio::DB::WebDBSeqI - LWP::UserAgent | | * Bio::DB::Query::WebQuery - LWP::UserAgent | | * Bio::Root::Build - LWP::UserAgent | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | libxml-perl | * XML::Parser::PerlSAX - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::OntologyIO::InterProParser - XML::Parser::PerlSAX | | * Bio::SeqIO::tinyseq - XML::Parser::PerlSAX | | * Bio::SeqIO::game::gameSubs - XML::Parser::PerlSAX | ============================================================================== ============================================================================== | Distribution | Module used - Description | Min. ver. | |---------------------------+--------------------------------------+-----------| | mod_perl | * Apache2::SubProcess - NA | None | |==============================================================================| | Used by: | |------------------------------------------------------------------------------| | * Bio::DB::WebDBSeqI - Apache2::SubProcess | ============================================================================== BioPerl-1.6.923/DEPRECATED000444000765000024 612212254227334 14764 0ustar00cjfieldsstaff000000000000# These are modules which are deprecated and later removed from the toolkit # See http://www.bioperl.org/wiki/Deprecated_modules for the latest details Version Version Deprecated Modules Deprecated Removed Comment -------------------------------------------------------------------------------- Bio::Annotation 1.0 1.1 use Bio::Annotation::Collection Bio::Tools::Blast 1.0 1.1 use Bio::SearchIO Bio::Tools::Blast::HSP 1.0 1.1 use Bio::Search::HSP::GenericHSP Bio::Tools::Blast::Sbjct 1.0 1.1 use Bio::Search::Hit::GenericHit Bio::Tools::Blast::HTML 1.0 1.1 use Bio::SearchIO::Writer::HTMLWriter Bio::Tools::SeqAnal 1.0 1.1 used only by deprecated Bio::Tools::Blast Bio::UnivAln 1.0 1.1 use Bio::SimpleAlign Bio::Tools::WWW 1.1 1.1.1 Just a collection of links Bio::Root::Err 1.5.2 1.5.2 Bio::Root* redundant classes Bio::Root::Global 1.5.2 1.5.2 Bio::Root* redundant classes Bio::Root::IOManager 1.5.2 1.5.2 Bio::Root* redundant classes Bio::Root::Object 1.5.2 1.5.2 Bio::Root* redundant classes Bio::Root::Vector 1.5.2 1.5.2 Bio::Root* redundant classes Bio::Root::Xref 1.5.2 1.5.2 Bio::Root* redundant classes Bio::Tools::RestrictionEnzyme 1.5 1.6 use Bio::Restriction Bio::Tools::BPlite 1.5 1.6 use Bio::SearchIO Bio::Tools::BPpsilite 1.5 1.6 use Bio::SearchIO Bio::Tools::BPbl2seq 1.5 1.6 use Bio::SearchIO Bio::Ontology::SimpleGOEngine 1.5.1 1.6 use Bio::Ontology::OBOEngine Bio::Factory::ResultFactoryI 1.5.2 1.6 Superseded by Bio::Factory::ObjectFactory Bio::Factory::HitFactoryI 1.5.2 1.6 Superseded by Bio::Factory::ObjectFactory Bio::Graph 1.5.2 1.6 Superseded by bioperl-network Bio::Tools::WebBlat 1.5.2 1.6 Requested that this not be maintained Bio::DB::XEMBL 1.5.2 1.6 Service no longer available; use DBFetch Bio::DB::XEMBLService 1.5.2 1.6 Service no longer available; use DBFetch Bio::Taxonomy 1.5.1 1.7 use Bio::Taxon & Bio::Tree::Tree Bio::Taxonomy::Node 1.5.1 1.7 renamed Bio::Taxon Bio::Taxonomy::Taxon 1.5.1 1.7 use Bio::Taxon Bio::Taxonomy::Tree 1.5.1 1.7 use Bio::Taxon & Bio::Tree::Tree Bio::Taxonomy::FactoryI 1.5.1 1.7 Redundant, no implementors Bio::Search::Processor 1.5.1 1.7 Superseded by Bio::SearchIO Bio::Tools::RNAMotif 1.5.2 1.7 Superseded by Bio::SearchIO::rnamotif Bio::Tools::Infernal 1.5.2 1.7 Superseded by Bio::SearchIO::infernal Bio::Tools::ERPIN 1.5.2 1.7 Superseded by Bio::SearchIO::erpin Bio::Seq::SeqWithQuality 1.5.1 1.7 Superceded by Bio::Seq::Quality Bio::DB::GDB 1.6 1.6 Service no longer available Bio::Expression - - Moved to inactive bioperl-microarray BioPerl-1.6.923/INSTALL000444000765000024 4336312254227312 14516 0ustar00cjfieldsstaff000000000000Installing BioPerl for Unix * 1 BIOPERL INSTALLATION * 2 SYSTEM REQUIREMENTS * 3 OPTIONAL * 4 ADDITIONAL INSTALLATION INFORMATION * 5 PRELIMINARY PREPARATION * 6 INSTALLING BIOPERL THE EASY WAY USING Build.PL * 7 INSTALLING BIOPERL THE EASY WAY USING CPAN * 8 WHERE ARE THE MAN PAGES? * 9 EXTERNAL PROGRAMS * 9.1 Environment Variables * 10 THE BIOPERL BUNDLE * 11 INSTALLING BIOPERL SCRIPTS * 12 INSTALLING BIOPERL IN A PERSONAL MODULE AREA * 13 INSTALLING BIOPERL MODULES THE HARD WAY * 14 USING MODULES NOT INSTALLED IN THE STANDARD LOCATION * 15 THE TEST SYSTEM * 16 BUILDING THE OPTIONAL bioperl-ext PACKAGE * 16.1 CONFIGURING for BSD and Solaris boxes * 16.2 INSTALLATION BIOPERL INSTALLATION For the most up-to-date installation instructions please see the BioPerl wiki: http://www.bioperl.org/wiki/Installing_BioPerl BioPerl has been installed on many forms of Unix, Win9X/NT/2000/XP, and on Mac OS X (see the PLATFORMS file for more details). Following are instructions for installing BioPerl for Unix/Linux/Mac OS X; Windows installation instructions can be found in INSTALL.WIN. For installing BioPerl for Mac OS X using Fink, see: http://www.bioperl.org/wiki/Getting_BioPerl#Mac_OS_X_using_fink SYSTEM REQUIREMENTS * Perl 5.6.1 or later; version 5.8 and greater are highly recommended. Modules are generally tested against perl 5.8 and above. * External modules: BioPerl uses functionality provided in other Perl modules. Some of these are included in the standard perl package but some need to be obtained from the CPAN site. The list of external modules is included in the DEPENDENCIES file. OPTIONAL * ANSI C or GNU C compiler (gcc) for XS extensions (the bioperl-ext package; see BUILDING THE OPTIONAL bioperl-ext PACKAGE, below). ADDITIONAL INSTALLATION INFORMATION * Additional information on BioPerl and MAC OS: * OS 9 - http://bioperl.org/Core/mac-bioperl.html NOTE: These are severely out-of-date and require MacPerl (the latest version of which is 5.6.1rc1). As such, we do not currently support BioPerl on OS 9 * OS X - Installing using Fink (in Getting BioPerl) PRELIMINARY PREPARATION This is optional, but regardless of your subsequent choice of installation method, it will help to carry out the following steps. They will increase the likelyhood of installation success (especially of optional dependencies). * Upgrade CPAN: >perl -MCPAN -e shell cpan>install Bundle::CPAN cpan>q * Install/upgrade Module::Build, and make it your preferred installer: >cpan cpan>install Module::Build cpan>o conf prefer_installer MB cpan>o conf commit cpan>q * Install the expat library by whatever method is appropriate for your system. * If your expat library is installed in a non-standard location, tell CPAN about it: >cpan cpan>o conf makepl_arg "EXPATLIBPATH=/non-standard/lib EXPATINCPATH=/non-standard/include" cpan>o conf commit INSTALLING BIOPERL THE EASY WAY USING Build.PL The advantage of this approach is it's stepwise, so it's easy to stop and analyze in case of any problem. Download, then unpack the tar file. For example: >tar xvfz BioPerl-1.6.1.tar.gz >cd BioPerl-1.6.1 Now issue the build commands: >perl Build.PL >./Build test If you've installed everything perfectly and all the network connections are working then you may pass all the tests run in the './Build test' phase. It's also possible that you may fail some tests. Possible explanations: problems with local Perl installation, network problems, previously undetected bug in BioPerl, flawed test script, problems with CGI script using for sequence retrieval at public database, and so on. Remember that there are over 900 modules in BioPerl and the test suite is running more than 12000 individual tests, a few failed tests may not affect your usage of BioPerl. If you decide that the failed tests will not affect how you intend to use BioPerl and you'd like to install anyway, or if all tests were fine, do: >./Build install This is what most experienced BioPerl users would do. However, if you're concerned about a failed test and need assistance or advice then contact bioperl-l@bioperl.org. (You could provide us the detailed results of the failed test(s): see the `THE TEST SYSTEM' below for information on how to generate such results.) To './Build install' you need write permission in the perl5/site_perl/source area (or similar, depending on your environment). Usually this will require you becoming root, so you will want to talk to your systems manager if you don't have the necessary privileges. It is also straightforward to install the package outside of the this standard Perl5 location. See INSTALLING BIOPERL IN A PERSONAL MODULE AREA, below. INSTALLING BIOPERL THE EASY WAY USING CPAN You can use the CPAN shell to install BioPerl. For example: >perl -MCPAN -e shell Or you might have the cpan alias installed: >cpan Then find the name of the BioPerl version you want: cpan>d /bioperl/ CPAN: Storable loaded ok Going to read /home/bosborne/.cpan/Metadata Database was generated on Mon, 20 Nov 2006 05:24:36 GMT .... Distribution B/BI/BIRNEY/bioperl-1.2.tar.gz Distribution B/BI/BIRNEY/bioperl-1.4.tar.gz Distribution C/CJ/CJFIELDS/BioPerl-1.6.1.tar.gz Now install: cpan>install C/CJ/CJFIELDS/BioPerl-1.6.1.tar.gz If you've installed everything perfectly and all the network connections are working then you may pass all the tests run in the './Build test' phase. It's also possible that you may fail some tests. Possible explanations: problems with local Perl installation, network problems, previously undetected bug in BioPerl, flawed test script, problems with CGI script used for sequence retrieval at public database, and so on. Remember that there are over 900 modules in BioPerl and the test suite is running more than 12000 individual tests, a few failed tests may not affect your usage of BioPerl. If you decide that the failed tests will not affect how you intend to use BioPerl and you'd like to install anyway do: cpan>force install C/CJ/CJFIELDS/BioPerl-1.6.1.tar.gz This is what most experienced BioPerl users would do. However, if you're concerned about a failed test and need assistance or advice then contact bioperl-l@bioperl.org. (You could provide us the detailed results of the failed test(s): see the `THE TEST SYSTEM' below for information on how to generate such results.) WHERE ARE THE MAN PAGES? Previously, when using Makefile.PL (no longer covered in this documentation), we had to disable the automatic creation of man pages because this step was triggering a "line too long" error on some OSs due to shell constraints. If you want man pages installed use the Build.PL installation process discussed above. EXTERNAL PROGRAMS BioPerl can interface with some external programs for executing analyses. These include clustalw and t_coffee for Multiple Sequence Alignment (Bio::Tools::Run::Alignment::Clustalw and Bio::Tools::Run::Alignment::TCoffee) and blastall, blastpgp, and bl2seq for BLAST analyses (Bio::Tools::Run::StandAloneBlast), and to all the programs in the EMBOSS suite (Bio::Factory::EMBOSS). Most of the modules which 'wrap' these programs are located in the separate bioperl-run distribution; however, two commonly-used modules are still distributed with the BioPerl core (Bio::Tools::Run::StandAloneBlast, Bio::Tools::Run::RemoteBlast). Environment Variables Some modules which run external programs need certain environment variables set. If you do not have a local copy of the specific executable you do not need to set these variables. Additionally the modules will attempt to locate the specific applications in your runtime PATH variable. You may also need to set an environment variable to tell BioPerl about your network configuration if your site uses a firewall. Setting environment variables on unix means adding lines like the following to your shell *rc file. For bash or sh: export BLASTDIR=/data1/blast For csh or tcsh: setenv BLASTDIR /data1/blast Some environment variables include: +------------------------------------------------------------------------+ | Env. Variable | Description | |---------------+--------------------------------------------------------| | |Specifies where the NCBI blastall, blastpgp, bl2seq, | |BLASTDIR |etc.. are located. A 'data' directory could also be | | |present in this directory as well, you could put your | | |blastable databases here. | |---------------+--------------------------------------------------------| | |If one does not want to locate the data dir within the | |BLASTDATADIR or|same dir as where the BLASTDIR variable points, a | |BLASTDB |BLASTDATADIR or BLASTDB variable can be set to point to | | |a dir where BLAST database indexes are located. | |---------------+--------------------------------------------------------| |BLASTMAT |The directory containing the substitution matrices such | | |as BLOSUM62. | |---------------+--------------------------------------------------------| |CLUSTALDIR |The directory where the clustalw executable is located. | |---------------+--------------------------------------------------------| |TCOFFEEDIR |The directory where the t_coffee executable is located. | |---------------+--------------------------------------------------------| | |If you access the internet via a proxy server then you | | |can tell the BioPerl modules which require network | | |access about this by using the http_proxy environment | |http_proxy |variable. The value set includes the proxy address and | | |the port, with optional username/password for | | |authentication purposes | | |(e.g. http://USERNAME:PASSWORD@proxy.example.com:8080). | +------------------------------------------------------------------------+ THE BIOPERL BUNDLE Users of previous versions of BioPerl may remember Bundle::BioPerl. You no longer need to install Bundle::BioPerl. Instead, the normal installation process will ask you if you'd like to install optional external module dependencies that BioPerl has. A full list of BioPerl dependencies can be found in the DEPENDENCIES file included with this distribution. INSTALLING BIOPERL SCRIPTS BioPerl comes with a set of production-quality scripts that are kept in the scripts/ directory. You can install these scripts if you'd like, simply answer the questions during 'perl Build.PL'. The installation directory can be specified by: perl Build.PL ./Build install --install_path script=/foo/scripts By default they install to /usr/bin or similar, depending on platform. INSTALLING BIOPERL IN A PERSONAL MODULE AREA If you lack permission to install perl modules into the standard site_perl/ system area you can configure BioPerl to install itself anywhere you choose. Ideally this would be a personal perl directory or standard place where you plan to put all your 'local' or personal perl modules. Example: >perl Build.PL --install_base /home/users/dag >./Build test >./Build install This tells perl to install all the various parts of bioperl in the desired place, e.g. creating: /home/users/dag/lib/perl5/Bio/Perl.pm Then in your BioPerl script you would write: use lib "/home/users/dag/lib/perl5/"; use Bio::Perl; For more information on these sorts of custom installs see the documentation for Module::Build. If you are used to using something like: >perl Makefile.PL PREFIX=/home/users/dag You can get similar behaviour by using this instead: >perl Build.PL --prefix /home/users/dag For more information, see Module::Build::Cookbook documentation for Installing_in_the_same_location_as_ExtUtils::MakeMaker You can also use CPAN to install modules in your local directory. First enter the CPAN shell, then set the arguments for the commands "perl Makefile.PL" and "./Build install", like this: >perl -e shell -MCPAN cpan>o conf makepl_arg LIB=/home/users/dag/My_Local_Perl_Modules cpan>o conf mbuild_install_arg "--install_path lib=/home/users/dag/My_Local_Perl_Modules" cpan>o conf commit INSTALLING BIOPERL MODULES THE HARD WAY As a last resort, you can simply copy all files in Bio/ to any directory in which you have write privileges. This is generally NOT recommended since some modules may require special configuration (currently none do, but don't rely on this). You will need to set "use lib '/path/to/my/bioperl/modules';" in your perl scripts so that you can access these modules if they are not installed in the standard site_perl/ location. See above for an example. To get manpage documentation to work correctly you will have to configure man so that it looks in the proper directory. On most systems this will just involve adding an additional directory to your $MANPATH environment variable. The installation of the Compile directory can be similarly redirected, but execute the make commands from the Compile/SW directory. If all else fails and you are unable to access the perl distribution directories, ask your system administrator to place the files there for you. You can always execute perl scripts in the same directory as the location of the modules (Bio/ in the distribution) since perl always checks the current working directory when looking for modules. USING MODULES NOT INSTALLED IN THE STANDARD LOCATION You can explicitly tell perl where to look for modules by using the Lib module which comes standard with perl. Example: #!/usr/bin/perl use lib "/home/users/dag/lib/perl5/"; use Bio::Perl; #<...insert whizzy perl code here...> Or, you can set the environmental variable PERL5LIB: csh or tcsh: setenv PERL5LIB /home/users/dag/lib/perl5/ bash or sh: export PERL5LIB=/home/users/dag/lib/perl5/ THE TEST SYSTEM The BioPerl test system is located in the t/ directory and is automatically run whenever you execute the './Build test' command (having previously run 'Perl Build.PL'; if you have already installed BioPerl answer 'no' to script installation to get nicer test output later). For the 1.6 release and beyond, tests have been organized into groups based upon the specific task or class the module being tested belongs to. If you want to investigate the behavior of a specific test such as the Seq test you would type: >./Build test --test_files t/Seq/Seq.t --verbose The ./ ensures you are using the Build script in the current directory to make sure you are testing the modules in this directory not ones installed elsewhere. The --test_files arguement can be used multiple times to try a set of test scripts in one go. The --verbose arguement outputs the detailed test results, instead of just the summary you see during './Build test'. The '--test-files' argument can also work as a glob. For instance, to run tests on all SearchIO modules, use the following: >./Build test --test_files t/SearchIO* --verbose If you are trying to learn how to use a module, often the test suite is a good place to look. All good extreme programmers try and write a test BEFORE they write the module to insure that their module behaves the way they expect. You'll notice some 'ok' and 'skip' commands in a test, this is part of the Perl test suite that signifies a passed test with an 'ok N', where N is the test number. Alternatively you can tell Perl to skip tests. This is useful when, for example, your test detects that the network is not present and thus should skip, not fail, any tests that require a network connection. The core developers have indicated that future releases of BioPerl will require that new modules come with a test suite with some minimal tests. Modules that lack adequate tests or could otherwise be considered 'unstable' will be moved into a separate developer distribution until adequate tests are added and the API stablizes. BUILDING THE OPTIONAL bioperl-ext PACKAGE The bioperl-ext package contains C code and XS extensions for various alignment and trace file modules (Bio::Tools::pSW for DNA Smith-Waterman, Bio::Tools::dpAlign for protein Smith-Waterman, Bio::SearchDist for EVD fitting of extreme value, Bio::SeqIO::staden). This Installation may work out-of-the box for most platforms except BSD and Solaris boxes. For other platforms skip this next paragraph. Of note, the code for bioperl-ext has not been updated along with the rest of bioperl, so one may expect to see some issues. If so, please report them to the BioPerl mailing list. Patches for these modules are always welcome. CONFIGURING for BSD and Solaris boxes You should add the line -fPIC to the CFLAGS line in Compile/SW/libs/makefile. This makes the compile generate position independent code, which is required for these architectures. In addition, on some Solaris boxes, the generated Makefile does not make the correct -fPIC/-fpic flags for the C compiler that is used. This requires manual editing of the generated Makefile to switch case. Try it out once, and if you get errors, try editing the -fpic line INSTALLATION Move to the directory bioperl-ext. This is available as a separate package released from ftp://bioperl.org/pub/bioperl/DIST. This is where the C code and XS extension for the bp_sw module is held and execute these commands: (possibly after making the change for BSD and Solaris, as detailed above) perl Makefile.PL # makes the system specific makefile make # builds all the libaries make test # runs a short test make install # installs the package correctly. This should install the compiled extension. The Bio::Tools::pSW module will work cleanly now. BioPerl-1.6.923/INSTALL.SKIP000444000765000024 2112254227334 15167 0ustar00cjfieldsstaff000000000000ConfigData\.\S+$ BioPerl-1.6.923/INSTALL.WIN000444000765000024 7271012254227323 15152 0ustar00cjfieldsstaff000000000000# $Id$ Installing Bioperl on Windows Contents * 1 Introduction * 2 Requirements * 3 Installation using the Perl Package Manager * 3.1 GUI Installation * 3.2 Comand-line Installation * 4 Installation using CPAN or manual installation * 5 Bioperl * 6 Perl on Windows * 7 Bioperl on Windows * 8 Beyond the Core * 8.1 Setting environment variables * 8.2 Installing bioperl-db * 9 Bioperl in Cygwin * 10 bioperl-db in Cygwin * 11 Cygwin tips * 12 MySQL and DBD::mysql * 13 Expat * 14 Directory for temporary files * 15 BLAST * 16 Compiling C code Introduction This installation guide was written by Barry Moore, Nathan Haigh and other Bioperl authors based on the original work of Paul Boutros. The guide was updated for the BioPerl wiki by Chris Fields and Nathan Haigh. Please report problems and/or fixes to the BioPerl mailing list. An up-to-date version of this document can be found on the BioPerl wiki: http://www.bioperl.org/wiki/Installing_Bioperl_on_Windows Requirements Only ActivePerl >= 5.8.8.819 is supported by the Bioperl team. Earlier versions may work, but we do not support them. One of the reason for this requirement is that ActivePerl >= 5.8.8.819 now use Perl Package Manager 4 (PPM4). PPM4 is now superior to earlier versions and also includes a Graphical User Interface (GUI). In short, it's easier for us to produce and maintain a package for installation via PPM and also easier for you to do the install! Proceed with earlier versions at your own risk. To install ActivePerl: 1) Download the ActivePerl MSI from ActiveState 2) Run the ActivePerl Installer (accepting all defaults is fine). Installation using the Perl Package Manager GUI Installation 1) Start the Perl Package Manager GUI from the Start menu. 2) Go to Edit >> Preferences and click the Repositories tab. Add a new repository for each of the following: Repositories to add +----------------------------------------------------------------+ | Name | Location | |--------------------------+-------------------------------------| |BioPerl-Release Candidates|[37]http://bioperl.org/DIST/RC | |--------------------------+-------------------------------------| |BioPerl-Regular Releases |[38]http://bioperl.org/DIST | |--------------------------+-------------------------------------| |Kobes |[39]http://theoryx5.uwinnipeg.ca/ppms| |--------------------------+-------------------------------------| |Bribes |[40]http://www.Bribes.org/perl/ppm | +----------------------------------------------------------------+ 3) Select View >> All Packages. 4) In the search box type bioperl. 5) Right click the latest version of Bioperl available and choose install. 5a) From bioperl 1.5.2 onward, all 'optional' pre-requisites will be marked for installation. If you see that some of them complain about needing a command-line installation (eg. XML::SAX::ExpatXS), and you want those particular pre-requisites, stop now (skip step 6) and see the 'Command-line Installation' section. 6) Click the green arrow (Run marked actions) to complete the installation. Comand-line Installation Use the ActiveState ppm-shell: 1) Open a cmd window by going to Start >> Run and typing 'cmd' and pressing return. 2) Do C:> ppm-shell ppm> 3) Make sure you have the module PPM-Repositories. Try installing it: ppm> install PPM-Repositories 4) For BioPerl 1.6.1, we require at least the following repositories. You may have some present already. ppm> repo add http://bioperl.org/DIST ppm> repo add uwinnipeg ppm> repo add trouchelle Because you have installed PPM-Repositories, PPM will know your Perl version, and select the correct repo from the table above. 5) Install BioPerl (not "bioperl"). ppm> install BioPerl If you are running ActiveState Perl 5.10, you may have a glitch involving SOAP::Lite. Use the following workaround: 1) Get the index numbers for your active repositories: ppm> repo | id | pkgs | name | | 1 | 11431 | ActiveState Package Repository | | 2 | 14 | bioperl.org | | 3 | 291 | uwinnipeg | | 4 | 11755 | trouchelle | 2) Execute the following commands. (The session here is based on the above table. Substitute the correct index numbers for your situation.) rem -turn off ActiveState, trouchelle repos ppm> repo off 1 ppm> repo off 4 rem -to get SOAP-Lite-0.69 from uwinnipeg... ppm> install SOAP-Lite rem -turn ActiveState, trouchelle back on... ppm> repo on 1 ppm> repo on 4 rem -now try... ppm> install BioPerl Installation using CPAN or manual installation Installation using PPM is preferred since it is easier, but if you run into problems, or a ppm isn't available for the version/package of bioperl you want, or you want to choose which optional dependencies to install, you can install manually by downloading the appropriate package or by using CPAN. In fact both methods ultimately need nmake to be installed, CPAN to be upgraded to >= v1.81, Module::Build to be installed (>= v0.2805) and Test::Harness to be upgraded to >= v2.62: 1) Download nmake 2) Double-click to run it, which extracts 3 files. Move both NMAKE.EXE and the NMAKE.ERR files to a place in your PATH; if set up properly, you can move these to your Perl bin directory, normally C:\Perl\bin. 1) Open a cmd window by going to Start >> Run and typing 'cmd' into the box and pressing return. 2) Type 'cpan' to enter the CPAN shell. 3) At the cpan> prompt, type 'install CPAN' to upgrade to the latest version. 4) Quit (by typing 'q') and reload cpan. You may be asked some configuration questions; accepting defaults is fine. 5) At the cpan> prompt, type 'o conf prefer_installer MB' to tell CPAN to prefer to use Build.PL scripts for installation. Type 'o conf commit' to save that choice. 6) At the cpan> prompt, type 'install Module::Build'. 7) At the cpan> prompt, type 'install Test::Harness'. You can now follow the unix instructions for installing using CPAN, or install manually: 8) Download the .zip version of the package you want. 9) Extract the archive in the normal way. 10) In a cmd window 'cd' to the directory you extracted to. Eg. if you extracted to directory 'Temp', 'cd Temp\bioperl-1.5.2_100' 11) Type 'perl Build.PL' and answer the questions appropriately. 12) Type 'perl Build test'. All the tests should pass, but if they don't, let us know. Your usage of Bioperl may not be affected by the failure, so you can choose to continue anyway. 13) Type 'perl Build install' to install Bioperl. Bioperl Bioperl is a large collection of Perl modules (extensions to the Perl language) that aid in the task of writing Perl code to deal with sequence data in a myriad of ways. Bioperl provides objects for various types of sequence data and their associated features and annotations. It provides interfaces for analysis of these sequences with a wide variety of external programs (BLAST, FASTA, clustalw and EMBOSS to name just a few). It provides interfaces to various types of databases both remote (GenBank, EMBL etc) and local (MySQL, Flat_databases flat files, GFF etc.) for storage and retrieval of sequences. And finally with its associated documentation and mailing lists, Bioperl represents a community of bioinformatics professionals working in Perl who are committed to supporting both development of Bioperl and the new users who are drawn to the project. While most bioinformatics and computational biology applications are developed in UNIX/Linux environments, more and more programs are being ported to other operating systems like Windows, and many users (often biologists with little background in programming) are looking for ways to automate bioinformatics analyses in the Windows environment. Perl and Bioperl can be installed natively on Windows NT/2000/XP. Most of the functionality of Bioperl is available with this type of install. Much of the heavy lifting in bioinformatics is done by programs originally developed in lower level languages like C and Pascal (e.g. BLAST, clustalw, Staden etc). Bioperl simply acts as a wrapper for running and parsing output from these external programs. Some of those programs (BLAST for example) are ported to Windows. These can be installed and work quite happily with Bioperl in the native Windows environment. Some external programs such as Staden and the EMBOSS suite of programs can only be installed on Windows by using Cygwin and its gcc C compiler (see Bioperl in Cygwin, below). Recent attempts to port EMBOSS to Windows, however, have been mostly successful. If you have a fairly simple project in mind, want to start using Bioperl quickly, only have access to a computer running Windows, and/or don't mind bumping up against some limitations then Bioperl on Windows may be a good place for you to start. For example, downloading a bunch of sequences from GenBank and sorting out the ones that have a particular annotation or feature works great. Running a bunch of your sequences against remote or local BLAST, parsing the output and storing it in a MySQL database would be fine also. Be aware that most Bioperl developers are working in some type of a UNIX environment (Linux, OS X, Cygwin). If you have problems with Bioperl that are specific to the Windows environment, you may be blazing new ground and your pleas for help on the Bioperl mailing list may get few responses (you can but try!) - simply because no one knows the answer to your Windows specific problem. If this is or becomes a problem for you then you are better off working in some type of UNIX-like environment. One solution to this problem that will keep you working on a Windows machine it to install Cygwin, a UNIX emulation environment for Windows. A number of Bioperl users are using this approach successfully and it is discussed in more detail below. Perl on Windows There are a couple of ways of installing Perl on a Windows machine. The most common and easiest is to get the most recent build from ActiveState, a software company that provides free builds of Perl for Windows users. The current (October 2006) build is ActivePerl 5.8.8.819. Bioperl also works on Perl 5.6.x, but due to installation problems etc, only ActivePerl 5.8.8.819 or later is supported for WinXP installation. To install ActivePerl on Windows: 1) Download the ActivePerl MSI from http://www.activestate.com/Products/ActivePerl/. 2) Run the ActivePerl Installer (accepting all defaults is fine). You can also build Perl yourself (which requires a C compiler) or download one of the other binary distributions. The Perl source for building it yourself is available from CPAN, as are a few other binary distributions that are alternatives to ActiveState. This approach is not recommended unless you have specific reasons for doing so and know what you're doing. If that's the case you probably don't need to be reading this guide. Cygwin is a UNIX emulation environment for Windows and comes with its own copy of Perl. Information on Cygwin and Bioperl is found below. Bioperl on Windows Perl is a programming language that has been extended a lot by the addition of external modules. These modules work with the core language to extend the functionality of Perl. Bioperl is one such extension to Perl. These modular extensions to Perl sometimes depend on the functionality of other Perl modules and this creates a dependency. You can't install module X unless you have already installed module Y. Some Perl modules are so fundamentally useful that the Perl developers have included them in the core distribution of Perl - if you've installed Perl then these modules are already installed. Other modules are freely available from CPAN, but you'll have to install them yourself if you want to use them. Bioperl has such dependencies. Bioperl is actually a large collection of Perl modules (over 1000 currently) and these modules are split into seven packages. These seven packages are: +------------------------------------------------------------------------+ | Bioperl Group | Functions | |----------------------+-------------------------------------------------| |bioperl (the core) |Most of the main functionality of Bioperl | |----------------------+-------------------------------------------------| |bioperl-run |Wrappers to a lot of external programs | |----------------------+-------------------------------------------------| |bioperl-ext |Interaction with some alignment functions and the| | |Staden package | |----------------------+-------------------------------------------------| |bioperl-db |Using Bioperl with BioSQL and local relational | | |databases | |----------------------+-------------------------------------------------| |bioperl-microarray |Microarray specific functions | |----------------------+-------------------------------------------------| |bioperl-pedigree |manipulating genotype, marker, and individual | | |data for linkage studies | |----------------------+-------------------------------------------------| |bioperl-gui |Some preliminary work on a graphical user | | |interface to some Bioperl functions | +------------------------------------------------------------------------+ The Bioperl core is what most new users will want to start with. Bioperl (the core) and the Perl modules that it depends on can be easily installed with the perl package Manager PPM. PPM is an ActivePerl utility for installing Perl modules on systems using ActivePerl. PPM will look online (you have to be connected to the internet of course) for files (these files end with .ppd) that tell it how to install the modules you want and what other modules your new modules depends on. It will then download and install your modules and all dependent modules for you. These .ppd files are stored online in PPM repositories. ActiveState maintains the largest PPM repository and when you installed ActivePerl PPM was installed with directions for using the ActiveState repositories. Unfortunately the ActiveState repositories are far from complete and other ActivePerl users maintain their own PPM repositories to fill in the gaps. Installing will require you to direct PPM to look in three new repositories as detailed in Installation Guide. Once PPM knows where to look for Bioperl and it's dependencies you simply tell PPM to search for packages with a particular name, select those of interest and then tell PPM to install the selected packages. Beyond the Core You may find that you want some of the features of other Bioperl groups like bioperl-run or bioperl-db. Currently, plans include setting up PPM packages for installing these parts of Bioperl; check this by doing a Bioperl search in PPM. If these are not available, though, you can use the following instructions for installing the other distributions. For this you will need a Windows version of the program make called nmake: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe You will also want to have a willingness to experiment. You'll have to read the installation documents for each component that you want to install, and use nmake where the instructions call for make, like so: perl Makefile.PL nmake nmake test nmake install 'nmake test' will likely produce lots of warnings, many of these can be safely ignored (these stem from the excessively paranoid '-w' flag in ActivePerl). You will have to determine from the installation documents what dependencies are required, and you will have to get them, read their documentation and install them first. It is recommended that you look through the PPM repositories for any modules before resorting to using nmake as there isn't any guarantee modules built using nmake will work. The details of this are beyond the scope of this guide. Read the documentation. Search Google. Try your best, and if you get stuck consult with others on the BioPerl mailing list. Setting environment variables Some modules and tools such as Bio::Tools::Run::StandAloneBlast and clustal_w, require that environment variables are set; a few examples are listed in the INSTALL document. Different versions of Windows utilize different methods for setting these variables. NOTE: The instructions that comes with the BLAST executables for setting up BLAST on Windows are out-of-date. Go to the following web address for instructions on setting up standalone BLAST for Windows: http://www.ncbi.nlm.nih.gov/staff/tao/URLAPI/pc_setup.html * For Windows XP, go here. This does not require a reboot but all active shells will not reflect any changes made to the environment. * For older versions (Windows 95 to ME), generally editing the C:\autoexec.bat file to add a variable works. This requires a reboot. Here's an example: set BLASTDB=C:\blast\data For either case, you can check the variable this way: C:\Documents and Settings\Administrator>echo %BLASTDB% C:\blast\data Some versions of Windows may have problems differentiating forward and back slashes used for directories. In general, always use backslashes (\). If something isn't working properly try reversing the slashes to see if it helps. For setting up Cygwin environment variables quirks, see an example below. Installing bioperl-db bioperl-db now works for Windows w/o installing CygWin. This has primarily been tested on WinXP using MySQL5, but it is expected that other bioperl-db supported databases (PostgreSQL, Oracle) should work. You will need Bioperl rel. 1.5.2, a relational database (I use MySQL5 here as an example), and the Perl modules DBI and DBD::mysql, which can be installed from PPM as desribed above (make sure the additional repositories for Kobes and Bribes are added, they will have the latest releases). Do NOT try using nmake with these modules as they will not build correctly under Windows! The PPM builds, by Randy Kobes, have been modified and tested specifically for Windows and ActivePerl. NOTE: we plan on having a PPM for bioperl-db available along with the regular bioperl 1.5.2 release PPM. We will post instructions at that time on using PPM to install bioperl-db. To begin, follow instructions detailed in the Installation Guide for adding the three new repositories (Bioperl, Kobes and Bribes). Then install the following packages: 1) DBI 2) DBD-mysql The next step involves creating a database. The following steps are for MySQL5: >mysqladmin -u root -p create bioseqdb Enter password: ********** The database needs to be loaded with the BioSQL schema, which can be downloaded as a tarball here. >mysql -u root -p bioseqdb < biosqldb-mysql.sql Enter password: ********** Download bioperl-db from CVS. Use the following to install the modules: perl Makefile.PL nmake Now, for testing out bioperl-db, make a copy of the file DBHarness.conf.example in the bioperl-db test subdirectory (bioperl-db\t). Rename it to DBHarness.biosql.conf, and modify it for your database setup (particularly the user, password, database name, and driver). Save the file, change back to the main bioperl-db directory, and run 'nmake test'. You may see lots of the following lines, .... Subroutine Bio::Annotation::Reference::(eq redefined at C:/Perl/lib/overload.pm line 25, line 1. Subroutine new redefined at C:\Perl\src\bioperl\bioperl-live/Bio\Annotation\Reference.pm line 80, line 1. .... which can be safely ignored (again, these come from ActivePerl's paranoid '-w' flag). All tests should pass. NOTE : tests should be run with a clean database with the BiOSQL schema loaded, but w/o taxonomy loaded (see below). To install, run: nmake install It is recommended that you load the taxonomy database using the script load_ncbi_taxonomy.pl included in biosql-schema\scripts. You will need to download the latest taxonomy files. This can be accomplished using the -download flag in load_ncbi_taxonomy.pl, but it will not 'untar' the file correctly unless you have GNU tar present in your PATH (which most Windows users will not have), thus causing the following error: >load_ncbi_taxonomy.pl -download -driver mysql -dbname bioseqdb -dbuser root -dbpass ********** The system cannot find the path specified. Loading NCBI taxon database in taxdata: ... retrieving all taxon nodes in the database ... reading in taxon nodes from nodes.dmp Couldn't open data file taxdata/nodes.dmp: No such file or directory rollback ineffective with AutoCommit enabled at C:\Perl\src\bioperl\biosql-schema\scripts\load_ncbi_taxonomy.pl line 818. Rollback ineffective while AutoCommit is on at C:\Perl\src\bioperl\biosql-schema\scripts\load_ncbi_taxonomy.pl line 818. rollback failed: Rollback ineffective while AutoCommit is on Use a file decompression utility like 7-Zip to 'untar' the files in the folder (if using 7-Zip, this can be accomplished by right-clicking on the file and using the option 'Extract here'). Rerun the script without the -download flag to load the taxonomic information. Be patient, as this can take quite a while: >load_ncbi_taxonomy.pl -driver mysql -dbname bioseqdb -dbuser root -dbpass ********** Loading NCBI taxon database in taxdata: ... retrieving all taxon nodes in the database ... reading in taxon nodes from nodes.dmp ... insert / update / delete taxon nodes ... (committing nodes) ... rebuilding nested set left/right values ... reading in taxon names from names.dmp ... deleting old taxon names ... inserting new taxon names ... cleaning up Done. Now, load the database with your sequences using the script load_seqdatabase.pl, in bioperl-db's bioperl-db\script directory: C:\Perl\src\bioperl\bioperl-db\scripts\biosql>load_seqdatabase.pl -drive mysql -dbname bioseqdb -dbuser root -dbpass ********** Loading NP_249092.gpt ... Done. You may see occasional errors depending on the sequence format, which is a non-platform-related issue. Many of these are due to not having an updated taxonomic database and may be rectified by updating the taxonomic information as detailed in load_ncbi_taxonomy.pl's POD. Thanks to Baohua Wang, who found the initial Windows-specific problem in Bio::Root::Root that led to this fix, to Sendu Bala for fixing Bug #1938, and to Hilmar Lapp for his input. Bioperl in Cygwin Cygwin is a Unix emulator and shell environment available free at http://www.cygwin.com. Bioperl v. 1.* supposedly runs well within Cygwin, though the latest release has not been tested with Cygwin yet. Some users claim that installation of Bioperl is easier within Cygwin than within Windows, but these may be users with UNIX backgrounds. A note on Cygwin: it doesn't write to your Registry, it doesn't alter your system or your existing files in any way, it doesn't create partitions, it simply creates a cygwin/ directory and writes all of its files to that directory. To uninstall Cygwin just delete that directory. One advantage of using Bioperl in Cygwin is that all the external modules are available through CPAN - the same cannot be said of ActiveState's PPM utility. To get Bioperl running first install the basic Cygwin package as well as the Cygwin perl, make, binutils, and gcc packages. Clicking the View button in the upper right of the installer window enables you to see details on the various packages. Then start up Cygwin and follow the Bioperl installation instructions for UNIX in Bioperl's INSTALL file (for example, THE BIOPERL BUNDLE and INSTALLING BIOPERL THE EASY WAY USING CPAN). bioperl-db in Cygwin This package is installed using the instructions contained in the package, without modification. Since postgres is a package within Cygwin this is probably the easiest of the 3 platforms supported in bioperl-db to install (postgres, Mysql, Oracle). Cygwin tips If you can, install Cygwin on a drive or partition that's NTFS-formatted, not FAT32-formatted. When you install Cygwin on a FAT32 partition you will not be able to set permissions and ownership correctly. In most situations this probably won't make any difference but there may be occasions where this is a problem. If you're trying to use some application or resource outside of Cygwin directory and you're having a problem remember that Cygwin's path syntax may not be the correct one. Cygwin understands /home/jacky or /cygdrive/e/cygwin/home/jacky (when referring to the E: drive) but the external resource may want E:/cygwin/home/jacky. So your *rc files may end up with paths written in these different syntaxes, depending. MySQL and DBD::mysql You may want to install a relational database in order to use BioPerl db, BioSQL or OBDA. The easiest way to install Mysql is to use the Windows binaries available at http://www.mysql.com. Note that Windows does not have sockets, so you need to force the Mysql connections to use TCP/IP instead. Do this by using the -h, or host, option from the command-line. Example: >mysql -h 127.0.0.1 -u -p Alternatively you could install postgres instead of MySQL, postgres is already a package in Cygwin. One known issue is that DBD::mysql can be tricky to install in Cygwin and this module is required for the bioperl-db, Biosql, and bioperl-pipeline external packages. Fortunately there's some good instructions online: * Instructions included with DBD::mysql: http://search.cpan.org/src/JWIED/DBD-mysql-2.1025/INSTALL.html#windows/cygwin * Additional instructions if you run into any problems; this information is more up-to-date, covers post-2.9 DBD::mysql quirks in Cygwin. http://rage.against.org/installingdbdmysqlInCygwin Expat Note that expat comes with Cygwin (it's used by the modules XML::Parser and XML::SAX::ExpatXS, which are used by certain Bioperl modules). Directory for temporary files Set the environmental variable TMPDIR, programs like BLAST and clustalw need a place to create temporary files. e.g.: setenv TMPDIR e:/cygwin/tmp # csh, tcsh export TMPDIR=e:/cygwin/tmp # sh, bash This is not the syntax that Cygwin understands, which would be something like /cygdrive/e/cygwin/tmp or /tmp, this is the syntax that a Windows application expects. If this variable is not set correctly you'll see errors like this when you run Bio::Tools::Run::StandAloneBlast: ------------- EXCEPTION: Bio::Root::Exception ------------- MSG: Could not open /tmp/gXkwEbrL0a: No such file or directory STACK: Error::throw .......... [edit] BLAST If you want use BLAST we recommend that the Windows binary be obtained from NCBI (ftp://ftp.ncbi.nih.gov/blast/executables/LATEST/ - the file will be named something like blast-2.2.13-ia32-win32.exe). Then follow the Windows instructions in README.bls. You will also need to set the BLASTDIR environment variable to reflect the directory which holds the blast executable and data folder. You may also want to set other variables to reflect the location of your databases and substitution matrices if they differ from the location of your blast executables; see Installing Bioperl for Unix for more details. Compiling C code Although we've recommended using the BLAST and MySQL binaries you should be able to compile just about everything else from source code using Cygwin's gcc. You'll notice when you're installing Cygwin that many different libraries are also available (gd, jpeg, etc.). BioPerl-1.6.923/LICENSE000444000765000024 12127012254227313 14505 0ustar00cjfieldsstaff000000000000BioPerl is licensed under the same terms as Perl itself, which means it is dually-licensed under either the Artistic or GPL licenses. Below are details of the Artistic License and, following it, the GPL. The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . BioPerl-1.6.923/MANIFEST000444000765000024 15205612254227327 14644 0ustar00cjfieldsstaff000000000000.travis.yml AUTHORS Bio/Align/AlignI.pm Bio/Align/DNAStatistics.pm Bio/Align/Graphics.pm Bio/Align/PairwiseStatistics.pm Bio/Align/ProteinStatistics.pm Bio/Align/StatisticsI.pm Bio/Align/Utilities.pm Bio/AlignIO.pm Bio/AlignIO/arp.pm Bio/AlignIO/bl2seq.pm Bio/AlignIO/clustalw.pm Bio/AlignIO/emboss.pm Bio/AlignIO/fasta.pm Bio/AlignIO/Handler/GenericAlignHandler.pm Bio/AlignIO/largemultifasta.pm Bio/AlignIO/maf.pm Bio/AlignIO/mase.pm Bio/AlignIO/mega.pm Bio/AlignIO/meme.pm Bio/AlignIO/metafasta.pm Bio/AlignIO/msf.pm Bio/AlignIO/nexml.pm Bio/AlignIO/nexus.pm Bio/AlignIO/pfam.pm Bio/AlignIO/phylip.pm Bio/AlignIO/po.pm Bio/AlignIO/proda.pm Bio/AlignIO/prodom.pm Bio/AlignIO/psi.pm Bio/AlignIO/selex.pm Bio/AlignIO/stockholm.pm Bio/AlignIO/xmfa.pm Bio/AnalysisI.pm Bio/AnalysisParserI.pm Bio/AnalysisResultI.pm Bio/AnnotatableI.pm Bio/Annotation/AnnotationFactory.pm Bio/Annotation/Collection.pm Bio/Annotation/Comment.pm Bio/Annotation/DBLink.pm Bio/Annotation/OntologyTerm.pm Bio/Annotation/Reference.pm Bio/Annotation/Relation.pm Bio/Annotation/SimpleValue.pm Bio/Annotation/StructuredValue.pm Bio/Annotation/TagTree.pm Bio/Annotation/Target.pm Bio/Annotation/Tree.pm Bio/Annotation/TypeManager.pm Bio/AnnotationCollectionI.pm Bio/AnnotationI.pm Bio/Assembly/Contig.pm Bio/Assembly/ContigAnalysis.pm Bio/Assembly/IO.pm Bio/Assembly/IO/ace.pm Bio/Assembly/IO/bowtie.pm Bio/Assembly/IO/maq.pm Bio/Assembly/IO/phrap.pm Bio/Assembly/IO/sam.pm Bio/Assembly/IO/tigr.pm Bio/Assembly/Scaffold.pm Bio/Assembly/ScaffoldI.pm Bio/Assembly/Singlet.pm Bio/Assembly/Tools/ContigSpectrum.pm Bio/Cluster/ClusterFactory.pm Bio/Cluster/FamilyI.pm Bio/Cluster/SequenceFamily.pm Bio/Cluster/UniGene.pm Bio/Cluster/UniGeneI.pm Bio/ClusterI.pm Bio/ClusterIO.pm Bio/ClusterIO/dbsnp.pm Bio/ClusterIO/unigene.pm Bio/CodonUsage/IO.pm Bio/CodonUsage/Table.pm Bio/Coordinate/Chain.pm Bio/Coordinate/Collection.pm Bio/Coordinate/ExtrapolatingPair.pm Bio/Coordinate/GeneMapper.pm Bio/Coordinate/Graph.pm Bio/Coordinate/MapperI.pm Bio/Coordinate/Pair.pm Bio/Coordinate/Result.pm Bio/Coordinate/Result/Gap.pm Bio/Coordinate/Result/Match.pm Bio/Coordinate/ResultI.pm Bio/Coordinate/Utils.pm Bio/Das/FeatureTypeI.pm Bio/Das/SegmentI.pm Bio/DasI.pm Bio/DB/Ace.pm Bio/DB/BioFetch.pm Bio/DB/CUTG.pm Bio/DB/DBFetch.pm Bio/DB/EMBL.pm Bio/DB/EntrezGene.pm Bio/DB/Expression.pm Bio/DB/Expression/geo.pm Bio/DB/Failover.pm Bio/DB/Fasta.pm Bio/DB/FileCache.pm Bio/DB/Flat.pm Bio/DB/Flat/BDB.pm Bio/DB/Flat/BDB/embl.pm Bio/DB/Flat/BDB/fasta.pm Bio/DB/Flat/BDB/genbank.pm Bio/DB/Flat/BDB/swiss.pm Bio/DB/Flat/BinarySearch.pm Bio/DB/GenBank.pm Bio/DB/GenericWebAgent.pm Bio/DB/GenPept.pm Bio/DB/GFF.pm Bio/DB/GFF/Adaptor/ace.pm Bio/DB/GFF/Adaptor/berkeleydb.pm Bio/DB/GFF/Adaptor/berkeleydb/iterator.pm Bio/DB/GFF/Adaptor/biofetch.pm Bio/DB/GFF/Adaptor/biofetch_oracle.pm Bio/DB/GFF/Adaptor/dbi.pm Bio/DB/GFF/Adaptor/dbi/caching_handle.pm Bio/DB/GFF/Adaptor/dbi/iterator.pm Bio/DB/GFF/Adaptor/dbi/mysql.pm Bio/DB/GFF/Adaptor/dbi/mysqlace.pm Bio/DB/GFF/Adaptor/dbi/mysqlcmap.pm Bio/DB/GFF/Adaptor/dbi/mysqlopt.pm Bio/DB/GFF/Adaptor/dbi/oracle.pm Bio/DB/GFF/Adaptor/dbi/oracleace.pm Bio/DB/GFF/Adaptor/dbi/pg.pm Bio/DB/GFF/Adaptor/dbi/pg_fts.pm Bio/DB/GFF/Adaptor/memory.pm Bio/DB/GFF/Adaptor/memory/feature_serializer.pm Bio/DB/GFF/Adaptor/memory/iterator.pm Bio/DB/GFF/Aggregator.pm Bio/DB/GFF/Aggregator/alignment.pm Bio/DB/GFF/Aggregator/clone.pm Bio/DB/GFF/Aggregator/coding.pm Bio/DB/GFF/Aggregator/gene.pm Bio/DB/GFF/Aggregator/match.pm Bio/DB/GFF/Aggregator/none.pm Bio/DB/GFF/Aggregator/orf.pm Bio/DB/GFF/Aggregator/processed_transcript.pm Bio/DB/GFF/Aggregator/so_transcript.pm Bio/DB/GFF/Aggregator/transcript.pm Bio/DB/GFF/Aggregator/ucsc_acembly.pm Bio/DB/GFF/Aggregator/ucsc_ensgene.pm Bio/DB/GFF/Aggregator/ucsc_genscan.pm Bio/DB/GFF/Aggregator/ucsc_refgene.pm Bio/DB/GFF/Aggregator/ucsc_sanger22.pm Bio/DB/GFF/Aggregator/ucsc_sanger22pseudo.pm Bio/DB/GFF/Aggregator/ucsc_softberry.pm Bio/DB/GFF/Aggregator/ucsc_twinscan.pm Bio/DB/GFF/Aggregator/ucsc_unigene.pm Bio/DB/GFF/Featname.pm Bio/DB/GFF/Feature.pm Bio/DB/GFF/Homol.pm Bio/DB/GFF/RelSegment.pm Bio/DB/GFF/Segment.pm Bio/DB/GFF/Typename.pm Bio/DB/GFF/Util/Binning.pm Bio/DB/GFF/Util/Rearrange.pm Bio/DB/HIV.pm Bio/DB/HIV/HIVAnnotProcessor.pm Bio/DB/HIV/HIVQueryHelper.pm Bio/DB/HIV/lanl-schema.xml Bio/DB/IndexedBase.pm Bio/DB/InMemoryCache.pm Bio/DB/LocationI.pm Bio/DB/MeSH.pm Bio/DB/NCBIHelper.pm Bio/DB/Qual.pm Bio/DB/Query/GenBank.pm Bio/DB/Query/HIVQuery.pm Bio/DB/Query/WebQuery.pm Bio/DB/QueryI.pm Bio/DB/RandomAccessI.pm Bio/DB/ReferenceI.pm Bio/DB/RefSeq.pm Bio/DB/Registry.pm Bio/DB/SeqFeature.pm Bio/DB/SeqFeature/NormalizedFeature.pm Bio/DB/SeqFeature/NormalizedFeatureI.pm Bio/DB/SeqFeature/NormalizedTableFeatureI.pm Bio/DB/SeqFeature/Segment.pm Bio/DB/SeqFeature/Store.pm Bio/DB/SeqFeature/Store/bdb.pm Bio/DB/SeqFeature/Store/berkeleydb.pm Bio/DB/SeqFeature/Store/berkeleydb3.pm Bio/DB/SeqFeature/Store/DBI/Iterator.pm Bio/DB/SeqFeature/Store/DBI/mysql.pm Bio/DB/SeqFeature/Store/DBI/Pg.pm Bio/DB/SeqFeature/Store/DBI/SQLite.pm Bio/DB/SeqFeature/Store/FeatureFileLoader.pm Bio/DB/SeqFeature/Store/GFF2Loader.pm Bio/DB/SeqFeature/Store/GFF3Loader.pm Bio/DB/SeqFeature/Store/Loader.pm Bio/DB/SeqFeature/Store/LoadHelper.pm Bio/DB/SeqFeature/Store/memory.pm Bio/DB/SeqHound.pm Bio/DB/SeqI.pm Bio/DB/SeqVersion.pm Bio/DB/SeqVersion/gi.pm Bio/DB/SwissProt.pm Bio/DB/Taxonomy.pm Bio/DB/Taxonomy/entrez.pm Bio/DB/Taxonomy/flatfile.pm Bio/DB/Taxonomy/greengenes.pm Bio/DB/Taxonomy/list.pm Bio/DB/Taxonomy/silva.pm Bio/DB/TFBS.pm Bio/DB/TFBS/transfac_pro.pm Bio/DB/Universal.pm Bio/DB/UpdateableSeqI.pm Bio/DB/WebDBSeqI.pm Bio/DBLinkContainerI.pm Bio/DescribableI.pm Bio/Draw/Pictogram.pm Bio/Event/EventGeneratorI.pm Bio/Event/EventHandlerI.pm Bio/Factory/AnalysisI.pm Bio/Factory/ApplicationFactoryI.pm Bio/Factory/DriverFactory.pm Bio/Factory/FTLocationFactory.pm Bio/Factory/LocationFactoryI.pm Bio/Factory/MapFactoryI.pm Bio/Factory/ObjectBuilderI.pm Bio/Factory/ObjectFactory.pm Bio/Factory/ObjectFactoryI.pm Bio/Factory/SeqAnalysisParserFactory.pm Bio/Factory/SeqAnalysisParserFactoryI.pm Bio/Factory/SequenceFactoryI.pm Bio/Factory/SequenceProcessorI.pm Bio/Factory/SequenceStreamI.pm Bio/Factory/TreeFactoryI.pm Bio/FeatureHolderI.pm Bio/HandlerBaseI.pm Bio/IdCollectionI.pm Bio/IdentifiableI.pm Bio/Index/Abstract.pm Bio/Index/AbstractSeq.pm Bio/Index/Blast.pm Bio/Index/BlastTable.pm Bio/Index/EMBL.pm Bio/Index/Fasta.pm Bio/Index/Fastq.pm Bio/Index/GenBank.pm Bio/Index/Hmmer.pm Bio/Index/Qual.pm Bio/Index/Stockholm.pm Bio/Index/SwissPfam.pm Bio/Index/Swissprot.pm Bio/LiveSeq/AARange.pm Bio/LiveSeq/Chain.pm Bio/LiveSeq/ChainI.pm Bio/LiveSeq/DNA.pm Bio/LiveSeq/Exon.pm Bio/LiveSeq/Gene.pm Bio/LiveSeq/Intron.pm Bio/LiveSeq/IO/BioPerl.pm Bio/LiveSeq/IO/Loader.pm Bio/LiveSeq/IO/README Bio/LiveSeq/Mutation.pm Bio/LiveSeq/Mutator.pm Bio/LiveSeq/Prim_Transcript.pm Bio/LiveSeq/Range.pm Bio/LiveSeq/Repeat_Region.pm Bio/LiveSeq/Repeat_Unit.pm Bio/LiveSeq/SeqI.pm Bio/LiveSeq/Transcript.pm Bio/LiveSeq/Translation.pm Bio/LocatableSeq.pm Bio/Location/Atomic.pm Bio/Location/AvWithinCoordPolicy.pm Bio/Location/CoordinatePolicyI.pm Bio/Location/Fuzzy.pm Bio/Location/FuzzyLocationI.pm Bio/Location/NarrowestCoordPolicy.pm Bio/Location/Simple.pm Bio/Location/Split.pm Bio/Location/SplitLocationI.pm Bio/Location/WidestCoordPolicy.pm Bio/LocationI.pm Bio/Map/Clone.pm Bio/Map/Contig.pm Bio/Map/CytoMap.pm Bio/Map/CytoMarker.pm Bio/Map/CytoPosition.pm Bio/Map/EntityI.pm Bio/Map/FPCMarker.pm Bio/Map/Gene.pm Bio/Map/GeneMap.pm Bio/Map/GenePosition.pm Bio/Map/GeneRelative.pm Bio/Map/LinkageMap.pm Bio/Map/LinkagePosition.pm Bio/Map/MapI.pm Bio/Map/Mappable.pm Bio/Map/MappableI.pm Bio/Map/Marker.pm Bio/Map/MarkerI.pm Bio/Map/Microsatellite.pm Bio/Map/OrderedPosition.pm Bio/Map/OrderedPositionWithDistance.pm Bio/Map/Physical.pm Bio/Map/Position.pm Bio/Map/PositionHandler.pm Bio/Map/PositionHandlerI.pm Bio/Map/PositionI.pm Bio/Map/PositionWithSequence.pm Bio/Map/Prediction.pm Bio/Map/Relative.pm Bio/Map/RelativeI.pm Bio/Map/SimpleMap.pm Bio/Map/TranscriptionFactor.pm Bio/MapIO.pm Bio/MapIO/fpc.pm Bio/MapIO/mapmaker.pm Bio/Matrix/Generic.pm Bio/Matrix/IO.pm Bio/Matrix/IO/mlagan.pm Bio/Matrix/IO/phylip.pm Bio/Matrix/IO/scoring.pm Bio/Matrix/MatrixI.pm Bio/Matrix/Mlagan.pm Bio/Matrix/PhylipDist.pm Bio/Matrix/PSM/InstanceSite.pm Bio/Matrix/PSM/InstanceSiteI.pm Bio/Matrix/PSM/IO.pm Bio/Matrix/PSM/IO/mast.pm Bio/Matrix/PSM/IO/masta.pm Bio/Matrix/PSM/IO/meme.pm Bio/Matrix/PSM/IO/psiblast.pm Bio/Matrix/PSM/IO/transfac.pm Bio/Matrix/PSM/ProtMatrix.pm Bio/Matrix/PSM/ProtPsm.pm Bio/Matrix/PSM/Psm.pm Bio/Matrix/PSM/PsmHeader.pm Bio/Matrix/PSM/PsmHeaderI.pm Bio/Matrix/PSM/PsmI.pm Bio/Matrix/PSM/SiteMatrix.pm Bio/Matrix/PSM/SiteMatrixI.pm Bio/Matrix/Scoring.pm Bio/MolEvol/CodonModel.pm Bio/Nexml/Factory.pm Bio/NexmlIO.pm Bio/Ontology/DocumentRegistry.pm Bio/Ontology/GOterm.pm Bio/Ontology/InterProTerm.pm Bio/Ontology/OBOEngine.pm Bio/Ontology/OBOterm.pm Bio/Ontology/Ontology.pm Bio/Ontology/OntologyEngineI.pm Bio/Ontology/OntologyI.pm Bio/Ontology/OntologyStore.pm Bio/Ontology/Path.pm Bio/Ontology/PathI.pm Bio/Ontology/Relationship.pm Bio/Ontology/RelationshipFactory.pm Bio/Ontology/RelationshipI.pm Bio/Ontology/RelationshipType.pm Bio/Ontology/SimpleGOEngine/GraphAdaptor.pm Bio/Ontology/SimpleOntologyEngine.pm Bio/Ontology/Term.pm Bio/Ontology/TermFactory.pm Bio/Ontology/TermI.pm Bio/OntologyIO.pm Bio/OntologyIO/dagflat.pm Bio/OntologyIO/goflat.pm Bio/OntologyIO/Handlers/BaseSAXHandler.pm Bio/OntologyIO/Handlers/InterPro_BioSQL_Handler.pm Bio/OntologyIO/Handlers/InterProHandler.pm Bio/OntologyIO/InterProParser.pm Bio/OntologyIO/obo.pm Bio/OntologyIO/simplehierarchy.pm Bio/OntologyIO/soflat.pm Bio/ParameterBaseI.pm Bio/Perl.pm Bio/Phenotype/Correlate.pm Bio/Phenotype/Measure.pm Bio/Phenotype/MeSH/Term.pm Bio/Phenotype/MeSH/Twig.pm Bio/Phenotype/OMIM/MiniMIMentry.pm Bio/Phenotype/OMIM/OMIMentry.pm Bio/Phenotype/OMIM/OMIMentryAllelicVariant.pm Bio/Phenotype/OMIM/OMIMparser.pm Bio/Phenotype/Phenotype.pm Bio/Phenotype/PhenotypeI.pm Bio/PhyloNetwork.pm Bio/PhyloNetwork/Factory.pm Bio/PhyloNetwork/FactoryX.pm Bio/PhyloNetwork/GraphViz.pm Bio/PhyloNetwork/muVector.pm Bio/PhyloNetwork/RandomFactory.pm Bio/PhyloNetwork/TreeFactory.pm Bio/PhyloNetwork/TreeFactoryMulti.pm Bio/PhyloNetwork/TreeFactoryX.pm Bio/PopGen/Genotype.pm Bio/PopGen/GenotypeI.pm Bio/PopGen/HtSNP.pm Bio/PopGen/Individual.pm Bio/PopGen/IndividualI.pm Bio/PopGen/IO.pm Bio/PopGen/IO/csv.pm Bio/PopGen/IO/hapmap.pm Bio/PopGen/IO/phase.pm Bio/PopGen/IO/prettybase.pm Bio/PopGen/Marker.pm Bio/PopGen/MarkerI.pm Bio/PopGen/PopStats.pm Bio/PopGen/Population.pm Bio/PopGen/PopulationI.pm Bio/PopGen/Simulation/Coalescent.pm Bio/PopGen/Simulation/GeneticDrift.pm Bio/PopGen/Statistics.pm Bio/PopGen/TagHaplotype.pm Bio/PopGen/Utilities.pm Bio/PrimarySeq.pm Bio/PrimarySeqI.pm Bio/PullParserI.pm Bio/Range.pm Bio/RangeI.pm Bio/Restriction/Analysis.pm Bio/Restriction/Enzyme.pm Bio/Restriction/Enzyme/MultiCut.pm Bio/Restriction/Enzyme/MultiSite.pm Bio/Restriction/EnzymeCollection.pm Bio/Restriction/EnzymeI.pm Bio/Restriction/IO.pm Bio/Restriction/IO/bairoch.pm Bio/Restriction/IO/base.pm Bio/Restriction/IO/itype2.pm Bio/Restriction/IO/prototype.pm Bio/Restriction/IO/withrefm.pm Bio/Root/Build.pm Bio/Root/Exception.pm Bio/Root/HTTPget.pm Bio/Root/IO.pm Bio/Root/Root.pm Bio/Root/RootI.pm Bio/Root/Storable.pm Bio/Root/Test.pm Bio/Root/Utilities.pm Bio/Root/Version.pm Bio/Search/BlastStatistics.pm Bio/Search/BlastUtils.pm Bio/Search/DatabaseI.pm Bio/Search/GenericDatabase.pm Bio/Search/GenericStatistics.pm Bio/Search/Hit/BlastHit.pm Bio/Search/Hit/BlastPullHit.pm Bio/Search/Hit/Fasta.pm Bio/Search/Hit/GenericHit.pm Bio/Search/Hit/HitFactory.pm Bio/Search/Hit/HitI.pm Bio/Search/Hit/hmmer3Hit.pm Bio/Search/Hit/HMMERHit.pm Bio/Search/Hit/HmmpfamHit.pm Bio/Search/Hit/ModelHit.pm Bio/Search/Hit/PsiBlastHit.pm Bio/Search/Hit/PullHitI.pm Bio/Search/HSP/BlastHSP.pm Bio/Search/HSP/BlastPullHSP.pm Bio/Search/HSP/FastaHSP.pm Bio/Search/HSP/GenericHSP.pm Bio/Search/HSP/HMMERHSP.pm Bio/Search/HSP/HmmpfamHSP.pm Bio/Search/HSP/HSPFactory.pm Bio/Search/HSP/HSPI.pm Bio/Search/HSP/ModelHSP.pm Bio/Search/HSP/PsiBlastHSP.pm Bio/Search/HSP/PSLHSP.pm Bio/Search/HSP/PullHSPI.pm Bio/Search/HSP/WABAHSP.pm Bio/Search/Iteration/GenericIteration.pm Bio/Search/Iteration/IterationI.pm Bio/Search/Processor.pm Bio/Search/Result/BlastPullResult.pm Bio/Search/Result/BlastResult.pm Bio/Search/Result/CrossMatchResult.pm Bio/Search/Result/GenericResult.pm Bio/Search/Result/hmmer3Result.pm Bio/Search/Result/HMMERResult.pm Bio/Search/Result/HmmpfamResult.pm Bio/Search/Result/PullResultI.pm Bio/Search/Result/ResultFactory.pm Bio/Search/Result/ResultI.pm Bio/Search/Result/WABAResult.pm Bio/Search/SearchUtils.pm Bio/Search/StatisticsI.pm Bio/Search/Tiling/MapTileUtils.pm Bio/Search/Tiling/MapTiling.pm Bio/Search/Tiling/TilingI.pm Bio/SearchDist.pm Bio/SearchIO.pm Bio/SearchIO/axt.pm Bio/SearchIO/blast.pm Bio/SearchIO/blast_pull.pm Bio/SearchIO/blasttable.pm Bio/SearchIO/blastxml.pm Bio/SearchIO/cross_match.pm Bio/SearchIO/erpin.pm Bio/SearchIO/EventHandlerI.pm Bio/SearchIO/exonerate.pm Bio/SearchIO/fasta.pm Bio/SearchIO/FastHitEventBuilder.pm Bio/SearchIO/gmap_f9.pm Bio/SearchIO/hmmer.pm Bio/SearchIO/hmmer2.pm Bio/SearchIO/hmmer3.pm Bio/SearchIO/hmmer_pull.pm Bio/SearchIO/infernal.pm Bio/SearchIO/IteratedSearchResultEventBuilder.pm Bio/SearchIO/megablast.pm Bio/SearchIO/psl.pm Bio/SearchIO/rnamotif.pm Bio/SearchIO/SearchResultEventBuilder.pm Bio/SearchIO/SearchWriterI.pm Bio/SearchIO/sim4.pm Bio/SearchIO/waba.pm Bio/SearchIO/wise.pm Bio/SearchIO/Writer/BSMLResultWriter.pm Bio/SearchIO/Writer/GbrowseGFF.pm Bio/SearchIO/Writer/HitTableWriter.pm Bio/SearchIO/Writer/HSPTableWriter.pm Bio/SearchIO/Writer/HTMLResultWriter.pm Bio/SearchIO/Writer/ResultTableWriter.pm Bio/SearchIO/Writer/TextResultWriter.pm Bio/SearchIO/XML/BlastHandler.pm Bio/SearchIO/XML/PsiBlastHandler.pm Bio/Seq.pm Bio/Seq/BaseSeqProcessor.pm Bio/Seq/EncodedSeq.pm Bio/Seq/LargeLocatableSeq.pm Bio/Seq/LargePrimarySeq.pm Bio/Seq/LargeSeq.pm Bio/Seq/LargeSeqI.pm Bio/Seq/Meta.pm Bio/Seq/Meta/Array.pm Bio/Seq/MetaI.pm Bio/Seq/PrimaryQual.pm Bio/Seq/PrimedSeq.pm Bio/Seq/QualI.pm Bio/Seq/Quality.pm Bio/Seq/RichSeq.pm Bio/Seq/RichSeqI.pm Bio/Seq/SeqBuilder.pm Bio/Seq/SeqFactory.pm Bio/Seq/SeqFastaSpeedFactory.pm Bio/Seq/SequenceTrace.pm Bio/Seq/SeqWithQuality.pm Bio/Seq/SimulatedRead.pm Bio/Seq/TraceI.pm Bio/SeqAnalysisParserI.pm Bio/SeqEvolution/DNAPoint.pm Bio/SeqEvolution/EvolutionI.pm Bio/SeqEvolution/Factory.pm Bio/SeqFeature/Amplicon.pm Bio/SeqFeature/AnnotationAdaptor.pm Bio/SeqFeature/Collection.pm Bio/SeqFeature/CollectionI.pm Bio/SeqFeature/Computation.pm Bio/SeqFeature/FeaturePair.pm Bio/SeqFeature/Gene/Exon.pm Bio/SeqFeature/Gene/ExonI.pm Bio/SeqFeature/Gene/GeneStructure.pm Bio/SeqFeature/Gene/GeneStructureI.pm Bio/SeqFeature/Gene/Intron.pm Bio/SeqFeature/Gene/NC_Feature.pm Bio/SeqFeature/Gene/Poly_A_site.pm Bio/SeqFeature/Gene/Promoter.pm Bio/SeqFeature/Gene/Transcript.pm Bio/SeqFeature/Gene/TranscriptI.pm Bio/SeqFeature/Gene/UTR.pm Bio/SeqFeature/Generic.pm Bio/SeqFeature/Lite.pm Bio/SeqFeature/PositionProxy.pm Bio/SeqFeature/Primer.pm Bio/SeqFeature/Similarity.pm Bio/SeqFeature/SimilarityPair.pm Bio/SeqFeature/SiRNA/Oligo.pm Bio/SeqFeature/SiRNA/Pair.pm Bio/SeqFeature/SubSeq.pm Bio/SeqFeature/Tools/FeatureNamer.pm Bio/SeqFeature/Tools/IDHandler.pm Bio/SeqFeature/Tools/TypeMapper.pm Bio/SeqFeature/Tools/Unflattener.pm Bio/SeqFeature/TypedSeqFeatureI.pm Bio/SeqFeatureI.pm Bio/SeqI.pm Bio/SeqIO.pm Bio/SeqIO/abi.pm Bio/SeqIO/ace.pm Bio/SeqIO/agave.pm Bio/SeqIO/alf.pm Bio/SeqIO/asciitree.pm Bio/SeqIO/bsml.pm Bio/SeqIO/bsml_sax.pm Bio/SeqIO/chadoxml.pm Bio/SeqIO/chaos.pm Bio/SeqIO/chaosxml.pm Bio/SeqIO/ctf.pm Bio/SeqIO/embl.pm Bio/SeqIO/embldriver.pm Bio/SeqIO/entrezgene.pm Bio/SeqIO/excel.pm Bio/SeqIO/exp.pm Bio/SeqIO/fasta.pm Bio/SeqIO/fastq.pm Bio/SeqIO/flybase_chadoxml.pm Bio/SeqIO/FTHelper.pm Bio/SeqIO/game.pm Bio/SeqIO/game/featHandler.pm Bio/SeqIO/game/gameHandler.pm Bio/SeqIO/game/gameSubs.pm Bio/SeqIO/game/gameWriter.pm Bio/SeqIO/game/seqHandler.pm Bio/SeqIO/gbdriver.pm Bio/SeqIO/gbxml.pm Bio/SeqIO/gcg.pm Bio/SeqIO/genbank.pm Bio/SeqIO/Handler/GenericRichSeqHandler.pm Bio/SeqIO/interpro.pm Bio/SeqIO/kegg.pm Bio/SeqIO/largefasta.pm Bio/SeqIO/lasergene.pm Bio/SeqIO/locuslink.pm Bio/SeqIO/mbsout.pm Bio/SeqIO/metafasta.pm Bio/SeqIO/msout.pm Bio/SeqIO/MultiFile.pm Bio/SeqIO/nexml.pm Bio/SeqIO/phd.pm Bio/SeqIO/pir.pm Bio/SeqIO/pln.pm Bio/SeqIO/qual.pm Bio/SeqIO/raw.pm Bio/SeqIO/scf.pm Bio/SeqIO/seqxml.pm Bio/SeqIO/strider.pm Bio/SeqIO/swiss.pm Bio/SeqIO/swissdriver.pm Bio/SeqIO/tab.pm Bio/SeqIO/table.pm Bio/SeqIO/tigr.pm Bio/SeqIO/tigrxml.pm Bio/SeqIO/tinyseq.pm Bio/SeqIO/tinyseq/tinyseqHandler.pm Bio/SeqIO/ztr.pm Bio/SeqUtils.pm Bio/SimpleAlign.pm Bio/SimpleAnalysisI.pm Bio/Species.pm Bio/Structure/Atom.pm Bio/Structure/Chain.pm Bio/Structure/Entry.pm Bio/Structure/IO.pm Bio/Structure/IO/pdb.pm Bio/Structure/Model.pm Bio/Structure/Residue.pm Bio/Structure/SecStr/DSSP/Res.pm Bio/Structure/SecStr/STRIDE/Res.pm Bio/Structure/StructureI.pm Bio/Symbol/Alphabet.pm Bio/Symbol/AlphabetI.pm Bio/Symbol/DNAAlphabet.pm Bio/Symbol/ProteinAlphabet.pm Bio/Symbol/README.Symbol Bio/Symbol/Symbol.pm Bio/Symbol/SymbolI.pm Bio/Taxon.pm Bio/Taxonomy.pm Bio/Taxonomy/FactoryI.pm Bio/Taxonomy/Node.pm Bio/Taxonomy/Taxon.pm Bio/Taxonomy/Tree.pm Bio/Tools/AlignFactory.pm Bio/Tools/Alignment/Consed.pm Bio/Tools/Alignment/Trim.pm Bio/Tools/AmpliconSearch.pm Bio/Tools/Analysis/DNA/ESEfinder.pm Bio/Tools/Analysis/Protein/Domcut.pm Bio/Tools/Analysis/Protein/ELM.pm Bio/Tools/Analysis/Protein/GOR4.pm Bio/Tools/Analysis/Protein/HNN.pm Bio/Tools/Analysis/Protein/Mitoprot.pm Bio/Tools/Analysis/Protein/NetPhos.pm Bio/Tools/Analysis/Protein/Scansite.pm Bio/Tools/Analysis/Protein/Sopma.pm Bio/Tools/Analysis/SimpleAnalysisBase.pm Bio/Tools/AnalysisResult.pm Bio/Tools/Blat.pm Bio/Tools/CodonTable.pm Bio/Tools/Coil.pm Bio/Tools/dpAlign.pm Bio/Tools/ECnumber.pm Bio/Tools/EMBOSS/Palindrome.pm Bio/Tools/EPCR.pm Bio/Tools/Eponine.pm Bio/Tools/ERPIN.pm Bio/Tools/Est2Genome.pm Bio/Tools/ESTScan.pm Bio/Tools/Fgenesh.pm Bio/Tools/FootPrinter.pm Bio/Tools/Gel.pm Bio/Tools/Geneid.pm Bio/Tools/Genemark.pm Bio/Tools/Genewise.pm Bio/Tools/Genomewise.pm Bio/Tools/Genscan.pm Bio/Tools/GFF.pm Bio/Tools/Glimmer.pm Bio/Tools/Grail.pm Bio/Tools/GuessSeqFormat.pm Bio/Tools/HMMER/Domain.pm Bio/Tools/HMMER/Results.pm Bio/Tools/HMMER/Set.pm Bio/Tools/Hmmpfam.pm Bio/Tools/Infernal.pm Bio/Tools/ipcress.pm Bio/Tools/isPcr.pm Bio/Tools/IUPAC.pm Bio/Tools/Lucy.pm Bio/Tools/Match.pm Bio/Tools/MZEF.pm Bio/Tools/OddCodes.pm Bio/Tools/Phylo/Gerp.pm Bio/Tools/Phylo/Gumby.pm Bio/Tools/Phylo/Molphy.pm Bio/Tools/Phylo/Molphy/Result.pm Bio/Tools/Phylo/PAML.pm Bio/Tools/Phylo/PAML/Codeml.pm Bio/Tools/Phylo/PAML/ModelResult.pm Bio/Tools/Phylo/PAML/Result.pm Bio/Tools/Phylo/Phylip/ProtDist.pm Bio/Tools/pICalculator.pm Bio/Tools/Prediction/Exon.pm Bio/Tools/Prediction/Gene.pm Bio/Tools/Primer/Assessor/Base.pm Bio/Tools/Primer/AssessorI.pm Bio/Tools/Primer/Feature.pm Bio/Tools/Primer/Pair.pm Bio/Tools/Primer3.pm Bio/Tools/Prints.pm Bio/Tools/Profile.pm Bio/Tools/Promoterwise.pm Bio/Tools/PrositeScan.pm Bio/Tools/Protparam.pm Bio/Tools/Pseudowise.pm Bio/Tools/pSW.pm Bio/Tools/QRNA.pm Bio/Tools/RandomDistFunctions.pm Bio/Tools/RepeatMasker.pm Bio/Tools/RNAMotif.pm Bio/Tools/Run/GenericParameters.pm Bio/Tools/Run/hmmer3.pm Bio/Tools/Run/ParametersI.pm Bio/Tools/Run/README Bio/Tools/Run/RemoteBlast.pm Bio/Tools/Run/StandAloneBlast.pm Bio/Tools/Run/StandAloneNCBIBlast.pm Bio/Tools/Run/StandAloneWUBlast.pm Bio/Tools/Run/WrapperBase.pm Bio/Tools/Run/WrapperBase/CommandExts.pm Bio/Tools/Seg.pm Bio/Tools/SeqPattern.pm Bio/Tools/SeqPattern/Backtranslate.pm Bio/Tools/SeqStats.pm Bio/Tools/SeqWords.pm Bio/Tools/Sigcleave.pm Bio/Tools/Signalp.pm Bio/Tools/Signalp/ExtendedSignalp.pm Bio/Tools/Sim4/Exon.pm Bio/Tools/Sim4/Results.pm Bio/Tools/SiRNA.pm Bio/Tools/SiRNA/Ruleset/saigo.pm Bio/Tools/SiRNA/Ruleset/tuschl.pm Bio/Tools/Spidey/Exon.pm Bio/Tools/Spidey/Results.pm Bio/Tools/TandemRepeatsFinder.pm Bio/Tools/TargetP.pm Bio/Tools/Tmhmm.pm Bio/Tools/tRNAscanSE.pm Bio/Tree/AlleleNode.pm Bio/Tree/AnnotatableNode.pm Bio/Tree/Compatible.pm Bio/Tree/DistanceFactory.pm Bio/Tree/Draw/Cladogram.pm Bio/Tree/Node.pm Bio/Tree/NodeI.pm Bio/Tree/NodeNHX.pm Bio/Tree/RandomFactory.pm Bio/Tree/Statistics.pm Bio/Tree/Tree.pm Bio/Tree/TreeFunctionsI.pm Bio/Tree/TreeI.pm Bio/TreeIO.pm Bio/TreeIO/cluster.pm Bio/TreeIO/lintree.pm Bio/TreeIO/newick.pm Bio/TreeIO/NewickParser.pm Bio/TreeIO/nexml.pm Bio/TreeIO/nexus.pm Bio/TreeIO/nhx.pm Bio/TreeIO/pag.pm Bio/TreeIO/phyloxml.pm Bio/TreeIO/svggraph.pm Bio/TreeIO/tabtree.pm Bio/TreeIO/TreeEventBuilder.pm Bio/UpdateableSeqI.pm Bio/Variation/AAChange.pm Bio/Variation/AAReverseMutate.pm Bio/Variation/Allele.pm Bio/Variation/DNAMutation.pm Bio/Variation/IO.pm Bio/Variation/IO/flat.pm Bio/Variation/IO/xml.pm Bio/Variation/README Bio/Variation/RNAChange.pm Bio/Variation/SeqDiff.pm Bio/Variation/SNP.pm Bio/Variation/VariantI.pm Bio/WebAgent.pm BioPerl.pm BUGS Build.PL Changes DEPENDENCIES DEPRECATED doc/Deobfuscator/bin/deob_index.pl doc/Deobfuscator/bin/run-deobfuscator-update.pl doc/Deobfuscator/Build.PL doc/Deobfuscator/cgi-bin/deob_detail.cgi doc/Deobfuscator/cgi-bin/deob_flowchart.png doc/Deobfuscator/cgi-bin/deob_help.html doc/Deobfuscator/cgi-bin/deob_interface.cgi doc/Deobfuscator/Changes doc/Deobfuscator/excluded_modules.txt doc/Deobfuscator/lib/Deobfuscator.pm doc/Deobfuscator/LICENSE doc/Deobfuscator/Makefile.PL doc/Deobfuscator/MANIFEST doc/Deobfuscator/META.yml doc/Deobfuscator/README doc/Deobfuscator/t/00.load.t doc/Deobfuscator/t/pod.t doc/makedoc.PL doc/README examples/align/align_on_codons.pl examples/align/aligntutorial.pl examples/align/clustalw.pl examples/align/FastAlign.pl examples/align/simplealign.pl examples/Bio-DB-GFF/load_ucsc.pl examples/bioperl.pl examples/cluster/dbsnp.pl examples/contributed/nmrpdb_parse.pl examples/contributed/prosite2perl.pl examples/contributed/rebase2list.pl examples/db/dbfetch examples/db/est_tissue_query.pl examples/db/gb2features.pl examples/db/get_seqs.pl examples/db/getGenBank.pl examples/db/rfetch.pl examples/db/use_registry.pl examples/generate_random_seq.pl examples/liveseq/change_gene.pl examples/longorf.pl examples/make_primers.pl examples/popgen/parse_calc_stats.pl examples/quality/svgtrace.pl examples/rev_and_trans.pl examples/revcom_dir.pl examples/root/exceptions1.pl examples/root/exceptions2.pl examples/root/exceptions3.pl examples/root/exceptions4.pl examples/root/lib/TestInterface.pm examples/root/lib/TestObject.pm examples/root/README examples/searchio/blast_example.pl examples/searchio/custom_writer.pl examples/searchio/hitwriter.pl examples/searchio/hspwriter.pl examples/searchio/htmlwriter.pl examples/searchio/psiblast_features.pl examples/searchio/psiblast_iterations.pl examples/searchio/rawwriter.pl examples/searchio/resultwriter.pl examples/searchio/waba2gff.pl examples/searchio/waba2gff3.pl examples/sirna/rnai_finder.cgi examples/sirna/TAG examples/structure/structure-io.pl examples/subsequence.cgi examples/tk/gsequence.pl examples/tk/hitdisplay.pl examples/tools/extract_genes.pl examples/tools/gb_to_gff.pl examples/tools/gff2ps.pl examples/tools/parse_codeml.pl examples/tools/psw.pl examples/tools/reverse-translate.pl examples/tools/run_genscan.pl examples/tools/run_primer3.pl examples/tools/seq_pattern.pl examples/tools/standaloneblast.pl examples/tree/paup2phylip.pl ide/bioperl-mode/dist/bioperl-mode-xemacs.tar ide/bioperl-mode/dist/bioperl-mode-xemacs.tar.md5 ide/bioperl-mode/dist/bioperl-mode.tar ide/bioperl-mode/dist/bioperl-mode.tar.md5 ide/bioperl-mode/dist/Changes ide/bioperl-mode/dist/package-me ide/bioperl-mode/dist/SKIP ide/bioperl-mode/etc/images/bpmode-tool-dis.xpm ide/bioperl-mode/etc/images/bpmode-tool.xpm ide/bioperl-mode/README ide/bioperl-mode/site-lisp/bioperl-init.el ide/bioperl-mode/site-lisp/bioperl-mode.el ide/bioperl-mode/site-lisp/bioperl-skel.el ide/bioperl-mode/site-lisp/pod.el ide/bioperl.komodo INSTALL INSTALL.SKIP INSTALL.WIN LICENSE maintenance/authors.pl maintenance/big_split/file_classification.csv maintenance/big_split/rbuels_notes.txt maintenance/check_NAME.pl maintenance/check_URLs.pl maintenance/cvs2cl_by_file.pl maintenance/dependencies.pl maintenance/deprecated.pl maintenance/find_mod_deps.pl maintenance/module_usage.pl maintenance/modules.pl maintenance/ncbi_blast_switches.pl maintenance/perltidy.conf maintenance/pod.pl maintenance/README maintenance/symlink_script.pl maintenance/version.pl MANIFEST This list of files models/biblio.dia models/bio_liveseq_variation.dia models/bio_map.dia models/bio_restriction.dia models/bioperl.dia models/coordinatemapper.dia models/map_proposal.txt models/maps_and_markers.dia models/popgen.dia models/population_proposal.txt models/README README README.md scripts/Bio-DB-GFF/bp_bulk_load_gff.pl scripts/Bio-DB-GFF/bp_fast_load_gff.pl scripts/Bio-DB-GFF/bp_genbank2gff.pl scripts/Bio-DB-GFF/bp_genbank2gff3.pl scripts/Bio-DB-GFF/bp_generate_histogram.pl scripts/Bio-DB-GFF/bp_load_gff.pl scripts/Bio-DB-GFF/bp_meta_gff.pl scripts/Bio-DB-GFF/bp_process_gadfly.pl scripts/Bio-DB-GFF/bp_process_sgd.pl scripts/Bio-DB-GFF/bp_process_wormbase.pl scripts/Bio-DB-GFF/README scripts/Bio-DB-SeqFeature-Store/bp_seqfeature_delete.pl scripts/Bio-DB-SeqFeature-Store/bp_seqfeature_gff3.pl scripts/Bio-DB-SeqFeature-Store/bp_seqfeature_load.pl scripts/das/bp_das_server.pl scripts/das/README scripts/das/TAG scripts/DB-HIV/bp_hivq.pl scripts/DB/bp_biofetch_genbank_proxy.pl scripts/DB/bp_bioflat_index.pl scripts/DB/bp_biogetseq.pl scripts/DB/bp_flanks.pl scripts/DB/TAG scripts/index/bp_fetch.pl scripts/index/bp_index.pl scripts/index/bp_seqret.pl scripts/index/TAG scripts/popgen/bp_composite_LD.pl scripts/popgen/bp_heterogeneity_test.pl scripts/README scripts/searchio/bp_fastam9_to_table.pl scripts/searchio/bp_filter_search.pl scripts/searchio/bp_hmmer_to_table.pl scripts/searchio/bp_parse_hmmsearch.pl scripts/searchio/bp_search2table.pl scripts/searchio/README scripts/searchio/TAG scripts/seq/bp_extract_feature_seq.pl scripts/seq/bp_make_mrna_protein.pl scripts/seq/bp_seqconvert.pl scripts/seq/bp_seqcut.pl scripts/seq/bp_seqpart.pl scripts/seq/bp_seqretsplit.pl scripts/seq/bp_split_seq.pl scripts/seq/bp_translate_seq.pl scripts/seq/bp_unflatten_seq.pl scripts/seq/TAG scripts/seqstats/bp_aacomp.pl scripts/seqstats/bp_chaos_plot.pl scripts/seqstats/bp_gccalc.pl scripts/seqstats/bp_oligo_count.pl scripts/seqstats/TAG scripts/taxa/bp_classify_hits_kingdom.pl scripts/taxa/bp_local_taxonomydb_query.pl scripts/taxa/bp_query_entrez_taxa.pl scripts/taxa/bp_taxid4species.pl scripts/taxa/bp_taxonomy2tree.pl scripts/taxa/TAG scripts/tree/bp_blast2tree.pl scripts/tree/bp_nexus2nh.pl scripts/tree/bp_tree2pag.pl scripts/tree/TAG scripts/utilities/bp_dbsplit.pl scripts/utilities/bp_download_query_genbank.pl scripts/utilities/bp_mask_by_search.pl scripts/utilities/bp_mrtrans.pl scripts/utilities/bp_mutate.pl scripts/utilities/bp_netinstall.pl scripts/utilities/bp_nrdb.pl scripts/utilities/bp_pairwise_kaks.pl scripts/utilities/bp_remote_blast.pl scripts/utilities/bp_revtrans-motif.pl scripts/utilities/bp_search2alnblocks.pl scripts/utilities/bp_search2BSML.pl scripts/utilities/bp_search2gff.pl scripts/utilities/bp_search2tribe.pl scripts/utilities/bp_seq_length.pl scripts/utilities/bp_sreformat.pl scripts/utilities/README scripts/utilities/TAG t/Align/AlignStats.t t/Align/AlignUtil.t t/Align/Graphics.t t/Align/SimpleAlign.t t/Align/TreeBuild.t t/Align/Utilities.t t/AlignIO/AlignIO.t t/AlignIO/arp.t t/AlignIO/bl2seq.t t/AlignIO/clustalw.t t/AlignIO/emboss.t t/AlignIO/fasta.t t/AlignIO/largemultifasta.t t/AlignIO/maf.t t/AlignIO/mase.t t/AlignIO/mega.t t/AlignIO/meme.t t/AlignIO/metafasta.t t/AlignIO/msf.t t/AlignIO/nexml.t t/AlignIO/nexus.t t/AlignIO/pfam.t t/AlignIO/phylip.t t/AlignIO/po.t t/AlignIO/prodom.t t/AlignIO/psi.t t/AlignIO/selex.t t/AlignIO/stockholm.t t/AlignIO/xmfa.t t/Alphabet.t t/Annotation/Annotation.t t/Annotation/AnnotationAdaptor.t t/Assembly/ContigSpectrum.t t/Assembly/core.t t/Assembly/IO/bowtie.t t/Assembly/IO/sam.t t/Cluster/UniGene.t t/ClusterIO/ClusterIO.t t/ClusterIO/SequenceFamily.t t/ClusterIO/unigene.t t/Coordinate/CoordinateBoundaryTest.t t/Coordinate/CoordinateGraph.t t/Coordinate/CoordinateMapper.t t/Coordinate/GeneCoordinateMapper.t t/data/01_basic.xml t/data/02_dogfish_dict_cdao_lsid_taxrefs.xml t/data/02_dogfish_no_taxrefs.xml t/data/02_dogfish_rdfa_2_cdao_lsid_taxrefs.xml t/data/02_dogfish_rdfa_tdwg_lsid_taxrefs.xml t/data/02_mackerel_dict_cdao_lsid_taxrefs.xml t/data/02_mackerel_no_taxrefs.xml t/data/02_mackerel_rdfa_2_cdao_lsid_taxrefs.xml t/data/02_mackerel_rdfa_tdwg_lsid_taxrefs.xml t/data/03_bootstraps.xml t/data/03_bootstraps_in_tag.xml t/data/04_labeled_ancestors.xml t/data/05_ancestral_states.xml t/data/13-pilE-F.scf t/data/1A11.pdb t/data/1A3I.pdb t/data/1BPT.pdb t/data/1ZZ19XR301R-Alignment.tblastn t/data/2008.blasttable t/data/27-contig_Newbler.ace t/data/503384.MEGABLAST.0 t/data/503384.MEGABLAST.2 t/data/5X_1895.FASTXY t/data/8HVP.pdb t/data/a_thaliana.blastn t/data/AAC12660.fa t/data/aaml.mlc t/data/aaml_pairwise.mlc t/data/AB077698.gb t/data/acefile.ace.1 t/data/acefile.singlets t/data/adh.mb_tree.nexus t/data/AE003528_ecoli.bls t/data/AE003644_Adh-genomic.gb t/data/AF032047.gbk t/data/AF165282.gb t/data/AF305198.gb t/data/AHCYL1.kegg t/data/alleles.fas t/data/alnfile.fasta t/data/amino.fa t/data/AnnIX-v003.gbk t/data/ar.embl t/data/assembly_with_singlets.ace t/data/ATF14F8.gbk t/data/atp1.matrix t/data/ay007676.gb t/data/AY095303S1.gbk t/data/ay116458.gb t/data/ay149291.gb t/data/AY763288.gb t/data/BAB68554.gb t/data/bad_dbfa/bug3172.fa t/data/bad_dbfa/shotdb.fa t/data/badfasta.fa t/data/barns-combined.nex t/data/baseml.pairwise t/data/baseml.usertree t/data/basic-bush.nex t/data/basic-ladder.nex t/data/BC000007.gbk t/data/BEL16-LTR_AG.embl t/data/biodbgff/test.gff t/data/biodbgff/test.gff3 t/data/biofpc.cor t/data/biofpc.fpc t/data/biorecipe.nhx t/data/Bird_Ovomucoids.nex t/data/BK000016-tpa.gbk t/data/bl2seq.blastn t/data/bl2seq.blastn.rev t/data/bl2seq.blastx.out t/data/bl2seq.bug940.out t/data/bl2seq.out t/data/bl2seq.tblastn.out t/data/bl2seq.tblastx.out t/data/blast.report t/data/blast_no_hit_desc.txt t/data/blast_plus.blastp t/data/blastp2215.blast t/data/blat.psLayout3 t/data/BLOSUM50 t/data/blosum62.bla t/data/BN000066-tpa.embl t/data/bootstrap.tre t/data/BOSS_DROME.FASTP_v35_04 t/data/branchSite.mlc t/data/brassica_ATH.WUBLASTN t/data/bug1986.blast2 t/data/bug1986.blastp t/data/bug2120.phd t/data/bug2246.blast t/data/bug2391.megablast t/data/bug2399.tblastn t/data/bug2453.maf t/data/bug2473.fasta t/data/bug2862.pmr t/data/bug2869.tree t/data/bug2901.fa t/data/bug2937.fasta t/data/bug2942.blastx t/data/bug2982.embl t/data/bug2982.gb t/data/bug3021.gmap t/data/bug3086.embl t/data/bug3331.mlc t/data/c200-vs-yeast.BLASTN t/data/c200-vs-yeast.BLASTN.m8 t/data/calm.swiss t/data/catalase-webblast.BLASTP t/data/cds-266.fas t/data/cds_sample.embl t/data/CG11099.fasaln t/data/CG2865.fasaln t/data/chad100.scf t/data/char-interleave.nex t/data/char-matrix-spaces.nex t/data/characters+trees.nexml.xml t/data/characters.nexml.old.xml t/data/codeml.mlc t/data/codeml315.mlc t/data/codeml4.mlc t/data/codeml43.mlc t/data/codeml43_nssites.mlc t/data/codeml45.mlc t/data/codeml45b.mlc t/data/codeml_lysozyme/2NG.dN t/data/codeml_lysozyme/2NG.dS t/data/codeml_lysozyme/2NG.tt t/data/codeml_lysozyme/4fold.nuc t/data/codeml_lysozyme/lnf t/data/codeml_lysozyme/lysozymeSmall.ctl t/data/codeml_lysozyme/lysozymeSmall.trees t/data/codeml_lysozyme/lysozymeSmall.txt t/data/codeml_lysozyme/mlc t/data/codeml_lysozyme/rst t/data/codeml_lysozyme/rst1 t/data/codeml_lysozyme/rub t/data/codeml_nan.mlc t/data/codeml_nssites.mlc t/data/compLD_missingtest.prettybase t/data/compLD_test.prettybase t/data/component.ontology.test t/data/component.ontology.test2 t/data/consed_project/edit_dir/test_project.contigs t/data/consed_project/edit_dir/test_project.fasta t/data/consed_project/edit_dir/test_project.fasta.log t/data/consed_project/edit_dir/test_project.fasta.screen t/data/consed_project/edit_dir/test_project.fasta.screen.ace.1 t/data/consed_project/edit_dir/test_project.fasta.screen.ace.2 t/data/consed_project/edit_dir/test_project.fasta.screen.contigs t/data/consed_project/edit_dir/test_project.fasta.screen.contigs.qual t/data/consed_project/edit_dir/test_project.fasta.screen.log t/data/consed_project/edit_dir/test_project.fasta.screen.problems t/data/consed_project/edit_dir/test_project.fasta.screen.problems.qual t/data/consed_project/edit_dir/test_project.fasta.screen.qual t/data/consed_project/edit_dir/test_project.fasta.screen.singlets t/data/consed_project/edit_dir/test_project.fasta.screen.view t/data/consed_project/edit_dir/test_project.newtags t/data/consed_project/edit_dir/test_project.phrap.out t/data/consed_project/edit_dir/test_project.screen.out t/data/consed_project/edit_dir/test_project_to_alu.cross t/data/consed_project/edit_dir/test_projectNewChromats.fof t/data/consed_project/phd_dir/ML4922R.phd.1 t/data/consed_project/phd_dir/ML4924F.phd.1 t/data/consed_project/phd_dir/ML4924R.phd.1 t/data/consed_project/phd_dir/ML4947F.phd.1 t/data/contig-by-hand.wublastp t/data/contigspectrumtest.tigr t/data/crab.dat.cn t/data/crab.nj t/data/crab.njb t/data/crypto.sim4-0 t/data/crypto.sim4-3 t/data/crypto.sim4-4 t/data/ctgdemo.fpc t/data/cys1_dicdi.water t/data/cysprot.fa t/data/cysprot.msf t/data/cysprot.needle t/data/cysprot.tblastn t/data/cysprot.water t/data/cysprot1.fa t/data/cysprot1.FASTA t/data/cysprot1a.fa t/data/cysprot1a.msf t/data/cysprot1b.fa t/data/cysprot1b.hmmsearch t/data/cysprot1b.msf t/data/cysprot1b.newick t/data/cysprot_vs_gadfly.FASTA t/data/D10483.gbk t/data/D12555.gbk t/data/dbfa/1.fa t/data/dbfa/2.fa t/data/dbfa/3.fa t/data/dbfa/4.fa t/data/dbfa/5.fa t/data/dbfa/6.fa t/data/dbfa/7.fa t/data/dbfa/mixed_alphabet.fasta t/data/dbqual/1.qual t/data/dbqual/2.qual t/data/dbqual/3.qual t/data/dcr1_sp.WUBLASTP t/data/dmel_2Lchunk.gb t/data/dna1.fa t/data/dna2.fa t/data/dnaE-bsub-prot.fa t/data/dnaE-bsub.fa t/data/dnaEbsub_ecoli.wublastx t/data/dnaEbsub_ecoli.wutblastn t/data/dnaEbsub_ecoli.wutblastx t/data/DQ018368.gb t/data/dq519393.gb t/data/ECAPAH02.embl t/data/echofilter.wublastn t/data/ecoli-trna-qrna.out t/data/ecoli_domains.rps.xml t/data/ecoli_domains.rpsblast t/data/ecolitst.bls t/data/ecolitst.fa t/data/ecolitst.noseqs.wublastp t/data/ecolitst.wublastp t/data/EG352462.gbxml t/data/empty.bl2seq t/data/ENr111.mfa.example.elems t/data/entrezgene.dat t/data/ex1.nucl.nhx t/data/example.hap t/data/example.phase t/data/example.vcf t/data/exonerate.output.dontwork t/data/exonerate.output.negativescore.works t/data/exonerate.output.works t/data/exonerate.whitespace_before_query.works t/data/expected.blast.out t/data/exsignalp.out t/data/factor7.embl t/data/Fang_2003.xml t/data/fastq/bug2335.fastq t/data/fastq/error_diff_ids.fastq t/data/fastq/error_double_qual.fastq t/data/fastq/error_double_seq.fastq t/data/fastq/error_long_qual.fastq t/data/fastq/error_no_qual.fastq t/data/fastq/error_qual_del.fastq t/data/fastq/error_qual_escape.fastq t/data/fastq/error_qual_null.fastq t/data/fastq/error_qual_space.fastq t/data/fastq/error_qual_tab.fastq t/data/fastq/error_qual_unit_sep.fastq t/data/fastq/error_qual_vtab.fastq t/data/fastq/error_short_qual.fastq t/data/fastq/error_spaces.fastq t/data/fastq/error_tabs.fastq t/data/fastq/error_trunc_at_plus.fastq t/data/fastq/error_trunc_at_qual.fastq t/data/fastq/error_trunc_at_seq.fastq t/data/fastq/error_trunc_in_plus.fastq t/data/fastq/error_trunc_in_qual.fastq t/data/fastq/error_trunc_in_seq.fastq t/data/fastq/error_trunc_in_title.fastq t/data/fastq/evil_wrapping.fastq t/data/fastq/example.fasta t/data/fastq/example.fastq t/data/fastq/example.qual t/data/fastq/illumina_faked.fastq t/data/fastq/sanger_93.fastq t/data/fastq/sanger_faked.fastq t/data/fastq/solexa_example.fastq t/data/fastq/solexa_faked.fastq t/data/fastq/test1_sanger.fastq t/data/fastq/test2_solexa.fastq t/data/fastq/test3_illumina.fastq t/data/fastq/tricky.fastq t/data/fastq/wrapping_issues.fastq t/data/fastq/zero_qual.fastq t/data/fgenesh.out t/data/footprinter.out t/data/forward_primer.fa t/data/forward_reverse_primers.fa t/data/frac_problems.blast t/data/frac_problems2.blast t/data/frac_problems3.blast t/data/geneid_1.0.out t/data/genemark-fragment.out t/data/genemark.out t/data/genewise.out t/data/genewise_output.paracel_btk t/data/genomewise.out t/data/genomic-seq.epcr t/data/genomic-seq.fasta t/data/genomic-seq.genscan t/data/genomic-seq.mzef t/data/Genscan.FastA t/data/gf-s71.needle t/data/Glimmer2.out t/data/glimmer3-fragment.detail t/data/glimmer3-fragment.predict t/data/Glimmer3.detail t/data/Glimmer3.predict t/data/GlimmerHMM.out t/data/GlimmerM.out t/data/gmap_f9-multiple_results.txt t/data/gmap_f9-reverse-strand.txt t/data/gmap_f9.txt t/data/GO.defs.test t/data/GO.defs.test2 t/data/headerless.psl t/data/hemoglobinA.meg t/data/hg16_chroms.gff t/data/hmmpfam.out t/data/hmmpfam_cs.out t/data/hmmpfam_fake.out t/data/hmmpfam_HSPdashline.txt t/data/hmmpfam_multiresult.out t/data/hmmscan.out t/data/hmmscan_multi_domain.out t/data/hmmscan_sec_struct.out t/data/hmmsearch.out t/data/hmmsearch3.out t/data/hs_est.est2genome t/data/hs_fugu.newick t/data/hs_owlmonkey.aln t/data/hs_owlmonkey.fas t/data/hs_owlmonkey.fasta t/data/hsinsulin.blastcl3.blastn t/data/HUMBETGLOA.fa t/data/HUMBETGLOA.FASTA t/data/HUMBETGLOA.gff t/data/HUMBETGLOA.grail t/data/HUMBETGLOA.grailexp t/data/HUMBETGLOA.mzef t/data/HUMBETGLOA.tblastx t/data/humor.maf t/data/humts1.pal t/data/hybrid2.gff3 t/data/in.fasta t/data/insulin.water t/data/interpro.xml t/data/interpro_ebi.xml t/data/interpro_relationship.xml t/data/interpro_sample.xml t/data/interpro_short.xml t/data/intrablock-comment.nex t/data/Kingdoms_DNA.nex t/data/L77119.hmmer t/data/little.largemultifasta t/data/LittleChrY.dbsnp.xml t/data/LOAD_Ccd1.dnd t/data/long-names.nex t/data/longnames.aln t/data/longnames.dnd t/data/lucy.info t/data/lucy.qual t/data/lucy.seq t/data/lucy.stderr t/data/lysozyme6.protml t/data/lysozyme6.simple.protml t/data/M0.mlc t/data/M12730.gb t/data/map_hem/HEM1-HEM12.fa t/data/map_hem/HEM1-HEM12.fa.revcom t/data/map_hem/HEM1-HEM12.meme.txt t/data/map_hem/HEM1-HEM13.fa t/data/map_hem/HEM1-HEM13.meme.txt t/data/map_hem/HEM1-HEM14.fa t/data/map_hem/HEM1-HEM14.meme.txt t/data/map_hem/HEM1-HEM15.fa t/data/map_hem/HEM1-HEM15.meme.txt t/data/map_hem/HEM1-HEM2.fa t/data/map_hem/HEM1-HEM2.fa.revcom t/data/map_hem/HEM1-HEM2.meme.txt t/data/map_hem/HEM1-HEM3.fa t/data/map_hem/HEM1-HEM3.meme.txt t/data/map_hem/HEM1-HEM4.fa t/data/map_hem/HEM1-HEM4.meme.txt t/data/map_hem/HEM1.ups.fa_ t/data/map_hem/HEM1.ups.fa_.revcom t/data/map_hem/HEM12-HEM13.fa t/data/map_hem/HEM12-HEM13.meme.txt t/data/map_hem/HEM12-HEM14.fa t/data/map_hem/HEM12-HEM14.meme.txt t/data/map_hem/HEM12-HEM15.fa t/data/map_hem/HEM12-HEM15.meme.txt t/data/map_hem/HEM12.ups.fa_ t/data/map_hem/HEM12.ups.fa_.revcom t/data/map_hem/HEM13-HEM14.fa t/data/map_hem/HEM13-HEM14.meme.txt t/data/map_hem/HEM13-HEM15.fa t/data/map_hem/HEM13-HEM15.meme.txt t/data/map_hem/HEM13.ups.fa_ t/data/map_hem/HEM13.ups.fa_.revcom t/data/map_hem/HEM14-HEM15.fa t/data/map_hem/HEM14-HEM15.meme.txt t/data/map_hem/HEM14.ups.fa_ t/data/map_hem/HEM14.ups.fa_.revcom t/data/map_hem/HEM15.ups.fa_ t/data/map_hem/HEM15.ups.fa_.revcom t/data/map_hem/HEM2-HEM12.fa t/data/map_hem/HEM2-HEM12.meme.txt t/data/map_hem/HEM2-HEM13.fa t/data/map_hem/HEM2-HEM13.meme.txt t/data/map_hem/HEM2-HEM14.fa t/data/map_hem/HEM2-HEM14.meme.txt t/data/map_hem/HEM2-HEM15.fa t/data/map_hem/HEM2-HEM15.meme.txt t/data/map_hem/HEM2-HEM3.fa t/data/map_hem/HEM2-HEM3.meme.txt t/data/map_hem/HEM2-HEM4.fa t/data/map_hem/HEM2-HEM4.meme.txt t/data/map_hem/HEM2.ups.fa_ t/data/map_hem/HEM2.ups.fa_.revcom t/data/map_hem/HEM3-HEM12.fa t/data/map_hem/HEM3-HEM12.meme.txt t/data/map_hem/HEM3-HEM13.fa t/data/map_hem/HEM3-HEM13.meme.txt t/data/map_hem/HEM3-HEM14.fa t/data/map_hem/HEM3-HEM14.meme.txt t/data/map_hem/HEM3-HEM15.fa t/data/map_hem/HEM3-HEM15.meme.txt t/data/map_hem/HEM3-HEM4.fa t/data/map_hem/HEM3-HEM4.meme.txt t/data/map_hem/HEM3.ups.fa_ t/data/map_hem/HEM3.ups.fa_.revcom t/data/map_hem/HEM4-HEM12.fa t/data/map_hem/HEM4-HEM12.meme.txt t/data/map_hem/HEM4-HEM13.fa t/data/map_hem/HEM4-HEM13.meme.txt t/data/map_hem/HEM4-HEM14.fa t/data/map_hem/HEM4-HEM14.meme.txt t/data/map_hem/HEM4-HEM15.fa t/data/map_hem/HEM4-HEM15.meme.txt t/data/map_hem/HEM4.ups.fa_ t/data/map_hem/HEM4.ups.fa_.revcom t/data/map_hem/yeast.nc.1.freq t/data/mapmaker.out t/data/mapmaker.txt t/data/mast.dat t/data/masta.dat t/data/match.output t/data/mbsout/mbsout_infile1 t/data/mbsout/mbsout_infile2 t/data/mbsout/mbsout_infile3 t/data/Mcjanrna_rdbII.gbk t/data/megablast_output.paracel_btk t/data/meme.dat t/data/mini-AE001405.gb t/data/mini-align.aln t/data/mixedmast.dat t/data/MmCT t/data/mpath.ontology.test t/data/MSGEFTUA.gb t/data/msout/bad_msout_infile1 t/data/msout/bad_msout_infile2 t/data/msout/msout_infile1 t/data/msout/msout_infile2 t/data/msout/msout_infile3 t/data/msout/msout_infile4 t/data/multi.blast.m8 t/data/multi.blast.m9 t/data/multi.phd t/data/multi_1.fa t/data/multi_2.fa t/data/multi_blast.bls t/data/multifa.seq t/data/multifa.seq.qual t/data/multiline-intrablock-comment.nex t/data/multiresult_blastn+.bls t/data/multiseq.bls t/data/multiseq_tags.phd t/data/mus.bls.xml t/data/mutations.dat t/data/mutations.old.dat t/data/mutations.old.xml t/data/mutations.xml t/data/myco_sites.gff t/data/NC_000007-ribosomal-slippage.gb t/data/NC_001284.gbk t/data/NC_002058_multDBLINK_bug3375.gb t/data/NC_006346.gb t/data/NC_006511-short.gbk t/data/NC_008536.gb t/data/nei_gojobori_test.aln t/data/neighbor.dist t/data/new_blastn.txt t/data/newblast.xml t/data/nexml/characters.nexml.8.xml t/data/nexml/characters.nexml.xml t/data/nexml/trees.nexml.8.xml t/data/nexml/trees.nexml.xml t/data/nhmmer-3.1.out t/data/nhx-bacteria.nhx t/data/NM_002254.gb t/data/no-genes.genscan t/data/no_cds_example.gb t/data/no_FH.embl t/data/no_hsps.blastp t/data/no_semicolon.newick t/data/noninterleaved.phy t/data/NT_021877.gbk t/data/nucmatrix.txt t/data/O_sat.wgs t/data/omim_genemap_test t/data/omim_genemap_test_nolinebreak t/data/omim_text_test t/data/P33897 t/data/P35527.gb t/data/P39765.gb t/data/PAM250 t/data/pep-266.aln t/data/pfam_tests.stk t/data/pfamOutput-bug3376.out t/data/phi.out t/data/phipsi.out t/data/phylipdist-36.out t/data/phylipdist.out t/data/phyloxml_examples.xml t/data/pictogram.fa t/data/plague_yeast.bls.xml t/data/polymorphism.dat t/data/polymorphism.old.xml t/data/polymorphism.xml t/data/popgen_saureus.dat t/data/popgen_saureus.multidat t/data/popstats.prettybase t/data/pre_rel9.swiss t/data/Primate_mtDNA.nex t/data/primedseq.fa t/data/primer3_infile.txt t/data/primer3_outfile.txt t/data/primer3_output.txt t/data/prints.out t/data/promoterwise.out t/data/protpars.phy t/data/protpars_longid.phy t/data/pseudowise.out t/data/psi_xml.dat t/data/psiblast.xml t/data/psiblastreport.out t/data/purine_v081.infernal t/data/puzzle.tre t/data/PX1CG.gb t/data/Q8GBD3.swiss t/data/qrna-relloc.out t/data/qualfile.qual t/data/quoted-strings1.nex t/data/quoted-strings2.nex t/data/Rab1.chaos-xml t/data/radical-whitespace.nex t/data/radical-whitespace_02.nex t/data/rebase.itype2 t/data/rebase.withrefm t/data/reference_ace.ace t/data/registry/bdb/seqdatabase.ini t/data/registry/flat/seqdatabase.ini t/data/regulation_test.obo t/data/rel9.swiss t/data/repeatmasker.fa.out t/data/revcomp_mrna.gb t/data/rfam_tests.stk t/data/ribosome-slippage.gb t/data/roa1.dat t/data/roa1.gbxml t/data/roa1.genbank t/data/roa1.swiss t/data/roa1_v2.dat t/data/rpsblast.bls t/data/rpsblast_no_hits.bls t/data/sample_dataset.tigr t/data/sbay_c127.fas t/data/sbay_c545-yeast.BLASTZ.PSL t/data/seg.out t/data/semicolon.newick t/data/seqdatabase.ini t/data/seqfeaturedb/test.gff3 t/data/seqfile.pir t/data/seqs.fas t/data/sequencefamily.dat t/data/seqxml.xml t/data/short.blx t/data/signalp.hmm.short t/data/signalp.hmm.summary t/data/signalp.negative.out t/data/signalp.nn.short t/data/signalp.nn.summary t/data/signalp.positive.out t/data/signalp.short t/data/signalp.summary t/data/sim4.for.for t/data/sim4.for.rev t/data/sim4.rev t/data/singleNSsite.mlc t/data/singlescore.gbk t/data/singlet_w_CT.ace t/data/so.obo t/data/sofa.ontology t/data/sp_subset.obo t/data/spaced_fasta.fa t/data/spaces.nex t/data/SPAN_Family4nl.nex t/data/SPAN_Family7n.nex t/data/SPAN_Family8a.nex t/data/sparsealn.needle t/data/spidey.noalignment t/data/spidey.test1 t/data/sprintf.rnamotif t/data/ssp160.embl.1 t/data/sv40_small.xml t/data/swiss.dat t/data/swisspfam.data t/data/SwissProt.dat t/data/T7.aln t/data/tab1part.mif t/data/tab2part.mif t/data/tab3part.mif t/data/tandem_repeats_finder.dat t/data/tandem_repeats_finder.noresults t/data/tandem_repeats_finder_no_desc.dat t/data/targetp.out t/data/taxdump/names.dmp t/data/taxdump/nodes.dmp t/data/taxonomy/greengenes_taxonomy_16S_candiv_gg_2011_1.txt t/data/taxonomy/silva_SSURef_108_tax_silva_trunc.fasta t/data/tblastn.out 't/data/test 2.txt' t/data/test-3.0-1.meme t/data/test-3.0-2.meme t/data/test-4.9.meme t/data/test.abi t/data/test.ace t/data/test.bam t/data/test.bowtie t/data/test.cns.fastq t/data/test.ctf t/data/test.embl t/data/test.embl2sq t/data/test.exp t/data/test.fasta t/data/test.fastq t/data/test.game t/data/test.gcg t/data/test.gcgblast t/data/test.gcgfasta t/data/test.genbank t/data/test.genbank.noseq t/data/test.infernal t/data/test.interpro t/data/test.interpro-go.xml t/data/test.lasergene t/data/test.locuslink t/data/test.maq t/data/test.mase t/data/test.metafasta t/data/test.nh t/data/test.nhx t/data/test.pfam t/data/test.phd t/data/test.pir t/data/test.pln t/data/test.raw t/data/test.ref.fas t/data/test.swiss t/data/test.tab t/data/test.tigrxml t/data/test.tseq t/data/test.tsv t/data/test.txt t/data/test.waba t/data/test.xls t/data/test.ztr t/data/test1.blasttab3 t/data/test1.wublastp t/data/test2.infernal t/data/test2.raw t/data/test_badlf.gcg t/data/test_clear_range.fastq t/data/test_data.axt t/data/test_singlets.cns.fastq t/data/test_singlets.maq t/data/testaln.aln t/data/testaln.arp t/data/testaln.fasta t/data/testaln.fastq t/data/testaln.list t/data/testaln.mase t/data/testaln.metafasta t/data/testaln.msf t/data/testaln.nexus t/data/testaln.pfam t/data/testaln.phylip t/data/testaln.po t/data/testaln.prodom t/data/testaln.psi t/data/testaln.selex t/data/testaln.stockholm t/data/testaln.xmfa t/data/testaln2.arp t/data/testaln2.fasta t/data/testdat.exonerate t/data/testdata.crossmatch t/data/testdbaccnums.out t/data/testfile.erpin t/data/testfuzzy.genbank t/data/tiny.stk t/data/tmhmm.out t/data/tmp.fst t/data/tol-2010-02-18.nhx t/data/traits.tab t/data/traittree.nexus t/data/transfac.dat t/data/transfac_pro/factor.dat t/data/transfac_pro/fragment.dat t/data/transfac_pro/gene.dat t/data/transfac_pro/matrix.dat t/data/transfac_pro/readme.txt t/data/transfac_pro/reference.dat t/data/transfac_pro/site.dat t/data/tree_nonewline.nexus t/data/Treebase-chlamy-dna.nex t/data/trees.nexml.old.xml t/data/tricky.wublast t/data/trna.strict.rnamotif t/data/U58726.gb t/data/U71225.gb t/data/U71225.gb.unix t/data/U71225.gb.win t/data/U83300.bsml t/data/UnaSmithHIV-both.nex t/data/unigene.data t/data/urease.tre.nexus t/data/version2.scf t/data/version3.scf t/data/wellcome_tol.nhx t/data/withrefm.906 t/data/worm_fam_2785.cdna t/data/X98338_Adh-mRNA.gb t/data/yeast.tRNAscanSE t/data/yn00.mlc t/data/yn00_45.mlc t/data/YP_007988852.gp t/data/ZABJ4EA7014.CH878695.1.blast.txt t/Draw/Pictogram.t t/lib/Error.pm t/LiveSeq/Chain.t t/LiveSeq/LiveSeq.t t/LiveSeq/Mutation.t t/LiveSeq/Mutator.t t/LocalDB/BioDBGFF.t t/LocalDB/Fasta.t t/LocalDB/Flat.t t/LocalDB/Index/Blast.t t/LocalDB/Index/BlastTable.t t/LocalDB/Index/Index.t t/LocalDB/Qual.t t/LocalDB/Registry.t t/LocalDB/SeqFeature.t t/LocalDB/Taxonomy/greengenes.t t/LocalDB/Taxonomy/silva.t t/LocalDB/transfac_pro.t t/Map/Cyto.t t/Map/Linkage.t t/Map/Map.t t/Map/MapIO.t t/Map/MicrosatelliteMarker.t t/Map/Physical.t t/Matrix/InstanceSite.t t/Matrix/IO/masta.t t/Matrix/IO/psm.t t/Matrix/Matrix.t t/Matrix/ProtMatrix.t t/Matrix/ProtPsm.t t/Matrix/SiteMatrix.t t/nexml.t t/Ontology/GOterm.t t/Ontology/GraphAdaptor.t t/Ontology/IO/go.t t/Ontology/IO/interpro.t t/Ontology/IO/obo.t t/Ontology/Ontology.t t/Ontology/OntologyEngine.t t/Ontology/OntologyStore.t t/Ontology/Relationship.t t/Ontology/RelationshipType.t t/Ontology/Term.t t/Perl.t t/Phenotype/Correlate.t t/Phenotype/Measure.t t/Phenotype/MeSH.t t/Phenotype/MiniMIMentry.t t/Phenotype/OMIMentry.t t/Phenotype/OMIMentryAllelicVariant.t t/Phenotype/OMIMparser.t t/Phenotype/Phenotype.t t/PodSyntax.t t/PopGen/Coalescent.t t/PopGen/HtSNP.t t/PopGen/MK.t t/PopGen/PopGen.t t/PopGen/PopGenSims.t t/PopGen/TagHaplotype.t t/RemoteDB/BioFetch.t t/RemoteDB/CUTG.t t/RemoteDB/EMBL.t t/RemoteDB/EntrezGene.t t/RemoteDB/GenBank.t t/RemoteDB/GenPept.t t/RemoteDB/HIV/HIV.t t/RemoteDB/HIV/HIVAnnotProcessor.t t/RemoteDB/HIV/HIVQuery.t t/RemoteDB/HIV/HIVQueryHelper.t t/RemoteDB/MeSH.t t/RemoteDB/Query/GenBank.t t/RemoteDB/RefSeq.t t/RemoteDB/SeqHound.t t/RemoteDB/SeqRead_fail.t t/RemoteDB/SeqVersion.t t/RemoteDB/SwissProt.t t/RemoteDB/Taxonomy.t t/Restriction/Analysis-refac.t t/Restriction/Analysis.t t/Restriction/Gel.t t/Restriction/IO.t t/Root/Exception.t t/Root/HTTPget.t t/Root/RootI.t t/Root/RootIO.t t/Root/Storable.t t/Root/Tempfile.t t/Root/Utilities.t t/SearchDist.t t/SearchIO/axt.t t/SearchIO/blast.t t/SearchIO/blast_pull.t t/SearchIO/blasttable.t t/SearchIO/blastxml.t t/SearchIO/CigarString.t t/SearchIO/cross_match.t t/SearchIO/erpin.t t/SearchIO/exonerate.t t/SearchIO/fasta.t t/SearchIO/gmap_f9.t t/SearchIO/hmmer.t t/SearchIO/hmmer_pull.t t/SearchIO/infernal.t t/SearchIO/megablast.t t/SearchIO/psl.t t/SearchIO/rnamotif.t t/SearchIO/SearchIO.t t/SearchIO/sim4.t t/SearchIO/SimilarityPair.t t/SearchIO/Tiling.t t/SearchIO/waba.t t/SearchIO/wise.t t/SearchIO/Writer/GbrowseGFF.t t/SearchIO/Writer/HitTableWriter.t t/SearchIO/Writer/HSPTableWriter.t t/SearchIO/Writer/HTMLWriter.t t/SearchIO/Writer/TextWriter.t t/Seq/DBLink.t t/Seq/EncodedSeq.t t/Seq/LargeLocatableSeq.t t/Seq/LargePSeq.t t/Seq/LocatableSeq.t t/Seq/MetaSeq.t t/Seq/PrimaryQual.t t/Seq/PrimarySeq.t t/Seq/PrimedSeq.t t/Seq/Quality.t t/Seq/Seq.t t/Seq/SimulatedRead.t t/Seq/WithQuality.t t/SeqEvolution.t t/SeqFeature/Amplicon.t t/SeqFeature/Clone.t t/SeqFeature/Collection.t t/SeqFeature/Computation.t t/SeqFeature/FeaturePair.t t/SeqFeature/Gene.t t/SeqFeature/Generic.t t/SeqFeature/Location.t t/SeqFeature/LocationFactory.t t/SeqFeature/Primer.t t/SeqFeature/Range.t t/SeqFeature/RangeI.t t/SeqFeature/SeqAnalysisParser.t t/SeqFeature/SubSeq.t t/SeqFeature/Unflattener.t t/SeqFeature/Unflattener2.t t/SeqIO/abi.t t/SeqIO/ace.t t/SeqIO/agave.t t/SeqIO/alf.t t/SeqIO/asciitree.t t/SeqIO/bsml.t t/SeqIO/bsml_sax.t t/SeqIO/chadoxml.t t/SeqIO/chaos.t t/SeqIO/chaosxml.t t/SeqIO/ctf.t t/SeqIO/embl.t t/SeqIO/entrezgene.t t/SeqIO/excel.t t/SeqIO/exp.t t/SeqIO/fasta.t t/SeqIO/fastq.t t/SeqIO/flybase_chadoxml.t t/SeqIO/game.t t/SeqIO/gbxml.t t/SeqIO/gcg.t t/SeqIO/genbank.t t/SeqIO/Handler.t t/SeqIO/interpro.t t/SeqIO/kegg.t t/SeqIO/largefasta.t t/SeqIO/lasergene.t t/SeqIO/locuslink.t t/SeqIO/mbsout.t t/SeqIO/metafasta.t t/SeqIO/msout.t t/SeqIO/MultiFile.t t/SeqIO/Multiple_fasta.t t/SeqIO/nexml.t t/SeqIO/phd.t t/SeqIO/pir.t t/SeqIO/pln.t t/SeqIO/qual.t t/SeqIO/raw.t t/SeqIO/scf.t t/SeqIO/SeqBuilder.t t/SeqIO/SeqIO.t t/SeqIO/seqxml.t t/SeqIO/Splicedseq.t t/SeqIO/strider.t t/SeqIO/swiss.t t/SeqIO/tab.t t/SeqIO/table.t t/SeqIO/tigr.t t/SeqIO/tigrxml.t t/SeqIO/tinyseq.t t/SeqIO/ztr.t t/SeqTools/Backtranslate.t t/SeqTools/CodonTable.t t/SeqTools/ECnumber.t t/SeqTools/GuessSeqFormat.t t/SeqTools/OddCodes.t t/SeqTools/SeqPattern.t t/SeqTools/SeqStats.t t/SeqTools/SeqUtils.t t/SeqTools/SeqWords.t t/Species.t t/Structure/IO.t t/Structure/Structure.t t/Symbol.t t/TaxonTree.t t/Tools/Alignment/Consed.t t/Tools/AmpliconSearch.t t/Tools/Analysis/DNA/ESEfinder.t t/Tools/Analysis/Protein/Domcut.t t/Tools/Analysis/Protein/ELM.t t/Tools/Analysis/Protein/GOR4.t t/Tools/Analysis/Protein/HNN.t t/Tools/Analysis/Protein/Mitoprot.t t/Tools/Analysis/Protein/NetPhos.t t/Tools/Analysis/Protein/Scansite.t t/Tools/Analysis/Protein/Sopma.t t/Tools/EMBOSS/Palindrome.t t/Tools/ePCR.t t/Tools/Est2Genome.t t/Tools/FootPrinter.t t/Tools/Geneid.t t/Tools/Genewise.t t/Tools/Genomewise.t t/Tools/Genpred.t t/Tools/GFF.t t/Tools/GuessSeqFormat.t t/Tools/Hmmer.t t/Tools/IUPAC.t t/Tools/Lucy.t t/Tools/Match.t t/Tools/Phylo/Gerp.t t/Tools/Phylo/Molphy.t t/Tools/Phylo/PAML.t t/Tools/Phylo/Phylip/ProtDist.t t/Tools/pICalculator.t t/Tools/Primer3.t t/Tools/Promoterwise.t t/Tools/Pseudowise.t t/Tools/QRNA.t t/Tools/RandDistFunctions.t t/Tools/RepeatMasker.t t/Tools/rnamotif.t t/Tools/Run/Dummy.pm t/Tools/Run/Dummy/Config.pm t/Tools/Run/RemoteBlast.t t/Tools/Run/RemoteBlast_rpsblast.t t/Tools/Run/StandAloneBlast.t t/Tools/Run/WBCommandExts.t t/Tools/Run/WrapperBase.t t/Tools/Seg.t t/Tools/Sigcleave.t t/Tools/Signalp.t t/Tools/Signalp/ExtendedSignalp.t t/Tools/Sim4.t t/Tools/SiRNA.t t/Tools/Spidey/Spidey.t t/Tools/TandemRepeatsFinder.t t/Tools/TargetP.t t/Tools/Tmhmm.t t/Tools/tRNAscanSE.t t/Tree/Compatible.t t/Tree/Node.t t/Tree/PhyloNetwork/Factory.t t/Tree/PhyloNetwork/GraphViz.t t/Tree/PhyloNetwork/MuVector.t t/Tree/PhyloNetwork/PhyloNetwork.t t/Tree/PhyloNetwork/RandomFactory.t t/Tree/PhyloNetwork/TreeFactory.t t/Tree/RandomTreeFactory.t t/Tree/Tree.t t/Tree/TreeIO.t t/Tree/TreeIO/lintree.t t/Tree/TreeIO/newick.t t/Tree/TreeIO/nexml.t t/Tree/TreeIO/nexus.t t/Tree/TreeIO/nhx.t t/Tree/TreeIO/phyloxml.t t/Tree/TreeIO/svggraph.t t/Tree/TreeIO/tabtree.t t/Tree/TreeStatistics.t t/Variation/AAChange.t t/Variation/AAReverseMutate.t t/Variation/Allele.t t/Variation/DNAMutation.t t/Variation/RNAChange.t t/Variation/SeqDiff.t t/Variation/SNP.t t/Variation/Variation_IO.t travis_scripts/dependency_installs META.yml META.json BioPerl-1.6.923/META.json000444000765000024 443612254227312 15064 0ustar00cjfieldsstaff000000000000{ "abstract" : "Bioinformatics Toolkit", "author" : [ "BioPerl Team " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4203", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "BioPerl", "no_index" : { "x_dir" : [ "examples/root/lib" ] }, "prereqs" : { "build" : { "requires" : { "CPAN" : "1.81", "Module::Build" : "0.2805", "Test::Harness" : "2.62", "Test::Most" : "0", "URI::Escape" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "recommends" : { "Algorithm::Munkres" : "0", "Array::Compare" : "0", "Clone" : "0", "Convert::Binary::C" : "0", "Error" : "0", "GD" : "0", "Graph" : "0.5", "GraphViz" : "0", "HTML::Entities" : "0", "HTML::HeadParser" : "3", "HTML::TableExtract" : "0", "HTTP::Request::Common" : "0", "LWP::UserAgent" : "0", "List::MoreUtils" : "0", "PostScript::TextBlock" : "0", "SOAP::Lite" : "0", "SVG" : "2.26", "SVG::Graph" : "0.01", "Set::Scalar" : "0", "Sort::Naturally" : "0", "Spreadsheet::ParseExcel" : "0", "Storable" : "2.05", "Text::ParseWords" : "0", "XML::Parser" : "0", "XML::Parser::PerlSAX" : "0", "XML::SAX" : "0.15", "XML::SAX::Writer" : "0", "XML::Simple" : "0", "XML::Twig" : "0", "XML::Writer" : "0.4", "YAML" : "0" }, "requires" : { "DB_File" : "0", "Data::Stag" : "0.11", "ExtUtils::Manifest" : "1.52", "IO::String" : "0", "Scalar::Util" : "0", "perl" : "v5.6.1" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "1.006923" } BioPerl-1.6.923/META.yml000444000765000024 240512254227314 14710 0ustar00cjfieldsstaff000000000000--- abstract: 'Bioinformatics Toolkit' author: - 'BioPerl Team ' build_requires: CPAN: 1.81 Module::Build: 0.2805 Test::Harness: 2.62 Test::Most: 0 URI::Escape: 0 configure_requires: Module::Build: 0.42 dynamic_config: 1 generated_by: 'Module::Build version 0.4203, CPAN::Meta::Converter version 2.132830' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: BioPerl no_index: x_dir: - examples/root/lib recommends: Algorithm::Munkres: 0 Array::Compare: 0 Clone: 0 Convert::Binary::C: 0 Error: 0 GD: 0 Graph: 0.5 GraphViz: 0 HTML::Entities: 0 HTML::HeadParser: 3 HTML::TableExtract: 0 HTTP::Request::Common: 0 LWP::UserAgent: 0 List::MoreUtils: 0 PostScript::TextBlock: 0 SOAP::Lite: 0 SVG: 2.26 SVG::Graph: 0.01 Set::Scalar: 0 Sort::Naturally: 0 Spreadsheet::ParseExcel: 0 Storable: 2.05 Text::ParseWords: 0 XML::Parser: 0 XML::Parser::PerlSAX: 0 XML::SAX: 0.15 XML::SAX::Writer: 0 XML::Simple: 0 XML::Twig: 0 XML::Writer: 0.4 YAML: 0 requires: DB_File: 0 Data::Stag: 0.11 ExtUtils::Manifest: 1.52 IO::String: 0 Scalar::Util: 0 perl: v5.6.1 resources: license: http://dev.perl.org/licenses/ version: 1.006923 BioPerl-1.6.923/README000444000765000024 2444512254227334 14351 0ustar00cjfieldsstaff000000000000This is the README file for the BioPerl central distribution. o Getting Started Please see the the INSTALL or INSTALL.WIN documents for installation instructions. o About BioPerl BioPerl is a package of public domain Perl tools for computational molecular biology. Our website, http://bioperl.org/, provides an online resource of modules, scripts, and web links for developers of Perl-based software for life science research. o Contact info BioPerl mailing list: bioperl-l@bioperl.org There's quite a variety of tools available in BioPerl, and more are added all the time. If the tool you're looking for isn't described in the documentation please write us, it could be undocumented or in process. Project website : http://bioperl.org/ Bug reports : https://redmine.open-bio.org/projects/bioperl/ Please send us bugs, in particular about documentation which you think is unclear or problems in installation. We are also very interested in functions which don't work the way you think they do! o The directory structure The BioPerl directory structure is organized as follows: - Bio/ - BioPerl modules - doc/ - Documentation utilities - examples/ - Scripts demonstrating the many uses of BioPerl - ide/ - files for developing BioPerl using an IDE - maintenance/ - BioPerl housekeeping scripts - models/ - DIA drawing program generated OO UML for BioPerl classes (these are quite out-of-date) - scripts/ - Useful production-quality scripts with POD documentation - t/ - Perl built-in tests, tests are divided into subdirectories based on the specific classes being tested - t/data/ - Data files used for the tests, provides good example data o Documentation For documentation on BioPerl see the HOWTO documents and tutorials online at http://bioperl.org. Useful documentation in the form of example code can also be found in the examples/ and scripts/ directories. The current collection includes scripts that run BLAST, index flat files, parse PDB structure files, make primers, retrieve ESTs based on tissue, align protein to nucleotide sequence, run GENSCAN on multiple sequences, and much more! See bioscripts.pod for a complete listing. Individual *.pm modules have their own embedded POD documentation as well. A complete set of hyperlinked POD, or module, documentation is available at http://www.bioperl.org/. Remember that 'perldoc' is your friend. You can use it to read any file containing POD formatted documentation without needing any type of translator (e.g. 'perldoc Bio::SeqIO'). If you used the Build.PL installation, and depending on your platform, you may have documentation installed as man pages, which can be accessed in the usual way. o Releases BioPerl releases are always available from the website at http://www.bioperl.org/DIST or in CPAN. The latest code can be found at https://github.com/bioperl. BioPerl formerly used a numbering scheme to indicate stable release series vs. development release series. A release number is a three digit number like 1.2.0. The first digit indicates the major release - the idea being that all the API calls in a major release are reasonably consistent. The second number is the release series. This is probably the most important number. From the 1.0 release until the 1.6 release, even numbers (1.0, 1.2 etc) indicated stable releases. Stable releases were well tested and recommended for most uses. Odd numbers (1.1, 1.3 etc) were development releases which one would only use if one were interested in the latest and greatest features. The final number (e.g. 1.2.0, 1.2.1) is the bug fix release. The higher the number the more bug fixes has been incorporated. In theory you can upgrade from one bug fix release to the next with no changes to your own code (for production cases, obviously check things out carefully before you switch over). The 1.6 release will be the last release series to utilize the alternating 'stable'/'developer' convention. Starting immediately after the 1.6 branch, we will start splitting BioPerl into several smaller easier-to-manage distributions, including a developer distribution for cutting-edge (in development) code, untested modules, and alternative implementations. o Caveats and warnings When you run the tests ("./Build test") some tests may issue warnings messages or even fail. Sometimes this is because we didn't have anyone to test the test system on the combination of your operating system, version of perl, and associated libraries and other modules. Because BioPerl depends on several outside libraries we may not be able to test every single combination so if there are warnings you may find that the package is still perfectly useful. If you install the bioperl-run system and run tests when you don't have the program installed you'll get messages like 'program XXX not found, skipping tests'. That's okay, BioPerl is doing what it is supposed to do. If you wanted to run the program you'd need to install it first. Not all scripts in the examples/ directory are correct and up-to-date. We need volunteers to help maintain these so if you find they do not submit a bug report to https://redmine.open-bio.org/projects/bioperl/ and consider helping out in their maintenance. If you are confused about what modules are appropriate when you try and solve a particular issue in bioinformatics we urge you to look at HOWTO documents first. o A simple module summary Here is a quick summary of many of the useful modules and how the toolkit is laid out: All modules are in the Bio/ namespace, - Perl is for newbies and gives a functional interface to the main parts of the package - Seq is for Sequences (protein and DNA). o Bio::PrimarySeq is a plain sequence (sequence data + identifiers) o Bio::Seq is a PrimarySeq plus it has a Bio::Annotation::Collection and Bio::SeqFeatureI objects attached (via Bio::FeatureHolderI). o Bio::Seq::RichSeq is all of the above plus it has slots for extra information specific to GenBank/EMBL/SwissProt files. o Bio::Seq::LargeSeq is for sequences which are too big for fitting into memory. - SeqIO is for reading and writing Sequences, it is a front end module for separate driver modules supporting the different sequence formats - SeqFeature - start/stop/strand annotations of sequences o Bio::SeqFeature::Generic is basic catchall o Bio::SeqFeature::Similarity a similarity sequence feature o Bio::SeqFeature::FeaturePair a sequence feature which is pairwise such as query/hit pairs - SearchIO is for reading and writing pairwise alignment reports like BLAST or FASTA - Search is where the alignment objects are defined o Bio::Search::Result::GenericResult is the result object (a blast query is a Result object) o Bio::Search::Hit::GenericHit is the Hit object (a query will have 0 -> many hits in a database) o Bio::Search::HSP::GenericHSP is the High-scoring Segment Pair object defining the alignment(s) of the query and hit. - SimpleAlign is for multiple sequence alignments - AlignIO is for reading and writing multiple sequence alignment formats - Assembly provides the start of an infrastructure for assemblies and Assembly::IO IO converters for them - DB is the namespace for all the database query objects o Bio::DB::GenBank/GenPept are two modules which query NCBI entrez for sequences o Bio::DB::SwissProt/EMBL query various EMBL and SwissProt repositories for a sequences o Bio::DB::GFF is Lincoln Stein's fast, lightweight feature and sequence database which is the backend to his GBrowse system (see www.gmod.org) o Bio::DB::Flat is a fast implementation of the OBDA flat-file indexing system (cross-language and cross-platform supported by O|B|F projects see http://obda.open-bio.org). o Bio::DB::BioFetch/DBFetch for OBDA, Web (HTTP) access to remote databases. o Bio::DB::InMemoryCache/FileCache (fast local caching of sequences from remote dbs to speed up your access). o Bio::DB::Registry interface to the OBDA specification for remote data sources o Bio::DB::Biblio for access to remote bibliographic databases. o Bio::DB::EUtilities is the initial set of modules used for generic queried using NCBI's eUtils. - Annotation collection of annotation objects (comments, DBlinks, References, and misc key/value pairs) - Coordinate is a system for mapping between different coordinate systems such as DNA to protein or between assemblies - Index is for locally indexed flatfiles with BerkeleyDB - Tools contains many miscellaneous parsers and function for different bioinformatics needs o Gene prediction parser (Genscan, MZEF, Grail, Genemark) o Annotation format (GFF) o Enumerate codon tables and valid sequences symbols (CodonTable, IUPAC) o Phylogenetic program parsing (PAML, Molphy, Phylip) - Map genetic and physical map representations - Structure - parse and represent protein structure data - TreeIO is for reading and writing Tree formats - Tree is the namespace for all the associated Tree objects o Bio::Tree::Tree is the basic tree object o Bio::Tree::Node are the nodes which make up the tree o Bio::Tree::Statistics is for computing statistics for a tree o Bio::Tree::TreeFunctionsI is where specific tree functions are implemented (like is_monophyletic and lca) - Bio::Biblio is where bibliographic data and database access objects are kept - Variation represent sequences with mutations and variations applied so one can compare and represent wild-type and mutation versions of a sequence. - Root, basic objects for the internals of BioPerl o Upgrading from an older version If you have a previously installed version of BioPerl on your system some of these notes may help you. Some modules have been removed because they have been superceded by new development efforts. They are documented in the DEPRECATED file that is included in the release. In addition some methods, or the Application Programming Interface (API), have changed or been removed. You may find that scripts which worked with BioPerl 1.4 may give you warnings or may not work at all (although we have tried very hard to minimize this!). Send an email to the list and we'll be happy to give you pointers. BioPerl-1.6.923/README.md000444000765000024 2613012254227315 14740 0ustar00cjfieldsstaff000000000000# Getting Started Please see the the `INSTALL` or `INSTALL.WIN` documents for installation instructions. # About BioPerl BioPerl is a package of public domain Perl tools for computational molecular biology. Our website (http://bioperl.org/) provides an online resource of modules, scripts, and web links for developers of Perl-based software for life science research. # Contact info BioPerl mailing list: bioperl-l@bioperl.org There's quite a variety of tools available in BioPerl, and more are added all the time. If the tool you're looking for isn't described in the documentation please write us, it could be undocumented or in process. * Project website : http://bioperl.org/ * Bug reports : https://redmine.open-bio.org/projects/bioperl/ Please send us bugs, in particular about documentation which you think is unclear or problems in installation. We are also very interested in functions which don't work the way you think they do! # The directory structure The BioPerl directory structure is organized as follows: * **`Bio/`** - BioPerl modules * **`doc/`** - Documentation utilities * **`examples/`** - Scripts demonstrating the many uses of BioPerl * **`ide/`** - files for developing BioPerl using an IDE * **`maintenance/`** - BioPerl housekeeping scripts * **`models/`** - DIA drawing program generated OO UML for BioPerl classes (these are quite out-of-date) * **`scripts/`** - Useful production-quality scripts with POD documentation * **`t/`** - Perl built-in tests, tests are divided into subdirectories based on the specific classes being tested * **`t/data/`** - Data files used for the tests, provides good example data # Documentation For documentation on BioPerl see the **HOWTO** documents and tutorials online at http://bioperl.org. Useful documentation in the form of example code can also be found in the **`examples/`** and **`scripts/`** directories. The current collection includes scripts that run BLAST, index flat files, parse PDB structure files, make primers, retrieve ESTs based on tissue, align protein to nucleotide sequence, run GENSCAN on multiple sequences, and much more! See `bioscripts.pod` for a complete listing. Individual `*.pm` modules have their own embedded POD documentation as well. A complete set of hyperlinked POD, or module, documentation is available at http://www.bioperl.org/. Remember that '`perldoc`' is your friend. You can use it to read any file containing POD formatted documentation without needing any type of translator (e.g. '`perldoc Bio::SeqIO`'). If you used the Build.PL installation, and depending on your platform, you may have documentation installed as man pages, which can be accessed in the usual way. # Releases BioPerl releases are always available from the website at http://www.bioperl.org/DIST or in CPAN. The latest code can be found at https://github.com/bioperl. * BioPerl currently uses a sematic numbering scheme to indicate stable release series vs. development release series. A release number is a three digit number like `1.2.0`. * The *first digit indicates the major release*, the idea being that all the API calls in a major release are reasonably consistent. * The *second number is the release series*. This is probably the most important number, and represents added functionality that is backwards-compatible. * The *third number is the point or patch release* and represents mainly bug fixes or additional code that doesn't add significant functionality to the code base. * From the **1.0 release until the 1.6 release**, even numbers (`1.0`, `1.2`, etc) indicated stable releases. Stable releases were well tested and recommended for most uses. Odd numbers (`1.1`, `1.3`, etc) were development releases which one would only use if one were interested in the latest and greatest features. The final number (e.g. `1.2.0`, `1.2.1`) is the bug fix release. The higher the number the more bug fixes has been incorporated. In theory you can upgrade from one bug fix release to the next with no changes to your own code (for production cases, obviously check things out carefully before you switch over). * The upcoming **1.7 release** will be the last release series to utilize the alternating 'stable'/'developer' convention. Starting immediately after the final 1.6 branch, we will start splitting BioPerl into several smaller easier-to-manage distributions. These will have independent versions, all likely starting with v1.7.0. **We do not anticipate major API changes in the 1.7.x release series*, merely that the code will be restructured in a way to make maintenance more feasible. We anticipate retaining semantic versioning until the **v2.x** release. # Caveats and warnings When you run the tests ("`./Build test`") some tests may issue warnings messages or even fail. Sometimes this is because we didn't have anyone to test the test system on the combination of your operating system, version of perl, and associated libraries and other modules. Because BioPerl depends on several outside libraries we may not be able to test every single combination so if there are warnings you may find that the package is still perfectly useful. If you install the bioperl-run system and run tests when you don't have the program installed you'll get messages like '`program XXX not found, skipping tests`'. That's okay, BioPerl is doing what it is supposed to do. If you wanted to run the program you'd need to install it first. Not all scripts in the `examples/` directory are correct and up-to-date. We need volunteers to help maintain these so if you find they do not submit a bug report to https://redmine.open-bio.org/projects/bioperl/ and consider helping out in their maintenance. If you are confused about what modules are appropriate when you try and solve a particular issue in bioinformatics we urge you to look at HOWTO documents first. # A simple module summary Here is a quick summary of many of the useful modules and how the toolkit is laid out: All modules are in the **`Bio/`** namespace, * **`Perl`** is for *new users*, and gives a functional interface to the main parts of the package. * **`Seq`** is for *Sequences* (protein and DNA). * `Bio::PrimarySeq` is a plain sequence (sequence data + identifiers) * `Bio::Seq` is a fancier `PrimarySeq`, in that it has annotation (via `Bio::Annotation::Collection`) and sequence features (via `Bio::SeqFeatureI` objects, attached via `Bio::FeatureHolderI`). * `Bio::Seq::RichSeq` is all of the above, plus it has slots for extra information specific to GenBank/EMBL/SwissProt files. * `Bio::Seq::LargeSeq` is for sequences which are too big for fitting into memory. * **`SeqIO`** is for *reading and writing Sequences*. It is a front end module for separate driver modules supporting the different sequence formats * **`SeqFeature`** represent *start/stop/strand-based localized annotations (features) of sequences* * **`Bio::SeqFeature::Generic`** is basic catchall * **`Bio::SeqFeature::Similarity`** a similarity sequence feature * **`Bio::SeqFeature::FeaturePair`** a sequence feature which is pairwise such as query/hit pairs * **`SearchIO`** is for *reading and writing pairwise alignment reports*, like BLAST or FASTA * **`Search`** is where the *alignment objects for `SearchIO` are defined* * **`Bio::Search::Result::GenericResult`** is the result object (a blast query is a `Result` object) * **`Bio::Search::Hit::GenericHit`** is the `Hit` object (a query will have 0 to many hits in a database) * **`Bio::Search::HSP::GenericHSP`** is the High-scoring Segment Pair object defining the alignment(s) of the query and hit. * **`SimpleAlign`** is for *multiple sequence alignments* * **`AlignIO`** is for *reading and writing multiple sequence alignment formats* * **`Assembly`** provides the start of an *infrastructure for assemblies* and **`Assembly::IO`** *IO converters* for them * **`DB`** is the namespace for *all the database query classes* * **`Bio::DB::GenBank/GenPept`** are two modules which query NCBI entrez for sequences * **`Bio::DB::SwissProt/EMBL`** query various EMBL and SwissProt repositories for a sequences * **`Bio::DB::GFF`** is Lincoln Stein's fast, lightweight feature and sequence database which is the backend to his GBrowse system (see www.gmod.org) * **`Bio::DB::Flat`** is a fast implementation of the OBDA flat-file indexing system (cross-language and cross-platform supported by O|B|F projects see http://obda.open-bio.org). * **`Bio::DB::BioFetch/DBFetch`** for OBDA, Web (HTTP) access to remote databases. * **`Bio::DB::InMemoryCache/FileCache`** (fast local caching of sequences from remote dbs to speed up your access). * **`Bio::DB::Registry`** interface to the OBDA specification for remote data sources * **`Bio::DB::Biblio`** for access to remote bibliographic databases. * **`Bio::DB::EUtilities`** is the initial set of modules used for generic queried using NCBI's eUtils. * **`Annotation`** collection of *annotation objects* (comments, DBlinks, References, and misc key/value pairs) * **`Coordinate`** is a system for *mapping between different coordinate systems* such as DNA to protein or between assemblies * **`Index`** is for *locally indexed flatfiles* with BerkeleyDB * **`Tools`** contains many *miscellaneous parsers and functions* for different bioinformatics needs * Gene prediction parser (Genscan, MZEF, Grail, Genemark) * Annotation format (GFF) * Enumerate codon tables and valid sequences symbols (CodonTable, IUPAC) * Phylogenetic program parsing (PAML, Molphy, Phylip) * **`Map`** represents *genetic and physical map representations* * **`Structure`** - parse and represent *protein structure data* * **`TreeIO`** is for reading and writing *Tree formats* * **`Tree`** is the namespace for **all associated Tree classes** * **`Bio::Tree::Tree`** is the basic tree object * **`Bio::Tree::Node`** are the nodes which make up the tree * **`Bio::Tree::Statistics`** is for computing statistics for a tree * **`Bio::Tree::TreeFunctionsI`** is where specific tree functions are implemented (like `is_monophyletic` and `lca`) * **`Bio::Biblio`** is where *bibliographic data and database access objects* are kept * **`Variation`** represent *sequences with mutations and variations* applied so one can compare and represent wild-type and mutation versions of a sequence. * **`Root`**, basic objects for the *internals of BioPerl* # Upgrading from an older version If you have a previously installed version of BioPerl on your system some of these notes may help you. * Some modules have been removed because they have been superceded by new development efforts. They are documented in the **`DEPRECATED`** file that is included in the release. * Some methods, or the Application Programming Interface (API), have changed or been removed. You may find that scripts which worked with BioPerl 1.4 may give you warnings or may not work at all (although we have tried very hard to minimize this!). Send an email to the list and we'll be happy to give you pointers. BioPerl-1.6.923/Bio000755000765000024 012254227336 14016 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/AlignIO.pm000444000765000024 3612312254227330 16012 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO # # based on the Bio::SeqIO module # by Ewan Birney # and Lincoln Stein # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # # History # September, 2000 AlignIO written by Peter Schattner # POD documentation - main docs before the code =head1 NAME Bio::AlignIO - Handler for AlignIO Formats =head1 SYNOPSIS use Bio::AlignIO; $inputfilename = "testaln.fasta"; $in = Bio::AlignIO->new(-file => $inputfilename , -format => 'fasta'); $out = Bio::AlignIO->new(-file => ">out.aln.pfam" , -format => 'pfam'); while ( my $aln = $in->next_aln() ) { $out->write_aln($aln); } # OR use Bio::AlignIO; open MYIN,"testaln.fasta"; $in = Bio::AlignIO->newFh(-fh => \*MYIN, -format => 'fasta'); open my $MYOUT, '>', 'testaln.pfam'; $out = Bio::AlignIO->newFh(-fh => $MYOUT, -format => 'pfam'); # World's smallest Fasta<->pfam format converter: print $out $_ while <$in>; =head1 DESCRIPTION L is a handler module for the formats in the AlignIO set, for example, L. It is the officially sanctioned way of getting at the alignment objects. The resulting alignment is a L-compliant object. The idea is that you request an object for a particular format. All the objects have a notion of an internal file that is read from or written to. A particular AlignIO object instance is configured for either input or output, you can think of it as a stream object. Each object has functions: $stream->next_aln(); And: $stream->write_aln($aln); Also: $stream->type() # returns 'INPUT' or 'OUTPUT' As an added bonus, you can recover a filehandle that is tied to the AlignIO object, allowing you to use the standard EE and print operations to read and write alignment objects: use Bio::AlignIO; # read from standard input $stream = Bio::AlignIO->newFh(-format => 'Fasta'); while ( $aln = <$stream> ) { # do something with $aln } And: print $stream $aln; # when stream is in output mode L is patterned on the L module and shares most of its features. One significant difference is that L usually handles IO for only a single alignment at a time, whereas L handles IO for multiple sequences in a single stream. The principal reason for this is that whereas simultaneously handling multiple sequences is a common requirement, simultaneous handling of multiple alignments is not. The only current exception is format C which parses results of the BLAST C program and which may produce several alignment pairs. This set of alignment pairs can be read using multiple calls to L. =head1 CONSTRUCTORS =head2 Bio::AlignIO-Enew() $seqIO = Bio::AlignIO->new(-file => 'filename', -format=>$format); $seqIO = Bio::AlignIO->new(-fh => \*FILEHANDLE, -format=>$format); $seqIO = Bio::AlignIO->new(-format => $format); $seqIO = Bio::AlignIO->new(-fh => \*STDOUT, -format => $format); The L class method constructs a new L object. The returned object can be used to retrieve or print alignment objects. L accepts the following parameters: =over 4 =item -file A file path to be opened for reading or writing. The usual Perl conventions apply: 'file' # open file for reading '>file' # open file for writing '>>file' # open file for appending '+new(-fh => \*STDIN); Note that you must pass filehandles as references to globs. If neither a filehandle nor a filename is specified, then the module will read from the @ARGV array or STDIN, using the familiar EE semantics. =item -format Specify the format of the file. Supported formats include: bl2seq Bl2seq Blast output clustalw clustalw (.aln) format emboss EMBOSS water and needle format fasta FASTA format maf Multiple Alignment Format mase mase (seaview) format mega MEGA format meme MEME format msf msf (GCG) format nexus Swofford et al NEXUS format pfam Pfam sequence alignment format phylip Felsenstein PHYLIP format prodom prodom (protein domain) format psi PSI-BLAST format selex selex (hmmer) format stockholm stockholm format Currently only those formats which were implemented in L have been incorporated into L. Specifically, C, C and C have only been implemented for input. See the specific module (e.g. L) for notes on supported versions. If no format is specified and a filename is given, then the module will attempt to deduce it from the filename suffix. If this is unsuccessful, C format is assumed. The format name is case insensitive; C, C and C are all treated equivalently. =back =head2 Bio::AlignIO-EnewFh() $fh = Bio::AlignIO->newFh(-fh => \*FILEHANDLE, -format=>$format); # read from STDIN or use @ARGV: $fh = Bio::AlignIO->newFh(-format => $format); This constructor behaves like L, but returns a tied filehandle rather than a L object. You can read sequences from this object using the familiar EE operator, and write to it using L. The usual array and $_ semantics work. For example, you can read all sequence objects into an array like this: @sequences = <$fh>; Other operations, such as read(), sysread(), write(), close(), and printf() are not supported. =over 1 =item -flush By default, all files (or filehandles) opened for writing alignments will be flushed after each write_aln() making the file immediately usable. If you do not need this facility and would like to marginally improve the efficiency of writing multiple sequences to the same file (or filehandle), pass the -flush option '0' or any other value that evaluates as defined but false: my $clustal = Bio::AlignIO->new( -file => " "clustalw" ); my $msf = Bio::AlignIO->new(-file => ">prot.msf", -format => "msf", -flush => 0 ); # go as fast as we can! while($seq = $clustal->next_aln) { $msf->write_aln($seq) } =back =head1 OBJECT METHODS See below for more detailed summaries. The main methods are: =head2 $alignment = $AlignIO-Enext_aln() Fetch an alignment from a formatted file. =head2 $AlignIO-Ewrite_aln($aln) Write the specified alignment to a file.. =head2 TIEHANDLE(), READLINE(), PRINT() These provide the tie interface. See L for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Schattner Email: schattner@alum.mit.edu =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # 'Let the code begin... package Bio::AlignIO; use strict; use Bio::Seq; use Bio::LocatableSeq; use Bio::SimpleAlign; use Bio::Tools::GuessSeqFormat; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : $stream = Bio::AlignIO->new(-file => $filename, -format => 'Format') Function: Returns a new seqstream Returns : A Bio::AlignIO::Handler initialised with the appropriate format Args : -file => $filename -format => format -fh => filehandle to attach to -displayname_flat => 1 [optional] to force the displayname to not show start/end information =cut sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::AlignIO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{-file} || $ARGV[0] ); unless ($format) { if ($param{-file}) { $format = Bio::Tools::GuessSeqFormat->new(-file => $param{-file}||$ARGV[0] )->guess; } elsif ($param{-fh}) { $format = Bio::Tools::GuessSeqFormat->new(-fh => $param{-fh}||$ARGV[0] )->guess; } } $format = "\L$format"; # normalize capitalization to lower case $class->throw("Unknown format given or could not determine it [$format]") unless $format; return unless( $class->_load_format_module($format) ); return "Bio::AlignIO::$format"->new(@args); } } =head2 newFh Title : newFh Usage : $fh = Bio::AlignIO->newFh(-file=>$filename,-format=>'Format') Function: does a new() followed by an fh() Example : $fh = Bio::AlignIO->newFh(-file=>$filename,-format=>'Format') $sequence = <$fh>; # read a sequence object print $fh $sequence; # write a sequence object Returns : filehandle tied to the Bio::AlignIO::Fh class Args : =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Example : $fh = $obj->fh; # make a tied filehandle $sequence = <$fh>; # read a sequence object print $fh $sequence; # write a sequence object Returns : filehandle tied to the Bio::AlignIO::Fh class Args : =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } =head2 format Title : format Usage : $format = $stream->format() Function: Get the alignment format Returns : alignment format Args : none =cut # format() method inherited from Bio::Root::IO # _initialize is where the heavy stuff will happen when new is called sub _initialize { my($self,@args) = @_; my ($flat,$alphabet,$width) = $self->_rearrange([qw(DISPLAYNAME_FLAT ALPHABET WIDTH)], @args); $self->force_displayname_flat($flat) if defined $flat; $self->alphabet($alphabet); $self->width($width) if defined $width; $self->_initialize_io(@args); 1; } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL AlignIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::AlignIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <next_aln Function: reads the next $aln object from the stream Returns : a Bio::Align::AlignI compliant object Args : =cut sub next_aln { my ($self,$aln) = @_; $self->throw("Sorry, you cannot read from a generic Bio::AlignIO object."); } =head2 write_aln Title : write_aln Usage : $stream->write_aln($aln) Function: writes the $aln object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_aln { my ($self,$aln) = @_; $self->throw("Sorry, you cannot write to a generic Bio::AlignIO object."); } =head2 _guess_format Title : _guess_format Usage : $obj->_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'clustalw' if /\.aln$/i; return 'emboss' if /\.(water|needle)$/i; return 'metafasta' if /\.metafasta$/; return 'fasta' if /\.(fasta|fast|seq|fa|fsa|nt|aa)$/i; return 'maf' if /\.maf/i; return 'mega' if /\.(meg|mega)$/i; return 'meme' if /\.meme$/i; return 'msf' if /\.(msf|pileup|gcg)$/i; return 'nexus' if /\.(nexus|nex)$/i; return 'pfam' if /\.(pfam|pfm)$/i; return 'phylip' if /\.(phylip|phlp|phyl|phy|ph)$/i; return 'psi' if /\.psi$/i; return 'stockholm' if /\.stk$/i; return 'selex' if /\.(selex|slx|selx|slex|sx)$/i; return 'xmfa' if /\.xmfa$/i; } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my $class = shift; return bless {'alignio' => shift},$class; } sub READLINE { my $self = shift; return $self->{'alignio'}->next_aln() unless wantarray; my (@list,$obj); push @list,$obj while $obj = $self->{'alignio'}->next_aln(); return @list; } sub PRINT { my $self = shift; $self->{'alignio'}->write_aln(@_); } =head2 force_displayname_flat Title : force_displayname_flat Usage : $obj->force_displayname_flat($newval) Function: Example : Returns : value of force_displayname_flat (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub force_displayname_flat{ my $self = shift; return $self->{'_force_displayname_flat'} = shift if @_; return $self->{'_force_displayname_flat'} || 0; } =head2 alphabet Title : alphabet Usage : $obj->alphabet($newval) Function: Get/Set alphabet for purpose of passing to Bio::LocatableSeq creation Example : $obj->alphabet('dna'); Returns : value of alphabet (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub alphabet { my $self = shift; my $value = shift; if ( defined $value ) { $self->throw("Invalid alphabet $value") unless $value eq 'rna' || $value eq 'protein' || $value eq 'dna'; $self->{'_alphabet'} = $value; } return $self->{'_alphabet'}; } 1; BioPerl-1.6.923/Bio/AnalysisI.pm000444000765000024 5444212254227313 16431 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AnalysisI # # Please direct questions and support issues to # # Cared for by Martin Senger # For copyright and disclaimer see below. # # POD documentation - main docs before the code =head1 NAME Bio::AnalysisI - An interface to any (local or remote) analysis tool =head1 SYNOPSIS This is an interface module - you do not instantiate it. Use C module: use Bio::Tools::Run::Analysis; my $tool = Bio::Tools::Run::Analysis->new(@args); =head1 DESCRIPTION This interface contains all public methods for accessing and controlling local and remote analysis tools. It is meant to be used on the client side. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Martin Senger (martin.senger@gmail.com) =head1 COPYRIGHT Copyright (c) 2003, Martin Senger and EMBL-EBI. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO http://www.ebi.ac.uk/Tools/webservices/soaplab/guide =head1 APPENDIX This is actually the main documentation... If you try to call any of these methods directly on this C object you will get a I error message. You need to call them on a C object instead. =cut # Let the code begin... package Bio::AnalysisI; use strict; use base qw(Bio::Root::RootI); # ----------------------------------------------------------------------------- =head2 analysis_name Usage : $tool->analysis_name; Returns : a name of this analysis Args : none =cut sub analysis_name { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 analysis_spec Usage : $tool->analysis_spec; Returns : a hash reference describing this analysis Args : none The returned hash reference uses the following keys (not all of them always present, perhaps others present as well): C, C, C, C, C, C. Here is an example output: Analysis 'edit.seqret': installation => EMBL-EBI description => Reads and writes (returns) sequences supplier => EMBOSS version => 2.6.0 type => edit name => seqret =cut sub analysis_spec { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 describe Usage : $tool->analysis_spec; Returns : an XML detailed description of this analysis Args : none The returned XML string contains metadata describing this analysis service. It includes also metadata returned (and easier used) by method C, C and C. The DTD used for returned metadata is based on the adopted standard (BSA specification for analysis engine): But the DTD may be extended by provider-specific metadata. For example, the EBI experimental SOAP-based service on top of EMBOSS uses DTD explained at C. =cut sub describe { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 input_spec Usage : $tool->input_spec; Returns : an array reference with hashes as elements Args : none The analysis input data are named, and can be also associated with a default value, with allowed values and with few other attributes. The names are important for feeding the service with the input data (the inputs are given to methods C, C, and/or C as name/value pairs). Here is a (slightly shortened) example of an input specification: $input_spec = [ { 'mandatory' => 'false', 'type' => 'String', 'name' => 'sequence_usa' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'sequence_direct_data' }, { 'mandatory' => 'false', 'allowed_values' => [ 'gcg', 'gcg8', ... 'raw' ], 'type' => 'String', 'name' => 'sformat' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'sbegin' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'send' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'sprotein' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'snucleotide' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'sreverse' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'slower' }, { 'mandatory' => 'false', 'type' => 'String', 'name' => 'supper' }, { 'mandatory' => 'false', 'default' => 'false', 'type' => 'String', 'name' => 'firstonly' }, { 'mandatory' => 'false', 'default' => 'fasta', 'allowed_values' => [ 'gcg', 'gcg8', 'embl', ... 'raw' ], 'type' => 'String', 'name' => 'osformat' } ]; =cut sub input_spec { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 result_spec Usage : $tool->result_spec; Returns : a hash reference with result names as keys and result types as values Args : none The analysis results are named and can be retrieved using their names by methods C and C. Here is an example of the result specification (again for the service I): $result_spec = { 'outseq' => 'String', 'report' => 'String', 'detailed_status' => 'String' }; =cut sub result_spec { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 create_job Usage : $tool->create_job ( {'sequence'=>'tatat'} ) Returns : Bio::Tools::Run::Analysis::Job Args : data and parameters for this execution (in various formats) Create an object representing a single execution of this analysis tool. Call this method if you wish to "stage the scene" - to create a job with all input data but without actually running it. This method is called automatically from other methods (C and C) so usually you do not need to call it directly. The input data and prameters for this execution can be specified in various ways: =over =item array reference The array has scalar elements of the form name = [[@]value] where C is the name of an input data or input parameter (see method C for finding what names are recognized by this analysis) and C is a value for this data/parameter. If C is missing a 1 is assumed (which is convenient for the boolean options). If C starts with C<@> it is treated as a local filename, and its contents is used as the data/parameter value. =item hash reference The same as with the array reference but now there is no need to use an equal sign. The hash keys are input names and hash values their data. The values can again start with a C<@> sign indicating a local filename. =item scalar In this case, the parameter represents a job ID obtained in some previous invocation - such job already exists on the server side, and we are just re-creating it here using the same job ID. I =item undef Finally, if the parameter is undefined, ask server to create an empty job. The input data may be added later using C method(s) - see scripts/papplmaker.PLS for details. =back =cut sub create_job { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 run Usage : $tool->run ( ['sequence=@my.seq', 'osformat=embl'] ) Returns : Bio::Tools::Run::Analysis::Job, representing started job (an execution) Args : the same as for create_job Create a job and start it, but do not wait for its completion. =cut sub run { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 wait_for Usage : $tool->wait_for ( { 'sequence' => '@my,file' } ) Returns : Bio::Tools::Run::Analysis::Job, representing finished job Args : the same as for create_job Create a job, start it and wait for its completion. Note that this is a blocking method. It returns only after the executed job finishes, either normally or by an error. Usually, after this call, you ask for results of the finished job: $analysis->wait_for (...)->results; =cut sub wait_for { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- # # Bio::AnalysisI::JobI # # ----------------------------------------------------------------------------- package Bio::AnalysisI::JobI; =head1 Module Bio::AnalysisI::JobI An interface to the public methods provided by C objects. The C objects represent a created, running, or finished execution of an analysis tool. The factory for these objects is module C where the following methods return an C object: create_job (returning a prepared job) run (returning a running job) wait_for (returning a finished job) =cut use strict; use base qw(Bio::Root::RootI); # ----------------------------------------------------------------------------- =head2 id Usage : $job->id; Returns : this job ID Args : none Each job (an execution) is identifiable by this unique ID which can be used later to re-create the same job (in other words: to re-connect to the same job). It is useful in cases when a job takes long time to finish and your client program does not want to wait for it within the same session. =cut sub id { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 Bio::AnalysisI::JobI::run Usage : $job->run Returns : itself Args : none It starts previously created job. The job already must have all input data filled-in. This differs from the method of the same name of the C object where the C method creates also a new job allowing to set input data. =cut sub run { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 Bio::AnalysisI::JobI::wait_for Usage : $job->wait_for Returns : itself Args : none It waits until a previously started execution of this job finishes. =cut sub wait_for { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 terminate Usage : $job->terminate Returns : itself Args : none Stop the currently running job (represented by this object). This is a definitive stop, there is no way to resume it later. =cut sub terminate { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 last_event Usage : $job->last_event Returns : an XML string Args : none It returns a short XML document showing what happened last with this job. This is the used DTD: Here is an example what is returned after a job was created and started, but before it finishes (note that the example uses an analysis 'showdb' which does not need any input data): use Bio::Tools::Run::Analysis; print new Bio::Tools::Run::Analysis (-name => 'display.showdb') ->run ->last_event; It prints: Mar 3, 2003 5:14:46 PM (Europe/London) The same example but now after it finishes: use Bio::Tools::Run::Analysis; print new Bio::Tools::Run::Analysis (-name => 'display.showdb') ->wait_for ->last_event; Mar 3, 2003 5:17:14 PM (Europe/London) =cut sub last_event { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 status Usage : $job->status Returns : string describing the job status Args : none It returns one of the following strings (and perhaps more if a server implementation extended possible job states): CREATED RUNNING COMPLETED TERMINATED_BY_REQUEST TERMINATED_BY_ERROR =cut sub status { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 created Usage : $job->created (1) Returns : time when this job was created Args : optional Without any argument it returns a time of creation of this job in seconds, counting from the beginning of the UNIX epoch (1.1.1970). With a true argument it returns a formatted time, using rules described in C. =cut sub created { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 started Usage : $job->started (1) Returns : time when this job was started Args : optional See C. =cut sub started { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 ended Usage : $job->ended (1) Returns : time when this job was terminated Args : optional See C. =cut sub ended { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 elapsed Usage : $job->elapsed Returns : elapsed time of the execution of the given job (in milliseconds), or 0 of job was not yet started Args : none Note that some server implementations cannot count in millisecond - so the returned time may be rounded to seconds. =cut sub elapsed { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 times Usage : $job->times ('formatted') Returns : a hash refrence with all time characteristics Args : optional It is a convenient method returning a hash reference with the folowing keys: created started ended elapsed See C for remarks on time formating. An example - both for unformatted and formatted times: use Data::Dumper; use Bio::Tools::Run::Analysis; my $rh = Bio::Tools::Run::Analysis->new(-name => 'nucleic_cpg_islands.cpgplot') ->wait_for ( { 'sequence_usa' => 'embl:hsu52852' } ) ->times (1); print Data::Dumper->Dump ( [$rh], ['Times']); $rh = Bio::Tools::Run::Analysis->new(-name => 'nucleic_cpg_islands.cpgplot') ->wait_for ( { 'sequence_usa' => 'embl:AL499624' } ) ->times; print Data::Dumper->Dump ( [$rh], ['Times']); $Times = { 'ended' => 'Mon Mar 3 17:52:06 2003', 'started' => 'Mon Mar 3 17:52:05 2003', 'elapsed' => '1000', 'created' => 'Mon Mar 3 17:52:05 2003' }; $Times = { 'ended' => '1046713961', 'started' => '1046713926', 'elapsed' => '35000', 'created' => '1046713926' }; =cut sub times { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 results Usage : $job->results (...) Returns : one or more results created by this job Args : various, see belou This is a complex method trying to make sense for all kinds of results. Especially it tries to help to put binary results (such as images) into local files. Generally it deals with fhe following facts: =over =item * Each analysis tool may produce more results. =item * Some results may contain binary data not suitable for printing into a terminal window. =item * Some results may be split into variable number of parts (this is mainly true for the image results that can consist of more *.png files). =back Note also that results have names to distinguish if there are more of them. The names can be obtained by method C. Here are the rules how the method works: Retrieving NAMED results: ------------------------- results ('name1', ...) => return results as they are, no storing into files results ( { 'name1' => 'filename', ... } ) => store into 'filename', return 'filename' results ( 'name1=filename', ...) => ditto results ( { 'name1' => '-', ... } ) => send result to the STDOUT, do not return anything results ( 'name1=-', ...) => ditto results ( { 'name1' => '@', ... } ) => store into file whose name is invented by this method, perhaps using RESULT_NAME_TEMPLATE env results ( 'name1=@', ...) => ditto results ( { 'name1' => '?', ... } ) => find of what type is this result and then use {'name1'=>'@' for binary files, and a regular return for non-binary files results ( 'name=?', ...) => ditto Retrieving ALL results: ----------------------- results() => return all results as they are, no storing into files results ('@') => return all results, as if each of them given as {'name' => '@'} (see above) results ('?') => return all results, as if each of them given as {'name' => '?'} (see above) Misc: ----- * any result can be returned as a scalar value, or as an array reference (the latter is used for results consisting of more parts, such images); this applies regardless whether the returned result is the result itself or a filename created for the result * look in the documentation of the C script for examples (especially how to use various templates for inventing file names) =cut sub results { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 result Usage : $job->result (...) Returns : the first result Args : see 'results' =cut sub result { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 remove Usage : $job->remove Returns : 1 Args : none The job object is not actually removed in this time but it is marked (setting 1 to C<_destroy_on_exit> attribute) as ready for deletion when the client program ends (including a request to server to forget the job mirror object on the server side). =cut sub remove { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- 1; __END__ BioPerl-1.6.923/Bio/AnalysisParserI.pm000444000765000024 1170612254227321 17601 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------------- # # BioPerl module Bio::AnalysisParserI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # Derived from Bio::SeqAnalysisParserI by Jason Stajich, Hilmar Lapp. # # You may distribute this module under the same terms as perl itself #--------------------------------------------------------------- =head1 NAME Bio::AnalysisParserI - Generic analysis output parser interface =head1 SYNOPSIS # get a AnalysisParserI somehow. # Eventually, there may be an Bio::Factory::AnalysisParserFactory. # For now a SearchIO object, an implementation of AnalysisParserI, can be created # directly, as in the following: my $parser = Bio::SearchIO->new( '-file' => 'inputfile', '-format' => 'blast'); while( my $result = $parser->next_result() ) { print "Result: ", $result->analysis_method, ", Query: ", $result->query_name, "\n"; while( my $feature = $result->next_feature() ) { print "Feature from ", $feature->start, " to ", $feature->end, "\n"; } } =head1 DESCRIPTION AnalysisParserI is a interface for describing generic analysis result parsers. This module makes no assumption about the nature of analysis being parsed, only that zero or more result sets can be obtained from the input source. This module was derived from Bio::SeqAnalysisParserI, the differences being =over 4 =item 1. next_feature() was replaced with next_result(). Instead of flattening a stream containing potentially multiple analysis results into a single set of features, AnalysisParserI segments the stream in terms of analysis result sets (Bio::AnalysisResultI objects). Each AnalysisResultI can then be queried for its features (if any) as well as other information about the result =item 2. AnalysisParserI is a pure interface. It does not inherit from Bio::Root::RootI and does not provide a new() method. Implementations are free to choose how to implement it. =back =head2 Rationale (copied from Bio::SeqAnalysisParserI) The concept behind this interface is to have a generic interface in sequence annotation pipelines (as used e.g. in high-throughput automated sequence annotation). This interface enables plug-and-play for new analysis methods and their corresponding parsers without the necessity for modifying the core of the annotation pipeline. In this concept the annotation pipeline has to rely on only a list of methods for which to process the results, and a factory from which it can obtain the corresponding parser implementing this interface. =head2 TODO Create Bio::Factory::AnalysisParserFactoryI and Bio::Factory::AnalysisParserFactory for interface and an implementation. Note that this factory could return Bio::SearchIO-derived objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Steve Chervitz, Jason Stajich, Hilmar Lapp Email sac@bioperl.org Authors of Bio::SeqAnalysisParserI on which this module is based: Email jason@bioperl.org Email hlapp@gmx.net =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::AnalysisParserI; use strict; use base qw(Bio::Root::RootI); =head2 next_result Title : next_result Usage : $result = $obj->next_result(); Function: Returns the next result available from the input, or undef if there are no more results. Example : Returns : A Bio::Search::Result::ResultI implementing object, or undef if there are no more results. Args : none =cut sub next_result { my ($self); $self->throw_not_implemented; } 1; __END__ NOTE (sac): My ten-month old son Russell added the following line. It doesn't look like it will compile so I'm putting it here: mt6 j7qa BioPerl-1.6.923/Bio/AnalysisResultI.pm000444000765000024 1454312254227314 17627 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::AnalysisResultI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # Derived from Bio::Tools::AnalysisResult by Hilmar Lapp # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::AnalysisResultI - Interface for analysis result objects =head1 SYNOPSIS Bio::AnalysisResultI defines an interface that must be implemented by a subclass. So you cannot create Bio::AnalysisResultI objects, only objects that inherit from Bio::AnalysisResultI. =head1 DESCRIPTION The AnalysisResultI module provides an interface for modules encapsulating the result of an analysis that was carried out with a query sequence and an optional subject dataset. The notion of an analysis represented by this base class is that of a unary or binary operator, taking either one query or a query and a subject and producing a result. The query is e.g. a sequence, and a subject is either a sequence, too, or a database of sequences. This interface defines methods to access analysis result data and does not impose any constraints on how the analysis result data is acquired. Note that this module does not provide support for B an analysis. Rather, it is positioned in the subsequent parsing step (concerned with turning raw results into BioPerl objects). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Steve Chervitz, Hilmar Lapp Email sac@bioperl.org Email hlapp@gmx.net (author of Bio::Tools::AnalysisResult on which this module is based) =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AnalysisResultI; use strict; use base qw(Bio::Root::RootI); =head2 analysis_query Usage : $query_obj = $result->analysis_query(); Purpose : Get a Bio::PrimarySeqI-compatible object representing the entity on which the analysis was performed. Lacks sequence information. Argument : n/a Returns : A Bio::PrimarySeqI-compatible object without sequence information. The sequence will have display_id, description, moltype, and length data. =cut #--------------------- sub analysis_query { #--------------------- my ($self) = @_; $self->throw_not_implemented; } =head2 analysis_subject Usage : $obj = $result->analyis_subject(); Purpose : Get the subject of the analysis against which it was performed. For similarity searches it will probably be a database, and for sequence feature predictions (exons, promoters, etc) it may be a collection of models or homologous sequences that were used, or undefined. Returns : An object of a type the depends on the implementation May also return undef for analyses that don\'t involve subjects. Argument : n/a Comments : Implementation of this method is optional. AnalysisResultI provides a default behavior of returning undef. =cut #--------------- sub analysis_subject { #--------------- my ($self) = @_; return; } =head2 analysis_subject_version Usage : $vers = $result->analyis_subject_version(); Purpose : Get the version string of the subject of the analysis. Returns : String or undef for analyses that don\'t involve subjects. Argument : n/a Comments : Implementation of this method is optional. AnalysisResultI provides a default behavior of returning undef. =cut #--------------- sub analysis_subject_version { #--------------- my ($self) = @_; return; } =head2 analysis_date Usage : $date = $result->analysis_date(); Purpose : Get the date on which the analysis was performed. Returns : String Argument : n/a =cut #--------------------- sub analysis_date { #--------------------- my ($self) = @_; $self->throw_not_implemented; } =head2 analysis_method Usage : $meth = $result->analysis_method(); Purpose : Get the name of the sequence analysis method that was used to produce this result (BLASTP, FASTA, etc.). May also be the actual name of a program. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self) = @_; $self->throw_not_implemented; } =head2 analysis_method_version Usage : $vers = $result->analysis_method_version(); Purpose : Get the version string of the analysis program. : (e.g., 1.4.9MP, 2.0a19MP-WashU). Returns : String Argument : n/a =cut #--------------------- sub analysis_method_version { #--------------------- my ($self) = @_; $self->throw_not_implemented; } =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut #--------------------- sub next_feature { #--------------------- my ($self); $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/AnnotatableI.pm000444000765000024 544112254227334 17054 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AnnotatableI # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AnnotatableI - the base interface an annotatable object must implement =head1 SYNOPSIS use Bio::SeqIO; # get an annotatable object somehow: for example, Bio::SeqI objects # are annotatable my $seqio = Bio::SeqIO->new(-fh => \*STDIN, -format => 'genbank'); while (my $seq = $seqio->next_seq()) { # $seq is-a Bio::AnnotatableI, hence: my $ann_coll = $seq->annotation(); # $ann_coll is-a Bio::AnnotationCollectionI, hence: my @all_anns = $ann_coll->get_Annotations(); # do something with the annotation objects } =head1 DESCRIPTION This is the base interface that all annotatable objects must implement. A good example is Bio::Seq which is an AnnotableI object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Hilmar Lapp Ehlapp@gmx.netE Allen Day Eallenday@ucla.eduE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AnnotatableI; use strict; use base qw(Bio::Root::RootI); =head2 annotation Title : annotation Usage : $obj->annotation($newval) Function: Get the annotation collection for this annotatable object. Example : Returns : a Bio::AnnotationCollectionI implementing object, or undef Args : on set, new value (a Bio::AnnotationCollectionI implementing object, optional) (an implementation may not support changing the annotation collection) See L =cut sub annotation{ shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/AnnotationCollectionI.pm000444000765000024 1457212254227327 21001 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AnnotationCollectionI # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AnnotationCollectionI - Interface for annotation collections =head1 SYNOPSIS # get an AnnotationCollectionI somehow, eg $ac = $seq->annotation(); foreach $key ( $ac->get_all_annotation_keys() ) { @values = $ac->get_Annotations($key); foreach $value ( @values ) { # value is an Bio::AnnotationI, and defines a "as_text" method print "Annotation ",$key," stringified value ",$value->as_text,"\n"; # also defined hash_tree method, which allows data orientated # access into this object $hash = $value->hash_tree(); } } =head1 DESCRIPTION Annotation Collections are a way of storing a series of "interesting facts" about something. We call an "interesting fact" in Bioperl an Annotation (this differs from a Sequence Feature, which is called a Sequence Feature and may or may not have an Annotation Collection). A benefit of this approach is that all sorts of simple, interesting observations can be collected, the possibility is endless. The Bioperl approach is that the "interesting facts" are represented by Bio::AnnotationI objects. The interface Bio::AnnotationI guarantees two methods $obj->as_text(); # string formated to display to users and $obj->hash_tree(); # hash with defined rules for data-orientated discovery The hash_tree method is designed to play well with XML output and other "nested-tag-of-data-values", think BoulderIO and/or Ace stuff. For more information see L. Annotations are stored in AnnotationCollections, each Annotation under a different "tag". The tags allow simple discovery of the available annotations, and in some cases (like the tag "gene_name") indicate how to interpret the data underneath the tag. The tag is only one tag deep and each tag can have an array of values. In addition, AnnotationCollections are guaranteed to maintain consistent types of objects under each tag - at least that each object complies to one interface. The "standard" AnnotationCollection insists the following rules are set up: Tag Object --- ------ comment Bio::Annotation::Comment dblink Bio::Annotation::DBLink description Bio::Annotation::SimpleValue gene_name Bio::Annotation::SimpleValue ontology_term Bio::Annotation::OntologyTerm reference Bio::Annotation::Reference These tags are the implict tags that the SeqIO system needs to round-trip GenBank/EMBL/Swissprot. However, you as a user and us collectively as a community can grow the "standard" tag mapping over time and specifically for a particular area. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AnnotationCollectionI; use strict; # Interface preamble - inherits from Bio::Root::RootI use base qw(Bio::Root::RootI); =head1 ACCESSOR METHODS Use these for Bio::AnnotationI object access. =cut =head2 get_all_annotation_keys() Usage : $ac->get_all_annotation_keys() Function: gives back a list of annotation keys, which are simple text strings Returns : list of strings Args : none =cut sub get_all_annotation_keys{ shift->throw_not_implemented(); } =head2 get_Annotations() Usage : my @annotations = $collection->get_Annotations('key') Function: Retrieves all the Bio::AnnotationI objects for a specific key Returns : list of Bio::AnnotationI - empty if no objects stored for a key Args : string which is key for annotations =cut sub get_Annotations{ shift->throw_not_implemented(); } =head2 add_Annotation() Usage : $self->add_Annotation('reference',$object); $self->add_Annotation($object,'Bio::MyInterface::DiseaseI'); $self->add_Annotation($object); $self->add_Annotation('disease',$object,'Bio::MyInterface::DiseaseI'); Function: Adds an annotation for a specific key. If the key is omitted, the object to be added must provide a value via its tagname(). If the archetype is provided, this and future objects added under that tag have to comply with the archetype and will be rejected otherwise. Returns : none Args : annotation key ('disease', 'dblink', ...) object to store (must be Bio::AnnotationI compliant) [optional] object archetype to map future storage of object of these types to =cut sub add_Annotation { shift->throw_not_implemented(); } =head2 remove_Annotations() Usage : Function: Remove the annotations for the specified key from this collection. Returns : an list of Bio::AnnotationI compliant objects which were stored under the given key(s) Args : the key(s) (tag name(s), one or more strings) for which to remove annotations (optional; if none given, flushes all annotations) =cut sub remove_Annotations{ shift->throw_not_implemented(); } =head2 get_num_of_annotations() Usage : my $count = $collection->get_num_of_annotations() Function: Returns the count of all annotations stored in this collection Returns : integer Args : none =cut sub get_num_of_annotations{ shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/AnnotationI.pm000444000765000024 1265312254227332 16757 0ustar00cjfieldsstaff000000000000 # # BioPerl module for Bio::AnnotationI # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AnnotationI - Annotation interface =head1 SYNOPSIS # generally you get AnnotationI's from AnnotationCollectionI's foreach $key ( $ac->get_all_annotation_keys() ) { @values = $ac->get_Annotations($key); foreach $value ( @values ) { # value is an Bio::AnnotationI, and defines a "as_text" method print "Annotation ",$key," stringified value ",$value->as_text,"\n"; # you can also use a generic hash_tree method for getting # stuff out say into XML format $hash_tree = $value->hash_tree(); } } =head1 DESCRIPTION Interface all annotations must support. There are two things that each annotation has to support. $annotation->as_text() Annotations have to support an "as_text" method. This should be a single text string, without newlines representing the annotation, mainly for human readability. It is not aimed at being able to store/represent the annotation. The second method allows annotations to at least attempt to represent themselves as pure data for storage/display/whatever. The method hash_tree $hash = $annotation->hash_tree(); should return an anonymous hash with "XML-like" formatting. The formatting is as follows. (1) For each key in the hash, if the value is a reference'd array - (2) For each element of the array if the value is a object - Assume the object has the method "hash_tree"; (3) else if the value is a referene to a hash Recurse again from point (1) (4) else Assumme the value is a scalar, and handle it directly as text (5) else (if not an array) apply rules 2,3 and 4 to value The XML path in tags is represented by the keys taken in the hashes. When arrays are encountered they are all present in the path level of this tag This is a pretty "natural" representation of an object tree in an XML style, without forcing everything to inheriet off some super-generic interface for representing things in the hash. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::AnnotationI; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::RootI); =head2 as_text Title : as_text Usage : Function: single text string, without newlines representing the annotation, mainly for human readability. It is not aimed at being able to store/represent the annotation. Example : Returns : a string Args : none =cut sub as_text{ shift->throw_not_implemented(); } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for the specific implementation. Implementations should allow passing a callback as an argument which allows custom text generation; the callback will be passed the current implementation. Note that this is meant to be used as a simple representation of the annotation data but probably shouldn't be used in cases where more complex comparisons are needed or where data is stored. Example : Returns : a string Args : [optional] callback =cut sub display_text { shift->throw_not_implemented(); } =head2 hash_tree Title : hash_tree Usage : Function: should return an anonymous hash with "XML-like" formatting Example : Returns : a hash reference Args : none =cut sub hash_tree{ shift->throw_not_implemented(); } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/ClusterI.pm000444000765000024 1011412254227313 16253 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::ClusterI # # Please direct questions and support issues to # # Cared for by Shawn Hoon # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::ClusterI - Cluster Interface =head1 SYNOPSIS # see the implementations of this interface for details my $cluster= $cluster->new(-description=>"POLYUBIQUITIN", -members =>[$seq1,$seq2]); my @members = $cluster->get_members(); my @sub_members = $cluster->get_members(-species=>"homo sapiens"); =head1 DESCRIPTION This interface is the basic structure for a cluster of bioperl objects. In this case it is up to the implementer to check arguments and initialize whatever new object the implementing class is designed for. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::ClusterI; use strict; use base qw(Bio::Root::RootI); =head1 Implementation Specific Functions These functions are the ones that a specific implementation must define. =head2 new We don't mandate but encourage implementors to support at least the following named parameters upon object initialization. Argument Description -------- ----------- -display_id the display ID or name for the cluster -description the consensus description or name of the cluster -members the array of objects belonging to the family =cut =head2 display_id Title : display_id Usage : Function: Get the display name or identifier for the cluster Returns : a string Args : =cut sub display_id{ shift->throw_not_implemented(); } =head2 description Title : description Usage : Bio::ClusterI->description("POLYUBIQUITIN") Function: get/set for the consensus description of the cluster Returns : the description string Args : Optional the description string =cut sub description{ shift->throw_not_implemented(); } =head2 size Title : size Usage : Bio::ClusterI->size(); Function: get/set for the size of the family, calculated from the number of members Returns : the size of the family Args : =cut sub size { shift->throw_not_implemented(); } =head2 cluster_score Title : cluster_score Usage : $cluster ->cluster_score(100); Function: get/set for cluster_score which represent the score in which the clustering algorithm assigns to this cluster. Returns : a number =cut sub cluster_score{ shift->throw_not_implemented(); } =head2 get_members Title : get_members Usage : Bio::ClusterI->get_members(($seq1, $seq2)); Function: retrieve the members of the family by some criteria, for example : $cluster->get_members(-species => 'homo sapiens'); Will return all members if no criteria are provided. Returns : the array of members Args : =cut sub get_members { shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/ClusterIO.pm000444000765000024 1743712254227326 16415 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::ClusterIO.pm # # Please direct questions and support issues to # # Cared for by Andrew Macgregor # # Copyright Andrew Macgregor, Jo-Ann Stanton, David Green # Molecular Embryology Group, Anatomy & Structural Biology, University of Otago # http://anatomy.otago.ac.nz/meg # # You may distribute this module under the same terms as perl itself # # _history # # May 7, 2002 - changed from UniGene.pm to more generic ClusterIO.pm # by Andrew Macgregor # # April 17, 2002 - Initial implementation by Andrew Macgregor # POD documentation - main docs before the code =head1 NAME Bio::ClusterIO - Handler for Cluster Formats =head1 SYNOPSIS #NB: This example is unigene specific use Bio::ClusterIO; $stream = Bio::ClusterIO->new('-file' => "Hs.data", '-format' => "unigene"); # note: we quote -format to keep older perl's from complaining. while ( my $in = $stream->next_cluster() ) { print $in->unigene_id() . "\n"; while ( my $sequence = $in->next_seq() ) { print $sequence->accession_number() . "\n"; } } # Parsing errors are printed to STDERR. =head1 DESCRIPTION The ClusterIO module works with the ClusterIO format module to read various cluster formats such as NCBI UniGene. =head1 CONSTRUCTORS =head2 Bio::ClusterIO-Enew() $str = Bio::ClusterIO->new(-file => 'filename', -format=>$format); The new() class method constructs a new Bio::ClusterIO object. The returned object can be used to retrieve or print cluster objects. new() accepts the following parameters: =over 4 =item -file A file path to be opened for reading. =item -format Specify the format of the file. Supported formats include: unigene *.data UniGene build files. dbsnp *.xml dbSNP XML files If no format is specified and a filename is given, then the module will attempt to deduce it from the filename. If this is unsuccessful, the main UniGene build format is assumed. The format name is case insensitive. 'UNIGENE', 'UniGene' and 'unigene' are all supported, as are dbSNP, dbsnp, and DBSNP =back =head1 OBJECT METHODS See below for more detailed summaries. The main methods are: =head2 $cluster = $str-Enext_cluster() Fetch the next cluster from the stream. =head2 TIEHANDLE(), READLINE(), PRINT() These I've left in here because they were in the SeqIO module. Feedback appreciated. There they provide the tie interface. See L for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Andrew Macgregor Email andrew@anatomy.otago.ac.nz =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::ClusterIO; use strict; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : Bio::ClusterIO->new(-file => $filename, -format => 'format') Function: Returns a new cluster stream Returns : A Bio::ClusterIO::Handler initialised with the appropriate format Args : -file => $filename -format => format =cut my $entry = 0; sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::ClusterIO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{-file} || $ARGV[0] ); $format = "\L$format"; # normalize capitalization to lower case return unless( $class->_load_format_module($format) ); return "Bio::ClusterIO::$format"->new(@args); } } =head2 format Title : format Usage : $format = $stream->format() Function: Get the cluster format Returns : cluster format Args : none =cut # format() method inherited from Bio::Root::IO # _initialize is chained for all ClusterIO classes sub _initialize { my($self, @args) = @_; # initialize the IO part $self->_initialize_io(@args); } =head2 next_cluster Title : next_cluster Usage : $cluster = $stream->next_cluster() Function: Reads the next cluster object from the stream and returns it. Returns : a L compliant object Args : none =cut sub next_cluster { my ($self, $seq) = @_; $self->throw("Sorry, you cannot read from a generic Bio::ClusterIO object."); } =head2 cluster_factory Title : cluster_factory Usage : $obj->cluster_factory($newval) Function: Get/set the object factory to use for creating the cluster objects. Example : Returns : a L compliant object Args : on set, new value (a L compliant object or undef, optional) =cut sub cluster_factory{ my $self = shift; return $self->{'cluster_factory'} = shift if @_; return $self->{'cluster_factory'}; } =head2 object_factory Title : object_factory Usage : $obj->object_factory($newval) Function: This is an alias to cluster_factory with a more generic name. Example : Returns : a L compliant object Args : on set, new value (a L compliant object or undef, optional) =cut sub object_factory{ return shift->cluster_factory(@_); } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL ClusterIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::ClusterIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Function: guess format based on file suffix Example : Returns : guessed format of filename (lower case) Args : Notes : formats that _filehandle() will guess include unigene and dbsnp =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'unigene' if /\.(data)$/i; return 'dbsnp' if /\.(xml)$/i; } sub DESTROY { my $self = shift; $self->close(); } # I need some direction on these!! The module works so I haven't fiddled with them! sub TIEHANDLE { my ($class,$val) = @_; return bless {'seqio' => $val}, $class; } sub READLINE { my $self = shift; return $self->{'seqio'}->next_seq() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'seqio'}->next_seq(); return @list; } sub PRINT { my $self = shift; $self->{'seqio'}->write_seq(@_); } 1; BioPerl-1.6.923/Bio/DasI.pm000444000765000024 3273012254227322 15351 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DasI # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DasI - DAS-style access to a feature database =head1 SYNOPSIS # Open up a feature database somehow... $db = Bio::DasI->new(@args); @segments = $db->segment(-name => 'NT_29921.4', -start => 1, -end => 1000000); # segments are Bio::Das::SegmentI - compliant objects # fetch a list of features @features = $db->features(-type=>['type1','type2','type3']); # invoke a callback over features $db->features(-type=>['type1','type2','type3'], -callback => sub { ... } ); $stream = $db->get_seq_stream(-type=>['type1','type2','type3']); while (my $feature = $stream->next_seq) { # each feature is a Bio::SeqFeatureI-compliant object } # get all feature types @types = $db->types; # count types %types = $db->types(-enumerate=>1); @feature = $db->get_feature_by_name($class=>$name); @feature = $db->get_feature_by_target($target_name); @feature = $db->get_feature_by_attribute($att1=>$value1,$att2=>$value2); $feature = $db->get_feature_by_id($id); $error = $db->error; =head1 DESCRIPTION Bio::DasI is a simplified alternative interface to sequence annotation databases used by the distributed annotation system (see L). In this scheme, the genome is represented as a series of features, a subset of which are named. Named features can be used as reference points for retrieving "segments" (see L), and these can, in turn, be used as the basis for exploring the genome further. In addition to a name, each feature has a "class", which is essentially a namespace qualifier and a "type", which describes what type of feature it is. Das uses the GO consortium's ontology of feature types, and so the type is actually an object of class Bio::Das::FeatureTypeI (see L). Bio::DasI provides methods for interrogating the database for the types it contains and the counts of each type. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::DasI; use strict; use Bio::Das::SegmentI; # Object preamble - inherits from Bio::Root::Root; use base qw(Bio::Root::RootI Bio::SeqFeature::CollectionI); =head2 new Title : new Usage : Bio::DasI->new(@args) Function: Create new Bio::DasI object Returns : a Bio::DasI object Args : see below The new() method creates a new object. The argument list is either a single argument consisting of a connection string, or the following list of -name=Evalue arguments: Argument Description -------- ----------- -dsn Connection string for database -adaptor Name of an adaptor class to use when connecting -aggregator Array ref containing list of aggregators "semantic mappers" to apply to database -user Authentication username -pass Authentication password Implementors of DasI may add other arguments. =cut sub new {shift->throw_not_implemented} =head2 types Title : types Usage : $db->types(@args) Function: return list of feature types in database Returns : a list of Bio::Das::FeatureTypeI objects Args : see below This routine returns a list of feature types known to the database. It is also possible to find out how many times each feature occurs. Arguments are -option=Evalue pairs as follows: -enumerate if true, count the features The returned value will be a list of Bio::Das::FeatureTypeI objects (see L. If -enumerate is true, then the function returns a hash (not a hash reference) in which the keys are the stringified versions of Bio::Das::FeatureTypeI and the values are the number of times each feature appears in the database. =cut sub types { shift->throw_not_implemented; } =head2 parse_types Title : parse_types Usage : $db->parse_types(@args) Function: parses list of types Returns : an array ref containing ['method','source'] pairs Args : a list of types in 'method:source' form Status : internal This method takes an array of type names in the format "method:source" and returns an array reference of ['method','source'] pairs. It will also accept a single argument consisting of an array reference with the list of type names. =cut # turn feature types in the format "method:source" into a list of [method,source] refs sub parse_types { my $self = shift; return [] if !@_ or !defined($_[0]); return $_[0] if ref $_[0] eq 'ARRAY' && ref $_[0][0]; my @types = ref($_[0]) ? @{$_[0]} : @_; my @type_list = map { [split(':',$_,2)] } @types; return \@type_list; } =head2 segment Title : segment Usage : $db->segment(@args); Function: create a segment object Returns : segment object(s) Args : see below This method generates a Bio::Das::SegmentI object (see L). The segment can be used to find overlapping features and the raw sequence. When making the segment() call, you specify the ID of a sequence landmark (e.g. an accession number, a clone or contig), and a positional range relative to the landmark. If no range is specified, then the entire region spanned by the landmark is used to generate the segment. Arguments are -option=Evalue pairs as follows: -name ID of the landmark sequence. -class A namespace qualifier. It is not necessary for the database to honor namespace qualifiers, but if it does, this is where the qualifier is indicated. -version Version number of the landmark. It is not necessary for the database to honor versions, but if it does, this is where the version is indicated. -start Start of the segment relative to landmark. Positions follow standard 1-based sequence rules. If not specified, defaults to the beginning of the landmark. -end End of the segment relative to the landmark. If not specified, defaults to the end of the landmark. The return value is a list of Bio::Das::SegmentI objects. If the method is called in a scalar context and there are no more than one segments that satisfy the request, then it is allowed to return the segment. Otherwise, the method must throw a "multiple segment exception". =cut #' sub segment { shift->throw_not_implemented } =head2 features Title : features Usage : $db->features(@args) Function: get all features, possibly filtered by type Returns : a list of Bio::SeqFeatureI objects Args : see below Status : public This routine will retrieve features in the database regardless of position. It can be used to return all features, or a subset based on their type Arguments are -option=Evalue pairs as follows: -types List of feature types to return. Argument is an array of Bio::Das::FeatureTypeI objects or a set of strings that can be converted into FeatureTypeI objects. -callback A callback to invoke on each feature. The subroutine will be passed each Bio::SeqFeatureI object in turn. -attributes A hash reference containing attributes to match. The -attributes argument is a hashref containing one or more attributes to match against: -attributes => { Gene => 'abc-1', Note => 'confirmed' } Attribute matching is simple exact string matching, and multiple attributes are ANDed together. See L for a more sophisticated take on this. If one provides a callback, it will be invoked on each feature in turn. If the callback returns a false value, iteration will be interrupted. When a callback is provided, the method returns undef. =cut sub features { shift->throw_not_implemented } =head2 get_feature_by_name Title : get_feature_by_name Usage : $db->get_feature_by_name(-class=>$class,-name=>$name) Function: fetch features by their name Returns : a list of Bio::SeqFeatureI objects Args : the class and name of the desired feature Status : public This method can be used to fetch named feature(s) from the database. The -class and -name arguments have the same meaning as in segment(), and the method also accepts the following short-cut forms: 1) one argument: the argument is treated as the feature name 2) two arguments: the arguments are treated as the class and name (note: this uses _rearrange() so the first argument must not begin with a hyphen or it will be interpreted as a named argument). This method may return zero, one, or several Bio::SeqFeatureI objects. The implementor may allow the name to contain wildcards, in which case standard C-shell glob semantics are expected. =cut sub get_feature_by_name { shift->throw_not_implemented(); } =head2 get_feature_by_target Title : get_feature_by_target Usage : $db->get_feature_by_target($class => $name) Function: fetch features by their similarity target Returns : a list of Bio::SeqFeatureI objects Args : the class and name of the desired feature Status : public This method can be used to fetch a named feature from the database based on its similarity hit. The arguments are the same as get_feature_by_name(). If this is not implemented, the interface defaults to using get_feature_by_name(). =cut sub get_feature_by_target { shift->get_feature_by_name(@_); } =head2 get_feature_by_id Title : get_feature_by_id Usage : $db->get_feature_by_target($id) Function: fetch a feature by its ID Returns : a Bio::SeqFeatureI objects Args : the ID of the feature Status : public If the database provides unique feature IDs, this can be used to retrieve a single feature from the database. If not overridden, this interface calls get_feature_by_name() and returns the first element. =cut sub get_feature_by_id { (shift->get_feature_by_name(@_))[0]; } =head2 get_feature_by_attribute Title : get_feature_by_attribute Usage : $db->get_feature_by_attribute(attribute1=>value1,attribute2=>value2) Function: fetch features by combinations of attribute values Returns : a list of Bio::SeqFeatureI objects Args : the class and name of the desired feature Status : public This method can be used to fetch a set of features from the database. Attributes are a list of name=Evalue pairs. They will be logically ANDed together. If an attribute value is an array reference, the list of values in the array is treated as an alternative set of values to be ORed together. =cut sub get_feature_by_attribute { shift->throw_not_implemented(); } =head2 search_notes Title : search_notes Usage : $db->search_notes($search_term,$max_results) Function: full-text search on features, ENSEMBL-style Returns : an array of [$name,$description,$score] Args : see below Status : public This routine performs a full-text search on feature attributes (which attributes depend on implementation) and returns a list of [$name,$description,$score], where $name is the feature ID, $description is a human-readable description such as a locus line, and $score is the match strength. Since this is a decidedly non-standard thing to do (but the generic genome browser uses it), the default method returns an empty list. You do not have to implement it. =cut sub search_notes { return } =head2 get_seq_stream Title : get_seq_stream Usage : $seqio = $db->get_seq_stream(@args) Function: Performs a query and returns an iterator over it Returns : a Bio::SeqIO stream capable of returning Bio::SeqFeatureI objects Args : As in features() Status : public This routine takes the same arguments as features(), but returns a Bio::SeqIO::Stream-compliant object. Use it like this: $stream = $db->get_seq_stream('exon'); while (my $exon = $stream->next_seq) { print $exon,"\n"; } NOTE: In the interface this method is aliased to get_feature_stream(), as the name is more descriptive. =cut sub get_seq_stream { shift->throw_not_implemented } sub get_feature_stream {shift->get_seq_stream(@_) } =head2 refclass Title : refclass Usage : $class = $db->refclass Function: returns the default class to use for segment() calls Returns : a string Args : none Status : public For data sources which use namespaces to distinguish reference sequence accessions, this returns the default namespace (or "class") to use. This interface defines a default of "Accession". =cut sub refclass { "Accession" } 1; BioPerl-1.6.923/Bio/DBLinkContainerI.pm000444000765000024 541612254227324 17573 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DBLinkContainerI # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DBLinkContainerI - Abstract interface for any object wanting to use database cross references =head1 SYNOPSIS # get an objects containing database cross reference foreach $obj ( @objs ) { if( $obj->isa('Bio::DBLinkContainerI') ) { foreach $dblink ( $obj->each_DBLink() ) { # do stuff } } } =head1 DESCRIPTION This interface defines the functions one can expect for any object wanting to use database cross-references. This class does not actually provide any implementation, it just provides the definitions of what methods one can call. The database cross-references are implemented as L objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DBLinkContainerI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 each_DBLink Title : each_DBLink Usage : foreach $ref ( $self->each_DBlink() ) Function: gets an array of DBlink of objects Example : Returns : an array of Bio::Annotation::DBLink objects Args : none =cut sub each_DBLink{ my ($self) = @_; my $class = ref($self) || $self; $self->throw("Class $class did not define method 'each_DBLink' for interface DBLinkContainerI"); } 1; BioPerl-1.6.923/Bio/DescribableI.pm000444000765000024 567312254227317 17033 0ustar00cjfieldsstaff000000000000 # # This module is licensed under the same terms as Perl itself. You use, # modify, and redistribute it under the terms of the Perl Artistic License. # =head1 NAME Bio::DescribableI - interface for objects with human readable names and descriptions =head1 SYNOPSIS # to test this is a describable object $obj->isa("Bio::DescribableI") || $obj->throw("$obj does not implement the Bio::DescribableI interface"); # accessors $name = $obj->display_name(); $desc = $obj->description(); =head1 DESCRIPTION This interface describes methods expected on describable objects, ie ones which have human displayable names and descriptions =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@sanger.ac.uk =cut package Bio::DescribableI; use strict; use base qw(Bio::Root::RootI); =head1 Implementation Specific Functions These functions are the ones that a specific implementation must define. =head2 display_name Title : display_name Usage : $string = $obj->display_name() Function: A string which is what should be displayed to the user the string should have no spaces (ideally, though a cautious user of this interface would not assumme this) and should be less than thirty characters (though again, double checking this is a good idea) Returns : A scalar Status : Virtual =cut sub display_name { my ($self) = @_; $self->throw_not_implemented(); } =head2 description Title : description Usage : $string = $obj->description() Function: A text string suitable for displaying to the user a description. This string is likely to have spaces, but should not have any newlines or formatting - just plain text. The string should not be greater than 255 characters and clients can feel justified at truncating strings at 255 characters for the purposes of display Returns : A scalar Status : Virtual =cut sub description { my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/FeatureHolderI.pm000444000765000024 1614212254227313 17372 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::FeatureHolderI # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::FeatureHolderI - the base interface an object with features must implement =head1 SYNOPSIS use Bio::SeqIO; # get a feature-holding object somehow: for example, Bio::SeqI objects # have features my $seqio = Bio::SeqIO->new(-fh => \*STDIN, -format => 'genbank'); while (my $seq = $seqio->next_seq()) { # $seq is-a Bio::FeatureHolderI, hence: my @feas = $seq->get_SeqFeatures(); # each element is-a Bio::SeqFeatureI foreach my $fea (@feas) { # do something with the feature objects } } =head1 DESCRIPTION This is the base interface that all feature-holding objects must implement. Popular feature-holders are for instance L objects. Since L defines a sub_SeqFeature() method, most Bio::SeqFeatureI implementations like L will implement the feature holder interface as well. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 CONTRIBUTORS Steffen Grossmann [SG], grossman-at-molgen.mpg.de Mark A. Jensen, maj -at- fortinbras -dot- us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::FeatureHolderI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 get_SeqFeatures() Usage : @feats = $obj->get_SeqFeatures() Function: Get the feature objects held by this feature holder. Example : Returns : an array of Bio::SeqFeatureI implementing objects if tag specified, return features having that tag Args : [optional] scalar string (feature tag) =cut sub get_SeqFeatures { shift->throw_not_implemented(); } =head2 add_SeqFeature() Usage : $feat->add_SeqFeature($subfeat); $feat->add_SeqFeature($subfeat,'EXPAND') Function: Add a SeqFeature into the subSeqFeature array. with no 'EXPAND' qualifer, subfeat will be tested as to whether it lies inside the parent, and throw an exception if not. If EXPAND is used and the object implements Bio::RangeI (which is not guaranteed), the parent''s start/end/strand will be extended so that the new subFeature can be accomodated. Example : Returns : nothing Args : a Bio::SeqFeatureI object =cut sub add_SeqFeature { shift->throw_not_implemented(); } =head2 remove_SeqFeatures() Usage : $obj->remove_SeqFeatures Function: Removes all sub SeqFeatures. If you want to remove only a subset, remove that subset from the returned array, and add back the rest. Returns : The array of Bio::SeqFeatureI implementing sub-features that was deleted from this feature. Args : none =cut sub remove_SeqFeatures { shift->throw_not_implemented(); } =head2 feature_count Title : feature_count Usage : $obj->feature_count() Function: Return the number of SeqFeatures attached to a feature holder. This is before flattening a possible sub-feature tree. We provide a default implementation here that just counts the number of objects returned by get_SeqFeatures(). Implementors may want to override this with a more efficient implementation. Returns : integer representing the number of SeqFeatures Args : None At some day we may want to expand this method to allow for a feature filter to be passed in. Our default implementation allows for any number of additional arguments and will pass them on to get_SeqFeatures(). I.e., in order to support filter arguments, just support them in get_SeqFeatures(). =cut sub feature_count { return scalar(shift->get_SeqFeatures(@_)); } =head2 get_all_SeqFeatures Title : get_all_SeqFeatures Usage : Function: Get the flattened tree of feature objects held by this feature holder. The difference to get_SeqFeatures is that the entire tree of sub-features will be flattened out. We provide a default implementation here, so implementors don''t necessarily need to implement this method. Example : Returns : an array of Bio::SeqFeatureI implementing objects Args : none At some day we may want to expand this method to allow for a feature filter to be passed in. Our default implementation allows for any number of additional arguments and will pass them on to any invocation of get_SeqFeatures(), wherever a component of the tree implements FeatureHolderI. I.e., in order to support filter arguments, just support them in get_SeqFeatures(). =cut sub get_all_SeqFeatures{ my $self = shift; my @flatarr; foreach my $feat ( $self->get_SeqFeatures(@_) ){ push(@flatarr,$feat); &_add_flattened_SeqFeatures(\@flatarr,$feat,@_); } # needed to deal with subfeatures which appear more than once in the hierarchy [SG] my %seen = (); my @uniq_flatarr = (); foreach my $feat (@flatarr) { push(@uniq_flatarr, $feat) unless $seen{$feat}++; } return @uniq_flatarr; } sub _add_flattened_SeqFeatures { my ($arrayref,$feat,@args) = @_; my @subs = (); if($feat->isa("Bio::FeatureHolderI")) { @subs = $feat->get_SeqFeatures(@args); } elsif($feat->isa("Bio::SeqFeatureI")) { @subs = $feat->sub_SeqFeature(); } else { confess ref($feat)." is neither a FeatureHolderI nor a SeqFeatureI. ". "Don't know how to flatten."; } foreach my $sub (@subs) { push(@$arrayref,$sub); &_add_flattened_SeqFeatures($arrayref,$sub); } } sub set_ParentIDs_from_hierarchy(){ # DEPRECATED - use IDHandler my $self = shift; require "Bio/SeqFeature/Tools/IDHandler.pm"; Bio::SeqFeature::Tools::IDHandler->new->set_ParentIDs_from_hierarchy($self); } sub create_hierarchy_from_ParentIDs(){ # DEPRECATED - use IDHandler my $self = shift; require "Bio/SeqFeature/Tools/IDHandler.pm"; Bio::SeqFeature::Tools::IDHandler->new->create_hierarchy_from_ParentIDs($self); } 1; BioPerl-1.6.923/Bio/HandlerBaseI.pm000444000765000024 1651412254227317 17020 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::HandlerI # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::HandlerBaseI - Interface class for handler methods which interact with any event-driven parsers (drivers). =head1 SYNOPSIS # MyHandler is a Bio::HandlerBaseI-derived class for dealing with GenBank # sequence data, derived from a GenBank event-driven parser # inside a parser (driver) constructor $self->seqhandler($handler || MyHandler->new(-format => 'genbank')); # in the driver parsing method ( such as next_seq() ) ... $handler = $self->seqhandler(); # roll data up into hashref chunks, pass off into Handler for processing... $hobj->data_handler($data); # or retrieve Handler methods and pass data directly to Handler methods my $hmeth = $hobj->handler_methods; if ($hmeth->{ $data->{NAME} }) { my $mth = $hmeth->{ $data->{NAME} }; # code ref $hobj->$mth($data); } =head1 DESCRIPTION This interface describes simple class methods used for processing data from an event-based parser (a driver). This is similar in theme to an XML SAX-based driver but differs in that one can optionally pass related data semi-intelligently as chunks (defined in a hash reference) vs. passing as single data elements in a stream. For instance, any reference-related and species-related data as well as individual sequence features could be passed as chunks of data to be processed in part or as a whole (from Data::Dumper output): Annotation Data (References): $VAR1 = { 'NAME' => 'REFERENCE', 'DATA' => '1 (bases 1 to 10001)' 'AUTHORS' => 'International Human Genome Sequencing Consortium.' 'TITLE' => 'The DNA sequence of Homo sapiens' 'JOURNAL' => 'Unpublished (2003)' }; Sequence features (source seqfeature): $VAR1 = { 'mol_type' => 'genomic DNA', 'LOCATION' => '<1..>10001', 'NAME' => 'FEATURES', 'FEATURE_KEY' => 'source', 'note' => 'Accession AL451081 sequenced by The Sanger Centre', 'db_xref' => 'taxon:9606', 'clone' => 'RP11-302I18', 'organism' => 'Homo sapiens' }; These would be 'handled' accordingly by methods specified in a HandlerI-based class. The data in a chunk is intentionally left vague here since this may vary from implementation to implementation and can be somewhat open to interpretation. A data chunk in a sequence record, for instance, will be different than a data chunk in a BLAST report. This also allows one the flexibility to pass data as more XML-like small bits, as huge chunks, or even as indexed locations in a file (such as when using a "pull" parser, like a Bio::PullParserI). For an sequence-based implementation see Bio::SeqIO::RichSeq::GenericRichSeqHandler, which handles any GenBank, UniProt, and EMBL data from their respective driver modules (Bio::SeqIO::gbdriver, Bio::SeqIO::swissdriver, and Bio::SeqIO::embldriver). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::HandlerBaseI; use strict; use warnings; use base qw(Bio::Root::RootI); my %HANDLERS = ('foo' => \&noop); =head2 data_handler Title : data_handler Usage : $handler->data_handler($data) Function: Centralized method which accepts all data chunks, then distributes to the appropriate methods for processing based on the chunk name from within the HandlerBaseI object. One can also use Returns : None Args : an hash ref containing a data chunk. =cut sub data_handler { shift->throw_not_implemented } =head2 handler_methods Title : handler_methods Usage : $handler->handler_methods('GenBank') %handlers = $handler->handler_methods(); Function: Retrieve the handler methods used for the current format() in the handler. This assumes the handler methods are already described in the HandlerI-implementing class. Returns : a hash reference with the data type handled and the code ref associated with it. Args : [optional] String representing the sequence format. If set here this will also set sequence_format() Throws : On unimplemented sequence format in %HANDLERS =cut sub handler_methods { shift->throw_not_implemented } =head2 format Title : format Usage : $handler->format('GenBank') $handler->format('BLAST') Function: Get/Set the format for the report/record being parsed. This can be used to set handlers in classes which are capable of processing similar data chunks from multiple driver modules. Returns : String with the sequence format Args : [optional] String with the sequence format Note : The format may be used to set the handlers (as in the current GenericRichSeqHandler implementation) =cut sub format { shift->throw_not_implemented } =head2 get_params Title : get_params Usage : $handler->get_params('-species') Function: Convenience method used to retrieve the specified parameters from the internal parameter cache Returns : Hash ref containing parameters requested and data as key-value pairs. Note that some parameter values may be objects, arrays, etc. Args : List (array) representing the parameters requested =cut sub get_params { shift->throw_not_implemented } =head2 set_params Title : set_params Usage : $handler->set_params({ '-species' => $species, '-accession_number' => $acc }); Function: Convenience method used to set specific parameters Returns : None Args : Hash ref containing the data to be passed as key-value pairs =cut sub set_params { shift->throw_not_implemented } =head2 reset_parameters Title : reset_parameters Usage : $handler->reset_parameters() Function: Resets the internal cache of data (normally object parameters for a builder or factory) Returns : None Args : None =cut sub reset_parameters { shift->throw_not_implemented } 1; BioPerl-1.6.923/Bio/IdCollectionI.pm000444000765000024 514012254227327 17172 0ustar00cjfieldsstaff000000000000 # # This module is licensed under the same terms as Perl itself. You use, # modify, and redistribute it under the terms of the Perl Artistic License. # =head1 NAME Bio::IdCollectionI - interface for objects with multiple identifiers =head1 SYNOPSIS # to test this is an identifiable collection object $obj->isa("Bio::IdCollectionI") || $obj->throw("$obj does not implement the Bio::IdCollectionI interface"); # accessors @authorities = $obj->id_authorities(); @ids = $obj->ids(); $id = $obj->ids($authority); =head1 DESCRIPTION This interface describes methods expected on objects that have multiple identifiers, each of which is controlled by a different authority. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =cut package Bio::IdCollectionI; use strict; use base qw(Bio::Root::RootI); =head1 Implementation Specific Functions These functions are the ones that a specific implementation must define. =head2 id_authorities Title : id_authorities Usage : @array = $obj->id_authorities() Function: Return the authorities which have names for this object. The authorities can then be used to select ids. Returns : An array Status : Virtual =cut sub id_authorities { my ($self) = @_; $self->throw_not_implemented(); } =head2 ids Title : ids Usage : @ids = $obj->ids([$authority1,$authority2...]) Function: return a list of Bio::IdentifiableI objects, optionally filtered by the list of authorities. Returns : A list of Bio::IdentifiableI objects. Status : Virtual =cut sub ids { my ($self) = @_; my @authorities = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/IdentifiableI.pm000444000765000024 1204712254227321 17217 0ustar00cjfieldsstaff000000000000# # This module is licensed under the same terms as Perl itself. You use, # modify, and redistribute it under the terms of the Perl Artistic License. # =head1 NAME Bio::IdentifiableI - interface for objects with identifiers =head1 SYNOPSIS # to test this is an identifiable object $obj->isa("Bio::IdentifiableI") || $obj->throw("$obj does not implement the Bio::IdentifiableI interface"); # Accessors $object_id = $obj->object_id(); $namespace = $obj->namespace(); $authority = $obj->authority(); $version = $obj->version(); # Gets authority:namespace:object_id $lsid = $obj->lsid_string(); # Gets namespace:object_id.version $ns_string = $obj->namespace_string(); =head1 DESCRIPTION This interface describes methods expected on identifiable objects, i.e. ones which have identifiers expected to make sense across a number of instances and/or domains. This interface is modeled after pretty much ubiquitous ideas for names in bioinformatics being databasename:object_id.version Example: swissprot:P012334.2 or: GO:0007048 The object will also work with LSID proposals which adds the concept of an authority, being the DNS name of the organisation assigning the namespace. See L. Helper functions are provided to make useful strings: lsid_string - string complying to the LSID standard namespace_string - string complying to the usual convention of namespace:object_id.version =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =cut package Bio::IdentifiableI; use strict; use base qw(Bio::Root::RootI); =head1 Implementation Specific Functions These functions are the ones that a specific implementation must define. =head2 object_id Title : object_id Usage : $string = $obj->object_id() Function: a string which represents the stable primary identifier in this namespace of this object. For DNA sequences this is its accession_number, similarly for protein sequences Returns : A scalar Status : Virtual =cut sub object_id { my ($self) = @_; $self->throw_not_implemented(); } =head2 version Title : version Usage : $version = $obj->version() Function: a number which differentiates between versions of the same object. Higher numbers are considered to be later and more relevant, but a single object described the same identifier should represent the same concept Returns : A number Status : Virtual =cut sub version { my ($self) = @_; $self->throw_not_implemented(); } =head2 authority Title : authority Usage : $authority = $obj->authority() Function: a string which represents the organisation which granted the namespace, written as the DNS name for organisation (eg, wormbase.org) Returns : A scalar Status : Virtual =cut sub authority { my ($self) = @_; $self->throw_not_implemented(); } =head2 namespace Title : namespace Usage : $string = $obj->namespace() Function: A string representing the name space this identifier is valid in, often the database name or the name describing the collection Returns : A scalar Status : Virtual =cut sub namespace { my ($self) = @_; $self->throw_not_implemented(); } =head1 Implementation optional functions These functions are helper functions that are provided by the interface but can be overridden if so wished =head2 lsid_string Title : lsid_string Usage : $string = $obj->lsid_string() Function: a string which gives the LSID standard notation for the identifier of interest Returns : A scalar =cut sub lsid_string { my ($self) = @_; return $self->authority.":".$self->namespace.":".$self->object_id; } =head2 namespace_string Title : namespace_string Usage : $string = $obj->namespace_string() Function: a string which gives the common notation of namespace:object_id.version Returns : A scalar =cut sub namespace_string { my ($self) = @_; return $self->namespace.":".$self->object_id . (defined($self->version()) ? ".".$self->version : ''); } 1; BioPerl-1.6.923/Bio/LocatableSeq.pm000444000765000024 5216212254227314 17072 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::LocatableSeq # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::LocatableSeq - A Bio::PrimarySeq object with start/end points on it that can be projected into a MSA or have coordinates relative to another seq. =head1 SYNOPSIS use Bio::LocatableSeq; my $seq = Bio::LocatableSeq->new(-seq => "CAGT-GGT", -id => "seq1", -start => 1, -end => 7); # a normal sequence object $locseq->seq(); $locseq->id(); # has start,end points $locseq->start(); $locseq->end(); # inherits off RangeI, so range operations possible =head1 DESCRIPTION The LocatableSeq sequence object was developed mainly because the SimpleAlign object requires this functionality, and in the rewrite of the Sequence object we had to decide what to do with this. It is, to be honest, not well integrated with the rest of bioperl. For example, the trunc() function does not return a LocatableSeq object, as some might have thought. Also, the sequence is not a Bio::SeqI, so the location is simply inherited from Bio::RangeI and is not stored in a Bio::Location. There are all sorts of nasty gotcha's about interactions between coordinate systems when these sort of objects are used. Some mapping now occurs to deal with HSP data, however it can probably be integrated in better and most methods do not implement it correctly yet. Also, several PrimarySeqI methods (subseq(), trunc(), etc.) do not behave as expected and must be used with care. Due to this, LocatableSeq functionality is to be refactored in a future BioPerl release. However, for alignment functionality it works adequately for the time being. If you do not need alignment functionality, L-implementing modules may be a suitable alternative to L. For example, L and L provide methods to attach a sequence to a specific region of a parent sequence and to set other useful attributes. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::LocatableSeq; use strict; use Bio::Location::Simple; use Bio::Location::Fuzzy; use vars qw($GAP_SYMBOLS $OTHER_SYMBOLS $FRAMESHIFT_SYMBOLS $RESIDUE_SYMBOLS $MATCHPATTERN); # The following global variables contain symbols used to represent gaps, # frameshifts, residues, and other valid symbols. These are set at compile-time; # expect scoping errors when using 'local' and resetting $MATCHPATTERN (see # LocatableSeq.t) $GAP_SYMBOLS = '\-\.=~'; $FRAMESHIFT_SYMBOLS = '\\\/'; $OTHER_SYMBOLS = '\?'; $RESIDUE_SYMBOLS = '0-9A-Za-z\*'; $MATCHPATTERN = $RESIDUE_SYMBOLS.$GAP_SYMBOLS.$FRAMESHIFT_SYMBOLS.$OTHER_SYMBOLS; use base qw(Bio::PrimarySeq Bio::RangeI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($start,$end,$strand, $mapping, $fs, $nse) = $self->_rearrange( [qw(START END STRAND MAPPING FRAMESHIFTS FORCE_NSE )], @args); $mapping ||= [1,1]; $self->mapping($mapping); $nse || 0; $self->force_nse($nse); defined $fs && $self->frameshifts($fs); defined $start && $self->start($start); defined $end && $self->end($end); defined $strand && $self->strand($strand); return $self; # success - we hope! } =head2 start Title : start Usage : $obj->start($newval) Function: Get/set the 1-based start position of this sequence in the original sequence. '0' means before the original sequence starts. Returns : value of start Args : newvalue (optional) =cut sub start { my $self = shift; if( @_ ) { my $value = shift; $self->{'start'} = $value; } return $self->{'start'} if defined $self->{'start'}; return 1 if $self->seq; return; } =head2 end Title : end Usage : $obj->end($newval) Function: Get/set the 1-based end position of this sequence in the original sequence. '0' means before the original sequence starts. Returns : value of end Args : newvalue (optional) Note : although this is a get/set, it checks passed values against the calculated end point ( derived from the sequence and based on $GAP_SYMBOLS and possible frameshifts() ). If there is no match, it will warn and set the proper value. Probably best used for debugging proper sequence calculations. =cut sub end { my $self = shift; if( @_ ) { my $value = shift; my $st = $self->start; # start of 0 usually means the sequence is all gaps but maps to # other sequences in an alignment if ($self->seq && $st != 0 ) { my $len = $self->_ungapped_len; my $calend = $st + $len - 1; my $id = $self->id || 'unknown'; if ($calend != $value) { $self->warn("In sequence $id residue count gives end value ". "$calend. \nOverriding value [$value] with value $calend for ". "Bio::LocatableSeq::end().\n".$self->seq); $value = $calend; } } $self->{'end'} = $value; } if (defined $self->{'end'}) { return $self->{'end'} } elsif ( my $len = $self->_ungapped_len) { return $len + $self->start - 1; } else { return; } } # changed 08.10.26 to return ungapped length, not the calculated end # of the sequence sub _ungapped_len { my $self = shift; return unless my $string = $self->seq; my ($map_res, $map_coord) = $self->mapping; my $offset = 0; if (my %data = $self->frameshifts) { map {$offset += $_} values %data; } $string =~ s{[$GAP_SYMBOLS$FRAMESHIFT_SYMBOLS]+}{}g; return CORE::length($string)/($map_res/$map_coord) + $offset/($map_coord/$map_res); } #sub length { # my $self = shift; # return unless my $string = $self->seq; # $string =~ s{[$GAP_SYMBOLS$FRAMESHIFT_SYMBOLS]+}{}g; # return CORE::length($string); #} =head2 strand Title : strand Usage : $obj->strand($newval) Function: return or set the strandedness Returns : the value of the strandedness (-1, 0 or 1) Args : the value of the strandedness (-1, 0 or 1) =cut sub strand { my $self = shift; if( @_ ) { my $value = shift; $self->{'strand'} = $value; } return $self->{'strand'}; } =head2 mapping Title : mapping Usage : $obj->mapping($newval) Function: return or set the mapping indices (indicates # symbols/positions in the source string mapping to # of coordinate positions) Returns : two-element array (# symbols => # coordinate pos) Args : two elements (# symbols => # coordinate pos); this can also be passed in as an array reference of the two elements (as might be passed upon Bio::LocatableSeq instantiation, for instance). =cut sub mapping { my $self = shift; if( @_ ) { my @mapping = (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; $self->throw("Must pass two values (# residues mapped to # positions)") if @mapping != 2; if ((grep {$_ != 1 && $_ != 3} @mapping) || ($mapping[0] == 3 && $mapping[1] == 3)) { $self->throw("Mapping values other than 1 or 3 are not currently supported") } $self->{'_mapping'} = \@mapping; } $self->throw('Mapping for LocatableSeq not set') if !exists $self->{'_mapping'}; return @{ $self->{'_mapping'} }; } =head2 frameshifts Title : frameshifts Usage : $obj->frameshifts($newval) Function: get/set the frameshift hash, which contains sequence positions as keys and the shift (-2, -1, 1, 2) as the value Returns : hash Args : hash or hash reference =cut sub frameshifts { my $self = shift; if( @_ ) { if (ref $_[0] eq 'HASH') { $self->{_frameshifts} = $_[0]; } else { # assume this is a full list to be converted to a hash $self->{_frameshifts} = \%{@_} # coerce into hash ref } } (defined $self->{_frameshifts} && ref $self->{_frameshifts} eq 'HASH') ? return %{$self->{_frameshifts}} : return (); } =head2 get_nse Title : get_nse Usage : Function: read-only name of form id/start-end Example : Returns : Args : =cut sub get_nse { my ($self,$char1,$char2) = @_; $char1 ||= "/"; $char2 ||= "-"; my ($id, $st, $end, $strand) = ($self->id(), $self->start(), $self->end(), $self->strand || 0); if ($self->force_nse) { $id ||= ''; $st ||= 0; $end ||= 0; } $self->throw("Attribute id not set") unless defined($id); $self->throw("Attribute start not set") unless defined($st); $self->throw("Attribute end not set") unless defined($end); if ($strand && $strand == -1) { ($st, $end) = ($end, $st); } #Stockholm Rfam includes version if present so it is optional my $v = $self->version ? '.'.$self->version : ''; return join('',$id, $v, $char1, $st, $char2, $end); } =head2 force_nse Title : force_nse Usage : $ls->force_nse() Function: Boolean which forces get_nse() to build an NSE, regardless of whether id(), start(), or end() is set Returns : Boolean value Args : (optional) Boolean (1 or 0) Note : This will convert any passed value evaluating as TRUE/FALSE to 1/0 respectively =cut sub force_nse { my ($self, $flag) = @_; if (defined $flag) { $flag ? (return $self->{'_force_nse'} = 1) : (return $self->{'_force_nse'} = 0); } return $self->{'_force_nse'}; } =head2 num_gaps Title : num_gaps Usage :$self->num_gaps('.') Function:Gets number of gaps in the sequence. The count excludes leading or trailing gap characters. Valid bioperl sequence characters are [A-Za-z\-\.\*]. Of these, '.' and '-' are counted as gap characters unless an optional argument specifies one of them. Returns : number of internal gaps in the sequence. Args : a gap character (optional) Status : Stable Note : replaces no_gaps =cut sub num_gaps { my ($self,$char) = @_; my ($seq, $count) = (undef, 0); # default gap characters $char ||= $GAP_SYMBOLS; $self->warn("I hope you know what you are doing setting gap to [$char]") unless $char =~ /[$GAP_SYMBOLS]/; $seq = $self->seq; return 0 unless $seq; # empty sequence does not have gaps $seq =~ s/^([$char]+)//; $seq =~ s/([$char]+)$//; while ( $seq =~ /[$char]+/g ) { $count++; } return $count; } =head2 column_from_residue_number Title : column_from_residue_number Usage : $col = $seq->column_from_residue_number($resnumber) Function: This function gives the position in the alignment (i.e. column number) of the given residue number in the sequence. For example, for the sequence Seq1/91-97 AC..DEF.GH column_from_residue_number(94) returns 6. An exception is thrown if the residue number would lie outside the length of the aligment (e.g. column_from_residue_number( "Seq2", 22 ) Returns : A column number for the position of the given residue in the given sequence (1 = first column) Args : A residue number in the whole sequence (not just that segment of it in the alignment) =cut sub column_from_residue_number { my ($self, $resnumber) = @_; $self->throw("Residue number has to be a positive integer, not [$resnumber]") unless $resnumber =~ /^\d+$/ and $resnumber > 0; if ($resnumber >= $self->start() and $resnumber <= $self->end()) { my @chunks; my $column_incr; my $current_column; my $current_residue = $self->start - 1; my $seq = $self->seq; my $strand = $self->strand || 0; if ($strand == -1) { #@chunks = reverse $seq =~ m/[^\.\-]+|[\.\-]+/go; @chunks = reverse $seq =~ m/[$RESIDUE_SYMBOLS]+|[$GAP_SYMBOLS]+/go; $column_incr = -1; $current_column = (CORE::length $seq) + 1; } else { #@chunks = $seq =~ m/[^\.\-]+|[\.\-]+/go; @chunks = $seq =~ m/[$RESIDUE_SYMBOLS]+|[$GAP_SYMBOLS]+/go; $column_incr = 1; $current_column = 0; } while (my $chunk = shift @chunks) { #if ($chunk =~ m|^[\.\-]|o) { if ($chunk =~ m|^[$GAP_SYMBOLS]|o) { $current_column += $column_incr * CORE::length($chunk); } else { if ($current_residue + CORE::length($chunk) < $resnumber) { $current_column += $column_incr * CORE::length($chunk); $current_residue += CORE::length($chunk); } else { if ($strand == -1) { $current_column -= $resnumber - $current_residue; } else { $current_column += $resnumber - $current_residue; } return $current_column; } } } } $self->throw("Could not find residue number $resnumber"); } =head2 location_from_column Title : location_from_column Usage : $loc = $ali->location_from_column($column_number) Function: This function gives the residue number for a given position in the alignment (i.e. column number) of the given. Gaps complicate this process and force the output to be a L where values can be undefined. For example, for the sequence: Seq/91-96 .AC..DEF.G. location_from_column( 3 ) position 92 location_from_column( 4 ) position 92^93 location_from_column( 9 ) position 95^96 location_from_column( 1 ) position undef An exact position returns a Bio::Location::Simple object where where location_type() returns 'EXACT', if a position is between bases location_type() returns 'IN-BETWEEN'. Column before the first residue returns undef. Note that if the position is after the last residue in the alignment, that there is no guarantee that the original sequence has residues after that position. An exception is thrown if the column number is not within the sequence. Returns : Bio::Location::Simple or undef Args : A column number Throws : If column is not within the sequence See L for more. =cut sub location_from_column { my ($self, $column) = @_; $self->throw("Column number has to be a positive integer, not [$column]") unless $column =~ /^\d+$/ and $column > 0; $self->throw("Column number [$column] is larger than". " sequence length [". $self->length. "]") unless $column <= $self->length; my ($loc); my $s = $self->subseq(1,$column); $s =~ s/[^a-zA-Z\*]//g; my $pos = CORE::length $s; my $start = $self->start || 0 ; my $strand = $self->strand() || 1; my $relative_pos = ($strand == -1) ? ($self->end - $pos + 1) : ($pos + $start - 1); if ($self->subseq($column, $column) =~ /[a-zA-Z\*]/ ) { $loc = Bio::Location::Simple->new (-start => $relative_pos, -end => $relative_pos, -strand => 1, ); } elsif ($pos == 0 and $self->start == 1) { } else { my ($start,$end) = ($relative_pos, $relative_pos + $strand); if ($strand == -1) { ($start,$end) = ($end,$start); } $loc = Bio::Location::Simple->new (-start => $start, -end => $end, -strand => 1, -location_type => 'IN-BETWEEN' ); } return $loc; } =head2 revcom Title : revcom Usage : $rev = $seq->revcom() Function: Produces a new Bio::LocatableSeq object which has the reversed complement of the sequence. For protein sequences this throws an exception of "Sequence is a protein. Cannot revcom" Returns : A new Bio::LocatableSeq object Args : none =cut sub revcom { my ($self) = @_; # since we don't know whether sequences without 1 => 1 correlation can be # revcom'd, kick back if (grep {$_ != 1} $self->mapping) { $self->warn('revcom() not supported for sequences with mapped values of > 1'); return; } my $new = $self->SUPER::revcom; $new->strand($self->strand * -1) if $self->strand; $new->start($self->start) if $self->start; $new->end($self->end) if $self->end; return $new; } =head2 trunc Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence, Returns : a fresh Bio::PrimarySeqI implementing object Args : Two integers denoting first and last columns of the sequence to be included into sub-sequence. =cut sub trunc { my ($self, $start, $end) = @_; my $new = $self->SUPER::trunc($start, $end); $new->strand($self->strand); # end will be automatically calculated $start = $end if $self->strand && $self->strand == -1; $start = $self->location_from_column($start); $start ? ($start = $start->end) : ($start = 1); $new->start($start) if $start; return $new; } =head2 validate_seq Title : validate_seq Usage : if(! $seqobj->validate_seq($seq_str) ) { print "sequence $seq_str is not valid for an object of alphabet ",$seqobj->alphabet, "\n"; } Function: Test that the given sequence is valid, i.e. contains only valid characters. The allowed characters are all letters (A-Z) and '-','.', '*','?','=' and '~'. Spaces are not valid. Note that this implementation does not take alphabet() into account. Returns : 1 if the supplied sequence string is valid, 0 otherwise. Args : - Sequence string to be validated - Boolean to throw an error if the sequence is invalid =cut sub validate_seq { my ($self, $seqstr, $throw) = @_; $seqstr = '' if not defined $seqstr; $throw = 0 if not defined $throw ; # 0 for backward compatiblity if ( (CORE::length $seqstr > 0 ) && ($seqstr !~ /^([$MATCHPATTERN]+)$/) ) { if ($throw) { $self->throw("Failed validation of sequence '".(defined($self->id) || '[unidentified sequence]')."'. Invalid characters were: " . join('',($seqstr =~ /([^$MATCHPATTERN]+)/g))); } return 0; } return 1; } ################## DEPRECATED METHODS ################## =head2 no_gap Title : no_gaps Usage : $self->no_gaps('.') Function : Gets number of gaps in the sequence. The count excludes leading or trailing gap characters. Valid bioperl sequence characters are [A-Za-z\-\.\*]. Of these, '.' and '-' are counted as gap characters unless an optional argument specifies one of them. Returns : number of internal gaps in the sequence. Args : a gap character (optional) Status : Deprecated (in favor of num_gaps()) =cut sub no_gaps { my $self = shift; $self->deprecated( -warn_version => 1.0069, -throw_version => 1.0075, -message => 'Use of method no_gaps() is deprecated, use num_gaps() instead' ); return $self->num_gaps(@_); } =head2 no_sequences Title : no_sequences Usage : $gaps = $seq->no_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : Status : Deprecated (in favor of num_sequences()) =cut sub no_sequences { my $self = shift; $self->deprecated( -warn_version => 1.0069, -throw_version => 1.0075, -message => 'Use of method no_sequences() is deprecated, use num_sequences() instead' ); return $self->num_sequences(@_); } 1; BioPerl-1.6.923/Bio/LocationI.pm000444000765000024 3003412254227315 16407 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::LocationI # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::LocationI - Abstract interface of a Location on a Sequence =head1 SYNOPSIS # get a LocationI somehow printf( "start = %d, end = %d, strand = %s, seq_id = %s\n", $location->start, $location->end, $location->strand, $location->seq_id); print "location str is ", $location->to_FTstring(), "\n"; =head1 DESCRIPTION This Interface defines the methods for a Bio::LocationI, an object which encapsulates a location on a biological sequence. Locations need not be attached to actual sequences as they are stand alone objects. LocationI objects are used by L objects to manage and represent locations for a Sequence Feature. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LocationI; use strict; use Carp; use base qw(Bio::RangeI); =head2 location_type Title : location_type Usage : my $location_type = $location->location_type(); Function: Get location type encoded as text Returns : string ('EXACT', 'WITHIN', 'IN-BETWEEN') Args : none =cut sub location_type { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 start Title : start Usage : $start = $location->start(); Function: Get the start coordinate of this location as defined by the currently active coordinate computation policy. In simple cases, this will return the same number as min_start() and max_start(), in more ambiguous cases like fuzzy locations the number may be equal to one or neither of both. We override this here from RangeI in order to delegate 'get' to a L implementing object. Implementing classes may also wish to provide 'set' functionality, in which case they *must* override this method. The implementation provided here will throw an exception if called with arguments. Returns : A positive integer value. Args : none See L for more information =cut sub start { my ($self,@args) = @_; # throw if @args means that we don't support updating information # in the interface but will delegate to the coordinate policy object # for interpreting the 'start' value $self->throw_not_implemented if @args; return $self->coordinate_policy()->start($self); } =head2 end Title : end Usage : $end = $location->end(); Function: Get the end coordinate of this location as defined by the currently active coordinate computation policy. In simple cases, this will return the same number as min_end() and max_end(), in more ambiguous cases like fuzzy locations the number may be equal to one or neither of both. We override this here from Bio::RangeI in order to delegate 'get' to a L implementing object. Implementing classes may also wish to provide 'set' functionality, in which case they *must* override this method. The implementation provided here will throw an exception if called with arguments. Returns : A positive integer value. Args : none See L and L for more information =cut sub end { my ($self,@args) = @_; # throw if @args means that we don't support updating information # in the interface but will delegate to the coordinate policy object # for interpreting the 'end' value $self->throw_not_implemented if @args; return $self->coordinate_policy()->end($self); } =head2 min_start Title : min_start Usage : my $minstart = $location->min_start(); Function: Get minimum starting point of feature. Note that an implementation must not call start() in this method. Returns : integer or undef if no minimum starting point. Args : none =cut sub min_start { my($self) = @_; $self->throw_not_implemented(); } =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get maximum starting point of feature. Note that an implementation must not call start() in this method unless start() is overridden such as not to delegate to the coordinate computation policy object. Returns : integer or undef if no maximum starting point. Args : none =cut sub max_start { my($self) = @_; $self->throw_not_implemented(); } =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get start position type encoded as text Known valid values are 'BEFORE' (<5..100), 'AFTER' (>5..100), 'EXACT' (5..100), 'WITHIN' ((5.10)..100), 'BETWEEN', (5^6), with their meaning best explained by their GenBank/EMBL location string encoding in brackets. Returns : string ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut sub start_pos_type { my($self) = @_; $self->throw_not_implemented(); } =head2 flip_strand Title : flip_strand Usage : $location->flip_strand(); Function: Flip-flop a strand to the opposite Returns : None Args : None =cut sub flip_strand { my $self= shift; $self->strand($self->strand * -1); } =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get minimum ending point of feature. Note that an implementation must not call end() in this method unless end() is overridden such as not to delegate to the coordinate computation policy object. Returns : integer or undef if no minimum ending point. Args : none =cut sub min_end { my($self) = @_; $self->throw_not_implemented(); } =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get maximum ending point of feature. Note that an implementation must not call end() in this method unless end() is overridden such as not to delegate to the coordinate computation policy object. Returns : integer or undef if no maximum ending point. Args : none =cut sub max_end { my($self) = @_; $self->throw_not_implemented(); } =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get end position encoded as text. Known valid values are 'BEFORE' (5..<100), 'AFTER' (5..>100), 'EXACT' (5..100), 'WITHIN' (5..(90.100)), 'BETWEEN', (5^6), with their meaning best explained by their GenBank/EMBL location string encoding in brackets. Returns : string ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut sub end_pos_type { my($self) = @_; $self->throw_not_implemented(); } =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to Returns : seq_id (a string) Args : [optional] seq_id value to set =cut sub seq_id { my($self) = @_; $self->throw_not_implemented(); } =head2 is_remote Title : is_remote Usage : $is_remote_loc = $loc->is_remote() Function: Whether or not a location is a remote location. A location is said to be remote if it is on a different 'object' than the object which 'has' this location. Typically, features on a sequence will sometimes have a remote location, which means that the location of the feature is on a different sequence than the one that is attached to the feature. In such a case, $loc->seq_id will be different from $feat->seq_id (usually they will be the same). While this may sound weird, it reflects the location of the kind of AL445212.9:83662..166657 which can be found in GenBank/EMBL feature tables. Example : Returns : TRUE if the location is a remote location, and FALSE otherwise Args : Value to set to =cut sub is_remote{ shift->throw_not_implemented(); } =head2 coordinate_policy Title : coordinate_policy Usage : $policy = $location->coordinate_policy(); $location->coordinate_policy($mypolicy); # set may not be possible Function: Get the coordinate computing policy employed by this object. See L for documentation about the policy object and its use. The interface *does not* require implementing classes to accept setting of a different policy. The implementation provided here does, however, allow to do so. Implementors of this interface are expected to initialize every new instance with a L object. The implementation provided here will return a default policy object if none has been set yet. To change this default policy object call this method as a class method with an appropriate argument. Note that in this case only subsequently created Location objects will be affected. Returns : A L implementing object. Args : On set, a L implementing object. See L for more information =cut sub coordinate_policy { shift->throw_not_implemented(); } =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: returns the FeatureTable string of this location Returns : string Args : none =cut sub to_FTstring { my($self) = @_; $self->throw_not_implemented(); } =head2 each_Location Title : each_Location Usage : @locations = $locObject->each_Location($order); Function: Conserved function call across Location:: modules - will return an array containing the component Location(s) in that object, regardless if the calling object is itself a single location or one containing sublocations. Returns : an array of Bio::LocationI implementing objects Args : Optional sort order to be passed to sub_Location() for Splits =cut sub each_Location { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 valid_Location Title : valid_Location Usage : if ($location->valid_location) {...}; Function: boolean method to determine whether location is considered valid (has minimum requirements for a specific LocationI implementation) Returns : Boolean value: true if location is valid, false otherwise Args : none =cut sub valid_Location { my ($self,@args) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/MapIO.pm000444000765000024 1252412254227317 15501 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::MapIO # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::MapIO - A Map Factory object =head1 SYNOPSIS use Bio::MapIO; my $mapio = Bio::MapIO->new(-format => "mapmaker", -file => "mapfile.map"); while( my $map = $mapio->next_map ) { # get each map foreach my $marker ( $map->each_element ) { # loop through the markers associated with the map } } =head1 DESCRIPTION This is the Factory object for reading Maps from a data stream or file. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::MapIO; use strict; use base qw(Bio::Root::Root Bio::Root::IO Bio::Factory::MapFactoryI); =head2 new Title : new Usage : my $obj = Bio::MapIO->new(); Function: Builds a new Bio::MapIO object Returns : Bio::MapIO Args : =cut sub new { my($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::MapIO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{'-file'} || $ARGV[0] ) || 'mapmaker'; $format = "\L$format"; # normalize capitalization to lower case # normalize capitalization return unless( $class->_load_format_module($format) ); return "Bio::MapIO::$format"->new(@args); } } =head2 format Title : format Usage : $format = $stream->format() Function: Get the map format Returns : map format Args : none =cut # format() method inherited from Bio::Root::IO =head2 Bio::Factory::MapFactoryI methods =cut =head2 next_map Title : next_tree Usage : my $map = $factory->next_map; Function: Get a map from the factory Returns : L Args : none =head2 write_map Title : write_tree Usage : $factory->write_map($map); Function: Write a map out through the factory Returns : none Args : L =cut =head2 attach_EventHandler Title : attach_EventHandler Usage : $parser->attatch_EventHandler($handler) Function: Adds an event handler to listen for events Returns : none Args : L =cut sub attach_EventHandler{ my ($self,$handler) = @_; return if( ! $handler ); if( ! $handler->isa('Bio::Event::EventHandlerI') ) { $self->warn("Ignoring request to attatch handler ".ref($handler). ' because it is not a Bio::Event::EventHandlerI'); } $self->{'_handler'} = $handler; return; } =head2 _eventHandler Title : _eventHandler Usage : private Function: Get the EventHandler Returns : L Args : none =cut sub _eventHandler{ my ($self) = @_; return $self->{'_handler'}; } sub _initialize { my($self, @args) = @_; $self->{'_handler'} = undef; # initialize the IO part $self->_initialize_io(@args); # $self->attach_EventHandler(Bio::MapIO::MapEventBuilder->new()); } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL MapIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::MapIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'mapmaker' if /\.(map)$/i; return 'mapxml' if /\.(xml)$/i; } sub DESTROY { my $self = shift; $self->close(); } 1; BioPerl-1.6.923/Bio/NexmlIO.pm000444000765000024 3207612254227313 16047 0ustar00cjfieldsstaff000000000000# $Id: Nexml.pm 15889 2009-07-29 13:35:29Z chmille4 $ # BioPerl module for Bio::NexmlIO # # Please direct questions and support issues to # # Cared for by Chase Miller # # Copyright Chase Miller # # You may distribute this module under the same terms as perl itself # # _history # June 16, 2009 Largely rewritten by Chase Miller # POD documentation - main docs before the code =head1 NAME Bio::NexmlIO - stream handler for NeXML documents =head1 SYNOPSIS #Instantiate a Bio::Nexml object and link it to a file my $in_nexml = Bio::Nexml->new(-file => 'nexml_doc.xml', -format => 'Nexml'); #Read in some data my $bptree1 = $in_nexml->next_tree(); my $bpaln1 = $in_nexml->next_aln(); my $bpseq1 = $in_nexml->next_seq(); #Use/manipulate data ... #Write data to nexml file my $out_nexml = Bio::Nexml->new(-file => '>new_nexml_doc.xml', -format => 'Nexml'); $out_nexml->to_xml(); =head1 DESCRIPTION Bio::NexmlIO is an I/O handler for a NeXML document. A NeXML document can represent three different data types: simple sequences, alignments, and trees. NexmlIO has four main methods next_tree, next_seq, next_aln, and write. NexmlIO returns bioperl seq, tree, and aln objects which can be manipulated then passed to the write method of a new NexmlIO instance to allow the creation of a NeXML document. Each bioperl object contains all the information necessary to recreate a Bio::Phylo::Taxa object, so each time a bioperl object is converted to a biophylo object, the bioperl object is checked to see if its associated taxa has already been created (against a hash using the NexmlIO_ID and Taxa_ID to create a unique string). If not, it is created; if so, that taxa object is used to link the Bio::Phylo tree or matrix. For more information on the NeXML format, see L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chase Miller Email chmille4@gmail.com =head1 CONTRIBUTORS Mark A. Jensen, maj -at- fortinbras -dot- com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::NexmlIO; use strict; #TODO Change this use lib '..'; use Bio::SeqIO::nexml; use Bio::AlignIO::nexml; use Bio::TreeIO::nexml; use Bio::Nexml::Factory; use base qw(Bio::Root::IO); my $nexml_fac = Bio::Nexml::Factory->new(); =head1 CONSTRUCTOR =head2 new Title : new Usage : my $in_nexmlIO = Bio::NexmlIO->new(-file => 'data.nexml.xml'); Function: Creates a L object linked to a stream Returns : a L object Args : file name See L =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my %params = @args; my $file_string = $params{'-file'}; #create unique ID by creating a scalar and using the memory address my $ID = bless \(my $dummy), "UniqueID"; ($self->{'_ID'}) = sprintf("%s",\$ID) =~ /(0x[0-9a-fA-F]+)/; unless ($file_string =~ m/^\>/) { $self->{'_doc'} = Bio::Phylo::IO->parse('-file' => $params{'-file'}, '-format' => 'nexml', '-as_project' => '1'); } return $self; } =head2 doc Title : doc Usage : my $nexml_doc = $in_nexmlIO->doc(); Function: returns a L object that contains all the Bio::Phylo data objects parsed from the stream Returns : a L object Args : none =cut sub doc { my $self = shift; return $self->{'_doc'}; } # Takes the Bio::Phylo::Project object and creats BioPerl trees, alns, and seqs from it sub _parse { my ($self) = @_; $self->{'_treeiter'} = 0; $self->{'_seqiter'} = 0; $self->{'_alniter'} = 0; $self->{_trees} = $nexml_fac->create_bperl_tree($self); $self->{_alns} = $nexml_fac->create_bperl_aln($self); $self->{_seqs} = $nexml_fac->create_bperl_seq($self); my $taxa_array = $self->doc->get_taxa(); $self->{'_parsed'} = 1; #success } =head1 ITERATORS =head2 next_tree Title : next_tree Usage : $tree = $stream->next_tree Function: Reads the next tree object from the stream and returns it. Returns : a L object Args : none See L, L =cut sub next_tree { my $self = shift; $self->_parse unless $self->{'_parsed'}; return $self->{'_trees'}->[ $self->{'_treeiter'}++ ]; } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq Function: Reads the next seq object from the stream and returns it. Returns : a L object Args : none See L, L =cut sub next_seq { my $self = shift; unless ( $self->{'_parsed'} ) { $self->_parse; } return $self->{'_seqs'}->[ $self->{'_seqiter'}++ ]; } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln Function: Reads the next aln object from the stream and returns it. Returns : a L object Args : none See L, L =cut sub next_aln { my $self = shift; unless ( $self->{'_parsed'} ) { $self->_parse; } return $self->{'_alns'}->[ $self->{'_alniter'}++ ]; } sub _rewind { my $self = shift; my $elt = shift; $self->{"_${elt}iter"} = 0 if defined $self->{"_${elt}iter"}; return 1; } =head2 rewind_seq Title : rewind_seq Usage : $stream->rewind_seq Function: Resets the stream for seqs Returns : none Args : none See L, L =cut sub rewind_seq { shift->_rewind('seq'); } =head2 rewind_aln Title : rewind_aln Usage : $stream->rewind_aln Function: Resets the stream for alns Returns : none Args : none See L, L =cut sub rewind_aln { shift->_rewind('aln'); } =head2 rewind_tree Title : rewind_tree Usage : $stream->rewind_tree Function: Resets the stream for trees Returns : none Args : none See L, L =cut sub rewind_tree { shift->_rewind('tree'); } =head2 write Title : write Usage : $stream->write(-alns => $alns,-seqs => $seqs,-trees => $trees) Function: converts BioPerl seq, tree, and aln objects into Bio::Phylo seq, tree, and aln objects, constructs a Bio::Phylo::Project object made up of the newly created Bio::Phylo objects, and writes the Bio::Phylo:Project object to the stream as a valid nexml document Returns : none Args : \@L, \@L, \@L See L, L, L, L =cut sub write { my ($self, @args) = @_; my %params = @args; my ($trees, $alns, $seqs) = @params{qw( -trees -alns -seqs )}; my %taxa_hash = (); my %seq_matrices = (); my $proj_doc = Bio::Phylo::Factory->create_project(); #convert trees to bio::Phylo objects my $forest = Bio::Phylo::Factory->create_forest(); my @forests; my @taxa_array; my $ent; my $taxa_o; my $phylo_tree_o; foreach my $tree (@$trees) { my $nexml_id = $tree->get_tag_values('_NexmlIO_ID'); $taxa_o = undef; if ( defined $taxa_hash{$nexml_id} ) { $taxa_o = $taxa_hash{$nexml_id}; } else { ($taxa_o) = $nexml_fac->create_bphylo_taxa($tree); $forest->set_taxa($taxa_o) if defined $taxa_o; $taxa_hash{$nexml_id} = $taxa_o; } ($phylo_tree_o) = $nexml_fac->create_bphylo_tree($tree, $taxa_o); $forest->insert($phylo_tree_o); } #convert matrices to Bio::Phylo objects my $matrices = Bio::Phylo::Matrices->new(); my $phylo_matrix_o; foreach my $aln (@$alns) { $taxa_o = undef; if (defined $taxa_hash{ $aln->{_Nexml_ID} }) { $taxa_o = $taxa_hash{$aln->{_Nexml_ID}}; } else { ($taxa_o) = $nexml_fac->create_bphylo_taxa($aln); $taxa_hash{$aln->{_Nexml_ID}} = $taxa_o; } ($phylo_matrix_o) = $nexml_fac->create_bphylo_aln($aln, $taxa_o); $phylo_matrix_o->set_taxa($taxa_o) if defined $taxa_o; $matrices->insert($phylo_matrix_o); } my $seq_matrix_o; my $datum; #convert sequences to Bio::Phylo objects foreach my $seq (@$seqs) { $taxa_o = undef; #check if this Bio::Phylo::Taxa obj has already been created if (defined $taxa_hash{ $seq->{_Nexml_ID} }) { $taxa_o = $taxa_hash{$seq->{_Nexml_ID}}; } else { ($taxa_o) = $nexml_fac->create_bphylo_taxa($seq); $taxa_hash{$seq->{_Nexml_ID}} = $taxa_o; } $datum = $nexml_fac->create_bphylo_seq($seq, $taxa_o); #check if this Bio::Phylo::Matrices::Matrix obj has already been created if (defined $seq_matrices{ $seq->{_Nexml_matrix_ID} }) { $seq_matrix_o = $seq_matrices{$seq->{_Nexml_matrix_ID}}; my $taxon_name = $datum->get_taxon()->get_name(); $datum->unset_taxon(); $seq_matrix_o->insert($datum); $datum->set_taxon($seq_matrix_o->get_taxa()->get_by_name($taxon_name)); } else { $seq_matrix_o = Bio::Phylo::Factory->create_matrix('-type' => $datum->moltype); $seq_matrices{$seq->{_Nexml_matrix_ID}} = $seq_matrix_o; $seq_matrix_o->set_taxa($taxa_o) if defined $taxa_o; $seq_matrix_o->insert($datum); #get matrix label my $feat = ($seq->get_SeqFeatures())[0]; my $matrix_label = ($feat->get_tag_values('matrix_label'))[0] if $feat->has_tag('id'); $seq_matrix_o->set_name($matrix_label); $matrices->insert($seq_matrix_o); } } #Add matrices and forest objects to project object which represents a complete nexml document if($forest->first) { $proj_doc->insert($forest); } while(my $curr_matrix = $matrices->next) { $proj_doc->insert($curr_matrix); } #write nexml document to stream my $ret = $self->_print($proj_doc->to_xml(-compact=>1)); $self->flush; return($ret); } =head2 extract_seqs Title : extract_seqs Usage : $nexmlIO->extract_seqs(-file => ">$outfile", -format => $format) Function: converts BioPerl seqs stored in the NexmlIO object into the provided format and writes it to the provided file. Uses L to do the conversion and writing. Returns : none Args : file to write to, format to be converted to See L, L =cut sub extract_seqs { my $self = shift; unless ( $self->{'_parsed'} ) { $self->_parse; } my %params = @_; my $remove_spaces = 0; my $ret = 0; my ($format, $file) = @params{qw( -format -file)}; for ($format) { /^fasta$/i && do { # this is ok, flag so that the nexmlid gets converted; $remove_spaces = 1; last; }; # default do { $self->throw("Format '$format' not yet supported for extraction"); }; } my $seqIO = Bio::SeqIO->new(-format => $format, -file => $file); my $seqs = $self->{_seqs}; foreach my $seq (@$seqs) { if ($remove_spaces) { my $id = $seq->id; $id =~ s/ /_/; $seq->id($id); } $ret = $seqIO->write_seq($seq); } return $ret; } =head2 extract_alns Title : extract_alns Usage : $nexmlIO->extract_alns(-file => ">$outfile", -format => $format) Function: converts BioPerl alns stored in the NexmlIO object into the provided format and writes it to the provided file. Uses L to do the conversion and writing. Returns : none Args : file to write to, format to be converted to See L, L =cut sub extract_alns { my $self = shift; unless ( $self->{'_parsed'} ) { $self->_parse; } my $ret = 0; my %params = @_; my ($format, $file) = @params{qw( -format -file)}; my $alignIO = Bio::AlignIO->new(-format => $format, -file => $file); my $alns = $self->{_alns}; foreach my $aln (@$alns) { $ret = $alignIO->write_aln($aln); } return $ret; } =head2 extract_trees Title : extract_trees Usage : $nexmlIO->extract_trees(-file => ">$outfile", -format => $format) Function: converts BioPerl trees stored in the NexmlIO object into the provided format and writes it to the provided file. Uses L to do the conversion and writing. Returns : none Args : file to write to, format to be converted to See L, L =cut sub extract_trees { my $self = shift; unless ( $self->{'_parsed'} ) { $self->_parse; } my $ret = 0; my %params = @_; my ($format, $file) = @params{qw( -format -file)}; my $treeIO = Bio::TreeIO->new(-format => $format, -file => $file); my $trees = $self->{_trees}; foreach my $tree (@$trees) { $treeIO->write_tree($tree); $ret = 1; } return $ret; } 1; BioPerl-1.6.923/Bio/OntologyIO.pm000444000765000024 2300312254227320 16562 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::OntologyIO # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO - Parser factory for Ontology formats =head1 SYNOPSIS use Bio::OntologyIO; my $parser = Bio::OntologyIO->new(-format => "go", -file=> $file); while(my $ont = $parser->next_ontology()) { print "read ontology ",$ont->name()," with ", scalar($ont->get_root_terms)," root terms, and ", scalar($ont->get_leaf_terms)," leaf terms\n"; } =head1 DESCRIPTION This is the parser factory for different ontology sources and formats. Conceptually, it is very similar to L, but the difference is that the chunk of data returned as an object is an entire ontology. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::Root::IO); # # Maps from format name to driver suitable for the format. # my %format_driver_map = ( "go" => "goflat", "so" => "soflat", "interpro" => "InterProParser", "interprosax" => "Handlers::InterPro_BioSQL_Handler", "evoc" => "simplehierarchy", "obo" => "obo" ); =head2 new Title : new Usage : my $parser = Bio::OntologyIO->new(-format => 'go', @args); Function: Returns a stream of ontologies opened on the specified input for the specified format. Returns : An ontology parser (an instance of Bio::OntologyIO) initialized for the specified format. Args : Named parameters. Common parameters are -format - the format of the input; the following are presently supported: goflat: DAG-Edit Gene Ontology flat files go : synonymous to goflat soflat: DAG-Edit Sequence Ontology flat files so : synonymous to soflat simplehierarchy: text format with one term per line and indentation giving the hierarchy evoc : synonymous to simplehierarchy interpro: InterPro XML interprosax: InterPro XML - this is actually not a Bio::OntologyIO compliant parser; instead it persists terms as they are encountered. L obo : OBO format style from Gene Ontology Consortium -file - the file holding the data -fh - the stream providing the data (-file and -fh are mutually exclusive) -ontology_name - the name of the ontology -engine - the L object to be reused (will be created otherwise); note that every L will qualify as well since that one inherits from the former. -term_factory - the ontology term factory to use. Provide a value only if you know what you are doing. DAG-Edit flat file parsers will usually also accept the following parameters. -defs_file - the name of the file holding the term definitions -files - an array ref holding the file names (for GO, there will usually be 3 files: component.ontology, function.ontology, process.ontology) Other parameters are specific to the parsers. =cut sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::OntologyIO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $class->_map_format($param{'-format'}); # normalize capitalization return unless( $class->_load_format_module($format) ); return "Bio::OntologyIO::$format"->new(@args); } } =head2 format Title : format Usage : $format = $parser->format() Function: Get the ontology format Returns : ontology format Args : none =cut # format() method inherited from Bio::Root::IO sub _initialize { my($self, @args) = @_; # initialize factories etc my ($eng,$fact,$ontname) = $self->_rearrange([qw(TERM_FACTORY) ], @args); # term object factory $self->term_factory($fact) if $fact; # initialize the Bio::Root::IO part $self->_initialize_io(@args); } =head2 next_ontology Title : next_ontology Usage : $ont = $stream->next_ontology() Function: Reads the next ontology object from the stream and returns it. Returns : a L compliant object, or undef at the end of the stream Args : none =cut sub next_ontology { shift->throw_not_implemented(); } =head2 term_factory Title : term_factory Usage : $obj->term_factory($newval) Function: Get/set the ontology term factory to use. As a user of this module it is not necessary to call this method as there will be default. In order to change the default, the easiest way is to instantiate L with the proper -type argument. Most if not all parsers will actually use this very implementation, so even easier than the aforementioned way is to simply call $ontio->term_factory->type("Bio::Ontology::MyTerm"). Example : Returns : value of term_factory (a Bio::Factory::ObjectFactoryI object) Args : on set, new value (a Bio::Factory::ObjectFactoryI object, optional) =cut sub term_factory{ my $self = shift; return $self->{'term_factory'} = shift if @_; return $self->{'term_factory'}; } =head1 Private Methods Some of these are actually 'protected' in OO speak, which means you may or will want to utilize them in a derived ontology parser, but you should not call them from outside. =cut =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL OntologyIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self, $format) = @_; my $module = "Bio::OntologyIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <close(); } sub _map_format { my $self = shift; my $format = shift; my $mod; if($format) { $mod = $format_driver_map{lc($format)}; $mod = lc($format) unless $mod; } else { $self->throw("unable to guess ontology format, specify -format"); } return $mod; } sub unescape { my( $self, $ref ) = @_; $ref =~ s/<\\;/\/g; $ref =~ s/&pct\\;/\%/g; $ref =~ s/\\n/\n/g; $ref =~ s/\\t/\t/g; return $ref; } 1; BioPerl-1.6.923/Bio/ParameterBaseI.pm000444000765000024 1570412254227330 17356 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::ParameterBaseI # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::ParameterBaseI - Simple interface class for any parameter-related data such as IDs, database name, program arguments, and other odds and ends. =head1 SYNOPSIS # Bio::DB::MyParams implements Bio::ParameterBaseI @params = (-db => 'protein', -id => \@ids, -retmax => 10); $pobj->Bio::DB::MyDBParams->new(); # sets only parameters passed; results in a state change if any parameter # passed is new or differs from previously set value $pobj->set_params(@params); # reset all parameters (sets to undef); results in a state change $pobj->reset_params(); # resets parameters to those in %param (sets all others to undef); resets the # object state to indicate change. $pobj->reset_params(@params); # direct get/set; results in a state change if any parameter passed is new or # differs from previously set value $pobj->db('nucleotide'); @ids = $pobj->id(); # retrieve list containing set defined parameters %myparams = $pobj->get_parameters(); # checks whether the state of the object has changed (i.e. parameter has # changed, so on) if ($pobj->parameters_changed) { # run new search } else { # return cached search } # available parameters @params = $pobj->available_parameters(); # retrieve string (URI, query, etc); calling to* methods changes object state # to indicate data hasn't changed (so future calls to parameters_changed() # will return FALSE) $query = $pobj->to_string(); # returns raw string $uri = $pobj->to_uri(); # returns URI-based object $uri = $pobj->to_my_data_struct(); # returns implemenation-specific data structure ... =head1 DESCRIPTION This is a class interface which focuses on common parameter-related tasks such as building simple database queries, URI-related requests, program arguments, etc. Implementing classes use the following ways to set parameters: 1) Create a new instance of a ParameterBaseI-implementing object. $pobj->Bio::DB::MyParamClass->new(-db => 'local', -id => \@ids); 2) Pass the parameters as a hash or array to set_parameters(), which sets the parameters listed in the hash but leaves all others as is. $pobj->set_parameters(-retmax => 100, -retstart => 20); 3) Pass the parameters as a hash or array to reset_parameters(), which sets the parameters listed in the hash and resets everything else. $pobj->reset_parameters(-term => 'pyrimidine'); # sets db and id to undef 4) Pass values using specific getter/setters. $pobj->id(\@ids); # sets IDs There is no restriction on what one uses to set up individual parameter getter/setters, though there are some other options implemented in BioPerl (for instance, Bio::Root::RootI::_set_from_args()). A key requirement is there be a way to detect changes in the state of the ParameterBaseI object so that any object with a Bio::ParameterBaseI can decide whether to submit a new request or return cached data. State changes are revealed by the returned values of the parameters_changed() method, which is a simple boolean set to TRUE when the object is first instantiated or parameters have changed. When retrieving anything using the implementation-specific to_* methods (such as to_query, to_string, to_uri, to_request, etc), the ParameterBaseI object state is set to FALSE to indicate the data has been accessed and indicate reaccessing will retrieve the same value. The observing object can then independently decide whether to rerun the cached query or return a previously cached result. One can also use indiviual getter/setters to retrieve single parameter values as well as use parameter_hash() to retrieve all of the parameters in one go as a hash. To check which parameters are available use available_parameters(). Args passed to =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@lists.open-bio.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web. https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::ParameterBaseI; use strict; use warnings; use base qw(Bio::Root::RootI); =head2 set_parameters Title : set_parameters Usage : $pobj->set_parameters(%params); Function: sets the parameters listed in the hash or array Returns : None Args : [optional] hash or array of parameter/values. =cut sub set_parameters { shift->throw_not_implemented; } =head2 reset_parameters Title : reset_parameters Usage : resets values Function: resets parameters to either undef or value in passed hash Returns : none Args : [optional] hash of parameter-value pairs =cut sub reset_parameters { shift->throw_not_implemented; } =head2 parameters_changed Title : parameters_changed Usage : if ($pobj->parameters_changed) {...} Function: Returns boolean true (1) if parameters have changed Returns : Boolean (0 or 1) Args : [optional] Boolean =cut sub parameters_changed { shift->throw_not_implemented; } =head2 available_parameters Title : available_parameters Usage : @params = $pobj->available_parameters() Function: Returns a list of the available parameters Returns : Array of parameters Args : [optional, implementation-dependent] string for returning subset of parameters =cut sub available_parameters { shift->throw_not_implemented; } =head2 get_parameters Title : get_parameters Usage : %params = $pobj->get_parameters; Function: Returns list of key-value pairs of parameter => value Returns : List of key-value pairs Args : [optional] A string is allowed if subsets are wanted or (if a parameter subset is default) 'all' to return all parameters =cut sub get_parameters { shift->throw_not_implemented; } =head1 to* methods All to_* methods are implementation-specific =cut 1; BioPerl-1.6.923/Bio/Perl.pm000444000765000024 4340612254227325 15440 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Perl # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Perl - Functional access to BioPerl for people who don't know objects =head1 SYNOPSIS use Bio::Perl; # will guess file format from extension $seq_object = read_sequence($filename); # forces genbank format $seq_object = read_sequence($filename,'genbank'); # reads an array of sequences @seq_object_array = read_all_sequences($filename,'fasta'); # sequences are Bio::Seq objects, so the following methods work # for more info see Bio::Seq, or do 'perldoc Bio/Seq.pm' print "Sequence name is ",$seq_object->display_id,"\n"; print "Sequence acc is ",$seq_object->accession_number,"\n"; print "First 5 bases is ",$seq_object->subseq(1,5),"\n"; # get the whole sequence as a single string $sequence_as_a_string = $seq_object->seq(); # writing sequences write_sequence(">$filename",'genbank',$seq_object); write_sequence(">$filename",'genbank',@seq_object_array); # making a new sequence from just a string $seq_object = new_sequence("ATTGGTTTGGGGACCCAATTTGTGTGTTATATGTA", "myname","AL12232"); # getting a sequence from a database (assumes internet connection) $seq_object = get_sequence('swissprot',"ROA1_HUMAN"); $seq_object = get_sequence('embl',"AI129902"); $seq_object = get_sequence('genbank',"AI129902"); # BLAST a sequence (assummes an internet connection) $blast_report = blast_sequence($seq_object); write_blast(">blast.out",$blast_report); =head1 DESCRIPTION Easy first time access to BioPerl via functions. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::Perl; use vars qw(@EXPORT @EXPORT_OK $DBOKAY); use strict; use Carp; use Bio::SeqIO; use Bio::Seq; use Bio::Root::Version '$VERSION'; BEGIN { eval { require Bio::DB::EMBL; require Bio::DB::GenBank; require Bio::DB::SwissProt; require Bio::DB::RefSeq; require Bio::DB::GenPept; }; if( $@ ) { $DBOKAY = 0; } else { $DBOKAY = 1; } } use base qw(Exporter); @EXPORT = qw(read_sequence read_all_sequences write_sequence new_sequence get_sequence translate translate_as_string reverse_complement revcom revcom_as_string reverse_complement_as_string blast_sequence write_blast); @EXPORT_OK = @EXPORT; =head2 read_sequence Title : read_sequence Usage : $seq = read_sequence('sequences.fa') $seq = read_sequence($filename,'genbank'); # pipes are fine $seq = read_sequence("my_fetching_program $id |",'fasta'); Function: Reads the top sequence from the file. If no format is given, it will try to guess the format from the filename. If a format is given, it forces that format. The filename can be any valid perl open() string - in particular, you can put in pipes Returns : A Bio::Seq object. A quick synopsis: $seq_object->display_id - name of the sequence $seq_object->seq - sequence as a string Args : Two strings, first the filename - any Perl open() string is ok Second string is the format, which is optional For more information on Seq objects see L. =cut sub read_sequence{ my ($filename,$format) = @_; if( !defined $filename ) { confess "read_sequence($filename) - usage incorrect"; } my $seqio; if( defined $format ) { $seqio = Bio::SeqIO->new( '-file' => $filename, '-format' => $format); } else { $seqio = Bio::SeqIO->new( '-file' => $filename); } my $seq = $seqio->next_seq(); return $seq; } =head2 read_all_sequences Title : read_all_sequences Usage : @seq_object_array = read_all_sequences($filename); @seq_object_array = read_all_sequences($filename,'genbank'); Function: Just as the function above, but reads all the sequences in the file and loads them into an array. For very large files, you will run out of memory. When this happens, you've got to use the SeqIO system directly (this is not so hard! Don't worry about it!). Returns : array of Bio::Seq objects Args : two strings, first the filename (any open() string is ok) second the format (which is optional) See L and L for more information =cut sub read_all_sequences{ my ($filename,$format) = @_; if( !defined $filename ) { confess "read_all_sequences($filename) - usage incorrect"; } my $seqio; if( defined $format ) { $seqio = Bio::SeqIO->new( '-file' => $filename, '-format' => $format); } else { $seqio = Bio::SeqIO->new( '-file' => $filename); } my @seq_array; while( my $seq = $seqio->next_seq() ) { push(@seq_array,$seq); } return @seq_array; } =head2 write_sequence Title : write_sequence Usage : write_sequence(">new_file.gb",'genbank',$seq) write_sequence(">new_file.gb",'genbank',@array_of_sequence_objects) Function: writes sequences in the specified format Returns : true Args : filename as a string, must provide an open() output file format as a string one or more sequence objects =cut sub write_sequence{ my ($filename,$format,@sequence_objects) = @_; if( scalar(@sequence_objects) == 0 ) { confess("write_sequence(filename,format,sequence_object)"); } my $error = 0; my $seqname = "sequence1"; # catch users who haven't passed us a filename we can open if( $filename !~ /^\>/ && $filename !~ /^|/ ) { $filename = ">".$filename; } my $seqio = Bio::SeqIO->new('-file' => $filename, '-format' => $format); foreach my $seq ( @sequence_objects ) { my $seq_obj; if( !ref $seq ) { if( length $seq > 50 ) { # odds are this is a sequence as a string, and someone has not figured out # how to make objects. Warn him/her and then make a sequence object # from this if( $error == 0 ) { carp("WARNING: You have put in a long string into write_sequence.\n". "I suspect this means that this is the actual sequence\n". "In the future try the\n". " new_sequence method of this module to make a new sequence object.\n". "Doing this for you here\n"); $error = 1; } $seq_obj = new_sequence($seq,$seqname); $seqname++; } else { confess("You have a non object [$seq] passed to write_sequence. It maybe that you". "want to use new_sequence to make this string into a sequence object?"); } } else { if( !$seq->isa("Bio::SeqI") ) { confess("object [$seq] is not a Bio::Seq object; can't write it out"); } $seq_obj = $seq; } # finally... we get to write out the sequence! $seqio->write_seq($seq_obj); } 1; } =head2 new_sequence Title : new_sequence Usage : $seq_obj = new_sequence("GATTACA", "kino-enzyme"); Function: Construct a sequency object from sequence string Returns : A Bio::Seq object Args : sequence string name string (optional, default "no-name-for-sequence") accession - accession number (optional, no default) =cut sub new_sequence{ my ($seq,$name,$accession) = @_; if( !defined $seq ) { confess("new_sequence(sequence_as_string) usage"); } $name ||= "no-name-for-sequence"; my $seq_object = Bio::Seq->new( -seq => $seq, -id => $name); $accession && $seq_object->accession_number($accession); return $seq_object; } =head2 blast_sequence Title : blast_sequence Usage : $blast_result = blast_sequence($seq) $blast_result = blast_sequence('MFVEGGTFASEDDDSASAEDE'); Function: If the computer has Internet accessibility, blasts the sequence using the NCBI BLAST server against nrdb. It chooses the flavour of BLAST on the basis of the sequence. This function uses Bio::Tools::Run::RemoteBlast, which itself use Bio::SearchIO - as soon as you want to know more, check out these modules Returns : Bio::Search::Result::GenericResult.pm Args : Either a string of protein letters or nucleotides, or a Bio::Seq object =cut sub blast_sequence { my ($seq,$verbose) = @_; if( !defined $verbose ) { $verbose = 1; } if( !ref $seq ) { $seq = Bio::Seq->new( -seq => $seq, -id => 'blast-sequence-temp-id'); } elsif ( !$seq->isa('Bio::PrimarySeqI') ) { croak("[$seq] is an object, but not a Bio::Seq object, cannot be blasted"); } require Bio::Tools::Run::RemoteBlast; my $prog = ( $seq->alphabet eq 'protein' ) ? 'blastp' : 'blastn'; my $e_val= '1e-10'; my @params = ( '-prog' => $prog, '-expect' => $e_val, '-readmethod' => 'SearchIO' ); my $factory = Bio::Tools::Run::RemoteBlast->new(@params); my $r = $factory->submit_blast($seq); if( $verbose ) { print STDERR "Submitted Blast for [".$seq->id."] "; } sleep 5; my $result; LOOP : while( my @rids = $factory->each_rid) { foreach my $rid ( @rids ) { my $rc = $factory->retrieve_blast($rid); if( !ref($rc) ) { if( $rc < 0 ) { $factory->remove_rid($rid); } if( $verbose ) { print STDERR "."; } sleep 10; } else { $result = $rc->next_result(); $factory->remove_rid($rid); last LOOP; } } } if( $verbose ) { print STDERR "\n"; } return $result; } =head2 write_blast Title : write_blast Usage : write_blast($filename,$blast_report); Function: Writes a BLAST result object (or more formally a SearchIO result object) out to a filename in BLAST-like format Returns : none Args : filename as a string Bio::SearchIO::Results object =cut sub write_blast { my ($filename,$blast) = @_; if( $filename !~ /^\>/ && $filename !~ /^|/ ) { $filename = ">".$filename; } my $output = Bio::SearchIO->new( -output_format => 'blast', -file => $filename); $output->write_result($blast); } =head2 get_sequence Title : get_sequence Usage : $seq_object = get_sequence('swiss',"ROA1_HUMAN"); Function: If the computer has Internet access this method gets the sequence from Internet accessible databases. Currently this supports Swissprot ('swiss'), EMBL ('embl'), GenBank ('genbank'), GenPept ('genpept'), and RefSeq ('refseq'). Swissprot and EMBL are more robust than GenBank fetching. If the user is trying to retrieve a RefSeq entry from GenBank/EMBL, the query is silently redirected. Returns : A Bio::Seq object Args : database type - one of swiss, embl, genbank, genpept, or refseq =cut my $genbank_db = undef; my $genpept_db = undef; my $embl_db = undef; my $swiss_db = undef; my $refseq_db = undef; sub get_sequence{ my ($db_type,$identifier) = @_; if( ! $DBOKAY ) { confess ("Your system does not have one of LWP, HTTP::Request::Common, IO::String\n". "installed so the DB retrieval method is not available.\n". "Full error message is:\n $!\n"); return; } $db_type = lc($db_type); my $db; if( $db_type =~ /genbank/ ) { if( !defined $genbank_db ) { $genbank_db = Bio::DB::GenBank->new(); } $db = $genbank_db; } if( $db_type =~ /genpept/ ) { if( !defined $genpept_db ) { $genpept_db = Bio::DB::GenPept->new(); } $db = $genpept_db; } if( $db_type =~ /swiss/ ) { if( !defined $swiss_db ) { $swiss_db = Bio::DB::SwissProt->new(); } $db = $swiss_db; } if( $db_type =~ /embl/ ) { if( !defined $embl_db ) { $embl_db = Bio::DB::EMBL->new(); } $db = $embl_db; } if( $db_type =~ /refseq/ or ($db_type !~ /swiss/ and $identifier =~ /^\s*N\S+_/)) { if( !defined $refseq_db ) { $refseq_db = Bio::DB::RefSeq->new(); } $db = $refseq_db; } my $seq; if( $identifier =~ /^\w+\d+$/ ) { $seq = $db->get_Seq_by_acc($identifier); } else { $seq = $db->get_Seq_by_id($identifier); } return $seq; } =head2 translate Title : translate Usage : $seqobj = translate($seq_or_string_scalar) Function: translates a DNA sequence object OR just a plain string of DNA to amino acids Returns : A Bio::Seq object Args : Either a sequence object or a string of just DNA sequence characters =cut sub translate { my ($scalar) = shift; my $obj; if( ref $scalar ) { if( !$scalar->isa("Bio::PrimarySeqI") ) { confess("Expecting a sequence object not a $scalar"); } else { $obj= $scalar; } } else { # check this looks vaguely like DNA my $n = ( $scalar =~ tr/ATGCNatgcn/ATGCNatgcn/ ); if( $n < length($scalar) * 0.85 ) { confess("Sequence [$scalar] is less than 85% ATGCN, which doesn't look very DNA to me"); } $obj = Bio::PrimarySeq->new(-id => 'internalbioperlseq',-seq => $scalar); } return $obj->translate(); } =head2 translate_as_string Title : translate_as_string Usage : $seqstring = translate_as_string($seq_or_string_scalar) Function: translates a DNA sequence object OR just a plain string of DNA to amino acids Returns : A string of just amino acids Args : Either a sequence object or a string of just DNA sequence characters =cut sub translate_as_string { my ($scalar) = shift; my $obj = Bio::Perl::translate($scalar); return $obj->seq; } =head2 reverse_complement Title : reverse_complement Usage : $seqobj = reverse_complement($seq_or_string_scalar) Function: reverse complements a string or sequence argument producing a Bio::Seq - if you want a string, you can use reverse_complement_as_string Returns : A Bio::Seq object Args : Either a sequence object or a string of just DNA sequence characters =cut sub reverse_complement { my ($scalar) = shift; my $obj; if( ref $scalar ) { if( !$scalar->isa("Bio::PrimarySeqI") ) { confess("Expecting a sequence object not a $scalar"); } else { $obj= $scalar; } } else { # check this looks vaguely like DNA my $n = ( $scalar =~ tr/ATGCNatgcn/ATGCNatgcn/ ); if( $n < length($scalar) * 0.85 ) { confess("Sequence [$scalar] is less than 85% ATGCN, which doesn't look very DNA to me"); } $obj = Bio::PrimarySeq->new(-id => 'internalbioperlseq',-seq => $scalar); } return $obj->revcom(); } =head2 revcom Title : revcom Usage : $seqobj = revcom($seq_or_string_scalar) Function: reverse complements a string or sequence argument producing a Bio::Seq - if you want a string, you can use reverse_complement_as_string This is an alias for reverse_complement Returns : A Bio::Seq object Args : Either a sequence object or a string of just DNA sequence characters =cut sub revcom { return &Bio::Perl::reverse_complement(@_); } =head2 reverse_complement_as_string Title : reverse_complement_as_string Usage : $string = reverse_complement_as_string($seq_or_string_scalar) Function: reverse complements a string or sequence argument producing a string Returns : A string of DNA letters Args : Either a sequence object or a string of just DNA sequence characters =cut sub reverse_complement_as_string { my ($scalar) = shift; my $obj = &Bio::Perl::reverse_complement($scalar); return $obj->seq; } =head2 revcom_as_string Title : revcom_as_string Usage : $string = revcom_as_string($seq_or_string_scalar) Function: reverse complements a string or sequence argument producing a string Returns : A string of DNA letters Args : Either a sequence object or a string of just DNA sequence characters =cut sub revcom_as_string { my ($scalar) = shift; my $obj = &Bio::Perl::reverse_complement($scalar); return $obj->seq; } 1; BioPerl-1.6.923/Bio/PhyloNetwork.pm000444000765000024 12734512254227330 17224 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona, Gabriel Valiente # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork - Module to compute with Phylogenetic Networks =head1 SYNOPSIS use Bio::PhyloNetwork; # Create a PhyloNetwork object from a eNewick string my $net1=Bio::PhyloNetwork->new( -eNewick=>'t0:((H1,(H2,l2)),H2); H1:((H3,l1)); H2:((H3,(l3,H1))); H3:(l4);' ); # Print all available data print $net1; # Rebuild $net1 from its mu_data my %mudata=$net1->mudata(); my $net2=Bio::PhyloNetwork->new(-mudata=>\%mudata,-numleaves=>4); print $net2; print "d=".$net1->mu_distance($net2)."\n"; # Get another one and compute distance my $net3=Bio::PhyloNetwork->new( -eNewick=>'(l2,((l1,(H1,l4)),H1))r; (l3)H1;' ); print "d=".$net1->mu_distance($net3)."\n"; # ...and find an optimal alignment w.r.t. the Manhattan distance (default) my ($weight,%alignment)=$net1->optimal_alignment($net3); print "weight:$weight\n"; foreach my $node1 (keys %alignment) { print "$node1 => ".$alignment{$node1}."\n"; } # ...or the Hamming distance my ($weightH,%alignmentH)=$net1->optimal_alignment($net3,-metric=>'Hamming'); print "weight:$weightH\n"; foreach my $node1 (keys %alignmentH) { print "$node1 => ".$alignmentH{$node1}."\n"; } # Test for time consistency of $net1 if ($net1->is_time_consistent) { print "net1 is time consistent\n" } else { print "net1 is not time consistent\n" } # create a network from the list of edges my $net4=Bio::PhyloNetwork->new(-edges=> [qw(r s r t s u s c t c t v u b u l3 u b v b v l4 b l2 c l1)]); # Test for time consistency of $net3 if ($net4->is_time_consistent) { print "net4 is time consistent\n" } else { print "net4 is not time consistent\n" } # And print all information on net4 print $net4; # Compute some tripartitions my %triparts=$net1->tripartitions(); # Now these are stored print $net1; # And can compute the tripartition error print "dtr=".$net1->tripartition_error($net3)."\n"; =head1 DESCRIPTION =head2 Phylogenetic Networks This is a module to work with phylogenetic networks. Phylogenetic networks have been studied over the last years as a richer model of the evolutionary history of sets of organisms than phylogenetic trees, because they take not only mutation events but also recombination and horizontal gene transfer events into account. The natural model for describing the evolutionary history of a set of sequences under recombination events is a DAG, hence this package relies on the package Graph::Directed to represent the underlying graph of a phylogenetic network. We refer the reader to [CRV1,CRV2] for formal definitions related to phylogenetic networks. =head2 eNewick description With this package, phylogenetic networks can be given by its eNewick string. This description appeared in other packages related to phylogenetic networks (see [PhyloNet] and [NetGen]); in fact, these two packages use different descriptions. The Bio::PhyloNetwork package allows both of them, but uses the second one in its output. The first approach [PhyloNet] goes as follows: For each hybrid node H, say with parents u_1,u_2,...,u_k and children v_1,v_2,...v_l: split H in k+1 different nodes; let each of the first k copies be a child of one of the u_1,...,u_k (one for each) and have no children (hence we will have k extra leaves); as for the last copy, let it have no parents and have v_1,...,v_l be its children. This way we get a forest; each of the trees will be rooted at either one root of the phylogenetic network or a hybrid node of it; the set of leaves (of the whole forest) will be the set of leaves of the original network together with the set of hybrid nodes (each of them repeated as many times as its in-degree). Then, the eNewick representation of the phylogenetic network will be the Newick representation of all the trees in the obtained forest, each of them with its root labeled. The second approach [NetGen] goes as follows: For each hybrid node H, say with parents u_1,u_2,...,u_k and children v_1,v_2,...v_l: split H in k different nodes; let the first copy be a child of u_1 and have all v_1,v_2,...v_l as its children; let the other copies be child of u_2,...,u_k (one for each) and have no children. This way, we get a tree whose set of leaves is the set of leaves of the original network together with the set of hybrid nodes (possibly repeated). Then the Newick string of the obtained tree (note that some internal nodes will be labeled and some leaves will be repeated) is the eNewick string of the phylogenetic network. For example, consider the network depicted below: r / \ / \ U V / \ / \ 1 \ / 3 H | 2 If the first approach is taken, we get the forest: r / \ / \ U V / \ / \ 1 H H 3 | H | 2 Hence, the eNewick string is '((1,H),(H,3))r; (2)H;'. As for the second one, one gets the tree: r / \ / \ U V / \ / \ 1 H | 3 H | 2 Hence, the eNewick string is '((1,H),((2)H,3))r;'. Note: when rooting a tree, this package allows the notations '(subtree,subtree,...)root' as well as 'root:(subtree,subtree,...)', but the first one is used when writing eNewick strings. =head2 Tree-child phylogenetic networks Tree-child (TC) phylogenetic networks are a special class of phylogenetic networks for which a distance, called mu-distance, is defined [CRV2] based on certain data (mu-data) associated to every node. Moreover, this distance extends the Robinson-Foulds on phylogenetic trees. This package allows testing for a phylogenetic network if it is TC and computes mu-distances between networks over the same set of leaves. Moreover, the mu-data allows one to define the optimal (in some precise sense) alignment between networks over the same set of leaves. This package also computes this optimal alignment. =head2 Tripartitions Although tripartitions (see [CRV1] and the references therein) do not allow to define distances, this package outputs tripartitions and computes a weak form of the tripartition error. =head2 Time-consistency Another useful property of Phylogenetic Networks that appears in the literature is that of time-consistency or real-time hybrids [BSS]. Roughly speaking, a network admits a temporal representation if it can be drawn in such a way that tree arcs (those whose end is a tree node) are inclined downwards, while hybridization arcs (those whose end is a hybrid node) are horizontal. This package checks for time-consistency and, if so, a temporal representation is provided. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es Gabriel Valiente, valiente(at)lsi(dot)upc(dot)edu =head1 SEE ALSO =over =item [CRV1] G. Cardona, F. Rossello, G. Valiente. Tripartitions do not always discriminate phylogenetic networks. arXiv:0707.2376v1 [q-bio.PE] =item [CRV2] G. Cardona, F. Rossello, G. Valiente. A Distance Measure for Tree-Child Phylogenetic Networks. Preprint. =item [NetGen] M.M. Morin, and B.M.E. Moret. NetGen: generating phylogenetic networks with diploid hybrids. Bioinformatics 22 (2006), 1921-1923 =item [PhyloNet] PhyloNet: "Phylogenetic Networks Toolkit". http://bioinfo.cs.rice.edu/phylonet =item [BSS] M. Baroni, C. Semple, and M. Steel. Hybrids in Real Time. Syst. Biol. 55(1):46-56, 2006 =back =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork; use strict; use warnings; use base qw(Bio::Root::Root); use Bio::PhyloNetwork::muVector; use Graph::Directed; use Bio::TreeIO; use Bio::Tree::Node; use IO::String; use Array::Compare; use Algorithm::Munkres; # Creator =head2 new Title : new Usage : my $obj = new Bio::PhyloNetwork(); Function: Creates a new Bio::PhyloNetwork object Returns : Bio::PhyloNetwork Args : none OR -eNewick => string OR -graph => Graph::Directed object OR -edges => reference to an array OR -tree => Bio::Tree::Tree object OR -mudata => reference to a hash, -leaves => reference to an array OR -mudata => reference to a hash, -numleaves => integer Returns a Bio::PhyloNetwork object, created according to the data given: =over 3 =item new() creates an empty network. =item new(-eNewick =E $str) creates the network whose Extended Newick representation (see description above) is the string $str. =item new(-graph =E $graph) creates the network with underlying graph given by the Graph::Directed object $graph =item new(-tree =E $tree) creates a network as a copy of the Bio::Tree::Tree object in $tree =item new(-mudata =E \%mudata, -leaves =E \@leaves) creates the network by reconstructing it from its mu-data stored in \%mudata and with set of leaves in \@leaves. =item new(-mudata =E \%mudata, -numleaves =E $numleaves) creates the network by reconstructing it from its mu-data stored in \%mudata and with set of leaves in ("l1".."l$numleaves"). =back =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($eNewick,$edgesR,$leavesR,$numleaves,$graph,$tree,$mudataR)= $self->_rearrange([qw(ENEWICK EDGES LEAVES NUMLEAVES GRAPH TREE MUDATA)],@args); bless($self,$pkg); $self->build_from_eNewick($eNewick) if defined $eNewick; $self->build_from_edges(@$edgesR) if defined $edgesR; $self->build_from_graph($graph) if defined $graph; $self->build_from_tree($tree) if defined $tree; if ((! defined $leavesR) && (defined $numleaves)) { my @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } $self->build_from_mudata($mudataR,$leavesR) if ((defined $mudataR) && (defined $leavesR)); return $self; } # Builders sub build_from_edges { my ($self,@edges)=@_; my $graph=Graph::Directed->new(); $graph->add_edges(@edges); $self->{graph}=$graph; $self->recompute(); my $labels={}; foreach my $node ($self->nodes()) { $labels->{$node}=$node; } $self->{labels}=$labels; } sub build_from_graph { my ($self,$graph)=@_; my $graphcp=$graph->copy(); $self->{graph}=$graphcp; $self->recompute(); my $labels={}; foreach my $node ($self->nodes()) { $labels->{$node}=$node; } $self->{labels}=$labels; } my $_eN_index; sub build_from_eNewick { my ($self,$string)=@_; $_eN_index=0; my $graph=Graph::Directed->new(); my $labels={}; my @blocks=split(/; */,$string); foreach my $block (@blocks) { my ($rt,$str)=get_root_and_subtree($block); my ($rtlbl,$rttype,$rtid,$rtlng)=get_label_type_id_length($rt); process_block($graph,$labels,$block,$rtid); $labels->{$rtid}=$rtlbl.''; } $self->{graph}=$graph; $self->{labels}=$labels; $self->recompute(); } sub process_block { my ($graph,$labels,$block,$rtid)=@_; my ($rt,$str)=get_root_and_subtree($block); my @substrs=my_split($str); foreach my $substr (@substrs) { my ($subrt,$subblock)=get_root_and_subtree($substr); my ($subrtlbl,$subrttype,$subrtid,$subrtlng)= get_label_type_id_length($subrt); if (! $subrtlng eq '') { $graph->add_weighted_edges($rtid,$subrtid,$subrtlng); } else { $graph->add_edges($rtid,$subrtid); } if (! $subrttype eq '') { $graph->set_edge_attribute($rtid,$subrtid,'type',$subrttype); } $subrtlbl.=''; # if (! $subrtlbl eq '') { if ((! defined $labels->{$subrtid})||($labels->{$subrtid} eq '')){ $labels->{$subrtid}=$subrtlbl; } elsif (( $labels->{$subrtid} ne $subrtlbl )&&($subrtlbl ne '')) { # error die("Different labels for the same node (".$labels->{$subrtid}." and $subrtlbl)"); } # } if ($subblock ne "") { process_block($graph,$labels,$subblock,$subrtid); } } } sub get_root_and_subtree { my ($block)=@_; my ($rt,$str)=("",""); # ($rt,$str)=split(/:|=/,$block); ($rt,$str)=split(/=/,$block); if ($rt eq $block) { # try to look for root label at the end my $pos=length($rt)-1; while ((substr($rt,$pos,1) ne ")") && ($pos >=0)) { $pos--; } $rt=substr($block,$pos+1,length($block)-$pos); $str=substr($block,0,$pos+1); } $rt=trim($rt); $str=trim($str); return ($rt,$str); } sub get_label_type_id_length { my ($string) = @_; $string.=''; # print "$string\n"; if (index($string,'#')==-1) { # no hybrid my ($label,$length)=split(':',$string); $label.=''; my $id; if ((! defined $label) || ($label eq '')) { # create id $_eN_index++; $id="T$_eN_index"; } else { $id=$label; } return ($label,'',$id,$length); } else { # hybrid my ($label,$string2)=split('#',$string); my ($typeid,$length)=split(':',$string2); my $type=$typeid; $type =~ s/\d//g; my $id=$typeid; $id =~ s/\D//g; return ($label,$type,'#'.$id,$length); } } sub trim { my ($string) = @_; $string =~ s/^\s+//; $string =~ s/\s+$//; return $string; } sub my_split { my ( $string ) = @_; my $temp=""; my @substrings; my $level=1; for my $i ( 1 .. length( $string ) ) { my $char=substr($string,$i,1); if ($char eq "(") { $level++; } if ($char eq ")") { if ($level==1) { push @substrings, $temp; $temp=""; } $level--; } if (($char eq ",") && ($level==1)) { push @substrings, $temp; $temp=""; $char=""; } $temp = $temp.$char; } return @substrings; } sub build_from_mudata { my ($self,$mus,$leavesR)=@_; my $graph=Graph::Directed->new(); my @nodes=keys %{$mus}; my @leaves=@{$leavesR}; my %seen; my @internal; @seen{@leaves} = (); foreach my $node (@nodes) { push(@internal, $node) unless exists $seen{$node}; } @internal=sort {$mus->{$b} <=> $mus->{$a} } @internal; @nodes=(@internal,@leaves); my $numnodes=@nodes; for (my $i=0;$i<$numnodes;$i++) { my $mu=$mus->{$nodes[$i]}; my $j=$i+1; while ($mu->is_positive() && $j<$numnodes) { if ($mu->geq_poset($mus->{$nodes[$j]})) { $graph->add_edges(($nodes[$i],$nodes[$j])); $mu = $mu - $mus->{$nodes[$j]}; } $j++; } } $self->build_from_graph($graph); } # sub relabel_tree { # my ($tree)=@_; # my $i=1; # my $j=1; # my $root=$tree->get_root_node(); # foreach my $node ($tree->get_nodes()) { # if ($node == $root) { # $node->{'_id'}="r"; # } # elsif (! $node->is_Leaf) { # $node->{'_id'}="t$i"; # $i++; # } # else { # if ($node->{'_id'} eq "") { # $node->{'_id'}="l$j"; # $j++; # } # } # } # return $tree; # } # sub build_subtree { # my ($graph,$root)=@_; # foreach my $child ($root->each_Descendent) { # $graph->add_edge($root->id,$child->id); # $graph=build_subtree($graph,$child); # } # return $graph; # } sub build_from_tree { my ($self,$tree)=@_; # relabel_tree($tree); # my $treeroot=$tree->get_root_node; # my $graph=Graph::Directed->new(); # $graph=build_subtree($graph,$treeroot); # $self->build_from_graph($graph); my $str; my $io=IO::String->new($str); my $treeio=Bio::TreeIO->new(-format => 'newick', -fh => $io); $treeio->write_tree($tree); # print "intern: $str\n"; $self->build_from_eNewick($str); } sub recompute { my ($self)=@_; $self->throw("Graph is not DAG:".$self->{graph}) unless $self->{graph}->is_dag(); my @leaves=$self->{graph}->successorless_vertices(); @leaves=sort @leaves; my $numleaves=@leaves; my @roots=$self->{graph}->predecessorless_vertices(); my $numroots=@roots; #$self->throw("Graph is not rooted") unless ($numroots == 1); my @nodes=$self->{graph}->vertices(); @nodes=sort @nodes; my $numnodes=@nodes; foreach my $node (@nodes) { if (! defined $self->{labels}->{$node}) { $self->{labels}->{$node}=''; } } $self->{leaves}=\@leaves; $self->{numleaves}=$numleaves; $self->{roots}=\@roots; $self->{numroots}=$numroots; $self->{nodes}=\@nodes; $self->{numnodes}=$numnodes; $self->{mudata}={}; $self->{h}={}; $self->compute_height(); $self->compute_mu(); return $self; } # Hybridizing sub is_attackable { my ($self,$u1,$v1,$u2,$v2)=@_; if ( $self->is_hybrid_node($v1) || $self->is_hybrid_node($v2) || $self->graph->is_reachable($v2,$u1) || (($u1 eq $u2)&&($v1 eq $v2)) || (! scalar grep {($_ ne $v2) && ($self->is_tree_node($_))} $self->graph->successors($u2))) { return 0; } return 1; } sub do_attack { my ($self,$u1,$v1,$u2,$v2,$lbl)=@_; my $graph=$self->{graph}; $graph->delete_edge($u1,$v1); $graph->delete_edge($u2,$v2); $graph->add_edge($u1,"T$lbl"); $graph->add_edge("T$lbl",$v1); $graph->add_edge($u2,"#H$lbl"); $graph->add_edge("#H$lbl",$v2); $graph->add_edge("T$lbl","#H$lbl"); $self->build_from_graph($graph); } # Computation of mu-data sub compute_mu { my ($self)=@_; my $graph=$self->{graph}; my $mudata=$self->{mudata}; my @leaves=@{$self->{leaves}}; my $numleaves=$self->{numleaves}; for (my $i=0;$i<$numleaves;$i++) { my $vec=Bio::PhyloNetwork::muVector->new($numleaves); $vec->[$i]=1; $mudata->{$leaves[$i]}=$vec; } my $h=1; while (my @nodes=grep {$self->{h}->{$_} == $h} @{$self->{nodes}} ) { foreach my $u (@nodes) { my $vec=Bio::PhyloNetwork::muVector->new($numleaves); foreach my $son ($graph->successors($u)) { $vec+=$mudata->{$son}; } $mudata->{$u}=$vec; } $h++; } } sub compute_height { my ($self)=@_; my $graph=$self->{graph}; my @leaves=@{$self->{leaves}}; foreach my $leaf (@leaves) { $self->{h}->{$leaf}=0; } my $h=0; while (my @nodes=grep {(defined $self->{h}->{$_})&&($self->{h}->{$_} == $h)} @{$self->{nodes}} ) { foreach my $node (@nodes) { foreach my $parent ($graph->predecessors($node)) { $self->{h}->{$parent}=$h+1; } } $h++; } } # Tests =head2 is_leaf Title : is_leaf Usage : my $b=$net->is_leaf($u) Function: tests if $u is a leaf in $net Returns : boolean Args : scalar =cut sub is_leaf { my ($self,$node)=@_; if ($self->{graph}->out_degree($node) == 0) {return 1;} return 0; } =head2 is_root Title : is_root Usage : my $b=$net->is_root($u) Function: tests if $u is the root of $net Returns : boolean Args : scalar =cut sub is_root { my ($self,$node)=@_; if ($self->{graph}->in_degree($node) == 0) {return 1;} return 0; } =head2 is_tree_node Title : is_tree_node Usage : my $b=$net->is_tree_node($u) Function: tests if $u is a tree node in $net Returns : boolean Args : scalar =cut sub is_tree_node { my ($self,$node)=@_; if ($self->{graph}->in_degree($node) <= 1) {return 1;} return 0; } =head2 is_hybrid_node Title : is_hybrid_node Usage : my $b=$net->is_hybrid_node($u) Function: tests if $u is a hybrid node in $net Returns : boolean Args : scalar =cut sub is_hybrid_node { my ($self,$node)=@_; if ($self->{graph}->in_degree($node) > 1) {return 1;} return 0; } sub has_tree_child { # has_tree_child(g,u) returns 1 if u has a tree child in graph g # and 0 otherwise my $g=shift(@_); my $node=shift(@_); my @Sons=$g->successors($node); foreach my $son (@Sons) { if ($g->in_degree($son)==1) { return 1; } } return 0; } =head2 is_tree_child Title : is_tree_child Usage : my $b=$net->is_tree_child() Function: tests if $net is a Tree-Child phylogenetic network Returns : boolean Args : Bio::PhyloNetwork =cut sub is_tree_child { my ($self)=@_; if (defined $self->{is_tree_child}) { return $self->{is_tree_child}; } $self->{is_tree_child}=0; my $graph=$self->{graph}; foreach my $node (@{$self->{nodes}}) { return 0 unless ($graph->out_degree($node)==0 || has_tree_child($graph,$node)); } $self->{is_tree_child}=1; return 1; } # Accessors =head2 nodes Title : nodes Usage : my @nodes=$net->nodes() Function: returns the set of nodes of $net Returns : array Args : none =cut sub nodes { my ($self)=@_; return @{$self->{nodes}}; } =head2 leaves Title : leaves Usage : my @leaves=$net->leaves() Function: returns the set of leaves of $net Returns : array Args : none =cut sub leaves { my ($self)=@_; return @{$self->{leaves}}; } =head2 roots Title : roots Usage : my @roots=$net->roots() Function: returns the set of roots of $net Returns : array Args : none =cut sub roots { my ($self)=@_; return @{$self->{roots}}; } =head2 internal_nodes Title : internal_nodes Usage : my @internal_nodes=$net->internal_nodes() Function: returns the set of internal nodes of $net Returns : array Args : none =cut sub internal_nodes { my ($self)=@_; return grep {! $self->is_leaf($_)} $self->nodes(); } =head2 tree_nodes Title : tree_nodes Usage : my @tree_nodes=$net->tree_nodes() Function: returns the set of tree nodes of $net Returns : array Args : none =cut sub tree_nodes { my ($self)=@_; return grep {$self->is_tree_node($_)} $self->nodes(); } =head2 hybrid_nodes Title : hybrid_nodes Usage : my @hybrid_nodes=$net->hybrid_nodes() Function: returns the set of hybrid nodes of $net Returns : array Args : none =cut sub hybrid_nodes { my ($self)=@_; return grep {$self->is_hybrid_node($_)} $self->nodes(); } =head2 graph Title : graph Usage : my $graph=$net->graph() Function: returns the underlying graph of $net Returns : Graph::Directed Args : none =cut sub graph { my ($self)=@_; return $self->{graph}; } =head2 edges Title : edges Usage : my @edges=$net->edges() Function: returns the set of edges of $net Returns : array Args : none Each element in the array is an anonimous array whose first element is the head of the edge and the second one is the tail. =cut sub edges { my ($self)=@_; return $self->{graph}->edges(); } =head2 tree_edges Title : tree_edges Usage : my @tree_edges=$net->tree_edges() Function: returns the set of tree edges of $net (those whose tail is a tree node) Returns : array Args : none =cut sub tree_edges { my ($self)=@_; return grep {$self->is_tree_node($_->[1])} $self->edges(); } =head2 hybrid_edges Title : hybrid_edges Usage : my @hybrid_edges=$net->hybrid_edges() Function: returns the set of hybrid edges of $net (those whose tail is a hybrid node) Returns : array Args : none =cut sub hybrid_edges { my ($self)=@_; return grep {$self->is_hybrid_node($_->[1])} $self->edges(); } =head2 explode Title : explode Usage : my @trees=$net->explode() Function: returns the representation of $net by a set of Bio::Tree:Tree objects Returns : array Args : none =cut sub explode { my ($self)=@_; my @trees; $self->explode_rec(\@trees); return @trees; } sub explode_rec { my ($self,$trees)=@_; my @h = $self->hybrid_nodes; if (scalar @h) { my $v = shift @h; for my $u ($self->{graph}->predecessors($v)) { $self->{graph}->delete_edge($u,$v); $self->explode_rec($trees); $self->{graph}->add_edge($u,$v); } } else { my $io = IO::String->new($self->eNewick); my $treeio = Bio::TreeIO->new(-format => 'newick', -fh => $io); my $tree = $treeio->next_tree; $tree->contract_linear_paths; push @{$trees}, $tree; } } =head2 mudata Title : mudata Usage : my %mudata=$net->mudata() Function: returns the representation of $net by its mu-data Returns : hash Args : none $net-Emudata() returns a hash with keys the nodes of $net and each value is a muVector object holding its mu-vector. =cut sub mudata { my ($self)=@_; return %{$self->{mudata}}; } sub mudata_node { my ($self,$u)=@_; return $self->{mudata}{$u}; } =head2 heights Title : heights Usage : my %heights=$net->heights() Function: returns the heights of the nodes of $net Returns : hash Args : none $net-Eheights() returns a hash with keys the nodes of $net and each value is its height. =cut sub heights { my ($self)=@_; return %{$self->{h}}; } sub height_node { my ($self,$u)=@_; return $self->{h}{$u}; } =head2 mu_distance Title : mu_distance Usage : my $dist=$net1->mu_distance($net2) Function: Computes the mu-distance between the networks $net1 and $net2 on the same set of leaves Returns : scalar Args : Bio::PhyloNetwork =cut sub mu_distance { my ($net1,$net2)=@_; my @nodes1=$net1->nodes; my @nodes2=$net2->nodes; my $comp = Array::Compare->new; $net1->throw("Cannot compare phylogenetic networks on different set of leaves") unless $comp->compare($net1->{leaves},$net2->{leaves}); $net1->warn("Not a tree-child phylogenetic network") unless $net1->is_tree_child(); $net2->warn("Not a tree-child phylogenetic network") unless $net2->is_tree_child(); my @leaves=@{$net1->{leaves}}; my %matched1; my %matched2; OUTER: foreach my $node1 (@nodes1) { foreach my $node2 (@nodes2) { if ( (! exists $matched1{$node1}) && (! exists $matched2{$node2}) && ($net1->{mudata}{$node1} == $net2->{mudata}{$node2}) ) { $matched1{$node1}=$node2; $matched2{$node2}=$node1; next OUTER; } } } return (scalar @nodes1)+(scalar @nodes2)-2*(scalar keys %matched1); } =head2 mu_distance_generalized Title : mu_distance_generalized Usage : my $dist=$net1->mu_distance($net2) Function: Computes the mu-distance between the topological restrictions of networks $net1 and $net2 on its common set of leaves Returns : scalar Args : Bio::PhyloNetwork =cut sub mu_distance_generalized { my ($net1,$net2)=@_; my ($netr1,$netr2)=$net1->topological_restriction($net2); return $netr1->mu_distance($netr2); } # mudata_string (code mu_data in a string; useful for isomorphism testing) sub mudata_string_node { my ($self,$u)=@_; return $self->{mudata}->{$u}->display(); } sub mudata_string { my ($self)=@_; return $self->{mudata_string} if defined $self->{mudata_string}; my @internal=$self->internal_nodes; my $mus=$self->{mudata}; @internal=sort {$mus->{$b} <=> $mus->{$a} } @internal; my $str=""; foreach my $node (@internal) { $str=$str.$self->mudata_string_node($node); } $self->{mudata_string}=$str; return $str; } sub is_mu_isomorphic { my ($net1,$net2)=@_; return ($net1->mudata_string() eq $net2->mudata_string()); } # tripartitions sub compute_tripartition_node { my ($self,$u)=@_; $self->warn("Cannot compute tripartitions on unrooted networks. Will assume one at random") unless ($self->{numroots} == 1); my $root=$self->{roots}->[0]; my $graph=$self->{graph}; my $graphPruned=$graph->copy(); $graphPruned->delete_vertex($u); my $tripartition=""; foreach my $leaf (@{$self->{leaves}}) { my $type; if ($graph->is_reachable($u,$leaf)) { if ($graphPruned->is_reachable($root,$leaf)) {$type="B";} else {$type="A";} } else {$type="C";} $tripartition .= $type; } $self->{tripartitions}->{$u}=$tripartition; } sub compute_tripartitions { my ($self)=@_; foreach my $node (@{$self->{nodes}}) { $self->compute_tripartition_node($node); } } =head2 tripartitions Title : tripartitions Usage : my %tripartitions=$net->tripartitions() Function: returns the set of tripartitions of $net Returns : hash Args : none $net-Etripartitions() returns a hash with keys the nodes of $net and each value is a string representing the tripartition of the leaves induced by the node. A string "BCA..." associated with a node u (e.g.) means, the first leaf is in the set B(u), the second one in C(u), the third one in A(u), and so on. =cut sub tripartitions { my ($self)=@_; $self->compute_tripartitions() unless defined $self->{tripartitions}; return %{$self->{tripartitions}}; } # to do: change to tri_distance and test for TC and time-cons sub tripartition_error { my ($net1,$net2)=@_; my $comp = Array::Compare->new; $net1->throw("Cannot compare phylogenetic networks on different set of leaves") unless $comp->compare($net1->{leaves},$net2->{leaves}); $net1->warn("Not a tree-child phylogenetic network") unless $net1->is_tree_child(); $net2->warn("Not a tree-child phylogenetic network") unless $net2->is_tree_child(); $net1->warn("Not a time-consistent network") unless $net1->is_time_consistent(); $net2->warn("Not a time-consistent network") unless $net2->is_time_consistent(); $net1->compute_tripartitions() unless defined $net1->{tripartitions}; $net2->compute_tripartitions() unless defined $net2->{tripartitions}; my @edges1=$net1->{graph}->edges(); my @edges2=$net2->{graph}->edges(); my ($FN,$FP)=(0,0); foreach my $edge1 (@edges1) { my $matched=0; foreach my $edge2 (@edges2) { if ($net1->{tripartitions}->{$edge1->[1]} eq $net2->{tripartitions}->{$edge2->[1]}) { $matched=1; last; } } if (! $matched) {$FN++;} } foreach my $edge2 (@edges2) { my $matched=0; foreach my $edge1 (@edges1) { if ($net1->{tripartitions}->{$edge1->[1]} eq $net2->{tripartitions}->{$edge2->[1]}) { $matched=1; last; } } if (! $matched) {$FP++;} } return ($FN/(scalar @edges1)+$FP/(scalar @edges2))/2; } # Time-consistency # to do: add weak time consistency =head2 is_time_consistent Title : is_time_consistent Usage : my $b=$net->is_time_consistent() Function: tests if $net is (strong) time-consistent Returns : boolean Args : none =cut sub is_time_consistent { my ($self)=@_; $self->compute_temporal_representation() unless exists $self->{has_temporal_representation}; return $self->{has_temporal_representation}; } =head2 temporal_representation Title : temporal_representation Usage : my %time=$net->temporal_representation() Function: returns a hash containing a temporal representation of $net, or 0 if $net is not time-consistent Returns : hash Args : none =cut sub temporal_representation { my ($self)=@_; if ($self->is_time_consistent) { return %{$self->{temporal_representation}}; } return 0; } sub compute_temporal_representation { my ($self)=@_; my $quotient=Graph::Directed->new(); my $classes=find_classes($self); my %repr; map {$repr{$_}=$classes->{$_}[0]} $self->nodes(); foreach my $e ($self->tree_edges()) { $quotient->add_edge($repr{$e->[0]},$repr{$e->[1]}); } my %temp; my $depth=0; while ($quotient->vertices()) { if (my @svs=$quotient->predecessorless_vertices()) { foreach my $sv (@svs) { $temp{$sv}=$depth; } $quotient->delete_vertices(@svs); } else { return 0; } $depth++; } foreach my $node (@{$self->{nodes}}) { $temp{$node}=$temp{$repr{$node}} } $self->{temporal_representation}=\%temp; $self->{has_temporal_representation}=1; } sub find_classes { my ($self)=@_; my $classes={}; map {$classes->{$_}=[$_]} $self->nodes(); foreach my $e ($self->hybrid_edges()) { $classes=join_classes($classes,$e->[0],$e->[1]); } return $classes; } sub join_classes { my ($classes,$u,$v)=@_; my @clu=@{$classes->{$u}}; my @clv=@{$classes->{$v}}; my @cljoin=(@clu,@clv); map {$classes->{$_}=\@cljoin} @cljoin; return $classes; } # alignment =head2 contract_elementary Title : contract_elementary Usage : my ($contracted,$blocks)=$net->contract_elementary(); Function: Returns the network $contracted, obtained by contracting elementary paths of $net into edges. The reference $blocks points to a hash where, for each node of $contracted, gives the corresponding nodes of $net that have been deleted. Returns : Bio::PhyloNetwork,reference to hash Args : none =cut sub contract_elementary { my ($self)=@_; my $contracted=$self->graph->copy(); my @nodes=$self->nodes(); my $mus=$self->{mudata}; my $hs=$self->{h}; my %blocks; foreach my $u (@nodes) { $blocks{$u}=[$u]; } my @elementary=grep { $contracted->out_degree($_) == 1} $self->tree_nodes(); @elementary=sort {$mus->{$b} <=> $mus->{$a} || $hs->{$b} <=> $hs->{$a}} @elementary; foreach my $elem (@elementary) { my @children=$contracted->successors($elem); my $child=$children[0]; if ($contracted->in_degree($elem) == 1) { my @parents=$contracted->predecessors($elem); my $parent=$parents[0]; $contracted->add_edge($parent,$child); } $contracted->delete_vertex($elem); my @blch=@{$blocks{$child}}; my @blem=@{$blocks{$elem}}; $blocks{$child}=[@blem,@blch]; delete $blocks{$elem}; } my $contr=Bio::PhyloNetwork->new(-graph => $contracted); return $contr,\%blocks; } =head2 optimal_alignment Title : optimal_alignment Usage : my ($weight,$alignment,$wgts)=$net->optimal_alignment($net2) Function: returns the total weight of an optimal alignment, the alignment itself, and partial weights between the networks $net1 and $net2 on the same set of leaves. An optional argument allows one to use the Manhattan (default) or the Hamming distance between mu-vectors. Returns : scalar,reference to hash,reference to hash Args : Bio::PhyloNetwork, -metric => string (optional) Supported strings for the -metric parameter are 'Manhattan' or 'Hamming'. =cut sub optimal_alignment { my ($net1,$net2,%params)=@_; my ($net1cont,$blocks1)=contract_elementary($net1); my ($net2cont,$blocks2)=contract_elementary($net2); my ($wc,$alignc,$weightc)= optimal_alignment_noelementary($net1cont,$net2cont,%params); my %alignment=(); my $totalweigth=0; my %weigths=(); foreach my $u1 (keys %$alignc) { my $u2=$alignc->{$u1}; my @block1=@{$blocks1->{$u1}}; my @block2=@{$blocks2->{$u2}}; while (@block1 && @block2) { my $u1dc=pop @block1; my $u2dc=pop @block2; $alignment{$u1dc}=$u2dc; $weigths{$u1dc}=$weightc->{$u1}; $totalweigth+=$weigths{$u1dc}; } } return $totalweigth,\%alignment,\%weigths; } sub optimal_alignment_noelementary { my ($net1,$net2,%params)=@_; my $comp = Array::Compare->new; $net1->throw("Cannot align phylogenetic networks on different set of leaves") unless $comp->compare($net1->{leaves},$net2->{leaves}); my $distance; if ((defined $params{-metric})and ($params{-metric} eq 'Hamming')) { $distance='Hamming'; } else { $distance='Manhattan'; } my $numleaves=$net1->{numleaves}; my @nodes1=$net1->internal_nodes(); my @nodes2=$net2->internal_nodes(); my $numnodes1=@nodes1; my $numnodes2=@nodes2; my @matrix=(); for (my $i=0;$i<$numnodes1;$i++) { my @row=(); for (my $j=0;$j<$numnodes2;$j++) { push @row,weight($net1,$nodes1[$i],$net2,$nodes2[$j],$distance); } push @matrix,\@row; } my @alignment=(); Algorithm::Munkres::assign(\@matrix,\@alignment); my %alignmenthash; my %weighthash; my $totalw=0; foreach my $leaf (@{$net1->{leaves}}) { $alignmenthash{$leaf}=$leaf; $weighthash{$leaf}=0; } for (my $i=0;$i<$numnodes1;$i++) { if (defined $nodes2[$alignment[$i]]) { $alignmenthash{$nodes1[$i]}=$nodes2[$alignment[$i]]; $weighthash{$nodes1[$i]}=$matrix[$i][$alignment[$i]]; $totalw += $matrix[$i][$alignment[$i]]; } } return $totalw,\%alignmenthash,\%weighthash; } =head2 optimal_alignment_generalized Title : optimal_alignment_generalized Usage : my ($weight,%alignment)=$net->optimal_alignment_generalized($net2) Function: returns the wieght of an optimal alignment, and the alignment itself, between the topological restriction of the networks $net1 and $net2 on the set of common leaves. An optional argument allows one to use the Manhattan (default) or the Hamming distance between mu-vectors. Returns : scalar,hash Args : Bio::PhyloNetwork, -metric => string (optional) Supported strings for the -metric parameter are 'Manhattan' or 'Hamming'. =cut sub optimal_alignment_generalized { my ($net1,$net2,%params)=@_; my ($netr1,$netr2)=$net1->topological_restriction($net2); return $netr1->optimal_alignment($netr2,%params); } sub weight { my ($net1,$v1,$net2,$v2,$distance)=@_; my $w; if (! defined $distance) { $distance='Manhattan'; } if ($distance eq 'Hamming') { $w=$net1->{mudata}->{$v1}->hamming($net2->{mudata}->{$v2}); } else { $w=$net1->{mudata}->{$v1}->manhattan($net2->{mudata}->{$v2}); } if (($net1->is_tree_node($v1) && $net2->is_hybrid_node($v2)) || ($net2->is_tree_node($v2) && $net1->is_hybrid_node($v1)) ) { $w +=1/(2*$net1->{numleaves}); } return $w; } =head2 topological_restriction Title : topological_restriction Usage : my ($netr1,$netr2)=$net1->topological_restriction($net2) Function: returns the topological restriction of $net1 and $net2 on its common set of leaves Returns : Bio::PhyloNetwork, Bio::PhyloNetwork Args : Bio::PhyloNetwork =cut sub topological_restriction { my ($net1,$net2)=@_; my @leaves1=$net1->leaves(); my @leaves2=$net2->leaves(); my $numleaves1=scalar @leaves1; my $numleaves2=scalar @leaves2; my %position1; for (my $i=0; $i<$numleaves1; $i++) { $position1{$leaves1[$i]}=$i; } my %position2; my @commonleaves=(); for (my $j=0; $j<$numleaves2; $j++) { if (defined $position1{$leaves2[$j]}) { push @commonleaves,$leaves2[$j]; $position2{$leaves2[$j]}=$j; } } my $graphred1=$net1->{graph}->copy(); my $graphred2=$net2->{graph}->copy(); OUTER1: foreach my $u ($graphred1->vertices()) { my $mu=$net1->mudata_node($u); foreach my $leaf (@commonleaves) { if ($mu->[$position1{$leaf}]>0) { next OUTER1; } } $graphred1->delete_vertex($u); } OUTER2: foreach my $u ($graphred2->vertices()) { my $mu=$net2->mudata_node($u); foreach my $leaf (@commonleaves) { if ($mu->[$position2{$leaf}]>0) { next OUTER2; } } $graphred2->delete_vertex($u); } my $netr1=Bio::PhyloNetwork->new(-graph => $graphred1); my $netr2=Bio::PhyloNetwork->new(-graph => $graphred2); return ($netr1,$netr2); } # Functions for eNewick representation =head2 eNewick Title : eNewick Usage : my $str=$net->eNewick() Function: returns the eNewick representation of $net without labeling internal tree nodes Returns : string Args : none =cut sub eNewick { my ($self)=@_; my $str=""; my $seen={}; foreach my $root ($self->roots()) { $str=$str.$self->eNewick_aux($root,$seen,undef)."; "; } return $str; } sub eNewick_aux { my ($self,$node,$seen,$parent)=@_; my $str=''; if ($self->is_leaf($node) || (defined $seen->{$node}) ) { $str=make_label($self,$parent,$node); } else { $seen->{$node}=1; my @sons=$self->{graph}->successors($node); $str="("; foreach my $son (@sons) { $str=$str.$self->eNewick_aux($son,$seen,$node).","; } chop($str); $str.=")".make_label($self,$parent,$node); } return $str; } sub make_label { my ($self,$parent,$node)=@_; my $str=''; if ($self->is_hybrid_node($node)) { my $lbl=$self->{labels}->{$node}; if ($lbl =~ /#/) { $lbl=''; } $str.=$lbl; #$self->{labels}->{$node}; $str.='#'; if ((defined $parent) && ($self->graph->has_edge_attribute($parent,$node,'type'))) { $str.=$self->graph->get_edge_attribute($parent,$node,'type'); } $str.=substr $node,1; } else { $str.=$self->{labels}->{$node}; } if ((defined $parent) && ($self->graph->has_edge_weight($parent,$node))) { $str.=":".$self->graph->get_edge_weight($parent,$node); } return $str; } =head2 eNewick_full Title : eNewick_full Usage : my $str=$net->eNewick_full() Function: returns the eNewick representation of $net labeling internal tree nodes Returns : string Args : none =cut sub eNewick_full { my ($self)=@_; my $str=""; my $seen={}; foreach my $root ($self->roots()) { $str=$str.$self->eNewick_full_aux($root,$seen,undef)."; "; } return $str; } sub eNewick_full_aux { my ($self,$node,$seen,$parent)=@_; my $str=''; if ($self->is_leaf($node) || (defined $seen->{$node}) ) { $str=make_label_full($self,$parent,$node); } else { $seen->{$node}=1; my @sons=$self->{graph}->successors($node); $str="("; foreach my $son (@sons) { $str=$str.$self->eNewick_full_aux($son,$seen,$node).","; } chop($str); $str.=")".make_label_full($self,$parent,$node); } return $str; } sub make_label_full { my ($self,$parent,$node)=@_; my $str=''; if ($self->is_hybrid_node($node)) { my $lbl=$self->{labels}->{$node}; if ($lbl =~ /#/) { $lbl=''; } $str.=$lbl; #$self->{labels}->{$node}; $str.='#'; if ((defined $parent) && ($self->graph->has_edge_attribute($parent,$node,'type'))) { $str.=$self->graph->get_edge_attribute($parent,$node,'type'); } $str.=substr $node,1; } else { if ((defined $self->{labels}->{$node})&&($self->{labels}->{$node} ne '')) { $str.=$self->{labels}->{$node}; } else { $str.=$node; } } if ((defined $parent) && ($self->graph->has_edge_weight($parent,$node))) { $str.=":".$self->graph->get_edge_weight($parent,$node); } return $str; } # sub eNewick_full { # my ($self)=@_; # my $str=""; # my $seen={}; # foreach my $root ($self->roots()) { # $str=$str.$self->eNewick_full_aux($root,$seen,undef)."; "; # } # return $str; # } # sub eNewick_full_aux { # my ($self,$node,$seen,$parent)=@_; # my $str; # if ($self->is_leaf($node) || # (defined $seen->{$node}) ) # { # if ($self->is_hybrid_node($node)) { # my $tag=substr $node,1; # if ((defined $parent) && # ($self->graph->has_edge_attribute($parent,$node,'type'))) { # $str='#'.$self->graph->get_edge_attribute($parent,$node,'type').$tag; # } else { # $str=$node; # } # } else { # $str=$node; # } # } # else { # $seen->{$node}=1; # my @sons=$self->{graph}->successors($node); # $str="("; # foreach my $son (@sons) { # $str=$str.$self->eNewick_full_aux($son,$seen,$node).","; # } # chop($str); # if ($self->is_hybrid_node($node)) { # my $tag=substr $node,1; # if ((defined $parent) && # ($self->graph->has_edge_attribute($parent,$node,'type'))) { # $str.=')#'.$self->graph->get_edge_attribute($parent,$node,'type').$tag; # } else { # $str.=")$node"; # } # } else { # $str.=")$node"; # } # } # if ((defined $parent) && # ($self->graph->has_edge_weight($parent,$node))) { # $str.=":".$self->graph->get_edge_weight($parent,$node); # } # return $str; # } # displaying data use overload '""' => \&display; =head2 display Title : display Usage : my $str=$net->display() Function: returns a string containing all the available information on $net Returns : string Args : none =cut sub display { my ($self)=@_; my $str=""; my $graph=$self->{graph}; my @leaves=$self->leaves(); my @nodes=@{$self->{nodes}}; $str.= "Leaves:\t@leaves\n"; $str.= "Nodes:\t@nodes\n"; $str.= "Graph:\t$graph\n"; $str.= "eNewick:\t".$self->eNewick()."\n"; $str.= "Full eNewick:\t".$self->eNewick_full()."\n"; $str.= "Mu-data and heights:\n"; foreach my $node (@nodes) { $str.= "v=$node: "; if (exists $self->{labels}->{$node}) { $str.="\tlabel=".$self->{labels}->{$node}.","; } else { $str.="\tlabel=(none),"; } $str.= "\th=".$self->{h}->{$node}.", \tmu=".$self->{mudata}->{$node}."\n"; } if (exists $self->{has_temporal_representation}) { $str.= "Temporal representation:\n"; if ($self->{has_temporal_representation}) { foreach my $node (@nodes) { $str.= "v=$node; "; $str.= "\tt=".$self->{temporal_representation}->{$node}."\n"; } } else { $str.= "Does not exist.\n"; } } if (exists $self->{tripartitions}) { $str.= "Tripartitions:\n"; foreach my $node (@nodes) { $str.= "v=$node; "; $str.= "\ttheta=".$self->{tripartitions}->{$node}."\n"; } } return $str; } 1; BioPerl-1.6.923/Bio/PrimarySeq.pm000444000765000024 7471312254227316 16637 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::PrimarySeq # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PrimarySeq - Bioperl lightweight sequence object =head1 SYNOPSIS # Bio::SeqIO for file reading, Bio::DB::GenBank for # database reading use Bio::Seq; use Bio::SeqIO; use Bio::DB::GenBank; # make from memory $seqobj = Bio::PrimarySeq->new ( -seq => 'ATGGGGTGGGCGGTGGGTGGTTTG', -id => 'GeneFragment-12', -accession_number => 'X78121', -alphabet => 'dna', -is_circular => 1, ); print "Sequence ", $seqobj->id(), " with accession ", $seqobj->accession_number, "\n"; # read from file $inputstream = Bio::SeqIO->new( -file => "myseq.fa", -format => 'Fasta', ); $seqobj = $inputstream->next_seq(); print "Sequence ", $seqobj->id(), " and desc ", $seqobj->desc, "\n"; # to get out parts of the sequence. print "Sequence ", $seqobj->id(), " with accession ", $seqobj->accession_number, " and desc ", $seqobj->desc, "\n"; $string = $seqobj->seq(); $string2 = $seqobj->subseq(1,40); =head1 DESCRIPTION PrimarySeq is a lightweight sequence object, storing the sequence, its name, a computer-useful unique name, and other fundamental attributes. It does not contain sequence features or other information. To have a sequence with sequence features you should use the Seq object which uses this object. Although new users will use Bio::PrimarySeq a lot, in general you will be using it from the Bio::Seq object. For more information on Bio::Seq see L. For interest you might like to know that Bio::Seq has-a Bio::PrimarySeq and forwards most of the function calls to do with sequence to it (the has-a relationship lets us get out of a otherwise nasty cyclical reference in Perl which would leak memory). Sequence objects are defined by the Bio::PrimarySeqI interface, and this object is a pure Perl implementation of the interface. If that's gibberish to you, don't worry. The take home message is that this object is the bioperl default sequence object, but other people can use their own objects as sequences if they so wish. If you are interested in wrapping your own objects as compliant Bioperl sequence objects, then you should read the Bio::PrimarySeqI documentation The documentation of this object is a merge of the Bio::PrimarySeq and Bio::PrimarySeqI documentation. This allows all the methods which you can call on sequence objects here. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::PrimarySeq; use strict; our $MATCHPATTERN = 'A-Za-z\-\.\*\?=~'; our $GAP_SYMBOLS = '-~'; use base qw(Bio::Root::Root Bio::PrimarySeqI Bio::IdentifiableI Bio::DescribableI); # Setup the allowed values for alphabet() my %valid_type = map {$_, 1} qw( dna rna protein ); =head2 new Title : new Usage : $seqobj = Bio::PrimarySeq->new( -seq => 'ATGGGGGTGGTGGTACCCT', -id => 'human_id', -accession_number => 'AL000012', ); Function: Returns a new primary seq object from basic constructors, being a string for the sequence and strings for id and accession_number. Note that you can provide an empty sequence string. However, in this case you MUST specify the type of sequence you wish to initialize by the parameter -alphabet. See alphabet() for possible values. Returns : a new Bio::PrimarySeq object Args : -seq => sequence string -ref_to_seq => ... or reference to a sequence string -display_id => display id of the sequence (locus name) -accession_number => accession number -primary_id => primary id (Genbank id) -version => version number -namespace => the namespace for the accession -authority => the authority for the namespace -description => description text -desc => alias for description -alphabet => skip alphabet guess and set it to dna, rna or protein -id => alias for display id -is_circular => boolean to indicate that sequence is circular -direct => boolean to directly set sequences. The next time -seq, seq() or -ref_to_seq is use, the sequence will not be validated. Be careful with this... -nowarnonempty => boolean to avoid warning when sequence is empty =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($seq, $id, $acc, $pid, $ns, $auth, $v, $oid, $desc, $description, $alphabet, $given_id, $is_circular, $direct, $ref_to_seq, $len, $nowarnonempty) = $self->_rearrange([qw(SEQ DISPLAY_ID ACCESSION_NUMBER PRIMARY_ID NAMESPACE AUTHORITY VERSION OBJECT_ID DESC DESCRIPTION ALPHABET ID IS_CIRCULAR DIRECT REF_TO_SEQ LENGTH NOWARNONEMPTY )], @args); # Private var _nowarnonempty, needs to be set before calling _guess_alphabet $self->{'_nowarnonempty'} = $nowarnonempty; $self->{'_direct'} = $direct; if( defined $id && defined $given_id ) { if( $id ne $given_id ) { $self->throw("Provided both id and display_id constructors: [$id] [$given_id]"); } } if( defined $given_id ) { $id = $given_id; } # Bernd's idea: set ids now for more informative invalid sequence messages defined $id && $self->display_id($id); $acc && $self->accession_number($acc); defined $pid && $self->primary_id($pid); # Set alphabet now to avoid guessing it later, when sequence is set $alphabet && $self->alphabet($alphabet); # Set the length before the seq. If there is a seq, length will be updated later $self->{'length'} = $len || 0; # Set the sequence (but also alphabet and length) if ($ref_to_seq) { $self->_set_seq_by_ref($ref_to_seq, $alphabet); } else { if (defined $seq) { # Note: the sequence string may be empty $self->seq($seq); } } $desc && $self->desc($desc); $description && $self->description($description); $ns && $self->namespace($ns); $auth && $self->authority($auth); # Any variable that can have a value "0" must be tested with defined # or it will fail to be added to the new object defined($v) && $self->version($v); defined($oid) && $self->object_id($oid); defined($is_circular) && $self->is_circular($is_circular); return $self; } =head2 seq Title : seq Usage : $string = $seqobj->seq(); Function: Get or set the sequence as a string of letters. The case of the letters is left up to the implementer. Suggested cases are upper case for proteins and lower case for DNA sequence (IUPAC standard), but you should not rely on this. An error is thrown if the sequence contains invalid characters: see validate_seq(). Returns : A scalar Args : - Optional new sequence value (a string) to set - Optional alphabet (it is guessed by default) =cut sub seq { my ($self, @args) = @_; if( scalar @args == 0 ) { return $self->{'seq'}; } my ($seq_str, $alphabet) = @args; if (@args) { $self->_set_seq_by_ref(\$seq_str, $alphabet); } return $self->{'seq'}; } sub _set_seq_by_ref { # Set a sequence by reference. A reference is used to avoid the cost of # copying the sequence (which can be very large) between functions. my ($self, $seq_str_ref, $alphabet) = @_; # Validate sequence if sequence is not empty and we are not in direct mode if ( (! $self->{'_direct'}) && (defined $$seq_str_ref) ) { $self->validate_seq($$seq_str_ref, 1); } delete $self->{'_direct'}; # next sequence will have to be validated # Record sequence length my $len = CORE::length($$seq_str_ref || ''); my $is_changed_seq = (exists $self->{'seq'}) && ($len > 0); # Note: if the new seq is empty or undef, this is not considered a change delete $self->{'_freeze_length'} if $is_changed_seq; $self->{'length'} = $len if not exists $self->{'_freeze_length'}; # Set sequence $self->{'seq'} = $$seq_str_ref; # Set or guess alphabet if ($alphabet) { # Alphabet specified, set it no matter what $self->alphabet($alphabet); } elsif ($is_changed_seq || (! defined($self->alphabet()))) { # If we changed a previous sequence to a new one or if there is no # alphabet yet at all, we need to guess the (possibly new) alphabet $self->_guess_alphabet(); } # else (seq not changed and alphabet was defined) do nothing return 1; } =head2 validate_seq Title : validate_seq Usage : if(! $seqobj->validate_seq($seq_str) ) { print "sequence $seq_str is not valid for an object of alphabet ",$seqobj->alphabet, "\n"; } Function: Test that the given sequence is valid, i.e. contains only valid characters. The allowed characters are all letters (A-Z) and '-','.', '*','?','=' and '~'. Spaces are not valid. Note that this implementation does not take alphabet() into account and that empty sequences are considered valid. Returns : 1 if the supplied sequence string is valid, 0 otherwise. Args : - Sequence string to be validated - Boolean to optionally throw an error if the sequence is invalid =cut sub validate_seq { my ($self, $seqstr, $throw) = @_; if ( (defined $seqstr ) && ($seqstr !~ /^[$MATCHPATTERN]*$/) ) { if ($throw) { $self->throw("Failed validation of sequence '".(defined($self->id) || '[unidentified sequence]')."'. Invalid characters were: " . join('',($seqstr =~ /[^$MATCHPATTERN]/g))); } return 0; } return 1; } =head2 subseq Title : subseq Usage : $substring = $seqobj->subseq(10,40); $substring = $seqobj->subseq(10,40,'nogap'); $substring = $seqobj->subseq(-start=>10, -end=>40, -replace_with=>'tga'); $substring = $seqobj->subseq($location_obj); $substring = $seqobj->subseq($location_obj, -nogap => 1); Function: Return the subseq from start to end, where the first sequence character has coordinate 1 number is inclusive, ie 1-2 are the first two characters of the sequence. The given start coordinate has to be larger than the end, even if the sequence is circular. Returns : a string Args : integer for start position integer for end position OR Bio::LocationI location for subseq (strand honored) Specify -NOGAP=>1 to return subseq with gap characters removed Specify -REPLACE_WITH=>$new_subseq to replace the subseq returned with $new_subseq in the sequence object =cut sub subseq { my $self = shift; my @args = @_; my ($start, $end, $nogap, $replace) = $self->_rearrange([qw(START END NOGAP REPLACE_WITH)], @args); # If -replace_with is specified, validate the replacement sequence if (defined $replace) { $self->validate_seq( $replace ) || $self->throw("Replacement sequence does not look valid"); } if( ref($start) && $start->isa('Bio::LocationI') ) { my $loc = $start; my $seq = ''; # For Split objects if Guide Strand is negative, # pass the sublocations in reverse my $order = 0; if ($loc->isa('Bio::Location::SplitLocationI')) { # guide_strand can return undef, so don't compare directly # to avoid 'uninitialized value' warning my $guide_strand = defined ($loc->guide_strand) ? ($loc->guide_strand) : 0; $order = ($guide_strand == -1) ? -1 : 0; } # Reversing order using ->each_Location(-1) does not work well for # cut by origin-splits (like "complement(join(1900..END,START..50))"), # so use "reverse" instead my @sublocs = ($order == -1) ? reverse $loc->each_Location(): $loc->each_Location; foreach my $subloc (@sublocs) { my $piece = $self->subseq(-start => $subloc->start(), -end => $subloc->end(), -replace_with => $replace, -nogap => $nogap); $piece =~ s/[$GAP_SYMBOLS]//g if $nogap; # strand can return undef, so don't compare directly # to avoid 'uninitialized value' warning my $strand = defined ($subloc->strand) ? ($subloc->strand) : 0; if ($strand < 0) { $piece = $self->_revcom_from_string($piece, $self->alphabet); } $seq .= $piece; } return $seq; } elsif( defined $start && defined $end ) { if( $start > $end ){ $self->throw("Bad start,end parameters. Start [$start] has to be ". "less than end [$end]"); } if( $start <= 0 ) { $self->throw("Bad start parameter ($start). Start must be positive."); } # Remove one from start, and then length is end-start $start--; my $seqstr; if (defined $replace) { $seqstr = substr $self->{seq}, $start, $end-$start, $replace; } else { $seqstr = substr $self->{seq}, $start, $end-$start; } if ($end > $self->length) { if ($self->is_circular) { my $start = 0; my $end = $end - $self->length; my $appendstr; if (defined $replace) { $appendstr = substr $self->{seq}, $start, $end-$start, $replace; } else { $appendstr = substr $self->{seq}, $start, $end-$start; } $seqstr .= $appendstr; } else { $self->throw("Bad end parameter ($end). End must be less than ". "the total length of sequence (total=".$self->length.")") } } $seqstr =~ s/[$GAP_SYMBOLS]//g if ($nogap); return $seqstr; } else { $self->warn("Incorrect parameters to subseq - must be two integers or ". "a Bio::LocationI object. Got:", $self,$start,$end,$replace,$nogap); return; } } =head2 length Title : length Usage : $len = $seqobj->length(); Function: Get the stored length of the sequence in number of symbols (bases or amino acids). In some circumstances, you can also set this attribute: 1/ For empty sequences, you can set the length to anything you want: my $seqobj = Bio::PrimarySeq->new( -length => 123 ); my $len = $seqobj->len; # 123 2/ To save memory when using very long sequences, you can set the length of the sequence to the length of the sequence (and nothing else): my $seqobj = Bio::PrimarySeq->new( -seq => 'ACGT...' ); # 1 Mbp sequence # process $seqobj... then after you're done with it $seqobj->length($seqobj->length); $seqobj->seq(undef); # free memory! my $len = $seqobj->len; # 1 Mbp Note that if you set seq() to a value other than undef at any time, the length attribute will be reset. Returns : integer representing the length of the sequence. Args : Optionally, the value on set =cut sub length { my ($self, $val) = @_; if (defined $val) { my $len = $self->{'length'}; if ($len && ($len != $val)) { $self->throw("You're trying to lie about the length: ". "is $len but you say ".$val); } $self->{'length'} = $val; $self->{'_freeze_length'} = undef; } return $self->{'length'}; } =head2 display_id Title : display_id or display_name Usage : $id_string = $seqobj->display_id(); Function: Get or set the display id, aka the common name of the sequence object. The semantics of this is that it is the most likely string to be used as an identifier of the sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. With the new Bio::DescribeableI interface, display_name aliases to this method. Returns : A string for the display ID Args : Optional string for the display ID to set =cut sub display_id { my ($self, $value) = @_; if( defined $value) { $self->{'display_id'} = $value; } return $self->{'display_id'}; } =head2 accession_number Title : accession_number or object_id Usage : $unique_key = $seqobj->accession_number; Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". [Note this method name is likely to change in 1.3] With the new Bio::IdentifiableI interface, this is aliased to object_id Returns : A string Args : A string (optional) for setting =cut sub accession_number { my( $self, $acc ) = @_; if (defined $acc) { $self->{'accession_number'} = $acc; } else { $acc = $self->{'accession_number'}; $acc = 'unknown' unless defined $acc; } return $acc; } =head2 primary_id Title : primary_id Usage : $unique_key = $seqobj->primary_id; Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no natural primary id, this method should return a stringified memory location. Returns : A string Args : A string (optional, for setting) =cut sub primary_id { my $self = shift; if(@_) { $self->{'primary_id'} = shift; } if( ! defined($self->{'primary_id'}) ) { return "$self"; } return $self->{'primary_id'}; } =head2 alphabet Title : alphabet Usage : if( $seqobj->alphabet eq 'dna' ) { # Do something } Function: Get/set the alphabet of sequence, one of 'dna', 'rna' or 'protein'. This is case sensitive. This is not called because this would cause upgrade problems from the 0.5 and earlier Seq objects. Returns : a string either 'dna','rna','protein'. NB - the object must make a call of the type - if there is no alphabet specified it has to guess. Args : optional string to set : 'dna' | 'rna' | 'protein' =cut sub alphabet { my ($self,$value) = @_; if (defined $value) { $value = lc $value; unless ( $valid_type{$value} ) { $self->throw("Alphabet '$value' is not a valid alphabet (". join(',', map "'$_'", sort keys %valid_type) .") lowercase"); } $self->{'alphabet'} = $value; } return $self->{'alphabet'}; } =head2 desc Title : desc or description Usage : $seqobj->desc($newval); Function: Get/set description of the sequence. 'description' is an alias for this for compliance with the Bio::DescribeableI interface. Returns : value of desc (a string) Args : newvalue (a string or undef, optional) =cut sub desc{ my $self = shift; return $self->{'desc'} = shift if @_; return $self->{'desc'}; } =head2 can_call_new Title : can_call_new Usage : Function: Example : Returns : true Args : =cut sub can_call_new { my ($self) = @_; return 1; } =head2 id Title : id Usage : $id = $seqobj->id(); Function: This is mapped on display_id Example : Returns : Args : =cut sub id { return shift->display_id(@_); } =head2 is_circular Title : is_circular Usage : if( $seqobj->is_circular) { # Do something } Function: Returns true if the molecule is circular Returns : Boolean value Args : none =cut sub is_circular{ my $self = shift; return $self->{'is_circular'} = shift if @_; return $self->{'is_circular'}; } =head1 Methods for Bio::IdentifiableI compliance =head2 object_id Title : object_id Usage : $string = $seqobj->object_id(); Function: Get or set a string which represents the stable primary identifier in this namespace of this object. For DNA sequences this is its accession_number, similarly for protein sequences. This is aliased to accession_number(). Returns : A scalar Args : Optional object ID to set. =cut sub object_id { return shift->accession_number(@_); } =head2 version Title : version Usage : $version = $seqobj->version(); Function: Get or set a number which differentiates between versions of the same object. Higher numbers are considered to be later and more relevant, but a single object described the same identifier should represent the same concept. Returns : A number Args : Optional version to set. =cut sub version{ my ($self,$value) = @_; if( defined $value) { $self->{'_version'} = $value; } return $self->{'_version'}; } =head2 authority Title : authority Usage : $authority = $seqobj->authority(); Function: Get or set a string which represents the organisation which granted the namespace, written as the DNS name of the organisation (eg, wormbase.org). Returns : A scalar Args : Optional authority to set. =cut sub authority { my ($self, $value) = @_; if( defined $value) { $self->{'authority'} = $value; } return $self->{'authority'}; } =head2 namespace Title : namespace Usage : $string = $seqobj->namespace(); Function: Get or set a string representing the name space this identifier is valid in, often the database name or the name describing the collection. Returns : A scalar Args : Optional namespace to set. =cut sub namespace{ my ($self,$value) = @_; if( defined $value) { $self->{'namespace'} = $value; } return $self->{'namespace'} || ""; } =head1 Methods for Bio::DescribableI compliance This comprises of display_name and description. =head2 display_name Title : display_name Usage : $string = $seqobj->display_name(); Function: Get or set a string which is what should be displayed to the user. The string should have no spaces (ideally, though a cautious user of this interface would not assumme this) and should be less than thirty characters (though again, double checking this is a good idea). This is aliased to display_id(). Returns : A string for the display name Args : Optional string for the display name to set. =cut sub display_name { return shift->display_id(@_); } =head2 description Title : description Usage : $string = $seqobj->description(); Function: Get or set a text string suitable for displaying to the user a description. This string is likely to have spaces, but should not have any newlines or formatting - just plain text. The string should not be greater than 255 characters and clients can feel justified at truncating strings at 255 characters for the purposes of display. This is aliased to desc(). Returns : A string for the description Args : Optional string for the description to set. =cut sub description { return shift->desc(@_); } =head1 Methods Inherited from Bio::PrimarySeqI These methods are available on Bio::PrimarySeq, although they are actually implemented on Bio::PrimarySeqI =head2 revcom Title : revcom Usage : $rev = $seqobj->revcom(); Function: Produces a new Bio::SeqI implementing object which is the reversed complement of the sequence. For protein sequences this throws an exception of "Sequence is a protein. Cannot revcom". The id is the same id as the orginal sequence, and the accession number is also indentical. If someone wants to track that this sequence has be reversed, it needs to define its own extensions. To do an inplace edit of an object you can go: $seqobj = $seqobj->revcom(); This of course, causes Perl to handle the garbage collection of the old object, but it is roughly speaking as efficient as an inplace edit. Returns : A new (fresh) Bio::SeqI object Args : none =head2 trunc Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence, Returns : A fresh Bio::SeqI implementing object. Args : Numbers for the start and end positions =head1 Internal methods These are internal methods to PrimarySeq =head2 _guess_alphabet Title : _guess_alphabet Usage : Function: Automatically guess and set the type of sequence: dna, rna, protein or '' if the sequence was empty. This method first removes dots (.), dashes (-) and question marks (?) before guessing the alphabet using the IUPAC conventions for ambiguous residues. Since the DNA and RNA characters are also valid characters for proteins, there is no foolproof way of determining the right alphabet. This is our best guess only! Returns : string 'dna', 'rna', 'protein' or ''. Args : none =cut sub _guess_alphabet { my ($self) = @_; # Guess alphabet my $alphabet = $self->_guess_alphabet_from_string($self->seq, $self->{'_nowarnonempty'}); # Set alphabet unless it is unknown $self->alphabet($alphabet) if $alphabet; return $alphabet; } sub _guess_alphabet_from_string { # Get the alphabet from a sequence string my ($self, $str, $nowarnonempty) = @_; $nowarnonempty = 0 if not defined $nowarnonempty; # Remove chars that clearly don't denote nucleic or amino acids $str =~ s/[-.?]//gi; # Check for sequences without valid letters my $alphabet; my $total = CORE::length($str); if( $total == 0 ) { if (not $nowarnonempty) { $self->warn("Got a sequence without letters. Could not guess alphabet"); } $alphabet = ''; } # Determine alphabet now if (not defined $alphabet) { if ($str =~ m/[EFIJLOPQXZ]/i) { # Start with a safe method to find proteins. # Unambiguous IUPAC letters for proteins are: E,F,I,J,L,O,P,Q,X,Z $alphabet = 'protein'; } else { # Alphabet is unsure, could still be DNA, RNA or protein # DNA and RNA contain mostly A, T, U, G, C and N, but the other # letters they use are also among the 15 valid letters that a # protein sequence can contain at this stage. Make our best guess # based on sequence composition. If it contains over 70% of ACGTUN, # it is likely nucleic. if( ($str =~ tr/ATUGCNWSKMatugcnwskm//) / $total > 0.7 ) { if ( $str =~ m/U/i ) { $alphabet = 'rna'; } else { $alphabet = 'dna'; } } else { $alphabet = 'protein'; } } } return $alphabet; } ############################################################################ # aliases due to name changes or to compensate for our lack of consistency # ############################################################################ sub accession { my $self = shift; $self->warn(ref($self)."::accession is deprecated, ". "use accession_number() instead"); return $self->accession_number(@_); } 1; BioPerl-1.6.923/Bio/PrimarySeqI.pm000444000765000024 7700212254227336 16744 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PrimarySeqI # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PrimarySeqI - Interface definition for a Bio::PrimarySeq =head1 SYNOPSIS # Bio::PrimarySeqI is the interface class for sequences. # If you are a newcomer to bioperl, you might want to start with # Bio::Seq documentation. # Test if this is a seq object $obj->isa("Bio::PrimarySeqI") || $obj->throw("$obj does not implement the Bio::PrimarySeqI interface"); # Accessors $string = $obj->seq(); $substring = $obj->subseq(12,50); $display = $obj->display_id(); # for human display $id = $obj->primary_id(); # unique id for this object, # implementation defined $unique_key= $obj->accession_number(); # unique biological id # Object manipulation eval { $rev = $obj->revcom(); }; if( $@ ) { $obj->throw( "Could not reverse complement. ". "Probably not DNA. Actual exception\n$@\n" ); } $trunc = $obj->trunc(12,50); # $rev and $trunc are Bio::PrimarySeqI compliant objects =head1 DESCRIPTION This object defines an abstract interface to basic sequence information - for most users of the package the documentation (and methods) in this class are not useful - this is a developers-only class which defines what methods have to be implmented by other Perl objects to comply to the Bio::PrimarySeqI interface. Go "perldoc Bio::Seq" or "man Bio::Seq" for more information on the main class for sequences. PrimarySeq is an object just for the sequence and its name(s), nothing more. Seq is the larger object complete with features. There is a pure perl implementation of this in L. If you just want to use L objects, then please read that module first. This module defines the interface, and is of more interest to people who want to wrap their own Perl Objects/RDBs/FileSystems etc in way that they "are" bioperl sequence objects, even though it is not using Perl to store the sequence etc. This interface defines what bioperl considers necessary to "be" a sequence, without providing an implementation of this, an implementation is provided in L. If you want to provide a Bio::PrimarySeq-compliant object which in fact wraps another object/database/out-of-perl experience, then this is the correct thing to wrap, generally by providing a wrapper class which would inherit from your object and this Bio::PrimarySeqI interface. The wrapper class then would have methods lists in the "Implementation Specific Functions" which would provide these methods for your object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::PrimarySeqI; use strict; use Bio::Tools::CodonTable; use base qw(Bio::Root::RootI); =head1 Implementation-specific Functions These functions are the ones that a specific implementation must define. =head2 seq Title : seq Usage : $string = $obj->seq() Function: Returns the sequence as a string of letters. The case of the letters is left up to the implementer. Suggested cases are upper case for proteins and lower case for DNA sequence (IUPAC standard), but implementations are suggested to keep an open mind about case (some users... want mixed case!) Returns : A scalar Status : Virtual =cut sub seq { my ($self) = @_; $self->throw_not_implemented(); } =head2 subseq Title : subseq Usage : $substring = $obj->subseq(10,40); Function: Returns the subseq from start to end, where the first base is 1 and the number is inclusive, i.e. 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A string Args : Status : Virtual =cut sub subseq { my ($self) = @_; $self->throw_not_implemented(); } =head2 display_id Title : display_id Usage : $id_string = $obj->display_id(); Function: Returns the display id, also known as the common name of the Sequence object. The semantics of this is that it is the most likely string to be used as an identifier of the sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convenience reasons. Returns : A string Args : None Status : Virtual =cut sub display_id { my ($self) = @_; $self->throw_not_implemented(); } =head2 accession_number Title : accession_number Usage : $unique_biological_key = $obj->accession_number; Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". Returns : A string Args : None Status : Virtual =cut sub accession_number { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 primary_id Title : primary_id Usage : $unique_implementation_key = $obj->primary_id; Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no accession number, this method should return a stringified memory location. Returns : A string Args : None Status : Virtual =cut sub primary_id { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 can_call_new Title : can_call_new Usage : if( $obj->can_call_new ) { $newobj = $obj->new( %param ); } Function: Can_call_new returns 1 or 0 depending on whether an implementation allows new constructor to be called. If a new constructor is allowed, then it should take the followed hashed constructor list. $myobject->new( -seq => $sequence_as_string, -display_id => $id -accession_number => $accession -alphabet => 'dna', ); Returns : 1 or 0 Args : =cut sub can_call_new { my ($self,@args) = @_; # we default to 0 here return 0; } =head2 alphabet Title : alphabet Usage : if( $obj->alphabet eq 'dna' ) { /Do Something/ } Function: Returns the type of sequence being one of 'dna', 'rna' or 'protein'. This is case sensitive. This is not called "type" because this would cause upgrade problems from the 0.5 and earlier Seq objects. Returns : A string either 'dna','rna','protein'. NB - the object must make a call of the alphabet, if there is no alphabet specified it has to guess. Args : None Status : Virtual =cut sub alphabet { my ( $self ) = @_; $self->throw_not_implemented(); } =head2 moltype Title : moltype Usage : Deprecated. Use alphabet() instead. =cut sub moltype { my ($self,@args) = @_; $self->warn("moltype: pre v1.0 method. Calling alphabet() instead..."); return $self->alphabet(@args); } =head1 Implementation-optional Functions The following functions rely on the above functions. An implementing class does not need to provide these functions, as they will be provided by this class, but is free to override these functions. The revcom(), trunc(), and translate() methods create new sequence objects. They will call new() on the class of the sequence object instance passed as argument, unless can_call_new() returns FALSE. In the latter case a Bio::PrimarySeq object will be created. Implementors which really want to control how objects are created (eg, for object persistence over a database, or objects in a CORBA framework), they are encouraged to override these methods =head2 revcom Title : revcom Usage : $rev = $seq->revcom() Function: Produces a new Bio::PrimarySeqI implementing object which is the reversed complement of the sequence. For protein sequences this throws an exception of "Sequence is a protein. Cannot revcom". The id is the same id as the original sequence, and the accession number is also indentical. If someone wants to track that this sequence has be reversed, it needs to define its own extensions. To do an inplace edit of an object you can go: $seq = $seq->revcom(); This of course, causes Perl to handle the garbage collection of the old object, but it is roughly speaking as efficient as an inplace edit. Returns : A new (fresh) Bio::PrimarySeqI object Args : None =cut sub revcom { my ($self) = @_; # Create a new fresh object if $self is 'Bio::Seq::LargePrimarySeq' # or 'Bio::Seq::LargeSeq', if not take advantage of # Bio::Root::clone to get an object copy my $out; if ( $self->isa('Bio::Seq::LargePrimarySeq') or $self->isa('Bio::Seq::LargeSeq') ) { my ($seqclass, $opts) = $self->_setup_class; $out = $seqclass->new( -seq => $self->_revcom_from_string($self->seq, $self->alphabet), -is_circular => $self->is_circular, -display_id => $self->display_id, -accession_number => $self->accession_number, -alphabet => $self->alphabet, -desc => $self->desc, -verbose => $self->verbose, %$opts, ); } else { $out = $self->clone; $out->seq( $out->_revcom_from_string($out->seq, $out->alphabet) ); } return $out; } sub _revcom_from_string { my ($self, $string, $alphabet) = @_; # Check that reverse-complementing makes sense if( $alphabet eq 'protein' ) { $self->throw("Sequence is a protein. Cannot revcom."); } if( $alphabet ne 'dna' && $alphabet ne 'rna' ) { my $msg = "Sequence is not dna or rna, but [$alphabet]. Attempting to revcom, ". "but unsure if this is right."; if( $self->can('warn') ) { $self->warn($msg); } else { warn("[$self] $msg"); } } # If sequence is RNA, map to DNA (then map back later) if( $alphabet eq 'rna' ) { $string =~ tr/uU/tT/; } # Reverse-complement now $string =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; $string = CORE::reverse $string; # Map back RNA to DNA if( $alphabet eq 'rna' ) { $string =~ tr/tT/uU/; } return $string; } =head2 trunc Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence. Returns : A fresh Bio::PrimarySeqI implementing object. Args : Two integers denoting first and last base of the sub-sequence. =cut sub trunc { my ($self,$start,$end) = @_; my $str; if( defined $start && ref($start) && $start->isa('Bio::LocationI') ) { $str = $self->subseq($start); # start is a location actually } elsif( !$end ) { $self->throw("trunc start,end -- there was no end for $start"); } elsif( $end < $start ) { my $msg = "start [$start] is greater than end [$end]. \n". "If you want to truncated and reverse complement, \n". "you must call trunc followed by revcom. Sorry."; $self->throw($msg); } else { $str = $self->subseq($start,$end); } # Create a new fresh object if $self is 'Bio::Seq::LargePrimarySeq' # or 'Bio::Seq::LargeSeq', if not take advantage of # Bio::Root::clone to get an object copy my $out; if ( $self->isa('Bio::Seq::LargePrimarySeq') or $self->isa('Bio::Seq::LargeSeq') ) { my ($seqclass, $opts) = $self->_setup_class; $out = $seqclass->new( -seq => $str, -is_circular => $self->is_circular, -display_id => $self->display_id, -accession_number => $self->accession_number, -alphabet => $self->alphabet, -desc => $self->desc, -verbose => $self->verbose, %$opts, ); } else { $out = $self->clone; $out->seq($str); } return $out; } =head2 translate Title : translate Usage : $protein_seq_obj = $dna_seq_obj->translate Or if you expect a complete coding sequence (CDS) translation, with initiator at the beginning and terminator at the end: $protein_seq_obj = $cds_seq_obj->translate(-complete => 1); Or if you want translate() to find the first initiation codon and return the corresponding protein: $protein_seq_obj = $cds_seq_obj->translate(-orf => 1); Function: Provides the translation of the DNA sequence using full IUPAC ambiguities in DNA/RNA and amino acid codes. The complete CDS translation is identical to EMBL/TREMBL database translation. Note that the trailing terminator character is removed before returning the translated protein object. Note: if you set $dna_seq_obj->verbose(1) you will get a warning if the first codon is not a valid initiator. Returns : A Bio::PrimarySeqI implementing object Args : -terminator character for terminator, default '*' -unknown character for unknown, default 'X' -frame positive integer frame shift (in bases), default 0 -codontable_id integer codon table id, default 1 -complete boolean, if true, complete CDS is expected. default false -complete_codons boolean, if true, codons which are incomplete are translated if a suitable amino acid is found. For instance, if the incomplete codon is 'GG', the completed codon is 'GGN', which is glycine (G). Defaults to 'false'; setting '-complete' also makes this true. -throw boolean, throw exception if ORF not complete, default false -orf if 'longest', find longest ORF. other true value, find first ORF. default 0 -codontable optional L object to use for translation -start optional three-character string to force as initiation codon (e.g. 'atg'). If unset, start codons are determined by the CodonTable. Case insensitive. -offset optional positive integer offset for fuzzy locations. if set, must be either 1, 2, or 3 =head3 Notes The -start argument only applies when -orf is set to 1. By default all initiation codons found in the given codon table are used but when "start" is set to some codon this codon will be used exclusively as the initiation codon. Note that the default codon table (NCBI "Standard") has 3 initiation codons! By default translate() translates termination codons to the some character (default is *), both internal and trailing codons. Setting "-complete" to 1 tells translate() to remove the trailing character. -offset is used for seqfeatures which contain the the \codon_start tag and can be set to 1, 2, or 3. This is the offset by which the sequence translation starts relative to the first base of the feature For details on codon tables used by translate() see L. Deprecated argument set (v. 1.5.1 and prior versions) where each argument is an element in an array: 1: character for terminator (optional), defaults to '*'. 2: character for unknown amino acid (optional), defaults to 'X'. 3: frame (optional), valid values are 0, 1, 2, defaults to 0. 4: codon table id (optional), defaults to 1. 5: complete coding sequence expected, defaults to 0 (false). 6: boolean, throw exception if not complete coding sequence (true), defaults to warning (false) 7: codontable, a custom Bio::Tools::CodonTable object (optional). =cut sub translate { my ($self,@args) = @_; my ($terminator, $unknown, $frame, $codonTableId, $complete, $complete_codons, $throw, $codonTable, $orf, $start_codon, $offset); ## new API with named parameters, post 1.5.1 if ($args[0] && $args[0] =~ /^-[A-Z]+/i) { ($terminator, $unknown, $frame, $codonTableId, $complete, $complete_codons, $throw,$codonTable, $orf, $start_codon, $offset) = $self->_rearrange([qw(TERMINATOR UNKNOWN FRAME CODONTABLE_ID COMPLETE COMPLETE_CODONS THROW CODONTABLE ORF START OFFSET)], @args); ## old API, 1.5.1 and preceding versions } else { ($terminator, $unknown, $frame, $codonTableId, $complete, $throw, $codonTable, $offset) = @args; } ## Initialize termination codon, unknown codon, codon table id, frame $terminator = '*' unless (defined($terminator) and $terminator ne ''); $unknown = "X" unless (defined($unknown) and $unknown ne ''); $frame = 0 unless (defined($frame) and $frame ne ''); $codonTableId = 1 unless (defined($codonTableId) and $codonTableId ne ''); $complete_codons ||= $complete || 0; ## Get a CodonTable, error if custom CodonTable is invalid if ($codonTable) { $self->throw("Need a Bio::Tools::CodonTable object, not ". $codonTable) unless $codonTable->isa('Bio::Tools::CodonTable'); } else { # shouldn't this be cached? Seems wasteful to have a new instance # every time... $codonTable = Bio::Tools::CodonTable->new( -id => $codonTableId); } ## Error if alphabet is "protein" $self->throw("Can't translate an amino acid sequence.") if ($self->alphabet =~ /protein/i); ## Error if -start parameter isn't a valid codon if ($start_codon) { $self->throw("Invalid start codon: $start_codon.") if ( $start_codon !~ /^[A-Z]{3}$/i ); } my $seq; if ($offset) { $self->throw("Offset must be 1, 2, or 3.") if ( $offset !~ /^[123]$/ ); my ($start, $end) = ($offset, $self->length); ($seq) = $self->subseq($start, $end); } else { ($seq) = $self->seq(); } ## ignore frame if an ORF is supposed to be found if ( $orf ) { my ($orf_region) = $self->_find_orfs_nucleotide( $seq, $codonTable, $start_codon, $orf eq 'longest' ? 0 : 'first_only' ); $seq = $self->_orf_sequence( $seq, $orf_region ); } else { ## use frame, error if frame is not 0, 1 or 2 $self->throw("Valid values for frame are 0, 1, or 2, not $frame.") unless ($frame == 0 or $frame == 1 or $frame == 2); $seq = substr($seq,$frame); } ## Translate it my $output = $codonTable->translate($seq, $complete_codons); # Use user-input terminator/unknown $output =~ s/\*/$terminator/g; $output =~ s/X/$unknown/g; ## Only if we are expecting to translate a complete coding region if ($complete) { my $id = $self->display_id; # remove the terminator character if( substr($output,-1,1) eq $terminator ) { chop $output; } else { $throw && $self->throw("Seq [$id]: Not using a valid terminator codon!"); $self->warn("Seq [$id]: Not using a valid terminator codon!"); } # test if there are terminator characters inside the protein sequence! if ($output =~ /\Q$terminator\E/) { $id ||= ''; $throw && $self->throw("Seq [$id]: Terminator codon inside CDS!"); $self->warn("Seq [$id]: Terminator codon inside CDS!"); } # if the initiator codon is not ATG, the amino acid needs to be changed to M if ( substr($output,0,1) ne 'M' ) { if ($codonTable->is_start_codon(substr($seq, 0, 3)) ) { $output = 'M'. substr($output,1); } elsif ($throw) { $self->throw("Seq [$id]: Not using a valid initiator codon!"); } else { $self->warn("Seq [$id]: Not using a valid initiator codon!"); } } } # Create a new fresh object if $self is 'Bio::Seq::LargePrimarySeq' # or 'Bio::Seq::LargeSeq', if not take advantage of # Bio::Root::clone to get an object copy my $out; if ( $self->isa('Bio::Seq::LargePrimarySeq') or $self->isa('Bio::Seq::LargeSeq') ) { my ($seqclass, $opts) = $self->_setup_class; $out = $seqclass->new( -seq => $output, -is_circular => $self->is_circular, -display_id => $self->display_id, -accession_number => $self->accession_number, -alphabet => 'protein', -desc => $self->desc, -verbose => $self->verbose, %$opts, ); } else { $out = $self->clone; $out->seq($output); $out->alphabet('protein'); } return $out; } =head2 transcribe() Title : transcribe Usage : $xseq = $seq->transcribe Function: Convert base T to base U Returns : PrimarySeqI object of alphabet 'rna' or undef if $seq->alphabet ne 'dna' Args : =cut sub transcribe { my $self = shift; return unless $self->alphabet eq 'dna'; my $s = $self->seq; $s =~ tr/tT/uU/; my $desc = $self->desc || ''; # Create a new fresh object if $self is 'Bio::Seq::LargePrimarySeq' # or 'Bio::Seq::LargeSeq', if not take advantage of # Bio::Root::clone to get an object copy my $out; if ( $self->isa('Bio::Seq::LargePrimarySeq') or $self->isa('Bio::Seq::LargeSeq') ) { my ($seqclass, $opts) = $self->_setup_class; $out = $seqclass->new( -seq => $s, -is_circular => $self->is_circular, -display_id => $self->display_id, -accession_number => $self->accession_number, -alphabet => 'rna', -desc => "${desc}[TRANSCRIBED]", -verbose => $self->verbose, %$opts, ); } else { $out = $self->clone; $out->seq($s); $out->alphabet('rna'); $out->desc($desc . "[TRANSCRIBED]"); } return $out; } =head2 rev_transcribe() Title : rev_transcribe Usage : $rtseq = $seq->rev_transcribe Function: Convert base U to base T Returns : PrimarySeqI object of alphabet 'dna' or undef if $seq->alphabet ne 'rna' Args : =cut sub rev_transcribe { my $self = shift; return unless $self->alphabet eq 'rna'; my $s = $self->seq; $s =~ tr/uU/tT/; my $desc = $self->desc || ''; # Create a new fresh object if $self is 'Bio::Seq::LargePrimarySeq' # or 'Bio::Seq::LargeSeq', if not take advantage of # Bio::Root::clone to get an object copy my $out; if ( $self->isa('Bio::Seq::LargePrimarySeq') or $self->isa('Bio::Seq::LargeSeq') ) { my ($seqclass, $opts) = $self->_setup_class; $out = $seqclass->new( -seq => $s, -is_circular => $self->is_circular, -display_id => $self->display_id, -accession_number => $self->accession_number, -alphabet => 'dna', -desc => $self->desc . "[REVERSE TRANSCRIBED]", -verbose => $self->verbose, %$opts, ); } else { $out = $self->clone; $out->seq($s); $out->alphabet('dna'); $out->desc($desc . "[REVERSE TRANSCRIBED]"); } return $out; } =head2 id Title : id Usage : $id = $seq->id() Function: ID of the sequence. This should normally be (and actually is in the implementation provided here) just a synonym for display_id(). Returns : A string. Args : =cut sub id { my ($self)= @_; return $self->display_id(); } =head2 length Title : length Usage : $len = $seq->length() Function: Returns : Integer representing the length of the sequence. Args : =cut sub length { my ($self)= @_; $self->throw_not_implemented(); } =head2 desc Title : desc Usage : $seq->desc($newval); $description = $seq->desc(); Function: Get/set description text for a seq object Returns : Value of desc Args : newvalue (optional) =cut sub desc { shift->throw_not_implemented(); } =head2 is_circular Title : is_circular Usage : if( $obj->is_circular) { # Do something } Function: Returns true if the molecule is circular Returns : Boolean value Args : none =cut sub is_circular { shift->throw_not_implemented; } =head1 Private functions These are some private functions for the PrimarySeqI interface. You do not need to implement these functions =head2 _find_orfs_nucleotide Title : _find_orfs_nucleotide Usage : Function: Finds ORF starting at 1st initiation codon in nucleotide sequence. The ORF is not required to have a termination codon. Example : Returns : a list of string coordinates of ORF locations (0-based half-open), sorted descending by length (so that the longest is first) as: [ start, end, frame, length ], [ start, end, frame, length ], ... Args : Nucleotide sequence, CodonTable object, (optional) alternative initiation codon (e.g. 'ATA'), (optional) boolean that, if true, stops after finding the first available ORF =cut sub _find_orfs_nucleotide { my ( $self, $sequence, $codon_table, $start_codon, $first_only ) = @_; $sequence = uc $sequence; $start_codon = uc $start_codon if $start_codon; my $is_start = $start_codon ? sub { shift eq $start_codon } : sub { $codon_table->is_start_codon( shift ) }; # stores the begin index of the currently-running ORF in each # reading frame my @current_orf_start = (-1,-1,-1); #< stores coordinates of longest observed orf (so far) in each # reading frame my @orfs; # go through each base of the sequence, and each reading frame for each base my $seqlen = CORE::length $sequence; for( my $j = 0; $j <= $seqlen-3; $j++ ) { my $frame = $j % 3; my $this_codon = substr( $sequence, $j, 3 ); # if in an orf and this is either a stop codon or the last in-frame codon in the string if ( $current_orf_start[$frame] >= 0 ) { if ( $codon_table->is_ter_codon( $this_codon ) ||( my $is_last_codon_in_frame = ($j >= $seqlen-5)) ) { # record ORF start, end (half-open), length, and frame my @this_orf = ( $current_orf_start[$frame], $j+3, undef, $frame ); my $this_orf_length = $this_orf[2] = ( $this_orf[1] - $this_orf[0] ); $self->warn( "Translating partial ORF " .$self->_truncate_seq( $self->_orf_sequence( $sequence, \@this_orf )) .' from end of nucleotide sequence' ) if $first_only && $is_last_codon_in_frame; return \@this_orf if $first_only; push @orfs, \@this_orf; $current_orf_start[$frame] = -1; } } # if this is a start codon elsif ( $is_start->($this_codon) ) { $current_orf_start[$frame] = $j; } } return sort { $b->[2] <=> $a->[2] } @orfs; } sub _truncate_seq { my ($self, $seq) = @_; return CORE::length($seq) > 200 ? substr($seq,0,50).'...'.substr($seq,-50) : $seq; } sub _orf_sequence { my ($self, $seq, $orf ) = @_; return '' unless $orf; return substr( $seq, $orf->[0], $orf->[2] ) } =head2 _attempt_to_load_Seq Title : _attempt_to_load_Seq Usage : Function: Example : Returns : Args : =cut sub _attempt_to_load_Seq { my ($self) = @_; if( $main::{'Bio::PrimarySeq'} ) { return 1; } else { eval { require Bio::PrimarySeq; }; if( $@ ) { my $text = "Bio::PrimarySeq could not be loaded for [$self]\n". "This indicates that you are using Bio::PrimarySeqI ". "without Bio::PrimarySeq loaded or without providing a ". "complete implementation.\nThe most likely problem is that there ". "has been a misconfiguration of the bioperl environment\n". "Actual exception:\n\n"; $self->throw("$text$@\n"); return 0; } return 1; } } sub _setup_class { # Return name of class and setup some default parameters my ($self) = @_; my $seqclass; if ($self->can_call_new()) { $seqclass = ref($self); } else { $seqclass = 'Bio::PrimarySeq'; $self->_attempt_to_load_Seq(); } my %opts; if ($seqclass eq 'Bio::PrimarySeq') { # Since sequence is in a Seq object, it has already been validated. # We do not need to validate its trunc(), revcom(), etc $opts{ -direct } = 1; } return $seqclass, \%opts; } 1; BioPerl-1.6.923/Bio/PullParserI.pm000444000765000024 4700512254227334 16737 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PullParserI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PullParserI - A base module for fast 'pull' parsing =head1 SYNOPSIS # do not use this class, it is intended for parser module # writers only =head1 DESCRIPTION If you are writing a module to parse some new format, you may wish to use a 'pull' approach whereby you only do work (reading file data, parsing it, turning the parsed data in an object) when absolutely necessary. PullParserI provides a system for doing exactly that. As a PullParser you need a chunk. A chunk is just a Bio::Root::IO that contains all the raw data you would want to parse. You can use the chunk() method to create a chunk from a filename, existing filehandle or even a string. If you make a chunk from a large file, but actually only want your chunk to be some portion of the whole file, supply start and end amounts in bytes to chunk() at the same time. The methods _chunk_seek() and _chunk_tell() provide seeks and tells that are relative to the start and end of your chunk, not the whole file. The other thing you will need to decide when making a chunk is how to handle piped input. A PullParser typically needs seekable data to parse, so if your data is piped in and unseekable, you must decide between creating a temp file or reading the input into memory, which will be done before the chunk becomes usable and you can begin any parsing. Alternatively you can choose to force a sequential read, in which case you can make use of _dependencies() to define the linear order of methods that would result in the file being read sequentially. The return value of _sequential() is also useful here, if you would need to cache some data or otherwise behave differently during a sequential read. The main method in the system is get_field(). This method relies on the existance of a private hash reference accessible to it with the method _fields(). That hash ref should have as keys all the sorts of data you will want to parse (eg. 'score'), and prior to parsing the values would be undefined. A user of your module can then call either $module-Eget_field('score') or $module-Escore and get_field will either return the answer from $self-E_fields-E{score} if it is defined, or call a method _discover_score() first if not. So for the system to work you need to define a _discover_*() method for every field in the fields hash, and ensure that the method stores an answer in the fields hash. How you implement your _discover_* methods is up to you, though you should never call a _discover_* method directly yourself; always use get_field(), since get_field() will deal with calling dependent methods for you if a forced sequenctial read is in progress due to piped input. You will almost certainly want to make use of the various chunk-related methods of this class (that are denoted private by the leading '_'; this means you can use them as the author of a parser class, but users of your parser should not). Primary amongst them is _*_chunk_by_end() to which you provide text that represents the end of your desired chunk and it does a readline with your argument as $/. The chunk knows about its line-endings, so if you want your end definition to include a new line, just always use "\n" and PullParserI will do any necessary conversion for you. If your input data is hierarchical (eg. report-Emany results-Emany hits-Emany hsps), and you want an object at the leaf of the hierarchy to have access to information that is shared amongst all of them (is parsed in the root), you don't have to copy the data to each leaf object; simply by defining parent(), when you call get_field() and the requested field isn't in your leaf's fields hash, the leaf's parent will be asked for the field instead, and so on till root. See Bio::SearchIO::hmmer_pull for an example of implementing a parser using PullParserI. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Inspired by a posting by Aaron J. Mackey =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PullParserI; use vars qw($AUTOLOAD $FORCE_TEMP_FILE); use strict; use Bio::Root::IO; use base qw(Bio::Root::RootI); BEGIN { # chunk() needs perl 5.8 feature for modes other than temp_file, so will # workaround by forcing temp_file mode in <5.8. Could also rewrite using # IO::String, but don't want to. if ($] < 5.008) { $FORCE_TEMP_FILE = 1; } } =head2 _fields Title : _fields Usage : $obj->_fields( { field1 => undef } ); my $fields_ref = $obj->_fields; Function: Get/set the hash reference containing all the fields for this parser Returns : hash ref Args : none to get, OR hash ref to set =cut sub _fields { my $self = shift; if (@_) { $self->{_fields} = shift; } unless (defined $self->{_fields}) { $self->{_fields} = { }; } return $self->{_fields}; } =head2 has_field Title : has_field Usage : if ($obj->has_field('field_name') {...} Function: Ask if a particular object has a given field (doesn't ask ancestors) Returns : boolean Args : string (the field name to test) =cut sub has_field { my ($self, $desired) = @_; $desired || return; return exists $self->_fields->{$desired}; } =head2 get_field Title : get_field Usage : my $field_value = $obj->get_field('field_name'); Function: Get the value of a given field. If this $obj doesn't have the field, it's parent() will be asked, and so on until there are no more parents. Returns : scalar, warns if a value for the field couldn't be found and returns undef. Args : string (the field to get) =cut sub get_field { my $self = shift; my $desired = shift || return keys %{$self->_fields}; if (exists $self->_fields->{$desired}) { unless (defined $self->_fields->{$desired}) { my $method = '_discover_'.$desired; my $dependency = $self->_dependencies($desired); if ($dependency && ! defined $self->_fields->{$dependency}) { $self->get_field($dependency); } # it might exist now $self->$method unless defined $self->_fields->{$desired}; } return $self->_fields->{$desired}; } # is it a field of our parent? (checks all ancestors) if (my $parent = $self->parent) { return $parent->get_field($desired); } $desired =~ s/_discover_//; $self->warn("This report does not hold information about '$desired'"); return; } =head2 parent Title : parent Usage : $obj->parent($parent_obj); my $parent_obj = $obj->parent; Function: Get/set the parent object of this one. Returns : Bio::PullParserI Args : none to get, OR Bio::PullParserI to set =cut sub parent { my $self = shift; if (@_) { $self->{parent} = shift } return $self->{parent} || return; } =head2 chunk Title : chunk Usage : $obj->chunk($filename); my $chunk = $obj->chunk; Function: Get/set the chunk of this parser. Returns : Bio:Root::IO Args : none to get, OR First argument of a GLOB reference, filename string, string data to treat as the chunk, or Bio::Root::IO. Optionally, also provide: -start => int : the byte position within the thing described by the first argument to consider as the start of this chunk (default 0) -end => int : the byte position to consider as the end (default true end) -piped_behaviour => 'memory'|'temp_file'|'sequential_read' The last option comes into effect when the first argument is something that cannot be seeked (eg. piped input filehandle). 'memory' means read all the piped input into a string first, then set the chunk to that string. 'temp_file' means read all the piped input and output it to a temp file, then set the chunk to that temp file. 'sequential_read' means that the piped input should be read sequentially and your parsing code must cope with not being able to seek. 'memory' is the fastest but uses the most memory. 'temp_file' and 'sequential_read' can be slow, with 'temp_file' being the most memory efficient but requiring disc space. The default is 'sequential_read'. Note that in versions of perl earlier than 5.8 only temp_file works and will be used regardless of what value is supplied here. =cut sub chunk { my $self = shift; if (@_) { my $thing = shift || $self->throw("Trying to set chunk() to an undefined value"); if (ref($thing) eq 'GLOB') { $self->{_chunk} = Bio::Root::IO->new(-fh => $thing); } elsif (ref(\$thing) eq 'SCALAR') { if ($thing !~ /\n/ && -e $thing) { $self->{_chunk} = Bio::Root::IO->new(-file => $thing); } else { unless ($FORCE_TEMP_FILE) { # treat a string as a filehandle open(my $fake_fh, "+<", \$thing); # requires perl 5.8 $self->{_chunk} = Bio::Root::IO->new(-fh => $fake_fh); } else { my ($handle) = $self->{_chunk}->tempfile(); print $handle $thing; $self->{_chunk} = Bio::Root::IO->new(-fh => $handle); } } } elsif ($thing->isa('Bio::Root::IO')) { $self->{_chunk} = $thing; } else { $self->throw("Unknown input into chunk()"); } my ($piped_behaviour, $start, $end); if (@_) { ($piped_behaviour, $start, $end) = $self->_rearrange([qw(PIPED_BEHAVIOUR START END)], @_); } $piped_behaviour ||= 'sequential_read'; $FORCE_TEMP_FILE && ($piped_behaviour = 'temp_file'); $start ||= 0; $self->_chunk_true_start($start); $self->_chunk_true_end($end); # determine if the chunk is seekable my $fh = $self->{_chunk}->_fh; seek($fh, 0, 0); my $first_line = <$fh>; seek($fh, 0, 0); my $seekable = tell($fh) == 0; unless ($seekable) { if ($piped_behaviour eq 'memory') { my $string = $first_line; while (<$fh>) { $string .= $_; } $self->chunk($string); } elsif ($piped_behaviour eq 'temp_file') { my ($handle) = $self->{_chunk}->tempfile(); print $handle $first_line; while (<$fh>) { print $handle $_; } seek($handle, 0, 0); $self->chunk($handle); } elsif ($piped_behaviour eq 'sequential_read') { $self->{_chunk}->_pushback($first_line); $self->_sequential(1); } else { $self->throw("Unknown piped behaviour type '$piped_behaviour'"); } } # determine our line ending if ($first_line =~ /\r\n/) { $self->_line_ending("\r\n"); } elsif ($first_line =~ /\r/) { $self->_line_ending("\r"); } else { $self->_line_ending("\n"); } } return $self->{_chunk} || return; } =head2 _sequential Title : _sequential Usage : if ($obj->_sequential) {...} Function: Ask if we have to do operations such that the input is read sequentially. Returns : boolean Args : none to get, OR boolean to set (typically, you should never set this yourself) =cut sub _sequential { my $self = shift; if (@_) { $self->{_sequential} = shift; } return $self->{_sequential} || 0; } =head2 _dependencies Title : _dependencies Usage : $obj->_dependencies( { field1 => field2 } ); my $dependancy = $obj->_dependencies('field_name'); Function: Set the fields that are dependent on each other, or get the field than another is dependent upon. Returns : string (a field name) Args : string (a field name) to get, OR hash ref to initially set, with field names as keys and values, key field being dependent upon value field. =cut sub _dependencies { my ($self, $thing) = @_; $thing || return; if (ref($thing) eq 'HASH') { $self->{_dependencies} = $thing; } else { return $self->{_dependencies}->{$thing}; } } =head2 _chunk_true_start Title : _chunk_true_start Usage : my $true_start = $obj->_chunk_true_start; Function: Get/set the true start position of the chunk within the filehandle it is part of. Returns : int Args : none to get, OR int to set (typically, you won't set this yourself) =cut sub _chunk_true_start { my $self = shift; if (@_) { $self->{_chunk_start} = shift; } return $self->{_chunk_start} || 0; } =head2 _chunk_true_end Title : _chunk_true_end Usage : my $true_end = $obj->_chunk_true_end; Function: Get/set for the true end position of the chunk within the filehandle it is part of. Returns : int Args : none to get, OR int to set (typically, you won't set this yourself) =cut sub _chunk_true_end { my $self = shift; if (@_) { $self->{_chunk_end} = shift; } return $self->{_chunk_end}; } =head2 _line_ending Title : _line_ending Usage : my $line_ending = $obj->_line_ending; Function: Get/set for the line ending for the chunk. Returns : string Args : none to get, OR string to set (typically, you won't set this yourself) =cut sub _line_ending { my $self = shift; if (@_) { $self->{_chunk_line_ending} = shift; } return $self->{_chunk_line_ending}; } =head2 _chunk_seek Title : _chunk_seek Usage : $obj->_chunk_seek($pos); Function: seek() the chunk to the provided position in bytes, relative to the defined start of the chunk within its filehandle. In _sequential() mode, this function does nothing. Returns : n/a Args : int =cut sub _chunk_seek { my ($self, $pos) = @_; $self->throw("Undefined position passed") unless defined $pos; return if $self->_sequential; my $fh = $self->chunk->_fh; # seek to the defined start seek($fh, $self->_chunk_true_start, 0); # now seek to desired position relative to defined start seek($fh, $pos, 1); } =head2 _chunk_tell Title : _chunk_seek Usage : my $pos = $obj->_chunk_tell; Function: Get the current tell() position within the chunk, relative to the defined start of the chunk within its filehandle. In _sequential() mode, this function does nothing. Returns : int Args : none =cut sub _chunk_tell { my $self = shift; return if $self->_sequential; my $fh = $self->chunk->_fh; return tell($fh) - $self->_chunk_true_start; } =head2 _get_chunk_by_nol Title : _chunk_seek Usage : my $string = $obj->_get_chunk_by_nol; Function: Get a chunk of chunk() from the current position onward for the given number of lines. Returns : string Args : int (number of lines you want) =cut sub _get_chunk_by_nol { my ($self, $nol) = @_; $nol > 0 || $self->throw("Can't request a chunk of fewer than 1 lines"); # hope that $/ is \n my ($line, $count); while (defined($_ = $self->chunk->_readline)) { $line .= $_; $count++; last if $count == $nol; } my $current = $self->_chunk_tell; my $end = ($current || 0) + $self->_chunk_true_start; if (! $current || ($self->_chunk_true_end ? $end <= $self->_chunk_true_end : 1)) { return $line; } return; } =head2 _get_chunk_by_end Title : _get_chunk_by_end Usage : my $string = $obj->_get_chunk_by_end; Function: Get a chunk of chunk() from the current position onward till the end of the line, as defined by the supplied argument. Returns : string Args : string (line ending - if you want the line ending to include a new line, always use \n) =cut sub _get_chunk_by_end { my ($self, $chunk_ending) = @_; my $start = $self->_chunk_tell; my $line_ending = $self->_line_ending; $chunk_ending =~ s/\n/$line_ending/g; local $/ = $chunk_ending || ''; my $line = $self->chunk->_readline; my $current = $self->_chunk_tell; my $end = ($current || 0) + $self->_chunk_true_start; if (! $current || ($self->_chunk_true_end ? $end <= $self->_chunk_true_end : 1)) { return $line; } $self->_chunk_seek($start); return; } =head2 _find_chunk_by_end Title : _find_chunk_by_end Usage : my $string = $obj->_find_chunk_by_end; Function: Get the start and end of what would be a chunk of chunk() from the current position onward till the end of the line, as defined by the supplied argument. In _sequential() mode, this function does nothing. Returns : _chunk_tell values for start and end in 2 element list Args : string (line ending - if you want the line ending to include a new line, always use \n) =cut sub _find_chunk_by_end { my ($self, $chunk_ending) = @_; return if $self->_sequential; my $line_ending = $self->_line_ending; $chunk_ending =~ s/\n/$line_ending/g; local $/ = $chunk_ending || ''; my $start = $self->_chunk_tell; $self->chunk->_readline; my $end = $self->_chunk_tell; my $comp_end = $end + $self->_chunk_true_start; if ($self->_chunk_true_end ? $comp_end <= $self->_chunk_true_end : 1) { return ($start, $end); } $self->_chunk_seek($start); return; } =head2 AUTOLOAD Title : AUTOLOAD Usage : n/a Function: Assumes that any unknown method called should be treated as get_field($method_name). Returns : n/a Args : n/a =cut sub AUTOLOAD { my $self = shift; ref($self) || return; my $name = $AUTOLOAD; $name =~ s/.*://; # strip fully-qualified portion # is it one of our fields? return $self->get_field($name); } 1; BioPerl-1.6.923/Bio/Range.pm000444000765000024 2121412254227316 15563 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Range # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copywright Matthew Pocock # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::Range - Pure perl RangeI implementation =head1 SYNOPSIS $range = Bio::Range->new(-start=>10, -end=>30, -strand=>+1); $r2 = Bio::Range->new(-start=>15, -end=>200, -strand=>+1); print join(', ', $range->union($r2)), "\n"; print join(', ', $range->intersection($r2)), "\n"; print $range->overlaps($r2), "\n"; print $range->contains($r2), "\n"; =head1 DESCRIPTION This provides a pure perl implementation of the BioPerl range interface. Ranges are modeled as having (start, end, length, strand). They use Bio-coordinates - all points E= start and E= end are within the range. End is always greater-than or equal-to start, and length is greather than or equal to 1. The behaviour of a range is undefined if ranges with negative numbers or zero are used. So, in summary: length = end - start + 1 end >= start strand = (-1 | 0 | +1) =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Range; use strict; use Carp; use integer; use base qw(Bio::Root::Root Bio::RangeI); =head1 Constructors =head2 new Title : new Usage : $range = Bio::Range->new(-start => 100, -end=> 200, -strand = +1); Function: generates a new Bio::Range Returns : a new range Args : -strand (defaults to 0) and any two of (-start, -end, -length), the third will be calculated =cut sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); my ($strand, $start, $end, $length) = $self->_rearrange([qw(STRAND START END LENGTH )],@args); $self->strand($strand || 0); if(defined $start ) { $self->start($start); if(defined $end) { $self->end($end); } elsif(defined $length) { $self->end($self->start()+ $length - 1); } } elsif(defined $end && defined $length ) { $self->end($end); $self->start($self->end() - $length + 1); } return $self; } =head2 unions Title : unions Usage : @unions = Bio::Range->unions(@ranges); Function: generate a list of non-intersecting Bio::Range objects from a list of Bio::Range objects which may intersect Returns : a list of Bio::Range objects Args : a list of Bio::Range objects =cut sub unions { my ($class,@i) = @_; my $i = 0; my %i = map { $i++ => $_ } @i; my $lastsize = scalar(keys %i); do { foreach my $j (sort { $i{$a}->start <=> $i{$b}->start } keys %i){ foreach my $k (sort { $i{$a}->start <=> $i{$b}->start } keys %i){ #it may have been replaced by a union under the key of #the overlapping range, we are altering the hash in-place next unless $i{$j}; next if $i{$k}->end < $i{$j}->start; last if $i{$k}->start > $i{$j}->end; if($i{$j}->overlaps($i{$k})){ my($start,$end,$strand) = $i{$j}->union($i{$k}); delete($i{$k}); $i{$j} = Bio::Range->new( -start => $start , -end => $end , -strand => $strand ); } } } goto DONE if scalar(keys %i) == $lastsize; $lastsize = scalar(keys %i); #warn $lastsize; } while(1); DONE: return values %i; } =head1 Member variable access These methods let you get at and set the member variables =head2 start Title : start Function : return or set the start co-ordinate Example : $s = $range->start(); $range->start(7); Returns : the value of the start co-ordinate Args : optionally, the new start co-ordinate Overrides: Bio::RangeI::start =cut sub start { my ($self,$value) = @_; if( defined $value) { $self->throw("'$value' is not an integer.\n") unless $value =~ /^[-+]?\d+$/; $self->{'start'} = $value; } return $self->{'start'}; } =head2 end Title : end Function : return or set the end co-ordinate Example : $e = $range->end(); $range->end(2000); Returns : the value of the end co-ordinate Args : optionally, the new end co-ordinate Overrides: Bio::RangeI::end =cut sub end { my ($self,$value) = @_; if( defined $value) { $self->throw("'$value' is not an integer.\n") unless $value =~ /^[-+]?\d+$/; $self->{'end'} = $value; } return $self->{'end'}; } =head2 strand Title : strand Function : return or set the strandedness Example : $st = $range->strand(); $range->strand(-1); Returns : the value of the strandedness (-1, 0 or 1) Args : optionally, the new strand - (-1, 0, 1) or (-, ., +). Overrides: Bio::RangeI::strand =cut { my %VALID_STRAND = ( -1 => -1, 0 => 0, 1 => 1, '+' => 1, '-' => -1, '.' => 0 ); sub strand { my $self = shift; if(@_) { my $val = shift; if (exists $VALID_STRAND{$val}) { $self->{'strand'} = $VALID_STRAND{$val}; } else { $self->throw("Invalid strand: $val"); } } return $self->{'strand'}; } } =head2 length Title : length Function : returns the length of this range Example : $length = $range->length(); Returns : the length of this range, equal to end - start + 1 Args : if you attempt to set the length an exception will be thrown Overrides: Bio::RangeI::Length =cut sub length { my $self = shift; if(@_) { confess ref($self), "->length() is read-only"; } return $self->end() - $self->start() + 1; } =head2 toString Title : toString Function: stringifies this range Example : print $range->toString(), "\n"; Returns : a string representation of this range =cut sub toString { my $self = shift; return "(${\$self->start}, ${\$self->end}) strand=${\$self->strand}"; } =head1 Boolean Methods These methods return true or false. $range->overlaps($otherRange) && print "Ranges overlap\n"; =head2 overlaps Title : overlaps Usage : if($r1->overlaps($r2)) { do stuff } Function : tests if $r2 overlaps $r1 Args : a range to test for overlap with Returns : true if the ranges overlap, false otherwise Inherited: Bio::RangeI =head2 contains Title : contains Usage : if($r1->contains($r2) { do stuff } Function : tests whether $r1 totally contains $r2 Args : a range to test for being contained Returns : true if the argument is totally contained within this range Inherited: Bio::RangeI =head2 equals Title : equals Usage : if($r1->equals($r2)) Function : test whether $r1 has the same start, end, length as $r2 Args : a range to test for equality Returns : true if they are describing the same range Inherited: Bio::RangeI =head1 Geometrical methods These methods do things to the geometry of ranges, and return triplets (start, end, strand) from which new ranges could be built. =head2 intersection Title : intersection Usage : ($start, $stop, $strand) = $r1->intersection($r2) Function : gives the range that is contained by both ranges Args : a range to compare this one to Returns : nothing if they do not overlap, or the range that they do overlap Inherited: Bio::RangeI::intersection =cut =head2 union Title : union Usage : ($start, $stop, $strand) = $r1->union($r2); : ($start, $stop, $strand) = Bio::Range->union(@ranges); Function : finds the minimal range that contains all of the ranges Args : a range or list of ranges Returns : the range containing all of the ranges Inherited: Bio::RangeI::union =cut 1; BioPerl-1.6.923/Bio/RangeI.pm000444000765000024 4664012254227323 15704 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::RangeI # # Please direct questions and support issues to # # Cared for by Lehvaslaiho # # Copyright Matthew Pocock # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::RangeI - Range interface =head1 SYNOPSIS #Do not run this module directly =head1 DESCRIPTION This provides a standard BioPerl range interface that should be implemented by any object that wants to be treated as a range. This serves purely as an abstract base class for implementers and can not be instantiated. Ranges are modeled as having (start, end, length, strand). They use Bio-coordinates - all points E= start and E= end are within the range. End is always greater-than or equal-to start, and length is greater than or equal to 1. The behaviour of a range is undefined if ranges with negative numbers or zero are used. So, in summary: length = end - start + 1 end >= start strand = (-1 | 0 | +1) =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Juha Muilu (muilu@ebi.ac.uk) Sendu Bala (bix@sendu.me.uk) Malcolm Cook (mec@stowers-institute.org) Stephen Montgomery (sm8 at sanger.ac.uk) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::RangeI; use strict; use Carp; use integer; use vars qw(%STRAND_OPTIONS); use base qw(Bio::Root::RootI); BEGIN { # STRAND_OPTIONS contains the legal values for the strand-testing options %STRAND_OPTIONS = map { $_, '_' . $_ } ( 'strong', # ranges must have the same strand 'weak', # ranges must have the same strand or no strand 'ignore', # ignore strand information ); } # utility methods # # returns true if strands are equal and non-zero sub _strong { my ($r1, $r2) = @_; my ($s1, $s2) = ($r1->strand(), $r2->strand()); return 1 if $s1 != 0 && $s1 == $s2; } # returns true if strands are equal or either is zero sub _weak { my ($r1, $r2) = @_; my ($s1, $s2) = ($r1->strand(), $r2->strand()); return 1 if $s1 == 0 || $s2 == 0 || $s1 == $s2; } # returns true for any strandedness sub _ignore { return 1; } # works out what test to use for the strictness and returns true/false # e.g. $r1->_testStrand($r2, 'strong') sub _testStrand() { my ($r1, $r2, $comp) = @_; return 1 unless $comp; my $func = $STRAND_OPTIONS{$comp}; return $r1->$func($r2); } =head1 Abstract methods These methods must be implemented in all subclasses. =head2 start Title : start Usage : $start = $range->start(); Function: get/set the start of this range Returns : the start of this range Args : optionally allows the start to be set using $range->start($start) =cut sub start { shift->throw_not_implemented(); } =head2 end Title : end Usage : $end = $range->end(); Function: get/set the end of this range Returns : the end of this range Args : optionally allows the end to be set using $range->end($end) =cut sub end { shift->throw_not_implemented(); } =head2 length Title : length Usage : $length = $range->length(); Function: get/set the length of this range Returns : the length of this range Args : optionally allows the length to be set using $range->length($length) =cut sub length { shift->throw_not_implemented(); } =head2 strand Title : strand Usage : $strand = $range->strand(); Function: get/set the strand of this range Returns : the strandedness (-1, 0, +1) Args : optionally allows the strand to be set using $range->strand($strand) =cut sub strand { shift->throw_not_implemented(); } =head1 Boolean Methods These methods return true or false. They throw an error if start and end are not defined. $range->overlaps($otherRange) && print "Ranges overlap\n"; =head2 overlaps Title : overlaps Usage : if($r1->overlaps($r2)) { do stuff } Function: tests if $r2 overlaps $r1 Args : arg #1 = a range to compare this one to (mandatory) arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') Returns : true if the ranges overlap, false otherwise =cut sub overlaps { my ($self, $other, $so) = @_; $self->throw("start is undefined") unless defined $self->start; $self->throw("end is undefined") unless defined $self->end; $self->throw("not a Bio::RangeI object") unless defined $other && $other->isa('Bio::RangeI'); $other->throw("start is undefined") unless defined $other->start; $other->throw("end is undefined") unless defined $other->end; return ($self->_testStrand($other, $so) and not ( ($self->start() > $other->end() or $self->end() < $other->start() ) )); } =head2 contains Title : contains Usage : if($r1->contains($r2) { do stuff } Function: tests whether $r1 totally contains $r2 Args : arg #1 = a range to compare this one to (mandatory) alternatively, integer scalar to test arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') Returns : true if the argument is totally contained within this range =cut sub contains { my ($self, $other, $so) = @_; $self->throw("start is undefined") unless defined $self->start; $self->throw("end is undefined") unless defined $self->end; if(defined $other && ref $other) { # a range object? $other->throw("Not a Bio::RangeI object: $other") unless $other->isa('Bio::RangeI'); $other->throw("start is undefined") unless defined $other->start; $other->throw("end is undefined") unless defined $other->end; return ($self->_testStrand($other, $so) and $other->start() >= $self->start() and $other->end() <= $self->end()); } else { # a scalar? $self->throw("'$other' is not an integer.\n") unless $other =~ /^[-+]?\d+$/; return ($other >= $self->start() and $other <= $self->end()); } } =head2 equals Title : equals Usage : if($r1->equals($r2)) Function: test whether $r1 has the same start, end, length as $r2 Args : arg #1 = a range to compare this one to (mandatory) arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') Returns : true if they are describing the same range =cut sub equals { my ($self, $other, $so) = @_; $self->throw("start is undefined") unless defined $self->start; $self->throw("end is undefined") unless defined $self->end; $other->throw("Not a Bio::RangeI object") unless $other->isa('Bio::RangeI'); $other->throw("start is undefined") unless defined $other->start; $other->throw("end is undefined") unless defined $other->end; return ($self->_testStrand($other, $so) and $self->start() == $other->start() and $self->end() == $other->end() ); } =head1 Geometrical methods These methods do things to the geometry of ranges, and return Bio::RangeI compliant objects or triplets (start, stop, strand) from which new ranges could be built. =head2 intersection Title : intersection Usage : ($start, $end, $strand) = $r1->intersection($r2); OR ($start, $end, $strand) = Bio::Range->intersection(\@ranges); OR my $containing_range = $r1->intersection($r2); OR my $containing_range = Bio::Range->intersection(\@ranges); Function: gives the range that is contained by all ranges Returns : undef if they do not overlap or if @ranges has only a single range, else returns the range that they do overlap. In scalar contex, the return value is an object of the same class as the calling one. In array context the return value is a three element array. Args : arg #1 = [REQUIRED] a Bio::RangeI to compare this one to, or an array ref of ranges arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') =cut sub intersection { my ($self, $given, $so) = @_; $self->throw("missing arg: you need to pass in another feature") unless $given; my @ranges; if ($self eq "Bio::RangeI") { $self = "Bio::Range"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } if (ref $self) { push(@ranges, $self); } ref($given) eq 'ARRAY' ? push(@ranges, @{$given}) : push(@ranges, $given); #$self->throw("Need at least 2 ranges") unless @ranges >= 2; # Rather than the above, I think the following is more consistent return undef unless @ranges >= 2; my $intersect; while (@ranges > 0) { unless ($intersect) { $intersect = shift(@ranges); $self->throw("Not an object: $intersect") unless ref($intersect); $self->throw("Not a Bio::RangeI object: $intersect") unless $intersect->isa('Bio::RangeI'); $self->throw("start is undefined") unless defined $intersect->start; $self->throw("end is undefined") unless defined $intersect->end; } my $compare = shift(@ranges); $self->throw("Not an object: $compare") unless ref($compare); $self->throw("Not a Bio::RangeI object: $compare") unless $compare->isa('Bio::RangeI'); $self->throw("start is undefined") unless defined $compare->start; $self->throw("end is undefined") unless defined $compare->end; return unless $compare->_testStrand($intersect, $so); my @starts = sort {$a <=> $b} ($intersect->start(), $compare->start()); my @ends = sort {$a <=> $b} ($intersect->end(), $compare->end()); my $start = pop @starts; # larger of the 2 starts my $end = shift @ends; # smaller of the 2 ends my $intersect_strand; # strand for the intersection if (defined($intersect->strand) && defined($compare->strand) && $intersect->strand == $compare->strand) { $intersect_strand = $compare->strand; } else { $intersect_strand = 0; } if ($start > $end) { return; } else { $intersect = $self->new(-start => $start, -end => $end, -strand => $intersect_strand); } } if (wantarray()) { return ($intersect->start, $intersect->end, $intersect->strand); } else { return $intersect; } } =head2 union Title : union Usage : ($start, $end, $strand) = $r1->union($r2); : ($start, $end, $strand) = Bio::Range->union(@ranges); my $newrange = Bio::Range->union(@ranges); Function: finds the minimal Range that contains all of the Ranges Args : a Range or list of Range objects Returns : the range containing all of the range. In scalar contex, the return value is an object of the same class as the calling one. In array context the return value is a three element array. =cut sub union { my $self = shift; my @ranges = @_; if ($self eq "Bio::RangeI") { $self = "Bio::Range"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } if(ref $self) { unshift @ranges, $self; } my @start = sort {$a<=>$b} map( { $_->start() } @ranges); my @end = sort {$a<=>$b} map( { $_->end() } @ranges); my $start = shift @start; while( !defined $start ) { $start = shift @start; } my $end = pop @end; my $union_strand; # Strand for the union range object. foreach(@ranges) { if(! defined $union_strand) { $union_strand = $_->strand; next; } else { if(not defined $_->strand or $union_strand ne $_->strand) { $union_strand = 0; last; } } } return unless $start or $end; if( wantarray() ) { return ( $start,$end,$union_strand); } else { return $self->new('-start' => $start, '-end' => $end, '-strand' => $union_strand ); } } =head2 overlap_extent Title : overlap_extent Usage : ($a_unique,$common,$b_unique) = $a->overlap_extent($b) Function: Provides actual amount of overlap between two different ranges Example : Returns : array of values containing the length unique to the calling range, the length common to both, and the length unique to the argument range Args : a range =cut sub overlap_extent{ my ($a,$b) = @_; $a->throw("start is undefined") unless defined $a->start; $a->throw("end is undefined") unless defined $a->end; $b->throw("Not a Bio::RangeI object") unless $b->isa('Bio::RangeI'); $b->throw("start is undefined") unless defined $b->start; $b->throw("end is undefined") unless defined $b->end; if( ! $a->overlaps($b) ) { return ($a->length,0,$b->length); } my ($au,$bu) = (0, 0); if( $a->start < $b->start ) { $au = $b->start - $a->start; } else { $bu = $a->start - $b->start; } if( $a->end > $b->end ) { $au += $a->end - $b->end; } else { $bu += $b->end - $a->end; } my $intersect = $a->intersection($b); if( ! $intersect ) { warn("no intersection\n"); return ($au, 0, $bu); } else { my $ie = $intersect->end; my $is = $intersect->start; return ($au,$ie-$is+1,$bu); } } =head2 disconnected_ranges Title : disconnected_ranges Usage : my @disc_ranges = Bio::Range->disconnected_ranges(@ranges); Function: finds the minimal set of ranges such that each input range is fully contained by at least one output range, and none of the output ranges overlap Args : a list of ranges Returns : a list of objects of the same type as the input (conforms to RangeI) =cut sub disconnected_ranges { my $self = shift; if ($self eq "Bio::RangeI") { $self = "Bio::Range"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } my @inranges = @_; if(ref $self) { unshift @inranges, $self; } my @outranges = (); # disconnected ranges # iterate through all input ranges $inrange, # adding each input range to the set of output ranges @outranges, # provided $inrange does not overlap ANY range in @outranges # - if it does overlap an outrange, then merge it foreach my $inrange (@inranges) { my $intersects = 0; my @outranges_new = (); my @intersecting_ranges = (); # iterate through all @outranges, testing if it intersects # current $inrange; if it does, merge and add to list # of @intersecting_ranges, otherwise add $outrange to # the new list of outranges that do NOT intersect for (my $i=0; $i<@outranges; $i++) { my $outrange = $outranges[$i]; my $intersection = $inrange->intersection($outrange); if ($intersection) { $intersects = 1; my $union = $inrange->union($outrange); push(@intersecting_ranges, $union); } else { push(@outranges_new, $outrange); } } @outranges = @outranges_new; # @outranges now contains a list of non-overlapping ranges # that do not intersect the current $inrange if (@intersecting_ranges) { if (@intersecting_ranges > 1) { # this sf intersected > 1 range, which means that # all the ranges it intersects should be joined # together in a new range my $merged_range = $self->union(@intersecting_ranges); push(@outranges, $merged_range); } else { # exactly 1 intersecting range push(@outranges, @intersecting_ranges); } } else { # no intersections found - new range push(@outranges, $self->new('-start'=>$inrange->start, '-end'=>$inrange->end, '-strand'=>$inrange->strand, )); } } return @outranges; } =head2 offsetStranded Title : offsetStranded Usage : $rnge->ofsetStranded($fiveprime_offset, $threeprime_offset) Function : destructively modifies RangeI implementing object to offset its start and stop coordinates by values $fiveprime_offset and $threeprime_offset (positive values being in the strand direction). Args : two integer offsets: $fiveprime_offset and $threeprime_offset Returns : $self, offset accordingly. =cut sub offsetStranded { my ($self, $offset_fiveprime, $offset_threeprime) = @_; my ($offset_start, $offset_end) = $self->strand() eq -1 ? (- $offset_threeprime, - $offset_fiveprime) : ($offset_fiveprime, $offset_threeprime); $self->start($self->start + $offset_start); $self->end($self->end + $offset_end); return $self; }; =head2 subtract Title : subtract Usage : my @subtracted = $r1->subtract($r2) Function: Subtract range r2 from range r1 Args : arg #1 = a range to subtract from this one (mandatory) arg #2 = strand option ('strong', 'weak', 'ignore') (optional) Returns : undef if they do not overlap or r2 contains this RangeI, or an arrayref of Range objects (this is an array since some instances where the subtract range is enclosed within this range will result in the creation of two new disjoint ranges) =cut sub subtract() { my ($self, $range, $so) = @_; $self->throw("missing arg: you need to pass in another feature") unless $range; return unless $self->_testStrand($range, $so); if ($self eq "Bio::RangeI") { $self = "Bio::Range"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } $range->throw("Input a Bio::RangeI object") unless $range->isa('Bio::RangeI'); my @sub_locations; if ($self->location->isa('Bio::Location::SplitLocationI') ) { @sub_locations = $self->location->sub_Location; } else { @sub_locations = $self; } my @outranges; foreach my $sl (@sub_locations) { if (!$sl->overlaps($range)) { push(@outranges, $self->new('-start' =>$sl->start, '-end' =>$sl->end, '-strand'=>$sl->strand, )); next; } ##Subtracts everything if ($range->contains($sl)) { next; } my ($start, $end, $strand) = $sl->intersection($range, $so); ##Subtract intersection from $self range if ($sl->start < $start) { push(@outranges, $self->new('-start' =>$sl->start, '-end' =>$start - 1, '-strand'=>$sl->strand, )); } if ($sl->end > $end) { push(@outranges, $self->new('-start' =>$end + 1, '-end' =>$sl->end, '-strand'=>$sl->strand, )); } } if (@outranges) { return \@outranges; } return; } 1; BioPerl-1.6.923/Bio/SearchDist.pm000444000765000024 1260312254227320 16555 0ustar00cjfieldsstaff000000000000 # # BioPerl module for Bio::SearchDist # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchDist - A perl wrapper around Sean Eddy's histogram object =head1 SYNOPSIS $dis = Bio::SearchDist->new(); foreach $score ( @scores ) { $dis->add_score($score); } if( $dis->fit_evd() ) { foreach $score ( @scores ) { $evalue = $dis->evalue($score); print "Score $score had an evalue of $evalue\n"; } } else { warn("Could not fit histogram to an EVD!"); } =head1 DESCRIPTION The Bio::SearchDist object is a wrapper around Sean Eddy's excellent histogram object. The histogram object can bascially take in a number of scores which are sensibly distributed somewhere around 0 that come from a supposed Extreme Value Distribution. Having add all the scores from a database search via the add_score method you can then fit a extreme value distribution using fit_evd(). Once fitted you can then get out the evalue for each score (or a new score) using evalue($score). The fitting procedure is better described in Sean Eddy's own code (available from http://hmmer.janelia.org/, or in the histogram.h header file in Compile/SW). Bascially it fits a EVD via a maximum likelhood method with pruning of the top end of the distribution so that real positives are discarded in the fitting procedure. This comes from an orginally idea of Richard Mott's and the likelhood fitting is from a book by Lawless [should ref here]. The object relies on the fact that the scores are sensibly distributed around about 0 and that integer bins are sensible for the histogram. Scores based on bits are often ideal for this (bits based scoring mechanisms is what this histogram object was originally designed for). =head1 CONTACT The original code this was based on comes from the histogram module as part of the HMMer2 package. Look at http://hmmer.janelia.org/ Its use in Bioperl is via the Compiled XS extension which is cared for by Ewan Birney (birney@ebi.ac.uk). Please contact Ewan first about the use of this module =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchDist; use strict; BEGIN { eval { require Bio::Ext::Align; }; if ( $@ ) { print $@; print STDERR ("\nThe C-compiled engine for histogram object (Bio::Ext::Align) has not been installed.\n Please install the bioperl-ext package\n\n"); exit(1); } } use base qw(Bio::Root::Root); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($min, $max, $lump) = $self->_rearrange([qw(MIN MAX LUMP)], @args); if( ! $min ) { $min = -100; } if( ! $max ) { $max = +100; } if( ! $lump ) { $lump = 50; } $self->_engine(&Bio::Ext::Align::new_Histogram($min,$max,$lump)); return $self; } =head2 add_score Title : add_score Usage : $dis->add_score(300); Function: Adds a single score to the distribution Returns : nothing Args : =cut sub add_score{ my ($self,$score) = @_; my ($eng); $eng = $self->_engine(); #$eng->AddToHistogram($score); $eng->add($score); } =head2 fit_evd Title : fit_evd Usage : $dis->fit_evd(); Function: fits an evd to the current distribution Returns : 1 if it fits successfully, 0 if not Args : =cut sub fit_evd{ my ($self,@args) = @_; return $self->_engine()->fit_EVD(10000,1); } =head2 fit_Gaussian Title : fit_Gaussian Usage : Function: Example : Returns : Args : =cut sub fit_Gaussian{ my ($self,$high) = @_; if( ! defined $high ) { $high = 10000; } return $self->_engine()->fit_Gaussian($high); } =head2 evalue Title : evalue Usage : $eval = $dis->evalue($score) Function: Returns the evalue of this score Returns : float Args : =cut sub evalue{ my ($self,$score) = @_; return $self->_engine()->evalue($score); } =head2 _engine Title : _engine Usage : $obj->_engine($newval) Function: underlyine bp_sw:: histogram engine Returns : value of _engine Args : newvalue (optional) =cut sub _engine{ my ($self,$value) = @_; if( defined $value) { $self->{'_engine'} = $value; } return $self->{'_engine'}; } ## End of Package 1; __END__ BioPerl-1.6.923/Bio/SearchIO.pm000444000765000024 5356412254227321 16175 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO - Driver for parsing Sequence Database Searches (BLAST, FASTA, ...) =head1 SYNOPSIS use Bio::SearchIO; # format can be 'fasta', 'blast', 'exonerate', ... my $searchio = Bio::SearchIO->new( -format => 'blastxml', -file => 'blastout.xml' ); while ( my $result = $searchio->next_result() ) { while( my $hit = $result->next_hit ) { # process the Bio::Search::Hit::HitI object while( my $hsp = $hit->next_hsp ) { # process the Bio::Search::HSP::HSPI object } } } =head1 DESCRIPTION This is a driver for instantiating a parser for report files from sequence database searches. This object serves as a wrapper for the format parsers in Bio::SearchIO::* - you should not need to ever use those format parsers directly. (For people used to the SeqIO system it, we are deliberately using the same pattern). Once you get a SearchIO object, calling next_result() gives you back a L compliant object, which is an object that represents one Blast/Fasta/HMMER whatever report. A list of module names and formats is below: blast BLAST (WUBLAST, NCBIBLAST,bl2seq) fasta FASTA -m9 and -m0 blasttable BLAST -m9 or -m8 output (both NCBI and WUBLAST tabular) megablast MEGABLAST psl UCSC PSL format waba WABA output axt AXT format sim4 Sim4 hmmer HMMER2 hmmpfam and hmmsearch or HMMER3 hmmscan and hmmsearch exonerate Exonerate CIGAR and VULGAR format blastxml NCBI BLAST XML wise Genewise -genesf format Also see the SearchIO HOWTO: http://bioperl.open-bio.org/wiki/HOWTO:SearchIO =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich & Steve Chervitz Email jason-at-bioperl.org Email sac-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO; use strict; use warnings; # Object preamble - inherits from Bio::Root::IO use Bio::SearchIO::SearchResultEventBuilder; # Special exception class for exceptions during parsing. # End users should not ever see these. # For an example of usage, see blast.pm. @Bio::SearchIO::InternalParserError::ISA = qw(Bio::Root::Exception); use Symbol; use base qw(Bio::Root::IO Bio::Event::EventGeneratorI Bio::AnalysisParserI); =head2 new Title : new Usage : my $obj = Bio::SearchIO->new(); Function: Builds a new Bio::SearchIO object Returns : Bio::SearchIO initialized with the correct format Args : -file => $filename -format => format -fh => filehandle to attach to -result_factory => object implementing Bio::Factory::ObjectFactoryI -hit_factory => object implementing Bio::Factory::ObjectFactoryI -hsp_factory => object implementing Bio::Factory::ObjectFactoryI -writer => object implementing Bio::SearchIO::SearchWriterI -output_format => output format, which will dynamically load writer -inclusion_threshold => e-value threshold for inclusion in the PSI-BLAST score matrix model -signif => float or scientific notation number to be used as a P- or Expect value cutoff -check_all_hits => boolean. Check all hits for significance against significance criteria. Default = false. If false, stops processing hits after the first non-significant hit or the first hit that fails the hit_filter call. This speeds parsing, taking advantage of the fact that the hits are processed in the order they appear in the report. -min_query_len => integer to be used as a minimum for query sequence length. Reports with query sequences below this length will not be processed. default = no minimum length. -best => boolean. Only process the best hit of each report; default = false. See L, L Any factory objects in the arguments are passed along to the SearchResultEventBuilder object which holds these factories and sets default ones if none are supplied as arguments. =cut # TODO: The below don't seem to be implemented (e.g. in Bio::SearchIO::blast) # # -score => integer or scientific notation number to be used # as a blast score value cutoff # -bits => integer or scientific notation number to be used # as a bit score value cutoff # -overlap => integer. The amount of overlap to permit between # adjacent HSPs when tiling HSPs. A reasonable value is 2. # default = $Bio::SearchIO::blast::MAX_HSP_OVERLAP. sub new { my($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::SearchIO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{'-file'} || $ARGV[0] ) || 'blast'; my $output_format = $param{'-output_format'}; my $writer = undef; if( defined $output_format ) { if( defined $param{'-writer'} ) { my $dummy = Bio::Root::Root->new(); $dummy->throw("Both writer and output format specified - not good"); } if( $output_format =~ /^blast$/i ) { $output_format = 'TextResultWriter'; } my $output_module = "Bio::SearchIO::Writer::".$output_format; $class->_load_module($output_module); $writer = $output_module->new(@args); push(@args,"-writer",$writer); } # normalize capitalization to lower case $format = "\L$format"; return unless( $class->_load_format_module($format) ); return "Bio::SearchIO::${format}"->new(@args); } } sub _initialize { my($self, @args) = @_; $self->{'_handler'} = undef; # not really necessary unless we put more in RootI #$self->SUPER::_initialize(@args); # initialize the IO part $self->_initialize_io(@args); $self->attach_EventHandler(Bio::SearchIO::SearchResultEventBuilder->new(@args)); $self->{'_reporttype'} = ''; $self->{_notfirsttime} = 0; my ($min_qlen, $check_all, $overlap, $best, $it, $writer ) = $self->_rearrange([qw( MIN_LENGTH CHECK_ALL_HITS OVERLAP BEST INCLUSION_THRESHOLD WRITER)], @args); # note: $overlap isn't used for some reason $writer && $self->writer( $writer ); defined $it && $self->inclusion_threshold($it); defined $min_qlen && $self->min_query_length($min_qlen); defined $best && $self->best_hit_only($best); defined $check_all && $self->check_all_hits($check_all); } =head2 newFh Title : newFh Usage : $fh = Bio::SearchIO->newFh(-file=>$filename, -format=>'Format') Function: does a new() followed by an fh() Example : $fh = Bio::SearchIO->newFh(-file=>$filename, -format=>'Format') $result = <$fh>; # read a ResultI object print $fh $result; # write a ResultI object Returns : filehandle tied to the Bio::SearchIO::Fh class Args : =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Example : $fh = $obj->fh; # make a tied filehandle $result = <$fh>; # read a ResultI object print $fh $result; # write a ResultI object Returns : filehandle tied to the Bio::SearchIO::Fh class Args : =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } =head2 format Title : format Usage : $format = $obj->format() Function: Get the search format Returns : search format Args : none =cut # format() method inherited from Bio::Root::IO =head2 attach_EventHandler Title : attach_EventHandler Usage : $parser->attatch_EventHandler($handler) Function: Adds an event handler to listen for events Returns : none Args : Bio::SearchIO::EventHandlerI See L =cut sub attach_EventHandler{ my ($self,$handler) = @_; return if( ! $handler ); if( ! $handler->isa('Bio::SearchIO::EventHandlerI') ) { $self->warn("Ignoring request to attatch handler ".ref($handler). ' because it is not a Bio::SearchIO::EventHandlerI'); } $self->{'_handler'} = $handler; return; } =head2 _eventHandler Title : _eventHandler Usage : private Function: Get the EventHandler Returns : Bio::SearchIO::EventHandlerI Args : none See L =cut sub _eventHandler{ my ($self) = @_; return $self->{'_handler'}; } =head2 next_result Title : next_result Usage : $result = stream->next_result Function: Reads the next ResultI object from the stream and returns it. Certain driver modules may encounter entries in the stream that are either misformatted or that use syntax not yet understood by the driver. If such an incident is recoverable, e.g., by dismissing a feature of a feature table or some other non-mandatory part of an entry, the driver will issue a warning. In the case of a non-recoverable situation an exception will be thrown. Do not assume that you can resume parsing the same stream after catching the exception. Note that you can always turn recoverable errors into exceptions by calling $stream->verbose(2) (see Bio::Root::RootI POD page). Returns : A Bio::Search::Result::ResultI object Args : n/a See L =cut sub next_result { my ($self) = @_; $self->throw_not_implemented; } =head2 write_result Title : write_result Usage : $stream->write_result($result_result, @other_args) Function: Writes data from the $result_result object into the stream. : Delegates to the to_string() method of the associated : WriterI object. Returns : 1 for success and 0 for error Args : Bio::Search:Result::ResultI object, : plus any other arguments for the Writer Throws : Bio::Root::Exception if a Writer has not been set. See L =cut sub write_result { my ($self, $result, @args) = @_; if( not ref($self->{'_result_writer'}) ) { $self->throw("ResultWriter not defined."); } @args = $self->{'_notfirsttime'} unless( @args ); my $str = $self->writer->to_string( $result, @args); $self->{'_notfirsttime'} = 1; $self->_print( "$str" ) if defined $str; $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 write_report Title : write_report Usage : $stream->write_report(SearchIO stream, @other_args) Function: Writes data directly from the SearchIO stream object into the : writer. This is mainly useful if one has multiple ResultI objects : in a SearchIO stream and you don't want to reiterate header/footer : between each call. Returns : 1 for success and 0 for error Args : Bio::SearchIO stream object, : plus any other arguments for the Writer Throws : Bio::Root::Exception if a Writer has not been set. See L =cut sub write_report { my ($self, $result, @args) = @_; if( not ref($self->{'_result_writer'}) ) { $self->throw("ResultWriter not defined."); } @args = $self->{'_notfirsttime'} unless( @args ); my $str = $self->writer->to_string( $result, @args); $self->{'_notfirsttime'} = 1; $self->_print( "$str" ) if defined $str; $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 writer Title : writer Usage : $writer = $stream->writer; Function: Sets/Gets a SearchWriterI object to be used for this searchIO. Returns : 1 for success and 0 for error Args : Bio::SearchIO::SearchWriterI object (when setting) Throws : Bio::Root::Exception if a non-Bio::SearchIO::SearchWriterI object is passed in. =cut sub writer { my ($self, $writer) = @_; if( ref($writer) and $writer->isa( 'Bio::SearchIO::SearchWriterI' )) { $self->{'_result_writer'} = $writer; } elsif( defined $writer ) { $self->throw("Can't set ResultWriter. Not a Bio::SearchIO::SearchWriterI: $writer"); } return $self->{'_result_writer'}; } =head2 result_count Title : result_count Usage : $num = $stream->result_count; Function: Gets the number of Blast results that have been successfully parsed at the point of the method call. This is not the total # of results in the file. Returns : integer Args : none Throws : none =cut sub result_count { my $self = shift; $self->throw_not_implemented; } =head2 inclusion_threshold Title : inclusion_threshold Usage : my $incl_thresh = $isreb->inclusion_threshold; : $isreb->inclusion_threshold(1e-5); Function: Get/Set the e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) that was used for generating the reports being parsed. Returns : number (real) Default value: $Bio::SearchIO::IteratedSearchResultEventBuilder::DEFAULT_INCLUSION_THRESHOLD Args : number (real) (e.g., 0.0001 or 1e-4 ) =cut # Delegates to the event handler. sub inclusion_threshold { shift->_eventHandler->inclusion_threshold(@_); } =head2 max_significance Usage : $obj->max_significance(); Purpose : Set/Get the P or Expect value used as significance screening cutoff. This is the value of the -signif parameter supplied to new(). Hits with P or E-value above this are skipped. Returns : Scientific notation number with this format: 1.0e-05. Argument : Scientific notation number or float (when setting) Comments : Screening of significant hits uses the data provided on the : description line. For NCBI BLAST1 and WU-BLAST, this data : is P-value. for NCBI BLAST2 it is an Expect value. =cut sub max_significance { shift->{'_handler_cache'}->max_significance(@_) } =head2 signif Synonym for L =cut sub signif { shift->max_significance(@_) } =head2 min_score Usage : $obj->min_score(); Purpose : Set/Get the Blast score used as screening cutoff. This is the value of the -score parameter supplied to new(). Hits with scores below this are skipped. Returns : Integer or scientific notation number. Argument : Integer or scientific notation number (when setting) Comments : Screening of significant hits uses the data provided on the : description line. =cut sub min_score { shift->{'_handler_cache'}->min_score(@_) } =head2 min_query_length Usage : $obj->min_query_length(); Purpose : Gets the query sequence length used as screening criteria. This is the value of the -min_query_len parameter supplied to new(). Hits with sequence length below this are skipped. Returns : Integer Argument : n/a =cut sub min_query_length { my $self = shift; if (@_) { my $min_qlen = shift; if ( $min_qlen =~ /\D/ or $min_qlen <= 0 ) { $self->throw( -class => 'Bio::Root::BadParameter', -text => "Invalid minimum query length value: $min_qlen\n" . "Value must be an integer > 0. Value not set.", -value => $min_qlen ); } $self->{'_confirm_qlength'} = 1; $self->{'_min_query_length'} = $min_qlen; } return $self->{'_min_query_length'}; } =head2 best_hit_only Title : best_hit_only Usage : print "only getting best hit.\n" if $obj->best_hit_only; Purpose : Set/Get the indicator for whether or not to process only : the best BlastHit. Returns : Boolean (1 | 0) Argument : Boolean (1 | 0) (when setting) =cut sub best_hit_only { my $self = shift; if (@_) { $self->{'_best'} = shift; } $self->{'_best'}; } =head2 check_all_hits Title : check_all_hits Usage : print "checking all hits.\n" if $obj->check_all_hits; Purpose : Set/Get the indicator for whether or not to process all hits. : If false, the parser will stop processing hits after the : the first non-significance hit or the first hit that fails : any hit filter. Returns : Boolean (1 | 0) Argument : Boolean (1 | 0) (when setting) =cut sub check_all_hits { my $self = shift; if (@_) { $self->{'_check_all'} = shift; } $self->{'_check_all'}; } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL SearchIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::SearchIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'blast' if (/\.(blast|t?bl\w)$/i ); return 'fasta' if (/\. (?: t? fas (?:ta)? | m\d+ | (?: t? (?: fa | fx | fy | ff | fs ) ) | (?: (?:ss | os | ps) (?:earch)? )) $/ix ); return 'blastxml' if ( /\.(blast)?xml$/i); return 'exonerate' if ( /\.exon(erate)?/i ); } sub close { my $self = shift; if( $self->writer ) { $self->_print($self->writer->end_report()); $self->{'_result_writer'}= undef; } $self->SUPER::close(@_); } sub DESTROY { my $self = shift; $self->close() if defined $self->_fh; $self->SUPER::DESTROY; } sub TIEHANDLE { my $class = shift; return bless {processor => shift}, $class; } sub READLINE { my $self = shift; return $self->{'processor'}->next_result() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'processor'}->next_result(); return @list; } sub PRINT { my $self = shift; $self->{'processor'}->write_result(@_); } 1; __END__ BioPerl-1.6.923/Bio/Seq.pm000444000765000024 11735512254227321 15307 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Seq # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq - Sequence object, with features =head1 SYNOPSIS # This is the main sequence object in Bioperl # gets a sequence from a file $seqio = Bio::SeqIO->new( '-format' => 'embl' , -file => 'myfile.dat'); $seqobj = $seqio->next_seq(); # SeqIO can both read and write sequences; see Bio::SeqIO # for more information and examples # get from database $db = Bio::DB::GenBank->new(); $seqobj = $db->get_Seq_by_acc('X78121'); # make from strings in script $seqobj = Bio::Seq->new( -display_id => 'my_id', -seq => $sequence_as_string); # gets sequence as a string from sequence object $seqstr = $seqobj->seq(); # actual sequence as a string $seqstr = $seqobj->subseq(10,50); # slice in biological coordinates # retrieves information from the sequence # features must implement Bio::SeqFeatureI interface @features = $seqobj->get_SeqFeatures(); # just top level foreach my $feat ( @features ) { print "Feature ",$feat->primary_tag," starts ",$feat->start," ends ", $feat->end," strand ",$feat->strand,"\n"; # features retain link to underlying sequence object print "Feature sequence is ",$feat->seq->seq(),"\n" } # sequences may have a species if( defined $seq->species ) { print "Sequence is from ",$species->binomial," [",$species->common_name,"]\n"; } # annotation objects are Bio::AnnotationCollectionI's $ann = $seqobj->annotation(); # annotation object # references is one type of annotations to get. Also get # comment and dblink. Look at Bio::AnnotationCollection for # more information foreach my $ref ( $ann->get_Annotations('reference') ) { print "Reference ",$ref->title,"\n"; } # you can get truncations, translations and reverse complements, these # all give back Bio::Seq objects themselves, though currently with no # features transfered my $trunc = $seqobj->trunc(100,200); my $rev = $seqobj->revcom(); # there are many options to translate - check out the docs my $trans = $seqobj->translate(); # these functions can be chained together my $trans_trunc_rev = $seqobj->trunc(100,200)->revcom->translate(); =head1 DESCRIPTION A Seq object is a sequence with sequence features placed on it. The Seq object contains a PrimarySeq object for the actual sequence and also implements its interface. In Bioperl we have 3 main players that people are going to use frequently Bio::PrimarySeq - just the sequence and its names, nothing else. Bio::SeqFeatureI - a feature on a sequence, potentially with a sequence and a location and annotation. Bio::Seq - A sequence and a collection of sequence features (an aggregate) with its own annotation. Although Bioperl is not tied heavily to file formats these distinctions do map to file formats sensibly and for some bioinformaticians this might help Bio::PrimarySeq - Fasta file of a sequence Bio::SeqFeatureI - A single entry in an EMBL/GenBank/DDBJ feature table Bio::Seq - A single EMBL/GenBank/DDBJ entry By having this split we avoid a lot of nasty circular references (sequence features can hold a reference to a sequence without the sequence holding a reference to the sequence feature). See L and L for more information. Ian Korf really helped in the design of the Seq and SeqFeature system. =head2 Examples A simple and fundamental block of code: use Bio::SeqIO; my $seqIOobj = Bio::SeqIO->new(-file=>"1.fa"); # create a SeqIO object my $seqobj = $seqIOobj->next_seq; # get a Seq object With the Seq object in hand one has access to a powerful set of Bioperl methods and related Bioperl objects. This next script will take a file of sequences in EMBL format and create a file of the reverse-complemented sequences in Fasta format using Seq objects. It also prints out details about the exons it finds as sequence features in Genbank Flat File format. use Bio::Seq; use Bio::SeqIO; $seqin = Bio::SeqIO->new( -format => 'EMBL' , -file => 'myfile.dat'); $seqout= Bio::SeqIO->new( -format => 'Fasta', -file => '>output.fa'); while((my $seqobj = $seqin->next_seq())) { print "Seen sequence ",$seqobj->display_id,", start of seq ", substr($seqobj->seq,1,10),"\n"; if( $seqobj->alphabet eq 'dna') { $rev = $seqobj->revcom; $id = $seqobj->display_id(); $id = "$id.rev"; $rev->display_id($id); $seqout->write_seq($rev); } foreach $feat ( $seqobj->get_SeqFeatures() ) { if( $feat->primary_tag eq 'exon' ) { print STDOUT "Location ",$feat->start,":", $feat->end," GFF[",$feat->gff_string,"]\n"; } } } Let's examine the script. The lines below import the Bioperl modules. Seq is the main Bioperl sequence object and SeqIO is the Bioperl support for reading sequences from files and to files use Bio::Seq; use Bio::SeqIO; These two lines create two SeqIO streams: one for reading in sequences and one for outputting sequences: $seqin = Bio::SeqIO->new( -format => 'EMBL' , -file => 'myfile.dat'); $seqout= Bio::SeqIO->new( -format => 'Fasta', -file => '>output.fa'); Notice that in the "$seqout" case there is a greater-than sign, indicating the file is being opened for writing. Using the '-argument' => value syntax is common in Bioperl. The file argument is like an argument to open() . You can also pass in filehandles or FileHandle objects by using the -fh argument (see L documentation for details). Many formats in Bioperl are handled, including Fasta, EMBL, GenBank, Swissprot (swiss), PIR, and GCG. $seqin = Bio::SeqIO->new( -format => 'EMBL' , -file => 'myfile.dat'); $seqout= Bio::SeqIO->new( -format => 'Fasta', -file => '>output.fa'); This is the main loop which will loop progressively through sequences in a file, and each call to $seqio-Enext_seq() provides a new Seq object from the file: while((my $seqobj = $seqio->next_seq())) { This print line below accesses fields in the Seq object directly. The $seqobj-Edisplay_id is the way to access the display_id attribute of the Seq object. The $seqobj-Eseq method gets the actual sequence out as string. Then you can do manipulation of this if you want to (there are however easy ways of doing truncation, reverse-complement and translation). print "Seen sequence ",$seqobj->display_id,", start of seq ", substr($seqobj->seq,1,10),"\n"; Bioperl has to guess the alphabet of the sequence, being either 'dna', 'rna', or 'protein'. The alphabet attribute is one of these three possibilities. if( $seqobj->alphabet eq 'dna') { The $seqobj-Erevcom method provides the reverse complement of the Seq object as another Seq object. Thus, the $rev variable is a reference to another Seq object. For example, one could repeat the above print line for this Seq object (putting $rev in place of $seqobj). In this case we are going to output the object into the file stream we built earlier on. $rev = $seqobj->revcom; When we output it, we want the id of the outputted object to be changed to "$id.rev", ie, with .rev on the end of the name. The following lines retrieve the id of the sequence object, add .rev to this and then set the display_id of the rev sequence object to this. Notice that to set the display_id attribute you just need call the same method, display_id(), with the new value as an argument. Getting and setting values with the same method is common in Bioperl. $id = $seqobj->display_id(); $id = "$id.rev"; $rev->display_id($id); The write_seq method on the SeqIO output object, $seqout, writes the $rev object to the filestream we built at the top of the script. The filestream knows that it is outputting in fasta format, and so it provides fasta output. $seqout->write_seq($rev); This block of code loops over sequence features in the sequence object, trying to find ones who have been tagged as 'exon'. Features have start and end attributes and can be outputted in Genbank Flat File format, GFF, a standarized format for sequence features. foreach $feat ( $seqobj->get_SeqFeatures() ) { if( $feat->primary_tag eq 'exon' ) { print STDOUT "Location ",$feat->start,":", $feat->end," GFF[",$feat->gff_string,"]\n"; } } The code above shows how a few Bio::Seq methods suffice to read, parse, reformat and analyze sequences from a file. A full list of methods available to Bio::Seq objects is shown below. Bear in mind that some of these methods come from PrimarySeq objects, which are simpler than Seq objects, stripped of features (see L for more information). # these methods return strings, and accept strings in some cases: $seqobj->seq(); # string of sequence $seqobj->subseq(5,10); # part of the sequence as a string $seqobj->accession_number(); # when there, the accession number $seqobj->alphabet(); # one of 'dna','rna',or 'protein' $seqobj->version() # when there, the version $seqobj->keywords(); # when there, the Keywords line $seqobj->length() # length $seqobj->desc(); # description $seqobj->primary_id(); # a unique id for this sequence regardless # of its display_id or accession number $seqobj->display_id(); # the human readable id of the sequence Some of these values map to fields in common formats. For example, The display_id() method returns the LOCUS name of a Genbank entry, the (\S+) following the E character in a Fasta file, the ID from a SwissProt file, and so on. The desc() method will return the DEFINITION line of a Genbank file, the description following the display_id in a Fasta file, and the DE field in a SwissProt file. # the following methods return new Seq objects, but # do not transfer features across to the new object: $seqobj->trunc(5,10) # truncation from 5 to 10 as new object $seqobj->revcom # reverse complements sequence $seqobj->translate # translation of the sequence # if new() can be called this method returns 1, else 0 $seqobj->can_call_new # the following method determines if the given string will be accepted # by the seq() method - if the string is acceptable then validate() # returns 1, or 0 if not $seqobj->validate_seq($string) # the following method returns or accepts a Species object: $seqobj->species(); Please see L for more information on this object. # the following method returns or accepts an Annotation object # which in turn allows access to Annotation::Reference # and Annotation::Comment objects: $seqobj->annotation(); These annotations typically refer to entire sequences, unlike features. See L, L, L, and L for details. It is also important to be able to describe defined portions of a sequence. The combination of some description and the corresponding sub-sequence is called a feature - an exon and its coordinates within a gene is an example of a feature, or a domain within a protein. # the following methods return an array of SeqFeatureI objects: $seqobj->get_SeqFeatures # The 'top level' sequence features $seqobj->get_all_SeqFeatures # All sequence features, including sub-seq # features, such as features in an exon # to find out the number of features use: $seqobj->feature_count Here are just some of the methods available to SeqFeatureI objects: # these methods return numbers: $feat->start # start position (1 is the first base) $feat->end # end position (2 is the second base) $feat->strand # 1 means forward, -1 reverse, 0 not relevant # these methods return or accept strings: $feat->primary_tag # the name of the sequence feature, eg # 'exon', 'glycoslyation site', 'TM domain' $feat->source_tag # where the feature comes from, eg, 'EMBL_GenBank', # or 'BLAST' # this method returns the more austere PrimarySeq object, not a # Seq object - the main difference is that PrimarySeq objects do not # themselves contain sequence features $feat->seq # the sequence between start,end on the # correct strand of the sequence See L for more details on PrimarySeq objects. # useful methods for feature comparisons, for start/end points $feat->overlaps($other) # do $feat and $other overlap? $feat->contains($other) # is $other completely within $feat? $feat->equals($other) # do $feat and $other completely agree? # one can also add features $seqobj->add_SeqFeature($feat) # returns 1 if successful # sub features. For complex join() statements, the feature # is one sequence feature with many sub SeqFeatures $feat->sub_SeqFeature # returns array of sub seq features Please see L and L, for more information on sequence features. It is worth mentioning that one can also retrieve the start and end positions of a feature using a Bio::LocationI object: $location = $feat->location # $location is a Bio::LocationI object $location->start; # start position $location->end; # end position This is useful because one needs a Bio::Location::SplitLocationI object in order to retrieve the coordinates inside the Genbank or EMBL join() statements (e.g. "CDS join(51..142,273..495,1346..1474)"): if ( $feat->location->isa('Bio::Location::SplitLocationI') && $feat->primary_tag eq 'CDS' ) { foreach $loc ( $feat->location->sub_Location ) { print $loc->start . ".." . $loc->end . "\n"; } } See L and L for more information. =head1 Implemented Interfaces This class implements the following interfaces. =over 4 =item Bio::SeqI Note that this includes implementing Bio::PrimarySeqI. =item Bio::IdentifiableI =item Bio::DescribableI =item Bio::AnnotatableI =item Bio::FeatureHolderI =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney, inspired by Ian Korf objects Email birney@ebi.ac.uk =head1 CONTRIBUTORS Jason Stajich Ejason@bioperl.orgE Mark A. Jensen maj -at- fortinbras -dot- us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut #' # Let the code begin... package Bio::Seq; use strict; use Bio::Annotation::Collection; use Bio::PrimarySeq; use base qw(Bio::Root::Root Bio::SeqI Bio::IdentifiableI Bio::DescribableI Bio::AnnotatableI Bio::FeatureHolderI Bio::AnnotationCollectionI); =head2 new Title : new Usage : $seq = Bio::Seq->new( -seq => 'ATGGGGGTGGTGGTACCCT', -id => 'human_id', -accession_number => 'AL000012', ); Function: Returns a new Seq object from basic constructors, being a string for the sequence and strings for id and accession_number Returns : a new Bio::Seq object =cut sub new { my($caller,@args) = @_; if( $caller ne 'Bio::Seq') { $caller = ref($caller) if ref($caller); } # we know our inherietance hierarchy my $self = Bio::Root::Root->new(@args); bless $self,$caller; # this is way too sneaky probably. We delegate the construction of # the Seq object onto PrimarySeq and then pop primary_seq into # our primary_seq slot my $pseq = Bio::PrimarySeq->new(@args); # as we have just made this, we know it is ok to set hash directly # rather than going through the method $self->{'primary_seq'} = $pseq; # setting this array is now delayed until the final # moment, again speed ups for non feature containing things # $self->{'_as_feat'} = []; my ($ann, $pid,$feat,$species) = &Bio::Root::RootI::_rearrange($self,[qw(ANNOTATION PRIMARY_ID FEATURES SPECIES)], @args); # for a number of cases - reading fasta files - these are never set. This # gives a quick optimisation around testing things later on if( defined $ann || defined $pid || defined $feat || defined $species ) { $pid && $self->primary_id($pid); $species && $self->species($species); $ann && $self->annotation($ann); if( defined $feat ) { if( ref($feat) !~ /ARRAY/i ) { if( ref($feat) && $feat->isa('Bio::SeqFeatureI') ) { $self->add_SeqFeature($feat); } else { $self->warn("Must specify a valid Bio::SeqFeatureI or ArrayRef of Bio::SeqFeatureI's with the -features init parameter for ".ref($self)); } } else { foreach my $feature ( @$feat ) { $self->add_SeqFeature($feature); } } } } return $self; } =head1 PrimarySeq interface The PrimarySeq interface provides the basic sequence getting and setting methods for on all sequences. These methods implement the Bio::PrimarySeq interface by delegating to the primary_seq inside the object. This means that you can use a Seq object wherever there is a PrimarySeq, and of course, you are free to use these functions anyway. =cut =head2 seq Title : seq Usage : $string = $obj->seq() Function: Get/Set the sequence as a string of letters. The case of the letters is left up to the implementer. Suggested cases are upper case for proteins and lower case for DNA sequence (IUPAC standard), but implementations are suggested to keep an open mind about case (some users... want mixed case!) Returns : A scalar Args : Optionally on set the new value (a string). An optional second argument presets the alphabet (otherwise it will be guessed). Both parameters may also be given in named parameter style with -seq and -alphabet being the names. =cut sub seq { return shift->primary_seq()->seq(@_); } =head2 validate_seq Title : validate_seq Usage : if(! $seqobj->validate_seq($seq_str) ) { print "sequence $seq_str is not valid for an object of alphabet ",$seqobj->alphabet, "\n"; } Function: Test that the given sequence is valid, i.e. contains only valid characters. The allowed characters are all letters (A-Z) and '-','.', '*','?','=' and '~'. Spaces are not valid. Note that this implementation does not take alphabet() into account. Returns : 1 if the supplied sequence string is valid, 0 otherwise. Args : - Sequence string to be validated - Boolean to throw an error if the sequence is invalid =cut sub validate_seq { return shift->primary_seq()->validate_seq(@_); } =head2 length Title : length Usage : $len = $seq->length() Function: Example : Returns : Integer representing the length of the sequence. Args : None =cut sub length { return shift->primary_seq()->length(@_); } =head1 Methods from the Bio::PrimarySeqI interface =head2 subseq Title : subseq Usage : $substring = $obj->subseq(10,40); Function: Returns the subseq from start to end, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence Start cannot be larger than end but can be equal Returns : A string Args : 2 integers =cut sub subseq { return shift->primary_seq()->subseq(@_); } =head2 display_id Title : display_id Usage : $id = $obj->display_id or $obj->display_id($newid); Function: Gets or sets the display id, also known as the common name of the Seq object. The semantics of this is that it is the most likely string to be used as an identifier of the sequence, and likely to have "human" readability. The id is equivalent to the LOCUS field of the GenBank/EMBL databanks and the ID field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convenience issues. Returns : A string Args : None or a new id =cut sub display_id { return shift->primary_seq->display_id(@_); } =head2 accession_number Title : accession_number Usage : $unique_biological_key = $obj->accession_number; Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". Can also be used to set the accession number. Example : $key = $seq->accession_number or $seq->accession_number($key) Returns : A string Args : None or an accession number =cut sub accession_number { return shift->primary_seq->accession_number(@_); } =head2 desc Title : desc Usage : $seqobj->desc($string) or $seqobj->desc() Function: Sets or gets the description of the sequence Example : Returns : The description Args : The description or none =cut sub desc { return shift->primary_seq->desc(@_); } =head2 primary_id Title : primary_id Usage : $unique_implementation_key = $obj->primary_id; Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementation can control clients can expect one id to map to one object. For sequences with no natural id, this method should return a stringified memory location. Can also be used to set the primary_id (or unset to undef). [Note this method name is likely to change in 1.3] Example : $id = $seq->primary_id or $seq->primary_id($id) Returns : A string Args : None or an id, or undef to unset the primary id. =cut sub primary_id { # Note: this used to not delegate to the primary seq. This is # really bad in very subtle ways. E.g., if you created the object # with a primary id given to the constructor and then later you # change the primary id, if this method wouldn't delegate you'd # have different values for primary id in the PrimarySeq object # compared to this instance. Not good. # I can't remember why not delegating was ever deemed # advantageous, but I hereby claim that its problems far outweigh # its advantages, if there are any. Convince me otherwise if you # disagree. HL 2004/08/05 return shift->primary_seq->primary_id(@_); } =head2 can_call_new Title : can_call_new Usage : if ( $obj->can_call_new ) { $newobj = $obj->new( %param ); } Function: can_call_new returns 1 or 0 depending on whether an implementation allows new constructor to be called. If a new constructor is allowed, then it should take the followed hashed constructor list. $myobject->new( -seq => $sequence_as_string, -display_id => $id -accession_number => $accession -alphabet => 'dna', ); Example : Returns : 1 or 0 Args : None =cut sub can_call_new { return 1; } =head2 alphabet Title : alphabet Usage : if ( $obj->alphabet eq 'dna' ) { /Do Something/ } Function: Get/Set the type of sequence being one of 'dna', 'rna' or 'protein'. This is case sensitive. This is not called because this would cause upgrade problems from the 0.5 and earlier Seq objects. Returns : A string either 'dna','rna','protein'. NB - the object must make a call of the type - if there is no type specified it has to guess. Args : optional string to set : 'dna' | 'rna' | 'protein' =cut sub alphabet { my $self = shift; return $self->primary_seq->alphabet(@_) if @_ && defined $_[0]; return $self->primary_seq->alphabet(); } =head2 is_circular Title : is_circular Usage : if( $obj->is_circular) { /Do Something/ } Function: Returns true if the molecule is circular Returns : Boolean value Args : none =cut sub is_circular { return shift->primary_seq()->is_circular(@_); } =head1 Methods for Bio::IdentifiableI compliance =head2 object_id Title : object_id Usage : $string = $obj->object_id() Function: a string which represents the stable primary identifier in this namespace of this object. For DNA sequences this is its accession_number, similarly for protein sequences This is aliased to accession_number(). Returns : A scalar =cut sub object_id { return shift->accession_number(@_); } =head2 version Title : version Usage : $version = $obj->version() Function: a number which differentiates between versions of the same object. Higher numbers are considered to be later and more relevant, but a single object described the same identifier should represent the same concept Returns : A number =cut sub version{ return shift->primary_seq->version(@_); } =head2 authority Title : authority Usage : $authority = $obj->authority() Function: a string which represents the organisation which granted the namespace, written as the DNS name for organisation (eg, wormbase.org) Returns : A scalar =cut sub authority { return shift->primary_seq()->authority(@_); } =head2 namespace Title : namespace Usage : $string = $obj->namespace() Function: A string representing the name space this identifier is valid in, often the database name or the name describing the collection Returns : A scalar =cut sub namespace{ return shift->primary_seq()->namespace(@_); } =head1 Methods for Bio::DescribableI compliance =head2 display_name Title : display_name Usage : $string = $obj->display_name() Function: A string which is what should be displayed to the user the string should have no spaces (ideally, though a cautious user of this interface would not assumme this) and should be less than thirty characters (though again, double checking this is a good idea) This is aliased to display_id(). Returns : A scalar =cut sub display_name { return shift->display_id(@_); } =head2 description Title : description Usage : $string = $obj->description() Function: A text string suitable for displaying to the user a description. This string is likely to have spaces, but should not have any newlines or formatting - just plain text. The string should not be greater than 255 characters and clients can feel justified at truncating strings at 255 characters for the purposes of display This is aliased to desc(). Returns : A scalar =cut sub description { return shift->desc(@_); } =head1 Methods for implementing Bio::AnnotatableI =head2 annotation Title : annotation Usage : $ann = $seq->annotation or $seq->annotation($ann) Function: Gets or sets the annotation Returns : Bio::AnnotationCollectionI object Args : None or Bio::AnnotationCollectionI object See L and L for more information =cut sub annotation { my ($obj,$value) = @_; if( defined $value ) { $obj->throw("object of class ".ref($value)." does not implement ". "Bio::AnnotationCollectionI. Too bad.") unless $value->isa("Bio::AnnotationCollectionI"); $obj->{'_annotation'} = $value; } elsif( ! defined $obj->{'_annotation'}) { $obj->{'_annotation'} = Bio::Annotation::Collection->new(); } return $obj->{'_annotation'}; } =head1 Methods for delegating Bio::AnnotationCollectionI =head2 get_Annotations() Usage : my @annotations = $seq->get_Annotations('key') Function: Retrieves all the Bio::AnnotationI objects for a specific key for this object Returns : list of Bio::AnnotationI - empty if no objects stored for a key Args : string which is key for annotations =cut sub get_Annotations { shift->annotation->get_Annotations(@_); } =head2 add_Annotation() Usage : $seq->add_Annotation('reference',$object); $seq->add_Annotation($object,'Bio::MyInterface::DiseaseI'); $seq->add_Annotation($object); $seq->add_Annotation('disease',$object,'Bio::MyInterface::DiseaseI'); Function: Adds an annotation for a specific key for this sequence object. If the key is omitted, the object to be added must provide a value via its tagname(). If the archetype is provided, this and future objects added under that tag have to comply with the archetype and will be rejected otherwise. Returns : none Args : annotation key ('disease', 'dblink', ...) object to store (must be Bio::AnnotationI compliant) [optional] object archetype to map future storage of object of these types to =cut sub add_Annotation { shift->annotation->add_Annotation(@_) } =head2 remove_Annotations() Usage : $seq->remove_Annotations() Function: Remove the annotations for the specified key from this sequence object Returns : an list of Bio::AnnotationI compliant objects which were stored under the given key(s) for this sequence object Args : the key(s) (tag name(s), one or more strings) for which to remove annotations (optional; if none given, flushes all annotations) =cut sub remove_Annotations { shift->annotation->remove_Annotations(@_) } =head2 get_num_of_annotations() Usage : my $count = $seq->get_num_of_annotations() Alias : num_Annotations Function: Returns the count of all annotations stored for this sequence object Returns : integer Args : none =cut sub get_num_of_annotations { shift->annotation->get_num_of_annotations(@_) } sub num_Annotations { shift->get_num_of_annotations }; #DWYM =head1 Methods to implement Bio::FeatureHolderI This includes methods for retrieving, adding, and removing features. =cut =head2 get_SeqFeatures Title : get_SeqFeatures Usage : Function: Get the feature objects held by this feature holder. Features which are not top-level are subfeatures of one or more of the returned feature objects, which means that you must traverse the subfeature arrays of each top-level feature object in order to traverse all features associated with this sequence. Top-level features can be obtained by tag, specified in the argument. Use get_all_SeqFeatures() if you want the feature tree flattened into one single array. Example : Returns : an array of Bio::SeqFeatureI implementing objects Args : [optional] scalar string (feature tag) =cut sub get_SeqFeatures{ my $self = shift; my $tag = shift; if( !defined $self->{'_as_feat'} ) { $self->{'_as_feat'} = []; } if ($tag) { return map { $_->primary_tag eq $tag ? $_ : () } @{$self->{'_as_feat'}}; } else { return @{$self->{'_as_feat'}}; } } =head2 get_all_SeqFeatures Title : get_all_SeqFeatures Usage : @feat_ary = $seq->get_all_SeqFeatures(); Function: Returns the tree of feature objects attached to this sequence object flattened into one single array. Top-level features will still contain their subfeature-arrays, which means that you will encounter subfeatures twice if you traverse the subfeature tree of the returned objects. Use get_SeqFeatures() if you want the array to contain only the top-level features. Returns : An array of Bio::SeqFeatureI implementing objects. Args : None =cut # this implementation is inherited from FeatureHolderI =head2 feature_count Title : feature_count Usage : $seq->feature_count() Function: Return the number of SeqFeatures attached to a sequence Returns : integer representing the number of SeqFeatures Args : None =cut sub feature_count { my ($self) = @_; if (defined($self->{'_as_feat'})) { return ($#{$self->{'_as_feat'}} + 1); } else { return 0; } } =head2 add_SeqFeature Title : add_SeqFeature Usage : $seq->add_SeqFeature($feat); Function: Adds the given feature object to the feature array of this sequence. The object passed is required to implement the Bio::SeqFeatureI interface. The 'EXPAND' qualifier (see L) is supported, but has no effect, Returns : 1 on success Args : A Bio::SeqFeatureI implementing object. =cut sub add_SeqFeature { my ($self, @feat) = @_; $self->{'_as_feat'} = [] unless $self->{'_as_feat'}; if (scalar @feat > 1) { $self->deprecated( -message => 'Providing an array of features to Bio::Seq add_SeqFeature()'. ' is deprecated and will be removed in a future version. '. 'Add a single feature at a time instead.', -warn_version => 1.007, -throw_version => 1.009, ); } for my $feat ( @feat ) { next if $feat eq 'EXPAND'; # Need to support it for FeatureHolderI compliance if( !$feat->isa("Bio::SeqFeatureI") ) { $self->throw("Expected a Bio::SeqFeatureI object, but got a $feat."); } # make sure we attach ourselves to the feature if the feature wants it my $aseq = $self->primary_seq; $feat->attach_seq($aseq) if $aseq; push(@{$self->{'_as_feat'}},$feat); } return 1; } =head2 remove_SeqFeatures Title : remove_SeqFeatures Usage : $seq->remove_SeqFeatures(); Function: Flushes all attached SeqFeatureI objects. To remove individual feature objects, delete those from the returned array and re-add the rest. Example : Returns : The array of Bio::SeqFeatureI objects removed from this seq. Args : None =cut sub remove_SeqFeatures { my $self = shift; return () unless $self->{'_as_feat'}; my @feats = @{$self->{'_as_feat'}}; $self->{'_as_feat'} = []; return @feats; } =head1 Methods provided in the Bio::PrimarySeqI interface These methods are inherited from the PrimarySeq interface and work as one expects, building new Bio::Seq objects or other information as expected. See L for more information. Sequence Features are B transferred to the new objects. This is possibly a mistake. Anyone who feels the urge in dealing with this is welcome to give it a go. =head2 revcom Title : revcom Usage : $rev = $seq->revcom() Function: Produces a new Bio::Seq object which is the reversed complement of the sequence. For protein sequences this throws an exception of "Sequence is a protein. Cannot revcom" The id is the same id as the original sequence, and the accession number is also identical. If someone wants to track that this sequence has be reversed, it needs to define its own extensions To do an in-place edit of an object you can go: $seq = $seq->revcom(); This of course, causes Perl to handle the garbage collection of the old object, but it is roughly speaking as efficient as an in-place edit. Returns : A new (fresh) Bio::Seq object Args : None =head2 trunc Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence Example : Returns : A fresh Seq object Args : A Seq object =head2 id Title : id Usage : $id = $seq->id() Function: This is mapped on display_id Returns : value of display_id() Args : [optional] value to update display_id =cut sub id { return shift->display_id(@_); } =head1 Seq only methods These methods are specific to the Bio::Seq object, and not found on the Bio::PrimarySeq object =head2 primary_seq Title : primary_seq Usage : $seq->primary_seq or $seq->primary_seq($newval) Function: Get or set a PrimarySeq object Example : Returns : PrimarySeq object Args : None or PrimarySeq object =cut sub primary_seq { my ($obj,$value) = @_; if( defined $value) { if( ! ref $value || ! $value->isa('Bio::PrimarySeqI') ) { $obj->throw("$value is not a Bio::PrimarySeq compliant object"); } $obj->{'primary_seq'} = $value; # descend down over all seqfeature objects, seeing whether they # want an attached seq. foreach my $sf ( $obj->get_SeqFeatures() ) { $sf->attach_seq($value); } } return $obj->{'primary_seq'}; } =head2 species Title : species Usage : $species = $seq->species() or $seq->species($species) Function: Gets or sets the species Returns : L object Args : None or L object See L for more information =cut sub species { my ($self, $species) = @_; if ($species) { $self->{'species'} = $species; } else { return $self->{'species'}; } } # Internal methods follow... # keep AUTOLOAD happy sub DESTROY { } ############################################################################ # aliases due to name changes or to compensate for our lack of consistency # ############################################################################ # in all other modules we use the object in the singular -- # lack of consistency sucks *flush_SeqFeature = \&remove_SeqFeatures; *flush_SeqFeatures = \&remove_SeqFeatures; # this is now get_SeqFeatures() (from FeatureHolderI) *top_SeqFeatures = \&get_SeqFeatures; # this is now get_all_SeqFeatures() in FeatureHolderI sub all_SeqFeatures{ return shift->get_all_SeqFeatures(@_); } sub accession { my $self = shift; $self->warn(ref($self)."::accession is deprecated, ". "use accession_number() instead"); return $self->accession_number(@_); } 1; BioPerl-1.6.923/Bio/SeqAnalysisParserI.pm000444000765000024 667212254227327 20246 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SeqAnalysisParserI # # Please direct questions and support issues to # # Cared for by Jason Stajich , # and Hilmar Lapp # # Copyright Jason Stajich, Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqAnalysisParserI - Sequence analysis output parser interface =head1 SYNOPSIS # get a SeqAnalysisParserI somehow, e.g. by my $parser = Bio::Factory::SeqAnalysisParserFactory->get_parser( '-input' => 'inputfile', '-method' => 'genscan'); while( my $feature = $parser->next_feature() ) { print "Feature from ", $feature->start, " to ", $feature->end, "\n"; } =head1 DESCRIPTION SeqAnalysisParserI is a generic interface for describing sequence analysis result parsers. Sequence analysis in this sense is a search for similarities or the identification of features on the sequence, like a databank search or a a gene prediction result. The concept behind this interface is to have a generic interface in sequence annotation pipelines (as used e.g. in high-throughput automated sequence annotation). This interface enables plug-and-play for new analysis methods and their corresponding parsers without the necessity for modifying the core of the annotation pipeline. In this concept the annotation pipeline has to rely on only a list of methods for which to process the results, and a factory from which it can obtain the corresponding parser implementing this interface. See Bio::Factory::SeqAnalysisParserFactoryI and Bio::Factory::SeqAnalysisParserFactory for interface and an implementation of the corresponding factory. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Jason Stajich Email Hilmar Lapp Ehlapp@gmx.netE, Jason Stajich Ejason@bioperl.orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqAnalysisParserI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut sub next_feature { my ($self) = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/SeqFeatureI.pm000444000765000024 5231512254227323 16710 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SeqFeatureI # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeatureI - Abstract interface of a Sequence Feature =head1 SYNOPSIS # get a seqfeature somehow, eg, from a Sequence with Features attached foreach $feat ( $seq->get_SeqFeatures() ) { print "Feature from ", $feat->start, "to ", $feat->end, " Primary tag ", $feat->primary_tag, ", produced by ", $feat->source_tag(), "\n"; if( $feat->strand == 0 ) { print "Feature applicable to either strand\n"; } else { print "Feature on strand ", $feat->strand,"\n"; # -1,1 } print "feature location is ",$feat->start, "..", $feat->end, " on strand ", $feat->strand, "\n"; print "easy utility to print locations in GenBank/EMBL way ", $feat->location->to_FTstring(), "\n"; foreach $tag ( $feat->get_all_tags() ) { print "Feature has tag ", $tag, " with values, ", join(' ',$feat->get_tag_values($tag)), "\n"; } print "new feature\n" if $feat->has_tag('new'); # features can have sub features my @subfeat = $feat->get_SeqFeatures(); } =head1 DESCRIPTION This interface is the functions one can expect for any Sequence Feature, whatever its implementation or whether it is a more complex type (eg, a Gene). This object does not actually provide any implementation, it just provides the definitions of what methods one can call. See Bio::SeqFeature::Generic for a good standard implementation of this object =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeatureI; use vars qw($HasInMemory); use strict; BEGIN { eval { require Bio::DB::InMemoryCache }; if( $@ ) { $HasInMemory = 0 } else { $HasInMemory = 1 } } use Bio::Seq; use Carp; use base qw(Bio::RangeI); =head1 Bio::SeqFeatureI specific methods New method interfaces. =cut =head2 get_SeqFeatures Title : get_SeqFeatures Usage : @feats = $feat->get_SeqFeatures(); Function: Returns an array of sub Sequence Features Returns : An array Args : none =cut sub get_SeqFeatures{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 display_name Title : display_name Usage : $name = $feat->display_name() Function: Returns the human-readable name of the feature for displays. Returns : a string Args : none =cut sub display_name { shift->throw_not_implemented(); } =head2 primary_tag Title : primary_tag Usage : $tag = $feat->primary_tag() Function: Returns the primary tag for a feature, eg 'exon' Returns : a string Args : none =cut sub primary_tag{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 source_tag Title : source_tag Usage : $tag = $feat->source_tag() Function: Returns the source tag for a feature, eg, 'genscan' Returns : a string Args : none =cut sub source_tag{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 has_tag Title : has_tag Usage : $tag_exists = $self->has_tag('some_tag') Function: Returns : TRUE if the specified tag exists, and FALSE otherwise Args : =cut sub has_tag{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_tag_values Title : get_tag_values Usage : @values = $self->get_tag_values('some_tag') Function: Returns : An array comprising the values of the specified tag. Args : a string throws an exception if there is no such tag =cut sub get_tag_values { shift->throw_not_implemented(); } =head2 get_tagset_values Title : get_tagset_values Usage : @values = $self->get_tagset_values(qw(label transcript_id product)) Function: Returns : An array comprising the values of the specified tags, in order of tags Args : An array of strings does NOT throw an exception if none of the tags are not present this method is useful for getting a human-readable label for a SeqFeatureI; not all tags can be assumed to be present, so a list of possible tags in preferential order is provided =cut # interface + abstract method sub get_tagset_values { my ($self, @args) = @_; my @vals = (); foreach my $arg (@args) { if ($self->has_tag($arg)) { push(@vals, $self->get_tag_values($arg)); } } return @vals; } =head2 get_all_tags Title : get_all_tags Usage : @tags = $feat->get_all_tags() Function: gives all tags for this feature Returns : an array of strings Args : none =cut sub get_all_tags{ shift->throw_not_implemented(); } =head2 attach_seq Title : attach_seq Usage : $sf->attach_seq($seq) Function: Attaches a Bio::Seq object to this feature. This Bio::Seq object is for the *entire* sequence: ie from 1 to 10000 Note that it is not guaranteed that if you obtain a feature from an object in bioperl, it will have a sequence attached. Also, implementors of this interface can choose to provide an empty implementation of this method. I.e., there is also no guarantee that if you do attach a sequence, seq() or entire_seq() will not return undef. The reason that this method is here on the interface is to enable you to call it on every SeqFeatureI compliant object, and that it will be implemented in a useful way and set to a useful value for the great majority of use cases. Implementors who choose to ignore the call are encouraged to specifically state this in their documentation. Example : Returns : TRUE on success Args : a Bio::PrimarySeqI compliant object =cut sub attach_seq { shift->throw_not_implemented(); } =head2 seq Title : seq Usage : $tseq = $sf->seq() Function: returns the truncated sequence (if there is a sequence attached) for this feature Example : Returns : sub seq (a Bio::PrimarySeqI compliant object) on attached sequence bounded by start & end, or undef if there is no sequence attached Args : none =cut sub seq { shift->throw_not_implemented(); } =head2 entire_seq Title : entire_seq Usage : $whole_seq = $sf->entire_seq() Function: gives the entire sequence that this seqfeature is attached to Example : Returns : a Bio::PrimarySeqI compliant object, or undef if there is no sequence attached Args : none =cut sub entire_seq { shift->throw_not_implemented(); } =head2 seq_id Title : seq_id Usage : $obj->seq_id($newval) Function: There are many cases when you make a feature that you do know the sequence name, but do not know its actual sequence. This is an attribute such that you can store the ID (e.g., display_id) of the sequence. This attribute should *not* be used in GFF dumping, as that should come from the collection in which the seq feature was found. Returns : value of seq_id Args : newvalue (optional) =cut sub seq_id { shift->throw_not_implemented(); } =head2 gff_string Title : gff_string Usage : $str = $feat->gff_string; $str = $feat->gff_string($gff_formatter); Function: Provides the feature information in GFF format. The implementation provided here returns GFF2 by default. If you want a different version, supply an object implementing a method gff_string() accepting a SeqFeatureI object as argument. E.g., to obtain GFF1 format, do the following: my $gffio = Bio::Tools::GFF->new(-gff_version => 1); $gff1str = $feat->gff_string($gff1io); Returns : A string Args : Optionally, an object implementing gff_string(). =cut sub gff_string{ my ($self,$formatter) = @_; $formatter = $self->_static_gff_formatter unless $formatter; return $formatter->gff_string($self); } my $static_gff_formatter = undef; =head2 _static_gff_formatter Title : _static_gff_formatter Usage : Function: Example : Returns : Args : =cut sub _static_gff_formatter{ my ($self,@args) = @_; require Bio::Tools::GFF; # on the fly inclusion -- is this better? if( !defined $static_gff_formatter ) { $static_gff_formatter = Bio::Tools::GFF->new('-gff_version' => 2); } return $static_gff_formatter; } =head1 Decorating methods These methods have an implementation provided by Bio::SeqFeatureI, but can be validly overwritten by subclasses =head2 spliced_seq Title : spliced_seq Usage : $seq = $feature->spliced_seq() $seq = $feature_with_remote_locations->spliced_seq($db_for_seqs) Function: Provides a sequence of the feature which is the most semantically "relevant" feature for this sequence. A default implementation is provided which for simple cases returns just the sequence, but for split cases, loops over the split location to return the sequence. In the case of split locations with remote locations, eg join(AB000123:5567-5589,80..1144) in the case when a database object is passed in, it will attempt to retrieve the sequence from the database object, and "Do the right thing", however if no database object is provided, it will generate the correct number of N's (DNA) or X's (protein, though this is unlikely). This function is deliberately "magical" attempting to second guess what a user wants as "the" sequence for this feature. Implementing classes are free to override this method with their own magic if they have a better idea what the user wants. Args : [optional] -db A L compliant object if one needs to retrieve remote seqs. -nosort boolean if the locations should not be sorted by start location. This may occur, for instance, 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) (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 =cut sub spliced_seq { my $self = shift; 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) { $self->warn(q(API has changed; please use '-db' or '-nosort' ). qq(for args. See POD for more details.)); $db = shift @args if @args; $nosort = shift @args if @args; $phase = shift @args if @args; }; if (defined($phase) && ($phase < 0 || $phase > 2)) { $self->warn("Phase must be 0,1, or 2. Setting phase to 0..."); $phase = 0; } if( $db && ref($db) && ! $db->isa('Bio::DB::RandomAccessI') ) { $self->warn("Must pass in a valid Bio::DB::RandomAccessI object". " for access to remote locations for spliced_seq"); $db = undef; } elsif( defined $db && $HasInMemory && $db->isa('Bio::DB::InMemoryCache') ) { $db = Bio::DB::InMemoryCache->new(-seqdb => $db); } if( ! $self->location->isa("Bio::Location::SplitLocationI") ) { if ($phase) { $self->debug("Subseq start: ",$phase+1,"\tend: ",$self->end,"\n"); my $seqstr = substr($self->seq->seq, $phase); my $out = Bio::Seq->new( -id => $self->entire_seq->display_id . "_spliced_feat", -seq => $seqstr); return $out; } else { return $self->seq(); # nice and easy! } } # redundant test, but the above ISA is probably not ideal. if( ! $self->location->isa("Bio::Location::SplitLocationI") ) { $self->throw("not atomic, not split, yikes, in trouble!"); } my $seqstr = ''; my $seqid = $self->entire_seq->display_id; # This is to deal with reverse strand features # so we are really sorting features 5' -> 3' on their strand # i.e. rev strand features will be sorted largest to smallest # as this how revcom CDSes seem to be annotated in genbank. # Might need to eventually allow this to be programable? # (can I mention how much fun this is NOT! --jason) my ($mixed,$mixedloc, $fstrand) = (0); if( $self->isa('Bio::Das::SegmentI') && ! $self->absolute ) { $self->warn("Calling spliced_seq with a Bio::Das::SegmentI which does have absolute set to 1 -- be warned you may not be getting things on the correct strand"); } my @locset = $self->location->each_Location; my @locs; if( ! $nosort ) { @locs = map { $_->[0] } # sort so that most negative is first basically to order # the features on the opposite strand 5'->3' on their strand # rather than they way most are input which is on the fwd strand sort { $a->[1] <=> $b->[1] } # Yes Tim, Schwartzian transformation map { $fstrand = $_->strand unless defined $fstrand; $mixed = 1 if defined $_->strand && $fstrand != $_->strand; if( defined $_->seq_id ) { $mixedloc = 1 if( $_->seq_id ne $seqid ); } [ $_, $_->start * ($_->strand || 1)]; } @locset; if ( $mixed ) { $self->warn("Mixed strand locations, spliced seq using the input order rather than trying to sort"); @locs = @locset; } } else { # use the original order instead of trying to sort @locs = @locset; $fstrand = $locs[0]->strand; } foreach my $loc ( @locs ) { if( ! $loc->isa("Bio::Location::Atomic") ) { $self->throw("Can only deal with one level deep locations"); } my $called_seq; if( $fstrand != $loc->strand ) { $self->warn("feature strand is different from location strand!"); } # deal with remote sequences if( defined $loc->seq_id && $loc->seq_id ne $seqid ) { if( defined $db ) { my $sid = $loc->seq_id; $sid =~ s/\.\d+$//g; eval { $called_seq = $db->get_Seq_by_acc($sid); }; if( $@ ) { $self->warn("In attempting to join a remote location, sequence $sid was not in database. Will provide padding N's. Full exception \n\n$@"); $called_seq = undef; } } else { $self->warn( "cannot get remote location for ".$loc->seq_id ." without a valid Bio::DB::RandomAccessI database handle (like Bio::DB::GenBank)"); $called_seq = undef; } if( !defined $called_seq ) { $seqstr .= 'N' x $self->length; next; } } else { $called_seq = $self->entire_seq; } # does the called sequence make sense? Bug 1780 if ($called_seq->length < $loc->end) { my $accession = $called_seq->accession; my $end = $loc->end; my $length = $called_seq->length; my $orig_id = $self->seq_id; # originating sequence my ($locus) = $self->get_tagset_values("locus_tag"); $self->throw("Location end ($end) exceeds length ($length) of ". "called sequence $accession.\nCheck sequence version used in ". "$locus locus-tagged SeqFeature in $orig_id."); } if( $self->isa('Bio::Das::SegmentI') ) { my ($s,$e) = ($loc->start,$loc->end); # $called_seq is Bio::DB::GFF::RelSegment, as well as its subseq(); # Bio::DB::GFF::RelSegment::seq() returns a Bio::PrimarySeq, and using seq() # in turn returns a string. Confused? $seqstr .= $called_seq->subseq($s,$e)->seq()->seq(); } else { # If guide_strand is defined, assemble the sequence first and revcom later if needed, # if its not defined, apply revcom immediately to proper locations if (defined $self->location->guide_strand) { $seqstr .= $called_seq->subseq($loc->start,$loc->end); } else { my $strand = defined ($loc->strand) ? ($loc->strand) : 0; if ($strand == -1) { $seqstr .= $called_seq->trunc($loc->start,$loc->end)->revcom->seq; } else { $seqstr .= $called_seq->subseq($loc->start,$loc->end); } } } } # Use revcom only after the whole sequence has been assembled my $guide_strand = defined ($self->location->guide_strand) ? ($self->location->guide_strand) : 0; if ($guide_strand == -1) { my $seqstr_obj = Bio::Seq->new(-seq => $seqstr); $seqstr = $seqstr_obj->revcom->seq; } if (defined($phase)) { $seqstr = substr($seqstr, $phase); } my $out = Bio::Seq->new( -id => $self->entire_seq->display_id . "_spliced_feat", -seq => $seqstr); return $out; } =head2 location Title : location Usage : my $location = $seqfeature->location() Function: returns a location object suitable for identifying location of feature on sequence or parent feature Returns : Bio::LocationI object Args : none =cut sub location { my ($self) = @_; $self->throw_not_implemented(); } =head2 primary_id Title : primary_id Usage : $obj->primary_id($newval) Function: Example : Returns : value of primary_id (a scalar) Args : on set, new value (a scalar or undef, optional) Primary ID is a synonym for the tag 'ID' =cut sub primary_id{ my $self = shift; # note from cjm@fruitfly.org: # I have commented out the following 2 lines: #return $self->{'primary_id'} = shift if @_; #return $self->{'primary_id'}; #... and replaced it with the following; see # http://bioperl.org/pipermail/bioperl-l/2003-December/014150.html # for the discussion that lead to this change if (@_) { if ($self->has_tag('ID')) { $self->remove_tag('ID'); } $self->add_tag_value('ID', shift); } my ($id) = $self->get_tagset_values('ID'); return $id; } sub generate_unique_persistent_id { # DEPRECATED - us IDHandler my $self = shift; require Bio::SeqFeature::Tools::IDHandler; Bio::SeqFeature::Tools::IDHandler->new->generate_unique_persistent_id($self); } =head2 phase Title : phase Usage : $obj->phase($newval) Function: get/set this feature's phase. Example : Returns : undef if no phase is set, otherwise 0, 1, or 2 (the only valid values for phase) Args : on set, the new value Most features do not have or need a defined phase. For features representing a CDS, the phase indicates where the feature begins with reference to the reading frame. The phase is one of the integers 0, 1, or 2, indicating the number of bases that should be removed from the beginning of this feature to reach the first base of the next codon. In other words, a phase of "0" indicates that the next codon begins at the first base of the region described by the current line, a phase of "1" indicates that the next codon begins at the second base of this region, and a phase of "2" indicates that the codon begins at the third base of this region. This is NOT to be confused with the frame, which is simply start modulo 3. For forward strand features, phase is counted from the start field. For reverse strand features, phase is counted from the end field. =cut sub phase { my $self = shift; if( @_ ) { $self->remove_tag('phase') if $self->has_tag('phase'); my $newphase = shift; $self->throw("illegal phase value '$newphase', phase must be either undef, 0, 1, or 2") unless !defined $newphase || $newphase == 0 || $newphase == 1 || $newphase == 2; $self->add_tag_value('phase', $newphase ); return $newphase; } return $self->has_tag('phase') ? ($self->get_tag_values('phase'))[0] : undef; } =head1 Bio::RangeI methods These methods are inherited from RangeI and can be used directly from a SeqFeatureI interface. Remember that a SeqFeature is-a RangeI, and so wherever you see RangeI you can use a feature ($r in the below documentation). =cut =head2 start() See L =head2 end() See L =head2 strand() See L =head2 overlaps() See L =head2 contains() See L =head2 equals() See L =head2 intersection() See L =head2 union() See L =cut 1; BioPerl-1.6.923/Bio/SeqI.pm000444000765000024 1462112254227325 15374 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SeqI # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqI - [Developers] Abstract Interface of Sequence (with features) =head1 SYNOPSIS # Bio::SeqI is the interface class for sequences. # If you are a newcomer to bioperl, you should # start with Bio::Seq documentation. This # documentation is mainly for developers using # Bioperl. # Bio::SeqI implements Bio::PrimarySeqI $seq = $seqobj->seq(); # actual sequence as a string $seqstr = $seqobj->subseq(10,50); # Bio::SeqI has annotationcollections $ann = $seqobj->annotation(); # annotation object # Bio::SeqI has sequence features # features must implement Bio::SeqFeatureI @features = $seqobj->get_SeqFeatures(); # just top level @features = $seqobj->get_all_SeqFeatures(); # descend into sub features =head1 DESCRIPTION Bio::SeqI is the abstract interface of annotated Sequences. These methods are those which you can be guaranteed to get for any Bio::SeqI. For most users of the package the documentation (and methods) in this class are not at useful - this is a developers only class which defines what methods have to be implemented by other Perl objects to comply to the Bio::SeqI interface. Go "perldoc Bio::Seq" or "man Bio::Seq" for more information. There aren't many method here, because too many complicated functions here would prevent implementations which are just wrappers around a database or similar delayed mechanisms. Most of the clever stuff happens inside the SeqFeatureI system. A good reference implementation is Bio::Seq which is a pure perl implementation of this class with a lot of extra pieces for extra manipulation. However, if you want to be able to use any sequence object in your analysis, if you can do it just using these methods, then you know you will be future proof and compatible with other implementations of Seq. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::SeqI; use strict; # Object preamble - inherits from Bio::PrimarySeqI use base qw(Bio::PrimarySeqI Bio::AnnotatableI Bio::FeatureHolderI); =head2 get_SeqFeatures Title : get_SeqFeatures Usage : my @feats = $seq->get_SeqFeatures(); Function: retrieve just the toplevel sequence features attached to this seq Returns : array of Bio::SeqFeatureI objects Args : none This method comes through extension of Bio::FeatureHolderI. See L and L for more information. =head2 get_all_SeqFeatures Title : get_all_SeqFeatures Usage : my @feats = $seq->get_all_SeqFeatures(); Function: returns all SeqFeatures, including sub SeqFeatures Returns : an array of Bio::SeqFeatureI objects Args : none This method comes through extension of Bio::FeatureHolderI. See L and L for more information. =head2 feature_count Title : feature_count Usage : my $count = $seq->feature_count(); Function: Return the number of SeqFeatures attached to a sequence Returns : integer representing the number of SeqFeatures Args : none This method comes through extension of Bio::FeatureHolderI. See L for more information. =head2 seq Title : seq Usage : my $string = $seq->seq(); Function: Retrieves the sequence string for the sequence object Returns : string Args : none =cut sub seq { my ($self) = @_; $self->throw_not_implemented(); } =head2 write_GFF Title : write_GFF Usage : $seq->write_GFF(\*FILEHANDLE); Function: Convenience method to write out all the sequence features in GFF format to the provided filehandle (STDOUT by default) Returns : none Args : [optional] filehandle to write to (default is STDOUT) =cut sub write_GFF { my ($self,$fh) = @_; $fh || do { $fh = \*STDOUT; }; foreach my $sf ( $self->get_all_SeqFeatures() ) { print $fh $sf->gff_string, "\n"; } } =head2 annotation Title : annotation Usage : my $ann = $seq->annotation($seq_obj); Function: retrieve the attached annotation object Returns : Bio::AnnotationCollectionI or none; See L and L for more information. This method comes through extension from L. =head2 species Title : species Usage : Function: Gets or sets the species Example : my $species = $seq->species(); Returns : Bio::Species object Args : Bio::Species object or none; See L for more information =cut sub species { my ($self) = @_; $self->throw_not_implemented(); } =head2 primary_seq Title : primary_seq Usage : my $primaryseq = $seq->primary_seq($newval) Function: Retrieve the underlying Bio::PrimarySeqI object if available. This is in the event one has a sequence with lots of features but want to be able to narrow the object to just one with the basics of a sequence (no features or annotations). Returns : Bio::PrimarySeqI Args : Bio::PrimarySeqI or none; See L for more information =cut sub primary_seq { my ($self) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/SeqIO.pm000444000765000024 5741312254227330 15515 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::SeqIO # # Please direct questions and support issues to # # Cared for by Ewan Birney # and Lincoln Stein # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # # _history # October 18, 1999 Largely rewritten by Lincoln Stein # POD documentation - main docs before the code =head1 NAME Bio::SeqIO - Handler for SeqIO Formats =head1 SYNOPSIS use Bio::SeqIO; $in = Bio::SeqIO->new(-file => "inputfilename" , -format => 'Fasta'); $out = Bio::SeqIO->new(-file => ">outputfilename" , -format => 'EMBL'); while ( my $seq = $in->next_seq() ) { $out->write_seq($seq); } # Now, to actually get at the sequence object, use the standard Bio::Seq # methods (look at Bio::Seq if you don't know what they are) use Bio::SeqIO; $in = Bio::SeqIO->new(-file => "inputfilename" , -format => 'genbank'); while ( my $seq = $in->next_seq() ) { print "Sequence ",$seq->id, " first 10 bases ", $seq->subseq(1,10), "\n"; } # The SeqIO system does have a filehandle binding. Most people find this # a little confusing, but it does mean you can write the world's # smallest reformatter use Bio::SeqIO; $in = Bio::SeqIO->newFh(-file => "inputfilename" , -format => 'Fasta'); $out = Bio::SeqIO->newFh(-format => 'EMBL'); # World's shortest Fasta<->EMBL format converter: print $out $_ while <$in>; =head1 DESCRIPTION Bio::SeqIO is a handler module for the formats in the SeqIO set (eg, Bio::SeqIO::fasta). It is the officially sanctioned way of getting at the format objects, which most people should use. The Bio::SeqIO system can be thought of like biological file handles. They are attached to filehandles with smart formatting rules (eg, genbank format, or EMBL format, or binary trace file format) and can either read or write sequence objects (Bio::Seq objects, or more correctly, Bio::SeqI implementing objects, of which Bio::Seq is one such object). If you want to know what to do with a Bio::Seq object, read L. The idea is that you request a stream object for a particular format. All the stream objects have a notion of an internal file that is read from or written to. A particular SeqIO object instance is configured for either input or output. A specific example of a stream object is the Bio::SeqIO::fasta object. Each stream object has functions $stream->next_seq(); and $stream->write_seq($seq); As an added bonus, you can recover a filehandle that is tied to the SeqIO object, allowing you to use the standard EE and print operations to read and write sequence objects: use Bio::SeqIO; $stream = Bio::SeqIO->newFh(-format => 'Fasta', -fh => \*ARGV); # read from standard input or the input filenames while ( $seq = <$stream> ) { # do something with $seq } and print $stream $seq; # when stream is in output mode This makes the simplest ever reformatter #!/usr/bin/perl use strict; my $format1 = shift; my $format2 = shift || die "Usage: reformat format1 format2 < input > output"; use Bio::SeqIO; my $in = Bio::SeqIO->newFh(-format => $format1, -fh => \*ARGV ); my $out = Bio::SeqIO->newFh(-format => $format2 ); # Note: you might want to quote -format to keep older # perl's from complaining. print $out $_ while <$in>; =head1 CONSTRUCTORS =head2 Bio::SeqIO-Enew() $seqIO = Bio::SeqIO->new(-file => 'filename', -format=>$format); $seqIO = Bio::SeqIO->new(-fh => \*FILEHANDLE, -format=>$format); $seqIO = Bio::SeqIO->new(-format => $format); The new() class method constructs a new Bio::SeqIO object. The returned object can be used to retrieve or print Seq objects. new() accepts the following parameters: =over 5 =item -file A file path to be opened for reading or writing. The usual Perl conventions apply: 'file' # open file for reading '>file' # open file for writing '>>file' # open file for appending '+new(-fh => \*STDIN); Note that you must pass filehandles as references to globs. If neither a filehandle nor a filename is specified, then the module will read from the @ARGV array or STDIN, using the familiar EE semantics. A string filehandle is handy if you want to modify the output in the memory, before printing it out. The following program reads in EMBL formatted entries from a file and prints them out in fasta format with some HTML tags: use Bio::SeqIO; use IO::String; my $in = Bio::SeqIO->new(-file => "emblfile", -format => 'EMBL'); while ( my $seq = $in->next_seq() ) { # the output handle is reset for every file my $stringio = IO::String->new($string); my $out = Bio::SeqIO->new(-fh => $stringio, -format => 'fasta'); # output goes into $string $out->write_seq($seq); # modify $string $string =~ s|(>)(\w+)|$1$2|g; # print into STDOUT print $string; } =item -format Specify the format of the file. Supported formats include fasta, genbank, embl, swiss (SwissProt), Entrez Gene and tracefile formats such as abi (ABI) and scf. There are many more, for a complete listing see the SeqIO HOWTO (L). If no format is specified and a filename is given then the module will attempt to deduce the format from the filename suffix. If there is no suffix that Bioperl understands then it will attempt to guess the format based on file content. If this is unsuccessful then SeqIO will throw a fatal error. The format name is case-insensitive: 'FASTA', 'Fasta' and 'fasta' are all valid. Currently, the tracefile formats (except for SCF) require installation of the external Staden "io_lib" package, as well as the Bio::SeqIO::staden::read package available from the bioperl-ext repository. =item -alphabet Sets the alphabet ('dna', 'rna', or 'protein'). When the alphabet is set then Bioperl will not attempt to guess what the alphabet is. This may be important because Bioperl does not always guess correctly. =item -flush By default, all files (or filehandles) opened for writing sequences will be flushed after each write_seq() (making the file immediately usable). If you do not need this facility and would like to marginally improve the efficiency of writing multiple sequences to the same file (or filehandle), pass the -flush option '0' or any other value that evaluates as defined but false: my $gb = Bio::SeqIO->new(-file => " "gb"); my $fa = Bio::SeqIO->new(-file => ">gball.fa", -format => "fasta", -flush => 0); # go as fast as we can! while($seq = $gb->next_seq) { $fa->write_seq($seq) } =item -seqfactory Provide a Bio::Factory::SequenceFactoryI object. See the sequence_factory() method. =item -locfactory Provide a Bio::Factory::LocationFactoryI object. See the location_factory() method. =item -objbuilder Provide a Bio::Factory::ObjectBuilderI object. See the object_builder() method. =back =head2 Bio::SeqIO-EnewFh() $fh = Bio::SeqIO->newFh(-fh => \*FILEHANDLE, -format=>$format); $fh = Bio::SeqIO->newFh(-format => $format); # etc. This constructor behaves like new(), but returns a tied filehandle rather than a Bio::SeqIO object. You can read sequences from this object using the familiar EE operator, and write to it using print(). The usual array and $_ semantics work. For example, you can read all sequence objects into an array like this: @sequences = <$fh>; Other operations, such as read(), sysread(), write(), close(), and printf() are not supported. =head1 OBJECT METHODS See below for more detailed summaries. The main methods are: =head2 $sequence = $seqIO-Enext_seq() Fetch the next sequence from the stream, or nothing if no more. =head2 $seqIO-Ewrite_seq($sequence [,$another_sequence,...]) Write the specified sequence(s) to the stream. =head2 TIEHANDLE(), READLINE(), PRINT() These provide the tie interface. See L for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: bioperl-l@bioperl.org rather than to the module maintainer directly. Many experienced and responsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney, Lincoln Stein Email birney@ebi.ac.uk lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' Let the code begin... package Bio::SeqIO; use strict; use warnings; use Bio::Factory::FTLocationFactory; use Bio::Seq::SeqBuilder; use Bio::Tools::GuessSeqFormat; use Symbol; use parent qw(Bio::Root::Root Bio::Root::IO Bio::Factory::SequenceStreamI); my %valid_alphabet_cache; =head2 new Title : new Usage : $stream = Bio::SeqIO->new(-file => 'sequences.fasta', -format => 'fasta'); Function: Returns a new sequence stream Returns : A Bio::SeqIO stream initialised with the appropriate format Args : Named parameters: -file => filename -fh => filehandle to attach to -format => format Additional arguments may be used. They all have reasonable defaults and are thus optional. -alphabet => 'dna', 'rna', or 'protein' -flush => 0 or 1 (default, flush filehandles after each write) -seqfactory => sequence factory -locfactory => location factory -objbuilder => object builder See L =cut my $entry = 0; sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::SeqIO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys unless( defined $param{-file} || defined $param{-fh} || defined $param{-string} ) { $class->throw("file argument provided, but with an undefined value") if exists $param{'-file'}; $class->throw("fh argument provided, but with an undefined value") if exists $param{'-fh'}; $class->throw("string argument provided, but with an undefined value") if exists($param{'-string'}); # $class->throw("No file, fh, or string argument provided"); # neither defined } my $format = $param{'-format'} || $class->_guess_format( $param{-file} || $ARGV[0] ); if( ! $format ) { if ($param{-file}) { $format = Bio::Tools::GuessSeqFormat->new(-file => $param{-file}||$ARGV[0] )->guess; } elsif ($param{-fh}) { $format = Bio::Tools::GuessSeqFormat->new(-fh => $param{-fh}||$ARGV[0] )->guess; } } # changed 1-3-11; no need to print out an empty string (only way this # exception is triggered) - cjfields $class->throw("Could not guess format from file/fh") unless $format; $format = "\L$format"; # normalize capitalization to lower case if ($format =~ /-/) { ($format, my $variant) = split('-', $format, 2); push @args, (-variant => $variant); } return unless( $class->_load_format_module($format) ); return "Bio::SeqIO::$format"->new(@args); } } =head2 newFh Title : newFh Usage : $fh = Bio::SeqIO->newFh(-file=>$filename,-format=>'Format') Function: Does a new() followed by an fh() Example : $fh = Bio::SeqIO->newFh(-file=>$filename,-format=>'Format') $sequence = <$fh>; # read a sequence object print $fh $sequence; # write a sequence object Returns : filehandle tied to the Bio::SeqIO::Fh class Args : See L =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Get or set the IO filehandle Example : $fh = $obj->fh; # make a tied filehandle $sequence = <$fh>; # read a sequence object print $fh $sequence; # write a sequence object Returns : filehandle tied to Bio::SeqIO class Args : none =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } # _initialize is chained for all SeqIO classes sub _initialize { my($self, @args) = @_; # flush is initialized by the Root::IO init my ($seqfact,$locfact,$objbuilder, $alphabet) = $self->_rearrange([qw(SEQFACTORY LOCFACTORY OBJBUILDER ALPHABET) ], @args); $locfact = Bio::Factory::FTLocationFactory->new(-verbose => $self->verbose) if ! $locfact; $objbuilder = Bio::Seq::SeqBuilder->new(-verbose => $self->verbose) unless $objbuilder; $self->sequence_builder($objbuilder); $self->location_factory($locfact); # note that this should come last because it propagates the sequence # factory to the sequence builder $seqfact && $self->sequence_factory($seqfact); #bug 2160 $alphabet && $self->alphabet($alphabet); # initialize the IO part $self->_initialize_io(@args); } =head2 next_seq Title : next_seq Usage : $seq = stream->next_seq Function: Reads the next sequence object from the stream and returns it. Certain driver modules may encounter entries in the stream that are either misformatted or that use syntax not yet understood by the driver. If such an incident is recoverable, e.g., by dismissing a feature of a feature table or some other non-mandatory part of an entry, the driver will issue a warning. In the case of a non-recoverable situation an exception will be thrown. Do not assume that you can resume parsing the same stream after catching the exception. Note that you can always turn recoverable errors into exceptions by calling $stream->verbose(2). Returns : a Bio::Seq sequence object, or nothing if no more sequences are available Args : none See L, L, L =cut sub next_seq { my ($self, $seq) = @_; $self->throw("Sorry, you cannot read from a generic Bio::SeqIO object."); } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self, $seq) = @_; $self->throw("Sorry, you cannot write to a generic Bio::SeqIO object."); } =head2 format Title : format Usage : $format = $stream->format() Function: Get the sequence format Returns : sequence format, e.g. fasta, fastq Args : none =cut # format() method inherited from Bio::Root::IO =head2 alphabet Title : alphabet Usage : $self->alphabet($newval) Function: Set/get the molecule type for the Seq objects to be created. Example : $seqio->alphabet('protein') Returns : value of alphabet: 'dna', 'rna', or 'protein' Args : newvalue (optional) Throws : Exception if the argument is not one of 'dna', 'rna', or 'protein' =cut sub alphabet { my ($self, $value) = @_; if ( defined $value) { $value = lc $value; unless ($valid_alphabet_cache{$value}) { # instead of hard-coding the allowed values once more, we check by # creating a dummy sequence object eval { require Bio::PrimarySeq; my $seq = Bio::PrimarySeq->new('-verbose' => $self->verbose, '-alphabet' => $value); }; if ($@) { $self->throw("Invalid alphabet: $value\n. See Bio::PrimarySeq for allowed values."); } $valid_alphabet_cache{$value} = 1; } $self->{'alphabet'} = $value; } return $self->{'alphabet'}; } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL SeqIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self, $format) = @_; my $module = "Bio::SeqIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_filehandle($newval) Function: This method is deprecated. Call _fh() instead. Example : Returns : value of _filehandle Args : newvalue (optional) =cut sub _filehandle { my ($self,@args) = @_; return $self->_fh(@args); } =head2 _guess_format Title : _guess_format Usage : $obj->_guess_format($filename) Function: guess format based on file suffix Example : Returns : guessed format of filename (lower case) Args : Notes : formats that _filehandle() will guess include fasta, genbank, scf, pir, embl, raw, gcg, ace, bsml, swissprot, fastq and phd/phred =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'abi' if /\.ab[i1]$/i; return 'ace' if /\.ace$/i; return 'alf' if /\.alf$/i; return 'bsml' if /\.(bsm|bsml)$/i; return 'ctf' if /\.ctf$/i; return 'embl' if /\.(embl|ebl|emb|dat)$/i; return 'entrezgene' if /\.asn$/i; return 'exp' if /\.exp$/i; return 'fasta' if /\.(fasta|fast|fas|seq|fa|fsa|nt|aa|fna|faa)$/i; return 'fastq' if /\.fastq$/i; return 'gcg' if /\.gcg$/i; return 'genbank' if /\.(gb|gbank|genbank|gbk|gbs)$/i; return 'phd' if /\.(phd|phred)$/i; return 'pir' if /\.pir$/i; return 'pln' if /\.pln$/i; return 'qual' if /\.qual$/i; return 'raw' if /\.txt$/i; return 'scf' if /\.scf$/i; return 'swiss' if /\.(swiss|sp)$/i; # from Strider 1.4 Release Notes: The file name extensions used by # Strider 1.4 are ".xdna", ".xdgn", ".xrna" and ".xprt" for DNA, # DNA Degenerate, RNA and Protein Sequence Files, respectively return 'strider' if /\.(xdna|xdgn|xrna|xprt)$/i; return 'ztr' if /\.ztr$/i; } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my ($class,$val) = @_; return bless {'seqio' => $val}, $class; } sub READLINE { my $self = shift; return $self->{'seqio'}->next_seq() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'seqio'}->next_seq(); return @list; } sub PRINT { my $self = shift; $self->{'seqio'}->write_seq(@_); } =head2 sequence_factory Title : sequence_factory Usage : $seqio->sequence_factory($seqfactory) Function: Get/Set the Bio::Factory::SequenceFactoryI Returns : Bio::Factory::SequenceFactoryI Args : [optional] Bio::Factory::SequenceFactoryI =cut sub sequence_factory { my ($self, $obj) = @_; if( defined $obj ) { if( ! ref($obj) || ! $obj->isa('Bio::Factory::SequenceFactoryI') ) { $self->throw("Must provide a valid Bio::Factory::SequenceFactoryI object to ".ref($self)."::sequence_factory()"); } $self->{'_seqio_seqfactory'} = $obj; my $builder = $self->sequence_builder(); if($builder && $builder->can('sequence_factory') && (! $builder->sequence_factory())) { $builder->sequence_factory($obj); } } $self->{'_seqio_seqfactory'}; } =head2 object_factory Title : object_factory Usage : $obj->object_factory($newval) Function: This is an alias to sequence_factory with a more generic name. Example : Returns : value of object_factory (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub object_factory{ return shift->sequence_factory(@_); } =head2 sequence_builder Title : sequence_builder Usage : $seqio->sequence_builder($seqfactory) Function: Get/Set the Bio::Factory::ObjectBuilderI used to build sequence objects. This applies to rich sequence formats only, e.g. genbank but not fasta. If you do not set the sequence object builder yourself, it will in fact be an instance of L, and you may use all methods documented there to configure it. Returns : a Bio::Factory::ObjectBuilderI compliant object Args : [optional] a Bio::Factory::ObjectBuilderI compliant object =cut sub sequence_builder { my ($self, $obj) = @_; if( defined $obj ) { if( ! ref($obj) || ! $obj->isa('Bio::Factory::ObjectBuilderI') ) { $self->throw("Must provide a valid Bio::Factory::ObjectBuilderI object to ".ref($self)."::sequence_builder()"); } $self->{'_object_builder'} = $obj; } $self->{'_object_builder'}; } =head2 location_factory Title : location_factory Usage : $seqio->location_factory($locfactory) Function: Get/Set the Bio::Factory::LocationFactoryI object to be used for location string parsing Returns : a Bio::Factory::LocationFactoryI implementing object Args : [optional] on set, a Bio::Factory::LocationFactoryI implementing object. =cut sub location_factory { my ($self,$obj) = @_; if( defined $obj ) { if( ! ref($obj) || ! $obj->isa('Bio::Factory::LocationFactoryI') ) { $self->throw("Must provide a valid Bio::Factory::LocationFactoryI" . " object to ".ref($self)."->location_factory()"); } $self->{'_seqio_locfactory'} = $obj; } $self->{'_seqio_locfactory'}; } 1; BioPerl-1.6.923/Bio/SeqUtils.pm000444000765000024 16167312254227327 16340 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::SeqUtils # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqUtils - Additional methods for PrimarySeq objects =head1 SYNOPSIS use Bio::SeqUtils; # get a Bio::PrimarySeqI compliant object, $seq, somehow $util = Bio::SeqUtils->new(); $polypeptide_3char = $util->seq3($seq); # or $polypeptide_3char = Bio::SeqUtils->seq3($seq); # set the sequence string (stored in one char code in the object) Bio::SeqUtils->seq3($seq, $polypeptide_3char); # translate a sequence in all six frames @seqs = Bio::SeqUtils->translate_6frames($seq); # inplace editing of the sequence Bio::SeqUtils->mutate($seq, Bio::LiveSeq::Mutation->new(-seq => 'c', -pos => 3 )); # mutate a sequence to desired similarity% $newseq = Bio::SeqUtils-> evolve ($seq, $similarity, $transition_transversion_rate); # concatenate two or more sequences with annotations and features, # the first sequence will be modified Bio::SeqUtils->cat(@seqs); my $catseq=$seqs[0]; # truncate a sequence, retaining features and adjusting their # coordinates if necessary my $truncseq = Bio::SeqUtils->trunc_with_features($seq, 100, 200); # reverse complement a sequence and its features my $revcomseq = Bio::SeqUtils->revcom_with_features($seq); # simulate cloning of a fragment into a vector. Cut the vector at # positions 1000 and 1100 (deleting postions 1001 to 1099) and # "ligate" a fragment into the sites. The fragment is # reverse-complemented in this example (option "flip"). # All features of the vector and fragment are preserved and # features that are affected by the deletion/insertion are # modified accordingly. # $vector and $fragment must be Bio::SeqI compliant objects my $new_molecule = Bio::Sequtils->ligate( -vector => $vector, -fragment => $fragment, -left => 1000, -right => 1100, -flip => 1 ); # delete a segment of a sequence (from pos 1000 to 1100, inclusive), # again preserving features and annotations my $new_molecule = Bio::SeqUtils->cut( $seq, 1000, 1100 ); # insert a fragment into a recipient between positions 1000 and # 1001. $recipient is a Bio::SeqI compliant object my $new_molecule = Bio::SeqUtils::PbrTools->insert( $recipient_seq, $fragment_seq, 1000 ); =head1 DESCRIPTION This class is a holder of methods that work on Bio::PrimarySeqI- compliant sequence objects, e.g. Bio::PrimarySeq and Bio::Seq. These methods are not part of the Bio::PrimarySeqI interface and should in general not be essential to the primary function of sequence objects. If you are thinking of adding essential functions, it might be better to create your own sequence class. See L, L, and L for more. The methods take as their first argument a sequence object. It is possible to use methods without first creating a SeqUtils object, i.e. use it as an anonymous hash. The first two methods, seq3() and seq3in(), give out or read in protein sequences coded in three letter IUPAC amino acid codes. The next two methods, translate_3frames() and translate_6frames(), wrap around the standard translate method to give back an array of three forward or all six frame translations. The mutate() method mutates the sequence string with a mutation description object. The cat() method concatenates two or more sequences. The first sequence is modified by addition of the remaining sequences. All annotations and sequence features will be transferred. The revcom_with_features() and trunc_with_features() methods are similar to the revcom() and trunc() methods from Bio::Seq, but also adjust any features associated with the sequence as appropriate. There are also methods that simulate molecular cloning with rich sequence objects. The delete() method cuts a segment out of a sequence and re-joins the left and right fragments (like splicing or digesting and re-ligating a molecule). Positions (and types) of sequence features are adjusted accordingly: Features that span the deleted segment are converted to split featuress to indicate the disruption. (Sub)Features that extend into the deleted segment are truncated. A new molecule is created and returned. The insert() method inserts a fragment (which can be a rich Bio::Seq object) into another sequence object adding all annotations and features to the final product. Features that span the insertion site are converted to split features to indicate the disruption. A new feature is added to indicate the inserted fragment itself. A new molecule is created and returned. The ligate() method simulates digesting a recipient (vector) and ligating a fragment into it, which can also be flipped if needed. It is simply a combination of a deletion and an insertion step and returns a new molecule. The rules for modifying feature locations outlined above are also used here, e.g. features that span the cut sites are converted to split features with truncated sub-locations. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Roy R. Chaudhuri - roy.chaudhuri at gmail.com Frank Schwach - frank.schwach@sanger.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqUtils; use strict; use warnings; use Scalar::Util qw(blessed); use parent qw(Bio::Root::Root); # new inherited from RootI our %ONECODE = ( 'Ala' => 'A', 'Asx' => 'B', 'Cys' => 'C', 'Asp' => 'D', 'Glu' => 'E', 'Phe' => 'F', 'Gly' => 'G', 'His' => 'H', 'Ile' => 'I', 'Lys' => 'K', 'Leu' => 'L', 'Met' => 'M', 'Asn' => 'N', 'Pro' => 'P', 'Gln' => 'Q', 'Arg' => 'R', 'Ser' => 'S', 'Thr' => 'T', 'Val' => 'V', 'Trp' => 'W', 'Xaa' => 'X', 'Tyr' => 'Y', 'Glx' => 'Z', 'Ter' => '*', 'Sec' => 'U', 'Pyl' => 'O', 'Xle' => 'J' ); our %THREECODE = ( 'A' => 'Ala', 'B' => 'Asx', 'C' => 'Cys', 'D' => 'Asp', 'E' => 'Glu', 'F' => 'Phe', 'G' => 'Gly', 'H' => 'His', 'I' => 'Ile', 'K' => 'Lys', 'L' => 'Leu', 'M' => 'Met', 'N' => 'Asn', 'P' => 'Pro', 'Q' => 'Gln', 'R' => 'Arg', 'S' => 'Ser', 'T' => 'Thr', 'V' => 'Val', 'W' => 'Trp', 'Y' => 'Tyr', 'Z' => 'Glx', 'X' => 'Xaa', '*' => 'Ter', 'U' => 'Sec', 'O' => 'Pyl', 'J' => 'Xle' ); =head2 seq3 Title : seq3 Usage : $string = Bio::SeqUtils->seq3($seq) Function: Read only method that returns the amino acid sequence as a string of three letter codes. alphabet has to be 'protein'. Output follows the IUPAC standard plus 'Ter' for terminator. Any unknown character, including the default unknown character 'X', is changed into 'Xaa'. A noncoded aminoacid selenocystein is recognized (Sec, U). Returns : A scalar Args : character used for stop in the protein sequence optional, defaults to '*' string used to separate the output amino acid codes, optional, defaults to '' =cut sub seq3 { my ( $self, $seq, $stop, $sep ) = @_; $seq->isa('Bio::PrimarySeqI') || $self->throw('Not a Bio::PrimarySeqI object but [$self]'); $seq->alphabet eq 'protein' || $self->throw('Not a protein sequence'); if ( defined $stop ) { length $stop != 1 and $self->throw('One character stop needed, not [$stop]'); $THREECODE{$stop} = "Ter"; } $sep ||= ''; my $aa3s; foreach my $aa ( split //, uc $seq->seq ) { $THREECODE{$aa} and $aa3s .= $THREECODE{$aa} . $sep, next; $aa3s .= 'Xaa' . $sep; } $sep and substr( $aa3s, -( length $sep ), length $sep ) = ''; return $aa3s; } =head2 seq3in Title : seq3in Usage : $seq = Bio::SeqUtils->seq3in($seq, 'MetGlyTer') Function: Method for changing of the sequence of a Bio::PrimarySeqI sequence object. The three letter amino acid input string is converted into one letter code. Any unknown character triplet, including the default 'Xaa', is converted into 'X'. Returns : Bio::PrimarySeq object Args : sequence string optional character to be used for stop in the protein sequence, defaults to '*' optional character to be used for unknown in the protein sequence, defaults to 'X' =cut sub seq3in { my ( $self, $seq, $string, $stop, $unknown ) = @_; $seq->isa('Bio::PrimarySeqI') || $self->throw("Not a Bio::PrimarySeqI object but [$self]"); $seq->alphabet eq 'protein' || $self->throw('Not a protein sequence'); if ( defined $stop ) { length $stop != 1 and $self->throw("One character stop needed, not [$stop]"); $ONECODE{'Ter'} = $stop; } if ( defined $unknown ) { length $unknown != 1 and $self->throw("One character stop needed, not [$unknown]"); $ONECODE{'Xaa'} = $unknown; } my ( $aas, $aa3 ); my $length = ( length $string ) - 2; for ( my $i = 0 ; $i < $length ; $i += 3 ) { $aa3 = substr( $string, $i, 3 ); $aa3 = ucfirst( lc($aa3) ); $ONECODE{$aa3} and $aas .= $ONECODE{$aa3}, next; $aas .= $ONECODE{'Xaa'}; } $seq->seq($aas); return $seq; } =head2 translate_3frames Title : translate_3frames Usage : @prots = Bio::SeqUtils->translate_3frames($seq) Function: Translate a nucleotide sequence in three forward frames. The IDs of the sequences are appended with '-0F', '-1F', '-2F'. Returns : An array of seq objects Args : sequence object same arguments as to Bio::PrimarySeqI::translate =cut sub translate_3frames { my ( $self, $seq, @args ) = @_; $self->throw( 'Object [$seq] ' . 'of class [' . ref($seq) . '] can not be translated.' ) unless $seq->can('translate'); my ( $stop, $unknown, $frame, $tableid, $fullCDS, $throw ) = @args; my @seqs; my $f = 0; while ( $f != 3 ) { my $translation = $seq->translate( $stop, $unknown, $f, $tableid, $fullCDS, $throw ); $translation->id( $seq->id . "-" . $f . "F" ); push @seqs, $translation; $f++; } return @seqs; } =head2 translate_6frames Title : translate_6frames Usage : @prots = Bio::SeqUtils->translate_6frames($seq) Function: translate a nucleotide sequence in all six frames The IDs of the sequences are appended with '-0F', '-1F', '-2F', '-0R', '-1R', '-2R'. Returns : An array of seq objects Args : sequence object same arguments as to Bio::PrimarySeqI::translate =cut sub translate_6frames { my ( $self, $seq, @args ) = @_; my @seqs = $self->translate_3frames( $seq, @args ); my @seqs2 = $self->translate_3frames( $seq->revcom, @args ); foreach my $seq2 (@seqs2) { my ($tmp) = $seq2->id; $tmp =~ s/F$/R/g; $seq2->id($tmp); } return @seqs, @seqs2; } =head2 valid_aa Title : valid_aa Usage : my @aa = $table->valid_aa Function: Retrieves a list of the valid amino acid codes. The list is ordered so that first 21 codes are for unique amino acids. The rest are ['B', 'Z', 'X', '*']. Returns : array of all the valid amino acid codes Args : [optional] $code => [0 -> return list of 1 letter aa codes, 1 -> return list of 3 letter aa codes, 2 -> return associative array of both ] =cut sub valid_aa { my ( $self, $code ) = @_; if ( !$code ) { my @codes; foreach my $c ( sort values %ONECODE ) { push @codes, $c unless ( $c =~ /[BZX\*]/ ); } push @codes, qw(B Z X *); # so they are in correct order ? return @codes; } elsif ( $code == 1 ) { my @codes; foreach my $c ( sort keys %ONECODE ) { push @codes, $c unless ( $c =~ /(Asx|Glx|Xaa|Ter)/ ); } push @codes, ( 'Asx', 'Glx', 'Xaa', 'Ter' ); return @codes; } elsif ( $code == 2 ) { my %codes = %ONECODE; foreach my $c ( keys %ONECODE ) { my $aa = $ONECODE{$c}; $codes{$aa} = $c; } return %codes; } else { $self->warn( "unrecognized code in " . ref($self) . " method valid_aa()" ); return (); } } =head2 mutate Title : mutate Usage : Bio::SeqUtils->mutate($seq,$mutation1, $mutation2); Function: Inplace editing of the sequence. The second argument can be a Bio::LiveSeq::Mutation object or an array of them. The mutations are applied sequentially checking only that their position is within the current sequence. Insertions are inserted before the given position. Returns : boolean Args : sequence object mutation, a Bio::LiveSeq::Mutation object, or an array of them See L. =cut sub mutate { my ( $self, $seq, @mutations ) = @_; $self->throw( 'Object [$seq] ' . 'of class [' . ref($seq) . '] should be a Bio::PrimarySeqI ' ) unless $seq->isa('Bio::PrimarySeqI'); $self->throw( 'Object [$mutations[0]] ' . 'of class [' . ref( $mutations[0] ) . '] should be a Bio::LiveSeq::Mutation' ) unless $mutations[0]->isa('Bio::LiveSeq::Mutation'); foreach my $mutation (@mutations) { $self->throw('Attempting to mutate sequence beyond its length') unless $mutation->pos - 1 <= $seq->length; my $string = $seq->seq; substr $string, $mutation->pos - 1, $mutation->len, $mutation->seq; $seq->seq($string); } 1; } =head2 cat Title : cat Usage : Bio::SeqUtils->cat(@seqs); my $catseq=$seqs[0]; Function: Concatenates a list of Bio::Seq objects, adding them all on to the end of the first sequence. Annotations and sequence features are copied over from any additional objects, and the coordinates of any copied features are adjusted appropriately. Returns : a boolean Args : array of sequence objects Note that annotations have no sequence locations. If you concatenate sequences with the same annotations they will all be added. =cut sub cat { my ( $self, $seq, @seqs ) = @_; $self->throw( 'Object [$seq] ' . 'of class [' . ref($seq) . '] should be a Bio::PrimarySeqI ' ) unless $seq->isa('Bio::PrimarySeqI'); for my $catseq (@seqs) { $self->throw( 'Object [$catseq] ' . 'of class [' . ref($catseq) . '] should be a Bio::PrimarySeqI ' ) unless $catseq->isa('Bio::PrimarySeqI'); $self->throw( 'Trying to concatenate sequences with different alphabets: ' . $seq->display_id . '(' . $seq->alphabet . ') and ' . $catseq->display_id . '(' . $catseq->alphabet . ')' ) unless $catseq->alphabet eq $seq->alphabet; my $length = $seq->length; $seq->seq( $seq->seq . $catseq->seq ); # move annotations if ( $seq->isa("Bio::AnnotatableI") and $catseq->isa("Bio::AnnotatableI") ) { foreach my $key ( $catseq->annotation->get_all_annotation_keys() ) { foreach my $value ( $catseq->annotation->get_Annotations($key) ) { $seq->annotation->add_Annotation( $key, $value ); } } } # move SeqFeatures if ( $seq->isa('Bio::SeqI') and $catseq->isa('Bio::SeqI') ) { for my $feat ( $catseq->get_SeqFeatures ) { $seq->add_SeqFeature( $self->_coord_adjust( $feat, $length ) ); } } } 1; } =head2 trunc_with_features Title : trunc_with_features Usage : $trunc=Bio::SeqUtils->trunc_with_features($seq, $start, $end); Function: Like Bio::Seq::trunc, but keeps features (adjusting coordinates where necessary. Features that partially overlap the region have their location changed to a Bio::Location::Fuzzy. Returns : A new sequence object Args : A sequence object, start coordinate, end coordinate (inclusive) =cut sub trunc_with_features { use Bio::Range; my ( $self, $seq, $start, $end ) = @_; $self->throw( 'Object [$seq] ' . 'of class [' . ref($seq) . '] should be a Bio::SeqI ' ) unless $seq->isa('Bio::SeqI'); my $trunc = $seq->trunc( $start, $end ); my $truncrange = Bio::Range->new( -start => $start, -end => $end, -strand => 0 ); # make sure that there is no annotation or features in $trunc # (->trunc() now clone objects except for Bio::Seq::LargePrimarySeq) $trunc->annotation->remove_Annotations; $trunc->remove_SeqFeatures; # move annotations foreach my $key ( $seq->annotation->get_all_annotation_keys() ) { foreach my $value ( $seq->annotation->get_Annotations($key) ) { $trunc->annotation->add_Annotation( $key, $value ); } } # move features foreach ( grep { $_ = $self->_coord_adjust( $_, 1 - $start, $end + 1 - $start ) if $_->overlaps($truncrange) } $seq->get_SeqFeatures ) { $trunc->add_SeqFeature($_); } return $trunc; } =head2 delete Title : delete Function: cuts a segment out of a sequence and re-joins the left and right fragments (like splicing or digesting and re-ligating a molecule). Positions (and types) of sequence features are adjusted accordingly: Features that span the cut site are converted to split featuress to indicate the disruption. Features that extend into the cut-out fragment are truncated. A new molecule is created and returned. Usage : my $cutseq = Bio::SeqUtils::PbrTools->cut( $seq, 1000, 1100 ); Args : a Bio::PrimarySeqI compliant object to cut, first nt of the segment to be deleted last nt of the segment to be deleted optional: hash-ref of options: clone_obj: if true, clone the input sequence object rather than calling "new" on the object's class Returns : a new Bio::Seq object =cut sub delete { my $self = shift; my ( $seq, $left, $right, $opts_ref ) = @_; $self->throw( 'was expecting 3-4 paramters but got ' . @_ ) unless @_ == 3 || @_ == 4; $self->throw( 'Object of class [' . ref($seq) . '] should be a Bio::PrimarySeqI ' ) unless blessed($seq) && $seq->isa('Bio::PrimarySeqI'); $self->throw("Left coordinate ($left) must be >= 1") if $left < 1; if ( $right > $seq->length ) { $self->throw( "Right coordinate ($right) must be less than " . 'sequence length (' . $seq->length . ')' ); } # piece together the sequence string of the remaining fragments my $left_seq = $seq->subseq( 1, $left - 1 ); my $right_seq = $seq->subseq( $right + 1, $seq->length ); if ( !$left_seq || !$right_seq ) { $self->throw( 'could not assemble sequences. At least one of the fragments is empty' ); } my $seq_str = $left_seq . $right_seq; # create the new seq object with the same class as the recipient # or (if requested), make a clone of the existing object. In the # latter case we need to remove sequence features from the cloned # object instead of copying them my $product; if ( $opts_ref->{clone_obj} ) { $product = $self->_new_seq_via_clone( $seq, $seq_str ); } else { $product = $self->_new_seq_from_old( $seq, { seq => $seq_str } ); } # move sequence features if ( $product->isa('Bio::SeqI') && $seq->isa('Bio::SeqI') ) { for my $feat ( $seq->get_SeqFeatures ) { my $adjfeat = $self->_coord_adjust_deletion( $feat, $left, $right ); $product->add_SeqFeature($adjfeat) if $adjfeat; } } # add a feature to annotatde the deletion my $deletion_feature = Bio::SeqFeature::Generic->new( -primary_tag => 'misc_feature', -tag => { note => 'deletion of ' . ( $right - $left + 1 ) . 'bp' }, -location => Bio::Location::Simple->new( -start => $left - 1, -end => $left, -location_type => 'IN-BETWEEN' ) ); $product->add_SeqFeature($deletion_feature); return $product; } =head2 insert Title : insert Function: inserts a fragment (a Bio::Seq object) into a nother sequence object adding all annotations and features to the final product. Features that span the insertion site are converted to split features to indicate the disruption. A new feature is added to indicate the inserted fragment itself. A new molecule is created and returned. Usage : # insert a fragment after pos 1000 my $insert_seq = Bio::SeqUtils::PbrTools->insert( $recipient_seq, $fragment_seq, 1000 ); Args : recipient sequence (a Bio::PrimarySeqI compliant object), a fragmetn to insert (Bio::PrimarySeqI compliant object), insertion position (fragment is inserted to the right of this pos) pos=0 will prepend the fragment to the recipient optional: hash-ref of options: clone_obj: if true, clone the input sequence object rather than calling "new" on the object's class Returns : a new Bio::Seq object =cut sub insert { my $self = shift; my ( $recipient, $fragment, $insert_pos, $opts_ref ) = @_; $self->throw( 'was expecting 3-4 paramters but got ' . @_ ) unless @_ == 3 || @_ == 4; $self->throw( 'Recipient object of class [' . ref($recipient) . '] should be a Bio::PrimarySeqI ' ) unless blessed($recipient) && $recipient->isa('Bio::PrimarySeqI'); $self->throw( 'Fragment object of class [' . ref($fragment) . '] should be a Bio::PrimarySeqI ' ) unless blessed($fragment) && $fragment->isa('Bio::PrimarySeqI'); $self->throw( 'Can\'t concatenate sequences with different alphabets: ' . 'recipient is ' . $recipient->alphabet . ' and fragment is ' . $fragment->alphabet ) unless $recipient->alphabet eq $fragment->alphabet; if ( $insert_pos < 0 or $insert_pos > $recipient->length ) { $self->throw( "insertion position ($insert_pos) must be between 0 and " . 'recipient sequence length (' . $recipient->length . ')' ); } if ( $fragment->can('is_circular') && $fragment->is_circular ) { $self->throw('Can\'t insert circular fragments'); } if ( !$recipient->seq ) { $self->throw( 'Recipient has no sequence, can not insert into this object'); } # construct raw sequence of the new molecule my $left_seq = $insert_pos > 0 ? $recipient->subseq( 1, $insert_pos ) : ''; my $mid_seq = $fragment->seq; my $right_seq = $insert_pos < $recipient->length ? $recipient->subseq( $insert_pos + 1, $recipient->length ) : ''; my $seq_str = $left_seq . $mid_seq . $right_seq; # create the new seq object with the same class as the recipient # or (if requested), make a clone of the existing object. In the # latter case we need to remove sequence features from the cloned # object instead of copying them my $product; if ( $opts_ref->{clone_obj} ) { $product = $self->_new_seq_via_clone( $recipient, $seq_str ); } else { my @desc; push @desc, 'Inserted fragment: ' . $fragment->desc if defined $fragment->desc; push @desc, 'Recipient: ' . $recipient->desc if defined $recipient->desc; $product = $self->_new_seq_from_old( $recipient, { seq => $seq_str, display_id => $recipient->display_id, accession_number => $recipient->accession_number || '', alphabet => $recipient->alphabet, desc => join( '; ', @desc ), verbose => $recipient->verbose || $fragment->verbose, is_circular => $recipient->is_circular || 0, } ); } # if clone_obj # move annotations from fragment to product if ( $product->isa("Bio::AnnotatableI") && $fragment->isa("Bio::AnnotatableI") ) { foreach my $key ( $fragment->annotation->get_all_annotation_keys ) { foreach my $value ( $fragment->annotation->get_Annotations($key) ) { $product->annotation->add_Annotation( $key, $value ); } } } # move sequence features to product with adjusted coordinates if ( $product->isa('Bio::SeqI') ) { # for the fragment, just shift the features to new position if ( $fragment->isa('Bio::SeqI') ) { for my $feat ( $fragment->get_SeqFeatures ) { my $adjfeat = $self->_coord_adjust( $feat, $insert_pos ); $product->add_SeqFeature($adjfeat) if $adjfeat; } } # for recipient, shift and modify features according to insertion. if ( $recipient->isa('Bio::SeqI') ) { for my $feat ( $recipient->get_SeqFeatures ) { my $adjfeat = $self->_coord_adjust_insertion( $feat, $insert_pos, $fragment->length ); $product->add_SeqFeature($adjfeat) if $adjfeat; } } } # add a feature to annotate the insertion my $insertion_feature = Bio::SeqFeature::Generic->new( -start => $insert_pos + 1, -end => $insert_pos + $fragment->length, -primary_tag => 'misc_feature', -tag => { note => 'inserted fragment' }, ); $product->add_SeqFeature($insertion_feature); return $product; } =head2 ligate title : ligate function: pastes a fragment (which can also have features) into a recipient sequence between two "cut" sites, preserving features and adjusting their locations. This is a shortcut for deleting a segment from a sequence object followed by an insertion of a fragmnet and is supposed to be used to simulate in-vitro cloning where a recipient (a vector) is digested and a fragment is then ligated into the recipient molecule. The fragment can be flipped (reverse-complemented with all its features). A new sequence object is returned to represent the product of the reaction. Features and annotations are transferred from the insert to the product and features on the recipient are adjusted according to the methods L amd L: Features spanning the insertion site will be split up into two sub-locations. (Sub-)features in the deleted region are themselves deleted. (Sub-)features that extend into the deleted region are truncated. The class of the product object depends on the class of the recipient (vector) sequence object. if it is not possible to instantiate a new object of that class, a Bio::Primaryseq object is created instead. usage : # insert the flipped fragment between positions 1000 and 1100 of the # vector, i.e. everything between these two positions is deleted and # replaced by the fragment my $new_molecule = Bio::Sequtils::Pbrtools->ligate( -recipient => $vector, -fragment => $fragment, -left => 1000, -right => 1100, -flip => 1, -clone_obj => 1 ); args : recipient: the recipient/vector molecule fragment: molecule that is to be ligated into the vector left: left cut site (fragment will be inserted to the right of this position) optional: right: right cut site (fragment will be inseterted to the left of this position). defaults to left+1 flip: boolean, if true, the fragment is reverse-complemented (including features) before inserting clone_obj: if true, clone the recipient object to create the product instead of calling "new" on its class returns : a new Bio::Seq object of the ligated fragments =cut sub ligate { my $self = shift; my ( $recipient, $fragment, $left, $right, $flip, $clone_obj ) = $self->_rearrange( [qw(RECIPIENT FRAGMENT LEFT RIGHT FLIP CLONE_OBJ )], @_ ); $self->throw("missing required parameter 'recipient'") unless $recipient; $self->throw("missing required parameter 'fragment'") unless $fragment; $self->throw("missing required parameter 'left'") unless defined $left; $right ||= $left + 1; $self->throw( "Fragment must be a Bio::PrimarySeqI compliant object but it is a " . ref($fragment) ) unless blessed($fragment) && $fragment->isa('Bio::PrimarySeqI'); $fragment = $self->revcom_with_features($fragment) if $flip; my $opts_ref = {}; $opts_ref->{clone_obj} = 1 if $clone_obj; # clone in two steps: first delete between the insertion sites, # then insert the fragment. Step 1 is skipped if insert positions # are adjacent (no deletion) my ( $product1, $product2 ); eval { if ( $right == $left + 1 ) { $product1 = $recipient; } else { $product1 = $self->delete( $recipient, $left + 1, $right - 1, $opts_ref ); } }; $self->throw( "Failed in step 1 (cut recipient): " . $@ ) if $@; eval { $product2 = $self->insert( $product1, $fragment, $left, $opts_ref ) }; $self->throw( "Failed in step 2 (insert fragment): " . $@ ) if $@; return $product2; } =head2 _coord_adjust_deletion title : _coord_adjust_deletion function: recursively adjusts coordinates of seqfeatures on a molecule where a segment has been deleted. (sub)features that span the deletion site become split features. (sub)features that extend into the deletion site are truncated. A note is added to the feature to inform about the size and position of the deletion. usage : my $adjusted_feature = Bio::Sequtils::_coord_adjust_deletion( $feature, $start, $end ); args : a Bio::SeqFeatureI compliant object, start (inclusive) position of the deletion site, end (inclusive) position of the deletion site returns : a Bio::SeqFeatureI compliant object =cut sub _coord_adjust_deletion { my ( $self, $feat, $left, $right ) = @_; $self->throw( 'object [$feat] ' . 'of class [' . ref($feat) . '] should be a Bio::SeqFeatureI ' ) unless $feat->isa('Bio::SeqFeatureI'); $self->throw('missing coordinates: need a left and a right position') unless defined $left && defined $right; if ( $left > $right ) { if ( $feat->can('is_circular') && $feat->is_circular ) { # todo handle circular molecules $self->throw( 'can not yet handle deletions in circular molecules if deletion spans origin' ); } else { $self->throw( "left coordinate ($left) must be less than right ($right)" . " but it was greater" ); } } my $deletion = Bio::Location::Simple->new( -start => $left, -end => $right, ); my $del_length = $right - $left + 1; my @adjsubfeat; for my $subfeat ( $feat->get_SeqFeatures ) { my $adjsubfeat = $self->_coord_adjust_deletion( $subfeat, $left, $right ); push @adjsubfeat, $adjsubfeat if $adjsubfeat; } my @loc; my $note; for ( $feat->location->each_Location ) { next if $deletion->contains($_); # this location will be deleted; my $strand = $_->strand; my $type = $_->location_type; my $start = $_->start; my $start_type = $_->can('start_pos_type') ? $_->start_pos_type : undef; my $end = $_->end; my $end_type = $_->can('end_pos_type') ? $_->end_pos_type : undef; my @newcoords = (); if ( $start < $deletion->start && $end > $deletion->end ) { # split the feature @newcoords = ( [ $start, ( $deletion->start - 1 ), $start_type, $end_type ], [ ( $deletion->start ), $end - $del_length, $start_type, $end_type ] ); $note = $del_length . 'bp internal deletion between pos ' . ( $deletion->start - 1 ) . ' and ' . $deletion->start; } elsif ( $_->start < $deletion->start && $_->end >= $deletion->start ) { # truncate feature end @newcoords = ( [ $start, ( $deletion->start - 1 ), $start_type, $end_type ] ); $note = ( $end - $deletion->start + 1 ) . 'bp deleted from feature '; if ( $feat->strand ) { $note .= $feat->strand == 1 ? "3' " : "5' "; } $note .= 'end'; } elsif ( $_->start <= $deletion->end && $_->end > $deletion->end ) { # truncate feature start and shift end @newcoords = ( [ ( $deletion->start ), $end - $del_length, $start_type, $end_type ] ); $note = ( $deletion->end - $start + 1 ) . 'bp deleted from feature '; if ( $feat->strand ) { $note .= $feat->strand == 1 ? "5' end" : "3' end"; } else { $note .= 'start'; } } elsif ( $start >= $deletion->end ) { # just shift entire location @newcoords = ( [ $start - $del_length, $end - $del_length, $start_type, $end_type ] ); } else { # not affected by deletion @newcoords = ( [ $start, $end, $start_type, $end_type ] ); } # if we have no coordinates, we return nothing # the feature is deleted return unless @newcoords; my @subloc = $self->_location_objects_from_coordinate_list( \@newcoords, $strand, $type ); push @loc, $self->_single_loc_object_from_collection(@subloc); } # each location # create new feature based on original one and move annotation across my $newfeat = Bio::SeqFeature::Generic->new( -primary => $feat->primary_tag ); foreach my $key ( $feat->annotation->get_all_annotation_keys() ) { foreach my $value ( $feat->annotation->get_Annotations($key) ) { $newfeat->annotation->add_Annotation( $key, $value ); } } foreach my $key ( $feat->get_all_tags() ) { $newfeat->add_tag_value( $key, $feat->get_tag_values($key) ); } # If we have a note about the deleted bases, add it if ($note) { $newfeat->add_tag_value( 'note', $note ); } # set modified location(s) for the new feature and # add its subfeatures if any my $loc = $self->_single_loc_object_from_collection(@loc); $loc ? $newfeat->location($loc) : return; $newfeat->add_SeqFeature($_) for @adjsubfeat; return $newfeat; } =head2 _coord_adjust_insertion title : _coord_adjust_insertion function: recursively adjusts coordinates of seqfeatures on a molecule where another sequence has been inserted. (sub)features that span the insertion site become split features and a note is added about the size and positin of the insertion. Features with an IN-BETWEEN location at the insertion site are lost (such features can only exist between adjacent bases) usage : my $adjusted_feature = Bio::Sequtils::_coord_adjust_insertion( $feature, $insert_pos, $insert_length ); args : a Bio::SeqFeatureI compliant object, insertion position (insert to the right of this position) length of inserted fragment returns : a Bio::SeqFeatureI compliant object =cut sub _coord_adjust_insertion { my ( $self, $feat, $insert_pos, $insert_len ) = @_; $self->throw( 'object [$feat] ' . 'of class [' . ref($feat) . '] should be a Bio::SeqFeatureI ' ) unless $feat->isa('Bio::SeqFeatureI'); $self->throw('missing insert position') unless defined $insert_pos; $self->throw('missing insert length') unless defined $insert_len; my @adjsubfeat; for my $subfeat ( $feat->get_SeqFeatures ) { push @adjsubfeat, $self->_coord_adjust_insertion( $subfeat, $insert_pos, $insert_len ); } my @loc; my $note; for ( $feat->location->each_Location ) { # loose IN-BETWEEN features at the insertion site next if ( $_->location_type eq 'IN-BETWEEN' && $_->start == $insert_pos ); my $strand = $_->strand; my $type = $_->location_type; my $start = $_->start; my $start_type = $_->can('start_pos_type') ? $_->start_pos_type : undef; my $end = $_->end; my $end_type = $_->can('end_pos_type') ? $_->end_pos_type : undef; my @newcoords = (); if ( $start <= $insert_pos && $end > $insert_pos ) { # split the feature @newcoords = ( [ $start, $insert_pos, $start_type, $end_type ], [ ( $insert_pos + 1 + $insert_len ), $end + $insert_len, $start_type, $end_type ] ); $note = $insert_len . 'bp internal insertion between pos ' . $insert_pos . ' and ' . ( $insert_pos + $insert_len + 1 ); } elsif ( $start > $insert_pos ) { # just shift entire location @newcoords = ( [ $start + $insert_len, $end + $insert_len, $start_type, $end_type ] ); } else { # not affected @newcoords = ( [ $start, $end, $start_type, $end_type ] ); } # if we have deleted all coordinates, return nothing # (possible if all locations are IN-BETWEEN) return unless @newcoords; my @subloc = $self->_location_objects_from_coordinate_list( \@newcoords, $strand, $type ); # put together final location which could be a split now push @loc, $self->_single_loc_object_from_collection(@subloc); } # each location # create new feature based on original one and move annotation across my $newfeat = Bio::SeqFeature::Generic->new( -primary => $feat->primary_tag ); foreach my $key ( $feat->annotation->get_all_annotation_keys() ) { foreach my $value ( $feat->annotation->get_Annotations($key) ) { $newfeat->annotation->add_Annotation( $key, $value ); } } foreach my $key ( $feat->get_all_tags() ) { $newfeat->add_tag_value( $key, $feat->get_tag_values($key) ); } # If we have a note about the inserted bases, add it if ($note) { $newfeat->add_tag_value( 'note', $note ); } # set modified location(s) for the new feature and # add its subfeatures if any my $loc = $self->_single_loc_object_from_collection(@loc); $loc ? $newfeat->location($loc) : return; $newfeat->add_SeqFeature($_) for @adjsubfeat; return $newfeat; } =head2 _single_loc_object_from_collection Title : _single_loc_object_from_collection Function: takes an array of location objects. Returns either a split location object if there are more than one locations in the array or returns the single location if there is only one Usage : my $loc = _single_loc_object_from_collection( @sublocs ); Args : array of Bio::Location objects Returns : a single Bio:;Location object containing all locations =cut sub _single_loc_object_from_collection { my ( $self, @locs ) = @_; my $loc; if ( @locs > 1 ) { $loc = Bio::Location::Split->new; $loc->add_sub_Location(@locs); } elsif ( @locs == 1 ) { $loc = shift @locs; } return $loc; } # _single_loc_object_from_collection =head2 _location_objects_from_coordinate_list Title : _location_objects_from_coordinate_list Function: takes an array-ref of start/end coordinates, a strand and a type and returns a list of Bio::Location objects (Fuzzy by default, Simple in case of in-between coordinates). If location type is not "IN-BETWEEN", individual types may be passed in for start and end location as per Bio::Location::Fuzzy documentation. Usage : my @loc_objs = $self->_location_objects_from_coordinate_list( \@coords, $strand, $type ); Args : array-ref of array-refs each containing: start, end [, start-type, end-type] where types are optional. If given, must be a one of ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') strand (all locations must be on same strand) location-type (EXACT, IN-BETWEEN etc) Returns : list of Bio::Location objects =cut sub _location_objects_from_coordinate_list { my $self = shift; my ( $coords_ref, $strand, $type ) = @_; $self->throw( 'expected 3 parameters but got ' . @_ ) unless @_ == 3; $self->throw('first argument must be an ARRAY reference#') unless ref($coords_ref) eq 'ARRAY'; my @loc; foreach my $coords_set (@$coords_ref) { my ( $start, $end, $start_type, $end_type ) = @$coords_set; # taken from Bio::SeqUtils::_coord_adjust if ( $type ne 'IN-BETWEEN' ) { my $loc = Bio::Location::Fuzzy->new( -start => $start, -end => $end, -strand => $strand, -location_type => $type ); $loc->start_pos_type($start_type) if $start_type; $loc->end_pos_type($end_type) if $end_type; push @loc, $loc; } else { push @loc, Bio::Location::Simple->new( -start => $start, -end => $end, -strand => $strand, -location_type => $type ); } } # each coords_set return @loc; } # _location_objects_from_coordinate_list =head2 _new_seq_via_clone Title : _new_seq_via_clone Function: clone a sequence object using Bio::Root::Root::clone and set the new sequence string sequence features are removed. Usage : my $new_seq = $self->_new_seq_via_clone( $seq_obj, $seq_str ); Args : original seq object [, new sequence string] Returns : a clone of the original sequence object, optionally with new sequence string =cut sub _new_seq_via_clone { my ( $self, $in_seq_obj, $seq_str ) = @_; my $out_seq_obj = $in_seq_obj->clone; $out_seq_obj->remove_SeqFeatures if $out_seq_obj->can('remove_SeqFeatures'); if ( blessed $out_seq_obj->seq && $out_seq_obj->seq->isa('Bio::PrimarySeq') ) { $out_seq_obj->seq->seq($seq_str); } else { $out_seq_obj->seq($seq_str); } return $out_seq_obj; } # _new_seq_via_clone =head2 _new_seq_from_old Title : _new_seq_from_old Function: creates a new sequence obejct, if possible of the same class as the old and adds attributes to it. Also copies annotation across to the new object. Usage : my $new_seq = $self->_new_seq_from_old( $seq_obj, { seq => $seq_str, display_id => 'some_ID'}); Args : old sequence object hashref of attributes for the new sequence (sequence string etc.) Returns : a new Bio::Seq object =cut sub _new_seq_from_old { my ( $self, $in_seq_obj, $attr ) = @_; $self->throw('attributes must be a hashref') if $attr && ref($attr) ne 'HASH'; my $seqclass; if ( $in_seq_obj->can_call_new ) { $seqclass = ref($in_seq_obj); } else { $seqclass = 'Bio::Primaryseq'; $self->_attempt_to_load_seq; } my $out_seq_obj = $seqclass->new( -seq => $attr->{seq} || $in_seq_obj->seq, -display_id => $attr->{display_id} || $in_seq_obj->display_id, -accession_number => $attr->{accession_number} || $in_seq_obj->accession_number || '', -alphabet => $in_seq_obj->alphabet, -desc => $attr->{desc} || $in_seq_obj->desc, -verbose => $attr->{verbose} || $in_seq_obj->verbose, -is_circular => $attr->{is_circular} || $in_seq_obj->is_circular || 0, ); # move the annotation across to the product if ( $out_seq_obj->isa("Bio::AnnotatableI") && $in_seq_obj->isa("Bio::AnnotatableI") ) { foreach my $key ( $in_seq_obj->annotation->get_all_annotation_keys ) { foreach my $value ( $in_seq_obj->annotation->get_Annotations($key) ) { $out_seq_obj->annotation->add_Annotation( $key, $value ); } } } return $out_seq_obj; } # _new_seq_from_old =head2 _coord_adjust Title : _coord_adjust Usage : my $newfeat=Bio::SeqUtils->_coord_adjust($feature, 100, $seq->length); Function: Recursive subroutine to adjust the coordinates of a feature and all its subfeatures. If a sequence length is specified, then any adjusted features that have locations beyond the boundaries of the sequence are converted to Bio::Location::Fuzzy objects. Returns : A Bio::SeqFeatureI compliant object. Args : A Bio::SeqFeatureI compliant object, the number of bases to add to the coordinates (optional) the length of the parent sequence =cut sub _coord_adjust { my ( $self, $feat, $add, $length ) = @_; $self->throw( 'Object [$feat] ' . 'of class [' . ref($feat) . '] should be a Bio::SeqFeatureI ' ) unless $feat->isa('Bio::SeqFeatureI'); my @adjsubfeat; for my $subfeat ( $feat->get_SeqFeatures ) { push @adjsubfeat, $self->_coord_adjust( $subfeat, $add, $length ); } my @loc; for ( $feat->location->each_Location ) { my @coords = ( $_->start, $_->end ); my $strand = $_->strand; my $type = $_->location_type; foreach (@coords) { $self->throw("can not handle negative feature positions (got: $_)") if $_ < 0; if ( $add + $_ < 1 ) { $_ = '<1'; } elsif ( defined $length and $add + $_ > $length ) { $_ = ">$length"; } else { $_ = $add + $_; } } push @loc, $self->_location_objects_from_coordinate_list( [ \@coords ], $strand, $type ); } my $newfeat = Bio::SeqFeature::Generic->new( -primary => $feat->primary_tag ); foreach my $key ( $feat->annotation->get_all_annotation_keys() ) { foreach my $value ( $feat->annotation->get_Annotations($key) ) { $newfeat->annotation->add_Annotation( $key, $value ); } } foreach my $key ( $feat->get_all_tags() ) { $newfeat->add_tag_value( $key, $feat->get_tag_values($key) ); } my $loc = $self->_single_loc_object_from_collection(@loc); $loc ? $newfeat->location($loc) : return; $newfeat->add_SeqFeature($_) for @adjsubfeat; return $newfeat; } =head2 revcom_with_features Title : revcom_with_features Usage : $revcom=Bio::SeqUtils->revcom_with_features($seq); Function: Like Bio::Seq::revcom, but keeps features (adjusting coordinates as appropriate. Returns : A new sequence object Args : A sequence object =cut sub revcom_with_features { my ( $self, $seq ) = @_; $self->throw( 'Object [$seq] ' . 'of class [' . ref($seq) . '] should be a Bio::SeqI ' ) unless $seq->isa('Bio::SeqI'); my $revcom = $seq->revcom; # make sure that there is no annotation or features in $trunc # (->revcom() now clone objects except for Bio::Seq::LargePrimarySeq) $revcom->annotation->remove_Annotations; $revcom->remove_SeqFeatures; #move annotations foreach my $key ( $seq->annotation->get_all_annotation_keys() ) { foreach my $value ( $seq->annotation->get_Annotations($key) ) { $revcom->annotation->add_Annotation( $key, $value ); } } #move features for ( map { $self->_feature_revcom( $_, $seq->length ) } reverse $seq->get_SeqFeatures ) { $revcom->add_SeqFeature($_); } return $revcom; } =head2 _feature_revcom Title : _feature_revcom Usage : my $newfeat=Bio::SeqUtils->_feature_revcom($feature, $seq->length); Function: Recursive subroutine to reverse complement a feature and all its subfeatures. The length of the parent sequence must be specified. Returns : A Bio::SeqFeatureI compliant object. Args : A Bio::SeqFeatureI compliant object, the length of the parent sequence =cut sub _feature_revcom { my ( $self, $feat, $length ) = @_; $self->throw( 'Object [$feat] ' . 'of class [' . ref($feat) . '] should be a Bio::SeqFeatureI ' ) unless $feat->isa('Bio::SeqFeatureI'); my @adjsubfeat; for my $subfeat ( $feat->get_SeqFeatures ) { push @adjsubfeat, $self->_feature_revcom( $subfeat, $length ); } my @loc; for ( $feat->location->each_Location ) { my $type = $_->location_type; my $strand; if ( $_->strand == -1 ) { $strand = 1 } elsif ( $_->strand == 1 ) { $strand = -1 } else { $strand = $_->strand } my $newend = $self->_coord_revcom( $_->start, $_->start_pos_type, $length ); my $newstart = $self->_coord_revcom( $_->end, $_->end_pos_type, $length ); my $newstart_type = $_->end_pos_type; $newstart_type = 'BEFORE' if $_->end_pos_type eq 'AFTER'; $newstart_type = 'AFTER' if $_->end_pos_type eq 'BEFORE'; my $newend_type = $_->start_pos_type; $newend_type = 'BEFORE' if $_->start_pos_type eq 'AFTER'; $newend_type = 'AFTER' if $_->start_pos_type eq 'BEFORE'; push @loc, $self->_location_objects_from_coordinate_list( [ [ $newstart, $newend, $newstart_type, $newend_type ] ], $strand, $type ); } my $newfeat = Bio::SeqFeature::Generic->new( -primary => $feat->primary_tag ); foreach my $key ( $feat->annotation->get_all_annotation_keys() ) { foreach my $value ( $feat->annotation->get_Annotations($key) ) { $newfeat->annotation->add_Annotation( $key, $value ); } } foreach my $key ( $feat->get_all_tags() ) { $newfeat->add_tag_value( $key, $feat->get_tag_values($key) ); } my $loc = $self->_single_loc_object_from_collection(@loc); $loc ? $newfeat->location($loc) : return; $newfeat->add_SeqFeature($_) for @adjsubfeat; return $newfeat; } sub _coord_revcom { my ( $self, $coord, $type, $length ) = @_; if ( $type eq 'BETWEEN' or $type eq 'WITHIN' ) { $coord =~ s/(\d+)(\D*)(\d+)/$length+1-$3.$2.$length+1-$1/ge; } else { $coord =~ s/(\d+)/$length+1-$1/ge; $coord =~ tr/<>/>' . $coord if $type eq 'BEFORE' and substr( $coord, 0, 1 ) ne '>'; $coord = '<' . $coord if $type eq 'AFTER' and substr( $coord, 0, 1 ) ne '<'; } return $coord; } =head2 evolve Title : evolve Usage : my $newseq = Bio::SeqUtils-> evolve($seq, $similarity, $transition_transversion_rate); Function: Mutates the sequence by point mutations until the similarity of the new sequence has decreased to the required level. Transition/transversion rate is adjustable. Returns : A new Bio::PrimarySeq object Args : sequence object percentage similarity (e.g. 80) tr/tv rate, optional, defaults to 1 (= 1:1) Set the verbosity of the Bio::SeqUtils object to positive integer to see the mutations as they happen. This method works only on nucleotide sequences. It prints a warning if you set the target similarity to be less than 25%. Transition/transversion ratio is an observed attribute of an sequence comparison. We are dealing here with the transition/transversion rate that we set for our model of sequence evolution. =cut sub evolve { my ( $self, $seq, $sim, $rate ) = @_; $rate ||= 1; $self->throw( 'Object [$seq] ' . 'of class [' . ref($seq) . '] should be a Bio::PrimarySeqI ' ) unless $seq->isa('Bio::PrimarySeqI'); $self->throw( "[$sim] " . ' should be a positive integer or float under 100' ) unless $sim =~ /^[+\d.]+$/ and $sim <= 100; $self->warn( "Nucleotide sequences are 25% similar by chance. Do you really want to set similarity to [$sim]%?\n" ) unless $sim > 25; $self->throw('Only nucleotide sequences are supported') if $seq->alphabet eq 'protein'; # arrays of possible changes have transitions as first items my %changes; $changes{'a'} = [ 't', 'c', 'g' ]; $changes{'t'} = [ 'a', 'c', 'g' ]; $changes{'c'} = [ 'g', 'a', 't' ]; $changes{'g'} = [ 'c', 'a', 't' ]; # given the desired rate, find out where cut off points need to be # when random numbers are generated from 0 to 100 # we are ignoring identical mutations (e.g. A->A) to speed things up my $bin_size = 100 / ( $rate + 2 ); my $transition = 100 - ( 2 * $bin_size ); my $first_transversion = $transition + $bin_size; # unify the look of sequence strings my $string = lc $seq->seq; # lower case $string =~ s/u/t/; # simplyfy our life; modules should deal with the change anyway # store the original sequence string my $oristring = $string; my $length = $seq->length; # stop evolving if the limit has been reached until ( $self->_get_similarity( $oristring, $string ) <= $sim ) { # find the location in the string to change my $loc = int( rand $length ) + 1; # nucleotide to change my $oldnuc = substr $string, $loc - 1, 1; my $newnuc; # nucleotide it is changed to my $choose = rand(100); if ( $choose < $transition ) { $newnuc = $changes{$oldnuc}[0]; } elsif ( $choose < $first_transversion ) { $newnuc = $changes{$oldnuc}[1]; } else { $newnuc = $changes{$oldnuc}[2]; } # do the change substr $string, $loc - 1, 1, $newnuc; $self->debug("$loc$oldnuc>$newnuc\n"); } return new Bio::PrimarySeq( -id => $seq->id . "-$sim", -description => $seq->description, -seq => $string ); } sub _get_similarity { my ( $self, $oriseq, $seq ) = @_; my $len = length($oriseq); my $c; for ( my $i = 0 ; $i < $len ; $i++ ) { $c++ if substr( $oriseq, $i, 1 ) eq substr( $seq, $i, 1 ); } return 100 * $c / $len; } 1; BioPerl-1.6.923/Bio/SimpleAlign.pm000444000765000024 26756412254227321 16773 0ustar00cjfieldsstaff000000000000package Bio::SimpleAlign; use strict; use warnings; use Bio::LocatableSeq; # uses Seq's as list use Bio::Seq; use Bio::SeqFeature::Generic; use parent qw(Bio::Root::Root Bio::Align::AlignI Bio::AnnotatableI Bio::FeatureHolderI); # BioPerl module for SimpleAlign # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # # History: # 11/3/00 Added threshold feature to consensus and consensus_aa - PS # May 2001 major rewrite - Heikki Lehvaslaiho =head1 NAME Bio::SimpleAlign - Multiple alignments held as a set of sequences =head1 SYNOPSIS # Use Bio::AlignIO to read in the alignment $str = Bio::AlignIO->new(-file => 't/data/testaln.pfam'); $aln = $str->next_aln(); # Describe print $aln->length; print $aln->num_residues; print $aln->is_flush; print $aln->num_sequences; print $aln->score; print $aln->percentage_identity; print $aln->consensus_string(50); # Find the position in the alignment for a sequence location $pos = $aln->column_from_residue_number('1433_LYCES', 14); # = 6; # Extract sequences and check values for the alignment column $pos foreach $seq ($aln->each_seq) { $res = $seq->subseq($pos, $pos); $count{$res}++; } foreach $res (keys %count) { printf "Res: %s Count: %2d\n", $res, $count{$res}; } # Manipulate $aln->remove_seq($seq); $mini_aln = $aln->slice(20,30); # get a block of columns $mini_aln = $aln->select_noncont(1,3,5,7,11); # select certain sequences $new_aln = $aln->remove_columns([20,30]); # remove by position $new_aln = $aln->remove_columns(['mismatch']); # remove by property # Analyze $str = $aln->consensus_string($threshold_percent); $str = $aln->match_line(); $str = $aln->cigar_line(); $id = $aln->percentage_identity; # See the module documentation for details and more methods. =head1 DESCRIPTION SimpleAlign is an object that handles a multiple sequence alignment (MSA). It is very permissive of types (it does not insist on sequences being all same length, for example). Think of it as a set of sequences with a whole series of built-in manipulations and methods for reading and writing alignments. SimpleAlign uses L, a subclass of L, to store its sequences. These are subsequences with a start and end positions in the parent reference sequence. Each sequence in the SimpleAlign object is a Bio::LocatableSeq. SimpleAlign expects the combination of name, start, and end for a given sequence to be unique in the alignment, and this is the key for the internal hashes (name, start, end are abbreviated C in the code). However, in some cases people do not want the name/start-end to be displayed: either multiple names in an alignment or names specific to the alignment (ROA1_HUMAN_1, ROA1_HUMAN_2 etc). These names are called C, and generally is what is used to print out the alignment. They default to name/start-end. The SimpleAlign Module is derived from the Align module by Ewan Birney. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Ewan Birney, birney@ebi.ac.uk =head1 CONTRIBUTORS Allen Day, allenday-at-ucla.edu, Richard Adams, Richard.Adams-at-ed.ac.uk, David J. Evans, David.Evans-at-vir.gla.ac.uk, Heikki Lehvaslaiho, heikki-at-bioperl-dot-org, Allen Smith, allens-at-cpan.org, Jason Stajich, jason-at-bioperl.org, Anthony Underwood, aunderwood-at-phls.org.uk, Xintao Wei & Giri Narasimhan, giri-at-cs.fiu.edu Brian Osborne, bosborne at alum.mit.edu Weigang Qiu, Weigang at GENECTR-HUNTER-CUNY-EDU Hongyu Zhang, forward at hongyu.org Jay Hannah, jay at jays.net Alexandr Bezginov, albezg at gmail.com =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut ## This data should probably be in a more centralized module... ## it is taken from Clustalw documentation. ## These are all the positively scoring groups that occur in the ## Gonnet Pam250 matrix. The strong and weak groups are ## defined as strong score >0.5 and weak score =<0.5 respectively. our %CONSERVATION_GROUPS = ( 'strong' => [qw(STA NEQK NHQK NDEQ QHRK MILV MILF HY FYW )], 'weak' => [qw(CSA ATV SAG STNK STPA SGND SNDEQK NDEQHK NEQHRK FVLIM HFY)], ); =head2 new Title : new Usage : my $aln = Bio::SimpleAlign->new(); Function : Creates a new simple align object Returns : Bio::SimpleAlign Args : -source => string representing the source program where this alignment came from -annotation => Bio::AnnotationCollectionI -seq_annotation => Bio::AnnotationCollectionI for sequences (requires -annotation also be set) -seqs => array ref containing Bio::LocatableSeq or Bio::Seq::Meta -consensus => consensus string -consensus_meta => Bio::Seq::Meta object containing consensus met information (kludge) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($src, $score, $id, $acc, $desc, $seqs, $feats, $coll, $sa, $con, $cmeta) = $self->_rearrange([qw( SOURCE SCORE ID ACCESSION DESCRIPTION SEQS FEATURES ANNOTATION SEQ_ANNOTATION CONSENSUS CONSENSUS_META )], @args); $src && $self->source($src); defined $score && $self->score($score); # we need to set up internal hashs first! $self->{'_seq'} = {}; $self->{'_order'} = {}; $self->{'_start_end_lists'} = {}; $self->{'_dis_name'} = {}; $self->{'_id'} = 'NoName'; # maybe we should automatically read in from args. Hmmm... $id && $self->id($id); $acc && $self->accession($acc); $desc && $self->description($desc); $coll && $self->annotation($coll); # sequence annotation is layered into a provided annotation collection (or dies) if ($sa) { $self->throw("Must supply an alignment-based annotation collection (-annotation) ". "with a sequence annotation collection") if !$coll; $coll->add_Annotation('seq_annotation', $sa); } if ($feats && ref $feats eq 'ARRAY') { for my $feat (@$feats) { $self->add_SeqFeature($feat); } } $con && $self->consensus($con); $cmeta && $self->consensus_meta($cmeta); # assumes these are in correct alignment order if ($seqs && ref($seqs) eq 'ARRAY') { for my $seq (@$seqs) { $self->add_seq($seq); } } return $self; # success - we hope! } =head1 Modifier methods These methods modify the MSA by adding, removing or shuffling complete sequences. =head2 add_seq Title : add_seq Usage : $myalign->add_seq($newseq); $myalign->add_seq(-SEQ=>$newseq, -ORDER=>5); Function : Adds another sequence to the alignment. *Does not* align it - just adds it to the hashes. If -ORDER is specified, the sequence is inserted at the the position spec'd by -ORDER, and existing sequences are pushed down the storage array. Returns : nothing Args : A Bio::LocatableSeq object Positive integer for the sequence position (optional) See L for more information =cut sub addSeq { my $self = shift; $self->deprecated("addSeq - deprecated method. Use add_seq() instead."); $self->add_seq(@_); } sub add_seq { my $self = shift; my @args = @_; my ($seq, $order) = $self->_rearrange([qw(SEQ ORDER)], @args); my ($name,$id,$start,$end); unless ($seq) { $self->throw("LocatableSeq argument required"); } if( ! ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("Unable to process non locatable sequences [". ref($seq). "]"); } !defined($order) and $order = 1 + keys %{$self->{'_seq'}}; # default $order--; # jay's patch (user-specified order is 1-origin) if ($order < 0) { $self->throw("User-specified value for ORDER must be >= 1"); } $id = $seq->id() ||$seq->display_id || $seq->primary_id; # build the symbol list for this sequence, # will prune out the gap and missing/match chars # when actually asked for the symbol list in the # symbol_chars # map { $self->{'_symbols'}->{$_} = 1; } split(//,$seq->seq) if $seq->seq; $name = $seq->get_nse; if( $self->{'_seq'}->{$name} ) { $self->warn("Replacing one sequence [$name]\n") unless $self->verbose < 0; } else { $self->debug( "Assigning $name to $order\n"); my $ordh = $self->{'_order'}; if ($ordh->{$order}) { # make space to insert # $c->() returns (in reverse order) the first subsequence # of consecutive integers; i.e., $c->(1,2,3,5,6,7) returns # (3,2,1), and $c->(2,4,5) returns (2). my $c; $c = sub { return (($_[1]-$_[0] == 1) ? ($c->(@_[1..$#_]),$_[0]) : $_[0]); }; map { $ordh->{$_+1} = $ordh->{$_} } $c->(sort {$a <=> $b} grep {$_ >= $order} keys %{$ordh}); } $ordh->{$order} = $name; unless( exists( $self->{'_start_end_lists'}->{$id})) { $self->{'_start_end_lists'}->{$id} = []; } push @{$self->{'_start_end_lists'}->{$id}}, $seq; } $self->{'_seq'}->{$name} = $seq; } =head2 remove_seq Title : remove_seq Usage : $aln->remove_seq($seq); Function : Removes a single sequence from an alignment Returns : Argument : a Bio::LocatableSeq object =cut sub removeSeq { my $self = shift; $self->deprecated("removeSeq - deprecated method. Use remove_seq() instead."); $self->remove_seq(@_); } sub remove_seq { my $self = shift; my $seq = shift; my ($name,$id); $self->throw("Need Bio::Locatable seq argument ") unless ref $seq && $seq->isa( 'Bio::LocatableSeq'); $id = $seq->id(); $name = $seq->get_nse; if( !exists $self->{'_seq'}->{$name} ) { $self->throw("Sequence $name does not exist in the alignment to remove!"); } delete $self->{'_seq'}->{$name}; # we need to remove this seq from the start_end_lists hash if (exists $self->{'_start_end_lists'}->{$id}) { # we need to find the sequence in the array. my ($i, $found);; for ($i=0; $i < @{$self->{'_start_end_lists'}->{$id}}; $i++) { if (${$self->{'_start_end_lists'}->{$id}}[$i] eq $seq) { $found = 1; last; } } if ($found) { splice @{$self->{'_start_end_lists'}->{$id}}, $i, 1; } else { $self->throw("Could not find the sequence to remoce from the start-end list"); } } else { $self->throw("There is no seq list for the name $id"); } # we need to shift order hash my %rev_order = reverse %{$self->{'_order'}}; my $no = $rev_order{$name}; my $num_sequences = $self->num_sequences; for (; $no < $num_sequences; $no++) { $self->{'_order'}->{$no} = $self->{'_order'}->{$no+1}; } delete $self->{'_order'}->{$no}; return 1; } =head2 purge Title : purge Usage : $aln->purge(0.7); Function: Removes sequences above given sequence similarity This function will grind on large alignments. Beware! Example : Returns : An array of the removed sequences Args : float, threshold for similarity =cut sub purge { my ($self,$perc) = @_; my (%duplicate, @dups); my @seqs = $self->each_seq(); for (my $i=0;$i< @seqs - 1;$i++ ) { #for each seq in alignment my $seq = $seqs[$i]; #skip if already in duplicate hash next if exists $duplicate{$seq->display_id} ; my $one = $seq->seq(); my @one = split '', $one; #split to get 1aa per array element for (my $j=$i+1;$j < @seqs;$j++) { my $seq2 = $seqs[$j]; #skip if already in duplicate hash next if exists $duplicate{$seq2->display_id} ; my $two = $seq2->seq(); my @two = split '', $two; my $count = 0; my $res = 0; for (my $k=0;$k<@one;$k++) { if ( $one[$k] ne '.' && $one[$k] ne '-' && defined($two[$k]) && $one[$k] eq $two[$k]) { $count++; } if ( $one[$k] ne '.' && $one[$k] ne '-' && defined($two[$k]) && $two[$k] ne '.' && $two[$k] ne '-' ) { $res++; } } my $ratio = 0; $ratio = $count/$res unless $res == 0; # if above threshold put in duplicate hash and push onto # duplicate array for returning to get_unique if ( $ratio > $perc ) { $self->warn("duplicate: ", $seq2->display_id) if $self->verbose > 0; $duplicate{$seq2->display_id} = 1; push @dups, $seq2; } } } foreach my $seq (@dups) { $self->remove_seq($seq); } return @dups; } =head2 sort_alphabetically Title : sort_alphabetically Usage : $ali->sort_alphabetically Function : Changes the order of the alignment to alphabetical on name followed by numerical by number. Returns : Argument : =cut sub sort_alphabetically { my $self = shift; my ($seq,$nse,@arr,%hash,$count); foreach $seq ( $self->each_seq() ) { $nse = $seq->get_nse; $hash{$nse} = $seq; } $count = 0; %{$self->{'_order'}} = (); # reset the hash; foreach $nse ( sort _alpha_startend keys %hash) { $self->{'_order'}->{$count} = $nse; $count++; } 1; } =head2 sort_by_list Title : sort_by_list Usage : $aln_ordered=$aln->sort_by_list($list_file) Function : Arbitrarily order sequences in an alignment Returns : A new Bio::SimpleAlign object Argument : a file listing sequence names in intended order (one name per line) =cut sub sort_by_list { my ($self, $list) = @_; my (@seq, @ids, %order); foreach my $seq ( $self->each_seq() ) { push @seq, $seq; push @ids, $seq->display_id; } my $ct=1; open(my $listfh, '<', $list) || $self->throw("can't open file for reading: $list"); while (<$listfh>) { chomp; my $name=$_; $self->throw("Not found in alignment: $name") unless &_in_aln($name, \@ids); $order{$name}=$ct++; } close($listfh); # use the map-sort-map idiom: my @sorted= map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$order{$_->id()}, $_] } @seq; my $aln = $self->new; foreach (@sorted) { $aln->add_seq($_) } return $aln; } =head2 set_new_reference Title : set_new_reference Usage : $aln->set_new_reference(3 or 'B31'): Select the 3rd sequence, or the sequence whoes name is "B31" (full, exact, and case-sensitive), as the reference (1st) sequence Function : Change/Set a new reference (i.e., the first) sequence Returns : a new Bio::SimpleAlign object. Throws an exception if designated sequence not found Argument : a positive integer of sequence order, or a sequence name in the original alignment =cut sub set_new_reference { my ($self, $seqid) = @_; my $aln = $self->new; my (@seq, @ids, @new_seq); my $is_num=0; foreach my $seq ( $self->each_seq() ) { push @seq, $seq; push @ids, $seq->display_id; } if ($seqid =~ /^\d+$/) { # argument is seq position $is_num=1; $self->throw("The new reference sequence number has to be a positive integer >1 and <= num_sequences ") if ($seqid <= 1 || $seqid > $self->num_sequences); } else { # argument is a seq name $self->throw("The new reference sequence not in alignment ") unless &_in_aln($seqid, \@ids); } for (my $i=0; $i<=$#seq; $i++) { my $pos=$i+1; if ( ($is_num && $pos == $seqid) || ($seqid eq $seq[$i]->display_id) ) { unshift @new_seq, $seq[$i]; } else { push @new_seq, $seq[$i]; } } foreach (@new_seq) { $aln->add_seq($_); } return $aln; } sub _in_aln { # check if input name exists in the alignment my ($str, $ref) = @_; foreach (@$ref) { return 1 if $str eq $_; } return 0; } =head2 uniq_seq Title : uniq_seq Usage : $aln->uniq_seq(): Remove identical sequences in in the alignment. Ambiguous base ("N", "n") and leading and ending gaps ("-") are NOT counted as differences. Function : Make a new alignment of unique sequence types (STs) Returns : 1a. if called in a scalar context, a new Bio::SimpleAlign object (all sequences renamed as "ST") 1b. if called in an array context, a new Bio::SimpleAlign object, and a hashref whose keys are sequence types, and whose values are arrayrefs to lists of sequence ids within the corresponding sequence type 2. if $aln->verbose > 0, ST of each sequence is sent to STDERR (in a tabular format) Argument : None =cut sub uniq_seq { my ($self, $seqid) = @_; my $aln = $self->new; my (%member, %order, @seq, @uniq_str, $st); my $order=0; my $len = $self->length(); $st = {}; foreach my $seq ( $self->each_seq() ) { my $str = $seq->seq(); # it's necessary to ignore "n", "N", leading gaps and ending gaps in # comparing two sequence strings # 1st, convert "n", "N" to "?" (for DNA sequence only): $str =~ s/n/\?/gi if $str =~ /^[atcgn-]+$/i; # 2nd, convert leading and ending gaps to "?": $str = &_convert_leading_ending_gaps($str, '-', '?'); # Note that '?' also can mean unknown residue. # I don't like making global class member changes like this, too # prone to errors... -- cjfields 08-11-18 local $Bio::LocatableSeq::GAP_SYMBOLS = '-\?'; my $new = Bio::LocatableSeq->new( -id => $seq->id(), -alphabet=> $seq->alphabet, -seq => $str, -start => $seq->start, -end => $seq->end ); push @seq, $new; } foreach my $seq (@seq) { my $str = $seq->seq(); my ($seen, $key) = &_check_uniq($str, \@uniq_str, $len); if ($seen) { # seen before my @memb = @{$member{$key}}; push @memb, $seq; $member{$key} = \@memb; } else { # not seen push @uniq_str, $key; $order++; $member{$key} = [ ($seq) ]; $order{$key} = $order; } } foreach my $str (sort {$order{$a} <=> $order{$b}} keys %order) { # sort by input order # convert leading/ending "?" back into "-" ("?" throws errors by SimpleAlign): my $str2 = &_convert_leading_ending_gaps($str, '?', '-'); # convert middle "?" back into "N" ("?" throws errors by SimpleAlign): $str2 =~ s/\?/N/g if $str2 =~ /^[atcg\-\?]+$/i; my $gap='-'; my $end= CORE::length($str2); $end -= CORE::length($1) while $str2 =~ m/($gap+)/g; my $new = Bio::LocatableSeq->new(-id =>"ST".$order{$str}, -seq =>$str2, -start=>1, -end =>$end ); $aln->add_seq($new); foreach (@{$member{$str}}) { push @{$$st{$order{$str}}}, $_->id(); # per Tristan's patch/Bug #2805 $self->debug($_->id(), "\t", "ST", $order{$str}, "\n"); } } return wantarray ? ($aln, $st) : $aln; } sub _check_uniq { # check if same seq exists in the alignment my ($str1, $ref, $length) = @_; my @char1=split //, $str1; my @array=@$ref; return (0, $str1) if @array==0; # not seen (1st sequence) foreach my $str2 (@array) { my $diff=0; my @char2=split //, $str2; for (my $i=0; $i<=$length-1; $i++) { next if $char1[$i] eq '?'; next if $char2[$i] eq '?'; $diff++ if $char1[$i] ne $char2[$i]; } return (1, $str2) if $diff == 0; # seen before } return (0, $str1); # not seen } sub _convert_leading_ending_gaps { my $s=shift; my $sym1=shift; my $sym2=shift; my @array=split //, $s; # convert leading char: for (my $i=0; $i<=$#array; $i++) { ($array[$i] eq $sym1) ? ($array[$i] = $sym2):(last); } # convert ending char: for (my $i = $#array; $i>= 0; $i--) { ($array[$i] eq $sym1) ? ($array[$i] = $sym2):(last); } my $s_new=join '', @array; return $s_new; } =head1 Sequence selection methods Methods returning one or more sequences objects. =head2 each_seq Title : each_seq Usage : foreach $seq ( $align->each_seq() ) Function : Gets a Seq object from the alignment Returns : Seq object Argument : =cut sub eachSeq { my $self = shift; $self->deprecated("eachSeq - deprecated method. Use each_seq() instead."); $self->each_seq(); } sub each_seq { my $self = shift; my (@arr,$order); foreach $order ( sort { $a <=> $b } keys %{$self->{'_order'}} ) { if( exists $self->{'_seq'}->{$self->{'_order'}->{$order}} ) { push(@arr,$self->{'_seq'}->{$self->{'_order'}->{$order}}); } } return @arr; } =head2 each_alphabetically Title : each_alphabetically Usage : foreach $seq ( $ali->each_alphabetically() ) Function : Returns a sequence object, but the objects are returned in alphabetically sorted order. Does not change the order of the alignment. Returns : Seq object Argument : =cut sub each_alphabetically { my $self = shift; my ($seq,$nse,@arr,%hash,$count); foreach $seq ( $self->each_seq() ) { $nse = $seq->get_nse; $hash{$nse} = $seq; } foreach $nse ( sort _alpha_startend keys %hash) { push(@arr,$hash{$nse}); } return @arr; } sub _alpha_startend { my ($aname,$astart,$bname,$bstart); ($aname,$astart) = split (/-/,$a); ($bname,$bstart) = split (/-/,$b); if( $aname eq $bname ) { return $astart <=> $bstart; } else { return $aname cmp $bname; } } =head2 each_seq_with_id Title : each_seq_with_id Usage : foreach $seq ( $align->each_seq_with_id() ) Function : Gets a Seq objects from the alignment, the contents being those sequences with the given name (there may be more than one) Returns : Seq object Argument : a seq name =cut sub eachSeqWithId { my $self = shift; $self->deprecated("eachSeqWithId - deprecated method. Use each_seq_with_id() instead."); $self->each_seq_with_id(@_); } sub each_seq_with_id { my $self = shift; my $id = shift; $self->throw("Method each_seq_with_id needs a sequence name argument") unless defined $id; my (@arr, $seq); if (exists($self->{'_start_end_lists'}->{$id})) { @arr = @{$self->{'_start_end_lists'}->{$id}}; } return @arr; } =head2 get_seq_by_pos Title : get_seq_by_pos Usage : $seq = $aln->get_seq_by_pos(3) # third sequence from the alignment Function : Gets a sequence based on its position in the alignment. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Returns : a Bio::LocatableSeq object Args : positive integer for the sequence position =cut sub get_seq_by_pos { my $self = shift; my ($pos) = @_; $self->throw("Sequence position has to be a positive integer, not [$pos]") unless $pos =~ /^\d+$/ and $pos > 0; $self->throw("No sequence at position [$pos]") unless $pos <= $self->num_sequences ; my $nse = $self->{'_order'}->{--$pos}; return $self->{'_seq'}->{$nse}; } =head2 get_seq_by_id Title : get_seq_by_id Usage : $seq = $aln->get_seq_by_id($name) # seq named $name Function : Gets a sequence based on its name. Sequences that do not exist will warn and return undef Returns : a Bio::LocatableSeq object Args : string for sequence name =cut sub get_seq_by_id { my ($self,$name) = @_; unless( defined $name ) { $self->warn("Must provide a sequence name"); return; } for my $seq ( values %{$self->{'_seq'}} ) { if ( $seq->id eq $name) { return $seq; } } return; } =head2 seq_with_features Title : seq_with_features Usage : $seq = $aln->seq_with_features(-pos => 1, -consensus => 60 -mask => sub { my $consensus = shift; for my $i (1..5){ my $n = 'N' x $i; my $q = '\?' x $i; while($consensus =~ /[^?]$q[^?]/){ $consensus =~ s/([^?])$q([^?])/$1$n$2/; } } return $consensus; } ); Function: produces a Bio::Seq object by first splicing gaps from -pos (by means of a splice_by_seq_pos() call), then creating features using non-? chars (by means of a consensus_string() call with stringency -consensus). Returns : a Bio::Seq object Args : -pos : required. sequence from which to build the Bio::Seq object -consensus : optional, defaults to consensus_string()'s default cutoff value -mask : optional, a coderef to apply to consensus_string()'s output before building features. this may be useful for closing gaps of 1 bp by masking over them with N, for instance =cut sub seq_with_features{ my ($self,%arg) = @_; #first do the preparatory splice $self->throw("must provide a -pos argument") unless $arg{-pos}; $self->splice_by_seq_pos($arg{-pos}); my $consensus_string = $self->consensus_string($arg{-consensus}); $consensus_string = $arg{-mask}->($consensus_string) if defined($arg{-mask}); my(@bs,@es); push @bs, 1 if $consensus_string =~ /^[^?]/; while($consensus_string =~ /\?[^?]/g){ push @bs, pos($consensus_string); } while($consensus_string =~ /[^?]\?/g){ push @es, pos($consensus_string); } push @es, CORE::length($consensus_string) if $consensus_string =~ /[^?]$/; my $seq = Bio::Seq->new(); # my $rootfeature = Bio::SeqFeature::Generic->new( # -source_tag => 'location', # -start => $self->get_seq_by_pos($arg{-pos})->start, # -end => $self->get_seq_by_pos($arg{-pos})->end, # ); # $seq->add_SeqFeature($rootfeature); while(my $b = shift @bs){ my $e = shift @es; $seq->add_SeqFeature( Bio::SeqFeature::Generic->new( -start => $b - 1 + $self->get_seq_by_pos($arg{-pos})->start, -end => $e - 1 + $self->get_seq_by_pos($arg{-pos})->start, -source_tag => $self->source || 'MSA', ) ); } return $seq; } =head1 Create new alignments The result of these methods are horizontal or vertical subsets of the current MSA. =head2 select Title : select Usage : $aln2 = $aln->select(1, 3) # three first sequences Function : Creates a new alignment from a continuous subset of sequences. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Returns : a Bio::SimpleAlign object Args : positive integer for the first sequence positive integer for the last sequence to include (optional) =cut sub select { my $self = shift; my ($start, $end) = @_; $self->throw("Select start has to be a positive integer, not [$start]") unless $start =~ /^\d+$/ and $start > 0; $self->throw("Select end has to be a positive integer, not [$end]") unless $end =~ /^\d+$/ and $end > 0; $self->throw("Select $start [$start] has to be smaller than or equal to end [$end]") unless $start <= $end; my $aln = $self->new; foreach my $pos ($start .. $end) { $aln->add_seq($self->get_seq_by_pos($pos)); } $aln->id($self->id); # fix for meta, sf, ann return $aln; } =head2 select_noncont Title : select_noncont Usage : # 1st and 3rd sequences, sorted $aln2 = $aln->select_noncont(1, 3) # 1st and 3rd sequences, sorted (same as first) $aln2 = $aln->select_noncont(3, 1) # 1st and 3rd sequences, unsorted $aln2 = $aln->select_noncont('nosort',3, 1) Function : Creates a new alignment from a subset of sequences. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Sorts the order added to new alignment by default, to prevent sorting pass 'nosort' as the first argument in the list. Returns : a Bio::SimpleAlign object Args : array of integers for the sequences. If the string 'nosort' is passed as the first argument, the sequences will not be sorted in the new alignment but will appear in the order listed. =cut sub select_noncont { my $self = shift; my $nosort = 0; my (@pos) = @_; if ($pos[0] !~ m{^\d+$}) { my $sortcmd = shift @pos; if ($sortcmd eq 'nosort') { $nosort = 1; } else { $self->throw("Command not recognized: $sortcmd. Only 'nosort' implemented at this time."); } } my $end = $self->num_sequences; foreach ( @pos ) { $self->throw("position must be a positive integer, > 0 and <= $end not [$_]") unless( /^\d+$/ && $_ > 0 && $_ <= $end ); } @pos = sort {$a <=> $b} @pos unless $nosort; my $aln = $self->new; foreach my $p (@pos) { $aln->add_seq($self->get_seq_by_pos($p)); } $aln->id($self->id); # fix for meta, sf, ann return $aln; } =head2 select_noncont_by_name Title : select_noncont_by_name Usage : my $aln2 = $aln->select_noncont_by_name('A123', 'B456'); Function : Creates a new alignment from a subset of sequences which are selected by name (sequence ID). Returns : a Bio::SimpleAlign object Args : array of names (i.e., identifiers) for the sequences. =cut sub select_noncont_by_name { my ($self, @names) = @_; my $aln = $self->new; foreach my $name (@names) { $aln->add_seq($self->get_seq_by_id($name)); } $aln->id($self->id); return $aln; } =head2 slice Title : slice Usage : $aln2 = $aln->slice(20,30) Function : Creates a slice from the alignment inclusive of start and end columns, and the first column in the alignment is denoted 1. Sequences with no residues in the slice are excluded from the new alignment and a warning is printed. Slice beyond the length of the sequence does not do padding. Returns : A Bio::SimpleAlign object Args : Positive integer for start column, positive integer for end column, optional boolean which if true will keep gap-only columns in the newly created slice. Example: $aln2 = $aln->slice(20,30,1) =cut sub slice { my $self = shift; my ($start, $end, $keep_gap_only) = @_; $self->throw("Slice start has to be a positive integer, not [$start]") unless $start =~ /^\d+$/ and $start > 0; $self->throw("Slice end has to be a positive integer, not [$end]") unless $end =~ /^\d+$/ and $end > 0; $self->throw("Slice start [$start] has to be smaller than or equal to end [$end]") unless $start <= $end; $self->throw("This alignment has only ". $self->length . " residues. Slice start " . "[$start] is too big.") if $start > $self->length; my $cons_meta = $self->consensus_meta; my $aln = $self->new; $aln->id($self->id); foreach my $seq ( $self->each_seq() ) { my $new_seq = $seq->isa('Bio::Seq::MetaI') ? Bio::Seq::Meta->new (-id => $seq->id, -alphabet => $seq->alphabet, -strand => $seq->strand, -verbose => $self->verbose) : Bio::LocatableSeq->new (-id => $seq->id, -alphabet => $seq->alphabet, -strand => $seq->strand, -verbose => $self->verbose); # seq my $seq_end = $end; $seq_end = $seq->length if( $end > $seq->length ); my $slice_seq = $seq->subseq($start, $seq_end); $new_seq->seq( $slice_seq ); # Allowed extra characters in string my $allowed_chars = ''; if (exists $self->{_mask_char}) { $allowed_chars = $self->{_mask_char}; $allowed_chars = quotemeta $allowed_chars; } $slice_seq =~ s/[^\w$allowed_chars]//g; if ($start > 1) { my $pre_start_seq = $seq->subseq(1, $start - 1); $pre_start_seq =~ s/[^\w$allowed_chars]//g; if (!defined($seq->strand)) { $new_seq->start( $seq->start + CORE::length($pre_start_seq) ); } elsif ($seq->strand < 0){ $new_seq->start( $seq->end - CORE::length($pre_start_seq) - CORE::length($slice_seq) + 1); } else { $new_seq->start( $seq->start + CORE::length($pre_start_seq) ); } } else { if ((defined $seq->strand)&&($seq->strand < 0)){ $new_seq->start( $seq->end - CORE::length($slice_seq) + 1); } else { $new_seq->start( $seq->start); } } if ($new_seq->isa('Bio::Seq::MetaI')) { for my $meta_name ($seq->meta_names) { $new_seq->named_meta($meta_name, $seq->named_submeta($meta_name, $start, $end)); } } $new_seq->end( $new_seq->start + CORE::length($slice_seq) - 1 ); if ($new_seq->start and $new_seq->end >= $new_seq->start) { $aln->add_seq($new_seq); } else { if( $keep_gap_only ) { $aln->add_seq($new_seq); } else { my $nse = $seq->get_nse(); $self->warn("Slice [$start-$end] of sequence [$nse] contains no residues.". " Sequence excluded from the new alignment."); } } } if ($cons_meta) { my $new = Bio::Seq::Meta->new(); for my $meta_name ($cons_meta->meta_names) { $new->named_meta($meta_name, $cons_meta->named_submeta($meta_name, $start, $end)); } $aln->consensus_meta($new); } $aln->annotation($self->annotation); # fix for meta, sf, ann return $aln; } =head2 remove_columns Title : remove_columns Usage : $aln2 = $aln->remove_columns(['mismatch','weak']) or $aln2 = $aln->remove_columns([0,0],[6,8]) Function : Creates an aligment with columns removed corresponding to the specified type or by specifying the columns by number. Returns : Bio::SimpleAlign object Args : Array ref of types ('match'|'weak'|'strong'|'mismatch'|'gaps'| 'all_gaps_columns') or array ref where the referenced array contains a pair of integers that specify a range. The first column is 0 =cut sub remove_columns { my ($self,@args) = @_; @args || $self->throw("Must supply column ranges or column types"); my $aln; if ($args[0][0] =~ /^[a-z_]+$/i) { $aln = $self->_remove_columns_by_type($args[0]); } elsif ($args[0][0] =~ /^\d+$/) { $aln = $self->_remove_columns_by_num(\@args); } else { $self->throw("You must pass array references to remove_columns(), not @args"); } # fix for meta, sf, ann $aln; } =head2 remove_gaps Title : remove_gaps Usage : $aln2 = $aln->remove_gaps Function : Creates an aligment with gaps removed Returns : a Bio::SimpleAlign object Args : a gap character(optional) if none specified taken from $self->gap_char, [optional] $all_gaps_columns flag (1 or 0, default is 0) indicates that only all-gaps columns should be deleted Used from method L in most cases. Set gap character using L. =cut sub remove_gaps { my ($self,$gapchar,$all_gaps_columns) = @_; my $gap_line; if ($all_gaps_columns) { $gap_line = $self->all_gap_line($gapchar); } else { $gap_line = $self->gap_line($gapchar); } my $aln = $self->new; my @remove; my $length = 0; my $del_char = $gapchar || $self->gap_char; # Do the matching to get the segments to remove while ($gap_line =~ m/[$del_char]/g) { my $start = pos($gap_line)-1; $gap_line =~ m/\G[$del_char]+/gc; my $end = pos($gap_line)-1; #have to offset the start and end for subsequent removes $start-=$length; $end -=$length; $length += ($end-$start+1); push @remove, [$start,$end]; } #remove the segments $aln = $#remove >= 0 ? $self->_remove_col($aln,\@remove) : $self; # fix for meta, sf, ann return $aln; } sub _remove_col { my ($self,$aln,$remove) = @_; my @new; my $gap = $self->gap_char; # splice out the segments and create new seq foreach my $seq($self->each_seq){ my $new_seq = Bio::LocatableSeq->new( -id => $seq->id, -alphabet=> $seq->alphabet, -strand => $seq->strand, -verbose => $self->verbose); my $sequence = $seq->seq; foreach my $pair(@{$remove}){ my $start = $pair->[0]; my $end = $pair->[1]; $sequence = $seq->seq unless $sequence; my $orig = $sequence; my $head = $start > 0 ? substr($sequence, 0, $start) : ''; my $tail = ($end + 1) >= CORE::length($sequence) ? '' : substr($sequence, $end + 1); $sequence = $head.$tail; # start unless (defined $new_seq->start) { if ($start == 0) { my $start_adjust = () = substr($orig, 0, $end + 1) =~ /$gap/g; $new_seq->start($seq->start + $end + 1 - $start_adjust); } else { my $start_adjust = $orig =~ /^$gap+/; if ($start_adjust) { $start_adjust = $+[0] == $start; } $new_seq->start($seq->start + $start_adjust); } } # end if (($end + 1) >= CORE::length($orig)) { my $end_adjust = () = substr($orig, $start) =~ /$gap/g; $new_seq->end($seq->end - (CORE::length($orig) - $start) + $end_adjust); } else { $new_seq->end($seq->end); } } if ($new_seq->end < $new_seq->start) { # we removed all columns except for gaps: set to 0 to indicate no # sequence $new_seq->start(0); $new_seq->end(0); } $new_seq->seq($sequence) if $sequence; push @new, $new_seq; } # add the new seqs to the alignment foreach my $new(@new){ $aln->add_seq($new); } # fix for meta, sf, ann return $aln; } sub _remove_columns_by_type { my ($self,$type) = @_; my $aln = $self->new; my @remove; my $gap = $self->gap_char if (grep { $_ eq 'gaps'} @{$type}); my $all_gaps_columns = $self->gap_char if (grep /all_gaps_columns/,@{$type}); my %matchchars = ( 'match' => '\*', 'weak' => '\.', 'strong' => ':', 'mismatch' => ' ', 'gaps' => '', 'all_gaps_columns' => '' ); # get the characters to delete against my $del_char; foreach my $type (@{$type}){ $del_char.= $matchchars{$type}; } my $length = 0; my $match_line = $self->match_line; # do the matching to get the segments to remove if($del_char){ while($match_line =~ m/[$del_char]/g ){ my $start = pos($match_line)-1; $match_line=~/\G[$del_char]+/gc; my $end = pos($match_line)-1; #have to offset the start and end for subsequent removes $start-=$length; $end -=$length; $length += ($end-$start+1); push @remove, [$start,$end]; } } # remove the segments $aln = $#remove >= 0 ? $self->_remove_col($aln,\@remove) : $self; $aln = $aln->remove_gaps() if $gap; $aln = $aln->remove_gaps('', 1) if $all_gaps_columns; # fix for meta, sf, ann $aln; } sub _remove_columns_by_num { my ($self,$positions) = @_; my $aln = $self->new; # sort the positions @$positions = sort { $a->[0] <=> $b->[0] } @$positions; my @remove; my $length = 0; foreach my $pos (@{$positions}) { my ($start, $end) = @{$pos}; #have to offset the start and end for subsequent removes $start-=$length; $end -=$length; $length += ($end-$start+1); push @remove, [$start,$end]; } #remove the segments $aln = $#remove >= 0 ? $self->_remove_col($aln,\@remove) : $self; # fix for meta, sf, ann $aln; } =head1 Change sequences within the MSA These methods affect characters in all sequences without changing the alignment. =head2 splice_by_seq_pos Title : splice_by_seq_pos Usage : $status = splice_by_seq_pos(1); Function: splices all aligned sequences where the specified sequence has gaps. Example : Returns : 1 on success Args : position of sequence to splice by =cut sub splice_by_seq_pos{ my ($self,$pos) = @_; my $guide = $self->get_seq_by_pos($pos); my $guide_seq = $guide->seq; $guide_seq =~ s/\./\-/g; my @gaps = (); $pos = -1; while(($pos = index($guide_seq, '-', $pos)) > -1 ){ unshift @gaps, $pos; $pos++; } foreach my $seq ($self->each_seq){ my @bases = split '', $seq->seq; splice(@bases, $_, 1) foreach @gaps; $seq->seq(join('', @bases)); } 1; } =head2 map_chars Title : map_chars Usage : $ali->map_chars('\.','-') Function : Does a s/$arg1/$arg2/ on the sequences. Useful for gap characters. Note that the first argument is interpreted as a regexp so be careful and escape any wild card characters (e.g. do $ali->map_chars('\.','-') to replace periods with dashes. Returns : 1 on success Argument : A regexp and a string =cut sub map_chars { my $self = shift; my $from = shift; my $to = shift; my ( $seq, $temp ); $self->throw("Need two arguments: a regexp and a string") unless defined $from and defined $to; foreach $seq ( $self->each_seq() ) { $temp = $seq->seq(); $temp =~ s/$from/$to/g; $seq->seq($temp); } return 1; } =head2 uppercase Title : uppercase() Usage : $ali->uppercase() Function : Sets all the sequences to uppercase Returns : 1 on success Argument : =cut sub uppercase { my $self = shift; my $seq; my $temp; foreach $seq ( $self->each_seq() ) { $temp = $seq->seq(); $temp =~ tr/[a-z]/[A-Z]/; $seq->seq($temp); } return 1; } =head2 cigar_line Title : cigar_line() Usage : %cigars = $align->cigar_line() Function : Generates a "cigar" (Compact Idiosyncratic Gapped Alignment Report) line for each sequence in the alignment. Examples are "1,60" or "5,10:12,58", where the numbers refer to conserved positions within the alignment. The keys of the hash are the NSEs (name/start/end) assigned to each sequence. Args : threshold (optional, defaults to 100) Returns : Hash of strings (cigar lines) =cut sub cigar_line { my $self = shift; my $thr=shift||100; my %cigars; my @consensus = split "",($self->consensus_string($thr)); my $len = $self->length; my $gapchar = $self->gap_char; # create a precursor, something like (1,4,5,6,7,33,45), # where each number corresponds to a conserved position foreach my $seq ( $self->each_seq ) { my @seq = split "", uc ($seq->seq); my $pos = 1; for (my $x = 0 ; $x < $len ; $x++ ) { if ($seq[$x] eq $consensus[$x]) { push @{$cigars{$seq->get_nse}},$pos; $pos++; } elsif ($seq[$x] ne $gapchar) { $pos++; } } } # duplicate numbers - (1,4,5,6,7,33,45) becomes (1,1,4,5,6,7,33,33,45,45) for my $name (keys %cigars) { splice @{$cigars{$name}}, 1, 0, ${$cigars{$name}}[0] if ( ${$cigars{$name}}[0] + 1 < ${$cigars{$name}}[1] ); push @{$cigars{$name}}, ${$cigars{$name}}[$#{$cigars{$name}}] if ( ${$cigars{$name}}[($#{$cigars{$name}} - 1)] + 1 < ${$cigars{$name}}[$#{$cigars{$name}}] ); for ( my $x = 1 ; $x < $#{$cigars{$name}} - 1 ; $x++) { if (${$cigars{$name}}[$x - 1] + 1 < ${$cigars{$name}}[$x] && ${$cigars{$name}}[$x + 1] > ${$cigars{$name}}[$x] + 1) { splice @{$cigars{$name}}, $x, 0, ${$cigars{$name}}[$x]; } } } # collapse series - (1,1,4,5,6,7,33,33,45,45) becomes (1,1,4,7,33,33,45,45) for my $name (keys %cigars) { my @remove; for ( my $x = 0 ; $x < $#{$cigars{$name}} ; $x++) { if ( ${$cigars{$name}}[$x] == ${$cigars{$name}}[($x - 1)] + 1 && ${$cigars{$name}}[$x] == ${$cigars{$name}}[($x + 1)] - 1 ) { unshift @remove,$x; } } for my $pos (@remove) { splice @{$cigars{$name}}, $pos, 1; } } # join and punctuate for my $name (keys %cigars) { my ($start,$end,$str) = ""; while ( ($start,$end) = splice @{$cigars{$name}}, 0, 2 ) { $str .= ($start . "," . $end . ":"); } $str =~ s/:$//; $cigars{$name} = $str; } %cigars; } =head2 match_line Title : match_line() Usage : $line = $align->match_line() Function : Generates a match line - much like consensus string except that a line indicating the '*' for a match. Args : (optional) Match line characters ('*' by default) (optional) Strong match char (':' by default) (optional) Weak match char ('.' by default) Returns : String =cut sub match_line { my ($self,$matchlinechar, $strong, $weak) = @_; my %matchchars = ('match' => $matchlinechar || '*', 'weak' => $weak || '.', 'strong' => $strong || ':', 'mismatch' => ' ', ); my @seqchars; my $alphabet; foreach my $seq ( $self->each_seq ) { push @seqchars, [ split(//, uc ($seq->seq)) ]; $alphabet = $seq->alphabet unless defined $alphabet; } my $refseq = shift @seqchars; # let's just march down the columns my $matchline; POS: foreach my $pos ( 0..$self->length ) { my $refchar = $refseq->[$pos]; my $char = $matchchars{'mismatch'}; unless( defined $refchar ) { last if $pos == $self->length; # short circuit on last residue # this in place to handle jason's soon-to-be-committed # intron mapping code goto bottom; } my %col = ($refchar => 1); my $dash = ($refchar eq '-' || $refchar eq '.' || $refchar eq ' '); foreach my $seq ( @seqchars ) { next if $pos >= scalar @$seq; $dash = 1 if( $seq->[$pos] eq '-' || $seq->[$pos] eq '.' || $seq->[$pos] eq ' ' ); $col{$seq->[$pos]}++ if defined $seq->[$pos]; } my @colresidues = sort keys %col; # if all the values are the same if( $dash ) { $char = $matchchars{'mismatch'} } elsif( @colresidues == 1 ) { $char = $matchchars{'match'} } elsif( $alphabet eq 'protein' ) { # only try to do weak/strong # matches for protein seqs TYPE: foreach my $type ( qw(strong weak) ) { # iterate through categories my %groups; # iterate through each of the aa in the col # look to see which groups it is in foreach my $c ( @colresidues ) { foreach my $f ( grep { index($_,$c) >= 0 } @{$CONSERVATION_GROUPS{$type}} ) { push @{$groups{$f}},$c; } } GRP: foreach my $cols ( values %groups ) { @$cols = sort @$cols; # now we are just testing to see if two arrays # are identical w/o changing either one # have to be same len next if( scalar @$cols != scalar @colresidues ); # walk down the length and check each slot for($_=0;$_ < (scalar @$cols);$_++ ) { next GRP if( $cols->[$_] ne $colresidues[$_] ); } $char = $matchchars{$type}; last TYPE; } } } bottom: $matchline .= $char; } return $matchline; } =head2 gap_line Title : gap_line() Usage : $line = $align->gap_line() Function : Generates a gap line - much like consensus string except that a line where '-' represents gap Args : (optional) gap line characters ('-' by default) Returns : string =cut sub gap_line { my ($self,$gapchar) = @_; $gapchar = $gapchar || $self->gap_char; my %gap_hsh; # column gaps vector foreach my $seq ( $self->each_seq ) { my $i = 0; map {$gap_hsh{$_->[0]} = undef} grep {$_->[1] =~ m/[$gapchar]/} map {[$i++, $_]} split(//, uc ($seq->seq)); } my $gap_line; foreach my $pos ( 0..$self->length-1 ) { $gap_line .= (exists $gap_hsh{$pos}) ? $self->gap_char:'.'; } return $gap_line; } =head2 all_gap_line Title : all_gap_line() Usage : $line = $align->all_gap_line() Function : Generates a gap line - much like consensus string except that a line where '-' represents all-gap column Args : (optional) gap line characters ('-' by default) Returns : string =cut sub all_gap_line { my ($self,$gapchar) = @_; $gapchar = $gapchar || $self->gap_char; my %gap_hsh; # column gaps counter hash my @seqs = $self->each_seq; foreach my $seq ( @seqs ) { my $i = 0; map {$gap_hsh{$_->[0]}++} grep {$_->[1] =~ m/[$gapchar]/} map {[$i++, $_]} split(//, uc ($seq->seq)); } my $gap_line; foreach my $pos ( 0..$self->length-1 ) { if (exists $gap_hsh{$pos} && $gap_hsh{$pos} == scalar @seqs) { # gaps column $gap_line .= $self->gap_char; } else { $gap_line .= '.'; } } return $gap_line; } =head2 gap_col_matrix Title : gap_col_matrix() Usage : my $cols = $align->gap_col_matrix() Function : Generates an array where each element in the array is a hash reference with a key of the sequence name and a value of 1 if the sequence has a gap at that column Returns : Reference to an array Args : Optional: gap line character ($aln->gap_char or '-' by default) =cut sub gap_col_matrix { my ( $self, $gapchar ) = @_; $gapchar = $gapchar || $self->gap_char; my %gap_hsh; # column gaps vector my @cols; foreach my $seq ( $self->each_seq ) { my $i = 0; my $str = $seq->seq; my $len = $seq->length; my $ch; my $id = $seq->display_id; while ( $i < $len ) { $ch = substr( $str, $i, 1 ); $cols[ $i++ ]->{$id} = ( $ch =~ m/[$gapchar]/ ); } } return \@cols; } =head2 match Title : match() Usage : $ali->match() Function : Goes through all columns and changes residues that are identical to residue in first sequence to match '.' character. Sets match_char. USE WITH CARE: Most MSA formats do not support match characters in sequences, so this is mostly for output only. NEXUS format (Bio::AlignIO::nexus) can handle it. Returns : 1 on success Argument : a match character, optional, defaults to '.' =cut sub match { my ( $self, $match ) = @_; $match ||= '.'; my ($matching_char) = $match; $matching_char = "\\$match" if $match =~ /[\^.$|()\[\]]/; #'; $self->map_chars( $matching_char, '-' ); my @seqs = $self->each_seq(); return 1 unless scalar @seqs > 1; my $refseq = shift @seqs; my @refseq = split //, $refseq->seq; my $gapchar = $self->gap_char; foreach my $seq (@seqs) { my @varseq = split //, $seq->seq(); for ( my $i = 0; $i < scalar @varseq; $i++ ) { $varseq[$i] = $match if defined $refseq[$i] && ( $refseq[$i] =~ /[A-Za-z\*]/ || $refseq[$i] =~ /$gapchar/ ) && $refseq[$i] eq $varseq[$i]; } $seq->seq( join '', @varseq ); } $self->match_char($match); return 1; } =head2 unmatch Title : unmatch() Usage : $ali->unmatch() Function : Undoes the effect of method match. Unsets match_char. Returns : 1 on success Argument : a match character, optional, defaults to '.' See L and L =cut sub unmatch { my ( $self, $match ) = @_; $match ||= '.'; my @seqs = $self->each_seq(); return 1 unless scalar @seqs > 1; my $refseq = shift @seqs; my @refseq = split //, $refseq->seq; my $gapchar = $self->gap_char; foreach my $seq (@seqs) { my @varseq = split //, $seq->seq(); for ( my $i = 0; $i < scalar @varseq; $i++ ) { $varseq[$i] = $refseq[$i] if defined $refseq[$i] && ( $refseq[$i] =~ /[A-Za-z\*]/ || $refseq[$i] =~ /$gapchar/ ) && $varseq[$i] eq $match; } $seq->seq( join '', @varseq ); } $self->match_char(''); return 1; } =head1 MSA attributes Methods for setting and reading the MSA attributes. Note that the methods defining character semantics depend on the user to set them sensibly. They are needed only by certain input/output methods. Unset them by setting to an empty string (''). =head2 id Title : id Usage : $myalign->id("Ig") Function : Gets/sets the id field of the alignment Returns : An id string Argument : An id string (optional) =cut sub id { my ( $self, $name ) = @_; if ( defined($name) ) { $self->{'_id'} = $name; } return $self->{'_id'}; } =head2 accession Title : accession Usage : $myalign->accession("PF00244") Function : Gets/sets the accession field of the alignment Returns : An acc string Argument : An acc string (optional) =cut sub accession { my ( $self, $acc ) = @_; if ( defined($acc) ) { $self->{'_accession'} = $acc; } return $self->{'_accession'}; } =head2 description Title : description Usage : $myalign->description("14-3-3 proteins") Function : Gets/sets the description field of the alignment Returns : An description string Argument : An description string (optional) =cut sub description { my ( $self, $name ) = @_; if ( defined($name) ) { $self->{'_description'} = $name; } return $self->{'_description'}; } =head2 missing_char Title : missing_char Usage : $myalign->missing_char("?") Function : Gets/sets the missing_char attribute of the alignment It is generally recommended to set it to 'n' or 'N' for nucleotides and to 'X' for protein. Returns : An missing_char string, Argument : An missing_char string (optional) =cut sub missing_char { my ( $self, $char ) = @_; if ( defined $char ) { $self->throw("Single missing character, not [$char]!") if CORE::length($char) > 1; $self->{'_missing_char'} = $char; } return $self->{'_missing_char'}; } =head2 match_char Title : match_char Usage : $myalign->match_char('.') Function : Gets/sets the match_char attribute of the alignment Returns : An match_char string, Argument : An match_char string (optional) =cut sub match_char { my ( $self, $char ) = @_; if ( defined $char ) { $self->throw("Single match character, not [$char]!") if CORE::length($char) > 1; $self->{'_match_char'} = $char; } return $self->{'_match_char'}; } =head2 gap_char Title : gap_char Usage : $myalign->gap_char('-') Function : Gets/sets the gap_char attribute of the alignment Returns : An gap_char string, defaults to '-' Argument : An gap_char string (optional) =cut sub gap_char { my ( $self, $char ) = @_; if ( defined $char || !defined $self->{'_gap_char'} ) { $char = '-' unless defined $char; $self->throw("Single gap character, not [$char]!") if CORE::length($char) > 1; $self->{'_gap_char'} = $char; } return $self->{'_gap_char'}; } =head2 symbol_chars Title : symbol_chars Usage : my @symbolchars = $aln->symbol_chars; Function: Returns all the seen symbols (other than gaps) Returns : array of characters that are the seen symbols Args : boolean to include the gap/missing/match characters =cut sub symbol_chars{ my ($self,$includeextra) = @_; unless ($self->{'_symbols'}) { foreach my $seq ($self->each_seq) { map { $self->{'_symbols'}->{$_} = 1; } split(//,$seq->seq); } } my %copy = %{$self->{'_symbols'}}; if( ! $includeextra ) { foreach my $char ( $self->gap_char, $self->match_char, $self->missing_char) { delete $copy{$char} if( defined $char ); } } return keys %copy; } =head1 Alignment descriptors These read only methods describe the MSA in various ways. =head2 score Title : score Usage : $str = $ali->score() Function : get/set a score of the alignment Returns : a score for the alignment Argument : an optional score to set =cut sub score { my $self = shift; $self->{score} = shift if @_; return $self->{score}; } =head2 consensus_string Title : consensus_string Usage : $str = $ali->consensus_string($threshold_percent) Function : Makes a strict consensus Returns : Consensus string Argument : Optional threshold ranging from 0 to 100. The consensus residue has to appear at least threshold % of the sequences at a given location, otherwise a '?' character will be placed at that location. (Default value = 0%) =cut sub consensus_string { my $self = shift; my $threshold = shift; my $out = ""; my $len = $self->length - 1; foreach ( 0 .. $len ) { $out .= $self->_consensus_aa( $_, $threshold ); } return $out; } =head2 consensus_conservation Title : consensus_conservation Usage : @conservation = $ali->consensus_conservation(); Function : Conservation (as a percent) of each position of alignment Returns : Array of percentages [0-100]. Gap columns are 0% conserved. Argument : =cut sub consensus_conservation { my $self = shift; my @cons; my $num_sequences = $self->num_sequences; foreach my $point (0..$self->length-1) { my %hash = $self->_consensus_counts($point); # max frequency of a non-gap letter my $max = (sort {$b<=>$a} values %hash )[0]; push @cons, 100 * $max / $num_sequences; } return @cons; } sub _consensus_aa { my $self = shift; my $point = shift; my $threshold_percent = shift || -1 ; my ($seq,%hash,$count,$letter,$key); my $gapchar = $self->gap_char; %hash = $self->_consensus_counts($point); my $number_of_sequences = $self->num_sequences(); my $threshold = $number_of_sequences * $threshold_percent / 100. ; $count = -1; $letter = '?'; foreach $key ( sort keys %hash ) { # print "Now at $key $hash{$key}\n"; if( $hash{$key} > $count && $hash{$key} >= $threshold) { $letter = $key; $count = $hash{$key}; } } return $letter; } # Frequency of each letter in one column sub _consensus_counts { my $self = shift; my $point = shift; my %hash; my $gapchar = $self->gap_char; foreach my $seq ( $self->each_seq() ) { my $letter = substr($seq->seq,$point,1); $self->throw("--$point-----------") if $letter eq ''; ($letter eq $gapchar || $letter =~ /\./) && next; $hash{$letter}++; } return %hash; } =head2 consensus_iupac Title : consensus_iupac Usage : $str = $ali->consensus_iupac() Function : Makes a consensus using IUPAC ambiguity codes from DNA and RNA. The output is in upper case except when gaps in a column force output to be in lower case. Note that if your alignment sequences contain a lot of IUPAC ambiquity codes you often have to manually set alphabet. Bio::PrimarySeq::_guess_type thinks they indicate a protein sequence. Returns : consensus string Argument : none Throws : on protein sequences =cut sub consensus_iupac { my $self = shift; my $out = ""; my $len = $self->length - 1; # only DNA and RNA sequences are valid foreach my $seq ( $self->each_seq() ) { $self->throw( "Seq [" . $seq->get_nse . "] is a protein" ) if $seq->alphabet eq 'protein'; } # loop over the alignment columns foreach my $count ( 0 .. $len ) { $out .= $self->_consensus_iupac($count); } return $out; } sub _consensus_iupac { my ($self, $column) = @_; my ($string, $char, $rna); #determine all residues in a column foreach my $seq ( $self->each_seq() ) { $string .= substr($seq->seq, $column, 1); } $string = uc $string; # quick exit if there's an N in the string if ($string =~ /N/) { $string =~ /\W/ ? return 'n' : return 'N'; } # ... or if there are only gap characters return '-' if $string =~ /^\W+$/; # treat RNA as DNA in regexps if ($string =~ /U/) { $string =~ s/U/T/; $rna = 1; } # the following s///'s only need to be done to the _first_ ambiguity code # as we only need to see the _range_ of characters in $string if ($string =~ /[VDHB]/) { $string =~ s/V/AGC/; $string =~ s/D/AGT/; $string =~ s/H/ACT/; $string =~ s/B/CTG/; } if ($string =~ /[SKYRWM]/) { $string =~ s/S/GC/; $string =~ s/K/GT/; $string =~ s/Y/CT/; $string =~ s/R/AG/; $string =~ s/W/AT/; $string =~ s/M/AC/; } # and now the guts of the thing if ($string =~ /A/) { $char = 'A'; # A A if ($string =~ /G/) { $char = 'R'; # A and G (purines) R if ($string =~ /C/) { $char = 'V'; # A and G and C V if ($string =~ /T/) { $char = 'N'; # A and G and C and T N } } elsif ($string =~ /T/) { $char = 'D'; # A and G and T D } } elsif ($string =~ /C/) { $char = 'M'; # A and C M if ($string =~ /T/) { $char = 'H'; # A and C and T H } } elsif ($string =~ /T/) { $char = 'W'; # A and T W } } elsif ($string =~ /C/) { $char = 'C'; # C C if ($string =~ /T/) { $char = 'Y'; # C and T (pyrimidines) Y if ($string =~ /G/) { $char = 'B'; # C and T and G B } } elsif ($string =~ /G/) { $char = 'S'; # C and G S } } elsif ($string =~ /G/) { $char = 'G'; # G G if ($string =~ /C/) { $char = 'S'; # G and C S } elsif ($string =~ /T/) { $char = 'K'; # G and T K } } elsif ($string =~ /T/) { $char = 'T'; # T T } $char = 'U' if $rna and $char eq 'T'; $char = lc $char if $string =~ /\W/; return $char; } =head2 consensus_meta Title : consensus_meta Usage : $seqmeta = $ali->consensus_meta() Function : Returns a Bio::Seq::Meta object containing the consensus strings derived from meta data analysis. Returns : Bio::Seq::Meta Argument : Bio::Seq::Meta Throws : non-MetaI object =cut sub consensus_meta { my ($self, $meta) = @_; if ($meta && (!ref $meta || !$meta->isa('Bio::Seq::MetaI'))) { $self->throw('Not a Bio::Seq::MetaI object'); } return $self->{'_aln_meta'} = $meta if $meta; return $self->{'_aln_meta'} } =head2 is_flush Title : is_flush Usage : if ( $ali->is_flush() ) Function : Tells you whether the alignment : is flush, i.e. all of the same length Returns : 1 or 0 Argument : =cut sub is_flush { my ( $self, $report ) = @_; my $seq; my $length = (-1); my $temp; foreach $seq ( $self->each_seq() ) { if ( $length == (-1) ) { $length = CORE::length( $seq->seq() ); next; } $temp = CORE::length( $seq->seq() ); if ( $temp != $length ) { $self->warn( "expecting $length not $temp from " . $seq->display_id ) if ($report); $self->debug( "expecting $length not $temp from " . $seq->display_id ); $self->debug( $seq->seq() . "\n" ); return 0; } } return 1; } =head2 length Title : length() Usage : $len = $ali->length() Function : Returns the maximum length of the alignment. To be sure the alignment is a block, use is_flush Returns : Integer Argument : =cut sub length_aln { my $self = shift; $self->deprecated("length_aln - deprecated method. Use length() instead."); $self->length(@_); } sub length { my $self = shift; my $seq; my $length = -1; my $temp; foreach $seq ( $self->each_seq() ) { $temp = $seq->length(); if( $temp > $length ) { $length = $temp; } } return $length; } =head2 maxdisplayname_length Title : maxdisplayname_length Usage : $ali->maxdisplayname_length() Function : Gets the maximum length of the displayname in the alignment. Used in writing out various MSA formats. Returns : integer Argument : =cut sub maxname_length { my $self = shift; $self->deprecated("maxname_length - deprecated method.". " Use maxdisplayname_length() instead."); $self->maxdisplayname_length(); } sub maxnse_length { my $self = shift; $self->deprecated("maxnse_length - deprecated method.". " Use maxnse_length() instead."); $self->maxdisplayname_length(); } sub maxdisplayname_length { my $self = shift; my $maxname = (-1); my ( $seq, $len ); foreach $seq ( $self->each_seq() ) { $len = CORE::length $self->displayname( $seq->get_nse() ); if ( $len > $maxname ) { $maxname = $len; } } return $maxname; } =head2 max_metaname_length Title : max_metaname_length Usage : $ali->max_metaname_length() Function : Gets the maximum length of the meta name tags in the alignment for the sequences and for the alignment. Used in writing out various MSA formats. Returns : integer Argument : None =cut sub max_metaname_length { my $self = shift; my $maxname = (-1); my ($seq,$len); # check seq meta first for $seq ( $self->each_seq() ) { next if !$seq->isa('Bio::Seq::MetaI' || !$seq->meta_names); for my $mtag ($seq->meta_names) { $len = CORE::length $mtag; if( $len > $maxname ) { $maxname = $len; } } } # alignment meta for my $meta ($self->consensus_meta) { next unless $meta; for my $name ($meta->meta_names) { $len = CORE::length $name; if( $len > $maxname ) { $maxname = $len; } } } return $maxname; } =head2 num_residues Title : num_residues Usage : $no = $ali->num_residues Function : number of residues in total in the alignment Returns : integer Argument : Note : replaces no_residues() =cut sub num_residues { my $self = shift; my $count = 0; foreach my $seq ( $self->each_seq ) { my $str = $seq->seq(); $count += ( $str =~ s/[A-Za-z]//g ); } return $count; } =head2 num_sequences Title : num_sequences Usage : $depth = $ali->num_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : none Note : replaces no_sequences() =cut sub num_sequences { my $self = shift; return scalar($self->each_seq); } =head2 average_percentage_identity Title : average_percentage_identity Usage : $id = $align->average_percentage_identity Function: The function uses a fast method to calculate the average percentage identity of the alignment Returns : The average percentage identity of the alignment Args : None Notes : This method implemented by Kevin Howe calculates a figure that is designed to be similar to the average pairwise identity of the alignment (identical in the absence of gaps), without having to explicitly calculate pairwise identities proposed by Richard Durbin. Validated by Ewan Birney ad Alex Bateman. =cut sub average_percentage_identity{ my ($self,@args) = @_; my @alphabet = ('A','B','C','D','E','F','G','H','I','J','K','L','M', 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'); my ($len, $total, $subtotal, $divisor, $subdivisor, @seqs, @countHashes); if (! $self->is_flush()) { $self->throw("All sequences in the alignment must be the same length"); } @seqs = $self->each_seq(); $len = $self->length(); # load the each hash with correct keys for existence checks for( my $index=0; $index < $len; $index++) { foreach my $letter (@alphabet) { $countHashes[$index]->{$letter} = 0; } } foreach my $seq (@seqs) { my @seqChars = split //, $seq->seq(); for( my $column=0; $column < @seqChars; $column++ ) { my $char = uc($seqChars[$column]); if (exists $countHashes[$column]->{$char}) { $countHashes[$column]->{$char}++; } } } $total = 0; $divisor = 0; for(my $column =0; $column < $len; $column++) { my %hash = %{$countHashes[$column]}; $subdivisor = 0; foreach my $res (keys %hash) { $total += $hash{$res}*($hash{$res} - 1); $subdivisor += $hash{$res}; } $divisor += $subdivisor * ($subdivisor - 1); } return $divisor > 0 ? ($total / $divisor )*100.0 : 0; } =head2 percentage_identity Title : percentage_identity Usage : $id = $align->percentage_identity Function: The function calculates the average percentage identity (aliased to average_percentage_identity) Returns : The average percentage identity Args : None =cut sub percentage_identity { my $self = shift; return $self->average_percentage_identity(); } =head2 overall_percentage_identity Title : overall_percentage_identity Usage : $id = $align->overall_percentage_identity $id = $align->overall_percentage_identity('short') Function: The function calculates the percentage identity of the conserved columns Returns : The percentage identity of the conserved columns Args : length value to use, optional defaults to alignment length possible values: 'align', 'short', 'long' The argument values 'short' and 'long' refer to shortest and longest sequence in the alignment. Method modification code by Hongyu Zhang. =cut sub overall_percentage_identity{ my ($self, $length_measure) = @_; my %alphabet = map {$_ => undef} qw (A C G T U B D E F H I J K L M N O P Q R S V W X Y Z); my %enum = map {$_ => undef} qw (align short long); $self->throw("Unknown argument [$length_measure]") if $length_measure and not exists $enum{$length_measure}; $length_measure ||= 'align'; if (! $self->is_flush()) { $self->throw("All sequences in the alignment must be the same length"); } # Count the residues seen at each position my $len; my $total = 0; # number of positions with identical residues my @countHashes; my @seqs = $self->each_seq; my $nof_seqs = scalar @seqs; my $aln_len = $self->length(); for my $seq (@seqs) { my $seqstr = $seq->seq; # Count residues for given sequence for my $column (0 .. $aln_len-1) { my $char = uc( substr($seqstr, $column, 1) ); if ( exists $alphabet{$char} ) { # This is a valid char if ( defined $countHashes[$column]->{$char} ) { $countHashes[$column]->{$char}++; } else { $countHashes[$column]->{$char} = 1; } if ( $countHashes[$column]->{$char} == $nof_seqs ) { # All sequences have this same residue $total++; } } } # Sequence length if ($length_measure eq 'short' || $length_measure eq 'long') { my $seq_len = $seqstr =~ tr/[A-Za-z]//; if ($length_measure eq 'short') { if ( (not defined $len) || ($seq_len < $len) ) { $len = $seq_len; } } elsif ($length_measure eq 'long') { if ( (not defined $len) || ($seq_len > $len) ) { $len = $seq_len; } } } } if ($length_measure eq 'align') { $len = $aln_len; } return ($total / $len ) * 100.0; } =head1 Alignment positions Methods to map a sequence position into an alignment column and back. column_from_residue_number() does the former. The latter is really a property of the sequence object and can done using L: # select somehow a sequence from the alignment, e.g. my $seq = $aln->get_seq_by_pos(1); #$loc is undef or Bio::LocationI object my $loc = $seq->location_from_column(5); =head2 column_from_residue_number Title : column_from_residue_number Usage : $col = $ali->column_from_residue_number( $seqname, $resnumber) Function: This function gives the position in the alignment (i.e. column number) of the given residue number in the sequence with the given name. For example, for the alignment Seq1/91-97 AC..DEF.GH. Seq2/24-30 ACGG.RTY... Seq3/43-51 AC.DDEF.GHI column_from_residue_number( "Seq1", 94 ) returns 6. column_from_residue_number( "Seq2", 25 ) returns 2. column_from_residue_number( "Seq3", 50 ) returns 10. An exception is thrown if the residue number would lie outside the length of the aligment (e.g. column_from_residue_number( "Seq2", 22 ) Note: If the the parent sequence is represented by more than one alignment sequence and the residue number is present in them, this method finds only the first one. Returns : A column number for the position in the alignment of the given residue in the given sequence (1 = first column) Args : A sequence id/name (not a name/start-end) A residue number in the whole sequence (not just that segment of it in the alignment) =cut sub column_from_residue_number { my ( $self, $name, $resnumber ) = @_; $self->throw("No sequence with name [$name]") unless $self->{'_start_end_lists'}->{$name}; $self->throw("Second argument residue number missing") unless $resnumber; foreach my $seq ( $self->each_seq_with_id($name) ) { my $col; eval { $col = $seq->column_from_residue_number($resnumber); }; next if $@; return $col; } $self->throw( "Could not find a sequence segment in $name " . "containing residue number $resnumber" ); } =head1 Sequence names Methods to manipulate the display name. The default name based on the sequence id and subsequence positions can be overridden in various ways. =head2 displayname Title : displayname Usage : $myalign->displayname("Ig", "IgA") Function : Gets/sets the display name of a sequence in the alignment Returns : A display name string Argument : name of the sequence displayname of the sequence (optional) =cut sub displayname { my ( $self, $name, $disname ) = @_; $self->throw("No sequence with name [$name]") unless defined $self->{'_seq'}->{$name}; if ( $disname and $name ) { $self->{'_dis_name'}->{$name} = $disname; return $disname; } elsif ( defined $self->{'_dis_name'}->{$name} ) { return $self->{'_dis_name'}->{$name}; } else { return $name; } } sub get_displayname { my $self = shift; $self->deprecated("get_displayname - deprecated method. Use displayname() instead."); $self->displayname(@_); } sub set_displayname { my $self = shift; $self->deprecated("set_displayname - deprecated method. Use displayname() instead."); $self->displayname(@_); } =head2 set_displayname_count Title : set_displayname_count Usage : $ali->set_displayname_count Function : Sets the names to be name_# where # is the number of times this name has been used. Returns : 1, on success Argument : =cut sub set_displayname_count { my $self= shift; my (@arr,$name,$seq,$count,$temp,$nse); foreach $seq ( $self->each_alphabetically() ) { $nse = $seq->get_nse(); #name will be set when this is the second #time (or greater) is has been seen if( defined $name and $name eq ($seq->id()) ) { $temp = sprintf("%s_%s",$name,$count); $self->displayname($nse,$temp); $count++; } else { $count = 1; $name = $seq->id(); $temp = sprintf("%s_%s",$name,$count); $self->displayname($nse,$temp); $count++; } } return 1; } =head2 set_displayname_flat Title : set_displayname_flat Usage : $ali->set_displayname_flat() Function : Makes all the sequences be displayed as just their name, not name/start-end (NSE) Returns : 1 Argument : =cut sub set_displayname_flat { my $self = shift; my ( $nse, $seq ); foreach $seq ( $self->each_seq() ) { $nse = $seq->get_nse(); $self->displayname( $nse, $seq->id() ); } return 1; } =head2 set_displayname_normal Title : set_displayname_normal Usage : $ali->set_displayname_normal() Function : Makes all the sequences be displayed as name/start-end (NSE) Returns : 1, on success Argument : =cut sub set_displayname_normal { my $self = shift; my ( $nse, $seq ); foreach $seq ( $self->each_seq() ) { $nse = $seq->get_nse(); $self->displayname( $nse, $nse ); } return 1; } =head2 source Title : source Usage : $obj->source($newval) Function: sets the Alignment source program Example : Returns : value of source Args : newvalue (optional) =cut sub source { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_source'} = $value; } return $self->{'_source'}; } =head2 set_displayname_safe Title : set_displayname_safe Usage : ($new_aln, $ref_name)=$ali->set_displayname_safe(4) Function : Assign machine-generated serial names to sequences in input order. Designed to protect names during PHYLIP runs. Assign 10-char string in the form of "S000000001" to "S999999999". Restore the original names using "restore_displayname". Returns : 1. a new $aln with system names; 2. a hash ref for restoring names Argument : Number for id length (default 10) =cut sub set_displayname_safe { my $self = shift; my $idlength = shift || 10; my ( $seq, %phylip_name ); my $ct = 0; my $new = Bio::SimpleAlign->new(); foreach $seq ( $self->each_seq() ) { $ct++; my $pname = "S" . sprintf "%0" . ( $idlength - 1 ) . "s", $ct; $phylip_name{$pname} = $seq->id(); my $new_seq = Bio::LocatableSeq->new( -id => $pname, -seq => $seq->seq(), -alphabet => $seq->alphabet, -start => $seq->{_start}, -end => $seq->{_end} ); $new->add_seq($new_seq); } $self->debug( "$ct seq names changed. Restore names by using restore_displayname."); return ( $new, \%phylip_name ); } =head2 restore_displayname Title : restore_displayname Usage : $aln_name_restored=$ali->restore_displayname($hash_ref) Function : Restore original sequence names (after running $ali->set_displayname_safe) Returns : a new $aln with names restored. Argument : a hash reference of names from "set_displayname_safe". =cut sub restore_displayname { my $self = shift; my $ref=shift; my %name=%$ref; my $new=Bio::SimpleAlign->new(); foreach my $seq ( $self->each_seq() ) { $self->throw("No sequence with name") unless defined $name{$seq->id()}; my $new_seq= Bio::LocatableSeq->new(-id => $name{$seq->id()}, -seq => $seq->seq(), -alphabet => $seq->alphabet, -start => $seq->{_start}, -end => $seq->{_end} ); $new->add_seq($new_seq); } return $new; } =head2 sort_by_start Title : sort_by_start Usage : $ali->sort_by_start Function : Changes the order of the alignment to the start position of each subalignment Returns : 1 on success Argument : =cut sub sort_by_start { my $self = shift; my ($seq,$nse,@arr,%hash,$count); foreach $seq ( $self->each_seq() ) { $nse = $seq->get_nse; $hash{$nse} = $seq; } $count = 0; %{$self->{'_order'}} = (); # reset the hash; foreach $nse ( sort _startend keys %hash) { $self->{'_order'}->{$count} = $nse; $count++; } 1; } sub _startend { my ($aname,$arange) = split (/[\/]/,$a); my ($bname,$brange) = split (/[\/]/,$b); my ($astart,$aend) = split(/\-/,$arange); my ($bstart,$bend) = split(/\-/,$brange); return $astart <=> $bstart; } =head2 bracket_string Title : bracket_string Usage : my @params = (-refseq => 'testseq', -allele1 => 'allele1', -allele2 => 'allele2', -delimiters => '{}', -separator => '/'); $str = $aln->bracket_string(@params) Function : When supplied with a list of parameters (see below), returns a string in BIC format. This is used for allelic comparisons. Briefly, if either allele contains a base change when compared to the refseq, the base or gap for each allele is represented in brackets in the order present in the 'alleles' parameter. For the following data: >testseq GGATCCATTGCTACT >allele1 GGATCCATTCCTACT >allele2 GGAT--ATTCCTCCT the returned string with parameters 'refseq => testseq' and 'alleles => [qw(allele1 allele2)]' would be: GGAT[C/-][C/-]ATT[C/C]CT[A/C]CT Returns : BIC-formatted string Argument : Required args refseq : string (ID) of the reference sequence used as basis for comparison allele1 : string (ID) of the first allele allele2 : string (ID) of the second allele Optional args delimiters: two symbol string of left and right delimiters. Only the first two symbols are used default = '[]' separator : string used as a separator. Only the first symbol is used default = '/' Throws : On no refseq/alleles, or invalid refseq/alleles. =cut sub bracket_string { my ($self, @args) = @_; my ($ref, $a1, $a2, $delim, $sep) = $self->_rearrange([qw(refseq allele1 allele2 delimiters separator)], @args); $self->throw('Missing refseq/allele1/allele2') if (!$a1 || !$a2 || !$ref); my ($ld, $rd); ($ld, $rd) = split('', $delim, 2) if $delim; $ld ||= '['; $rd ||= ']'; $sep ||= '/'; my ($refseq, $allele1, $allele2) = map {( $self->each_seq_with_id($_) )} ($ref, $a1, $a2); if (!$refseq || !$allele1 || !$allele2) { $self->throw("One of your refseq/allele IDs is invalid!"); } my $len = $self->length-1; my $bic = ''; # loop over the alignment columns for my $column ( 0 .. $len ) { my $string; my ($compres, $res1, $res2) = map{substr($_->seq, $column, 1)} ($refseq, $allele1, $allele2); # are any of the allele symbols different from the refseq? $string = ($compres eq $res1 && $compres eq $res2) ? $compres : $ld.$res1.$sep.$res2.$rd; $bic .= $string; } return $bic; } =head2 methods implementing Bio::FeatureHolderI FeatureHolderI implementation to support labeled character sets like one would get from NEXUS represented data. =head2 get_SeqFeatures Usage : @features = $aln->get_SeqFeatures Function: Get the feature objects held by this feature holder. Example : Returns : an array of Bio::SeqFeatureI implementing objects Args : optional filter coderef, taking a Bio::SeqFeatureI : as argument, returning TRUE if wanted, FALSE if : unwanted =cut sub get_SeqFeatures { my $self = shift; my $filter_cb = shift; $self->throw("Arg (filter callback) must be a coderef") unless !defined($filter_cb) or ref($filter_cb) eq 'CODE'; if ( !defined $self->{'_as_feat'} ) { $self->{'_as_feat'} = []; } if ($filter_cb) { return grep { $filter_cb->($_) } @{ $self->{'_as_feat'} }; } return @{ $self->{'_as_feat'} }; } =head2 add_SeqFeature Usage : $aln->add_SeqFeature($subfeat); Function: Adds a SeqFeature into the SeqFeature array. The 'EXPAND' qualifier (see L) is supported, but has no effect. Example : Returns : 1 on success Args : a Bio::SeqFeatureI object =cut sub add_SeqFeature { my ($self, @feat) = @_; $self->{'_as_feat'} = [] unless $self->{'_as_feat'}; if (scalar @feat > 1) { $self->deprecated( -message => 'Providing an array of features to Bio::SimpleAlign add_SeqFeature()'. ' is deprecated and will be removed in a future version. '. 'Add a single feature at a time instead.', -warn_version => 1.007, -throw_version => 1.009, ); } for my $feat ( @feat ) { next if $feat eq 'EXPAND'; # Need to support it for FeatureHolderI compliance if( !$feat->isa("Bio::SeqFeatureI") ) { $self->throw("Expected a Bio::SeqFeatureI object, but got a $feat."); } push @{$self->{'_as_feat'}}, $feat; } return 1; } =head2 remove_SeqFeatures Usage : $obj->remove_SeqFeatures Function: Removes all SeqFeatures. If you want to remove only a subset, remove that subset from the returned array, and add back the rest. Returns : The array of Bio::SeqFeatureI features that was deleted from this alignment. Args : none =cut sub remove_SeqFeatures { my $self = shift; return () unless $self->{'_as_feat'}; my @feats = @{$self->{'_as_feat'}}; $self->{'_as_feat'} = []; return @feats; } =head2 feature_count Title : feature_count Usage : $obj->feature_count() Function: Return the number of SeqFeatures attached to the alignment Returns : integer representing the number of SeqFeatures Args : None =cut sub feature_count { my ($self) = @_; if (defined($self->{'_as_feat'})) { return ($#{$self->{'_as_feat'}} + 1); } else { return 0; } } =head2 get_all_SeqFeatures Title : get_all_SeqFeatures Usage : Function: Get all SeqFeatures. Example : Returns : an array of Bio::SeqFeatureI implementing objects Args : none Note : Falls through to Bio::FeatureHolderI implementation. =cut =head2 methods for Bio::AnnotatableI AnnotatableI implementation to support sequence alignments which contain annotation (NEXUS, Stockholm). =head2 annotation Title : annotation Usage : $ann = $aln->annotation or $aln->annotation($ann) Function: Gets or sets the annotation Returns : Bio::AnnotationCollectionI object Args : None or Bio::AnnotationCollectionI object See L and L for more information =cut sub annotation { my ($obj,$value) = @_; if( defined $value ) { $obj->throw("object of class ".ref($value)." does not implement ". "Bio::AnnotationCollectionI. Too bad.") unless $value->isa("Bio::AnnotationCollectionI"); $obj->{'_annotation'} = $value; } elsif( ! defined $obj->{'_annotation'}) { $obj->{'_annotation'} = Bio::Annotation::Collection->new(); } return $obj->{'_annotation'}; } =head1 Deprecated methods =cut =head2 no_residues Title : no_residues Usage : $no = $ali->no_residues Function : number of residues in total in the alignment Returns : integer Argument : Note : deprecated in favor of num_residues() =cut sub no_residues { my $self = shift; $self->deprecated(-warn_version => 1.0069, -throw_version => 1.0075, -message => 'Use of method no_residues() is deprecated, use num_residues() instead'); $self->num_residues(@_); } =head2 no_sequences Title : no_sequences Usage : $depth = $ali->no_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : Note : deprecated in favor of num_sequences() =cut sub no_sequences { my $self = shift; $self->deprecated(-warn_version => 1.0069, -throw_version => 1.0075, -message => 'Use of method no_sequences() is deprecated, use num_sequences() instead'); $self->num_sequences(@_); } =head2 mask_columns Title : mask_columns Usage : $aln2 = $aln->mask_columns(20,30) Function : Masks a slice of the alignment inclusive of start and end columns, and the first column in the alignment is denoted 1. Mask beyond the length of the sequence does not do padding. Returns : A Bio::SimpleAlign object Args : Positive integer for start column, positive integer for end column, optional string value use for the mask. Example: $aln2 = $aln->mask_columns(20,30,'?') Note : Masking must use a character that is not used for gaps or frameshifts. These can be adjusted using the relevant global variables, but be aware these may be (uncontrollably) modified elsewhere within BioPerl (see bug 2715) =cut sub mask_columns { #based on slice(), but did not include the Bio::Seq::Meta sections as I was not sure what it is doing my $self = shift; my $nonres = $Bio::LocatableSeq::GAP_SYMBOLS. $Bio::LocatableSeq::FRAMESHIFT_SYMBOLS; # coordinates are alignment-based, not sequence-based my ($start, $end, $mask_char) = @_; unless (defined $mask_char) { $mask_char = 'N' } $self->throw("Mask start has to be a positive integer and less than ". "alignment length, not [$start]") unless $start =~ /^\d+$/ && $start > 0 && $start <= $self->length; $self->throw("Mask end has to be a positive integer and less than ". "alignment length, not [$end]") unless $end =~ /^\d+$/ && $end > 0 && $end <= $self->length; $self->throw("Mask start [$start] has to be smaller than or equal to ". "end [$end]") unless $start <= $end; $self->throw("Mask character $mask_char has to be a single character ". "and not a gap or frameshift symbol") unless CORE::length($mask_char) == 1 && $mask_char !~ m{$nonres}; my $aln = $self->new; $aln->id($self->id); foreach my $seq ( $self->each_seq() ) { my $new_seq = Bio::LocatableSeq->new(-id => $seq->id, -alphabet => $seq->alphabet, -strand => $seq->strand, -verbose => $self->verbose); # convert from 1-based alignment coords! my $masked_string = substr($seq->seq, $start - 1, $end - $start + 1); $masked_string =~ s{[^$nonres]}{$mask_char}g; my $new_dna_string = substr($seq->seq,0,$start-1) . $masked_string . substr($seq->seq,$end); $new_seq->seq($new_dna_string); $aln->add_seq($new_seq); } # Preserve chosen mask character, it may be need later (like in 'slice') $aln->{_mask_char} = $mask_char; return $aln; } 1; BioPerl-1.6.923/Bio/SimpleAnalysisI.pm000444000765000024 1704712254227330 17602 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SimpleAnalysisI # # Please direct questions and support issues to # # Cared for by Martin Senger # For copyright and disclaimer see below. # # POD documentation - main docs before the code =head1 NAME Bio::SimpleAnalysisI - A simple interface to any (local or remote) analysis tool =head1 SYNOPSIS This is an interface module - you do not instantiate it. Use other modules instead (those that implement this interface). =head1 DESCRIPTION This interface contains public methods for accessing and controlling local and remote analysis tools. It is meant to be used on the client side. The interface consists only of a necessary set of methods for synchronous invocation of analysis tools. For more complex set, including an asynchronous access, see interface C (which inherits from this one, by the way). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Martin Senger (martin.senger@gmail.com) =head1 COPYRIGHT Copyright (c) 2003, Martin Senger and EMBL-EBI. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO =over =item * http://www.ebi.ac.uk/Tools/webservices/soaplab/guide =back =head1 APPENDIX This is actually the main documentation... If you try to call any of these methods directly on this C object you will get a I error message. =cut # Let the code begin... package Bio::SimpleAnalysisI; use strict; use base qw(Bio::Root::RootI); # ----------------------------------------------------------------------------- =head2 analysis_name Usage : $tool->analysis_name; Returns : a name of this analysis Args : none =cut sub analysis_name { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 analysis_spec Usage : $tool->analysis_spec; Returns : a hash reference describing this analysis Args : none The returned hash reference uses the following keys (not all of them always present, perhaps others present as well): C, C, C, C, C, C. =cut sub analysis_spec { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 input_spec Usage : $tool->input_spec; Returns : an array reference with hashes as elements Args : none The analysis input data are named, and can be also associated with a default value, with allowed values and with few other attributes. The names are important for feeding the analysis with the input data (the inputs are given to methods C and C as name/value pairs). =cut sub input_spec { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 result_spec Usage : $tool->result_spec; Returns : a hash reference with result names as keys and result types as values Args : none An analysis can produce several results, or the same result in several different formats. All such results are named and can be retrieved using their names by metod C. Here is an example of the result specification: $result_spec = { 'outseq' => 'String', 'report' => 'String', 'detailed_status' => 'String' }; =cut sub result_spec { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 run Usage : $tool->run ( ['sequence=@my.seq', 'osformat=embl'] ) Returns : $self Args : data and parameters for this execution (in various formats) Create a job, start it, and wait for its completion. The method is identical to the method C. Why there are two methods doing the same? Because it is expected that the sub-classes may implement them differently (an example is an interface C which uses method C for an asynchronous execution and method C for a synchronous one. Usually, after this call, you ask for results of the finished job: $analysis->run (...)->result; The input data and prameters for this execution can be specified in various ways: =over =item array reference The array has scalar elements of the form name = [[@]value] where C is the name of an input data or input parameter (see method C for finding what names are recognized by this analysis) and C is a value for this data/parameter. If C is missing a 1 is assumed (which is convenient for the boolean options). If C starts with C<@> it is treated as a local filename, and its contents is used as the data/parameter value. =item hash reference The same as with the array reference but now there is no need to use an equal sign. The hash keys are input names and hash values their data. The values can again start with a C<@> sign indicating a local filename. =back =cut sub run { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 wait_for Usage : $tool->wait_for ( { 'sequence' => '@my,file' } ) Returns : $self Args : the same as for method 'run' Create a job, start it and wait for its completion. The method is identical to the method C. See details in the C method. =cut sub wait_for { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 status Usage : $tool->status Returns : string describing a status of the execution Args : none It returns one of the following strings (and perhaps more if a server implementation extended possible job states): CREATED (not run yet) COMPLETED (run and finished normally) TERMINATED_BY_ERROR (run and finished with an error or a signal) =cut sub status { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 result Usage : $job->result (...) Returns : a result created by running an analysis Args : none (but an implementation may choose to add arguments for instructions how to process the raw result) The method returns a scalar representing a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data (or both, depending on the implementation). =cut sub result { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- 1; __END__ BioPerl-1.6.923/Bio/Species.pm000444000765000024 4617212254227314 16132 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Species # # Please direct questions and support issues to # # Cared for by James Gilbert # Reimplemented by Sendu Bala # Re-reimplemented by Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Species - Generic species object. =head1 SYNOPSIS $species = Bio::Species->new(-classification => [@classification]); # Can also pass classification # array to new as below $species->classification(qw( sapiens Homo Hominidae Catarrhini Primates Eutheria Mammalia Vertebrata Chordata Metazoa Eukaryota )); $genus = $species->genus(); $bi = $species->binomial(); # $bi is now "Homo sapiens" # For storing common name $species->common_name("human"); # For storing subspecies $species->sub_species("accountant"); =head1 DESCRIPTION B Provides a very simple object for storing phylogenetic information. The classification is stored in an array, which is a list of nodes in a phylogenetic tree. Access to getting and setting species and genus is provided, but not to any of the other node types (eg: "phylum", "class", "order", "family"). There's plenty of scope for making the model more sophisticated, if this is ever needed. A methods are also provided for storing common names, and subspecies. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR James Gilbert email B =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk Chris Fields, cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' Let the code begin... package Bio::Species; use strict; use warnings; use Bio::DB::Taxonomy; use Bio::Tree::Tree; use Bio::Taxon; use base qw(Bio::Root::Root Bio::Tree::NodeI); =head2 new Title : new Usage : my $obj = Bio::Species->new(-classification => \@class) Function: Build a new Species object Returns : Bio::Species object Args : -ncbi_taxid => NCBI taxonomic ID (optional) -classification => arrayref of classification =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); # Bio::Species is now just a proxy object that just observes the NodeI # interface methods but delegates them to the proper classes (Bio::Taxon and # Bio::Tree::Tree). This will be surplanted by the much simpler # Bio::Taxon/Bio::DB::Taxonomy modules in the future. # Using a proxy allows proper GC w/o using weaken(). This just wraps the # older instances, which have no reciprocal refs (thus no circular refs). # This can then run proper cleanup $self->taxon(Bio::Taxon->new(@args)); my ($org, $sp, $var, $classification) = $self->_rearrange([qw(ORGANELLE SUB_SPECIES VARIANT CLASSIFICATION)], @args); if (defined $classification && ref($classification) eq "ARRAY" && @{$classification}) { $self->classification(@$classification); } else { $self->tree(Bio::Tree::Tree->new()); } defined $org && $self->organelle($org); defined $sp && $self->sub_species($sp); defined $var && $self->variant($var); return $self; } =head2 classification Title : classification Usage : $self->classification(@class_array); @classification = $self->classification(); Function: Get/set the lineage of this species. The array provided must be in the order ... ---> SPECIES, GENUS ---> KINGDOM ---> etc. Example : $obj->classification(qw( 'Homo sapiens' Homo Hominidae Catarrhini Primates Eutheria Mammalia Vertebrata Chordata Metazoa Eukaryota)); Returns : Classification array Args : Classification array OR A reference to the classification array. In the latter case if there is a second argument and it evaluates to true, names will not be validated. NB: in any case, names are never validated anyway. =cut sub classification { my ($self, @vals) = @_; my $taxon = $self->taxon; if (@vals) { if (ref($vals[0]) eq 'ARRAY') { @vals = @{$vals[0]}; } $vals[1] ||= ''; # make sure the lineage contains us as first or second element # (lineage may have subspecies, species, genus ...) my $name = $taxon->node_name; my ($genus, $species) = (quotemeta($vals[1]), quotemeta($vals[0])); if ($name && ($name !~ m{$species}i && $name !~ m{$genus}i) && $name !~ m{$vals[1] $vals[0]}i) { if ($name =~ /^$vals[1] $vals[0]\s*(.+)/) { # just assume the problem is someone tried to make a Bio::Species starting at subspecies #*** no idea if this is appropriate! just a possible fix related to bug 2092 $self->sub_species($1); $name = $taxon->node_name("$vals[1] $vals[0]"); } else { $self->warn("The supplied lineage does not start near '$name' (I was supplied '".join(" | ", @vals)."')"); } } # create a lineage for ourselves my $db = Bio::DB::Taxonomy->new(-source => 'list', -names => [reverse @vals]); unless ($taxon->scientific_name) { # assume we're supposed to be the leaf of the supplied lineage $self->taxon->scientific_name($vals[0]); } unless ($taxon->rank) { # and that we are rank species $taxon->rank('species'); } $taxon->db_handle($db); $self->tree(Bio::Tree::Tree->new(-node => $taxon)); } @vals = (); foreach my $node ($self->tree->get_lineage_nodes($taxon), $taxon) { unshift(@vals, $node->scientific_name || next); } return @vals; } =head2 ncbi_taxid Title : ncbi_taxid Usage : $obj->ncbi_taxid($newval) Function: Get/set the NCBI Taxon ID Returns : the NCBI Taxon ID as a string Args : newvalue to set or undef to unset (optional) =cut =head2 common_name Title : common_name Usage : $self->common_name( $common_name ); $common_name = $self->common_name(); Function: Get or set the common name of the species Example : $self->common_name('human') Returns : The common name in a string Args : String, which is the common name (optional) =cut =head2 division Title : division Usage : $obj->division($newval) Function: Genbank Division for a species Returns : value of division (a scalar) Args : value of division (a scalar) =cut =head2 species Title : species Usage : $self->species( $species ); $species = $self->species(); Function: Get or set the species name. Note that this is NOT genus and species -- use $self->binomial() for that. Example : $self->species('sapiens'); Returns : species name as string (NOT genus and species) Args : species name as string (NOT genus and species) =cut sub species { my ($self, $species) = @_; if ($species) { $self->{_species} = $species; } unless (defined $self->{_species}) { # work it out from our nodes my $species_taxon = $self->tree->find_node(-rank => 'species'); unless ($species_taxon) { # just assume we are rank species $species_taxon = $self->taxon; } $species = $species_taxon->scientific_name; # # munge it like the Bio::SeqIO modules used to do # (more or less copy/pasted from old Bio::SeqIO::genbank, hence comments # referring to 'ORGANISM' etc.) # my $root = $self->tree->get_root_node; unless ($root) { $self->tree(Bio::Tree::Tree->new(-node => $species_taxon)); $root = $self->tree->get_root_node; } my @spflds = split(' ', $species); if (@spflds > 1 && $root->node_name ne 'Viruses') { $species = undef; # does the next term start with uppercase? # yes: valid genus; no then unconventional # e.g. leaf litter basidiomycete sp. Collb2-39 my $genus; if ($spflds[0] =~ m/^[A-Z]/) { $genus = shift(@spflds); } else { undef $genus; } my $sub_species; if (@spflds) { while (my $fld = shift @spflds) { $species .= "$fld "; # does it have subspecies or varieties? last if ($fld =~ m/(sp\.|var\.)/); } chop $species; # last space $sub_species = join ' ',@spflds if(@spflds); } else { $species = 'sp.'; } # does ORGANISM start with any words which make its genus undefined? # these are in @unkn_genus # this in case species starts with uppercase so isn't caught above. # alter common name if required my $unconv = 0; # is it unconventional species name? my @unkn_genus = ('unknown','unclassified','uncultured','unidentified'); foreach (@unkn_genus) { if ($genus && $genus =~ m/$_/i) { $species = $genus . " " . $species; undef $genus; $unconv = 1; last; } elsif ($species =~ m/$_/i) { $unconv = 1; last; } } if (!$unconv && !$sub_species && $species =~ s/^(\w+)\s(\w+)$/$1/) { # need to extract subspecies from conventional ORGANISM format. # Will the 'word' in a two element species name # e.g. $species = 'thummi thummi' => $species='thummi' & # $sub_species='thummi' $sub_species = $2; } $self->genus($genus) if $genus; $self->sub_species($sub_species) if $sub_species; } $self->{_species} = $species; } return $self->{_species}; } =head2 genus Title : genus Usage : $self->genus( $genus ); $genus = $self->genus(); Function: Get or set the scientific genus name. Example : $self->genus('Homo'); Returns : Scientific genus name as string Args : Scientific genus name as string =cut sub genus { my ($self, $genus) = @_; # TODO: instead of caching the raw name, cache the actual node instance. if ($genus) { $self->{_genus} = $genus; } unless (defined $self->{_genus}) { my $genus_taxon = $self->tree->find_node(-rank => 'genus'); unless ($genus_taxon) { # just assume our ancestor is rank genus $genus_taxon = $self->taxon->ancestor; } $self->{_genus} = $genus_taxon->scientific_name if $genus_taxon; } return $self->{_genus}; } =head2 sub_species Title : sub_species Usage : $obj->sub_species($newval) Function: Get or set the scientific subspecies name. Returns : value of sub_species Args : newvalue (optional) =cut sub sub_species { my ($self, $sub) = @_; # TODO: instead of caching the raw name, cache the actual node instance. if (!defined $self->{'_sub_species'}) { my $ss_taxon = $self->tree->find_node(-rank => 'subspecies'); if ($ss_taxon) { if ($sub) { $ss_taxon->scientific_name($sub); # *** weakening ref to our root node in species() to solve a # memory leak means that we have a subspecies taxon to set # during the first call to species(), but it has vanished by # the time a user subsequently calls sub_species() to get the # value. So we 'cheat' and just store the subspecies name in # our self hash, instead of the tree. Is this a problem for # a Species object? Can't decide --sendu # This can now be changed to deal with this information on the # fly. For now, the caching remains, but maybe we should just # let these things deal with mutable data as needed? -- cjfields $self->{'_sub_species'} = $sub; } return $ss_taxon->scientific_name; } else { # should we create a node here to be added to the tree? } } # fall back to direct storage on self $self->{'_sub_species'} = $sub if $sub; return $self->{'_sub_species'}; } =head2 variant Title : variant Usage : $obj->variant($newval) Function: Get/set variant information for this species object (strain, isolate, etc). Example : Returns : value of variant (a scalar) Args : new value (a scalar or undef, optional) =cut sub variant{ my ($self, $var) = @_; # TODO: instead of caching the raw name, cache the actual node instance. if (!defined $self->{'_variant'}) { my $var_taxon = $self->tree->find_node(-rank => 'variant'); if ($var_taxon) { if ($var) { $var_taxon->scientific_name($var); } return $var_taxon->scientific_name; } else { # should we create a node here to be added to the tree? } } # fall back to direct storage on self $self->{'_variant'} = $var if $var; return $self->{'_variant'}; } =head2 binomial Title : binomial Usage : $binomial = $self->binomial(); $binomial = $self->binomial('FULL'); Function: Returns a string "Genus species", or "Genus species subspecies", if the first argument is 'FULL' (and the species has a subspecies). Args : Optionally the string 'FULL' to get the full name including the subspecies. Note : This is just munged from the taxon() name =cut sub binomial { my ($self, $full) = @_; my $rank = $self->taxon->rank || 'no rank'; my ($species, $genus) = ($self->species, $self->genus); unless (defined $species) { $species = 'sp.'; $self->warn("requested binomial but classification was not set"); } $genus = '' unless( defined $genus); $species =~ s/$genus\s+//; my $bi = "$genus $species"; if (defined($full) && $full =~ /full/i) { my $ssp = $self->sub_species; if ($ssp) { $ssp =~ s/$bi\s+//; $ssp =~ s/$species\s+//; $bi .= " $ssp"; } } return $bi; } =head2 validate_species_name Title : validate_species_name Usage : $result = $self->validate_species_name($string); Function: Validate the species portion of the binomial Args : string Notes : The string following the "genus name" in the NCBI binomial is so variable that it's not clear that this is a useful function. Consider the binomials "Simian 11 rotavirus (serotype 3 / strain SA11-Patton)", or "St. Thomas 3 rotavirus", straight from GenBank. This is particularly problematic in microbes and viruses. As such, this isn't actually used automatically by any Bio::Species method. =cut sub validate_species_name { my( $self, $string ) = @_; return 1 if $string eq "sp."; return 1 if $string =~ /strain/; return 1 if $string =~ /^[a-z][\w\s-]+$/i; $self->throw("Invalid species name '$string'"); } sub validate_name { return 1; } =head2 organelle Title : organelle Usage : $self->organelle( $organelle ); $organelle = $self->organelle(); Function: Get or set the organelle name Example : $self->organelle('Chloroplast') Returns : The organelle name in a string Args : String, which is the organelle name Note : TODO: We currently do not know where the organelle definition will eventually go. This is stored in the source seqfeature, though, so the information isn't lost. =cut sub organelle { my($self) = shift; return $self->{'_organelle'} = shift if @_; return $self->{'_organelle'}; } =head2 Delegation The following methods delegate to the internal Bio::Taxon instance. This is mainly to allow code continue using older methods, with the mind to migrate to using Bio::Taxon and related methods when this class is deprecated. =cut sub node_name {shift->taxon->node_name(@_)} sub scientific_name {shift->taxon->node_name(@_)} sub id {shift->taxon->id(@_)} sub object_id {shift->taxon->id(@_)} sub ncbi_taxid {shift->taxon->ncbi_taxid(@_)} sub rank {shift->taxon->rank(@_)} sub division {shift->taxon->division(@_)} sub common_names {shift->taxon->common_names(@_)} sub common_name {shift->taxon->common_names(@_)} sub genetic_code {shift->taxon->genetic_code(@_)} sub mitochondrial_genetic_code {shift->taxon->mitochondrial_genetic_code(@_)} sub create_date { shift->taxon->create_date(@_)} sub pub_date { shift->taxon->pub_date(@_)} sub update_date { shift->taxon->update_date(@_)} sub db_handle { shift->taxon->db_handle(@_)} sub parent_id { shift->taxon->parent_id(@_)} sub parent_taxon_id { shift->taxon->parent_id(@_)} sub version { shift->taxon->version(@_)} sub authority { shift->taxon->authority(@_)} sub namespace { shift->taxon->namespace(@_)} sub ancestor { shift->taxon->ancestor(@_)} sub get_Parent_Node { shift->taxon->get_Parent_Node(@_)} sub each_Descendent { shift->taxon->each_Descendent(@_)} sub get_Children_Nodes { shift->taxon->get_Children_Nodes(@_)} sub remove_Descendant { shift->taxon->remove_Descendant(@_)} sub name { shift->taxon->name(@_)} =head2 taxon Title : taxon Usage : $obj->taxon Function : retrieve the internal Bio::Taxon instance Returns : A Bio::Taxon. If one is not previously set, an instance is created lazily Args : Bio::Taxon (optional) =cut sub taxon { my ($self, $taxon) = @_; if (!$self->{taxon} || $taxon) { $taxon ||= Bio::Taxon->new(); $self->{taxon} = $taxon; } $self->{taxon}; } =head2 tree Title : tree Usage : $obj->tree Function : Returns a Bio::Tree::Tree object Returns : A Bio::Tree::Tree. If one is not previously set, an instance is created lazily Args : Bio::Tree::Tree (optional) =cut sub tree { my ($self, $tree) = @_; if (!$self->{tree} || $tree) { $tree ||= Bio::Tree::Tree->new(); delete $tree->{_root_cleanup_methods}; $self->{tree} = $tree; } $self->{tree}; } sub DESTROY { my $self = shift; $self->tree->cleanup_tree; delete $self->{tree}; $self->taxon->node_cleanup; } 1; BioPerl-1.6.923/Bio/Taxon.pm000444000765000024 5574712254227330 15636 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Taxon # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala, based heavily on a module by Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Taxon - A node in a represented taxonomy =head1 SYNOPSIS use Bio::Taxon; # Typically you will get a Taxon from a Bio::DB::Taxonomy object # but here is how you initialize one my $taxon = Bio::Taxon->new(-name => $name, -id => $id, -rank => $rank, -division => $div); # Get one from a database my $dbh = Bio::DB::Taxonomy->new(-source => 'flatfile', -directory=> '/tmp', -nodesfile=> '/path/to/nodes.dmp', -namesfile=> '/path/to/names.dmp'); my $human = $dbh->get_taxon(-name => 'Homo sapiens'); $human = $dbh->get_taxon(-taxonid => '9606'); print "id is ", $human->id, "\n"; # 9606 print "rank is ", $human->rank, "\n"; # species print "scientific name is ", $human->scientific_name, "\n"; # Homo sapiens print "division is ", $human->division, "\n"; # Primates my $mouse = $dbh->get_taxon(-name => 'Mus musculus'); # You can quickly make your own lineages with the list database my @ranks = qw(superkingdom class genus species); my @h_lineage = ('Eukaryota', 'Mammalia', 'Homo', 'Homo sapiens'); my $list_dbh = Bio::DB::Taxonomy->new(-source => 'list', -names => \@h_lineage, -ranks => \@ranks); $human = $list_dbh->get_taxon(-name => 'Homo sapiens'); my @names = $human->common_names; # @names is empty $human->common_names('woman'); @names = $human->common_names; # @names contains woman # You can switch to another database when you need more information my $entrez_dbh = Bio::DB::Taxonomy->new(-source => 'entrez'); $human->db_handle($entrez_dbh); @names = $human->common_names; # @names contains woman, human, man # Since Bio::Taxon implements Bio::Tree::NodeI, we have access to those # methods (and can manually create our own taxa and taxonomy without the use # of any database) my $homo = $human->ancestor; # Though be careful with each_Descendent - unless you add_Descendent() # yourself, you won't get an answer because unlike for ancestor(), Bio::Taxon # does not ask the database for the answer. You can ask the database yourself # using the same method: ($human) = $homo->db_handle->each_Descendent($homo); # We can also take advantage of Bio::Tree::Tree* methods: # a) some methods are available with just an empty tree object use Bio::Tree::Tree; my $tree_functions = Bio::Tree::Tree->new(); my @lineage = $tree_functions->get_lineage_nodes($human); my $lineage = $tree_functions->get_lineage_string($human); my $lca = $tree_functions->get_lca($human, $mouse); # b) for other methods, create a tree using your Taxon object my $tree = Bio::Tree::Tree->new(-node => $human); my @taxa = $tree->get_nodes; $homo = $tree->find_node(-rank => 'genus'); # Normally you can't get the lca of a list-database derived Taxon and an # entrez or flatfile-derived one because the two different databases might # have different roots and different numbers of ranks between the root and the # taxa of interest. To solve this, make a tree of the Taxon with the more # detailed lineage and splice out all the taxa that won't be in the lineage of # your other Taxon: my $entrez_mouse = $entrez_dbh->get_taxon(-name => 'Mus musculus'); my $list_human = $list_dbh->get_taxon(-name => 'Homo sapiens'); my $mouse_tree = Bio::Tree::Tree->new(-node => $entrez_mouse); $mouse_tree->splice(-keep_rank => \@ranks); $lca = $mouse_tree->get_lca($entrez_mouse, $list_human); =head1 DESCRIPTION This is the next generation (for Bioperl) of representing Taxonomy information. Previously all information was managed by a single object called Bio::Species. This new implementation allows representation of the intermediate nodes not just the species nodes and can relate their connections. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl-dot-org (original Bio::Taxonomy::Node) Juguang Xiao, juguang@tll.org.sg Gabriel Valiente, valiente@lsi.upc.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Taxon; use strict; use Scalar::Util qw(blessed); use Bio::DB::Taxonomy; use base qw(Bio::Tree::Node Bio::IdentifiableI); =head2 new Title : new Usage : my $obj = Bio::Taxonomy::Node->new(); Function: Builds a new Bio::Taxonomy::Node object Returns : an instance of Bio::Taxonomy::Node Args : -dbh => a reference to a Bio::DB::Taxonomy object [no default] -name => a string representing the taxon name (scientific name) -id => human readable id - typically NCBI taxid -ncbi_taxid => same as -id, but explicitly say that it is an NCBI taxid -rank => node rank (one of 'species', 'genus', etc) -common_names => array ref of all common names -division => 'Primates', 'Rodents', etc -genetic_code => genetic code table number -mito_genetic_code => mitochondrial genetic code table number -create_date => date created in database -update_date => date last updated in database -pub_date => date published in database =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($name, $id, $objid, $rank, $div, $dbh, $ncbitaxid, $commonname, $commonnames, $gcode, $mitocode, $createdate, $updatedate, $pubdate, $parent_id) = $self->_rearrange([qw(NAME ID OBJECT_ID RANK DIVISION DBH NCBI_TAXID COMMON_NAME COMMON_NAMES GENETIC_CODE MITO_GENETIC_CODE CREATE_DATE UPDATE_DATE PUB_DATE PARENT_ID)], @args); if (defined $id && (defined $ncbitaxid && $ncbitaxid ne $id || defined $objid && $objid ne $id)) { $self->warn("Only provide one of -id, -object_id or -ncbi_taxid, using $id\n"); } elsif(!defined $id) { $id = $objid || $ncbitaxid; } defined $id && $self->id($id); $self->{_ncbi_tax_id_provided} = 1 if $ncbitaxid; defined $rank && $self->rank($rank); defined $name && $self->node_name($name); my @common_names; if ($commonnames) { $self->throw("-common_names takes only an array reference") unless $commonnames && ref($commonnames) eq 'ARRAY'; @common_names = @{$commonnames}; } if ($commonname) { my %c_names = map { $_ => 1 } @common_names; unless (exists $c_names{$commonname}) { unshift(@common_names, $commonname); } } @common_names > 0 && $self->common_names(@common_names); defined $gcode && $self->genetic_code($gcode); defined $mitocode && $self->mitochondrial_genetic_code($mitocode); defined $createdate && $self->create_date($createdate); defined $updatedate && $self->update_date($updatedate); defined $pubdate && $self->pub_date($pubdate); defined $div && $self->division($div); defined $dbh && $self->db_handle($dbh); # deprecated and will issue a warning when method called, # eventually to be removed completely as option defined $parent_id && $self->parent_id($parent_id); # some things want to freeze/thaw Bio::Species objects, but # _root_cleanup_methods contains a CODE ref, delete it. delete $self->{_root_cleanup_methods}; return $self; } =head1 Bio::IdentifiableI interface Also see L =head2 version Title : version Usage : $taxon->version($newval) Returns : value of version (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub version { my $self = shift; return $self->{'version'} = shift if @_; return $self->{'version'}; } =head2 authority Title : authority Usage : $taxon->authority($newval) Returns : value of authority (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub authority { my $self = shift; return $self->{'authority'} = shift if @_; return $self->{'authority'}; } =head2 namespace Title : namespace Usage : $taxon->namespace($newval) Returns : value of namespace (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub namespace { my $self = shift; return $self->{'namespace'} = shift if @_; return $self->{'namespace'}; } =head1 Bio::Taxonomy::Node implementation =head2 db_handle Title : db_handle Usage : $taxon->db_handle($newval) Function: Get/Set Bio::DB::Taxonomy Handle Returns : value of db_handle (a scalar) (Bio::DB::Taxonomy object) Args : on set, new value (a scalar, optional) Bio::DB::Taxonomy object Also see L =cut sub db_handle { my $self = shift; if (@_) { my $db = shift; if (! ref($db) || ! $db->isa('Bio::DB::Taxonomy')) { $self->throw("Must provide a valid Bio::DB::Taxonomy object to db_handle()"); } if (!$self->{'db_handle'} || ($self->{'db_handle'} && $self->{'db_handle'} ne $db)) { my $new_self = $self->_get_similar_taxon_from_db($self, $db); $self->_merge_taxa($new_self) if $new_self; } # NB: The Bio::DB::Taxonomy modules access this data member directly # to avoid calling this method and going infinite $self->{'db_handle'} = $db; } return $self->{'db_handle'}; } =head2 rank Title : rank Usage : $taxon->rank($newval) Function: Get/set rank of this Taxon, 'species', 'genus', 'order', etc... Returns : value of rank (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub rank { my $self = shift; return $self->{'rank'} = shift if @_; return $self->{'rank'}; } =head2 id Title : id Usage : $taxon->id($newval) Function: Get/Set id (NCBI Taxonomy ID in most cases); object_id() and ncbi_taxid() are synonyms of this method. Returns : id (a scalar) Args : none to get, OR scalar to set =cut sub id { my $self = shift; return $self->SUPER::id(@_); } *object_id = \&id; =head2 ncbi_taxid Title : ncbi_taxid Usage : $taxon->ncbi_taxid($newval) Function: Get/Set the NCBI Taxonomy ID; This actually sets the id() but only returns an id when ncbi_taxid has been explictely set with this method. Returns : id (a scalar) Args : none to get, OR scalar to set =cut sub ncbi_taxid { my ($self, $id) = @_; if ($id) { $self->{_ncbi_tax_id_provided} = 1; return $self->SUPER::id($id); } if ($self->{_ncbi_tax_id_provided}) { return $self->SUPER::id; } return; } =head2 parent_id Title : parent_id Usage : $taxon->parent_id() Function: Get parent ID, (NCBI Taxonomy ID in most cases); parent_taxon_id() is a synonym of this method. Returns : value of parent_id (a scalar) Args : none Status : deprecated =cut sub parent_id { my $self = shift; if (@_) { $self->warn("You can no longer set the parent_id - use ancestor() instead"); } my $ancestor = $self->ancestor() || return; return $ancestor->id; } *parent_taxon_id = \&parent_id; =head2 genetic_code Title : genetic_code Usage : $taxon->genetic_code($newval) Function: Get/set genetic code table Returns : value of genetic_code (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub genetic_code { my $self = shift; return $self->{'genetic_code'} = shift if @_; return $self->{'genetic_code'}; } =head2 mitochondrial_genetic_code Title : mitochondrial_genetic_code Usage : $taxon->mitochondrial_genetic_code($newval) Function: Get/set mitochondrial genetic code table Returns : value of mitochondrial_genetic_code (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub mitochondrial_genetic_code { my $self = shift; return $self->{'mitochondrial_genetic_code'} = shift if @_; return $self->{'mitochondrial_genetic_code'}; } =head2 create_date Title : create_date Usage : $taxon->create_date($newval) Function: Get/Set Date this node was created (in the database) Returns : value of create_date (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub create_date { my $self = shift; return $self->{'create_date'} = shift if @_; return $self->{'create_date'}; } =head2 update_date Title : update_date Usage : $taxon->update_date($newval) Function: Get/Set Date this node was updated (in the database) Returns : value of update_date (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub update_date { my $self = shift; return $self->{'update_date'} = shift if @_; return $self->{'update_date'}; } =head2 pub_date Title : pub_date Usage : $taxon->pub_date($newval) Function: Get/Set Date this node was published (in the database) Returns : value of pub_date (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub pub_date { my $self = shift; return $self->{'pub_date'} = shift if @_; return $self->{'pub_date'}; } =head2 ancestor Title : ancestor Usage : my $ancestor_taxon = $taxon->ancestor() Function: Retrieve the ancestor taxon. Normally the database is asked what the ancestor is. If you manually set the ancestor (or you make a Bio::Tree::Tree with this object as an argument to new()), the database (if any) will not be used for the purposes of this method. To restore normal database behaviour, call ancestor(undef) (which would remove this object from the tree), or request this taxon again as a new Taxon object from the database. Returns : Bio::Taxon Args : none =cut sub ancestor { my $self = shift; my $ancestor = $self->SUPER::ancestor(@_); if ($ancestor) { return $ancestor; } my $dbh = $self->db_handle; #*** could avoid the db lookup if we knew our current id was definitely # information from the db... my $definitely_from_dbh = $self->_get_similar_taxon_from_db($self); return $dbh->ancestor($definitely_from_dbh); } =head2 get_Parent_Node Title : get_Parent_Node Function: Synonym of ancestor() Status : deprecated =cut sub get_Parent_Node { my $self = shift; $self->warn("get_Parent_Node is deprecated, use ancestor() instead"); return $self->ancestor(@_); } =head2 each_Descendent Title : each_Descendent Usage : my @taxa = $taxon->each_Descendent(); Function: Get all the descendents for this Taxon (but not their descendents, ie. not a recursive fetchall). get_Children_Nodes() is a synonym of this method. Note that this method never asks the database for the descendents; it will only return objects you have manually set with add_Descendent(), or where this was done for you by making a Bio::Tree::Tree with this object as an argument to new(). To get the database descendents use $taxon->db_handle->each_Descendent($taxon). Returns : Array of Bio::Taxon objects Args : optionally, when you have set your own descendents, the string "height", "creation", "alpha", "revalpha", or coderef to be used to sort the order of children nodes. =cut # implemented by Bio::Tree::Node =head2 get_Children_Nodes Title : get_Children_Nodes Function: Synonym of each_Descendent() Status : deprecated =cut sub get_Children_Nodes { my $self = shift; $self->warn("get_Children_Nodes is deprecated, use each_Descendent() instead"); return $self->each_Descendent(@_); } =head2 name Title: name Usage: $taxon->name('scientific', 'Homo sapiens'); $taxon->name('common', 'human', 'man'); my @names = @{$taxon->name('common')}; Function: Get/set the names. node_name(), scientific_name() and common_names() are shorthands to name('scientific'), name('scientific') and name('common') respectively. Returns: names (a array reference) Args: Arg1 => the name_class. You can assign any text, but the words 'scientific' and 'common' have the special meaning, as scientific name and common name, respectively. 'scientific' and 'division' are treated specially, allowing only the first value in the Arg2 list to be set. Arg2 ... => list of names =cut sub name { my ($self, $name_class, @names) = @_; $self->throw('No name class specified') unless defined $name_class; if (@names) { if ($name_class =~ /scientific|division/i) { delete $self->{'_names_hash'}->{$name_class}; @names = (shift(@names)); } push @{$self->{'_names_hash'}->{$name_class}}, @names; } return $self->{'_names_hash'}->{$name_class} || return; } =head2 node_name Title : node_name Usage : $taxon->node_name($newval) Function: Get/set the name of this taxon (node), typically the scientific name of the taxon, eg. 'Primate' or 'Homo'; scientific_name() is a synonym of this method. Returns : value of node_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub node_name { my $self = shift; my @v = @{$self->name('scientific', @_) || []}; return pop @v; } *scientific_name = \&node_name; =head2 common_names Title : common_names Usage : $taxon->common_names($newval) Function: Get/add the other names of this taxon, typically the genbank common name and others, eg. 'Human' and 'man'. common_name() is a synonym of this method. Returns : array of names in list context, one of those names in scalar context Args : on add, new list of names (scalars, optional) =cut sub common_names { my $self = shift; my @v = @{$self->name('common', @_) || []}; return ( wantarray ) ? @v : pop @v; } *common_name = \&common_names; =head2 division Title : division Usage : $taxon->division($newval) Function: Get/set the division this taxon belongs to, eg. 'Primates' or 'Bacteria'. Returns : value of division (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub division { my $self = shift; my @v = @{$self->name('division',@_) || []}; return pop @v; } # get a node from the database that is like the supplied node sub _get_similar_taxon_from_db { #*** not really happy with this having to be called so much; there must be # a better way... my ($self, $taxon, $db) = @_; $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa("Bio::Taxon"); ($self->id || $self->node_name) || return; $db ||= $self->db_handle || return; if (!blessed($db) || !$db->isa('Bio::DB::Taxonomy')) { $self->throw("DB handle is not a Bio::DB::Taxonomy: got $db in node ".$self->node_name) } my $db_taxon = $db->get_taxon(-taxonid => $taxon->id) if $taxon->id; unless ($db_taxon) { my @try_ids = $db->get_taxonids($taxon->node_name) if $taxon->node_name; my $own_rank = $taxon->rank || 'no rank'; foreach my $try_id (@try_ids) { my $try = $db->get_taxon(-taxonid => $try_id); my $try_rank = $try->rank || 'no rank'; if ($own_rank eq 'no rank' || $try_rank eq 'no rank' || $own_rank eq $try_rank) { $db_taxon = $try; last; } } } return $db_taxon; } # merge data from supplied Taxon into self sub _merge_taxa { my ($self, $taxon) = @_; $self->throw("Must supply a Bio::Taxon object") unless ref($taxon) && $taxon->isa('Bio::Taxon'); return if ($taxon eq $self); foreach my $attrib (qw(scientific_name version authority namespace genetic_code mitochondrial_genetic_code create_date update_date pub_date division id)) { my $own = $self->$attrib(); my $his = $taxon->$attrib(); if (!$own && $his) { $self->$attrib($his); } } my $own = $self->rank || 'no rank'; my $his = $taxon->rank || 'no rank'; if ($own eq 'no rank' && $his ne 'no rank') { $self->rank($his); } my %own_cnames = map { $_ => 1 } $self->common_names; my %his_cnames = map { $_ => 1 } $taxon->common_names; foreach (keys %his_cnames) { unless (exists $own_cnames{$_}) { $self->common_names($_); } } #*** haven't merged the other things in names() hash, could do above much easier with direct access to object data } =head2 remove_Descendent Title : remove_Descendent Usage : $node->remove_Descedent($node_foo); Function: Removes a specific node from being a Descendent of this node Returns : nothing Args : An array of Bio::Node::NodeI objects which have been previously passed to the add_Descendent call of this object. =cut sub remove_Descendent { # need to override this method from Bio::Tree::Node since it casually # throws away nodes if they don't branch my ($self,@nodes) = @_; my $c= 0; foreach my $n ( @nodes ) { if ($self->{'_desc'}->{$n->internal_id}) { $self->{_removing_descendent} = 1; $n->ancestor(undef); $self->{_removing_descendent} = 0; $self->{'_desc'}->{$n->internal_id}->ancestor(undef); delete $self->{'_desc'}->{$n->internal_id}; $c++; } } return $c; } 1; BioPerl-1.6.923/Bio/Taxonomy.pm000444000765000024 2707312254227332 16354 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Taxonomy # # Please direct questions and support issues to # # Cared for by Juguang Xiao # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Taxonomy - representing Taxonomy. =head1 SYNOPSIS # NB: This module is deprecated. Use Bio::Taxon in combination with # Bio::Tree::Tree methods instead. use Bio::Taxonomy; # CREATION: You can either create an instance by assigning it, # or fetch it through factory. # Create the nodes first. See Bio::Taxonomy::Node for details. my $node_species_sapiens = Bio::Taxonomy::Node->new( -object_id => 9606, # or -ncbi_taxid. Requird tag -names => { 'scientific' => ['sapiens'], 'common_name' => ['human'] }, -rank => 'species' # Required tag ); my $node_genus_Homo = Bio::Taxonomy::Node->new( -object_id => 9605, -names => { 'scientific' => ['Homo'] }, -rank => 'genus' ); my $node_class_Mammalia = Bio::Taxonomy::Node->new( -object_id => 40674, -names => { 'scientific' => ['Mammalia'], 'common' => ['mammals'] }, -rank => 'class' ); my $taxonomy = Bio::Taxonomy->new; $taxonomy->add_node($node_class_Mammalia); $taxonomy->add_node($node_species_sapiens); $taxonomy->add_node($node_genus_Homo); # OR you can fetch it through a factory implementing # Bio::Taxonomy::FactoryI my $factory; my $taxonomy = $factory->fetch_by_ncbi_taxid(40674); # USAGE # In this case, binomial returns a defined value. my $binomial = $taxonomy->binomial; # 'common_names' refers to the lowest-rank node's common names, in # array. my @common_names = $taxonomy->common_names; # 'get_node', will return undef if the rank is no defined in # taxonomy object. It will throw error if the rank string is not # defined, say 'species lah'. my $node = $taxonomy->get_node('class'); my @nodes = $taxonomy->get_all_nodes; # Also, you can search for parent and children nodes, if taxonomy # comes with factory. my $parent_taxonomy = $taxonomy->get_parent =head1 DESCRIPTION Bio::Taxonomy object represents any rank-level in taxonomy system, rather than Bio::Species which is able to represent only species-level. There are two ways to create Taxonomy object, e.g. 1) instantiate an object and assign all nodes on your own code; and 2) fetch an object by factory. =head2 Creation by instantiation The abstraction of Taxonomy is actually a hash in data structure term. The keys of the hash are the rank names, such as 'genus' and 'species', and the values are the instances of Bio::Taxonomy::Node. =head2 Creation by Factory fetching NCBI Taxonomy system is well accepted as the standard. The Taxonomy Factories in bioperl access this system, through HTTP to NCBI Entrez, dump file, and advanced biosql database. Bio::Taxonomy::FactoryI defines all methods that all implementations must obey. $factory-Efetch is a general method to fetch Taxonomy by either NCBI taxid or any types of names. $factory-Efetch_parent($taxonomy), returns a Taxonomy that is one-step higher rank of the taxonomy specified as argument. $factory-Efetch_children($taxonomy), reports an array of Taxonomy those are one-step lower rank of the taxonomy specified as the argument. =head2 Usage of Taxonomy object ## =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 CONTACT Juguang Xiao, juguang@tll.org.sg =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # code begins... package Bio::Taxonomy; use strict; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::Taxonomy->new(); Function: Builds a new Bio::Taxonomy object Returns : Bio::Taxonomy Args : -method -> method used to decide classification (none|trust|lookup) -ranks -> what ranks are there =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->warn("Bio::Taxonomy is deprecated. Use Bio::Taxon in combination with Bio::Tree::Tree instead."); $self->{'_method'}='none'; $self->{'_ranks'}=[]; $self->{'_rank_hash'}={}; $self->{_hierarchy} = {}; # used to store the nodes, with ranks as keys. my ($method,$ranks,$order) = $self->_rearrange([qw(METHOD RANKS ORDER)], @args); if ($method) { $self->method($method); } if (defined $ranks && (ref($ranks) eq "ARRAY") ) { $self->ranks(@$ranks); } else { # default ranks # I think these are in the right order, but not sure: # some parvorder|suborder and varietas|subspecies seem # to be at the same level - any taxonomists? # I don't expect that these will actually be used except as a way # to find what ranks there are in taxonomic use $self->ranks(('root', 'superkingdom', 'kingdom', 'superphylum', 'phylum', 'subphylum', 'superclass', 'class', 'subclass', 'infraclass', 'superorder', 'order', 'suborder', 'parvorder', 'infraorder', 'superfamily', 'family', 'subfamily', 'tribe', 'subtribe', 'genus', 'subgenus', 'species group', 'species subgroup', 'species', 'subspecies', 'varietas', 'forma', 'no rank')); } return $self; } =head2 method Title : method Usage : $obj = taxonomy->method($method); Function: set or return the method used to decide classification Returns : $obj Args : $obj =cut sub method { my ($self,$value) = @_; if (defined $value && $value=~/none|trust|lookup/) { $self->{'_method'} = $value; } return $self->{'_method'}; } =head2 classify Title : classify Usage : @obj[][0-1] = taxonomy->classify($species); Function: return a ranked classification Returns : @obj of taxa and ranks as word pairs separated by "@" Args : Bio::Species object =cut sub classify { my ($self,$value) = @_; my @ranks; if (! $value->isa('Bio::Species') ) { $self->throw("Trying to classify $value which is not a Bio::Species object"); } my @classes=reverse($value->classification); if ($self->method eq 'none') { for (my $i=0; $i < @classes-2; $i++) { ($ranks[$i][0],$ranks[$i][1])=($classes[$i],'no rank'); } push @ranks,[$classes[-2],'genus']; push @ranks,[$value->binomial,'species']; } elsif ($self->method eq 'trust') { if (scalar(@classes)==scalar($self->ranks)) { for (my $i=0; $i < @classes; $i++) { if ($self->rank_of_number($i) eq 'species') { push @ranks,[$value->binomial,$self->rank_of_number($i)]; } else { push @ranks,[$classes[$i],$self->rank_of_number($i)]; } } } else { $self->throw("Species object and taxonomy object cannot be reconciled"); } } elsif ($self->method eq 'lookup') { # this will lookup a DB for the rank of a taxon name # I imagine that some kind of Bio::DB class will be need to # be given to the taxonomy object to act as an DB interface # (I'm not sure how useful this is though - if you have a DB of # taxonomy - why would you be doing things this way?) $self->throw_not_implemented(); } return @ranks; } =head2 level_of_rank Title : level_of_rank Usage : $obj = taxonomy->level_of_rank($obj); Function: returns the level of a rank name Returns : $obj Args : $obj =cut sub level_of { my ($self,$value) = @_; return $self->{'_rank_hash'}{$value}; } =head2 rank_of_number Title : rank_of_number Usage : $obj = taxonomy->rank_of_number($obj); Function: returns the rank name of a rank level Returns : $obj Args : $obj =cut sub rank_of_number { my ($self,$value) = @_; return ${$self->{'_ranks'}}[$value]; } =head2 ranks Title : ranks Usage : @obj = taxonomy->ranks(@obj); Function: set or return all ranks Returns : @obj Args : @obj =cut sub ranks { my ($self,@value) = @_; # currently this makes no uniqueness sanity check (this should be done) # I am think that adding a way of converting multiple 'no rank' ranks # to unique 'no rank #' ranks so that the level of a 'no rank' is # abstracted way from the user - I'm not sure of the value of this if (@value) { $self->{'_ranks'}=\@value; } for (my $i=0; $i <= @{$self->{'_ranks'}}-1; $i++) { $self->{'_rank_hash'}{$self->{'_ranks'}[$i]}=$i unless $self->{'_ranks'}[$i] eq 'no rank'; } return @{$self->{'_ranks'}}; } =head2 add_node Title: add_node Usage: $obj->add_node($node[, $node2, ...]); Function: add one or more Bio::Taxonomy::Node objects Returns: None Args: any number of Bio::Taxonomy::Node(s) =cut sub add_node { my ($self, @nodes) = @_; foreach(@nodes){ $self->throw("A Bio::Taxonomy::Node object needed") unless($_->isa('Bio::Taxonomy::Node')); my ($node, $rank) = ($_, $_->rank); if(exists $self->{_hierarchy}->{$rank}){ # $self->throw("$rank has been defined"); # print STDERR "RANK:$rank\n"; # return; } $self->{_hierarchy}->{$rank} = $node; } } =head2 binomial Title : binomial Usage : my $val = $obj->binomial; Function: returns the binomial name if this taxonomy reachs species level Returns : the binomial name OR undef if taxonmy does not reach species level Args : [No arguments] =cut sub binomial { my $self = shift; return $self->get_node('species')->scientific_name; my $genus = $self->get_node('genus'); my $species = $self->get_node('species'); return ($species && $genus) ? "$species $genus" : undef; } =head2 get_node Title : get_node Usage : $node = $taxonomy->get_node('species'); Function: get a Bio::Taxonomy::Node object according to rank name Returns : a Bio::Taxonomy::Node object or undef if null Args : a vaild rank name =cut sub get_node { my ($self, $rank) = @_; unless(grep /$rank/, keys %{$self->{_hierarchy}}){ $self->throw("'$rank' is not in the rank list"); } return (exists $self->{_hierarchy}->{$rank})? $self->{_hierarchy}->{$rank} : undef; } =head2 classification Title : classification Usage : @names = $taxonomy->classification; Function: get the classification names of one taxonomy Returns : array of names Args : [No arguments] =cut sub classification { my $self = shift; my %rank_hash = %{$self->{_rank_hash}}; my %hierarchy = %{$self->{_hierarchy}}; my @ordered_nodes = sort { ($rank_hash{$a} <=> $rank_hash{$b}) } keys %hierarchy; return map {$hierarchy{$_}->scientific_name} @ordered_nodes; } 1; BioPerl-1.6.923/Bio/TreeIO.pm000444000765000024 2031612254227324 15657 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::TreeIO # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO - Parser for Tree files =head1 SYNOPSIS { use Bio::TreeIO; my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 'globin.dnd'); while( my $tree = $treeio->next_tree ) { print "Tree is ", $tree->number_nodes, "\n"; } } =head1 DESCRIPTION This is the driver module for Tree reading from data streams and flatfiles. This is intended to be able to create Bio::Tree::TreeI objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Allen Day Eallenday@ucla.eduE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::TreeIO::TreeEventBuilder; use base qw(Bio::Root::Root Bio::Root::IO Bio::Event::EventGeneratorI Bio::Factory::TreeFactoryI); =head2 new Title : new Usage : my $obj = Bio::TreeIO->new(); Function: Builds a new Bio::TreeIO object Returns : Bio::TreeIO Args : a hash. useful keys: -format : Specify the format of the file. Supported formats: newick Newick tree format nexus Nexus tree format nhx NHX tree format svggraph SVG graphical representation of tree tabtree ASCII text representation of tree lintree lintree output format =cut sub new { my($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object?n my $obj; if( $class =~ /Bio::TreeIO::(\S+)/ ) { $obj = $class->SUPER::new(@args); $obj->_initialize(@args); } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{'-file'} || $ARGV[0] ) || 'newick'; $format = "\L$format"; # normalize capitalization to lower case # normalize capitalization return undef unless( $class->_load_format_module($format) ); $obj = "Bio::TreeIO::$format"->new(@args); } return $obj; } =head2 format Title : format Usage : $format = $obj->format() Function: Get the tree format Returns : tree format Args : none =cut # format() method inherited from Bio::Root::IO =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree; Function: Gets the next tree off the stream Returns : Bio::Tree::TreeI or undef if no more trees Args : none =cut sub next_tree{ my ($self) = @_; $self->throw("Cannot call method next_tree on Bio::TreeIO object must use a subclass"); } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Writes a tree onto the stream Returns : none Args : Bio::Tree::TreeI =cut sub write_tree{ my ($self,$tree) = @_; $self->throw("Cannot call method write_tree on Bio::TreeIO object must use a subclass"); } =head2 attach_EventHandler Title : attach_EventHandler Usage : $parser->attatch_EventHandler($handler) Function: Adds an event handler to listen for events Returns : none Args : Bio::Event::EventHandlerI =cut sub attach_EventHandler{ my ($self,$handler) = @_; return if( ! $handler ); if( ! $handler->isa('Bio::Event::EventHandlerI') ) { $self->warn("Ignoring request to attach handler ".ref($handler). ' because it is not a Bio::Event::EventHandlerI'); } $self->{'_handler'} = $handler; return; } =head2 _eventHandler Title : _eventHandler Usage : private Function: Get the EventHandler Returns : Bio::Event::EventHandlerI Args : none =cut sub _eventHandler{ my ($self) = @_; return $self->{'_handler'}; } sub _initialize { my($self, @args) = @_; $self->{'_handler'} = undef; $self->get_params; # Initialize the default parameters. my ($nen,$ini) = $self->_rearrange ([qw(NEWLINE_EACH_NODE INTERNAL_NODE_ID)],@args); $self->set_param('newline_each_node',$nen); $self->set_param('internal_node_id',$ini); $self->attach_EventHandler(Bio::TreeIO::TreeEventBuilder->new (-verbose => $self->verbose(), @args)); $self->_initialize_io(@args); #$self->debug_params; } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL TreeIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::TreeIO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <get_params->{$param} = $value; } return $self->get_params->{$param}; } sub set_param { my $self = shift; my $param = shift; my $value = shift; #print STDERR "[$param] -> [undef]\n" if (!defined $value); return unless (defined $value); #print STDERR "[$param] -> [$value]\n"; $self->get_params->{$param} = $value; return $self->param($param); } sub params { my $self = shift; return $self->get_params; } sub get_params { my $self = shift; if (!defined $self->{_params}) { $self->{_params} = $self->get_default_params; } return $self->{_params}; } sub set_params { my $self = shift; my $params = shift; # Apply all the passed parameters to our internal parm hashref. my $cur_params = $self->get_params; $self->{_params} = { %$cur_params, %$params }; return $self->get_params; } sub get_default_params { my $self = shift; return {}; } sub debug_params { my $self = shift; my $params = $self->get_params; print STDERR "{\n"; foreach my $param (keys %$params) { my $value = $params->{$param}; print STDERR " [$param] -> [$value]\n"; } print STDERR "}\n"; } =head2 _guess_format Title : _guess_format Usage : $obj->_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'newick' if /\.(dnd|newick|nh)$/i; return 'nhx' if /\.(nhx)$/i; return 'phyloxml' if /\.(xml)$/i; return 'svggraph' if /\.svg$/i; return 'lintree' if( /\.(lin|lintree)$/i ); } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my $class = shift; return bless {'treeio' => shift},$class; } sub READLINE { my $self = shift; return $self->{'treeio'}->next_tree() unless wantarray; my (@list,$obj); push @list,$obj while $obj = $self->{'treeio'}->next_tree(); return @list; } sub PRINT { my $self = shift; $self->{'treeio'}->write_tree(@_); } 1; BioPerl-1.6.923/Bio/UpdateableSeqI.pm000444000765000024 662412254227326 17350 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::UpdateableSeqI # # Please direct questions and support issues to # # Cared for by David Block # # Copyright David Block # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::UpdateableSeqI - Descendant of Bio::SeqI that allows updates =head1 SYNOPSIS See Bio::SeqI for most of the documentation. See the documentation of the methods for further details. =head1 DESCRIPTION Bio::UpdateableSeqI is an interface for Sequence objects which are expected to allow users to perform basic editing functions (update/delete) on their component SeqFeatures. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - David Block Email dblock@gene.pbi.nrc.ca =head1 CONTRIBUTORS Ewan Birney forced me to this... =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::UpdateableSeqI; use strict; use Carp; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SeqI); =head2 delete_feature Title : delete_feature Usage : my $orphanlist=$self->delete_feature($feature,$transcript,$gene); Function: deletes the specified $feature from the given transcript, if $transcript is sent and exists and $feature is a feature of $transcript, or from $gene if the $feature is a feature of $gene, or from $self if $transcript and $gene are not sent. Keeps track of the features of the $gene object that may be left as orphans and returns them as a listref. Example : I want to delete transcript 'abc' of gene 'def', with three exons, leaving only transcript 'ghi' with two exons. This will leave exons 1 and 3 part of 'ghi', but exon 2 will become an orphan. my $orphanlist=$seq->delete_feature($transcript{'abc'},undef,$gene{'def'}); $orphanlist is a reference to a list containing $exon{'2'}; Returns : a listref of orphaned features after the deletion of $feature (optional) Args : $feature - the feature to be deleted $transcript - the transcript containing the $feature, so that a $feature can be removed from only one transcript when there are multiple transcripts in a gene. $gene - the gene containing the $transcript and/or the $feature =cut sub delete_feature{ my ($self,$feature,$transcript,$gene) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/WebAgent.pm000444000765000024 1204312254227314 16221 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::WebAgent # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # For copyright and disclaimer see below. # # POD documentation - main docs before the code =head1 NAME Bio::WebAgent - A base class for Web (any protocol) access =head1 SYNOPSIS # This is a abstract superclass for bioperl modules accessing web # resources - normally you do not instantiate it but one of its # subclasess. =head1 DESCRIPTION This abstract superclass is a subclass of L which allows protocol independent access of remote locations over the Net. It takes care of error handling, proxies and various net protocols. BioPerl classes accessing the net should inherit from it. For details, see L. The interface is still evolving. For now, two public methods have been copied from Bio::DB::WebDBSeqI: delay() and delay_policy. These are used to prevent overwhelming the server by rapidly repeated . Ideally there should be a common abstract superclass with these. See L. =head1 SEE ALSO L, L, =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 COPYRIGHT Copyright (c) 2003, Heikki Lehvaslaiho and EMBL-EBI. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::WebAgent; use vars qw($LAST_INVOCATION_TIME); use strict; use base qw(LWP::UserAgent Bio::Root::Root); sub new { my $class = shift; # We make env_proxy the default here, but it can be # over-ridden by $self->env_proxy later, # or by new(env_proxy=>0) at constructor time my $self = $class->SUPER::new(env_proxy => 1); while( @_ ) { my $key = shift; $key =~ s/^-//; my $value = shift; $self->can($key) || next; $self->$key($value); } return $self; # success - we hope! } # ----------------------------------------------------------------------------- =head2 url Usage : $agent->url Returns : URL to reach out to Net Args : string =cut sub url { my ($self,$value) = @_; if( defined $value) { $self->{'_url'} = $value; } return $self->{'_url'}; } =head2 delay Title : delay Usage : $secs = $self->delay([$secs]) Function: get/set number of seconds to delay between fetches Returns : number of seconds to delay Args : new value NOTE: the default is to use the value specified by delay_policy(). This can be overridden by calling this method, or by passing the -delay argument to new(). =cut sub delay { my ($self, $value) = @_; if ($value) { $self->throw("Need a positive integer, not [$value]") unless $value >= 0; $self->{'_delay'} = int $value; } return $self->{'_delay'} || $self->delay_policy; } =head2 delay_policy Title : delay_policy Usage : $secs = $self->delay_policy Function: return number of seconds to delay between calls to remote db Returns : number of seconds to delay Args : none NOTE: The default delay policy is 3s. Override in subclasses to implement other delays. The timer has only second resolution, so the delay will actually be +/- 1s. =cut sub delay_policy { my $self = shift; return 3; } =head2 sleep Title : sleep Usage : $self->sleep Function: sleep for a number of seconds indicated by the delay policy Returns : none Args : none NOTE: This method keeps track of the last time it was called and only imposes a sleep if it was called more recently than the delay_policy() allows. =cut sub sleep { my $self = shift; $LAST_INVOCATION_TIME ||= 0; if (time - $LAST_INVOCATION_TIME < $self->delay) { my $delay = $self->delay - (time - $LAST_INVOCATION_TIME); $self->debug("sleeping for $delay seconds\n"); sleep $delay; } $LAST_INVOCATION_TIME = time; } 1; __END__ BioPerl-1.6.923/Bio/Align000755000765000024 012254227340 15043 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Align/AlignI.pm000444000765000024 4713612254227340 16734 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Align::AlignI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Align::AlignI - An interface for describing sequence alignments. =head1 SYNOPSIS # get a Bio::Align::AlignI somehow - typically using Bio::AlignIO system # some descriptors print $aln->length, "\n"; print $aln->num_residues, "\n"; print $aln->is_flush, "\n"; print $aln->num_sequences, "\n"; print $aln->percentage_identity, "\n"; print $aln->consensus_string(50), "\n"; # find the position in the alignment for a sequence location $pos = $aln->column_from_residue_number('1433_LYCES', 14); # = 6; # extract sequences and check values for the alignment column $pos foreach $seq ($aln->each_seq) { $res = $seq->subseq($pos, $pos); $count{$res}++; } foreach $res (keys %count) { printf "Res: %s Count: %2d\n", $res, $count{$res}; } =head1 DESCRIPTION This interface describes the basis for alignment objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Ewan Birney, birney@ebi.ac.uk Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Align::AlignI; use strict; use base qw(Bio::Root::RootI); =head1 Modifier methods These methods modify the MSE by adding, removing or shuffling complete sequences. =head2 add_seq Title : add_seq Usage : $myalign->add_seq($newseq); Function : Adds another sequence to the alignment. *Does not* align it - just adds it to the hashes. Returns : None Argument : a Bio::LocatableSeq object order (optional) See L for more information. =cut sub add_seq { my ($self) = @_; $self->throw_not_implemented(); } =head2 remove_seq Title : remove_seq Usage : $aln->remove_seq($seq); Function : Removes a single sequence from an alignment Returns : Argument : a Bio::LocatableSeq object =cut sub remove_seq { my ($self) = @_; $self->throw_not_implemented(); } =head2 purge Title : purge Usage : $aln->purge(0.7); Function: Removes sequences above whatever %id. This function will grind on large alignments. Beware! (perhaps not ideally implemented) Example : Returns : An array of the removed sequences Argument: =cut sub purge { my ($self) = @_; $self->throw_not_implemented(); } =head2 sort_alphabetically Title : sort_alphabetically Usage : $ali->sort_alphabetically Function : Changes the order of the alignment to alphabetical on name followed by numerical by number. Returns : an array Argument : =cut sub sort_alphabetically { my ($self) = @_; $self->throw_not_implemented(); } =head1 Sequence selection methods Methods returning one or more sequences objects. =head2 each_seq Title : each_seq Usage : foreach $seq ( $align->each_seq() ) Function : Gets an array of Seq objects from the alignment Returns : an array Argument : =cut sub each_seq { my ($self) = @_; $self->throw_not_implemented(); } =head2 each_alphabetically Title : each_alphabetically Usage : foreach $seq ( $ali->each_alphabetically() ) Function : Returns an array of sequence object sorted alphabetically by name and then by start point. Does not change the order of the alignment Returns : Argument : =cut sub each_alphabetically { my($self) = @_; $self->throw_not_implemented(); } =head2 each_seq_with_id Title : each_seq_with_id Usage : foreach $seq ( $align->each_seq_with_id() ) Function : Gets an array of Seq objects from the alignment, the contents being those sequences with the given name (there may be more than one) Returns : an array Argument : a seq name =cut sub each_seq_with_id { my ($self) = @_; $self->throw_not_implemented(); } =head2 get_seq_by_pos Title : get_seq_by_pos Usage : $seq = $aln->get_seq_by_pos(3) # third sequence from the alignment Function : Gets a sequence based on its position in the alignment. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Returns : a Bio::LocatableSeq object Argument : positive integer for the sequence position =cut sub get_seq_by_pos { my ($self) = @_; $self->throw_not_implemented(); } =head1 Create new alignments The result of these methods are horizontal or vertical subsets of the current MSE. =head2 select Title : select Usage : $aln2 = $aln->select(1, 3) # three first sequences Function : Creates a new alignment from a continuous subset of sequences. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Returns : a Bio::SimpleAlign object Argument : positive integer for the first sequence positive integer for the last sequence to include (optional) =cut sub select { my ($self) = @_; $self->throw_not_implemented(); } =head2 select_noncont Title : select_noncont Usage : $aln2 = $aln->select_noncont(1, 3) # first and 3rd sequences Function : Creates a new alignment from a subset of sequences. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Returns : a Bio::SimpleAlign object Args : array of integers for the sequences =cut sub select_noncont { my ($self) = @_; $self->throw_not_implemented(); } =head2 slice Title : slice Usage : $aln2 = $aln->slice(20, 30) Function : Creates a slice from the alignment inclusive of start and end columns. Sequences with no residues in the slice are excluded from the new alignment and a warning is printed. Slice beyond the length of the sequence does not do padding. Returns : a Bio::SimpleAlign object Argument : positive integer for start column positive integer for end column =cut sub slice { my ($self) = @_; $self->throw_not_implemented(); } =head1 Change sequences within the MSE These methods affect characters in all sequences without changing the alignment. =head2 map_chars Title : map_chars Usage : $ali->map_chars('\.','-') Function : Does a s/$arg1/$arg2/ on the sequences. Useful for gap characters Notice that the from (arg1) is interpreted as a regex, so be careful about quoting meta characters (eg $ali->map_chars('.','-') wont do what you want) Returns : None Argument : 'from' rexexp 'to' string =cut sub map_chars { my ($self) = @_; $self->throw_not_implemented(); } =head2 uppercase Title : uppercase() Usage : $ali->uppercase() Function : Sets all the sequences to uppercase Returns : Argument : =cut sub uppercase { my ($self) = @_; $self->throw_not_implemented(); } =head2 match_line Title : match_line() Usage : $align->match_line() Function : Generates a match line - much like consensus string except that a line indicating the '*' for a match. Argument : (optional) Match line characters ('*' by default) (optional) Strong match char (':' by default) (optional) Weak match char ('.' by default) =cut sub match_line { my ($self) = @_; $self->throw_not_implemented(); } =head2 match Title : match() Usage : $ali->match() Function : Goes through all columns and changes residues that are identical to residue in first sequence to match '.' character. Sets match_char. USE WITH CARE: Most MSE formats do not support match characters in sequences, so this is mostly for output only. NEXUS format (Bio::AlignIO::nexus) can handle it. Returns : 1 Argument : a match character, optional, defaults to '.' =cut sub match { my ($self) = @_; $self->throw_not_implemented(); } =head2 unmatch Title : unmatch() Usage : $ali->unmatch() Function : Undoes the effect of method match. Unsets match_char. Returns : 1 Argument : a match character, optional, defaults to '.' =cut sub unmatch { my ($self) = @_; $self->throw_not_implemented(); } =head1 MSE attibutes Methods for setting and reading the MSE attributes. Note that the methods defining character semantics depend on the user to set them sensibly. They are needed only by certain input/output methods. Unset them by setting to an empty string (''). =head2 id Title : id Usage : $myalign->id("Ig") Function : Gets/sets the id field of the alignment Returns : An id string Argument : An id string (optional) =cut sub id { my ($self) = @_; $self->throw_not_implemented(); } =head2 missing_char Title : missing_char Usage : $myalign->missing_char("?") Function : Gets/sets the missing_char attribute of the alignment It is generally recommended to set it to 'n' or 'N' for nucleotides and to 'X' for protein. Returns : An missing_char string, Argument : An missing_char string (optional) =cut sub missing_char { my ($self) = @_; $self->throw_not_implemented(); } =head2 match_char Title : match_char Usage : $myalign->match_char('.') Function : Gets/sets the match_char attribute of the alignment Returns : An match_char string, Argument : An match_char string (optional) =cut sub match_char { my ($self) = @_; $self->throw_not_implemented(); } =head2 gap_char Title : gap_char Usage : $myalign->gap_char('-') Function : Gets/sets the gap_char attribute of the alignment Returns : An gap_char string, defaults to '-' Argument : An gap_char string (optional) =cut sub gap_char { my ($self) = @_; $self->throw_not_implemented(); } =head2 symbol_chars Title : symbol_chars Usage : my @symbolchars = $aln->symbol_chars; Function: Returns all the seen symbols (other than gaps) Returns : array of characters that are the seen symbols Argument: boolean to include the gap/missing/match characters =cut sub symbol_chars{ my ($self) = @_; $self->throw_not_implemented(); } =head1 Alignment descriptors These read only methods describe the MSE in various ways. =head2 consensus_string Title : consensus_string Usage : $str = $ali->consensus_string($threshold_percent) Function : Makes a strict consensus Returns : consensus string Argument : Optional threshold ranging from 0 to 100. The consensus residue has to appear at least threshold % of the sequences at a given location, otherwise a '?' character will be placed at that location. (Default value = 0%) =cut sub consensus_string { my ($self) = @_; $self->throw_not_implemented(); } =head2 consensus_iupac Title : consensus_iupac Usage : $str = $ali->consensus_iupac() Function : Makes a consensus using IUPAC ambiguity codes from DNA and RNA. The output is in upper case except when gaps in a column force output to be in lower case. Note that if your alignment sequences contain a lot of IUPAC ambiquity codes you often have to manually set alphabet. Bio::PrimarySeq::_guess_type thinks they indicate a protein sequence. Returns : consensus string Argument : none Throws : on protein sequences =cut sub consensus_iupac { my ($self) = @_; $self->throw_not_implemented(); } =head2 is_flush Title : is_flush Usage : if( $ali->is_flush() ) : : Function : Tells you whether the alignment : is flush, ie all of the same length : : Returns : 1 or 0 Argument : =cut sub is_flush { my ($self) = @_; $self->throw_not_implemented(); } =head2 length Title : length() Usage : $len = $ali->length() Function : Returns the maximum length of the alignment. To be sure the alignment is a block, use is_flush Returns : integer Argument : =cut sub length { my ($self) = @_; $self->throw_not_implemented(); } =head2 maxname_length Title : maxname_length Usage : $ali->maxname_length() Function : Gets the maximum length of the displayname in the alignment. Used in writing out various MSE formats. Returns : integer Argument : =cut sub maxname_length { my ($self) = @_; $self->throw_not_implemented(); } =head2 num_residues Title : num_residues Usage : $no = $ali->num_residues Function : number of residues in total in the alignment Returns : integer Argument : Note : replaces no_residues =cut sub num_residues { my ($self) = @_; $self->throw_not_implemented(); } =head2 num_sequences Title : num_sequences Usage : $depth = $ali->num_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : None Note : replaces no_sequences =cut sub num_sequences { my ($self) = @_; $self->throw_not_implemented(); } =head2 percentage_identity Title : percentage_identity Usage : $id = $align->percentage_identity Function: The function calculates the percentage identity of the alignment Returns : The percentage identity of the alignment (as defined by the implementation) Argument: None =cut sub percentage_identity{ my ($self) = @_; $self->throw_not_implemented(); } =head2 overall_percentage_identity Title : overall_percentage_identity Usage : $id = $align->overall_percentage_identity Function: The function calculates the percentage identity of the conserved columns Returns : The percentage identity of the conserved columns Args : None =cut sub overall_percentage_identity{ my ($self) = @_; $self->throw_not_implemented(); } =head2 average_percentage_identity Title : average_percentage_identity Usage : $id = $align->average_percentage_identity Function: The function uses a fast method to calculate the average percentage identity of the alignment Returns : The average percentage identity of the alignment Args : None =cut sub average_percentage_identity{ my ($self) = @_; $self->throw_not_implemented(); } =head1 Alignment positions Methods to map a sequence position into an alignment column and back. column_from_residue_number() does the former. The latter is really a property of the sequence object and can done using L: # select somehow a sequence from the alignment, e.g. my $seq = $aln->get_seq_by_pos(1); #$loc is undef or Bio::LocationI object my $loc = $seq->location_from_column(5); =head2 column_from_residue_number Title : column_from_residue_number Usage : $col = $ali->column_from_residue_number( $seqname, $resnumber) Function: This function gives the position in the alignment (i.e. column number) of the given residue number in the sequence with the given name. For example, for the alignment Seq1/91-97 AC..DEF.GH Seq2/24-30 ACGG.RTY.. Seq3/43-51 AC.DDEFGHI column_from_residue_number( "Seq1", 94 ) returns 6. column_from_residue_number( "Seq2", 25 ) returns 2. column_from_residue_number( "Seq3", 50 ) returns 9. An exception is thrown if the residue number would lie outside the length of the alignment (e.g. column_from_residue_number( "Seq2", 22 ) Note: If the parent sequence is represented by more than one alignment sequence and the residue number is present in them, this method finds only the first one. Returns : A column number for the position in the alignment of the given residue in the given sequence (1 = first column) Args : A sequence id/name (not a name/start-end) A residue number in the whole sequence (not just that segment of it in the alignment) =cut sub column_from_residue_number { my ($self) = @_; $self->throw_not_implemented(); } =head1 Sequence names Methods to manipulate the display name. The default name based on the sequence id and subsequence positions can be overridden in various ways. =head2 displayname Title : displayname Usage : $myalign->displayname("Ig", "IgA") Function : Gets/sets the display name of a sequence in the alignment : Returns : A display name string Argument : name of the sequence displayname of the sequence (optional) =cut sub displayname { my ($self) = @_; $self->throw_not_implemented(); } =head2 set_displayname_count Title : set_displayname_count Usage : $ali->set_displayname_count Function : Sets the names to be name_# where # is the number of times this name has been used. Returns : None Argument : None =cut sub set_displayname_count { my ($self) = @_; $self->throw_not_implemented(); } =head2 set_displayname_flat Title : set_displayname_flat Usage : $ali->set_displayname_flat() Function : Makes all the sequences be displayed as just their name, not name/start-end Returns : 1 Argument : None =cut sub set_displayname_flat { my ($self) = @_; $self->throw_not_implemented(); } =head2 set_displayname_normal Title : set_displayname_normal Usage : $ali->set_displayname_normal() Function : Makes all the sequences be displayed as name/start-end Returns : None Argument : None =cut sub set_displayname_normal { my ($self) = @_; $self->throw_not_implemented(); } =head1 Deprecated methods =head2 no_residues Title : no_residues Usage : $no = $ali->no_residues Function : number of residues in total in the alignment Returns : integer Argument : Note : deprecated in favor of num_residues() =cut sub no_residues { # immediate deprecation shift->deprecated(); } =head2 no_sequences Title : no_sequences Usage : $depth = $ali->no_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : None Note : deprecated in favor of num_sequences() =cut sub no_sequences { # immediate deprecation shift->deprecated(); } 1; BioPerl-1.6.923/Bio/Align/DNAStatistics.pm000444000765000024 14366512254227315 20274 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Align::DNAStatistics # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Align::DNAStatistics - Calculate some statistics for a DNA alignment =head1 SYNOPSIS use Bio::AlignIO; use Bio::Align::DNAStatistics; my $stats = Bio::Align::DNAStatistics->new(); my $alignin = Bio::AlignIO->new(-format => 'emboss', -file => 't/data/insulin.water'); my $aln = $alignin->next_aln; my $jcmatrix = $stats->distance(-align => $aln, -method => 'Jukes-Cantor'); print $jcmatrix->print_matrix; ## and for measurements of synonymous /nonsynonymous substitutions ## my $in = Bio::AlignIO->new(-format => 'fasta', -file => 't/data/nei_gojobori_test.aln'); my $alnobj = $in->next_aln; my ($seq1id,$seq2id) = map { $_->display_id } $alnobj->each_seq; my $results = $stats->calc_KaKs_pair($alnobj, $seq1id, $seq2id); print "comparing ".$results->[0]{'Seq1'}." and ".$results->[0]{'Seq2'}."\n"; for (sort keys %{$results->[0]} ){ next if /Seq/; printf("%-9s %.4f \n",$_ , $results->[0]{$_}); } my $results2 = $stats->calc_all_KaKs_pairs($alnobj); for my $an (@$results2){ print "comparing ". $an->{'Seq1'}." and ". $an->{'Seq2'}. " \n"; for (sort keys %$an ){ next if /Seq/; printf("%-9s %.4f \n",$_ , $an->{$_}); } print "\n\n"; } my $result3 = $stats->calc_average_KaKs($alnobj, 1000); for (sort keys %$result3 ){ next if /Seq/; printf("%-9s %.4f \n",$_ , $result3->{$_}); } =head1 DESCRIPTION This object contains routines for calculating various statistics and distances for DNA alignments. The routines are not well tested and do contain errors at this point. Work is underway to correct them, but do not expect this code to give you the right answer currently! Use dnadist/distmat in the PHLYIP or EMBOSS packages to calculate the distances. Several different distance method calculations are supported. Listed in brackets are the pattern which will match =over 3 =item * JukesCantor [jc|jukes|jukescantor|jukes-cantor] =item * Uncorrected [jcuncor|uncorrected] =item * F81 [f81|felsenstein] =item * Kimura [k2|k2p|k80|kimura] =item * Tamura [t92|tamura|tamura92] =item * F84 [f84|felsenstein84] =item * TajimaNei [tajimanei|tajima\-nei] =item * JinNei [jinnei|jin\-nei] (not implemented) =back There are also three methods to calculate the ratio of synonymous to non-synonymous mutations. All are implementations of the Nei-Gojobori evolutionary pathway method and use the Jukes-Cantor method of nucleotide substitution. This method works well so long as the nucleotide frequencies are roughly equal and there is no significant transition/transversion bias. In order to use these methods there are several pre-requisites for the alignment. =over 3 =item 1 DNA alignment must be based on protein alignment. Use the subroutine L to achieve this. =item 2 Therefore alignment gaps must be in multiples of 3 (representing an aa deletion/insertion) and at present must be indicated by a '-' symbol. =item 3 Alignment must be solely of coding region and be in reading frame 0 to achieve meaningful results =item 4 Alignment must therefore be a multiple of 3 nucleotides long. =item 5 All sequences must be the same length (including gaps). This should be the case anyway if the sequences have been automatically aligned using a program like Clustal. =item 6 Only the standard codon alphabet is supported at present. =back calc_KaKs_pair() calculates a number of statistics for a named pair of sequences in the alignment. calc_all_KaKs_pairs() calculates these statistics for all pairwise comparisons in an MSA. The statistics returned are: =over 3 =item * S_d - Number of synonymous mutations between the 2 sequences. =item * N_d - Number of non-synonymous mutations between the 2 sequences. =item * S - Mean number of synonymous sites in both sequences. =item * N - mean number of synonymous sites in both sequences. =item * P_s - proportion of synonymous differences in both sequences given by P_s = S_d/S. =item * P_n - proportion of non-synonymous differences in both sequences given by P_n = S_n/S. =item * D_s - estimation of synonymous mutations per synonymous site (by Jukes-Cantor). =item * D_n - estimation of non-synonymous mutations per non-synonymous site (by Jukes-Cantor). =item * D_n_var - estimation of variance of D_n . =item * D_s_var - estimation of variance of S_n. =item * z_value - calculation of z value.Positive value indicates D_n E D_s, negative value indicates D_s E D_n. =back The statistics returned by calc_average_KaKs are: =over 3 =item * D_s - Average number of synonymous mutations/synonymous site. =item * D_n - Average number of non-synonymous mutations/non-synonymous site. =item * D_s_var - Estimated variance of Ds from bootstrapped alignments. =item * D_n_var - Estimated variance of Dn from bootstrapped alignments. =item * z_score - calculation of z value. Positive value indicates D_n ED_s, negative values vice versa. =back The design of the code is based around the explanation of the Nei-Gojobori algorithm in the excellent book "Molecular Evolution and Phylogenetics" by Nei and Kumar, published by Oxford University Press. The methods have been tested using the worked example 4.1 in the book, and reproduce those results. If people like having this sort of analysis in BioPerl other methods for estimating Ds and Dn can be provided later. Much of the DNA distance code is based on implementations in EMBOSS (Rice et al, www.emboss.org) [distmat.c] and PHYLIP (J. Felsenstein et al) [dnadist.c]. Insight also gained from Eddy, Durbin, Krogh, & Mitchison. =head1 REFERENCES =over 3 =item * D_JukesCantor "Phylogenetic Inference", Swoffrod, Olsen, Waddell and Hillis, in Mol. Systematics, 2nd ed, 1996, Ch 11. Derived from "Evolution of Protein Molecules", Jukes & Cantor, in Mammalian Prot. Metab., III, 1969, pp. 21-132. =item * D_Tamura K Tamura, Mol. Biol. Evol. 1992, 9, 678. =item * D_Kimura M Kimura, J. Mol. Evol., 1980, 16, 111. =item * JinNei Jin and Nei, Mol. Biol. Evol. 82, 7, 1990. =item * D_TajimaNei Tajima and Nei, Mol. Biol. Evol. 1984, 1, 269. =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-AT-bioperl.org =head1 CONTRIBUTORS Richard Adams, richard.adams@ed.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Align::DNAStatistics; use vars qw(%DNAChanges @Nucleotides %NucleotideIndexes $GapChars $SeqCount $DefaultGapPenalty %DistanceMethods $CODONS %synchanges $synsites $Precision $GCChhars); use strict; use Bio::Align::PairwiseStatistics; use Bio::Matrix::PhylipDist; use Bio::Tools::IUPAC; BEGIN { $GapChars = '[\.\-]'; $GCChhars = '[GCS]'; @Nucleotides = qw(A G T C); $SeqCount = 2; $Precision = 5; # these values come from EMBOSS distmat implementation %NucleotideIndexes = ( 'A' => 0, 'T' => 1, 'C' => 2, 'G' => 3, 'AT' => 0, 'AC' => 1, 'AG' => 2, 'CT' => 3, 'GT' => 4, 'CG' => 5, # these are wrong now # 'S' => [ 1, 3], # 'W' => [ 0, 4], # 'Y' => [ 2, 3], # 'R' => [ 0, 1], # 'M' => [ 0, 3], # 'K' => [ 1, 2], # 'B' => [ 1, 2, 3], # 'H' => [ 0, 2, 3], # 'V' => [ 0, 1, 3], # 'D' => [ 0, 1, 2], ); $DefaultGapPenalty = 0; # could put ambiguities here? %DNAChanges = ( 'Transversions' => { 'A' => [ 'T', 'C'], 'T' => [ 'A', 'G'], 'C' => [ 'A', 'G'], 'G' => [ 'C', 'T'], }, 'Transitions' => { 'A' => [ 'G' ], 'G' => [ 'A' ], 'C' => [ 'T' ], 'T' => [ 'C' ], }, ); %DistanceMethods = ( 'jc|jukes|jukescantor|jukes\-cantor' => 'JukesCantor', 'jcuncor|uncorrected' => 'Uncorrected', 'f81|felsenstein81' => 'F81', 'k2|k2p|k80|kimura' => 'Kimura', 't92|tamura|tamura92' => 'Tamura', 'f84|felsenstein84' => 'F84', 'tajimanei|tajima\-nei' => 'TajimaNei', 'jinnei|jin\-nei' => 'JinNei'); } use base qw(Bio::Root::Root Bio::Align::StatisticsI); ## generate look up hashes for Nei_Gojobori methods## $CODONS = get_codons(); my @t = split '', "FFLLSSSSYY**CC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG"; #create look up hash of number of possible synonymous mutations per codon $synsites = get_syn_sites(); #create reference look up hash of single basechanges in codons %synchanges = get_syn_changes(); =head2 new Title : new Usage : my $obj = Bio::Align::DNAStatistics->new(); Function: Builds a new Bio::Align::DNAStatistics object Returns : Bio::Align::DNAStatistics Args : none =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->pairwise_stats( Bio::Align::PairwiseStatistics->new()); return $self; } =head2 distance Title : distance Usage : my $distance_mat = $stats->distance(-align => $aln, -method => $method); Function: Calculates a distance matrix for all pairwise distances of sequences in an alignment. Returns : L object Args : -align => Bio::Align::AlignI object -method => String specifying specific distance method (implementing class may assume a default) See also: L =cut sub distance{ my ($self,@args) = @_; my ($aln,$method) = $self->_rearrange([qw(ALIGN METHOD)],@args); if( ! defined $aln || ! ref ($aln) || ! $aln->isa('Bio::Align::AlignI') ) { $self->throw("Must supply a valid Bio::Align::AlignI for the -align parameter in distance"); } $method ||= 'JukesCantor'; foreach my $m ( keys %DistanceMethods ) { if(defined $m && $method =~ /$m/i ) { my $mtd = "D_$DistanceMethods{$m}"; return $self->$mtd($aln); } } $self->warn("Unrecognized distance method $method must be one of [". join(',',$self->available_distance_methods())."]"); return; } =head2 available_distance_methods Title : available_distance_methods Usage : my @methods = $stats->available_distance_methods(); Function: Enumerates the possible distance methods Returns : Array of strings Args : none =cut sub available_distance_methods{ my ($self,@args) = @_; return values %DistanceMethods; } =head2 D - distance methods =cut =head2 D_JukesCantor Title : D_JukesCantor Usage : my $d = $stat->D_JukesCantor($aln) Function: Calculates D (pairwise distance) between 2 sequences in an alignment using the Jukes-Cantor 1 parameter model. Returns : L Args : L of DNA sequences double - gap penalty =cut sub D_JukesCantor{ my ($self,$aln,$gappenalty) = @_; return 0 unless $self->_check_arg($aln); $gappenalty = $DefaultGapPenalty unless defined $gappenalty; # ambiguities ignored at this point my (@seqs,@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id; push @seqs, uc $seq->seq(); $seqct++; } my $precisionstr = "%.$Precision"."f"; for(my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { my ($matrix,$pfreq,$gaps) = $self->_build_nt_matrix($seqs[$i], $seqs[$j]); # just want diagonals my $m = ( $matrix->[0]->[0] + $matrix->[1]->[1] + $matrix->[2]->[2] + $matrix->[3]->[3] ); my $D = 1 - ( $m / ($aln->length - $gaps + ( $gaps * $gappenalty))); my $d = (- 3 / 4) * log ( 1 - (4 * $D/ 3)); # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$d); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values); } =head2 D_F81 Title : D_F81 Usage : my $d = $stat->D_F81($aln) Function: Calculates D (pairwise distance) between 2 sequences in an alignment using the Felsenstein 1981 distance model. Relaxes the assumption of equal base frequencies that is in JC. Returns : L Args : L of DNA sequences =cut sub D_F81{ my ($self,$aln,$gappenalty) = @_; return 0 unless $self->_check_arg($aln); $gappenalty = $DefaultGapPenalty unless defined $gappenalty; # ambiguities ignored at this point my (@seqs,@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id;; push @seqs, uc $seq->seq(); $seqct++; } my $precisionstr = "%.$Precision"."f"; for(my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { my ($matrix,$pfreq,$gaps) = $self->_build_nt_matrix($seqs[$i], $seqs[$j]); # just want diagonals my $m = ( $matrix->[0]->[0] + $matrix->[1]->[1] + $matrix->[2]->[2] + $matrix->[3]->[3] ); my $D = 1 - ( $m / ($aln->length - $gaps + ( $gaps * $gappenalty))); my $d = (- 3 / 4) * log ( 1 - (4 * $D/ 3)); # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$d); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values); } =head2 D_Uncorrected Title : D_Uncorrected Usage : my $d = $stats->D_Uncorrected($aln) Function: Calculate a distance D, no correction for multiple substitutions is used. In rare cases where sequences may not overlap, 'NA' is substituted for the distance. Returns : L Args : L (DNA Alignment) [optional] gap penalty =cut sub D_Uncorrected { my ($self,$aln,$gappenalty) = @_; $gappenalty = $DefaultGapPenalty unless defined $gappenalty; return 0 unless $self->_check_arg($aln); # ambiguities ignored at this point my (@seqs,@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id; push @seqs, uc $seq->seq(); $seqct++; } my $precisionstr = "%.$Precision"."f"; my $len = $aln->length; for( my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { my ($matrix,$pfreq,$gaps) = $self->_build_nt_matrix($seqs[$i], $seqs[$j]); my $m = ( $matrix->[0]->[0] + $matrix->[1]->[1] + $matrix->[2]->[2] + $matrix->[3]->[3] ); my $denom = ( $len - $gaps + ( $gaps * $gappenalty)); $self->warn("No distance calculated between $names[$i] and $names[$j], inserting -1") unless $denom; my $D = $denom ? 1 - ( $m / $denom) : -1; # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = $denom ? sprintf($precisionstr,$D) : sprintf("%-*s", $Precision + 2, $D); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values); } # M Kimura, J. Mol. Evol., 1980, 16, 111. =head2 D_Kimura Title : D_Kimura Usage : my $d = $stat->D_Kimura($aln) Function: Calculates D (pairwise distance) between all pairs of sequences in an alignment using the Kimura 2 parameter model. Returns : L Args : L of DNA sequences =cut sub D_Kimura { my ($self,$aln) = @_; return 0 unless $self->_check_arg($aln); # ambiguities ignored at this point my (@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id; $seqct++; } my $precisionstr = "%.$Precision"."f"; for( my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { my $pairwise = $aln->select_noncont($i+1,$j+1); my $L = $self->pairwise_stats->number_of_comparable_bases($pairwise); unless( $L ) { $L = 1; } my $P = $self->transitions($pairwise) / $L; my $Q = $self->transversions($pairwise) / $L; my $K = 0; my $denom = ( 1 - (2 * $P) - $Q); if( $denom == 0 ) { $self->throw("cannot find distance for ",$i+1, ",",$j+1," $P, $Q\n"); } my $a = 1 / ( 1 - (2 * $P) - $Q); my $b = 1 / ( 1 - 2 * $Q ); if( $a < 0 || $b < 0 ) { $K = -1; } else{ $K = (1/2) * log ( $a ) + (1/4) * log($b); } # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$K); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values); } =head2 D_Kimura_variance Title : D_Kimura Usage : my $d = $stat->D_Kimura_variance($aln) Function: Calculates D (pairwise distance) between all pairs of sequences in an alignment using the Kimura 2 parameter model. Returns : array of 2 L, the first is the Kimura distance and the second is a matrix of variance V(K) Args : L of DNA sequences =cut sub D_Kimura_variance { my ($self,$aln) = @_; return 0 unless $self->_check_arg($aln); # ambiguities ignored at this point my (@names,@values,%dist,@var); my $seqct = 0; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id; $seqct++; } my $precisionstr = "%.$Precision"."f"; for( my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { my $pairwise = $aln->select_noncont($i+1,$j+1); my $L = $self->pairwise_stats->number_of_comparable_bases($pairwise); unless( $L ) { $L = 1; } my $P = $self->transitions($pairwise) / $L; my $Q = $self->transversions($pairwise) / $L; my ($a,$b,$K,$var_k); my $a_denom = ( 1 - (2 * $P) - $Q); my $b_denom = 1 - 2 * $Q; unless( $a_denom > 0 && $b_denom > 0 ) { $a = 1; $b = 1; $K = -1; $var_k = -1; } else { $a = 1 / $a_denom; $b = 1 / $b_denom; $K = (1/2) * log ( $a ) + (1/4) * log($b); # from Wu and Li 1985 which in turn is from Kimura 1980 my $c = ( $a - $b ) / 2; my $d = ( $a + $b ) / 2; $var_k = ( $a**2 * $P + $d**2 * $Q - ( $a * $P + $d * $Q)**2 ) / $L; } # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$K); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j]->[$j] = sprintf($precisionstr,0); $var[$j]->[$i] = $var[$i]->[$j] = sprintf($precisionstr,$var_k); $var[$j]->[$j] = $values[$j]->[$j]; } } return ( Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values), Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@var) ); } # K Tamura, Mol. Biol. Evol. 1992, 9, 678. =head2 D_Tamura Title : D_Tamura Usage : Calculates D (pairwise distance) between 2 sequences in an alignment using Tamura 1992 distance model. Returns : L Args : L of DNA sequences =cut sub D_Tamura { my ($self,$aln) = @_; return 0 unless $self->_check_arg($aln); # ambiguities ignored at this point my (@seqs,@names,@values,%dist,$i,$j); my $seqct = 0; my $length = $aln->length; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id;; push @seqs, uc $seq->seq(); $seqct++; } my $precisionstr = "%.$Precision"."f"; my (@gap,@gc,@trans,@tranv,@score); $i = 0; for my $t1 ( @seqs ) { $j = 0; for my $t2 ( @seqs ) { $gap[$i][$j] = 0; for( my $k = 0; $k < $length; $k++ ) { my ($c1,$c2) = ( substr($seqs[$i],$k,1), substr($seqs[$j],$k,1) ); if( $c1 =~ /^$GapChars$/ || $c2 =~ /^$GapChars$/ ) { $gap[$i][$j]++; } elsif( $c2 =~ /^$GCChhars$/i ) { $gc[$i][$j]++; } } $gc[$i][$j] = ( $gc[$i][$j] / ($length - $gap[$i][$j]) ); $j++; } $i++; } for( $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( $j = $i+1; $j < $seqct; $j++ ) { my $pairwise = $aln->select_noncont($i+1,$j+1); my $L = $self->pairwise_stats->number_of_comparable_bases($pairwise); my $P = $self->transitions($pairwise) / $L; my $Q = $self->transversions($pairwise) / $L; my $C = $gc[$i][$j] + $gc[$j][$i]- ( 2 * $gc[$i][$j] * $gc[$j][$i] ); if( $P ) { $P = $P / $C; } my $d = -($C * log(1- $P - $Q)) -(0.5* ( 1 - $C) * log(1 - 2 * $Q)); # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$d); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values); } =head2 D_F84 Title : D_F84 Usage : my $d = $stat->D_F84($aln) Function: Calculates D (pairwise distance) between 2 sequences in an alignment using the Felsenstein 1984 distance model. Returns : L Args : L of DNA sequences [optional] double - gap penalty =cut sub D_F84 { my ($self,$aln,$gappenalty) = @_; return 0 unless $self->_check_arg($aln); $self->throw_not_implemented(); # ambiguities ignored at this point my (@seqs,@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { # if there is no name, my $id = $seq->display_id; if( ! length($id) || # deal with empty names $id =~ /^\s+$/ ) { $id = $seqct+1; } push @names, $id; push @seqs, uc $seq->seq(); $seqct++; } my $precisionstr = "%.$Precision"."f"; for( my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { } } } # Tajima and Nei, Mol. Biol. Evol. 1984, 1, 269. # Tajima-Nei correction used for multiple substitutions in the calc # of the distance matrix. Nucleic acids only. # # D = p-distance = 1 - (matches/(posns_scored + gaps) # # distance = -b * ln(1-D/b) # =head2 D_TajimaNei Title : D_TajimaNei Usage : my $d = $stat->D_TajimaNei($aln) Function: Calculates D (pairwise distance) between 2 sequences in an alignment using the TajimaNei 1984 distance model. Returns : L Args : Bio::Align::AlignI of DNA sequences =cut sub D_TajimaNei{ my ($self,$aln) = @_; return 0 unless $self->_check_arg($aln); # ambiguities ignored at this point my (@seqs,@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { # if there is no name, push @names, $seq->display_id; push @seqs, uc $seq->seq(); $seqct++; } my $precisionstr = "%.$Precision"."f"; my ($i,$j,$bs); # pairwise for( $i =0; $i < $seqct -1; $i++ ) { $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for ( $j = $i+1; $j <$seqct;$j++ ) { my ($matrix,$pfreq,$gaps) = $self->_build_nt_matrix($seqs[$i], $seqs[$j]); my $pairwise = $aln->select_noncont($i+1,$j+1); my $slen = $self->pairwise_stats->number_of_comparable_bases($pairwise); my $fij2 = 0; for( $bs = 0; $bs < 4; $bs++ ) { my $fi = 0; map {$fi += $matrix->[$bs]->[$_] } 0..3; my $fj = 0; # summation map { $fj += $matrix->[$_]->[$bs] } 0..3; my $fij = ( $fi && $fj ) ? ($fi + $fj) /( 2 * $slen) : 0; $fij2 += $fij**2; } my ($pair,$h) = (0,0); for( $bs = 0; $bs < 3; $bs++ ) { for(my $bs1 = $bs+1; $bs1 <= 3; $bs1++ ) { my $fij = $pfreq->[$pair++] / $slen; if( $fij ) { my ($ci1,$ci2,$cj1,$cj2) = (0,0,0,0); map { $ci1 += $matrix->[$_]->[$bs] } 0..3; map { $cj1 += $matrix->[$bs]->[$_] } 0..3; map { $ci2 += $matrix->[$_]->[$bs1] } 0..3; map { $cj2 += $matrix->[$bs1]->[$_] } 0..3; if( $fij ) { $h += ( ($fij**2) / 2 ) / ( ( ( $ci1 + $cj1 ) / (2 * $slen) ) * ( ( $ci2 + $cj2 ) / (2 * $slen) ) ); } $self->debug( "slen is $slen h is $h fij = $fij ci1 =$ci1 cj1=$cj1 ci2=$ci2 cj2=$cj2\n"); } } } # just want diagonals which are matches (A matched A, C -> C) my $m = ( $matrix->[0]->[0] + $matrix->[1]->[1] + $matrix->[2]->[2] + $matrix->[3]->[3] ); my $D = 1 - ( $m / $slen); my $d; if( $h == 0 ) { $d = -1; } else { my $b = (1 - $fij2 + (($D**2)/$h)) / 2; my $c = 1- $D/ $b; if( $c < 0 ) { $d = -1; } else { $d = (-1 * $b) * log ( $c); } } # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$d); # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_DNAstats', -matrix => \%dist, -names => \@names, -values => \@values); } # Jin and Nei, Mol. Biol. Evol. 82, 7, 1990. =head2 D_JinNei Title : D_JinNei Usage : my $d = $stat->D_JinNei($aln) Function: Calculates D (pairwise distance) between 2 sequences in an alignment using the Jin-Nei 1990 distance model. Returns : L Args : L of DNA sequences =cut sub D_JinNei{ my ($self,@args) = @_; $self->warn("JinNei implementation not completed"); return; } =head2 transversions Title : transversions Usage : my $transversions = $stats->transversion($aln); Function: Calculates the number of transversions between two sequences in an alignment Returns : integer Args : Bio::Align::AlignI =cut sub transversions{ my ($self,$aln) = @_; return $self->_trans_count_helper($aln, $DNAChanges{'Transversions'}); } =head2 transitions Title : transitions Usage : my $transitions = Bio::Align::DNAStatistics->transitions($aln); Function: Calculates the number of transitions in a given DNA alignment Returns : integer representing the number of transitions Args : Bio::Align::AlignI object =cut sub transitions{ my ($self,$aln) = @_; return $self->_trans_count_helper($aln, $DNAChanges{'Transitions'}); } sub _trans_count_helper { my ($self,$aln,$type) = @_; return 0 unless( $self->_check_arg($aln) ); if( ! $aln->is_flush ) { $self->throw("must be flush") } my (@tcount); my ($first,$second) = ( uc $aln->get_seq_by_pos(1)->seq(), uc $aln->get_seq_by_pos(2)->seq() ); my $alen = $aln->length; for (my $i = 0;$i<$alen; $i++ ) { my ($c1,$c2) = ( substr($first,$i,1), substr($second,$i,1) ); if( $c1 ne $c2 ) { foreach my $nt ( @{$type->{$c1}} ) { if( $nt eq $c2) { $tcount[$i]++; } } } } my $sum = 0; map { if( $_) { $sum += $_} } @tcount; return $sum; } # this will generate a matrix which records across the row, the number # of DNA subst # sub _build_nt_matrix { my ($self,$seqa,$seqb) = @_; my $basect_matrix = [ [ qw(0 0 0 0) ], # number of bases that match [ qw(0 0 0 0) ], [ qw(0 0 0 0) ], [ qw(0 0 0 0) ] ]; my $gaps = 0; # number of gaps my $pfreq = [ qw( 0 0 0 0 0 0)]; # matrix for pair frequency my $len_a = length($seqa); for( my $i = 0; $i < $len_a; $i++) { my ($ti,$tj) = (substr($seqa,$i,1),substr($seqb,$i,1)); $ti =~ tr/U/T/; $tj =~ tr/U/T/; if( $ti =~ /^$GapChars$/) { $gaps++; next; } if( $tj =~ /^$GapChars$/) { $gaps++; next } my $ti_index = $NucleotideIndexes{$ti}; my $tj_index = $NucleotideIndexes{$tj}; if( ! defined $ti_index ) { $self->warn("ti_index not defined for $ti\n"); next; } $basect_matrix->[$ti_index]->[$tj_index]++; if( $ti ne $tj ) { $pfreq->[$NucleotideIndexes{join('',sort ($ti,$tj))}]++; } } return ($basect_matrix,$pfreq,$gaps); } sub _check_ambiguity_nucleotide { my ($base1,$base2) = @_; my %iub = Bio::Tools::IUPAC->iupac_iub(); my @amb1 = @{ $iub{uc($base1)} }; my @amb2 = @{ $iub{uc($base2)} }; my ($pmatch) = (0); for my $amb ( @amb1 ) { if( grep { $amb eq $_ } @amb2 ) { $pmatch = 1; last; } } if( $pmatch ) { return (1 / scalar @amb1) * (1 / scalar @amb2); } else { return 0; } } sub _check_arg { my($self,$aln ) = @_; if( ! defined $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI compliant object to Bio::Align::DNAStatistics"); return 0; } elsif( $aln->get_seq_by_pos(1)->alphabet ne 'dna' ) { $self->warn("Must provide a DNA alignment to Bio::Align::DNAStatistics, you provided a " . $aln->get_seq_by_pos(1)->alphabet); return 0; } return 1; } =head2 Data Methods =cut =head2 pairwise_stats Title : pairwise_stats Usage : $obj->pairwise_stats($newval) Function: Returns : value of pairwise_stats Args : newvalue (optional) =cut sub pairwise_stats{ my ($self,$value) = @_; if( defined $value) { $self->{'_pairwise_stats'} = $value; } return $self->{'_pairwise_stats'}; } =head2 calc_KaKs_pair Title : calc_KaKs_pair Useage : my $results = $stats->calc_KaKs_pair($alnobj, $name1, $name2). Function : calculates Nei-Gojobori statistics for pairwise comparison. Args : A Bio::Align::AlignI compliant object such as a Bio::SimpleAlign object, and 2 sequence name strings. Returns : a reference to a hash of statistics with keys as listed in Description. =cut sub calc_KaKs_pair { my ( $self, $aln, $seq1_id, $seq2_id) = @_; $self->throw("Needs 3 arguments - an alignment object, and 2 sequence ids") if @_!= 4; $self->throw ("This calculation needs a Bio::Align::AlignI compatible object, not a [ " . ref($aln) . " ]object") unless $aln->isa('Bio::Align::AlignI'); my @seqs = ( #{id => $seq1_id, seq =>($aln->each_seq_with_id($seq1_id))[0]->seq}, #{id => $seq2_id, seq =>($aln->each_seq_with_id($seq2_id))[0]->seq} {id => $seq1_id, seq => uc(($aln->each_seq_with_id($seq1_id))[0]->seq)}, {id => $seq2_id, seq => uc(($aln->each_seq_with_id($seq2_id))[0]->seq)} ) ; if (length($seqs[0]{'seq'}) != length($seqs[1]{'seq'})) { $self->throw(" aligned sequences must be of equal length!"); } my $results = []; $self->_get_av_ds_dn(\@seqs, $results); return $results; } =head2 calc_all_KaKs_pairs Title : calc_all_KaKs_pairs Useage : my $results2 = $stats->calc_KaKs_pair($alnobj). Function : Calculates Nei_gojobori statistics for all pairwise combinations in sequence. Arguments: A Bio::Align::ALignI compliant object such as a Bio::SimpleAlign object. Returns : A reference to an array of hashes of statistics of all pairwise comparisons in the alignment. =cut sub calc_all_KaKs_pairs { #returns a multi_element_array with all pairwise comparisons my ($self,$aln) = @_; $self->throw ("This calculation needs a Bio::Align::AlignI compatible object, not a [ " . ref($aln) . " ]object") unless $aln->isa('Bio::Align::AlignI'); my @seqs; for my $seq ($aln->each_seq) { push @seqs, {id => $seq->display_id, seq=>$seq->seq}; } my $results ; $results = $self->_get_av_ds_dn(\@seqs, $results); return $results; } =head2 calc_average_KaKs Title : calc_average_KaKs. Useage : my $res= $stats->calc_average_KaKs($alnobj, 1000). Function : calculates Nei_Gojobori stats for average of all sequences in the alignment. Args : A Bio::Align::AlignI compliant object such as a Bio::SimpleAlign object, number of bootstrap iterations (default 1000). Returns : A reference to a hash of statistics as listed in Description. =cut sub calc_average_KaKs { #calculates global value for sequences in alignment using bootstrapping #this is quite slow (~10 seconds per 3 X 200nt seqs); my ($self, $aln, $bootstrap_rpt) = @_; $bootstrap_rpt ||= 1000; $self->throw ("This calculation needs a Bio::Align::AlignI compatible object, not a [ " . ref($aln) . " ]object") unless $aln->isa('Bio::Align::AlignI'); my @seqs; for my $seq ($aln->each_seq) { push @seqs, {id => $seq->display_id, seq=>$seq->seq}; } my $results ; my ($ds_orig, $dn_orig) = $self->_get_av_ds_dn(\@seqs); #print "ds = $ds_orig, dn = $dn_orig\n"; $results = {D_s => $ds_orig, D_n => $dn_orig}; $self->_run_bootstrap(\@seqs, $results, $bootstrap_rpt); return $results; } ############## primary internal subs for alignment comparisons ######################## sub _run_bootstrap { ### generates sampled sequences, calculates Ds and Dn values, ### then calculates variance of sampled sequences and add results to results hash ### my ($self,$seq_ref, $results, $bootstrap_rpt) = @_; my @seqs = @$seq_ref; my @btstrp_aoa; # to hold array of array of nucleotides for resampling my %bootstrap_values = (ds => [], dn =>[]); # to hold list of av values #1st make alternative array of codons; my $c = 0; while ($c < length $seqs[0]{'seq'}) { for (0..$#seqs) { push @{$btstrp_aoa[$_]}, substr ($seqs[$_]{'seq'}, $c, 3); } $c+=3; } for (1..$bootstrap_rpt) { my $sampled = _resample (\@btstrp_aoa); my ($ds, $dn) = $self->_get_av_ds_dn ($sampled) ; # is array ref push @{$bootstrap_values{'ds'}}, $ds; push @{$bootstrap_values{'dn'}}, $dn; } $results->{'D_s_var'} = sampling_variance($bootstrap_values{'ds'}); $results->{'D_n_var'} = sampling_variance($bootstrap_values{'dn'}); $results->{'z_score'} = ($results->{'D_n'} - $results->{'D_s'}) / sqrt($results->{'D_s_var'} + $results->{'D_n_var'} ); #print "bootstrapped var_syn = $results->{'D_s_var'} \n" ; #print "bootstrapped var_nc = $results->{'D_n_var'} \n"; #print "z is $results->{'z_score'}\n"; ### end of global set up of/perm look up data } sub _resample { my $ref = shift; my $codon_num = scalar (@{$ref->[0]}); my @altered; for (0..$codon_num -1) { #for each codon my $rand = int (rand ($codon_num)); for (0..$#$ref) { push @{$altered[$_]}, $ref->[$_][$rand]; } } my @stringed = map {join '', @$_}@altered; my @return; #now out in random name to keep other subs happy for (@stringed) { push @return, {id=>'1', seq=> $_}; } return \@return; } sub _get_av_ds_dn { # takes array of hashes of sequence strings and ids # my $self = shift; my $seq_ref = shift; my $result = shift if @_; my @caller = caller(1); my @seqarray = @$seq_ref; my $bootstrap_score_list; #for a multiple alignment considers all pairwise combinations# my %dsfor_average = (ds => [], dn => []); for (my $i = 0; $i < scalar @seqarray; $i++) { for (my $j = $i +1; $jwarn(" aligned sequences must be of equal length!"); next; } my $syn_site_count = count_syn_sites($seqarray[$i]{'seq'}, $synsites); my $syn_site_count2 = count_syn_sites($seqarray[$j]{'seq'}, $synsites); # print "syn 1 is $syn_site_count , syn2 is $syn_site_count2\n"; my ($syn_count, $non_syn_count, $gap_cnt) = analyse_mutations($seqarray[$i]{'seq'}, $seqarray[$j]{'seq'}); #get averages my $av_s_site = ($syn_site_count + $syn_site_count2)/2; my $av_ns_syn_site = length($seqarray[$i]{'seq'}) - $gap_cnt- $av_s_site ; #calculate ps and pn (p54) my $syn_prop = $syn_count / $av_s_site; my $nc_prop = $non_syn_count / $av_ns_syn_site ; #now use jukes/cantor to calculate D_s and D_n, would alter here if needed a different method my $d_syn = $self->jk($syn_prop); my $d_nc = $self->jk($nc_prop); #JK calculation must succeed for continuation of calculation #ret_value = -1 if error next unless $d_nc >=0 && $d_syn >=0; push @{$dsfor_average{'ds'}}, $d_syn; push @{$dsfor_average{'dn'}}, $d_nc; #if not doing bootstrap, calculate the pairwise comparisin stats if ($caller[3] =~ /calc_KaKs_pair/ || $caller[3] =~ /calc_all_KaKs_pairs/) { #now calculate variances assuming large sample my $d_syn_var = jk_var($syn_prop, length($seqarray[$i]{'seq'}) - $gap_cnt ); my $d_nc_var = jk_var($nc_prop, length ($seqarray[$i]{'seq'}) - $gap_cnt); #now calculate z_value #print "d_syn_var is $d_syn_var,and d_nc_var is $d_nc_var\n"; #my $z = ($d_nc - $d_syn) / sqrt($d_syn_var + $d_nc_var); my $z = ($d_syn_var + $d_nc_var) ? ($d_nc - $d_syn) / sqrt($d_syn_var + $d_nc_var) : 0; # print "z is $z\n"; push @$result , {S => $av_s_site, N=>$av_ns_syn_site, S_d => $syn_count, N_d =>$non_syn_count, P_s => $syn_prop, P_n=>$nc_prop, D_s => @{$dsfor_average{'ds'}}[-1], D_n => @{$dsfor_average{'dn'}}[-1], D_n_var =>$d_nc_var, D_s_var => $d_syn_var, Seq1 => $seqarray[$i]{'id'}, Seq2 => $seqarray[$j]{'id'}, z_score => $z, }; $self->warn (" number of mutations too small to justify normal test for $seqarray[$i]{'id'} and $seqarray[$j]{'id'}\n- use Fisher's exact, or bootstrap a MSA") if ($syn_count < 10 || $non_syn_count < 10 ) && $self->verbose > -1 ; }#endif } } #warn of failure if no results hashes are present #will fail if Jukes Cantor has failed for all pairwise combinations #$self->warn("calculation failed!") if scalar @$result ==0; #return results unless bootstrapping return $result if $caller[3]=~ /calc_all_KaKs/ || $caller[3] =~ /calc_KaKs_pair/; #else if getting average for bootstrap return( mean ($dsfor_average{'ds'}),mean ($dsfor_average{'dn'})) ; } sub jk { my ($self, $p) = @_; if ($p > 0.75) { $self->warn( " Jukes Cantor won't work -too divergent!"); return -1; } return -1 * (3/4) * (log(1 - (4/3) * $p)); } #works for large value of n (50?100?) sub jk_var { my ($p, $n) = @_; return (9 * $p * (1 -$p))/(((3 - 4 *$p) **2) * $n); } # compares 2 sequences to find the number of synonymous/non # synonymous mutations between them sub analyse_mutations { my ($seq1, $seq2) = @_; my %mutator = ( 2=> {0=>[[1,2], # codon positions to be altered [2,1]], # depend on which is the same 1=>[[0,2], [2,0]], 2=>[[0,1], [1,0]], }, 3=> [ [0,1,2], # all need to be altered [1,0,2], [0,2,1], [1,2,0], [2,0,1], [2,1,0] ], ); my $TOTAL = 0; # total synonymous changes my $TOTAL_n = 0; # total non-synonymous changes my $gap_cnt = 0; my %input; my $seqlen = length($seq1); for (my $j=0; $j< $seqlen; $j+=3) { $input{'cod1'} = substr($seq1, $j,3); $input{'cod2'} = substr($seq2, $j,3); #ignore codon if beeing compared with gaps! if ($input{'cod1'} =~ /\-/ || $input{'cod2'} =~ /\-/){ $gap_cnt += 3; #just increments once if there is a pair of gaps next; } my ($diff_cnt, $same) = count_diffs(\%input); #ignore if codons are identical next if $diff_cnt == 0 ; if ($diff_cnt == 1) { $TOTAL += $synchanges{$input{'cod1'}}{$input{'cod2'}}; $TOTAL_n += 1 - $synchanges{$input{'cod1'}}{$input{'cod2'}}; #print " \nfordiff is 1 , total now $TOTAL, total n now $TOTAL_n\n\n" } elsif ($diff_cnt ==2) { my $s_cnt = 0; my $n_cnt = 0; my $tot_muts = 4; #will stay 4 unless there are stop codons at intervening point OUTER:for my $perm (@{$mutator{'2'}{$same}}) { my $altered = $input{'cod1'}; my $prev= $altered; # print "$prev -> (", $t[$CODONS->{$altered}], ")"; for my $mut_i (@$perm) { #index of codon mutated substr($altered, $mut_i,1) = substr($input{'cod2'}, $mut_i, 1); if ($t[$CODONS->{$altered}] eq '*') { $tot_muts -=2; #print "changes to stop codon!!\n"; next OUTER; } else { $s_cnt += $synchanges{$prev}{$altered}; # print "$altered ->(", $t[$CODONS->{$altered}], ") "; } $prev = $altered; } # print "\n"; } if ($tot_muts != 0) { $TOTAL += ($s_cnt/($tot_muts/2)); $TOTAL_n += ($tot_muts - $s_cnt)/ ($tot_muts / 2); } } elsif ($diff_cnt ==3 ) { my $s_cnt = 0; my $n_cnt = 0; my $tot_muts = 18; #potential number of mutations OUTER: for my $perm (@{$mutator{'3'}}) { my $altered = $input{'cod1'}; my $prev= $altered; # print "$prev -> (", $t[$CODONS->{$altered}], ")"; for my $mut_i (@$perm) { #index of codon mutated substr($altered, $mut_i,1) = substr($input{'cod2'}, $mut_i, 1); if ($t[$CODONS->{$altered}] eq '*') { $tot_muts -=3; # print "changes to stop codon!!\n"; next OUTER; } else { $s_cnt += $synchanges{$prev}{$altered}; # print "$altered ->(", $t[$CODONS->{$altered}], ") "; } $prev = $altered; } # print "\n"; }#end OUTER loop #calculate number of synonymous/non synonymous mutations for that codon # and add to total if ($tot_muts != 0) { $TOTAL += ($s_cnt / ($tot_muts /3)); $TOTAL_n += 3 - ($s_cnt / ($tot_muts /3)); } } #endif $diffcnt = 3 } #end of sequencetraversal return ($TOTAL, $TOTAL_n, $gap_cnt); } sub count_diffs { #counts the number of nucleotide differences between 2 codons # returns this value plus the codon index of which nucleotide is the same when 2 #nucleotides are different. This is so analyse_mutations() knows which nucleotides # to change. my $ref = shift; my $cnt = 0; my $same= undef; #just for 2 differences for (0..2) { if (substr($ref->{'cod1'}, $_,1) ne substr($ref->{'cod2'}, $_, 1)){ $cnt++; } else { $same = $_; } } return ($cnt, $same); } =head2 get_syn_changes Title : get_syn_changes Usage : Bio::Align::DNAStatitics->get_syn_changes Function: Generate a hashref of all pairwise combinations of codns differing by 1 Returns : Symetic matrix using hashes First key is codon and each codon points to a hashref of codons the values of which describe type of change. my $type = $hash{$codon1}->{$codon2}; values are : 1 synonymous 0 non-syn -1 either codon is a stop codon Args : none =cut sub get_syn_changes { #hash of all pairwise combinations of codons differing by 1 # 1 = syn, 0 = non-syn, -1 = stop my %results; my @codons = _make_codons (); my $arr_len = scalar @codons; for (my $i = 0; $i < $arr_len -1; $i++) { my $cod1 = $codons[$i]; for (my $j = $i +1; $j < $arr_len; $j++) { my $diff_cnt = 0; for my $pos(0..2) { $diff_cnt++ if substr($cod1, $pos, 1) ne substr($codons[$j], $pos, 1); } next if $diff_cnt !=1; #synon change if($t[$CODONS->{$cod1}] eq $t[$CODONS->{$codons[$j]}]) { $results{$cod1}{$codons[$j]} =1; $results{$codons[$j]}{$cod1} = 1; } #stop codon elsif ($t[$CODONS->{$cod1}] eq '*' or $t[$CODONS->{$codons[$j]}] eq '*') { $results{$cod1}{$codons[$j]} = -1; $results{$codons[$j]}{$cod1} = -1; } # nc change else { $results{$cod1}{$codons[$j]} = 0; $results{$codons[$j]}{$cod1} = 0; } } } return %results; } =head2 dnds_pattern_number Title : dnds_pattern_number Usage : my $patterns = $stats->dnds_pattern_number($alnobj); Function: Counts the number of codons with no gaps in the MSA Returns : Number of codons with no gaps ('patterns' in PAML notation) Args : A Bio::Align::AlignI compliant object such as a Bio::SimpleAlign object. =cut sub dnds_pattern_number{ my ($self, $aln) = @_; return ($aln->remove_gaps->length)/3; } sub count_syn_sites { #counts the number of possible synonymous changes for sequence my ($seq, $synsite) = @_; __PACKAGE__->throw("not integral number of codons") if length($seq) % 3 != 0; my $S = 0; for (my $i = 0; $i< length($seq); $i+=3) { my $cod = substr($seq, $i, 3); next if $cod =~ /\-/; #deal with alignment gaps $S += $synsite->{$cod}{'s'}; } #print "S is $S\n"; return $S; } sub get_syn_sites { #sub to generate lookup hash for the number of synonymous changes per codon my @nucs = qw(T C A G); my %raw_results; for my $i (@nucs) { for my $j (@nucs) { for my $k (@nucs) { # for each possible codon my $cod = "$i$j$k"; my $aa = $t[$CODONS->{$cod}]; #calculate number of synonymous mutations vs non syn mutations for my $i (qw(0 1 2)){ my $s = 0; my $n = 3; for my $nuc (qw(A T C G)) { next if substr ($cod, $i,1) eq $nuc; my $test = $cod; substr($test, $i, 1) = $nuc ; if ($t[$CODONS->{$test}] eq $aa) { $s++; } if ($t[$CODONS->{$test}] eq '*') { $n--; } } $raw_results{$cod}[$i] = {'s' => $s , 'n' => $n }; } } #end analysis of single codon } } #end analysis of all codons my %final_results; for my $cod (sort keys %raw_results) { my $t = 0; map{$t += ($_->{'s'} /$_->{'n'})} @{$raw_results{$cod}}; $final_results{$cod} = { 's'=>$t, 'n' => 3 -$t}; } return \%final_results; } sub _make_codons { #makes all codon combinations, returns array of them my @nucs = qw(T C A G); my @codons; for my $i (@nucs) { for my $j (@nucs) { for my $k (@nucs) { push @codons, "$i$j$k"; } } } return @codons; } sub get_codons { #generates codon translation look up table# my $x = 0; my $CODONS = {}; for my $codon (_make_codons) { $CODONS->{$codon} = $x; $x++; } return $CODONS; } #########stats subs, can go in another module? Here for speed. ### sub mean { my $ref = shift; my $el_num = scalar @$ref; my $tot = 0; map{$tot += $_}@$ref; return ($tot/$el_num); } sub variance { my $ref = shift; my $mean = mean($ref); my $sum_of_squares = 0; map{$sum_of_squares += ($_ - $mean) **2}@$ref; return $sum_of_squares; } sub sampling_variance { my $ref = shift; return variance($ref) / (scalar @$ref -1); } 1; BioPerl-1.6.923/Bio/Align/Graphics.pm000444000765000024 11152512254227340 17343 0ustar00cjfieldsstaff000000000000#Author: William McCaig #Date: 06/16/2006 #Purpose: To print visual images of alignments # #Requires: An alignment file # #Produces: An image file # #Revision History: #09/01/2006 - WDM - Introduction of "wrap" flag, allowing alignment to be # wrapped at a set base and stacked vertically # Addition of internal members y_num and y_size for tracking # of number of vertical panels and size of panels, # respectively # #09/06/2006 - WDM - Introduction of "p_legend" flag, for printing of an optional # colored legend when protein coloring is selected # #09/24/2008 - WDM - Test file created for the module # #03/01/2009 - YH - Introduction of "show_nonsynonymous" flag which enables # highlighting of nonsynonymous mutations in nucleotide # alignments. Addition of internal members codon_table and # missense_pos for translating codons -> amino acids and for # keeping track of missense mutation positions respectively. # #03/05/2009 - YH - Swapped names of subroutines x_label and y_label to match # both documentation and intuition. Finalized implementation # of show_nonsynonymous functionality. # docs after the code! package Bio::Align::Graphics; use vars qw( @PRINT_PARAMS %OK_FIELD); use 5.008003; use strict; use warnings; use GD; use GD::Simple; use Bio::AlignIO; use Data::Dumper; use POSIX qw(ceil floor); require Exporter; our @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use PrintAlignment ':all'; # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK # will save memory. our %EXPORT_TAGS = ( 'all' => [ qw( ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( ); # Preloaded methods go here. our %FONT_TABLE = (1 => gdTinyFont, 2 => gdSmallFont, 3 => gdMediumBoldFont, 4 => gdLargeFont, 5 => gdGiantFont ); our %PROTEIN_COLORS = ('Q' => [255, 0, 204], 'E' => [255, 0, 102], 'D' => [255, 0, 0] , 'S' => [255, 51, 0] , 'T' => [255, 102, 0 ], 'G' => [255, 153, 0] , 'P' => [255, 204, 0] , 'C' => [255, 255, 0] , 'A' => [204, 255, 0] , 'V' => [153, 255, 0], 'I' => [102, 255, 0] , 'L' => [51 , 255, 0] , 'M' => [0, 255, 0] , 'F' => [0 , 255, 102] , 'Y' => [0 , 255, 204], 'W' => [0, 204, 255] , 'H' => [0, 102, 255] , 'R' => [0, 0, 255] , 'K' => [102, 0, 255] , 'N' => [204, 0, 255] ); ################################################################# #New sub new { my $class = shift; my %options = @_; my $self = { #####OPTIONS##### #Display Defaults font => defined($options{font}) ? $FONT_TABLE{$options{font}} : $FONT_TABLE{2}, x_label => defined($options{x_label}) ? $options{x_label} : 1, y_label => defined($options{y_label}) ? $options{y_label} : 1, #Colors bg_color => $options{bg_color} || 'white', fg_color => $options{font_color} || 'black', x_label_color => $options{x_label_color} || 'blue', y_label_color => $options{y_label_color} || 'red', p_color => $options{p_color} || undef, p_legend => $options{p_legend} || undef, p_color_table => undef, #Sequence Defaults reference => $options{reference} || undef, reference_id => $options{reference_id} || undef, match_char => $options{match_char} || ".", block_size => defined($options{block_size}) ? $options{block_size} : 10, block_space => defined ($options{block_space}) ? ($options{block_space} * ($options{font} ? $FONT_TABLE{$options{font}}->width : $FONT_TABLE{2}->width)) : ( ($options{font} ? ($FONT_TABLE{$options{font}}->width * 2 ) : ($FONT_TABLE{2}->width * 2)) ), wrap => $options{wrap} || 80, show_nonsynonymous => $options{show_nonsynonymous} || undef, # If turned on, will highlight nonsynonymous (missense) mutations. Valid only for nucleotide alignments #Padding pad_left => $options{pad_left} || 5, #space between x label and border pad_right => $options{pad_right} || 5, #space between end of sequences and border pad_top => $options{pad_top} || 5, #space between y label and border pad_bottom => $options{pad_bottom} || 5, #space between bottom of sequences and border x_label_space => $options{x_label_space} || 1, #space between x label and sequences y_label_space => $options{y_label_space} || 1, #space between y label and sequences #Labels labels => $options{labels} || undef, dm_labels => $options{dm_labels} || undef, dm_label_start => $options{dml_start} || undef, dm_label_end => $options{dml_end} || undef, dm_label_color => $options{dml_color} || undef, domain_start => $options{dm_start} || undef, domain_end => $options{dm_end} || undef, domain_color => $options{dm_color} || undef, #File Defaults align => $options{align} || undef, output => $options{output} || undef, out_format => $options{out_format} || undef, ####PRIVATE VALUES##### image => $options{image} || undef, seq_format => undef, #X and Y size of char x_char_size => ($options{font} ? $FONT_TABLE{$options{font}}->width : $FONT_TABLE{2}->width), y_char_size => ($options{font} ? $FONT_TABLE{$options{font}}->height : $FONT_TABLE{2}->height), #Image W & H width => undef, #overall width of the image height => undef, #overall height of image #Sequences sequences => undef, seq_ids => undef, ref_sequence => undef, id_length => 0, seq_length => $options{align}->length() || 0, no_sequences => $options{align}->num_sequences() || 0, seq_start_x => undef, seq_start_y => undef, start => $options{start} || 1, end => $options{end} || $options{align}->length(), y_num => undef, y_size => undef, footer_size => 110, footer_start => undef }; bless ($self, $class); die "new:Must supply alignment for drawing!\n" unless defined ($self->{align}); foreach my $seq ($self->{align}->each_seq) { $self->{id_length} = ( length($seq->id()) > $self->{id_length} ) ? length($seq->id()) : $self->{id_length}; if( $self->{reference_id} && ($seq->id() eq $self->{reference_id}) ) { @{$self->{ref_sequence}} = split //, $seq->seq; unshift @{$self->{sequences}}, $seq->seq; unshift @{$self->{seq_ids}}, $seq->id(); }else { push @{$self->{sequences}}, $seq->seq; push @{$self->{seq_ids}}, $seq->id(); } if(!defined($self->{seq_format})) { $self->{seq_format} = $seq->alphabet; } } if(!($self->{reference_id}) ) { @{$self->{ref_sequence}} = split //, ${$self->{sequences}}[0]; $self->{reference_id} = ${$self->{seq_ids}}[0]; } $self->{y_num} = ($self->{seq_length} > $self->{wrap}) ? ( sprintf( "%.0f", ( ($self->{seq_length} / $self->{wrap}) + .5) ) ) : 1; $self->{y_size} = ( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); $self->{seq_start_x} = ($self->{pad_left} + $self->{id_length} + $self->{x_label_space}) * $self->{x_char_size}; if( defined($self->{show_nonsynonymous}) ) # Extra column changes dimensions { $self->{seq_length_aa} = ($self->{seq_length} / 3) + $self->{seq_length}; # Consider length of sequence plus extra column every 3 nucleotides $self->{seq_start_y} = ($self->{pad_top} + length($self->{seq_length_aa}) + $self->{y_label_space}) * $self->{y_char_size}; $self->{width} = $self->{seq_start_x} + ((( $self->{wrap} / $self->{block_size}) + 1) * $self->{block_space}) + ( ($self->{wrap} + $self->{pad_right}) * ($self->{x_char_size} + 1.2) ) + ( ($self->{seq_length} / 3) * 2); # Needed to add this for width to fit whole sequence on one line }else { $self->{seq_start_y} = ($self->{pad_top} + length($self->{seq_length}) + $self->{y_label_space}) * $self->{y_char_size}; $self->{width} = $self->{seq_start_x} + ((( $self->{wrap} / $self->{block_size}) + 1) * $self->{block_space}) + ($self->{wrap} + $self->{pad_right}) * $self->{x_char_size}; } $self->{footer_start} = $self->{seq_start_y} + $self->{y_size} * $self->{y_num}; if(defined($self->{p_color}) && defined($self->{p_legend}) && $self->{p_legend}){ $self->{height} = $self->{seq_start_y} + $self->{footer_size} + $self->{y_size} * $self->{y_num}; }else{ $self->{height} = $self->{seq_start_y} + $self->{y_size} * $self->{y_num}; } $self->{image} = GD::Simple->new($self->{width},$self->{height}); $self->{image}->alphaBlending(1); $self->{image}->saveAlpha(1); $self->{image}->bgcolor($self->{bg_color}); $self->{image}->fgcolor($self->{fg_color}); $self->{image}->rectangle(0,0,$self->{width}-1, $self->{height} - 1); return $self; } #End new Subroutine######################################################### sub draw{ my $self = shift; die "draw:Must supply alignment for drawing!\n" unless defined ($self->{align}); if(defined($self->{x_label}) && $self->{x_label}) { $self->x_label(); } if(defined($self->{y_label}) && $self->{y_label}) { $self->y_label(); } if(defined($self->{domain_start}) && defined($self->{domain_end}) && not defined($self->{p_color}) ) { $self->_draw_domain(); } # if( defined($self->{show_nonsynonymous}) && ( $self->{seq_format} eq "protein" ) ) { die "draw:Option show_nonsynonymous only works with Nucleotide alignments!\n"; }elsif ( defined($self->{show_nonsynonymous}) ) { $self->{codon_table} = Bio::Tools::CodonTable->new(); $self->{missense_pos} = {}; # print STDERR "You are using option show_nonsynonymous. Option works best if wrap value is a multiple of 4.\n" } if(defined($self->{p_color}) && $self->{seq_format} eq "protein") { $self->_draw_colored_sequences(); if(defined($self->{p_legend}) && $self->{p_legend}) { $self->_draw_legend(); } }elsif(defined($self->{p_color}) && ($self->{seq_format} ne "protein")) { die "draw:Option p_color only works with Protein alignments!\n"; }else { $self->_draw_sequences(); } if(defined($self->{dm_label_start})) { $self->_domain_label(); } if($self->{output}) { open(OUTPUT, ">$self->{output}"); binmode OUTPUT; if(defined($self->{out_format})) { SWITCH: { if($self->{out_format} eq "png") {print OUTPUT $self->{image}->png; last SWITCH;} if($self->{out_format} eq "jpeg") {print OUTPUT $self->{image}->jpeg; last SWITCH;} if($self->{out_format} eq "gif") {print OUTPUT $self->{image}->gif; last SWITCH;} if($self->{out_format} eq "gd") {print OUTPUT $self->{image}->gd; last SWITCH;} } }else { print OUTPUT $self->{image}->png; } close OUTPUT; }else { binmode STDOUT; if(defined($self->{out_format})) { SWITCH: { if($self->{out_format} eq "png") {print STDOUT $self->{image}->png; last SWITCH;} if($self->{out_format} eq "jpeg") {print STDOUT $self->{image}->jpeg; last SWITCH;} if($self->{out_format} eq "gif") {print STDOUT $self->{image}->gif; last SWITCH;} if($self->{out_format} eq "gd") {print STDOUT $self->{image}->gd; last SWITCH;} } }else { print STDOUT $self->{image}->png; } }#End Output if/else #print "Left\tRight\tTop\tBottom\n"; #print $self->{pad_left}, "\t", $self->{pad_right}, "\t", $self->{pad_top}, "\t", $self->{pad_bottom}, "\n"; }; ########################################## #Draws Sequences sub _draw_sequences{ my $self = shift; my $block_num = 0; my $block_total = 0; my $print_char; $self->{image}->fgcolor($self->{fg_color}); for (my $i=0; $i < $self->{no_sequences}; $i++) { my @letters = split //, ${$self->{sequences}}[$i]; my $y_num = $self->{y_num}; #sprintf( "%.0f", ( ($self->{seq_length} / $self->{wrap}) + .5) ) - 1; my $y_char = $self->{y_size}; #( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); for(my $k=0; $k<=$y_num; $k++) { my $x_char = $k * $self->{wrap}; for (my $j=$x_char; $j <= ( ($x_char + $self->{wrap}) - 1); $j++) { last unless defined($letters[$j]); # If show_nonsynonymous is on, and this is the 3rd nucleotide, # save the codon and amino acid for comparison my ($codon, $aa); if ((defined($self->{show_nonsynonymous})) && ((($j+1) % 3) == 0)) { $codon = $letters[$j-2] . $letters[$j-1] . $letters[$j]; $aa = $self->{codon_table}->translate($codon); } if( $self->{reference} ) { if(${$self->{seq_ids}}[$i] eq $self->{reference_id}) { $print_char = $letters[$j]; }else { if($letters[$j] eq ${$self->{ref_sequence}}[$j]) { $print_char = $self->{match_char}; }else { $print_char = $letters[$j]; } } }else { $print_char = $letters[$j]; } if( ( ($j + 1) % ($self->{block_size})) == 0) { $block_num = $self->{block_space}; }else { $block_num = 0; } #print "J is: $j\n"; #print "Char is: $print_char\n"; my $new_x_pos = $self->{seq_start_x} + ( ($j - $x_char) * $self->{x_char_size}) + $block_total; my $new_y_pos = $self->{seq_start_y} + ($i * $self->{y_char_size}) + ($k * $y_char); $new_x_pos += ( ( floor( ($j-$x_char)/3 ) * $self->{x_char_size} ) + ( ( floor( ($j-$x_char)/3 ) ) * 6 )) if ( defined($self->{show_nonsynonymous}) ); $self->{image}->moveTo( $new_x_pos, $new_y_pos ); $self->{image}->font($self->{font}); $self->{image}->string($print_char); if ( (defined($self->{show_nonsynonymous})) && ((($j+1) % 3) == 0) ) { $new_x_pos += ($self->{x_char_size} + 3); $self->{image}->moveTo( $new_x_pos, $new_y_pos ); # If show_nonsynonymous is on, and this is the 3rd nucleotide # on reference, print the amino acid after the nucleotide if(($self->{reference}) && (${$self->{seq_ids}}[$i] eq $self->{reference_id})) { $self->{image}->font(gdMediumBoldFont); $self->{image}->string($aa); $self->{image}->font($self->{font}); }elsif ( ( $self->{reference} ) && ( ${$self->{seq_ids}}[$i] ne $self->{reference_id} ) ) { # In case current sequence is not reference my $ref_codon = ${$self->{ref_sequence}}[$j-2] . ${$self->{ref_sequence}}[$j-1] . ${$self->{ref_sequence}}[$j]; my $ref_aa = $self->{codon_table}->translate($ref_codon); if ( $ref_aa eq $aa ) # Synonymous mutation { $self->{image}->string($self->{match_char}); }else # Nonsynonymous mutation { $self->{image}->font(gdMediumBoldFont); $self->{image}->string($aa); $self->{image}->font($self->{font}); # Highlight nonsynonymous mutations by drawing a rectangle around them if ( ( ${$self->{seq_ids}}[$i] ne $self->{reference_id} ) && !( ${$self->{missense_pos}}{$j} ) ) { ${$self->{missense_pos}}{$j} = 1; $self->{image}->bgcolor(undef); $self->{image}->rectangle( $new_x_pos - 2, ( $new_y_pos - ( ( $self->{y_char_size} * ($i+1)) ) ) - 2, ( $new_x_pos + ( $self->{x_char_size} + 1) ), ( $new_y_pos + ( $self->{y_char_size} * ( $self->{no_sequences} - ( $i+1 ) ) ) ) + 2); $self->{image}->bgcolor($self->{bg_color}); } } }else # No reference sequence defined { $self->{image}->string($aa); } } if( defined($self->{labels}) && $i == ($self->{no_sequences} - 1)) { if(${$self->{labels}}{$j + 1}) { my $label = ${$self->{labels}}{$j + 1}; my $offset = defined($self->{dm_label_start}) ? 3 : 0; $self->{image}->moveTo($self->{seq_start_x} + ( ( ($j - $x_char) + 1.25) * $self->{x_char_size}) + $block_total, $self->{seq_start_y} + (($self->{no_sequences}) * $self->{y_char_size}) + ($k * $y_char) + ( (length($label) + $offset) * ($self->{x_char_size}) ) ); $self->{image}->font($self->{font}); $self->{image}->angle(-90); $self->{image}->string($label); $self->{image}->angle(0); } } $block_total += $block_num; } $block_total = 0; } } } # WARNING YH - This function has not been modified to work with show_nonsynonymous: needs test data to make sure it will work! ############################################## #Draw Domain Label sub _domain_label{ my $self = shift; my $start_block_total = 0; my $end_block_total = 0; my $wrap_block_total = 0; my $y_char = $self->{y_size};# ( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); for(my $i = 0; $i <= $#{$self->{dm_label_start}}; $i++) { my $start = ${$self->{dm_label_start}}[$i]; my $end = ${$self->{dm_label_end}}[$i]; my $y_num_start = int( $start / $self->{wrap}); my $y_num_end = int( $end / $self->{wrap}); my $x_num_start; if($start >= $self->{wrap}) { $x_num_start = ($start % $self->{wrap}) - 1; }else { $x_num_start = $start - 1; } my $x_num_end; if($end >= $self->{wrap}) { $x_num_end = ($end % $self->{wrap}); }else { $x_num_end = $end; } my $label = ${$self->{dm_labels}}[$i]; my $color = ${$self->{dm_label_color}}[$i] || ${$self->{dm_label_color}}[-1] || "silver"; my $label_x = (($x_num_end - $x_num_start) / 2) - (length($label) / 2); my $label_x_start = (($self->{wrap} - $x_num_start) / 2) - (length($label) / 2); my $label_x_end = ($x_num_end / 2) - (length($label) / 2); $start_block_total = ( ($x_num_start - ($x_num_start % $self->{block_size}) ) / $self->{block_size} ) * $self->{block_space}; $end_block_total = ( ($x_num_end - ($x_num_end % $self->{block_size}) ) / $self->{block_size} ) * $self->{block_space}; $wrap_block_total = ( ($self->{wrap} - ( ($self->{wrap} - 1) % $self->{block_size}) ) / $self->{block_size} ) * $self->{block_space}; $self->{image}->bgcolor($color); $self->{image}->fgcolor($color); if($y_num_start == $y_num_end) #if the label does not cross the wrap line { $self->{image}->rectangle( $self->{seq_start_x} + ( ($x_num_start) * $self->{x_char_size} ) + $start_block_total, $self->{seq_start_y} + (($self->{no_sequences}) * $self->{y_char_size}) + ($y_num_start * $y_char), $self->{seq_start_x} + (($x_num_end) * $self->{x_char_size}) + $end_block_total, $self->{seq_start_y} + (($self->{no_sequences} + 1) * $self->{y_char_size}) + ($y_num_start * $y_char)); $self->{image}->fgcolor($self->{fg_color}); $self->{image}->bgcolor($self->{bg_color}); $self->{image}->moveTo( $self->{seq_start_x} + ( ($x_num_start + $label_x) * $self->{x_char_size}) + $start_block_total, $self->{seq_start_y} + (($self->{no_sequences} + 1) * $self->{y_char_size}) + ($y_num_start * $y_char) ); $self->{image}->font($self->{font}); $self->{image}->string($label); }else { $self->{image}->rectangle( $self->{seq_start_x} + ( ($x_num_start) * $self->{x_char_size} ) + $start_block_total, $self->{seq_start_y} + (($self->{no_sequences}) * $self->{y_char_size}) + ($y_num_start * $y_char), $self->{seq_start_x} + (($self->{wrap}) * $self->{x_char_size}) + $wrap_block_total, $self->{seq_start_y} + (($self->{no_sequences} + 1) * $self->{y_char_size}) + ($y_num_start * $y_char)); $self->{image}->rectangle( $self->{seq_start_x} , $self->{seq_start_y} + (($self->{no_sequences}) * $self->{y_char_size}) + ($y_num_end * $y_char), $self->{seq_start_x} + (($x_num_end) * $self->{x_char_size}) + $end_block_total, $self->{seq_start_y} + (($self->{no_sequences} + 1) * $self->{y_char_size}) + ($y_num_end * $y_char)); $self->{image}->fgcolor($self->{fg_color}); $self->{image}->bgcolor($self->{bg_color}); $self->{image}->moveTo( $self->{seq_start_x} + ( ($x_num_start + $label_x_start) * $self->{x_char_size}) + $start_block_total, $self->{seq_start_y} + (($self->{no_sequences} + 1) * $self->{y_char_size}) + ($y_num_start * $y_char) ); $self->{image}->font($self->{font}); $self->{image}->string($label); $self->{image}->moveTo( $self->{seq_start_x} + ( $label_x_end * $self->{x_char_size}), $self->{seq_start_y} + (($self->{no_sequences} + 1) * $self->{y_char_size}) + ($y_num_end * $y_char) ); $self->{image}->font($self->{font}); $self->{image}->string($label); } } } ############################################## #Draw Y Label sub y_label{ my $self = shift; $self->{image}->fgcolor($self->{y_label_color}); my $y_num = $self->{y_num}; #sprintf( "%.0f" , (($self->{seq_length} / $self->{wrap}) + .5)) - 1; my $y_char = $self->{y_size}; # ( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); for(my $k=0; $k<$y_num; $k++) { for (my $i=0; $i< $self->{no_sequences}; $i++) { $self->{image}->moveTo($self->{pad_left}, $self->{seq_start_y} + ($i * $self->{y_char_size}) + ($k * $y_char) ); $self->{image}->font($self->{font}); $self->{image}->string(${$self->{seq_ids}}[$i]); } } } ##################################################### #Draw X Label sub x_label{ my $self = shift; my $block_num = 0; my $block_total = 0; $self->{image}->fgcolor($self->{x_label_color}); my $y_char = $self->{y_size}; # ( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); for (my $i=1; $i<= $self->{seq_length}; $i++) { my $y_num = floor( $i / $self->{wrap}); # Used to be int(), but perl documentation advises against this my $x_num; if($i >= $self->{wrap}) { $x_num = ($i % $self->{wrap}); }else { $x_num = $i; } my @digits = split //, reverse($i); if( ($i % $self->{block_size}) == 0) { $block_num = $self->{block_space}; }else { $block_num = 0; } if( (($i - 1) % $self->{block_size}) == 0) { for (my $j=0; $j<=$#digits; $j++) { if ( defined($self->{show_nonsynonymous}) ) { $self->{image}->moveTo($self->{seq_start_x} + $block_total + ( ($x_num-1) * $self->{x_char_size}) + ( ( floor( ($x_num-1)/3 ) * $self->{x_char_size} ) + ( ( floor( ($x_num-1)/3 ) ) * 6 )), ($self->{pad_top} + length($self->{seq_length_aa}) - $j) * $self->{y_char_size} + ($y_num * $y_char)); }else { $self->{image}->moveTo($self->{seq_start_x} + $block_total + ( ($x_num-1) * $self->{x_char_size}), ($self->{pad_top} + length($self->{seq_length}) - $j) * $self->{y_char_size} + ($y_num * $y_char)); } $self->{image}->font($self->{font}); $self->{image}->string($digits[$j]); } } if($x_num == 0) { $block_total = 0; }else { $block_total += $block_num; } } } #################################################### #Domain Highlighting sub _draw_domain{ my $self = shift; my $block_total = 0; my ($start, $end, $block_num); my $y_char = $self->{y_size}; # ( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); for (my $k=0; $k <= $#{$self->{domain_start}}; $k++) { #print STDERR join "\n", GD::Simple->color_names; my $dmc = $self->{domain_color}[$k] || $self->{domain_color}[-1] || "silver"; $start = ${$self->{domain_start}}[$k] - 1; $end = ${$self->{domain_end}}[$k] - 1; for (my $i=0; $i < $self->{no_sequences}; $i++) { for (my $j = $start; $j <= $end; $j++) { my $y_num = int( $j / $self->{wrap}); my $x_num; if($j >= $self->{wrap}) { $x_num = ($j % $self->{wrap}); }else { $x_num = $j; } #print "J: $j\nXNUM: $x_num\nYNUM: $y_num\n"; $block_total = ( ($x_num - ($x_num % $self->{block_size}) ) / $self->{block_size} ) * $self->{block_space}; $self->{image}->bgcolor($dmc); $self->{image}->fgcolor($dmc); if ( defined($self->{show_nonsynonymous}) ) { # NOTE To shade amino acids as well, change $x_num HERE and HERE to $x_num + 1 $self->{image}->rectangle( $self->{seq_start_x} + ( ($x_num ) * $self->{x_char_size} ) + $block_total - 1 + ( ( floor( $x_num / 3 ) * $self->{x_char_size} ) + ( ( floor( $x_num / 3 ) ) * 6 )), $self->{seq_start_y} + ( $i * $self->{y_char_size} ) - $self->{y_char_size} + ($y_num * $y_char) , $self->{seq_start_x} + (($x_num + 1) * $self->{x_char_size}) + $block_total - 1 + ( ( floor( ($x_num)/3 ) * $self->{x_char_size} ) + ( ( floor( ($x_num)/3 ) ) * 6 )), $self->{seq_start_y} + ( $i * $self->{y_char_size}) + ($y_num * $y_char)); }else { $self->{image}->rectangle( $self->{seq_start_x} + ( ($x_num ) * $self->{x_char_size} ) + $block_total - 1, $self->{seq_start_y} + ( $i * $self->{y_char_size} ) - $self->{y_char_size} + ($y_num * $y_char) , $self->{seq_start_x} + (($x_num + 1) * $self->{x_char_size}) + $block_total - 1, $self->{seq_start_y} + ( $i * $self->{y_char_size}) + ($y_num * $y_char)); } #$self->{image}->rectangle( $self->{seq_start_x} + ( ($j) * $self->{x_char_size} ) + $block_total, $self->{seq_start_y} + ($i - 1 * $self->{y_char_size}), $self->{seq_start_x} + (($j + 1) * $self->{x_char_size}) + $block_total , $self->{seq_start_y} + ( ($i) * $self->{y_char_size})); $self->{image}->fgcolor($self->{fg_color}); $self->{image}->bgcolor($self->{bg_color}); } $block_total = 0; } } } sub _draw_colored_sequences{ my $self = shift; my $block_num = 0; my $block_total = 0; my $print_char; my %colors; for my $values ( keys %PROTEIN_COLORS) { #print STDERR "$values : @{ $PROTEIN_COLORS{$values} }\n"; $colors{$values} = $self->{image}->colorAllocate(@{ $PROTEIN_COLORS{$values} }); } $self->{p_color_table} = \%colors; $self->{image}->fgcolor($self->{fg_color}); for (my $i=0; $i < $self->{no_sequences}; $i++) { my @letters = split //, ${$self->{sequences}}[$i]; my $y_num = $self->{y_num}; #sprintf( "%.0f", ( ($self->{seq_length} / $self->{wrap}) + .5) ) - 1; my $y_char = $self->{y_size}; #( ($self->{no_sequences} + $self->{pad_bottom}) * $self->{y_char_size}); for(my $k=0; $k<=$y_num; $k++) { my $x_char = $k * $self->{wrap}; for (my $j=$x_char; $j <= ( ($x_char + $self->{wrap}) - 1); $j++) { last unless defined($letters[$j]); $print_char = $letters[$j]; if( ( ($j + 1) % ($self->{block_size})) == 0) { $block_num = $self->{block_space}; }else { $block_num = 0; } #print "Chunk Space: $chunk_space\n"; $self->{image}->bgcolor($colors{$print_char}); $self->{image}->fgcolor($colors{$print_char}); $self->{image}->rectangle( $self->{seq_start_x} + ( ($j - $x_char) * $self->{x_char_size} ) + $block_total - 1 , $self->{seq_start_y} + ( $i * $self->{y_char_size} ) + ($k * $y_char) - $self->{y_char_size} , $self->{seq_start_x} + (($j - $x_char + 1) * $self->{x_char_size}) + $block_total - 1 , $self->{seq_start_y} + ($k * $y_char) + ( $i * $self->{y_char_size})); $self->{image}->moveTo($self->{seq_start_x} + ( ($j - $x_char) * $self->{x_char_size}) + $block_total, $self->{seq_start_y} + ($k * $y_char) + ($i * $self->{y_char_size}) ); $self->{image}->fgcolor($self->{fg_color}); $self->{image}->font($self->{font}); $self->{image}->string($print_char); if( defined($self->{labels}) && $i == ($self->{no_sequences} - 1)) { if(${$self->{labels}}{$j + 1}) { my $label = ${$self->{labels}}{$j + 1}; my $offset = defined($self->{dm_label_start}) ? 3 : 0; $self->{image}->moveTo($self->{seq_start_x} + ( ( ($j - $x_char) + 1.25) * $self->{x_char_size}) + $block_total, $self->{seq_start_y} + (($self->{no_sequences}) * $self->{y_char_size}) + ($k * $y_char) + ( (length($label) + $offset) * ($self->{x_char_size}) ) ); $self->{image}->font($self->{font}); $self->{image}->angle(-90); $self->{image}->string($label); $self->{image}->angle(0); } } $block_total += $block_num; } $block_total = 0; } } } sub _draw_legend{ my $self = shift; my $title_font = $FONT_TABLE{3}; my @l_order = ("Negatively Charged", "Positively Charged", "Hydrophobic", "Aromatic", "Found in Loops", "Large Polar Acids"); my %legend = ("Negatively Charged" => ["D" , "E"] , "Positively Charged" => ["K", "R"] , "Hydrophobic" => ["A","F","I","L","M","V","W","Y"] , "Aromatic" => ["F", "H", "W", "Y"] , "Found in Loops" => ["D", "G", "P", "S", "T"] , "Large Polar Acids" => ["H", "K", "N", "Q", "R"]); my $x1 = 2; my $x2 = 42; my $colors = $self->{p_color_table}; my $y_start = $self->{footer_start}; my $label = "Protein Color Legend"; $self->{image}->bgcolor($self->{bg_color}); $self->{image}->fgcolor($self->{fg_color}); $self->{image}->rectangle(1,$y_start, 70 * $self->{x_char_size}, $self->{height} - 2); $self->{image}->moveTo((35 - (length($label) / 2) ) * $self->{x_char_size} , $y_start + $self->{y_char_size}); $self->{image}->font($title_font); $self->{image}->string($label); my $count = 3; foreach my $c_label (@l_order) { if( ($count % 2) == 0) { $self->{image}->moveTo( $x2 * $self->{x_char_size}, $y_start + ( ($count - 1) * $self->{y_char_size})); $self->{image}->font($self->{font}); $self->{image}->string($c_label); my $i = 0; foreach my $chars(@{$legend{$c_label}}) { $self->{image}->bgcolor($$colors{$chars}); $self->{image}->fgcolor($$colors{$chars}); $self->{image}->rectangle( ($x2 + 20 + $i) * $self->{x_char_size}, $y_start + ( ($count - 2) * $self->{y_char_size}), ($x2 + 20 + $i + 1) * $self->{x_char_size}, $y_start + ( ($count -1) * $self->{y_char_size})); $self->{image}->bgcolor($self->{bg_color}); $self->{image}->fgcolor($self->{fg_color}); $i++; } }else { $self->{image}->moveTo($x1 * $self->{x_char_size} , $y_start + ($count * $self->{y_char_size})); $self->{image}->font($self->{font}); $self->{image}->string($c_label); my $i = 0; foreach my $chars(@{$legend{$c_label}}) { $self->{image}->bgcolor($$colors{$chars}); $self->{image}->fgcolor($$colors{$chars}); $self->{image}->rectangle( ($x1 + 20 + $i) * $self->{x_char_size}, $y_start + ( ($count - 1) * $self->{y_char_size}), ($x1 + 20 + $i + 1) * $self->{x_char_size}, $y_start + ( ($count) * $self->{y_char_size})); $self->{image}->bgcolor($self->{bg_color}); $self->{image}->fgcolor($self->{fg_color}); $i++; } } $count += 1; } } ######################################## #####ACCESSORS##### sub width{ my $self = shift; return $self->{image}->width if exists $self->{image}; } sub height{ my $self = shift; return $self->{image}->height if exists $self->{image}; } sub aln_length{ my $self = shift; return $self->{seq_length} if exists $self->{seq_length}; } sub aln_format{ my $self = shift; return $self->{seq_format} if exists $self->{seq_format}; } sub no_sequences{ my $self = shift; return $self->{no_sequences} if exists $self->{no_sequences}; } 1; __END__ =head1 NAME Bio::Align::Graphics - Graphic Rendering of Bio::Align::AlignI Objects =head1 SYNOPSIS use Bio::Align::Graphics; #Get an AlignI object, usually by using Bio::AlignIO my $file=shift @ARGV; my $in=new Bio::AlignIO(-file=>$file, -format=>'clustalw'); my $aln=$in->next_aln(); #Create a new Graphics object my $print_align = new Bio::Align::Graphics(align => $aln); #Draw the alignment $print_align->draw(); =head1 DESCRIPTION Bio::Align::Graphics is a module designed to create image files out of Bio::Align::AlignI objects. An alignment may be manipulated with various formatting and highlighting options. An example: #!/usr/bin/perl -w use Bio::AlignIO; use Bio::Align::Graphics; use strict; #Get an alignment file my $file = shift @ARGV; #Create an AlignI object using AlignIO my $in=new Bio::AlignIO(-file=>$file, -format=>'clustalw'); #Read the alignment my $aln=$in->next_aln(); #Create some domains for highlighting my @domain_start = ( 25 , 50, 80 ); my @domain_end = ( 40 , 60 , 100 ); my @domain_color = ( 'red' , 'cyan' , 'green' ); #Create Labels for the domains my @dml = ("CARD", "Proline Rich", "Transmembrane"); my @dml_start = (25, 50, 80); my @dml_end = (40, 60, 100); my @dml_color = ("lightpink", "lightblue", "lightgreen"); #Create individual labels my %labels = ( 145 => "Hep-c target"); my $print_align = new Bio::Align::Graphics( align => $aln, pad_bottom => 5, domain_start => \@domain_start, domain_end => \@domain_end, dm_color => \@domain_color, dm_labels => \@dml, dm_label_start => \@dml_start, dm_label_end => \@dml_end, dm_label_color => \@dml_color, labels => \%labels, out_format => "png"); $print_align->draw(); =head1 METHODS This section describes the class and object methods for Bio::Align::Graphics. Typically you will begin by creating a Bio::Align::Graphics object, passing it an alignment object created using Bio::AlignIO. The Bio::Align::Graphics-Enew() method has a number of configuration variables that allow you to control the appearance of the final image. You will then call the draw() method to output the final image. =head1 CONSTRUCTORS new() is the constructor for Bio::Align::Graphics: =over 4 =item $print_align = Bio::Align::Graphics-Enew(@options) The new() method creates a new graphics object. The options are a set of tag/value pairs as follows: Option Value Default ------ ----- ------- align Bio::AlignI object None, must be supplied to draw an alignment output Filename to print image to STDOUT out_format png, jpeg, gif, gd png font Size of font, ranging from 1 to 5 2 and equal to the standard GD fonts ranging from gdTinyFont to gdGiantFont x_label Draws a scale numbering alignment true bases along top of image, every x bases are numbered, where x is the block_size option y_label Draws sequence ids of alignment true along left side of image bg_color Background color of the image white font_color Color of the font used for drawing black the alignment characters x_label_color Color of the font used for drawing red the base scale characters y_label_color Color of the font used for drawing blue the sequence id characters p_color Colors protein bases according to false a coloring scheme proposed by W.R. Taylor(Protein Engineering, vol 10 no 7, 1997), only works with protein alignments pad_top Additional whitespace characters 5 between top of image and x-label pad_bottom Additional whitespace characters 5 between bottom of image and alignment pad_left Additional whitespace characters 5 between left side of image and y-label pad_right Additional whitespace characters 5 between right side of image and alignment x_label_space Additional whitespace characters 1 between x_label and alignment y_label_space Additional whitespace characters 1 between y_label and alignment reference Characters which are identical to false the reference sequence are replaced with the match character reference_id Sequence id of the sequence to use First sequence as the reference supplied in alignment match_char Character to replace identical bases . in aligned sequences block_size Number of bases to group together 10 when printing alignment, groups are separated by whitespace block_space Amount of character whitespace to 2 separate groups of bases by labels A hash containing labels to be none printed beneath the alignment, where the keys are the bases to print the values at dm_start An array containing start bases none for highlighting of segments of the alignment, paired with dm_end option dm_end An array containing end bases none for highlighting of segments of the alignment, paired with dm_start options dm_color An array containing colors for silver highlighting segments of bases denoted by the coordinates located in the dm_start and dm_end options dml_start An array containing start bases none for addition of domain labels underneath the alignment, paired with dml_end dml_end An array containing end bases none for addition of domain labels underneath the alignment, paired with dml_start dml_color An array containing colors for silver the domain labels denoted by the coordinates located in the dml_start and dml_end options dm_labels An array containing labels to be none printed underneath specified domains, each label should correspond with the base position located in the dml_start option show_nonsynonymous Boolean value to turn option false on or off. If 0 (or undef), option is off. If 1 (or non-0), option is on. Only valid for nucleotide alignments. Output images are wider with this option on. Note that all arrays and hashes must be passed by reference. =back =head1 OBJECT METHODS =over 4 =item $draw_align-Edraw(); The draw() method draws the image with the options that were specified with new(). =item $draw_align-Ewidth(); Get the width of the image created with new(), in pixels. =item $draw_align-Eheight(); Get the height of the image created with new(), in pixels. =item $draw_align-Ealn_length(); Get the length of the alignment submitted to new(). =item $draw_align-Ealn_format(); Get the format of the alignment submitted to new(). =item $draw_align-Eno_sequences(); Get the number of sequences in the alignment submitted to new(). =back =head1 AUTHORS AND CONTRIBUTORS William McCaig, Ewmccaig@gmail.comE Mikhail Bekarev, Embekarev@hunter.cuny.eduE YE<246>zen HernE<225>ndez, Eyzhernand@gmail.comE Weigang Qiu (Corresponding Developer), Eweigang@genectr.hunter.cuny.eduE =head1 COPYRIGHT AND LICENSE Copyright (C) 2006-2008 by William McCaig This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.3 or, at your option, any later version of Perl 5 you may have available. =head1 SEE ALSO L, L, L, L =cut BioPerl-1.6.923/Bio/Align/PairwiseStatistics.pm000444000765000024 1630212254227317 21422 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Align::PairwiseStatistics # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Align::PairwiseStatistics - Base statistic object for Pairwise Alignments =head1 SYNOPSIS use strict; my $stats = Bio::Align::PairwiseStatistics->new(); # get alignment object of two sequences somehow my $pwaln; print $stats->number_of_comparable_bases($pwaln); my $score = $stats->score_nuc($pwaln); =head1 DESCRIPTION Calculate pairwise statistics. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Align::PairwiseStatistics; use vars qw($GapChars); use strict; BEGIN { $GapChars = '(\.|\-)'; } use base qw(Bio::Root::Root Bio::Align::StatisticsI); =head2 number_of_comparable_bases Title : number_of_comparable_bases Usage : my $bases = $stat->number_of_comparable_bases($aln); Function: Returns the count of the number of bases that can be compared (L) in this alignment ( length - gaps) Returns : integer Args : L =cut sub number_of_comparable_bases{ my ($self,$aln) = @_; if ( ! defined $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->throw("Must provide a Bio::Align::AlignI compliant object to ". "Bio::Align::PairwiseStatistics"); return 0; } elsif ( $aln->num_sequences != 2 ) { $self->throw("Only pairwise calculations supported. Found ". $aln->num_sequences." sequences in alignment\n"); } my $L = $aln->length - $self->number_of_gaps($aln); return $L; } =head2 number_of_differences Title : number_of_differences Usage : my $nd = $stat->number_of_distances($aln); Function: Returns the number of differences between two sequences Returns : integer Args : L =cut sub number_of_differences{ my ($self,$aln) = @_; if( ! defined $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->throw("Must provide a Bio::Align::AlignI compliant object to ". "Bio::Align::PairwiseStatistics"); } elsif ( $aln->num_sequences != 2 ) { $self->throw("Only pairwise calculations supported. Found ". $aln->num_sequences." sequences in alignment\n"); } my (@seqs); foreach my $seq ( $aln->each_seq ) { push @seqs, [ split(//,$seq->seq())]; } my $firstseq = shift @seqs; #my $secondseq = shift @seqs; my $diffcount = 0; for (my $i = 0;$i<$aln->length; $i++ ) { next if ( $firstseq->[$i] =~ /^$GapChars$/ ); foreach my $seq ( @seqs ) { next if ( $seq->[$i] =~ /^$GapChars$/ ); if( $firstseq->[$i] ne $seq->[$i] ) { $diffcount++; } } } return $diffcount; } =head2 number_of_gaps Title : number_of_gaps Usage : my $nd = $stat->number_of_gaps($aln); Function: Returns the number of gapped positions among sequences in alignment Returns : integer Args : L =cut sub number_of_gaps{ my ($self,$aln) = @_; if ( ! defined $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->throw("Must provide a Bio::Align::AlignI compliant object to ". "Bio::Align::PairwiseStatistics"); } elsif ( $aln->num_sequences != 2 ) { $self->throw("Only pairwise calculations supported. Found ". $aln->num_sequences." sequences in alignment\n"); } my $gapline = $aln->gap_line; # this will count the number of '-' characters return $gapline =~ tr/-/-/; } =head2 score_nuc Title : score_nuc Usage : my $score = $stat->score_nuc($aln); or my $score = $stat->score_nuc( -aln =>$aln, -match => 1, -mismatch => -1, -gap_open => -1, -gap_ext => -1 ); Function: Calculate the score of an alignment of 2 nucleic acid sequences. The scoring parameters can be specified. Otherwise the blastn default parameters are used: match = 2, mismatch = -3, gap opening = -5, gap extension = -2 Returns : alignment score (number) Args : L match score [optional] mismatch score [optional] gap opening score [optional] gap extension score [optional] =cut sub score_nuc { my ($self, @args) = @_; my ( $aln, $match, $mismatch, $gap_open, $gap_ext) = $self->_rearrange( [qw( ALN MATCH MISMATCH GAP_OPEN GAP_EXT)], @args ); if ( ! defined $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->throw("Must provide a Bio::Align::AlignI compliant object to ". "Bio::Align::PairwiseStatistics"); } elsif ( $aln->num_sequences != 2 ) { $self->throw("Only pairwise calculations supported. Found ". $aln->num_sequences." sequences in alignment\n"); } my $seq1 = $aln->get_seq_by_pos(1); my $seq2 = $aln->get_seq_by_pos(2); if (! ( ($seq1->alphabet eq 'dna' || $seq1->alphabet eq 'rna') && ($seq2->alphabet eq 'dna' || $seq2->alphabet eq 'rna') )) { $self->throw("Can only score nucleic acid alignments"); } $match ||= 2; # Blastn scoring defaults $mismatch ||= -3; $gap_open ||= -5; $gap_ext ||= -2; my $score = 0; my $prevres1 = '-'; my $prevres2 = '-'; for (my $pos = 1 ; $pos <= $aln->length ; $pos++) { my $res1 = $seq1->subseq($pos, $pos); my $res2 = $seq2->subseq($pos, $pos); if (!($res1 eq '-' || $res2 eq '-')) { # no gap if ($res1 eq $res2) { # same residue $score += $match; } else { # other residue $score += $mismatch; } } else { # open or ext gap? my $open = 0; if (!($res1 eq '-' && $res2 eq '-')) { # exactly one gap my $prevres = $prevres1; $prevres = $prevres2 if $res2 eq '-'; $open = 1 unless $prevres eq '-'; } else { # 2 gaps $open = 1 unless $prevres1 eq '-' && $prevres2 eq '-'; } if ($open) { $score += $gap_open; # gap opening } else { $score += $gap_ext; # gap extension } } $prevres1 = $res1; $prevres2 = $res2; } return $score; } 1; BioPerl-1.6.923/Bio/Align/ProteinStatistics.pm000444000765000024 2052612254227336 21263 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Align::ProteinStatistics # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Align::ProteinStatistics - Calculate Protein Alignment statistics (mostly distances) =head1 SYNOPSIS use Bio::Align::ProteinStatistics; use Bio::AlignIO; my $in = Bio::AlignIO->new(-format => 'fasta', -file => 'pep-104.fasaln'); my $aln = $in->next_aln; my $pepstats = Bio::Align::ProteinStatistics->new(); $kimura = $protstats->distance(-align => $aln, -method => 'Kimura'); print $kimura->print_matrix; =head1 DESCRIPTION This object is for generating various statistics from a protein alignment. Mostly it is where pairwise protein distances can be calculated. =head1 REFERENCES D_Kimura - Kimura, M. 1983. The Neutral Theory of Molecular Evolution. CUP, Cambridge. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Align::ProteinStatistics; use vars qw(%DistanceMethods $Precision $DefaultGapPenalty); use strict; use Bio::Align::PairwiseStatistics; use Bio::Matrix::PhylipDist; %DistanceMethods = ('kimura|k' => 'Kimura', ); $Precision = 5; $DefaultGapPenalty = 0; use base qw(Bio::Root::Root Bio::Align::StatisticsI); =head2 new Title : new Usage : my $obj = Bio::Align::ProteinStatistics->new(); Function: Builds a new Bio::Align::ProteinStatistics object Returns : an instance of Bio::Align::ProteinStatistics Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->pairwise_stats( Bio::Align::PairwiseStatistics->new()); return $self; } =head2 distance Title : distance Usage : my $distance_mat = $stats->distance(-align => $aln, -method => $method); Function: Calculates a distance matrix for all pairwise distances of sequences in an alignment. Returns : L object Args : -align => Bio::Align::AlignI object -method => String specifying specific distance method (implementing class may assume a default) =cut sub distance{ my ($self,@args) = @_; my ($aln,$method) = $self->_rearrange([qw(ALIGN METHOD)],@args); if( ! defined $aln || ! ref ($aln) || ! $aln->isa('Bio::Align::AlignI') ) { $self->throw("Must supply a valid Bio::Align::AlignI for the -align parameter in distance"); } $method ||= 'Kimura'; foreach my $m ( keys %DistanceMethods ) { if(defined $m && $method =~ /$m/i ) { my $mtd = "D_$DistanceMethods{$m}"; return $self->$mtd($aln); } } $self->warn("Unrecognized distance method $method must be one of [". join(',',$self->available_distance_methods())."]"); return; } =head2 available_distance_methods Title : available_distance_methods Usage : my @methods = $stats->available_distance_methods(); Function: Enumerates the possible distance methods Returns : Array of strings Args : none =cut sub available_distance_methods{ my ($self,@args) = @_; return values %DistanceMethods; } =head2 D - distance methods =cut =head2 D_Kimura Title : D_Kimura Usage : my $matrix = $pepstats->D_Kimura($aln); Function: Calculate Kimura protein distance (Kimura 1983) which approximates PAM distance D = -ln ( 1 - p - 0.2 * p^2 ) Returns : L Args : L =cut # Kimura, M. 1983. The Neutral Theory of Molecular Evolution. CUP, Cambridge. sub D_Kimura{ my ($self,$aln) = @_; return 0 unless $self->_check_arg($aln); # ambiguities ignored at this point my (@seqs,@names,@values,%dist); my $seqct = 0; foreach my $seq ( $aln->each_seq) { push @names, $seq->display_id; push @seqs, uc $seq->seq(); $seqct++; } my $len = $aln->length; my $precisionstr = "%.$Precision"."f"; for( my $i = 0; $i < $seqct-1; $i++ ) { # (diagonals) distance is 0 for same sequence $dist{$names[$i]}->{$names[$i]} = [$i,$i]; $values[$i][$i] = sprintf($precisionstr,0); for( my $j = $i+1; $j < $seqct; $j++ ) { my ($scored,$match) = (0,0); for( my $k=0; $k < $len; $k++ ) { my $m1 = substr($seqs[$i],$k,1); my $m2 = substr($seqs[$j],$k,1); if( $m1 ne '-' && $m2 ne '-' ) { # score is number of scored bases (alignable bases) # it could have also come from # my $L = $self->pairwise_stats->number_of_comparable_bases($pairwise); # match is number of matches weighting ambiguity bases # as well $match += _check_ambiguity_protein($m1,$m2); $scored++; } } # From Felsenstein's PHYLIP documentation: # This is very quick to do but has some obvious # limitations. It does not take into account which amino # acids differ or to what amino acids they change, so some # information is lost. The units of the distance measure # are fraction of amino acids differing, as also in the # case of the PAM distance. If the fraction of amino acids # differing gets larger than 0.8541 the distance becomes # infinite. my $D = 1 - ( $match / $scored ); if( $D < 0.8541 ) { $D = - log ( 1 - $D - (0.2 * ($D ** 2))); $values[$j][$i] = $values[$i][$j] = sprintf($precisionstr,$D); } else { $values[$j][$i] = $values[$i][$j] = ' NaN'; } # fwd and rev lookup $dist{$names[$i]}->{$names[$j]} = [$i,$j]; $dist{$names[$j]}->{$names[$i]} = [$i,$j]; # (diagonals) distance is 0 for same sequence $dist{$names[$j]}->{$names[$j]} = [$j,$j]; $values[$j][$j] = sprintf($precisionstr,0); } } return Bio::Matrix::PhylipDist->new(-program => 'bioperl_PEPstats', -matrix => \%dist, -names => \@names, -values => \@values); } # some methods from EMBOSS distmat sub _check_ambiguity_protein { my ($t1,$t2) = @_; my $n = 0; if( $t1 ne 'X' && $t1 eq $t2 ) { $n = 1.0; } elsif( (($t1 eq 'B' && $t2 =~ /[DN]/ ) || ($t2 eq 'B' && $t1 =~ /[DN]/ )) || (($t1 eq 'Z' && $t2 =~ /[EQ]/) || ($t2 eq 'Z' && $t1 =~ /[EQ]/ ))) { $n = 0.5; } elsif ( $t1 eq 'X' && $t2 eq 'X' ) { $n = 0.0025; } elsif( $t1 eq 'X' || $t2 eq 'X' ) { $n = 0.05; } return $n; } =head2 Data Methods =cut =head2 pairwise_stats Title : pairwise_stats Usage : $obj->pairwise_stats($newval) Function: Returns : value of pairwise_stats Args : newvalue (optional) =cut sub pairwise_stats{ my ($self,$value) = @_; if( defined $value) { $self->{'_pairwise_stats'} = $value; } return $self->{'_pairwise_stats'}; } sub _check_arg { my($self,$aln ) = @_; if( ! defined $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI compliant object to Bio::Align::DNAStatistics"); return 0; } elsif( $aln->get_seq_by_pos(1)->alphabet ne 'protein' ) { $self->warn("Must provide a protein alignment to Bio::Align::ProteinStatistics, you provided a " . $aln->get_seq_by_pos(1)->alphabet); return 0; } return 1; } 1; BioPerl-1.6.923/Bio/Align/StatisticsI.pm000444000765000024 506712254227327 20016 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Align::StatisticsI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Align::StatisticsI - Calculate some statistics for an alignment =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the interface here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Align::StatisticsI; use strict; use base qw(Bio::Root::RootI); =head2 distance Title : distance Usage : my $distance_mat = $stats->distance(-align => $aln, -method => $method); Function: Calculates a distance matrix for all pairwise distances of sequences in an alignment. Returns : Array ref Args : -align => Bio::Align::AlignI object -method => String specifying specific distance method (implementing class may assume a default) =cut sub distance{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 available_distance_methods Title : available_distance_methods Usage : my @methods = $stats->available_distance_methods(); Function: Enumerates the possible distance methods Returns : Array of strings Args : none =cut sub available_distance_methods{ my ($self,@args) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Align/Utilities.pm000444000765000024 4453512254227327 17551 0ustar00cjfieldsstaff000000000000package Bio::Align::Utilities; use strict; use warnings; use Carp; use Bio::Root::Version; use Exporter 'import'; our @EXPORT_OK = qw( aa_to_dna_aln bootstrap_replicates cat bootstrap_replicates_codons dna_to_aa_aln most_common_sequences ); our %EXPORT_TAGS = (all => \@EXPORT_OK); # # BioPerl module for Bio::Align::Utilities # # Please direct questions and support issues to # # Cared for by Jason Stajich and Brian Osborne # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Align::Utilities - A collection of utilities regarding converting and manipulating alignment objects =head1 SYNOPSIS use Bio::Align::Utilities qw(:all); # Even if the protein alignments are local make sure the start/end # stored in the LocatableSeq objects are to the full length protein. # The coding sequence that is passed in should still be the full # length CDS as the nt alignment will be generated. # %dnaseqs is a hash of CDS sequences (spliced) my $dna_aln = aa_to_dna_aln($aa_aln,\%dnaseqs); # The reverse, which is simpler. The input alignment has to be # translate-able, with gap lengths and an overall length divisible by 3 my $aa_aln = dna_to_aa_aln($dna_al); # Generate bootstraps my $replicates = bootstrap_replicates($aln,$count); =head1 DESCRIPTION This module contains utility methods for manipulating sequence alignments (L) objects. The B utility is essentially the same as the B program by Bill Pearson available at ftp://ftp.virginia.edu/pub/fasta/other/mrtrans.shar. Of course this is a pure-Perl implementation, but just to mention that if anything seems odd you can check the alignments generated against Bill's program. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut use constant CODONSIZE => 3; our $GAP = '-'; our $CODONGAP = $GAP x CODONSIZE; =head2 aa_to_dna_aln Title : aa_to_dna_aln Usage : my $dnaaln = aa_to_dna_aln($aa_aln, \%seqs); Function: Will convert an AA alignment to DNA space given the corresponding DNA sequences. Note that this method expects the DNA sequences to be in frame +1 (GFF frame 0) as it will start to project into coordinates starting at the first base of the DNA sequence, if this alignment represents a different frame for the cDNA you will need to edit the DNA sequences to remove the 1st or 2nd bases (and revcom if things should be). Returns : Bio::Align::AlignI object Args : 2 arguments, the alignment and a hashref. Alignment is a Bio::Align::AlignI of amino acid sequences. The hash reference should have keys which are the display_ids for the aa sequences in the alignment and the values are a Bio::PrimarySeqI object for the corresponding spliced cDNA sequence. See also: L, L, L =cut sub aa_to_dna_aln { my ( $aln, $dnaseqs ) = @_; unless ( defined $aln && ref($aln) && $aln->isa('Bio::Align::AlignI') ) { croak( 'Must provide a valid Bio::Align::AlignI object as the first argument to aa_to_dna_aln, see the documentation for proper usage and the method signature' ); } my $alnlen = $aln->length; my $dnaalign = Bio::SimpleAlign->new(); $aln->map_chars( '\.', $GAP ); foreach my $seq ( $aln->each_seq ) { my $aa_seqstr = $seq->seq(); my $id = $seq->display_id; my $dnaseq = $dnaseqs->{$id} || $aln->throw( "cannot find " . $seq->display_id ); my $start_offset = ( $seq->start - 1 ) * CODONSIZE; $dnaseq = $dnaseq->seq(); my $dnalen = $dnaseqs->{$id}->length; my $nt_seqstr; my $j = 0; for ( my $i = 0 ; $i < $alnlen ; $i++ ) { my $char = substr( $aa_seqstr, $i + $start_offset, 1 ); if ( $char eq $GAP || $j >= $dnalen ) { $nt_seqstr .= $CODONGAP; } else { $nt_seqstr .= substr( $dnaseq, $j, CODONSIZE ); $j += CODONSIZE; } } $nt_seqstr .= $GAP x ( ( $alnlen * 3 ) - length($nt_seqstr) ); my $newdna = Bio::LocatableSeq->new( -display_id => $id, -alphabet => 'dna', -start => $start_offset + 1, -end => ( $seq->end * CODONSIZE ), -strand => 1, -seq => $nt_seqstr ); $dnaalign->add_seq($newdna); } return $dnaalign; } =head2 dna_to_aa_aln Title : dna_to_aa_aln Usage : my $aa_aln = dna_to_aa_aln($dna_aln); Function: Convert a DNA alignment to an amino acid alignment where the length of all alignment strings and the lengths of any gaps must be divisible by 3 Returns : Bio::Align::AlignI object Args : the DNA alignment, a Bio::Align::AlignI of DNA sequences See also: L, L, L =cut sub dna_to_aa_aln { my $dna_aln = shift; unless ( defined $dna_aln && ref($dna_aln) && $dna_aln->isa('Bio::Align::AlignI') ) { croak( 'Must provide a valid Bio::Align::AlignI object as the argument to dna_to_aa_aln' ); } my $codon_table = Bio::Tools::CodonTable->new; my $aa_aln = Bio::SimpleAlign->new; for my $seq ( $dna_aln->each_seq ) { my ($aa_str, $aa_len); my @aln_str = split '', $seq->seq; croak("All lines in the alignment must have lengths divisible by 3") if ( scalar(@aln_str) % CODONSIZE ); while ( @aln_str ) { my $triplet = join '', (splice( @aln_str, 0, CODONSIZE )); if ( $triplet =~ /^[GATC]+$/i ) { $aa_str .= $codon_table->translate($triplet); $aa_len++; } elsif ( $triplet =~ /^[$Bio::LocatableSeq::GAP_SYMBOLS]+$/ ) { $aa_str .= $GAP; } else { croak("The triplet '$triplet' is neither a valid codon nor all gaps"); } } my $new_aa = Bio::LocatableSeq->new( -display_id => $seq->display_id, -alphabet => 'protein', -start => 1, -end => $aa_len, -strand => 1, -seq => $aa_str ); $aa_aln->add_seq($new_aa); } $aa_aln; } =head2 bootstrap_replicates Title : bootstrap_replicates Usage : my $alns = &bootstrap_replicates($aln,100); Function: Generate a pseudo-replicate of the data by randomly sampling, with replacement, the columns from an alignment for the non-parametric bootstrap. Returns : Arrayref of L objects Args : L object Number of replicates to generate =cut sub bootstrap_replicates { my ( $aln, $count ) = @_; $count ||= 1; my $alen = $aln->length; my ( @seqs, @nm ); $aln->set_displayname_flat(1); for my $s ( $aln->each_seq ) { push @seqs, $s->seq(); push @nm, $s->id; } my ( @alns, $i ); while ( $count-- > 0 ) { my @newseqs; for ( $i = 0 ; $i < $alen ; $i++ ) { my $index = int( rand($alen) ); my $c = 0; for (@seqs) { $newseqs[ $c++ ] .= substr( $_, $index, 1 ); } } my $newaln = Bio::SimpleAlign->new(); my $i = 0; for my $s (@newseqs) { ( my $tmp = $s ) =~ s/[$Bio::LocatableSeq::GAP_SYMBOLS]+//g; $newaln->add_seq( Bio::LocatableSeq->new( -start => 1, -end => length($tmp), -display_id => $nm[ $i++ ], -seq => $s ) ); } push @alns, $newaln; } return \@alns; } =head2 bootstrap_replicates_codons Title : bootstrap_replicates_codons Usage : my $alns = &bootstrap_replicates_codons($aln,100); Function: Generate a pseudo-replicate of the data by randomly sampling, with replacement, the columns from a codon alignment for the non-parametric bootstrap. The alignment is assumed to start on the first position of a codon. Returns : Arrayref of L objects Args : L object Number of replicates to generate =cut sub bootstrap_replicates_codons { my ( $aln, $count ) = @_; $count ||= 1; my $alen = $aln->length; my $ncodon = int( $alen / 3 ); my ( @seqs, @nm ); $aln->set_displayname_flat(1); for my $s ( $aln->each_seq ) { push @seqs, $s->seq(); push @nm, $s->id; } my ( @alns, $i ); while ( $count-- > 0 ) { my @newseqs; for ( $i = 0 ; $i < $ncodon ; $i++ ) { my $index = int( rand($ncodon) ); my $seqpos = $index * 3; my $c = 0; for (@seqs) { $newseqs[ $c++ ] .= substr( $_, $seqpos, 3 ); } } my $newaln = Bio::SimpleAlign->new(); my $i = 0; for my $s (@newseqs) { ( my $tmp = $s ) =~ s{[$Bio::LocatableSeq::GAP_SYMBOLS]+}{}g; $newaln->add_seq( Bio::LocatableSeq->new( -start => 1, -end => length($tmp), -display_id => $nm[ $i++ ], -seq => $s ) ); } push @alns, $newaln; } return \@alns; } =head2 cat Title : cat Usage : $aln123 = cat($aln1, $aln2, $aln3) Function : Concatenates alignment objects. Sequences are identified by id. An error will be thrown if the sequence ids are not unique in the first alignment. If any ids are not present or not unique in any of the additional alignments then those sequences are omitted from the concatenated alignment, and a warning is issued. An error will be thrown if any of the alignments are not flush, since concatenating such alignments is unlikely to make biological sense. Returns : A new Bio::SimpleAlign object Args : A list of Bio::SimpleAlign objects =cut sub cat { my ( $self, @aln ) = @_; $self->throw("cat method called with no arguments") unless $self; for ( $self, @aln ) { $self->throw( $_->id . " is not a Bio::Align::AlignI object" ) unless $_->isa('Bio::Align::AlignI'); $self->throw( $_->id . " is not flush" ) unless $_->is_flush; } my $aln = $self->new; $aln->id( $self->id ); $aln->annotation( $self->annotation ); my %unique; SEQ: foreach my $seq ( $self->each_seq() ) { throw( "ID: ", $seq->id, " is not unique in initial alignment." ) if exists $unique{ $seq->id }; $unique{ $seq->id } = 1; # Can be Bio::LocatableSeq, Bio::Seq::Meta or Bio::Seq::Meta::Array my $new_seq = $seq->new( -id => $seq->id, -strand => $seq->strand, -verbose => $self->verbose ); $new_seq->seq( $seq->seq ); $new_seq->start( $seq->start ); $new_seq->end( $seq->end ); if ( $new_seq->isa('Bio::Seq::MetaI') ) { for my $meta_name ( $seq->meta_names ) { $new_seq->named_submeta( $meta_name, $new_seq->start, $new_seq->end, $seq->named_meta($meta_name) ); } } for my $cat_aln (@aln) { my @cat_seq = $cat_aln->each_seq_with_id( $seq->id ); if ( @cat_seq == 0 ) { $self->warn( $seq->id . " not found in alignment " . $cat_aln->id . ", skipping this sequence." ); next SEQ; } if ( @cat_seq > 1 ) { $self->warn( $seq->id . " found multiple times in alignment " . $cat_aln->id . ", skipping this sequence." ); next SEQ; } my $cat_seq = $cat_seq[0]; my $old_end = $new_seq->end; $new_seq->seq( $new_seq->seq . $cat_seq->seq ); # Not sure if this is a sensible way to deal with end coordinates $new_seq->end( $new_seq->end + $cat_seq->end + 1 - $cat_seq->start ); if ( $cat_seq->isa('Bio::Seq::Meta::Array') ) { unless ( $new_seq->isa('Bio::Seq::Meta::Array') ) { my $meta_seq = Bio::Seq::Meta::Array->new; $meta_seq->seq( $new_seq->seq ); $meta_seq->start( $new_seq->start ); $meta_seq->end( $new_seq->end ); if ( $new_seq->isa('Bio::Seq::Meta') ) { for my $meta_name ( $new_seq->meta_names ) { $meta_seq->named_submeta( $meta_name, $new_seq->start, $old_end, [ split( //, $new_seq->named_meta($meta_name) ) ] ); } } $new_seq = $meta_seq; } for my $meta_name ( $cat_seq->meta_names ) { $new_seq->named_submeta( $meta_name, $old_end + 1, $new_seq->end, $cat_seq->named_meta($meta_name) ); } } elsif ( $cat_seq->isa('Bio::Seq::Meta') ) { if ( $new_seq->isa('Bio::Seq::Meta::Array') ) { for my $meta_name ( $cat_seq->meta_names ) { $new_seq->named_submeta( $meta_name, $old_end + 1, $new_seq->end, [ split( //, $cat_seq->named_meta($meta_name) ) ] ); } } else { unless ( $new_seq->isa('Bio::Seq::Meta') ) { my $meta_seq = Bio::Seq::Meta::Array->new; $meta_seq->seq( $new_seq->seq ); $meta_seq->start( $new_seq->start ); $meta_seq->end( $new_seq->end ); $new_seq = $meta_seq; } for my $meta_name ( $cat_seq->meta_names ) { $new_seq->named_submeta( $meta_name, $old_end + 1, $new_seq->end, $cat_seq->named_meta($meta_name) ); } } } } $aln->add_seq($new_seq); } my $cons_meta = $self->consensus_meta; my $new_cons_meta; if ($cons_meta) { $new_cons_meta = Bio::Seq::Meta->new(); for my $meta_name ( $cons_meta->meta_names ) { $new_cons_meta->named_submeta( $meta_name, 1, $self->length, $cons_meta->$meta_name ); } } my $end = $self->length; for my $cat_aln (@aln) { my $cat_cons_meta = $cat_aln->consensus_meta; if ($cat_cons_meta) { $new_cons_meta = Bio::Seq::Meta->new() if !$new_cons_meta; for my $meta_name ( $cat_cons_meta->meta_names ) { $new_cons_meta->named_submeta( $meta_name, $end + 1, $end + $cat_aln->length, $cat_cons_meta->$meta_name ); } } $end += $cat_aln->length; } $aln->consensus_meta($new_cons_meta) if $new_cons_meta; return $aln; } =head2 most_common_sequences Title : most_common_sequences Usage : @common = most_common_sequences ($align, $case_sensitivity) Function : Returns an array of the sequences that appear most often in the alignment (although this probably makes more sense when there is only a single most common sequence). Sequences are compared after removing any "-" (gap characters), and ambiguous units (e.g., R for purines) are only compared to themselves. The returned sequence is also missing the "-" since they don't actually make part of the sequence. Returns : Array of text strings. Arguments : Optional argument defining whether the comparison between sequences to find the most common should be case sensitive. Defaults to false, i.e, not case sensitive. =cut sub most_common_sequences { my $align = shift or croak ("Must provide Bio::AlignI object to Bio::Align::Utilities::most_common_sequences"); my $case_sensitive = shift; # defaults to false (we get undef if nothing) ## We keep track of the max on this loop. Saves us having to ## transverse the hash table later to find the maximum value. my $max = 0; my %counts; foreach ($align->each_seq) { (my $seq = $_->seq) =~ tr/-//d; $seq = uc ($seq) unless $case_sensitive; $max++ if (++$counts{$seq} > $max); } my @common = grep ($counts{$_} == $max, keys %counts); return @common; } 1; BioPerl-1.6.923/Bio/AlignIO000755000765000024 012254227337 15301 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/AlignIO/arp.pm000444000765000024 2153012254227336 16576 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::arp # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::arp - ARP MSA Sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can create L objects from ARP flat files. These are typically configuration-like data files for the program Arlequin. For more information, see: http://lgb.unige.ch/arlequin/ For the moment, this retains the allele sequence data in the DATA section and inserts them into SimpleAlign objects. ARP files that contain other data (RFLP, etc.) are not expected to parse properly. Also, if the DNA data is actually SNP data, then the LocatableSeq object instantiation will throw an error. This is now set up as a generic parser (i.e. it parses everything) and collects as much data as possible into the SimpleAlign object. The following in a general mapping of where data can be found: Tag SimpleAlign Method ---------------------------------------------------------------------- Title description SampleName id ---------------------------------------------------------------------- Tag Bio::Annotation TagName Bio::Annotation Class Parameters ---------------------------------------------------------------------- NE SimpleValue pfam_family_accession value NL SimpleValue sequence_start_stop value SS SimpleValue sec_structure_source value BM SimpleValue build_model value RN Reference reference * ---------------------------------------------------------------------- * RN is generated based on the number of Bio::Annotation::Reference objects In addition, the number of samples found in the alignment is retained in a Bio::Annotation::TagTree object in the annotation collection and is accessible via: ($samples) = $aln->annotation->get_Annotations('Samples'); say $samples->display_text; # or use other relevant TagTree methods to retrieve data =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Chris Fields (cjfields) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::arp; use strict; use base qw(Bio::AlignIO); use Data::Dumper; use Bio::Annotation::AnnotationFactory; =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln Function: returns the next alignment in the stream. Returns : Bio::Align::AlignI object - returns 0 on end of file or on error Args : -width => optional argument to specify the width sequence will be written (60 chars by default) See L =cut sub next_aln { my $self = shift; my $aln = Bio::SimpleAlign->new(-source => 'arp'); my ($data, $cur_block, $cur_type, $cur_data); SCAN: while (defined ($data = $self->_readline) ) { next if $data =~ m{^\s*$}xms; if ($data =~ m{\[{1,2}(\w+)\]{1,2}}xms) { $self->{state}->{current_block} = $1; next SCAN; } elsif ($data =~ m{^\s*(\w+)=\s?(\S[^\n]*$)}xms) { ($cur_type, $cur_data) = ($1, $2); if ($cur_data =~ m{^\s*\{\s*$}) { $self->throw("Curly block must be embedded in a named Block") if !exists($self->{state}->{current_block}); $self->{state}->{in_curly_block} = 1; next SCAN; } $cur_data =~ s{[\"\']}{}g; $cur_data =~ s{\s*$}{}; # per alignment annotation data (i.e. Sample Blocks) or # annotation data retained for each alignment? $self->{state}->{current_block} eq 'Samples' ? push @{$self->{state}->{SampleAnnotation}->{$cur_type}}, $cur_data : push @{$self->{state}->{Annotation}->{$cur_type}}, $cur_data; } elsif ($data =~ m{^\s*\}\s*$}xms) { $self->throw("Unmatched bracket in ARP file:\n$data") if !exists($self->{state}->{in_curly_block}); if ($self->{state}->{current_block} eq 'Samples') {; my $ac = $self->_process_annotation($aln); delete $self->{state}->{SampleAnnotation}; } else { # process other data at a later point } delete $self->{state}->{blockdata}; $self->{state}->{in_curly_block} = 0; last SCAN; } else { # all other data should be in a curly block and have a block title $self->throw("Data found outside of proper block:\n$data") if !exists($self->{state}->{current_block}) && !$self->{state}->{in_curly_block}; # bypass commented stuff (but we may want to process it at a later # point, so turn back here) next if $data =~ m{^\s*\#}xms; if ($self->{state}->{current_block} eq 'Samples') { chomp $data; # we have two possible ways to deal with sample number, either # clone the LocatableSeq (in which case we need to deal with ID # duplication), or store as annotation data. I chose the latter # route using a Bio::Annotation::TagTree. YMMV - cjfields 10-15-08 my ($ls, $samples) = $self->_process_sequence($data); my $id = $ls->id; push @{ $self->{state}->{SampleAnnotation}->{Samples} }, [$id => $samples]; $aln->add_seq($ls); } else { # add elsif's for further processing #$self->debug('Unmatched data in block '. # $self->{state}->{current_block}. # ":\n$data\n"); $self->{state}->{blockdata} .= $data; } } } # alignments only returned if they contain sequences return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in xmfa format Returns : 1 for success and 0 for error Args : L object See L =cut sub write_aln { my ($self,@aln) = @_; $self->throw_not_implemented; } ################ PRIVATE SUBS ################ sub _process_sequence { my ($self, $raw) = @_; return unless defined $raw; $raw =~ s{(?:^\s+|\s+$)}{}g; my ($id, $samples, $seq) = split(' ', $raw); my $ls = Bio::LocatableSeq->new('-seq' => $seq, '-start' => 1, '-display_id' => $id, '-alphabet' => $self->alphabet); return($ls, $samples); } sub _process_annotation { my ($self, $aln) = @_; my $coll = Bio::Annotation::Collection->new(); my $factory = Bio::Annotation::AnnotationFactory->new(-type => 'Bio::Annotation::SimpleValue'); for my $anntype (qw(SampleAnnotation Annotation)) { for my $key (keys %{ $self->{state}->{$anntype} }) { if ($key eq 'Title') { $aln->description($self->{state}->{$anntype}->{$key}[0]); } elsif ($key eq 'Samples') { $factory->type('Bio::Annotation::TagTree'); $coll->add_Annotation($key, $factory->create_object( -value => [$key => $self->{state}->{$anntype}->{$key}])); $factory->type('Bio::Annotation::SimpleValue'); } elsif ($key eq 'SampleName') { $aln->id($self->{state}->{$anntype}->{$key}[0]); } else { $self->throw('Expecting an array reference') unless ref $self->{state}->{$anntype}->{$key} eq 'ARRAY'; for my $a (@{ $self->{state}->{$anntype}->{$key} }) { $coll->add_Annotation($key, $factory->create_object( -value => $a) ); } } } } #$self->debug("Collection:".Dumper($coll)."\n"); $aln->annotation($coll); } 1; BioPerl-1.6.923/Bio/AlignIO/bl2seq.pm000444000765000024 1312012254227314 17174 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::bl2seq # based on the Bio::SeqIO modules # by Ewan Birney # and Lincoln Stein # # the Bio::Tools::BPlite modules by # Ian Korf (ifkorf at ucdavis.edu, http://www.bioperl.org/wiki/Ian_Korf), # Lorenz Pollak (lorenz@ist.org, bioperl port) # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::bl2seq - bl2seq sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class, as in: use Bio::AlignIO; $in = Bio::AlignIO->new(-file => "inputfilename" , -format => "bl2seq", -report_type => "blastn"); $aln = $in->next_aln(); =head1 DESCRIPTION This object can create L sequence alignment objects (of two sequences) from C BLAST reports. A nice feature of this module is that - in combination with L or a remote BLAST - it can be used to align two sequences and make a L object from them which can then be manipulated using any L methods, eg: # Get two sequences $str = Bio::SeqIO->new(-file=>'t/amino.fa' , '-format' => 'Fasta', ); my $seq3 = $str->next_seq(); my $seq4 = $str->next_seq(); # Run bl2seq on them $factory = Bio::Tools::StandAloneBlast->new('program' => 'blastp', 'outfile' => 'bl2seq.out'); my $bl2seq_report = $factory->bl2seq($seq3, $seq4); # Note that report is a Bio::SearchIO object # Use AlignIO.pm to create a SimpleAlign object from the bl2seq report $str = Bio::AlignIO->new(-file=> 'bl2seq.out','-format' => 'bl2seq'); $aln = $str->next_aln(); =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Schattner Email: schattner@alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::bl2seq; use strict; use Bio::SearchIO; use base qw(Bio::AlignIO); =head2 new Title : new Usage : my $alignio = Bio::SimpleAlign->new(-format => 'bl2seq', -file => 'filename', -report_type => 'blastx'); Function: Get a L Returns : L object Args : -report_type => report type (blastn,blastx,tblastx,tblastn,blastp) =cut sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize(@args); my ($rt) = $self->_rearrange([qw(REPORT_TYPE)],@args); defined $rt && $self->report_type($rt); } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object on success, undef on error or end of file Args : none =cut sub next_aln { my $self = shift; unless (exists $self->{'_searchio'}) { $self->{'_searchio'} = Bio::SearchIO->new(-fh => $self->_fh, -format => 'blast', -report_type => $self->report_type); } while (1) { if (!exists $self->{'_result'}) { $self->{'_result'} = $self->{'_searchio'}->next_result; } return if !defined $self->{'_result'}; if (!exists $self->{'_hit'}) { $self->{'_hit'} = $self->{'_result'}->next_hit; } # out of hits for this result? if (!defined $self->{'_hit'}) { delete $self->{'_result'}; next; } my $hsp = $self->{'_hit'}->next_hsp; # out of hsps for this hit? if (!defined $hsp) { delete $self->{'_hit'}; next; } $hsp ? return $hsp->get_aln: return; } } =head2 write_aln (NOT IMPLEMENTED) Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in bl2seq format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; $self->throw_not_implemented(); } =head2 report_type Title : report_type Usage : $obj->report_type($newval) Function: Sets the report type (blastn, blastp...) Returns : value of report_type (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub report_type{ my $self = shift; return $self->{'report_type'} = shift if @_; return $self->{'report_type'}; } 1; BioPerl-1.6.923/Bio/AlignIO/clustalw.pm000444000765000024 2431312254227322 17647 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::clustalw # # based on the Bio::SeqIO modules # by Ewan Birney # and Lincoln Stein # and the Bio::SimpleAlign module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # History # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::clustalw - clustalw sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::AlignIO class. =head1 DESCRIPTION This object can transform Bio::Align::AlignI objects to and from clustalw files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Peter Schattner Email: schattner@alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::clustalw; use vars qw($LINELENGTH $CLUSTALPRINTVERSION); use strict; $LINELENGTH = 60; $CLUSTALPRINTVERSION = '1.81'; use base qw(Bio::AlignIO); =head2 new Title : new Usage : $alignio = Bio::AlignIO->new(-format => 'clustalw', -file => 'filename'); Function: returns a new Bio::AlignIO object to handle clustalw files Returns : Bio::AlignIO::clustalw object Args : -verbose => verbosity setting (-1, 0, 1, 2) -file => name of file to read in or to write, with ">" -fh => alternative to -file param - provide a filehandle to read from or write to -format => alignment format to process or produce -percentages => display a percentage of identity in each line of the alignment (clustalw only) -linelength=> alignment output line length (default 60) =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ( $percentages, $ll ) = $self->_rearrange( [qw(PERCENTAGES LINELENGTH)], @args ); defined $percentages && $self->percentages($percentages); $self->line_length( $ll || $LINELENGTH ); } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream Returns : Bio::Align::AlignI object Args : NONE See L for details =cut sub next_aln { my ($self) = @_; my $first_line; while ( $first_line = $self->_readline ) { last if $first_line !~ /^$/; } $self->_pushback($first_line); if ( defined( $first_line = $self->_readline ) && $first_line !~ /CLUSTAL/ ) { $self->throw( "trying to parse a file which does not start with a CLUSTAL header" ); } my %alignments; my $aln = Bio::SimpleAlign->new( -source => 'clustalw', -verbose => $self->verbose ); my $order = 0; my %order; $self->{_lastline} = ''; my ($first_block, $seen_block) = (0,0); while ( defined( $_ = $self->_readline ) ) { next if (/^\s+$/ && !$first_block); if (/^\s$/) { # line contains no description $seen_block = 1; next; } $first_block = 1; # break the loop if we come to the end of the current alignment # and push back the CLUSTAL header if (/CLUSTAL/) { $self->_pushback($_); last; } my ( $seqname, $aln_line ) = ( '', '' ); if (/^\s*(\S+)\s*\/\s*(\d+)-(\d+)\s+(\S+)\s*$/ox) { # clustal 1.4 format ( $seqname, $aln_line ) = ( "$1:$2-$3", $4 ); # } elsif( /^\s*(\S+)\s+(\S+)\s*$/ox ) { without trailing numbers } elsif (/^\s*(\S+)\s+(\S+)\s*\d*\s*$/ox) { # with numbers ( $seqname, $aln_line ) = ( $1, $2 ); if ( $seqname =~ /^[\*\.\+\:]+$/ ) { $self->{_lastline} = $_; next; } } else { $self->{_lastline} = $_; next; } if ( !$seen_block ) { if (exists $order{$seqname}) { $self->warn("Duplicate sequence : $seqname\n". "Can't guarantee alignment quality"); } else { $order{$seqname} = $order++; } } $alignments{$seqname} .= $aln_line; } my ( $sname, $start, $end ); foreach my $name ( sort { $order{$a} <=> $order{$b} } keys %alignments ) { if ( $name =~ /(\S+):(\d+)-(\d+)/ ) { ( $sname, $start, $end ) = ( $1, $2, $3 ); } else { ( $sname, $start ) = ( $name, 1 ); my $str = $alignments{$name}; $str =~ s/[^A-Za-z]//g; $end = length($str); } my $seq = Bio::LocatableSeq->new ( '-seq' => $alignments{$name}, '-display_id' => $sname, '-start' => $start, '-end' => $end, '-alphabet' => $self->alphabet, ); $aln->add_seq($seq); } # not sure if this should be a default option - or we can pass in # an option to do this in the future? --jason stajich # $aln->map_chars('\.','-'); # no sequences added, so just return return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the clustalw-format object (.aln) into the stream Returns : 1 for success and 0 for error Args : Bio::Align::AlignI object =cut sub write_aln { my ( $self, @aln ) = @_; my ( $count, $length, $seq, @seq, $tempcount, $line_len ); $line_len = $self->line_length || $LINELENGTH; foreach my $aln (@aln) { if ( !$aln || !$aln->isa('Bio::Align::AlignI') ) { $self->warn( "Must provide a Bio::Align::AlignI object when calling write_aln" ); next; } my $matchline = $aln->match_line; if ( $self->force_displayname_flat ) { $aln->set_displayname_flat(1); } $self->_print( sprintf( "CLUSTAL W (%s) multiple sequence alignment\n\n\n", $CLUSTALPRINTVERSION ) ) or return; $length = $aln->length(); $count = $tempcount = 0; @seq = $aln->each_seq(); my $max = 22; foreach $seq (@seq) { $max = length( $aln->displayname( $seq->get_nse() ) ) if ( length( $aln->displayname( $seq->get_nse() ) ) > $max ); } while ( $count < $length ) { my ( $linesubstr, $first ) = ( '', 1 ); foreach $seq (@seq) { # # Following lines are to suppress warnings # if some sequences in the alignment are much longer than others. my ($substring); my $seqchars = $seq->seq(); SWITCH: { if ( length($seqchars) >= ( $count + $line_len ) ) { $substring = substr( $seqchars, $count, $line_len ); if ($first) { $linesubstr = substr( $matchline, $count, $line_len ); $first = 0; } last SWITCH; } elsif ( length($seqchars) >= $count ) { $substring = substr( $seqchars, $count ); if ($first) { $linesubstr = substr( $matchline, $count ); $first = 0; } last SWITCH; } $substring = ""; } $self->_print( sprintf( "%-" . $max . "s %s\n", $aln->displayname( $seq->get_nse() ), $substring ) ) or return; } my $percentages = ''; if ( $self->percentages ) { my ($strcpy) = ($linesubstr); my $count = ( $strcpy =~ tr/\*// ); $percentages = sprintf( "\t%d%%", 100 * ( $count / length($linesubstr) ) ); } $self->_print( sprintf( "%-" . $max . "s %s%s\n", '', $linesubstr, $percentages ) ); $self->_print( sprintf("\n\n") ) or return; $count += $line_len; } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 percentages Title : percentages Usage : $obj->percentages($newval) Function: Set the percentages flag - whether or not to show percentages in each output line Returns : value of percentages Args : newvalue (optional) =cut sub percentages { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_percentages'} = $value; } return $self->{'_percentages'}; } =head2 line_length Title : line_length Usage : $obj->line_length($newval) Function: Set the alignment output line length Returns : value of line_length Args : newvalue (optional) =cut sub line_length { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_line_length'} = $value; } return $self->{'_line_length'}; } 1; BioPerl-1.6.923/Bio/AlignIO/emboss.pm000444000765000024 1513412254227332 17303 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::emboss # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::emboss - Parse EMBOSS alignment output (from applications water and needle) =head1 SYNOPSIS # do not use the object directly use Bio::AlignIO; # read in an alignment from the EMBOSS program water my $in = Bio::AlignIO->new(-format => 'emboss', -file => 'seq.water'); while( my $aln = $in->next_aln ) { # do something with the alignment } =head1 DESCRIPTION This object handles parsing and writing pairwise sequence alignments from the EMBOSS suite. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::emboss; use vars qw($EMBOSSTitleLen $EMBOSSLineLen); use strict; use Bio::LocatableSeq; use base qw(Bio::AlignIO); BEGIN { $EMBOSSTitleLen = 13; $EMBOSSLineLen = 50; } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); $self->{'_type'} = undef; } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object - returns 0 on end of file or on error Args : NONE =cut sub next_aln { my ($self) = @_; my $seenbegin = 0; my %data = ( 'seq1' => { 'start'=> undef, 'end'=> undef, 'name' => '', 'data' => '' }, 'seq2' => { 'start'=> undef, 'end'=> undef, 'name' => '', 'data' => '' }, 'align' => '', 'type' => $self->{'_type'}, # to restore type from # previous aln if possible ); my %names; while( defined($_ = $self->_readline) ) { next if( /^\#?\s+$/ || /^\#+\s*$/ ); if( /^\#(\=|\-)+\s*$/) { last if( $seenbegin); } elsif( /(Local|Global):\s*(\S+)\s+vs\s+(\S+)/ || /^\#\s+Program:\s+(\S+)/ ) { my ($name1,$name2) = ($2,$3); if( ! defined $name1 ) { # Handle EMBOSS 2.2.X $data{'type'} = $1; $name1 = $name2 = ''; } else { $data{'type'} = $1 eq 'Local' ? 'water' : 'needle'; } $data{'seq1'}->{'name'} = $name1; $data{'seq2'}->{'name'} = $name2; $self->{'_type'} = $data{'type'}; } elsif( /Score:\s+(\S+)/ ) { $data{'score'} = $1; } elsif( /^\#\s+(1|2):\s+(\S+)/ && ! $data{"seq$1"}->{'name'} ) { my $nm = $2; $nm = substr($nm,0,$EMBOSSTitleLen); # emboss has a max seq length if( $names{$nm} ) { $nm .= "-". $names{$nm}; } $names{$nm}++; $data{"seq$1"}->{'name'} = $nm; } elsif( $data{'seq1'}->{'name'} && /^\Q$data{'seq1'}->{'name'}/ ) { my $count = 0; $seenbegin = 1; my @current; while( defined ($_) ) { my $align_other = ''; my $delayed; if($count == 0 || $count == 2 ) { my @l = split; my ($seq,$align,$start,$end); if( $count == 2 && $data{'seq2'}->{'name'} eq '' ) { # weird boundary condition ($start,$align,$end) = @l; } elsif( @l == 3 ) { $align = ''; ($seq,$start,$end) = @l } else { ($seq,$start,$align,$end) = @l; } my $seqname = sprintf("seq%d", ($count == 0) ? '1' : '2'); $data{$seqname}->{'data'} .= $align; $data{$seqname}->{'start'} ||= $start; $data{$seqname}->{'end'} = $end; $current[$count] = [ $start,$align || '']; } else { s/^\s+//; s/\s+$//; $data{'align'} .= $_; } BOTTOM: last if( $count++ == 2); $_ = $self->_readline(); } if( $data{'type'} eq 'needle' ) { # which ever one is shorter we want to bring it up to # length. Man this stinks. my ($s1,$s2) = ($data{'seq1'}, $data{'seq2'}); my $d = length($current[0]->[1]) - length($current[2]->[1]); if( $d < 0 ) { # s1 is smaller, need to add some # compare the starting points for this alignment line if( $current[0]->[0] <= 1 ) { $s1->{'data'} = ('-' x abs($d)) . $s1->{'data'}; $data{'align'} = (' 'x abs($d)).$data{'align'}; } else { $s1->{'data'} .= '-' x abs($d); $data{'align'} .= ' 'x abs($d); } } elsif( $d > 0) { # s2 is smaller, need to add some if( $current[2]->[0] <= 1 ) { $s2->{'data'} = ('-' x abs($d)) . $s2->{'data'}; $data{'align'} = (' 'x abs($d)).$data{'align'}; } else { $s2->{'data'} .= '-' x abs($d); $data{'align'} .= ' 'x abs($d); } } } } } return unless $seenbegin; my $aln = Bio::SimpleAlign->new(-verbose => $self->verbose(), -score => $data{'score'}, -source => "EMBOSS-".$data{'type'}); foreach my $seqname ( qw(seq1 seq2) ) { return unless ( defined $data{$seqname} ); $data{$seqname}->{'name'} ||= $seqname; my $seq = Bio::LocatableSeq->new ('-seq' => $data{$seqname}->{'data'}, '-display_id' => $data{$seqname}->{'name'}, '-start' => $data{$seqname}->{'start'}, '-end' => $data{$seqname}->{'end'}, '-alphabet' => $self->alphabet, ); $aln->add_seq($seq); } return $aln; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in emboss format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; $self->throw("Sorry: writing emboss output is not currently available! \n"); } 1; BioPerl-1.6.923/Bio/AlignIO/fasta.pm000444000765000024 1510212254227314 17104 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::fasta # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::fasta - fasta MSA Sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from fasta flat files. This is for the fasta alignment format, not for the FastA sequence analysis program. To process the alignments from FastA (FastX, FastN, FastP, tFastA, etc) use the Bio::SearchIO module. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Peter Schattner =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::fasta; use strict; use base qw(Bio::AlignIO); our $WIDTH = 60; use Bio::LocatableSeq; =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln Function: returns the next alignment in the stream. Returns : Bio::Align::AlignI object - returns 0 on end of file or on error Args : -width => optional argument to specify the width sequence will be written (60 chars by default) See L =cut sub next_aln { my $self = shift; my ($width) = $self->_rearrange( [qw(WIDTH)], @_ ); $self->width( $width || $WIDTH ); my ($start, $end, $name, $seqname, $seq, $seqchar, $entry, $tempname, $tempdesc, %align, $desc, $maxlen ); my $aln = Bio::SimpleAlign->new(); while ( defined( $entry = $self->_readline ) ) { chomp $entry; if ( $entry =~ s/^>\s*(\S+)\s*// ) { $tempname = $1; chomp($entry); $tempdesc = $entry; if ( defined $name ) { $seqchar =~ s/\s//g; $seqname = $name; $start = 1; $end = $self->_get_len($seqchar); $seq = Bio::LocatableSeq->new( -seq => $seqchar, -display_id => $seqname, -description => $desc, -start => $start, -end => $end, -alphabet => $self->alphabet, ); $aln->add_seq($seq); $self->debug("Reading $seqname\n"); } $desc = $tempdesc; $name = $tempname; $desc = $entry; $seqchar = ""; next; } # removed redundant symbol validation # this is already done in Bio::PrimarySeq $seqchar .= $entry; } # Next two lines are to silence warnings that # otherwise occur at EOF when using <$fh> $name = "" if ( !defined $name ); $seqchar = "" if ( !defined $seqchar ); $seqchar =~ s/\s//g; # Put away last name and sequence if ( $name =~ /(\S+)\/(\d+)-(\d+)$/ ) { $seqname = $1; $start = $2; $end = $3; } else { $seqname = $name; $start = 1; $end = $self->_get_len($seqchar); } # This logic now also reads empty lines at the # end of the file. Skip this is seqchar and seqname is null unless ( length($seqchar) == 0 && length($seqname) == 0 ) { $seq = Bio::LocatableSeq->new( -seq => $seqchar, -display_id => $seqname, -description => $desc, -start => $start, -end => $end, -alphabet => $self->alphabet, ); $aln->add_seq($seq); $self->debug("Reading $seqname\n"); } my $alnlen = $aln->length; foreach my $seq ( $aln->each_seq ) { if ( $seq->length < $alnlen ) { my ($diff) = ( $alnlen - $seq->length ); $seq->seq( $seq->seq() . "-" x $diff ); } } # no sequences means empty alignment (possible EOF) return $aln if $aln->num_sequences; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in fasta format Returns : 1 for success and 0 for error Args : L object See L =cut sub write_aln { my ($self,@aln) = @_; my $width = $self->width; my ($seq,$desc,$rseq,$name,$count,$length,$seqsub); foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } if( $self->force_displayname_flat ) { $aln->set_displayname_flat(1); } foreach $rseq ( $aln->each_seq() ) { $name = $aln->displayname($rseq->get_nse()); $seq = $rseq->seq(); $desc = $rseq->description || ''; $desc = ' '.$desc if $desc; $self->_print (">$name$desc\n") or return; $count = 0; $length = length($seq); if(defined $seq && $length > 0) { $seq =~ s/(.{1,$width})/$1\n/g; } else { $seq = "\n"; } $self->_print($seq); } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 _get_len Title : _get_len Usage : Function: determine number of alphabetic chars Returns : integer Args : sequence string =cut sub _get_len { my ($self,$seq) = @_; my $chars = $Bio::LocatableSeq::GAP_SYMBOLS.$Bio::LocatableSeq::FRAMESHIFT_SYMBOLS; $seq =~ s{[$chars]+}{}gi; return CORE::length($seq); } =head2 width Title : width Usage : $obj->width($newwidth) $width = $obj->width; Function: Get/set width of alignment Returns : integer value of width Args : on set, new value (a scalar or undef, optional) =cut sub width{ my $self = shift; return $self->{'_width'} = shift if @_; return $self->{'_width'} || $WIDTH; } 1; BioPerl-1.6.923/Bio/AlignIO/largemultifasta.pm000444000765000024 1255512254227332 21203 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::largemultifasta # based on the Bio::SeqIO::largefasta module # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Albert Vilella # # You may distribute this module under the same terms as perl itself # _history # January 20, 2004 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::largemultifasta - Largemultifasta MSA Sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from largemultifasta flat file databases. This is for the fasta sequence format NOT FastA analysis program. To process the pairwise alignments from a FastA (FastX, FastN, FastP, tFastA, etc) use the Bio::SearchIO module. Reimplementation of Bio::AlignIO::fasta modules so that creates temporary files instead of keeping the whole sequences in memory. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Albert Vilella, Heikki Lehvaslaiho Email: avilella-at-gmail-dot-com, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::largemultifasta; use strict; use Bio::Seq::LargeLocatableSeq; use Bio::Seq::SeqFactory; use base qw(Bio::AlignIO Bio::SeqIO Bio::SimpleAlign); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new( -verbose => $self->verbose(), -type => 'Bio::Seq::LargeLocatableSeq' )); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream while taking care of the length Returns : Bio::Seq object Args : NONE =cut sub next_seq { my ($self) = @_; my $largeseq = $self->sequence_factory->create(-alphabet=>$self->alphabet); my ($id,$fulldesc,$entry); my $count = 0; my $seen = 0; while( defined ($entry = $self->_readline) ) { if( $seen == 1 && $entry =~ /^\s*>/ ) { $self->_pushback($entry); return $largeseq; } if ( $entry eq '>' ) { $seen = 1; next; } elsif( $entry =~ /\s*>(.+?)$/ ) { $seen = 1; ($id,$fulldesc) = ($1 =~ /^\s*(\S+)\s*(.*)$/) or $self->warn("Can't parse fasta header"); $largeseq->display_id($id); $largeseq->primary_id($id); $largeseq->desc($fulldesc); } else { $entry =~ s/\s+//g; $largeseq->add_sequence_as_string($entry); } (++$count % 1000 == 0 && $self->verbose() > 0) && print "line $count\n"; } if( ! $seen ) { return; } return $largeseq; } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object - returns 0 on end of file or on error Args : NONE =cut sub next_aln { my $self = shift; my $largeseq; my $aln = Bio::SimpleAlign->new(); while (defined ($largeseq = $self->next_seq) ) { $aln->add_seq($largeseq); $self->debug("sequence readed\n"); } my $alnlen = $aln->length; foreach my $largeseq ( $aln->each_seq ) { if( $largeseq->length < $alnlen ) { my ($diff) = ($alnlen - $largeseq->length); $largeseq->seq("-" x $diff); } } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in largemultifasta format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; my ($seq,$desc,$rseq,$name,$count,$length,$seqsub); foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } foreach $rseq ( $aln->each_seq() ) { $name = $aln->displayname($rseq->get_nse()); $seq = $rseq->seq(); $desc = $rseq->description || ''; $self->_print (">$name $desc\n") or return ; $count =0; $length = length($seq); while( ($count * 60 ) < $length ) { $seqsub = substr($seq,$count*60,60); $self->_print ("$seqsub\n") or return ; $count++; } } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/maf.pm000444000765000024 1014012254227331 16545 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::maf # # Copyright Allen Day # =head1 NAME Bio::AlignIO::maf - Multiple Alignment Format sequence input stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::AlignIO class. use Bio::AlignIO; my $alignio = Bio::AlignIO->new(-fh => \*STDIN, -format => 'maf'); while(my $aln = $alignio->next_aln()){ my $match_line = $aln->match_line; print $aln, "\n"; print $aln->length, "\n"; print $aln->num_residues, "\n"; print $aln->is_flush, "\n"; print $aln->num_sequences, "\n"; $aln->splice_by_seq_pos(1); print $aln->consensus_string(60), "\n"; print $aln->get_seq_by_pos(1)->seq, "\n"; print $aln->match_line(), "\n"; print "\n"; } =head1 DESCRIPTION This class constructs Bio::SimpleAlign objects from an MAF-format multiple alignment file. Writing in MAF format is currently unimplemented. Spec of MAF format is here: http://genome.ucsc.edu/FAQ/FAQformat =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Allen Day Email: allenday@ucla.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::maf; use strict; use Bio::SimpleAlign; use base qw(Bio::AlignIO); =head2 new Title : new Usage : my $alignio = Bio::AlignIO->new(-format => 'maf' -file => '>file', -idlength => 10, -idlinebreak => 1); Function: Initialize a new L reader Returns : L object Args : =cut sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); 1; } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Throws an exception if trying to read in PHYLIP sequential format. Returns : L object Args : =cut sub next_aln { my $self = shift; # check beginning of file for proper header if(!$self->{seen_header}){ my $line = $self->_readline; $self->throw("This doesn't look like a MAF file. First line should start with ##maf, but it was: ".$line) unless $line =~ /^##maf/; $self->{seen_header} = 1; # keep in case we parse this later $self->_pushback($line); } my $aln = Bio::SimpleAlign->new(-source => 'maf'); my($aline, @slines, $seen_aline); while(my $line = $self->_readline()){ if ($line =~ /^a\s/xms) { # next block? if ($seen_aline) { $self->_pushback($line); last; } $aline = $line; $seen_aline++; } elsif ($line =~ /^s\s/xms) { push @slines, $line; } else { # missed lines $self->debug($line); } } # all MAF starts with 'a' line return unless $aline; my($kvs) = $aline =~ /^a\s+(.+)$/; my @kvs = split /\s+/, $kvs if $kvs; my %kv; foreach my $kv (@kvs){ my($k,$v) = $kv =~ /(.+)=(.+)/; $kv{$k} = $v; } $aln->score($kv{score}); foreach my $sline (@slines){ my($s,$src,$start,$size,$strand,$srcsize,$text) = split /\s+/, $sline; # adjust coordinates to be one-based inclusive $start = $start + 1; $strand = $strand eq '+' ? 1 : $strand eq '-' ? -1 : 0; my $seq = Bio::LocatableSeq->new('-seq' => $text, '-display_id' => $src, '-start' => $start, '-end' => $start + $size - 1, '-strand' => $strand, '-alphabet' => $self->alphabet, ); $aln->add_seq($seq); } return $aln if $aln->num_sequences; return; } sub write_aln { shift->throw_not_implemented } 1; BioPerl-1.6.923/Bio/AlignIO/mase.pm000444000765000024 632712254227316 16726 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::mase # based on the Bio::SeqIO::mase module # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::mase - mase sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from mase flat file databases. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Peter Schattner Email: schattner@alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::mase; use strict; use base qw(Bio::AlignIO); =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object Args : NONE =cut sub next_aln { my $self = shift; my $entry; my $name; my $start; my $end; my $seq; my $add; my $count = 0; my $seq_residues; my $aln = Bio::SimpleAlign->new(-source => 'mase'); while( $entry = $self->_readline) { $entry =~ /^;/ && next; if( $entry =~ /^(\S+)\/(\d+)-(\d+)/ ) { $name = $1; $start = $2; $end = $3; } else { $entry =~ s/\s//g; $name = $entry; $end = -1; } $seq = ""; while( $entry = $self->_readline) { $entry =~ /^;/ && last; $entry =~ s/[^A-Za-z\.\-]//g; $seq .= $entry; } if( $end == -1) { $start = 1; $seq_residues = $seq; $seq_residues =~ s/\W//g; $end = length($seq_residues); } $add = Bio::LocatableSeq->new('-seq' => $seq, '-display_id' => $name, '-start' => $start, '-end' => $end, '-alphabet' => $self->alphabet, ); $aln->add_seq($add); # If $end <= 0, we have either reached the end of # file in <> or we have encountered some other error # if ($end <= 0) { undef $aln;} } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in mase format ###Not yet implemented!### Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/AlignIO/mega.pm000444000765000024 1445512254227337 16736 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::mega # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::mega - Parse and Create MEGA format data files =head1 SYNOPSIS use Bio::AlignIO; my $alignio = Bio::AlignIO->new(-format => 'mega', -file => 't/data/hemoglobinA.meg'); while( my $aln = $alignio->next_aln ) { # process each alignment or convert to another format like NEXUS } =head1 DESCRIPTION This object handles reading and writing data streams in the MEGA format (Kumar and Nei). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::mega; use vars qw($MEGANAMELEN %VALID_TYPES $LINELEN $BLOCKLEN); use strict; use Bio::SimpleAlign; use Bio::LocatableSeq; # symbols are changed due to MEGA's use of '.' for redundant sequences BEGIN { $MEGANAMELEN = 10; $LINELEN = 60; $BLOCKLEN = 10; %VALID_TYPES = map {$_, 1} qw( dna rna protein standard); } use base qw(Bio::AlignIO); =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Supports the following MEGA format features: - The file has to start with '#mega' - Reads in the name of the alignment from a comment (anything after '!TITLE: ') . - Reads in the format parameters datatype Returns : L object - returns 0 on end of file or on error Args : NONE =cut sub next_aln{ my ($self) = @_; my $entry; my ($alphabet,%seqs); local $Bio::LocatableSeq::OTHER_SYMBOLS = '\*\?\.'; local $Bio::LocatableSeq::GAP_SYMBOLS = '\-'; my $aln = Bio::SimpleAlign->new(-source => 'mega'); while( defined($entry = $self->_readline()) && ($entry =~ /^\s+$/) ) {} $self->throw("Not a valid MEGA file! [#mega] not starting the file!") unless $entry =~ /^#mega/i; while( defined($entry = $self->_readline() ) ) { local($_) = $entry; if(/\!Title:\s*([^\;]+)\s*/i) { $aln->id($1)} elsif( s/\!Format\s+([^\;]+)\s*/$1/ ) { my (@fields) = split(/\s+/,$1); foreach my $f ( @fields ) { my ($name,$value) = split(/\=/,$f); if( $name eq 'datatype' ) { $alphabet = $value; } elsif( $name eq 'identical' ) { $aln->match_char($value); } elsif( $name eq 'indel' ) { $aln->gap_char($value); } } } elsif( /^\#/ ) { last; } } my @order; while( defined($entry) ) { if( $entry !~ /^\s+$/ ) { # this is to skip the leading '#' my $seqname = substr($entry,1,$MEGANAMELEN-1); $seqname =~ s/(\S+)\s+$/$1/g; my $line = substr($entry,$MEGANAMELEN); $line =~ s/\s+//g; if( ! defined $seqs{$seqname} ) {push @order, $seqname; } $seqs{$seqname} .= $line; } $entry = $self->_readline(); } foreach my $seqname ( @order ) { my $s = $seqs{$seqname}; $s =~ s/[$Bio::LocatableSeq::GAP_SYMBOLS]+//g; my $end = length($s); my $seq = Bio::LocatableSeq->new('-alphabet' => $alphabet, '-display_id' => $seqname, '-seq' => $seqs{$seqname}, '-start' => 1, '-end' => $end); $aln->add_seq($seq); } $aln->unmatch; return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in MEGA format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln{ my ($self,@aln) = @_; my $count = 0; my $wrapped = 0; my $maxname; foreach my $aln ( @aln ) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); return 0; } elsif( ! $aln->is_flush($self->verbose) ) { $self->warn("All Sequences in the alignment must be the same length"); return 0; } $aln->match(); my $len = $aln->length(); my $format = sprintf('datatype=%s identical=%s indel=%s;', $aln->get_seq_by_pos(1)->alphabet(), $aln->match_char, $aln->gap_char); $self->_print(sprintf("#mega\n!Title: %s;\n!Format %s\n\n\n", $aln->id, $format)); my ($count, $blockcount,$length) = ( 0,0,$aln->length()); $aln->set_displayname_flat(); while( $count < $length ) { foreach my $seq ( $aln->each_seq ) { my $seqchars = $seq->seq(); $blockcount = 0; my $substring = substr($seqchars, $count, $LINELEN); my @blocks; while( $blockcount < length($substring) ) { push @blocks, substr($substring, $blockcount,$BLOCKLEN); $blockcount += $BLOCKLEN; } $self->_print(sprintf("#%-".($MEGANAMELEN-1)."s%s\n", substr($aln->displayname($seq->get_nse()), 0,$MEGANAMELEN-2), join(' ', @blocks))); } $self->_print("\n"); $count += $LINELEN; } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/meme.pm000444000765000024 1547612254227317 16752 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::meme # Based on the Bio::SeqIO modules # by Ewan Birney # and Lincoln Stein # and the SimpleAlign.pm module of Ewan Birney # # Copyright Benjamin Berman # # You may distribute this module under the same terms as perl itself =head1 NAME Bio::AlignIO::meme - meme sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::AlignIO class. use Bio::AlignIO; # read in an alignment from meme my $in = Bio::AlignIO->new(-format => 'meme', -file => 'meme.out'); while( my $aln = $in->next_aln ) { # do something with the alignment } =head1 DESCRIPTION This object transforms the "sites sorted by position p-value" sections of a meme (text) output file into a series of Bio::SimpleAlign objects. Each SimpleAlign object contains Bio::LocatableSeq objects which represent the individual aligned sites as defined by the central portion of the "site" field in the meme file. The start and end coordinates are derived from the "Start" field. See L and L for more information. This module can only parse MEME version 3 and 4. Previous versions have output formats that are more difficult to parse correctly. If the meme output file is not version 3.0 or greater we signal an error. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Benjamin Berman Bbased on the Bio::SeqIO modules by Ewan Birney and others Email: benb@fruitfly.berkeley.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with an underscore. =cut # Let the code begin... package Bio::AlignIO::meme; use strict; use Bio::LocatableSeq; use base qw(Bio::AlignIO); # Constants my $MEME_VERS_ERR = "MEME output file must be generated by version 3.0 or higher"; my $MEME_NO_HEADER_ERR = "MEME output file contains no header line (ex: MEME version 3.0)"; my $HTML_VERS_ERR = "MEME output file must be generated with the -text option"; =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream Returns : Bio::SimpleAlign object with the score() set to the evalue of the motif. Args : NONE =cut sub next_aln { my ($self) = @_; my $aln = Bio::SimpleAlign->new( -source => 'meme' ); my $line; my $good_align_sec = 0; my $in_align_sec = 0; my $evalue; while ( !$good_align_sec && defined( $line = $self->_readline() ) ) { if ( !$in_align_sec ) { # Check for the meme header if ( $line =~ /^\s*MEME\s+version\s+(\S+)/ ) { $self->{'meme_vers'} = $1; my ($vers) = $self->{'meme_vers'} =~ /^(\d)/; $self->throw($MEME_VERS_ERR) unless ( $vers >= 3 ); $self->{'seen_header'} = 1; } # Check if they've output the HTML version if ( $line =~ /\/i ) { $self->throw($HTML_VERS_ERR); } # Grab the evalue if ( $line =~ /MOTIF\s+\d+\s+width.+E-value = (\S+)/ ) { $self->throw($MEME_NO_HEADER_ERR) unless ( $self->{'seen_header'} ); $evalue = $1; } # Check if we're going into an alignment section if ( $line =~ /sites sorted by position/ ) { $self->throw($MEME_NO_HEADER_ERR) unless ( $self->{'seen_header'} ); $in_align_sec = 1; } } # The first regexp is for version 3, the second is for version 4 elsif ( $line =~ /^(\S+)\s+([+-]?)\s+(\d+)\s+ \S+\s+[.A-Z\-]*\s+([A-Z\-]+)\s+ ([.A-Z\-]*)/xi || $line =~ /^(\S+)\s+([+-]?)\s+(\d+)\s+ \S+\s+\.\s+([A-Z\-]+)/xi ) { # Got a sequence line my $seq_name = $1; my $strand = ( $2 eq '-' ) ? -1 : 1; my $start_pos = $3; my $central = uc($4); # my $p_val = $4; # my $left_flank = uc($5); # my $right_flank = uc($7); # Info about the flanking sequence # my $start_len = ($strand > 0) ? length($left_flank) : # length($right_flank); # my $end_len = ($strand > 0) ? length($right_flank) : # length($left_flank); # Make the sequence. Meme gives the start coordinate at the left # hand side of the motif relative to the INPUT sequence. my $end_pos = $start_pos + length($central) - 1; my $seq = Bio::LocatableSeq->new( -seq => $central, -display_id => $seq_name, -start => $start_pos, -end => $end_pos, -strand => $strand, -alphabet => $self->alphabet, ); # Add the sequence motif to the alignment $aln->add_seq($seq); } elsif ( ( $line =~ /^\-/ ) || ( $line =~ /Sequence name/ ) ) { # These are acceptable things to be in the site section } elsif ( $line =~ /^\s*$/ ) { # This ends the site section $in_align_sec = 0; $good_align_sec = 1; } else { $self->warn("Unrecognized format:\n$line"); return 0; } } # Signal an error if we didn't find a header section $self->throw($MEME_NO_HEADER_ERR) unless ( $self->{'seen_header'} ); if ($good_align_sec) { $aln->score($evalue); return $aln; } return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: Not implemented Returns : 1 for success and 0 for error Args : Bio::SimpleAlign object =cut sub write_aln { my ( $self, @aln ) = @_; $self->throw_not_implemented(); } # ---------------------------------------- # - Private methods # ---------------------------------------- sub _initialize { my ( $self, @args ) = @_; # Call into our base version $self->SUPER::_initialize(@args); # Then initialize our data variables $self->{'seen_header'} = 0; } 1; BioPerl-1.6.923/Bio/AlignIO/metafasta.pm000444000765000024 1304512254227330 17755 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::metafasta # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::metafasta - Metafasta MSA Sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from metafasta flat file databases. The format of a metafasta file is >test/1-25 ABCDEFHIJKLMNOPQRSTUVWXYZ &charge NBNAANCNJCNNNONNCNNUNNXNZ &chemical LBSAARCLJCLSMOIMCHHULRXRZ where the sequence block is followed by one or several meta blocks. Each meta block starts with the ampersand character '&' in the first column and is immediately followed by the name of the meta data which continues until the new line. The meta data follows it. All characters, except new line, are important in meta data. =head1 SEE ALSO L =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::metafasta; use vars qw($WIDTH); use strict; use Bio::SimpleAlign; use Bio::Seq::Meta; use Bio::Seq::SeqFactory; use Bio::Seq::SeqFastaSpeedFactory; use base qw(Bio::AlignIO); BEGIN { $WIDTH = 60} sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($width) = $self->_rearrange([qw(WIDTH)], @args); $width && $self->width($width); } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object - returns 0 on end of file or on error Args : NONE =cut sub next_aln { my( $self ) = @_; my $seq; my $alphabet; local $/ = "\n>"; my $aln = Bio::SimpleAlign->new(); while(defined (my $entry = $self->_readline)) { chomp($entry); if ($entry =~ m/\A\s*\Z/s) { # very first one return unless $entry = $self->_readline; chomp($entry); } $entry =~ s/^>//; my ($top,$sequence) = split(/\n/,$entry,2); defined $sequence && $sequence =~ s/>//g; my @metas; ($sequence, @metas) = split /\n&/, $sequence; my ($id, $start, $end); if ( $top =~ /(\S+)\/(\d+)-(\d+)/ ) { $id = $1; $start = $2; $end = $3; } elsif ($top =~ /(\S+)/) { $id = $1; $start = 1; $end = length($sequence); } defined $sequence && $sequence =~ s/\s//g; # Remove whitespace $seq = Bio::Seq::Meta->new('-seq' => $sequence, '-display_id' => $id, '-start' => $start, '-end' => $end, '-alphabet' => $self->alphabet, ); foreach my $meta (@metas) { my ($name,$string) = split /\n/, $meta; $string =~ s/\n//g; # Remove newlines, spaces are important $seq->named_meta($name, $string); } $aln->add_seq($seq); # alignment needs seqs all the same length, pad with gaps my $alnlen = $aln->length; foreach my $seq ( $aln->each_seq ) { if ( $seq->length < $alnlen ) { my ($diff) = ($alnlen - $seq->length); $seq->seq( $seq->seq() . "-" x $diff); } } } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in fasta format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; my $width = $self->width; foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } foreach my $seq ( $aln->each_seq() ) { my $name = $aln->displayname($seq->get_nse); my $str = $seq->seq(); if(length($str) > 0) { $str =~ s/(.{1,$width})/$1\n/g; } else { $str = "\n"; } $self->_print (">",$name,"\n",$str) or return; if ($seq->isa('Bio::Seq::MetaI')) { foreach my $meta ($seq->meta_names) { my $str = $seq->named_meta($meta); $str =~ s/(.{1,$width})/$1\n/g; $self->_print ("&",$meta,"\n",$str); } } } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 width Title : width Usage : $obj->width($newval) Function: Get/Set the line width for METAFASTA output Returns : value of width Args : newvalue (optional) =cut sub width{ my ($self,$value) = @_; if( defined $value) { $self->{'width'} = $value; } return $self->{'width'} || $WIDTH; } 1; BioPerl-1.6.923/Bio/AlignIO/msf.pm000444000765000024 1423712254227321 16601 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::msf # based on the Bio::SeqIO::msf module # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::msf - msf sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from msf flat file databases. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Peter Schattner Email: schattner@alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::msf; use vars qw(%valid_type); use strict; use Bio::SeqIO::gcg; # for GCG_checksum() use Bio::SimpleAlign; use base qw(Bio::AlignIO); BEGIN { %valid_type = qw( dna N rna N protein P ); } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Tries to read *all* MSF It reads all non whitespace characters in the alignment area. For MSFs with weird gaps (eg ~~~) map them by using $aln->map_chars('~','-') Returns : Bio::Align::AlignI object Args : NONE =cut sub next_aln { my $self = shift; my $entry; my (%hash,$name,$str,@names,$seqname,$start,$end,$count,$seq); my $aln = Bio::SimpleAlign->new(-source => 'gcg' ); while( $entry = $self->_readline) { $entry =~ m{//} && last; # move to alignment section $entry =~ /Name:\s+(\S+)/ && do { $name = $1; $hash{$name} = ""; # blank line push(@names,$name); # we need it ordered! }; # otherwise - skip } # alignment section while( $entry = $self->_readline) { next if ( $entry =~ /^\s+(\d+)/ ) ; $entry =~ /^\s*(\S+)\s+(.*)$/ && do { $name = $1; $str = $2; if( ! exists $hash{$name} ) { $self->throw("$name exists as an alignment line but not in the header. Not confident of what is going on!"); } $str =~ s/\s//g; $str =~ s/~/-/g; $hash{$name} .= $str; }; } # return 0 if scalar @names < 1; if (scalar(@names) < 1) { undef $aln; return $aln; } # now got this as a name - sequence hash. Let's make some sequences! for $name ( @names ) { if( $name =~ m{(\S+)/(\d+)-(\d+)} ) { $seqname = $1; $start = $2; $end = $3; } else { $seqname = $name; $start = 1; $str = $hash{$name}; $str =~ s/[^0-9A-Za-z$Bio::LocatableSeq::OTHER_SYMBOLS]//g; $end = length($str); } $seq = Bio::LocatableSeq->new('-seq' => $hash{$name}, '-display_id' => $seqname, '-start' => $start, '-end' => $end, '-alphabet' => $self->alphabet, ); $aln->add_seq($seq); # If $end <= 0, we have either reached the end of # file in <> or we have encountered some other error } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in MSF format Sequence type of the alignment is determined by the first sequence. Returns : 1 for success and 0 for error Args : Bio::Align::AlignI object =cut sub write_aln { my ($self,@aln) = @_; my $msftag; my $type; my $count = 0; my $maxname; my ($length,$date,$name,$seq,$miss,$pad,%hash,@arr,$tempcount,$index); foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } $date = localtime(time); $msftag = "MSF"; $type = $valid_type{$aln->get_seq_by_pos(1)->alphabet}; $maxname = $aln->maxdisplayname_length(); $length = $aln->length(); $name = $aln->id(); if( !defined $name ) { $name = "Align"; } $self->_print (sprintf("\n%s MSF: %d Type: %s %s Check: 00 ..\n\n", $name, $aln->num_sequences, $type, $date)); my $seqCountFormat = "%".($maxname > 20 ? $maxname + 2: 22)."s%-27d%27d\n"; my $seqNameFormat = "%-".($maxname > 20 ? $maxname : 20)."s "; foreach $seq ( $aln->each_seq() ) { $name = $aln->displayname($seq->get_nse()); $miss = $maxname - length ($name); $miss += 2; $pad = " " x $miss; $self->_print (sprintf(" Name: %s%sLen: %d Check: %d Weight: 1.00\n",$name,$pad,length $seq->seq(), Bio::SeqIO::gcg->GCG_checksum($seq))); $hash{$name} = $seq->seq(); push(@arr,$name); } # ok - heavy handed, but there you go. # $self->_print ("\n//\n\n\n"); while( $count < $length ) { # there is another block to go! $self->_print (sprintf($seqCountFormat,' ',$count+1,$count+50)); foreach $name ( @arr ) { $self->_print (sprintf($seqNameFormat,$name)); $tempcount = $count; $index = 0; while( ($tempcount + 10 < $length) && ($index < 5) ) { $self->_print (sprintf("%s ",substr($hash{$name}, $tempcount,10))); $tempcount += 10; $index++; } # # ok, could be the very last guy ;) # if( $index < 5) { # space to print! # $self->_print (sprintf("%s ",substr($hash{$name},$tempcount))); $tempcount += 10; } $self->_print ("\n"); } $self->_print ("\n\n"); $count = $tempcount; } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/nexml.pm000444000765000024 720312254227323 17114 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::nexml # # Copyright Chase Miller # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::nexml - NeXML format sequence alignment input/output stream driver =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from NeXML format. For more information on NeXML, visit L. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Chase Miller =head1 CONTRIBUTORS Mark Jensen, maj@fortinbras.us Rutger Vos, rutgeraldo@gmail.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::nexml; use strict; use lib '../..'; use Bio::Nexml::Factory; use Bio::Phylo::IO qw(parse unparse); use base qw(Bio::AlignIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); $self->{_doc} = undef; } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln Function: returns the next alignment in the stream. Returns : Bio::Align::AlignI object - returns 0 on end of file or on error Args : See L =cut sub next_aln { my ($self) = @_; unless ( $self->{'_parsed'} ) { #use a parse function to load all the alignment objects found in the nexml file at once $self->_parse; } return $self->{'_alns'}->[ $self->{'_alnsiter'}++ ]; } =head2 rewind Title : rewind Usage : $alnio->rewind Function: Resets the stream Returns : none Args : none =cut sub rewind { my $self = shift; $self->{'_alniter'} = 0; } =head2 doc Title : doc Usage : $treeio->doc Function: Returns the biophylo nexml document object Returns : Bio::Phylo::Project Args : none or Bio::Phylo::Project object =cut sub doc { my ($obj,$value) = @_; if( defined $value) { $obj->{'_doc'} = $value; } return $obj->{'_doc'}; } sub _parse { my ($self) = @_; $self->{'_parsed'} = 1; $self->{'_alnsiter'} = 0; my $fac = Bio::Nexml::Factory->new(); $self->doc(parse( '-file' => $self->{'_file'}, '-format' => 'nexml', '-as_project' => '1' )); $self->{'_alns'} = $fac->create_bperl_aln($self); if(@{ $self->{'_alns'} } == 0) { self->debug("no seqs in $self->{_file}"); } } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in nexml format Returns : 1 for success and 0 for error Args : L object See L =cut sub write_aln { my ($self, $aln) = @_; my $fac = Bio::Nexml::Factory->new(); my $taxa = $fac->create_bphylo_taxa($aln); my ($matrix) = $fac->create_bphylo_aln($aln, $taxa); $matrix->set_taxa($taxa); $self->doc(Bio::Phylo::Factory->create_project()); $self->doc->insert($matrix); my $ret = $self->_print($self->doc->to_xml()); $self->flush; return $ret; } 1; BioPerl-1.6.923/Bio/AlignIO/nexus.pm000444000765000024 3356112254227333 17162 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::nexus # # Copyright Heikki Lehvaslaiho # =head1 NAME Bio::AlignIO::nexus - NEXUS format sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. use Bio::AlignIO; my $in = Bio::AlignIO->new(-format => 'nexus', -file => 'aln.nexus'); while( my $aln = $in->next_aln ) { # do something with the alignment } =head1 DESCRIPTION This object can transform L objects to and from NEXUS data blocks. See method documentation for supported NEXUS features. =head1 ACKNOWLEDGEMENTS Will Fisher has written an excellent standalone NEXUS format parser in Perl, readnexus. A number of tricks were adapted from it. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::nexus; use vars qw(%valid_type); use strict; no strict "refs"; use base qw(Bio::AlignIO); BEGIN { %valid_type = map {$_, 1} qw( dna rna protein standard ); # standard throws error: inherited from Bio::PrimarySeq } =head2 new Title : new Usage : $alignio = Bio::AlignIO->new(-format => 'nexus', -file => 'filename'); Function: returns a new Bio::AlignIO object to handle clustalw files Returns : Bio::AlignIO::clustalw object Args : -verbose => verbosity setting (-1,0,1,2) -file => name of file to read in or with ">" - writeout -fh => alternative to -file param - provide a filehandle to read from/write to -format => type of Alignment Format to process or produce Customization of nexus flavor output -show_symbols => print the symbols="ATGC" in the data definition (MrBayes does not like this) boolean [default is 1] -show_endblock => print an 'endblock;' at the end of the data (MyBayes does not like this) boolean [default is 1] =cut sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize(@args); my ($show_symbols, $endblock) = $self->_rearrange([qw(SHOW_SYMBOLS SHOW_ENDBLOCK)], @args); my @names = qw(symbols endblock); for my $v ( $show_symbols, $endblock ) { $v = 1 unless defined $v; # default value is 1 my $n = shift @names; $self->flag($n, $v); } } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: Returns the next alignment in the stream. Supports the following NEXUS format features: - The file has to start with '#NEXUS' - Reads in the name of the alignment from a comment (anything after 'TITLE: ') . - Sequence names can be given in a taxa block, too. - If matchchar notation is used, converts them back to sequence characters. - Does character conversions specified in the NEXUS equate command. - Sequence names of type 'Homo sapiens' and Homo_sapiens are treated identically. Returns : L object Args : =cut sub next_aln { my $self = shift; my $entry; my ($aln_name, $seqcount, $residuecount, %hash, $alphabet, $match, $gap, $missing, $equate, $interleave, $name,$str,@names,$seqname,$start,$end,$count,$seq); local $Bio::LocatableSeq::OTHER_SYMBOLS = '\*\?\.'; local $Bio::LocatableSeq::GAP_SYMBOLS = '\-'; my $aln = Bio::SimpleAlign->new(-source => 'nexus'); # file starts with '#NEXUS' but we allow white space only lines before it $entry = $self->_readline; $entry = $self->_readline while defined $entry && $entry =~ /^\s+$/; return unless $entry; $self->throw("Not a valid interleaved NEXUS file! [#NEXUS] not starting the file\n$entry") unless ($entry && $entry =~ /^#NEXUS/i); # skip anything before either the taxa or data block # but read in the optional title in a comment while (defined($entry = $self->_readline)) { local ($_) = $entry; /\[TITLE. *([^\]]+)]\s+/i and $aln_name = $1; last if /^begin +data/i || /^begin +taxa/i; } $aln_name =~ s/\s/_/g and $aln->id($aln_name) if $aln_name; # data and taxa blocks my $incomment; while (defined ($entry = $self->_readline)) { local ($_) = $entry; next if s/\[[^\]]+\]//g; # remove comments if( s/\[[^\]]+$// ) { $incomment = 1; # skip line if it is now empty or contains only whitespace next if /^\s*$/; } elsif($incomment) { if( s/^[^\]]*\]// ) { $incomment = 0; } else { next; } } elsif( /taxlabels/i ) { # doesn't deal with taxlabels adequately and can mess things up! # @names = $self->_read_taxlabels; } else { /ntax\s*=\s*(\d+)/i and $seqcount = $1; /nchar\s*=\s*(\d+)/i and $residuecount = $1; /matchchar\s*=\s*(.)/i and $match = $1; /gap\s*=\s*(.)/i and $gap = $1; /missing\s*=\s*(.)/i and $missing = $1; /equate\s*=\s*\"([^\"]+)/i and $equate = $1; # "e.g. equate="T=C G=A"; /datatype\s*=\s*(\w+)/i and $alphabet = lc $1; /interleave/i and $interleave = 1 ; last if /matrix/io; } } $self->throw("Not a valid NEXUS sequence file. Datatype not specified.") unless $alphabet; $self->throw("Not a valid NEXUS sequence file. Datatype should not be [$alphabet]") unless $valid_type{$alphabet}; $self->throw("\"$gap\" is not a valid gap character. For compatability, gap char can not be one of: ()[]{}/\,;:=*'`\"<>^") if $gap && $gap =~ /[\(\)\[\]\{\}\/\\\,\;\:\=\*\'\`\<\>\^]/; $self->throw("\"$missing\" is not a valid missing character. For compatability, missing char can not be one of: ()[]{}/\,;:=*'`\"<>^") if $missing && $missing =~ /[\(\)\[\]\{\}\/\\\,\;\:\=\*\'\`\<\>\^]/; $aln->gap_char($gap); $aln->missing_char($missing); # # if data is not right after the matrix line # read the empty lines out # while ($entry = $self->_readline) { unless ($entry =~ /^\s+$/) { $self->_pushback($entry); last; } } # # matrix command # # first alignment section if (@names == 0) { # taxa block did not exist while ($entry = $self->_readline) { local ($_) = $entry; if( s/\[[^\]]+\]//g ) { #] remove comments next if /^\s*$/; # skip line if it is now empty or contains only whitespace } if ($interleave && defined$count && ($count <= $seqcount)) { /^\s+$/ and last; } else { /^\s+$/ and next; } /^\s*;/ and last; # stop if colon at end of matrix is on it's own line #/^\s*;\s*$/ and last; if ( /^\s*([\"\'](.+?)[\"\']|(\S+))\s+(.*)\s*$/ ) { # get single and double quoted names, or all the first # nonwhite word as the name, and remained is seq #if (/^\s*('([^']*?)'|([^']\S*))\s+(.*)$/) { #' $name = ($2 || $3); if ($4) { # seq is on same line as name # this is the usual NEXUS format $str = $4; } else { # otherwise get seq from following lines. No comments allowed # a less common matrix format, usually used for very long seqs $str=''; while (local ($_) = $self->_readline) { my $str_tmp = $_; $str_tmp =~ s/[\s;]//g; $str .= $str_tmp; last if length$str == $residuecount; } } $name =~ s/ /_/g; push @names, $name; $str =~ s/[\s;]//g; $count = @names; $hash{$count} = $str; } $self->throw("Not a valid interleaved NEXUS file! seqcount [$count] > predeclared [$seqcount] in the first section") if $count > $seqcount; /;/ and last; # stop if colon at end of matrix is on the same line as the last seq } } # interleaved sections $count = 0; if ( $interleave ) { # only read next section if file is interleaved while( $entry = $self->_readline) { local ($_) = $entry; if( s/\[[^\]]+\]//g ) { #] remove comments next if /^\s*$/; # skip line if it is now empty or contains only whitespace } /^\s*;/ and last; # stop if colon at end of matrix is on it's own line $count = 0, next if $entry =~ /^\s*$/; if (/^\s*(\'([^\']*?)\'|([^\']\S*))\s+(.*)$/) { $str = $4; $str =~ s/[\s;]//g; $count++; $hash{$count} .= $str; }; $self->throw("Not a valid interleaved NEXUS file! seqcount [$count] > predeclared [$seqcount] ") if $count > $seqcount; /;/ and last; # stop if colon at end of matrix is on the same line as the last seq } } return 0 if @names < 1; # sequence creation $count = 0; foreach $name ( @names ) { $count++; if( $name =~ /(\S+)\/(\d+)-(\d+)/ ) { ($seqname,$start,$end) = ($1,$2,$3); } else { ($seqname,$start,$str) = ($name,1,$hash{$count}); $str =~ s/[$Bio::LocatableSeq::GAP_SYMBOLS]//g; $end = length($str); } # consistency test $self->throw("Length of sequence [$seqname] is not [$residuecount]; got".CORE::length($hash{$count})) unless CORE::length($hash{$count}) == $residuecount; $seq = Bio::LocatableSeq->new('-seq' => $hash{$count}, '-display_id' => $seqname, '-start' => $start, '-end' => $end, '-alphabet' => $alphabet ); $aln->add_seq($seq); } # if matchchar is used $aln->unmatch($match) if $match; # if equate ( e.g. equate="T=C G=A") is used if ($equate) { $aln->map_chars($1, $2) while $equate =~ /(\S)=(\S)/g; } while (defined $entry && $entry !~ /endblock/i) { $entry = $self->_readline; } return $aln if $aln->num_sequences; return; } sub _read_taxlabels { my ($self) = @_; my ($name, @names); while (my $entry = $self->_readline) { last if $entry =~ m/^\s*(END)?;/i; if( $entry =~ m/\s*(\S+)\s+/ ) { ($name) = ($1); $name =~ s/\[[^\[]+\]//g; $name =~ s/\W/_/g; push @names, $name; } } return @names; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: Writes the $aln object into the stream in interleaved NEXUS format. Everything is written into a data block. SimpleAlign methods match_char, missing_char and gap_char must be set if you want to see them in the output. Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; my $count = 0; my $wrapped = 0; my $maxname; my ($length,$date,$name,$seq,$miss,$pad,%hash,@arr,$tempcount,$index ); my ($match, $missing, $gap,$symbols) = ('', '', '',''); foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } $self->throw("All sequences in the alignment must be the same length") unless $aln->is_flush($self->verbose); $length = $aln->length(); $self->_print (sprintf("#NEXUS\n[TITLE: %s]\n\nbegin data;\ndimensions ntax=%s nchar=%s;\n", $aln->id, $aln->num_sequences, $length)); $match = "match=". $aln->match_char if $aln->match_char; $missing = "missing=". $aln->missing_char if $aln->missing_char; $gap = "gap=". $aln->gap_char if $aln->gap_char; $symbols = 'symbols="'.join('',$aln->symbol_chars). '"' if( $self->flag('symbols') && $aln->symbol_chars); $self->_print (sprintf("format interleave datatype=%s %s %s %s %s;\n\nmatrix\n", $aln->get_seq_by_pos(1)->alphabet, $match, $missing, $gap, $symbols)); # account for single quotes round names my $indent = $aln->maxdisplayname_length+2; $aln->set_displayname_flat(); foreach $seq ( $aln->each_seq() ) { my $nmid = $aln->displayname($seq->get_nse()); if( $nmid =~ /[^\w\d\.]/ ) { # put name in single quotes incase it contains any of # the following chars: ()[]{}/\,;:=*'"`+-<> that are not # allowed in PAUP* and possible other software $name = sprintf("%-${indent}s", "\'" . $nmid . "\'"); } else { $name = sprintf("%-${indent}s", $nmid); } $hash{$name} = $seq->seq; push(@arr,$name); } while( $count < $length ) { # there is another block to go! foreach $name ( @arr ) { my $dispname = $name; # $dispname = '' if $wrapped; $self->_print (sprintf("%${indent}s ",$dispname)); $tempcount = $count; $index = 0; while( ($tempcount + 10 < $length) && ($index < 5) ) { $self->_print (sprintf("%s ",substr($hash{$name},$tempcount,10))); $tempcount += 10; $index++; } # last if( $index < 5) { # space to print! $self->_print (sprintf("%s ",substr($hash{$name},$tempcount))); $tempcount += 10; } $self->_print ("\n"); } $self->_print ("\n\n"); $count = $tempcount; $wrapped = 1; } if( $self->flag('endblock') ) { $self->_print (";\n\nendblock;\n"); } else { $self->_print (";\n\nend;\n"); } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 flag Title : flag Usage : $obj->flag($name,$value) Function: Get/Set a flag value Returns : value of flag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub flag{ my ($self,$name,$val) = @_; return $self->{'flag'}->{$name} = $val if defined $val; return $self->{'flag'}->{$name}; } 1; BioPerl-1.6.923/Bio/AlignIO/pfam.pm000444000765000024 713012254227335 16716 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::pfam # based on the Bio::SeqIO:: modules # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::pfam - pfam sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform Bio::SimpleAlign objects to and from pfam flat file databases. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Peter Schattner Email: schattner@alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::pfam; use strict; use Bio::SimpleAlign; use base qw(Bio::AlignIO); =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream Returns : L object Args : NONE =cut sub next_aln { my $self = shift; my $entry; my $name; my $start; my $end; my $seq; my $add; my $acc; my %names; my $aln = Bio::SimpleAlign->new(-source => 'pfam'); while( $entry = $self->_readline) { chomp $entry; $entry =~ m{^//} && last; if($entry !~ m{^(\S+)/(\d+)-(\d+)\s+(\S+)\s*} ) { $self->throw("Found a bad line [$_] in the pfam format alignment"); next; } $name = $1; $start = $2; $end = $3; $seq = $4; $add = Bio::LocatableSeq->new('-seq' => $seq, '-display_id' => $name, '-start' => $start, '-end' => $end, '-alphabet' => $self->alphabet, ); $aln->add_seq($add); } # If $end <= 0, we have either reached the end of # file in <> or we have encountered some other error # return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; if( @aln > 1 ) { $self->warn("Only the 1st pfam alignment will be output since the format does not support multiple alignments in the same file"); } my $aln = shift @aln; if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } my ($namestr,$seq,$add); my ($maxn); $maxn = $aln->maxdisplayname_length(); foreach $seq ( $aln->each_seq() ) { $namestr = $aln->displayname($seq->get_nse()); $add = $maxn - length($namestr) + 2; $namestr .= " " x $add; $self->_print (sprintf("%s %s\n",$namestr,$seq->seq())) or return; } $self->flush() if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/phylip.pm000444000765000024 4051312254227317 17322 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::phylip # # Copyright Heikki Lehvaslaiho # =head1 NAME Bio::AlignIO::phylip - PHYLIP format sequence input/output stream =head1 SYNOPSIS # Do not use this module directly. Use it via the Bio::AlignIO class. use Bio::AlignIO; use Bio::SimpleAlign; #you can set the name length to something other than the default 10 #if you use a version of phylip (hacked) that accepts ids > 10 my $phylipstream = Bio::AlignIO->new(-format => 'phylip', -fh => \*STDOUT, -idlength=>30); # convert data from one format to another my $gcgstream = Bio::AlignIO->new(-format => 'msf', -file => 't/data/cysprot1a.msf'); while( my $aln = $gcgstream->next_aln ) { $phylipstream->write_aln($aln); } # do it again with phylip sequential format format $phylipstream->interleaved(0); # can also initialize the object like this $phylipstream = Bio::AlignIO->new(-interleaved => 0, -format => 'phylip', -fh => \*STDOUT, -idlength=>10); $gcgstream = Bio::AlignIO->new(-format => 'msf', -file => 't/data/cysprot1a.msf'); while( my $aln = $gcgstream->next_aln ) { $phylipstream->write_aln($aln); } =head1 DESCRIPTION This object can transform Bio::SimpleAlign objects to and from PHYLIP format. By default it works with the interleaved format. By specifying the flag -interleaved =E 0 in the initialization the module can read or write data in sequential format. Long IDs up to 50 characters are supported by flag -longid =E 1. ID strings can be surrounded by single quoted. They are mandatory only if the IDs contain spaces. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Heikki Lehvaslaiho and Jason Stajich Email: heikki at ebi.ac.uk Email: jason at bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::phylip; use vars qw($DEFAULTIDLENGTH $DEFAULTLINELEN $DEFAULTTAGLEN); use strict; use Bio::SimpleAlign; use POSIX; # for the rounding call use base qw(Bio::AlignIO); BEGIN { $DEFAULTIDLENGTH = 10; $DEFAULTLINELEN = 60; $DEFAULTTAGLEN = 10; } =head2 new Title : new Usage : my $alignio = Bio::AlignIO->new(-format => 'phylip' -file => '>file', -idlength => 10, -idlinebreak => 1); Function: Initialize a new L reader or writer Returns : L object Args : [specific for writing of phylip format files] -idlength => integer - length of the id (will pad w/ spaces if needed) -interleaved => boolean - whether interleaved or sequential format required -line_length => integer of how long a sequence lines should be -idlinebreak => insert a line break after the sequence id so that sequence starts on the next line -flag_SI => whether or not write a "S" or "I" just after the num.seq. and line len., in the first line -tag_length => integer of how long the tags have to be in each line between the space separator. set it to 0 to have 1 tag only. -wrap_sequential => boolean for whether or not sequential format should be broken up or a single line default is false (single line) -longid => boolean for allowing arbitrary long IDs (default is false) =cut sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($interleave,$linelen,$idlinebreak, $idlength, $flag_SI, $tag_length,$ws, $longid) = $self->_rearrange([qw(INTERLEAVED LINE_LENGTH IDLINEBREAK IDLENGTH FLAG_SI TAG_LENGTH WRAP_SEQUENTIAL LONGID)],@args); $self->interleaved($interleave ? 1 : 0) if defined $interleave; $self->idlength($idlength || $DEFAULTIDLENGTH); $self->id_linebreak(1) if( $idlinebreak ); $self->line_length($linelen) if defined $linelen && $linelen > 0; $self->flag_SI(1) if ( $flag_SI ); $self->tag_length($tag_length) if ( $tag_length || $DEFAULTTAGLEN ); $self->wrap_sequential($ws ? 1 : 0); $self->longid($longid ? 1 : 0); 1; } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Throws an exception if trying to read in PHYLIP sequential format. Returns : L object Args : =cut sub next_aln { my $self = shift; my $entry; my ($seqcount, $residuecount, %hash, $name,$str, @names,$seqname,$start,$end,$count,$seq); my $aln = Bio::SimpleAlign->new(-source => 'phylip'); # First, parse up through the header. # If we see a non-blank line that isn't the seqcount and residuecount line # then bail out of next_aln (return) while ($entry = $self->_readline) { if ($entry =~ /^\s?$/) { next; } elsif ($entry =~ /\s*(\d+)\s+(\d+)/) { ($seqcount, $residuecount) = ($1, $2); last; } else { $self->warn ("Failed to parse PHYLIP: Did not see a sequence count and residue count."); return; } } # First alignment section. We expect to see a name and (part of) a sequence. my $idlen = $self->idlength; $count = 0; while ($entry = $self->_readline) { if ($entry =~ /^\s?$/) { # eat the newlines next; } # Names can be in a few different formats: # 1. they can be traditional phylip: 10 chars long, period. If this is the case, that name can have spaces. # 2. they can be hacked with a long ID, as passed in with the flag -longid. # 3. if there is a long ID, the name can have spaces as long as it is wrapped in single quotes. if ($self->longid()) { # 2 or 3 if ($entry =~ /^'(.+)'\s+(.+)$/) { # 3. name has single quotes. $name = $1; $str = $2; } else { # 2. name does not have single quotes, so should not have spaces. # therefore, the first part of the line is the name and the rest is the seq. # make sure that the line does not lead with extra spaces. $entry =~ s/^\s+//; ($name, $str) = split (/\s+/,$entry, 2); } } else { # 1. traditional phylip. $entry =~ /^(.{10})\s+(.+)$/; $name = $1; $str = $2; $name =~ s/\s+$//; # eat any trailing spaces $name =~ s/\s+/_/g; } push @names, $name; #clean sequence of spaces: $str =~ s/\s+//g; # are we sequential? If so, we should keep adding to the sequence until we've got all the residues. if (($self->interleaved) == 0) { while (length($str) < $residuecount) { $entry = $self->_readline; $str .= $entry; $str =~ s/\s+//g; if ($entry =~ /^\s*$/) { # we ran into a newline before we got a complete sequence: bail! $self->warn("Failed to parse PHYLIP: Sequence $name was shorter than expected: " . length($str) . " instead of $residuecount."); last; } } } $hash{$count} = $str; $count++; # if we've read as many seqs as we're supposed to, move on. if ($count == $seqcount) { last; } } # if we are interleaved, we're going to keep seeing chunks of sequence until we get all of it. if ($self->interleaved) { while (length($hash{$seqcount-1}) < $residuecount) { $count = 0; while ($entry = $self->_readline) { if ($entry =~ /^\s*$/) { # eat newlines if ($count != 0) { # there was a newline at an unexpected place! $self->warn("Failed to parse PHYLIP: Interleaved file is missing a segment: saw $count, expected $seqcount."); return; } next; } else { # start taking in chunks $entry =~ s/\s//g; $hash{$count} .= $entry; $count++; } if ($count >= $seqcount) { # we've read all of the sequences for this chunk, so move on. last; } } } } if ((scalar @names) != $seqcount) { $self->warn("Failed to parse PHYLIP: Did not see the correct number of seqs: saw " . scalar(@names) . ", expected $seqcount."); return; } for ($count=0; $count<$seqcount; $count++) { $str = $hash{$count}; my $seqname = $names[$count]; if (length($str) != $residuecount) { $self->warn("Failed to parse PHYLIP: Sequence $seqname was the wrong length: " . length($str) . " instead of $residuecount."); } $seq = Bio::LocatableSeq->new('-seq' => $hash{$count}, '-display_id' => $seqname); $aln->add_seq($seq); } return $aln; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in phylip format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; my $count = 0; my $wrapped = 0; my $maxname; my $width = $self->line_length(); my ($length,$date,$name,$seq,$miss,$pad, %hash,@arr,$tempcount,$index,$idlength,$flag_SI,$line_length, $tag_length); foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } $self->throw("All sequences in the alignment must be the same length") unless $aln->is_flush(1) ; $flag_SI = $self->flag_SI(); $aln->set_displayname_flat(); # plain $length = $aln->length(); if ($flag_SI) { if ($self->interleaved() ) { $self->_print (sprintf(" %s %s I\n", $aln->num_sequences, $aln->length)); } else { $self->_print (sprintf(" %s %s S\n", $aln->num_sequences, $aln->length)); } } else { $self->_print (sprintf(" %s %s\n", $aln->num_sequences, $aln->length)); } $idlength = $self->idlength(); $line_length = $self->line_length(); $tag_length = $self->tag_length(); foreach $seq ( $aln->each_seq() ) { $name = $aln->displayname($seq->get_nse); if ($self->longid) { $self->warn("The length of the name is over 50 chars long [$name]") if length($name) > 50; $name = "'$name' " } else { $name = substr($name, 0, $idlength) if length($name) > $idlength; $name = sprintf("%-".$idlength."s",$name); if( $self->interleaved() ) { $name .= ' ' ; } elsif( $self->id_linebreak) { $name .= "\n"; } } #phylip needs dashes not dots my $seq = $seq->seq(); $seq =~ s/\./-/g; $hash{$name} = $seq; push(@arr,$name); } if( $self->interleaved() ) { my $numtags; if ($tag_length <= $line_length) { $numtags = floor($line_length/$tag_length); $line_length = $tag_length*$numtags; } else { $numtags = 1; } while( $count < $length ) { # there is another block to go! foreach $name ( @arr ) { my $dispname = $name; $dispname = '' if $wrapped; $self->_print (sprintf("%".($idlength+3)."s",$dispname)); $tempcount = $count; $index = 0; $self->debug("residue count: $count\n") if ($count%100000 == 0); while( ($tempcount + $tag_length < $length) && ($index < $numtags) ) { $self->_print (sprintf("%s ",substr($hash{$name}, $tempcount, $tag_length))); $tempcount += $tag_length; $index++; } # last if( $index < $numtags) { # space to print! $self->_print (sprintf("%s",substr($hash{$name}, $tempcount))); $tempcount += $tag_length; } $self->_print ("\n"); } $self->_print ("\n"); $count = $tempcount; $wrapped = 1; } } else { foreach $name ( @arr ) { my $dispname = $name; my $line = sprintf("%s%s\n",$dispname,$hash{$name}); if( $self->wrap_sequential ) { $line =~ s/(.{1,$width})/$1\n/g; } $self->_print ($line); } } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 interleaved Title : interleaved Usage : my $interleaved = $obj->interleaved Function: Get/Set Interleaved status Returns : boolean Args : boolean =cut sub interleaved { my ($self,$value) = @_; if( defined $value ) { if ($value) {$self->{'_interleaved'} = 1 } else {$self->{'_interleaved'} = 0 } } return 1 unless defined $self->{'_interleaved'}; return $self->{'_interleaved'}; } =head2 flag_SI Title : flag_SI Usage : my $flag = $obj->flag_SI Function: Get/Set if the Sequential/Interleaved flag has to be shown after the number of sequences and sequence length Example : Returns : boolean Args : boolean =cut sub flag_SI{ my ($self,$value) = @_; my $previous = $self->{'_flag_SI'}; if( defined $value ) { $self->{'_flag_SI'} = $value; } return $previous; } =head2 idlength Title : idlength Usage : my $idlength = $obj->idlength Function: Get/Set value of id length Returns : string Args : string =cut sub idlength { my($self,$value) = @_; if (defined $value){ $self->{'_idlength'} = $value; } return $self->{'_idlength'}; } =head2 line_length Title : line_length Usage : $obj->line_length($newval) Function: Returns : value of line_length Args : newvalue (optional) =cut sub line_length{ my ($self,$value) = @_; if( defined $value) { $self->{'_line_length'} = $value; } return $self->{'_line_length'} || $DEFAULTLINELEN; } =head2 tag_length Title : tag_length Usage : $obj->tag_length($newval) Function: Example : my $tag_length = $obj->tag_length Returns : value of the length for each space-separated tag in a line Args : newvalue (optional) - set to zero to have one tag per line =cut sub tag_length{ my ($self,$value) = @_; if( defined $value) { $self->{'_tag_length'} = $value; } return $self->{'_tag_length'} || $DEFAULTTAGLEN; } =head2 id_linebreak Title : id_linebreak Usage : $obj->id_linebreak($newval) Function: Returns : value of id_linebreak Args : newvalue (optional) =cut sub id_linebreak{ my ($self,$value) = @_; if( defined $value) { $self->{'_id_linebreak'} = $value; } return $self->{'_id_linebreak'} || 0; } =head2 wrap_sequential Title : wrap_sequential Usage : $obj->wrap_sequential($newval) Function: Returns : value of wrap_sequential Args : newvalue (optional) =cut sub wrap_sequential{ my ($self,$value) = @_; if( defined $value) { $self->{'_wrap_sequential'} = $value; } return $self->{'_wrap_sequential'} || 0; } =head2 longid Title : longid Usage : $obj->longid($newval) Function: Returns : value of longid Args : newvalue (optional) =cut sub longid{ my ($self,$value) = @_; if( defined $value) { $self->{'_longid'} = $value; } return $self->{'_longid'} || 0; } 1; BioPerl-1.6.923/Bio/AlignIO/po.pm000444000765000024 2137312254227317 16436 0ustar00cjfieldsstaff000000000000# $Id: po.pm # # BioPerl module for Bio::AlignIO::po # based on the Bio::AlignIO::fasta module # by Peter Schattner (and others?) # # and the SimpleAlign.pm module of Ewan Birney # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::po - po MSA Sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from 'po' format flat file databases. 'po' format is the native format of the POA alignment program (Lee C, Grasso C, Sharlow MF, 'Multiple sequence alignment using partial order graphs', Bioinformatics (2002), 18(3):452-64). =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Matthew Betts Email: matthew.betts@ii.uib.no =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::po; use strict; use Bio::SimpleAlign; use base qw(Bio::AlignIO); =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object - returns undef on end of file or on error Args : NONE =cut sub next_aln { my $self = shift; my $aln; my $entry; my $name; my $seqs; my $seq; my $nodes; my $list; my $node; my @chars; my $s; my $a; $aln = Bio::SimpleAlign->new(); # get to the first 'VERSION' line while(defined($entry = $self->_readline)) { if($entry =~ /^VERSION=(\S+)/) { $aln->source($1); if(defined($entry = $self->_readline) and $entry =~ /^NAME=(\S+)/) { $aln->id($1); } last; } } # read in the sequence names and node data, up to the end of # the file or the next 'VERSION' line, whichever comes first $seqs = []; $nodes = []; while(defined($entry = $self->_readline)) { if($entry =~ /^VERSION/) { # start of a new alignment, so... $self->_pushback($entry); last; } elsif($entry =~ /^SOURCENAME=(\S+)/) { $name = $1; if($name =~ /(\S+)\/(\d+)-(\d+)/) { $seq = Bio::LocatableSeq->new( '-display_id' => $1, '-start' => $2, '-end' => $3, '-alphabet' => $self->alphabet, ); } else { $seq = Bio::LocatableSeq->new('-display_id'=> $name, '-alphabet' => $self->alphabet); } # store sequences in a list initially, because can't guarantee # that will get them back from SimpleAlign object in the order # they were read, and also can't add them to the SimpleAlign # object here because their sequences are currently unknown push @{$seqs}, { 'seq' => $seq, 'str' => '', }; } elsif($entry =~ /^SOURCEINFO=(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(.*)/) { $seq->desc($5); } elsif($entry =~ /^(\S):(\S+)/) { $node = { 'aa' => $1, 'L' => [], 'S' => [], 'A' => [], 'status' => 'unvisited', }; $list = $2; if($list =~ /^([L\d]*)([S\d]*)([A\d]*)/) { push(@{$node->{'L'}}, split(/L/, $1)); push(@{$node->{'S'}}, split(/S/, $2)); push(@{$node->{'A'}}, split(/A/, $3)); (@{$node->{'L'}} > 0) and shift @{$node->{'L'}}; (@{$node->{'S'}} > 0) and shift @{$node->{'S'}}; (@{$node->{'A'}} > 0) and shift @{$node->{'A'}}; } push @{$nodes}, $node; } } # process the nodes foreach $node (@{$nodes}) { ($node->{'status'} ne 'unvisited') and next; @chars = ($aln->gap_char) x @{$seqs}; # char for each seq defaults to a gap # set the character for each sequence represented by this node foreach $s (@{$node->{'S'}}) { $chars[$s] = $node->{'aa'}; } $node->{'status'} = 'visited'; # do the same for each node in the same align ring while(defined($a = $node->{'A'}->[0])) { $node = $nodes->[$a]; ($node->{'status'} ne 'unvisited') and last; foreach $s (@{$node->{'S'}}) { $chars[$s] = $node->{'aa'}; } $node->{'status'} = 'visited'; } # update the sequences foreach $seq (@{$seqs}) { $seq->{'str'} .= shift @chars; } } # set the sequences of the bioperl objects # and add them to the alignment foreach $seq (@{$seqs}) { $seq->{'seq'}->seq($seq->{'str'}); $aln->add_seq($seq->{'seq'}); } # has an alignment been read?... return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in po format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my $self = shift; my @alns = @_; my $aln; my $seqs; my $nodes; my $seq; my $node; my $col; my $ring; my $i; my $char; foreach $aln (@alns) { if(!$aln or !$aln->isa('Bio::Align::AlignI')) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } # store the seqs on a list, because po format # refers to them by position on this list $seqs = []; foreach $seq ($aln->each_seq()) { push @{$seqs}, { 'seq' => $seq, 'n_nodes' => 0, 'first' => undef, 'previous' => undef, }; } # go through each column in the alignment and construct # the nodes for the equivalent poa alignment ring $nodes = []; for($col = 0; $col < $aln->length; $col++) { $ring = { 'nodes' => {}, 'first' => scalar @{$nodes}, 'last' => scalar @{$nodes}, }; for($i = 0; $i < @{$seqs}; $i++) { $seq = $seqs->[$i]; $char = $seq->{'seq'}->subseq($col + 1, $col + 1); ($char eq $aln->gap_char) and next; if(!defined($node = $ring->{'nodes'}->{$char})) { $node = { 'n' => scalar @{$nodes}, 'aa' => $char, 'L' => {}, 'S' => [], 'A' => [], }; # update the ring $ring->{'nodes'}->{$char} = $node; $ring->{'last'} = $node->{'n'}; # add the node to the node list push @{$nodes}, $node; } # add the sequence to the node push @{$node->{'S'}}, $i; # add the node to the sequence defined($seq->{'first'}) or ($seq->{'first'} = $node); $seq->{'n_nodes'}++; # add an edge from the previous node in the sequence to this one. # Then set the previous node to the current one, ready for the next # residue in this sequence defined($seq->{'previous'}) and ($node->{'L'}->{$seq->{'previous'}->{'n'}} = $seq->{'previous'}); $seq->{'previous'} = $node; } # set the 'next node in ring' field for each node in the ring if($ring->{'first'} < $ring->{'last'}) { for($i = $ring->{'first'}; $i < $ring->{'last'}; $i++) { push @{$nodes->[$i]->{'A'}}, $i + 1; } push @{$nodes->[$ring->{'last'}]->{'A'}}, $ring->{'first'}; } } # print header information $self->_print( 'VERSION=', ($aln->source and ($aln->source !~ /\A\s*\Z/)) ? $aln->source : 'bioperl', "\n", 'NAME=', $aln->id, "\n", 'TITLE=', ($seqs->[0]->{'seq'}->description or $aln->id), "\n", 'LENGTH=', scalar @{$nodes}, "\n", 'SOURCECOUNT=', scalar @{$seqs}, "\n", ); # print sequence information foreach $seq (@{$seqs}) { $self->_print( 'SOURCENAME=', $seq->{'seq'}->display_id, "\n", 'SOURCEINFO=', $seq->{'n_nodes'}, ' ', # number of nodes in the sequence $seq->{'first'}->{'n'}, ' ', # index of first node containing the sequence 0, ' ', # FIXME - sequence weight? -1, ' ', # FIXME - index of bundle containing sequence? ($seq->{'seq'}->description or 'untitled'), "\n", ); } # print node information foreach $node (@{$nodes}) { $self->_print($node->{'aa'}, ':'); (keys %{$node->{'L'}} > 0) and $self->_print('L', join('L', sort {$a <=> $b} keys %{$node->{'L'}})); (@{$node->{'S'}} > 0) and $self->_print('S', join('S', @{$node->{'S'}})); (@{$node->{'A'}} > 0) and $self->_print('A', join('A', @{$node->{'A'}})); $self->_print("\n"); } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/proda.pm000444000765000024 2003212254227331 17110 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::proda # # based on the Bio::SeqIO modules # by Ewan Birney # and Lincoln Stein # and the Bio::SimpleAlign module of Ewan Birney # # Copyright Albert Vilella # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::proda - proda sequence input/output stream This provides the basic capabilities to parse the output alignments from the ProDA multiple sequence alignment program (http://proda.stanford.edu) =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::AlignIO class. =head1 DESCRIPTION This object can transform Bio::Align::AlignI objects to and from proda files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Albert Vilella Email: avilella-at-gmail-dot-com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::proda; use vars qw($LINELENGTH); use strict; $LINELENGTH = 60; use base qw(Bio::AlignIO); =head2 new Title : new Usage : $alignio = Bio::AlignIO->new(-format => 'proda', -file => 'filename'); Function: returns a new Bio::AlignIO object to handle proda files Returns : Bio::AlignIO::proda object Args : -verbose => verbosity setting (-1, 0, 1, 2) -file => name of file to read in or to write, with ">" -fh => alternative to -file param - provide a filehandle to read from or write to -format => alignment format to process or produce -percentages => display a percentage of identity in each line of the alignment (proda only) -linelength=> alignment output line length (default 60) =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ( $percentages, $ll ) = $self->_rearrange( [qw(PERCENTAGES LINELENGTH)], @args ); defined $percentages && $self->percentages($percentages); $self->line_length( $ll || $LINELENGTH ); } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream Returns : Bio::Align::AlignI object Args : NONE See L for details =cut sub next_aln { my ($self) = @_; my $first_line; while ( $first_line = $self->_readline ) { last if $first_line !~ /^$/; } $self->_pushback($first_line); if ( defined( $first_line = $self->_readline ) && $first_line !~ /\(/ ) { $self->throw( "trying to parse a file which does not start with proda headers" ); } else { # use it inside the loop $self->_pushback($first_line); } my %alignments; my $aln = Bio::SimpleAlign->new( -source => 'proda', -verbose => $self->verbose ); my $order = 0; my %order; $self->{_lastline} = ''; my ($first_block, $seen_block, $seen_header) = (0,0,0); my @ids; my @ids_copy; while ( defined( $_ = $self->_readline ) ) { next if (/^\s+$/ && !$first_block); if (/^\s$/) { # line contains no description $seen_block = 1; next; } $first_block = 1; # break the loop if we come to the end of the current alignment # and push back the proda header if (/\(/ && $seen_header) { $self->_pushback($_); last; } if (/\(/ && !$seen_header) { @ids = split(' ', $_); $seen_header = 1; next; } my ( $seqname, $aln_line ) = ( '', '' ); if (/^\s*(\S+)\s*\/\s*(\d+)-(\d+)\s+(\S+)\s*$/ox) { # clustal 1.4 format ( $seqname, $aln_line ) = ( "$1:$2-$3", $4 ); # } elsif( /^\s*(\S+)\s+(\S+)\s*$/ox ) { without trailing numbers } elsif (/^\s*(\S+)\s+(\S+)\s*\d*\s*$/ox) { # with numbers ( $seqname, $aln_line ) = ( $1, $2 ); if ( $seqname =~ /^[\*\.\+\:]+$/ ) { $self->{_lastline} = $_; next; } } else { $self->{_lastline} = $_; next; } # we ended up the first block and now are on the second @ids_copy = @ids unless(defined($ids_copy[0])); #FIXME - hacky my $seqname_with_coords = shift(@ids_copy); if ($seqname_with_coords !~ /$seqname/) { { $self->throw("header and body of the alignment dont match"); } } $alignments{$seqname_with_coords} .= $aln_line; if ( !$seen_block ) { if (exists $order{$seqname_with_coords}) { $self->warn("Duplicate sequence : $seqname\n". "Can't guarantee alignment quality"); } else { $order{$seqname_with_coords} = $order++; } } } my ( $sname, $start, $end ); foreach my $name ( sort { $order{$a} <=> $order{$b} } keys %alignments ) { if ( $name =~ /(\S+):(\d+)-(\d+)/ ) { ( $sname, $start, $end ) = ( $1, $2, $3 ); } else { ( $sname, $start ) = ( $name, 1 ); my $str = $alignments{$name}; $str =~ s/[^A-Za-z]//g; $end = length($str); } my $seq = Bio::LocatableSeq->new( -seq => $alignments{$name}, -id => $sname, -start => $start, -end => $end, -alphabet => $self->alphabet, ); $aln->add_seq($seq); } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the proda-format object (.aln) into the stream Returns : 1 for success and 0 for error Args : Bio::Align::AlignI object =cut sub write_aln { my ($self,@aln) = @_; $self->throw_not_implemented(); } =head2 percentages Title : percentages Usage : $obj->percentages($newval) Function: Set the percentages flag - whether or not to show percentages in each output line Returns : value of percentages Args : newvalue (optional) =cut sub percentages { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_percentages'} = $value; } return $self->{'_percentages'}; } =head2 line_length Title : line_length Usage : $obj->line_length($newval) Function: Set the alignment output line length Returns : value of line_length Args : newvalue (optional) =cut sub line_length { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_line_length'} = $value; } return $self->{'_line_length'}; } =head2 no_header Title : no_header Usage : $obj->no_header($newval) Function: Set if the alignment input has a CLUSTAL header or not Returns : value of no_header Args : newvalue (optional) =cut sub no_header { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_no_header'} = $value; } return $self->{'_no_header'}; } 1; BioPerl-1.6.923/Bio/AlignIO/prodom.pm000444000765000024 600212254227321 17263 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::prodom # based on the Bio::SeqIO::prodom module # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::prodom - prodom sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects to and from prodom flat file databases. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Peter Schattner Email: schattner@alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::prodom; use strict; use base qw(Bio::AlignIO); =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object Args : NONE =cut sub next_aln { my $self = shift; my $entry; my ($acc, $fake_id, $start, $end, $seq, $add, %names); my $aln = Bio::SimpleAlign->new(-source => 'prodom'); while( $entry = $self->_readline) { if ($entry =~ /^AC\s+(\S+)\s*$/) { #ps 9/12/00 $aln->id( $1 ); } elsif ($entry =~ /^AL\s+(\S+)\|(\S+)\s+(\d+)\s+(\d+)\s+\S+\s+(\S+)\s*$/){ #ps 9/12/00 $acc=$1; $fake_id=$2; # Accessions have _species appended $start=$3; $end=$4; $seq=$5; $names{'fake_id'} = $fake_id; $add = Bio::LocatableSeq->new('-seq' => $seq, '-id' => $acc, '-start' => $start, '-end' => $end, '-alphabet' => $self->alphabet, ); $aln->add_seq($add); } elsif ($entry =~ /^CO/) { # the consensus line marks the end of the alignment part of the entry last; } } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in prodom format ###Not yet implemented!### Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/AlignIO/psi.pm000444000765000024 767312254227330 16575 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::psi # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::psi - Read/Write PSI-BLAST profile alignment files =head1 SYNOPSIS This module will parse PSI-BLAST output of the format seqid XXXX =head1 DESCRIPTION This is a parser for psi-blast blocks. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::psi; use vars qw($BlockLen $IdLength); use strict; $BlockLen = 100; $IdLength = 13; # Object preamble - inherits from Bio::Root::Root use Bio::SimpleAlign; use Bio::LocatableSeq; use base qw(Bio::AlignIO); =head2 new Title : new Usage : my $obj = Bio::AlignIO::psi->new(); Function: Builds a new Bio::AlignIO::psi object Returns : Bio::AlignIO::psi Args : =cut =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream Returns : Bio::Align::AlignI object Args : NONE See L =cut sub next_aln { my ($self) = @_; my $aln; my %seqs; my @order; while( defined ($_ = $self->_readline ) ) { next if( /^\s+$/); if( !defined $aln ) { $aln = Bio::SimpleAlign->new(); } my ($id,$s) = split; push @order, $id if( ! defined $seqs{$id}); $seqs{$id} .= $s; } foreach my $id ( @order) { my $gaps = $seqs{$id} =~ tr/-/-/; my $seq = Bio::LocatableSeq->new(-seq => $seqs{$id}, -id => $id, -start => 1, -end => length($seqs{$id}) - $gaps, -alphabet => $self->alphabet, ); $aln->add_seq($seq); } return $aln if defined $aln && $aln->num_sequences; return $aln; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the NCBI psi-format object (.aln) into the stream Returns : 1 for success and 0 for error Args : Bio::Align::AlignI object L =cut sub write_aln { my ($self,$aln) = @_; unless( defined $aln && ref($aln) && $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a valid Bio::Align::AlignI to write_aln"); return 0; } my $ct = 0; my @seqs = $aln->each_seq; my $len = 1; my $alnlen = $aln->length; my $idlen = $IdLength; my @ids = map { substr($_->display_id,0,$idlen) } @seqs; while( $len < ($alnlen + 1) ) { my $start = $len; my $end = $len + $BlockLen; $end = $alnlen if ( $end > $alnlen ); my $c = 0; foreach my $seq ( @seqs ) { $self->_print(sprintf("%-".$idlen."s %s\n", $ids[$c++], $seq->subseq($start,$end))); } $self->_print("\n"); $len += $BlockLen+1; } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/selex.pm000444000765000024 1060312254227322 17126 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::selex # based on the Bio::SeqIO::selex module # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::selex - selex sequence input/output stream =head1 SYNOPSIS # Do not use this module directly. Use it via the L class. use Bio::AlignIO; use strict; my $in = Bio::AlignIO->new(-format => 'selex', -file => 't/data/testaln.selex'); while( my $aln = $in->next_aln ) { } =head1 DESCRIPTION This object can transform L objects to and from selex flat file databases. =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Peter Schattner Email: schattner@alum.mit.edu =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::selex; use strict; use base qw(Bio::AlignIO); =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Tries to read *all* selex It reads all non whitespace characters in the alignment area. For selexs with weird gaps (eg ~~~) map them by using $al->map_chars('~','-') Returns : L object Args : NONE =cut sub next_aln { my $self = shift; my $entry; my ($start,$end,%align,$name,$seqname,%hash,@c2name, %accession,%desc); my $aln = Bio::SimpleAlign->new(-source => 'selex'); # in selex format, every non-blank line that does not start # with '#=' is an alignment segment; the '#=' lines are mark up lines. # Of particular interest are the '#=GF AC ' # lines, which give accession numbers for each segment while( $entry = $self->_readline) { if( $entry =~ /^\#=GS\s+(\S+)\s+AC\s+(\S+)/ ) { $accession{ $1 } = $2; next; } elsif( $entry =~ /^\#=GS\s+(\S+)\s+DE\s+(.+)\s*$/ ) { $desc{$1} .= $2; } elsif ( $entry =~ /^([^\#]\S+)\s+([A-Za-z\.\-\*]+)\s*/ ) { my ($name,$seq) = ($1,$2); if( ! defined $align{$name} ) { push @c2name, $name; } $align{$name} .= $seq; } } # ok... now we can make the sequences foreach my $name ( @c2name ) { if( $name =~ /(\S+)\/(\d+)-(\d+)/ ) { $seqname = $1; $start = $2; $end = $3; } else { $seqname=$name; $start = 1; $end = length($align{$name}); } my $seq = Bio::LocatableSeq->new ('-seq' => $align{$name}, '-display_id' => $seqname, '-start' => $start, '-end' => $end, '-description' => $desc{$name}, '-accession_number' => $accession{$name}, '-alphabet' => $self->alphabet, ); $aln->add_seq($seq); } return $aln if $aln->num_sequences; return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in selex format Returns : 1 for success and 0 for error Args : L object =cut sub write_aln { my ($self,@aln) = @_; my ($namestr,$seq,$add); my ($maxn); foreach my $aln (@aln) { $maxn = $aln->maxdisplayname_length(); foreach $seq ( $aln->each_seq() ) { $namestr = $aln->displayname($seq->get_nse()); $add = $maxn - length($namestr) + 2; $namestr .= " " x $add; $self->_print (sprintf("%s %s\n",$namestr,$seq->seq())) or return; } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; BioPerl-1.6.923/Bio/AlignIO/stockholm.pm000444000765000024 6423412254227327 20027 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::stockholm # # Based on the Bio::SeqIO::stockholm module # by Ewan Birney # and Lincoln Stein # # and the SimpleAlign.pm module of Ewan Birney # # Copyright Peter Schattner, Chris Fields # # You may distribute this module under the same terms as perl itself # _history # September 5, 2000 # November 6, 2006 - completely refactor read_aln(), add write_aln() # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::stockholm - stockholm sequence input/output stream =head1 SYNOPSIS # Do not use this module directly. Use it via the L class. use Bio::AlignIO; use strict; my $in = Bio::AlignIO->new(-format => 'stockholm', -file => 't/data/testaln.stockholm'); while( my $aln = $in->next_aln ) { } =head1 DESCRIPTION This object can transform L objects to and from stockholm flat file databases. This has been completely refactored from the original stockholm parser to handle annotation data and now includes a write_aln() method for (almost) complete stockholm format output. Stockholm alignment records normally contain additional sequence-based and alignment-based annotation GF Lines (alignment feature/annotation): #=GF Placed above the alignment GC Lines (Alignment consensus) #=GC Placed below the alignment GS Lines (Sequence annotations) #=GS GR Lines (Sequence meta data) #=GR Currently, sequence annotations (those designated with GS tags) are parsed only for accession numbers and descriptions. It is intended that full parsing will be added at some point in the near future along with a builder option for optionally parsing alignment annotation and meta data. The following methods/tags are currently used for storing and writing the alignment annotation data. Tag SimpleAlign Method ---------------------------------------------------------------------- AC accession ID id DE description ---------------------------------------------------------------------- Tag Bio::Annotation TagName Parameters Class ---------------------------------------------------------------------- AU SimpleValue record_authors value SE SimpleValue seed_source value GA SimpleValue gathering_threshold value NC SimpleValue noise_cutoff value TC SimpleValue trusted_cutoff value TP SimpleValue entry_type value SQ SimpleValue num_sequences value PI SimpleValue previous_ids value DC Comment database_comment comment CC Comment alignment_comment comment DR Target dblink database primary_id comment AM SimpleValue build_method value NE SimpleValue pfam_family_accession value NL SimpleValue sequence_start_stop value SS SimpleValue sec_structure_source value BM SimpleValue build_model value RN Reference reference * RC Reference reference comment RM Reference reference pubmed RT Reference reference title RA Reference reference authors RL Reference reference location ---------------------------------------------------------------------- * RN is generated based on the number of Bio::Annotation::Reference objects =head2 Custom annotation Some users may want to add custom annotation beyond those mapped above. Currently there are two methods to do so; however, the methods used for adding such annotation may change in the future, particularly if alignment Writer classes are introduced. In particular, do not rely on changing the global variables @WRITEORDER or %WRITEMAP as these may be made private at some point. 1) Use (and abuse) the 'custom' tag. The tagname for the object can differ from the tagname used to store the object in the AnnotationCollection. # AnnotationCollection from the SimpleAlign object my $coll = $aln->annotation; my $factory = Bio::Annotation::AnnotationFactory->new(-type => Bio::Annotation::SimpleValue'); my $rfann = $factory->create_object(-value => $str, -tagname => 'mytag'); $coll->add_Annotation('custom', $rfann); $rfann = $factory->create_object(-value => 'foo', -tagname => 'bar'); $coll->add_Annotation('custom', $rfann); OUTPUT: # STOCKHOLM 1.0 #=GF ID myID12345 #=GF mytag katnayygqelggvnhdyddlakfyfgaglealdffnnkeaaakiinwvaEDTTRGKIQDLV?? #=GF mytag TPtd~????LDPETQALLV???????????????????????NAIYFKGRWE?????????~?? #=GF mytag ??HEF?A?EMDTKPY??DFQH?TNen?????GRI??????V???KVAM??MF?????????N?? #=GF mytag ???DD?VFGYAEL????DE???????L??D??????A??TALELAY?????????????????? #=GF mytag ?????????????KG??????Sa???TSMLILLP???????????????D?????????????? #=GF mytag ???????????EGTr?????AGLGKLLQ??QL????????SREef??DLNK??L???AH????R #=GF mytag ????????????L????????????????????????????????????????R?????????R #=GF mytag ??QQ???????V???????AVRLPKFSFefefdlkeplknlgmhqafdpnsdvfklmdqavlvi #=GF mytag gdlqhayafkvd???????????????????????????????????????????????????? #=GF mytag ???????????????????????????????????????????????????????????????? #=GF mytag ???????????????????????????????????????????????????????????????? #=GF mytag ???????????????????????????????????????????????????????????????? #=GF mytag ?????????????INVDEAG?TEAAAATAAKFVPLSLppkt??????????????????PIEFV #=GF mytag ADRPFAFAIR??????E?PAT?G????SILFIGHVEDPTP?msv? #=GF bar foo ... 2) Modify the global @WRITEORDER and %WRITEMAP. # AnnotationCollection from the SimpleAlign object my $coll = $aln->annotation; # add to WRITEORDER my @order = @Bio::AlignIO::stockholm::WRITEORDER; push @order, 'my_stuff'; @Bio::AlignIO::stockholm::WRITEORDER = @order; # make sure new tag maps to something $Bio::AlignIO::stockholm::WRITEMAP{my_stuff} = 'Hobbit/SimpleValue'; my $rfann = $factory->create_object(-value => 'Frodo', -tagname => 'Hobbit'); $coll->add_Annotation('my_stuff', $rfann); $rfann = $factory->create_object(-value => 'Bilbo', -tagname => 'Hobbit'); $coll->add_Annotation('my_stuff', $rfann); OUTPUT: # STOCKHOLM 1.0 #=GF ID myID12345 #=GF Hobbit Frodo #=GF Hobbit Bilbo .... =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Chris Fields, Peter Schattner Email: cjfields-at-uiuc-dot-edu, schattner@alum.mit.edu =head1 CONTRIBUTORS Andreas Kahari, ak-at-ebi.ac.uk Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::stockholm; use strict; use Bio::Seq::Meta; use Bio::AlignIO::Handler::GenericAlignHandler; use Text::Wrap qw(wrap); use base qw(Bio::AlignIO); my $STKVERSION = 'STOCKHOLM 1.0'; # This maps the two-letter annotation key to a Annotation/parameter/tagname # combination. Some data is stored using get/set methods ('Methods') The rest # is mapped to Annotation objects using the parameter for the parsed data # and the tagname for, well, the Annotation tagname. A few are treated differently # based on the type of data stored (Reference data in particular). my %MAPPING = ( 'AC' => 'ACCESSION', 'ID' => 'ID', 'DE' => ['DESCRIPTION' => 'DESCRIPTION'], 'AU' => ['RECORD_AUTHORS' => 'RECORD_AUTHORS'], 'SE' => 'SEED_SOURCE', 'BM' => 'BUILD_COMMAND', 'GA' => 'GATHERING_THRESHOLD', 'NC' => 'NOISE_CUTOFF', 'TC' => 'TRUSTED_CUTOFF', 'TP' => 'ENTRY_TYPE', 'SQ' => 'NUM_SEQUENCES', 'PI' => 'PREVIOUS_IDS', 'DC' => ['DATABASE_COMMENT' => 'DATABASE_COMMENT'], 'DR' => 'DBLINK', 'RN' => ['REFERENCE' => 'REFERENCE'], 'RC' => ['REFERENCE' => 'COMMENT'], 'RM' => ['REFERENCE' => 'PUBMED'], 'RT' => ['REFERENCE' => 'TITLE'], 'RA' => ['REFERENCE' => 'AUTHORS'], 'RL' => ['REFERENCE' => 'JOURNAL'], 'CC' => ['ALIGNMENT_COMMENT' => 'ALIGNMENT_COMMENT'], #Pfam-specific 'AM' => 'BUILD_METHOD', 'NE' => 'PFAM_FAMILY_ACCESSION', 'NL' => 'SEQ_START_STOP', # Rfam-specific GF lines #'SS' => 'SEC_STRUCTURE_SOURCE', 'SEQUENCE' => 'SEQUENCE' ); # this is the order that annotations are written our @WRITEORDER = qw(accession id description previous_ids record_authors seed_source sec_structure_source gathering_threshold trusted_cutoff noise_cutoff entry_type build_command build_method pfam_family_accession seq_start_stop reference database_comment custom dblink alignment_comment num_sequences seq_annotation ); # This maps the tagname back to a tagname-annotation value combination. # Some data is stored using get/set methods ('Methods'), others # are mapped b/c of more complex annotation types. our %WRITEMAP = ( 'accession' => 'AC/Method', 'id' => 'ID/Method', 'description' => 'DE/Method', 'record_authors' => 'AU/SimpleValue', 'seed_source' => 'SE/SimpleValue', 'build_command' => 'BM/SimpleValue', 'gathering_threshold' => 'GA/SimpleValue', 'noise_cutoff' => 'NC/SimpleValue', 'trusted_cutoff' => 'TC/SimpleValue', 'entry_type' => 'TP/SimpleValue', 'num_sequences' => 'SQ/SimpleValue', 'previous_ids' => 'PI/SimpleValue', 'database_comment' => 'DC/SimpleValue', 'dblink' => 'DR/DBLink', 'reference' => 'RX/Reference', 'ref_number' => 'RN/number', 'ref_comment' => 'RC/comment', 'ref_pubmed' => 'RM/pubmed', 'ref_title' => 'RT/title', 'ref_authors' => 'RA/authors', 'ref_location' => 'RL/location', 'alignment_comment' => 'CC/Comment', 'seq_annotation' => 'DR/Collection', #Pfam-specific 'build_method' => 'AM/SimpleValue', 'pfam_family_accession' => 'NE/SimpleValue', 'seq_start_stop' => 'NL/SimpleValue', # Rfam-specific GF lines 'sec_structure_source' => 'SS/SimpleValue', # custom; this is used to carry over anything from the input alignment # not mapped to LocatableSeqs or SimpleAlign in a meaningful way 'custom' => 'XX/SimpleValue' ); # This maps the tagname back to a tagname-annotation value combination. # Some data is stored using get/set methods ('Methods'), others # are mapped b/c of more complex annotation types. =head2 new Title : new Usage : my $alignio = Bio::AlignIO->new(-format => 'stockholm' -file => '>file'); Function: Initialize a new L reader or writer Returns : L object Args : -line_length : length of the line for the alignment block -alphabet : symbol alphabet to set the sequences to. If not set, the parser will try to guess based on the alignment accession (if present), defaulting to 'dna'. -spaces : (optional, def = 1) boolean to add a space in between the "# STOCKHOLM 1.0" header and the annotation and the annotation and the alignment. =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ($handler, $linelength, $spaces) = $self->_rearrange([qw(HANDLER LINE_LENGTH SPACES)],@args); $spaces = defined $spaces ? $spaces : 1; $self->spaces($spaces); # hash for functions for decoding keys. $handler ? $self->alignhandler($handler) : $self->alignhandler(Bio::AlignIO::Handler::GenericAlignHandler->new( -format => 'stockholm', -verbose => $self->verbose, )); $linelength && $self->line_length($linelength); } =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln() Function: returns the next alignment in the stream. Returns : L object Args : NONE =cut sub next_aln { my $self = shift; my $handler = $self->alignhandler; # advance to alignment header while( defined(my $line = $self->_readline) ) { if ($line =~ m{^\#\s*STOCKHOLM\s+}xmso) { last; } } $self->{block_line} = 0; # go into main body of alignment my ($data_chunk, $isa_primary, $name, $alphabet); my $last_feat = ''; while( defined(my $line = $self->_readline) ) { # only blank lines are in between blocks, so reset block line my ($primary_tag, $secondary_tag, $data, $nse, $feat, $align, $concat); if ($line =~ m{^\s*$}xmso) { $self->{block_line} &&= 0; next; } # End of Record if (index($line, '//') == 0) { # fencepost $handler->data_handler($data_chunk); undef $data_chunk; $handler->data_handler({ALIGNMENT => 1, NAME => 'ALPHABET', DATA => $self->alphabet}) if $self->alphabet; last; } elsif ($line =~ m{^\#=([A-Z]{2})\s+([^\n]+?)\s*$}xmso) { ($primary_tag, $data) = ($1, $2); if ($primary_tag eq 'GS' || $primary_tag eq 'GR') { ($nse, $feat, $data) = split(/\s+/, $data, 3); } else { ($feat, $data) = split(/\s+/, $data, 2); } $align = ($primary_tag eq 'GF' || $primary_tag eq 'GR') ? 1 : 0; } elsif ($line =~ m{^(\S+)\s+([^\s]+)\s*}) { $self->{block_line}++; ($feat, $nse, $data) = ('SEQUENCE', $1, $2); } else { $self->debug("Missed line : $line\n"); } $primary_tag ||= ''; # when no #= line is present $align ||= 0; # array refs where the two values are equal indicate the start of a # primary chunk of data, otherwise it is to be folded into the last # data chunk under a secondary tag. These are also concatenated # to previous values if the if (exists($MAPPING{$feat}) && ref $MAPPING{$feat} eq 'ARRAY') { ($name, $secondary_tag, $isa_primary) = ( $MAPPING{$feat}->[0] eq $MAPPING{$feat}->[1] ) ? ($MAPPING{$feat}->[0], 'DATA', 1) : (@{ $MAPPING{$feat} }, 0) ; $concat = $last_feat eq $feat ? 1 : 0; } elsif (exists($MAPPING{$feat})) { ($name, $secondary_tag, $isa_primary) = ($MAPPING{$feat}, 'DATA', 1); # catch alphabet here if possible if ($align && $name eq 'ACCESSION' && !$self->alphabet) { if ($data =~ m{^(P|R)F}) { $self->alphabet($1 eq 'R' ? 'rna' : $1 eq 'P' ? 'protein' : undef ); } } } else { $name = ($primary_tag eq 'GR') ? 'NAMED_META' : ($primary_tag eq 'GC') ? 'CONSENSUS_META' : 'CUSTOM'; ($secondary_tag, $isa_primary) = ('DATA', 1); } # Since we can't determine whether data should be passed into the # Handler until the next round (due to concatenation and combining # data), we always check for the presence of the last chunk when the # occasion calls for it (i.e. when the current data string needs to go # into a new data chunk). If the data needs to be concatenated it is # flagged above and checked below (and passed by if the conditions # warrant it). # We run into a bit of a fencepost problem, (one chunk left over at # the end); that is taken care of above when the end of the record is # found. if ($isa_primary && defined $data_chunk && !$concat) { $handler->data_handler($data_chunk); undef $data_chunk; } $data_chunk->{NAME} = $name; # used for the handler $data_chunk->{ALIGNMENT} = $align; # flag that determines chunk destination $data_chunk->{$secondary_tag} .= (defined($data_chunk->{$secondary_tag})) ? ' '.$data : $data; $data_chunk->{NSE} = $nse if $nse; if ($name eq 'SEQUENCE' || $name eq 'NAMED_META' || $name eq 'CONSENSUS_META') { $data_chunk->{BLOCK_LINE} = $self->{block_line}; $data_chunk->{META_TAG} = $feat if ($name ne 'SEQUENCE'); } $last_feat = $feat; } my $aln = $handler->build_alignment; $handler->reset_parameters; return $aln; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in stockholm format Returns : 1 for success and 0 for error Args : L object =cut { my %LINK_CB = ( 'PDB' => sub {join('; ',($_[0]->database, $_[0]->primary_id.' '. ($_[0]->optional_id || ''), $_[0]->start, $_[0]->end)).';'}, 'SCOP' => sub {join('; ',($_[0]->database, $_[0]->primary_id || '', $_[0]->optional_id)).';'}, '_DEFAULT_' => sub {join('; ',($_[0]->database, $_[0]->primary_id)).';'}, ); sub write_aln { # enable array of SimpleAlign objects as well (see clustalw write_aln()) my ($self, @aln) = @_; for my $aln (@aln) { $self->throw('Need Bio::Align::AlignI object') if (!$aln || !($aln->isa('Bio::Align::AlignI'))); my $coll = $aln->annotation; my ($aln_ann, $seq_ann) = ('#=GF ', '#=GS '); $self->_print("# $STKVERSION\n") || return 0; $self->spaces && $self->_print("\n"); # annotations first #=GF XX .... for my $param (@WRITEORDER) { my @anns; # no point in going through this if there is no annotation! last if !$coll; # alignment annotations my $ct = 1; $self->throw("Bad parameter: $param") if !exists $WRITEMAP{$param}; # get the data, act on it based on the tag my ($tag, $key) = split q(/), $WRITEMAP{$param}; if ($key eq 'Method') { push @anns, $aln->$param; } else { @anns = $coll->get_Annotations($param); } my $rn = 1; ANNOTATIONS: for my $ann (@anns) { # using Text::Wrap::wrap() for word wrap my ($text, $alntag, $data); if ($tag eq 'RX') { REFS: for my $rkey (qw(ref_comment ref_number ref_pubmed ref_title ref_authors ref_location)) { my ($newtag, $method) = split q(/), $WRITEMAP{$rkey}; $alntag = sprintf('%-10s',$aln_ann.$newtag); if ($rkey eq 'ref_number') { $data = "[$rn]"; } else { $data = $ann->$method; } next REFS unless $data; $text = wrap($alntag, $alntag, $data); $self->_print("$text\n") or return 0; } $rn++; next ANNOTATIONS; } elsif ($tag eq 'XX') { # custom my $newtag = $ann->tagname; my $tmp = $aln_ann.$newtag; $alntag = sprintf('%-*s',length($tmp) + 1, $tmp); $data = $ann->display_text; } elsif ($tag eq 'SQ') { # use the actual number, not the stored Annotation data my $tmp = $aln_ann.$tag; $alntag = sprintf('%-*s',length($tmp) + 1, $tmp); $data = $aln->num_sequences; } elsif ($tag eq 'DR') { my $tmp = $aln_ann.$tag; $alntag = sprintf('%-*s',length($tmp) + 1, $tmp); my $db = uc $ann->database; my $cb = exists $LINK_CB{$db} ? $LINK_CB{$db} : $LINK_CB{_DEFAULT_}; $data = $ann->display_text($cb); } else { my $tmp = $aln_ann.$tag; $alntag = sprintf('%-*s',length($tmp) + 1, $tmp); $data = ref $ann ? $ann->display_text : $ann; } next unless $data; $text = wrap($alntag, $alntag, $data); $self->_print("$text\n") || return 0; } } #=GS AC xxxxxx my $tag = 'AC'; for my $seq ($aln->each_seq) { if (my $acc = $seq->accession_number) { my $text = sprintf("%-4s%-22s%-3s%s\n",$seq_ann, $aln->displayname($seq->get_nse), $tag, $acc); $self->_print($text) || return 0; } } #=GS DR xxxxxx $tag = 'DR'; for my $sf ($aln->get_SeqFeatures) { if (my @links = $sf->annotation->get_Annotations('dblink')) { for my $link (@links) { my $db = uc $link->database; my $cb = exists $LINK_CB{$db} ? $LINK_CB{$db} : $LINK_CB{_DEFAULT_}; my $text = sprintf("%-4s%-22s%-3s%s\n",$seq_ann, $aln->displayname($sf->entire_seq->get_nse), $tag, $link->display_text($cb)); $self->_print($text) || return 0; } } } $self->spaces && $self->_print("\n"); # now the sequences... my $blocklen = $self->line_length; my $maxlen = $aln->maxdisplayname_length() + 3; my $metalen = $aln->max_metaname_length() || 0; if ($blocklen) { my $blockstart = 1; my $alnlen = $aln->length; while ($blockstart < $alnlen) { my $subaln = $aln->slice($blockstart, $blockstart+$blocklen-1 ,1); $self->_print_seqs($subaln,$maxlen,$metalen); $blockstart += $blocklen; $self->_print("\n") unless $blockstart >= $alnlen; } } else { $self->_print_seqs($aln,$maxlen,$metalen); } $self->_print("//\n") || return 0; } $self->flush() if $self->_flush_on_write && defined $self->_fh; return 1; } } =head2 line_length Title : line_length Usage : $obj->line_length($newval) Function: Set the alignment output line length Returns : value of line_length Args : newvalue (optional) =cut sub line_length { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_line_length'} = $value; } return $self->{'_line_length'}; } =head2 spaces Title : spaces Usage : $obj->spaces(1) Function: Set the 'spaces' flag, which prints extra newlines between the header and the annotation and the annotation and the alignment Returns : sequence data type Args : newvalue (optional) =cut sub spaces { my $self = shift; return $self->{'_spaces'} = shift if @_; return $self->{'_spaces'}; }; =head2 alignhandler Title : alignhandler Usage : $stream->alignhandler($handler) Function: Get/Set the Bio::HandlerBaseI object Returns : Bio::HandlerBaseI Args : Bio::HandlerBaseI =cut sub alignhandler { my ($self, $handler) = @_; if ($handler) { $self->throw("Not a Bio::HandlerBaseI") unless ref($handler) && $handler->isa("Bio::HandlerBaseI"); $self->{'_alignhandler'} = $handler; } return $self->{'_alignhandler'}; } ############# PRIVATE INIT/HANDLER METHODS ############# sub _print_seqs { my ($self, $aln, $maxlen, $metalen) = @_; my ($seq_meta, $aln_meta) = ('#=GR','#=GC'); # modified (significantly) from AlignIO::pfam my ($namestr,$seq,$add); # pad extra for meta lines for $seq ( $aln->each_seq() ) { my ($s, $e, $str) = ($seq->start, $seq->end, $seq->strand); $namestr = $aln->displayname($seq->get_nse()); $self->_print(sprintf("%-*s%s\n",$maxlen+$metalen, $namestr, $seq->seq())) || return 0; if ($seq->isa('Bio::Seq::MetaI')) { for my $mname ($seq->meta_names) { $self->_print(sprintf("%-*s%s\n",$maxlen+$metalen, $seq_meta.' '.$namestr.' '.$mname, $seq->named_meta($mname))) || return 0; } } } # alignment consensus my $ameta = $aln->consensus_meta; if ($ameta) { for my $mname ($ameta->meta_names) { $self->_print(sprintf("%-*s%s\n",$maxlen+$metalen, $aln_meta.' '.$mname, $ameta->named_meta($mname))) || return 0; } } } 1; BioPerl-1.6.923/Bio/AlignIO/xmfa.pm000444000765000024 1450112254227334 16745 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::AlignIO::xmfa # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::AlignIO::xmfa - XMFA MSA Sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L class. =head1 DESCRIPTION This object can transform L objects from XMFA flat file databases. For more information, see: http://asap.ahabs.wisc.edu/mauve-aligner/mauve-user-guide/mauve-output-file-formats.html This module is based on the AlignIO::fasta parser written by Peter Schattner =head1 TODO Finish write_aln(), clean up code, allow LargeLocatableSeq (ie for very large sequences a'la Mauve) =head1 FEEDBACK =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Chris Fields =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::AlignIO::xmfa; use strict; use base qw(Bio::AlignIO); our $WIDTH = 60; =head2 next_aln Title : next_aln Usage : $aln = $stream->next_aln Function: returns the next alignment in the stream. Returns : Bio::Align::AlignI object - returns 0 on end of file or on error Args : -width => optional argument to specify the width sequence will be written (60 chars by default) See L =cut sub next_aln { my $self = shift; my ($width) = $self->_rearrange([qw(WIDTH)],@_); $self->width($width || $WIDTH); my ($name, $tempname, $seqchar); my $aln = Bio::SimpleAlign->new(); my $seqs = 0; # alignments while (defined (my $entry = $self->_readline) ) { chomp $entry; if ( index($entry, '=') == 0 ) { if (defined $name && $seqchar) { my $seq = $self->_process_seq($name, $seqchar); $aln->add_seq($seq); } if ($aln && $entry =~ m{score\s*=\s*(\d+)}) { $aln->score($1); } $seqchar = ''; undef $name; last; } elsif ( $entry =~ m{^>.+$}xms) { if ( defined $name ) { my $seq = $self->_process_seq($name, $seqchar); $aln->add_seq($seq); } $seqchar = ''; $name = $entry; } else { $seqchar .= $entry; } } # this catches last sequence if '=' is not present (Mauve) if ( defined $name ) { my $seq = $self->_process_seq($name, $seqchar); $aln->add_seq($seq); } $aln->num_sequences ? return $aln : return; } =head2 write_aln Title : write_aln Usage : $stream->write_aln(@aln) Function: writes the $aln object into the stream in xmfa format Returns : 1 for success and 0 for error Args : L object See L =cut sub write_aln { my ($self,@aln) = @_; my $width = $self->width; my ($seq,$desc,$rseq,$name,$count,$length,$seqsub,$start,$end,$strand,$id); foreach my $aln (@aln) { if( ! $aln || ! $aln->isa('Bio::Align::AlignI') ) { $self->warn("Must provide a Bio::Align::AlignI object when calling write_aln"); next; } #if( $self->force_displayname_flat ) { # $aln->set_displayname_flat(1); #} my $seqct = 1; foreach $rseq ( $aln->each_seq() ) { ($start, $end, $strand, $id) = ($rseq->start, $rseq->end, $rseq->strand || 0, $rseq->display_id); $strand = ($strand == 1) ? '+' : ($strand == -1) ? '-' : ''; $name = sprintf("%d:%d-%d %s %s",$seqct,$start,$end,$strand,$id); $seq = $rseq->seq(); $desc = $rseq->description || ''; $self->_print (">$name $desc\n") or return ; $count = 0; $length = length($seq); if(defined $seq && $length > 0) { $seq =~ s/(.{1,$width})/$1\n/g; } else { $seq = "\n"; } $self->_print($seq) || return 0; $seqct++; } my $alndesc = ''; $alndesc = "score = ".$aln->score if ($aln->score); $self->_print("= $alndesc\n") || return 0; } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 _get_len Title : _get_len Usage : Function: determine number of alphabetic chars Returns : integer Args : sequence string =cut sub _get_len { my ($self,$seq) = @_; $seq =~ s/[^A-Z]//gi; return CORE::length($seq); } =head2 width Title : width Usage : $obj->width($newwidth) $width = $obj->width; Function: Get/set width of alignment Returns : integer value of width Args : on set, new value (a scalar or undef, optional) =cut sub width{ my $self = shift; return $self->{'_width'} = shift if @_; return $self->{'_width'} || $WIDTH; } ####### PRIVATE ####### sub _process_seq { my ($self, $entry, $seq) = @_; my ($start, $end, $strand, $seqname, $desc, $all); # put away last name and sequence if ( $entry =~ m{^>\s*\d+:(\d+)-(\d+)\s([+-]{1})(?:\s+(\S+)\s*(\S\.*)?)?} ) { ($start, $end, $seqname, $desc) = ($1, $2, $4, $5); $strand = ($3 eq '+') ? 1 : -1; } else { $self->throw("Line does not comform to XMFA format:\n$entry"); } my $seqobj = Bio::LocatableSeq->new( -nowarnonempty => 1, -strand => $strand, -seq => $seq, -display_id => $seqname, -description => $desc || $all, -start => $start, -end => $end, -alphabet => $self->alphabet, ); $self->debug("Reading $seqname\n"); return $seqobj; } 1; BioPerl-1.6.923/Bio/AlignIO/Handler000755000765000024 012254227317 16654 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/AlignIO/Handler/GenericAlignHandler.pm000444000765000024 5717312254227317 23231 0ustar00cjfieldsstaff000000000000# Let the code begin... package Bio::AlignIO::Handler::GenericAlignHandler; use strict; use warnings; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::SimpleValue; use Bio::Annotation::Target; use Bio::Annotation::DBLink; use Bio::Annotation::Reference; use Bio::SimpleAlign; use Data::Dumper; use base qw(Bio::Root::Root Bio::HandlerBaseI); # only stockholm is defined for now... my %HANDLERS = ( # stockholm has sequence and alignment specific annotation; this 'stockholm' => { 'CONSENSUS_META' => \&_generic_consensus_meta, 'SEQUENCE' => \&_generic_metaseq, 'NAMED_META' => \&_generic_metaseq, 'ACCESSION' => \&_generic_store, 'ALPHABET' => \&_generic_store, 'ID' => \&_generic_store, 'DESCRIPTION' => \&_generic_store, 'REFERENCE' => \&_generic_reference, 'DBLINK' => \&_stockholm_target, 'DATABASE_COMMENT' => \&_generic_comment, 'ALIGNMENT_COMMENT' => \&_generic_comment, '_DEFAULT_' => \&_generic_simplevalue }, ); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($format, $verbose) = $self->_rearrange([qw(FORMAT VERBOSE)], @args); $self->throw("Must define alignment record format") if !$format; $verbose && $self->verbose($verbose); $self->format($format); $self->handler_methods(); # if we intend at a later point we can add a Builder #$builder && $self->alignbuilder($builder); return $self; } sub handler_methods { my $self = shift; if (!($self->{'handlers'})) { $self->throw("No handlers defined for alignment format ",$self->format) unless exists $HANDLERS{$self->format}; $self->{'handlers'} = $HANDLERS{$self->format}; } return ($self->{'handlers'}); } sub data_handler { my ($self, $data) = @_; my $nm = $data->{NAME} || $self->throw("No name tag defined!"); # this should handle data on the fly w/o caching; any caching should be # done in the driver! my $method = (exists $self->{'handlers'}->{$nm}) ? ($self->{'handlers'}->{$nm}) : (exists $self->{'handlers'}->{'_DEFAULT_'}) ? ($self->{'handlers'}->{'_DEFAULT_'}) : undef; if (!$method) { $self->debug("No handler defined for $nm\n"); return; }; $self->$method($data); } sub reset_parameters { my $self = shift; $self->{'_params'} = undef; $self->{'_nse_cache'} = undef; $self->{'_features'} = undef; } sub format { my $self = shift; if (@_) { my $format = lc shift; $self->throw("Format $format not supported") unless exists $HANDLERS{$format}; $self->{'_alignformat'} = $format; }; return $self->{'_alignformat'}; } sub get_params { my ($self, @ids) = @_; my $data; if (scalar(@ids)) { for my $id (@ids) { if (!index($id, '-')==0) { $id = '-'.$id ; } $data->{$id} = $self->{'_params'}->{$id} if (exists $self->{'_params'}->{$id}); } $data ||= {}; } else { $data = $self->{'_params'}; } return $data; } sub set_params { shift->throw('Not implemented yet!'); } sub build_alignment { my $self = shift; my %init; $self->process_seqs; my $param = $self->get_params; if (defined $param->{-seqs}) { return Bio::SimpleAlign->new(%$param, -source => $self->format); } } sub annotation_collection { my ($self, $coll) = @_; if ($coll) { $self->throw("Must have Bio::AnnotationCollectionI ". "when explicitly setting annotation_collection()") unless (ref($coll) && $coll->isa('Bio::AnnotationCollectionI')); $self->{'_params'}->{'-annotation'} = $coll; } elsif (!exists($self->{'_params'}->{'-annotation'})) { $self->{'_params'}->{'-annotation'} = Bio::Annotation::Collection->new() } return $self->{'_params'}->{'-annotation'}; } sub seq_annotation_collection { my ($self, $coll) = @_; if ($coll) { $self->throw("Must have Bio::AnnotationCollectionI ". "when explicitly setting seq_annotation_collection()") unless (ref($coll) && $coll->isa('Bio::AnnotationCollectionI')); $self->{'_params'}->{'-seq_annotation'} = $coll; } elsif (!exists($self->{'_params'}->{'-seq_annotation'})) { $self->{'_params'}->{'-seq_annotation'} = Bio::Annotation::Collection->new() } return $self->{'_params'}->{'-seq_annotation'}; } sub process_seqs { my $self = shift; my $data = $self->get_params(qw(-seqs -seq_class -consensus_meta)); my $class = $data->{-seq_class} || 'Bio::LocatableSeq'; # cache classes loaded already if (!exists($self->{'_loaded_modules'}->{$class})) { $self->_load_module($class); $self->{'_loaded_modules'}->{$class}++; } # process any meta sequence data if ( $data->{-consensus_meta} && !UNIVERSAL::isa($data->{-consensus_meta},'Bio::Seq::Meta')) { my $ref = $data->{-consensus_meta}; if (!exists($self->{'_loaded_modules'}->{'Bio::Seq::Meta'})) { $self->_load_module('Bio::Seq::Meta'); $self->{'_loaded_modules'}->{'Bio::Seq::Meta'}++; } my $ms = Bio::Seq::Meta->new(); for my $tag (sort keys %{$ref}) { $ms->named_meta($tag, $ref->{$tag}); } $self->{'_params'}->{'-consensus_meta'} = $ms; } # this should always be an array ref! for my $seq (@{$data->{-seqs}}) { next if (UNIVERSAL::isa($seq,'Bio::LocatableI')); # process anything else $self->_from_nse($seq) if $seq->{NSE}; if (UNIVERSAL::isa($seq,'HASH')) { my %param; for my $p (keys %$seq) { $param{'-'.lc $p} = $seq->{$p} if exists $seq->{$p}; } my $ls = $class->new(%param); # a little switcheroo to attach the sequence # (though using it to get seq() doesn't work correctly yet!) if (defined $seq->{NSE} && exists $self->{'_features'} && exists $self->{'_features'}->{ $seq->{NSE} }) { for my $feat (@{ $self->{'_features'}->{ $seq->{NSE} } }) { push @{ $self->{'_params'}->{'-features'} }, $feat; $feat->attach_seq($ls); } } $seq = $ls; } } } ####################### SEQUENCE HANDLERS ####################### # any sequence data for a Bio::Seq::Meta sub _generic_metaseq { my ($self, $data) = @_; return unless $data; $self->throw("No alignment position passed") if !exists($data->{BLOCK_LINE}); $self->throw("Alignment position must be an index greater than 0") if $data->{BLOCK_LINE} < 1; $self->{'_params'}->{'-seq_class'} = 'Bio::Seq::Meta'; my $index = $data->{BLOCK_LINE} - 1; if (my $nse = $self->{'_params'}->{'-seqs'}->[$index]->{NSE}) { $self->throw("NSE in passed data doesn't match stored data in same position: $nse") unless $nse eq $data->{NSE}; } else { $self->{'_params'}->{'-seqs'}->[$index]->{NSE} = $data->{NSE}; } if ($data->{NAME} eq 'SEQUENCE') { $self->{'_params'}->{'-seqs'}->[$index]->{SEQ} .= $data->{DATA}; } elsif ($data->{NAME} eq 'NAMED_META') { $self->{'_params'}->{'-seqs'}->[$index]->{NAMED_META}->{$data->{META_TAG}} .= $data->{DATA}; } } sub _generic_consensus_meta { my ($self, $data) = @_; return unless $data; if ($data->{NAME} eq 'CONSENSUS_META') { $self->{'_params'}->{'-consensus_meta'}->{$data->{META_TAG}} .= $data->{DATA}; } } # any sequence data for a Bio::LocatableSeq sub _generic_locatableseq { my ($self, $data) = @_; return unless $data; $self->throw("No alignment position passed") if !exists($data->{BLOCK_LINE}); $self->throw("Alignment position must be an index greater than 0") if $data->{BLOCK_LINE} < 1; my $index = $data->{BLOCK_LINE} - 1; if (my $nse = $self->{'_params'}->{'-seqs'}->[$index]->{NSE}) { $self->throw("NSE in passed data doesn't match stored data in same position: $nse") if $nse ne $data->{NSE}; } else { $self->{'_params'}->{'-seqs'}->[$index]->{NSE} = $data->{NSE}; } if ($data->{NAME} eq 'SEQUENCE') { $self->{'_params'}->{'-seqs'}->[$index]->{SEQ} .= $data->{DATA}; } } ####################### RAW DATA HANDLERS ####################### # store by data name (ACCESSION, ID, etc), which can be mapped to the # appropriate alignment or sequence parameter sub _generic_store { my ($self, $data) = @_; return unless $data; if ($data->{ALIGNMENT}) { $self->{'_params'}->{'-'.lc $data->{NAME}} = $data->{DATA}; } else { $self->{'_params'}->{'-seq_'.lc $data->{NAME}}->{$data->{NSE}} = $data->{DATA} } } sub _generic_reference { my ($self, $data) = @_; my $ref = Bio::Annotation::Reference->new(-title => $data->{TITLE}, -authors => $data->{AUTHORS}, -pubmed => $data->{PUBMED}, -location => $data->{JOURNAL}, -tagname => lc $data->{NAME}); $self->annotation_collection->add_Annotation($ref); } sub _generic_simplevalue { my ($self, $data) = @_; my $sv = Bio::Annotation::SimpleValue->new(-value => $data->{DATA}, -tagname => lc $data->{NAME}); $self->annotation_collection->add_Annotation($sv); } sub _generic_comment { my ($self, $data) = @_; my $comment = Bio::Annotation::Comment->new(-type => lc $data->{NAME}, -text => $data->{DATA}, -tagname => lc $data->{NAME}); $self->annotation_collection->add_Annotation($comment); } # Some DBLinks in Stockholm format are unique, so a unique handler for them sub _stockholm_target { my ($self, $data) = @_; # process database info $self->_from_stk_dblink($data); my $comment; # Bio::Annotation::Target is now a DBLink, but has additional (RangeI) # capabilities (for PDB data) my $dblink = Bio::Annotation::Target->new( -database => $data->{DBLINK_DB}, -primary_id => $data->{DBLINK_ACC}, -optional_id => $data->{DBLINK_OPT}, -start => $data->{DBLINK_START}, -end => $data->{DBLINK_END}, -strand => $data->{DBLINK_STRAND}, -comment => $comment, -tagname => 'dblink', ); if ($data->{ALIGNMENT}) { # Alignment-specific DBLinks $self->annotation_collection->add_Annotation($dblink); } else { # Sequence-specific DBLinks # These should come with identifying information of some sort # (ID/START/END/STRAND). Make into a SeqFeature (SimpleAlign is # FeatureHolderI) spanning the length acc. to the NSE. Add the DBLink as # Annotation specific to that SeqFeature, store in an internal hash by # NSE so we can tie the LocatableSeq to the proper Features $self->_from_nse($data) if $data->{NSE}; $self->throw("Must supply an sequence DISPLAY_ID or NSE for sequence-related DBLinks") unless $data->{ACCESSION_NUMBER} || $data->{DISPLAY_ID}; my $sf = Bio::SeqFeature::Generic->new(-seq_id => $data->{DISPLAY_ID}, -accession_number => $data->{ACCESSION_NUMBER}, -start => $data->{START}, -end => $data->{END}, -strand => $data->{STRAND} ); $sf->annotation->add_Annotation($dblink); # index by NSE push @{ $self->{'_features'}->{ $data->{NSE} } }, $sf; #$self->seq_annotation_collection->add_Annotation($dblink); } } ####################### HELPER METHODS ####################### # returns ACCESSION VERSION START END STRAND ALPHABET # cached for multiple lookups, should reset in between uses sub _from_nse { my ($self, $data) = @_; return unless my $nse = $data->{NSE}; $data->{ALPHABET} = $self->get_params('-alphabet')->{'-alphabet'} || 'protein'; # grab any accessions if present, switch out with ACCESSION from NSE # (move that to primary_id) my $new_acc; if (exists $self->{'_params'}->{'-seq_accession'}) { $new_acc = $self->{'_params'}->{'-seq_accession'}->{$data->{NSE}}; } if ($nse =~ m{(\S+?)(?:\.(\d+))?/(\d+)-(\d+)}xmso) { my $strand = $data->{ALPHABET} eq 'dna' || $data->{ALPHABET} eq 'rna' ? 1 : undef; my ($start, $end) = ($3, $4); if ($start > $end) { ($start, $end, $strand) = ($end, $start, -1); } $data->{ACCESSION_NUMBER} = $new_acc || $1; $data->{DISPLAY_ID} = $1; $data->{VERSION} = $2; $data->{START} = $start; $data->{END} = $end; $data->{STRAND} = $strand; } else { # we can parse for version here if needed $data->{DISPLAY_ID} = $data->{NSE}; } } # this will probably be split up into subhandlers based on Record/DB sub _from_stk_dblink { my ($self, $data) = @_; return unless my $raw = $data->{DATA}; my @rawdata = split(m{\s*;\s*}, $raw); my %dblink_data; if ($rawdata[0] eq 'PDB') { # fix for older Stockholm PDB range format if (scalar(@rawdata) == 3 && $rawdata[2] =~ m{-}) { @rawdata[2,3] = split('-',$rawdata[2],2); } $self->throw("Not standard PDB form: ".$data->{DATA}) if scalar(@rawdata) != 4; my ($main, $chain) = split(m{\s+}, $rawdata[1]); %dblink_data = ( DBLINK_DB => $rawdata[0], DBLINK_ACC => $main, DBLINK_OPT => $chain || '', DBLINK_START => $rawdata[2], DBLINK_END => $rawdata[3] ); } elsif ($rawdata[0] eq 'SCOP') { $self->throw("Not standard SCOP form: ".$data->{DATA}) if scalar(@rawdata) != 3; %dblink_data = ( DBLINK_DB => $rawdata[0], DBLINK_ACC => $rawdata[1], DBLINK_OPT => $rawdata[2], ); } else { $self->warn("Some data missed: ".$data->{DATA}) if scalar(@rawdata) > 2; %dblink_data = ( DBLINK_DB => $rawdata[0], DBLINK_ACC => $rawdata[1], ); } while (my ($k, $v) = each %dblink_data) { $data->{$k} = $v if $v; } } 1; __END__ # $Id: GenericAlignHandler.pm 14816 2008-08-21 16:00:12Z cjfields $ # # BioPerl module for Bio::AlignIO::Handler::GenericAlignHandler # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # # Documentation after the __END__ marker =head1 NAME Bio::AlignIO::Handler::GenericAlignHandler - Bio::HandlerI-based generic data handler class for alignment-based data =head1 SYNOPSIS # MyHandler is a GenericAlignHandler object. # inside a parser (driver) constructor.... $self->alignhandler($handler || MyHandler->new(-format => 'stockholm')); # in next_aln() in driver... $hobj = $self->alignhandler(); # roll data up into hashref chunks, pass off into Handler for processing... $hobj->data_handler($data); # or retrieve Handler methods and pass data directly to Handler methods... my $hmeth = $hobj->handler_methods; if ($hmeth->{ $data->{NAME} }) { my $mth = $hmeth->{ $data->{NAME} }; $hobj->$mth($data); } =head1 DESCRIPTION This is an experimental implementation of a alignment-based HandlerBaseI parser and may change over time. It is possible that the way handler methods are set up will change over development to allow more flexibility. Standard Developer caveats: Here thar be dragoons... Consider yourself warned! =head2 NOTES As in the SeqIO Handler object (still in development), data is passed in as chunks. The Annotation and SeqFeatures are essentially the same as the SeqIO parser; the significant difference is that data hash being passed could pertain to either the alignment or to a specific sequence, so an extra tag may be needed to disambiguate between the two in some cases. Here I use the ALIGNMENT tag as a boolean flag: it must be present and set to 0 for the data to be tagged for Bio::LocatableSeq or similar (in all other cases it is assumed to be for the alignment). In some cases this will not matter (the actual sequence data, for instance) but it is highly recommmended adding this tag in to prevent possible ambiguities. This is the current Annotation data chunk (via Data::Dumper): $VAR1 = { 'NAME' => 'REFERENCE', 'DATA' => '1 (bases 1 to 10001)' 'AUTHORS' => 'International Human Genome Sequencing Consortium.' 'TITLE' => 'The DNA sequence of Homo sapiens' 'JOURNAL' => 'Unpublished (2003)' 'ALIGNMENT' => 1, }; In the case of LocatableSeqs, one can pass them in as follows for simplicity (note the block line): $VAR1 = { 'NAME' => 'SEQUENCE', 'BLOCK_LINE' => 0, 'NSE' => 'Q7WNI7_BORBR/113-292', 'ALPHABET' => 'protein', 'DATA' => 'VALILGVYRRL...CYVNREM..RAG....QW', 'ALIGNMENT' => 0 }; This can be done as the parser parses each block instead of parsing all the blocks and then passing them in one at a time; the handler will store the sequence data by the block line in an internal hash, concatenating them along the way. This behaviour is b/c the alignment building step requires that the sequence be checked for start/end/strand, possible meta sequence, optional accession, etc. Similarly, a Meta sequence line can be passed in as follows: $VAR1 = { 'NAME' => 'NAMED_META', 'BLOCK_LINE' => 0, 'NSE' => 'Q7WNI7_BORBR/113-292', 'META_KEY' => 'pAS', 'DATA' => '................................', 'ALIGNMENT' => 0 }; The meta sequence will be checked against the NSE for the block position and stored based on the meta tag. A meta sequence does not have to correspond to a real sequence. At this time, unique meta sequence tags must be used for each sequence or they will be overwritten (this may change). An alignment consensus string: $VAR1 = { 'NAME' => 'CONSENSUS', 'DATA' => 'VALILGVYRRL...CYVNREM..RAG....QW', 'ALIGNMENT' => 1 }; A consensus meta sequence: $VAR1 = { 'NAME' => 'CONSENSUS_META', 'META_KEY' => 'pAS', 'DATA' => '................................', 'ALIGNMENT' => 1 }; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut =head2 new Title : new Usage : Function: Returns : Args : -format Sequence format to be mapped for handler methods -builder Bio::Seq::SeqBuilder object (normally defined in SequenceStreamI object implementation constructor) Throws : On undefined '-format' sequence format parameter Note : Still under heavy development =cut =head1 L implementing methods =head2 handler_methods Title : handler_methods Usage : $handler->handler_methods('GenBank') %handlers = $handler->handler_methods(); Function: Retrieve the handler methods used for the current format() in the handler. This assumes the handler methods are already described in the HandlerI-implementing class. Returns : a hash reference with the data type handled and the code ref associated with it. Args : [optional] String representing the sequence format. If set here this will also set sequence_format() Throws : On unimplemented sequence format in %HANDLERS =cut =head2 data_handler Title : data_handler Usage : $handler->data_handler($data) Function: Centralized method which accepts all data chunks, then distributes to the appropriate methods for processing based on the chunk name from within the HandlerBaseI object. One can also use Returns : None Args : an hash ref containing a data chunk. =cut =head2 reset_parameters Title : reset_parameters Usage : $handler->reset_parameters() Function: Resets the internal cache of data (normally object parameters for a builder or factory) Returns : None Args : None =cut =head2 format Title : format Usage : $handler->format('GenBank') Function: Get/Set the format for the report/record being parsed. This can be used to set handlers in classes which are capable of processing similar data chunks from multiple driver modules. Returns : String with the sequence format Args : [optional] String with the sequence format Note : The format may be used to set the handlers (as in the current GenericRichSeqHandler implementation) =cut =head2 get_params Title : get_params Usage : $handler->get_params('-species') Function: Convenience method used to retrieve the specified parameters from the internal parameter cache Returns : Hash ref containing parameters requested and data as key-value pairs. Note that some parameter values may be objects, arrays, etc. Args : List (array) representing the parameters requested =cut =head2 set_params Title : set_params Usage : $handler->set_param({'-seqs' => $seqs}) Function: Convenience method used to set specific parameters Returns : None Args : Hash ref containing the data to be passed as key-value pairs =cut =head1 Methods unique to this implementation =head2 build_alignment Title : build_alignment Usage : Function: Returns : a Bio::SimpleAlign Args : Throws : Note : This may be replaced by a Builder object at some point =cut =head2 annotation_collection Title : annotation_collection Usage : Function: Returns : Args : Throws : Note : =cut =head2 seq_annotation_collection Title : seq_annotation_collection Usage : Function: Returns : Args : Throws : Note : =cut =head2 process_seqs Title : process_seqs Usage : $handler->process_seqs; Function: checks internal sequences to ensure they are converted over to the proper Bio::AlignI-compatible sequence class Returns : 1 if successful Args : none =cut BioPerl-1.6.923/Bio/Annotation000755000765000024 012254227340 16123 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Annotation/AnnotationFactory.pm000444000765000024 1624712254227321 22311 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::AnnotationFactory # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Annotation::AnnotationFactory - Instantiates a new Bio::AnnotationI (or derived class) through a factory =head1 SYNOPSIS use Bio::Annotation::AnnotationFactory; # my $factory = Bio::Annotation::AnnotationFactory->new( -type => 'Bio::Annotation::SimpleValue'); my $ann = $factory->create_object(-value => 'peroxisome', -tagname => 'cellular component'); =head1 DESCRIPTION This object will build L objects generically. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 CONTRIBUTORS This is mostly copy-and-paste with subsequent adaptation from Bio::Seq::SeqFactory by Jason Stajich. Most credits should in fact go to him. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::AnnotationFactory; use strict; use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI); =head2 new Title : new Usage : my $obj = Bio::Annotation::AnnotationFactory->new(); Function: Builds a new Bio::Annotation::AnnotationFactory object Returns : Bio::Annotation::AnnotationFactory Args : -type => string, name of a L derived class. If type is not set the module guesses it based on arguments passed to method L. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type) = $self->_rearrange([qw(TYPE)], @args); $self->{'_loaded_types'} = {}; $self->type($type) if $type; return $self; } =head2 create_object Title : create_object Usage : my $seq = $factory->create_object(); Function: Instantiates new Bio::AnnotationI (or one of its child classes) This object allows us to genericize the instantiation of cluster objects. Returns : L compliant object The return type is configurable using new(-type =>"..."). Args : initialization parameters specific to the type of annotation object we want. =cut sub create_object { my ($self,@args) = @_; my $type = $self->type; if(! $type) { # we need to guess this $type = $self->_guess_type(@args); if(! $type) { $self->throw("No annotation type set and unable to guess."); } # load dynamically if it hasn't been loaded yet if(! $self->{'_loaded_types'}->{$type}) { eval { $self->_load_module($type); $self->{'_loaded_types'}->{$type} = 1; }; if($@) { $self->throw("Bio::AnnotationI implementation $type ". "failed to load: ".$@); } } } return $type->new(-verbose => $self->verbose, @args); } =head2 type Title : type Usage : $obj->type($newval) Function: Get/set the type of L object to be created. This may be changed at any time during the lifetime of this factory. Returns : value of type Args : newvalue (optional) =cut sub type{ my $self = shift; if(@_) { my $type = shift; if($type && (! $self->{'_loaded_types'}->{$type})) { eval { $self->_load_module($type); }; if( $@ ) { $self->throw("Annotation class '$type' failed to load: ". $@); } my $a = bless {},$type; if( ! $a->isa('Bio::AnnotationI') ) { $self->throw("'$type' does not implement Bio::AnnotationI. ". "Too bad."); } $self->{'_loaded_types'}->{$type} = 1; } return $self->{'type'} = $type; } return $self->{'type'}; } =head2 _guess_type Title : _guess_type Usage : Function: Guesses the right type of L implementation based on initialization parameters for the prospective object. Example : Returns : the type (a string, the module name) Args : initialization parameters to be passed to the prospective cluster object =cut sub _guess_type{ my ($self,@args) = @_; my $type; # we can only guess from a certain number of arguments my ($val, $db, $text, $name, $authors, $start, $tree, $node) = $self->_rearrange([qw(VALUE DATABASE TEXT NAME AUTHORS START TREE_OBJ NODE )], @args); SWITCH: { $val && do { $type = ref($val) ? "TagTree" : "SimpleValue"; last SWITCH; }; $authors && do { $type = "Reference"; last SWITCH; }; $db && do { $type = "DBLink"; last SWITCH; }; $text && do { $type = "Comment"; last SWITCH; }; $name && do { $type = "OntologyTerm"; last SWITCH; }; $start && do { $type = "Target"; last SWITCH; }; $tree && do { $type = "Tree"; last SWITCH; }; $node && do { $type = "TagTree"; last SWITCH; }; # what else could we look for? } $type = "Bio::Annotation::".$type; return $type; } ##################################################################### # aliases for naming consistency or other reasons # ##################################################################### *create = \&create_object; 1; BioPerl-1.6.923/Bio/Annotation/Collection.pm000444000765000024 4460612254227317 20747 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::Collection.pm # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::Collection - Default Perl implementation of AnnotationCollectionI =head1 SYNOPSIS # get an AnnotationCollectionI somehow, eg $ac = $seq->annotation(); foreach $key ( $ac->get_all_annotation_keys() ) { @values = $ac->get_Annotations($key); foreach $value ( @values ) { # value is an Bio::AnnotationI, and defines a "as_text" method print "Annotation ",$key," stringified value ",$value->as_text,"\n"; # also defined hash_tree method, which allows data orientated # access into this object $hash = $value->hash_tree(); } } =head1 DESCRIPTION Bioperl implementation for Bio::AnnotationCollectionI =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::Collection; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Annotation::TypeManager; use Bio::Annotation::SimpleValue; use base qw(Bio::Root::Root Bio::AnnotationCollectionI Bio::AnnotationI); =head2 new Title : new Usage : $coll = Bio::Annotation::Collection->new() Function: Makes a new Annotation::Collection object. Returns : Bio::Annotation::Collection Args : none =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_annotation'} = {}; $self->_typemap(Bio::Annotation::TypeManager->new()); return $self; } =head1 L implementing methods =cut =head2 get_all_annotation_keys Title : get_all_annotation_keys Usage : $ac->get_all_annotation_keys() Function: gives back a list of annotation keys, which are simple text strings Returns : list of strings Args : none =cut sub get_all_annotation_keys{ my ($self) = @_; return keys %{$self->{'_annotation'}}; } =head2 get_Annotations Title : get_Annotations Usage : my @annotations = $collection->get_Annotations('key') Function: Retrieves all the Bio::AnnotationI objects for one or more specific key(s). If no key is given, returns all annotation objects. The returned objects will have their tagname() attribute set to the key under which they were attached, unless the tagname was already set. Returns : list of Bio::AnnotationI - empty if no objects stored for a key Args : keys (list of strings) for annotations (optional) =cut sub get_Annotations{ my ($self,@keys) = @_; my @anns = (); @keys = $self->get_all_annotation_keys() unless @keys; foreach my $key (@keys) { if(exists($self->{'_annotation'}->{$key})) { push(@anns, map { $_->tagname($key) if ! $_->tagname(); $_; } @{$self->{'_annotation'}->{$key}}); } } return @anns; } =head2 get_nested_Annotations Title : get_nested_Annotations Usage : my @annotations = $collection->get_nested_Annotations( '-key' => \@keys, '-recursive => 1); Function: Retrieves all the Bio::AnnotationI objects for one or more specific key(s). If -recursive is set to true, traverses the nested annotation collections recursively and returns all annotations matching the key(s). If no key is given, returns all annotation objects. The returned objects will have their tagname() attribute set to the key under which they were attached, unless the tagname was already set. Returns : list of Bio::AnnotationI - empty if no objects stored for a key Args : -keys => arrayref of keys to search for (optional) -recursive => boolean, whether or not to recursively traverse the nested annotations and return annotations with matching keys. =cut sub get_nested_Annotations { my ($self, @args) = @_; my ($keys, $recursive) = $self->_rearrange([qw(KEYS RECURSIVE)], @args); $self->verbose(1); my @anns = (); # if not recursive behave exactly like get_Annotations() if (!$recursive) { my @keys = $keys? @$keys : $self->get_all_annotation_keys(); foreach my $key (@keys) { if(exists($self->{'_annotation'}->{$key})) { push(@anns, map { $_->tagname($key) if ! $_->tagname(); $_; } @{$self->{'_annotation'}->{$key}}); } } } # if recursive search for keys recursively else { my @allkeys = $self->get_all_annotation_keys(); foreach my $key (@allkeys) { my $keymatch = 0; foreach my $searchkey (@$keys) { if ($key eq $searchkey) { $keymatch = 1;} } if ($keymatch) { if(exists($self->{'_annotation'}->{$key})) { push(@anns, map { $_->tagname($key) if ! $_->tagname(); $_; } @{$self->{'_annotation'}->{$key}}); } } else { my @annotations = @{$self->{'_annotation'}->{$key}}; foreach (@annotations) { if ($_->isa("Bio::AnnotationCollectionI")) { push (@anns, $_->get_nested_Annotations('-keys' => $keys, '-recursive' => 1) ); } } } } } return @anns; } =head2 get_all_Annotations Title : get_all_Annotations Usage : Function: Similar to get_Annotations, but traverses and flattens nested annotation collections. This means that collections in the tree will be replaced by their components. Keys will not be passed on to nested collections. I.e., if the tag name of a nested collection matches the key, it will be flattened in its entirety. Hence, for un-nested annotation collections this will be identical to get_Annotations. Example : Returns : an array of L compliant objects Args : keys (list of strings) for annotations (optional) =cut sub get_all_Annotations{ my ($self,@keys) = @_; return map { $_->isa("Bio::AnnotationCollectionI") ? $_->get_all_Annotations() : $_; } $self->get_Annotations(@keys); } =head2 get_num_of_annotations Title : get_num_of_annotations Usage : my $count = $collection->get_num_of_annotations() Function: Returns the count of all annotations stored in this collection Returns : integer Args : none =cut sub get_num_of_annotations{ my ($self) = @_; my $count = 0; map { $count += scalar @$_ } values %{$self->{'_annotation'}}; return $count; } =head1 Implementation specific functions - mainly for adding =cut =head2 add_Annotation Title : add_Annotation Usage : $self->add_Annotation('reference',$object); $self->add_Annotation($object,'Bio::MyInterface::DiseaseI'); $self->add_Annotation($object); $self->add_Annotation('disease',$object,'Bio::MyInterface::DiseaseI'); Function: Adds an annotation for a specific key. If the key is omitted, the object to be added must provide a value via its tagname(). If the archetype is provided, this and future objects added under that tag have to comply with the archetype and will be rejected otherwise. Returns : none Args : annotation key ('disease', 'dblink', ...) object to store (must be Bio::AnnotationI compliant) [optional] object archetype to map future storage of object of these types to =cut sub add_Annotation{ my ($self,$key,$object,$archetype) = @_; # if there's no key we use the tagname() as key if(ref($key) && $key->isa("Bio::AnnotationI") && (!ref($object))) { $archetype = $object if defined($object); $object = $key; $key = $object->tagname(); $key = $key->name() if ref($key); # OntologyTermI $self->throw("Annotation object must have a tagname if key omitted") unless $key; } if( !defined $object ) { $self->throw("Must have at least key and object in add_Annotation"); } if( !ref $object ) { $self->throw("Must add an object. Use Bio::Annotation::{Comment,SimpleValue,OntologyTerm} for simple text additions"); } if( !$object->isa("Bio::AnnotationI") ) { $self->throw("object must be AnnotationI compliant, otherwise we won't add it!"); } # ok, now we are ready! If we don't have an archetype, set it # from the type of the object if( !defined $archetype ) { $archetype = ref $object; } # check typemap, storing if needed. my $stored_map = $self->_typemap->type_for_key($key); if( defined $stored_map ) { # check validity, irregardless of archetype. A little cheeky # this means isa stuff is executed correctly if( !$self->_typemap()->is_valid($key,$object) ) { $self->throw("Object $object was not valid with key $key. ". "If you were adding new keys in, perhaps you want to make use\n". "of the archetype method to allow registration to a more basic type"); } } else { $self->_typemap->_add_type_map($key,$archetype); } # we are ok to store if( !defined $self->{'_annotation'}->{$key} ) { $self->{'_annotation'}->{$key} = []; } push(@{$self->{'_annotation'}->{$key}},$object); return 1; } =head2 remove_Annotations Title : remove_Annotations Usage : Function: Remove the annotations for the specified key from this collection. Example : Returns : an array Bio::AnnotationI compliant objects which were stored under the given key(s) Args : the key(s) (tag name(s), one or more strings) for which to remove annotations (optional; if none given, flushes all annotations) =cut sub remove_Annotations{ my ($self, @keys) = @_; @keys = $self->get_all_annotation_keys() unless @keys; my @anns = $self->get_Annotations(@keys); # flush foreach my $key (@keys) { delete $self->{'_annotation'}->{$key}; delete $self->{'_typemap'}->{'_type'}->{$key}; } return @anns; } =head2 flatten_Annotations Title : flatten_Annotations Usage : Function: Flattens part or all of the annotations in this collection. This is a convenience method for getting the flattened annotation for the given keys, removing the annotation for those keys, and adding back the flattened array. This should not change anything for un-nested collections. Example : Returns : an array Bio::AnnotationI compliant objects which were stored under the given key(s) Args : list of keys (strings) the annotation for which to flatten, defaults to all keys if not given =cut sub flatten_Annotations{ my ($self,@keys) = @_; my @anns = $self->get_all_Annotations(@keys); my @origanns = $self->remove_Annotations(@keys); foreach (@anns) { $self->add_Annotation($_); } return @origanns; } =head1 Bio::AnnotationI methods implementations This is to allow nested annotation: you can use a collection as an annotation object for an annotation collection. =cut =head2 as_text Title : as_text Usage : Function: See L Example : Returns : a string Args : none =cut sub as_text{ my $self = shift; my $txt = "Collection consisting of "; my @texts = (); foreach my $ann ($self->get_Annotations()) { push(@texts, $ann->as_text()); } if(@texts) { $txt .= join(", ", map { '['.$_.']'; } @texts); } else { $txt .= "no elements"; } return $txt; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { # this just calls the default display_text output for # any AnnotationI my $DEFAULT_CB = sub { my $obj = shift; my $txt; foreach my $ann ($obj->get_Annotations()) { $txt .= $ann->display_text()."\n"; } return $txt; }; sub display_text { my ($self, $cb) = @_; $cb ||= $DEFAULT_CB; $self->throw("") if ref $cb ne 'CODE'; return $cb->($self); } } =head2 hash_tree Title : hash_tree Usage : Function: See L Example : Returns : a hash reference Args : none =cut sub hash_tree{ my $self = shift; my $tree = {}; foreach my $key ($self->get_all_annotation_keys()) { # all contained objects will support hash_tree() # (they are AnnotationIs) $tree->{$key} = [$self->get_Annotations($key)]; } return $tree; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my $self = shift; return $self->{'tagname'} = shift if @_; return $self->{'tagname'}; } =head1 Backward compatible functions Functions put in for backward compatibility with old Bio::Annotation.pm stuff =cut =head2 description Title : description Usage : Function: Example : Returns : Args : =cut sub description{ my ($self,$value) = @_; $self->deprecated("Using old style annotation call on new Annotation::Collection object"); if( defined $value ) { my $val = Bio::Annotation::SimpleValue->new(); $val->value($value); $self->add_Annotation('description',$val); } my ($desc) = $self->get_Annotations('description'); # If no description tag exists, do not attempt to call value on undef: return $desc ? $desc->value : undef; } =head2 add_gene_name Title : add_gene_name Usage : Function: Example : Returns : Args : =cut sub add_gene_name{ my ($self,$value) = @_; $self->deprecated("Old style add_gene_name called on new style Annotation::Collection"); my $val = Bio::Annotation::SimpleValue->new(); $val->value($value); $self->add_Annotation('gene_name',$val); } =head2 each_gene_name Title : each_gene_name Usage : Function: Example : Returns : Args : =cut sub each_gene_name{ my ($self) = @_; $self->deprecated("Old style each_gene_name called on new style Annotation::Collection"); my @out; my @gene = $self->get_Annotations('gene_name'); foreach my $g ( @gene ) { push(@out,$g->value); } return @out; } =head2 add_Reference Title : add_Reference Usage : Function: Example : Returns : Args : =cut sub add_Reference{ my ($self, @values) = @_; $self->deprecated("add_Reference (old style Annotation) on new style Annotation::Collection"); # Allow multiple (or no) references to be passed, as per old method foreach my $value (@values) { $self->add_Annotation('reference',$value); } } =head2 each_Reference Title : each_Reference Usage : Function: Example : Returns : Args : =cut sub each_Reference{ my ($self) = @_; $self->deprecated("each_Reference (old style Annotation) on new style Annotation::Collection"); return $self->get_Annotations('reference'); } =head2 add_Comment Title : add_Comment Usage : Function: Example : Returns : Args : =cut sub add_Comment{ my ($self,$value) = @_; $self->deprecated("add_Comment (old style Annotation) on new style Annotation::Collection"); $self->add_Annotation('comment',$value); } =head2 each_Comment Title : each_Comment Usage : Function: Example : Returns : Args : =cut sub each_Comment{ my ($self) = @_; $self->deprecated("each_Comment (old style Annotation) on new style Annotation::Collection"); return $self->get_Annotations('comment'); } =head2 add_DBLink Title : add_DBLink Usage : Function: Example : Returns : Args : =cut sub add_DBLink{ my ($self,$value) = @_; $self->deprecated("add_DBLink (old style Annotation) on new style Annotation::Collection"); $self->add_Annotation('dblink',$value); } =head2 each_DBLink Title : each_DBLink Usage : Function: Example : Returns : Args : =cut sub each_DBLink{ my ($self) = @_; $self->deprecated("each_DBLink (old style Annotation) on new style Annotation::Collection - use get_Annotations('dblink')"); return $self->get_Annotations('dblink'); } =head1 Implementation management functions =cut =head2 _typemap Title : _typemap Usage : $obj->_typemap($newval) Function: Example : Returns : value of _typemap Args : newvalue (optional) =cut sub _typemap{ my ($self,$value) = @_; if( defined $value) { $self->{'_typemap'} = $value; } return $self->{'_typemap'}; } 1; BioPerl-1.6.923/Bio/Annotation/Comment.pm000444000765000024 1101112254227333 20234 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::Comment # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::Comment - A comment object, holding text =head1 SYNOPSIS $comment = Bio::Annotation::Comment->new(); $comment->text("This is the text of this comment"); $annotation->add_Annotation('comment', $comment); =head1 DESCRIPTION A holder for comments in annotations, just plain text. This is a very simple object, and justifiably so. =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::Comment; use strict; use base qw(Bio::Root::Root Bio::AnnotationI); =head2 new Title : new Usage : $comment = Bio::Annotation::Comment->new( '-text' => 'some text for this comment'); Function: This returns a new comment object, optionally with text filed Example : Returns : a Bio::Annotation::Comment object Args : a hash with -text optionally set =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($text,$tag, $type) = $self->_rearrange([qw(TEXT TAGNAME TYPE)], @args); defined $text && $self->text($text); defined $tag && $self->tagname($tag); defined $type && $self->type($type); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : Function: Example : Returns : Args : =cut sub as_text{ my ($self) = @_; return "Comment: ".$self->text; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub {$_[0]->text || ''}; 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); } } =head2 hash_tree Title : hash_tree Usage : Function: Example : Returns : Args : =cut sub hash_tree{ my $self = shift; my $h = {}; $h->{'text'} = $self->text; return $h; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my ($self,$value) = @_; if( defined $value) { $self->{'tagname'} = $value; } return $self->{'tagname'}; } =head1 Specific accessors for Comments =cut =head2 text Title : text Usage : $value = $self->text($newval) Function: get/set for the text field. A comment object just holds a single string which is accessible through this method Example : Returns : value of text Args : newvalue (optional) =cut sub text{ my ($self,$value) = @_; if( defined $value) { $self->{'text'} = $value; } return $self->{'text'}; } =head2 value Title : value Usage : $value = $self->value($newval) Function: Alias of the 'text' method Example : Returns : value of text Args : newvalue (optional) =cut *value = \&text; =head2 type Title : type Usage : $value = $self->type($newval) Function: get/set for the comment type field. The comment type is normally found as a subfield within comment sections in some files, such as SwissProt Example : Returns : value of text Args : newvalue (optional) =cut sub type { my ($self,$type) = @_; if( defined $type) { $self->{'type'} = $type; } return $self->{'type'}; } 1; BioPerl-1.6.923/Bio/Annotation/DBLink.pm000444000765000024 2456012254227340 17750 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::DBLink # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::DBLink - untyped links between databases =head1 SYNOPSIS $link1 = Bio::Annotation::DBLink->new(-database => 'TSC', -primary_id => 'TSC0000030' ); #or $link2 = Bio::Annotation::DBLink->new(); $link2->database('dbSNP'); $link2->primary_id('2367'); # DBLink is-a Bio::AnnotationI object, can be added to annotation # collections, e.g. the one on features or seqs $feat->annotation->add_Annotation('dblink', $link2); =head1 DESCRIPTION Provides an object which represents a link from one object to something in another database without prescribing what is in the other database. Aside from L, this class also implements L. =head1 AUTHOR - Ewan Birney Ewan Birney - birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::DBLink; use strict; use base qw(Bio::Root::Root Bio::AnnotationI Bio::IdentifiableI); =head2 new Title : new Usage : $dblink = Bio::Annotation::DBLink->new(-database =>"GenBank", -primary_id => "M123456"); Function: Creates a new instance of this class. Example : Returns : A new instance of Bio::Annotation::DBLink. Args : Named parameters. At present, the following parameters are recognized. -database the name of the database referenced by the xref -primary_id the primary (main) id of the referenced entry (usually this will be an accession number) -optional_id a secondary ID under which the referenced entry is known in the same database -comment comment text for the dbxref -tagname the name of the tag under which to add this instance to an annotation bundle (usually 'dblink') -type the type of information in the referenced entry (e.g. protein, mRNA, structure) -namespace synonymous with -database (also overrides) -version version of the referenced entry -authority attribute of the Bio::IdentifiableI interface -url attribute of the Bio::IdentifiableI interface =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($database,$primary_id,$optional_id,$comment,$tag,$type,$ns,$auth,$v,$url) = $self->_rearrange([qw(DATABASE PRIMARY_ID OPTIONAL_ID COMMENT TAGNAME TYPE NAMESPACE AUTHORITY VERSION URL )], @args); $database && $self->database($database); $primary_id && $self->primary_id($primary_id); $optional_id && $self->optional_id($optional_id); $comment && $self->comment($comment); $tag && $self->tagname($tag); $type && $self->type($type); # Bio::IdentifiableI parameters: $ns && $self->namespace($ns); # this will override $database $auth && $self->authority($auth); defined($v) && $self->version($v); defined($url) && $self->url($url); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : Function: Example : Returns : Args : =cut sub as_text{ my ($self) = @_; return "Direct database link to ".$self->primary_id .($self->version ? ".".$self->version : "") .($self->optional_id ? " (".$self->optional_id.")" : "") ." in database ".$self->database; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub { (($_[0]->database ? $_[0]->database . ':' : '' ) . ($_[0]->primary_id ? $_[0]->primary_id : '') . ($_[0]->version ? '.' . $_[0]->version : '')) || '' }; 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); } } =head2 hash_tree Title : hash_tree Usage : Function: Example : Returns : Args : =cut sub hash_tree{ my ($self) = @_; my $h = {}; $h->{'database'} = $self->database; $h->{'primary_id'} = $self->primary_id; if( defined $self->optional_id ) { $h->{'optional_id'} = $self->optional_id; } if( defined $self->comment ) { # we know that comments have hash_tree methods $h->{'comment'} = $self->comment; } return $h; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my $self = shift; return $self->{'tagname'} = shift if @_; return $self->{'tagname'}; } =head1 Specific accessors for DBLinks =cut =head2 database Title : database Usage : $self->database($newval) Function: set/get on the database string. Databases are just a string here which can then be interpreted elsewhere Example : Returns : value of database Args : newvalue (optional) =cut sub database{ my $self = shift; return $self->{'database'} = shift if @_; return $self->{'database'}; } =head2 primary_id Title : primary_id Usage : $self->primary_id($newval) Function: set/get on the primary id (a string) The primary id is the main identifier used for this object in the database. Good examples would be accession numbers. The id is meant to be the main, stable identifier for this object Example : Returns : value of primary_id Args : newvalue (optional) =cut sub primary_id{ my $self = shift; return $self->{'primary_id'} = shift if @_; return $self->{'primary_id'}; } =head2 optional_id Title : optional_id Usage : $self->optional_id($newval) Function: get/set for the optional_id (a string) optional id is a slot for people to use as they wish. The main issue is that some databases do not have a clean single string identifier scheme. It is hoped that the primary_id can behave like a reasonably sane "single string identifier" of objects, and people can use/abuse optional ids to their heart's content to provide precise mappings. Example : Returns : value of optional_id Args : newvalue (optional) =cut #' sub optional_id{ my $self = shift; return $self->{'optional_id'} = shift if @_; return $self->{'optional_id'}; } =head2 comment Title : comment Usage : $self->comment($newval) Function: get/set of comments (comment object) Sets or gets comments of this dblink, which is sometimes relevant Example : Returns : value of comment (Bio::Annotation::Comment) Args : newvalue (optional) =cut sub comment{ my $self = shift; return $self->{'comment'} = shift if @_; return $self->{'comment'}; } =head2 type Title : type Usage : $self->type($newval) Function: get/set of type Sets or gets the type of this dblink. Example : $self->type('protein') Returns : value of type Args : newvalue (optional) =cut sub type { my $self = shift; return $self->{'type'} = shift if @_; return $self->{'type'}; } =head1 Methods for Bio::IdentifiableI compliance =head2 object_id Title : object_id Usage : $string = $obj->object_id() Function: a string which represents the stable primary identifier in this namespace of this object. For DNA sequences this is its accession_number, similarly for protein sequences This is aliased to primary_id(). Returns : A scalar =cut sub object_id { return shift->primary_id(@_); } =head2 version Title : version Usage : $version = $obj->version() Function: a number which differentiates between versions of the same object. Higher numbers are considered to be later and more relevant, but a single object described the same identifier should represent the same concept Returns : A number =cut sub version{ my $self = shift; return $self->{'version'} = shift if @_; return $self->{'version'}; } =head2 url Title : url Usage : $url = $obj->url() Function: URL which is associated with this DB link Returns : string, full URL descriptor =cut sub url { my $self = shift; return $self->{'url'} = shift if @_; return $self->{'url'}; } =head2 authority Title : authority Usage : $authority = $obj->authority() Function: a string which represents the organisation which granted the namespace, written as the DNS name for organisation (eg, wormbase.org) Returns : A scalar =cut sub authority{ my $self = shift; return $self->{'authority'} = shift if @_; return $self->{'authority'}; } =head2 namespace Title : namespace Usage : $string = $obj->namespace() Function: A string representing the name space this identifier is valid in, often the database name or the name describing the collection For DBLink this is the same as database(). Returns : A scalar =cut sub namespace{ return shift->database(@_); } 1; BioPerl-1.6.923/Bio/Annotation/OntologyTerm.pm000444000765000024 3444712254227315 21316 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::OntologyTerm # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Annotation::OntologyTerm - An ontology term adapted to AnnotationI =head1 SYNOPSIS use Bio::Annotation::OntologyTerm; use Bio::Annotation::Collection; use Bio::Ontology::Term; my $coll = Bio::Annotation::Collection->new(); # this also implements a tag/value pair, where tag _and_ value are treated # as ontology terms my $annterm = Bio::Annotation::OntologyTerm->new(-label => 'ABC1', -tagname => 'Gene Name'); # ontology terms can be added directly - they implicitly have a tag $coll->add_Annotation($annterm); # implementation is by composition - you can get/set the term object # e.g. my $term = $annterm->term(); # term is-a Bio::Ontology::TermI print "ontology term ",$term->name()," (ID ",$term->identifier(), "), ontology ",$term->ontology()->name(),"\n"; $term = Bio::Ontology::Term->new(-name => 'ABC2', -ontology => 'Gene Name'); $annterm->term($term); =head1 DESCRIPTION Ontology term annotation object =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::OntologyTerm; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Ontology::Term; use base qw(Bio::Root::Root Bio::AnnotationI Bio::Ontology::TermI); =head2 new Title : new Usage : my $sv = Bio::Annotation::OntologyTerm->new(); Function: Instantiate a new OntologyTerm object Returns : Bio::Annotation::OntologyTerm object Args : -term => $term to initialize the term data field [optional] Most named arguments that Bio::Ontology::Term accepts will work here too. -label is a synonym for -name, -tagname is a synonym for -ontology. =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($term,$name,$label,$identifier,$definition,$ont,$tag) = $self->_rearrange([qw(TERM NAME LABEL IDENTIFIER DEFINITION ONTOLOGY TAGNAME)], @args); if($term) { $self->term($term); } else { $self->name($name || $label) if $name || $label; $self->identifier($identifier) if $identifier; $self->definition($definition) if $definition; } $self->ontology($ont || $tag) if $ont || $tag; return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : my $text = $obj->as_text Function: Returns a textual representation of the annotation that this object holds. Presently, it is tag name, name of the term, and the is_obsolete attribute concatenated togather with a delimiter (|). Returns : string Args : none =cut sub as_text{ my ($self) = @_; return $self->tagname()."|".$self->name()."|".($self->is_obsolete()||''); } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub { $_[0]->identifier || ''}; 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); } } =head2 hash_tree Title : hash_tree Usage : my $hashtree = $value->hash_tree Function: For supporting the AnnotationI interface just returns the value as a hashref with the key 'value' pointing to the value Returns : hashrf Args : none =cut sub hash_tree{ my ($self) = @_; my $h = {}; $h->{'name'} = $self->name(); $h->{'identifier'} = $self->identifier(); $h->{'definition'} = $self->definition(); $h->{'synonyms'} = [$self->get_synonyms()]; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to AnnotationCollection when adding this object. This is aliased to ontology() here. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my $self = shift; return $self->ontology(@_) if @_; # if in get mode we need to get the name from the ontology my $ont = $self->ontology(); return ref($ont) ? $ont->name() : $ont; } =head1 Methods for Bio::Ontology::TermI compliance =cut =head2 term Title : term Usage : $obj->term($newval) Function: Get/set the Bio::Ontology::TermI implementing object. We implement TermI by composition, and this method sets/gets the object we delegate to. Example : Returns : value of term (a Bio::Ontology::TermI compliant object) Args : new value (a Bio::Ontology::TermI compliant object, optional) =cut sub term{ my ($self,$value) = @_; if( defined $value) { $self->{'term'} = $value; } if(! exists($self->{'term'})) { $self->{'term'} = Bio::Ontology::Term->new(); } return $self->{'term'}; } =head2 identifier Title : identifier Usage : $term->identifier( "0003947" ); or print $term->identifier(); Function: Set/get for the identifier of this Term. Returns : The identifier [scalar]. Args : The identifier [scalar] (optional). =cut sub identifier { return shift->term()->identifier(@_); } # identifier =head2 name Title : name Usage : $term->name( "N-acetylgalactosaminyltransferase" ); or print $term->name(); Function: Set/get for the name of this Term. Returns : The name [scalar]. Args : The name [scalar] (optional). =cut sub name { return shift->term()->name(@_); } # name =head2 definition Title : definition Usage : $term->definition( "Catalysis of ..." ); or print $term->definition(); Function: Set/get for the definition of this Term. Returns : The definition [scalar]. Args : The definition [scalar] (optional). =cut sub definition { return shift->term()->definition(@_); } # definition =head2 ontology Title : ontology Usage : $term->ontology( $top ); or $top = $term->ontology(); Function: Set/get for a relationship between this Term and another Term (e.g. the top level of the ontology). Returns : The ontology of this Term [TermI]. Args : The ontology of this Term [TermI or scalar -- which becomes the name of the catagory term] (optional). =cut sub ontology { return shift->term()->ontology(@_); } =head2 is_obsolete Title : is_obsolete Usage : $term->is_obsolete( 1 ); or if ( $term->is_obsolete() ) Function: Set/get for the obsoleteness of this Term. Returns : the obsoleteness [0 or 1]. Args : the obsoleteness [0 or 1] (optional). =cut sub is_obsolete { return shift->term()->is_obsolete(@_); } # is_obsolete =head2 comment Title : comment Usage : $term->comment( "Consider the term ..." ); or print $term->comment(); Function: Set/get for an arbitrary comment about this Term. Returns : A comment. Args : A comment (optional). =cut sub comment { return shift->term()->comment(@_); } # comment =head2 get_synonyms Title : get_synonyms() Usage : @aliases = $term->get_synonyms(); Function: Returns a list of aliases of this Term. Returns : A list of aliases [array of [scalar]]. Args : =cut sub get_synonyms { return shift->term()->get_synonyms(@_); } # get_synonyms =head2 add_synonym Title : add_synonym Usage : $term->add_synonym( @asynonyms ); or $term->add_synonym( $synonym ); Function: Pushes one or more synonyms into the list of synonyms. Returns : Args : One synonym [scalar] or a list of synonyms [array of [scalar]]. =cut sub add_synonym { return shift->term()->add_synonym(@_); } # add_synonym =head2 remove_synonyms Title : remove_synonyms() Usage : $term->remove_synonyms(); Function: Deletes (and returns) the synonyms of this Term. Returns : A list of synonyms [array of [scalar]]. Args : =cut sub remove_synonyms { return shift->term()->remove_synonyms(@_); } # remove_synonyms =head2 get_dblinks Title : get_dblinks() Usage : @ds = $term->get_dblinks(); Function: Returns a list of each dblinks of this GO term. Returns : A list of dblinks [array of [scalars]]. Args : Note : this is deprecated in favor of get_dbxrefs(), which works with strings or L instances =cut sub get_dblinks { my $self = shift; $self->deprecated('get_dblinks() is deprecated; use get_dbxrefs()'); return $self->term->get_dbxrefs(@_); } # get_dblinks =head2 get_dbxrefs Title : get_dbxrefs() Usage : @ds = $term->get_dbxrefs(); Function: Returns a list of each dblinks of this GO term. Returns : A list of dblinks [array of [scalars] or Bio::Annotation::DBLink instances]. Args : =cut sub get_dbxrefs { return shift->term->get_dbxrefs(@_); } # get_dblinks =head2 add_dblink Title : add_dblink Usage : $term->add_dblink( @dbls ); or $term->add_dblink( $dbl ); Function: Pushes one or more dblinks into the list of dblinks. Returns : Args : One dblink [scalar] or a list of dblinks [array of [scalars]]. Note : this is deprecated in favor of add_dbxref(), which works with strings or L instances =cut sub add_dblink { my $self = shift; $self->deprecated('add_dblink() is deprecated; use add_dbxref()'); return $self->term->add_dbxref(@_); } # add_dblink =head2 add_dbxref Title : add_dbxref Usage : $term->add_dbxref( @dbls ); or $term->add_dbxref( $dbl ); Function: Pushes one or more dblinks into the list of dblinks. Returns : Args : =cut sub add_dbxref { return shift->term->add_dbxref(@_); } =head2 remove_dblinks Title : remove_dblinks() Usage : $term->remove_dblinks(); Function: Deletes (and returns) the definition references of this GO term. Returns : A list of definition references [array of [scalars]]. Args : Note : this is deprecated in favor of remove_dbxrefs(), which works with strings or L instances =cut sub remove_dblinks { my $self = shift; $self->deprecated('remove_dblinks() is deprecated; use remove_dbxrefs()'); return $self->term->remove_dbxrefs(@_); } # remove_dblinks =head2 remove_dbxrefs Title : remove_dbxrefs() Usage : $term->remove_dbxrefs(); Function: Deletes (and returns) the definition references of this GO term. Returns : A list of definition references [array of [scalars]]. Args : =cut sub remove_dbxrefs { return shift->term->remove_dbxrefs(@_); } =head2 get_secondary_ids Title : get_secondary_ids Usage : @ids = $term->get_secondary_ids(); Function: Returns a list of secondary identifiers of this Term. Secondary identifiers mostly originate from merging terms, or possibly also from splitting terms. Returns : A list of secondary identifiers [array of [scalar]] Args : =cut sub get_secondary_ids { return shift->term->get_secondary_ids(@_); } # get_secondary_ids =head2 add_secondary_id Title : add_secondary_id Usage : $term->add_secondary_id( @ids ); or $term->add_secondary_id( $id ); Function: Adds one or more secondary identifiers to this term. Returns : Args : One or more secondary identifiers [scalars] =cut sub add_secondary_id { return shift->term->add_secondary_id(@_); } # add_secondary_id =head2 remove_secondary_ids Title : remove_secondary_ids Usage : $term->remove_secondary_ids(); Function: Deletes (and returns) the secondary identifiers of this Term. Returns : The previous list of secondary identifiers [array of [scalars]] Args : =cut sub remove_secondary_ids { return shift->term->remove_secondary_ids(@_); } # remove_secondary_ids 1; BioPerl-1.6.923/Bio/Annotation/Reference.pm000444000765000024 3074112254227323 20542 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::Reference # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::Reference - Specialised DBLink object for Literature References =head1 SYNOPSIS $reg = Bio::Annotation::Reference->new( -title => 'title line', -location => 'location line', -authors => 'author line', -medline => 998122 ); =head1 DESCRIPTION Object which presents a literature reference. This is considered to be a specialised form of database link. The additional methods provided are all set/get methods to store strings commonly associated with references, in particular title, location (ie, journal page) and authors line. There is no attempt to do anything more than store these things as strings for processing elsewhere. This is mainly because parsing these things suck and generally are specific to the specific format one is using. To provide an easy route to go format --E object --E format without losing data, we keep them as strings. Feel free to post the list for a better solution, but in general this gets very messy very fast... =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::Reference; use strict; use base qw(Bio::Annotation::DBLink); =head2 new Title : new Usage : $ref = Bio::Annotation::Reference->new( -title => 'title line', -authors => 'author line', -location => 'location line', -medline => 9988812); Function: Example : Returns : a new Bio::Annotation::Reference object Args : a hash with optional title, authors, location, medline, pubmed, start, end, consortium, rp and rg attributes =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($start,$end,$authors,$consortium,$location,$title,$medline, $pubmed,$rp,$rg,$doi) = $self->_rearrange([qw(START END AUTHORS CONSORTIUM LOCATION TITLE MEDLINE PUBMED RP RG DOI )],@args); defined $start && $self->start($start); defined $end && $self->end($end); defined $authors && $self->authors($authors); defined $consortium && $self->consortium($consortium); defined $location && $self->location($location); defined $title && $self->title($title); defined $medline && $self->medline($medline); defined $pubmed && $self->pubmed($pubmed); defined $rp && $self->rp($rp); defined $rg && $self->rg($rg); defined $doi && $self->doi($doi); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : Function: Example : Returns : Args : =cut sub as_text{ my ($self) = @_; # this could get out of hand! return "Reference: ".$self->title; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub { $_[0]->title || ''}; 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); } } =head2 hash_tree Title : hash_tree Usage : Function: Example : Returns : Args : =cut sub hash_tree{ my ($self) = @_; my $h = {}; $h->{'title'} = $self->title; $h->{'authors'} = $self->authors; $h->{'location'} = $self->location; if (defined $self->start) { $h->{'start'} = $self->start; } if (defined $self->end) { $h->{'end'} = $self->end; } $h->{'medline'} = $self->medline; if (defined $self->pubmed) { $h->{'pubmed'} = $self->pubmed; } return $h; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut =head1 Specific accessors for References =cut =head2 start Title : start Usage : $self->start($newval) Function: Gives the reference start base Example : Returns : value of start Args : newvalue (optional) =cut sub start { my ($self,$value) = @_; if( defined $value) { $self->{'start'} = $value; } return $self->{'start'}; } =head2 end Title : end Usage : $self->end($newval) Function: Gives the reference end base Example : Returns : value of end Args : newvalue (optional) =cut sub end { my ($self,$value) = @_; if( defined $value) { $self->{'end'} = $value; } return $self->{'end'}; } =head2 rp Title : rp Usage : $self->rp($newval) Function: Gives the RP line. No attempt is made to parse this line. Example : Returns : value of rp Args : newvalue (optional) =cut sub rp{ my ($self,$value) = @_; if( defined $value) { $self->{'rp'} = $value; } return $self->{'rp'}; } =head2 rg Title : rg Usage : $obj->rg($newval) Function: Gives the RG line. This is Swissprot/Uniprot specific, and if set will usually be identical to the authors attribute, but the swissprot manual does allow both RG and RA (author) to be present for the same reference. Example : Returns : value of rg (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub rg{ my $self = shift; return $self->{'rg'} = shift if @_; return $self->{'rg'}; } =head2 authors Title : authors Usage : $self->authors($newval) Function: Gives the author line. No attempt is made to parse the author line Example : Returns : value of authors Args : newvalue (optional) =cut sub authors{ my ($self,$value) = @_; if( defined $value) { $self->{'authors'} = $value; } return $self->{'authors'}; } =head2 location Title : location Usage : $self->location($newval) Function: Gives the location line. No attempt is made to parse the location line Example : Returns : value of location Args : newvalue (optional) =cut sub location{ my ($self,$value) = @_; if( defined $value) { $self->{'location'} = $value; } return $self->{'location'}; } =head2 title Title : title Usage : $self->title($newval) Function: Gives the title line (if exists) Example : Returns : value of title Args : newvalue (optional) =cut sub title{ my ($self,$value) = @_; if( defined $value) { $self->{'title'} = $value; } return $self->{'title'}; } =head2 medline Title : medline Usage : $self->medline($newval) Function: Gives the medline number Example : Returns : value of medline Args : newvalue (optional) =cut sub medline{ my ($self,$value) = @_; if( defined $value) { $self->{'medline'} = $value; } return $self->{'medline'}; } =head2 pubmed Title : pubmed Usage : $refobj->pubmed($newval) Function: Get/Set the PubMed number, if it is different from the MedLine number. Example : Returns : value of medline Args : newvalue (optional) =cut sub pubmed { my ($self,$value) = @_; if( defined $value) { $self->{'pubmed'} = $value; } return $self->{'pubmed'}; } =head2 database Title : database Usage : Function: Overrides DBLink database to be hard coded to 'MEDLINE' (or 'PUBMED' if only pubmed id has been supplied), unless the database has been set explicitly before. Example : Returns : Args : =cut sub database{ my ($self, @args) = @_; my $default = 'MEDLINE'; if (! defined $self->medline && defined $self->pubmed) { $default = 'PUBMED'; } return $self->SUPER::database(@args) || $default; } =head2 primary_id Title : primary_id Usage : Function: Overrides DBLink primary_id to provide medline number, or pubmed number if only that has been defined Example : Returns : Args : =cut sub primary_id{ my ($self, @args) = @_; if (@args) { $self->medline(@args); } if (! defined $self->medline && defined $self->pubmed) { return $self->pubmed; } return $self->medline; } =head2 optional_id Title : optional_id Usage : Function: Overrides DBLink optional_id to provide the PubMed number. Example : Returns : Args : =cut sub optional_id{ my ($self, @args) = @_; return $self->pubmed(@args); } =head2 publisher Title : publisher Usage : $self->publisher($newval) Function: Gives the publisher line. No attempt is made to parse the publisher line Example : Returns : value of publisher Args : newvalue (optional) =cut sub publisher { my ($self,$value) = @_; if( defined $value) { $self->{'publisher'} = $value; } return $self->{'publisher'}; } =head2 editors Title : editors Usage : $self->editors($newval) Function: Gives the editors line. No attempt is made to parse the editors line Example : Returns : value of editors Args : newvalue (optional) =cut sub editors { my ($self,$value) = @_; if( defined $value) { $self->{'editors'} = $value; } return $self->{'editors'}; } =head2 encoded_ref Title : encoded_ref Usage : $self->encoded_ref($newval) Function: Gives the encoded_ref line. No attempt is made to parse the encoded_ref line (this is added for reading PDB records (REFN record), where this contains ISBN/ISSN/ASTM code) Example : Returns : value of encoded_ref Args : newvalue (optional) =cut sub encoded_ref { my ($self,$value) = @_; if( defined $value) { $self->{'encoded_ref'} = $value; } return $self->{'encoded_ref'}; } =head2 doi Title : doi Usage : $self->doi($newval) Function: Gives the DOI (Digital Object Identifier) from the International DOI Foundation (http://www.doi.org/), which can be used to resolve URL links for the full-text documents using: http://dx.doi.org/ Example : Returns : value of doi Args : newvalue (optional) =cut sub doi { my ($self,$value) = @_; if( defined $value) { $self->{'doi'} = $value; } return $self->{'doi'}; } =head2 consortium Title : consortium Usage : $self->consortium($newval) Function: Gives the consortium line. No attempt is made to parse the consortium line Example : Returns : value of consortium Args : newvalue (optional) =cut sub consortium{ my ($self,$value) = @_; if( defined $value) { $self->{'consortium'} = $value; } return $self->{'consortium'}; } =head2 gb_reference Title : gb_reference Usage : $obj->gb_reference($newval) Function: Gives the generic GenBank REFERENCE line. This is GenBank-specific. If set, this includes everything on the reference line except the REFERENCE tag and the reference count. This is mainly a fallback for the few instances when REFERENCE lines have unusual additional information such as split sequence locations, feature references, etc. See Bug 2020 in Bugzilla for more information. Example : Returns : value of gb_reference (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub gb_reference{ my ($self,$value) = @_; if( defined $value) { $self->{'gb_reference'} = $value; } return $self->{'gb_reference'}; } 1; BioPerl-1.6.923/Bio/Annotation/Relation.pm000444000765000024 1675412254227330 20427 0ustar00cjfieldsstaff000000000000# $Id: Relation.pm 14708 2008-06-10 00:08:17Z heikki $ # # BioPerl module for Bio::Annotation::Relation # # Please direct questions and support issues to # # Cared for by bioperl # # Copyright bioperl # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::Relation - Relationship (pairwise) with other objects SeqI and NodeI; =head1 SYNOPSIS use Bio::Annotation::Relation; use Bio::Annotation::Collection; my $col = Bio::Annotation::Collection->new(); my $sv = Bio::Annotation::Relation->new(-type => "paralogy" -to => "someSeqI"); $col->add_Annotation('tagname', $sv); =head1 DESCRIPTION Scalar value annotation object =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mira Han Email mirhan@indiana.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::Relation; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::AnnotationI); =head2 new Title : new Usage : my $sv = Bio::Annotation::Relation->new(); Function: Instantiate a new Relation object Returns : Bio::Annotation::Relation object Args : -type => $type of relation [optional] -to => $obj which $self is in relation to [optional] -tagname => $tag to initialize the tagname [optional] -tag_term => ontology term representation of the tag [optional] =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type, $to, $tag, $term) = $self->_rearrange([qw(TYPE TO TAGNAME TAG_TERM)], @args); # set the term first defined $term && $self->tag_term($term); defined $type && $self->type($type); defined $to && $self->to($to); defined $tag && $self->tagname($tag); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : my $text = $obj->as_text Function: return the string "Value: $v" where $v is the value Returns : string Args : none =cut sub as_text{ my ($self) = @_; return $self->type." to ".$self->to->id; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub { return $_[0]->type." to ".$_[0]->to->id }; #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); } } =head2 hash_tree Title : hash_tree Usage : my $hashtree = $value->hash_tree Function: For supporting the AnnotationI interface just returns the value as a hashref with the key 'value' pointing to the value Returns : hashrf Args : none =cut sub hash_tree{ my $self = shift; my $h = {}; $h->{'type'} = $self->type; $h->{'to'} = $self->to; return $h; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to AnnotationCollection when adding this object. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my $self = shift; # check for presence of an ontology term if($self->{'_tag_term'}) { # keep a copy in case the term is removed later $self->{'tagname'} = $_[0] if @_; # delegate to the ontology term object return $self->tag_term->name(@_); } return $self->{'tagname'} = shift if @_; return $self->{'tagname'}; } =head1 Specific accessors for Relation =cut =head2 type Title : type Usage : $obj->type($newval) Function: Get/Set the type Returns : type of relation Args : newtype (optional) =cut sub type{ my ($self,$type) = @_; if( defined $type) { $self->{'type'} = $type; } return $self->{'type'}; } =head2 to Title : to Usage : $obj->to($newval) Function: Get/Set the object which $self is in relation to Returns : the object which the relation applies to Args : new target object (optional) =cut sub to{ my ($self,$to) = @_; if( defined $to) { $self->{'to'} = $to; } return $self->{'to'}; } =head2 confidence Title : confidence Usage : $self->confidence($newval) Function: Gives the confidence value. Example : Returns : value of confidence Args : newvalue (optional) =cut sub confidence{ my ($self,$value) = @_; if( defined $value) { $self->{'confidence'} = $value; } return $self->{'confidence'}; } =head2 confidence_type Title : confidence_type Usage : $self->confidence_type($newtype) Function: Gives the confidence type. Example : Returns : type of confidence Args : newtype (optional) =cut sub confidence_type{ my ($self,$type) = @_; if( defined $type) { $self->{'confidence_type'} = $type; } return $self->{'confidence_type'}; } =head2 tag_term Title : tag_term Usage : $obj->tag_term($newval) Function: Get/set the L object representing the tag name. This is so you can specifically relate the tag of this annotation to an entry in an ontology. You may want to do this to associate an identifier with the tag, or a particular category, such that you can better match the tag against a controlled vocabulary. This accessor will return undef if it has never been set before in order to allow this annotation to stay light-weight if an ontology term representation of the tag is not needed. Once it is set to a valid value, tagname() will actually delegate to the name() of this term. Example : Returns : a L compliant object, or undef Args : on set, new value (a L compliant object or undef, optional) =cut sub tag_term{ my $self = shift; return $self->{'_tag_term'} = shift if @_; return $self->{'_tag_term'}; } 1; BioPerl-1.6.923/Bio/Annotation/SimpleValue.pm000444000765000024 1435712254227317 21102 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::SimpleValue # # Please direct questions and support issues to # # Cared for by bioperl # # Copyright bioperl # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::SimpleValue - A simple scalar =head1 SYNOPSIS use Bio::Annotation::SimpleValue; use Bio::Annotation::Collection; my $col = Bio::Annotation::Collection->new(); my $sv = Bio::Annotation::SimpleValue->new(-value => 'someval'); $col->add_Annotation('tagname', $sv); =head1 DESCRIPTION Scalar value annotation object =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::SimpleValue; use strict; # Object preamble - inherits from Bio::Root::Root #use Bio::Ontology::TermI; use base qw(Bio::Root::Root Bio::AnnotationI); =head2 new Title : new Usage : my $sv = Bio::Annotation::SimpleValue->new(); Function: Instantiate a new SimpleValue object Returns : Bio::Annotation::SimpleValue object Args : -value => $value to initialize the object data field [optional] -tagname => $tag to initialize the tagname [optional] -tag_term => ontology term representation of the tag [optional] =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($value,$tag,$term) = $self->_rearrange([qw(VALUE TAGNAME TAG_TERM)], @args); # set the term first defined $term && $self->tag_term($term); defined $value && $self->value($value); defined $tag && $self->tagname($tag); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : my $text = $obj->as_text Function: return the string "Value: $v" where $v is the value Returns : string Args : none =cut sub as_text{ my ($self) = @_; return "Value: ".$self->value; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { 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); } } =head2 hash_tree Title : hash_tree Usage : my $hashtree = $value->hash_tree Function: For supporting the AnnotationI interface just returns the value as a hashref with the key 'value' pointing to the value Returns : hashrf Args : none =cut sub hash_tree{ my $self = shift; my $h = {}; $h->{'value'} = $self->value; return $h; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to AnnotationCollection when adding this object. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my $self = shift; # check for presence of an ontology term if($self->{'_tag_term'}) { # keep a copy in case the term is removed later $self->{'tagname'} = $_[0] if @_; # delegate to the ontology term object return $self->tag_term->name(@_); } return $self->{'tagname'} = shift if @_; return $self->{'tagname'}; } =head1 Specific accessors for SimpleValue =cut =head2 value Title : value Usage : $obj->value($newval) Function: Get/Set the value for simplevalue Returns : value of value Args : newvalue (optional) =cut sub value{ my ($self,$value) = @_; if( defined $value) { $self->{'value'} = $value; } return $self->{'value'}; } =head2 tag_term Title : tag_term Usage : $obj->tag_term($newval) Function: Get/set the L object representing the tag name. This is so you can specifically relate the tag of this annotation to an entry in an ontology. You may want to do this to associate an identifier with the tag, or a particular category, such that you can better match the tag against a controlled vocabulary. This accessor will return undef if it has never been set before in order to allow this annotation to stay light-weight if an ontology term representation of the tag is not needed. Once it is set to a valid value, tagname() will actually delegate to the name() of this term. Example : Returns : a L compliant object, or undef Args : on set, new value (a L compliant object or undef, optional) =cut sub tag_term{ my $self = shift; return $self->{'_tag_term'} = shift if @_; return $self->{'_tag_term'}; } 1; BioPerl-1.6.923/Bio/Annotation/StructuredValue.pm000444000765000024 2340312254227312 22000 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::StructuredValue # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Annotation::StructuredValue - A scalar with embedded structured information =head1 SYNOPSIS use Bio::Annotation::StructuredValue; use Bio::Annotation::Collection; my $col = Bio::Annotation::Collection->new(); my $sv = Bio::Annotation::StructuredValue->new(-value => 'someval'); $col->add_Annotation('tagname', $sv); =head1 DESCRIPTION Scalar value annotation object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp-at-gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::StructuredValue; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Annotation::SimpleValue); =head2 new Title : new Usage : my $sv = Bio::Annotation::StructuredValue->new(); Function: Instantiate a new StructuredValue object Returns : Bio::Annotation::StructuredValue object Args : -value => $value to initialize the object data field [optional] -tagname => $tag to initialize the tagname [optional] =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($value,$tag) = $self->_rearrange([qw(VALUE TAGNAME)], @args); $self->{'values'} = []; defined $value && $self->value($value); defined $tag && $self->tagname($tag); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : my $text = $obj->as_text Function: return the string "Value: $v" where $v is the value Returns : string Args : none =cut sub as_text{ my ($self) = @_; return "Value: ".$self->value; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { 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); } } =head2 hash_tree Title : hash_tree Usage : my $hashtree = $value->hash_tree Function: For supporting the AnnotationI interface just returns the value as a hashref with the key 'value' pointing to the value Returns : hashrf Args : none =cut sub hash_tree{ my ($self) = @_; my $h = {}; $h->{'value'} = $self->value; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to AnnotationCollection when adding this object. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my ($self,$value) = @_; if( defined $value) { $self->{'tagname'} = $value; } return $self->{'tagname'}; } =head1 Specific accessors for StructuredValue =cut =head2 value Title : value Usage : $obj->value($newval) Function: Get/set the value for this annotation. Set mode is here only to retain compatibility with SimpleValue. It is equivalent to calling add_value([0], $newval). In get mode, this implementation allows one to pass additional parameters that control how the structured annotation components will be joined together to form a string. Recognized are presently -joins a reference to an array of join strings, the elements at index i applying to joining annotations at dimension i. The last element will be re-used for dimensions higher than i. Defaults to ['; ']. -brackets a reference to an array of two strings denoting the opening and closing brackets for the elements of one dimension, if there is more than one element in the dimension. Defaults to ['(',')']. Returns : value of value Args : newvalue (optional) =cut sub value{ my ($self,$value,@args) = @_; # set mode? return $self->add_value([0], $value) if defined($value) && (@args == 0); # no, get mode # determine joins and brackets unshift(@args, $value); my ($joins, $brackets) = $self->_rearrange([qw(JOINS BRACKETS)], @args); $joins = ['; '] unless $joins; $brackets = ['(', ')'] unless $brackets; my $txt = &_to_text($self->{'values'}, $joins, $brackets); # if there's only brackets at the start and end, remove them if((@{$self->{'values'}} == 1) && (length($brackets->[0]) == 1) && (length($brackets->[1]) == 1)) { my $re = '\\'.$brackets->[0]. '([^\\'.$brackets->[1].']*)\\'.$brackets->[1]; $txt =~ s/^$re$/$1/; } return $txt; } sub _to_text{ my ($arr, $joins, $brackets, $rec_n) = @_; $rec_n = 0 unless defined($rec_n); my $i = $rec_n >= @$joins ? @$joins-1 : $rec_n; my $txt = join($joins->[$i], map { ref($_) ? (ref($_) eq "ARRAY" ? &_to_text($_, $joins, $brackets, $rec_n+1) : $_->value()) : $_; } @$arr); if($rec_n && (@$arr > 1)) { $txt = $brackets->[0] . $txt . $brackets->[1]; } return $txt; } =head2 get_values Title : get_values Usage : Function: Get the top-level array of values. Each of the elements will recursively be a reference to an array or a scalar, depending on the depth of this structured value annotation. Example : Returns : an array Args : none =cut sub get_values{ my $self = shift; return @{$self->{'values'}}; } =head2 get_all_values Title : get_all_values Usage : Function: Flattens all values in this structured annotation and returns them as an array. Example : Returns : the (flat) array of values Args : none =cut sub get_all_values{ my ($self) = @_; # we code lazy here and just take advantage of value() my $txt = $self->value(-joins => ['@!@'], -brackets => ['','']); return split(/\@!\@/, $txt); } =head2 add_value Title : add_value Usage : Function: Adds the given value to the structured annotation at the given index. The index is multi-dimensional, with the first dimension applying to the first level, and so forth. If a particular dimension or a particular index does not exist yet, it will be created. If it does exist and adding the value would mean replacing a scalar with an array reference, we throw an exception to prevent unintended damage. An index of -1 at any dimension means append. If an array of values is to be added, it will create an additional dimension at the index specified, unless the last index value is -1, in which case they will all be appended to the last dimension. Example : Returns : none Args : the index at which to add (a reference to an array) the value(s) to add =cut sub add_value{ my ($self,$index,@values) = @_; my $tree = $self->{'values'}; my $lastidx = pop(@$index); foreach my $i (@$index) { if($i < 0) { my $subtree = []; push(@$tree, $subtree); $tree = $subtree; } elsif((! $tree->[$i]) || (ref($tree->[$i]) eq "ARRAY")) { $tree->[$i] = [] unless ref($tree->[$i]) eq "ARRAY"; $tree = $tree->[$i]; } else { $self->throw("element $i is a scalar but not in last dimension"); } } if($lastidx < 0) { push(@$tree, @values); } elsif(@values < 2) { $tree->[$lastidx] = shift(@values); } else { $tree->[$lastidx] = [@values]; } } 1; BioPerl-1.6.923/Bio/Annotation/TagTree.pm000444000765000024 4507412254227317 20207 0ustar00cjfieldsstaff000000000000# $Id: TagTree.pm 11693 2007-09-17 20:54:04Z cjfields $ # # BioPerl module for Bio::Annotation::TagTree # # Cared for Chris Fields # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Annotation::TagTree - AnnotationI with tree-like hierarchal key-value relationships ('structured tags') that can be represented as simple text. =head1 SYNOPSIS use Bio::Annotation::TagTree; use Bio::Annotation::Collection; my $col = Bio::Annotation::Collection->new(); # data structure can be an array reference with a data structure # corresponding to that defined by Data::Stag: my $sv = Bio::Annotation::TagTree->new(-tagname => 'mytag1', -value => $data_structure); $col->add_Annotation($sv); # regular text passed is parsed based on the tagformat(). my $sv2 = Bio::Annotation::TagTree->new(-tagname => 'mytag2', -tagformat => 'xml', -value => $xmltext); $col->add_Annotation($sv2); =head1 DESCRIPTION This takes tagged data values and stores them in a hierarchal structured element-value hierarchy (complements of Chris Mungall's Data::Stag module). Data can then be represented as text using a variety of output formats (indention, itext, xml, spxr). Furthermore, the data structure can be queried using various means. See L for details. Data passed in using value() or the '-value' parameter upon instantiation can either be: 1) an array reference corresponding to the data structure for Data::Stag; 2) a text string in 'xml', 'itext', 'spxr', or 'indent' format. The default format is 'xml'; this can be changed using tagformat() prior to using value() or by passing in the proper format using '-tagformat' upon instantiation; 3) another Bio::Annotation::TagTree or Data::Stag node instance. In both cases a deep copy (duplicate) of the instance is generated. Beyond checking for an array reference no format guessing occurs (so, for roundtrip tests ensure that the IO formats correspond). For now, we recommend when using text input to set tagformat() to one of these formats prior to data loading to ensure the proper Data::Stag parser is selected. After data loading, the tagformat() can be changed to change the text string format returned by value(). (this may be rectified in the future) This Annotation type is fully BioSQL compatible and could be considered a temporary replacement for nested Bio::Annotation::Collections, at least until BioSQL and bioperl-db can support nested annotation collections. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Chris Fields =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::TagTree; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Annotation::SimpleValue); use Data::Stag; =head2 new Title : new Usage : my $sv = Bio::Annotation::TagTree->new(); Function: Instantiate a new TagTree object Returns : Bio::Annotation::TagTree object Args : -value => $value to initialize the object data field [optional] -tagname => $tag to initialize the tagname [optional] -tagformat => format for output [optional] (types 'xml', 'itext', 'sxpr', 'indent', default = 'itext') -node => Data::Stag node or Bio::Annotation::TagTree instance =cut 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 =cut =head2 as_text Title : as_text Usage : my $text = $obj->as_text Function: return the string "Value: $v" where $v is the value Returns : string Args : none =cut sub as_text { my ($self) = @_; return "TagTree: " . $self->value; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for the specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { 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); } } =head2 hash_tree Title : hash_tree Usage : my $hashtree = $value->hash_tree Function: For supporting the AnnotationI interface just returns the value as a hashref with the key 'value' pointing to the value Maybe reimplement using Data::Stag::hash()? Returns : hashrf Args : none =cut sub hash_tree { my ($self) = @_; my $h = {}; $h->{'value'} = $self->value; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to AnnotationCollection when adding this object. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'tagname'} = $value; } return $self->{'tagname'}; } =head1 Specific accessors for TagTree =cut =head2 value Title : value Usage : $obj->value($newval) Function: Get/set the value for this annotation. Returns : value of value Args : newvalue (optional) =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 run an eval {} to catch Data::Stag output errors $self->node->$format; } =head2 tagformat Title : tagformat Usage : $obj->tagformat($newval) Function: Get/set the output tag format for this annotation. Returns : value of tagformat Args : newvalue (optional) - format for the data passed into value must be of values 'xml', 'indent', 'sxpr', 'itext', 'perl' =cut 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'}; } =head2 node Title : node Usage : $obj->node() Function: Get/set the topmost Data::Stag node used for this annotation. Returns : Data::Stag node implementation (default is Data::Stag::StagImpl) Args : (optional) Data::Stag node implementation (optional)'copy' => flag to create a copy of the node =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'); } # lazily create Data::Stag instance if not present if (!$self->{'db'}) { $self->{'db'} = Data::Stag->new(); } return $self->{'db'}; } =head2 Data::Stag convenience methods Because Data::Stag uses blessed arrays and the core Bioperl class uses blessed hashes, TagTree uses an internal instance of a Data::Stag node for data storage. Therefore the following methods actually delegate to the Data:::Stag internal instance. For consistency (since one could recursively check child nodes), methods retain the same names as Data::Stag. Also, no 'magic' (AUTOLOAD'ed) methods are employed, simply b/c full-fledged Data::Stag functionality can be attained by grabbing the Data::Stag instance using node(). =head2 element Title : element Usage : Function: Returns the element name (key name) for this node Example : Returns : scalar Args : none =cut sub element { my $self = shift; return $self->node->element; } =head2 data Title : data Usage : Function: Returns the data structure (array ref) for this node Example : Returns : array ref Args : none =cut sub data { my $self = shift; return $self->node->data; } =head2 children Title : children Usage : Function: Get the top-level array of Data::Stag nodes or (if the top level is a terminal node) a scalar value. This is similar to StructuredValue's get_values() method, with the key difference being instead of array refs and scalars you get either Data::Stag nodes or the value for this particular node. For consistency (since one could recursively check nodes), we use the same method name as Data::Stag children(). Example : Returns : an array Args : none =cut sub children { my $self = shift; return $self->node->children; } =head2 subnodes Title : subnodes Usage : Function: Get the top-level array of Data::Stag nodes. Unlike children(), this only returns an array of nodes (if this is a terminal node, no value is returned) Example : Returns : an array of nodes Args : none =cut sub subnodes { my $self = shift; return $self->node->subnodes; } =head2 get Title : get Usage : Function: Returns the nodes or value for the named element or path Example : Returns : returns array of nodes or a scalar (if node is terminal) dependent on wantarray Args : none =cut sub get { my ( $self, @vals ) = @_; return $self->node->get(@vals); } =head2 find Title : find Usage : Function: Recursively searches for and returns the nodes or values for the named element or path Example : Returns : returns array of nodes or scalars (for terminal nodes) Args : none =cut sub find { my ( $self, @vals ) = @_; return $self->node->find(@vals); } =head2 findnode Title : findnode Usage : Function: Recursively searches for and returns a list of nodes of the given element path Example : Returns : returns array of nodes Args : none =cut sub findnode { my ( $self, @vals ) = @_; return $self->node->findnode(@vals); } =head2 findval Title : findval Usage : Function: Example : Returns : returns array of nodes or values Args : none =cut sub findval { my ( $self, @vals ) = @_; return $self->node->findval(@vals); } =head2 addchild Title : addchild Usage : $struct->addchild(['name' => [['foo'=> 'bar1']]]); Function: add new child node to the current node. One can pass in a node, TagTree, or data structure; for instance, in the above, this would translate to (in XML): bar1 Returns : node Args : first arg = element name all other args are added as tag-value pairs =cut sub addchild { my ( $self, @vals ) = @_; # check for element tag first (if no element, must be empty Data::Stag node) if ( !$self->element ) { # try to do the right thing; if more than one element, wrap in array ref @vals > 1 ? $self->value( \@vals ) : $self->value( $vals[0] ); return $self->{db}; } elsif ( !$self->node->ntnodes ) { # if this is a terminal node, can't add to it (use set?) $self->throw("Can't add child to node; only terminal node is present!"); } else { return $self->node->addchild(@vals); } } =head2 add Title : add Usage : $struct->add('foo', 'bar1', 'bar2', 'bar3'); Function: add tag-value nodes to the current node. In the above, this would translate to (in XML): bar1 bar2 bar3 Returns : Args : first arg = element name all other args are added as tag-value pairs =cut sub add { my ( $self, @vals ) = @_; # check for empty object and die for now if ( !$self->node->element ) { $self->throw("Can't add to terminal element!"); } return $self->node->add(@vals); } =head2 set Title : set Usage : $struct->set('foo','bar'); Function: sets a single tag-value pair in the current node. Note this differs from add() in that this replaces any data already present Returns : node Args : first arg = element name all other args are added as tag-value pairs =cut sub set { my ( $self, @vals ) = @_; # check for empty object if ( !$self->node->element ) { $self->throw("Can't add to tree; empty tree!"); } return $self->node->set(@vals); } =head2 unset Title : unset Usage : $struct->unset('foo'); Function: unsets all key-value pairs of the passed element from the current node Returns : node Args : element name =cut sub unset { my ( $self, @vals ) = @_; return $self->node->unset(@vals); } =head2 free Title : free Usage : $struct->free Function: removes all data from the current node Returns : Args : =cut sub free { my ($self) = @_; return $self->node->free; } =head2 hash Title : hash Usage : $struct->hash; Function: turns the tag-value tree into a hash, all data values are array refs Returns : hash Args : first arg = element name all other args are added as tag-value pairs =cut sub hash { my ($self) = @_; return $self->node->hash; } =head2 pairs Title : pairs Usage : $struct->pairs; Function: turns the tag-value tree into a hash, all data values are scalar Returns : hash Args : first arg = element name all other args are added as tag-value pairs, note that duplicates will be lost =cut sub pairs { my ($self) = @_; return $self->node->pairs; } =head2 qmatch Title : qmatch Usage : @persons = $s->qmatch('person', ('name'=>'fred')); Function : returns all elements in the node tree which match the element name and the key-value pair Returns : Array of nodes Args : return-element str, match-element str, match-value str =cut sub qmatch { my ( $self, @vals ) = @_; return $self->node->qmatch(@vals); } =head2 tnodes Title : tnodes Usage : @termini = $s->tnodes; Function : returns all terminal nodes below this node Returns : Array of nodes Args : return-element str, match-element str, match-value str =cut sub tnodes { my ($self) = @_; return $self->node->tnodes; } =head2 ntnodes Title : ntnodes Usage : @termini = $s->ntnodes; Function : returns all nonterminal nodes below this node Returns : Array of nodes Args : return-element str, match-element str, match-value str =cut sub ntnodes { my ($self) = @_; return $self->node->ntnodes; } =head2 StructureValue-like methods =cut =head2 get_all_values Title : get_all_values Usage : @termini = $s->get_all_values; Function : returns all terminal node values Returns : Array of values Args : return-element str, match-element str, match-value str This is meant to emulate the values one would get from StructureValue's get_all_values() method. Note, however, using this method dissociates the tag-value relationship (i.e. you only get the value list, no elements) =cut sub get_all_values { my $self = shift; my @kids = $self->children; my @vals; while ( my $val = shift @kids ) { ( ref $val ) ? push @kids, $val->children : push @vals, $val; } return @vals; } 1; BioPerl-1.6.923/Bio/Annotation/Target.pm000444000765000024 1061612254227324 20072 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::Target # # Please direct questions and support issues to # # Cared for by Scott Cain # # Copyright Scott Cain # # Based on the Bio::Annotation::DBLink by Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::Target - Provides an object which represents a target (ie, a similarity hit) from one object to something in another database =head1 SYNOPSIS $target1 = Bio::Annotation::Target->new(-target_id => 'F321966.1', -start => 1, -end => 200, -strand => 1, # or -1 ); # or $target2 = Bio::Annotation::Target->new(); $target2->target_id('Q75IM5'); $target2->start(7); # ... etc ... # Target is-a Bio::AnnotationI object, can be added to annotation # collections, e.g. the one on features or seqs $feat->annotation->add_Annotation('Target', $target2); =head1 DESCRIPTION Provides an object which represents a target (ie, a similarity hit) from one object to something in another database without prescribing what is in the other database =head1 AUTHOR - Scott Cain Scott Cain - cain@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::Target; use strict; use base qw(Bio::Annotation::DBLink Bio::AnnotationI Bio::Range); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($target_id, $tstart, $tend, $tstrand) = $self->_rearrange([ qw( TARGET_ID START END STRAND ) ], @args); $target_id && $self->target_id($target_id); $tstart && $self->start($tstart); $tend && $self->end($tend); $tstrand && $self->strand($tstrand); return $self; } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : Function: Example : Returns : Args : =cut sub as_text{ my ($self) = @_; my $target = $self->target_id || ''; my $start = $self->start || ''; my $end = $self->end || ''; my $strand = $self->strand || ''; return "Target=".$target." ".$start." ".$end." ".$strand; } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub { $_[0]->as_text || ''}; 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); } } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Example : Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my ($self,$value) = @_; if( defined $value) { $self->{'tagname'} = $value; } return $self->{'tagname'}; } =head1 Specific accessors for Targets =cut =head2 target_id =over =item Usage $obj->target_id() #get existing value $obj->target_id($newval) #set new value =item Function =item Returns value of target_id (a scalar) =item Arguments new value of target_id (to set) =back =cut sub target_id { my $self = shift; return $self->{'target_id'} = shift if defined($_[0]); return $self->{'target_id'} || $self->primary_id(); } 1; BioPerl-1.6.923/Bio/Annotation/Tree.pm000444000765000024 1277212254227326 17552 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Annotation::Tree # # Please direct questions and support issues to # # Cared for by Weigang Qiu # # Based on the Bio::Annotation::DBLink by Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::Tree - Provide a tree as an annotation to a Bio::AnnotatableI object =head1 SYNOPSIS # Read a tree and an alignment $treeio=Bio::TreeIO->new(-file=>'foo.dnd', -format=>'newic'); $tree=$treeio->next_tree; $alnio=Bio::AlignIO->new(-file=>'foo.aln', -format=>'clustalw'); $aln=$alnio->next_aln; # Construct a tree annotation $ann_tree = Bio::Annotation::Tree->new (-tree_id => 'mytree', -tree_obj => $tree, ); # Add the tree annotation to AlignI $ac = Bio::Annotation::Collection->new(); $ac->add_Annotation('tree', $ann_tree); $aln->annotation($ac); # NOTE & TODO: # The above procedures are sensible only if # the tree is generated from the alignment. However, # currently no effort has been made to check the consistency # between the tree OTU names and the sequence names =head1 DESCRIPTION Provides a Bio::AnnotationI object which contains a Bio::Tree::TreeI, which can be added to a Bio::AnnotationCollectionI, which in turn be attached to a Bio::AnnotatableI (typically a Bio::AlignI object) =head1 AUTHOR Weigang Qiu - weigang at genectr.hunter.cuny.edu =head1 CONTRIBUTORS Aaron Mackey Jason Stajich =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a '_' =cut # Let the code begin... package Bio::Annotation::Tree; use strict; use base qw(Bio::Root::Root Bio::AnnotationI Bio::TreeIO); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($tree_id, $tree_obj, $tag) = $self->_rearrange([ qw( TREE_ID TREE_OBJ TAGNAME ) ], @args); defined $tag && $self->tagname($tag); defined $tree_id && $self->tree_id($tree_id); defined $tree_obj && $self->tree($tree_obj); return $self; # other possible variables to store # TREE_PROGRAM # TREE_METHOD # TREE_FREQUENCY # defined $program && $self->program($program); # defined $method && $self->method($method); # defined $freq && $self->freq($tree_freq); } =head1 AnnotationI implementing functions =cut =head2 as_text Title : as_text Usage : $ann_tree->as_text(); Function: output tree as a string Returns : a newic tree file Args : None =cut sub as_text{ my ($self) = @_; my $tree = $self->tree || $self->throw("Tree object absent"); my $treeio = Bio::TreeIO->new(); $treeio->write_tree($tree); } =head2 display_text Title : display_text Usage : my $str = $ann->display_text(); Function: returns a string. Unlike as_text(), this method returns a string formatted as would be expected for te specific implementation. One can pass a callback as an argument which allows custom text generation; the callback is passed the current instance and any text returned Example : Returns : a string Args : [optional] callback =cut { my $DEFAULT_CB = sub { $_[0]->as_text || ''}; 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); } } =head2 hash_tree Title : hash_tree Usage : my $hashtree = $value->hash_tree Function: For supporting the AnnotationI interface just returns the value as a hashref with the key 'value' pointing to the value Returns : hashrf to tree Args : none =cut sub hash_tree{ my $self = shift; my $h = {}; $h->{'value'} = $self->tree(); return $h; } =head2 tagname Title : tagname Usage : $obj->tagname($newval) Function: Get/set the tagname for this annotation value. Setting this is optional. If set, it obviates the need to provide a tag to Bio::AnnotationCollectionI when adding this object. When obtaining an AnnotationI object from the collection, the collection will set the value to the tag under which it was stored unless the object has a tag stored already. Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tagname{ my ($self,$value) = @_; if( defined $value) { $self->{'tagname'} = $value; } return $self->{'tagname'}; } =head1 Specific accessors for Tree =head2 tree_id Title : tree_id Usage : $obj->tree_id($newval) Function: Get/set a name for the tree Returns : value of tagname (a scalar) Args : new value (a scalar, optional) =cut sub tree_id { my $self = shift; return $self->{'tree_id'} = shift if defined($_[0]); return $self->{'tree_id'}; } =head2 tree Title : tree Usage : $obj->tree($newval) Function: Get/set tree Returns : tree ref Args : new value (a tree ref, optional) =cut sub tree { my $self = shift; return $self->{'tree'} = shift if defined($_[0]); return $self->{'tree'}; } 1; BioPerl-1.6.923/Bio/Annotation/TypeManager.pm000444000765000024 644112254227313 21037 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Annotation::TypeManager # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Annotation::TypeManager - Manages types for annotation collections =head1 SYNOPSIS # default type manager $tm = Bio::Annotation::TypeManager->new(); # $key is a string or a Bio::Ontology::TermI compliant object print "The type for $key is ",$tm->type_for_key($key),"\n"; if( !$tm->is_valid($key,$object) ) { $self->throw("Invalid object for key $key"); } =head1 DESCRIPTION Manages types for annotation collections. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Annotation::TypeManager; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); # new() can be inherited from Bio::Root::Root =head2 new Title : new Usage : Function: Example : Returns : Args : =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_type'} = {}; $self->_add_type_map('reference',"Bio::Annotation::Reference"); $self->_add_type_map('comment',"Bio::Annotation::Comment"); $self->_add_type_map('dblink',"Bio::Annotation::DBLink"); return $self; } =head2 type_for_key Title : type_for_key Usage : Function: Example : Returns : Args : =cut sub type_for_key{ my ($self,$key) = @_; $key = $key->name() if ref($key) && $key->isa("Bio::Ontology::TermI"); return $self->{'_type'}->{$key}; } =head2 is_valid Title : is_valid Usage : Function: Example : Returns : Args : =cut sub is_valid{ my ($self,$key,$object) = @_; if( !defined $object || !ref $object ) { $self->throw("Cannot type an object [$object]!"); } if( !$object->isa($self->type_for_key($key)) ) { return 0; } else { return 1; } } =head2 _add_type_map Title : _add_type_map Usage : Function: Example : Returns : Args : =cut sub _add_type_map{ my ($self,$key,$type) = @_; $key = $key->name() if ref($key) && $key->isa("Bio::Ontology::TermI"); $self->{'_type'}->{$key} = $type; } 1; BioPerl-1.6.923/Bio/Assembly000755000765000024 012254227340 15570 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Assembly/Contig.pm000444000765000024 20133612254227335 17557 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::Contig # Mostly based on Bio::SimpleAlign by Ewan Birney # # Please direct questions and support issues to # # Cared for by Robson Francisco de Souza # # Copyright Robson Francisco de Souza # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Assembly::Contig - Perl module to hold and manipulate sequence assembly contigs. =head1 SYNOPSIS # Module loading use Bio::Assembly::IO; # Assembly loading methods $aio = Bio::Assembly::IO->new(-file=>"test.ace.1", -format=>'phrap'); $assembly = $aio->next_assembly; foreach $contig ($assembly->all_contigs) { # do something } # OR, if you want to build the contig yourself, use Bio::Assembly::Contig; $c = Bio::Assembly::Contig->new(-id=>"1"); $ls = Bio::LocatableSeq->new(-seq=>"ACCG-T", -id=>"r1", -alphabet=>'dna'); $ls2 = Bio::LocatableSeq->new(-seq=>"ACA-CG-T", -id=>"r2", -alphabet=>'dna'); $ls_coord = Bio::SeqFeature::Generic->new(-start=>3, -end=>8, -strand=>1); $ls2_coord = Bio::SeqFeature::Generic->new(-start=>1, -end=>8, -strand=>1); $c->add_seq($ls); $c->add_seq($ls2); $c->set_seq_coord($ls_coord,$ls); $c->set_seq_coord($ls2_coord,$ls2); $con = Bio::LocatableSeq->new(-seq=>"ACACCG-T", -alphabet=>'dna'); $c->set_consensus_sequence($con); $l = $c->change_coord('unaligned r2','ungapped consensus',6); print "6 in unaligned r2 => $l in ungapped consensus\n"; =head1 DESCRIPTION A contig is as a set of sequences, locally aligned to each other, so that every sequence has overlapping regions with at least one sequence in the contig, such that a continuous of overlapping sequences is formed, allowing the deduction of a consensus sequence which may be longer than any of the sequences from which it was deduced. In this documentation we refer to the overlapping sequences used to build the contig as "aligned sequences" and to the sequence deduced from the overlap of aligned sequences as the "consensus". Methods to deduce the consensus sequence from aligned sequences were not yet implemented in this module, but its posssible to add a consensus sequence deduced by other means, e.g, by the assembly program used to build the alignment. All aligned sequences in a Bio::Assembly::Contig must be Bio::Assembly::Locatable objects and have a unique ID. The unique ID restriction is due to the nature of the module's internal data structures and is also a request of some assembly programs. If two sequences with the same ID are added to a contig, the first sequence added is replaced by the second one. =head2 Coordinate_systems There are four base coordinate systems in Bio::Assembly::Contig. When you need to access contig elements or data that exists on a certain range or location, you may be specifying coordinates in relation to different sequences, which may be either the contig consensus or one of the aligned sequences that were used to do the assembly. ========================================================= Name | Referenced sequence --------------------------------------------------------- "gapped consensus" | Contig (with gaps) "ungapped consensus" | Contig (without gaps) "aligned $seqID" | sequence $seqID (with gaps) "unaligned $seqID" | sequence $seqID (without gaps) ========================================================= "gapped consensus" refers to positions in the aligned consensus sequence, which is the consensus sequence including the gaps inserted to align it agains the aligned sequences that were used to assemble the contig. So, its limits are [ 1, (consensus length + number of gaps in consensus) ] "ungapped consensus" is a coordinate system based on the consensus sequence, but excluding consensus gaps. This is just the coordinate system that you have when considering the consensus sequence alone, instead of aligned to other sequences. "aligned $seqID" refers to locations in the sequence $seqID after alignment of $seqID against the consensus sequence (reverse complementing the original sequence, if needed). Coordinate 1 in "aligned $seqID" is equivalent to the start location (first base) of $seqID in the consensus sequence, just like if the aligned sequence $seqID was a feature of the consensus sequence. "unaligned $seqID" is equivalent to a location in the isolated sequence, just like you would have when considering the sequence alone, out of an alignment. When changing coordinates from "aligned $seq2" to "unaligned $seq2", if $seq2 was reverse complemented when included in the alignment, the output coordinates will be reversed to fit that fact, i.e. 1 will be changed to length($seq2), 2 will be length($seq)-1 and so on. An important note: when you change gap coordinates from a gapped system ("gapped consensus" or "aligned $seqID") to a system that does not include gaps ("ungapped consensus" or "unaligned $seqID"), the position returned will be the first location before all gaps neighboring the input location. =head2 Feature_collection Bio::Assembly::Contig stores much information about a contig in a Bio::Assembly::SeqFeature::Collection object. Relevant information on the alignment is accessed by selecting features based on their primary tags (e.g. all features which have a primary tag of the form '_aligned_coord:$seqID', where $seqID is an aligned sequence ID, are coordinates for sequences in the contig alignment) and, by using methods from Bio::Assembly::SeqFeature::Collection, it's possible to select features by overlap with other features. We suggest that you use the primary tags of features as identifiers for feature classes. By convention, features with primary tags starting with a '_' are generated by modules that populate the contig data structure and return the contig object, maybe as part of an assembly object, e.g. drivers from the Bio::Assembly::IO set. Features in the features collection may be associated with particular aligned sequences. To obtain this, you must attach the sequence to the feature, using attach() seq from Bio::Assembly::SeqFeatureI, before you add the feature to the feature collection. We also suggest to add the sequence id to the primary tag, so that is easy to select feature for a particular sequence. There is only one feature class that some methods in Bio::Assembly::Contig expect to find in the feature collection: features with primary tags of the form '_aligned_coord:$seqID', where $seqID is the aligned sequence id (like returned by $seq-Eid()). These features describe the position (in "gapped consensus" coordinates) of aligned sequences, and the method set_seq_coord() automatically changes a feature's primary tag to this form whenever the feature is added to the collection by this method. Only two methods in Bio::Assembly::Contig will not work unless there are features from this class: change_coord() and get_seq_coord(). Other feature classes will be automatically available only when Bio::Assembly::Contig objects are created by a specific module. Such feature classes are (or should be) documented in the documentation of the module which create them, to which the user should refer. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Robson Francisco de Souza rfsouza@citri.iq.usp.br =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' package Bio::Assembly::Contig; use strict; use Bio::DB::SeqFeature::Store; # isa Bio::SeqFeature::CollectionI use Bio::Seq::PrimaryQual; # isa Bio::Seq::QualI use Scalar::Util qw(weaken); use base qw(Bio::Root::Root Bio::Align::AlignI); =head1 Object creator =head2 new Title : new Usage : my $contig = Bio::Assembly::Contig->new(); Function : Creates a new contig object Returns : Bio::Assembly::Contig Args : -id => unique contig ID -source => string for the sequence assembly program used -collection => Bio::SeqFeature::CollectionI instance =cut #----------- sub new { #----------- my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($src, $id, $collection) = $self->_rearrange([qw(SOURCE ID COLLECTION)], @args); $src && $self->source($src); ($id && $self->id($id)) || ($self->{'_id'} = 'NoName'); # Alignment (contig) name ($id && $self->id($id)) || ($self->{'_source'} = 'Unknown'); # Program used to build the contig # we need to set up internal hashes first! # Bio::SimpleAlign derived fields (check which ones are needed for AlignI compatibility) $self->{'_elem'} = {}; # contig elements: aligned sequence objects (keyed by ID) $self->{'_order'} = {}; # store sequence order # $self->{'start_end_lists'} = {}; # References to entries in {'_seq'}. Keyed by seq ids. # $self->{'_dis_name'} = {}; # Display names for each sequence $self->{'_symbols'} = {}; # List of symbols #Contig specific slots $self->{'_consensus_sequence'} = undef; $self->{'_consensus_quality'} = undef; $self->{'_nof_residues'} = 0; $self->{'_nof_seqs'} = 0; # $self->{'_nof_segments'} = 0; # Let's not make it heavier than needed by now... # for cases where SF::Collection is shared between Bio::Assembly::Contig if ($collection) { $self->throw("Collection must implement Bio::SeqFeature::CollectionI") unless $collection->isa('Bio::SeqFeature::CollectionI'); $self->{'_sfc'} = $collection; } else { $self->{'_sfc'} = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory', -index_subfeatures => 1, ); } # Assembly specifics $self->{'_assembly'} = undef; # Bio::Assembly::Scaffold the contig belongs to $self->{'_strand'} = 0; # Reverse (-1) or forward (1), if contig is in a scaffold. 0 otherwise $self->{'_neighbor_start'} = undef; # Neighbor Bio::Assembly::Contig $self->{'_neighbor_end'} = undef; # Neighbor Bio::Assembly::Contig return $self; # success - we hope! } =head1 Assembly related methods These methods exist to enable adding information about possible relations among contigs, e.g. when you already have a scaffold for your assembly, describing the ordering of contigs in the final assembly, but no sequences covering the gaps between neighboring contigs. =head2 source Title : source Usage : $contig->source($program); Function : Get/Set program used to build this contig Returns : string Argument : [optional] string =cut sub source { my $self = shift; my $source = shift; $self->{'_source'} = $source if (defined $source); return $self->{'_source'}; } =head2 assembly Title : assembly Usage : $contig->assembly($assembly); Function : Get/Set assembly object for this contig Returns : a Bio::Assembly::Scaffold object Argument : a Bio::Assembly::Scaffold object =cut sub assembly { my $self = shift; my $assembly = shift; $self->throw("Using non Bio::Assembly::Scaffold object when assign contig to assembly") if (defined $assembly && ! $assembly->isa("Bio::Assembly::Scaffold")); # We create a circular reference to a Scaffold object. It is made weak # to prevent memory leaks. $self->{'_assembly'} = $assembly if (defined $assembly); weaken($self->{'_assembly'}); return $self->{'_assembly'}; } =head2 strand Title : strand Usage : $contig->strand($num); Function : Get/Set contig orientation in a scaffold/assembly. Its equivalent to the strand property of sequence objects and sets whether the contig consensus should be reversed and complemented before being added to a scaffold or assembly. Returns : integer Argument : 1 if orientaion is forward, -1 if reverse and 0 if none =cut sub strand { my $self = shift; my $ori = shift; if (defined $ori) { $self->throw("Contig strand must be either 1, -1 or 0") unless $ori == 1 || $ori == 0 || $ori == -1; $self->{'_strand'} = $ori; } return $self->{'_strand'}; } =head2 upstream_neighbor Title : upstream_neighbor Usage : $contig->upstream_neighbor($contig); Function : Get/Set a contig neighbor for the current contig when building a scaffold. The upstream neighbor is located before $contig first base Returns : nothing Argument : Bio::Assembly::Contig =cut sub upstream_neighbor { my $self = shift; my $ref = shift; $self->throw("Trying to assign a non Bio::Assembly::Contig object to upstream contig") if (defined $ref && ! $ref->isa("Bio::Assembly::Contig")); $self->{'_neighbor_start'} = $ref if (defined $ref); return $self->{'_neighbor_start'}; } =head2 downstream_neighbor Title : downstream_neighbor Usage : $contig->downstream_neighbor($num); Function : Get/Set a contig neighbor for the current contig when building a scaffold. The downstream neighbor is located after $contig last base Returns : nothing Argument : Bio::Assembly::Contig =cut sub downstream_neighbor { my $self = shift; my $ref = shift; $self->throw("Trying to assign a non Bio::Assembly::Contig object to downstream contig") if (defined $ref && ! $ref->isa("Bio::Assembly::Contig")); $self->{'_neighbor_end'} = $ref if (defined $ref); return $self->{'_neighbor_end'}; } =head1 Contig feature collection methods =head2 add_features Title : add_features Usage : $contig->add_features($feat,$flag) Function : Add an array of features to the contig feature collection. The consensus sequence may be attached to the added feature, if $flag is set to 1. If $flag is 0 and the feature attached to one of the contig aligned sequences, the feature is registered as an aligned sequence feature. If $flag is 0 and the feature is not attched to any sequence in the contig, the feature is simply added to the feature collection and no attachment or registration is made. Note: You must attach aligned sequences to their features prior to calling add_features, otherwise you won't be able to access the feature through get_seq_feat_by_tag() method. Returns : number of features added. Argument : $feat : A reference to an array of Bio::SeqFeatureI $flag : boolean - true if consensus sequence object should be attached to this feature, false if no consensus attachment should be made. Default: false. =cut sub add_features { my ($self, $args, $flag) = @_; # Adding shortcuts for aligned sequence features $flag = 0 unless (defined $flag); if ($flag && defined $self->{'_consensus_sequence'}) { foreach my $feat (@$args) { next if (defined $feat->seq); $feat->attach_seq($self->{'_consensus_sequence'}); } } elsif (!$flag) { # Register aligned sequence features foreach my $feat (@$args) { if (my $seq = $feat->entire_seq()) { my $seqID = $seq->id() || $seq->display_id || $seq->primary_id; $self->warn("Adding contig feature attached to unknown sequence $seqID!") unless (exists $self->{'_elem'}{$seqID}); my $tag = $feat->primary_tag; $self->{'_elem'}{$seqID}{'_feat'}{$tag} = $feat; } } } # Add feature to feature collection my $nof_added = $self->get_features_collection->add_features($args); return $nof_added; } =head2 remove_features Title : remove_features Usage : $contig->remove_features(@feat) Function : Remove an array of contig features Returns : true if successful Argument : An array of Bio::SeqFeature::Generic (Bio::SeqFeatureI) =cut sub remove_features { my ($self, @args) = @_; # Removing shortcuts for aligned sequence features for my $feat (@args) { if (my $seq = $feat->entire_seq()) { my $seqID = $seq->id || $seq->display_id || $seq->primary_id; my $tag = $feat->primary_tag; $tag =~ s/:$seqID$/$1/g; delete( $self->{'_elem'}{$seqID}{'_feat'}{$tag} ) if (exists $self->{'_elem'}{$seqID}{'_feat'}{$tag} && $self->{'_elem'}{$seqID}{'_feat'}{$tag} eq $feat); } } # Removing Bio::SeqFeature objects return $self->get_features_collection->delete(@args); } =head2 get_features_collection Title : get_features_collection Usage : $contig->get_features_collection() Function : Get the collection of all contig features and seqfeatures Returns : Bio::DB::SeqFeature::Store (Bio::SeqFeature::CollectionI) Argument : none =cut sub get_features_collection { my $self = shift; return $self->{'_sfc'}; } =head2 remove_features_collection Title : remove_features_collection Usage : $contig->remove_features_collection() Function : Remove the collection of all contig features. It is useful to save some memory (when contig features are not needed). Returns : none Argument : none =cut sub remove_features_collection { my $self = shift; # Removing shortcuts for aligned sequence features for my $seqID (keys %{$self->{'_elem'}}) { delete $self->{'_elem'}{$seqID}; } # Removing Bio::SeqFeature::Collection features $self->{'_sfc'} = {}; return; } =head1 Coordinate system's related methods See L above. =head2 change_coord Title : change_coord Usage : $contig->change_coord($in,$out,$query) Function : Change coordinate system for $query. This method transforms locations between coordinate systems described in section "Coordinate Systems" of this document. Note: this method will throw an exception when changing coordinates between "ungapped consensus" and other systems if consensus sequence was not set. It will also throw exceptions when changing coordinates among aligned sequence, either with or without gaps, and other systems if sequence locations were not set with set_seq_coord(). Returns : integer Argument : $in : [string] input coordinate system $out : [string] output coordinate system $query : [integer] a position in a sequence =cut sub change_coord { my $self = shift; my $type_in = shift; my $type_out = shift; my $query = shift; # Parsing arguments # Loading read objects (these calls will throw exceptions whether $read_in or # $read_out is not found my ($read_in,$read_out) = (undef,undef); my $in_ID = ( split(' ',$type_in) )[1]; my $out_ID = ( split(' ',$type_out) )[1]; if ($in_ID ne 'consensus') { $read_in = $self->get_seq_coord( $self->get_seq_by_name($in_ID) ); $self->throw("Can't change coordinates without sequence location for $in_ID") unless (defined $read_in); } if ($out_ID ne 'consensus') { $read_out = $self->get_seq_coord( $self->get_seq_by_name($out_ID) ); $self->throw("Can't change coordinates without sequence location for $out_ID") unless (defined $read_out); } # Performing transformation between coordinates SWITCH1: { # Transformations between contig padded and contig unpadded (($type_in eq 'gapped consensus') && ($type_out eq 'ungapped consensus')) && do { $self->throw("Can't use ungapped consensus coordinates without a consensus sequence") unless (defined $self->{'_consensus_sequence'}); $query = &_padded_unpadded($self->{'_consensus_gaps'}, $query); last SWITCH1; }; (($type_in eq 'ungapped consensus') && ($type_out eq 'gapped consensus')) && do { $self->throw("Can't use ungapped consensus coordinates without a consensus sequence") unless (defined $self->{'_consensus_sequence'}); $query = &_unpadded_padded($self->{'_consensus_gaps'},$query); last SWITCH1; }; # Transformations between contig (padded) and read (padded) (($type_in eq 'gapped consensus') && ($type_out =~ /^aligned /) && defined($read_out)) && do { $query = $query - $read_out->start() + 1; last SWITCH1; }; (($type_in =~ /^aligned /) && defined($read_in) && ($type_out eq 'gapped consensus')) && do { $query = $query + $read_in->start() - 1; last SWITCH1; }; # Transformations between contig (unpadded) and read (padded) (($type_in eq 'ungapped consensus') && ($type_out =~ /^aligned /) && defined($read_out)) && do { $query = $self->change_coord('ungapped consensus','gapped consensus',$query); $query = $self->change_coord('gapped consensus',"aligned $out_ID",$query); last SWITCH1; }; (($type_in =~ /^aligned /) && defined($read_in) && ($type_out eq 'ungapped consensus')) && do { $query = $self->change_coord("aligned $in_ID",'gapped consensus',$query); $query = $self->change_coord('gapped consensus','ungapped consensus',$query); last SWITCH1; }; # Transformations between seq $read_in padded and seq $read_out padded (defined($read_in) && ($type_in =~ /^aligned /) && defined($read_out) && ($type_out =~ /^aligned /)) && do { $query = $self->change_coord("aligned $in_ID",'gapped consensus',$query); $query = $self->change_coord('gapped consensus',"aligned $out_ID",$query); last SWITCH1; }; # Transformations between seq $read_in padded and seq $read_out unpadded (defined($read_in) && ($type_in =~ /^aligned /) && defined($read_out) && ($type_out =~ /^unaligned /)) && do { if ($read_in ne $read_out) { $query = $self->change_coord("aligned $in_ID",'gapped consensus',$query); $query = $self->change_coord('gapped consensus',"aligned $out_ID",$query); } my $list_out = $self->{'_elem'}{$out_ID}{'_gaps'}; $query = &_padded_unpadded($list_out,$query); # Changing read orientation if read was reverse complemented when aligned if ($read_out->strand == -1) { my ($length) = $read_out->length(); $length = $length - &_nof_gaps($list_out,$length); $query = $length - $query + 1; } last SWITCH1; }; (defined($read_in) && ($type_in =~ /^unaligned /) && defined($read_out) && ($type_out =~ /^aligned /)) && do { my $list_in = $self->{'_elem'}{$in_ID}{'_gaps'}; # Changing read orientation if read was reverse complemented when aligned if ($read_in->strand == -1) { my ($length) = $read_in->length(); $length = $length - &_nof_gaps($list_in,$length); $query = $length - $query + 1; } $query = &_unpadded_padded($list_in,$query); if ($read_in ne $read_out) { $query = $self->change_coord("aligned $in_ID",'gapped consensus',$query); $query = $self->change_coord('gapped consensus',"aligned $out_ID",$query); } last SWITCH1; }; # Transformations between seq $read_in unpadded and seq $read_out unpadded (defined($read_in) && ($type_in =~ /^unaligned /) && defined($read_out) && ($type_out =~ /^unaligned /)) && do { $query = $self->change_coord("unaligned $in_ID","aligned $out_ID",$query); $query = $self->change_coord("aligned $out_ID","unaligned $out_ID",$query); last SWITCH1; }; # Transformations between contig (padded) and read (unpadded) (($type_in eq 'gapped consensus') && ($type_out =~ /^unaligned /) && defined($read_out)) && do { $query = $self->change_coord('gapped consensus',"aligned $out_ID",$query); $query = $self->change_coord("aligned $out_ID","unaligned $out_ID",$query); last SWITCH1; }; (($type_in =~ /^unaligned /) && defined($read_in) && ($type_out eq 'gapped consensus')) && do { $query = $self->change_coord("unaligned $in_ID","aligned $in_ID",$query); $query = $self->change_coord("aligned $in_ID",'gapped consensus',$query); last SWITCH1; }; # Transformations between contig (unpadded) and read (unpadded) (($type_in eq 'ungapped consensus') && ($type_out =~ /^unaligned /) && defined($read_out)) && do { $query = $self->change_coord('ungapped consensus','gapped consensus',$query); $query = $self->change_coord('gapped consensus',"unaligned $out_ID",$query); last SWITCH1; }; (($type_in =~ /^unaligned /) && defined($read_in) && ($type_out eq 'ungapped consensus')) && do { $query = $self->change_coord("unaligned $in_ID",'gapped consensus',$query); $query = $self->change_coord('gapped consensus','ungapped consensus',$query); last SWITCH1; }; $self->throw("Unknow coordinate system. Args: $type_in, $type_out."); $query = undef; # If a coordinate systems just requested is unknown } return $query; } =head2 get_seq_coord Title : get_seq_coord Usage : $contig->get_seq_coord($seq); Function : Get "gapped consensus" location for aligned sequence Returns : Bio::SeqFeature::Generic for coordinates or undef. A warning is printed if sequence coordinates were not set. Argument : Bio::LocatableSeq object =cut sub get_seq_coord { my ($self,$seq) = @_; if( !ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("$seq is not a Bio::LocatableSeq"); } my $seqID = $seq->id() || $seq->display_id || $seq->primary_id; unless (exists( $self->{'_elem'}{$seqID} )) { $self->warn("No such sequence ($seqID) in contig ".$self->id); return; } unless (exists( $self->{'_elem'}{$seqID}{'_feat'}{"_aligned_coord:$seqID"} )) { # $self->warn("Chad. Location not set for sequence ($seqID) in contig ".$self->id); return; } return $self->{'_elem'}{$seqID}{'_feat'}{"_aligned_coord:$seqID"}; } =head2 set_seq_coord Title : set_seq_coord Usage : $contig->set_seq_coord($feat,$seq); Function : Set "gapped consensus" location for an aligned sequence. If the sequence was previously added using add_seq, its coordinates are changed/set. Otherwise, add_seq is called and the sequence is added to the contig. Returns : Bio::SeqFeature::Generic for old coordinates or undef. Argument : $feat : a Bio::SeqFeature::Generic object representing a location for the aligned sequence, in "gapped consensus" coordinates. Note: the original feature primary tag will be lost. $seq : a Bio::LocatableSeq object =cut sub set_seq_coord { my ($self,$feat,$seq) = @_; if( !ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("Unable to process non locatable sequences [".ref($seq)."]"); } # Complaining about inadequate feature object $self->throw("Coordinates must be a Bio::SeqFeature::Generic object!") unless ( $feat->isa("Bio::SeqFeature::Generic") ); $self->throw("Sequence coordinates must have an end!") unless (defined $feat->end); $self->throw("Sequence coordinates must have a start!") unless (defined $feat->start); my $seqID = $seq->id() || $seq->display_id || $seq->primary_id; if ( exists( $self->{'_elem'}{$seqID} ) && exists( $self->{'_elem'}{$seqID}{'_seq'} ) && defined( $self->{'_elem'}{$seqID}{'_seq'} ) && ($seq ne $self->{'_elem'}{$seqID}{'_seq'}) ) { $self->warn("Replacing sequence $seqID\n"); $self->remove_seq($self->{'_elem'}{$seqID}{'_seq'}); $self->remove_features($feat); } # Add new sequence and Bio::Generic::SeqFeature $self->add_seq($seq); $feat->add_tag_value('contig',$self->id) unless ( $feat->has_tag('contig') ); $feat->primary_tag("_aligned_coord"); $feat->source_tag($seqID); $feat->attach_seq($seq); $self->{'_elem'}{$seqID}{'_feat'}{"_aligned_coord:$seqID"} = $feat; $self->add_features([ $feat ]); } =head1 Bio::Assembly::Contig consensus methods =head2 set_consensus_sequence Title : set_consensus_sequence Usage : $contig->set_consensus_sequence($seq) Function : Set the consensus sequence object for this contig Returns : consensus length Argument : Bio::LocatableSeq =cut sub set_consensus_sequence { my $self = shift; my $seq = shift; $self->throw("Consensus sequence must be a Bio::LocatableSeq!") unless ($seq->isa("Bio::LocatableSeq")); $self->{'_consensus_gaps'} = []; # Consensus Gap registry $self->_register_gaps( $seq->seq, $self->{'_consensus_gaps'} ); $self->{'_consensus_sequence'} = $seq; $seq->start(1); $seq->end($seq->_ungapped_len); my $con_len = $seq->length; return $con_len; } =head2 set_consensus_quality Title : set_consensus_quality Usage : $contig->set_consensus_quality($qual) Function : Set the quality object for consensus sequence Returns : nothing Argument : Bio::Seq::QualI object =cut sub set_consensus_quality { my ($self, $qual) = @_; $self->throw("Consensus quality must be a Bio::Seq::QualI object!") unless ( $qual->isa("Bio::Seq::QualI") ); $self->throw("Consensus quality can't be added before you set the consensus sequence!") unless (defined $self->{'_consensus_sequence'}); $self->{'_consensus_quality'} = $qual; } =head2 get_consensus_length Title : get_consensus_length Usage : $contig->get_consensus_length() Function : Get consensus sequence length Returns : integer Argument : none =cut sub get_consensus_length { my $self = shift; return $self->{'_consensus_sequence'}->length(); } =head2 get_consensus_sequence Title : get_consensus_sequence Usage : $contig->get_consensus_sequence() Function : Get a reference to the consensus sequence object for this contig Returns : Bio::SeqI object Argument : none =cut sub get_consensus_sequence { my ($self, @args) = @_; return $self->{'_consensus_sequence'}; } =head2 get_consensus_quality Title : get_consensus_quality Usage : $contig->get_consensus_quality() Function : Get a reference to the consensus quality object for this contig. Returns : A Bio::Seq::QualI object Argument : none =cut sub get_consensus_quality { my ($self, @args) = @_; return $self->{'_consensus_quality'}; } =head1 Bio::Assembly::Contig aligned sequences methods =head2 set_seq_qual Title : set_seq_qual Usage : $contig->set_seq_qual($seq,$qual); Function : Adds quality to an aligned sequence. Returns : nothing Argument : a Bio::LocatableSeq object and a Bio::Seq::QualI object See L for more information. =cut sub set_seq_qual { my ($self,$seq,$qual) = @_; if( !ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("Unable to process non locatable sequences [".ref($seq)."]"); } my $seqID = $seq->id() || $seq->display_id || $seq->primary_id; $self->throw("Consensus quality must be a Bio::Seq::QualI object!") unless ( $qual->isa("Bio::Seq::QualI") ); $self->throw("Use add_seq first: aligned sequence qualities can't be added before you load the sequence!") unless (exists $self->{'_elem'}{$seqID}{'_seq'}); $self->throw("Use set_seq_coord first: aligned sequence qualities can't be added before you add coordinates for the sequence!") unless (defined( $self->get_seq_coord($seq) )); # Adding gaps to quality object my $sequence = $self->{'_elem'}{$seqID}{'_seq'}->seq(); my $tmp = $qual->qual(); @{$tmp} = reverse(@{$tmp}) if ($self->get_seq_coord($seq)->strand() == -1); my @quality = (); my $previous = 0; my $next = 0; my $i = 0; my $j = 0; while ($i <= $#{$tmp}) { # IF base is a gap, quality is the average for neighbouring sites if ($j > $i && substr($sequence,$j,1) eq '-') { $previous = $tmp->[$i-1] unless ($i == 0); if ($i < $#{$tmp}) { $next = $tmp->[$i+1]; } else { $next = 0; } push(@quality,int( ($previous+$next)/2 )); } else { push(@quality,$tmp->[$i]); $i++; } $j++; } $self->{'_elem'}{$seqID}{'_qual'} = Bio::Seq::PrimaryQual->new( -qual=>join(" ",@quality), -id=>$seqID ); } =head2 get_seq_ids Title : get_seq_ids Usage : $contig->get_seq_ids( -start => $start, -end => $end, -type => "gapped A0QR67B08.b" ); Function : Get list of sequence IDs overlapping interval [$start, $end] The default interval is [1,$contig->length] Default coordinate system is "gapped contig" Returns : An array Argument : A hash with optional elements: -start : consensus subsequence start -end : consensus subsequence end -type : the coordinate system type for $start and $end arguments Coordinate system available are: "gapped consensus" : consensus coordinates with gaps "ungapped consensus" : consensus coordinates without gaps "aligned $ReadID" : read $ReadID coordinates with gaps "unaligned $ReadID" : read $ReadID coordinates without gaps =cut sub get_seq_ids { my ($self, @args) = @_; my ($type, $start, $end) = $self->_rearrange([qw(TYPE START END)], @args); my @list; if (defined($start) && defined($end)) { if (defined($type) && ($type ne 'gapped consensus')) { $start = $self->change_coord($type,'gapped consensus',$start); $end = $self->change_coord($type,'gapped consensus',$end); } @list = $self->get_features_collection->features( -type => '_aligned_coord', # primary tag -start => $start, -end => $end, #-contain => 0, #-strandmatch => 'ignore', ); @list = map { $_->entire_seq->id } @list; } else { # Entire aligned sequences list @list = map { $self->{'_order'}{$_} } sort { $a cmp $b } keys %{ $self->{'_order'} }; } return @list; } =head2 get_seq_feat_by_tag Title : get_seq_feat_by_tag Usage : $seq = $contig->get_seq_feat_by_tag($seq,"_aligned_coord:$seqID") Function : Get a sequence feature based on its primary_tag. Returns : a Bio::SeqFeature object Argument : a Bio::LocatableSeq and a string (feature primary tag) =cut sub get_seq_feat_by_tag { my ($self,$seq,$tag) = @_; if( !ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("Unable to process non locatable sequences [".ref($seq)."]"); } my $seqID = $seq->id || $seq->display_id || $seq->primary_id; return $self->{'_elem'}{$seqID}{'_feat'}{$tag}; } =head2 get_seq_by_name Title : get_seq_by_name Usage : $seq = $contig->get_seq_by_name('Seq1') Function : Gets a sequence based on its id. Returns : a Bio::LocatableSeq object undef if name is not found Argument : string =cut sub get_seq_by_name { my $self = shift; my ($seqID) = @_; unless (exists $self->{'_elem'}{$seqID}{'_seq'}) { $self->throw("Could not find sequence $seqID in contig ".$self->id); return; } return $self->{'_elem'}{$seqID}{'_seq'}; } =head2 get_qual_by_name Title : get_qual_by_name Usage : $seq = $contig->get_qual_by_name('Seq1') Function : Gets Bio::Seq::QualI object for a sequence through its id ( as given by $qual->id() ). Returns : a Bio::Seq::QualI object. undef if name is not found Argument : string =cut sub get_qual_by_name { my $self = shift; my ($seqID) = @_; unless (exists $self->{'_elem'}{$seqID}{'_qual'}) { $self->warn("Could not find quality for $seqID in contig!"); return; } return $self->{'_elem'}{$seqID}{'_qual'}; } =head1 Bio::Align::AlignI compatible methods =head2 Modifier methods These methods modify the MSE by adding, removing or shuffling complete sequences. =head2 add_seq Title : add_seq Usage : $contig->add_seq($newseq); Function : Adds a sequence to the contig. *Does* *not* align it - just adds it to the hashes. Returns : nothing Argument : a Bio::LocatableSeq object See L for more information. =cut sub add_seq { my $self = shift; my $seq = shift; if( !ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("Unable to process non locatable sequences [".ref($seq)."]"); } my $seqID = $seq->id() || $seq->display_id || $seq->primary_id; $self->{'_elem'}{$seqID} = {} unless (exists $self->{'_elem'}{$seqID}); if (exists( $self->{'_elem'}{$seqID}{'_seq'} ) && ($seq eq $self->{'_elem'}{$seqID}{'_seq'}) ) { $self->warn("Adding sequence $seqID, which has already been added"); } # Our locatable sequences are always considered to be complete sequences $seq->start(1); $seq->end($seq->_ungapped_len); my $alphabet = $seq->alphabet; $alphabet = lc($alphabet) if defined $alphabet; $self->warn("Adding non-nucleotidic sequence ".$seqID) if (!$alphabet || ($alphabet ne 'dna' && $alphabet ne 'rna')); # build the symbol list for this sequence, # will prune out the gap and missing/match chars # when actually asked for the symbol list in the # symbol_chars if (defined $seq->seq) { map { $self->{'_symbols'}->{$_} = 1; } split(//,$seq->seq); } else { $self->{'_symbols'} = {}; } my $seq_no = ++$self->{'_nof_seqs'}; if (ref( $self->{'_elem'}{$seqID}{'_seq'} )) { $self->warn("Replacing one sequence [$seqID]\n"); } else { #print STDERR "Assigning $seqID to $order\n"; $self->{'_order'}->{$seq_no} = $seqID; # $self->{'_start_end_lists'}->{$id} = [] # unless(exists $self->{'_start_end_lists'}->{$id}); # push @{$self->{'_start_end_lists'}->{$id}}, $seq; } $self->{'_elem'}{$seqID}{'_seq'} = $seq; $self->{'_elem'}{$seqID}{'_feat'} = {}; $self->{'_elem'}{$seqID}{'_gaps'} = []; my $dbref = $self->{'_elem'}{$seqID}{'_gaps'}; my $nofgaps = $self->_register_gaps($seq->seq,$dbref); # Updating residue count $self->{'_nof_residues'} += $seq->length - $nofgaps; return 1; } =head2 remove_seq Title : remove_seq Usage : $contig->remove_seq($seq); Function : Removes a single sequence from a contig Returns : 1 on success, 0 otherwise Argument : a Bio::LocatableSeq object =cut sub remove_seq { my ($self,$seq) = @_; if( !ref $seq || ! $seq->isa('Bio::LocatableSeq') ) { $self->throw("Unable to process non locatable sequences [".ref($seq)."]"); } my $seqID = $seq->id() || $seq->display_id || $seq->primary_id; unless (exists $self->{'_elem'}{$seqID} ) { $self->warn("No sequence named $seqID [$seq]"); return 0; } # 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 = (); for my $tag (keys %{ $self->{'_elem'}{$seqID}{'_feat'} }) { push(@feats, $self->{'_elem'}{$seqID}{'_feat'}{$tag}); } $self->{'_sfc'}->remove_features(\@feats); delete $self->{'_elem'}{$seqID}; return 1; } =head2 purge Title : purge Usage : $contig->purge(0.7); Function: Removes sequences above whatever %id. This function will grind on large alignments. Beware! (perhaps not ideally implemented) Example : Returns : An array of the removed sequences Argument: =cut sub purge { my ($self) = @_; $self->throw_not_implemented(); } =head2 sort_alphabetically Title : sort_alphabetically Usage : $contig->sort_alphabetically Function : Changes the order of the alignemnt to alphabetical on name followed by numerical by number. Returns : Argument : =cut sub sort_alphabetically { my ($self) = @_; $self->throw_not_implemented(); } =head2 Sequence selection methods Methods returning one or more sequences objects. =head2 each_seq Title : each_seq Usage : foreach $seq ( $contig->each_seq() ) Function : Gets an array of Seq objects from the alignment Returns : an array Argument : =cut sub each_seq { my ($self) = @_; my (@arr,$seqID); foreach $seqID ( map { $self->{'_order'}{$_} } sort { $a <=> $b } keys %{$self->{'_order'}} ) { push(@arr,$self->{'_elem'}{$seqID}{'_seq'}); } return @arr; } =head2 each_alphabetically Title : each_alphabetically Usage : foreach $seq ( $contig->each_alphabetically() ) Function : Returns an array of sequence object sorted alphabetically by name and then by start point. Does not change the order of the alignment Returns : Argument : =cut sub each_alphabetically { my($self) = @_; $self->throw_not_implemented(); } =head2 each_seq_with_id Title : each_seq_with_id Usage : foreach $seq ( $contig->each_seq_with_id() ) Function : Gets an array of Seq objects from the alignment, the contents being those sequences with the given name (there may be more than one) Returns : an array Argument : a seq name =cut sub each_seq_with_id { my ($self) = @_; $self->throw_not_implemented(); } =head2 get_seq_by_pos Title : get_seq_by_pos Usage : $seq = $contig->get_seq_by_pos(3) Function : Gets a sequence based on its position in the alignment. Numbering starts from 1. Sequence positions larger than num_sequences() will thow an error. Returns : a Bio::LocatableSeq object Argument : positive integer for the sequence osition =cut sub get_seq_by_pos { my $self = shift; my ($pos) = @_; $self->throw("Sequence position has to be a positive integer, not [$pos]") unless $pos =~ /^\d+$/ and $pos > 0; $self->throw("No sequence at position [$pos]") unless $pos <= $self->num_sequences ; my $seqID = $self->{'_order'}->{--$pos}; return $self->{'_elem'}{$seqID}{'_seq'}; } =head2 Create new alignments The result of these methods are horizontal or vertical subsets of the current MSE. =head2 select Title : select Usage : $contig2 = $contig->select(1, 3) # three first sequences Function : Creates a new alignment from a continuous subset of sequences. Numbering starts from 1. Sequence positions larger than num_sequences() will thow an error. Returns : a Bio::Assembly::Contig object Argument : positive integer for the first sequence positive integer for the last sequence to include (optional) =cut sub select { my ($self) = @_; $self->throw_not_implemented(); } =head2 select_noncont Title : select_noncont Usage : $contig2 = $contig->select_noncont(1, 3) # first and 3rd sequences Function : Creates a new alignment from a subset of sequences. Numbering starts from 1. Sequence positions larger than num_sequences() will throw an error. Returns : a Bio::Assembly::Contig object Args : array of integers for the sequences =cut sub select_noncont { my ($self) = @_; $self->throw_not_implemented(); } =head2 slice Title : slice Usage : $contig2 = $contig->slice(20, 30) Function : Creates a slice from the alignment inclusive of start and end columns. Sequences with no residues in the slice are excluded from the new alignment and a warning is printed. Slice beyond the length of the sequence does not do padding. Returns : a Bio::Assembly::Contig object Argument : positive integer for start column positive integer for end column =cut sub slice { my ($self) = @_; $self->throw_not_implemented(); } =head2 Change sequences within the MSE These methods affect characters in all sequences without changeing the alignment. =head2 map_chars Title : map_chars Usage : $contig->map_chars('\.','-') Function : Does a s/$arg1/$arg2/ on the sequences. Useful for gap characters Notice that the from (arg1) is interpretted as a regex, so be careful about quoting meta characters (eg $contig->map_chars('.','-') wont do what you want) Returns : Argument : 'from' rexexp 'to' string =cut sub map_chars { my ($self) = @_; $self->throw_not_implemented(); } =head2 uppercase Title : uppercase() Usage : $contig->uppercase() Function : Sets all the sequences to uppercase Returns : Argument : =cut sub uppercase { my ($self) = @_; $self->throw_not_implemented(); } =head2 match_line Title : match_line() Usage : $contig->match_line() Function : Generates a match line - much like consensus string except that a line indicating the '*' for a match. Argument : (optional) Match line characters ('*' by default) (optional) Strong match char (':' by default) (optional) Weak match char ('.' by default) =cut sub match_line { my ($self) = @_; $self->throw_not_implemented(); } =head2 match Title : match() Usage : $contig->match() Function : Goes through all columns and changes residues that are identical to residue in first sequence to match '.' character. Sets match_char. USE WITH CARE: Most MSE formats do not support match characters in sequences, so this is mostly for output only. NEXUS format (Bio::AlignIO::nexus) can handle it. Returns : 1 Argument : a match character, optional, defaults to '.' =cut sub match { my ($self) = @_; $self->throw_not_implemented(); } =head2 unmatch Title : unmatch() Usage : $contig->unmatch() Function : Undoes the effect of method match. Unsets match_char. Returns : 1 Argument : a match character, optional, defaults to '.' =cut sub unmatch { my ($self) = @_; $self->throw_not_implemented(); } =head2 MSE attibutes Methods for setting and reading the MSE attributes. Note that the methods defining character semantics depend on the user to set them sensibly. They are needed only by certain input/output methods. Unset them by setting to an empty string (''). =head2 id Title : id Usage : $contig->id("Ig") Function : Gets/sets the id field of the alignment Returns : An id string Argument : An id string (optional) =cut sub id { my ($self, $contig_name) = @_; if (defined( $contig_name )) { $self->{'_id'} = $contig_name; } return $self->{'_id'}; } =head2 missing_char Title : missing_char Usage : $contig->missing_char("?") Function : Gets/sets the missing_char attribute of the alignment It is generally recommended to set it to 'n' or 'N' for nucleotides and to 'X' for protein. Returns : An missing_char string, Argument : An missing_char string (optional) =cut sub missing_char { my ($self) = @_; $self->throw_not_implemented(); } =head2 match_char Title : match_char Usage : $contig->match_char('.') Function : Gets/sets the match_char attribute of the alignment Returns : An match_char string, Argument : An match_char string (optional) =cut sub match_char { my ($self) = @_; $self->throw_not_implemented(); } =head2 gap_char Title : gap_char Usage : $contig->gap_char('-') Function : Gets/sets the gap_char attribute of the alignment Returns : An gap_char string, defaults to '-' Argument : An gap_char string (optional) =cut sub gap_char { my ($self) = @_; $self->throw_not_implemented(); } =head2 symbol_chars Title : symbol_chars Usage : my @symbolchars = $contig->symbol_chars; Function: Returns all the seen symbols (other than gaps) Returns : array of characters that are the seen symbols Argument: boolean to include the gap/missing/match characters =cut sub symbol_chars{ my ($self) = @_; $self->throw_not_implemented(); } =head2 Alignment descriptors These read only methods describe the MSE in various ways. =head2 consensus_string Title : consensus_string Usage : $str = $contig->consensus_string($threshold_percent) Function : Makes a strict consensus Returns : Argument : Optional threshold ranging from 0 to 100. The consensus residue has to appear at least threshold % of the sequences at a given location, otherwise a '?' character will be placed at that location. (Default value = 0%) =cut sub consensus_string { my ($self) = @_; $self->throw_not_implemented(); } =head2 consensus_iupac Title : consensus_iupac Usage : $str = $contig->consensus_iupac() Function : Makes a consensus using IUPAC ambiguity codes from DNA and RNA. The output is in upper case except when gaps in a column force output to be in lower case. Note that if your alignment sequences contain a lot of IUPAC ambiquity codes you often have to manually set alphabet. Bio::PrimarySeq::_guess_type thinks they indicate a protein sequence. Returns : consensus string Argument : none Throws : on protein sequences =cut sub consensus_iupac { my ($self) = @_; $self->throw_not_implemented(); } =head2 is_flush Title : is_flush Usage : if( $contig->is_flush() ) : : Function : Tells you whether the alignment : is flush, ie all of the same length : : Returns : 1 or 0 Argument : =cut sub is_flush { my ($self) = @_; $self->throw_not_implemented(); } =head2 length Title : length() Usage : $len = $contig->length() Function : Returns the maximum length of the alignment. To be sure the alignment is a block, use is_flush Returns : Argument : =cut sub length { my ($self) = @_; $self->throw_not_implemented(); } =head2 maxname_length Title : maxname_length Usage : $contig->maxname_length() Function : Gets the maximum length of the displayname in the alignment. Used in writing out various MSE formats. Returns : integer Argument : =cut sub maxname_length { my ($self) = @_; $self->throw_not_implemented(); } =head2 num_residues Title : num_residues Usage : $no = $contig->num_residues Function : number of residues in total in the alignment Returns : integer Argument : Note : replaces no_residues =cut sub num_residues { my ($self) = @_; return $self->{'_nof_residues'}; } =head2 num_sequences Title : num_sequences Usage : $depth = $contig->num_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : None Note : replaces no_sequences =cut sub num_sequences { my ($self) = @_; return scalar( keys %{ $self->{'_elem'} } ); } =head2 percentage_identity Title : percentage_identity Usage : $id = $contig->percentage_identity Function: The function calculates the percentage identity of the alignment Returns : The percentage identity of the alignment (as defined by the implementation) Argument: None =cut sub percentage_identity{ my ($self) = @_; $self->throw_not_implemented(); } =head2 overall_percentage_identity Title : percentage_identity Usage : $id = $contig->percentage_identity Function: The function calculates the percentage identity of the conserved columns Returns : The percentage identity of the conserved columns Args : None =cut sub overall_percentage_identity{ my ($self) = @_; $self->throw_not_implemented(); } =head2 average_percentage_identity Title : average_percentage_identity Usage : $id = $contig->average_percentage_identity Function: The function uses a fast method to calculate the average percentage identity of the alignment Returns : The average percentage identity of the alignment Args : None =cut sub average_percentage_identity { my ($self) = @_; $self->throw_not_implemented(); } =head2 Alignment positions Methods to map a sequence position into an alignment column and back. column_from_residue_number() does the former. The latter is really a property of the sequence object and can done using L: # select somehow a sequence from the alignment, e.g. my $seq = $contig->get_seq_by_pos(1); #$loc is undef or Bio::LocationI object my $loc = $seq->location_from_column(5); =head2 column_from_residue_number Title : column_from_residue_number Usage : $col = $contig->column_from_residue_number( $seqname, $resnumber) Function: This function gives the position in the alignment (i.e. column number) of the given residue number in the sequence with the given name. For example, for the alignment Seq1/91-97 AC..DEF.GH Seq2/24-30 ACGG.RTY.. Seq3/43-51 AC.DDEFGHI column_from_residue_number( "Seq1", 94 ) returns 5. column_from_residue_number( "Seq2", 25 ) returns 2. column_from_residue_number( "Seq3", 50 ) returns 9. An exception is thrown if the residue number would lie outside the length of the aligment (e.g. column_from_residue_number( "Seq2", 22 ) Note: If the the parent sequence is represented by more than one alignment sequence and the residue number is present in them, this method finds only the first one. Returns : A column number for the position in the alignment of the given residue in the given sequence (1 = first column) Args : A sequence id/name (not a name/start-end) A residue number in the whole sequence (not just that segment of it in the alignment) =cut sub column_from_residue_number { my ($self) = @_; $self->throw_not_implemented(); } =head2 Sequence names Methods to manipulate the display name. The default name based on the sequence id and subsequence positions can be overridden in various ways. =head2 displayname Title : displayname Usage : $contig->displayname("Ig", "IgA") Function : Gets/sets the display name of a sequence in the alignment : Returns : A display name string Argument : name of the sequence displayname of the sequence (optional) =cut sub displayname { # Do nothing } =head2 set_displayname_count Title : set_displayname_count Usage : $contig->set_displayname_count Function : Sets the names to be name_# where # is the number of times this name has been used. Returns : None Argument : None =cut sub set_displayname_count { my ($self) = @_; $self->throw_not_implemented(); } =head2 set_displayname_flat Title : set_displayname_flat Usage : $contig->set_displayname_flat() Function : Makes all the sequences be displayed as just their name, not name/start-end Returns : 1 Argument : None =cut sub set_displayname_flat { # Do nothing! } =head2 set_displayname_normal Title : set_displayname_normal Usage : $contig->set_displayname_normal() Function : Makes all the sequences be displayed as name/start-end Returns : None Argument : None =cut sub set_displayname_normal { # Do nothing! } =head1 Internal Methods =head2 _binary_search Title : _binary_search Usage : _binary_search($list,$query) Function : Find a number in a sorted list of numbers. Return values may be on or two integers. One positive integer or zero (>=0) is the index of the element that stores the queried value. Two positive integers (or zero and another number) are the indexes of elements among which the queried value should be placed. Negative single values mean: -1: $query is smaller than smallest element in list -2: $query is greater than greatest element in list Returns : array of integers Argument : $list : array reference $query : integer =cut sub _binary_search { my $list = shift; my $query = shift; # # If there is only one element in list if (!$#{$list} && ($query == $list->[0])) { return (0) } # If there are others... my $start = 0; my $end = $#{$list}; (&_compare($query,$list->[$start]) == 0) && do { return ($start) }; (&_compare($query,$list->[$end]) == 0) && do { return ($end) }; (&_compare($query,$list->[$start]) < 0) && do { return (-1) }; (&_compare($query,$list->[$end]) > 0) && do { return (-2) }; my $middle = 0; while ($end - $start > 1) { $middle = int(($end+$middle)/2); (&_compare($query,$list->[$middle]) == 0) && return ($middle); (&_compare($query,$list->[$middle]) < 0) && do { $end = $middle ; $middle = 0; next }; $start = $middle; # If &_compare() > 0, move region beggining } return ($start,$end); } =head2 _compare Title : _compare Usage : _compare($arg1,$arg2) Function: Perform numeric or string comparisons Returns : integer (0, 1 or -1) Args : values to be compared =cut sub _compare { my $arg1 = shift; my $arg2 = shift; # if (($arg1 =~ /^\d+$/) && ($arg2 =~ /^\d+$/)) { return $arg1 <=> $arg2 } else { return $arg1 cmp $arg2 } } =head2 _nof_gaps Title : _nof_gaps Usage : _nof_gaps($array_ref, $query) Function: number of gaps found before position $query Returns : integer Args : $array_ref : gap registry reference $query : [integer] a position in a sequence =cut #' emacs... sub _nof_gaps { my $list = shift; my $query = shift; # If there are no gaps in this contig return 0 unless (defined($list) && scalar(@{$list})); # Locate query index in gap list (if any) my @index = &_binary_search($list,$query); # If after all alignments, correct using total number of align if ($index[0] == -2) { $query = scalar(@{$list}) } # If before any alignment, return 0 elsif ($index[0] == -1) { $query = 0 } elsif ($index[0] >= 0) { # If query is between alignments, translate coordinates if ($#index > 0) { $query = $index[0] + 1 } # If query sits upon an alignment, do another correction elsif ($#index == 0) { $query = $index[0] } } # return $query; } =head2 _padded_unpadded Title : _padded_unpadded Usage : _padded_unpadded($array_ref, $query) Function: Returns a coordinate corresponding to position $query after gaps were removed from a sequence. Returns : integer Args : $array_ref : reference to this gap registry $query : [integer] coordionate to change =cut sub _padded_unpadded { my $list = shift; my $query = shift; my $align = &_nof_gaps($list,$query); $query-- if (defined($list->[$align]) && ($list->[$align] == $query)); $query = $query - $align; # return $query; } =head2 _unpadded_padded Title : _unpadded_padded Usage : _unpadded_padded($array_ref, $query) Function: Returns the value corresponding to ungapped position $query when gaps are counted as valid sites in a sequence Returns : Args : $array_ref = a reference to this sequence's gap registry $query = [integer] location to change =cut #' sub _unpadded_padded { my $list = shift; my $query = shift; my $align = &_nof_gaps($list,$query); $query = $query + $align; my $new_align = &_nof_gaps($list,$query); while ($new_align - $align > 0) { $query = $query + $new_align - $align; $align = $new_align; $new_align = &_nof_gaps($list,$query); } # If current position is also a align, look for the first upstream base while (defined($list->[$align]) && ($list->[$align] == $query)) { $query++; $align++; } # return $query; } =head2 _register_gaps Title : _register_gaps Usage : $self->_register_gaps($seq, $array_ref) Function: stores gap locations for a sequence Returns : number of gaps found Args : $seq : sequence string $array_ref : a reference to an array, where gap locations will be stored =cut sub _register_gaps { my $self = shift; my $sequence = shift; my $dbref = shift; $self->throw("Not an aligned sequence string to register gaps") if (ref($sequence)); $self->throw("Not an array reference for gap registry") unless (ref($dbref) eq 'ARRAY'); # Registering alignments @{$dbref} = (); # Cleaning registry if (defined $sequence) { my $i = -1; while(1) { $i = index($sequence,"-",$i+1); last if ($i == -1); push(@{$dbref},$i+1); } } else { # $self->warn("Found undefined sequence while registering gaps"); return 0; } return scalar(@{$dbref}); } =head1 Deprecated methods =cut =head2 no_residues Title : no_residues Usage : $no = $ali->no_residues Function : number of residues in total in the alignment Returns : integer Argument : Note : deprecated in favor of num_residues() =cut sub no_residues { my $self = shift; $self->deprecated(-warn_version => 1.0069, -throw_version => 1.0075); $self->num_residues(@_); } =head2 no_sequences Title : no_sequences Usage : $depth = $ali->no_sequences Function : number of sequence in the sequence alignment Returns : integer Argument : Note : deprecated in favor of num_sequences() =cut sub no_sequences { my $self = shift; $self->deprecated(-warn_version => 1.0069, -throw_version => 1.0075); $self->num_sequences(@_); } 1; BioPerl-1.6.923/Bio/Assembly/ContigAnalysis.pm000444000765000024 4412712254227340 21242 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::ContigAnalysis # # Please direct questions and support issues to # # Cared for by Robson francisco de Souza # # Copyright Robson Francisco de Souza # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::ContigAnalysis - Perform analysis on sequence assembly contigs. =head1 SYNOPSIS # Module loading use Bio::Assembly::ContigAnalysis; # Assembly loading methods my $ca = Bio::Assembly::ContigAnalysis->new( -contig=>$contigOBJ ); my @lcq = $ca->low_consensus_quality; my @hqd = $ca->high_quality_discrepancies; my @ss = $ca->single_strand_regions; =head1 DESCRIPTION A contig is as a set of sequences, locally aligned to each other, when the sequences in a pair may be aligned. It may also include a consensus sequence. Bio::Assembly::ContigAnalysis is a module holding a collection of methods to analyze contig objects. It was developed around the Bio::Assembly::Contig implementation of contigs and can not work with another contig interface. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Robson Francisco de Souza Email: rfsouza@citri.iq.usp.br =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Assembly::ContigAnalysis; use strict; use base qw(Bio::Root::Root); =head1 Object creator =head2 new Title : new Usage : my $contig = Bio::Assembly::ContigAnalysis->new(-contig=>$contigOBJ); Function : Creates a new contig analysis object Returns : Bio::Assembly::ContigAnalysis Args : -contig : a Bio::Assembly::Contig object =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($contigOBJ) = $self->_rearrange([qw(CONTIG)],@args); unless ($contigOBJ->isa("Bio::Assembly::Contig")) { $self->throw("ContigAnal works only on Bio::Assembly::Contig objects\n"); } $self->{'_objref'} = $contigOBJ; return $self; } =head1 Analysis methods =head2 high_quality_discrepancies Title : high_quality_discrepancies Usage : my $sfc = $ContigAnal->high_quality_discrepancies(); Function : Locates all high quality discrepancies among aligned sequences and the consensus sequence. Note: see Bio::Assembly::Contig POD documentation, section "Coordinate System", for a definition of available types. Default coordinate system type is "gapped consensus", i.e. consensus sequence (with gaps) coordinates. If limits are not specified, the entire alignment is analyzed. Returns : Bio::SeqFeature::Collection Args : optional arguments are -threshold : cutoff value for low quality (minimum high quality) Default: 40 -ignore : number of bases that will not be analysed at both ends of contig aligned elements Default: 5 -start : start of interval that will be analyzed -end : start of interval that will be analyzed -type : coordinate system type for interval =cut sub high_quality_discrepancies { my ($self,@args) = shift; # Package reference my ($threshold,$ignore,$start,$end,$type) = $self->_rearrange([qw(THRESHOLD IGNORE START END TYPE)],@args); # Defining default threhold and HQD_ignore $threshold = 40 unless (defined($threshold)); $ignore = 5 unless (defined($ignore)); $type = 'gapped consensus' unless (defined($type)); # Changing input coordinates system (if needed) if (defined $start && $type ne 'gapped consensus') { $start = $self->{'_objref'}->change_coord($type,'gapped consensus',$start); } elsif (!defined $start) { $start = 1; } if (defined $end && $type ne 'gapped consensus') { $end = $self->{'_objref'}->change_coord($type,'gapped consensus',$end); } elsif (!defined $end) { $end = $self->{'_objref'}->get_consensus_length(); } # Scanning each read sequence and the contig sequence and # adding discrepancies to Bio::SeqFeature::Collection my @seqIDs = $self->{'_objref'}->get_seq_ids(-start=>$start, -end=>$end, -type=>$type); my $consensus = $self->{'_objref'}->get_consensus_sequence()->seq; my @HQD = (); foreach my $seqID (@seqIDs) { # Setting aligned read sub-sequence limits and loading data my $seq = $self->{'_objref'}->get_seq_by_name($seqID); my $qual = $self->{'_objref'}->get_qual_by_name($seqID); unless (defined $qual) { $self->warn("Can't correctly evaluate HQD without aligned sequence qualities for $seqID"); next; } my $sequence = $seq->seq; my @quality = @{ $qual->qual }; # Scanning the aligned region of each read my $seq_ix = 0; my $coord = $self->{'_objref'}->get_seq_feat_by_tag($seq,"_align_clipping:$seqID"); if (!$coord) { $self->warn("Read $seqID has no alignment coordinates; considered low quality.\nSkipping..."); next; } my ($astart,$aend) = ($coord->start,$coord->end); $astart = $astart + $ignore; # Redefining limits to evaluate HQDs (jump $ignore at start) $aend = $aend - $ignore; # Redefining limits to evaluate HQDs (stop $ignore before end) my ($d_start,$d_end,$i); for ($i=$astart-1; $i<=$aend-1; $i++) { # Changing coordinate $i+1 from 'gapped consensus' mode to "aligned $seqID" (coordinate $seq_ix) $seq_ix = $self->{'_objref'}->change_coord('gapped consensus',"aligned $seqID",$i+1); next unless (($i >= $start) && ($i <= $end)); my $r_base = uc(substr($sequence,$seq_ix-1,1)); my $c_base = uc(substr($consensus,$i,1)); # Discrepant region start: store $d_start and $type (!defined($d_start) && ($r_base ne $c_base) && ($quality[$seq_ix-1] >= $threshold)) && do { $d_start = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i+1); #print $seqID," ",$r_base," ",$i+1," ",$c_base," ",$contig_ix-1," ",$quality[$i]," $type\n"; next; }; # Quality change or end of discrepant region: store limits and undef $d_start if (defined($d_start) && (($quality[$seq_ix-1] < $threshold) || (uc($r_base) eq uc($c_base)))) { $d_end = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i); #print $seqID," ",$r_base," ",$i+1," ",$c_base," ",$contig_ix-1," ",$quality[$i]," $type\n"; push(@HQD, Bio::SeqFeature::Generic->new(-primary=>"high_quality_discrepancy:$seqID", -start=>$d_start, -end=>$d_end, -strand=>$seq->strand()) ); $d_start = undef; next; } } # for ($i=$astart-1; $i<=$aend-1; $i++) # Loading discrepancies located at sub-sequence end, if any. if (defined($d_start)) { $d_end = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i); push(@HQD, Bio::SeqFeature::Generic->new(-primary=>"high_quality_discrepancy:$seqID", -start=>$d_start, -end=>$d_end, -strand=>$seq->strand()) ); } } # foreach my $seqID (@seqIDs) return @HQD; } =head2 low_consensus_quality Title : low_consensus_quality Usage : my $sfc = $ContigAnal->low_consensus_quality(); Function : Locates all low quality regions in the consensus Returns : an array of Bio::SeqFeature::Generic objects Args : optional arguments are -threshold : cutoff value for low quality (minimum high quality) Default: 25 -start : start of interval that will be analyzed -end : start of interval that will be analyzed -type : coordinate system type for interval =cut sub low_consensus_quality { my ($self,@args) = shift; # Packege reference my ($threshold,$start,$end,$type) = $self->_rearrange([qw(THRESHOLD START END TYPE)],@args); # Setting default value for threshold $threshold = 25 unless (defined($threshold)); # Loading qualities my @quality = @{ $self->{'_objref'}->get_consensus_quality()->qual }; # Changing coordinates to gap mode noaln (consed: consensus without alignments) $start = 1 unless (defined($start)); if (defined $start && defined $type && ($type ne 'gapped consensus')) { $start = $self->{'objref'}->change_coord($type,'gapped consensus',$start); $end = $self->{'objref'}->change_coord($type,'gapped consensus',$end) if (defined($end)); } $end = $self->{'_objref'}->get_consensus_length unless (defined $end); # Scanning @quality vector and storing intervals limits with base qualities less then # the threshold value my ($lcq_start); my ($i,@LCQ); for ($i=$start-1; $i<=$end-1; $i++) { # print $quality[$i],"\t",$i,"\n"; if (!defined($lcq_start) && (($quality[$i] <= $threshold) || ($quality[$i] == 98))) { $lcq_start = $i+1; } elsif (defined($lcq_start) && ($quality[$i] > $threshold)) { $lcq_start = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$lcq_start); my $lcq_end = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i); push(@LCQ, Bio::SeqFeature::Generic->new(-start=>$lcq_start, -end=>$lcq_end, -primary=>'low_consensus_quality') ); $lcq_start = undef; } } if (defined $lcq_start) { $lcq_start = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$lcq_start); my $lcq_end = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i); push(@LCQ, Bio::SeqFeature::Generic->new(-start=>$lcq_start, -end=>$lcq_end, -primary=>'low_consensus_quality') ); } return @LCQ; } =head2 not_confirmed_on_both_strands Title : low_quality_consensus Usage : my $sfc = $ContigAnal->low_quality_consensus(); Function : Locates all regions whose consensus bases were not confirmed by bases from sequences aligned in both orientations, i.e., in such regions, no bases in aligned sequences of either +1 or -1 strand agree with the consensus bases. Returns : an array of Bio::SeqFeature::Generic objects Args : optional arguments are -start : start of interval that will be analyzed -end : start of interval that will be analyzed -type : coordinate system type for interval =cut sub not_confirmed_on_both_strands { my ($self,@args) = shift; # Package reference my ($start,$end,$type) = $self->_rearrange([qw(START END TYPE)],@args); # Changing coordinates to default system 'align' (contig sequence with alignments) $start = 1 unless (defined($start)); if (defined($type) && ($type ne 'gapped consensus')) { $start = $self->{'_objref'}->change_coord($type,'gapped consensus',$start); $end = $self->{'_objref'}->change_coord($type,'gapped consensus',$end) if (defined($end)); } $end = $self->{'_objref'}->get_consensus_length unless (defined($end)); # Scanning alignment my %confirmed = (); # If ($confirmed{$orientation}[$i] > 0) then $i is confirmed in $orientation strand my ($i); my $consensus = $self->{'_objref'}->get_consensus_sequence()->seq; foreach my $seqID ($self->{'_objref'}->get_seq_ids) { # Setting aligned read sub-sequence limits and loading data my $seq = $self->{'_objref'}->get_seq_by_name($seqID); my $sequence = $seq->seq; # Scanning the aligned regions of each read and registering confirmed sites my $contig_ix = 0; my $coord = $self->{'_objref'}->get_seq_feat_by_tag($seq,"_align_clipping:$seqID"); my ($astart,$aend,$orientation) = ($coord->start,$coord->end,$coord->strand); $astart = $self->{'_objref'}->change_coord('gapped consensus',"aligned $seqID",$astart); $aend = $self->{'_objref'}->change_coord('gapped consensus',"aligned $seqID",$aend); for ($i=$astart-1; $i<=$aend-1; $i++) { # $i+1 in 'align' mode is $contig_ix $contig_ix = $self->{'_objref'}->change_coord("aligned $seqID",'gapped consensus',$i+1); next unless (($contig_ix >= $start) && ($contig_ix <= $end)); my $r_base = uc(substr($sequence,$i,1)); my $c_base = uc(substr($consensus,$contig_ix-1,1)); if ($c_base eq '-') { $confirmed{$orientation}[$contig_ix] = -1; } elsif (uc($r_base) eq uc($c_base)) { # Non discrepant region found $confirmed{$orientation}[$contig_ix]++; } } # for ($i=$astart-1; $i<=$aend-1; $i++) } # foreach $seqID (@reads) # Locating non-confirmed aligned regions for each orientation in $confirmed registry my ($orientation); my @NCBS = (); foreach $orientation (keys %confirmed) { my ($ncbs_start,$ncbs_end); for ($i=$start; $i<=$end; $i++) { if (!defined($ncbs_start) && (!defined($confirmed{$orientation}[$i]) || ($confirmed{$orientation}[$i] == 0))) { $ncbs_start = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i); } elsif (defined($ncbs_start) && defined($confirmed{$orientation}[$i]) && ($confirmed{$orientation}[$i] > 0)) { $ncbs_end = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$i-1); push(@NCBS, Bio::SeqFeature::Generic->new(-start=>$ncbs_start, -end=>$ncbs_end, -strand=>$orientation, -primary=>"not_confirmed_on_both_strands") ); $ncbs_start = undef; } } if (defined($ncbs_start)) { # NCBS at the end of contig $ncbs_end = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$end); push(@NCBS, Bio::SeqFeature::Generic->new(-start=>$ncbs_start, -end=>$ncbs_end, -strand=>$orientation, -primary=>'not_confirmed_on_both_strands') ); } } return @NCBS; } =head2 single_strand Title : single_strand Usage : my $sfc = $ContigAnal->single_strand(); Function : Locates all regions covered by aligned sequences only in one of the two strands, i.e., regions for which aligned sequence's strand() method returns +1 or -1 for all sequences. Returns : an array of Bio::SeqFeature::Generic objects Args : optional arguments are -start : start of interval that will be analyzed -end : start of interval that will be analyzed -type : coordinate system type for interval =cut #' sub single_strand { my ($self,@args) = shift; # Package reference my ($start,$end,$type) = $self->_rearrange([qw(START END TYPE)],@args); # Changing coordinates to gap mode align (consed: consensus sequence with alignments) $type = 'gapped consensus' unless(defined($type)); $start = 1 unless (defined($start)); if (defined($type) && $type ne 'gapped consensus') { $start = $self->{'objref'}->change_coord($type,'gapped consensus',$start); $end = $self->{'objref'}->change_coord($type,'gapped consensus',$end) if (defined($end)); } ($end) = $self->{'_objref'}->get_consensus_length unless (defined($end)); # Loading complete list of coordinates for aligned sequences my $sfc = $self->{'_objref'}->get_features_collection(); my @forward = grep { $_->primary_tag =~ /^_aligned_coord:/ } $sfc->features_in_range(-start=>$start, -end=>$end, -contain=>0, -strand=>1, -strandmatch=>'strong'); my @reverse = grep { $_->primary_tag =~ /^_aligned_coord:/ } $sfc->features_in_range(-start=>$start, -end=>$end, -contain=>0, -strand=>-1, -strandmatch=>'strong'); # Merging overlapping features @forward = $self->_merge_overlapping_features(@forward); @reverse = $self->_merge_overlapping_features(@reverse); # Finding single stranded regions my ($length) = $self->{'_objref'}->get_consensus_length; $length = $self->{'_objref'}->change_coord('gapped consensus','ungapped consensus',$length); @forward = $self->_complementary_features_list(1,$length,@forward); @reverse = $self->_complementary_features_list(1,$length,@reverse); my @SS = (); foreach my $feat (@forward, @reverse) { $feat->primary_tag('single_strand_region'); push(@SS,$feat); } return @SS; } =head1 Internal Methods =head2 _merge_overlapping_features Title : _merge_overlapping_features Usage : my @feat = $ContigAnal->_merge_overlapping_features(@features); Function : Merge all overlapping features into features that hold original features as sub-features Returns : array of Bio::SeqFeature::Generic objects Args : array of Bio::SeqFeature::Generic objects =cut sub _merge_overlapping_features { my ($self,@feat) = @_; $self->throw_not_implemented(); } =head2 _complementary_features_list Title : _complementary_features_list Usage : @feat = $ContigAnal->_complementary_features_list($start,$end,@features); Function : Build a list of features for regions not covered by features in @features array Returns : array of Bio::SeqFeature::Generic objects Args : $start : [integer] start of first output feature $end : [integer] end of last output feature @features : array of Bio::SeqFeature::Generic objects =cut sub _complementary_features_list { my ($self,$start,$end,@feat) = @_; $self->throw_not_implemented(); } 1; __END__ BioPerl-1.6.923/Bio/Assembly/IO.pm000444000765000024 2272512254227325 16625 0ustar00cjfieldsstaff000000000000# $Id: IO.pm 16690 2010-01-14 07:27:29Z kortsch $ # # BioPerl module for Bio::Assembly::IO # # based on the Bio::SeqIO module # by Ewan Birney # and Lincoln Stein # # Copyright Robson Francisco de Souza # # You may distribute this module under the same terms as perl itself # # _history # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO - Handler for Assembly::IO Formats =head1 SYNOPSIS use Bio::Assembly::IO; $in = Bio::Assembly::IO->new(-file=>"'phrap'); $out = Bio::Assembly::IO->new(-file=>">outputfilename", -format=>'phrap'); 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 (e.g. Bio::Assembly::IO::phrap). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Robson Francisco de Souza E-mail: rfsouza@citri.iq.usp.br =head1 CONTRIBUTORS # =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Assembly::IO; use strict; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : $stream = Bio::Assembly::IO->new( -file => $filename, -format =>'format' ) Function: Returns a new assembly stream Returns : A Bio::Assembly::IO::Handler initialised with the appropriate format Args : -file => $filename -format => format =cut sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::Assembly::IO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys $class->throw("Need at least a file name to proceed!") unless (defined $param{'-file'} || defined $ARGV[0]); my $format = $param{'-format'} || $class->_guess_format( $param{-file} || $ARGV[0] ); $format = "\L$format"; # normalize capitalization to lower case if ($format =~ /-/) { ($format, my $variant) = split('-', $format, 2); push @args, (-variant => $variant); } return unless( $class->_load_format_module($format) ); return "Bio::Assembly::IO::$format"->new(@args); } } =head2 format Title : format Usage : $format = $stream->format() Function: Get the assembly format Returns : assembly format Args : none =cut # format() method inherited from Bio::Root::IO # _initialize is chained for all SeqIO classes sub _initialize { my($self, @args) = @_; # initialize the IO part $self->_initialize_io(@args); } =head2 next_assembly Title : next_assembly Usage : $scaffold = $stream->next_assembly() Function: Reads the next assembly object from the stream and returns it. Returns : a Bio::Assembly::ScaffoldI compliant object Args : none =cut sub next_assembly { my ($self) = @_; $self->throw("Cannot read from a generic Bio::Assembly::IO object."); } =head2 next_contig Title : next_contig Usage : $contig = $stream->next_contig() Function: Reads the next contig or singlet from the stream and returns it. Returns : a Bio::Assembly::Contig or Bio::Contig::Assembly::Singlet Args : none =cut sub next_contig { my ($self) = @_; $self->throw("Cannot read from a generic Bio::Assembly::IO object."); } =head2 write_assembly Title : write_assembly Usage : $stream->write_assembly($assembly) Function: Write the assembly object in desired format. This method calls write_header(), write_contigs() and write_footer() internally. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object =cut sub write_assembly { my ($self, @args) = @_; my ($scaf, $write_singlets) = $self->_rearrange([qw(SCAFFOLD SINGLETS)], @args); # Sanity check if ( !$scaf || !$scaf->isa('Bio::Assembly::ScaffoldI') ) { $self->throw("Must provide a Bio::Assembly::Scaffold object when calling write_assembly"); } # Write header $self->write_header($scaf); # ID-sorted contig and read entries my @contig_ids = $scaf->get_contig_ids; if ($write_singlets) { push @contig_ids, $scaf->get_singlet_ids; } @contig_ids = _sort(@contig_ids); # Write contigs for my $contig_id ( @contig_ids ) { my $contig = $scaf->get_contig_by_id($contig_id) || $scaf->get_singlet_by_id($contig_id); $self->write_contig($contig); } # Write footer $self->write_footer($scaf); return 1; } =head2 write_header Title : write_header Usage : $stream->write_header($assembly) Function: Write the start of the assembly file. It can be called at any time, not when starting to write the assembly file. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object or ... (check the specific format driver for more details) =cut sub write_header { my ($self) = @_; $self->throw("Cannot write from a generic Bio::Assembly::IO object."); } =head2 write_contig Title : write_contig Usage : $stream->write_contig($contig) Function: Write a contig object in the desired format. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Contig object =cut sub write_contig { my ($self) = @_; $self->throw("Cannot write from a generic Bio::Assembly::IO object."); } =head2 write_footer Title : write_footer Usage : $stream->write_footer($assembly) Function: Write the start of the assembly file. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object or ... (check the specific format driver for more details) =cut sub write_footer { my ($self) = @_; $self->throw("Cannot write from a generic Bio::Assembly::IO object."); } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL Assembly::IO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::Assembly::IO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Function: guess format based on file suffix Example : Returns : guessed format of filename (lower case) Args : Notes : formats that _filehandle() will guess includes ace, phrap and tigr at the moment =cut sub _guess_format { my $class = shift; my $arg = shift; return unless defined($arg); return 'ace' if ($arg =~ /\.ace/i); return 'phrap' if ($arg =~ /\.phrap/i); return 'tigr' if ($arg =~ /\.tigr/i); return 'maq' if ($arg =~ /\.maq/i); return 'sam' if ($arg =~ /\.[bs]am/i); return 'bowtie' if ($arg =~ /\.bowtie/i); } =head2 _sort Title : _sort Usage : @sorted_values = $ass_io->_sort(@values) Function: Sort a list of values naturally if Sort::Naturally is installed (nicer), lexically otherwise (not as nice, but safe) Returns : array of sorted values Args : array of values to sort =cut sub _sort { my @arr = @_; my @sorted_arr; if (eval { require Sort::Naturally }) { @sorted_arr = Sort::Naturally::nsort( @arr ); # natural sort (better) } else { @sorted_arr = sort @arr; # lexical sort (safe) } return @sorted_arr; } sub DESTROY { my $self = shift; $self->close(); } # I need some direction on these!! The module works so I haven't fiddled with them! # Me neither! (rfsouza) sub TIEHANDLE { my ($class,$val) = @_; return bless {'seqio' => $val}, $class; } sub READLINE { my $self = shift; return $self->{'seqio'}->next_seq() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'seqio'}->next_seq(); return @list; } sub PRINT { my $self = shift; $self->{'seqio'}->write_seq(@_); } 1; BioPerl-1.6.923/Bio/Assembly/Scaffold.pm000444000765000024 4452112254227316 20035 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::Scaffold # # Copyright by Robson F. de Souza # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::Scaffold - Perl module to hold and manipulate sequence assembly data. =head1 SYNOPSIS # # Module loading use Bio::Assembly::IO; # Assembly loading methods my $aio = Bio::Assembly::IO->new(-file=>"test.ace.1", -format=>'phrap'); my $assembly = $aio->next_assembly; foreach my $contig ($assembly->all_contigs) { # do something... (see Bio::Assembly::Contig) } =head1 DESCRIPTION Bio::Assembly::Scaffold was developed to store and manipulate data from sequence assembly programs like Phrap. It implements the ScaffoldI interface and intends to be generic enough to be used by Bio::Assembly::IO drivers written to programs other than Phrap. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Robson Francisco de Souza rfsouza@citri.iq.usp.br =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Assembly::Scaffold; use strict; use Bio::Annotation::Collection; use base qw(Bio::Root::Root Bio::Assembly::ScaffoldI); =head2 new () Title : new Usage : $scaffold = new ( -id => "assembly 1", -source => 'program_name', -contigs => \@contigs, -singlets => \@singlets ); Function: creates a new scaffold object Returns : Bio::Assembly::Scaffold Args : -id : [string] scaffold name -source : [string] sequence assembly program -contigs : reference to array of Bio::Assembly::Contig objects -singlets : reference to array of Bio::Assembly::Singlet objects =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($id, $src, $contigs, $singlets) = $self->_rearrange( [qw(ID SOURCE CONTIGS SINGLETS)], @args); # Scaffold defaults $self->{'_id'} = 'NoName'; $self->{'_source'} = 'Unknown'; $self->{'_contigs'} = {}; $self->{'_singlets'} = {}; $self->{'_seqs'} = {}; $self->{'_annotation'} = Bio::Annotation::Collection->new(); # Import manual info $self->{'_id'} = $id if (defined $id); $self->{'_source'} = $src if (defined $src); # Add contigs and singlets to scaffold if (defined $contigs && ref($contigs = 'ARRAY')) { for my $contig (@{$contigs}) { if( ! ref $contig || ! $contig->isa('Bio::Assembly::Contig') ) { $self->throw("Bio::Assembly::Scaffold::new is unable to process non". "Bio::Assembly::Contig object [", ref($contig), "]"); } $self->add_contig($contig); } } if (defined $singlets && ref($singlets = 'ARRAY')) { for my $singlet (@{$singlets}) { if( ! ref $singlet || ! $singlet->isa('Bio::Assembly::Singlet') ) { $self->throw("Bio::Assembly::Scaffold::new is unable to process non". "Bio::Assembly::Singlet object [", ref($singlet), "]"); } $self->add_singlet($singlet); } } return $self; } =head1 Accessing general assembly data =cut =head2 id Title : id Usage : $assembly->id() Function: Get/Set assembly ID Returns : string or undef Args : string =cut sub id { my ($self, $id) = @_; return $self->{'_id'} = $id if (defined $id); return $self->{'_id'}; } =head2 annotation Title : annotation Usage : $assembly->annotation() Function: Get/Set assembly annotation object Returns : Bio::Annotation::Collection Args : none =cut sub annotation { my ($self, $ref) = shift; $self->{'_annotation'} = $ref if (defined $ref); return $self->{'_annotation'}; } =head2 get_nof_contigs Title : get_nof_contigs Usage : $assembly->get_nof_contigs() Function: Get the number of contigs included in the scaffold Returns : integer Args : none =cut sub get_nof_contigs { my $self = shift; return scalar( $self->get_contig_ids() ); } =head2 get_nof_contig_seqs Title : get_nof_contig_seqs Usage : $assembly->get_nof_contig_seqs() Function: Get the number of sequences included in contigs of the scaffold (no consensus sequences or singlets) Returns : integer Args : none =cut sub get_nof_contig_seqs { my $self = shift; my $nof_seqs = 0; foreach my $contig ($self->all_contigs) { $nof_seqs += scalar( $contig->get_seq_ids() ); } return $nof_seqs; } # function alias for backward compatibility *get_nof_sequences_in_contigs = \&get_nof_contig_seqs; =head2 get_nof_singlets (get_nof_singlet_seqs) Title : nof_singlets Usage : $assembly->nof_singlets() Function: Get the number of singlets included in the assembly Returns : integer Args : none =cut sub get_nof_singlets { my $self = shift; return scalar( $self->get_singlet_ids() ); } *get_nof_singlet_seqs = \&get_nof_singlets; =head2 get_all_seq_ids Title : get_all_seq_ids Usage : $assembly->get_all_seq_ids() Function: Get the ID of all sequences making up the scaffold (sequences from contigs and singlets, not consensus). Returns : array of strings Args : none =cut sub get_all_seq_ids { my $self = shift; return keys %{ $self->{'_seqs'} }; } =head2 get_nof_seqs Title : get_nof_seqs Usage : $assembly->get_nof_seqs() Function: Get total number of sequences making up the scaffold (sequences from contigs and singlets, not consensus). Returns : integer Args : none =cut sub get_nof_seqs { my $self = shift; return scalar $self->get_all_seq_ids; } =head2 get_contig_seq_ids Title : get_contig_seq_ids Usage : $assembly->get_contig_seq_ids() Function: Get the ID of all sequences in contigs Returns : array of strings Args : none =cut sub get_contig_seq_ids { my $self = shift; my @ids; for my $contig ( $self->all_contigs ) { push @ids, $contig->get_seq_ids; } return @ids; } # function alias for backward compatibility *get_seq_ids = \&get_contig_seq_ids; =head2 get_contig_ids Title : get_contig_ids Usage : $assembly->get_contig_ids() Function: Access list of contig IDs from assembly Returns : an array, if there are any contigs in the assembly. An empty array otherwise Args : none =cut sub get_contig_ids { my $self = shift; return wantarray ? sort keys %{$self->{'_contigs'}} : scalar keys %{$self->{'_contigs'}}; } =head2 get_singlet_ids (get_singlet_seq_ids) Title : get_singlet_ids Usage : $assembly->get_singlet_ids() Function: Access list of singlet IDs from assembly Returns : array of strings if there are any singlets otherwise an empty array Args : none =cut sub get_singlet_ids { my $self = shift; return wantarray ? sort keys %{$self->{'_singlets'}} : scalar keys %{$self->{'_singlets'}}; } *get_singlet_seq_ids = \&get_singlet_ids; =head2 get_seq_by_id Title : get_seq_by_id Usage : $assembly->get_seq_by_id($id) Function: Get a reference for an sequence making up the scaffold (from a contig or singlet, not consensus) Returns : a Bio::LocatableSeq object undef if sequence $id is not found in the scaffold Args : [string] sequence identifier (id) =cut sub get_seq_by_id { my $self = shift; my $seqID = shift; return unless (exists $self->{'_seqs'}{$seqID}); return $self->{'_seqs'}{$seqID}->get_seq_by_name($seqID); } =head2 get_contig_by_id Title : get_contig_by_id Usage : $assembly->get_contig_by_id($id) Function: Get a reference for a contig Returns : a Bio::Assembly::Contig object or undef Args : [string] contig unique identifier (ID) =cut sub get_contig_by_id { my $self = shift; my $contigID = shift; return unless (exists $self->{'_contigs'}{$contigID}); return $self->{'_contigs'}{$contigID}; } =head2 get_singlet_by_id Title : get_singlet_by_id Usage : $assembly->get_singlet_by_id() Function: Get a reference for a singlet Returns : Bio::Assembly::Singlet object or undef Args : [string] a singlet ID =cut sub get_singlet_by_id { my $self = shift; my $singletID = shift; return unless (exists $self->{'_singlets'}{$singletID}); return $self->{'_singlets'}{$singletID}; } =head1 Modifier methods =cut =head2 add_contig Title : add_contig Usage : $assembly->add_contig($contig) Function: Add a contig to the assembly Returns : 1 on success Args : a Bio::Assembly::Contig object order (optional) =cut sub add_contig { my ($self, $contig) = @_; # Input check if( !ref $contig || ! $contig->isa('Bio::Assembly::Contig') ) { $self->throw("Bio::Assembly::Scaffold::add_contig is unable to process". " non Bio::Assembly::Contig object [", ref($contig), "]"); } # Create and attribute contig ID my $contigID = $contig->id(); if( !defined $contigID ) { $contigID = 'Unknown_' . ($self->get_nof_contigs() + 1); $contig->id($contigID); $self->warn("Attributing ID $contigID to unnamed Bio::Assembly::Contig". " object."); } # Adding contig to scaffold $self->warn("Replacing contig $contigID with a new contig object") if (exists $self->{'_contigs'}{$contigID}); $self->{'_contigs'}{$contigID} = $contig; $contig->assembly($self); # weak circular reference # Put contig sequences in the list of sequences belonging to the scaffold foreach my $seqID ($contig->get_seq_ids()) { if (exists $self->{'_seqs'}{$seqID} && not($self->{'_seqs'}{$seqID} eq $contig) ) { $self->warn( "Sequence $seqID already assigned to object ". $self->{'_seqs'}{$seqID}->id().". Moving to contig $contigID"); } $self->{'_seqs'}{$seqID} = $contig; } return 1; } =head2 add_singlet Title : add_singlet Usage : $assembly->add_singlet($seq) Function: Add a singlet to the assembly Returns : 1 on success Args : a Bio::Assembly::Singlet object order (optional) =cut sub add_singlet { my ($self, $singlet) = @_; # Input check if ( !ref $singlet || ! $singlet->isa('Bio::Assembly::Singlet') ) { $self->throw("Bio::Assembly::Scaffold::add_singlet is unable to process". " non Bio::Assembly::Singlet object [", ref($singlet), "]"); } # Create and attribute singlet ID my $singletID = $singlet->id(); if( !defined $singletID ) { $singletID = 'Unknown_' . ($self->get_nof_singlets() + 1); $singlet->id($singletID); $self->warn("Attributing ID $singletID to unnamed Bio::Assembly::". "Singlet object."); } # Adding singlet to scaffold $self->warn("Replacing singlet $singletID with a new singlet object") if (exists $self->{'_singlets'}{$singletID}); $self->{'_singlets'}{$singletID} = $singlet; $singlet->assembly($self); # weak circular reference # Put singlet sequence in the list of sequences belonging to the scaffold my $seqID = $singlet->seqref->id(); if (exists $self->{'_seqs'}{$seqID} && not($self->{'_seqs'}{$seqID} eq $singlet) ) { $self->warn( "Sequence $seqID already assigned to object ". $self->{'_seqs'}{$seqID}->id().". Moving to singlet $singletID"); } $self->{'_seqs'}{$seqID} = $singlet; return 1; } =head2 update_seq_list Title : update_seq_list Usage : $assembly->update_seq_list() Function: Synchronizes the assembly registry for sequences in contigs and contig actual aligned sequences content. You probably want to run this after you remove/add a sequence from/to a contig in the assembly. Returns : 1 for success Args : none =cut sub update_seq_list { my $self = shift; $self->{'_seqs'} = {}; # Put sequences in contigs in list of sequences belonging to the scaffold foreach my $contig ($self->all_contigs) { my $contigID = $contig->id(); foreach my $seqID ($contig->get_seq_ids) { if (exists $self->{'_seqs'}{$seqID} && not($self->{'_seqs'}{$seqID} eq $contig) ) { $self->warn( "Sequence $seqID already assigned to object ". $self->{'_seqs'}{$seqID}->id().". Moving to contig $contigID"); } $self->{'_seqs'}{$seqID} = $contig; } } # Put singlet sequences in the list of sequences belonging to the scaffold foreach my $singlet ($self->all_singlets) { my $singletID = $singlet->id(); my $seqID = $singlet->seqref->id(); if (exists $self->{'_seqs'}{$seqID} && not($self->{'_seqs'}{$seqID} eq $singlet) ) { $self->warn( "Sequence $seqID already assigned to object ". $self->{'_seqs'}{$seqID}->id().". Moving to singlet $singletID"); } $self->{'_seqs'}{$seqID} = $singlet; } return 1; } =head2 remove_contigs Title : remove_contigs Usage : $assembly->remove_contigs(1..4) Function: Remove contig from assembly object Returns : an array of removed Bio::Assembly::Contig objects Args : an array of contig IDs See function get_contig_ids() above =cut sub remove_contigs { my ($self, @args) = @_; my @ret = (); foreach my $contigID (@args) { foreach my $seqID ($self->get_contig_by_id($contigID)->get_seq_ids()) { delete $self->{'_seqs'}{$seqID}; } push(@ret, $self->{'_contigs'}{$contigID}); delete $self->{'_contigs'}{$contigID}; } return @ret; } =head2 remove_singlets Title : remove_singlets Usage : $assembly->remove_singlets(@singlet_ids) Function: Remove singlet from assembly object Returns : the Bio::Assembly::Singlet objects removed Args : a list of singlet IDs See function get_singlet_ids() above =cut sub remove_singlets { my ($self,@args) = @_; my @ret = (); foreach my $singletID (@args) { push(@ret,$self->{'_singlets'}{$singletID}); delete $self->{'_singlets'}{$singletID}; } return @ret; } =head2 remove_features_collection Title : remove_features_collection Usage : $assembly->remove_features_collection() Function: Removes the collection of features associated to every contig and singlet of the scaffold. This can be useful to save some memory (when contig and singlet features are not needed). Returns : none Argument : none =cut sub remove_features_collection { my ($self) = @_; for my $obj ( $self->all_contigs, $self->all_singlets ) { $obj->remove_features_collection; } return; } =head1 Contig and singlet selection methods =cut =head2 select_contigs Title : select_contigs Usage : $assembly->select_contigs(@list) Function: Select an array of contigs from the assembly Returns : an array of Bio::Assembly::Contig objects Args : an array of contig ids See function get_contig_ids() above =cut sub select_contigs { my ($self,@args) = @_; my @contigs = (); foreach my $contig (@args) { unless (exists $self->{'_contigs'}{$contig}) { $self->warn("$contig contig not found. Ignoring..."); next; } push(@contigs, $self->{'_contigs'}{$contig}); } return @contigs; } =head2 select_singlets Title : select_singlets Usage : $assembly->select_singlets(@list) Function: Selects an array of singlets from the assembly Returns : an array of Bio::Assembly::Singlet objects Args : an array of singlet ids See function get_singlet_ids() above =cut sub select_singlets { my ($self,@args) = @_; my @singlets = (); foreach my $singlet (@args) { unless (exists $self->{'_singlets'}{$singlet}) { $self->warn("$singlet singlet not found. Ignoring..."); next; } push(@singlets, $self->{'_singlets'}{$singlet}); } return @singlets; } =head2 all_contigs Title : all_contigs Usage : my @contigs = $assembly->all_contigs Function: Returns a list of all contigs in this assembly. Contigs are both clusters and alignments of one or more reads, with an associated consensus sequence. Returns : array of Bio::Assembly::Contig (in lexical id order) Args : none =cut sub all_contigs { my ($self) = @_; my @contigs = (); foreach my $contig (sort { $a cmp $b } keys %{ $self->{'_contigs'} }) { push(@contigs, $self->{'_contigs'}{$contig}); } return @contigs; } =head2 all_singlets Title : all_singlets Usage : my @singlets = $assembly->all_singlets Function: Returns a list of all singlets in this assembly. Singlets are isolated reads, without non-vector matches to any other read in the assembly. Returns : array of Bio::Assembly::Singlet objects (in lexical order by id) Args : none =cut sub all_singlets { my ($self) = @_; my @singlets = (); foreach my $singlet (sort { $a cmp $b } keys %{ $self->{'_singlets'} }) { push(@singlets, $self->{'_singlets'}{$singlet}); } return @singlets; } 1; BioPerl-1.6.923/Bio/Assembly/ScaffoldI.pm000444000765000024 1647312254227335 20154 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::ScaffoldI # # Copyright by Robson F. de Souza # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::ScaffoldI - Abstract Inteface of Sequence Assemblies =head1 SYNOPSIS # get a Bio::Assembly::ScaffoldI object somehow foreach my $contig ($assembly->all_contigs) { # do something (see Bio::Assembly::Contig) } =head1 DESCRIPTION This interface defines the basic set of methods an object should have to manipulate assembly data. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Robson Francisco de Souza Email: rfsouza@citri.iq.usp.br =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # # Now, let's code! package Bio::Assembly::ScaffoldI; use strict; use Carp; # Inheritance use base qw(Bio::Root::RootI); # # Methods =head1 Accessing general assembly data =cut =head2 get_nof_contigs Title : get_nof_contigs Usage : $assembly->get_nof_contigs() Function: Get the number of contigs included in the assembly Returns : integer Args : none =cut sub get_nof_contigs { my $self = shift; $self->throw_not_implemented(); } =head2 get_nof_singlets Title : get_nof_singlets Usage : $assembly->get_nof_singlets() Function: Get the number of singlets included in the assembly Returns : integer Args : none =cut sub get_nof_singlets { my $self = shift; $self->throw_not_implemented(); } =head2 get_contig_ids Title : get_contig_ids Usage : $assembly->get_contig_ids() Function: Access list of contig IDs from assembly Returns : an array if there are any contigs in the assembly. undef otherwise Args : an array of contig IDs =cut sub get_contig_ids { my $self = shift; $self->throw_not_implemented(); } =head2 get_singlet_ids Title : get_singlet_ids Usage : $assembly->get_singlet_ids() Function: Access list of singlet IDs from assembly Returns : an array if there are any singlets in the assembly. undef otherwise Args : an array of singlet IDs =cut sub get_singlet_ids { my $self = shift; $self->throw_not_implemented(); } =head2 get_contig_by_id Title : get_contig_by_id Usage : $assembly->get_contig_by_id($id) Function: Get a reference for a contig from the assembly Returns : a Bio::Assembly::Contig object or undef Args : [string] contig unique identifier (ID) =cut sub get_contig_by_id { my $self = shift; $self->throw_not_implemented(); } =head2 get_singlet_by_id Title : get_singlet_by_id Usage : $assembly->get_singlet_by_id() Function: Get a reference for a singlet from the assembly Returns : Bio::Assembly::Singlet object or undef Args : [string] a singlet ID =cut sub get_singlet_by_id { my $self = shift; $self->throw_not_implemented(); } =head1 Modifier methods Implementation of these methods is optional in the sense that read-only implementations may not have these. If an object implements one of them, it should however implement all. =cut =head2 add_contig Title : add_contig Usage : $assembly->add_contig($contig) Function: Add another contig to the Bio::Assembly::ScaffoldI object Returns : 1 on success, 0 otherwise Args : a Bio::Assembly:Contig object See Bio::Assembly::Contig for more information =cut #--------------------- sub add_contig { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head2 add_singlet Title : add_singlet Usage : $assembly->add_singlet($seq) Function: Add another singlet to the Bio::Assembly::ScaffoldI object Returns : 1 on success, 0 otherwise Args : a Bio::Assembly::Singlet object =cut #--------------------- sub add_singlet { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head2 remove_contigs Title : remove_contigs Usage : $assembly->remove_contigs(1..4) Function: Remove contig from assembly object Returns : a Bio::Assembly::Contig object Args : a list of contig IDs See function get_contig_ids() above =cut #--------------------- sub remove_contigs { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head2 remove_singlets Title : remove_singlets Usage : $assembly->remove_singlets(1..4) Function: Remove singlets from assembly object Returns : an array of Bio::Assembly::Singlet objects Args : an array of singlet IDs See function get_singlet_ids() above =cut #--------------------- sub remove_singlets { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head1 Contig and singlet selection methos =cut =head2 select_contigs Title : select_contig Usage : $assembly->select_contig Function: Selects an array of contigs from the assembly Returns : an array of Bio::Assembly::Contig objects Args : an array of contig ids See function get_contig_ids() above =cut #--------------------- sub select_contigs { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head2 select_singlets Title : select_singlets Usage : $assembly->select_singlets(@list) Function: Selects an array of singlets from the assembly Returns : an array of Bio::Assembly::Singlet objects Args : an array of singlet ids See function get_singlet_ids() above =cut #--------------------- sub select_singlets { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head2 all_contigs Title : all_contigs Usage : my @contigs = $assembly->all_contigs Function: Returns a list of all contigs in this assembly. Contigs are both clusters and alignments of one or more reads, with an associated consensus sequence. Returns : array of Bio::Assembly::Contig Args : none =cut #--------------------- sub all_contigs { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } =head2 all_singlets Title : all_singlets Usage : my @singlets = $assembly->all_singlets Function: Returns a list of all singlets in this assembly. Singlets are isolated reads, without non-vector matches to any other read in the assembly. Returns : array of Bio::Assembly::Singlet objects Args : none =cut #--------------------- sub all_singlets { #--------------------- my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Assembly/Singlet.pm000444000765000024 1166312254227332 17720 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::Singlet # # Please direct questions and support issues to # # Cared for by Chad Matsalla # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Assembly::Singlet - Perl module to hold and manipulate singlets from sequence assembly contigs. =head1 SYNOPSIS # Module loading use Bio::Assembly::IO; # Assembly loading methods $aio = Bio::Assembly::IO->new( -file => 'test.ace.1', -format => 'phrap' ); $assembly = $aio->next_assembly; foreach $singlet ($assembly->all_singlets) { # do something } # OR, if you want to build the singlet yourself, use Bio::Assembly::Singlet; $singlet = Bio::Assembly::Singlet->new( -id => 'Singlet1', -seqref => $seq ); =head1 DESCRIPTION A singlet is a sequence that phrap was unable to align to any other sequences. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad S. Matsalla bioinformatics1 at dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' package Bio::Assembly::Singlet; use strict; use Bio::SeqFeature::Collection; use Bio::LocatableSeq; use Bio::Seq::PrimaryQual; use base qw(Bio::Assembly::Contig Bio::Root::Root Bio::Align::AlignI); =head2 new Title : new Usage : $singlet = $io->new( -seqref => $seq ) Function: Create a new singlet object Returns : A Bio::Assembly::Singlet object Args : -seqref => Bio::Seq-compliant sequence object for the singlet =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($seqref) = $self->_rearrange([qw(SEQREF)], @args); $self->{'_seqref'} = undef; if (defined $seqref) { $self->seqref($seqref); } return $self; } =head2 seqref Title : seqref Usage : $seqref = $singlet->seqref($seq); Function: Get/set the sequence to which this singlet refers Returns : A Bio::Seq-compliant object Args : A Bio::Seq-compliant or Bio::Seq::Quality object =cut sub seqref { my ($self,$seq) = @_; if (defined $seq) { $self->_seq_to_singlet($seq) }; return $self->{'_seqref'}; } =head2 _seq_to_singlet Title : _seq_to_singlet Usage : $singlet->seqref($seq) Function: Transform a sequence into a singlet Returns : 1 for sucess Args : A Bio::Seq-compliant object =cut sub _seq_to_singlet { my ($self, $seq) = @_; # Object type checking $self->throw("Unable to process non Bio::Seq-compliant object [".ref($seq)."]") unless ( defined $seq && ($seq->isa('Bio::PrimarySeqI') || $seq->isa('Bio::Seq::Quality')) ); # Sanity check $self->throw("Unable to have more than one sequence reference in a singlet") if (defined $self->{'_seqref'}); # From sequence to locatable sequence my $lseq = Bio::LocatableSeq->new( -id => $seq->id, -seq => $seq->seq, -strand => $seq->isa('Bio::LocatableSeq') ? $seq->strand : 1, -start => 1, #-end => we let Bio::LocatableSeq calculate it (Seq and LocatableSeq) ); # Get End from $seq if $lseq can't figure it out (e.g. phrap output) if (not defined $lseq->end) { $lseq->end($seq->end); } # Add new sequence and its coordinates to the contig my $lcoord = Bio::SeqFeature::Generic->new( -start => $lseq->start, -end => $lseq->end ); $self->set_seq_coord( $lcoord, $lseq ); $self->{'_seqref'} = $lseq; # Creating consensus $self->set_consensus_sequence($lseq); if ($seq->isa("Bio::Seq::Quality")) { my $qual = Bio::Seq::PrimaryQual->new( -id => $seq->id, -qual => $seq->qual ); $self->set_consensus_quality($qual); } return 1; } 1; BioPerl-1.6.923/Bio/Assembly/IO000755000765000024 012254227335 16103 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Assembly/IO/ace.pm000444000765000024 11176212254227335 17376 0ustar00cjfieldsstaff000000000000# $Id: ace.pm 16969 2010-05-09 15:26:53Z fangly $ # ## BioPerl module for Bio::Assembly::IO::ace # # Copyright by Robson F. de Souza (the reading part) and Florent Angly (the # writing and ACE variants part) # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO::ace - module to load ACE files from various assembly programs =head1 SYNOPSIS # Building an input stream use Bio::Assembly::IO; # Load a reference ACE assembly my $in_io = Bio::Assembly::IO->new( -file => 'results.ace', -format => 'ace' ); # Read the entire scaffold my $scaffold = $in_io->next_assembly; # Or read one contig at a time to save resources while ( my $contig = $in_io->next_contig ) { # Do something ... } # Assembly writing methods my $out_io = Bio::Assembly::IO->new( -file => ">output.ace", -format => 'ace' ); $out_io->write_assembly( -scaffold => $scaffold, -singlets => 1 ); # Read the '454' Newbler variant of ACE instead of the default 'consed' # reference ACE variant my $in_io = Bio::Assembly::IO->new( -file => 'results.ace', -format => 'ace-454' ); # or ... my $in_io = Bio::Assembly::IO->new( -file => 'results.ace', -format => 'ace', -variant => '454' ); =head1 DESCRIPTION This package loads the standard ACE files generated by various assembly programs (Phrap, CAP3, Newbler, Arachne, ...). It was written to be used as a driver module for Bio::Assembly::IO input/output. =head2 Implemention Assemblies are loaded into Bio::Assembly::Scaffold objects composed by Bio::Assembly::Contig and Bio::Assembly::Singlet objects. Only the ACE file is used, so if you need singlets, make sure that they are present in the ACE file. A brief description of the ACE format is available at http://www.cbcb.umd.edu/research/contig_representation.shtml#ACE Read the full format description from http://bozeman.mbt.washington.edu/consed/distributions/README.14.0.txt In addition to default "_aligned_coord:$seqID" feature class from Bio::Assembly::Contig, contig objects loaded by this module will have the following special feature classes in their feature collection: "_align_clipping:$seqID" (AF) Location of subsequence in read $seqID which is aligned to the contig. The coordinates are relative to the contig. If no feature containing this tag is present the read is considered low quality by Consed. "_quality_clipping:$seqID" (AF) The location of high quality subsequence in read $seqID (relative to contig) "_base_segments" (BS) Location of read subsequences used to build the consensus "_read_tags:$readID" (RT) Sequence features stored as sub_SeqFeatures of the sequence's coordinate feature (the corresponding "_aligned_coord:$seqID" feature, easily accessed through get_seq_coord() method). "_read_desc:$readID" (DS) Sequence features stored as sub_SeqFeatures of the read's coordinate feature "consensus tags" (CT) Equivalent to a bioperl sequence feature and, therefore, are added to the feature collection using their type field (see Consed's README.txt file) as primary tag. "whole assembly tags" (WA) They have no start and end, as they are not associated to any particular sequence in the assembly, and are added to the assembly's annotation collection using "whole assembly" as tag. =head2 Variants The default ACE variant is called 'consed' and corresponds to the reference ACE format. The ACE files produced by the 454 GS Assembler (Newbler) do not conform to the reference ACE format. In 454 ACE, the consensus sequence reported covers only its clear range and the start of the clear range consensus is defined as position 1. Consequently, aligned reads in the contig can have negative positions. Be sure to use the '454' variant to have positive alignment positions. No attempt is made to construct the missing part of the consensus sequence (beyond the clear range) based on the underlying reads in the contig. Instead the ends of the consensus are simply padded with the gap character '-'. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Robson Francisco de Souza Email rfsouza@citri.iq.usp.br =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Assembly::IO::ace; use strict; use Bio::Assembly::Scaffold; use Bio::Assembly::Contig; use Bio::Assembly::Singlet; use Bio::LocatableSeq; use Bio::Seq::PrimaryQual; use Bio::Annotation::SimpleValue; use Bio::SeqIO; use Bio::SeqFeature::Generic; use base qw(Bio::Assembly::IO); our $line_width = 50; our $qual_value = 20; our %variant = ( 'consed' => undef, # default '454' => undef ); =head1 Parser methods =head2 next_assembly Title : next_assembly Usage : $scaffold = $stream->next_assembly() Function: returns the next assembly in the stream Returns : a Bio::Assembly::Scaffold object Args : none =cut sub next_assembly { my $self = shift; my $assembly = Bio::Assembly::Scaffold->new(); # Load contigs and singlets in the scaffold while ( my $obj = $self->next_contig() ) { # Add contig /singlet to assembly if ($obj->isa('Bio::Assembly::Singlet')) { # a singlet $assembly->add_singlet($obj); } else { # a contig $assembly->add_contig($obj); } } # Load annotations of assembly and contigs $self->scaffold_annotations($assembly); return $assembly; } =head2 next_contig Title : next_contig Usage : $scaffold = $stream->next_contig() Function: Returns the next contig or singlet in the ACE stream. Returns : a Bio::Assembly::Contig or Bio::Assembly::Single object Args : none =cut sub next_contig { my ($self) = shift; local $/ = "\n"; my $contigOBJ; my $read_name; my $min_start; my $read_data = {}; # Temporary holder for read data # Keep reading the ACE stream starting at where we stopped while ( $_ = $self->_readline) { chomp; # Loading contig sequence (COntig sequence field) if (/^CO\s(\S+)\s(\d+)\s(\d+)\s(\d+)\s(\w+)/xms) { # New contig starts! if (not $contigOBJ) { # Start a new contig object my $contigID = $1; # Contig ID #my $nof_bases = $2; # Contig length in base pairs my $nof_reads = $3; # Number of reads in this contig #my $nof_segments = $4; # Number of read segments selected for consensus assembly my $ori = $5; # 'C' if contig was complemented or U if not (default) $ori = $ori eq 'U' ? 1 : -1; # Create a singlet or contig if ($nof_reads == 1) { # This is a singlet $contigOBJ = Bio::Assembly::Singlet->new( ); } elsif ( $nof_reads > 1 ) { # This is a contig $contigOBJ = Bio::Assembly::Contig->new( ); } $contigOBJ->id($contigID); $contigOBJ->strand($ori); my $consensus_sequence; while ($_ = $self->_readline) { # Looping over contig lines chomp; # Drop (\n) on current line last if (/^$/); # Stop if empty line (contig end) is found s/\*/-/g; # Forcing '-' as gap symbol $consensus_sequence .= $_; } $consensus_sequence = Bio::LocatableSeq->new( -seq => $consensus_sequence, -start => 1, -strand => $ori, ); $consensus_sequence->id($contigID); $contigOBJ->set_consensus_sequence($consensus_sequence); } else { # A second contig is about to start. Backtrack one line and go # to the return statement $self->_pushback($_); last; } } # Loading contig qualities... (Base Quality field) elsif (/^BQ/) { my $qual_string = ''; while ($_ = $self->_readline) { chomp; last if (/^$/); $qual_string .= "$_ "; } my @qual_arr = $self->_input_qual($qual_string, $contigOBJ->get_consensus_sequence->seq); my $qual = Bio::Seq::PrimaryQual->new(-qual => join(" ", @qual_arr), -id => $contigOBJ->id() ); $contigOBJ->set_consensus_quality($qual); } # Loading read info... (Assembled From field) elsif (/^AF (\S+) (C|U) (-*\d+)/) { $read_name = $1; # read ID my $ori = $2; # strand my $start = $3; # aligned start $ori = $ori eq 'U' ? 1 : -1; $read_data->{$read_name}{'strand'} = $ori; $read_data->{$read_name}{'padded_start'} = $start; if ( $self->variant eq '454' ) { if ( (not defined $min_start) || ($start < $min_start) ) { $min_start = $start; } } } # Base segments definitions (Base Segment field) # They indicate which read segments were used to calculate the consensus # Coordinates are relative to the contig elsif (/^BS (\d+) (\d+) (\S+)/) { my ($start, $end, $contig_id) = ($1, $2, $3); if ($self->variant eq '454') { $start += abs($min_start) + 1; $end += abs($min_start) + 1; } my $bs_feat = Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -source => 'ace', -strand => 1, -primary => '_base_segments', -tag => { 'contig_id' => $contig_id} ); $contigOBJ->add_features([ $bs_feat ], 0); } # Loading reads... (ReaD sequence field) # They define the reads in each contig elsif (/^RD (\S+) (-*\d+) (\d+) (\d+)/) { $read_name = $1; $read_data->{$read_name}{'length'} = $2; # number_of_padded_bases $read_data->{$read_name}{'contig'} = $contigOBJ; # $read_data->{$read_name}{'number_of_read_info_items'} = $3; # $read_data->{$read_name}{'number_of_tags'} = $4; # Add a read to a contig my $read_sequence; while ($_ = $self->_readline) { chomp; last if (/^$/); s/\*/-/g; # Forcing '-' as gap symbol $read_sequence .= $_; # aligned read sequence } my $read = Bio::LocatableSeq->new( -seq => $read_sequence, -start => 1, -strand => $read_data->{$read_name}{'strand'}, -id => $read_name, -primary_id => $read_name, -alphabet => 'dna' ); # Adding read location and sequence to contig ("gapped consensus" coordinates) my $padded_start = $read_data->{$read_name}{'padded_start'}; if ($self->variant eq '454') { $padded_start += abs($min_start) + 1; } my $padded_end = $padded_start + $read_data->{$read_name}{'length'} - 1; my $coord = Bio::SeqFeature::Generic->new( -start => $padded_start, -end => $padded_end, -source => 'ace', -strand => $read_data->{$read_name}{'strand'}, -tag => { 'contig' => $contigOBJ->id } ); if ($contigOBJ->isa('Bio::Assembly::Singlet')) { # Set the the sequence in the singlet $contigOBJ->seqref($read); } else { # a contig # this sets the "_aligned_coord:$seqID" feature $contigOBJ->set_seq_coord($coord,$read); } } # Loading read trimming and alignment ranges... elsif (/^QA (-?\d+) (-?\d+) (-?\d+) (-?\d+)/) { my ($qual_start, $qual_end, $aln_start, $aln_end) = ($1, $2, $3, $4); # Regions of the read that were aligned to the consensus (see BS) unless ($aln_start == -1 && $aln_end == -1) { $aln_start = $contigOBJ->change_coord("aligned $read_name",'gapped consensus',$aln_start); $aln_end = $contigOBJ->change_coord("aligned $read_name",'gapped consensus',$aln_end); my $aln_feat = Bio::SeqFeature::Generic->new( -start => $aln_start, -end => $aln_end, -strand => $read_data->{$read_name}{'strand'}, -primary => '_align_clipping', -source => $read_name, ); $aln_feat->attach_seq( $contigOBJ->get_seq_by_name($read_name) ); $contigOBJ->add_features([ $aln_feat ], 0); } # Regions of the read with high quality score unless ($qual_start == -1 && $qual_end == -1) { $qual_start = $contigOBJ->change_coord("aligned $read_name",'gapped consensus',$qual_start); $qual_end = $contigOBJ->change_coord("aligned $read_name",'gapped consensus',$qual_end); my $qual_feat = Bio::SeqFeature::Generic->new( -start => $qual_start, -end => $qual_end, -strand => $read_data->{$read_name}{'strand'}, -primary => '_quality_clipping', -source => $read_name || '', ); $qual_feat->attach_seq( $contigOBJ->get_seq_by_name($read_name) ); $contigOBJ->add_features([ $qual_feat ], 0); } } # Loading read DeScription (DS) elsif (/^DS\s+(.*)/) { my $desc = $1; # Expected tags are CHROMAT_FILE, PHD_FILE, TIME and to a lesser # extent DYE, TEMPLATE, CHEM and DIRECTION, but any other tag is # allowed my (undef, %tags) = split /\s?(\S+):\s+/, $desc; my $coord = $contigOBJ->get_seq_coord( $contigOBJ->get_seq_by_name($read_name) ); my $start = $coord->start; my $end = $coord->end; my $read_desc = Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -primary => '_read_desc', # primary_tag -source => $read_name || '', -tag => \%tags ); $contigOBJ->get_features_collection->add_features([$read_desc]); $contigOBJ->get_features_collection->add_SeqFeature($coord, $read_desc); } # Loading Read Tags elsif (/^RT\s*\{/) { my ($readID,$type,$source,$start,$end,$date) = split(' ',$self->_readline); my $extra_info = undef; while ($_ = $self->_readline) { last if (/\}/); $extra_info .= $_; } $start = $contigOBJ->change_coord("aligned $readID",'gapped consensus',$start); $end = $contigOBJ->change_coord("aligned $readID",'gapped consensus',$end); my $read_tag = Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -primary => '_read_tags', -source => $readID || '', -tag => { 'type' => $type, 'source' => $source, 'creation_date' => $date} ); $read_tag->add_tag_value('extra_info', $extra_info) if defined $extra_info; my $contig = $read_data->{$readID}{'contig'}; my $coord = $contig->get_seq_coord( $contig->get_seq_by_name($readID) ); $contig->get_features_collection->add_features([$read_tag]); $contig->get_features_collection->add_SeqFeature($coord, $read_tag); } } # Adjust consensus sequence of 454 variant by padding its start and end if (($self->variant eq '454') && (defined $contigOBJ)) { my $pad_char = '-'; my $pad_score = 0; # Find maximum coordinate my $max_end; for my $readid ($contigOBJ->get_seq_ids) { my ($alncoord) = $contigOBJ->get_features_collection->get_features_by_type("_aligned_coord:$readid"); my $end = $alncoord->location->end; if ( (not defined $max_end) || ($end > $max_end) ) { $max_end = $end; } } # Pad consensus sequence my $cons_seq = $contigOBJ->get_consensus_sequence; my $cons_string = $cons_seq->seq; my $l_pad_len = abs($min_start) + 1; my $r_pad_len = $max_end - length($cons_string) - $l_pad_len; $cons_string = $pad_char x $l_pad_len . $cons_string . $pad_char x $r_pad_len; $cons_seq = Bio::LocatableSeq->new( -seq => $cons_string, -id => $cons_seq->id, -start => $cons_seq->start, -strand => $cons_seq->strand, ); $contigOBJ->set_consensus_sequence($cons_seq); # Pad consensus quality my $cons_qual = $contigOBJ->get_consensus_quality; if (defined $cons_qual) { my $cons_score = [ ($pad_score) x $l_pad_len, @{$cons_qual->qual}, ($pad_score) x $r_pad_len ]; $cons_qual = Bio::Seq::PrimaryQual->new( -qual => join(' ', @$cons_score), -id => $cons_qual->id ); $contigOBJ->set_consensus_quality($cons_qual); } } return $contigOBJ; } =head2 scaffold_annotations Title : scaffold_annotations Usage : $stream->scaffold_annotations($scaffold) Function: Add assembly and contig annotations to a scaffold. In the ACE format, annotations are the WA and CT tags. Returns : 1 for success Args : a Bio::Assembly::Scaffold object to attach the annotations to =cut sub scaffold_annotations { my ($self, $assembly) = @_; local $/ = "\n";; # Read the ACE stream from the beginning again seek($self->_fh, 0, 0); while ($_ = $self->_readline) { chomp; # Assembly information (ASsembly field) # Ignore it #(/^AS\s+(\d+)\s+(\d+)/) && do { # my $nof_contigs = $1; # my $nof_seq_in_contigs = $2; #}; # Loading Whole Assembly tags /^WA\s*\{/ && do { my ($type,$source,$date) = split(' ',$self->_readline); my $extra_info = undef; while ($_ = $self->_readline) { last if (/\}/); $extra_info .= $_; } my $assembly_tags = join(" ","TYPE:",$type,"PROGRAM:",$source, "DATE:",$date,"DATA:",$extra_info); $assembly_tags = Bio::Annotation::SimpleValue->new(-value=>$assembly_tags); $assembly->annotation->add_Annotation('whole assembly',$assembly_tags); }; # Loading Contig Tags (a.k.a. Bioperl features) /^CT\s*\{/ && do { my ($contigID,$type,$source,$start,$end,$date) = split(' ',$self->_readline); my %tags = ('source' => $source, 'creation_date' => $date); my $tag_type = 'extra_info'; while ($_ = $self->_readline) { if (/COMMENT\s*\{/) { $tag_type = 'comment'; } elsif (/C\}/) { $tag_type = 'extra_info'; } elsif (/\}/) { last; } else { $tags{$tag_type} .= "$_"; } } my $contig_tag = Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -primary => $type, -source => 'ace', -tag => \%tags ); my $contig = $assembly->get_contig_by_id($contigID) || $assembly->get_singlet_by_id($contigID); $self->throw("Cannot add feature to unknown contig '$contigID'") unless defined $contig; $contig->add_features([ $contig_tag ],1); }; } return 1; } =head2 write_assembly Title : write_assembly Usage : $ass_io->write_assembly($assembly) Function: Write the assembly object in ACE compatible format. The contig IDs are sorted naturally if the Sort::Naturally module is present, or lexically otherwise. Internally, write_assembly use the write_contig, write_footer and write_header methods. Use these methods if you want more control on the writing process. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object =cut =head2 write_contig Title : write_contig Usage : $ass_io->write_contig($contig) Function: Write a contig or singlet object in ACE compatible format. Quality scores are automatically generated if the contig does not contain any Returns : 1 on success, 0 for error Args : A Bio::Assembly::Contig or Singlet object =cut sub write_contig { my ($self, @args) = @_; my ($contig) = $self->_rearrange([qw(CONTIG)], @args); # Sanity check if ( !$contig || !$contig->isa('Bio::Assembly::Contig') ) { $self->throw("Must provide a Bio::Assembly::Contig or Singlet object when calling write_contig"); } # Contig consensus sequence my $contig_id = $contig->id; my $cons = $contig->get_consensus_sequence; my $cons_seq = $cons->seq; my $cons_len = $cons->length; my $contig_num_reads = $contig->num_sequences; my $cons_strand = ($contig->strand == -1) ? 'C' : 'U'; my @bs_feats = $contig->get_features_collection->get_features_by_type('_base_segments'); my $nof_segments = scalar @bs_feats; $self->_print( "CO $contig_id $cons_len $contig_num_reads $nof_segments $cons_strand\n". _formatted_seq($cons_seq, $line_width). "\n" ); # Consensus quality scores $cons = $contig->get_consensus_quality; my $cons_qual = $cons->qual if defined $cons; $self->_print( "BQ\n". _formatted_qual($cons_qual, $cons_seq, $line_width, $qual_value). "\n" ); # Read entries my @reads = $contig->each_seq; for my $read (@reads) { my $read_id = $read->id; my $read_strand = ($read->strand == -1) ? 'C' : 'U'; my $read_start = $contig->change_coord("aligned $read_id",'gapped consensus',1); $self->_print( "AF $read_id $read_strand $read_start\n" ); } $self->_print( "\n" ); # Deal with base segments (BS) if ( @bs_feats ) { # sort segments by increasing start position @bs_feats = sort { $a->start <=> $b->start } @bs_feats; # write segments for my $bs_feat ( @bs_feats ) { my $start = $bs_feat->start; my $end = $bs_feat->end; my $id = ($bs_feat->get_tag_values('contig_id'))[0]; $self->_print( "BS $start $end $id\n" ); } $self->_print( "\n" ); } for my $read (@reads) { $self->_write_read($read, $contig); } return 1; } =head2 write_header Title : write_header Usage : $ass_io->write_header($scaffold) or $ass_io->write_header(\@contigs); or $ass_io->write_header(); Function: Write ACE header (AS tags). You can call this function at any time, i.e. not necessarily at the start of the stream - this is useful if you have an undetermined number of contigs to write to ACE, e.g: for my $contig (@list_of_contigs) { $ass_io->_write_contig($contig); } $ass_io->_write_header(); Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold or an arrayref of Bio::Assembly::Contig or nothing (the header is dynamically written based on the ACE file content) =cut sub write_header { my ($self, $input) = @_; # Input validation my @contigs; my $err_msg = "If an input is given to write_header, it must be a single ". "Bio::Assembly::Scaffold object or an arrayref of Bio::Assembly::Contig". " or Singlet objects"; my $ref = ref $input; if ( $ref eq 'ARRAY' ) { for my $obj ( @$input ) { $self->throw($err_msg) if not $obj->isa('Bio::Assembly::Contig'); push @contigs, $obj; } } elsif ( $ref =~ m/Bio::Assembly::Scaffold/ ) { @contigs = ($input->all_contigs, $input->all_singlets); } # Count number of contigs and reads my $num_contigs = 0; my $num_reads = 0; if ( scalar @contigs > 0 ) { # the contigs were provided $num_contigs = scalar @contigs; for my $contig ( @contigs ) { $num_reads += $contig->num_sequences; } } else { # need to read the contigs from file $self->flush; my $file = $self->file(); # e.g. '+>output.ace' $file =~ s/^\+?[><]?//; # e.g. 'output.ace' my $read_io = Bio::Assembly::IO->new( -file => $file, -format => 'ace' ); while ( my $contig = $read_io->next_contig ) { $num_contigs++; $num_reads += $contig->num_sequences; } $read_io->close; } # Write ASsembly tag at the start of the file my $header = "AS $num_contigs $num_reads\n\n"; $self->_insert($header, 1); return 1; } =head2 write_footer Title : write_footer Usage : $ass_io->write_footer($scaffold) Function: Write ACE footer (WA and CT tags). Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object (optional) =cut sub write_footer { my ($self, $scaf) = @_; # Nothing to write if scaffold was not provided return 1 if not defined $scaf; # Verify that provided object is a scaffold if ($scaf->isa('Bio::Assembly:ScaffoldI')) { $self->throw("Must provide a Bio::Assembly::Scaffold object when calling write_footer"); } # Whole Assembly tags (WA) my $asm_anno = ($scaf->annotation->get_Annotations('whole assembly'))[0]; if ($asm_anno) { my $asm_tags = $asm_anno->value; if ($asm_tags =~ m/^TYPE: (\S+) PROGRAM: (\S+) DATE: (\S+) DATA: (.*)$/ms) { my ($type, $program, $date, $data) = ($1, $2, $3, $4); $data ||= ''; $self->_print( "WA{\n". "$type $program $date\n". $data. "}\n". "\n" ); } } # Contig Tags (CT) for my $contig_id ( Bio::Assembly::IO::_sort( $scaf->get_contig_ids ) ) { my $contig = $scaf->get_contig_by_id($contig_id) || $scaf->get_singlet_by_id($contig_id); # Is there a better way of doing this? Grepping is not very efficient... my @feats = (grep { not $_->primary_tag =~ m/^_/ } $contig->get_features_collection->features ); for my $feat (@feats) { my $type = $feat->primary_tag; my $start = $feat->start; my $end = $feat->end; my $source = ($feat->get_tag_values('source') )[0]; my $date = ($feat->get_tag_values('creation_date'))[0]; my $extra = ''; if ($feat->has_tag('extra_info')) { $extra = ($feat->get_tag_values('extra_info') )[0]; } $self->_print( "CT{\n". "$contig_id $type $source $start $end $date\n". $extra. "}\n". "\n" ); } } return 1; } =head2 variant Title : variant Usage : $variant = $ass_io->variant(); Function: Get and set method for the assembly variant. This is important since not all assemblers respect the reference ACE format. Returns : string Args : string: 'consed' (default) or '454' =cut # variant() method inherited from Bio::Root::IO =head2 _write_read Title : _write_read Usage : $ass_io->_write_read($read, $contig) Function: Write a read object in ACE compatible format Returns : 1 on success, 0 for error Args : a Bio::LocatableSeq read the Contig or Singlet object that this read belongs to =cut sub _write_read { my ($self, @args) = @_; my ($read, $contig) = $self->_rearrange([qw(READ CONTIG)], @args); # Sanity check if ( !$read || !$read->isa('Bio::LocatableSeq') ) { $self->throw("Must provide a Bio::LocatableSeq when calling write_read"); } if ( !$contig || !$contig->isa('Bio::Assembly::Contig') ) { $self->throw("Must provide a Bio::Assembly::Contig or Singlet object when calling write_read"); } # Read info my $read_id = $read->id; my $read_len = $read->length; # aligned length my $read_seq = $read->seq; my $nof_info = 0; # fea: could not find exactly the meaning of this? my @read_tags = $contig->get_features_collection->get_SeqFeatures( $contig->get_seq_coord($read), "_read_tags:$read_id"); my $nof_tags = scalar @read_tags; $self->_print( "RD $read_id $read_len $nof_info $nof_tags\n". _formatted_seq($read_seq, $line_width). "\n" ); # Aligned "align clipping" and quality coordinates if read object has them my $qual_clip_start = 1; my $qual_clip_end = length($read->seq); my ($qual_clip) = $contig->get_features_collection->get_features_by_type("_quality_clipping:$read_id"); if ( defined $qual_clip ) { $qual_clip_start = $qual_clip->location->start; $qual_clip_end = $qual_clip->location->end; $qual_clip_start = $contig->change_coord('gapped consensus',"aligned $read_id",$qual_clip_start); $qual_clip_end = $contig->change_coord('gapped consensus',"aligned $read_id",$qual_clip_end ); } my $aln_clip_start = 1; my $aln_clip_end = length($read->seq); my ($aln_clip) = $contig->get_features_collection->get_features_by_type("_align_clipping:$read_id"); if ( defined $aln_clip ) { $aln_clip_start = $aln_clip->location->start; $aln_clip_end = $aln_clip->location->end; $aln_clip_start = $contig->change_coord('gapped consensus',"aligned $read_id",$aln_clip_start ); $aln_clip_end = $contig->change_coord('gapped consensus',"aligned $read_id",$aln_clip_end ); } $self->_print( "QA $qual_clip_start $qual_clip_end $aln_clip_start $aln_clip_end\n". "\n" ); # Read description, if read object has them my $read_desc = ( $contig->get_features_collection->get_SeqFeatures( $contig->get_seq_coord($read), "_read_desc:$read_id") )[0]; if ($read_desc) { $self->_print("DS"); for my $tag_name ( $read_desc->get_all_tags ) { my $tag_value = ($read_desc->get_tag_values($tag_name))[0]; $self->_print(" $tag_name: $tag_value"); } $self->_print("\n\n"); } # Read tags, if read object has them for my $read_tag (@read_tags) { #my $type = $read_tag->primary_tag; my $start = $read_tag->start; my $end = $read_tag->end; my $type = ($read_tag->get_tag_values('type') )[0]; my $source = ($read_tag->get_tag_values('source') )[0]; my $date = ($read_tag->get_tag_values('creation_date'))[0]; my $extra = $read_tag->has_tag('extra_info') ? ($read_tag->get_tag_values('extra_info') )[0] : ''; $self->_print( "RT{\n". "$read_id $type $source $start $end $date\n". $extra. "}\n". "\n" ); } return 1; } =head2 _formatted_seq Title : _formatted_seq Usage : Bio::Assembly::IO::ace::_formatted_seq($sequence, $line_width) Function: Format a sequence for ACE output: i ) replace gaps in the sequence by the '*' char ii) split the sequence on multiple lines as needed Returns : new sequence string Args : sequence string on one line maximum line width =cut sub _formatted_seq { my ($seq_str, $line_width) = @_; my $new_str = ''; # In the ACE format, gaps are '*' $seq_str =~ s/-/*/g; # Split sequences on several lines while ( my $chunk = substr $seq_str, 0, $line_width, '' ) { $new_str .= "$chunk\n"; } return $new_str; } =head2 _formatted_qual Title : _formatted_qual Usage : Bio::Assembly::IO::ace::_formatted_qual($qual_arr, $sequence, $line_width, $qual_default) Function: Format quality scores for ACE output: i ) use the default quality values when they are missing ii ) remove gaps (they get no score in ACE) iii) split the quality scores on several lines as needed Returns : new quality score string Args : quality score array reference corresponding sequence string maximum line width default quality score =cut sub _formatted_qual { my ($qual_arr, $seq, $line_width, $qual_default) = @_; my $qual_str = ''; my @qual_arr; if (defined $qual_arr) { # Copy array @qual_arr = @$qual_arr; } else { # Default quality @qual_arr = map( $qual_default, (1 .. length $seq) ); } # Gaps get no quality score in ACE format my $gap_pos = -1; while ( 1 ) { $gap_pos = index($seq, '-', $gap_pos + 1); last if $gap_pos == -1; substr $seq, $gap_pos, 1, ''; splice @qual_arr, $gap_pos, 1; $gap_pos--; } # Split quality scores on several lines while ( my @chunks = splice @qual_arr, 0, $line_width ) { $qual_str .= "@chunks\n"; } return $qual_str; } =head2 _input_qual Title : _input_qual Usage : Bio::Assembly::IO::ace::_input_qual($qual_string, $sequence) Function: Reads input quality string and converts it to an array of quality scores. Gaps get a quality score equals to the average of the quality score of its neighbours. Returns : new quality score array Args : quality score string corresponding sequence string =cut sub _input_qual { my ($self, $qual_string, $sequence) = @_; my @qual_arr = (); # Remove whitespaces in front of qual string and split quality values $qual_string =~ s/^\s+//; my @tmp = split(/\s+/, $qual_string); # Remove gaps my $i = 0; # position in quality my $j = 0; # position in sequence my $prev = 0; my $next = 0; for $j (0 .. length($sequence)-1) { my $nt = substr($sequence, $j, 1); if ($nt eq '-') { if ($i > 0) { $prev = $tmp[$i-1]; } else { $prev = 0; } if ($i < $#tmp) { $next = $tmp[$i]; } else { $next = 0; } push @qual_arr, int(($prev+$next)/2); } else { push @qual_arr, $tmp[$i]; $i++; } } return @qual_arr; } =head2 _initialize Title : _initialize Usage : $ass_io->_initialize(@args) Function: Initialize the Bio::Assembly::IO object with the proper ACE variant Returns : Args : =cut sub _initialize { my($self, @args) = @_; $self->SUPER::_initialize(@args); my ($variant) = $self->_rearrange([qw(VARIANT)], @args); $variant ||= 'consed'; $self->variant($variant); } 1; __END__ BioPerl-1.6.923/Bio/Assembly/IO/bowtie.pm000555000765000024 2400712254227325 20114 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::IO::sam # # Please direct questions and support issues to # # Cared for by Dan Kortschak # # Copyright Dan Kortschak # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO::bowtie - An IO module for assemblies in Bowtie format *BETA* =head1 SYNOPSIS $aio = Bio::Assembly::IO( -file => "mybowtie.bowtie", -index => "myindex", -format => "bowtie"); $assy = $aio->next_assembly; =head1 DESCRIPTION This is a read-only IO module designed to convert Bowtie (L) formatted alignments to L representations, containing L and L objects. It is a wrapper that converts the Bowtie format to BAM format taken by the Bio::Assembly::IO::sam module which in turn uses lstein's L to parse binary formatted SAM (.bam) files guided by a reference sequence fasta database. Some information is lost in conversion from bowtie format to SAM/BAM format that is provided by Bowtie using the SAM output option and the conversion to SAM format from bowtie format is slower than using bowtie's SAM option. If you plan to use SAM/BAM format it is preferable to use this Bowtie option rather than convert the format after the fact. See the Bio::Assembly::IO::sam documentation for relevant details. =head1 DETAILS =over =item * Required files A bowtie (C<.bowtie>) alignment and the bowtie index or fasta file used to generate the alignment are required. =item * Compressed files ...can be specified directly , if L is installed. Get it from your local CPAN mirror. =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: L rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Dan Kortschak Email dan.kortschak adelaide.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Assembly::IO::bowtie; use strict; use warnings; # Object preamble - inherits from Bio::Root::Root use Bio::SeqIO; use Bio::Tools::Run::Samtools; use Bio::Assembly::IO; use base qw( Bio::Assembly::IO ); our $HD = "\@HD\tVN:1.0\tSO:unsorted\n"; our $PG = "\@PG\tID=Bowtie\n"; our $HAVE_IO_UNCOMPRESS; our $HAVE_BOWTIE; BEGIN { # check requirements eval "require Bio::Tools::Run::Bowtie; \$HAVE_BOWTIE = 1"; unless ( eval "require IO::Uncompress::Gunzip; \$HAVE_IO_UNCOMPRESS = 1") { Bio::Root::Root->warn("IO::Uncompress::Gunzip is not available; you'll have to do your decompression by hand."); } } =head2 new() Title : new Usage : my $obj = new Bio::Assembly::IO::bowtie(); Function: Builds a new Bio::Assembly::IO object Returns : an instance of Bio::Assembly::IO Args : hash of options: -file => bowtie_output_file -index => bowtie_index or fasta_file used to create index -no_head => boolean skip SAM header -no_sq => boolean skip SQ lines of SAM header Note : bowtie_output and fasta files may be gzipped =cut sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args); $self->_initialize(@args); $self->{'_tempdir'} = $self->tempdir(CLEANUP=>1); my ($file, $index, $no_head, $no_sq) = $self->_rearrange([qw(FILE INDEX NO_HEAD NO_SQ)], @args); $file =~ s/^{'_no_head'} = $no_head; $self->{'_no_sq'} = $no_sq; # get the sequence so Bio::DB::Sam can work with it my $refdb; my $inspector; if (-e $index && -r _ ) { $refdb = ($index =~ m/\.gz[^.]*$/) ? $self->_uncompress($index) : $index; my $guesser = Bio::Tools::GuessSeqFormat->new(-file=>$refdb); $self->throw("'$index' is not a fasta file.") unless $guesser->guess =~ m/^fasta$/; } elsif ($HAVE_BOWTIE) { $inspector = Bio::Tools::Run::Bowtie->new( -command => 'inspect' ); $refdb = $inspector->run($index); } else { $self->throw("Bio::Tools::Run::Bowtie is not available - cannot extract refdb from index."); } my $bam_file = $self->_make_bam($self->_bowtie_to_sam($file, $refdb)); my $sam = Bio::Assembly::IO->new( -file => "<$bam_file", -refdb => $refdb , -format => 'sam' ); return $sam; } sub _bowtie_to_sam { my ($self, $file, $refdb) = @_; $self->throw("'$file' does not exist or is not readable.") unless ( -e $file && -r _ ); if ($file =~ m/\.gz[^.]*$/) { $file = $self->_uncompress($file); $self->close; open (my $fh,$file); $self->file($file); $self->_fh($fh); } my $guesser = Bio::Tools::GuessSeqFormat->new(-file=>$file); $self->throw("'$file' is not a bowtie formatted file.") unless $guesser->guess =~ m/^bowtie$/; my %SQ; my $mapq = 255; my $in_pair; my @mate_line; my $mlen; # create temp file for working my ($sam_tmp_h, $sam_tmp_f) = $self->tempfile( -dir => $self->{'_tempdir'}, -suffix => '.sam' ); while (my $line = $self->_readline) { chomp($line); my ($qname,$strand,$rname,$pos,$seq,$qual,$m,$details)=split("\cI",$line); $SQ{$rname} = 1; my $paired_f = ($qname =~ m#/[12]#) ? 0x03 : 0; my $strand_f = ($strand eq '-') ? 0x10 : 0; my $op_strand_f = ($strand eq '+' && $paired_f) ? 0x20 : 0; my $first_f = ($qname =~ m#/1#) ? 0x40 : 0; my $second_f = ($qname =~ m#/2#) ? 0x80 : 0; my $flag = $paired_f | $strand_f | $op_strand_f | $first_f | $second_f; $pos++; my $len = length $seq; die unless $len == length $qual; my $cigar = $len.'M'; my @detail = split(',',$details); my $dist = 'NM:i:'.scalar @detail; my @mismatch; my $last_pos = 0; for (@detail) { m/(\d+):(\w)>\w/; my $err = ($1-$last_pos); $last_pos = $1+1; push @mismatch,($err,$2); } push @mismatch, $len-$last_pos; @mismatch = reverse @mismatch if $strand eq '-'; my $mismatch = join('',('MD:Z:',@mismatch)); if ($paired_f) { my $mrnm = '='; if ($in_pair) { my $mpos = $mate_line[3]; $mate_line[7] = $pos; my $isize = $mpos-$pos-$len; $mate_line[8] = -$isize; print $sam_tmp_h join("\t",@mate_line),"\n"; print $sam_tmp_h join("\t",$qname, $flag, $rname, $pos, $mapq, $cigar, $mrnm, $mpos, $isize, $seq, $qual, $mismatch, $dist),"\n"; $in_pair = 0; } else { $mlen = $len; @mate_line = ($qname, $flag, $rname, $pos, $mapq, $cigar, $mrnm, undef, undef, $seq, $qual, $mismatch, $dist); $in_pair = 1; } } else { my $mrnm = '*'; my $mpos = 0; my $isize = 0; print $sam_tmp_h join("\t",$qname, $flag, $rname, $pos, $mapq, $cigar, $mrnm, $mpos, $isize, $seq, $qual, $mismatch, $dist),"\n"; } } $sam_tmp_h->close; return $sam_tmp_f if $self->{'_no_head'}; my ($samh, $samf) = $self->tempfile( -dir => $self->{'_tempdir'}, -suffix => '.sam' ); # print header print $samh $HD; # print sequence dictionary unless ($self->{'_no_sq'}) { my $db = Bio::SeqIO->new( -file => $refdb, -format => 'fasta' ); while ( my $seq = $db->next_seq() ) { $SQ{$seq->id} = $seq->length if $SQ{$seq->id}; } map { print $samh join("\t", ('@SQ', "SN:$_", "LN:$SQ{$_}")), "\n" } keys %SQ; } # print program print $samh $PG; # print alignments open($sam_tmp_h, $sam_tmp_f) or $self->throw("Can not open '$sam_tmp_f' for reading: $!"); print $samh $_ while (<$sam_tmp_h>); close($sam_tmp_h); $samh->close; return $samf; } sub _uncompress { my ($self, $file) = @_; unless ($HAVE_IO_UNCOMPRESS) { croak( "IO::Uncompress::Gunzip not available, can't expand '$file'" ); } my ($tfh, $tf) = $self->tempfile( -dir => $self->{'_tempdir'} ); my $z = IO::Uncompress::Gunzip->new($file); while (my $block = $z->getline) { print $tfh $block } close $tfh; $file = $tf; return $file } sub _make_bam { my ($self, $file) = @_; $self->throw("'$file' does not exist or is not readable") unless ( -e $file && -r _ ); # make a sorted bam file from a sam file input my ($bamh, $bamf) = $self->tempfile( -dir => $self->{'_tempdir'}, -suffix => '.bam' ); my ($srth, $srtf) = $self->tempfile( -dir => $self->{'_tempdir'}, -suffix => '.srt' ); $_->close for ($bamh, $srth); my $samt = Bio::Tools::Run::Samtools->new( -command => 'view', -sam_input => 1, -bam_output => 1 ); $samt->run( -bam => $file, -out => $bamf ); $samt = Bio::Tools::Run::Samtools->new( -command => 'sort' ); $samt->run( -bam => $bamf, -pfx => $srtf); return $srtf.'.bam' } 1; BioPerl-1.6.923/Bio/Assembly/IO/maq.pm000555000765000024 4321512254227333 17402 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::IO::maq # # Copyright by Mark A. Jensen # # You may distribute this module under the same terms as Perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO::maq - Driver to read assembly files in maq format *BETA* =head1 SYNOPSIS # convert the native maq map format to plain text $ maq mapview all.map > all.maq # Building an input stream use Bio::Assembly::IO; # Assembly loading methods my $asmio = Bio::Assembly::IO->new( -file => 'all.maq', -format => 'maq' ); my $scaffold = $asmio->next_assembly; =head1 DESCRIPTION This package loads and writes map information in/from C map files converted by the C utility. This module is a driver module for Bio::Assembly::IO input/output. Parsing is based on Heng Li's description of C output, found at the C manpage: L. The basic C workflow is: map reads to a reference sequence (with C), then create a consensus from the map (with C). To read a complete assembly with this module, the following files need to be available: [basename].maq : created by maq mapview [basename].map > [basename].maq [basename].cns.fastq : created as follows $ maq assemble [basename].cns [refseq].bfa [basename].map $ maq cns2fq [basename].cns > [basename].cns.fastq C produces only one "contig"; all reads map to the reference sequence, which covers everything. This module breaks the reads into contigs by dividing the C consensus into pieces for which there are contiguous non-zero quality values. The module C will help in this process (eventually). This module has no write capability. =head2 Implementation Assemblies are loaded into Bio::Assembly::Scaffold objects composed of Bio::Assembly::Contig and Bio::Assembly::Singlet objects. Contigs are not explicitly specified in C files; the division of the map into contigs is calculated in this module. Additional assembly information is stored as features. Contig objects have SeqFeature information associated with the primary_tag: _main_contig_feature:$contig_id -> misc contig information Read objects have sub_seqFeature information associated with the primary_tag: _main_read_feature:$read_id -> misc read information Singlets are contigs of a single sequence, as calculated within this module. They are cataloged separately, as specified in L. =head1 TODO =over =item * Add pod descriptions of maq descriptive data (currently SeqFeatures added to each contig component) =item * Add features describing the aggregate status of reads and contigs based on the maq "paired flag" =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the BioPerl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via email or the web: bioperl-bugs@bio.perl.org https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj -at- fortinbras -dot- us =head1 CONTRIBUTORS Further improvements by Florent Angly (florent dot angly at gmail dot com) =head1 ACKNOWLEDGEMENT Code and some POD text ripped liberally from Florent Angly's L. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut package Bio::Assembly::IO::maq; use strict; use Bio::Seq::Quality; use Bio::Seq::PrimaryQual; use Bio::LocatableSeq; use Bio::Assembly::IO; use Bio::Assembly::Scaffold; use Bio::Assembly::Contig; use Bio::Assembly::Singlet; use Bio::SeqIO; use File::Spec; use File::Basename; use base qw(Bio::Assembly::IO); # paired flag constants use constant { FF => 1, FR => 2, RF => 4, RR => 8, PE => 16, XC => 32, UN => 64, CP => 18 }; my $progname = 'maq'; =head2 next_assembly Title : next_assembly Usage : $scaffold = $stream->next_assembly() Function: return the assembly defined by the map and cns files Returns : Bio::Assembly::Scaffold object Args : none =cut sub next_assembly { my $self = shift; my $assembly = Bio::Assembly::Scaffold->new( -progname => $progname ); # Load contigs and singlets in the scaffold while ( my $obj = $self->next_contig()) { # Add contig /singlet to assembly if ($obj->isa('Bio::Assembly::Singlet')) { # a singlet $assembly->add_singlet($obj); } else { # a contig $assembly->add_contig($obj); } } return $assembly; } =head2 next_contig Title : next_contig Usage : $scaffold = $stream->next_contig() Function: Returns the next contig or singlet in the ACE stream. Returns : a Bio::Assembly::Contig or Bio::Assembly::Single object Args : none =cut sub next_contig { my $self = shift; # object reference # Read the file of consensus sequences if it has not already been done for # this Bio:::Assembly::IO stream already if (not defined $self->_cons) { $self->_parse_cns_file or $self->throw("Associated maq consensus file is not available"); } # Contig and read related my $contigobj; my %contiginfo; # Loop over all assembly file lines while ($_ = $self->_readline) { chomp; next if /^$/; # mapview format parsing ; every line is a read... my %readinfo; @readinfo{ qw(read_name chr posn strand insert_size paired_flag map_qual se_map_qual alt_map_qual num_mm_best_hit sum_qual_mm_best_hit zero_mm_hits one_mm_hits read_len seqstr qualstr) } = split(/\s+/); # sanger conversion my @qual = map { ord($_)-33 } split('', $readinfo{qualstr}); $readinfo{seq} = Bio::Seq::Quality->new( -id => $readinfo{read_name}, -seq => $readinfo{seqstr}, -qual => \@qual ); if ( not defined $contiginfo{start} ) { # First read of new contig or singlet $contiginfo{'seqnum'} = 1; $contiginfo{'qualobj'} = $self->_next_cons; $contiginfo{'start'} = $contiginfo{'qualobj'}->start; $contiginfo{'end'} = $contiginfo{'qualobj'}->end; $contiginfo{'asmbl_id'} = 'maq_assy['.$self->_basename.']/'.$contiginfo{start}.'-'.$contiginfo{end}; # It may be a singlet, but assume it's a contig for now $contigobj = $self->_init_contig(\%contiginfo); $self->_store_read(\%readinfo, $contigobj); } else { if ( $readinfo{'posn'} <= $contiginfo{end} ) { # Add read to existing contig $contiginfo{'seqnum'}++; $self->_store_read(\%readinfo, $contigobj); } else { # Read belongs in a new contig if ($contiginfo{'seqnum'} > 1) { $self->_store_contig(\%contiginfo, $contigobj); } else { # singlet # Create a new singlet object from the read info $contigobj = $self->_store_singlet(\%contiginfo, $contigobj); } # do a pushback $self->_pushback($_); last; } } } return $contigobj; } =head2 _init_contig() Title : _init_contig Usage : my $contigobj; $contigobj = $self->_init_contig( \%contiginfo, $scaffoldobj); Function: store information of a contig belonging to a scaffold in the appropriate object Returns : Bio::Assembly::Contig object Args : hash, Bio::Assembly::Scaffold =cut sub _init_contig { my ($self, $contiginfo) = @_; # Create a contig and attach it to scaffold my $contigobj = Bio::Assembly::Contig->new( -id => $$contiginfo{'asmbl_id'}, -source => $progname, -strand => 1 ); return $contigobj; } =head2 _store_contig() Title : _store_contig Usage : my $contigobj; $contigobj = $self->_store_contig( \%contiginfo, $contigobj); Function: store information of a contig belonging to a scaffold in the appropriate object Returns : Bio::Assembly::Contig object Args : hash, Bio::Assembly::Contig =cut sub _store_contig { my ($self, $contiginfo, $contigobj) = @_; $self->throw("Contig object must be defined") unless $contigobj; my $consensus_seq = Bio::LocatableSeq->new( -id => $$contiginfo{'asmbl_id'}, -seq => $$contiginfo{'qualobj'}->seq, -start => 1, ); $contigobj->set_consensus_sequence($consensus_seq); my $consensus_qual = Bio::Seq::PrimaryQual->new( -id => $$contiginfo{'asmbl_id'}, -qual => $$contiginfo{'qualobj'}->qual, -start => 1, ); $contigobj->set_consensus_quality($consensus_qual); # Add other misc contig information as features of the contig # Add other misc read information as subsequence feature my @other = grep !/asmbl_id|end|qualobj|start/, keys %$contiginfo; my %other; @other{@other} = @$contiginfo{@other}; my $contigtags = Bio::SeqFeature::Generic->new( -primary => '_main_contig_feature', -source => $$contiginfo{'asmbl_id'}, -start => 1, -end => $contigobj->get_consensus_length(), -strand => 1, # dumping ground: -tag => \%other ); $contigobj->add_features([ $contigtags ], 1); return $contigobj; } =head2 _parse_cns_file() Title : _parse_cns_file Usage : $self->_parse_cns_file Function: parse the .cns.fastq (consensus) file associated with the present map; set the objects cns attribute Returns : true on success; nil if file dne Args : none =cut sub _parse_cns_file { my ($self) = @_; my @cons; $self->{'_cns_parsed'} = 1; my $file = $self->file; $file =~ s/^[<>+]*//; # byebye parasitic mode chars my ($fname, $dir, $suf) = fileparse($file, ".maq"); my $cnsf = File::Spec->catdir($dir, "$fname.cns.fastq"); return unless (-e $cnsf ); my $fqio = Bio::SeqIO->new( -file => $cnsf ); my $cns = $fqio->next_seq; # now, infer the contigs on the basis of quality values # - assuming quality of zero => no coverage my $qual = $cns->qual; # covered sites my @sites = grep { $$qual[$_] > 0 } (0..$#$qual); my @ranges = ($sites[0]+1); for my $i (1..$#sites) { if ($sites[$i]-$sites[$i-1]>1) { push @ranges, $sites[$i-1]+1, $sites[$i]+1; } } push @ranges, $sites[-1]; for (my $i = 0; $i<$#ranges; $i+=2) { push @cons, Bio::Seq::Quality->new( -display_id => "${fname}/".$ranges[$i]."-".$ranges[$i+1], -start => $ranges[$i], -end => $ranges[$i+1], -seq => $cns->subseq($ranges[$i], $ranges[$i+1]), -qual => [@{$cns->qual}[$ranges[$i]-1..$ranges[$i+1]-1]] ); } $self->{'_cons'} = \@cons; return 1; } =head2 _cons() Title : _cons Usage : @cons = $self->_cons Function: get the array of consensus fastq Bio::Seq::Quality objects Returns : array of Bio::Seq::Quality objects Args : none =cut sub _cons { my $self = shift; my $cons = undef; if (defined $self->{'_cons'}) { $cons = $self->{'_cons'}; } return $cons; } =head2 _next_cons() =cut sub _next_cons { shift(@{shift->{'_cons'}}) } =head2 _store_read() Title : _store_read Usage : my $readobj = $self->_store_read(\%readinfo, $contigobj); Function: store information of a read belonging to a contig in the appropriate object Returns : a Bio::LocatableSeq object Args : hash, Bio::Assembly::Contig =cut # @readinfo{ qw(read_name chr posn strand insert_size, # paired_flag map_qual se_map_qual alt_map_qual, # num_mm_best_hit sum_qual_mm_best_hit zero_mm_hits, # one_mm_hits seqstr qualstr) } = split(/\s+/); sub _store_read { my ($self, $readinfo, $contigobj) = @_; # Create an aligned read object $$readinfo{'strand'} = ($$readinfo{strand} eq '+' ? 1 : -1); my $readobj = Bio::LocatableSeq->new( -display_id => $$readinfo{'read_name'}, -primary_id => $$readinfo{'read_name'}, -seq => $$readinfo{'seqstr'}, -start => 1, -strand => $$readinfo{'strand'}, -alphabet => 'dna' ); # Add read location and sequence to contig (in 'gapped consensus' coordinates) $$readinfo{'aln_start'} = $$readinfo{'posn'}; $$readinfo{'aln_end'} = $$readinfo{'posn'} + length($$readinfo{'seqstr'})-1; my $alncoord = Bio::SeqFeature::Generic->new( -primary => $readobj->id, -start => $$readinfo{'aln_start'}, -end => $$readinfo{'aln_end'}, -strand => $$readinfo{'strand'}, -qual => join(' ', $$readinfo{seq}->qual), # check here, need to create contigs "by hand"... -tag => { 'contig' => $contigobj->id() } ); $contigobj->set_seq_coord($alncoord, $readobj); # Add other misc read information as subsequence feature my @other = grep !/aln_(?:end|start)|seq(?:str)?|strand/, keys %$readinfo; my %other; @other{@other} = @$readinfo{@other}; my $readtags = Bio::SeqFeature::Generic->new( -primary => '_main_read_feature', -source => $readobj->id, -start => $$readinfo{'aln_start'}, -end => $$readinfo{'aln_end'}, -strand => $$readinfo{'strand'}, # dumping ground: -tag => \%other ); $contigobj->get_features_collection->add_features([$readtags]); $contigobj->get_features_collection->add_SeqFeature($alncoord, $readtags); return $readobj; } #### revamp for maq =head2 _store_singlet() Title : _store_singlet Usage : my $singletobj = $self->_store_read(\%readinfo, \%contiginfo); Function: store information of a singlet belonging to a scaffold in a singlet object Returns : Bio::Assembly::Singlet Args : hash, hash =cut sub _store_singlet { my ($self, $contiginfo, $contigobj) = @_; my $contigid = $$contiginfo{'asmbl_id'}; my $seqref = ($contigobj->each_seq())[0]; my $singletobj = Bio::Assembly::Singlet->new( -id => $contigid, -seqref => $seqref ); # Add other misc contig information as features of the contig # Add other misc read information as subsequence feature #my @other = grep !/_sfc|_assembly|_elem/, keys %$contiginfo; # remove the objects; _elem contains a code ref and can't be frozen. Just shooting blind here. #my %other; #@other{@other} = @$contiginfo{@other}; #my $contigtags = Bio::SeqFeature::Generic->new( # -primary => '_main_contig_feature', # -source => $$contiginfo{asmbl_id}, # -start => 1, # -end => $singletobj->get_consensus_length(), # -strand => 1, # # dumping ground: # -tag => \%other #); #$singletobj->add_features([ $contigtags ], 1); #$$readinfo{'aln_start'} = $$readinfo{'start'}; #$$readinfo{'aln_end'} = $$readinfo{'end'}; #$$readinfo{'strand'} = ($$readinfo{strand} eq '+' ? 1 : -1); #my $alncoord = Bio::SeqFeature::Generic->new( # -primary => '_aligned_coord', # -source => $$readinfo{read_name}, # -start => $$readinfo{'start'}, # -end => $$readinfo{'end'}, # -strand => $$readinfo{'strand'}, # -tag => { 'contig' => $$contiginfo{asmbl_id} } # ); #$alncoord->attach_seq($singletobj->seqref); #$singletobj->add_features([ $alncoord ], 0); # Add other misc read information as subsequence feature #my @other = grep !/seqstr|strand/, keys %$readinfo; #my %other; #@other{@other} = @$readinfo{@other}; #my $readtags = Bio::SeqFeature::Generic->new( # -primary => '_main_read_feature', # -source => $$readinfo{read_name}, # -start => $$readinfo{'aln_start'}, # -end => $$readinfo{'aln_end'}, # -strand => $$readinfo{'strand'}, # # dumping ground: # -tag => \%other # ); #$singletobj->get_features_collection->add_features([$readtags]); #$singletobj->get_features_collection->add_SeqFeature($alncoord, $readtags); return $singletobj; } ###### writes -- need them?? =head2 write_assembly() Title : write_assembly Usage : Function: not currently available for maq assemblies Returns : throw Args : =cut sub write_assembly { my ($self,@args) = @_; $self->throw("Writes not currently available for maq assemblies. Complain to author.") } =head2 _basename() Title : _basename Usage : $self->_basename Function: return the basename of the associate IO file Returns : scalar string Args : none =cut sub _basename { my $self = shift; return (fileparse($self->file, ".maq"))[0]; } 1; __END__ BioPerl-1.6.923/Bio/Assembly/IO/phrap.pm000444000765000024 3474212254227317 17742 0ustar00cjfieldsstaff000000000000# # BioPerl driver for phrap.out file # # Copyright by Robson F. de Souza # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO::phrap - driver to load phrap.out files. =head1 SYNOPSIS # Building an input stream use Bio::Assembly::IO; # Assembly loading methods my $io = Bio::Assembly::IO->new( -file => 'results.phrap', -format => 'phrap'); # Read the entire scaffold my $scaffold = $io->next_assembly; # Or read one contig at a time to save resources while ( my $contig = $io->next_contig ) { # Do something ... } =head1 DESCRIPTION This package was developed to load the phrap.out files from the (phred/phrap/consed) package by Phill Green. This files contain just the messages printed to standard out by phrap when building an assembly. This output is redirected by phredPhrap perl-script to a file in the project's directory and hold some bit of information regarding assembly quality, connections between contigs and clone's position inside contigs. It should be noted that such files have no data about the sequence. neither for contig consensus nor for any aligned sequence. Anyway, such information may be loaded from Fasta files in the projects directory and added to the assembly object later. Note that, because no sequence is loaded for the contig consensus and locations for aligned sequences are only given in "ungapped consensus" coordinates in a phrap.out file, you can't make coordinate changes in assemblies loaded by pharp.pm, unless you add an aligned coordinates for each sequence to each contig's features collection yourself. See L and L.. This driver also loads singlets into the assembly contigs as Bio::Assembly::Singlet objects, although without their sequence strings. It also adds a feature for the entire sequence, thus storing the singlet length in its end position, and adds a tag '_nof_trimmed_nonX' to the feature, which stores the number of non-vector bases in the singlet. =head2 Implementation Assemblies are loaded into Bio::Assembly::Scaffold objects composed by Bio::Assembly::Contig objects. No features are added to Bio::Assembly::Contig "_aligned_coord:$seqID" feature class, therefore you can't make coordinate changes in contigs loaded by this module. Contig objects created by this module will have the following special feature classes, identified by their primary tags, in their features collection: "_main_contig_feature:$ID" : main feature for contig $ID. This feature is used to store information about the entire consensus sequence. This feature always start at base 1 and its end position is the consensus sequence length. A tag, 'trimmed_length' holds the length of the trimmed good quality region inside the consensus sequence. "_covered_region:$index" : coordinates for valid clones inside the contig. $index is the covered region number, starting at 1 for the covered region closest to the consensus sequence first base. "_unalign_coord:$seqID" : location of a sequence in "ungapped consensus" coordinates (consensus sequence without gaps). Primary and secondary scores, indel and substitutions statistics are stored as feature tags. "_internal_clones:$cloneID" : clones inside contigs $cloneID should be used as the unique id for each clone. These features have six tags: '_1st_name', which is the id of the upstream (5') aligned sequence delimiting the clone; '_1st_strand', the upstream sequence strand in the alignment; '_2nd_name', downstream (3') sequence id; '_2nd_strand', the downstream sequence strand in the alignment; '_length', unaligned clone length; '_rejected', a boolean flag, which is false if the clone is valid and true if it was rejected. All coordinates for the features above are expressed as "ungapped consensus" coordinates (See L.. =head2 Feature collection # =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Robson Francisco de Souza Email rfsouza@citri.iq.usp.br head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Assembly::IO::phrap; use strict; use Bio::Assembly::Scaffold; use Bio::Assembly::Singlet; use Bio::Assembly::Contig; use Bio::LocatableSeq; use Bio::Seq; use Bio::SeqFeature::Generic; use base qw(Bio::Assembly::IO); our $progname = 'phrap'; =head1 Parser methods =head2 next_assembly Title : next_assembly Usage : $scaffold = $stream->next_assembly() Function: returns the next assembly in the stream Returns : a Bio::Assembly::Scaffold object Args : none =cut sub next_assembly { my $self = shift; my $assembly = Bio::Assembly::Scaffold->new( -source => $progname ); # Load contigs and singlets in the scaffold while ( my $obj = $self->next_contig()) { # Add contig /singlet to assembly if ($obj->isa('Bio::Assembly::Singlet')) { # a singlet $assembly->add_singlet($obj); } else { # a contig $assembly->add_contig($obj); } } # Load annotations of assembly and contigs $self->scaffold_annotations($assembly); return $assembly; } =head2 next_contig Title : next_contig Usage : $scaffold = $stream->next_contig() Function: Returns the next contig or singlet in the PHRAP stream. Returns : a Bio::Assembly::Contig or Bio::Assembly::Single object Args : none =cut sub next_contig { my $self = shift; # Package reference # Looping over all phrap out file lines my $contigOBJ; while ($_ = $self->_readline) { chomp; # Loading singlets reads data #/^(\d+) isolated singlet/ && do { # should it match 'singlets' and 'singletons'? # while ($_ = $self->_readline) { # chomp; # last if (/^$/); /^\s+(\S+)\s+(\d+)\s+\((\d+)\)/ && do { my ($singletID, $length, $nof_trimmed_nonX) = ($1, $2, $3); # Create singlet object, and add it to scaffold my $seq = Bio::LocatableSeq->new( -id => $singletID, -primary_id => $singletID, -start => 1, -end => $length, -strand => 1, -nowarnonempty => 1, -alphabet => 'dna' ); $contigOBJ = Bio::Assembly::Singlet->new( -id => $singletID, -seqref => $seq, -verbose => $self->verbose ); my $feat = Bio::SeqFeature::Generic->new( -start => 1, -end => $length, -primary => "_main_contig_feature", -source => $contigOBJ->id, -tag => { '_nof_trimmed_nonX' => $nof_trimmed_nonX } ); $contigOBJ->add_features([ $feat ],1); # Go to return statement last; }; # } #}; # Loading contig information /^Contig (\d+)\.\s+(\d+) reads?; (\d+) bp \(untrimmed\), (\d+) \(trimmed\)\./ && do { my ($contigID, $nof_reads, $length, $trimmed_length) = ($1, $2, $3, $4); $contigOBJ = Bio::Assembly::Contig->new( -id => $contigID, -verbose => $self->verbose, -source => 'phrap' ); my $feat = Bio::SeqFeature::Generic->new( -start => 1, -end => $length, -primary => "_main_contig_feature", -source => $contigOBJ->id, -tag => { '_trimmed_length' => $trimmed_length } ); $contigOBJ->add_features([ $feat ],1); }; # Loading read information /^(C?)\s+(-?\d+)\s+(\d+)\s+(\S+)\s+(\d+)\s+\(\s*(\d+)\)\s+(\d+\.\d*)\s+(\d+\.\d*)\s+(\d+\.\d*)/ && do { my ($strand, $start, $end, $readID, $primary_score, $secondary_score, $substitutions, $deletions, $insertions) = ($1, $2, $3, $4, $5, $6, $7, $8, $9); $strand = ($strand eq 'C' ? -1 : 1); my $seq = Bio::LocatableSeq->new( -start => $start, -end => $end, -nowarnonempty => 1, -strand => $strand, -id => $readID, -primary_id => $readID, -alphabet => 'dna'); my $unalign_coord = Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -primary => "_unalign_coord", -source => $readID, -tag => {'_primary_score'=>$primary_score, '_secondary_score'=>$secondary_score, '_substitutions'=>$substitutions, '_insertions'=>,$insertions, '_deletions'=>$deletions } ); $unalign_coord->attach_seq($seq); $contigOBJ->add_seq($seq); $contigOBJ->add_features([ $unalign_coord ]); }; /^$/ && do { # blank line, could be the end of a contig if ($contigOBJ) { # Go to the return statement last; } }; } # while ($_ = $self->_readline) return $contigOBJ; } =head2 scaffold_annotations Title : scaffold_annotations Usage : $stream->scaffold_annotations($scaffold) Function: Adds ssembly and contig annotations to a scaffold. In the PHRAP format, this is the section starting with "INTERNAL" Returns : 1 for success Args : a Bio::Assembly::Scaffold object to attach the annotations to =cut sub scaffold_annotations { my ($self, $assembly) = @_; # Read the PHRAP stream from the beginning again seek($self->_fh, 0, 0); while ($_ = $self->_readline) { chomp; # Loading exact dupicated reads list # /Exact duplicate reads:/ && do { # my @exact_dupl; # while () { # last if (/^\s*$/); # /(\S+)\s+(\S+)/ && do { # push(@exact_dupl,[$1,$2]); # }; # $self->{'assembly'}{'exact_dupl_reads'} = # new Data::Table(\@exact_dupl,['included','excluded'],0); # } # }; # Loading INTERNAL clones description /INTERNAL\s+Contig\s+(\d+)\s+opp\s+sense/ && do { my $contigID = $1; my $contig = $assembly->get_contig_by_id($contigID) || $assembly->get_singlet_by_id($contigID); while ($_ = $self->_readline) { my (@data,$rejected,$c1_strand,$c2_strand); (@data = /\s+(\*?)\s+(C?)\s+(\S+)\s+(C?)\s+(\S+)\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)/) && do { if ($data[0] eq '*') { $rejected = 1 } else { $rejected = 0 } $c1_strand = ($data[1] eq 'C' ? -1 : 1); $c2_strand = ($data[3] eq 'C' ? -1 : 1); (my $clone_name = $data[2]) =~ s/^(\S+)\.\w.*/$1/; my $clone = Bio::SeqFeature::Generic->new( -start => $data[6], -end => $data[7], -strand => 0, -primary => "_internal_clone", -source => $clone_name, -tag => {'_1st_strand'=>,$c1_strand, '_2nd_strand'=>,$c2_strand, '_1st_name'=>$data[2], '_2nd_name'=>$data[4], '_length'=>$data[5], '_rejected'=>$rejected} ); $contig->add_features([ $clone ]); }; /Covered regions:/ && do { my %coord = /(\d+)/g; my $i = 0; foreach my $start (sort { $a <=> $b } keys %coord) { my $cov = Bio::SeqFeature::Generic->new( -start => $start, -end => $coord{$start}, -primary => '_covered_region', -source => ++$i, ); # 1: attach feature to contig consensus, if any $contig->add_features([ $cov ],1); } last; # exit while loop }; # /Covered regions:/ } # while ($_ = $self->_readline) }; # /INTERNAL\s+Contig\s+(\d+)\s+opp\s+sense/ } # while ($_ = $self->_readline) return 1; } =head2 write_assembly (NOT IMPLEMENTED) Title : write_assembly Usage : $ass_io->write_assembly($assembly) Function: Write the assembly object in Phrap compatible ACE format Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object =cut sub write_assembly { my $self = shift; $self->throw_not_implemented(); } 1; __END__ BioPerl-1.6.923/Bio/Assembly/IO/sam.pm000555000765000024 5525312254227317 17413 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::IO::sam # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO::sam - An IO module for assemblies in Sam format *BETA* =head1 SYNOPSIS $aio = Bio::Assembly::IO( -file => "mysam.bam", -refdb => "myrefseqs.fas"); $assy = $aio->next_assembly; =head1 DESCRIPTION This is a (currently) read-only IO module designed to convert Sequence/Alignment Map (SAM; L) formatted alignments to L representations, containing .L and L objects. It uses lstein's L to parse binary formatted SAM (.bam) files guided by a reference sequence fasta database. B: C is not a BioPerl module; it can be obtained via CPAN. It in turn requires the C library; source can be downloaded at L. =head1 DETAILS =over =item * Required files A binary SAM (C<.bam>) alignment and a reference sequence database in FASTA format are required. Various required indexes (C<.fai>, C<.bai>) will be created as necessary (via L). =item * Compressed files ...can be specified directly , if L is installed. Get it from your local CPAN mirror. =item * BAM vs. SAM The input alignment should be in (possibly gzipped) binary SAM (C<.bam>) format. If it isn't, you will get a message explaining how to convert it, viz.: $ samtools view -Sb mysam.sam > mysam.bam The bam file must also be sorted on coordinates: do $ samtools sort mysam.unsorted.bam > mysam.bam =item * Contigs Contigs are calculated by this module, using the 'coverage' feature of the L object. A contig represents a contiguous portion of a reference sequence having non-zero coverage at each base. The bwa assembler (L) can assign read sequences to multiple reference sequence locations. The present implementation currently assigns such reads only to the first contig in which they appear. =item * Consensus sequences Consensus sequence and quality objects are calculated by this module, using the C callback feature of C. The consensus is (currently) simply the residue at a position that has the maximum sum of quality values. The consensus quality is the integer portion of the simple average of quality values for the consensus residue. =item * SeqFeatures Read sequences stored in contigs are accompanied by the following features: contig : name of associated contig cigar : CIGAR string for this read If the read is paired with a successfully mapped mate, these features will also be available: mate_start : coordinate of to which the mate was aligned mate_len : length of mate read mate_strand : strand of mate (-1 or 1) insert_size : size of insert spanned by the mate pair These features are obtained as follows: @ids = $contig->get_seq_ids; $an_id = $id[0]; # or whatever $seq = $contig->get_seq_by_name($an_id); # Bio::LocatableSeq's aren't SeqFeature containers, so... $feat = $contig->get_seq_feat_by_tag( $seq, "_aligned_coord:".$s->id ); ($cigar) = $feat->get_tag_values('cigar'); # etc. =back =head1 TODO =over =item * Supporting both text SAM (TAM) and binary SAM (BAM) =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: L rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj -at- fortinbras -dot- us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Assembly::IO::sam; use strict; use warnings; # Object preamble - inherits from Bio::Root::Root use Bio::Seq::Quality; use Bio::Seq::PrimaryQual; use Bio::LocatableSeq; use Bio::Assembly::IO; use Bio::Assembly::Scaffold; use Bio::Assembly::Contig; use Bio::Assembly::Singlet; use Bio::SeqIO; use File::Spec; use File::Basename; use File::Temp qw(tempfile); use Carp; use Bio::Root::Root; use base qw(Bio::Root::Root Bio::Assembly::IO Bio::Root::IO); our $HAVE_IO_UNCOMPRESS; BEGIN { # check requirements unless ( eval "require Bio::DB::Sam; 1" ) { Bio::Root::Root->throw(__PACKAGE__.' requires installation of samtools (libbam) and Bio::DB::Sam (available on CPAN; not part of BioPerl)'); } unless ( eval "require IO::Uncompress::Gunzip; \$HAVE_IO_UNCOMPRESS = 1") { Bio::Root::Root->warn("IO::Uncompress::Gunzip is not available; you'll have to do your decompression by hand."); } } my $progname = 'sam'; sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args); my ($file, $refdb, $format) = $self->_rearrange([qw(FILE REFDB FORMAT)], @args); $self->file($file); $refdb && $self->refdb($refdb); $self->_init_sam() or croak( "Sam initialization failed" ); $self->{_assigned} = {}; return $self; } =head1 Bio::Assembly::IO compliance =head2 next_assembly() Title : next_assembly Usage : my $scaffold = $asmio->next_assembly(); Function: return the next assembly in the sam-formatted stream Returns : Bio::Assembly::Scaffold object Args : none =cut sub next_assembly { my $self = shift; my @contig_set; # get Bio::DB::Sam object # could add a refdb or fasfile attribute to contain the reference db name # iterate through seq_ids... my @refseq_ids = $self->sam->seq_ids; my $assembly = Bio::Assembly::Scaffold->new( -progname => $progname ); foreach my $id (@refseq_ids) { #### this is choice 1: all refseqs into one assy...### $self->_current_refseq_id( $id ); # Load contigs and singlets in the scaffold while ( my $obj = $self->next_contig()) { # Add contig /singlet to assembly if ($obj->isa('Bio::Assembly::Singlet')) { # a singlet $assembly->add_singlet($obj); } else { # a contig $assembly->add_contig($obj); } } } return $assembly; } =head2 next_contig() Title : next_contig Usage : my $contig = $asmio->next_contig(); Function: return the next contig or singlet from the sam stream Returns : Bio::Assembly::Contig or Bio::Assembly::Singlet Args : none =cut sub next_contig { my $self = shift; if (!defined $self->_current_contig_seg_idx) { $self->_current_contig_seg_idx(0); } else { $self->_current_contig_seg_idx( 1+$self->_current_contig_seg_idx ); } unless ($self->_current_refseq_id) { croak("No current refseq id set"); } my $contig_segs = $self->_segset($self->_current_refseq_id); unless ($contig_segs && @$contig_segs) { croak("No contig segset for current id '".$self->_current_refseq_id."'") } # each segment in @$contig_segs represents a contig within the # current refseq my $contig_seg = $$contig_segs[$self->_current_contig_seg_idx]; return if (!defined $contig_seg); # iterator finished # each 'feature' in $contig_seg represents a read; # $seqio lets us iterate efficiently over the reads: my $seqio = $contig_seg->features(-iterator => 1); # Contig and read related my $contigobj = $self->_store_contig($contig_seg); my $numseq = 0; while ( my $read = $seqio->next_seq ) { if ($self->{_assigned}->{$read->name}) { next; } $self->{_assigned}->{$read->name}=1; $self->_store_read($read, $contigobj); $numseq++; } if ($numseq == 1) { # ooh! a singlet! $contigobj = $self->_store_singlet($contigobj); } return $contigobj; } =head2 write_assembly() Title : write_assembly Usage : Function: not implemented (module currrently read-only) Returns : Args : =cut sub write_assembly { my $self = shift; $self->throw( "This module is currently read-only" ); } =head1 Internal =head2 _store_contig() Title : _store_contig Usage : my $contigobj = $self->_store_contig(\%contiginfo); Function: create and load a contig object Returns : Bio::Assembly::Contig object Args : Bio::DB::Sam::Segment object =cut sub _store_contig { my ($self, $contig_seg) = @_; # Create a contig my $contigobj = Bio::Assembly::Contig->new( -id => 'sam_assy['.$self->_basename.':'.$self->_current_refseq_id.']/'.$contig_seg->start.'-'.$contig_seg->end, -source => $progname, -strand => 1 ); my $consobj = $self->_calc_consensus($contig_seg); my $consensus_seq = Bio::LocatableSeq->new( -id => $contigobj->id, -seq => $consobj->seq, -start => 1, ); $contigobj->set_consensus_sequence($consensus_seq); my $consensus_qual = Bio::Seq::PrimaryQual->new( -id => $contigobj->id, -qual => $consobj->qual, -start => 1, ); $contigobj->set_consensus_quality($consensus_qual); # Add other misc contig information as subsequence feature #my @other = grep !/asmbl_id|end|qualobj|start/, keys %$contiginfo; #my %other; #@other{@other} = @$contiginfo{@other}; #my $contigtags = Bio::SeqFeature::Generic->new( # -primary => '_main_contig_feature', # -source => $$contiginfo{'asmbl_id'}, # -start => 1, # -end => $contig_seg->length, # -strand => 1, # # dumping ground: # -tag => \%other #); #$contigobj->add_features([ $contigtags ], 1); return $contigobj; } =head2 _store_read() Title : _store_read Usage : my $readobj = $self->_store_read($readobj, $contigobj); Function: store information of a read belonging to a contig in a contig object Returns : Bio::LocatableSeq Args : Bio::DB::Bam::AlignWrapper, Bio::Assembly::Contig =cut sub _store_read { my $self = shift; my ($read, $contigobj) = @_; my $readseq = Bio::LocatableSeq->new( -display_id => $read->name, -primary_id => $read->name, -seq => $read->dna, -start => 1, -strand => $read->strand, -alphabet => 'dna' ); my $qual = Bio::Seq::PrimaryQual->new( -id => $read->name."_qual", -qual => [$read->qscore] ); # add pair information my @pair_info; if ($read->proper_pair) { # mate also aligned @pair_info = ( mate_start => $read->mate_start, mate_len => $read->mate_len, mate_strand => $read->mstrand, insert_size => $read->isize ); } my $alncoord = Bio::SeqFeature::Generic->new( -primary => $read->name, -start => $read->start, -end => $read->end, -strand => $read->strand, -qual => join(' ',$read->qscore), -tag => { 'contig' => $contigobj->id, 'cigar' => $read->cigar_str, @pair_info } ); $contigobj->set_seq_coord($alncoord, $readseq); $contigobj->set_seq_qual( $readseq, $qual ); #add other misc read info as subsequence feature: #my @other = grep !/aln_(?:end|start)|seq(?:str)?|strand/, keys %$readinfo; #my %other; #@other{@other} = @$readinfo{@other}; #my $readtags = Bio::SeqFeature::Generic->new( # -primary => '_main_read_feature', # -source => $readobj->id, # -start => $$readinfo{'aln_start'}, # -end => $$readinfo{'aln_end'}, # -strand => $$readinfo{'strand'}, # # dumping ground: # -tag => \%other #); #$contigobj->get_features_collection->add_features([$readtags]); #$contigobj->get_features_collection->add_SeqFeature($alncoord, $readtags); return $readseq; } =head2 _store_singlet() Title : _store_singlet Usage : my $singletobj = $self->_store_singlet($contigobj); Function: convert a contig object containing a single read into a singlet object Returns : Bio::Assembly::Singlet Args : Bio::Assembly::Contig (previously loaded with only one seq) =cut sub _store_singlet { my $self = shift; my ($contigobj) = @_; my ($readseq) = $contigobj->each_seq; my $singletobj = Bio::Assembly::Singlet->new( -id => $contigobj->id, -seqref => $readseq ); # may want to attach this someday # my $qual = $contigobj->get_qual_by_name($readseq->id); return $singletobj; } =head1 REALLY Internal =head2 _init_sam() Title : _init_sam Usage : $self->_init_sam($fasfile) Function: obtain a Bio::DB::Sam parsing of the associated sam file Returns : true on success Args : [optional] name of the fasta reference db (scalar string) Note : The associated file can be plain text (.sam) or binary (.bam); If the fasta file is not specified, and no file is contained in the refdb() attribute, a .fas file with the same basename as the sam file will be searched for. =cut sub _init_sam { my $self = shift; my $fasfile = shift; my $file = $self->file; my $sam; $fasfile ||= $self->refdb; $file =~ s/^[<>+]*//; # byebye parasitic mode chars my ($fname, $dir, $suf) = fileparse($file, ".sam", ".bam"); $self->_set_from_args({ '_basename' => $fname }, -methods => [qw( _basename)], -create => 1); if (!defined $fasfile) { for (qw( fas fa fasta fas.gz fa.gz fasta.gz )) { $fasfile = File::Spec->catdir($dir, $self->_basename.$_); last if -e $fasfile; undef $fasfile; } } unless (-e $fasfile) { croak( "Can't find associated reference fasta db" ); } !$self->refdb && $self->refdb($fasfile); # compression if ($fasfile =~ /\.gz[^.]*$/) { unless ($HAVE_IO_UNCOMPRESS) { croak( "IO::Uncompress::Gunzip not available; can't decompress on the fly"); } my ($tfh, $tf) = tempfile( UNLINK => 1); my $z = IO::Uncompress::Gunzip->new($fasfile) or croak("Can't expand: $@"); while (<$z>) { print $tfh $_ } close $tfh; $fasfile = $tf; } if ($file =~ /\.gz[^.]*$/) { unless ($HAVE_IO_UNCOMPRESS) { croak( "IO::Uncompress::Gunzip not available; can't decompress on the fly"); } my ($tfh, $tf) = tempfile( UNLINK => 1); my $z = IO::Uncompress::Gunzip->new($file) or croak("Can't expand: $@"); while (<$z>) { print $tfh $_; } close $tfh; $file = $tf; } # sam conversion : just barf for now if (-T $file) { my $bam = $file; $bam =~ s/\.sam/\.bam/; croak( "'$file' looks like a text file.\n\tTo convert to the required .bam (binary SAM) format, run\n\t\$ samtools view -Sb $file > $bam\n"); } $sam = Bio::DB::Sam->new( -bam => $file, -fasta => $fasfile, -autoindex => 1, -expand_flags => 1); unless (defined $sam) { croak( "Couldn't create the Bio::DB::Sam object" ); } $self->{sam} = $sam; # now produce the contig segments for each seq_id... for ($sam->seq_ids) { my $seg = $sam->segment(-seq_id=>$_, -start=>1, -end=>$sam->length($_)); ${$self->{_segset}}{$_} = [$self->_get_contig_segs_from_coverage($seg)]; } return 1; } =head2 _get_contig_segs_from_coverage() Title : _get_contig_segs_from_coverage Usage : Function: calculates separate contigs using coverage info in the segment Returns : array of Bio::DB::Sam::Segment objects, representing each contig Args : Bio::DB::Sam::Segment object =cut sub _get_contig_segs_from_coverage { my $self = shift; my $segment = shift; unless ($self->sam) { croak("Sam object not yet initialized (call _init_sam)"); } unless ( ref($segment) =~ /Bio::DB::Sam::Segment/ ) { croak("Requires Bio::DB::Sam::Segment object at arg 1"); } my ($cov, @covdata, @rngs, @segs); ($cov) = $segment->features('coverage'); unless ($cov) { croak("No coverage data!"); } @covdata = $cov->coverage; # calculate contigs: my $in_contig; my ($lf_end,$rt_end); for (0..$#covdata) { if ($covdata[$_]) { if ($in_contig) { $rt_end = $_+1; next; } else { $in_contig = 1; # push previous range if (defined $lf_end && defined $rt_end) { push @rngs, [$lf_end, $rt_end]; } $lf_end = $_+1; } } else { $in_contig = 0; } } # last one push @rngs, [$lf_end, $rt_end] if (defined $lf_end and defined $rt_end and $lf_end <= $rt_end); unless (@rngs) { carp ("No coverage for this segment!"); return; } for (@rngs) { push @segs, $self->sam->segment(-seq_id=>$segment->seq_id, -start=>$$_[0], -end=>$$_[1]); } return @segs; } =head2 _calc_consensus_quality() Title : _calc_consensus_quality Usage : @qual = $aio->_calc_consensus_quality( $contig_seg ); Function: calculate an average or other data-reduced quality over all sites represented by the features contained in a Bio::DB::Sam::Segment Returns : Args : a Bio::DB::Sam::Segment object =cut sub _calc_consensus_quality { # just an average over sites for now... my $self = shift; my $seg = shift; my @quals; my $region = $seg->seq_id.':'.$seg->start.'..'.$seg->end; my $qual_averager = sub { my ($seqid, $pos, $p) = @_; return unless ($seg->start <= $pos and $pos <= $seg->end); my $acc = 0; my $n = 0; for my $pileup (@$p) { my $b = $pileup->alignment; $acc += $b->qscore->[$pileup->qpos]; $n++; } push @quals, int($acc/$n); }; $self->sam->pileup($region, $qual_averager); return @quals; } =head2 _calc_consensus() Title : _calc_consensus Usage : @qual = $aio->_calc_consensus( $contig_seg ); Function: calculate a simple quality-weighted consensus sequence for the segment Returns : a SeqWithQuality object Args : a Bio::DB::Sam::Segment object =cut sub _calc_consensus { # just an average over sites for now... my $self = shift; my $seg = shift; my @quals; my $conseq =''; my $region = $seg->seq_id.':'.$seg->start.'-'.$seg->end; my $weighted_consensus = sub { my ($seqid, $pos, $p) = @_; return unless ($seg->start <= $pos and $pos <= $seg->end); my %wt_tbl; my %n; for my $pileup (@$p) { my $b = $pileup->alignment; my $res = substr($b->qseq,$pileup->qpos,1); $wt_tbl{$res} += $b->qscore->[$pileup->qpos] || 0; $n{$res} ||= 0; $n{$res}++; } # really simple my $c = (sort { $wt_tbl{$b}<=>$wt_tbl{$a} } keys %wt_tbl)[0]; $conseq .= $c; push @quals, int($wt_tbl{$c}/$n{$c}); }; $self->sam->pileup($region, $weighted_consensus); return Bio::Seq::Quality->new( -qual => join(' ', @quals ), -seq => $conseq, -id => $region ); } =head2 refdb() Title : refdb Usage : $obj->refdb($newval) Function: the name of the reference db fasta file Example : Returns : value of refdb (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub refdb { my $self = shift; return $self->{'refdb'} = shift if @_; return $self->{'refdb'}; } =head2 _segset() Title : _segset Usage : $segset_hashref = $self->_segset() Function: hash container for the Bio::DB::Sam::Segment objects that represent each set of contigs for each seq_id { $seq_id => [@contig_segments], ... } Example : Returns : value of _segset (a hashref) if no arg, or the arrayref of contig segments, if arg == a seq id Args : [optional] seq id (scalar string) Note : readonly; hash elt set in _init_sam() =cut sub _segset { my $self = shift; return $self->{'_segset'} unless @_; return ${$self->{'_segset'}}{shift()}; } =head2 _current_refseq_id() Title : _current_refseq_id Usage : $obj->_current_refseq_id($newval) Function: the "current" reference sequence id Example : Returns : value of _current_refseq (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _current_refseq_id { my $self = shift; return $self->{'_current_refseq_id'} = shift if @_; return $self->{'_current_refseq_id'}; } =head2 _current_contig_seg_idx() Title : current_contig_seg_idx Usage : $obj->current_contig_seg_idx($newval) Function: the "current" segment index in the "current" refseq Example : Returns : value of current_contig_seg_idx (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _current_contig_seg_idx { my $self = shift; return $self->{'_current_contig_seg_idx'} = shift if @_; return $self->{'_current_contig_seg_idx'}; } =head2 sam() Title : sam Usage : $obj->sam($newval) Function: store the associated Bio::DB::Sam object Example : Returns : value of sam (a Bio::DB::Sam object) Args : on set, new value (a scalar or undef, optional) =cut sub sam { my $self = shift; return $self->{'sam'}; } sub DESTROY { my $self = shift; undef $self->{'sam'}; delete $self->{_segset}->{$_} foreach (keys %{$self->{_segset}}); } 1; BioPerl-1.6.923/Bio/Assembly/IO/tigr.pm000444000765000024 14527212254227314 17613 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::IO::tigr # # Copyright by Florent Angly # # You may distribute this module under the same terms as Perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::IO::tigr - Driver to read and write assembly files in the TIGR Assembler v2 default format. =head1 SYNOPSIS # Building an input stream use Bio::Assembly::IO; # Assembly loading methods my $asmio = Bio::Assembly::IO->new( -file => 'SGC0-424.tasm', -format => 'tigr' ); my $scaffold = $asmio->next_assembly; # Do some things on contigs... # Assembly writing methods my $outasm = Bio::Assembly::IO->new( -file => ">SGC0-modified.tasm", -format => 'tigr' ); $outasm->write_assembly( -scaffold => $assembly, -singlets => 1 ); =head1 DESCRIPTION This package loads and writes assembly information in/from files in the default TIGR Assembler v2 format. The files are lassie-formatted and often have the .tasm extension. This module was written to be used as a driver module for Bio::Assembly::IO input/output. =head2 Implementation Assemblies are loaded into Bio::Assembly::Scaffold objects composed of Bio::Assembly::Contig and Bio::Assembly::Singlet objects. Since aligned reads and contig gapped consensus can be obtained in the tasm files, only aligned/gapped sequences are added to the different BioPerl objects. Additional assembly information is stored as features. Contig objects have SeqFeature information associated with the primary_tag: _main_contig_feature:$contig_id -> misc contig information _quality_clipping:$read_id -> quality clipping position Read objects have sub_seqFeature information associated with the primary_tag: _main_read_feature:$read_id -> misc read information Singlets are considered by TIGR Assembler as contigs of one sequence. Contigs are represented here with features having these primary_tag: _main_contig_feature:$contig_id _quality_clipping:$read_primary_id _main_read_feature:$read_primary_id _aligned_coord:$read_primary_id =head1 THE TIGR TASM LASSIE FORMAT =head2 Description In the TIGR tasm lassie format, contigs are separated by a line containing a single pipe character "|", whereas the reads in a contig are separated by a blank line. Singlets can be present in the file and are represented as a contig composed of a single sequence. Other than the two above-mentioned separators, each line has an attribute name, followed a tab and then an attribute value. The tasm format is used by more TIGR applications than just TIGR Assembler. Some of the attributes are not used by TIGR Assembler or have constant values. They are indicated by an asterisk * Contigs have the following attributes: asmbl_id -> contig ID sequence -> contig ungapped consensus sequence (ambiguities are lowercase) lsequence -> gapped consensus sequence (lowercase ambiguities) quality -> gapped consensus quality score (in hexadecimal) seq_id -> * com_name -> * type -> * method -> always 'asmg' * ed_status -> * 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 -> * cds_start -> start of coding sequence * cds_end -> end of coding sequence * ed_pn -> name of editor (always 'GRA') * ed_date -> date and time of edition comment -> some comments * frameshift -> * Each read has the following attributes: seq_name -> read name asm_lend -> position of first base on contig ungapped consensus sequence asm_rend -> position of last base on contig ungapped consensus sequence seq_lend -> start of quality-trimmed sequence (aligned read coordinates) seq_rend -> end of quality-trimmed sequence (aligned read coordinates) best -> always '0' * comment -> some comments * db -> database name associated with the sequence (e.g. >my_db|seq1234) offset -> offset of the sequence (gapped consensus coordinates) lsequence -> aligned read sequence (ambiguities are uppercase) When asm_rend E asm_lend, the sequence was on the complementary DNA strand but its reverse complement is shown in the aligned sequence of the assembly file, not the original read. Ambiguities are reflected in the contig consensus sequence as lowercase IUPAC characters: a c g t u m r w s y k x n . In the read sequences, however, ambiguities are uppercase: M R W S Y K X N =head2 Example Example of a contig containing three sequences: sequence CGATGCTGTACGGCTGTTGCGACAGATTGCGCTGGGTCGATACCGCGTTGGTGATCGGCTTGTTCAGCGGGCTCTGGTTCGGCGACAGCGCGGCGATCTTGGCGGCTGCGAAGGTTGCCGGCGCAATCATGCGCTGCTGACCGTTGACCTGGTCCTGCCAGTACACCCAGTCGCCCACCATGACCTTCAGCGCGTAGCTGTCACAGCCGGCTGTGGTCAGCGCAGTGGCGACGGTGGTGTAGGAGGCGCCAGCAACACCTTGGGTGATCATGTAGCAGCCTTCTGACAGGCCGTAGGTCAGCATGGTCGGCCACTGGGTACCAGTCAGTCGGGTCAACCGAGATTCGCAsCTGAGCGCCACTGCCGCGCAGAGCGTACATGCCCTTGCGGGTCGCGCCGGTAACACCATCCACGCCGATCAGAACTGCGTCGGTGATGGTGGTGTTACCCGAGGTGCCAGTGGTGAAGGCGACGGTCTGGGTGCTGGCCACAGGCGCCAGAGTGGTCGCGCCAACGGTGGCGATGACCAGTTGCGATGGGCCACGGATACCTGACTGCCCGTTGTTCACGGCGCTGACGATGTTCTGCCACAGCGCCAGGCCAGAGCCGGTGATGTTGTCGAACACTTCGGGCGCAACGCCAGGGAGCGAGACGGTCAGCTTCCAGCTCGAAGCAGCGGAGCCAGTAGCCAGGGCGGCGCTGAGCGAGTTGCCGAGCGTGCCGGTGTAGAACGCGGTCAGCGTGGCGCCGGTGGCGGCGGCAGTGTCCTTCAGCGCACTGGTCGCGGCGGTGTCGGTGCCGTCAGTGACGCGCACGGCGCGGATGTTCGAGGCGCCGCCCTGGATTGATACCGCCAGCGCGGTGCACAGGTCGTACTTGCGCACGGTCyGAGTGCCGAACTTCTGCGATGCGTCACCTGGCGAGCCGATAaGCGTGGCGCTGTTCACCGGCCCCCAGTCAGCAATGCCGACGATGCCGAGAATGTCAGTCGGGACGCCATTGATGTAGCGGGTCTTGGGCGCCACTATTTGTATGTACAAATCTGGCGCAGATAAAGCCGCCGTATTCAAATAACCAGCAGGATAGATAGGCATCACGCCTCCAGAATGAAAAAGGCCACCGATTAGGTGGCCTTTGTTGTGTTCGGCTGGCTGTTAGAGCAGCAGCCCGTTTTCCCGCGCAAACGCGAATGGGTCCTTGTCATGCTTCCTGCAATTGCAGGTAGGACAAAGAATTTGCAGGTTGGATTTGTCGTTCGATCCGCCCTTTGCAAGCGGGAACACGTGGTCAACGTGATACCCATCCCTTATGGATATAGTGCACATGGCGCATTTCCAGCGCTGAGCAGCCAGCAAAAATTTTATGTCGTCGCCGGTGTGTGAGCCGACAGCATTTTTCTTGCGAGCCTTGTATGTCCGCGAGAGTGAACGAACTTGCTCCTTGTTGGCTGTCTTCCAGAGCTTTTGAGTAAGCGCACAGAGATCCTTGTTTCTTGATCTCCACTCTCTGGTTGCGGAAAT lsequence CGATGCTGTACGGCTGTTGCGACAGATTGCGCTGGGTCGATACCGCGTTGGTGATCGGCTTGTTCAGCGGGCTCTGGTTCGGCGACAGCGCGGCGATCTTGGCGGCTGCGAAGGTTGCCGGCGCAATCATGCGCTGCTGACCGTTGACCTGGTCCTGCCAGTACACCCAGTCGCCCACCATGACCTTCAGCGCGTAGCTGTCACAGCCGGCTGTGGTCAGCGCAGTGGCGACGGTGGTGTAGGAGGCGCCAGCAACACCTTGGGTGATCATGTAGCAGCCTTCTGACAGGCCGTAGGTCAGCATGGTCGGCCACTGGGTACCAGTCAGTCGGGTCAACCGAGATTCG-CAsCTGAGCGCCACTGCCGCGCAGAGCGTACATGCCCTTGCGGGTCGCGCCGGTAACACCATCCACGCCGATCAGAACTGCGTCGGTGATGGTGGTGTTACCCGAGGTGCCAGTGGTGAAGGCGACGGTCTGGGTGCTGGCCACAGGCGCCAGAGTGGTCGCGCCAACGGTGGCGATGACCAGTTGCGATGGGCCACGGATACCTGACTGCCCGTTGTTCACGGCGCTGACGATGTTCTGCCACAGCGCCAGGCCAGAGCCGGTGATGTTGTCGAACACTTCGGGCGCAACGCCAGGGAGCGAGACGGTCAGCTTCCAGCTCGAAGCAGCGGAGCCAGTAGCCAGGGCGGCGCTGAGCGAGTTGCCGAGCGTGCCGGTGTAGAACGCGGTCAGCGTGGCGCCGGTGGCGGCGGCAGTGTCCTTCAGCGCACTGGTCGCGGCGGTGTCGGTGCCGTCAGTGACGCGCACGGCGCGGATGTTCGAGGCGCCGCCCTGGATTGATACCGCCAGCGCGGTGCACAGGTCGTACTTGCGCACGGTCyGAGTGCCGAACTTCTGCGATGCGTCACCTGGCGAGCCGATAaGCGTGGCGCTGTTCACCGGCCCCCAGTCAGCAATGCCGACGATGCCGAGAATGTCAGTCGGGACGCCATTGATGTAGCGGGTCTTGGGCGCCACTATTTGTATGTACAAATCTGGCGCAGATAAAGCCGCCGTATTCAAATAACCAGCAGGATAGATAGGCATCACGCCTCCAGAATGAAAAAGGCCACCGATTAGGTGGCCTTTGTTGTGTTCGGCTGGCTGTTAGAGCAGCAGCCCGTTTTCCCGCGCAAACGCGAATGGGTCCTTGTCATGCTTCCTGCAATTGCAGGTAGGACAAAGAATTTGCAGGTTGGATTTGTCGTTCGATCCGCCCTTTGCAAGCGGGAACACGTGGTCAACGTGATACCCATCCCTTATGGATATAGTGCACATGGCGCATTTCCAGCGCTGAGCAGCCAGCAAAAATTTTATGTCGTCGCCGGTGTGTGAGCCGACAGCATTTTTCTTGCGAGCCTTGTATGTCCGCGAGAGTGAACGAACTTGCTCCTTGTTGGCTGTCTTCCAGAGCTTTTGAGTAAGCGCACAGAGATCCTTGTTTCTTGATCTCCACTCTCTGGTTGCGGAAAT quality 0x0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0505050505050505050E0505160505050505050505050505050505050505050505050505050505050303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303030303090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0404040404040404041604040404040404040404040404040404040404040404040404040404040404040404040404040404040E0404040404040404040B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090909090B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B0B asmbl_id 93 seq_id com_name type method asmg ed_status redundancy 1.11 perc_N 0.20 seq# 3 full_cds cds_start cds_end ed_pn GRA ed_date 08/16/07 17:10:12 comment frameshift seq_name SDSU_RFPERU_010_C09.x01.phd.1 asm_lend 1 asm_rend 4423 seq_lend 1 seq_rend 442 best 0 comment db offset 0 lsequence CGATGCTGTACGGCTGTTGCGACAGATTGCGCTGGGTCGATACCGCGTTGGTGATCGGCTTGTTCAGCGGGCTCTGGTTCGGCGACAGCGCGGCGATCTTGGCGGCTGCGAAGGTTGCCGGCGCAATCATGCGCTGCTGACCGTTGACCTGGTCCTGCCAGTACACCCAGTCGCCCACCATGACCTTCAGCGCGTAGCTGTCACAGCCGGCTGTGGTCAGCGCAGTGGCGACGGTGGTGTAGGAGGCGCCAGCAACACCTTGGGTGATCATGTAGCAGCCTTCTGACAGGCCGTAGGTCAGCATGGTCGGCCACTGGGTACCAGTCAGTCGGGTCAACCGAGATTCG-CAGCTGAGCGCCACTGCCGCGCAGAGCGTACATGCCCTTGCGGGTCGCGCCGGTAACACCATCCACGCCGATCAGAACTGCGTCGGTGATGGTGG seq_name SDSU_RFPERU_002_H12.x01.phd.1 asm_lend 339 asm_rend 940 seq_lend 1 seq_rend 602 best 0 comment db offset 338 lsequence CGAGATTCGCCACCTGAGCGCCACTGCCGCGCAGAGCGTACATGCCCTTGCGGGTCGCGCCGGTAACACCATCCACGCCGATCAGAACTGCGTCGGTGATGGTGGTGTTACCCGAGGTGCCAGTGGTGAAGGCGACGGTCTGGGTGCTGGCCACAGGCGCCAGAGTGGTCGCGCCAACGGTGGCGATGACCAGTTGCGATGGGCCACGGATACCTGACTGCCCGTTGTTCACGGCGCTGACGATGTTCTGCCACAGCGCCAGGCCAGAGCCGGTGATGTTGTCGAACACTTCGGGCGCAACGCCAGGGAGCGAGACGGTCAGCTTCCAGCTCGAAGCAGCGGAGCCAGTAGCCAGGGCGGCGCTGAGCGAGTTGCCGAGCGTGCCGGTGTAGAACGCGGTCAGCGTGGCGCCGGTGGCGGCGGCAGTGTCCTTCAGCGCACTGGTCGCGGCGGTGTCGGTGCCGTCAGTGACGCGCACGGCGCGGATGTTCGAGGCGCCGCCCTGGATTGATACCGCCAGCGCGGTGCACAGGTCGTACTTGCGCACGGTCCGAGTGCCGAACTTCTGCGATGCGTCACCTGGCGAGCCGATA-GCGTGGCGC seq_name SDSU_RFPERU_009_E07.x01.phd.1 asm_lend 880 asm_rend 1520 seq_lend 641 seq_rend 1 best 0 comment db offset 8803 lsequence CGCACGGTCTGAGTGCCGAACTTCTGCGATGCGTCACCTGGCGAGCCGATAAGCGTGGCGCTGTTCACCGGCCCCCAGTCAGCAATGCCGACGATGCCGAGAATGTCAGTCGGGACGCCATTGATGTAGCGGGTCTTGGGCGCCACTATTTGTATGTACAAATCTGGCGCAGATAAAGCCGCCGTATTCAAATAACCAGCAGGATAGATAGGCATCACGCCTCCAGAATGAAAAAGGCCACCGATTAGGTGGCCTTTGTTGTGTTCGGCTGGCTGTTAGAGCAGCAGCCCGTTTTCCCGCGCAAACGCGAATGGGTCCTTGTCATGCTTCCTGCAATTGCAGGTAGGACAAAGAATTTGCAGGTTGGATTTGTCGTTCGATCCGCCCTTTGCAAGCGGGAACACGTGGTCAACGTGATACCCATCCCTTATGGATATAGTGCACATGGCGCATTTCCAGCGCTGAGCAGCCAGCAAAAATTTTATGTCGTCGCCGGTGTGTGAGCCGACAGCATTTTTCTTGCGAGCCTTGTATGTCCGCGAGAGTGAACGAACTTGCTCCTTGTTGGCTGTCTTCCAGAGCTTTTGAGTAAGCGCACAGAGATCCTTGTTTCTTGATCTCCACTCTCTGGTTGCGGAAAT | ... =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the BioPerl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via email or the web: bioperl-bugs@bio.perl.org https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Florent E Angly Email florent dot angly at gmail dot com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut package Bio::Assembly::IO::tigr; use strict; use Bio::Seq::PrimaryQual; use Bio::LocatableSeq; use Bio::Seq::Quality; use Bio::Assembly::IO; use Bio::Assembly::Scaffold; use Bio::Assembly::Contig; use Bio::Assembly::Singlet; use base qw(Bio::Assembly::IO); our $progname = 'TIGR_Assembler'; =head2 next_assembly Title : next_assembly Usage : my $scaffold = $asmio->next_assembly(); Function: return the next assembly in the tasm-formatted stream Returns : Bio::Assembly::Scaffold object Args : none =cut sub next_assembly { my $self = shift; my $assembly = Bio::Assembly::Scaffold->new( -source => $progname ); # Load contigs and singlets in the scaffold while ( my $obj = $self->next_contig()) { # Add contig /singlet to assembly if ($obj->isa('Bio::Assembly::Singlet')) { # a singlet $assembly->add_singlet($obj); } else { # a contig $assembly->add_contig($obj); } } return $assembly; } =head2 next_contig Title : next_contig Usage : my $contig = $asmio->next_contig(); Function: return the next contig or singlet TIGR-formatted stream Returns : Bio::Assembly::Contig or Bio::Assembly::Singlet Args : none =cut sub next_contig { my $self = shift; # Contig and read related my $contigobj; my $iscontig = 1; my %contiginfo; my %readinfo; # Loop over all assembly file lines while ($_ = $self->_readline) { chomp; if ( /^\|/ ) { # a line with a single pipe | # The end of a read from a contig/singlet, the start of a new one last; } elsif ( /^$/ ) { # a blank line if ($contiginfo{'seqnum'} > 1) { if ($iscontig) { # The end of a contig, the start of a read in that contig $contigobj = $self->_store_contig(\%contiginfo, $contigobj); } else { # The end of a read in a contig, the start of a new read in $self->_store_read(\%readinfo, $contigobj); undef %readinfo; } } # else it's a singlet and we'll store the singlet and its unique # sequence all at once later $iscontig = 0; } else { if ($iscontig) { # Parse contig if (/^sequence\t(.*)/) {$contiginfo{'sequence'} = $1; next} elsif (/^lsequence\t(.*)/) {$contiginfo{'lsequence'} = $1; next} elsif (/^quality\t(.*)/) {$contiginfo{'quality'} = $1; next} elsif (/^asmbl_id\t(.*)/) {$contiginfo{'asmbl_id'} = $1; next} elsif (/^seq_id\t(.*)/) {$contiginfo{'seq_id'} = $1; next} elsif (/^com_name\t(.*)/) {$contiginfo{'com_name'} = $1; next} elsif (/^type\t(.*)/) {$contiginfo{'type'} = $1; next} elsif (/^method\t(.*)/) {$contiginfo{'method'} = $1; next} elsif (/^ed_status\t(.*)/) {$contiginfo{'ed_status'} = $1; next} elsif (/^redundancy\t(.*)/) {$contiginfo{'redundancy'} = $1; next} elsif (/^perc_N\t(.*)/) {$contiginfo{'perc_N'} = $1; next} elsif (/^seq\#\t(.*)/) {$contiginfo{'seqnum'} = $1; next} elsif (/^full_cds\t(.*)/) {$contiginfo{'full_cds'} = $1; next} elsif (/^cds_start\t(.*)/) {$contiginfo{'cds_start'} = $1; next} elsif (/^cds_end\t(.*)/) {$contiginfo{'cds_end'} = $1; next} elsif (/^ed_pn\t(.*)/) {$contiginfo{'ed_pn'} = $1; next} elsif (/^ed_date\t(.*\s.*)/) {$contiginfo{'ed_date'} = $1; next} elsif (/^comment\t(.*)/) {$contiginfo{'comment'} = $1; next} elsif (/^frameshift\t(.*)/) {$contiginfo{'frameshift'} = $1; next} else { $self->throw("Format unknown at line $.:\n$_\nIs your file". " really a TIGR Assembler tasm-formatted file?"); } } else { # Parse read info if (/^seq_name\t(.*)/) {$readinfo{'seq_name'} = $1; next} elsif (/^asm_lend\t(.*)/) {$readinfo{'asm_lend'} = $1; next} elsif (/^asm_rend\t(.*)/) {$readinfo{'asm_rend'} = $1; next} elsif (/^seq_lend\t(.*)/) {$readinfo{'seq_lend'} = $1; next} elsif (/^seq_rend\t(.*)/) {$readinfo{'seq_rend'} = $1; next} elsif (/^best\t(.*)/) {$readinfo{'best'} = $1; next} elsif (/^comment\t(.*)/) {$readinfo{'comment'} = $1; next} elsif (/^db\t(.*)/) {$readinfo{'db'} = $1; next} elsif (/^offset\t(.*)/) {$readinfo{'offset'} = $1; next} elsif (/^lsequence\t(.*)/) {$readinfo{'lsequence'} = $1; next} else { $self->throw("Format unknown at line $.:\n$_\nIs your file". " really a TIGR Assembler tasm-formatted file?"); } } } } # Store read info into a singlet or contig if (defined $contiginfo{'seqnum'}) { if ($contiginfo{'seqnum'} > 1) { # This is a read to attach to an existing contig object. $self->_store_read(\%readinfo, $contigobj); } elsif ($contiginfo{'seqnum'} == 1) { # This is a read. Save singlet and read together in a singlet object. $contigobj = $self->_store_singlet(\%readinfo, \%contiginfo); } else { # That should not happen $self->throw("Unhandled exception"); } } return $contigobj; } =head2 _qual_hex2dec Title : _qual_hex2dec Usage : my dec_quality = $self->_qual_hex2dec($hex_quality); Function: convert an hexadecimal quality score into a decimal quality score Returns : string Args : string =cut sub _qual_hex2dec { my ($self, $qual) = @_; $qual =~ s/^0x(.*)$/$1/; $qual =~ s/(..)/hex($1).' '/eg; return $qual; } =head2 _qual_dec2hex Title : _qual_dec2hex Usage : my hex_quality = $self->_qual_dec2hex($dec_quality); Function: convert a decimal quality score into an hexadecimal quality score Returns : string Args : string =cut sub _qual_dec2hex { my ($self, $qual) = @_; $qual =~ s/(\d+)\s*/sprintf('%02X', $1)/eg; $qual = '0x'.$qual; return $qual; } =head2 _store_contig Title : _store_contig Usage : my $contigobj = $self->_store_contig(\%contiginfo, $contigobj); Function: store information of a contig belonging to a scaffold in the appropriate object Returns : Bio::Assembly::Contig object Args : hash, Bio::Assembly::Contig =cut sub _store_contig { my ($self, $contiginfo, $contigobj) = @_; # Create a contig $contigobj = Bio::Assembly::Contig->new( -id => $$contiginfo{'asmbl_id'}, -strand => 1 ); # Create a gapped consensus sequence and attach it to contig #$$contiginfo{'llength'} = length($$contiginfo{'lsequence'}); my $consensus = Bio::LocatableSeq->new( -id => $$contiginfo{'asmbl_id'}, -seq => $$contiginfo{'lsequence'}, -start => 1, ); $contigobj->set_consensus_sequence($consensus); # Create an gapped consensus quality score and attach it to contig $$contiginfo{'quality'} = $self->_qual_hex2dec($$contiginfo{'quality'}); my $qual = Bio::Seq::PrimaryQual->new( -qual => $$contiginfo{'quality'}, -id => $$contiginfo{'asmbl_id'} ); $contigobj->set_consensus_quality($qual); # Add other misc contig information as features of the contig my $contigtags = Bio::SeqFeature::Generic->new( -primary => '_main_contig_feature', -source => $$contiginfo{'asmbl_id'}, -start => 1, -end => $contigobj->get_consensus_length(), -strand => 1, -tag => { 'seq_id' => $$contiginfo{'seq_id'}, 'com_name' => $$contiginfo{'com_name'}, 'type' => $$contiginfo{'type'}, 'method' => $$contiginfo{'method'}, 'ed_status' => $$contiginfo{'ed_status'}, 'full_cds' => $$contiginfo{'full_cds'}, 'cds_start' => $$contiginfo{'cds_start'}, 'cds_end' => $$contiginfo{'cds_end'}, 'ed_pn' => $$contiginfo{'ed_pn'}, 'ed_date' => $$contiginfo{'ed_date'}, 'comment' => $$contiginfo{'comment'}, 'frameshift' => $$contiginfo{'frameshift'} } ); $contigobj->add_features([ $contigtags ], 1); return $contigobj; } =head2 _store_read Title : _store_read Usage : my $readobj = $self->_store_read(\%readinfo, $contigobj); Function: store information of a read belonging to a contig in a contig object Returns : Bio::LocatableSeq Args : hash, Bio::Assembly::Contig =cut 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); my $readobj = Bio::LocatableSeq->new( # the ids of sequence objects are supposed to include the db name in it, i.e. "big_db|seq1234" # that's how sequence ids coming from the fasta parser are at least -display_id => $self->_merge_seq_name_and_db($$readinfo{'seq_name'}, $$readinfo{'db'}), -primary_id => $self->_merge_seq_name_and_db($$readinfo{'seq_name'}, $$readinfo{'db'}), -seq => $$readinfo{'lsequence'}, -start => 1, -strand => $$readinfo{'strand'}, -alphabet => 'dna' ); # 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 => $readobj->id, -start => $$readinfo{'aln_start'}, -end => $$readinfo{'aln_end'}, -strand => $$readinfo{'strand'}, -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'}); $$readinfo{'clip_end'} = $contigobj->change_coord('aligned '.$readobj->id, 'gapped consensus', $$readinfo{'seq_rend'}); my $clipcoord = Bio::SeqFeature::Generic->new( -primary => '_quality_clipping', -source => $readobj->id, -start => $$readinfo{'clip_start'}, -end => $$readinfo{'clip_end'}, -strand => $$readinfo{'strand'} ); $clipcoord->attach_seq($readobj); $contigobj->add_features([ $clipcoord ], 0); # Add other misc read information as subsequence feature my $readtags = Bio::SeqFeature::Generic->new( -primary => '_main_read_feature', -source => $readobj->id, -start => $$readinfo{'aln_start'}, -end => $$readinfo{'aln_end'}, -strand => $$readinfo{'strand'}, -tag => { 'best' => $$readinfo{'best'}, 'comment' => $$readinfo{'comment'} } ); $contigobj->get_features_collection->add_features([$readtags]); $contigobj->get_features_collection->add_SeqFeature($alncoord, $readtags); return $readobj; } =head2 _store_singlet Title : _store_singlet Usage : my $singletobj = $self->_store_read(\%readinfo, \%contiginfo); Function: store information of a singlet belonging to a scaffold in a singlet object Returns : Bio::Assembly::Singlet Args : hash, hash =cut sub _store_singlet { my ($self, $readinfo, $contiginfo) = @_; # Singlets in TIGR_Assembler are represented as a contig of one sequence # We try to simulate this duality by playing around with the Singlet object my $contigid = $$contiginfo{'asmbl_id'}; my $readid = $self->_merge_seq_name_and_db($$readinfo{'seq_name'}, $$readinfo{'db'}); # Create a sequence object #$$contiginfo{'llength'} = length($$contiginfo{'lsequence'}); my $seqobj = Bio::Seq::Quality->new( -primary_id => $readid, -display_id => $readid, -seq => $$contiginfo{'lsequence'}, # do not use $$readinfo as ambiguities are uppercase -start => 1, -strand => $$readinfo{'strand'}, -alphabet => 'dna', -qual => $self->_qual_hex2dec($$contiginfo{'quality'}) ); # Create singlet from sequence and add it to scaffold my $singletobj = Bio::Assembly::Singlet->new( -id => $contigid, -seqref => $seqobj ); # Add other misc contig information as features of the singlet my $contigtags = Bio::SeqFeature::Generic->new( -primary => '_main_contig_feature', -source => $contigid, -start => 1, -end => $singletobj->get_consensus_length(), -strand => 1, -tag => { 'seq_id' => $$contiginfo{'seq_id'}, 'com_name' => $$contiginfo{'com_name'}, 'type' => $$contiginfo{'type'}, 'method' => $$contiginfo{'method'}, 'ed_status' => $$contiginfo{'ed_status'}, 'full_cds' => $$contiginfo{'full_cds'}, 'cds_start' => $$contiginfo{'cds_start'}, 'cds_end' => $$contiginfo{'cds_end'}, 'ed_pn' => $$contiginfo{'ed_pn'}, 'ed_date' => $$contiginfo{'ed_date'}, 'comment' => $$contiginfo{'comment'}, 'frameshift' => $$contiginfo{'frameshift'} } ); $singletobj->add_features([ $contigtags ], 1); # 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 => '_aligned_coord', -source => $readid, -start => $$readinfo{'aln_start'}, -end => $$readinfo{'aln_end'}, -strand => $$readinfo{'strand'}, -tag => { 'contig' => $contigid } ); $alncoord->attach_seq($singletobj->seqref); $singletobj->add_features([ $alncoord ], 0); # Add quality clipping read information in singlet features # (from 'aligned read' to 'gapped consensus' coordinates) $$readinfo{'clip_start'} = $$readinfo{'seq_lend'}; $$readinfo{'clip_end'} = $$readinfo{'seq_rend'}; my $clipcoord = Bio::SeqFeature::Generic->new( -primary => '_quality_clipping', -source => $readid, -start => $$readinfo{'clip_start'}, -end => $$readinfo{'clip_end'}, -strand => $$readinfo{'strand'}, -tag => { 'contig' => $contigid } ); $clipcoord->attach_seq($singletobj->seqref); $singletobj->add_features([ $clipcoord ], 0); # Add other misc read information as subsequence feature my $readtags = Bio::SeqFeature::Generic->new( -primary => '_main_read_feature', -source => $readid, -start => $$readinfo{'aln_start'}, -end => $$readinfo{'aln_end'}, -strand => $$readinfo{'strand'}, -tag => { 'best' => $$readinfo{'best'}, 'comment' => $$readinfo{'comment'} } ); $singletobj->get_features_collection->add_features([$readtags]); $singletobj->get_features_collection->add_SeqFeature($alncoord, $readtags); return $singletobj; } =head2 write_assembly Title : write_assembly Usage : $asmio->write_assembly($assembly) Function: Write the assembly object in TIGR Assembler compatible format. The contig IDs are sorted naturally if the Sort::Naturally module is present, or lexically otherwise. Internally, write_assembly use the write_contig, write_footer and write_header methods. Use these methods if you want more control on the writing process. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object 1 to write singlets in the assembly file, 0 otherwise =cut =head2 write_contig Title : write_contig Usage : $asmio->write_contig($contig) Function: Write a contig or singlet object in TIGR compatible format. Quality scores are automatically generated if the contig does not contain any Returns : 1 on success, 0 for error Args : A Bio::Assembly::Contig or Singlet object =cut sub write_contig { my ($self, @args) = @_; my ($contigobj) = $self->_rearrange([qw(CONTIG)], @args); # Sanity check if ( !$contigobj || !$contigobj->isa('Bio::Assembly::Contig') ) { $self->throw("Must provide a Bio::Assembly::Contig or Singlet object when calling write_contig"); } my $decimal_format = '%.2f'; my $contigid = $contigobj->id; my $numseqs = $contigobj->num_sequences; if ( $contigobj->isa('Bio::Assembly::Singlet') ) { # This is a singlet my $readid = $contigobj->seqref->id; my $singletobj = $contigobj; # Get contig information my ($contanno) = $singletobj->get_features_collection->get_features_by_type("_main_contig_feature:$contigid"); my %contiginfo; $contiginfo{'sequence'} = $singletobj->seqref->seq; $contiginfo{'lsequence'} = $contiginfo{'sequence'}; $contiginfo{'quality'} = $self->_qual_dec2hex( join ' ', @{$singletobj->get_consensus_quality->qual} ); $contiginfo{'asmbl_id'} = $contigid; $contiginfo{'seq_id'} = ($contanno->get_tag_values('seq_id'))[0]; $contiginfo{'com_name'} = ($contanno->get_tag_values('com_name'))[0]; $contiginfo{'type'} = ($contanno->get_tag_values('type'))[0]; $contiginfo{'method'} = ($contanno->get_tag_values('method'))[0]; $contiginfo{'ed_status'} = ($contanno->get_tag_values('ed_status'))[0]; $contiginfo{'redundancy'} = sprintf($decimal_format, 1); $contiginfo{'perc_N'} = sprintf( $decimal_format, $self->_perc_N($contiginfo{'sequence'})); $contiginfo{'seqnum'} = 1; $contiginfo{'full_cds'} = ($contanno->get_tag_values('full_cds'))[0]; $contiginfo{'cds_start'} = ($contanno->get_tag_values('cds_start'))[0]; $contiginfo{'cds_end'} = ($contanno->get_tag_values('cds_end'))[0]; $contiginfo{'ed_pn'} = ($contanno->get_tag_values('ed_pn'))[0]; $contiginfo{'ed_date'} = $self->_date_time; $contiginfo{'comment'} = ($contanno->get_tag_values('comment'))[0]; $contiginfo{'frameshift'} = ($contanno->get_tag_values('frameshift'))[0]; # Check that no tag value is undef $contiginfo{'seq_id'} = '' unless defined $contiginfo{'seq_id'}; $contiginfo{'com_name'} = '' unless defined $contiginfo{'com_name'}; $contiginfo{'type'} = '' unless defined $contiginfo{'type'}; $contiginfo{'method'} = '' unless defined $contiginfo{'method'}; $contiginfo{'ed_status'} = '' unless defined $contiginfo{'ed_status'}; $contiginfo{'full_cds'} = '' unless defined $contiginfo{'full_cds'}; $contiginfo{'cds_start'} = '' unless defined $contiginfo{'cds_start'}; $contiginfo{'cds_end'} = '' unless defined $contiginfo{'cds_end'}; $contiginfo{'ed_pn'} = '' unless defined $contiginfo{'ed_pn'}; $contiginfo{'comment'} = '' unless defined $contiginfo{'comment'}; $contiginfo{'frameshift'} = '' unless defined $contiginfo{'frameshift'}; # Print singlet information $self->_print( "sequence\t$contiginfo{'sequence'}\n". "lsequence\t$contiginfo{'lsequence'}\n". "quality\t$contiginfo{'quality'}\n". "asmbl_id\t$contiginfo{'asmbl_id'}\n". "seq_id\t$contiginfo{'seq_id'}\n". "com_name\t$contiginfo{'com_name'}\n". "type\t$contiginfo{'type'}\n". "method\t$contiginfo{'method'}\n". "ed_status\t$contiginfo{'ed_status'}\n". "redundancy\t$contiginfo{'redundancy'}\n". "perc_N\t$contiginfo{'perc_N'}\n". "seq#\t$contiginfo{'seqnum'}\n". "full_cds\t$contiginfo{'full_cds'}\n". "cds_start\t$contiginfo{'cds_start'}\n". "cds_end\t$contiginfo{'cds_end'}\n". "ed_pn\t$contiginfo{'ed_pn'}\n". "ed_date\t$contiginfo{'ed_date'}\n". "comment\t$contiginfo{'comment'}\n". "frameshift\t$contiginfo{'frameshift'}\n". "\n" ); # Get read information my ($seq_name, $db) = $self->_split_seq_name_and_db($readid); my ($clipcoord) = $singletobj->get_features_collection->get_features_by_type("_quality_clipping:$readid"); my ($alncoord) = $singletobj->get_features_collection->get_features_by_type("_aligned_coord:$readid"); my ($readanno) = $singletobj->get_features_collection->get_features_by_type("_main_read_feature:$readid"); my %readinfo; $readinfo{'seq_name'} = $seq_name; $readinfo{'asm_lend'} = $alncoord->location->start; $readinfo{'asm_rend'} = $alncoord->location->end; $readinfo{'seq_lend'} = $clipcoord->location->start; $readinfo{'seq_rend'} = $clipcoord->location->end; $readinfo{'best'} = ($readanno->get_tag_values('best'))[0]; $readinfo{'comment'} = ($readanno->get_tag_values('comment'))[0]; $readinfo{'db'} = $db; $readinfo{'offset'} = 0; # ambiguities in read sequence are uppercase $readinfo{'lsequence'} = uc($contiginfo{'lsequence'}); # Check that no tag value is undef $readinfo{'best'} = '' unless defined $readinfo{'best'}; $readinfo{'comment'} = '' unless defined $readinfo{'comment'}; # Print read information $self->_print( "seq_name\t$readinfo{'seq_name'}\n". "asm_lend\t$readinfo{'asm_lend'}\n". "asm_rend\t$readinfo{'asm_rend'}\n". "seq_lend\t$readinfo{'seq_lend'}\n". "seq_rend\t$readinfo{'seq_rend'}\n". "best\t$readinfo{'best'}\n". "comment\t$readinfo{'comment'}\n". "db\t$readinfo{'db'}\n". "offset\t$readinfo{'offset'}\n". "lsequence\t$readinfo{'lsequence'}\n" ); $self->_print("|\n"); } else { # This is a contig # Get contig information my ($contanno) = $contigobj->get_features_collection->get_features_by_type("_main_contig_feature:$contigid"); my %contiginfo; $contiginfo{'sequence'} = $self->_ungap( $contigobj->get_consensus_sequence->seq); $contiginfo{'lsequence'} = $contigobj->get_consensus_sequence->seq; $contiginfo{'quality'} = $self->_qual_dec2hex( join ' ', @{$contigobj->get_consensus_quality->qual}); $contiginfo{'asmbl_id'} = $contigid; $contiginfo{'seq_id'} = ($contanno->get_tag_values('seq_id'))[0]; $contiginfo{'com_name'} = ($contanno->get_tag_values('com_name'))[0]; $contiginfo{'type'} = ($contanno->get_tag_values('type'))[0]; $contiginfo{'method'} = ($contanno->get_tag_values('method'))[0]; $contiginfo{'ed_status'} = ($contanno->get_tag_values('ed_status'))[0]; $contiginfo{'redundancy'} = sprintf( $decimal_format, $self->_redundancy($contigobj)); $contiginfo{'perc_N'} = sprintf( $decimal_format, $self->_perc_N($contiginfo{'sequence'})); $contiginfo{'seqnum'} = $contigobj->num_sequences; $contiginfo{'full_cds'} = ($contanno->get_tag_values('full_cds'))[0]; $contiginfo{'cds_start'} = ($contanno->get_tag_values('cds_start'))[0]; $contiginfo{'cds_end'} = ($contanno->get_tag_values('cds_end'))[0]; $contiginfo{'ed_pn'} = ($contanno->get_tag_values('ed_pn'))[0]; $contiginfo{'ed_date'} = $self->_date_time; $contiginfo{'comment'} = ($contanno->get_tag_values('comment'))[0]; $contiginfo{'frameshift'} = ($contanno->get_tag_values('frameshift'))[0]; # Check that no tag value is undef $contiginfo{'seq_id'} = '' unless defined $contiginfo{'seq_id'}; $contiginfo{'com_name'} = '' unless defined $contiginfo{'com_name'}; $contiginfo{'type'} = '' unless defined $contiginfo{'type'}; $contiginfo{'method'} = '' unless defined $contiginfo{'method'}; $contiginfo{'ed_status'} = '' unless defined $contiginfo{'ed_status'}; $contiginfo{'full_cds'} = '' unless defined $contiginfo{'full_cds'}; $contiginfo{'cds_start'} = '' unless defined $contiginfo{'cds_start'}; $contiginfo{'cds_end'} = '' unless defined $contiginfo{'cds_end'}; $contiginfo{'ed_pn'} = '' unless defined $contiginfo{'ed_pn'}; $contiginfo{'comment'} = '' unless defined $contiginfo{'comment'}; $contiginfo{'frameshift'} = '' unless defined $contiginfo{'frameshift'}; # Print contig information $self->_print( "sequence\t$contiginfo{'sequence'}\n". "lsequence\t$contiginfo{'lsequence'}\n". "quality\t$contiginfo{'quality'}\n". "asmbl_id\t$contiginfo{'asmbl_id'}\n". "seq_id\t$contiginfo{'seq_id'}\n". "com_name\t$contiginfo{'com_name'}\n". "type\t$contiginfo{'type'}\n". "method\t$contiginfo{'method'}\n". "ed_status\t$contiginfo{'ed_status'}\n". "redundancy\t$contiginfo{'redundancy'}\n". "perc_N\t$contiginfo{'perc_N'}\n". "seq#\t$contiginfo{'seqnum'}\n". "full_cds\t$contiginfo{'full_cds'}\n". "cds_start\t$contiginfo{'cds_start'}\n". "cds_end\t$contiginfo{'cds_end'}\n". "ed_pn\t$contiginfo{'ed_pn'}\n". "ed_date\t$contiginfo{'ed_date'}\n". "comment\t$contiginfo{'comment'}\n". "frameshift\t$contiginfo{'frameshift'}\n". "\n" ); my $seqno = 0; for my $readobj ( $contigobj->each_seq() ) { $seqno++; # Get read information my ($seq_name, $db) = $self->_split_seq_name_and_db($readobj->id); my ($asm_lend, $asm_rend, $seq_lend, $seq_rend, $offset) = $self->_coord($readobj, $contigobj); my $readanno = ($contigobj->get_features_collection->get_SeqFeatures( $contigobj->get_seq_coord($readobj) , '_main_read_feature:'.$readobj->primary_id) )[0]; my %readinfo; $readinfo{'seq_name'} = $seq_name; $readinfo{'asm_lend'} = $asm_lend; $readinfo{'asm_rend'} = $asm_rend; $readinfo{'seq_lend'} = $seq_lend; $readinfo{'seq_rend'} = $seq_rend; $readinfo{'best'} = ($readanno->get_tag_values('best'))[0]; $readinfo{'comment'} = ($readanno->get_tag_values('comment'))[0]; $readinfo{'db'} = $db; $readinfo{'offset'} = $offset; $readinfo{'lsequence'} = $readobj->seq(); # Check that no tag value is undef $readinfo{'best'} = '' unless defined $readinfo{'best'}; $readinfo{'comment'} = '' unless defined $readinfo{'comment'}; # Print read information $self->_print( "seq_name\t$readinfo{'seq_name'}\n". "asm_lend\t$readinfo{'asm_lend'}\n". "asm_rend\t$readinfo{'asm_rend'}\n". "seq_lend\t$readinfo{'seq_lend'}\n". "seq_rend\t$readinfo{'seq_rend'}\n". "best\t$readinfo{'best'}\n". "comment\t$readinfo{'comment'}\n". "db\t$readinfo{'db'}\n". "offset\t$readinfo{'offset'}\n". "lsequence\t$readinfo{'lsequence'}\n" ); if ($seqno < $contiginfo{'seqnum'}) { $self->_print("\n"); } else { $self->_print("|\n") }; } } return 1; } =head2 write_header Title : write_header Usage : $asmio->write_header($assembly) Function: In the TIGR Asseformat assembly driver, this does nothing. The method is present for compatibility with other assembly drivers that need to write a file header. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object =cut sub write_header { my ($self) = @_; return 1; } =head2 write_footer Title : write_footer Usage : $asmio->write_footer($assembly) Function: Write TIGR footer, i.e. do nothing except making sure that the file does not end with a '|'. Returns : 1 on success, 0 for error Args : A Bio::Assembly::Scaffold object =cut sub write_footer { my ($self) = @_; # In this implementation, the TIGR file always ends with '|\n'. Remove it. seek $self->_fh, -length("|\n"), 2; $self->_print("\n\n"); return 1; } =head2 _perc_N Title : _perc_N Usage : my $perc_N = $asmio->_perc_N($sequence_string) Function: Calculate the percent of ambiguities in a sequence. M R W S Y K X N are regarded as ambiguities in an aligned read sequence by TIGR Assembler. In the case of a gapped contig consensus sequence, all lowercase symbols are ambiguities, i.e.: a c g t u m r w s y k x n. Returns : decimal number Args : string =cut sub _perc_N { my ($self, $seq_string) = @_; $self->throw("Cannot accept an empty sequence") if length($seq_string) == 0; my $perc_N = 0; for my $base ( split //, $seq_string ) { # individual base matches an ambiguity? if (( $base =~ m/[x|n|m|r|w|s|y|k]/i ) || ( $base =~ m/[a|c|g|t|u]/ ) ) { $perc_N++; } } $perc_N = $perc_N * 100 / length $seq_string; return $perc_N; } =head2 _redundancy Title : _redundancy Usage : my $ref = $asmio->_redundancy($contigobj) 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 =cut sub _redundancy { # redundancy = (sum of all aligned read lengths - ( number of gaps in gapped # consensus + number of gaps in aligned reads that are also in the consensus ) ) # / length of ungapped consensus my ($self, $contigobj) = @_; my $redundancy = 0; # sum of all aligned read lengths my $read_tot = 0; for my $readobj ( $contigobj->each_seq ) { my $read_length = length($readobj->seq); $read_tot += $read_length; } $redundancy += $read_tot; # - respected gaps my $consensus_sequence = $contigobj->get_consensus_sequence->seq; my @consensus_gaps = (); $contigobj->_register_gaps($consensus_sequence, \@consensus_gaps); my $respected_gaps = scalar(@consensus_gaps); if ($respected_gaps > 0) { my @cons_arr = split //, $consensus_sequence; for my $gap_pos_cons ( @consensus_gaps ) { for my $readobj ( $contigobj->each_seq ) { my $readid = $readobj->id; my $read_start = $contigobj->change_coord( "aligned $readid", 'gapped consensus', $readobj->start); my $read_end = $contigobj->change_coord( "aligned $readid", 'gapped consensus', $readobj->end ); # skip this if consensus gap position not within in the read boundaries next if ( ($gap_pos_cons < $read_start) || ($gap_pos_cons > $read_end) ); # does the read position have read have a gap? my @read_arr = split //, $readobj->seq; my $gap_pos_read = $contigobj->change_coord( 'gapped consensus', "aligned $readid", $gap_pos_cons); if ($read_arr[$gap_pos_read-1] eq $cons_arr[$gap_pos_cons-1]) { $respected_gaps++; } } } } $redundancy -= $respected_gaps; # / length of ungapped consensus my $contig_length = length($self->_ungap($contigobj->get_consensus_sequence->seq)); $redundancy /= $contig_length; return $redundancy; } =head2 _ungap Title : _ungap Usage : my $ungapped = $asmio->_ungap($gapped) Function: Remove the gaps from a sequence. Gaps are - in TIGR Assembler Returns : string Args : string =cut sub _ungap { my ($self, $seq_string) = @_; $seq_string =~ s/-//g; return $seq_string; } =head2 _date_time Title : _date_time Usage : my $timepoint = $asmio->date_time Function: Get date and time (MM//DD/YY HH:MM:SS) Returns : string Args : none =cut sub _date_time { my ($self) = @_; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); my $formatted_date_time = sprintf('%02d', $mon+1).'/'. sprintf('%02d', $mday).'/'. sprintf('%02d', $year % 100). ' '. sprintf('%02d', $hour).':'. sprintf('%02d', $min).':'. sprintf('%02d',$sec) ; return $formatted_date_time; } =head2 _split_seq_name_and_db Title : _split_seq_name_and_db Usage : my ($seqname, $db) = $asmio->_split_seq_name_and_db($id) Function: Extract seq_name and db from sequence id Returns : seq_name, db Args : id =cut sub _split_seq_name_and_db { my ($self, $id) = @_; my $seq_name = ''; my $db = ''; if ($id =~ m/(\S+)\|(\S+)/) { $db = $1; $seq_name = $2; } else { $seq_name = $id; } return ($seq_name, $db); } =head2 _merge_seq_name_and_db Title : _merge_seq_name_and_db Usage : my $id = $asmio->_merge_seq_name_and_db($seq_name, $db) Function: Construct id from seq_name and db Returns : id Args : seq_name, db =cut sub _merge_seq_name_and_db { my ($self, $seq_name, $db) = @_; my $id = ''; if ($db) { $id = $db.'|'.$seq_name; } else { $id = $seq_name; } return $id; } =head2 _coord Title : _coord Usage : my $id = $asmio->__coord($readobj, $contigobj) Function: Get different coordinates for the read Returns : number, number, number, number, number Args : Bio::Assembly::Seq, Bio::Assembly::Contig =cut sub _coord { my ($self, $readobj, $contigobj) = @_; my ($asm_lend, $asm_rend, $seq_lend, $seq_rend, $offset) = (0, 0, 0, 0, 0); # Get read gapped consensus coordinates from contig and calculate # asm_lend and asm_rend in ungapped consensus my $aln_lend = $contigobj->get_seq_coord($readobj)->location->start; my $aln_rend = $contigobj->get_seq_coord($readobj)->location->end; $asm_lend = $contigobj->change_coord( 'gapped consensus', 'ungapped consensus', $aln_lend); $asm_rend = $contigobj->change_coord( 'gapped consensus', 'ungapped consensus', $aln_rend); # Get gapped consensus coordinates for quality-clipped reads from contig # annotation and determine seq_lend and seq_rend in unaligned sequence coord my ($readclip) = $contigobj->get_features_collection->get_features_by_type('_quality_clipping:'.$readobj->primary_id); my $clip_lend = $readclip->location->start; my $clip_rend = $readclip->location->end; $seq_lend = $contigobj->change_coord( 'gapped consensus', 'aligned '.$readobj->id, $clip_lend); $seq_rend = $contigobj->change_coord( 'gapped consensus', 'aligned '.$readobj->id, $clip_rend); # Offset $offset = $aln_lend - 1; return ($asm_lend, $asm_rend, $seq_lend, $seq_rend, $offset); } 1; __END__ BioPerl-1.6.923/Bio/Assembly/Tools000755000765000024 012254227314 16671 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Assembly/Tools/ContigSpectrum.pm000444000765000024 17714412254227314 22410 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Assembly::Tools::ContigSpectrum # # Copyright by Florent Angly # # You may distribute this module under the same terms as Perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Assembly::Tools::ContigSpectrum - create and manipulate contig spectra =head1 SYNOPSIS # Simple contig spectrum creation my $csp1 = Bio::Assembly::Tools::ContigSpectrum->new( -id => 'csp1', -spectrum => { 1 => 10, 2 => 2, 3 => 1 } ); # ...or another way to create a simple contig spectrum my $csp2 = Bio::Assembly::Tools::ContigSpectrum->new; $csp2->id('csp2'); $csp2->spectrum({ 1 => 20, 2 => 1, 4 => 1 }); # Get some information print "This is contig spectrum ".$csp->id."\n"; print "It contains ".$csp->nof_seq." sequences\n"; print "The largest contig has ".$csp->max_size." sequences\n"; print "The spectrum is: ".$csp->to_string($csp->spectrum)."\n"; # Let's add the contig spectra my $summed_csp = Bio::Assembly::Tools::ContigSpectrum->new; $summed_csp->add($csp1); $summed_csp->add($csp2); print "The summed contig spectrum is ".$summed_csp->to_string."\n"; # Make an average my $avg_csp = Bio::Assembly::Tools::ContigSpectrum->new; $avg_csp = $avg_csp->average([$csp1, $csp2]); print "The average contig spectrum is ".$avg_csp->to_string."\n"; # Get a contig spectrum from an assembly my $from_assembly = Bio::Assembly::Tools::ContigSpectrum->new( -assembly => $assembly_object, -eff_asm_params => 1); print "The contig spectrum from assembly is ".$from_assembly->to_string."\n"; # Report advanced information (possible because eff_asm_params = 1) print "Average sequence length: ".$from_assembly->avg_seq_len." bp\n"; print "Minimum overlap length: ".$from_assembly->min_overlap." bp\n"; print "Average overlap length: ".$from_assembly->avg_overlap." bp\n"; print "Minimum overlap match: ".$from_assembly->min_identity." %\n"; print "Average overlap match: ".$from_assembly->avg_identity." %\n"; # Assuming the assembly object contains sequences from several different # metagenomes, we have a mixed contig spectrum from which a cross contig # spectrum and dissolved contig spectra can be obtained my $mixed_csp = $from_assembly; # Calculate a dissolved contig spectrum my $meta1_dissolved = Bio::Assembly::Tools::ContigSpectrum->new( -dissolve => [$mixed_csp, 'metagenome1'] ); my $meta2_dissolved = Bio::Assembly::Tools::ContigSpectrum->new( -dissolve => [$mixed_csp, 'metagenome2'] ); print "The dissolved contig spectra are:\n". $meta1_dissolved->to_string."\n". $meta2_dissolved->to_string."\n"; # Determine a cross contig spectrum my $cross_csp = Bio::Assembly::Tools::ContigSpectrum->new( -cross => $mixed_csp ); print "The cross contig spectrum is ".$cross_csp->to_string."\n"; # Score a contig spectrum (the more abundant the contigs and the larger their # size, the larger the score) my $csp_score = $csp->score( $csp->nof_seq ); =head1 DESCRIPTION The Bio::Assembly::Tools::ContigSpectrum Perl module enables to manually create contig spectra, import them from assemblies, manipulate them, transform between different types of contig spectra and output them. Bio::Assembly::Tools::ContigSpectrum is a module to create, manipulate and output contig spectra, assembly-derived data used in metagenomics (community genomics) for diversity estimation. =head2 Background A contig spectrum is the count of the number of contigs of different size in an assembly. For example, the contig spectrum [100 5 1 0 0 ...] means that there were 100 singlets (1-contigs), 5 contigs of 2 sequences (2-contigs), 1 contig of 3 sequences (3-contig) and no larger contigs. An assembly can be produced from a mixture of sequences from different metagenomes. The contig obtained from this assembly is a mixed contig spectrum. The contribution of each metagenome in this mixed contig spectrum can be obtained by determining a dissolved contig spectrum. Finally, based on a mixed contig spectrum, a cross contig spectrum can be determined. In a cross contig spectrum, only contigs containing sequences from different metagenomes are kept; "pure" contigs are excluded. Additionally, the total number of singletons (1-contigs) from each region that assembles with any fragments from other regions is the number of 1-contigs in the cross contig spectrum. =head2 Implementation The simplest representation of a contig spectrum is as a hash representation where the key is the contig size (number of sequences making up the contig) and the value the number of contigs of this size. In fact, it is useful to have more information associated with the contig spectrum, hence the Bio::Assembly::Tools::ContigSpectrum module implements an object containing a contig spectrum hash and additional information. The get/set methods to access them are: id contig spectrum ID nof_rep number of repetitions (assemblies) used max_size size of (number of sequences in) the largest contig spectrum hash representation of a contig spectrum nof_seq number of sequences avg_seq_len average sequence length eff_asm_params reports effective assembly parameters nof_overlaps number of overlaps (needs eff_asm_params) min_overlap minimum overlap length in a contig (needs eff_asm_params) min_identity minimum sequence identity percentage (needs eff_asm_params) avg_overlap average overlap length (needs eff_asm_params) avg_identity average overlap identity percentage (needs eff_asm_params) Operations on the contig spectra: to_string create a string representation of the spectrum spectrum import a hash contig spectrum assembly determine a contig spectrum from an assembly, contig or singlet dissolve calculate a dissolved contig spectrum (depends on assembly) cross produce a cross contig spectrum (depends on assembly) add add a contig spectrum to an existing one average make an average of several contig spectra score score a contig spectrum: the higher the number of contigs and the larger their size, the higher the score. When using operations that rely on knowing "where" (from what metagenomes) a sequence came from (i.e. when creating a dissolved or cross contig spectrum), make sure that the sequences used for the assembly have a name header, e.g. Emetagenome1|seq1, Emetagenome2|seq1, ... Note: The following operations require the C module: eff_asm_params, cross, dissolve =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the BioPerl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via email or the web: bioperl-bugs@bio.perl.org https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Florent E Angly Email florent_dot_angly_at_gmail_dot_com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut package Bio::Assembly::Tools::ContigSpectrum; use strict; use Bio::Root::Root; use Bio::Assembly::Scaffold; use Bio::SimpleAlign; use Bio::LocatableSeq; use base 'Bio::Root::Root'; =head2 new Title : new Usage : my $csp = Bio::Assembly::Tools::ContigSpectrum->new(); or my $csp = Bio::Assembly::Tools::ContigSpectrum->new( -id => 'some_name', -spectrum => { 1 => 90 , 2 => 3 , 4 => 1 }, ); or my $csp = Bio::Assembly::Tools::ContigSpectrum->new( -assembly => $assembly_obj ); Function: create a new contig spectrum object Returns : reference to a contig spectrum object Args : none =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ( $id, $nof_seq, $nof_rep, $max_size, $nof_overlaps, $min_overlap, $min_identity, $avg_overlap, $avg_identity, $avg_seq_len, $spectrum, $assembly, $eff_asm_params, $dissolve, $cross) = $self->_rearrange( [qw(ID NOF_SEQ NOF_REP MAX_SIZE NOF_OVERLAPS MIN_OVERLAP MIN_IDENTITY AVG_OVERLAP AVG_IDENTITY AVG_SEQ_LEN SPECTRUM ASSEMBLY EFF_ASM_PARAMS DISSOLVE CROSS)], @args ); # First set up some defauts $self->{'_id'} = 'NoName'; $self->{'_nof_seq'} = 0; $self->{'_nof_rep'} = 0; $self->{'_max_size'} = 0; $self->{'_nof_overlaps'} = 0; $self->{'_min_overlap'} = undef; $self->{'_min_identity'} = undef; $self->{'_avg_overlap'} = 0; $self->{'_avg_identity'} = 0; $self->{'_avg_seq_len'} = 0; $self->{'_eff_asm_params'} = 0; $self->{'_spectrum'} = {1 => 0}; # contig spectrum hash representation $self->{'_assembly'} = []; # list of assembly, contigs and singlet objects # Then, according to user desires, override defaults $self->{'_id'} = $id if (defined $id); $self->{'_nof_seq'} = $nof_seq if (defined $nof_seq); $self->{'_nof_rep'} = $nof_rep if (defined $nof_rep); $self->{'_max_size'} = $max_size if (defined $max_size); $self->{'_nof_overlaps'} = $nof_overlaps if (defined $nof_overlaps); $self->{'_min_overlap'} = $min_overlap if (defined $min_overlap); $self->{'_avg_overlap'} = $avg_overlap if (defined $avg_overlap); $self->{'_min_identity'} = $min_identity if (defined $min_identity); $self->{'_avg_identity'} = $avg_identity if (defined $avg_identity); $self->{'_avg_seq_len'} = $avg_seq_len if (defined $avg_seq_len); $self->{'_eff_asm_params'} = $eff_asm_params if (defined $eff_asm_params); # Finally get stuff that can be obtained in an automated way $self->_import_spectrum($spectrum) if defined($spectrum); $self->_import_assembly($assembly) if defined($assembly); $self->_import_cross_csp($cross) if defined($cross); if (defined($dissolve)) { my ($mixed_csp, $header) = (@$dissolve[0], @$dissolve[1]); $self->_import_dissolved_csp($mixed_csp, $header); } return $self; } =head2 id Title : id Usage : $csp->id Function: get/set contig spectrum id Returns : string Args : string [optional] =cut sub id { my ($self, $id) = @_; if (defined $id) { $self->{'_id'} = $id; } $id = $self->{'_id'}; return $id; } =head2 nof_seq Title : nof_seq Usage : $csp->nof_seq Function: get/set the number of sequences making up the contig spectrum Returns : integer Args : integer [optional] =cut sub nof_seq { my ($self, $nof_seq) = @_; if (defined $nof_seq) { $self->throw("The number of sequences must be strictly positive. Got ". "'$nof_seq'") if $nof_seq < 1; $self->{'_nof_seq'} = $nof_seq; } $nof_seq = $self->{'_nof_seq'}; return $nof_seq; } =head2 nof_rep Title : nof_rep Usage : $csp->nof_rep Function: Get/Set the number of repetitions (assemblies) used to create the contig spectrum Returns : integer Args : integer [optional] =cut sub nof_rep { my ($self, $nof_rep) = @_; if (defined $nof_rep) { $self->throw("The number of repetitions must be strictly positive. Got ". "'$nof_rep'") if $nof_rep < 1; $self->{'_nof_rep'} = $nof_rep; } $nof_rep = $self->{'_nof_rep'}; return $nof_rep; } =head2 max_size Title : max_size Usage : $csp->max_size Function: get/set the size of (number of sequences in) the largest contig Returns : integer Args : integer [optional] =cut sub max_size { my ($self, $max_size) = @_; if (defined $max_size) { $self->throw("The contig maximum size must be strictly positive. Got ". "'$max_size'") if $max_size < 1; $self->{'_max_size'} = $max_size; } $max_size = $self->{'_max_size'}; return $max_size; } =head2 nof_overlaps Title : nof_overlaps Usage : $csp->nof_overlaps Function: Get/Set the number of overlaps in the assembly. Returns : integer Args : integer [optional] =cut sub nof_overlaps { my ($self, $nof_overlaps) = @_; if (defined $nof_overlaps) { $self->throw("The number of overlaps must be strictly positive. Got ". "'$nof_overlaps'") if $nof_overlaps < 1; $self->{'_nof_overlaps'} = $nof_overlaps; } $nof_overlaps = $self->{'_nof_overlaps'}; return $nof_overlaps; } =head2 min_overlap Title : min_overlap Usage : $csp->min_overlap Function: get/set the assembly minimum overlap length Returns : integer Args : integer [optional] =cut sub min_overlap { my ($self, $min_overlap) = @_; if (defined $min_overlap) { $self->throw("The minimum of overlap length must be strictly positive. Got". " '$min_overlap'") if $min_overlap < 1; $self->{'_min_overlap'} = $min_overlap; } $min_overlap = $self->{'_min_overlap'}; return $min_overlap; } =head2 avg_overlap Title : avg_overlap Usage : $csp->avg_overlap Function: get/set the assembly average overlap length Returns : decimal Args : decimal [optional] =cut sub avg_overlap { my ($self, $avg_overlap) = @_; if (defined $avg_overlap) { $self->throw("The average overlap length must be strictly positive. Got ". "'$avg_overlap'") if $avg_overlap < 1; $self->{'_avg_overlap'} = $avg_overlap; } $avg_overlap = $self->{'_avg_overlap'}; return $avg_overlap; } =head2 min_identity Title : min_identity Usage : $csp->min_identity Function: get/set the assembly minimum overlap identity percent Returns : 0 < decimal < 100 Args : 0 < decimal < 100 [optional] =cut sub min_identity { my ($self, $min_identity) = @_; if (defined $min_identity) { $self->throw("The minimum overlap percent identity must be strictly ". "positive. Got '$min_identity'") if $min_identity < 1; $self->{'_min_identity'} = $min_identity; } $min_identity = $self->{'_min_identity'}; return $min_identity; } =head2 avg_identity Title : avg_identity Usage : $csp->avg_identity Function: get/set the assembly average overlap identity percent Returns : 0 < decimal < 100 Args : 0 < decimal < 100 [optional] =cut sub avg_identity { my ($self, $avg_identity) = @_; if (defined $avg_identity) { $self->throw("The average overlap percent identity must be strictly ". "positive. Got '$avg_identity'") if $avg_identity < 1; $self->{'_avg_identity'} = $avg_identity; } $avg_identity = $self->{'_avg_identity'}; return $avg_identity; } =head2 avg_seq_len Title : avg_seq_len Usage : $csp->avg_seq_len Function: get/set the assembly average sequence length Returns : avg_seq_len Args : real [optional] =cut sub avg_seq_len { my ($self, $avg_seq_len) = @_; if (defined $avg_seq_len) { $self->throw("The average sequence length must be strictly positive. Got ". "'$avg_seq_len'") if $avg_seq_len < 1; $self->{'_avg_seq_len'} = $avg_seq_len; } $avg_seq_len = $self->{'_avg_seq_len'}; return $avg_seq_len; } =head2 eff_asm_params Title : eff_asm_params Usage : $csp->eff_asm_params(1) Function: Get/set the effective assembly parameters option. It defines if the effective assembly parameters should be determined when a contig spectrum based or derived from an assembly is calculated. The effective assembly parameters include avg_seq_length, nof_overlaps, min_overlap, avg_overlap, min_identity and avg_identity. 1 = get them, 0 = don't. Returns : integer Args : integer [optional] =cut sub eff_asm_params { my ($self, $eff_asm_params) = @_; if (defined $eff_asm_params) { $self->throw("eff_asm_params can only take values 0 or 1. Input value was ". "'$eff_asm_params'") unless $eff_asm_params == 0 || $eff_asm_params == 1; $self->{'_eff_asm_params'} = $eff_asm_params; } $eff_asm_params = $self->{'_eff_asm_params'}; return $eff_asm_params; } =head2 spectrum Title : spectrum Usage : my $spectrum = $csp->spectrum({1=>10, 2=>2, 3=>1}); Function: Get the current contig spectrum represented as a hash / Update a contig spectrum object based on a contig spectrum represented as a hash The hash representation of a contig spectrum is as following: key -> contig size (in number of sequences) value -> number of contigs of this size Returns : contig spectrum as a hash reference Args : contig spectrum as a hash reference [optional] =cut sub spectrum { my ($self, $spectrum) = @_; if (defined $spectrum) { $self->_import_spectrum($spectrum); } $spectrum = $self->{'_spectrum'}; return $spectrum; } =head2 assembly Title : assembly Usage : my @obj_list = $csp->assembly(); Function: get/set the contig spectrum object by adding an assembly, contig or singlet object to it, or get the list of objects associated with it Returns : arrayref of assembly, contig and singlet objects used in the contig spectrum object (Bio::Assembly::Scaffold, Bio::Assembly::Contig and Bio::Assembly::Singlet objects) Args : Bio::Assembly::Scaffold, Contig or Singlet object =cut sub assembly { my ($self, $assembly) = @_; if (defined $assembly) { $self->_import_assembly($assembly); } my @obj_list = @{$self->{'_assembly'}} if defined $self->{'_assembly'}; return @obj_list; } =head2 drop_assembly Title : drop_assembly Usage : $csp->drop_assembly(); Function: Remove all assembly objects associated with a contig spectrum. Assembly objects can take a lot of memory, which can be freed by calling this method. Don't call this method if you need the assembly object later on, for example for creating a dissolved or cross contig spectrum. Returns : 1 for success Args : none =cut sub drop_assembly { my ($self) = @_; $self->{'_assembly'} = []; return 1; } =head2 dissolve Title : dissolve Usage : $dissolved_csp->dissolve($mixed_csp, $seq_header); Function: Dissolve a mixed contig spectrum for the set of sequences that contain the specified header, i.e. determine the contribution of these sequences to the mixed contig spectrum. The mixed contig spectrum object must have one or several assembly object(s). In addition, min_overlap, min_identity and eff_asm_params are taken from the mixed contig spectrum, unless they are specified manually for the dissolved contig spectrum. The dissolved contigs underlying the contig spectrum can be obtained by calling the assembly() method. Returns : 1 for success Args : Bio::Assembly::Tools::ContigSpectrum reference sequence header string =cut sub dissolve { my ($self, $mixed_csp, $seq_header) = @_; $self->_import_dissolved_csp($mixed_csp, $seq_header); return 1; } =head2 cross Title : cross Usage : $cross_csp->cross($mixed_csp); Function: Calculate a cross contig_spectrum based on a mixed contig_spectrum. The underlying cross-contigs themselves can be obtained by calling the assembly() method. Returns : 1 for success Args : Bio::Assembly::Tools::ContigSpectrum reference =cut sub cross { my ($self, $mixed_csp) = @_; $self->_import_cross_csp($mixed_csp); return 1; } =head2 to_string Title : to_string Usage : my $csp_string = $csp->to_string; Function: Convert the contig spectrum into a string (easy to print!!). Returns : string Args : element separator (integer) [optional] 1 -> space-separated 2 -> tab-separated 3 -> newline-separated =cut sub to_string { my ($self, $element_separator) = @_; return 0 if $self->{'_max_size'} == 0; $element_separator ||= 1; if ($element_separator == 1) { $element_separator = ' '; } elsif ($element_separator == 2) { $element_separator = "\t"; } elsif ($element_separator == 3) { $element_separator = "\n"; } else { $self->throw("Unknown separator type '$element_separator'\n"); } my $str = ''; for (my $q = 1 ; $q <= $self->{'_max_size'} ; $q++) { my $val = 0; if (exists $self->{'_spectrum'}{$q}) { $val = $self->{'_spectrum'}{$q}; } $str .= $val.$element_separator; } $str =~ s/\s$//; return $str; } =head2 add Title : add Usage : $csp->add($additional_csp); Function: Add a contig spectrum to an existing one: sums the spectra, update the number of sequences, number of repetitions, ... Returns : 1 for success Args : Bio::Assembly::Tools::ContigSpectrum object =cut sub add { my ($self, $csp) = @_; # Sanity check if( !ref $csp || ! $csp->isa('Bio::Assembly::Tools::ContigSpectrum') ) { $self->throw("Unable to process non Bio::Assembly::Tools::ContigSpectrum ". "object [".ref($csp)."]"); } # Update overlap statistics if ( $self->{'_eff_asm_params'} > 0 ) { # Warnings if ( $csp->{'_eff_asm_params'} == 0 ) { $self->warn("The parent contig spectrum needs effective assembly ". "parameters (eff_asm_params = ".$self->{'_eff_asm_params'}.") but the ". "child contig spectrum doesn't have them (eff_asm_params = ". $csp->{'_eff_asm_params'}."). Skipping them..."); } elsif ( $csp->{'_eff_asm_params'} != $self->{'_eff_asm_params'} ) { $self->warn("The parent contig spectrum needs a different method for ". "detecting the effective assembly parameters (eff_asm_params = ". $self->{'_eff_asm_params'}.") than the one specified for the child ". "contig spectrum (eff_asm_params = ".$csp->{'_eff_asm_params'}."). ". "Ignoring the differences..."); } # Update existing stats ( $self->{'_avg_overlap'} , $self->{'_avg_identity'}, $self->{'_min_overlap'}, $self->{'_min_identity'}, $self->{'_nof_overlaps'} ) = $self->_update_overlap_stats( $self->{'_avg_overlap'} , $self->{'_avg_identity'}, $self->{'_min_overlap'}, $self->{'_min_identity'}, $self->{'_nof_overlaps'}, $csp->{'_avg_overlap'} , $csp->{'_avg_identity'} , $csp->{'_min_overlap'}, $csp->{'_min_identity'} , $csp->{'_nof_overlaps'} ); } # Update sequence average length (not number of sequences) ( $self->{'_avg_seq_len'} ) = $self->_update_seq_stats( $self->{'_avg_seq_len'}, $self->{'_nof_seq'}, $csp->{'_avg_seq_len'}, $csp->{'_nof_seq'} ); # Update spectrum (and nof_seq, max_size, and increment nof_rep by 1) $self->_import_spectrum($csp->{'_spectrum'}); # Update nof_rep $self->{'_nof_rep'}--; $self->{'_nof_rep'} += $csp->{'_nof_rep'}; # Update list of assembly objects used push @{$self->{'_assembly'}}, @{$csp->{'_assembly'}} if defined $csp->{'_assembly'}; return 1; } =head2 average Title : average Usage : my $avg_csp = $csp->average([$csp1, $csp2, $csp3]); Function: Average one contig spectrum or the sum of several contig spectra by the number of repetitions Returns : Bio::Assembly::Tools::ContigSpectrum Args : Bio::Assembly::Tools::ContigSpectrum array reference eff_asm_params =cut sub average { my ($self, $list) = @_; # Sanity check if ( ! ref $list || ! ref $list eq 'ARRAY') { $self->throw("Average takes an array reference but got [".ref($list)."]"); } # New average contig spectrum object my $avg = Bio::Assembly::Tools::ContigSpectrum->new; $avg->{'_eff_asm_params'} = $self->{'_eff_asm_params'}; # Cycle through contig spectra my $tot_nof_rep = 0; for my $csp (@$list) { # Sanity check if (not $csp->isa('Bio::Assembly::Tools::ContigSpectrum')) { $csp->throw("Unable to process non Bio::Assembly::Tools::ContigSpectrum ". "object [".ref($csp)."]"); } # Import contig spectrum $avg->add($csp); } # Average sum of contig spectra by number of repetitions for (my $q = 1 ; $q <= $avg->{'_max_size'} ; $q++) { $avg->{'_spectrum'}{$q} /= $avg->{'_nof_rep'} if (defined $avg->{'_spectrum'}{$q}); } # Average number of sequences $avg->{'_nof_seq'} /= $avg->{'_nof_rep'}; # Average number of overlaps $avg->{'_nof_overlaps'} /= $avg->{'_nof_rep'}; return $avg; } =head2 score Title : score Usage : my $score = $csp->score(); Function: Score a contig spectrum (or cross-contig spectrum) such that the higher the number of contigs (or cross-contigs) and the larger their size, the higher the score. Let n : total number of sequences c_q : number of contigs of size q q : number of sequence in a contig We define: score = n/(n-1) * (X - 1/n) where X = sum ( c_q * q^2 ) / n**2 The score ranges from 0 (singlets only) to 1 (a single large contig) It is possible to specify a value for the number of sequences to assume in the contig spectrum. Returns : contig score, or undef if there were no sequences in the contig spectrum Args : number of total sequences to assume [optional] =cut sub score { my ($self, $nof_seqs) = @_; # Sanity check my $n = $self->nof_seq; return undef if ($n <= 0); # Calculate X my $score = 0; my $q_max = $self->max_size; my $spec = $self->spectrum; for my $q ( 1 .. $q_max ) { my $c_q = $spec->{$q}; if ( $q == 1 && $nof_seqs ) { $c_q += $nof_seqs - $n; $n = $nof_seqs; } next if not $c_q; $score += $c_q * $q ** 2; } $score /= $n ** 2; # Rescale X to obtain the score $score = $n/($n-1) * ($score - 1/$n); return $score; } =head2 _naive_assembler Title : _naive_assembler Usage : Function: Reassemble the specified sequences only based on their position in the contig. This naive assembly only verifies that the minimum overlap length and percentage identity are respected. No actual alignment is done Returns : arrayref of contigs and singlets Args : Bio::Assembly::Contig array reference of sequence IDs to use [optional] minimum overlap length (integer) [optional] minimum percentage identity (integer) [optional] =cut sub _naive_assembler { my ($self, $contig, $seqlist, $min_overlap, $min_identity) = @_; # Use all reads if none was specified: if (not defined $seqlist) { for my $seq ($contig->each_seq) { push @$seqlist, $seq->id; } } # Sanity checks if ( ! ref $seqlist || ! ref($seqlist) eq 'ARRAY') { $self->throw('Expecting an array reference. Got ['.ref($seqlist)."] \n"); } my $max = scalar @$seqlist; $self->throw("Expecting at least 2 sequences as input for _naive_assembler") if ($max < 2); # Build contig graph my %seq_hash = map { $_ => undef } (@$seqlist) if (scalar @$seqlist > 0); my ($g, $overlaps) = $self->_contig_graph($contig, \%seq_hash, $min_overlap, $min_identity); # Construct sub-contigs my @contig_objs; my $num = 1; if (defined $g) { for my $connected_reads ($g->connected_components) { # reads that belong in contigs my $sub_id = $contig->id.'_'.$num; my $sub_contig = $self->_create_subcontig($contig, $connected_reads, $sub_id); push @contig_objs, $sub_contig; $num++; for my $read_id ( @$connected_reads ) { delete $seq_hash{$read_id}; } } } # Construct sub-singlets my @singlet_objs; for my $read_id ( keys %seq_hash ) { my $read = $contig->get_seq_by_name($read_id); my $sub_singlet = Bio::Assembly::Singlet->new( -id => $contig->id.'_'.$num, -seqref => $self->_obj_copy($read) ); $num++; push @singlet_objs, $sub_singlet; } return [@contig_objs, @singlet_objs]; } =head2 _create_subcontig Title : _create_subcontig Usage : Function: Create a subcontig from another contig Returns : Bio::Assembly::Contig object Args : Bio::Assembly::Contig arrayref of the IDs of the reads to includes in the subcontig ID to give to the subcontig =cut sub _create_subcontig { my ($self, $contig, $read_ids, $sub_contig_id) = @_; my $sub_contig = Bio::Assembly::Contig->new( -id => $sub_contig_id ); # Get min and max read coordinates my ($min, $max) = (undef, undef); for my $read_id ( @$read_ids ) { my ($aln_coord) = $contig->get_features_collection->get_features_by_type("_aligned_coord:$read_id"); my $seq_start = $aln_coord->location->start; my $seq_end = $aln_coord->location->end; $min = $seq_start if (not defined $min) || ((defined $min) && ($seq_start < $min)); $max = $seq_end if (not defined $max) || ((defined $max) && ($seq_end > $max)); } # Add reads to subcontig for my $read_id (@$read_ids) { my $read = $self->_obj_copy($contig->get_seq_by_name($read_id)); my $coord = $self->_obj_copy($contig->get_seq_coord($read)); if ($min > 1) { # adjust read coordinates $coord->start( $coord->start - $min + 1 ); $coord->end( $coord->end - $min + 1 ); } $sub_contig->set_seq_coord($coord, $read); } # Truncate copy of original consensus to new boundaries my $cons_seq = $contig->get_consensus_sequence; $sub_contig->set_consensus_sequence( $self->_obj_copy($cons_seq, $min, $max) ); my $cons_qual = $contig->get_consensus_quality; if ($cons_qual) { $sub_contig->set_consensus_quality( $self->_obj_copy($cons_qual, $min, $max) ); } return $sub_contig; } =head2 _obj_copy Title : _obj_copy Usage : Function: Copy (most of) an object, and optionally truncate it Returns : another a Bio::LocatableSeq, Bio::Seq::PrimaryQual, or Bio::SeqFeature::Generic object Args : a Bio::LocatableSeq, Bio::Seq::PrimaryQual, or Bio::SeqFeature::Generic object a start position an end position =cut sub _obj_copy { my ($self, $obj, $start, $end) = @_; my $new; if ($obj->isa('Bio::Seq::PrimaryQual')) { my $qual = [@{$obj->qual}]; # copy of the quality scores if (defined $start && defined $end && $start !=1 && $end != scalar(@$qual)) { # Truncate the quality scores $qual = [ splice @$qual, $start - 1, $end - $start + 1 ]; } $new = Bio::Seq::PrimaryQual->new( -qual => $qual, -id => $obj->id, ); } elsif ($obj->isa('Bio::LocatableSeq')) { my $seq = $obj->seq; if (defined $start && defined $end && $start != 1 && $end != length($seq)) { # Truncate the aligned sequence $seq = substr $seq, $start - 1, $end - $start + 1; } $new = Bio::LocatableSeq->new( -seq => $seq, -id => $obj->id, -start => $obj->start, -strand => $obj->strand, -alphabet => $obj->alphabet, ); } elsif ($obj->isa('Bio::SeqFeature::Generic')) { $new = Bio::SeqFeature::Generic->new( -start => $obj->start, -end => $obj->end ); } return $new; } =head2 _new_from_assembly Title : _new_from_assembly Usage : Function: Creates a new contig spectrum object based solely on the result of an assembly, contig or singlet Returns : Bio::Assembly::Tools::ContigSpectrum object Args : Bio::Assembly::Scaffold, Contig or Singlet object =cut sub _new_from_assembly { # Create new contig spectrum object based purely on what we can get from the # assembly object my ($self, $assemblyobj) = @_; my $csp = Bio::Assembly::Tools::ContigSpectrum->new(); # 1: Set id $csp->{'_id'} = $assemblyobj->id; # 2: Set overlap statistics: nof_overlaps, min_overlap, avg_overlap, # min_identity and avg_identity $csp->{'_eff_asm_params'} = $self->{'_eff_asm_params'}; $csp->{'_min_overlap'} = $self->{'_min_overlap'}; $csp->{'_min_identity'} = $self->{'_min_identity'}; if ( $csp->{'_eff_asm_params'} > 0 ) { ( $csp->{'_avg_overlap'}, $csp->{'_avg_identity'}, $csp->{'_min_overlap'}, $csp->{'_min_identity'}, $csp->{'_nof_overlaps'} ) = $csp->_get_assembly_overlap_stats($assemblyobj); } # 3: Set sequence statistics: nof_seq and avg_seq_len ($csp->{'_avg_seq_len'}, $csp->{'_nof_seq'}) = $self->_get_assembly_seq_stats($assemblyobj); ### any use in using _naive_assembler here to re-assemble with specific minmum criteria? # 4: Set the spectrum: spectrum and max_size for my $contigobj ( $self->_get_contig_like($assemblyobj) ) { my $size = $contigobj->num_sequences; if (defined $csp->{'_spectrum'}{$size}) { $csp->{'_spectrum'}{$size}++; } else { $csp->{'_spectrum'}{$size} = 1; } $csp->{'_max_size'} = $size if $size > $csp->{'_max_size'}; } # 5: Set list of assembly objects used push @{$csp->{'_assembly'}}, $assemblyobj; # 6: Set number of repetitions $csp->{'_nof_rep'} = 1; return $csp; } =head2 _new_dissolved_csp Title : _new_dissolved_csp Usage : Function: create a dissolved contig spectrum object Returns : dissolved contig spectrum Args : mixed contig spectrum header of sequences to keep in this contig spectrum =cut sub _new_dissolved_csp { my ($self, $mixed_csp, $seq_header) = @_; # Sanity checks on the mixed contig spectrum # min_overlap and min_identity must be specified if there are some overlaps # in the mixed contig if ($mixed_csp->{'_nof_overlaps'} > 0) { unless ( defined $self->{'_min_overlap'} || defined $mixed_csp->{'_min_overlap'} ) { $self->throw("min_overlap must be defined in the dissolved contig spectrum". " or mixed contig spectrum to dissolve a contig"); } unless ( defined $self->{'_min_identity'} || defined $mixed_csp->{'_min_identity'} ) { $self->throw("min_identity must be defined in the dissolved contig spectrum". " or mixed contig spectrum"); } } # there must be at least one assembly in mixed contig spectrum if (!defined $mixed_csp->{'_assembly'} || scalar @{$mixed_csp->{'_assembly'}} < 1) { $self->throw("The mixed contig spectrum must be based on at least one assembly"); } # New dissolved contig spectrum object my $dissolved = Bio::Assembly::Tools::ContigSpectrum->new(); # Take attributes of the parent contig spectrum if they exist, or those of the # mixed contig spectrum otherwise my ($eff_asm_params, $min_overlap, $min_identity); if ($self->{'_eff_asm_params'}) { $eff_asm_params = $self->{'_eff_asm_params'}; } else { $eff_asm_params = $mixed_csp->{'_eff_asm_params'}; } if ($self->{'_min_overlap'}) { $min_overlap = $self->{'_min_overlap'}; } else { $min_overlap = $mixed_csp->{'_min_overlap'}; } if ($self->{'_min_identity'}) { $min_identity = $self->{'_min_identity'}; } else { $min_identity = $mixed_csp->{'_min_identity'}; } ($dissolved->{'_eff_asm_params'}, $dissolved->{'_min_overlap'}, $dissolved->{'_min_identity'}) = ($eff_asm_params, $min_overlap, $min_identity); # Dissolve each assembly for my $obj (@{$mixed_csp->{'_assembly'}}) { for my $contig ( $self->_get_contig_like($obj) ) { # Dissolve this assembly/contig/singlet for the given sequences my $dissolved_objs = $self->_dissolve_contig( $contig, $seq_header, $min_overlap, $min_identity ); # Add dissolved contigs to contig spectrum for my $dissolved_obj (@$dissolved_objs) { $dissolved->assembly($dissolved_obj); $dissolved->{'_nof_rep'}--; } } } # Update nof_rep $dissolved->{'_nof_rep'} += $mixed_csp->{'_nof_rep'}; return $dissolved; } =head2 _dissolve_contig Title : _dissolve_contig Usage : Function: dissolve a contig Returns : arrayref of contigs and singlets Args : mixed contig spectrum header of sequences to keep in this contig spectrum minimum overlap minimum identity =cut sub _dissolve_contig { my ($self, $contig, $wanted_origin, $min_overlap, $min_identity) = @_; # List of reads my @seqs; if ($contig->isa('Bio::Assembly::Singlet')) { @seqs = $contig->seqref; } elsif ($contig->isa('Bio::Assembly::Contig')) { @seqs = $contig->each_seq; } # Get sequences from the desired metagenome my @contig_seqs; for my $seq (@seqs) { my $seq_id = $seq->id; # get sequence origin next unless $self->_seq_origin($seq_id) eq $wanted_origin; # add it to hash push @contig_seqs, $seq_id; } # Update spectrum my $size = scalar @contig_seqs; my $objs; if ($size == 1) { # create a singlet and add it to list of objects my $id = $contig_seqs[0]; my $seq = $contig->get_seq_by_name($id); push @$objs, Bio::Assembly::Singlet->new(-id => $contig->id, -seqref => $self->_obj_copy($seq) ); } elsif ($size > 1) { # Reassemble good sequences my $contig_objs = $self->_naive_assembler( $contig, \@contig_seqs, $min_overlap, $min_identity ); push @$objs, @$contig_objs; } return $objs; } =head2 _new_cross_csp Title : _new_cross_csp Usage : Function: create a cross contig spectrum object Returns : cross-contig spectrum Args : mixed contig spectrum =cut sub _new_cross_csp { my ($self, $mixed_csp) = @_; # Sanity check on the mixed contig spectrum # There must be at least one assembly if (!defined $mixed_csp->{'_assembly'} || scalar @{$mixed_csp->{'_assembly'}} < 1) { $self->throw("The mixed contig spectrum must be based on at least one ". "assembly."); } # New dissolved contig spectrum object my $cross = Bio::Assembly::Tools::ContigSpectrum->new(); # Take attributes from parent or from mixed contig spectrums my ($eff_asm_params, $min_overlap, $min_identity); if ($self->{'_eff_asm_params'}) { $eff_asm_params = $self->{'_eff_asm_params'}; } else { $eff_asm_params = $mixed_csp->{'_eff_asm_params'}; } if ($self->{'_min_overlap'}) { $min_overlap = $self->{'_min_overlap'}; } else { $min_overlap = $mixed_csp->{'_min_overlap'}; } if ($self->{'_min_identity'}) { $min_identity = $self->{'_min_identity'}; } else { $min_identity = $mixed_csp->{'_min_identity'}; } ($cross->{'_eff_asm_params'},$cross->{'_min_overlap'},$cross->{'_min_identity'}) = ($eff_asm_params, $min_overlap, $min_identity); # Get cross contig spectrum for each assembly for my $obj ( @{$mixed_csp->{'_assembly'}} ) { for my $contig ( $self->_get_contig_like($obj) ) { # Go through contigs and skip the pure ones my ($cross_contigs, $nof_cross_singlets) = $self->_cross_contig($contig, $min_overlap, $min_identity); # Add cross-contig for my $cross_contig ( @$cross_contigs ) { $cross->assembly($cross_contig); $cross->{'_nof_rep'}--; } # Add cross-singlets $cross->{'_spectrum'}->{'1'} += $nof_cross_singlets; } } # Update nof_rep $cross->{'_nof_rep'} += $mixed_csp->{'_nof_rep'}; return $cross; } =head2 _cross_contig Title : _cross_contig Usage : Function: calculate cross contigs Returns : arrayref of cross-contigs number of cross-singlets Args : contig minimum overlap minimum identity =cut sub _cross_contig { my ($self, $contig, $min_overlap, $min_identity) = @_; my $nof_cross_singlets = 0; my @cross_contigs; # Weed out pure contigs my %all_origins; for my $seq ($contig->each_seq) { my $seq_id = $seq->id; my $seq_origin = $self->_seq_origin($seq_id); if (not defined $seq_origin) { $self->warn("Sequence $seq_id doesn't have any header. Skipping it..."); next; } if ( scalar keys %all_origins > 1 ) { # a cross-contig spectrum last; } $all_origins{$seq_origin} = undef; } if ( scalar keys %all_origins <= 1 ) { # a pure contig return \@cross_contigs, $nof_cross_singlets; } %all_origins = (); # Break the cross-contigs using the specified stringency my $test_contigs = $self->_naive_assembler($contig, undef, $min_overlap, $min_identity); # Find cross contigs and singlets for my $test_contig ( @$test_contigs ) { # Find cross-contigs my %origins; for my $seq ($test_contig->each_seq) { my $seq_id = $seq->id; my $seq_origin = $self->_seq_origin($seq_id); next if not defined $seq_origin; push @{$origins{$seq_origin}}, $seq_id; } if (scalar keys %origins > 1) { # Found a cross-contig push @cross_contigs, $test_contig; } else { next; } # Find cross-singlets for my $origin (keys %origins) { my @ori_ids = @{$origins{$origin}}; if (scalar @ori_ids == 1) { $nof_cross_singlets++; } elsif (scalar @ori_ids > 1) { # Dissolve contig for the given origin ### consider using the minimum overlap and identity here again? my $ori_contigs = $self->_naive_assembler($test_contig, \@ori_ids, undef, undef); for my $ori_contig (@$ori_contigs) { $nof_cross_singlets++ if $ori_contig->num_sequences == 1; } } } } return \@cross_contigs, $nof_cross_singlets; } =head2 _seq_origin Title : _seq_origin Usage : Function: determines where a sequence comes from using its header. For example the origin of the sequence 'metagenome1|gi|9626988|ref|NC_001508.1|' is 'metagenome1' Returns : origin Args : sequence ID =cut sub _seq_origin { # Current sequence origin. Example: sequence with ID # 'metagenome1|gi|9626988|ref|NC_001508.1|' has header 'metagenome1' my ($self, $seq_id) = @_; my $origin; if ( $seq_id =~ m/^(.+?)\|/ ) { $origin = $1; } return $origin; } =head2 _import_assembly Title : _import_assembly Usage : $csp->_import_assembly($assemblyobj); Function: Update a contig spectrum object based on an assembly, contig or singlet object Returns : 1 for success Args : Bio::Assembly::Scaffold, Contig or Singlet object =cut sub _import_assembly { my ($self, $assemblyobj) = @_; # Sanity check if ( ! ref $assemblyobj || ( ! $assemblyobj->isa('Bio::Assembly::ScaffoldI') && ! $assemblyobj->isa('Bio::Assembly::Contig') )) { $self->throw("Unable to process non Bio::Assembly::ScaffoldI, Contig or ". "Singlet object [".ref($assemblyobj)."]"); } # Create new object from assembly my $csp = $self->_new_from_assembly($assemblyobj); # Update current contig spectrum object with new one $self->add($csp); return 1; } =head2 _import_spectrum Title : _import_spectrum Usage : $csp->_import_spectrum({ 1 => 90 , 2 => 3 , 4 => 1 }) Function: update a contig spectrum object based on a contig spectrum represented as a hash (key: contig size, value: number of contigs of this size) Returns : 1 for success Args : contig spectrum as a hash reference =cut sub _import_spectrum { my ($self, $spectrum) = @_; # Sanity check if( ! ref $spectrum || ! ref $spectrum eq 'HASH') { $self->throw("Spectrum should be a hash reference, but it is [". ref($spectrum)."]"); } # Update the spectrum (+ nof_rep, max_size and nof_seq) for my $size (keys %$spectrum) { # Get the number of contigs of different size if (defined $self->{'_spectrum'}{$size}) { $self->{'_spectrum'}{$size} += $$spectrum{$size}; } else { $self->{'_spectrum'}{$size} = $$spectrum{$size}; } # Update nof_seq $self->{'_nof_seq'} += $size * $$spectrum{$size}; # Update max_size $self->{'_max_size'} = $size if $size > $self->{'_max_size'}; } # If the contig spectrum has only zero 1-contigs, max_size is zero $self->{'_max_size'} = 0 if scalar keys %{$self->{'_spectrum'}} == 1 && defined $self->{'_spectrum'}{'1'} && $self->{'_spectrum'}{'1'} == 0; # Update nof_rep $self->{'_nof_rep'}++; return 1; } =head2 _import_dissolved_csp Title : _import_dissolved_csp Usage : $csp->_import_dissolved_csp($mixed_csp, $seq_header); Function: Update a contig spectrum object by dissolving a mixed contig spectrum based on the header of the sequences Returns : 1 for success Args : Bio::Assembly::Tools::ContigSpectrum sequence header string =cut sub _import_dissolved_csp { my ($self, $mixed_csp, $seq_header) = @_; # Sanity check if (not defined $mixed_csp || not defined $seq_header) { $self->throw("Expecting a contig spectrum reference and sequence header as". " arguments"); } # Create new object from assembly my $dissolved_csp = $self->_new_dissolved_csp($mixed_csp, $seq_header); # Update current contig spectrum object with new one $self->add($dissolved_csp); return 1; } =head2 _import_cross_csp Title : _import_cross_csp Usage : $csp->_import_cross_csp($mixed_csp); Function: Update a contig spectrum object by calculating the cross contig spectrum based on a mixed contig spectrum Returns : 1 for success Args : Bio::Assembly::Tools::ContigSpectrum =cut sub _import_cross_csp { my ($self, $mixed_csp) = @_; # Sanity check if (not defined $mixed_csp) { $self->throw("Expecting a contig spectrum reference as argument"); } # Create new object from assembly my $cross_csp = $self->_new_cross_csp($mixed_csp); my $nof_1_cross_contigs = $cross_csp->spectrum->{1}; # Update current contig spectrum object with new one $self->add($cross_csp); # Remove 1-contigs $self->{'_nof_seq'} -= $nof_1_cross_contigs; return 1; } =head2 _get_contig_like Title : _get_contig_like Usage : my @contig_like_objs = $csp->_get_contig_like($assembly_obj); Function: Get contigs and singlets from an assembly, contig or singlet Returns : array of Bio::Assembly::Contig and Singlet objects Args : a Bio::Assembly::Scaffold, Contig or singlet object =cut sub _get_contig_like { my ($self, $assembly_obj) = @_; my @contig_objs; if ($assembly_obj->isa('Bio::Assembly::ScaffoldI')) { # all contigs and singlets in the scaffold push @contig_objs, ($assembly_obj->all_contigs, $assembly_obj->all_singlets); } else { # a contig or singlet @contig_objs = $assembly_obj; } return @contig_objs; } =head2 _get_assembly_seq_stats Title : _get_assembly_seq_stats Usage : my $seqlength = $csp->_get_assembly_seq_stats($assemblyobj); Function: Get sequence statistics from an assembly: average sequence length, number of sequences Returns : average sequence length (decimal) number of sequences (integer) Args : Bio::Assembly::Scaffold, Contig or singlet object hash reference with the IDs of the sequences to consider [optional] =cut sub _get_assembly_seq_stats { my ($self, $assemblyobj, $seq_hash) = @_; # Sanity checks if ( !defined $assemblyobj || ( !$assemblyobj->isa('Bio::Assembly::ScaffoldI') && !$assemblyobj->isa('Bio::Assembly::Contig') ) ) { $self->throw("Must provide a Bio::Assembly::Scaffold, Contig or Singlet object"); } $self->throw("Expecting a hash reference. Got [".ref($seq_hash)."]") if (defined $seq_hash && ! ref($seq_hash) eq 'HASH'); # Update sequence stats my @asm_stats = (0,0); # asm_stats = (avg_seq_len, nof_seq) for my $contigobj ( $self->_get_contig_like($assemblyobj) ) { @asm_stats = $self->_update_seq_stats( @asm_stats, $self->_get_contig_seq_stats($contigobj, $seq_hash) ); } return @asm_stats; } =head2 _get_contig_seq_stats Title : _get_contig_seq_stats Usage : my $seqlength = $csp->_get_contig_seq_stats($contigobj); Function: Get sequence statistics from a contig: average sequence length, number of sequences Returns : average sequence length (decimal) number of sequences (integer) Args : contig object reference hash reference with the IDs of the sequences to consider [optional] =cut sub _get_contig_seq_stats { my ($self, $contigobj, $seq_hash) = @_; my @contig_stats = (0, 0); # contig_stats = (avg_length, nof_seq) for my $seqobj ($contigobj->each_seq) { next if defined $seq_hash && !defined $$seq_hash{$seqobj->id}; my $seq_string; if ($contigobj->isa('Bio::Assembly::Singlet')) { # a singlet $seq_string = $contigobj->seqref->seq; } else { # a contig $seq_string = $seqobj->seq; } # Number of non-gap characters in the sequence my $seq_len = $seqobj->_ungapped_len; my @seq_stats = ($seq_len); @contig_stats = $self->_update_seq_stats(@contig_stats, @seq_stats); } return @contig_stats; } =head2 _update_seq_stats Title : _update_seq_stats Usage : Function: Update the number of sequences and their average length 1 average identity 1 minimum length 1 minimum identity 1 number of overlaps 1 average sequence length Returns : average sequence length number of sequences Args : average sequence length 1 number of sequences 1 average sequence length 2 number of sequences 2 =cut sub _update_seq_stats { my ($self, $p_avg_length, $p_nof_seq, $n_avg_length, $n_nof_seq) = @_; # Defaults if (not defined $n_nof_seq) { $n_nof_seq = 1; } # Update overlap statistics my $avg_length = 0; my $nof_seq = $p_nof_seq + $n_nof_seq; if ($nof_seq != 0) { $avg_length = ($p_avg_length * $p_nof_seq + $n_avg_length * $n_nof_seq) / $nof_seq; } return $avg_length, $nof_seq; } =head2 _get_assembly_overlap_stats Title : _get_assembly_overlap_stats Usage : my ($avglength, $avgidentity, $minlength, $min_identity, $nof_overlaps) = $csp->_get_assembly_overlap_stats($assemblyobj); Function: Get statistics about pairwise overlaps in contigs of an assembly Returns : average overlap length average identity percent minimum overlap length minimum identity percent number of overlaps Args : Bio::Assembly::Scaffold, Contig or Singlet object hash reference with the IDs of the sequences to consider [optional] =cut sub _get_assembly_overlap_stats { my ($self, $assembly_obj, $seq_hash) = @_; # Sanity check if ( !defined $assembly_obj || ( !$assembly_obj->isa('Bio::Assembly::ScaffoldI') && !$assembly_obj->isa('Bio::Assembly::Contig') ) ) { $self->throw("Must provide a Bio::Assembly::ScaffoldI, Contig or Singlet object"); } $self->throw("Expecting a hash reference. Got [".ref($seq_hash)."]") if (defined $seq_hash && ! ref($seq_hash) eq 'HASH'); # Look at all the contigs (no singlets!) my @asm_stats = (0, 0, undef, undef, 0); # asm_stats = (avg_length, avg_identity, min_length, min_identity, nof_overlaps) for my $contig_obj ( $self->_get_contig_like($assembly_obj) ) { @asm_stats = $self->_update_overlap_stats( @asm_stats, $self->_get_contig_overlap_stats($contig_obj, $seq_hash) ); } return @asm_stats; } =head2 _get_contig_overlap_stats Title : _get_contig_overlap_stats Usage : my ($avglength, $avgidentity, $minlength, $min_identity, $nof_overlaps) = $csp->_get_contig_overlap_stats($contigobj); Function: Get statistics about pairwise overlaps in a contig or singlet. The statistics are obtained using graph theory: each read is a node and the edges between 2 reads are weighted by minus the number of conserved residues in the alignment between the 2 reads. The minimum spanning tree of this graph represents the overlaps that form the contig. Overlaps that do not satisfy the minimum overlap length and similarity get a malus on their score. Note: This function requires the optional BioPerl dependency module called 'Graph' Returns : average overlap length average identity percent minimum overlap length minimum identity percent number of overlaps Args : Bio::Assembly::Contig or Singlet object hash reference with the IDs of the sequences to consider [optional] =cut sub _get_contig_overlap_stats { my ($self, $contig_obj, $seq_hash) = @_; # Sanity check $self->throw("Must provide a Bio::Assembly::Contig object") if (!defined $contig_obj || !$contig_obj->isa("Bio::Assembly::Contig")); $self->throw("Expecting a hash reference. Got [".ref($seq_hash)."]") if (defined $seq_hash && ! ref($seq_hash) eq 'HASH'); my @contig_stats = (0, 0, undef, undef, 0); # contig_stats = (avg_length, avg_identity, min_length, min_identity, nof_overlaps) # Build contig graph ### consider providing the minima to _contig_graph here too? my ($g, $overlaps) = $self->_contig_graph($contig_obj, $seq_hash); if ( defined $g ) { # Graph minimum spanning tree (tree that goes through strongest overlaps) $g = $g->MST_Kruskal(); # Calculate minimum overlap length and identity for this contig for my $edge ( $g->edges ) { # Retrieve overlap information my ($id1, $id2) = @$edge; if (not exists $$overlaps{$id1}{$id2}) { ($id2, $id1) = @$edge; } my ($score, $length, $identity) = @{$$overlaps{$id1}{$id2}}; # Update contig stats my @overlap_stats = ($length, $identity); @contig_stats = $self->_update_overlap_stats(@contig_stats, @overlap_stats); } } return @contig_stats; } =head2 _update_overlap_stats Title : _update_overlap_stats Usage : Function: update the number of overlaps and their minimum and average length and identity Returns : Args : average length 1 average identity 1 minimum length 1 minimum identity 1 number of overlaps 1 average length 2 average identity 2 minimum length 2 minimum identity 2 number of overlaps 2 =cut sub _update_overlap_stats { my ($self, $p_avg_length, $p_avg_identity, $p_min_length, $p_min_identity, $p_nof_overlaps, $n_avg_length, $n_avg_identity, $n_min_length, $n_min_identity, $n_nof_overlaps) = @_; # Defaults if (not defined $n_nof_overlaps) { $n_nof_overlaps = 1 }; if ((not defined $n_min_length) && ($n_avg_length != 0)) { $n_min_length = $n_avg_length }; if ((not defined $n_min_identity) && ($n_avg_identity != 0)) { $n_min_identity = $n_avg_identity }; # Update overlap statistics my ($avg_length, $avg_identity, $min_length, $min_identity, $nof_overlaps) = (0, 0, undef, undef, 0); $nof_overlaps = $p_nof_overlaps + $n_nof_overlaps; if ($nof_overlaps > 0) { $avg_length = ($p_avg_length * $p_nof_overlaps + $n_avg_length * $n_nof_overlaps) / $nof_overlaps; $avg_identity = ($p_avg_identity * $p_nof_overlaps + $n_avg_identity * $n_nof_overlaps) / $nof_overlaps; } if ( not defined $p_min_length ) { $min_length = $n_min_length; } elsif ( not defined $n_min_length ) { $min_length = $p_min_length; } else { # both values are defined if ($n_min_length < $p_min_length) { $min_length = $n_min_length; } else { $min_length = $p_min_length; } } if ( not defined $p_min_identity ) { $min_identity = $n_min_identity; } elsif ( not defined $n_min_identity ) { $min_identity = $p_min_identity; } else { # both values are defined if ($n_min_identity < $p_min_identity) { $min_identity = $n_min_identity; } else { $min_identity = $p_min_identity; } } return $avg_length, $avg_identity, $min_length, $min_identity, $nof_overlaps; } =head2 _overlap_alignment Title : _overlap_alignment Usage : Function: Produce an alignment of the overlapping section of two sequences of a contig. Minimum overlap length and percentage identity can be specified. Return undef if the sequences do not overlap or do not meet the minimum overlap criteria. Return : Bio::SimpleAlign object reference alignment overlap length alignment overlap identity Args : Bio::Assembly::Contig object reference Bio::LocatableSeq contig sequence 1 Bio::LocatableSeq contig sequence 2 minium overlap length [optional] minimum overlap identity percentage[optional] =cut sub _overlap_alignment { my ($self, $contig, $qseq, $tseq, $min_overlap, $min_identity) = @_; # get query and target sequence position my $qpos = $contig->get_seq_coord($qseq); my $tpos = $contig->get_seq_coord($tseq); # check that there is an overlap my $qend = $qpos->end; my $tstart = $tpos->start; return if $qend < $tstart; my $qstart = $qpos->start; my $tend = $tpos->end; return if $qstart > $tend; # get overlap boundaries and check overlap length my $left; if ($qstart >= $tstart) { $left = $qstart } else { $left = $tstart; } my $right; if ($qend > $tend) { $right = $tend; } else { $right = $qend; } my $overlap = $right - $left + 1; return if defined $min_overlap && $overlap < $min_overlap; # slice query and target sequence to overlap boundaries my $qleft = $contig->change_coord('gapped consensus', "aligned ".$qseq->id, $left); my $qstring = substr($qseq->seq, $qleft - 1, $overlap); my $tleft = $contig->change_coord('gapped consensus', "aligned ".$tseq->id, $left); my $tstring = substr($tseq->seq, $tleft - 1, $overlap); # remove gaps present in both sequences at the same position for (my $pos = 0 ; $pos < $overlap ; $pos++) { my $qnt = substr($qstring, $pos, 1); if ($qnt eq '-') { my $tnt = substr($tstring, $pos, 1); if ($tnt eq '-') { substr($qstring, $pos, 1, ''); substr($tstring, $pos, 1, ''); $pos--; $overlap--; } } } return if defined $min_overlap && $overlap < $min_overlap; # count the number of gaps remaining in each sequence my $qgaps = ($qstring =~ tr/-//); my $tgaps = ($tstring =~ tr/-//); # make an alignment object with the query and target sequences my $aln = Bio::SimpleAlign->new; my $alseq = Bio::LocatableSeq->new( -id => 1, -seq => $qstring, -start => 1, -end => $overlap - $qgaps, -alphabet => 'dna', ); $aln->add_seq($alseq); $alseq = Bio::LocatableSeq->new( -id => 2, -seq => $tstring, -start => 1, -end => $overlap - $tgaps, -alphabet => 'dna', ); $aln->add_seq($alseq); # check overlap percentage identity my $identity = $aln->overall_percentage_identity; return if defined $min_identity && $identity < $min_identity; # all checks passed, return alignment return $aln, $overlap, $identity; } =head2 _contig_graph Title : _contig_graph Usage : Function: Creates a graph data structure of the contig.The graph is undirected. The vertices are the reads of the contig and edges are the overlap between the reads. The edges are weighted by the opposite of the overlap, so it is negative and the better the overlap, the lower the weight. Return : Graph object or undef hashref of overlaps (score, length, identity) for each read pair Args : Bio::Assembly::Contig object reference hash reference with the IDs of the sequences to consider [optional] minimum overlap length (integer) [optional] minimum percentage identity (integer) [optional] =cut sub _contig_graph { my ($self, $contig_obj, $seq_hash, $min_overlap, $min_identity) = @_; # Sanity checks if( !ref $contig_obj || ! $contig_obj->isa('Bio::Assembly::Contig') ) { $self->throw("Unable to process non Bio::Assembly::Contig ". "object [".ref($contig_obj)."]"); } if (not eval { require Graph::Undirected }) { $self->throw("Error: the module 'Graph' is needed by the method ". "_contig_graph but could not be found\n$@"); } # Skip contigs of 1 sequence (they have no overlap) my @seq_objs = $contig_obj->each_seq; my $nof_seqs = scalar @seq_objs; return if ($nof_seqs <= 1); # Calculate alignment between all pairs of reads my %overlaps; for my $i (0 .. $nof_seqs-1) { my $seq_obj = $seq_objs[$i]; my $seq_id = $seq_obj->id; # Skip this read if not in list of wanted sequences next if defined $seq_hash && !exists $$seq_hash{$seq_id}; # What is the best sequence to align to? my ($best_score, $best_length, $best_identity); for my $j ($i+1 .. $nof_seqs-1) { # Skip this sequence if not in list of wanted sequences my $target_obj = $seq_objs[$j]; my $target_id = $target_obj->id; next if defined $seq_hash && !exists $$seq_hash{$target_id}; # How much overlap with this sequence? my ($aln_obj, $length, $identity) = $self->_overlap_alignment($contig_obj, $seq_obj, $target_obj, $min_overlap, $min_identity); next if ! defined $aln_obj; # there was no sequence overlap or overlap not good enough # Score the overlap as the number of conserved residues. In practice, it # seems to work better than giving +1 for match and -3 for errors # (mismatch or indels) my $score = $length * $identity / 100; # Apply a malus (square root) for scores that do not satisfy the minimum # overlap length similarity. It is necessary for overlaps that get a high # score without satisfying both the minimum values. if ( ( $min_overlap && ($length < $min_overlap ) ) || ( $min_identity && ($identity < $min_identity) ) ) { $score = sqrt($score); } $overlaps{$seq_id}{$target_id} = [$score, $length, $identity]; } } # Process overlaps my $g; # the Graph object if (scalar keys %overlaps >= 1) { # At least 1 overlap. Create a weighted undirected graph $g = Graph::Undirected->new(); for my $seq_id (keys %overlaps) { for my $target_id (keys %{$overlaps{$seq_id}}) { my $score = @{$overlaps{$seq_id}{$target_id}}[0]; my $weight = -$score; $g->add_weighted_edge($seq_id, $target_id, $weight); } } } return $g, \%overlaps; } =head2 _draw_graph Title : _draw_graph Usage : Function: Generates a PNG picture of the contig graph. It is mostly for debugging purposes. Return : 1 for success Args : a Graph object hashref of overlaps (score, length, identity) for each read pair name of output file overlap info to display: 'score' (default), 'length' or 'identity' =cut sub _draw_graph { my ($self, $g, $overlaps, $outfile, $edge_type) = @_; $self->throw("Error: need to provide a graph as input\n") if not defined $g; if (not eval { require GraphViz }) { $self->throw("Error: the module 'GraphViz' is needed by the method ". "_draw_graph but could not be found\n$@"); } $edge_type ||= 'score'; my $viz = GraphViz->new( directed => 0 ); for my $edge ( $g->edges ) { # Retrieve overlap information my ($id1, $id2) = @$edge; if (not exists $$overlaps{$id1}{$id2}) { ($id2, $id1) = @$edge; } my ($score, $length, $identity) = @{$$overlaps{$id1}{$id2}}; my $edge_val; if ($edge_type eq 'score') { $edge_val = $score; } elsif ($edge_type eq 'length') { $edge_val = $length; } elsif ($edge_type eq 'identity') { $edge_val = $identity; } else { $self->throw("Error: invalid edge type to display, '$edge_val'"); } $viz->add_edge($id1 => $id2, label => $edge_val); } open my $fh, '>', $outfile or die "Error: Could not write file '$outfile'\n$!\n"; print $fh $viz->as_png; close $fh; return 1; } 1; __END__ BioPerl-1.6.923/Bio/Cluster000755000765000024 012254227332 15433 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Cluster/ClusterFactory.pm000444000765000024 1224612254227320 21121 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Cluster::ClusterFactory # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Cluster::ClusterFactory - Instantiates a new Bio::ClusterI (or derived class) through a factory =head1 SYNOPSIS use Bio::Cluster::ClusterFactory; # if you don't provide a default type, the factory will try # some guesswork based on display_id and namespace my $factory = Bio::Cluster::ClusterFactory->new(-type => 'Bio::Cluster::UniGene'); my $clu = $factory->create_object(-description => 'NAT', -display_id => 'Hs.2'); =head1 DESCRIPTION This object will build L objects generically. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Cluster::ClusterFactory; use strict; use Bio::Root::Root; use base qw(Bio::Factory::ObjectFactory); =head2 new Title : new Usage : my $obj = Bio::Cluster::ClusterFactory->new(); Function: Builds a new Bio::Cluster::ClusterFactory object Returns : Bio::Cluster::ClusterFactory Args : -type => string, name of a ClusterI derived class. If not provided, the factory will have to guess from ID and namespace, which may or may not be successful. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->interface("Bio::ClusterI"); $self->type($self->type) if $self->type; return $self; } =head2 create_object Title : create_object Usage : my $seq = $factory->create_object(); Function: Instantiates new Bio::ClusterI (or one of its child classes) This object allows us to genericize the instantiation of cluster objects. Returns : L compliant object The return type is configurable using new(-type =>"..."). Args : initialization parameters specific to the type of cluster object we want. Typically -display_id => $name -description => description of the cluster -members => arrayref, members of the cluster =cut sub create_object { my ($self,@args) = @_; my $type = $self->type(); if(! $type) { # we need to guess this $type = $self->_guess_type(@args); $self->throw("No cluster type set and unable to guess.") unless $type; $self->type($type); } return $type->new(-verbose => $self->verbose, @args); } =head2 _guess_type Title : _guess_type Usage : Function: Guesses the right type of L implementation based on initialization parameters for the prospective object. Example : Returns : the type (a string, the module name) Args : initialization parameters to be passed to the prospective cluster object =cut sub _guess_type{ my ($self,@args) = @_; my $type; # we can only guess from a certain number of arguments my ($dispid, $ns, $members) = $self->_rearrange([qw(DISPLAY_ID NAMESPACE MEMBERS )], @args); # Unigene namespace or ID? if($ns && (lc($ns) eq "unigene")) { $type = 'Bio::Cluster::UniGene'; } elsif($dispid && ($dispid =~ /^Hs\.[0-9]/)) { $type = 'Bio::Cluster::UniGene'; } # what else could we look for? return $type; } 1; BioPerl-1.6.923/Bio/Cluster/FamilyI.pm000444000765000024 1022312254227313 17475 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Cluster::FamilyI # # Please direct questions and support issues to # # Cared for by Shawn Hoon # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Cluster::FamilyI - Family Interface =head1 SYNOPSIS # see the implementations of this interface for details my $cluster= $cluster->new(-description=>"POLYUBIQUITIN", -members =>[$seq1,$seq2]); my @members = $cluster->get_members(); my @sub_members = $cluster->get_members(-species=>"homo sapiens"); =head1 DESCRIPTION This interface if for a Family object representing a family of biological objects. A generic implementation for this may be found a L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Cluster::FamilyI; use strict; use base qw(Bio::ClusterI); =head2 new We don't mandate but encourage implementors to support at least the following named parameters upon object initialization. Arguments Description --------- ----------- -family_id the name of the family -description the consensus description of the family -annotation_score the confidence by which the consensus description is representative of the family -members the members belonging to the family -alignment the multiple alignment of the members =cut =head2 family_id Title : family_id Usage : Bio::Cluster::FamilyI->family_id("znfp"); Function: get/set for the family id Returns : the family id Args : the family id =cut sub family_id{ shift->throw_not_implemented(); } =head2 family_score Title : family_score Usage : Bio::Cluster::FamilyI->family_score(95); Function: get/set for the score of algorithm used to generate the family if present Returns : the score Args : the score =cut sub family_score { shift->throw_not_implemented(); } =head1 Methods inherited from L =cut =head2 display_id Title : display_id Usage : Function: Get the display name or identifier for the cluster Returns : a string Args : =cut =head2 get_members Title : get_members Usage : Bio::Cluster::FamilyI->get_members(); Function: get the members of the family Returns : the array of members Args : the array of members =cut =head2 description Title : description Usage : Bio::Cluster::FamilyI->description("Zinc Finger Protein"); Function: get/set for the description of the family Returns : the description Args : the description =cut =head2 size Title : size Usage : Bio::Cluster::FamilyI->size(); Function: get/set for the description of the family Returns : size Args : =cut =head2 cluster_score Title : cluster_score Usage : $cluster ->cluster_score(100); Function: get/set for cluster_score which represent the score in which the clustering algorithm assigns to this cluster. Returns : a number =cut 1; BioPerl-1.6.923/Bio/Cluster/SequenceFamily.pm000444000765000024 2462112254227332 21065 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Cluster::SequenceFamily # # Please direct questions and support issues to # # Cared for by Shawn Hoon # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Cluster::SequenceFamily - Sequence Family object =head1 SYNOPSIS use Bio::SeqIO; use Bio::Cluster::SequenceFamily; use File::Spec; my $file = File::Spec->catfile('t','data','swiss.dat'); my $seqio= Bio::SeqIO->new(-format => 'swiss', -file => $file); my @mem; while(my $seq = $seqio->next_seq){ push @mem, $seq; } #create the family my $family = Bio::Cluster::SequenceFamily->new( -family_id=>"Family_1", -description=>"Family Description Here", -annotation_score=>"100", -members=>\@mem); #access the family foreach my $mem ($family->get_members){ print $mem->display_id."\t".$mem->desc."\n"; } #select members if members have a Bio::Species Object my @mem = $family->get_members(-binomial=>"Homo sapiens"); @mem = $family->get_members(-ncbi_taxid => 9606); @mem = $family->get_members(-common_name=>"Human"); @mem = $family->get_members(-species=>"sapiens"); @mem = $family->get_members(-genus=>"Homo"); =head1 DESCRIPTION This is a simple Family object that may hold any group of object. For more specific families, one should derive from FamilyI. =head1 FEEDBACK Email bioperl-l@bioperl.org for support and feedback. =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut # Let the code begin... package Bio::Cluster::SequenceFamily; use strict; use warnings; use base qw(Bio::Root::Root Bio::Cluster::FamilyI); =head2 new Title : new Usage : my $family = Bio::Cluster::SequenceFamily->new( -family_id=>"Family_1", -description=>"Family Description Here", -annotation_score=>"100", -members=>\@mem); Function: Constructor for SequenceFamily object Returns : Bio::Cluster::SequenceFamily object See L. =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($id,$description,$version,$annot_score, $family_score,$members) = $self->_rearrange([qw(FAMILY_ID DESCRIPTION VERSION ANNOTATION_SCORE FAMILY_SCORE MEMBERS)],@args); $self->{'_members'} = []; $id && $self->family_id($id); $description && $self->description($description); $version && $self->version($version); $annot_score && $self->annotation_score($annot_score); $family_score && $self->family_score($family_score); $members && $self->add_members($members); return $self; } =head2 version Title : version Usage : $family->version("1.0"); Function: get/set for version Returns : a string version of the family generated. =cut sub version{ my ($self,$value) = @_; if($value){ $self->{'_version'} =$value; } return $self->{'_version'}; } =head2 annotation_score Title : annotation_score Usage : $family->annotation_score(100); Function: get/set for annotation_score which represent the confidence in which the consensus description has been assigned to the family. Returns : Bio::SimpleAlign See L =cut sub annotation_score{ my ($self,$score) = @_; if($score){ $self->{'_annotation_score'} = $score; } return $self->{'_annotation_score'}; } =head2 alignment Title : alignment Usage : $family->alignment($align); Function: get/set for an alignment object representing the multiple alignment of the members of the family. Returns : Bio::SimpleAlign See L =cut sub alignment { my ($self,$align) = @_; if($align){ $self->{'_alignment'} = $align; } return $self->{'_alignment'}; } =head2 tree Title : tree Usage : $family->tree($tree); Function: get/set for an tree object representing the phylogenetic tree of the family. Returns : Bio::Tree See L =cut sub tree { my ($self,$tree) = @_; if($tree) { $self->{'_tree'} = $tree; } return $self->{'_tree'}; } =head1 L methods =cut =head2 family_score Title : family_score Usage : Bio::Cluster::FamilyI->family_score(95); Function: get/set for the score of algorithm used to generate the family if present This is aliased to cluster_score(). Returns : the score Args : the score =cut sub family_score { return shift->cluster_score(@_); } =head2 family_id Title : family_id Usage : $family->family_id("Family_1"); Function: get/set for family id This is aliased to display_id(). Returns : a string specifying identifier of the family =cut sub family_id{ return shift->display_id(@_); } =head1 L methods =cut =head2 display_id Title : display_id Usage : Function: Get/set the display name or identifier for the cluster Returns : a string Args : optional, on set the display ID ( a string) =cut sub display_id{ my ($self,$id) = @_; if($id){ $self->{'_cluster_id'} = $id; } return $self->{'_cluster_id'}; } =head2 description Title : description Usage : $fam->description("POLYUBIQUITIN") Function: get/set for the consensus description of the cluster Returns : the description string Args : Optional the description string =cut sub description{ my ($self,$desc) = @_; if($desc){ $self->{'_description'} = $desc; } return $self->{'_description'}; } =head2 get_members Title : get_members Usage : Valid criteria: -common_name -binomial -ncbi_taxid -organelle -genus $family->get_members(-common_name =>"human"); $family->get_members(-species =>"homo sapiens"); $family->get_members(-ncbi_taxid => 9606); For now, multiple critieria are ORed. Will return all members if no criteria are provided. Function: get members using methods from L the phylogenetic tree of the family. Returns : an array of objects that are member of this family. =cut sub get_members { my $self = shift; return @{$self->{'_members'}} unless @_; ## since the logic behind the checks is OR, we keep the ids in an hash for ## performance (skip the test if it's already there) and to avoid repats my %match; my %filter = @_; foreach my $key (keys %filter) { (my $method = $key) =~ s/^-//; %match = (%match, map { $_ => $_ } grep { ! $match{$_} && $_->species && ($_->species->can($method) || $self->throw("$method is an invalid criteria")) && $_->species->$method() eq $filter{$key} } @{$self->{'_members'}}); } return map {$match{$_}} keys (%match); } =head2 size Title : size Usage : $fam->size(); Function: get/set for the size of the family, calculated from the number of members Returns : the size of the family Args : =cut sub size { my ($self) = @_; return scalar(@{$self->{'_members'}}); } =head2 cluster_score Title : cluster_score Usage : $fam->cluster_score(100); Function: get/set for cluster_score which represent the score in which the clustering algorithm assigns to this cluster. Returns : a number =cut sub cluster_score{ my ($self,$score) = @_; if($score){ $self->{'_cluster_score'} = $score; } return $self->{'_cluster_score'}; } =head1 Implementation specific methods These are mostly for adding/removing/changing. =cut =head2 add_members Title : add_members Usage : $fam->add_member([$seq1,$seq1]); Function: add members to a family Returns : Args : the member(s) to add, as an array or arrayref =cut sub add_members{ my ($self,@mems) = @_; if (@mems) { my $mem = shift(@mems); if(ref($mem) eq "ARRAY"){ push @{$self->{'_members'}},@{$mem}; } else { push @{$self->{'_members'}},$mem; } push @{$self->{'_members'}}, @mems; } return 1; } =head2 remove_members Title : remove_members Usage : $fam->remove_members(); Function: remove all members from a family Returns : the previous array of members Args : none =cut sub remove_members{ my ($self) = @_; my $mems = $self->{'_members'}; $self->{'_members'} = []; return @$mems; } ##################################################################### # aliases for naming consistency or other reasons # ##################################################################### *flush_members = \&remove_members; *add_member = \&add_members; =head2 members Title : members Usage : $members = $fam->members([$seq1,$seq1]); Function: Deprecated. Use add_members() or get_members() instead =cut sub members{ my $self = shift; if(@_) { # this is in set mode $self->warn("setting members() in ".ref($self)." is deprecated.\n". "Use add_members() instead."); return $self->add_members(@_); } else { # get mode $self->warn("members() in ".ref($self)." is deprecated.\n". "Use get_members() instead."); return $self->get_members(); } } 1; BioPerl-1.6.923/Bio/Cluster/UniGene.pm000444000765000024 10434312254227316 17527 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Cluster::UniGene.pm # # Please direct questions and support issues to # # Cared for by Andrew Macgregor # # Copyright Andrew Macgregor, Jo-Ann Stanton, David Green # Molecular Embryology Group, Anatomy & Structural Biology, University of Otago # http://meg.otago.ac.nz/ # # You may distribute this module under the same terms as perl itself # # _history # April 17, 2002 - Initial implementation by Andrew Macgregor # POD documentation - main docs before the code =head1 NAME Bio::Cluster::UniGene - UniGene object =head1 SYNOPSIS use Bio::Cluster::UniGene; use Bio::ClusterIO; $stream = Bio::ClusterIO->new('-file' => "Hs.data", '-format' => "unigene"); # note: we quote -format to keep older perl's from complaining. while ( my $in = $stream->next_cluster() ) { print $in->unigene_id() . "\n"; while ( my $sequence = $in->next_seq() ) { print $sequence->accession_number() . "\n"; } } =head1 DESCRIPTION This UniGene object implements the L interface for the representation if UniGene clusters in Bioperl. It is returned by the L parser for unigene format and contains all the data associated with one UniGene record. This class implements several interfaces and hence can be used wherever instances of such interfaces are expected. In particular, the interfaces are L as the base interface for all cluster representations, and in addition L and L. The following lists the UniGene specific methods that are available (see below for details). Be aware next_XXX iterators take a snapshot of the array property when they are first called, and this snapshot is not reset until the iterator is exhausted. Hence, once called you need to exhaust the iterator to see any changes that have been made to the property in the meantime. You will usually want to use the non-iterator equivalents and loop over the elements yourself. new() - standard new call unigene_id() - set/get unigene_id title() - set/get title (description) gene() - set/get gene cytoband() - set/get cytoband mgi() - set/get mgi locuslink() - set/get locuslink homol() - set/get homologene gnm_terminus() - set/get gnm_terminus scount() - set/get scount express() - set/get express, currently takes/returns a reference to an array of expressed tissues next_express() - returns the next tissue expression from the expressed tissue array chromosome() - set/get chromosome, currently takes/returns a reference to an array of chromosome lines next_chromosome() - returns the next chromosome line from the array of chromosome lines sts() - set/get sts, currently takes/returns a reference to an array of sts lines next_sts() - returns the next sts line from the array of sts lines txmap() - set/get txmap, currently takes/returns a reference to an array of txmap lines next_txmap() - returns the next txmap line from the array of txmap lines protsim() - set/get protsim, currently takes/returns a reference to an array of protsim lines next_protsim() - returns the next protsim line from the array of protsim lines sequences() - set/get sequence, currently takes/returns a reference to an array of references to seq info next_seq() - returns a Seq object that currently only contains an accession number =head1 Implemented Interfaces This class implementes the following interfaces. =over 4 =item Bio::Cluster::UniGeneI This includes implementing Bio::ClusterI. =item Bio::IdentifiableI =item Bio::DescribableI =item Bio::AnnotatableI =item Bio::Factory::SequenceStreamI =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Andrew Macgregor Email andrew at cbbc.murdoch.edu.au =head1 CONTRIBUTORS Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut # Let the code begin... package Bio::Cluster::UniGene; use strict; use Bio::Annotation::Collection; use Bio::Annotation::DBLink; use Bio::Annotation::SimpleValue; use Bio::Species; use Bio::Seq::SeqFactory; use base qw(Bio::Root::Root Bio::Cluster::UniGeneI Bio::IdentifiableI Bio::DescribableI Bio::AnnotatableI Bio::Factory::SequenceStreamI); my %species_map = ( 'Aga' => "Anopheles gambiae", 'Ame' => "Apis mellifera", 'At' => "Arabidopsis thaliana", 'Bmo' => "Bombyx mori", 'Bt' => "Bos taurus", 'Cel' => "Caenorhabditis elegans", 'Cfa' => "Canine familiaris", 'Cin' => "Ciona intestinalis", 'Cre' => "Chlamydomonas reinhardtii", 'Csa' => "Ciona savignyi", 'Csi' => "Citrus sinensis", 'Ddi' => "Dictyostelium discoideum", 'Dr' => "Danio rerio", 'Dm' => "Drosophila melanogaster", 'Gga' => "Gallus gallus", 'Gma' => "Glycine max", 'Han' => "Helianthus annus", 'Hs' => "Homo sapiens", 'Hma' => "Hydra magnipapillata", 'Hv' => "Hordeum vulgare", 'Lco' => "Lotus corniculatus", 'Les' => "Lycopersicon esculentum", 'Lsa' => "Lactuca sativa", 'Mdo' => "Malus x domestica", 'Mgr' => "Magnaporthe grisea", 'Mm' => "Mus musculus", 'Mtr' => "Medicago truncatula", 'Ncr' => "Neurospora crassa", 'Oar' => "Ovis aries", 'Omy' => "Oncorhynchus mykiss", 'Os' => "Oryza sativa", 'Ola' => "Oryzias latipes", 'Ppa' => "Physcomitrella patens", 'Pta' => "Pinus taeda", 'Ptp' => "Populus tremula x Populus tremuloides", 'Rn' => "Rattus norvegicus", 'Sbi' => "Sorghum bicolor", 'Sma' => "Schistosoma mansoni", 'Sof' => "Saccharum officinarum", 'Spu' => "Strongylocentrotus purpuratus", 'Ssa' => "Salmo salar", 'Ssc' => "Sus scrofa", 'Str' => "Xenopus tropicalis", 'Stu' => "Solanum tuberosum", 'Ta' => "Triticum aestivum", 'Tgo' => "Toxoplasma gondii", 'Tru' => "Takifugu rubripes", 'Vvi' => "Vitis vinifera", 'Xl' => "Xenopus laevis", 'Zm' => "Zea mays", ); =head2 new Title : new Usage : used by ClusterIO Returns : a new Bio::Cluster::Unigene object =cut sub new { # standard new call.. my($caller,@args) = @_; my $self = $caller->SUPER::new(@args); my ($ugid,$desc,$mems,$size,$species,$dispid,$id,$ns,$auth,$v,$seqfact) = $self->_rearrange([qw(UNIGENE_ID DESCRIPTION MEMBERS SIZE SPECIES DISPLAY_ID OBJECT_ID NAMESPACE AUTHORITY VERSION SEQFACTORY )], @args); $self->{'_alphabet'} = 'dna'; $self->unigene_id($ugid) if $ugid; $self->description($desc) if $desc; $self->sequences($mems) if $mems; $self->size($size) if defined($size); $self->display_id($dispid) if $dispid; # overwrites ugid $self->object_id($id) if $id; # overwrites dispid $self->namespace($ns || 'UniGene'); $self->authority($auth || 'NCBI'); $self->version($v) if defined($v); if( ! defined $seqfact ) { $seqfact = Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq'); } $self->sequence_factory($seqfact); if( (! $species) && (defined $self->unigene_id() && $self->unigene_id() =~ /^([A-Za-z]+)\.[0-9]/)) { # try set a default one depending on the ID $species = $species_map{$1}; } $self->species($species); return $self; } =head1 L methods =cut =head2 unigene_id Title : unigene_id Usage : unigene_id(); Function: Returns the unigene_id associated with the object. Example : $id = $unigene->unigene_id or $unigene->unigene_id($id) Returns : A string Args : None or an id =cut sub unigene_id { my ($obj,$value) = @_; if( defined $value) { $obj->{'unigene_id'} = $value; } return $obj->{'unigene_id'}; } =head2 title Title : title Usage : title(); Function: Returns the title associated with the object. Example : $title = $unigene->title or $unigene->title($title) Returns : A string Args : None or a title =cut sub title { my ($obj,$value) = @_; if( defined $value) { $obj->{'title'} = $value; } return $obj->{'title'}; } =head2 gene Title : gene Usage : gene(); Function: Returns the gene associated with the object. Example : $gene = $unigene->gene or $unigene->gene($gene) Returns : A string Args : None or a gene =cut sub gene { my $self = shift; return $self->_annotation_value('gene_name', @_); } =head2 cytoband Title : cytoband Usage : cytoband(); Function: Returns the cytoband associated with the object. Example : $cytoband = $unigene->cytoband or $unigene->cytoband($cytoband) Returns : A string Args : None or a cytoband =cut sub cytoband { my $self = shift; return $self->_annotation_value('cyto_band', @_); } =head2 mgi Title : mgi Usage : mgi(); Function: Returns the mgi associated with the object. Example : $mgi = $unigene->mgi or $unigene->mgi($mgi) Returns : A string Args : None or a mgi =cut sub mgi { my $self = shift; my $acc; if(@_) { # purge first $self->_remove_dblink('dblink','MGI'); # then add if a valid value is present if($acc = shift) { $self->_annotation_dblink('dblink','MGI',$acc); } } else { ($acc) = $self->_annotation_dblink('dblink','MGI'); } return $acc; } =head2 locuslink Title : locuslink Usage : locuslink(); Function: Returns or stores a reference to an array containing locuslink data. Returns : An array reference Args : None or an array reference =cut sub locuslink { my ($self,$ll) = @_; if($ll) { # purge first $self->_remove_dblink('dblink','LocusLink'); # then add as many accessions as are present foreach my $acc (@$ll) { $self->_annotation_dblink('dblink','LocusLink',$acc); } } else { my @accs = $self->_annotation_dblink('dblink','LocusLink'); $ll = [@accs]; } return $ll; } =head2 homol Title : homol Usage : homol(); Function: Returns the homol entry associated with the object. Example : $homol = $unigene->homol or $unigene->homol($homol) Returns : A string Args : None or a homol entry =cut sub homol { my $self = shift; return $self->_annotation_value('homol', @_); } =head2 restr_expr Title : restr_expr Usage : restr_expr(); Function: Returns the restr_expr entry associated with the object. Example : $restr_expr = $unigene->restr_expr or $unigene->restr_expr($restr_expr) Returns : A string Args : None or a restr_expr entry =cut sub restr_expr { my $self = shift; return $self->_annotation_value('restr_expr', @_); } =head2 gnm_terminus Title : gnm_terminus Usage : gnm_terminus(); Function: Returns the gnm_terminus associated with the object. Example : $gnm_terminus = $unigene->gnm_terminus or $unigene->gnm_terminus($gnm_terminus) Returns : A string Args : None or a gnm_terminus =cut sub gnm_terminus { my $self = shift; return $self->_annotation_value('gnm_terminus', @_); } =head2 scount Title : scount Usage : scount(); Function: Returns the scount associated with the object. Example : $scount = $unigene->scount or $unigene->scount($scount) Returns : A string Args : None or a scount =cut sub scount { my ($obj,$value) = @_; if( defined $value) { $obj->{'scount'} = $value; } elsif((! defined($obj->{'scount'})) && defined($obj->sequences())) { $obj->{'scount'} = $obj->size(); } return $obj->{'scount'}; } =head2 express Title : express Usage : express(); Function: Returns or stores a reference to an array containing tissue expression data Returns : An array reference Args : None or an array reference =cut sub express { my $self = shift; return $self->_annotation_value_ary('expressed',@_); } =head2 chromosome Title : chromosome Usage : chromosome(); Function: Returns or stores a reference to an array containing chromosome lines Returns : An array reference Args : None or an array reference =cut sub chromosome { my $self = shift; return $self->_annotation_value_ary('chromosome',@_); } =head2 sts Title : sts Usage : sts(); Function: Returns or stores a reference to an array containing sts lines Returns : An array reference Args : None or an array reference =cut sub sts { my $self = shift; return $self->_annotation_value_ary('sts',@_); } =head2 txmap Title : txmap Usage : txmap(); Function: Returns or stores a reference to an array containing txmap lines Returns : An array reference Args : None or an array reference =cut sub txmap { my $self = shift; return $self->_annotation_value_ary('txmap',@_); } =head2 protsim Title : protsim Usage : protsim(); Function: Returns or stores a reference to an array containing protsim lines This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub protsim { my $self = shift; return $self->_annotation_value_ary('protsim',@_); } =head2 sequences Title : sequences Usage : sequences(); Function: Returns or stores a reference to an array containing sequence data. This is mostly reserved for ClusterIO parsers. You should use get_members() for get and add_member()/remove_members() for set. Returns : An array reference, or undef Args : None or an array reference or undef =cut sub sequences { my $self = shift; return $self->{'members'} = shift if @_; return $self->{'members'}; } =head2 species Title : species Usage : $obj->species($newval) Function: Get/set the species object for this Unigene cluster. Example : Returns : value of species (a L object) Args : on set, new value (a L object or the binomial name, or undef, optional) =cut sub species{ my $self = shift; if(@_) { my $species = shift; if($species && (! ref($species))) { my @class = reverse(split(' ',$species)); $species = Bio::Species->new(-classification => \@class); } return $self->{'species'} = $species; } return $self->{'species'}; } =head1 L methods =cut =head2 display_id Title : display_id Usage : Function: Get/set the display name or identifier for the cluster This is aliased to unigene_id(). Returns : a string Args : optional, on set the display ID ( a string) =cut sub display_id{ return shift->unigene_id(@_); } =head2 description Title : description Usage : Bio::ClusterI->description("POLYUBIQUITIN") Function: get/set for the consensus description of the cluster This is aliased to title(). Returns : the description string Args : Optional the description string =cut sub description{ return shift->title(@_); } =head2 size Title : size Usage : Bio::ClusterI->size(); Function: get for the size of the family, calculated from the number of members This is aliased to scount(). Returns : the size of the cluster Args : =cut sub size { my $self = shift; # hard-wiring the size is allowed if there are no sequences return $self->scount(@_) unless defined($self->sequences()); # but we can't change the number of members through this method my $n = scalar(@{$self->sequences()}); if(@_ && ($n != $_[0])) { $self->throw("Cannot change cluster size using size() from $n to ". $_[0]); } return $n; } =head2 cluster_score Title : cluster_score Usage : $cluster ->cluster_score(100); Function: get/set for cluster_score which represent the score in which the clustering algorithm assigns to this cluster. For UniGene clusters, there really is no cluster score that would come with the data. However, we provide an implementation here so that you can score UniGene clusters if you want to. Returns : a number Args : optionally, on set a number =cut sub cluster_score{ my $self = shift; return $self->{'cluster_score'} = shift if @_; return $self->{'cluster_score'}; } =head2 get_members Title : get_members Usage : Bio::ClusterI->get_members(($seq1, $seq2)); Function: retrieve the members of the family by some criteria Will return all members if no criteria are provided. At this time this implementation does not support specifying criteria and will always return all members. Returns : the array of members Args : =cut sub get_members { my $self = shift; my $mems = $self->sequences() || []; # already objects? if(@$mems && (ref($mems->[0]) eq "HASH")) { # nope, we need to build the object list from scratch my @memlist = (); while(my $seq = $self->next_seq()) { push(@memlist, $seq); } # we cache this array of objects as the new member list $mems = \@memlist; $self->sequences($mems); } # done return @$mems; } =head1 Annotatable view at the object properties =cut =head2 annotation Title : annotation Usage : $obj->annotation($newval) Function: Get/set the L object for this UniGene cluster. Many attributes of this class are actually stored within the annotation collection object as L compliant objects, so you can conveniently access them through the same interface as you would e.g. access L annotation properties. If you call this method in set mode and replace the annotation collection with another one you should know exactly what you are doing. Example : Returns : a L compliant object Args : on set, new value (a L compliant object or undef, optional) =cut sub annotation{ my $self = shift; if(@_) { return $self->{'annotation'} = shift; } elsif(! exists($self->{'annotation'})) { $self->{'annotation'} = Bio::Annotation::Collection->new(); } return $self->{'annotation'}; } =head1 Implementation specific methods These are mostly for adding/removing to array properties, and for methods with special functionality. =cut =head2 add_member Title : add_member Usage : Function: Adds a member object to the list of members. Example : Returns : TRUE if the new member was successfuly added, and FALSE otherwise. Args : The member to add. =cut sub add_member{ my ($self,@mems) = @_; my $memlist = $self->{'members'} || []; # this is an object interface; is the member list already objects? if(@$memlist && (ref($memlist->[0]) eq "HASH")) { # nope, convert to objects $memlist = [$self->get_members()]; } # add new member(s) push(@$memlist, @mems); # store if we created this array ref ourselves $self->sequences($memlist); # done return 1; } =head2 remove_members Title : remove_members Usage : Function: Remove the list of members for this cluster such that the member list is undefined afterwards (as opposed to zero members). Example : Returns : the previous list of members Args : none =cut sub remove_members{ my $self = shift; my @mems = $self->get_members(); $self->sequences(undef); return @mems; } =head2 next_locuslink Title : next_locuslink Usage : next_locuslink(); Function: Returns the next locuslink from an array referred to using $obj->{'locuslink'} If you call this iterator again after it returned undef, it will re-cycle through the list of elements. Changes in the underlying array property while you loop over this iterator will not be reflected until you exhaust the iterator. Example : while ( my $locuslink = $in->next_locuslink() ) { print "$locuslink\n"; } Returns : String Args : None =cut sub next_locuslink { my ($obj) = @_; return $obj->_next_element("ll","locuslink"); } =head2 next_express Title : next_express Usage : next_express(); Function: Returns the next tissue from an array referred to using $obj->{'express'} If you call this iterator again after it returned undef, it will re-cycle through the list of elements. Changes in the underlying array property while you loop over this iterator will not be reflected until you exhaust the iterator. Example : while ( my $express = $in->next_express() ) { print "$express\n"; } Returns : String Args : None =cut sub next_express { my ($obj) = @_; return $obj->_next_element("express","express"); } =head2 next_chromosome Title : next_chromosome Usage : next_chromosome(); Function: Returns the next chromosome line from an array referred to using $obj->{'chromosome'} If you call this iterator again after it returned undef, it will re-cycle through the list of elements. Changes in the underlying array property while you loop over this iterator will not be reflected until you exhaust the iterator. Example : while ( my $chromosome = $in->next_chromosome() ) { print "$chromosome\n"; } Returns : String Args : None =cut sub next_chromosome { my ($obj) = @_; return $obj->_next_element("chr","chromosome"); } =head2 next_protsim Title : next_protsim Usage : next_protsim(); Function: Returns the next protsim line from an array referred to using $obj->{'protsim'} If you call this iterator again after it returned undef, it will re-cycle through the list of elements. Changes in the underlying array property while you loop over this iterator will not be reflected until you exhaust the iterator. Example : while ( my $protsim = $in->next_protsim() ) { print "$protsim\n"; } Returns : String Args : None =cut sub next_protsim { my ($obj) = @_; return $obj->_next_element("protsim","protsim"); } =head2 next_sts Title : next_sts Usage : next_sts(); Function: Returns the next sts line from an array referred to using $obj->{'sts'} If you call this iterator again after it returned undef, it will re-cycle through the list of elements. Changes in the underlying array property while you loop over this iterator will not be reflected until you exhaust the iterator. Example : while ( my $sts = $in->next_sts() ) { print "$sts\n"; } Returns : String Args : None =cut sub next_sts { my ($obj) = @_; return $obj->_next_element("sts","sts"); } =head2 next_txmap Title : next_txmap Usage : next_txmap(); Function: Returns the next txmap line from an array referred to using $obj->{'txmap'} If you call this iterator again after it returned undef, it will re-cycle through the list of elements. Changes in the underlying array property while you loop over this iterator will not be reflected until you exhaust the iterator. Example : while ( my $tsmap = $in->next_txmap() ) { print "$txmap\n"; } Returns : String Args : None =cut sub next_txmap { my ($obj) = @_; return $obj->_next_element("txmap","txmap"); } ############################### # private method # # args: prefix name for the queue # name of the method from which to re-fill # returns: the next element from that queue, or undef if the queue is empty ############################### sub _next_element{ my ($self,$queuename,$meth) = @_; $queuename = "_".$queuename."_queue"; if(! exists($self->{$queuename})) { # re-initialize from array of sequence data $self->{$queuename} = [@{$self->$meth() }]; } my $queue = $self->{$queuename}; # is queue exhausted (equivalent to end of stream)? if(! @$queue) { # yes, remove queue and signal to the caller delete $self->{$queuename}; return; } return shift(@$queue); } =head1 L methods =cut =head2 object_id Title : object_id Usage : $string = $obj->object_id() Function: a string which represents the stable primary identifier in this namespace of this object. For DNA sequences this is its accession_number, similarly for protein sequences This is aliased to unigene_id(). Returns : A scalar =cut sub object_id { return shift->unigene_id(@_); } =head2 version Title : version Usage : $version = $obj->version() Function: a number which differentiates between versions of the same object. Higher numbers are considered to be later and more relevant, but a single object described the same identifier should represent the same concept Unigene clusters usually won't have a version, so this will be mostly undefined. Returns : A number Args : on set, new value (a scalar or undef, optional) =cut sub version { my $self = shift; return $self->{'version'} = shift if @_; return $self->{'version'}; } =head2 authority Title : authority Usage : $authority = $obj->authority() Function: a string which represents the organisation which granted the namespace, written as the DNS name for organisation (eg, wormbase.org) Returns : A scalar Args : on set, new value (a scalar or undef, optional) =cut sub authority { my $self = shift; return $self->{'authority'} = shift if @_; return $self->{'authority'}; } =head2 namespace Title : namespace Usage : $string = $obj->namespace() Function: A string representing the name space this identifier is valid in, often the database name or the name describing the collection Returns : A scalar Args : on set, new value (a scalar or undef, optional) =cut sub namespace { my $self = shift; return $self->{'namespace'} = shift if @_; return $self->{'namespace'}; } =head1 L methods =cut =head2 display_name Title : display_name Usage : $string = $obj->display_name() Function: A string which is what should be displayed to the user the string should have no spaces (ideally, though a cautious user of this interface would not assumme this) and should be less than thirty characters (though again, double checking this is a good idea) This is aliased to unigene_id(). Returns : A scalar Status : Virtual =cut sub display_name { return shift->unigene_id(@_); } =head2 description() Title : description Usage : $string = $obj->description() Function: A text string suitable for displaying to the user a description. This string is likely to have spaces, but should not have any newlines or formatting - just plain text. The string should not be greater than 255 characters and clients can feel justified at truncating strings at 255 characters for the purposes of display This is already demanded by Bio::ClusterI and hence is present anyway. Returns : A scalar =cut =head1 L methods =cut =head2 next_seq Title : next_seq Usage : next_seq(); Function: Returns the next seq as a Seq object as defined by $seq->sequence_factory(), at present an empty Bio::Seq::RichSeq object with just the accession_number() and pid() set This iterator will not exhaust the array of member sequences. If you call next_seq() again after it returned undef, it will re-cycle through the list of member sequences. Example : while ( my $sequence = $in->next_seq() ) { print $sequence->accession_number() . "\n"; } Returns : Bio::PrimarySeqI object Args : None =cut sub next_seq { my ($obj) = @_; if(! exists($obj->{'_seq_queue'})) { # re-initialize from array of sequence data $obj->{'_seq_queue'} = [@{$obj->sequences()}]; } my $queue = $obj->{'_seq_queue'}; # is queue exhausted (equivalent to end of stream)? if(! @$queue) { # yes, remove queue and signal to the caller delete $obj->{'_seq_queue'}; return; } # no, still data in the queue: get the next one from the queue my $seq_h = shift(@$queue); # if this is not a simple hash ref, it's an object already, and we'll # return just that return $seq_h if(ref($seq_h) ne 'HASH'); # nope, we need to assemble this object from scratch # # assemble the annotation collection my $ac = Bio::Annotation::Collection->new(); foreach my $k (keys %$seq_h) { next if $k =~ /acc|pid|nid|version/; my $ann = Bio::Annotation::SimpleValue->new(-tagname => $k, -value => $seq_h->{$k}); $ac->add_Annotation($ann); } # assemble the initialization parameters and create object my $seqobj = $obj->sequence_factory->create( -accession_number => $seq_h->{acc}, -pid => $seq_h->{pid}, # why does NCBI prepend a 'g' to its own identifiers?? -primary_id => $seq_h->{nid} && $seq_h->{nid} =~ /^g\d+$/ ? substr($seq_h->{nid},1) : $seq_h->{nid}, -display_id => $seq_h->{acc}, -seq_version => $seq_h->{version}, -alphabet => $obj->{'_alphabet'}, -namespace => $seq_h->{acc} =~ /^NM_/ ? 'RefSeq' : 'GenBank', -authority => $obj->authority(), # default is NCBI -species => $obj->species(), -annotation => $ac ); return $seqobj; } =head2 sequence_factory Title : sequence_factory Usage : $seqio->sequence_factory($seqfactory) Function: Get/Set the Bio::Factory::SequenceFactoryI Returns : Bio::Factory::SequenceFactoryI Args : [optional] Bio::Factory::SequenceFactoryI =cut sub sequence_factory { my ($self,$obj) = @_; if( defined $obj ) { if( ! ref($obj) || ! $obj->isa('Bio::Factory::SequenceFactoryI') ) { $self->throw("Must provide a valid Bio::Factory::SequenceFactoryI object to ".ref($self)." sequence_factory()"); } $self->{'_seqfactory'} = $obj; } $self->{'_seqfactory'}; } =head1 Private methods =cut =head2 _annotation_value Title : _annotation_value Usage : Function: Private method. Example : Returns : the value (a string) Args : annotation key (a string) on set, annotation value (a string) =cut sub _annotation_value{ my $self = shift; my $key = shift; my ($ann, $val); if(@_) { $val = shift; if(! defined($val)) { ($ann) = $self->annotation->remove_Annotations($key); return $ann ? $ann->value() : undef; } } ($ann) = $self->annotation->get_Annotations($key); if(defined $ann && (! $val)) { # get mode and exists $val = $ann->value(); } elsif($val) { # set mode if(!defined $ann) { $ann = Bio::Annotation::SimpleValue->new(-tagname => $key); $self->annotation->add_Annotation($ann); } $ann->value($val); } return $val; } =head2 _annotation_value_ary Title : _annotation_value_ary Usage : Function: Private method. Example : Returns : reference to the array of values Args : annotation key (a string) on set, reference to an array holding the values =cut sub _annotation_value_ary{ my ($self,$key,$arr) = @_; my $ac = $self->annotation; if($arr) { # purge first $ac->remove_Annotations($key); # then add as many values as are present foreach my $val (@$arr) { my $ann = Bio::Annotation::SimpleValue->new(-value => $val, -tagname => $key ); $ac->add_Annotation($ann); } } else { my @vals = map { $_->value(); } $ac->get_Annotations($key); $arr = [@vals]; } return $arr; } =head2 _annotation_dblink Title : _annotation_dblink Usage : Function: Private method. Example : Returns : array of accessions for the given database (namespace) Args : annotation key (a string) dbname (a string) (optional on get, mandatory on set) on set, accession or ID (a string), and version =cut sub _annotation_dblink{ my ($self,$key,$dbname,$acc,$version) = @_; if($acc) { # set mode -- this is adding here my $ann = Bio::Annotation::DBLink->new(-tagname => $key, -primary_id => $acc, -database => $dbname, -version => $version); $self->annotation->add_Annotation($ann); return 1; } else { # get mode my @anns = $self->annotation->get_Annotations($key); # filter out those that don't match the requested database if($dbname) { @anns = grep { $_->database() eq $dbname; } @anns; } return map { $_->primary_id(); } @anns; } } =head2 _remove_dblink Title : _remove_dblink Usage : Function: Private method. Example : Returns : array of accessions for the given database (namespace) Args : annotation key (a string) dbname (a string) (optional) =cut sub _remove_dblink{ my ($self,$key,$dbname) = @_; my $ac = $self->annotation(); my @anns = (); if($dbname) { foreach my $ann ($ac->remove_Annotations($key)) { if($ann->database() eq $dbname) { push(@anns, $ann); } else { $ac->add_Annotation($ann); } } } else { @anns = $ac->remove_Annotations($key); } return map { $_->primary_id(); } @anns; } ##################################################################### # aliases for naming consistency or other reasons # ##################################################################### *sequence = \&sequences; 1; BioPerl-1.6.923/Bio/Cluster/UniGeneI.pm000444000765000024 2216612254227326 17623 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Cluster::UniGeneI.pm # # Please direct questions and support issues to # # Cared for by Andrew Macgregor # # Copyright Andrew Macgregor, Jo-Ann Stanton, David Green # Molecular Embryology Group, Anatomy & Structural Biology, University of Otago # http://anatomy.otago.ac.nz/meg # # You may distribute this module under the same terms as perl itself # # _history # April 31, 2002 - Initial implementation by Andrew Macgregor # POD documentation - main docs before the code =head1 NAME Bio::Cluster::UniGeneI - abstract interface of UniGene object =head1 SYNOPSIS # =head1 DESCRIPTION This is the general interface for a UniGene cluster representation in Bioperl. You cannot use this module directly, use an implementation instead. You can create UniGene cluster objects yourself by instantiating L. If you read UniGene clusters from a ClusterIO parser, you will get objects implementing this interface, most likely instances of said UniGene class. L inherits from L, so you can use it wherever a cluster object is expected. =head1 FEEDBACK # =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Andrew Macgregor Email andrew at cbbc.murdoch.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut # Let the code begin... package Bio::Cluster::UniGeneI; use strict; use base qw(Bio::ClusterI); =head2 unigene_id Title : unigene_id Usage : unigene_id(); Function: Returns the unigene_id associated with the object. Example : $id = $unigene->unigene_id or $unigene->unigene_id($id) Returns : A string Args : None or an id =cut sub unigene_id { my ($self) = @_; $self->throw_not_implemented; } =head2 title Title : title Usage : title(); Function: Returns the title associated with the object. Example : $title = $unigene->title or $unigene->title($title) Returns : A string Args : None or a title =cut sub title { my ($self) = @_; $self->throw_not_implemented; } =head2 gene Title : gene Usage : gene(); Function: Returns the gene associated with the object. Example : $gene = $unigene->gene or $unigene->gene($gene) Returns : A string Args : None or a gene =cut sub gene { my ($self) = @_; $self->throw_not_implemented; } =head2 cytoband Title : cytoband Usage : cytoband(); Function: Returns the cytoband associated with the object. Example : $cytoband = $unigene->cytoband or $unigene->cytoband($cytoband) Returns : A string Args : None or a cytoband =cut sub cytoband { my ($self) = @_; $self->throw_not_implemented; } =head2 mgi Title : mgi Usage : mgi(); Function: Returns the mgi associated with the object. Example : $mgi = $unigene->mgi or $unigene->mgi($mgi) Returns : A string Args : None or a mgi =cut sub mgi { my ($self) = @_; $self->throw_not_implemented; } =head2 locuslink Title : locuslink Usage : locuslink(); Function: Returns or stores a reference to an array containing locuslink data. This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub locuslink { my ($self) = @_; $self->throw_not_implemented; } =head2 homol Title : homol Usage : homol(); Function: Returns the homol entry associated with the object. Example : $homol = $unigene->homol or $unigene->homol($homol) Returns : A string Args : None or a homol entry =cut sub homol { my ($self) = @_; $self->throw_not_implemented; } =head2 restr_expr Title : restr_expr Usage : restr_expr(); Function: Returns the restr_expr entry associated with the object. Example : $restr_expr = $unigene->restr_expr or $unigene->restr_expr($restr_expr) Returns : A string Args : None or a restr_expr entry =cut sub restr_expr { my ($self) = @_; $self->throw_not_implemented; } =head2 gnm_terminus Title : gnm_terminus Usage : gnm_terminus(); Function: Returns the gnm_terminus associated with the object. Example : $gnm_terminus = $unigene->gnm_terminus or $unigene->gnm_terminus($gnm_terminus) Returns : A string Args : None or a gnm_terminus =cut sub gnm_terminus { my ($self) = @_; $self->throw_not_implemented; } =head2 scount Title : scount Usage : scount(); Function: Returns the scount associated with the object. Example : $scount = $unigene->scount or $unigene->scount($scount) Returns : A string Args : None or a scount =cut sub scount { my ($self) = @_; $self->throw_not_implemented; } =head2 express Title : express Usage : express(); Function: Returns or stores a reference to an array containing tissue expression data. This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub express { my ($self) = @_; $self->throw_not_implemented; } =head2 chromosome Title : chromosome Usage : chromosome(); Function: Returns or stores a reference to an array containing chromosome lines This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub chromosome { my ($self) = @_; $self->throw_not_implemented; } =head2 sts Title : sts Usage : sts(); Function: Returns or stores a reference to an array containing sts lines This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub sts { my ($self) = @_; $self->throw_not_implemented; } =head2 txmap Title : txmap Usage : txmap(); Function: Returns or stores a reference to an array containing txmap lines Returns : An array reference Args : None or an array reference =cut sub txmap { my ($self) = @_; $self->throw_not_implemented; } =head2 protsim Title : protsim Usage : protsim(); Function: Returns or stores a reference to an array containing protsim lines This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub protsim { my ($self) = @_; $self->throw_not_implemented; } =head2 sequence Title : sequence Usage : sequence(); Function: Returns or stores a reference to an array containing sequence data This should really only be used by ClusterIO, not directly Returns : An array reference Args : None or an array reference =cut sub sequence { my ($self) = @_; $self->throw_not_implemented; } =head2 species Title : species Usage : $obj->species($newval) Function: Get the species object for this Unigene cluster. Example : Returns : value of species (a L object) Args : =cut sub species{ shift->throw_not_implemented(); } =head1 Methods inherited from L =cut =head2 display_id Title : display_id Usage : Function: Get/set the display name or identifier for the cluster Returns : a string Args : optional, on set the display ID ( a string) =cut =head2 description Title : description Usage : Bio::ClusterI->description("POLYUBIQUITIN") Function: get/set for the consensus description of the cluster Returns : the description string Args : Optional the description string =cut =head2 size Title : size Usage : Bio::ClusterI->size(); Function: get/set for the size of the family, calculated from the number of members Returns : the size of the family Args : =cut =head2 cluster_score Title : cluster_score Usage : $cluster ->cluster_score(100); Function: get/set for cluster_score which represent the score in which the clustering algorithm assigns to this cluster. Returns : a number =cut =head2 get_members Title : get_members Usage : Bio::ClusterI->get_members(($seq1, $seq2)); Function: retrieve the members of the family by some criteria, for example : $cluster->get_members(-species => 'homo sapiens'); Will return all members if no criteria are provided. Returns : the array of members Args : =cut 1; BioPerl-1.6.923/Bio/ClusterIO000755000765000024 012254227340 15662 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/ClusterIO/dbsnp.pm000444000765000024 2450612254227340 17512 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::ClusterIO::dbsnp # # Copyright Allen Day , Stan Nelson # Human Genetics, UCLA Medical School, University of California, Los Angeles # POD documentation - main docs before the code =head1 NAME Bio::ClusterIO::dbsnp - dbSNP input stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::ClusterIO class. =head1 DESCRIPTION Parse dbSNP XML files, one refSNP entry at a time. Note this handles dbSNPp output generated by NBCI's eutils and does NOT parse output derived from SNP's XML format (found at ftp://ftp.ncbi.nih.gov/snp/). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Allen Day Eallenday@ucla.eduE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::ClusterIO::dbsnp; use strict; use Bio::Root::Root; use Bio::Variation::SNP; use XML::SAX; use Data::Dumper; use IO::File; use Time::HiRes qw(tv_interval gettimeofday); use base qw(Bio::ClusterIO); our $DEBUG = 0; our %MAPPING = ( #the ones commented out i haven't written methods for yet... -Allen 'Rs_rsId' => 'id', # 'Rs_taxId' => 'tax_id', # 'Rs_organism' => 'organism', 'Rs_snpType' => {'type' => 'value'}, 'Rs_sequence_observed' => 'observed', 'Rs_sequence_seq5' => 'seq_5', 'Rs_sequence_seq3' => 'seq_3', # 'Rs_sequence_exemplarSs' => 'exemplar_subsnp', 'Rs_create_build' => 'ncbi_build', #?? 'Rs_update_build' => 'ncbi_build', # 'NSE-rs_ncbi-num-chr-hits' => 'ncbi_chr_hits', # 'NSE-rs_ncbi-num-ctg-hits' => 'ncbi_ctg_hits', # 'NSE-rs_ncbi-num-seq-loc' => 'ncbi_seq_loc', # 'NSE-rs_ncbi-mapweight' => 'ncbi_mapweight', # 'NSE-rs_ucsc-build-id' => 'ucsc_build', # 'NSE-rs_ucsc-num-chr-hits' => 'ucsc_chr_hits', # 'NSE-rs_ucsc-num-seq-loc' => 'ucsc_ctg_hits', # 'NSE-rs_ucsc-mapweight' => 'ucsc_mapweight', 'Rs_het_value' => 'heterozygous', 'Rs_het-stdError' => 'heterozygous_SE', 'Rs_validation' => {'validated' => 'value'}, #?? # 'NSE-rs_genotype' => {'genotype' => 'value'}, 'Ss_handle' => 'handle', 'Ss_batchId' => 'batch_id', 'Ss_locSnpId' => 'id', # 'Ss_locSnpId' => 'loc_id', # 'Ss_orient' => {'orient' => 'value'}, # 'Ss_buildId' => 'build', 'Ss_methodClass' => {'method' => 'value'}, # 'NSE-ss_accession_E' => 'accession', # 'NSE-ss_comment_E' => 'comment', # 'NSE-ss_genename' => 'gene_name', # 'NSE-ss_assay-5_E' => 'seq_5', # 'NSE-ss_assay-3_E' => 'seq_3', # 'NSE-ss_observed' => 'observed', # 'NSE-ss-popinfo_type' => 'pop_type', # 'NSE-ss-popinfo_batch-id' => 'pop_batch_id', # 'NSE-ss-popinfo_pop-name' => 'pop_name', # 'NSE-ss-popinfo_samplesize' => 'pop_samplesize', # 'NSE-ss_popinfo_est-het' => 'pop_est_heterozygous', # 'NSE-ss_popinfo_est-het-se-sq' => 'pop_est_heterozygous_se_sq', # 'NSE-ss-alleleinfo_type' => 'allele_type', # 'NSE-ss-alleleinfo_batch-id' => 'allele_batch_id', # 'NSE-ss-alleleinfo_pop-id' => 'allele_pop_id', # 'NSE-ss-alleleinfo_snp-allele' => 'allele_snp', # 'NSE-ss-alleleinfo_other-allele' => 'allele_other', # 'NSE-ss-alleleinfo_freq' => 'allele_freq', # 'NSE-ss-alleleinfo_count' => 'allele_count', # 'NSE-rsContigHit_contig-id' => 'contig_hit', # 'NSE-rsContigHit_accession' => 'accession_hit', # 'NSE-rsContigHit_version' => 'version', # 'NSE-rsContigHit_chromosome' => 'chromosome_hit', # 'NSE-rsMaploc_asn-from' => 'asn_from', # 'NSE-rsMaploc_asn-to' => 'asn_to', # 'NSE-rsMaploc_loc-type' => {'loc_type' => 'value'}, # 'NSE-rsMaploc_hit-quality' => {'hit_quality' => 'value'}, # 'NSE-rsMaploc_orient' => {'orient' => 'value'}, # 'NSE-rsMaploc_physmap-str' => 'phys_from', # 'NSE-rsMaploc_physmap-int' => 'phys_to', 'FxnSet_geneId' => 'locus_id', # does the code realise that there can be multiple of these 'FxnSet_symbol' => 'symbol', 'FxnSet_mrnaAcc' => 'mrna', 'FxnSet_protAcc' => 'protein', 'FxnSet_fxnClass' => {'functional_class' => 'value'}, #... #... #there are lots more, but i don't need them at the moment... -Allen ); sub _initialize{ my ($self,@args) = @_; $self->SUPER::_initialize(@args); my ($usetempfile) = $self->_rearrange([qw(TEMPFILE)],@args); defined $usetempfile && $self->use_tempfile($usetempfile); # start up the parser factory my $parserfactory = XML::SAX::ParserFactory->parser( Handler => $self); $self->{'_xmlparser'} = $parserfactory; $DEBUG = 1 if( ! defined $DEBUG && $self->verbose > 0); } =head2 next_cluster Title : next_cluster Usage : $dbsnp = $stream->next_cluster() Function: returns the next refSNP in the stream Returns : Bio::Variation::SNP object representing composite refSNP and its component subSNP(s). Args : NONE =cut ### #Adapted from Jason's blastxml.pm ### # you shouldn't have to preparse this; the XML is well-formed and refers # accurately to a remote DTD/schema sub next_cluster { my $self = shift; my $data = ''; my($tfh); if( $self->use_tempfile ) { $tfh = IO::File->new_tmpfile or $self->throw("Unable to open temp file: $!"); $tfh->autoflush(1); } my $start = 1; while( defined( $_ = $self->_readline ) ){ #skip to beginning of refSNP entry if($_ !~ m{]*>} && $start){ next; } elsif($_ =~ m{]*>} && $start){ $start = 0; } #slurp up the data if( defined $tfh ) { print $tfh $_; } else { $data .= $_; } #and stop at the end of the refSNP entry last if $_ =~ m{}; } #if we didn't find a start tag return if $start; my %parser_args; if( defined $tfh ) { seek($tfh,0,0); %parser_args = ('Source' => { 'ByteStream' => $tfh }, 'Handler' => $self); } else { %parser_args = ('Source' => { 'String' => $data }, 'Handler' => $self); } my $starttime; my $result; if( $DEBUG ) { $starttime = [ Time::HiRes::gettimeofday() ]; } eval { $result = $self->{'_xmlparser'}->parse(%parser_args); }; if( $@ ) { $self->warn("error in parsing a report:\n $@"); $result = undef; } if( $DEBUG ) { $self->debug( sprintf("parsing took %f seconds\n", Time::HiRes::tv_interval($starttime))); } return $self->refsnp; } =head2 SAX methods =cut =head2 start_document Title : start_document Usage : $parser->start_document; Function: SAX method to indicate starting to parse a new document. Creates a Bio::Variation::SNP Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{refsnp} = Bio::Variation::SNP->new; } sub refsnp { return shift->{refsnp}; } =head2 end_document Title : end_document Usage : $parser->end_document; Function: SAX method to indicate finishing parsing a new document Returns : none Args : none =cut sub end_document{ my ($self,@args) = @_; } =head2 start_element Title : start_element Usage : $parser->start_element($data) Function: SAX method to indicate starting a new element Returns : none Args : hash ref for data =cut sub start_element{ my ($self,$data) = @_; my $nm = $data->{'Name'}; my $at = $data->{'Attributes'}->{'{}value'}; #$self->debug(Dumper($at)) if $nm = ; if($nm eq 'Ss'){ $self->refsnp->add_subsnp; return; } if(my $type = $MAPPING{$nm}){ if(ref $type eq 'HASH'){ #okay, this is nasty. what can you do? $self->{will_handle} = (keys %$type)[0]; $self->{last_data} = $at->{Value}; } else { $self->{will_handle} = $type; $self->{last_data} = undef; } } else { undef $self->{will_handle}; } } =head2 end_element Title : end_element Usage : $parser->end_element($data) Function: Signals finishing an element Returns : none Args : hash ref for data =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $at = $data->{'Attributes'}; my $method = $self->{will_handle}; if($method){ if($nm =~ /^Rs/ or $nm =~ /^NSE-SeqLoc/ or $nm =~ /^FxnSet/){ $self->refsnp->$method($self->{last_data}); } elsif ($nm =~ /^Ss/){ $self->refsnp->subsnp->$method($self->{last_data}); } } } =head2 characters Title : characters Usage : $parser->characters($data) Function: Signals new characters to be processed Returns : characters read Args : hash ref with the key 'Data' =cut sub characters{ my ($self,$data) = @_; $self->{last_data} = $data->{Data} if $data->{Data} =~ /\S/; #whitespace is meaningless -ad } =head2 use_tempfile Title : use_tempfile Usage : $obj->use_tempfile($newval) Function: Get/Set boolean flag on whether or not use a tempfile Example : Returns : value of use_tempfile Args : newvalue (optional) =cut sub use_tempfile{ my ($self,$value) = @_; if( defined $value) { $self->{'_use_tempfile'} = $value; } return $self->{'_use_tempfile'}; } 1; BioPerl-1.6.923/Bio/ClusterIO/unigene.pm000444000765000024 1775012254227330 20040 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::ClusterIO::unigene # # Please direct questions and support issues to # # Cared for by Andrew Macgregor # # Copyright Andrew Macgregor, Jo-Ann Stanton, David Green # Molecular Embryology Group, Anatomy & Structural Biology, University of Otago # http://meg.otago.ac.nz # # You may distribute this module under the same terms as perl itself # # _history # April 17, 2002 - Initial implementation by Andrew Macgregor # POD documentation - main docs before the code =head1 NAME Bio::ClusterIO::unigene - UniGene input stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::ClusterIO class. =head1 DESCRIPTION This object reads from Unigene *.data files downloaded from ftp://ftp.ncbi.nih.gov/repository/UniGene/. It does not download and decompress the file, you have to do that yourself. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Andrew Macgregor Email: andrew at cbbc.murdoch.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::ClusterIO::unigene; use strict; use Bio::Cluster::UniGene; use Bio::Cluster::ClusterFactory; use base qw(Bio::ClusterIO); my %line_is = ( ID => q/ID\s+(\w{2,3}\.\d+)/, TITLE => q/TITLE\s+(\S.*)/, GENE => q/GENE\s+(\S.*)/, CYTOBAND => q/CYTOBAND\s+(\S.*)/, MGI => q/MGI\s+(\S.*)/, LOCUSLINK => q/LOCUSLINK\s+(\S.*)/, HOMOL => q/HOMOL\s+(\S.*)/, EXPRESS => q/EXPRESS\s+(\S.*)/, RESTR_EXPR => q/RESTR_EXPR\s+(\S.*)/, GNM_TERMINUS => q/GNM_TERMINUS\s+(\S.*)/, CHROMOSOME => q/CHROMOSOME\s+(\S.*)/, STS => q/STS\s+(\S.*)/, TXMAP => q/TXMAP\s+(\S.*)/, PROTSIM => q/PROTSIM\s+(\S.*)/, SCOUNT => q/SCOUNT\s+(\S.*)/, SEQUENCE => q/SEQUENCE\s+(\S.*)/, ACC => q/ACC=(\w+)(\.\d+)?/, NID => q/NID=\s*(\S.*)/, PID => q/PID=\s*(\S.*)/, CLONE => q/CLONE=\s*(\S.*)/, END => q/END=\s*(\S.*)/, LID => q/LID=\s*(\S.*)/, MGC => q/MGC=\s*(\S.*)/, SEQTYPE => q/SEQTYPE=\s*(\S.*)/, TRACE => q/TRACE=\s*(\S.*)/, PERIPHERAL => q/PERIPHERAL=\s*(\S.*)/, DELIMITER => q{^//}, ); # we set the right factory here sub _initialize { my($self, @args) = @_; $self->SUPER::_initialize(@args); if(! $self->cluster_factory()) { $self->cluster_factory(Bio::Cluster::ClusterFactory->new( -type => 'Bio::Cluster::UniGene')); } } =head2 next_cluster Title : next_cluster Usage : $unigene = $stream->next_cluster() Function: returns the next unigene in the stream Returns : Bio::Cluster::UniGene object Args : NONE =cut sub next_cluster { my( $self) = @_; local $/ = "\n//"; return unless my $entry = $self->_readline; # set up the variables we'll need my (%unigene,@express,@locuslink,@chromosome, @sts,@txmap,@protsim,@sequence); my $UGobj; # set up the regexes # add whitespace parsing and precompile regexes #foreach (values %line_is) { # $_ =~ s/\s+/\\s+/g; # print STDERR "Regex is $_\n"; # #$_ = qr/$_/x; #} #$line_is{'TITLE'} = qq/TITLE\\s+(\\S.+)/; # run each line in an entry against the regexes foreach my $line (split /\n/, $entry) { #print STDERR "Wanting to match $line\n"; if ($line =~ /$line_is{ID}/gcx) { $unigene{ID} = $1; } elsif ($line =~ /$line_is{TITLE}/gcx ) { #print STDERR "MATCHED with [$1]\n"; $unigene{TITLE} = $1; } elsif ($line =~ /$line_is{GENE}/gcx) { $unigene{GENE} = $1; } elsif ($line =~ /$line_is{CYTOBAND}/gcx) { $unigene{CYTOBAND} = $1; } elsif ($line =~ /$line_is{MGI}/gcx) { $unigene{MGI} = $1; } elsif ($line =~ /$line_is{LOCUSLINK}/gcx) { @locuslink = split /;/, $1; } elsif ($line =~ /$line_is{HOMOL}/gcx) { $unigene{HOMOL} = $1; } elsif ($line =~ /$line_is{EXPRESS}/gcx) { my $express = $1; # remove initial semicolon if present $express =~ s/^;//; @express = split /\s*;/, $express; } elsif ($line =~ /$line_is{RESTR_EXPR}/gcx) { $unigene{RESTR_EXPR} = $1; } elsif ($line =~ /$line_is{GNM_TERMINUS}/gcx) { $unigene{GNM_TERMINUS} = $1; } elsif ($line =~ /$line_is{CHROMOSOME}/gcx) { push @chromosome, $1; } elsif ($line =~ /$line_is{TXMAP}/gcx) { push @txmap, $1; } elsif ($line =~ /$line_is{STS}/gcx) { push @sts, $1; } elsif ($line =~ /$line_is{PROTSIM}/gcx) { push @protsim, $1; } elsif ($line =~ /$line_is{SCOUNT}/gcx) { $unigene{SCOUNT} = $1; } elsif ($line =~ /$line_is{SEQUENCE}/gcx) { # parse into each sequence line my $seq = {}; # add unigene id to each seq #$seq->{unigene_id} = $unigene{ID}; my @items = split(/;/, $1); foreach (@items) { if (/$line_is{ACC}/gcx) { $seq->{acc} = $1; # remove leading dot if version pattern matched $seq->{version} = substr($2,1) if defined $2; } elsif (/$line_is{NID}/gcx) { $seq->{nid} = $1; } elsif (/$line_is{PID}/gcx) { $seq->{pid} = $1; } elsif (/$line_is{CLONE}/gcx) { $seq->{clone} = $1; } elsif (/$line_is{END}/gcx) { $seq->{end} = $1; } elsif (/$line_is{LID}/gcx) { $seq->{lid} = $1; } elsif (/$line_is{MGC}/gcx) { $seq->{mgc} = $1; } elsif (/$line_is{SEQTYPE}/gcx) { $seq->{seqtype} = $1; } elsif (/$line_is{TRACE}/gcx) { $seq->{trace} = $1; } elsif (/$line_is{PERIPHERAL}/gcx) { $seq->{peripheral} = $1; } } push @sequence, $seq; } elsif ($line =~ /$line_is{DELIMITER}/gcx) { # at the end of the record, add data to the object $UGobj = $self->cluster_factory->create_object( -display_id => $unigene{ID}, -description => $unigene{TITLE}, -size => $unigene{SCOUNT}, -members => \@sequence); $UGobj->gene($unigene{GENE}) if defined ($unigene{GENE}); $UGobj->cytoband($unigene{CYTOBAND}) if defined($unigene{CYTOBAND}); $UGobj->mgi($unigene{MGI}) if defined ($unigene{MGI}); $UGobj->locuslink(\@locuslink); $UGobj->homol($unigene{HOMOL}) if defined ($unigene{HOMOL}); $UGobj->express(\@express); $UGobj->restr_expr($unigene{RESTR_EXPR}) if defined ($unigene{RESTR_EXPR}); $UGobj->gnm_terminus($unigene{GNM_TERMINUS}) if defined ($unigene{GNM_TERMINUS}); $UGobj->chromosome(\@chromosome); $UGobj->sts(\@sts); $UGobj->txmap(\@txmap); $UGobj->protsim(\@protsim); } } return $UGobj; } 1; BioPerl-1.6.923/Bio/CodonUsage000755000765000024 012254227337 16046 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/CodonUsage/IO.pm000555000765000024 1344512254227337 17102 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::CodonUsage::IO # # Please direct questions and support issues to # # Cared for by Richard Adams (richard.adams@ed.ac.uk) # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::CodonUsage::IO - for reading and writing codon usage tables to file =head1 SYNOPSIS use Bio::CodonUsage::IO; ## read in a codon usage file my $io = Bio::CodonUsage::IO->new(-file => "in"); my $cut = $io->next_data(); ## write it out again my $out = Bio::CodonUsage::IO->new(-file => ">out"); $out->write_data($cut); =head1 DESCRIPTION This class provides standard IO methods for reading and writing text files of codon usage tables. These tables can initially be retrieved using Bio::DB::CUTG. At present only this format is supported for read/write. Reading a CUTG will return a Bio::CodonUsage::Table object. =head1 SEE ALSO L, L, L, L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin package Bio::CodonUsage::IO; use Bio::CodonUsage::Table; use base qw(Bio::Root::IO); =head2 new Title : new Usage : my $io = Bio::CodonUsage::IO->new(-file => "CUTfile"); Purpose: To read/write a Bio:CodonUsage::Table object Returns: A Bio:CodonUsage::IO object Args : a file or file handle =cut sub new { my ($class , @args) = @_; my $self = $class->SUPER::new(@args); } =head2 next_data Title : next_data Usage : my $cut = $io->next_data(); Purpose: To obtain a Bio:CodonUsage::Table object Returns: A Bio:CodonUsage::Table object Args : none =cut sub next_data { my $self = shift; my $cut = $self->_parse; return $cut; } =head2 write_data Title : write_data Usage : $io->write_data($cut); Purpose: To write a CUT to file Returns: void Args : a Bio::CodonUsage::Table object reference =cut sub write_data { my ($self, $cut) = @_; if (!$cut || ! $cut->isa(Bio::CodonUsage::Table)) { $self->throw("must supply a Bio::CodonUsage::Table object for writing\n"); } my $outstring = "Codon usage table\n\n"; my $sp_string = $cut->species . "[" . $cut->_gb_db . "] " . $cut->cds_count . " CDS's\n\n"; $outstring .= $sp_string; my $colhead = sprintf("%-9s%-9s%15s%12s%12s\n\n", "AmAcid", "Codon", "Number", "/1000", "Fraction"); $outstring .= $colhead; ### now write bulk of codon data ## my $ctable = Bio::Tools::CodonTable->new; for my $f (qw(G A T C)) { for my $s (qw(G A T C)) { for my $t (qw(G A T C)) { $cod = $f . $s . $t; my $aa =$Bio::SeqUtils::THREECODE {$ctable->translate($cod)}; my $codstr = sprintf("%-9s%-9s%15.2f%12.2f%12.2f\n", $aa, $cod, my $tt = $cut->codon_count($cod)|| 0.00, my $ll =$cut->{'_table'}{$aa}{$cod}{'per1000'}|| 0.00, my $ss = $cut->codon_rel_frequency($cod) || 0.00); $outstring .= $codstr; } $outstring .= "\n"; } } $outstring .= "\n\n"; ## now append GC data $outstring .= "Coding GC ". $cut->get_coding_gc('all'). "%\n"; $outstring .= "1st letter GC ". $cut->get_coding_gc(1). "%\n"; $outstring .= "2nd letter GC ". $cut->get_coding_gc(2). "%\n"; $outstring .= "3rd letter GC ". $cut->get_coding_gc(3). "%\n"; $outstring .= "Genetic code " . $cut->genetic_code() ."\n\n\n"; $self->_print ($outstring); $self->flush(); } sub _parse { my $self = shift; my $cdtableobj = Bio::CodonUsage::Table->new(); while (my $line = $self->_readline() ) { next if $line =~ /^$/ ; $line =~ s/End/Ter/; ## now parse in species name, cds number if ($line =~ /^(.+?)\s*\[(\w+)\].+?(\d+)/) { $cdtableobj->species($1); $cdtableobj->{'_gb_db'} = $2; $cdtableobj->cds_count($3); } ## now parse in bulk of codon usage table elsif ( $line =~ /^(\w\w\w)\s+(\w+)\s+(\d+\.\d+) \s+(\d+\.\d+)\s+(\d+\.\d+)/x){ if (defined ($1)) { $cdtableobj->{'_table'}{$1}{$2} = { 'abs_count'=>$3, 'per1000'=> $4, 'rel_freq'=> $5, }; } } ## now parse in gc data #### if($line =~ /^Cod.+?(\d\d\.\d\d)/ ){ $cdtableobj->{'_coding_gc'}{'all'} = $1; } elsif ($line =~ /^1st.+?(\d\d\.\d\d)/){ $cdtableobj->{'_coding_gc'}{'1'} = $1; } elsif($line =~ /^2nd.+?(\d\d\.\d\d)/){ $cdtableobj->{'_coding_gc'}{'2'} = $1; } elsif ($line =~ /^3rd.+?(\d\d\.\d\d)/){ $cdtableobj->{'_coding_gc'}{'3'} = $1; } elsif ($line =~ /^Gen.+?(\d+)/){ $cdtableobj->{'_genetic_code'} = $1; } } ## check has been parsed ok ## if (scalar keys %{$cdtableobj->{'_table'}} != 21) { $cdtableobj->warn("probable parsing error - should be 21 entries for 20aa + stop codon"); } return $cdtableobj; } 1; __END__ BioPerl-1.6.923/Bio/CodonUsage/Table.pm000555000765000024 4254212254227330 17613 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::CodonUsage::Table # # Please direct questions and support issues to # # Cared for by Richard Adams (richard.adams@ed.ac.uk) # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::CodonUsage::Table - for access to the Codon usage Database at http://www.kazusa.or.jp/codon. =head1 SYNOPSIS use Bio::CodonUsage::Table; use Bio::DB::CUTG; use Bio::CodonUsage::IO; use Bio::Tools::SeqStats; # Get a codon usage table from web database my $cdtable = Bio::DB::CUTG->new(-sp => 'Mus musculus', -gc => 1); # Or from local file my $io = Bio::CodonUsage::IO->new(-file => "file"); my $cdtable = $io->next_data(); # Or create your own from a Bio::PrimarySeq compliant object, # $codonstats is a ref to a hash of codon name /count key-value pairs my $codonstats = Bio::Tools::SeqStats->count_codons($Seq_objct); # '-data' must be specified, '-species' and 'genetic_code' are optional my $CUT = Bio::CodonUsage::Table->new(-data => $codonstats, -species => 'Hsapiens_kinase'); print "leu frequency is ", $cdtable->aa_frequency('LEU'), "\n"; print "freq of ATG is ", $cdtable->codon_rel_frequency('ttc'), "\n"; print "abs freq of ATG is ", $cdtable->codon_abs_frequency('ATG'), "\n"; print "number of ATG codons is ", $cdtable->codon_count('ATG'), "\n"; print "GC content at position 1 is ", $cdtable->get_coding_gc('1'), "\n"; print "total CDSs for Mus musculus is ", $cdtable->cds_count(), "\n"; =head1 DESCRIPTION This class provides methods for accessing codon usage table data. All of the methods at present are simple look-ups of the table or are derived from simple calculations from the table. Future methods could include measuring the codon usage of a sequence , for example, or provide methods for examining codon usage in alignments. =head1 SEE ALSO L, L, L, L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::CodonUsage::Table; use strict; use vars qw(%STRICTAA @AA); use Bio::SeqUtils; use Bio::Tools::CodonTable; use base qw(Bio::Root::Root); BEGIN{ @AA = qw(A C D E F G H I K L M N P Q R S T V W Y *); map {$STRICTAA{$_} = undef} @AA; } =head2 new Title : new Usage : my $cut = Bio::CodonUsage::Table->new(-data => $cut_hash_ref, -species => 'H.sapiens_kinase' -genetic_code =>1); Returns : a reference to a new Bio::CodonUsage::Table object Args : none or a reference to a hash of codon counts. This constructor is designed to be compatible with the output of Bio::Tools::SeqUtils::count_codons() Species and genetic code parameters can be entered here or via the species() and genetic_code() methods separately. =cut sub new { my ($class, @args) = @_; my $self= $class->SUPER::new(@args); if (@args) { $self->_rearrange([qw(DATA)], @args); shift @args; # get rid of key my $arg = shift @args; $self->throw("need a hash reference, not a [" . ref($arg). "] reference") if ref($arg) ne 'HASH'; ### flags to detect argument type, can be either to start with ## my $is_codon_hash = 1; my $is_Aa_hash = 1; for my $k (keys %$arg) { ## convert to UC $k =~ s/(\w+)/\U$1/; if (!exists($STRICTAA{$k}) ){ $is_Aa_hash = 0; } elsif ($k =~ /[^ATCGatcg]/) { $is_codon_hash = 0; } } if (!$is_codon_hash && !$is_Aa_hash) { $self->throw(" invalid key values in CUT hash - must be unique aa or nucleotide identifiers"); } elsif ($is_Aa_hash) { $self->_init_from_aa($arg); } elsif($is_codon_hash) { $self->_init_from_cod($arg); } while (@args) { my $key = shift @args; $key =~ s/\-(\w+)/\L$1/; $self->$key(shift @args); } } return $self; } =head2 all_aa_frequencies Title : all_aa_frequencies Usage : my $freq = $cdtable->all_aa_frequencies(); Returns : a reference to a hash where each key is an amino acid and each value is its frequency in all proteins in that species. Args : none =cut sub all_aa_frequencies { my $self = shift; my %aa_freqs =(); for my $aa (keys %STRICTAA) { my $freq = $self->aa_frequency($aa); $aa_freqs{$aa} = $freq; } return \%aa_freqs; } =head2 codon_abs_frequency Title : codon_abs_frequency Usage : my $freq = $cdtable->codon_abs_frequency('CTG'); Purpose : To return the frequency of that codon as a percentage of all codons in the organism. Returns : a percentage frequency Args : a non-ambiguous codon string =cut sub codon_abs_frequency { my ($self, $a) = @_; my $cod = uc $a; if ($self->_check_codon($cod)) { my $ctable = Bio::Tools::CodonTable->new; $ctable->id($self->genetic_code() ); my $aa =$Bio::SeqUtils::THREECODE {$ctable->translate($cod)}; return $self->{'_table'}{$aa}{$cod}{'per1000'}/10 ; } else {return 0;} } =head2 codon_rel_frequency Title : codon_rel_frequency Usage : my $freq = $cdtable->codon_rel_frequency('CTG'); Purpose : To return the frequency of that codon as a percentage of codons coding for the same amino acid. E.g., ATG and TGG would return 100 as those codons are unique. Returns : a percentage frequency Args : a non-ambiguous codon string =cut sub codon_rel_frequency { my ($self, $a) = @_; my $cod = uc $a; if ($self->_check_codon($cod)) { my $ctable = Bio::Tools::CodonTable->new; $ctable->id($self->genetic_code () ); my $aa =$Bio::SeqUtils::THREECODE {$ctable->translate($cod)}; return $self->{'_table'}{$aa}{$cod}{'rel_freq'}; } else { return 0; } } =head2 probable_codons Title : probable_codons Usage : my $prob_codons = $cd_table->probable_codons(10); Purpose : to obtain a list of codons for the amino acid above a given threshold % relative frequency Returns : A reference to a hash where keys are 1 letter amino acid codes and values are references to arrays of codons whose frequency is above the threshold. Arguments: a minimum threshold frequency =cut sub probable_codons { my ($self, $threshold) = @_; if (!$threshold || $threshold < 0 || $threshold > 100) { $self->throw(" I need a threshold percentage "); } my %return_hash; for my $a(keys %STRICTAA) { my @common_codons; my $aa =$Bio::SeqUtils::THREECODE{$a}; for my $codon (keys %{ $self->{'_table'}{$aa}}) { if ($self->{'_table'}{$aa}{$codon}{'rel_freq'} > $threshold/100){ push @common_codons, $codon; } } $return_hash{$a} = \@common_codons; } ## check to make sure that all codons are populated ## if (grep{scalar @{$return_hash{$_}} == 0} keys %return_hash) { $self->warn("Threshold is too high, some amino acids do not" . " have any codon above the threshold!"); } return \%return_hash; } =head2 most_common_codons Title : most_common_codons Usage : my $common_codons = $cd_table->most_common_codons(); Purpose : To obtain the most common codon for a given amino acid Returns : A reference to a hash where keys are 1 letter amino acid codes and the values are the single most common codons for those amino acids Arguments: None =cut sub most_common_codons { my $self = shift; my %return_hash; for my $a ( keys %STRICTAA ) { my $common_codon = ''; my $rel_freq = 0; my $aa = $Bio::SeqUtils::THREECODE{$a}; if ( ! defined $self->{'_table'}{$aa} ) { $self->warn("Amino acid $aa ($a) does not have any codons!"); next; } for my $codon ( keys %{ $self->{'_table'}{$aa}} ) { if ($self->{'_table'}{$aa}{$codon}{'rel_freq'} > $rel_freq ){ $common_codon = $codon; $rel_freq = $self->{'_table'}{$aa}{$codon}{'rel_freq'}; } } $return_hash{$a} = $common_codon; } return \%return_hash; } =head2 codon_count Title : codon_count Usage : my $count = $cdtable->codon_count('CTG'); Purpose : To obtain the absolute number of the codons in the organism. Returns : an integer Args : a non-ambiguous codon string =cut sub codon_count { my $self = shift; if (@_) { my $a = shift; my $cod = uc $a; if ($self->_check_codon($cod)) { my $ctable = Bio::Tools::CodonTable->new; $ctable->id($self->genetic_code()); my $aa =$Bio::SeqUtils::THREECODE {$ctable->translate($cod)}; return $self->{'_table'}{$aa}{$cod}{'abs_count'}; } else {return 0;} } else { $self->warn(" need to give a codon sequence as a parameter "); return 0; } } =head2 get_coding_gc Title : get_coding_gc Usage : my $count = $cdtable->get_coding_gc(1); Purpose : To return the percentage GC composition for the organism at codon positions 1,2 or 3, or an average for all coding sequence ('all'). Returns : a number (%-age GC content) or 0 if these fields are undefined Args : 1,2,3 or 'all'. =cut sub get_coding_gc { my $self = shift; if (! @_) { $self->warn(" no parameters supplied must be a codon position (1,2,3) or 'all'"); return 0; } else{ my $n = shift; ##return request if valid ## if ( exists($self->{'_coding_gc'}{$n} ) ) { return sprintf("%.2f", $self->{'_coding_gc'}{$n}); } ##else return 'all' value if exists elsif (exists($self->{'_coding_gc'}{'all'} )) { $self->warn("coding gc doesn't have value for [$n], returning gc content for all CDSs"); return sprintf("%.2f", $self->{'_coding_gc'}{'all'}); } ### else return 0, else { $self->warn("coding gc values aren't defined, returning 0"); return 0; } }#end of outer else } =head2 set_coding_gc Title : set_coding_gc Usage : my $count = $cdtable->set_coding_gc(-1=>55.78); Purpose : To set the percentage GC composition for the organism at codon positions 1,2 or 3, or an average for all coding sequence ('all'). Returns : void Args : a hash where the key must be 1,2,3 or 'all' and the value the %age GC at that codon position.. =cut sub set_coding_gc { my ($self, $key, $value) = @_; my @allowed = qw(1 2 3 all); $key =~ s/\-//; if (!grep {$key eq $_} @allowed ) { $self->warn ("invalid key! - must be one of [ ". (join " ", @allowed) . "]"); return; } $self->{'_coding_gc'}{$key} = $value; } =head2 species Title : species Usage : my $sp = $cut->species(); Purpose : Get/setter for species name of codon table Returns : Void or species name string Args : None or species name string =cut sub species { my $self = shift; if (@_ ){ $self->{'_species'} = shift; } return $self->{'_species'} || "unknown"; } =head2 genetic_code Title : genetic_code Usage : my $sp = $cut->genetic_code(); Purpose : Get/setter for genetic_code name of codon table Returns : Void or genetic_code id, 1 by default Args : None or genetic_code id, 1 by default if invalid argument. =cut sub genetic_code { my $self = shift; if (@_ ){ my $val = shift; if ($val < 0 || $val >16 || $val =~ /[^\d]/ || $val ==7 || $val ==8) { $self->warn ("invalid genetic code - must be 1-16 but not 7 or 8,setting to default [1]"); $self->{'_genetic_code'} = 1; } else { $self->{'_genetic_code'} = shift; } } return $self->{'_genetic_code'} || 1; } =head2 cds_count Title : cds_count Usage : my $count = $cdtable->cds_count(); Purpose : To retrieve the total number of CDSs used to generate the Codon Table for that organism. Returns : an integer Args : none (if retrieving the value) or an integer( if setting ). =cut sub cds_count { my $self= shift; if (@_) { my $val = shift; if ($val < 0) { $self->warn("can't have negative count initializing to 1"); $self->{'_cds_count'} = 0.00; } else{ $self->{'_cds_count'} = $val; } } $self->warn("cds_count value is undefined, returning 0") if !exists($self->{'_cds_count'}); return $self->{'_cds_count'} || 0.00; } =head2 aa_frequency Title : aa_frequency Usage : my $freq = $cdtable->aa_frequency('Leu'); Purpose : To retrieve the frequency of an amino acid in the organism Returns : a percentage Args : a 1 letter or 3 letter string representing the amino acid =cut sub aa_frequency { my ($self, $a) = @_; ## process args ## ## deal with cases ## my $aa = lc $a; $aa =~ s/^(\w)/\U$1/; if (!exists($STRICTAA{$aa}) && !exists($Bio::SeqUtils::ONECODE{$aa}) ) { $self->warn("Invalid amino acid! must be a unique 1 letter or 3 letter identifier"); return; } #translate to 3 letter code for Ctable # my $aa3 = $Bio::SeqUtils::THREECODE{$aa} || $aa; ## return % of all amino acids in organism ## my $freq = 0; map {$freq += $self->{'_table'}{$aa3}{$_}{'per1000'} } keys %{$self->{'_table'}{$aa3}}; return sprintf("%.2f", $freq/10); } =head2 common_codon Title : common_codon Usage : my $freq = $cdtable->common_codon('Leu'); Purpose : To retrieve the frequency of the most common codon of that aa Returns : a percentage Args : a 1 letter or 3 letter string representing the amino acid =cut sub common_codon{ my ($self, $a) = @_; my $aa = lc $a; $aa =~ s/^(\w)/\U$1/; if ($self->_check_aa($aa)) { my $aa3 = $Bio::SeqUtils::THREECODE{$aa} ; $aa3 ||= $aa; my $max = 0; for my $cod (keys %{$self->{'_table'}{$aa3}}) { $max = ($self->{'_table'}{$aa3}{$cod}{'rel_freq'} > $max) ? $self->{'_table'}{$aa3}{$cod}{'rel_freq'}:$max; } return $max; }else {return 0;} } =head2 rare_codon Title : rare_codon Usage : my $freq = $cdtable->rare_codon('Leu'); Purpose : To retrieve the frequency of the least common codon of that aa Returns : a percentage Args : a 1 letter or 3 letter string representing the amino acid =cut sub rare_codon { my ($self, $a) = @_; my $aa = lc $a; $aa =~ s/^(\w)/\U$1/; if ($self->_check_aa($aa)) { my $aa3 = $Bio::SeqUtils::THREECODE{$aa}; $aa3 ||= $aa; my $min = 1; for my $cod (keys %{$self->{'_table'}{$aa3}}) { $min = ($self->{'_table'}{$aa3}{$cod}{'rel_freq'} < $min) ? $self->{'_table'}{$aa3}{$cod}{'rel_freq'}:$min; } return $min; }else {return 0;} } ## internal sub that checks a codon is correct format sub _check_aa { my ($self, $aa ) = @_; if (!exists($STRICTAA{$aa}) && !exists($Bio::SeqUtils::ONECODE{$aa}) ) { $self->warn("Invalid amino acid! must be a unique 1 letter or 3 letter identifier"); return 0; }else {return 1;} } sub _check_codon { my ($self, $cod) = @_; if ($cod =~ /[^ATCG]/ || $cod !~ /\w\w\w/) { $self->warn(" impossible codon - must be 3 letters and just containing ATCG"); return 0; } else {return 1;} } sub _init_from_cod { ## make hash based on aa and then send to _init_from_aa my ($self, $ref) = @_; my $ct = Bio::Tools::CodonTable->new(); my %aa_hash; for my $codon(keys %$ref ) { my $aa = $ct->translate($codon); $aa_hash{$aa}{$codon} = $ref->{$codon}; } $self->_init_from_aa(\%aa_hash); } sub _init_from_aa { my ($self, $ref) = @_; ## abs counts and count codons my $total_codons = 0; my %threeletter; map{$threeletter{$Bio::SeqUtils::THREECODE{$_}} = $ref->{$_} } keys %$ref; $ref = \%threeletter; for my $aa (keys %$ref) { for my $cod(keys %{$ref->{$aa}} ) { $self->{'_table'}{$aa}{$cod}{'abs_count'} = $ref->{$aa}{$cod}; $total_codons += $ref->{$aa}{$cod}; } } ## now calculate abs codon frequencies for my $aa (keys %$ref) { for my $cod(keys %{$ref->{$aa}} ) { $self->{'_table'}{$aa}{$cod}{'per1000'} = sprintf("%.2f",$ref->{$aa}{$cod} /$total_codons * 1000) ; } } ## now calculate rel codon_frequencies for my $aa (keys %$ref) { my $aa_freq = 0; map{$aa_freq += $ref->{$aa}{$_} } keys %{$ref->{$aa}}; for my $cod(keys %{$ref->{$aa}} ) { $self->{'_table'}{$aa}{$cod}{'rel_freq'}= sprintf("%.2f",$ref->{$aa}{$cod}/ $aa_freq ); } } ## now calculate gc fields my %GC; for my $aa (keys %$ref) { for my $cod(keys %{$ref->{$aa}} ) { for my $index (qw(1 2 3) ) { if (substr ($cod, $index -1, 1) =~ /g|c/oi) { $GC{$index} += $ref->{$aa}{$cod}; } } } } my $tot = 0; map{$tot += $GC{$_}} qw(1 2 3); $self->set_coding_gc('all', $tot/(3 *$total_codons) * 100); map{$self->set_coding_gc($_,$GC{$_}/$total_codons * 100)} qw(1 2 3); ## return $self; } sub _gb_db { my $self = shift; return $self->{'_gd_db'} || "unknown"; } 1; BioPerl-1.6.923/Bio/Coordinate000755000765000024 012254227337 16106 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Coordinate/Chain.pm000444000765000024 1165112254227332 17642 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::Chain # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::Chain - Mapping locations through a chain of coordinate mappers =head1 SYNOPSIS # create Bio::Coordinate::Pairs, or any MapperIs, somehow $pair1; $pair2; # add them into a Chain $collection = Bio::Coordinate::Chain->new; $collection->add_mapper($pair1); $collection->add_mapper($pair2); # create a position and map it $pos = Bio::Location::Simple->new (-start => 5, -end => 9 ); $match = $collection->map($pos); if ($match) { sprintf "Matches at %d-%d\n", $match->start, $match->end, } else { print "No match\n"; } =head1 DESCRIPTION This class assumes that you have built several mappers and want to link them together so that output from the previous mapper is the next mappers input. This way you can build arbitrarily complex mappers from simpler components. Note that Chain does not do any sanity checking on its mappers. You are solely responsible that input and output coordinate systems, direction of mapping and parameters internal to mappers make sense when chained together. To put it bluntly, the present class is just a glorified foreach loop over an array of mappers calling the map method. It would be neat to an internal function that would generate a new single step mapper from those included in the chain. It should speed things up considerably. Any volunteers? =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Ewan Birney, birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::Chain; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use Bio::Coordinate::Result; use base qw(Bio::Coordinate::Collection Bio::Coordinate::MapperI); =head2 map Title : map Usage : $newpos = $obj->map($pos); Function: Map the location through all the mappers in the chain. Example : Returns : new Location in the output coordiante system Args : a Bio::Location::Simple object =cut sub map { my ($self,$value) = @_; $self->throw("Need to pass me a value.") unless defined $value; $self->throw("I need a Bio::Location, not [$value]") unless $value->isa('Bio::LocationI'); $self->throw("No coordinate mappers!") unless $self->each_mapper; my $res = Bio::Coordinate::Result->new(); foreach my $mapper ($self->each_mapper) { my $res = $mapper->map($value); return unless $res->each_match; $value = $res->match; } return $value; } =head2 Inherited methods =cut =head2 add_mapper Title : add_mapper Usage : $obj->add_mapper($mapper) Function: Pushes one Bio::Coodinate::MapperI into the list of mappers. Sets _is_sorted() to false. Example : Returns : 1 when succeeds, 0 for failure. Args : mapper object =cut =head2 mappers Title : mappers Usage : $obj->mappers(); Function: Returns or sets a list of mappers. Example : Returns : array of mappers Args : array of mappers =cut =head2 each_mapper Title : each_mapper Usage : $obj->each_mapper(); Function: Returns a list of mappers. Example : Returns : array of mappers Args : none =cut =head2 swap Title : swap Usage : $obj->swap; Function: Swap the direction of mapping;input <-> output Example : Returns : 1 Args : =cut =head2 test Title : test Usage : $obj->test; Function: test that both components of all pairs are of the same length. Ran automatically. Example : Returns : boolean Args : =cut sub sort{ my ($self) = @_; $self->warn("You do not really want to sort your chain, do you!\nDoing nothing."); } 1; BioPerl-1.6.923/Bio/Coordinate/Collection.pm000444000765000024 2355412254227315 20721 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::Collection # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::Collection - Noncontinuous match between two coordinate sets =head1 SYNOPSIS # create Bio::Coordinate::Pairs or other Bio::Coordinate::MapperIs somehow $pair1; $pair2; # add them into a Collection $collection = Bio::Coordinate::Collection->new; $collection->add_mapper($pair1); $collection->add_mapper($pair2); # create a position and map it $pos = Bio::Location::Simple->new (-start => 5, -end => 9 ); $res = $collection->map($pos); $res->match->start == 1; $res->match->end == 5; # if mapping is many to one (*>1) or many-to-many (*>*) # you have to give seq_id not get unrelevant entries $pos = Bio::Location::Simple->new (-start => 5, -end => 9 -seq_id=>'clone1'); =head1 DESCRIPTION Generic, context neutral mapper to provide coordinate transforms between two B coordinate systems. It brings into Bioperl the functionality from Ewan Birney's Bio::EnsEMBL::Mapper ported into current bioperl. This class is aimed for representing mapping between whole chromosomes and contigs, or between contigs and clones, or between sequencing reads and assembly. The submaps are automatically sorted, so they can be added in any order. To map coordinates to the other direction, you have to swap() the collection. Keeping track of the direction and ID restrictions are left to the calling code. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Ewan Birney, birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::Collection; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Coordinate::Result; use Bio::Coordinate::Result::Gap; use base qw(Bio::Root::Root Bio::Coordinate::MapperI); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_mappers'} = []; my($in, $out, $strict, $mappers, $return_match) = $self->_rearrange([qw(IN OUT STRICT MAPPERS RETURN_MATCH )], @args); $in && $self->in($in); $out && $self->out($out); $mappers && $self->mappers($mappers); $return_match && $self->return_match('return_match'); return $self; # success - we hope! } =head2 add_mapper Title : add_mapper Usage : $obj->add_mapper($mapper) Function: Pushes one Bio::Coordinate::MapperI into the list of mappers. Sets _is_sorted() to false. Example : Returns : 1 when succeeds, 0 for failure. Args : mapper object =cut sub add_mapper { my ($self,$value) = @_; $self->throw("Is not a Bio::Coordinate::MapperI but a [$self]") unless defined $value && $value->isa('Bio::Coordinate::MapperI'); # test pair range lengths $self->warn("Coordinates in pair [". $value . ":" . $value->in->seq_id . "/". $value->out->seq_id . "] are not right.") unless $value->test; $self->_is_sorted(0); push(@{$self->{'_mappers'}},$value); } =head2 mappers Title : mappers Usage : $obj->mappers(); Function: Returns or sets a list of mappers. Example : Returns : array of mappers Args : array of mappers =cut sub mappers{ my ($self,@args) = @_; if (@args) { $self->throw("Is not a Bio::Coordinate::MapperI but a [$self]") unless defined $args[0] && $args[0]->isa('Bio::Coordinate::MapperI'); push(@{$self->{'_mappers'}}, @args); } return @{$self->{'_mappers'}}; } =head2 each_mapper Title : each_mapper Usage : $obj->each_mapper(); Function: Returns a list of mappers. Example : Returns : list of mappers Args : none =cut sub each_mapper{ my ($self) = @_; return @{$self->{'_mappers'}}; } =head2 mapper_count Title : mapper_count Usage : my $count = $collection->mapper_count; Function: Get the count of the number of mappers stored in this collection Example : Returns : integer Args : none =cut sub mapper_count{ my $self = shift; return scalar @{$self->{'_mappers'} || []}; } =head2 swap Title : swap Usage : $obj->swap; Function: Swap the direction of mapping;input <-> output Example : Returns : 1 Args : =cut sub swap { my ($self) = @_; use Data::Dumper; $self->sort unless $self->_is_sorted; map {$_->swap;} @{$self->{'_mappers'}}; ($self->{'_in_ids'}, $self->{'_out_ids'}) = ($self->{'_out_ids'}, $self->{'_in_ids'}); 1; } =head2 test Title : test Usage : $obj->test; Function: test that both components of all pairs are of the same length. Ran automatically. Example : Returns : boolean Args : =cut sub test { my ($self) = @_; my $res = 1; foreach my $mapper ($self->each_mapper) { unless( $mapper->test ) { $self->warn("Coordinates in pair [". $mapper . ":" . $mapper->in->seq_id . "/". $mapper->out->seq_id . "] are not right."); $res = 0; } } $res; } =head2 map Title : map Usage : $newpos = $obj->map($pos); Function: Map the location from the input coordinate system to a new value in the output coordinate system. Example : Returns : new value in the output coordinate system Args : integer =cut sub map { my ($self,$value) = @_; $self->throw("Need to pass me a value.") unless defined $value; $self->throw("I need a Bio::Location, not [$value]") unless $value->isa('Bio::LocationI'); $self->throw("No coordinate mappers!") unless $self->each_mapper; $self->sort unless $self->_is_sorted; if ($value->isa("Bio::Location::SplitLocationI")) { my $result = Bio::Coordinate::Result->new(); foreach my $loc ( $value->sub_Location(1) ) { my $res = $self->_map($loc); map { $result->add_sub_Location($_) } $res->each_Location; } return $result; } else { return $self->_map($value); } } =head2 _map Title : _map Usage : $newpos = $obj->_map($simpleloc); Function: Internal method that does the actual mapping. Called multiple times by map() if the location to be mapped is a split location Example : Returns : new location in the output coordinate system or undef Args : Bio::Location::Simple =cut sub _map { my ($self,$value) = @_; my $result = Bio::Coordinate::Result->new(-is_remote=>1); IDMATCH: { # bail out now we if are forcing the use of an ID # and it is not in this collection last IDMATCH if defined $value->seq_id && ! $self->{'_in_ids'}->{$value->seq_id}; foreach my $pair ($self->each_mapper) { # if we are limiting input to a certain ID next if defined $value->seq_id && $value->seq_id ne $pair->in->seq_id; # if we haven't even reached the start, move on next if $pair->in->end < $value->start; # if we have over run, break last if $pair->in->start > $value->end; my $subres = $pair->map($value); $result->add_result($subres); } } $result->seq_id($result->match->seq_id) if $result->match; unless ($result->each_Location) { #build one gap; my $gap = Bio::Location::Simple->new(-start => $value->start, -end => $value->end, -strand => $value->strand, -location_type => $value->location_type ); $gap->seq_id($value->seq_id) if defined $value->seq_id; bless $gap, 'Bio::Coordinate::Result::Gap'; $result->seq_id($value->seq_id) if defined $value->seq_id; $result->add_sub_Location($gap); } return $result; } =head2 sort Title : sort Usage : $obj->sort; Function: Sort function so that all mappings are sorted by input coordinate start Example : Returns : 1 Args : =cut sub sort{ my ($self) = @_; @{$self->{'_mappers'}} = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->in->start] } @{$self->{'_mappers'}}; #create hashes for sequence ids $self->{'_in_ids'} = (); $self->{'_out_ids'} = (); foreach ($self->each_mapper) { $self->{'_in_ids'}->{$_->in->seq_id} = 1; $self->{'_out_ids'}->{$_->out->seq_id} = 1; } $self->_is_sorted(1); } =head2 _is_sorted Title : _is_sorted Usage : $newpos = $obj->_is_sorted; Function: toggle for whether the (internal) coodinate mapper data are sorted Example : Returns : boolean Args : boolean =cut sub _is_sorted{ my ($self,$value) = @_; $self->{'_is_sorted'} = 1 if defined $value && $value; return $self->{'_is_sorted'}; } 1; BioPerl-1.6.923/Bio/Coordinate/ExtrapolatingPair.pm000444000765000024 1425212254227335 22260 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::ExtrapolatingPair # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::ExtrapolatingPair - Continuous match between two coordinate sets =head1 SYNOPSIS use Bio::Location::Simple; use Bio::Coordinate::ExtrapolatingPair; $match1 = Bio::Location::Simple->new (-seq_id => 'propeptide', -start => 21, -end => 40, -strand=>1 ); $match2 = Bio::Location::Simple->new (-seq_id => 'peptide', -start => 1, -end => 20, -strand=>1 ); $pair = Bio::Coordinate::ExtrapolatingPair-> new(-in => $match1, -out => $match2, -strict => 1 ); $pos = Bio::Location::Simple->new (-start => 40, -end => 60, -strand=> 1 ); $res = $pair->map($pos); $res->start eq 20; $res->end eq 20; =head1 DESCRIPTION This class represents a one continuous match between two coordinate systems represented by Bio::Location::Simple objects. The relationship is directed and reversible. It implements methods to ensure internal consistency, and map continuous and split locations from one coordinate system to another. 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 the chromosomal coordinate system and extends indefinetely in both directions. If you want to define the matching regions exactly, you can do that and set strict() to true. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::ExtrapolatingPair; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use Bio::LocationI; use base qw(Bio::Coordinate::Pair); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($strict) = $self->_rearrange([qw(STRICT )], @args); $strict && $self->strict($strict); return $self; } =head2 strict Title : strict Usage : $obj->strict(1); Function: Set and read the strictness of the coordinate system. Example : Returns : value of input system Args : boolean =cut sub strict { my ($self,$value) = @_; if( defined $value) { $self->{'_strict'} = 1 if $value; } return $self->{'_strict'}; } =head2 map Title : map Usage : $newpos = $obj->map($loc); Function: Map the location from the input coordinate system to a new value in the output coordinate system. In extrapolating coodinate system there is no location zero. Locations are... Example : Returns : new location in the output coordinate system or undef Args : Bio::Location::Simple =cut sub map { my ($self,$value) = @_; $self->throw("Need to pass me a value.") unless defined $value; $self->throw("I need a Bio::Location, not [$value]") unless $value->isa('Bio::LocationI'); $self->throw("Input coordinate system not set") unless $self->in; $self->throw("Output coordinate system not set") unless $self->out; my $match; if ($value->isa("Bio::Location::SplitLocationI")) { my $split = Bio::Coordinate::Result->new(-seq_id=>$self->out->seq_id); foreach my $loc ( sort { $a->start <=> $b->start } $value->sub_Location ) { $match = $self->_map($loc); $split->add_sub_Location($match) if $match; } $split->each_Location ? (return $split) : return ; } else { return $self->_map($value); } } =head2 _map Title : _map Usage : $newpos = $obj->_map($simpleloc); Function: Internal method that does the actual mapping. Called multiple times by map() if the location to be mapped is a split location Example : Returns : new location in the output coordinate system or undef Args : Bio::Location::Simple =cut sub _map { my ($self,$value) = @_; my ($offset, $start, $end); if ($self->strand == -1) { $offset = $self->in->end + $self->out->start; $start = $offset - $value->end; $end = $offset - $value->start ; } else { # undef, 0 or 1 $offset = $self->in->start - $self->out->start; $start = $value->start - $offset; $end = $value->end - $offset; } # strict prevents matches outside stated range if ($self->strict) { return if $start < 0 and $end < 0; return if $start > $self->out->end; $start = 1 if $start < 0; $end = $self->out->end if $end > $self->out->end; } my $match = Bio::Location::Simple-> new(-start => $start, -end => $end, -strand => $self->strand, -seq_id => $self->out->seq_id, -location_type => $value->location_type ); $match->strand($match->strand * $value->strand) if $value->strand; bless $match, 'Bio::Coordinate::Result::Match'; return $match; } 1; BioPerl-1.6.923/Bio/Coordinate/GeneMapper.pm000444000765000024 11572112254227337 20673 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::GeneMapper # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::GeneMapper - transformations between gene related coordinate systems =head1 SYNOPSIS use Bio::Coordinate::GeneMapper; # get a Bio::RangeI representing the start, end and strand of the CDS # in chromosomal (or entry) coordinates my $cds; # get a Bio::Location::Split or an array of Bio::LocationI objects # holding the start, end and strand of all the exons in chromosomal # (or entry) coordinates my $exons; # create a gene mapper and set it to map from chromosomal to cds coordinates my $gene = Bio::Coordinate::GeneMapper->new(-in =>'chr', -out =>'cds', -cds =>$cds, -exons=>$exons ); # get a a Bio::Location or sequence feature in input (chr) coordinates my $loc; # map the location into output coordinates and get a new location object $newloc = $gene->map($loc); =head1 DESCRIPTION Bio::Coordinate::GeneMapper is a module for simplifying the mappings of coodinate locations between various gene related locations in human genetics. It also adds a special human genetics twist to coordinate systems by making it possible to disable the use of zero (0). Locations before position one start from -1. See method L. It understands by name the following coordinate systems and mapping between them: peptide (peptide length) ^ | -peptide_offset | frame propeptide (propeptide length) ^ ^ \ | translate \ | \ | cds (transcript start and end) ^ negative_intron | \ ^ | \ transcribe \ | \ intron exon \ ^ ^ ^ / splice \ \ / | / \ \ / | / \ inex | / \ ^ | / \ \ |/ ----- gene (gene_length) ^ | - gene_offset | chr (or entry) This structure is kept in the global variable $DAG which is a representation of a Directed Acyclic Graph. The path calculations traversing this graph are done in a helper class. See L. Of these, two operations are special cases, translate and splice. Translating and reverse translating are implemented as internal methods that do the simple 1E-E3 conversion. Splicing needs additional information that is provided by method L which takes in an array of Bio::LocationI objects. Most of the coordinate system names should be selfexplanatory to anyone familiar with genes. Negative intron coordinate system is starts counting backwards from -1 as the last nucleotide in the intron. This used when only exon and a few flanking intron nucleotides are known. This class models coordinates within one transcript of a gene, so to tackle multiple transcripts you need several instances of the class. It is therefore valid to argue that the name of the class should be TranscriptMapper. GeneMapper is a catchier name, so it stuck. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::GeneMapper; use vars qw(%COORDINATE_SYSTEMS %COORDINATE_INTS $TRANSLATION $DAG $NOZERO_VALUES $NOZERO_KEYS); use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Coordinate::Result; use Bio::Location::Simple; use Bio::Coordinate::Graph; use Bio::Coordinate::Collection; use Bio::Coordinate::Pair; use Bio::Coordinate::ExtrapolatingPair; use base qw(Bio::Root::Root Bio::Coordinate::MapperI); # first set internal values for all translation tables %COORDINATE_SYSTEMS = ( peptide => 10, propeptide => 9, frame => 8, cds => 7, negative_intron => 6, intron => 5, exon => 4, inex => 3, gene => 2, chr => 1 ); %COORDINATE_INTS = ( 10 => 'peptide', 9 => 'propeptide', 8 => 'frame', 7 => 'cds', 6 => 'negative_intron', 5 => 'intron', 4 => 'exon', 3 => 'inex', 2 => 'gene', 1 => 'chr' ); $TRANSLATION = $COORDINATE_SYSTEMS{'cds'}. "-". $COORDINATE_SYSTEMS{'propeptide'}; $DAG = { 10 => [], 9 => [10], 8 => [], 7 => [8, 9], 6 => [], 5 => [6], 4 => [7], 3 => [4, 5], 2 => [3, 4, 5, 7], 1 => [2] }; $NOZERO_VALUES = {0 => 0, 'in' => 1, 'out' => 2, 'in&out' => 3 }; $NOZERO_KEYS = { 0 => 0, 1 => 'in', 2 => 'out', 3 => 'in&out' }; sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); # prime the graph my $graph = Bio::Coordinate::Graph->new(); $graph->hash_of_arrays($DAG); $self->graph($graph); my($in, $out, $peptide_offset, $exons, $cds, $nozero, $strict) = $self->_rearrange([qw(IN OUT PEPTIDE_OFFSET EXONS CDS NOZERO STRICT )], @args); # direction of mapping when going chr to protein $self->{_direction} = 1; $in && $self->in($in); $out && $self->out($out); $cds && $self->cds($cds); $exons && ref($exons) =~ /ARRAY/i && $self->exons(@$exons); $peptide_offset && $self->peptide_offset($peptide_offset); $nozero && $self->nozero($nozero); $strict && $self->strict($strict); return $self; # success - we hope! } =head2 in Title : in Usage : $obj->in('peptide'); Function: Set and read the input coordinate system. Example : Returns : value of input system Args : new value (optional) =cut sub in { my ($self,$value) = @_; if( defined $value) { $self->throw("Not a valid input coordinate system name [$value]\n". "Valid values are ". join(", ", keys %COORDINATE_SYSTEMS )) unless defined $COORDINATE_SYSTEMS{$value}; $self->{'_in'} = $COORDINATE_SYSTEMS{$value}; } return $COORDINATE_INTS{ $self->{'_in'} }; } =head2 out Title : out Usage : $obj->out('peptide'); Function: Set and read the output coordinate system. Example : Returns : value of output system Args : new value (optional) =cut sub out { my ($self,$value) = @_; if( defined $value) { $self->throw("Not a valid input coordinate system name [$value]\n". "Valid values are ". join(", ", keys %COORDINATE_SYSTEMS )) unless defined $COORDINATE_SYSTEMS{$value}; $self->{'_out'} = $COORDINATE_SYSTEMS{$value}; } return $COORDINATE_INTS{ $self->{'_out'} }; } =head2 strict Title : strict Usage : $obj->strict('peptide'); Function: Set and read whether strict boundaried of coordinate systems are enforced. When strict is on, the end of the coordinate range must be defined. Example : Returns : boolean Args : boolean (optional) =cut sub strict { my ($self,$value) = @_; if( defined $value) { $value ? ( $self->{'_strict'} = 1 ) : ( $self->{'_strict'} = 0 ); ## update in each mapper !! } return $self->{'_strict'} || 0 ; } =head2 nozero Title : nozero Usage : $obj->nozero(1); Function: Flag to disable the use of zero in the input, output or both coordinate systems. Use of coordinate systems without zero is a peculiarity common in human genetics community. Example : Returns : 0 (default), or 'in', 'out', 'in&out' Args : 0 (default), or 'in', 'out', 'in&out' =cut sub nozero { my ($self,$value) = @_; if (defined $value) { $self->throw("Not a valid value for nozero [$value]\n". "Valid values are ". join(", ", keys %{$NOZERO_VALUES} )) unless defined $NOZERO_VALUES->{$value}; $self->{'_nozero'} = $NOZERO_VALUES->{$value}; } my $res = $self->{'_nozero'} || 0; return $NOZERO_KEYS->{$res}; } =head2 graph Title : graph Usage : $obj->graph($new_graph); Function: Set and read the graph object representing relationships between coordinate systems Example : Returns : Bio::Coordinate::Graph object Args : new Bio::Coordinate::Graph object (optional) =cut sub graph { my ($self,$value) = @_; if( defined $value) { $self->throw("Not a valid graph [$value]\n") unless $value->isa('Bio::Coordinate::Graph'); $self->{'_graph'} = $value; } return $self->{'_graph'}; } =head2 peptide Title : peptide Usage : $obj->peptide_offset($peptide_coord); Function: Read and write the offset of peptide from the start of propeptide and peptide length Returns : a Bio::Location::Simple object Args : a Bio::LocationI object =cut sub peptide { my ($self, $value) = @_; if( defined $value) { $self->throw("I need a Bio::LocationI, not [". $value. "]") unless $value->isa('Bio::LocationI'); $self->throw("Peptide start not defined") unless defined $value->start; $self->{'_peptide_offset'} = $value->start - 1; $self->throw("Peptide end not defined") unless defined $value->end; $self->{'_peptide_length'} = $value->end - $self->{'_peptide_offset'}; my $a = $self->_create_pair ('propeptide', 'peptide', $self->strict, $self->{'_peptide_offset'}, $self->{'_peptide_length'} ); my $mapper = $COORDINATE_SYSTEMS{'propeptide'}. "-". $COORDINATE_SYSTEMS{'peptide'}; $self->{'_mappers'}->{$mapper} = $a; } return Bio::Location::Simple->new (-seq_id => 'propeptide', -start => $self->{'_peptide_offset'} + 1 , -end => $self->{'_peptide_length'} + $self->{'_peptide_offset'}, -strand => 1, -verbose => $self->verbose, ); } =head2 peptide_offset Title : peptide_offset Usage : $obj->peptide_offset(20); Function: Set and read the offset of peptide from the start of propeptide Returns : set value or 0 Args : new value (optional) =cut sub peptide_offset { my ($self,$offset, $len) = @_; if( defined $offset) { $self->throw("I need an integer, not [$offset]") unless $offset =~ /^[+-]?\d+$/; $self->{'_peptide_offset'} = $offset; if (defined $len) { $self->throw("I need an integer, not [$len]") unless $len =~ /^[+-]?\d+$/; $self->{'_peptide_length'} = $len; } my $a = $self->_create_pair ('propeptide', 'peptide', $self->strict, $offset, $self->{'_peptide_length'} ); my $mapper = $COORDINATE_SYSTEMS{'propeptide'}. "-". $COORDINATE_SYSTEMS{'peptide'}; $self->{'_mappers'}->{$mapper} = $a; } return $self->{'_peptide_offset'} || 0; } =head2 peptide_length Title : peptide_length Usage : $obj->peptide_length(20); Function: Set and read the offset of peptide from the start of propeptide Returns : set value or 0 Args : new value (optional) =cut sub peptide_length { my ($self, $len) = @_; if( defined $len) { $self->throw("I need an integer, not [$len]") if defined $len && $len !~ /^[+-]?\d+$/; $self->{'_peptide_length'} = $len; } return $self->{'_peptide_length'}; } =head2 exons Title : exons Usage : $obj->exons(@exons); Function: Set and read the offset of CDS from the start of transcript You do not have to sort the exons before calling this method as they will be sorted automatically. If you have not defined the CDS, is will be set to span all exons here. Returns : array of Bio::LocationI exons in genome coordinates or 0 Args : array of Bio::LocationI exons in genome (or entry) coordinates =cut sub exons { my ($self,@value) = @_; my $cds_mapper = $COORDINATE_SYSTEMS{'gene'}. "-". $COORDINATE_SYSTEMS{'cds'}; my $inex_mapper = $COORDINATE_SYSTEMS{'gene'}. "-". $COORDINATE_SYSTEMS{'inex'}; my $exon_mapper = $COORDINATE_SYSTEMS{'gene'}. "-". $COORDINATE_SYSTEMS{'exon'}; my $intron_mapper = $COORDINATE_SYSTEMS{'gene'}. "-". $COORDINATE_SYSTEMS{'intron'}; my $negative_intron_mapper = $COORDINATE_SYSTEMS{'intron'}. "-". $COORDINATE_SYSTEMS{'negative_intron'}; my $exon_cds_mapper = $COORDINATE_SYSTEMS{'exon'}. "-". $COORDINATE_SYSTEMS{'cds'}; if(@value) { if (ref($value[0]) && $value[0]->isa('Bio::SeqFeatureI') and $value[0]->location->isa('Bio::Location::SplitLocationI')) { @value = $value[0]->location->each_Location; } else { $self->throw("I need an array , not [@value]") unless ref \@value eq 'ARRAY'; $self->throw("I need a reference to an array of Bio::LocationIs, not to [". $value[0]. "]") unless ref $value[0] and $value[0]->isa('Bio::LocationI'); } # # sort the input array # # and if the used has not defined CDS assume it is the complete exonic range if (defined $value[0]->strand && $value[0]->strand == - 1) { #reverse strand @value = map { $_->[0] } sort { $b->[1] <=> $a->[1] } map { [ $_, $_->start] } @value; unless ($self->cds) { $self->cds(Bio::Location::Simple->new (-start => $value[-1]->start, -end => $value[0]->end, -strand => $value[0]->strand, -seq_id => $value[0]->seq_id, -verbose => $self->verbose, ) ); } } else { # undef or forward strand @value = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->start] } @value; unless ($self->cds) { $self->cds(Bio::Location::Simple->new (-start => $value[0]->start, -end => $value[-1]->end, -strand => $value[0]->strand, -seq_id => $value[0]->seq_id, -verbose => $self->verbose, ) ); } } $self->{'_chr_exons'} = \@value; # transform exons from chromosome to gene coordinates # but only if gene coordinate system has been set my @exons ; #my $gene_mapper = $self->$COORDINATE_SYSTEMS{'chr'}. "-". $COORDINATE_SYSTEMS{'gene'}; my $gene_mapper = "1-2"; if (defined $self->{'_mappers'}->{$gene_mapper} ) { my $tmp_in = $self->{'_in'}; my $tmp_out = $self->{'_out'}; my $tmp_verb = $self->verbose; $self->verbose(0); $self->in('chr'); $self->out('gene'); @exons = map {$self->map($_) } @value; $self->{'_in'} = ($tmp_in); $self->{'_out'} = ($tmp_out); $self->verbose($tmp_verb); } else { @exons = @value; } my $cds_map = Bio::Coordinate::Collection->new; my $inex_map = Bio::Coordinate::Collection->new; my $exon_map = Bio::Coordinate::Collection->new; my $exon_cds_map = Bio::Coordinate::Collection->new; my $intron_map = Bio::Coordinate::Collection->new; my $negative_intron_map = Bio::Coordinate::Collection->new; my $tr_end = 0; my $coffset; my $exon_counter; my $prev_exon_end; for my $exon ( @exons ) { $exon_counter++; # # gene -> cds # my $match1 = Bio::Location::Simple->new (-seq_id =>'gene' , -start => $exon->start, -end => $exon->end, -strand => 1, -verbose=> $self->verbose); my $match2 = Bio::Location::Simple->new (-seq_id => 'cds', -start => $tr_end + 1, -end => $tr_end + $exon->end - $exon->start +1, -strand=>$exon->strand, -verbose=>$self->verbose); $cds_map->add_mapper(Bio::Coordinate::Pair->new (-in => $match1, -out => $match2, ) ); if ($exon->start <= 1 and $exon->end >= 1) { $coffset = $tr_end - $exon->start + 1; } $tr_end = $tr_end + $exon->end - $exon->start + 1; # # gene -> intron # if (defined $prev_exon_end) { my $match3 = Bio::Location::Simple->new (-seq_id => 'gene', -start => $prev_exon_end + 1, -end => $exon->start -1, -strand => $exon->strand, -verbose => $self->verbose); my $match4 = Bio::Location::Simple->new (-seq_id => 'intron'. ($exon_counter -1), -start => 1, -end => $exon->start - 1 - $prev_exon_end, -strand =>$exon->strand, -verbose => $self->verbose,); # negative intron coordinates my $match5 = Bio::Location::Simple->new (-seq_id => 'intron'. ($exon_counter -1), -start => -1 * ($exon->start - 2 - $prev_exon_end) -1, -end => -1, -strand => $exon->strand, -verbose => $self->verbose); $inex_map->add_mapper(Bio::Coordinate::Pair->new (-in => $match3, -out => $match4 ) ); $intron_map->add_mapper(Bio::Coordinate::Pair->new (-in => $self->_clone_loc($match3), -out => $self->_clone_loc($match4) ) ); $negative_intron_map->add_mapper(Bio::Coordinate::Pair->new (-in => $self->_clone_loc($match4), -out => $match5 )); } # store the value $prev_exon_end = $exon->end; # # gene -> exon # my $match6 = Bio::Location::Simple->new (-seq_id => 'exon'. $exon_counter, -start => 1, -end => $exon->end - $exon->start +1, -strand => $exon->strand, -verbose=> $self->verbose,); my $pair2 = Bio::Coordinate::Pair->new(-in => $self->_clone_loc($match1), -out => $match6 ); my $pair3 = Bio::Coordinate::Pair->new(-in => $self->_clone_loc($match6), -out => $self->_clone_loc($match2) ); $inex_map->add_mapper(Bio::Coordinate::Pair->new (-in => $self->_clone_loc($match1), -out => $match6 ) ); $exon_map->add_mapper(Bio::Coordinate::Pair->new (-in => $self->_clone_loc($match1), -out => $self->_clone_loc($match6) ) ); $exon_cds_map->add_mapper(Bio::Coordinate::Pair->new (-in => $self->_clone_loc($match6), -out => $self->_clone_loc($match2) ) ); } # move coordinate start if exons have negative values if ($coffset) { foreach my $m ($cds_map->each_mapper) { $m->out->start($m->out->start - $coffset); $m->out->end($m->out->end - $coffset); } } $self->{'_mappers'}->{$cds_mapper} = $cds_map; $self->{'_mappers'}->{$exon_cds_mapper} = $exon_cds_map; $self->{'_mappers'}->{$inex_mapper} = $inex_map; $self->{'_mappers'}->{$exon_mapper} = $exon_map; $self->{'_mappers'}->{$intron_mapper} = $intron_map; $self->{'_mappers'}->{$negative_intron_mapper} = $negative_intron_map; } return @{$self->{'_chr_exons'}} || 0; } =head2 _clone_loc Title : _clone_loc Usage : $copy_of_loc = $obj->_clone_loc($loc); Function: Make a deep copy of a simple location Returns : a Bio::Location::Simple object Args : a Bio::Location::Simple object to be cloned =cut sub _clone_loc { # clone a simple location my ($self,$loc) = @_; $self->throw("I need a Bio::Location::Simple , not [". ref $loc. "]") unless $loc->isa('Bio::Location::Simple'); return Bio::Location::Simple->new (-verbose => $self->verbose, -seq_id => $loc->seq_id, -start => $loc->start, -end => $loc->end, -strand => $loc->strand, -location_type => $loc->location_type ); } =head2 cds Title : cds Usage : $obj->cds(20); Function: Set and read the offset of CDS from the start of transcipt Simple input can be an integer which gives the start of the coding region in genomic coordinate. If you want to provide the end of the coding region or indicate the use of the opposite strand, you have to pass a Bio::RangeI (e.g. Bio::Location::Simple or Bio::SegFeature::Generic) object to this method. Returns : set value or 0 Args : new value (optional) =cut sub cds { my ($self,$value) = @_; if( defined $value) { if ($value =~ /^[+-]?\d+$/ ) { my $loc = Bio::Location::Simple->new(-start=>$value, -end => $value, -verbose=>$self->verbose); $self->{'_cds'} = $loc; } elsif (ref $value && $value->isa('Bio::RangeI') ) { $self->{'_cds'} = $value; } else { $self->throw("I need an integer or Bio::RangeI, not [$value]") } # strand !! my $len; $len = $self->{'_cds'}->end - $self->{'_cds'}->start +1 if defined $self->{'_cds'}->end; my $a = $self->_create_pair ('chr', 'gene', 0, $self->{'_cds'}->start-1, $len, $self->{'_cds'}->strand); my $mapper = $COORDINATE_SYSTEMS{'chr'}. "-". $COORDINATE_SYSTEMS{'gene'}; $self->{'_mappers'}->{$mapper} = $a; # recalculate exon-based mappers if ( defined $self->{'_chr_exons'} ) { $self->exons(@{$self->{'_chr_exons'}}); } } return $self->{'_cds'} || 0; } =head2 map Title : map Usage : $newpos = $obj->map(5); Function: Map the location from the input coordinate system to a new value in the output coordinate system. Example : Returns : new value in the output coordiante system Args : a Bio::Location::Simple =cut sub map { my ($self,$value) = @_; my ($res); $self->throw("Need to pass me a Bio::Location::Simple or ". "Bio::Location::Simple or Bio::SeqFeatureI, not [". ref($value). "]") unless ref($value) && ($value->isa('Bio::Location::Simple') or $value->isa('Bio::Location::SplitLocationI') or $value->isa('Bio::SeqFeatureI')); $self->throw("Input coordinate system not set") unless $self->{'_in'}; $self->throw("Output coordinate system not set") unless $self->{'_out'}; $self->throw("Do not be silly. Input and output coordinate ". "systems are the same!") unless $self->{'_in'} != $self->{'_out'}; $self->_check_direction(); $value = $value->location if $value->isa('Bio::SeqFeatureI'); $self->debug( "=== Start location: ". $value->start. ",". $value->end. " (". ($value->strand || ''). ")\n"); # if nozero coordinate system is used in the input values if ( defined $self->{'_nozero'} && ( $self->{'_nozero'} == 1 || $self->{'_nozero'} == 3 ) ) { $value->start($value->start + 1) if defined $value->start && $value->start < 1; $value->end($value->end + 1) if defined $value->end && $value->end < 1; } my @steps = $self->_get_path(); $self->debug( "mapping ". $self->{'_in'}. "->". $self->{'_out'}. " Mappers: ". join(", ", @steps). "\n"); foreach my $mapper (@steps) { if ($mapper eq $TRANSLATION) { if ($self->direction == 1) { $value = $self->_translate($value); $self->debug( "+ $TRANSLATION cds -> propeptide (translate) \n"); } else { $value = $self->_reverse_translate($value); $self->debug("+ $TRANSLATION propeptide -> cds (reverse translate) \n"); } } # keep the start and end values, and go on to next iteration # if this mapper is not set elsif ( ! defined $self->{'_mappers'}->{$mapper} ) { # update mapper name $mapper =~ /\d+-(\d+)/; my ($counter) = $1; $value->seq_id($COORDINATE_INTS{$counter}); $self->debug( "- $mapper\n"); } else { # # the DEFAULT : generic mapping # $value = $self->{'_mappers'}->{$mapper}->map($value); $value->purge_gaps if ($value && $value->isa('Bio::Location::SplitLocationI') && $value->can('gap')); $self->debug( "+ $mapper (". $self->direction. "): start ". $value->start. " end ". $value->end. "\n") if $value && $self->verbose > 0; } } # if nozero coordinate system is asked to be used in the output values if ( defined $value && defined $self->{'_nozero'} && ( $self->{'_nozero'} == 2 || $self->{'_nozero'} == 3 ) ) { $value->start($value->start - 1) if defined $value->start && $value->start < 1; $value->end($value->end - 1) if defined $value->end && $value->end < 1; } # handle merging of adjacent split locations! if (ref $value eq "Bio::Coordinate::Result" && $value->each_match > 1 ) { my $prevloc; my $merging = 0; my $newvalue; my @matches; foreach my $loc ( $value->each_Location(1) ) { unless ($prevloc) { $prevloc = $loc; push @matches, $prevloc; next; } if ($prevloc->end == ($loc->start - 1) && $prevloc->seq_id eq $loc->seq_id) { $prevloc->end($loc->end); $merging = 1; } else { push @matches, $loc; $prevloc = $loc; } } if ($merging) { if (@matches > 1 ) { $newvalue = Bio::Coordinate::Result->new; map {$newvalue->add_sub_Location} @matches; } else { $newvalue = Bio::Coordinate::Result::Match->new (-seq_id => $matches[0]->seq_id, -start => $matches[0]->start, -end => $matches[0]->end, -strand => $matches[0]->strand, -verbose => $self->verbose,); } $value = $newvalue; } } elsif (ref $value eq "Bio::Coordinate::Result" && $value->each_match == 1 ){ $value = $value->match; } return $value; } =head2 direction Title : direction Usage : $obj->direction('peptide'); Function: Read-only method for the direction of mapping deduced from predefined input and output coordinate names. Example : Returns : 1 or -1, mapping direction Args : new value (optional) =cut sub direction { my ($self) = @_; return $self->{'_direction'}; } =head2 swap Title : swap Usage : $obj->swap; Function: Swap the direction of transformation (input <-> output) Example : Returns : 1 Args : =cut sub swap { my ($self,$value) = @_; ($self->{'_in'}, $self->{'_out'}) = ($self->{'_out'}, $self->{'_in'}); map { $self->{'_mappers'}->{$_}->swap } keys %{$self->{'_mappers'}}; # record the changed direction; $self->{_direction} *= -1; return 1; } =head2 to_string Title : to_string Usage : $newpos = $obj->to_string(5); Function: Dump the internal mapper values into a human readable format Example : Returns : string Args : =cut sub to_string { my ($self) = shift; print "-" x 40, "\n"; # chr-gene my $mapper_str = 'chr-gene'; my $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; if (defined $self->cds) { my $end = $self->cds->end -1 if defined $self->cds->end; printf "%16s%s: %s (%s)\n", ' ', 'gene offset', $self->cds->start-1 , $end || ''; printf "%16s%s: %s\n", ' ', 'gene strand', $self->cds->strand || 0; } # gene-intron $mapper_str = 'gene-intron'; $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; my $i = 1; foreach my $pair ( $self->{'_mappers'}->{$mapper}->each_mapper ) { printf "%8s :%8s -> %-12s\n", $i, $pair->in->start, $pair->out->start ; printf "%8s :%8s -> %-12s\n", '', $pair->in->end, $pair->out->end ; $i++; } # intron-negative_intron $mapper_str = 'intron-negative_intron'; $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; $i = 1; foreach my $pair ( $self->{'_mappers'}->{$mapper}->each_mapper ) { printf "%8s :%8s -> %-12s\n", $i, $pair->in->start, $pair->out->start ; printf "%8s :%8s -> %-12s\n", '', $pair->in->end, $pair->out->end ; $i++; } # gene-exon $mapper_str = 'gene-exon'; $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; $i = 1; foreach my $pair ( $self->{'_mappers'}->{$mapper}->each_mapper ) { printf "%8s :%8s -> %-12s\n", $i, $pair->in->start, $pair->out->start ; printf "%8s :%8s -> %-12s\n", '', $pair->in->end, $pair->out->end ; $i++; } # gene-cds $mapper_str = 'gene-cds'; $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; $i = 1; foreach my $pair ( $self->{'_mappers'}->{$mapper}->each_mapper ) { printf "%8s :%8s -> %-12s\n", $i, $pair->in->start, $pair->out->start ; printf "%8s :%8s -> %-12s\n", '', $pair->in->end, $pair->out->end ; $i++; } # cds-propeptide $mapper_str = 'cds-propeptide'; $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; printf "%9s%-12s\n", "", '"translate"'; # propeptide-peptide $mapper_str = 'propeptide-peptide'; $mapper = $self->_mapper_string2code($mapper_str); printf "\n %-12s (%s)\n", $mapper_str, $mapper ; printf "%16s%s: %s\n", ' ', "peptide offset", $self->peptide_offset; print "\nin : ", $self->in, "\n"; print "out: ", $self->out, "\n"; my $dir; $self->direction ? ($dir='forward') : ($dir='reverse'); printf "direction: %-8s(%s)\n", $dir, $self->direction; print "\n", "-" x 40, "\n"; 1; } sub _mapper_code2string { my ($self, $code) = @_; my ($a, $b) = $code =~ /(\d+)-(\d+)/; return $COORDINATE_INTS{$a}. '-'. $COORDINATE_INTS{$b}; } sub _mapper_string2code { my ($self, $string) =@_; my ($a, $b) = $string =~ /([^-]+)-(.*)/; return $COORDINATE_SYSTEMS{$a}. '-'. $COORDINATE_SYSTEMS{$b}; } =head2 _create_pair Title : _create_pair Usage : $mapper = $obj->_create_pair('chr', 'gene', 0, 2555, 10000, -1); Function: Internal helper method to create a mapper between two coordinate systems Returns : a Bio::Coordinate::Pair object Args : string, input coordinate system name, string, output coordinate system name, boolean, strict mapping positive integer, offset positive integer, length 1 || -1 , strand =cut sub _create_pair { my ($self, $in, $out, $strict, $offset, $length, $strand ) = @_; $strict ||= 0; $strand ||= 1; $length ||= 20; my $match1 = Bio::Location::Simple->new (-seq_id => $in, -start => $offset+1, -end => $offset+$length, -strand => 1, -verbose => $self->verbose); my $match2 = Bio::Location::Simple->new (-seq_id => $out, -start => 1, -end => $length, -strand => $strand, -verbose => $self->verbose); my $pair = Bio::Coordinate::ExtrapolatingPair->new (-in => $match1, -out => $match2, -strict => $strict, -verbose => $self->verbose, ); return $pair; } =head2 _translate Title : _translate Usage : $newpos = $obj->_translate($loc); Function: Translate the location from the CDS coordinate system to a new value in the propeptide coordinate system. Example : Returns : new location Args : a Bio::Location::Simple or Bio::Location::SplitLocationI =cut sub _translate { my ($self,$value) = @_; $self->throw("Need to pass me a Bio::Location::Simple or ". "Bio::Location::SplitLocationI, not [". ref($value). "]") unless defined $value && ($value->isa('Bio::Location::Simple') || $value->isa('Bio::Location::SplitLocationI')); my $seqid = 'propeptide'; if ($value->isa("Bio::Location::SplitLocationI") ) { my $split = Bio::Location::Split->new(-seq_id=>$seqid); foreach my $loc ( $value->each_Location(1) ) { my $match = Bio::Location::Simple->new (-start => int ($loc->start / 3 ) +1, -end => int ($loc->end / 3 ) +1, -seq_id => $seqid, -strand => 1, -verbose => $self->verbose, ); $split->add_sub_Location($match); } return $split; } else { return new Bio::Location::Simple(-start => int($value->start / 3 )+1, -end => int($value->end / 3 )+1, -seq_id => $seqid, -strand => 1, -verbose=> $self->verbose, ); } } sub _frame { my ($self,$value) = @_; $self->throw("Need to pass me a Bio::Location::Simple or ". "Bio::Location::SplitLocationI, not [". ref($value). "]") unless defined $value && ($value->isa('Bio::Location::Simple') || $value->isa('Bio::Location::SplitLocationI')); my $seqid = 'propeptide'; if ($value->isa("Bio::Location::SplitLocationI")) { my $split = Bio::Location::Split->new(-seq_id=>$seqid); foreach my $loc ( $value->each_Location(1) ) { my $match = Bio::Location::Simple->new (-start => ($value->start-1) % 3 +1, -end => ($value->end-1) % 3 +1, -seq_id => 'frame', -strand => 1, -verbose=> $self->verbose); $split->add_sub_Location($match); } return $split; } else { return new Bio::Location::Simple(-start => ($value->start-1) % 3 +1, -end => ($value->end-1) % 3 +1, -seq_id => 'frame', -strand => 1, -verbose => $self->verbose, ); } } =head2 _reverse_translate Title : _reverse_translate Usage : $newpos = $obj->_reverse_translate(5); Function: Reverse translate the location from the propeptide coordinate system to a new value in the CSD. Note that a single peptide location expands to cover the codon triplet Example : Returns : new location in the CDS coordinate system Args : a Bio::Location::Simple or Bio::Location::SplitLocationI =cut sub _reverse_translate { my ($self,$value) = @_; $self->throw("Need to pass me a Bio::Location::Simple or ". "Bio::Location::SplitLocationI, not [". ref($value). "]") unless defined $value && ($value->isa('Bio::Location::Simple') || $value->isa('Bio::Location::SplitLocationI')); my $seqid = 'cds'; if ($value->isa("Bio::Location::SplitLocationI")) { my $split = Bio::Location::Split->new(-seq_id=>$seqid); foreach my $loc ( $value->each_Location(1) ) { my $match = Bio::Location::Simple->new (-start => $value->start * 3 - 2, -end => $value->end * 3, -seq_id => $seqid, -strand => 1, -verbose => $self->verbose, ); $split->add_sub_Location($match); } return $split; } else { return new Bio::Location::Simple(-start => $value->start * 3 - 2, -end => $value->end * 3, -seq_id => $seqid, -strand => 1, -verbose => $self->verbose, ); } } =head2 _check_direction Title : _check_direction Usage : $obj->_check_direction(); Function: Check and swap when needed the direction the location mapping Pairs based on input and output values Example : Returns : new location Args : a Bio::Location::Simple =cut sub _check_direction { my ($self) = @_; my $new_direction = 1; $new_direction = -1 if $self->{'_in'} > $self->{'_out'}; unless ($new_direction == $self->{_direction} ) { map { $self->{'_mappers'}->{$_}->swap } keys %{$self->{'_mappers'}}; # record the changed direction; $self->{_direction} *= -1; } 1; } =head2 _get_path Title : _get_path Usage : $obj->_get_path('peptide'); Function: internal method for finding that shortest path between input and output coordinate systems. Calculations and caching are handled by the graph class. See L. Example : Returns : array of the mappers Args : none =cut sub _get_path { my ($self) = @_; my $start = $self->{'_in'} || 0; my $end = $self->{'_out'} || 0; # note the order # always go from smaller to bigger: it makes caching more efficient my $reverse; if ($start > $end) { ($start, $end) = ($end, $start ); $reverse++; } my @mappers; if (exists $self->{'_previous_path'} and $self->{'_previous_path'} eq "$start$end" ) { # use cache @mappers = @{$self->{'_mapper_path'}}; } else { my $mapper; my $prev_node = ''; @mappers = map { $mapper = "$prev_node-$_"; $prev_node = $_; $mapper; } $self->{'_graph'}->shortest_path($start, $end); shift @mappers; $self->{'_previous_path'} = "$start$end"; $self->{'_mapper_path'} = \@mappers; } $reverse ? return reverse @mappers : return @mappers; } 1; BioPerl-1.6.923/Bio/Coordinate/Graph.pm000444000765000024 2343112254227321 17656 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::Graph # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::Graph - Finds shortest path between nodes in a graph =head1 SYNOPSIS # get a hash of hashes representing the graph. E.g.: my $hash= { '1' => { '2' => 1 }, '2' => { '4' => 1, '3' => 1 }, '3' => undef, '4' => { '5' => 1 }, '5' => undef }; # create the object; my $graph = Bio::Coordinate::Graph->new(-graph => $hash); # find the shortest path between two nodes my $a = 1; my $b = 6; my @path = $graph->shortest_paths($a); print join (", ", @path), "\n"; =head1 DESCRIPTION This class calculates the shortest path between input and output coordinate systems in a graph that defines the relationships between them. This class is primarely designed to analyze gene-related coordinate systems. See L. Note that this module can not be used to manage graphs. Technically the graph implemented here is known as Directed Acyclic Graph (DAG). DAG is composed of vertices (nodes) and edges (with optional weights) linking them. Nodes of the graph are the coordinate systems in gene mapper. The shortest path is found using the Dijkstra's algorithm. This 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 simpler and faster breadth-first would be enough. Luckily the difference for small graphs is not significant and the implementation is capable of taking weights into account if needed at some later time. =head2 Input format The graph needs to be primed using a hash of hashes where there is a key for each node. The second keys are the names of the downstream neighboring nodes and values are the weights for reaching them. Here is part of the gene coordiante system graph:: $hash = { '6' => undef, '3' => { '6' => 1 }, '2' => { '6' => 1, '4' => 1, '3' => 1 }, '1' => { '2' => 1 }, '4' => { '5' => 1 }, '5' => undef }; 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. An alternative (shorter) way of describing input is to use hash of arrays. See L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::Graph; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($graph, $hasharray) = $self->_rearrange([qw( GRAPH HASHARRAY )], @args); $graph && $self->graph($graph); $hasharray && $self->hasharray($hasharray); $self->{'_root'} = undef; return $self; # success - we hope! } =head2 Graph structure input methods =cut =head2 graph Title : graph Usage : $obj->graph($my_graph) Function: Read/write method for the graph structure Example : Returns : hash of hashes grah structure Args : reference to a hash of hashes =cut sub graph { my ($self,$value) = @_; if ($value) { $self->throw("Need a hash of hashes") unless ref($value) eq 'HASH' ; $self->{'_dag'} = $value; # empty the cache $self->{'_root'} = undef; } return $self->{'_dag'}; } =head2 hash_of_arrays Title : hash_of_arrays Usage : $obj->hash_of_array(%hasharray) Function: An alternative method to read in the graph structure. Hash arrays are easier to type. This method converts arrays into hashes and assigns equal values "1" to weights. Example : Here is an example of simple structure containing a graph. my $DAG = { 6 => [], 5 => [], 4 => [5], 3 => [6], 2 => [3, 4, 6], 1 => [2] }; Returns : hash of hashes graph structure Args : reference to a hash of arrays =cut sub hash_of_arrays { my ($self,$value) = @_; # empty the cache $self->{'_root'} = undef; if ($value) { $self->throw("Need a hash of hashes") unless ref($value) eq 'HASH' ; #copy the hash of arrays into a hash of hashes; my %hash; foreach my $start ( keys %{$value}){ $hash{$start} = undef; map { $hash{$start}{$_} = 1 } @{$value->{$start}}; } $self->{'_dag'} = \%hash; } return $self->{'_dag'}; } =head2 Methods for determining the shortest path in the graph =cut =head2 shortest_path Title : shortest_path Usage : $obj->shortest_path($a, $b); Function: Method for retrieving the shortest path between nodes. If the start node remains the same, the method is sometimes able to use cached results, otherwise it will recalculate the paths. Example : Returns : array of node names, only the start node name if no path Args : name of the start node : name of the end node =cut sub shortest_path { my ($self, $root, $end) = @_; $self->throw("Two arguments needed") unless @_ == 3; $self->throw("No node name [$root]") unless exists $self->{'_dag'}->{$root}; $self->throw("No node name [$end]") unless exists $self->{'_dag'}->{$end}; my @res; # results my $reverse; if ($root > $end) { ($root, $end) = ($end, $root ); $reverse++; } # try to use cached paths $self->dijkstra($root) unless defined $self->{'_root'} and $self->{'_root'} eq $root; return @res unless $self->{'_paths'} ; # create the list my $node = $end; my $prev = $self->{'_paths'}->{$end}{'prev'}; while ($prev) { unshift @res, $node; $node = $self->{'_paths'}->{$node}{'prev'}; $prev = $self->{'_paths'}->{$node}{'prev'}; } unshift @res, $node; $reverse ? return reverse @res : return @res; } =head2 dijkstra Title : dijkstra Usage : $graph->dijkstra(1); Function: Implements Dijkstra's algorithm. Returns or sets a list of mappers. The returned path description is always directed down from the root. Called from shortest_path(). Example : Returns : Reference to a hash of hashes representing a linked list which contains shortest path down to all nodes from the start node. E.g.: $res = { '2' => { 'prev' => '1', 'dist' => 1 }, '1' => { 'prev' => undef, 'dist' => 0 }, }; Args : name of the start node =cut #' keep emacs happy sub dijkstra { my ($self,$root) = @_; $self->throw("I need the name of the root node input") unless $root; $self->throw("No node name [$root]") unless exists $self->{'_dag'}->{$root}; my %est = (); # estimate hash my %res = (); # result hash my $nodes = keys %{$self->{'_dag'}}; my $maxdist = 1000000; # cache the root value $self->{'_root'} = $root; foreach my $node ( keys %{$self->{'_dag'}} ){ if ($node eq $root) { $est{$node}{'prev'} = undef; $est{$node}{'dist'} = 0; } else { $est{$node}{'prev'} = undef; $est{$node}{'dist'} = $maxdist; } } # remove nodes from %est until it is empty while (keys %est) { #select the node closest to current one, or root node my $min_node; my $min = $maxdist; foreach my $node (reverse sort keys %est) { if ( $est{$node}{'dist'} < $min ) { $min = $est{$node}{'dist'}; $min_node = $node; } } # no more links between nodes last unless ($min_node); # move the node from %est into %res; $res{$min_node} = delete $est{$min_node}; # recompute distances to the neighbours my $dist = $res{$min_node}{'dist'}; foreach my $neighbour ( keys %{$self->{'_dag'}->{$min_node}} ){ next unless $est{$neighbour}; # might not be there any more $est{$neighbour}{'prev'} = $min_node; $est{$neighbour}{'dist'} = $dist + $self->{'_dag'}{$min_node}{$neighbour} if $est{$neighbour}{'dist'} > $dist + 1 ; } } return $self->{'_paths'} = \%res; } 1; BioPerl-1.6.923/Bio/Coordinate/MapperI.pm000444000765000024 730112254227317 20135 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::MapperI # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::MapperI - Interface describing coordinate mappers =head1 SYNOPSIS # not to be used directly =head1 DESCRIPTION MapperI defines methods for classes capable for mapping locations between coordinate systems. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::MapperI; use strict; # Object preamble - inherits from Bio::Root::RootI use base qw(Bio::Root::RootI); =head2 in Title : in Usage : $obj->in('peptide'); Function: Set and read the input coordinate system. Example : Returns : value of input system Args : new value (optional), Bio::LocationI =cut sub in { my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 out Title : out Usage : $obj->out('peptide'); Function: Set and read the output coordinate system. Example : Returns : value of output system Args : new value (optional), Bio::LocationI =cut sub out { my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 swap Title : swap Usage : $obj->swap; Function: Swap the direction of mapping: input <-> output) Example : Returns : 1 Args : =cut sub swap { my ($self) = @_; $self->throw_not_implemented(); } =head2 test Title : test Usage : $obj->test; Function: test that both components are of same length Example : Returns : ( 1 | undef ) Args : =cut sub test { my ($self) = @_; $self->throw_not_implemented(); } =head2 map Title : map Usage : $newpos = $obj->map($loc); Function: Map the location from the input coordinate system to a new value in the output coordinate system. Example : Returns : new value in the output coordiante system Args : Bio::LocationI =cut sub map { my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 return_match Title : return_match Usage : $obj->return_match(1); Function: A flag to turn on the simplified mode of returning only one joined Match object or undef Example : Returns : boolean Args : boolean (optional) =cut sub return_match { my ($self,$value) = @_; if( defined $value) { $value ? ( $self->{'_return_match'} = 1 ) : ( $self->{'_return_match'} = 0 ); } return $self->{'_return_match'} || 0 ; } 1; BioPerl-1.6.923/Bio/Coordinate/Pair.pm000444000765000024 2710712254227314 17516 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::Pair # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::Pair - Continuous match between two coordinate sets =head1 SYNOPSIS use Bio::Location::Simple; use Bio::Coordinate::Pair; my $match1 = Bio::Location::Simple->new (-seq_id => 'propeptide', -start => 21, -end => 40, -strand=>1 ); my $match2 = Bio::Location::Simple->new (-seq_id => 'peptide', -start => 1, -end => 20, -strand=>1 ); my $pair = Bio::Coordinate::Pair->new(-in => $match1, -out => $match2 ); # location to match $pos = Bio::Location::Simple->new (-start => 25, -end => 25, -strand=> -1 ); # results are in a Bio::Coordinate::Result # they can be Matches and Gaps; are Bio::LocationIs $res = $pair->map($pos); $res->isa('Bio::Coordinate::Result'); $res->each_match == 1; $res->each_gap == 0; $res->each_Location == 1; $res->match->start == 5; $res->match->end == 5; $res->match->strand == -1; $res->match->seq_id eq 'peptide'; =head1 DESCRIPTION This class represents a one continuous match between two coordinate systems represented by Bio::Location::Simple objects. The relationship is directed and reversible. It implements methods to ensure internal consistency, and map continuous and split locations from one coordinate system to another. The map() method returns Bio::Coordinate::Results with Bio::Coordinate::Result::Gaps. The calling code have to deal (process or ignore) them. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::Pair; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Coordinate::Result; use Bio::Coordinate::Result::Match; use Bio::Coordinate::Result::Gap; use base qw(Bio::Root::Root Bio::Coordinate::MapperI); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($in, $out) = $self->_rearrange([qw(IN OUT )], @args); $in && $self->in($in); $out && $self->out($out); return $self; # success - we hope! } =head2 in Title : in Usage : $obj->in('peptide'); Function: Set and read the input coordinate system. Example : Returns : value of input system Args : new value (optional), Bio::LocationI =cut sub in { my ($self,$value) = @_; if( defined $value) { $self->throw("Not a valid input Bio::Location [$value] ") unless $value->isa('Bio::LocationI'); $self->{'_in'} = $value; } return $self->{'_in'}; } =head2 out Title : out Usage : $obj->out('peptide'); Function: Set and read the output coordinate system. Example : Returns : value of output system Args : new value (optional), Bio::LocationI =cut sub out { my ($self,$value) = @_; if( defined $value) { $self->throw("Not a valid output coordinate Bio::Location [$value] ") unless $value->isa('Bio::LocationI'); $self->{'_out'} = $value; } return $self->{'_out'}; } =head2 swap Title : swap Usage : $obj->swap; Function: Swap the direction of mapping; input <-> output Example : Returns : 1 Args : =cut sub swap { my ($self) = @_; ($self->{'_in'}, $self->{'_out'}) = ($self->{'_out'}, $self->{'_in'}); return 1; } =head2 strand Title : strand Usage : $obj->strand; Function: Get strand value for the pair Example : Returns : ( 1 | 0 | -1 ) Args : =cut sub strand { my ($self) = @_; $self->warn("Outgoing coordinates are not defined") unless $self->out; $self->warn("Incoming coordinates are not defined") unless $self->in; return ($self->in->strand || 0) * ($self->out->strand || 0); } =head2 test Title : test Usage : $obj->test; Function: test that both components are of the same length Example : Returns : ( 1 | undef ) Args : =cut sub test { my ($self) = @_; $self->warn("Outgoing coordinates are not defined") unless $self->out; $self->warn("Incoming coordinates are not defined") unless $self->in; return ($self->in->end - $self->in->start) == ($self->out->end - $self->out->start); } =head2 map Title : map Usage : $newpos = $obj->map($pos); Function: Map the location from the input coordinate system to a new value in the output coordinate system. Example : Returns : new Bio::LocationI in the output coordinate system or undef Args : Bio::LocationI object =cut sub map { my ($self,$value) = @_; $self->throw("Need to pass me a value.") unless defined $value; $self->throw("I need a Bio::Location, not [$value]") unless $value->isa('Bio::LocationI'); $self->throw("Input coordinate system not set") unless $self->in; $self->throw("Output coordinate system not set") unless $self->out; if ($value->isa("Bio::Location::SplitLocationI")) { my $result = Bio::Coordinate::Result->new(); foreach my $loc ( $value->sub_Location(1) ) { my $res = $self->_map($loc); map { $result->add_sub_Location($_) } $res->each_Location; } return $result; } else { return $self->_map($value); } } =head2 _map Title : _map Usage : $newpos = $obj->_map($simpleloc); Function: Internal method that does the actual mapping. Called multiple times by map() if the location to be mapped is a split location Example : Returns : new location in the output coordinate system or undef Args : Bio::Location::Simple =cut sub _map { my ($self,$value) = @_; my $result = Bio::Coordinate::Result->new(); my $offset = $self->in->start - $self->out->start; my $start = $value->start - $offset; my $end = $value->end - $offset; my $match = Bio::Location::Simple->new; $match->location_type($value->location_type); $match->strand($self->strand); #within # |-------------------------| # |-| if ($start >= $self->out->start and $end <= $self->out->end) { $match->seq_id($self->out->seq_id); $result->seq_id($self->out->seq_id); if ($self->strand >= 0) { $match->start($start); $match->end($end); } else { $match->start($self->out->end - $end + $self->out->start); $match->end($self->out->end - $start + $self->out->start); } if ($value->strand) { $match->strand($match->strand * $value->strand); $result->strand($match->strand); } bless $match, 'Bio::Coordinate::Result::Match'; $result->add_sub_Location($match); } #out # |-------------------------| # |-| or |-| elsif ( ($end < $self->out->start or $start > $self->out->end ) or #insertions just outside the range need special settings ($value->location_type eq 'IN-BETWEEN' and ($end = $self->out->start or $start = $self->out->end))) { $match->seq_id($self->in->seq_id); $result->seq_id($self->in->seq_id); $match->start($value->start); $match->end($value->end); $match->strand($value->strand); bless $match, 'Bio::Coordinate::Result::Gap'; $result->add_sub_Location($match); } #partial I # |-------------------------| # |-----| elsif ($start < $self->out->start and $end <= $self->out->end ) { $result->seq_id($self->out->seq_id); if ($value->strand) { $match->strand($match->strand * $value->strand); $result->strand($match->strand); } my $gap = Bio::Location::Simple->new; $gap->start($value->start); $gap->end($self->in->start - 1); $gap->strand($value->strand); $gap->seq_id($self->in->seq_id); bless $gap, 'Bio::Coordinate::Result::Gap'; $result->add_sub_Location($gap); # match $match->seq_id($self->out->seq_id); if ($self->strand >= 0) { $match->start($self->out->start); $match->end($end); } else { $match->start($self->out->end - $end + $self->out->start); $match->end($self->out->end); } bless $match, 'Bio::Coordinate::Result::Match'; $result->add_sub_Location($match); } #partial II # |-------------------------| # |------| elsif ($start >= $self->out->start and $end > $self->out->end ) { $match->seq_id($self->out->seq_id); $result->seq_id($self->out->seq_id); if ($value->strand) { $match->strand($match->strand * $value->strand); $result->strand($match->strand); } if ($self->strand >= 0) { $match->start($start); $match->end($self->out->end); } else { $match->start($self->out->start); $match->end($self->out->end - $start + $self->out->start); } bless $match, 'Bio::Coordinate::Result::Match'; $result->add_sub_Location($match); my $gap = Bio::Location::Simple->new; $gap->start($self->in->end + 1); $gap->end($value->end); $gap->strand($value->strand); $gap->seq_id($self->in->seq_id); bless $gap, 'Bio::Coordinate::Result::Gap'; $result->add_sub_Location($gap); } #enveloping # |-------------------------| # |---------------------------------| elsif ($start < $self->out->start and $end > $self->out->end ) { $result->seq_id($self->out->seq_id); if ($value->strand) { $match->strand($match->strand * $value->strand); $result->strand($match->strand); } # gap1 my $gap1 = Bio::Location::Simple->new; $gap1->start($value->start); $gap1->end($self->in->start - 1); $gap1->strand($value->strand); $gap1->seq_id($self->in->seq_id); bless $gap1, 'Bio::Coordinate::Result::Gap'; $result->add_sub_Location($gap1); # match $match->seq_id($self->out->seq_id); $match->start($self->out->start); $match->end($self->out->end); bless $match, 'Bio::Coordinate::Result::Match'; $result->add_sub_Location($match); # gap2 my $gap2 = Bio::Location::Simple->new; $gap2->start($self->in->end + 1); $gap2->end($value->end); $gap2->strand($value->strand); $gap2->seq_id($self->in->seq_id); bless $gap2, 'Bio::Coordinate::Result::Gap'; $result->add_sub_Location($gap2); } else { $self->throw("Should not be here!"); } return $result; } 1; BioPerl-1.6.923/Bio/Coordinate/Result.pm000444000765000024 1441212254227326 20077 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::Result # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::Result - Results from coordinate transformation =head1 SYNOPSIS use Bio::Coordinate::Result; #get results from a Bio::Coordinate::MapperI $matched = $result->each_match; =head1 DESCRIPTION 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. If only one Match is returned, there is a convenience method of retrieving it or accessing its methods. Same holds true for a Gap. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::Result; use strict; use base qw(Bio::Location::Split Bio::Coordinate::ResultI); =head2 add_location Title : add_sub_Location Usage : $obj->add_sub_Location($variant) Function: Pushes one Bio::LocationI into the list of variants. Example : Returns : 1 when succeeds Args : Location object =cut sub add_sub_Location { my ($self,$value) = @_; if( ! $value ) { $self->warn("provding an empty value for location\n"); return; } $self->throw("Is not a Bio::LocationI but [$value]") unless $value->isa('Bio::LocationI'); $self->{'_match'} = $value if $value->isa('Bio::Coordinate::Result::Match'); $self->{'_gap'} = $value if $value->isa('Bio::Coordinate::Result::Gap'); $self->SUPER::add_sub_Location($value); } =head2 add_result Title : add_result Usage : $obj->add_result($result) Function: Adds the contents of one Bio::Coordinate::Result Example : Returns : 1 when succeeds Args : Result object =cut sub add_result { my ($self,$value) = @_; $self->throw("Is not a Bio::Coordinate::Result but [$value]") unless $value->isa('Bio::Coordinate::Result'); map { $self->add_sub_Location($_) } $value->each_Location; } =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to We override this here in order to propagate to all sublocations which are not remote (provided this root is not remote either) Returns : seq_id Args : [optional] seq_id value to set =cut sub seq_id { my ($self, $seqid) = @_; my @ls = $self->each_Location; if (@ls) { return $ls[0]->seq_id; } else { return; } } =head2 Convenience methods These methods are shortcuts to Match and Gap locations. =cut =head2 each_gap Title : each_gap Usage : $obj->each_gap(); Function: Returns a list of Bio::Coordianate::Result::Gap objects. Returns : list of gaps Args : none =cut sub each_gap { my ($self) = @_; my @gaps; foreach my $gap ($self->each_Location) { push @gaps, $gap if $gap->isa('Bio::Coordinate::Result::Gap'); } return @gaps; } =head2 each_match Title : each_match Usage : $obj->each_match(); Function: Returns a list of Bio::Coordinate::Result::Match objects. Returns : list of Matchs Args : none =cut sub each_match { my ($self) = @_; my @matches; foreach my $match ($self->each_Location) { push @matches, $match if $match->isa('Bio::Coordinate::Result::Match'); } return @matches; } =head2 match Title : match Usage : $match_object = $obj->match(); #or $gstart = $obj->gap->start; Function: Read only method for retrieving or accessing the match object. Returns : one Bio::Coordinate::Result::Match Args : =cut sub match { my ($self) = @_; $self->warn("More than one match in results") if $self->each_match > 1 and $self->verbose > 0; unless (defined $self->{'_match'} ) { my @m = $self->each_match; $self->{'_match'} = $m[-1]; } return $self->{'_match'}; } =head2 gap Title : gap Usage : $gap_object = $obj->gap(); #or $gstart = $obj->gap->start; Function: Read only method for retrieving or accessing the gap object. Returns : one Bio::Coordinate::Result::Gap Args : =cut sub gap { my ($self) = @_; $self->warn("More than one gap in results") if $self->each_gap > 1 and $self->verbose > 0; unless (defined $self->{'_gap'} ) { my @m = $self->each_gap; $self->{'_gap'} = $m[-1]; } return $self->{'_gap'}; } =head2 purge_gaps Title : purge_gaps Usage : $gap_count = $obj->purge_gaps; Function: remove all gaps from the Result Returns : count of removed gaps Args : =cut sub purge_gaps { my ($self) = @_; my @matches; my $count = 0; foreach my $loc ($self->each_Location) { if ($loc->isa('Bio::Coordinate::Result::Match')) { push @matches, $loc; } else { $count++ } } @{$self->{'_sublocations'}} = (); delete $self->{'_gap'} ; push @{$self->{'_sublocations'}}, @matches; return $count; } 1; BioPerl-1.6.923/Bio/Coordinate/ResultI.pm000444000765000024 355112254227321 20165 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::Coordinate::ResultI # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::ResultI - Interface to identify coordinate mapper results =head1 SYNOPSIS # not to be used directly =head1 DESCRIPTION ResultI identifies Bio::LocationIs returned by Bio::Coordinate::MapperI implementing classes from other locations. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::ResultI; use strict; # Object preamble use base qw(Bio::LocationI); 1; BioPerl-1.6.923/Bio/Coordinate/Utils.pm000444000765000024 1552512254227333 17725 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Coordinate::Utils # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Coordinate::Utils - Additional methods to create Bio::Coordinate objects =head1 SYNOPSIS use Bio::Coordinate::Utils; # get a Bio::Align::AlignI compliant object, $aln, somehow # it could be a Bio::SimpleAlign $mapper = Bio::Coordinate::Utils->from_align($aln, 1); # Build a set of mappers which will map, for each sequence, # that sequence position in the alignment (exon position to alignment # position) my @mappers = Bio::Coordinate::Utils->from_seq_to_alignmentpos($aln); =head1 DESCRIPTION This class is a holder of methods that work on or create Bio::Coordinate::MapperI- compliant objects. . These methods are not part of the Bio::Coordinate::MapperI interface and should in general not be essential to the primary function of sequence objects. If you are thinking of adding essential functions, it might be better to create your own sequence class. See L, L, and L for more. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org Jason Stajich jason at bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Coordinate::Utils; use Bio::Location::Simple; use Bio::Coordinate::Pair; use Bio::Coordinate::Collection; use strict; use base qw(Bio::Root::Root); # new inherited from Root =head2 from_align Title : from_align Usage : $mapper = Bio::Coordinate::Utils->from_align($aln, 1); Function: Create a mapper out of an alignment. The mapper will return a value only when both ends of the input range find a match. Note: This implementation works only on pairwise alignments and is not yet well tested! Returns : A Bio::Coordinate::MapperI Args : Bio::Align::AlignI object Id for the reference sequence, optional =cut sub from_align { my ($self, $aln, $ref ) = @_; $aln->isa('Bio::Align::AlignI') || $self->throw('Not a Bio::Align::AlignI object but ['. ref($aln). ']'); # default reference sequence to the first sequence $ref ||= 1; my $collection = Bio::Coordinate::Collection->new(-return_match=>1); # this works only for pairs, so split the MSA # take the ref #foreach remaining seq in aln, do: $aln->map_chars('\.','-'); my $cs = $aln->gap_line; my $seq1 = $aln->get_seq_by_pos(1); my $seq2 = $aln->get_seq_by_pos(2); while ( $cs =~ /([^\-]+)/g) { # alignment coordinates my $lenmatch = length($1); my $start = pos($cs) - $lenmatch +1; my $end = $start + $lenmatch -1; my $match1 = Bio::Location::Simple->new (-seq_id => $seq1->id, -start => $seq1->location_from_column($start)->start, -end => $seq1->location_from_column($end)->start, -strand => $seq1->strand ); my $match2 = Bio::Location::Simple->new (-seq_id => $seq2->id, -start => $seq2->location_from_column($start)->start, -end => $seq2->location_from_column($end)->start, -strand => $seq2->strand ); my $pair = Bio::Coordinate::Pair->new (-in => $match1, -out => $match2 ); unless( $pair->test ) { $self->warn(join("", "pair align did not pass test ($start..$end):\n", "\tm1=",$match1->to_FTstring(), " len=", $match1->length, " m2=", $match2->to_FTstring()," len=", $match2->length,"\n")); } $collection->add_mapper($pair); } return ($collection->each_mapper)[0] if $collection->mapper_count == 1; return $collection; } =head2 from_seq_to_alignmentpos Title : from_seq_to_alignmentpos Usage : $mapper = Bio::Coordinate::Utils->from_seq_to_alignmentpos($aln, 1); Function: Create a mapper out of an alignment. The mapper will map the position of a sequence into that position in the alignment. Will work on alignments of >= 2 sequences Returns : An array of Bio::Coordinate::MapperI Args : Bio::Align::AlignI object =cut sub from_seq_to_alignmentpos { my ($self, $aln ) = @_; $aln->isa('Bio::Align::AlignI') || $self->throw('Not a Bio::Align::AlignI object but ['. ref($aln). ']'); # default reference sequence to the first sequence my @mappers; $aln->map_chars('\.','-'); for my $seq ( $aln->each_seq ) { my $collection = Bio::Coordinate::Collection->new(-return_match=>1); my $cs = $seq->seq(); # do we change this over to use index and substr for speed? while ( $cs =~ /([^\-]+)/g) { # alignment coordinates my $lenmatch = length($1); my $start = pos($cs) - $lenmatch +1; my $end = $start + $lenmatch -1; my $match1 = Bio::Location::Simple->new (-seq_id => $seq->id, -start => $seq->location_from_column($start)->start, -end => $seq->location_from_column($end)->start, -strand => $seq->strand ); my $match2 = Bio::Location::Simple->new (-seq_id => 'alignment', -start => $start, -end => $end, -strand => 0 ); my $pair = Bio::Coordinate::Pair->new (-in => $match1, -out => $match2 ); unless ( $pair->test ) { $self->warn(join("", "pair align did not pass test ($start..$end):\n", "\tm1=",$match1->to_FTstring(), " len=", $match1->length, " m2=", $match2->to_FTstring()," len=", $match2->length,"\n")); } $collection->add_mapper($pair); } if( $collection->mapper_count == 1) { push @mappers, ($collection->each_mapper)[0]; } else { push @mappers, $collection; } } return @mappers; } 1; BioPerl-1.6.923/Bio/Coordinate/Result000755000765000024 012254227331 17356 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Coordinate/Result/Gap.pm000444000765000024 366612254227331 20573 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Coordinate::Result::Gap # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copywright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::Coordinate::Result::Gap - Another name for Bio::Location::Simple =head1 SYNOPSIS $loc = Bio::Coordinate::Result::Gap->new(-start=>10, -end=>30, -strand=>1); =head1 DESCRIPTION This is a location object for coordinate mapping results. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Coordinate::Result::Gap; use strict; use base qw(Bio::Location::Simple Bio::Coordinate::ResultI); 1; BioPerl-1.6.923/Bio/Coordinate/Result/Match.pm000444000765000024 370212254227314 21110 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Coordinate::Result::Match # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copywright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::Coordinate::Result::Match - Another name for Bio::Location::Simple =head1 SYNOPSIS $loc = Bio::Coordinate::Result::Match->new(-start=>10, -end=>30, -strand=>+1); =head1 DESCRIPTION This is a location class for coordinate mapping results. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Coordinate::Result::Match; use strict; use base qw(Bio::Location::Simple Bio::Coordinate::ResultI); 1; BioPerl-1.6.923/Bio/Das000755000765000024 012254227331 14520 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Das/FeatureTypeI.pm000444000765000024 2452612254227324 17614 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Das::FeatureTypeI # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Das::FeatureTypeI - Simple interface to Sequence Ontology feature types =head1 SYNOPSIS # Get a Bio::Das::FeatureTypeI object from somewhere $term = $db->fetch.... # Get the name of the term $definition = $term->name; # Get the accession of the term $accession = $term->accession; # Get the definition of the term $definition = $term->definition; # Get the parents of the term, optionally filtered by relationship @parents = $term->parents($relationship); # Get the children of the term, optionally filtered by relationship @children = $term->children($relationship); # Given a parent and child, returns their relationship, or undef if # not directly related $relationship = $parent->relationship($child); # Return true if two terms are identical $match = $term1->equals($term2); # Return true if $term2 is a descendent of $term1, optionally # filtering by relationship ("isa" assumed) $match = $term1->is_descendent($term2,$relationship); # Return true if $term2 is a parent of $term1, optionally # filtering by relationship ("isa" assumed) $match = $term1->is_parent($term2,$relationship); # Return true if $term2 is equal to $term1 or if $term2 descends # from term 1 via the "isa" relationship $match = $term1->match($term2); # Create a new term de novo $term = Bio::Das::FeatureTypeI->new(-name => $name, -accession => $accession, -definition => $definition); # Add a child to a term $term1->add_child($term2,$relationship); # Delete a child from a term $term1->delete_child($term2); =head1 DESCRIPTION Bio::Das::FeatureTypeI is an interface to the Gene Ontology Consortium's Sequence Ontology (SO). The SO, like other ontologies, is a directed acyclic graph in which a child node may have multiple parents. The relationship between parent and child is one of a list of relationships. The SO currently recognizes two relationships "isa" and "partof". The intent of this interface is to interoperate with older software that uses bare strings to represent feature types. For this reason, the interface overloads the stringify ("") and string equals (eq) operations. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bio.perl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::Das::FeatureTypeI; use strict; use overload '""' => 'name', eq => 'match', fallback => 1; # Object preamble - inherits from Bio::Root::RootI; =pod this is somehow FUBAR, implementation classes cannot successfully inherit from Bio::Das::FeatureTypeI =cut use base qw(Bio::Root::RootI); =head2 name Title : name Usage : $string = $term->name Function: return the term for the type Returns : a string Args : none Status : Public =cut sub name { shift->throw_not_implemented } =head2 accession Title : accession Usage : $string = $term->accession Function: return the accession number for the term Returns : a string Args : none Status : Public =cut sub accession { shift->throw_not_implemented } =head2 definition Title : definition Usage : $string = $term->definition Function: return the human-readable definition for the term Returns : a string Args : none Status : Public =cut sub definition { shift->throw_not_implemented } =head2 parents Title : parents Usage : @terms = $term->parents($relationship) Function: return parent terms Returns : list of Bio::Das::FeatureTypeI Args : none Status : Public Returns the parents for the current term, empty if there are none. An optional relationship argument will return those parents that are related via the specified relationship type. The relationship is one of "isa" or "partof". =cut sub parents { shift->throw_not_implemented; } =head2 children Title : children Usage : @terms = $term->children($relationship) Function: return children terms Returns : list of Bio::Das::FeatureTypeI Args : none Status : Public Returns the children for the current term, empty if there are none. An optional relationship argument will return those children that are related via the specified relationship type. The relationship is one of "isa" or "partof". =cut sub children { shift->throw_not_implemented; } =head2 relationship Title : relationship Usage : $relationship = $parent->relationship($child) Function: return the relationship between a parent and a child Returns : one of "isa" or "partof" Args : none Status : Public This method returns the relationship between a parent and one of its immediate descendents. It can return "isa", "partof", or undef if there is not a direct parent/child relationship (kissing cousins are *not* recognized). =cut sub relationship { shift->throw_not_implemented } =head2 equals Title : equals Usage : $boolean = $term1->equals($term2) Function: return true if $term1 and $term2 are the same Returns : boolean Args : second term Status : Public The two terms must be identical. In practice, this means that if term2 is a Bio::Das::FeatureI object, then its accession number must match the first term's accession number. Otherwise, if term2 is a bare string, then it must equal (in a case insensitive manner) the name of term1. NOTE TO IMPLEMENTORS: This method is defined in terms of other methods, so does not need to be implemented. =cut #' sub equals { my $self = shift; my $term2 = shift; if ($term2->isa('Bio::Das::FeatureTypeI')) { return $self->accession eq $term2->accession; } else { return lc $self->name eq lc $term2; } } =head2 is_descendent Title : is_descendent Usage : $boolean = $term1->is_descendent($term2 [,$relationship]) Function: return true of $term2 is a descendent of $term1 Returns : boolean Args : second term Status : Public This method returns true if $term2 descends from $term1. The operation traverses the tree. The traversal can be limited to the relationship type ("isa" or "partof") if desired. $term2 can be a bare string, in which case the term names will be used as the basis for term matching (see equals()). NOTE TO IMPLEMENTORS: this method is defined as the inverse of is_parent(). Do not implement it directly, but do implement is_parent(). =cut sub is_descendent { my $self = shift; my ($term,$relationship) = @_; $self->throw("$term is not a Bio::Das::FeatureTypeI") unless $term->isa('Bio::Das::FeatureTypeI'); $term->is_parent($self,$relationship); } =head2 is_parent Title : is_parent Usage : $boolean = $term1->is_parent($term2 [,$relationship]) Function: return true of $term2 is a parent of $term1 Returns : boolean Args : second term Status : Public This method returns true if $term2 is a parent of $term1. The operation traverses the tree. The traversal can be limited to the relationship type ("isa" or "partof") if desired. $term2 can be a bare string, in which case the term names will be used as the basis for term matching (see equals()). NOTE TO IMPLEMENTORS: Implementing this method will also implement is_descendent(). =cut sub is_parent { shift->throw_not_implemented } =head2 match Title : match Usage : $boolean = $term1->match($term2) Function: return true if $term1 equals $term2 or if $term2 is an "isa" descendent Returns : boolean Args : second term Status : Public This method combines equals() and is_descendent() in such a way that the two terms will match if they are the same or if the second term is an instance of the first one. This is also the basis of the operator overloading of eq. NOTE TO IMPLEMENTORS: This method is defined in terms of other methods and does not need to be implemented. =cut sub match { my $self = shift; my $term2 = shift; return 1 if $self->equals($term2); return $self->is_descendent($term2,'isa'); } =head2 new Title : new Usage : $term = Bio::Das::FeatureTypeI->new(@args) Function: create a new term Returns : new term Args : see below Status : Public This method creates a new Bio::Das::FeatureTypeI. Arguments: Argument Description -------- ------------ -name Name of this term -accession Accession number for the term -definition Definition of the term =cut sub new { shift->throw_not_implemented } =head2 add_child Title : add_child Usage : $boolean = $term->add_child($term2,$relationship) Function: add a child to a term Returns : a boolean indicating success Args : new child Throws : a "cycle detected" exception Status : Public This method adds a new child to the indicated node. It may detect a cycle in the DAG and throw a "cycle detected" exception. =cut sub add_child { shift->throw_not_implemented } =head2 delete_child Title : delete_child Usage : $boolean = $term->delete_child($term2); Function: delete a child of the term Returns : a boolean indicating success Args : child to be deleted Throws : a "not a child" exception Status : Public This method deletes a new child from the indicated node. It will throw an exception if the indicated child is not a direct descendent. =cut sub delete_child { shift->throw_not_implemented } 1; BioPerl-1.6.923/Bio/Das/SegmentI.pm000444000765000024 3032712254227331 16753 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Das::SegmentI # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Das::SegmentI - DAS-style access to a feature database =head1 SYNOPSIS # Get a Bio::Das::SegmentI object from a Bio::DasI database... $segment = $das->segment(-name=>'Landmark', -start=>$start, -end => $end); @features = $segment->overlapping_features(-type=>['type1','type2']); # each feature is a Bio::SeqFeatureI-compliant object @features = $segment->contained_features(-type=>['type1','type2']); @features = $segment->contained_in(-type=>['type1','type2']); $stream = $segment->get_feature_stream(-type=>['type1','type2','type3']; while (my $feature = $stream->next_seq) { # do something with feature } $count = $segment->features_callback(-type=>['type1','type2','type3'], -callback => sub { ... { } ); =head1 DESCRIPTION Bio::Das::SegmentI is a simplified alternative interface to sequence annotation databases used by the distributed annotation system. In this scheme, the genome is represented as a series of landmarks. Each Bio::Das::SegmentI object ("segment") corresponds to a genomic region defined by a landmark and a start and end position relative to that landmark. A segment is created using the Bio::DasI segment() method. Features can be filtered by the following attributes: 1) their location relative to the segment (whether overlapping, contained within, or completely containing) 2) their type 3) other attributes using tag/value semantics Access to the feature list uses three distinct APIs: 1) fetching entire list of features at a time 2) fetching an iterator across features 3) a callback =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bio.perl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::Das::SegmentI; use strict; # Object preamble - inherits from Bio::Root::RootI; use base qw(Bio::Root::RootI); =head2 seq_id Title : seq_id Usage : $ref = $s->seq_id Function: return the ID of the landmark Returns : a string Args : none Status : Public =cut sub seq_id { shift->throw_not_implemented } =head2 display_name Title : seq_name Usage : $ref = $s->seq_name Function: return the human-readable name for the landmark Returns : a string Args : none Status : Public This defaults to the same as seq_id. =cut sub display_name { shift->seq_id } =head2 start Title : start Usage : $s->start Function: start of segment Returns : integer Args : none Status : Public This is a read-only accessor for the start of the segment. Alias to low() for Gadfly compatibility. =cut sub start { shift->throw_not_implemented } sub low { shift->start } =head2 end Title : end Usage : $s->end Function: end of segment Returns : integer Args : none Status : Public This is a read-only accessor for the end of the segment. Alias to high() for Gadfly compatibility. =cut sub end { shift->throw_not_implemented } sub stop { shift->end } sub high { shift->end } =head2 length Title : length Usage : $s->length Function: length of segment Returns : integer Args : none Status : Public Returns the length of the segment. Always a positive number. =cut sub length { shift->throw_not_implemented; } =head2 seq Title : seq Usage : $s->seq Function: get the sequence string for this segment Returns : a string Args : none Status : Public Returns the sequence for this segment as a simple string. =cut sub seq {shift->throw_not_implemented} =head2 ref Title : ref Usage : $ref = $s->ref([$newlandmark]) Function: get/set the reference landmark for addressing Returns : a string Args : none Status : Public This method is used to examine/change the reference landmark used to establish the coordinate system. By default, the landmark cannot be changed and therefore this has the same effect as seq_id(). The new landmark might be an ID, or another Das::SegmentI object. =cut sub ref { shift->seq_id } *refseq = \&ref; =head2 absolute Title : absolute Usage : $s->absolute([$new_value]) Function: get/set absolute addressing mode Returns : flag Args : new flag (optional) Status : Public Turn on and off absolute-addressing mode. In absolute addressing mode, coordinates are relative to some underlying "top level" coordinate system (such as a chromosome). ref() returns the identity of the top level landmark, and start() and end() return locations relative to that landmark. In relative addressing mode, coordinates are relative to the landmark sequence specified at the time of segment creation or later modified by the ref() method. The default is to return false and to do nothing in response to attempts to set absolute addressing mode. =cut sub absolute { return } =head2 features Title : features Usage : @features = $s->features(@args) Function: get features that overlap this segment Returns : a list of Bio::SeqFeatureI objects Args : see below Status : Public This method will find all features that intersect the segment in a variety of ways and return a list of Bio::SeqFeatureI objects. The feature locations will use coordinates relative to the reference sequence in effect at the time that features() was called. The returned list can be limited to certain types, attributes or range intersection modes. Types of range intersection are one of: "overlaps" the default "contains" return features completely contained within the segment "contained_in" return features that completely contain the segment Two types of argument lists are accepted. In the positional argument form, the arguments are treated as a list of feature types. In the named parameter form, the arguments are a series of -name=Evalue pairs. Argument Description -------- ------------ -types An array reference to type names in the format "method:source" -attributes A hashref containing a set of attributes to match -rangetype One of "overlaps", "contains", or "contained_in". -iterator Return an iterator across the features. -callback A callback to invoke on each feature The -attributes argument is a hashref containing one or more attributes to match against: -attributes => { Gene => 'abc-1', Note => 'confirmed' } Attribute matching is simple string matching, and multiple attributes are ANDed together. More complex filtering can be performed using the -callback option (see below). If -iterator is true, then the method returns an object reference that implements the next_seq() method. Each call to next_seq() returns a new Bio::SeqFeatureI object. If -callback is passed a code reference, the code reference will be invoked on each feature returned. The code will be passed two arguments consisting of the current feature and the segment object itself, and must return a true value. If the code returns a false value, feature retrieval will be aborted. -callback and -iterator are mutually exclusive options. If -iterator is defined, then -callback is ignored. NOTE: the following methods all build on top of features(), and do not need to be explicitly implemented. overlapping_features() contained_features() contained_in() get_feature_stream() =cut sub features {shift->throw_not_implemented} =head2 overlapping_features Title : overlapping_features Usage : @features = $s->overlapping_features(@args) Function: get features that overlap this segment Returns : a list of Bio::SeqFeatureI objects Args : see below Status : Public This method is identical to features() except that it defaults to finding overlapping features. =cut sub overlapping_features { my $self = shift; my @args = $_[0] =~ /^-/ ? (@_, -rangetype=>'overlaps') : (-types=>\@_,-rangetype=>'overlaps'); $self->features(@args); } =head2 contained_features Title : contained_features Usage : @features = $s->contained_features(@args) Function: get features that are contained in this segment Returns : a list of Bio::SeqFeatureI objects Args : see below Status : Public This method is identical to features() except that it defaults to a range type of 'contained'. =cut sub contained_features { my $self = shift; my @args = $_[0] =~ /^-/ ? (@_, -rangetype=>'contained') : (-types=>\@_,-rangetype=>'contained'); $self->features(@args); } =head2 contained_in Title : contained_in Usage : @features = $s->contained_in(@args) Function: get features that contain this segment Returns : a list of Bio::SeqFeatureI objects Args : see below Status : Public This method is identical to features() except that it defaults to a range type of 'contained_in'. =cut sub contained_in { my $self = shift; my @args = $_[0] =~ /^-/ ? (@_, -rangetype=>'contained_in') : (-types=>\@_,-rangetype=>'contained_in'); $self->features(@args); } =head2 get_feature_stream Title : get_feature_stream Usage : $iterator = $s->get_feature_stream(@args) Function: get an iterator across the segment Returns : an object that implements next_seq() Args : see below Status : Public This method is identical to features() except that it always generates an iterator. NOTE: This is defined in the interface in terms of features(). You do not have to implement it. =cut sub get_feature_stream { my $self = shift; my @args = defined $_[0] && $_[0] =~ /^-/ ? (@_, -iterator=>1) : (-types=>\@_,-iterator=>1); $self->features(@args); } =head2 factory Title : factory Usage : $factory = $s->factory Function: return the segment factory Returns : a Bio::DasI object Args : see below Status : Public This method returns a Bio::DasI object that can be used to fetch more segments. This is typically the Bio::DasI object from which the segment was originally generated. =cut #' sub factory {shift->throw_not_implemented} =head2 primary_tag Title : primary_tag Usage : $tag = $s->primary_tag Function: identifies the segment as type "DasSegment" Returns : a string named "DasSegment" Args : none Status : Public, but see below This method provides Bio::Das::Segment objects with a primary_tag() field that identifies them as being of type "DasSegment". This allows the Bio::Graphics engine to render segments just like a feature in order nis way useful. This does not need to be implemented. It is defined by the interface. =cut #' sub primary_tag {"DasSegment"} =head2 strand Title : strand Usage : $strand = $s->strand Function: identifies the segment strand as 0 Returns : the number 0 Args : none Status : Public, but see below This method provides Bio::Das::Segment objects with a strand() field that identifies it as being strandless. This allows the Bio::Graphics engine to render segments just like a feature in order nis way useful. This does not need to be implemented. It is defined by the interface. =cut sub strand { 0 } 1; BioPerl-1.6.923/Bio/DB000755000765000024 012254227340 14276 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/Ace.pm000444000765000024 1127412254227327 15513 0ustar00cjfieldsstaff000000000000 # # BioPerl module for Bio::DB::Ace # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Ace - Database object interface to ACeDB servers =head1 SYNOPSIS $db = Bio::DB::Ace->new( -server => 'myace.server.com', port => '120000'); $seq = $db->get_Seq_by_id('J00522'); # Unique ID # or ... $seq = $db->get_Seq_by_acc('J00522'); # Accession Number =head1 DESCRIPTION This provides a standard BioPerl database access to Ace, using Lincoln Steins excellent AcePerl module. You need to download and install the aceperl module from http://stein.cshl.org/AcePerl/ before this interface will work. This interface is designed at the moment to work through a aceclient/aceserver type mechanism =head1 INSTALLING ACEPERL Download the latest aceperl tar file, gunzip/untar and cd into the directory. This is a standard CPAN-style directory, so if you go Perl Makefile.PL make make install Then you will have installed Aceperl. Use the PREFIX mechanism to install elsewhere. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Ace; use strict; # Object preamble - inherits from Bio::DB::RandomAccessI use Bio::Seq; BEGIN { eval "require Ace;"; if( $@) { print STDERR "You have not installed Ace.pm.\n Read the docs in Bio::DB::Ace for more information about how to do this.\n It is very easy\n\nError message $@"; } } use base qw(Bio::DB::RandomAccessI); # new() is inherited from Bio::DB::Abstract # _initialize is where the heavy stuff will happen when new is called sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($host,$port) = $self->_rearrange([qw( HOST PORT )], @args, ); if( !$host || !$port ) { $self->throw("Must have a host and port for an acedb server to work"); } my $aceobj = Ace->connect(-host => $host, -port => $port) || $self->throw("Could not make acedb object to $host:$port"); $self->_aceobj($aceobj); return $self; } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id($uid); Function: Gets a Bio::Seq object by its unique identifier/name Returns : a Bio::Seq object Args : $id : the id (as a string) of the desired sequence entry =cut sub get_Seq_by_id { my $self = shift; my $id = shift or $self->throw("Must supply an identifier!\n"); my $ace = $self->_aceobj(); my ($seq,$dna,$out); $seq = $ace->fetch( 'Sequence' , $id); # get out the sequence somehow! $dna = $seq->asDNA(); $dna =~ s/^>.*\n//; $dna =~ s/\n//g; $out = Bio::Seq->new( -id => $id, -alphabet => 'Dna', -seq => $dna, -name => "Sequence from Bio::DB::Ace $id"); return $out; } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc($acc); Function: Gets a Bio::Seq object by its accession number Returns : a Bio::Seq object Args : $acc : the accession number of the desired sequence entry =cut sub get_Seq_by_acc { my $self = shift; my $acc = shift or $self->throw("Must supply an accession number!\n"); return $self->get_Seq_by_id($acc); } =head2 _aceobj Title : _aceobj Usage : $ace = $db->_aceobj(); Function: Get/Set on the acedb object Returns : Ace object Args : New value of the ace object =cut sub _aceobj { my ($self,$arg) = @_; if( $arg ) { $self->{'_aceobj'} = $arg; } return $self->{'_aceobj'}; } 1; BioPerl-1.6.923/Bio/DB/BioFetch.pm000444000765000024 3345712254227330 16507 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::BioFetch # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # package Bio::DB::BioFetch; use strict; use HTTP::Request::Common 'POST'; =head1 NAME Bio::DB::BioFetch - Database object interface to BioFetch retrieval =head1 SYNOPSIS use Bio::DB::BioFetch; $bf = Bio::DB::BioFetch->new(); $seq = $bf->get_Seq_by_id('BUM'); # EMBL or SWALL ID # change formats, storage procedures $bf = Bio::DB::BioFetch->new(-format => 'fasta', -retrievaltype => 'tempfile', -db => 'EMBL'); $stream = $bf->get_Stream_by_id(['BUM','J00231']); while (my $s = $stream->next_seq) { print $s->seq,"\n"; } # get a RefSeq entry $bf->db('refseq'); eval { $seq = $bf->get_Seq_by_version('NM_006732.1'); # RefSeq VERSION }; print "accession is ", $seq->accession_number, "\n" unless $@; =head1 DESCRIPTION Bio::DB::BioFetch is a guaranteed best effort sequence entry fetching method. It goes to the Web-based dbfetch server located at the EBI (http://www.ebi.ac.uk/Tools/dbfetch/dbfetch) to retrieve sequences in the EMBL or GenBank sequence repositories. This module implements all the Bio::DB::RandomAccessI interface, plus the get_Stream_by_id() and get_Stream_by_acc() methods that are found in the Bio::DB::SwissProt interface. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email Lincoln Stein Elstein@cshl.orgE Also thanks to Heikki Lehvaslaiho Eheikki-at-bioperl-dot-orgE for the BioFetch server and interface specification. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... use vars qw(%FORMATMAP); use base qw(Bio::DB::WebDBSeqI Bio::Root::Root); # warning: names used here must map into Bio::SeqIO::* space use constant DEFAULT_LOCATION => 'http://www.ebi.ac.uk/Tools/dbfetch/dbfetch'; BEGIN { %FORMATMAP = ( 'embl' => { default => 'embl', # default BioFetch format/SeqIOmodule pair embl => 'embl', # alternative BioFetch format/module pair fasta => 'fasta', # alternative BioFetch format/module pair namespace => 'embl', }, 'swissprot' => { default => 'swiss', swissprot => 'swiss', fasta => 'fasta', namespace => 'uniprot', }, 'refseq' => { default => 'genbank', genbank => 'genbank', fasta => 'fasta', namespace => 'RefSeq', }, 'swall' => { default => 'swiss', swissprot => 'swiss', fasta => 'fasta', namespace => 'uniprot', }, 'uniprot' => { default => 'swiss', swissprot => 'swiss', fasta => 'fasta', namespace => 'uniprot', }, 'genbank' => { default => 'genbank', genbank => 'genbank', namespace => 'genbank', }, 'genpep' => { default => 'genbank', genbank => 'genbank', namespace => 'genpep', }, 'unisave' => { default => 'swiss', swissprot => 'swiss', fasta => 'fasta', namespace => 'unisave', } ); } =head2 new Title : new Usage : $bf = Bio::DB::BioFetch->new(@args) Function: Construct a new Bio::DB::BioFetch object Returns : a Bio::DB::BioFetch object Args : see below Throws : @args are standard -name=Evalue options as listed in the following table. If you do not provide any options, the module assumes reasonable defaults. Option Value Default ------ ----- ------- -baseaddress location of dbfetch server http://www.ebi.ac.uk/Tools/dbfetch/dbfetch -retrievaltype "tempfile" or "io_string" io_string -format "embl", "fasta", "swissprot", embl or "genbank" -db "embl", "genbank" or "swissprot" embl =cut #' sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($db) = $self->_rearrange([qw(DB)],@args); $db ||= $self->default_db; $self->db($db); $self->url_base_address(DEFAULT_LOCATION) unless $self->url_base_address; $self; } =head2 new_from_registry Title : new_from_registry Usage : $biofetch = $db->new_from_registry(%config) Function: Creates a BioFetch object from the registry config hash Returns : itself Args : A configuration hash (see Registry.pm) Throws : =cut sub new_from_registry { my ($class,%config)=@_; my $self = $class->SUPER::new( -BASEADDRESS=>$config{'location'} ); $self->db($config{'dbname'}) if $config{dbname}; return $self; } # from Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =cut =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut =head2 get_Seq_by_gi Title : get_Seq_by_gi Usage : $seq = $db->get_Seq_by_gi('405830'); Function: Gets a Bio::Seq object by gi number Returns : A Bio::Seq object Args : gi number (as a string) Throws : "gi does not exist" exception =cut =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Seq_by_version { my ($self,$seqid) = @_; return $self->get_Seq_by_acc($seqid); } =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id( [$uid1, $uid2] ); Function: Gets a series of Seq objects by unique identifiers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of unique identifiers for the desired sequence entries =cut =head2 get_Stream_by_gi Title : get_Stream_by_gi Usage : $seq = $db->get_Seq_by_gi([$gi1, $gi2]); Function: Gets a series of Seq objects by gi numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of gi numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut =head2 get_Stream_by_batch Title : get_Stream_by_batch Usage : $seq = $db->get_Stream_by_batch($ref); Function: Get a series of Seq objects by their IDs Example : Returns : a Bio::SeqIO stream object Args : $ref : an array reference containing a list of unique ids/accession numbers. In some of the Bio::DB::* moduels, get_Stream_by_id() is called get_Stream_by_batch(). Since there seems to be no consensus, this is provided as an alias. =cut *get_Stream_by_batch = \&Bio::DB::WebDBSeqI::get_Stream_by_id; =head1 The remainder of these methods are for internal use =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: returns a HTTP::Request object Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =cut sub get_request { my ($self, @qualifiers) = @_; my ($uids, $format) = $self->_rearrange([qw(UIDS FORMAT)], @qualifiers); my $db = $self->db; my $namespace = $self->_namespace; $self->throw("Must specify a value for UIDs to fetch") unless defined $uids; my $tmp; my $format_string = ''; $format ||= $self->default_format; ($format, $tmp) = $self->request_format($format); my $base = $self->url_base_address; my $uid = join('+',ref $uids ? @$uids : $uids); $self->debug("\n$base$format_string&id=$uid\n"); return POST($base, [ db => $namespace, id => join('+',ref $uids ? @$uids : $uids), format => $format, style => 'raw' ]); } =head2 default_format Title : default_format Usage : $format = $self->default_format Function: return the default format Returns : a string Args : =cut sub default_format { return 'default'; } =head2 default_db Title : default_db Usage : $db = $self->default_db Function: return the default database Returns : a string Args : =cut sub default_db { 'embl' } =head2 db Title : db Usage : $db = $self->db([$db]) Function: get/set the database Returns : a string Args : new database =cut sub db { my $self = shift; if (@_) { my $db = lc shift; my $base = $self->url_base_address; $FORMATMAP{$db} or $self->throw("invalid db [$db] at [$base], must be one of [". join(' ',keys %FORMATMAP). "]"); $self->{_db} = $db; } return $self->{_db} || $self->default_db ; } sub _namespace { my $self = shift; my $db = $self->db; return $FORMATMAP{$db}{namespace} or $db; } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data ( 'type' => 'string', 'location' => \$datastr); Function: process downloaded data before loading into a Bio::SeqIO Returns : void Args : hash with two keys - 'type' can be 'string' or 'file' - 'location' either file location or string reference containing data =cut sub postprocess_data { my ($self,%args) = @_; # check for errors in the stream if ($args{'type'} eq 'string') { my $stringref = $args{'location'}; if ($$stringref =~ /^ERROR (\d+) (.+)/m) { $self->throw("BioFetch Error $1: $2"); } } elsif ($args{'type'} eq 'file') { open (F,$args{'location'}) or $self->throw("Couldn't open $args{location}: $!"); # this is dumb, but the error may be anywhere on the first three lines because the # CGI headers are sometimes printed out by the server... my @data = grep {defined $_} (scalar ,scalar ,scalar ); if (join('',@data) =~ /^ERROR (\d+) (.+)/m) { $self->throw("BioFetch Error $1: $2"); } close F; } else { $self->throw("Don't know how to postprocess data of type $args{'type'}"); } } =head2 request_format Title : request_format Usage : my ($req_format, $ioformat) = $self->request_format; $self->request_format("genbank"); $self->request_format("fasta"); Function: Get/Set sequence format retrieval. The get-form will normally not be used outside of this and derived modules. Returns : Array of two strings, the first representing the format for retrieval, and the second specifying the corresponding SeqIO format. Args : $format = sequence format =cut sub request_format { my ($self, $value) = @_; if ( defined $value ) { my $db = $self->db; my $namespace = $self->_namespace; my $format = lc $value; print "format:", $format, " module:", $FORMATMAP{$db}->{$format}, " ($namespace)\n" if $self->verbose > 0; $self->throw("Invalid format [$format], must be one of [". join(' ',keys %{$FORMATMAP{$db}}). "]") unless $format eq 'default' || $FORMATMAP{$db}->{$format}; $self->{'_format'} = [ $format, $FORMATMAP{$db}->{$format}]; } return @{$self->{'_format'}}; } =head2 Bio::DB::WebDBSeqI methods Overriding WebDBSeqI method to help newbies to retrieve sequences. EMBL database is all too often passed RefSeq accessions. This redirects those calls. See L. =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Seq_by_acc([$acc1, $acc2]); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries =cut sub get_Stream_by_acc { my ($self, $ids ) = @_; $self->_check_id($ids); return $self->get_seq_stream('-uids' => $ids, '-mode' => 'single'); } =head2 _check_id Title : _check_id Usage : Function: Throw on whole chromosome NCBI sequences not in sequence databases and redirect RefSeq accession requests sent to EMBL. Returns : Args : $id(s), $string Throws : if accessionn number indicates whole chromosome NCBI sequence =cut sub _check_id { my ($self, $id) = @_; # NT contigs can not be retrieved $self->throw("NT_ contigs are whole chromosome files which are not part of regular ". "database distributions. Go to ftp://ftp.ncbi.nih.gov/genomes/.") if $id =~ /NT_/; # Asking for a RefSeq from EMBL/GenBank if ($id =~ /N._/ && $self->db ne 'refseq') { $self->warn("[$id] is not a normal sequence entry but a RefSeq entry.". " Redirecting the request.\n") if $self->verbose >= 0; $self->db('RefSeq'); } } 1; BioPerl-1.6.923/Bio/DB/CUTG.pm000555000765000024 2041212254227332 15556 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::CUTG # # Please direct questions and support issues to # # Cared for by Richard Adams (richard.adams@ed.ac.uk) # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::CUTG - for access to the Codon usage Database at http://www.kazusa.or.jp/codon. =head1 SYNOPSIS use Bio::CodonUsage::Table; use Bio::DB::CUTG; my $db = Bio::DB::CUTG->new(-sp =>'Pan troglodytes'); my $CUT = $db->get_request(); =head1 DESCRIPTION This class retrieves and objectifies codon usage tables either from the CUTG web database . The idea is that you can initially retrieve a CUT from the web database, and write it to file in a way that can be read in later, using the Bio::CodonUsage::IO module. For a web query, two parameters need to be specified: species(sp) and genetic code id (gc). The database is searched using regular expressions, therefore the full latin name must be given to specify the organism. If the species name is ambiguous the first CUT in the list is retrieved. Defaults are Homo sapiens and 1(standard genetic code). If you are retrieving CUTs from organisms using other genetic codes this needs to be put in as a parameter. Parameters can be entered in the constructor or in the get_web_request ()method. Allowable parameters are listed in the $QUERY_KEYS hash reference variable. I intend at a later date to allow retrieval of multiple codon tables e.g., from a wildcard search. Examples URLs: L L =head1 SEE ALSO L, L, L, L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::CUTG; use Bio::CodonUsage::IO; use IO::String; use URI::Escape; use vars qw($URL $QUERY_KEYS); use base qw(Bio::WebAgent); $QUERY_KEYS = { sp => 'full Latin species name', gc => 'genetic code id' }; BEGIN { $URL = "http://www.kazusa.or.jp"; } =head2 new Title : new Usage : my $db = Bio::DB::CUTG->new() Returns : a reference to a new Bio::DB::CUTG Args : hash of optional values for db query =cut sub new { my ( $class, @args ) = @_; _check_args(@args); my $self = $class->SUPER::new(@args); return $self; } =head2 query_keys Title : query_keys Usage : $db->query_keys() Purpose : To determine valid keys for parameters for db query. Returns : a reference to a hash describing valid query keys Args : none =cut sub query_keys { return $QUERY_KEYS; } =head2 sp Title : sp Usage : my $sp = $db->sp(); Purpose: Get/set method for species name Returns: void or species name string Args : None or species name string =cut sub sp { my $self = shift; if (@_) { my $name = shift; $self->{'_sp'} = $name; } return $self->{'_sp'} || "Homo sapiens"; } =head2 gc Title : gc Usage : my $gc = $db->gc(); Purpose: Get/set method for genetic code id Returns: void or genetic code integer Args : None or genetic code integer =cut sub gc { #### genetic code id for translations #### my $self = shift; if (@_) { if ( $_[0] =~ /^\d+$/ && $_[0] >= 1 && $_[0] <= 15 && $_[0] != 7 && $_[0] != 8 ) { $self->{'_gc'} = shift; } else { $self->warn( "invalid genetic code index - setting to standard default (1)"); $self->{'_gc'} = 1; } } return $self->{'_gc'} || 1; #return 1 if not defined } =head2 get_request Title : get_request Usage : my $cut = $db->get_request(); Purpose: To query remote CUT with a species name Returns: a new codon usage table object Args : species name(mandatory), genetic code id(optional) =cut sub get_request { my ( $self, @args ) = @_; _check_args(@args); shift; ### can put in parameters here as well while (@_) { my $key = shift; $key =~ s/^-//; $self->$key(shift); } $self->url($URL); ###1st of all search DB to check species exists and is unique my $nameparts = join "+", $self->sp =~ /(\S+)/g; my $search_url = $self->url . "/codon/cgi-bin/spsearch.cgi?species=" . $nameparts . "&c=s"; my $rq = HTTP::Request->new( GET => $search_url ); my $reply = $self->request($rq); if ( $reply->is_error ) { $self->throw( $reply->as_string() . "\nError getting for url $search_url!\n" ); } my $content = $reply->content; return 0 unless $content; $self->debug(" reply from query is \n $content"); ##### if no matches, assign defaults - or can throw here? ###### if ( $content =~ /not found/i ) { $self->warn("organism not found -selecting human [9606] as default"); $self->sp("9606"); $self->_db("gbpri"); } else { my @names = $content =~ /species=([^"]+)/g; ### get 1st species data from report #### my @dbs = $content =~ /\[([^\]]+)\]:\s+\d+/g; ## warn if more than 1 matching species ## ## if multiple species retrieved, choose first one by default ## $self->throw("No names returned for $nameparts") unless @names; if ( @names > 1 ) { $self->warn( "too many species - not a unique species id\n" . "selecting $names[0] using database [$dbs[0]]" ); } ### now assign species and database value $self->sp( $names[0] ); $self->_db( $dbs[0] ); } ######## now get codon table , all defaults established now ##construct URL## $nameparts = $self->sp; my $CT_url = $self->url . "/codon/cgi-bin/showcodon.cgi?species=" . $nameparts . "&aa=" . $self->gc . "&style=GCG"; $self->debug("URL : $CT_url\n"); ## retrieve data in html## my $rq2 = HTTP::Request->new( GET => $CT_url ); $reply = $self->request($rq2); if ( $reply->is_error ) { $self->throw( $reply->as_string() . "\nError getting for url $CT_url!\n" ); } my $content2 = $reply->content; ## strip html tags, basic but works here $content2 =~ s/<[^>]+>//sg; $content2 =~ s/Format.*//sg; $self->debug("raw DDB table is :\n $content2"); ### and pass to Bio::CodonUsage::IO for parsing my $iostr = IO::String->new($content2); my $io = Bio::CodonUsage::IO->new( -fh => $iostr ); ##return object ## return $io->next_data; } sub _check_args { ###checks parameters for matching $QUERYKEYS my @args = @_; while ( my $key = shift @args ) { $key = lc($key); $key =~ s/\-//; if ( !exists( $QUERY_KEYS->{$key} ) ) { Bio::Root::Root->throw( "invalid parameter - must be one of [" . ( join "] [", keys %$QUERY_KEYS ) . "]" ); } shift @args; } } #### internal URL parameter not specifiable ###### sub _db { my $self = shift; if (@_) { $self->{'_db'} = shift; } return $self->{'_db'}; } 1; BioPerl-1.6.923/Bio/DB/DBFetch.pm000444000765000024 2320712254227313 16254 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::DBFetch # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::DBFetch - Database object for retrieving using the dbfetch script =head1 SYNOPSIS #do not use this module directly =head1 DESCRIPTION Allows the dynamic retrieval of entries from databases using the dbfetch script at EBI: LEwww.ebi.ac.ukEcgi-binEdbfetch>. In order to make changes transparent we have host type (currently only ebi) and location (defaults to ebi) separated out. This allows later additions of more servers in different geographical locations. This is a superclass which is called by instantiable subclasses with correct parameters. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email Heikki Lehvaslaiho Eheikki-at-bioperl-dot-orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::DBFetch; use strict; use vars qw($MODVERSION $DEFAULTFORMAT $DEFAULTLOCATION $DEFAULTSERVERTYPE); $MODVERSION = '0.1'; use HTTP::Request::Common; use base qw(Bio::DB::WebDBSeqI); # the new way to make modules a little more lightweight BEGIN { # global vars $DEFAULTSERVERTYPE = 'dbfetch'; $DEFAULTLOCATION = 'ebi'; } =head1 Routines from Bio::DB::WebDBSeqI =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: returns a HTTP::Request object Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =cut sub get_request { my ($self, @qualifiers) = @_; my ($uids, $format) = $self->_rearrange([qw(UIDS FORMAT)], @qualifiers); $self->throw("Must specify a value for UIDs to fetch") unless defined $uids; my $tmp; my $format_string = ''; $format ||= $self->default_format; ($format, $tmp) = $self->request_format($format); $format_string = "&format=$format"; my $url = $self->location_url(); my $uid; if( ref($uids) =~ /ARRAY/i ) { $uid = join (',', @$uids); $self->warn ('The server will accept maximum of 50 entries in a request. The rest are ignored.') if scalar @$uids >50; } else { $uid = $uids; } return GET $url. $format_string. '&id='. $uid; } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data ( 'type' => 'string', 'location' => \$datastr); Function: process downloaded data before loading into a Bio::SeqIO Returns : void Args : hash with two keys - 'type' can be 'string' or 'file' - 'location' either file location or string reference containing data =cut # remove occasional blank lines at top of web output sub postprocess_data { my ($self, %args) = @_; if ($args{type} eq 'string') { ${$args{location}} =~ s/^\s+//; # get rid of leading whitespace } elsif ($args{type} eq 'file') { my $F; open $F,"<", $args{location} or $self->throw("Cannot open $args{location}: $!"); my @data = <$F>; for (@data) { last unless /^\s+$/; shift @data; } open $F,">", $args{location} or $self->throw("Cannot write to $args{location}: $!"); print $F @data; close $F; } } =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: Returns default sequence format for this module Returns : string Args : none =cut sub default_format { my ($self) = @_; return $self->{'_default_format'}; } =head1 Bio::DB::DBFetch specific routines =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $seq = $db->get_Stream_by_id($ref); Function: Retrieves Seq objects from the server 'en masse', rather than one at a time. For large numbers of sequences, this is far superior than get_Stream_by_[id/acc](). Example : Returns : a Bio::SeqIO stream object Args : $ref : either an array reference, a filename, or a filehandle from which to get the list of unique ids/accession numbers. NOTE: for backward compatibility, this method is also called get_Stream_by_batch. =cut sub get_Stream_by_id { my ($self, $ids) = @_; return $self->get_seq_stream('-uids' => $ids, '-mode' => 'batch'); } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : version number (as a string) Throws : "version does not exist" exception =cut sub get_Seq_by_version { my ($self,$seqid) = @_; my $seqio = $self->get_Stream_by_acc([$seqid]); $self->throw("version does not exist") if( !defined $seqio ); return $seqio->next_seq(); } =head2 request_format Title : request_format Usage : my ($req_format, $ioformat) = $self->request_format; $self->request_format("genbank"); $self->request_format("fasta"); Function: Get/Set sequence format retrieval. The get-form will normally not be used outside of this and derived modules. Returns : Array of two strings, the first representing the format for retrieval, and the second specifying the corresponding SeqIO format. Args : $format = sequence format =cut sub request_format { my ($self, $value) = @_; if( defined $value ) { $value = lc $value; $self->{'_format'} = $value; return ($value, $value); } $value = $self->{'_format'}; if( $value and defined $self->formatmap->{$value} ) { return ($value, $self->formatmap->{$value}); } else { # Try to fall back to a default. return ($self->default_format, $self->default_format ); } } =head2 servertype Title : servertype Usage : my $servertype = $self->servertype $self->servertype($servertype); Function: Get/Set server type Returns : string Args : server type string [optional] =cut sub servertype { my ($self, $servertype) = @_; if( defined $servertype && $servertype ne '') { $self->throw("You gave an invalid server type ($servertype)". " - available types are ". keys %{$self->hosts}) unless( $self->hosts->{$servertype} ); $self->{'_servertype'} = $servertype; } $self->{'_servertype'} = $DEFAULTSERVERTYPE unless $self->{'_servertype'}; return $self->{'_servertype'}; } =head2 hostlocation Title : hostlocation Usage : my $location = $self->hostlocation() $self->hostlocation($location) Function: Set/Get Hostlocation Returns : string representing hostlocation Args : string specifying hostlocation [optional] =cut sub hostlocation { my ($self, $location ) = @_; my $servertype = $self->servertype; $self->throw("Must have a valid servertype defined not $servertype") unless defined $servertype; my %hosts = %{$self->hosts->{$servertype}->{'hosts'}}; if( defined $location && $location ne '' ) { $location = lc $location; if( ! $hosts{$location} ) { $self->throw("Must specify a known host, not $location,". " possible values (". join(",", sort keys %hosts ). ")"); } $self->{'_hostlocation'} = $location; } $self->{'_hostlocation'} = $DEFAULTLOCATION unless $self->{'_hostlocation'}; return $self->{'_hostlocation'}; } =head2 location_url Title : location Usage : my $url = $self->location_url() Function: Get host url Returns : string representing url Args : none =cut sub location_url { my ($self) = @_; my $servertype = $self->servertype(); my $location = $self->hostlocation(); if( ! defined $location || !defined $servertype ) { $self->throw("must have a valid hostlocation and servertype set before calling location_url"); } return sprintf($self->hosts->{$servertype}->{'baseurl'}, $self->hosts->{$servertype}->{'hosts'}->{$location}); } =head1 Bio::DB::DBFetch routines These methods allow subclasses to pass parameters. =head2 hosts Title : hosts Usage : Function: get/set for host hash Returns : Args : optional hash =cut sub hosts { my ($self, $value) = @_; if (defined $value) { $self->{'_hosts'} = $value; } unless (exists $self->{'_hosts'}) { return (''); } else { return $self->{'_hosts'}; } } =head2 formatmap Title : formatmap Usage : Function: get/set for format hash Returns : Args : optional hash =cut sub formatmap { my ($self, $value) = @_; if (defined $value) { $self->{'_formatmap'} = $value; } unless (exists $self->{'_formatmap'}) { return (''); } else { return $self->{'_formatmap'}; } } 1; __END__ BioPerl-1.6.923/Bio/DB/EMBL.pm000444000765000024 1341012254227314 15530 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::EMBL # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::EMBL - Database object interface for EMBL entry retrieval =head1 SYNOPSIS use Bio::DB::EMBL; $embl = Bio::DB::EMBL->new(); # remember that EMBL_ID does not equal GenBank_ID! $seq = $embl->get_Seq_by_id('BUM'); # EMBL ID print "cloneid is ", $seq->id, "\n"; # or changeing to accession number and Fasta format ... $embl->request_format('fasta'); $seq = $embl->get_Seq_by_acc('J02231'); # EMBL ACC print "cloneid is ", $seq->id, "\n"; # especially when using versions, you better be prepared # in not getting what what want eval { $seq = $embl->get_Seq_by_version('J02231.1'); # EMBL VERSION }; print "cloneid is ", $seq->id, "\n" unless $@; # or ... best when downloading very large files, prevents # keeping all of the file in memory # also don't want features, just sequence so let's save bandwith # and request Fasta sequence $embl = Bio::DB::EMBL->new(-retrievaltype => 'tempfile' , -format => 'fasta'); my $seqio = $embl->get_Stream_by_id(['AC013798', 'AC021953'] ); while( my $clone = $seqio->next_seq ) { print "cloneid is ", $clone->id, "\n"; } =head1 DESCRIPTION Allows the dynamic retrieval of sequence objects L from the EMBL database using the dbfetch script at EBI: L. In order to make changes transparent we have host type (currently only ebi) and location (defaults to ebi) separated out. This allows later additions of more servers in different geographical locations. The functionality of this module is inherited from L which implements L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email Heikki Lehvaslaiho Eheikki-at-bioperl-dot-orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::EMBL; use strict; use vars qw($MODVERSION %HOSTS %FORMATMAP $DEFAULTFORMAT); $MODVERSION = '0.2'; use Bio::DB::RefSeq; use base qw(Bio::DB::DBFetch); BEGIN { # you can add your own here theoretically. %HOSTS = ( 'dbfetch' => { baseurl => 'http://%s/Tools/dbfetch/dbfetch?db=embl&style=raw', hosts => { 'ebi' => 'www.ebi.ac.uk' } } ); %FORMATMAP = ( 'embl' => 'embl', 'fasta' => 'fasta' ); $DEFAULTFORMAT = 'embl'; } =head2 new Title : new Usage : $gb = Bio::DB::GenBank->new(@options) Function: Creates a new genbank handle Returns : New genbank handle Args : -delay number of seconds to delay between fetches (3s) NOTE: There are other options that are used internally. =cut sub new { my ($class, @args ) = @_; my $self = $class->SUPER::new(@args); $self->{ '_hosts' } = {}; $self->{ '_formatmap' } = {}; $self->hosts(\%HOSTS); $self->formatmap(\%FORMATMAP); $self->{'_default_format'} = $DEFAULTFORMAT; return $self; } =head2 Bio::DB::WebDBSeqI methods Overriding WebDBSeqI method to help newbies to retrieve sequences. EMBL database is all too often passed RefSeq accessions. This redirects those calls. See L. =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Seq_by_acc([$acc1, $acc2]); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut sub get_Stream_by_acc { my ($self, $ids ) = @_; my $newdb = $self->_check_id($ids); if ($newdb && $newdb->isa('Bio::DB::RefSeq')) { return $newdb->get_seq_stream('-uids' => $ids, '-mode' => 'single'); } else { return $self->get_seq_stream('-uids' => $ids, '-mode' => 'single'); } } =head2 _check_id Title : _check_id Usage : Function: Returns : A Bio::DB::RefSeq reference or throws Args : $id(s), $string =cut sub _check_id { my ($self, $ids) = @_; # NT contigs can not be retrieved $self->throw("NT_ contigs are whole chromosome files which are not part of regular". "database distributions. Go to ftp://ftp.ncbi.nih.gov/genomes/.") if $ids =~ /NT_/; # Asking for a RefSeq from EMBL/GenBank if ($ids =~ /N._/) { $self->warn("[$ids] is not a normal sequence entry but a RefSeq entry.". " Redirecting the request.\n") if $self->verbose >= 0; return Bio::DB::RefSeq->new(-verbose => $self->verbose); } } 1; BioPerl-1.6.923/Bio/DB/EntrezGene.pm000444000765000024 1264512254227332 17070 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::EntrezGene # # Please direct questions and support issues to # # Cared for by Brian Osborne bosborne at alum.mit.edu # # Copyright Brian Osborne # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::EntrezGene - Database object interface to Entrez Gene =head1 SYNOPSIS use Bio::DB::EntrezGene; my $db = Bio::DB::EntrezGene->new; my $seq = $db->get_Seq_by_id(2); # Gene id # or ... my $seqio = $db->get_Stream_by_id([2, 4693, 3064]); # Gene ids while ( my $seq = $seqio->next_seq ) { print "id is ", $seq->display_id, "\n"; } =head1 DESCRIPTION Allows the dynamic retrieval of Sequence objects from the Entrez Gene database at NCBI, via an Entrez query using Gene ids. This module requires the CPAN Bio::ASN1 module. WARNING: Please do NOT spam the Entrez web server with multiple requests. NCBI offers Batch Entrez for this purpose. =head1 NOTES The Entrez eutils API does not allow Entrez Gene queries by name as of this writing, therefore there are only get_Seq_by_id and get_Stream_by_id methods in this module, and these expect Gene ids. There are no get_Seq_by_acc or get_Stream_by_acc methods. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Brian Osborne Email bosborne at alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::EntrezGene; use strict; use vars qw($DEFAULTFORMAT $DEFAULTMODE %PARAMSTRING); use base qw(Bio::DB::NCBIHelper); BEGIN { $DEFAULTMODE = 'single'; $DEFAULTFORMAT = 'asn.1'; %PARAMSTRING = ('batch' => {'db' => 'gene', 'usehistory' => 'y', 'tool' => 'bioperl', 'retmode' => 'asn.1'}, 'gi' => {'db' => 'gene', 'usehistory' => 'y', 'tool' => 'bioperl', 'retmode' => 'asn.1'}, 'version' => {'db' => 'gene', 'usehistory' => 'y', 'tool' => 'bioperl', 'retmode' => 'asn.1'}, 'single' => {'db' => 'gene', 'usehistory' => 'y', 'tool' => 'bioperl', 'retmode' => 'asn.1'} ); } # the new way to make modules a little more lightweight sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); # Seems that Bio::SeqIO::entrezgene requires this: $self->{_retrieval_type} = "tempfile"; $self->request_format($self->default_format); return $self; } =head2 get_params Title : get_params Usage : my %params = $self->get_params($mode) Function: Returns key,value pairs to be passed to NCBI database for either 'batch' or 'single' sequence retrieval method Returns : A key,value pair hash Args : 'single' or 'batch' mode for retrieval =cut sub get_params { my ($self, $mode) = @_; return defined $PARAMSTRING{$mode} ? %{$PARAMSTRING{$mode}} : %{$PARAMSTRING{$DEFAULTMODE}}; } =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: Returns default sequence format for this module Returns : string Args : none =cut sub default_format { return $DEFAULTFORMAT; } # from Bio::DB::WebDBSeqI from Bio::DB::RandomAccessI =head1 Routines from Bio::DB::WebDBSeqI and Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id(2) Function: Gets a Bio::Seq object by its name Returns : A Bio::Seq object Args : Gene id Throws : "id does not exist" exception =head1 Routines implemented by Bio::DB::NCBIHelper =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: HTTP::Request Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id( [$gid1, $gid2] ); Function: Gets a series of Seq objects using Gene ids Returns : A Bio::SeqIO stream object Args : A reference to an array of Gene ids =head2 request_format Title : request_format Usage : my $format = $self->request_format; $self->request_format($format); Function: Get or set sequence format retrieval Returns : String representing format Args : $format = sequence format =cut # override to force format sub request_format { my ($self) = @_; return $self->SUPER::request_format($self->default_format()); } 1; __END__ BioPerl-1.6.923/Bio/DB/Expression.pm000444000765000024 1045412254227327 17161 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Expression # # Please direct questions and support issues to # # Cared for by Allen Day # # Copyright Allen Day # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Expression - DESCRIPTION of Object =head1 SYNOPSIS use Bio::DB::Expression; my $db = Bio::DB::Expression->new( -source => 'geo' ); my @platforms = $db->get_platforms(); foreach my $platform ( @platforms ) { my @datasets = $platform->get_datasets(); foreach my $dataset ( @datasets ) { my @samples = $dataset->get_samples(); foreach my $sample ( @samples ) { #... } } } =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Allen Day Email allenday@ucla.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Expression; use strict; use base qw(Bio::Root::HTTPget Bio::Root::Root); use Bio::Root::HTTPget; our $DefaultSource = 'geo'; =head2 new() Usage : my $obj = Bio::DB::Expression->new(); Function: Builds a new Bio::DB::Expression object Returns : an instance of Bio::DB::Expression Args : =cut sub new { my($class,@args) = @_; if( $class =~ /Bio::DB::Expression::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $source = $param{'-source'} || $DefaultSource; $source = "\L$source"; # normalize capitalization to lower case # normalize capitalization return unless( $class->_load_expression_module($source) ); return "Bio::DB::Expression::$source"->new(@args); } } =head2 get_platforms() Usage : Function: Example : Returns : a list of Bio::Expression::Platform objects Args : =cut sub get_platforms { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_samples() Usage : Function: Example : Returns : a list of Bio::Expression::Sample objects Args : =cut sub get_samples { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_contacts() Usage : Function: Example : Returns : a list of Bio::Expression::Contact objects Args : =cut sub get_contacts { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_datasets() Usage : Function: Example : Returns : a list of Bio::Expression::DataSet objects Args : =cut sub get_datasets { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 _load_expression_module Title : _load_expression_module Usage : *INTERNAL Bio::DB::Expression stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_expression_module { my ($self, $source) = @_; my $module = "Bio::DB::Expression::" . $source; my $ok; eval { $ok = $self->_load_module($module) }; if ( $@ ) { print STDERR $@; print STDERR <new(); $failover->add_database($db); # fail over Bio::DB::RandomAccessI.pm # this will check each database in priority, returning when # the first one succeeds $seq = $failover->get_Seq_by_id($id); =head1 DESCRIPTION This module provides fail over access to a set of Bio::DB::RandomAccessI objects. =head1 CONTACT Ewan Birney Ebirney@ebi.ac.ukE originally wrote this class. =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Failover; use strict; use base qw(Bio::Root::Root Bio::DB::RandomAccessI); sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_database'} = []; return $self; } =head2 add_database Title : add_database Usage : add_database(%db) Function: Adds a database to the Failover object Returns : Count of number of databases Args : Array of db resources Throws : Not a RandomAccessI exception =cut sub add_database { my ($self,@db) = @_; for my $db ( @db ) { if ( !ref $db || !$db->isa('Bio::DB::RandomAccessI') ) { $self->throw("Database object $db is a not a Bio::DB::RandomAccessI"); next; } push(@{$self->{'_database'}},$db); } scalar @{$self->{'_database'}}; } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "no id" exception =cut sub get_Seq_by_id { my ($self,$id) = @_; if( !defined $id ) { $self->throw("no id is given!"); } foreach my $db ( @{$self->{'_database'}} ) { my $seq; eval { $seq = $db->get_Seq_by_id($id); }; $self->warn($@) if $@; if ( defined $seq ) { return $seq; } else { $self->warn("No sequence retrieved by database " . ref($db)); } } return; } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "no id" exception =cut sub get_Seq_by_acc { my ($self,$id) = @_; if( !defined $id ) { $self->throw("no id is given!"); } foreach my $db ( @{$self->{'_database'}} ) { my $seq; eval { $seq = $db->get_Seq_by_acc($id); }; $self->warn($@) if $@; if ( defined $seq ) { return $seq; } else { $self->warn("No sequence retrieved by database " . ref($db)); } } return; } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_acc('X77802.2'); Function: Gets a Bio::Seq object by versioned accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut sub get_Seq_by_version { my ($self,$id) = @_; if( !defined $id ) { $self->throw("no acc is given!"); } foreach my $db ( @{$self->{'_database'}} ) { my $seq; eval { $seq = $db->get_Seq_by_version($id); }; $self->warn($@) if $@; if ( defined $seq ) { return $seq; } else { $self->warn("No sequence retrieved by database " . ref($db)); } } return; } ## End of Package 1; __END__ BioPerl-1.6.923/Bio/DB/Fasta.pm000444000765000024 3407312254227316 16061 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Fasta # # You may distribute this module under the same terms as perl itself # =head1 NAME Bio::DB::Fasta - Fast indexed access to fasta files =head1 SYNOPSIS use Bio::DB::Fasta; # Create database from a directory of Fasta files my $db = Bio::DB::Fasta->new('/path/to/fasta/files/'); my @ids = $db->get_all_primary_ids; # Simple access my $seqstr = $db->seq('CHROMOSOME_I', 4_000_000 => 4_100_000); my $revseq = $db->seq('CHROMOSOME_I', 4_100_000 => 4_000_000); my $length = $db->length('CHROMOSOME_I'); my $header = $db->header('CHROMOSOME_I'); my $alphabet = $db->alphabet('CHROMOSOME_I'); # Access to sequence objects. See Bio::PrimarySeqI. my $seq = $db->get_Seq_by_id('CHROMOSOME_I'); my $seqstr = $seq->seq; my $subseq = $seq->subseq(4_000_000 => 4_100_000); my $trunc = $seq->trunc(4_000_000 => 4_100_000); my $length = $seq->length; # Loop through sequence objects my $stream = $db->get_PrimarySeq_stream; while (my $seq = $stream->next_seq) { # Bio::PrimarySeqI stuff } # Filehandle access my $fh = Bio::DB::Fasta->newFh('/path/to/fasta/files/'); while (my $seq = <$fh>) { # Bio::PrimarySeqI stuff } # Tied hash access tie %sequences,'Bio::DB::Fasta','/path/to/fasta/files/'; print $sequences{'CHROMOSOME_I:1,20000'}; =head1 DESCRIPTION Bio::DB::Fasta provides indexed access to a single Fasta file, several files, or a directory of files. It provides persistent random access to each sequence entry (either as a Bio::PrimarySeqI-compliant object or a string), and to subsequences within each entry, allowing you to retrieve portions of very large sequences without bringing the entire sequence into memory. Bio::DB::Fasta is based on Bio::DB::IndexedBase. See this module's documentation for details. The Fasta files may contain any combination of nucleotide and protein sequences; during indexing the module guesses the molecular type. Entries may have any line length up to 65,536 characters, and different line lengths are allowed in the same file. However, within a sequence entry, all lines must be the same length except for the last. An error will be thrown if this is not the case. The module uses /^E(\S+)/ to extract the primary ID of each sequence from the Fasta header. See -makeid in Bio::DB::IndexedBase to pass a callback routine to reversibly modify this primary ID, e.g. if you wish to extract a specific portion of the gi|gb|abc|xyz GenBank IDs. =head1 DATABASE CREATION AND INDEXING The object-oriented constructor is new(), the filehandle constructor is newFh() and the tied hash constructor is tie(). They all allow to index a single Fasta file, several files, or a directory of files. See Bio::DB::IndexedBase. =head1 SEE ALSO L L L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See DISCLAIMER.txt for disclaimers of warranty. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ For BioPerl-style access, the following methods are provided: =head2 get_Seq_by_id Title : get_Seq_by_id, get_Seq_by_acc, get_Seq_by_primary_id Usage : my $seq = $db->get_Seq_by_id($id); Function: Given an ID, fetch the corresponding sequence from the database. Returns : A Bio::PrimarySeq::Fasta object (Bio::PrimarySeqI compliant) Note that to save resource, Bio::PrimarySeq::Fasta sequence objects only load the sequence string into memory when requested using seq(). See L for methods provided by the sequence objects returned from get_Seq_by_id() and get_PrimarySeq_stream(). Args : ID =head2 get_PrimarySeq_stream Title : get_PrimarySeq_stream Usage : my $stream = $db->get_PrimarySeq_stream(); Function: Get a stream of Bio::PrimarySeq::Fasta objects. The stream supports a single method, next_seq(). Each call to next_seq() returns a new Bio::PrimarySeq::Fasta sequence object, until no more sequences remain. Returns : A Bio::DB::Indexed::Stream object Args : None =head1 For simple access, the following methods are provided: =cut package Bio::DB::Fasta; use strict; use IO::File; use File::Spec; use Bio::PrimarySeqI; use base qw(Bio::DB::IndexedBase); our $obj_class = 'Bio::PrimarySeq::Fasta'; our $file_glob = '*.{fa,FA,fasta,FASTA,fast,FAST,dna,DNA,fna,FNA,faa,FAA,fsa,FSA}'; =head2 new Title : new Usage : my $db = Bio::DB::Fasta->new( $path, %options); Function: Initialize a new database object. When indexing a directory, files ending in .fa,fasta,fast,dna,fna,faa,fsa are indexed by default. Returns : A new Bio::DB::Fasta object. Args : A single file, or path to dir, or arrayref of files Optional arguments: see Bio::DB::IndexedBase =cut sub _calculate_offsets { # Bio::DB::IndexedBase calls this to calculate offsets my ($self, $fileno, $file, $offsets) = @_; my $fh = IO::File->new($file) or $self->throw( "Could not open $file: $!"); binmode $fh; warn "Indexing $file\n" if $self->{debug}; my ($offset, @ids, $linelen, $alphabet, $headerlen, $count, $seq_lines, $last_line, %offsets); my ($l3_len, $l2_len, $l_len, $blank_lines) = (0, 0, 0, 0); my $termination_length = $self->{termination_length}; while (my $line = <$fh>) { # Account for crlf-terminated Windows files if (index($line, '>') == 0) { if ($line =~ /^>(\S+)/) { print STDERR "Indexed $count sequences...\n" if $self->{debug} && (++$count%1000) == 0; $self->_check_linelength($linelen); my $pos = tell($fh); if (@ids) { my $strlen = $pos - $offset - length($line); $strlen -= $termination_length * $seq_lines; my $ppos = &{$self->{packmeth}}($offset, $strlen, $strlen, $linelen, $headerlen, $alphabet, $fileno); $alphabet = Bio::DB::IndexedBase::NA; for my $id (@ids) { $offsets->{$id} = $ppos; } } @ids = $self->_makeid($line); ($offset, $headerlen, $linelen, $seq_lines) = ($pos, length $line, 0, 0); ($l3_len, $l2_len, $l_len, $blank_lines) = (0, 0, 0, 0); } else { # Catch bad header lines, bug 3172 $self->throw("FASTA header doesn't match '>(\\S+)': $line"); } } elsif ($line !~ /\S/) { # Skip blank line $blank_lines++; next; } else { # Need to check every line :( $l3_len = $l2_len; $l2_len = $l_len; $l_len = length $line; if (Bio::DB::IndexedBase::DIE_ON_MISSMATCHED_LINES) { if ( ($l3_len > 0) && ($l2_len > 0) && ($l3_len != $l2_len) ) { my $fap = substr($line, 0, 20).".."; $self->throw("Each line of the fasta entry must be the same ". "length except the last. Line above #$. '$fap' is $l2_len". " != $l3_len chars."); } if ($blank_lines) { # Blank lines not allowed in entry $self->throw("Blank lines can only precede header lines, ". "found preceding line #$."); } } $linelen ||= length $line; $alphabet ||= $self->_guess_alphabet($line); $seq_lines++; } $last_line = $line; } # Process last entry $self->_check_linelength($linelen); my $pos = tell $fh; if (@ids) { my $strlen = $pos - $offset; if ($linelen == 0) { # yet another pesky empty chr_random.fa file $strlen = 0; } else { if ($last_line !~ /\s$/) { $seq_lines--; } $strlen -= $termination_length * $seq_lines; } my $ppos = &{$self->{packmeth}}($offset, $strlen, $strlen, $linelen, $headerlen, $alphabet, $fileno); for my $id (@ids) { $offsets->{$id} = $ppos; } } return \%offsets; } =head2 seq Title : seq, sequence, subseq Usage : # Entire sequence string my $seqstr = $db->seq($id); # Subsequence my $subseqstr = $db->seq($id, $start, $stop, $strand); # or... my $subseqstr = $db->seq($compound_id); Function: Get a subseq of a sequence from the database. For your convenience, the sequence to extract can be specified with any of the following compound IDs: $db->seq("$id:$start,$stop") $db->seq("$id:$start..$stop") $db->seq("$id:$start-$stop") $db->seq("$id:$start,$stop/$strand") $db->seq("$id:$start..$stop/$strand") $db->seq("$id:$start-$stop/$strand") $db->seq("$id/$strand") In the case of DNA or RNA sequence, if $stop is less than $start, then the reverse complement of the sequence is returned. Avoid using it if possible since this goes against Bio::Seq conventions. Returns : A string Args : ID of sequence to retrieve or Compound ID of subsequence to fetch or ID, optional start (defaults to 1), optional end (defaults to length of sequence) and optional strand (defaults to 1). =cut sub subseq { my ($self, $id, $start, $stop, $strand) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; ($id, $start, $stop, $strand) = $self->_parse_compound_id($id, $start, $stop, $strand); my $data; my $fh = $self->_fh($id) or return; my $filestart = $self->_calc_offset($id, $start); my $filestop = $self->_calc_offset($id, $stop ); seek($fh, $filestart,0); read($fh, $data, $filestop-$filestart+1); $data =~ s/\n//g; $data =~ s/\r//g; if ($strand == -1) { # Reverse-complement the sequence $data = Bio::PrimarySeqI::_revcom_from_string($self, $data, $self->alphabet($id)); } return $data; } *seq = *sequence = \&subseq; =head2 length Title : length Usage : my $length = $qualdb->length($id); Function: Get the number of residues in the indicated sequence. Returns : Number Args : ID of entry =head2 header Title : header Usage : my $header = $db->header($id); Function: Get the header line (ID and description fields) of the specified sequence. Returns : String Args : ID of sequence =cut sub header { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my ($offset, $headerlen) = (&{$self->{unpackmeth}}($self->{offsets}{$id}))[0,4]; $offset -= $headerlen; my $data; my $fh = $self->_fh($id) or return; seek($fh, $offset, 0); read($fh, $data, $headerlen); # On Windows chomp remove '\n' but leaves '\r' # when reading '\r\n' in binary mode $data =~ s/\n//g; $data =~ s/\r//g; substr($data, 0, 1) = ''; return $data; } =head2 alphabet Title : alphabet Usage : my $alphabet = $db->alphabet($id); Function: Get the molecular type of the indicated sequence: dna, rna or protein Returns : String Args : ID of sequence =cut #------------------------------------------------------------- # Bio::PrimarySeqI compatibility # package Bio::PrimarySeq::Fasta; use overload '""' => 'display_id'; use base qw(Bio::Root::Root Bio::PrimarySeqI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($db, $id, $start, $stop) = $self->_rearrange( [qw(DATABASE ID START STOP)], @args); $self->{db} = $db; $self->{id} = $id; $self->{stop} = $stop || $db->length($id); $self->{start} = $start || ($self->{stop} > 0 ? 1 : 0); # handle 0-length seqs return $self; } sub fetch_sequence { return shift->seq(@_); } sub seq { my $self = shift; return $self->{db}->seq($self->{id}, $self->{start}, $self->{stop}); } sub subseq { my $self = shift; return $self->trunc(@_)->seq(); } sub trunc { # Override Bio::PrimarySeqI trunc() method. This way, we create an object # that does not store the sequence in memory. my ($self, $start, $stop) = @_; $self->throw("Stop cannot be smaller than start") if $stop < $start; if ($self->{start} <= $self->{stop}) { $start = $self->{start}+$start-1; $stop = $self->{start}+$stop-1; } else { $start = $self->{start}-($start-1); $stop = $self->{start}-($stop-1); } return $self->new( $self->{db}, $self->{id}, $start, $stop ); } sub is_circular { my $self = shift; return $self->{is_circular}; } sub display_id { my $self = shift; return $self->{id}; } sub accession_number { my $self = shift; return 'unknown'; } sub primary_id { # Following Bio::PrimarySeqI, since this sequence has no accession number, # its primary_id should be a stringified memory location. my $self = shift; return overload::StrVal($self); } sub can_call_new { return 0; } sub alphabet { my $self = shift; return $self->{db}->alphabet($self->{id}); } sub revcom { # Override Bio::PrimarySeqI revcom() with optimized method. my $self = shift; return $self->new(@{$self}{'db', 'id', 'stop', 'start'}); } sub length { # Get length from sequence location, not the sequence string (too expensive) my $self = shift; return $self->{start} < $self->{stop} ? $self->{stop} - $self->{start} + 1 : $self->{start} - $self->{stop} + 1 ; } sub description { my $self = shift; my $header = $self->{'db'}->header($self->{id}); # Remove the ID from the header return (split(/\s+/, $header, 2))[1]; } *desc = \&description; 1; BioPerl-1.6.923/Bio/DB/FileCache.pm000444000765000024 1606412254227334 16626 0ustar00cjfieldsstaff000000000000# # POD documentation - main docs before the code # # =head1 NAME Bio::DB::FileCache - In file cache for BioSeq objects =head1 SYNOPSIS $cachedb = Bio::DB::FileCache->new($real_db); # # $real_db is a Bio::DB::RandomAccessI database # $seq = $cachedb->get_Seq_by_id('ROA1_HUMAN'); # # $seq is a Bio::Seq object # # more control provided with named-parameter form $cachedb = Bio::DB::FileCache->new( -seqdb => $real_db, -file => $path, -keep => $flag, ); =head1 DESCRIPTION This is a disk cache system which saves the objects returned by Bio::DB::RandomAccessI on disk. The disk cache grows without limit, while the process is running, but is automatically unlinked at process termination unless the -keep flag is set. This module requires DB_File and Storable. =head1 CONTACT Lincoln Stein Elstein@cshl.orgE =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::FileCache; use DB_File; use Storable qw(freeze thaw); use Fcntl qw(O_CREAT O_RDWR O_RDONLY); use File::Temp 'tmpnam'; use strict; use base qw(Bio::Root::Root Bio::DB::SeqI); use Bio::Seq::RichSeq; use Bio::Location::Split; use Bio::Location::Fuzzy; use Bio::Seq; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Annotation::Collection; =head2 new Title : new Usage : $db = Bio::DB::FileCache->new( -seqdb => $db, # Bio::DB::RandomAccessI database -file => $path, # path to index file -keep => $flag, # don't unlink index file ) Function: creates a new on-disk cache Returns : a Bio::DB::RandomAccessI database Args : as above Throws : "Must be a randomaccess database" exception "Could not open primary index file" exception If no index file is specified, will create a temporary file in your system's temporary file directory. The name of this temporary file can be retrieved using file_name(). =cut #' sub new { my ($class,@args) = @_; my $self = Bio::Root::Root->new(); bless $self,$class; my ($seqdb,$file_name,$keep) = $self->_rearrange([qw(SEQDB FILE KEEP)],@args); if( !defined $seqdb || !ref $seqdb || ! $seqdb->isa('Bio::DB::RandomAccessI') ) { $self->throw("Must be a randomaccess database not a [$seqdb]"); } $self->seqdb($seqdb); $file_name ||= tmpnam(); $self->file_name($file_name); $self->keep($keep); $self->_open_database($file_name); return $self; } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =cut sub get_Seq_by_id{ my ($self,$id) = @_; # look in the cache first my $obj = $self->_get('id' => $id); return $obj if defined $obj; # get object from seqdb $obj = $self->seqdb->get_Seq_by_id($id); $self->_store('id' => $id, $obj); return $obj; } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut sub get_Seq_by_acc{ my ($self,$acc) = @_; # look in the cache first my $obj = $self->_get('acc' => $acc); return $obj if defined $obj; # get object from seqdb $obj = $self->seqdb->get_Seq_by_acc($acc); $self->_store('acc' => $acc, $obj); return $obj; } =head2 seqdb Title : seqdb Usage : $seqdb = $db->seqdb([$seqdb]) Function: gets/sets the Bio::DB::RandomAccessI database Returns : a Bio::DB::RandomAccessI database Args : new sequence database (optional) Throws : nothing =cut sub seqdb { my ($self, $seqdb) = @_; if ($seqdb) { $self->{'seqdb'} = $seqdb; } else { return $self->{'seqdb'}; } } =head2 file_name Title : file_name Usage : $path = $db->file_name([$file_name]) Function: gets/sets the name of the cache file Returns : a path Args : new cache file name (optional) Throws : nothing It probably isn't useful to set the cache file name after you've opened it. =cut #' sub file_name { my $self = shift; my $d = $self->{file_name}; $self->{file_name} = shift if @_; $d; } =head2 keep Title : keep Usage : $keep = $db->keep([$flag]) Function: gets/sets the value of the "keep" flag Returns : current value Args : new value (optional) Throws : nothing The keep flag will cause the index file to be unlinked when the process exits. Since on some operating systems (Unix, OS/2) the unlinking occurs during the new() call immediately after opening the file, it probably isn't safe to change this value. =cut #' sub keep { my $self = shift; my $d = $self->{keep}; $self->{keep} = shift if @_; $d; } =head2 db Title : db Usage : $db->db Function: returns tied hash to index database Returns : a Berkeley DB tied hashref Args : none Throws : nothing =cut sub db { shift->{db} } =head2 flush Title : flush Usage : $db->flush Function: flushes the cache Returns : nothing Args : none Throws : nothing =cut sub flush { my $db = shift->db or return; %{$db} = (); } sub _get { my $self = shift; my ($type,$id) = @_; my $serialized = $self->db->{"${type}_${id}"}; my $obj = thaw($serialized); $obj; } sub _store { my $self = shift; my ($type,$id,$obj) = @_; if( ! defined $obj ) { # bug #1628 $self->debug("tried to store an undefined value for $id, skipping"); return; } my $serialized = freeze($obj); $self->db->{"${type}_${id}"} = $serialized; } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Seq_by_version{ my ($self,@args) = @_; $self->throw("Not implemented it"); } sub DESTROY { my $self = shift; unlink $self->file_name unless $self->keep; } sub _open_database { my $self = shift; my $file = shift; my $flags = O_CREAT|O_RDWR; my %db; tie(%db,'DB_File',$file,$flags,0666,$DB_BTREE) or $self->throw("Could not open primary index file"); $self->{db} = \%db; unlink $file unless $self->keep; } ## End of Package 1; BioPerl-1.6.923/Bio/DB/Flat.pm000444000765000024 4150012254227340 15677 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::Flat # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat - Interface for indexed flat files =head1 SYNOPSIS $db = Bio::DB::Flat->new(-directory => '/usr/share/embl', -dbname => 'mydb', -format => 'embl', -index => 'bdb', -write_flag => 1); $db->build_index('/usr/share/embl/primate.embl', '/usr/share/embl/protists.embl'); $seq = $db->get_Seq_by_id('BUM'); @sequences = $db->get_Seq_by_acc('DIV' => 'primate'); $raw = $db->fetch_raw('BUM'); =head1 DESCRIPTION This object provides the basic mechanism to associate positions in files with primary and secondary name spaces. Unlike Bio::Index::Abstract (see L), this is specialized to work with the "flat index" and BerkeleyDB indexed flat file formats worked out at the 2002 BioHackathon. This object is a general front end to the underlying databases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email - lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with an "_" (underscore). =cut # Let the code begin... package Bio::DB::Flat; use File::Spec; use base qw(Bio::Root::Root Bio::DB::RandomAccessI); use constant CONFIG_FILE_NAME => 'config.dat'; =head2 new Title : new Usage : my $db = Bio::DB::Flat->new( -directory => $root_directory, -dbname => 'mydb', -write_flag => 1, -index => 'bdb', -verbose => 0, -out => 'outputfile', -format => 'genbank'); Function: create a new Bio::DB::Flat object Returns : new Bio::DB::Flat object Args : -directory Root directory containing "config.dat" -write_flag If true, allows creation/updating. -verbose Verbose messages -out File to write to when write_seq invoked -index 'bdb' or 'binarysearch' Status : Public The required -directory argument indicates where the flat file indexes will be stored. The build_index() and write_seq() methods will automatically create subdirectories of this root directory. Each subdirectory will contain a human-readable configuration file named "config.dat" that specifies where the individual indexes are stored. The required -dbname argument gives a name to the database index. The index files will actually be stored in a like-named subdirectory underneath the root directory. The -write_flag enables writing new entries into the database as well as the creation of the indexes. By default the indexes will be opened read only. -index is one of "bdb" or "binarysearch" and indicates the type of index to generate. "bdb" corresponds to Berkeley DB. You *must* be using BerkeleyDB version 2 or higher, and have the Perl BerkeleyDB extension installed (DB_File will *not* work). "binarysearch" corresponds to the OBDA "flat" indexed file. The -out argument specifies the output file for writing objects created with write_seq(). The -format argument specifies the format of the input file or files. If the file suffix is one that Bioperl can already associate with a format then this is optional. =cut sub new { my $class = shift; $class = ref($class) if ref($class); my $self = $class->SUPER::new(@_); # first we initialize ourselves my ($flat_directory,$dbname,$format) = $self->_rearrange([qw(DIRECTORY DBNAME FORMAT)],@_); defined $flat_directory or $self->throw('Please supply a -directory argument'); defined $dbname or $self->throw('Please supply a -dbname argument'); # set values from configuration file $self->directory($flat_directory); $self->dbname($dbname); $self->throw("Base directory $flat_directory doesn't exist") unless -e $flat_directory; $self->throw("$flat_directory isn't a directory") unless -d _; my $dbpath = File::Spec->catfile($flat_directory,$dbname); unless (-d $dbpath) { $self->debug("creating db directory $dbpath\n"); mkdir $dbpath,0777 or $self->throw("Can't create $dbpath: $!"); } $self->_read_config(); # but override with initialization values $self->_initialize(@_); $self->throw('you must specify an indexing scheme') unless $self->indexing_scheme; # now we figure out what subclass to instantiate my $index_type = $self->indexing_scheme eq 'BerkeleyDB/1' ? 'BDB' :$self->indexing_scheme eq 'flat/1' ? 'Binary' :$self->throw("unknown indexing scheme: " . $self->indexing_scheme); $format = $self->file_format; # because Michele and Lincoln did it differently # Michele's way is via a standalone concrete class if ($index_type eq 'Binary') { my $child_class = 'Bio::DB::Flat::BinarySearch'; eval "use $child_class"; $self->throw($@) if $@; push @_, ('-format', $format); return $child_class->new(@_); } # Lincoln uses Bio::SeqIO style delegation. my $child_class= "Bio\:\:DB\:\:Flat\:\:$index_type\:\:\L$format"; eval "use $child_class"; $self->throw($@) if $@; # rebless & reinitialize with the new class # (this prevents subclasses from forgetting to call our own initialization) bless $self,$child_class; $self->_initialize(@_); $self->_set_namespaces(@_); $self; } sub _initialize { my $self = shift; my ($flat_write_flag,$dbname,$flat_indexing,$flat_verbose,$flat_outfile,$flat_format) = $self->_rearrange([qw(WRITE_FLAG DBNAME INDEX VERBOSE OUT FORMAT)],@_); $self->write_flag($flat_write_flag) if defined $flat_write_flag; if (defined $flat_indexing) { # very permissive $flat_indexing = 'BerkeleyDB/1' if $flat_indexing =~ /bdb/; $flat_indexing = 'flat/1' if $flat_indexing =~ /^(flat|binary)/; $self->indexing_scheme($flat_indexing); } $self->verbose($flat_verbose) if defined $flat_verbose; $self->dbname($dbname) if defined $dbname; $self->out_file($flat_outfile) if defined $flat_outfile; $self->file_format($flat_format) if defined $flat_format; } sub _set_namespaces { my $self = shift; $self->primary_namespace($self->default_primary_namespace) unless defined $self->{flat_primary_namespace}; $self->secondary_namespaces($self->default_secondary_namespaces) unless defined $self->{flat_secondary_namespaces}; $self->file_format($self->default_file_format) unless defined $self->{flat_format}; } =head2 new_from_registry Title : new_from_registry Usage : $db = Bio::DB::Flat->new_from_registry(%config) Function: creates a new Bio::DB::Flat object in a Bio::DB::Registry- compatible fashion Returns : new Bio::DB::Flat Args : provided by the registry, see below Status : Public The following registry-configuration tags are recognized: location Root of the indexed flat file; corresponds to the new() method's -directory argument. =cut sub new_from_registry { my ($self,%config) = @_; my $location = $config{'location'} or $self->throw('location tag must be specified.'); my $dbname = $config{'dbname'} or $self->throw('dbname tag must be specified.'); my $db = $self->new(-directory => $location, -dbname => $dbname, ); $db; } # accessors sub directory { my $self = shift; my $d = $self->{flat_directory}; $self->{flat_directory} = shift if @_; $d; } sub write_flag { my $self = shift; my $d = $self->{flat_write_flag}; $self->{flat_write_flag} = shift if @_; $d; } sub verbose { my $self = shift; my $d = $self->{flat_verbose}; $self->{flat_verbose} = shift if @_; $d; } sub out_file { my $self = shift; my $d = $self->{flat_outfile}; $self->{flat_outfile} = shift if @_; $d; } sub dbname { my $self = shift; my $d = $self->{flat_dbname}; $self->{flat_dbname} = shift if @_; $d; } sub primary_namespace { my $self = shift; my $d = $self->{flat_primary_namespace}; $self->{flat_primary_namespace} = shift if @_; $d; } # get/set secondary namespace(s) # pass an array ref. # get an array ref in scalar context, list in list context. sub secondary_namespaces { my $self = shift; my $d = $self->{flat_secondary_namespaces}; $self->{flat_secondary_namespaces} = (ref($_[0]) eq 'ARRAY' ? shift : [@_]) if @_; return unless $d; $d = [$d] if $d && ref($d) ne 'ARRAY'; # just paranoia return wantarray ? @$d : $d; } # return the file format sub file_format { my $self = shift; my $d = $self->{flat_format}; $self->{flat_format} = shift if @_; $d; } # return the alphabet sub alphabet { my $self = shift; my $d = $self->{flat_alphabet}; $self->{flat_alphabet} = shift if @_; $d; } sub parse_one_record { my $self = shift; my $fh = shift; my $parser = $self->{cached_parsers}{fileno($fh)} ||= Bio::SeqIO->new(-fh=>$fh,-format=>$self->default_file_format); my $seq = $parser->next_seq or return; $self->{flat_alphabet} ||= $seq->alphabet; my $ids = $self->seq_to_ids($seq); return $ids; } # return the indexing scheme sub indexing_scheme { my $self = shift; my $d = $self->{flat_indexing}; $self->{flat_indexing} = shift if @_; $d; } sub add_flat_file { my $self = shift; my ($file_path,$file_length,$nf) = @_; # check that file_path is absolute unless (File::Spec->file_name_is_absolute($file_path)) { $file_path = File::Spec->rel2abs($file_path); } -r $file_path or $self->throw("flat file $file_path cannot be read: $!"); my $current_size = -s _; if (defined $file_length) { $current_size == $file_length or $self->throw("flat file $file_path has changed size. Was $file_length bytes; now $current_size"); } else { $file_length = $current_size; } unless (defined $nf) { $self->{flat_file_index} = 0 unless exists $self->{flat_file_index}; $nf = $self->{flat_file_index}++; } $self->{flat_flat_file_path}{$nf} = $file_path; $self->{flat_flat_file_no}{$file_path} = $nf; $nf; } sub write_config { my $self = shift; $self->write_flag or $self->throw("cannot write configuration file because write_flag is not set"); my $path = $self->_config_path; open (my $F,">$path") or $self->throw("open error on $path: $!"); my $index_type = $self->indexing_scheme; print $F "index\t$index_type\n"; my $format = $self->file_format; my $alphabet = $self->alphabet; my $alpha = $alphabet ? "/$alphabet" : ''; print $F "format\tURN:LSID:open-bio.org:${format}${alpha}\n"; my @filenos = $self->_filenos or $self->throw("cannot write config file because no flat files defined"); for my $nf (@filenos) { my $path = $self->{flat_flat_file_path}{$nf}; my $size = -s $path; print $F join("\t","fileid_$nf",$path,$size),"\n"; } # write primary namespace my $primary_ns = $self->primary_namespace or $self->throw('cannot write config file because no primary namespace defined'); print $F join("\t",'primary_namespace',$primary_ns),"\n"; # write secondary namespaces my @secondary = $self->secondary_namespaces; print $F join("\t",'secondary_namespaces',@secondary),"\n"; close $F or $self->throw("close error on $path: $!"); } sub files { my $self = shift; return unless $self->{flat_flat_file_no}; return keys %{$self->{flat_flat_file_no}}; } sub write_seq { my $self = shift; my $seq = shift; $self->write_flag or $self->throw("cannot write sequences because write_flag is not set"); my $file = $self->out_file or $self->throw('no outfile defined; use the -out argument to new()'); my $seqio = $self->{flat_cached_parsers}{$file} ||= Bio::SeqIO->new(-Format => $self->file_format, -file => ">$file") or $self->throw("couldn't create Bio::SeqIO object"); my $fh = $seqio->_fh or $self->throw("couldn't get filehandle from Bio::SeqIO object"); my $offset = tell($fh); $seqio->write_seq($seq); my $length = tell($fh)-$offset; my $ids = $self->seq_to_ids($seq); $self->_store_index($ids,$file,$offset,$length); $self->{flat_outfile_dirty}++; } sub close { my $self = shift; return unless $self->{flat_outfile_dirty}; $self->write_config; delete $self->{flat_outfile_dirty}; delete $self->{flat_cached_parsers}{$self->out_file}; } sub _filenos { my $self = shift; return unless $self->{flat_flat_file_path}; return keys %{$self->{flat_flat_file_path}}; } # read the configuration file sub _read_config { my $self = shift; my $path = $self->_config_path; return unless -e $path; open (my $F,$path) or $self->throw("open error on $path: $!"); my %config; while (<$F>) { chomp; my ($tag,@values) = split "\t"; $config{$tag} = \@values; } CORE::close $F or $self->throw("close error on $path: $!"); $config{index}[0] =~ m~(flat/1|BerkeleyDB/1)~ or $self->throw("invalid configuration file $path: no index line"); $self->indexing_scheme($1); if ($config{format}) { # handle LSID format if ($config{format}[0] =~ /^URN:LSID:open-bio\.org:(\w+)(?:\/(\w+))/) { $self->file_format($1); $self->alphabet($2); } else { # compatibility with older versions $self->file_format($config{format}[0]); } } # set up primary namespace my $primary_namespace = $config{primary_namespace}[0] or $self->throw("invalid configuration file $path: no primary namespace defined"); $self->primary_namespace($primary_namespace); # set up secondary namespaces (may be empty) $self->secondary_namespaces($config{secondary_namespaces}); # get file paths and their normalization information my @normalized_files = grep {$_ ne ''} map {/^fileid_(\S+)/ && $1} keys %config; for my $nf (@normalized_files) { my ($file_path,$file_length) = @{$config{"fileid_${nf}"}}; $self->add_flat_file($file_path,$file_length,$nf); } 1; } sub _config_path { my $self = shift; $self->_catfile($self->_config_name); } sub _catfile { my $self = shift; my $component = shift; File::Spec->catfile($self->directory,$self->dbname,$component); } sub _config_name { CONFIG_FILE_NAME } sub _path2fileno { my $self = shift; my $path = shift; return $self->add_flat_file($path) unless exists $self->{flat_flat_file_no}{$path}; $self->{flat_flat_file_no}{$path}; } sub _fileno2path { my $self = shift; my $fileno = shift; $self->{flat_flat_file_path}{$fileno}; } sub _files { my $self = shift; my $paths = $self->{flat_flat_file_no}; return keys %$paths; } =head2 fetch Title : fetch Usage : $index->fetch( $id ) Function: Returns a Bio::Seq object from the index Example : $seq = $index->fetch( 'dJ67B12' ) Returns : Bio::Seq object Args : ID Deprecated. Use get_Seq_by_id instead. =cut sub fetch { shift->get_Seq_by_id(@_) } =head2 To Be Implemented in Subclasses The following methods MUST be implemented by subclasses. =cut # create real live Bio::Seq object sub get_Seq_by_id { my $self = shift; my $id = shift; $self->throw_not_implemented; } # fetch array of Bio::Seq objects sub get_Seq_by_acc { my $self = shift; return $self->get_Seq_by_id(shift) if @_ == 1; my ($ns,$key) = @_; $self->throw_not_implemented; } sub fetch_raw { my ($self,$id,$namespace) = @_; $self->throw_not_implemented; } sub default_file_format { my $self = shift; $self->throw_not_implemented; } sub _store_index { my $self = shift; my ($ids,$file,$offset,$length) = @_; $self->throw_not_implemented; } =head2 May Be Overridden in Subclasses The following methods MAY be overridden by subclasses. =cut sub default_primary_namespace { return "ACC"; } sub default_secondary_namespaces { return; } sub seq_to_ids { my $self = shift; my $seq = shift; my %ids; $ids{$self->primary_namespace} = $seq->accession_number; \%ids; } sub DESTROY { my $self = shift; $self->close; } 1; BioPerl-1.6.923/Bio/DB/GenBank.pm000444000765000024 2754212254227335 16334 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::GenBank # # Please direct questions and support issues to # # Cared for by Aaron Mackey # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # # Added LWP support - Jason Stajich 2000-11-6 # completely reworked by Jason Stajich 2000-12-8 # to use WebDBSeqI # Added batch entrez back when determined that new entrez cgi will # essentially work (there is a limit to the number of characters in a # GET request so I am not sure how we can get around this). The NCBI # Batch Entrez form has changed some and it does not support retrieval # of text only data. Still should investigate POST-ing (tried and # failed) a message to the entrez cgi to get around the GET # limitations. =head1 NAME Bio::DB::GenBank - Database object interface to GenBank =head1 SYNOPSIS use Bio::DB::GenBank; $gb = Bio::DB::GenBank->new(); $seq = $gb->get_Seq_by_id('J00522'); # Unique ID, *not always the LOCUS ID* # or ... $seq = $gb->get_Seq_by_acc('J00522'); # Accession Number $seq = $gb->get_Seq_by_version('J00522.1'); # Accession.version $seq = $gb->get_Seq_by_gi('405830'); # GI Number # get a stream via a query string my $query = Bio::DB::Query::GenBank->new (-query =>'Oryza sativa[Organism] AND EST', -reldate => '30', -db => 'nucleotide'); my $seqio = $gb->get_Stream_by_query($query); while( my $seq = $seqio->next_seq ) { print "seq length is ", $seq->length,"\n"; } # or ... best when downloading very large files, prevents # keeping all of the file in memory # also don't want features, just sequence so let's save bandwith # and request Fasta sequence $gb = Bio::DB::GenBank->new(-retrievaltype => 'tempfile' , -format => 'Fasta'); my $seqio = $gb->get_Stream_by_acc(['AC013798', 'AC021953'] ); while( my $clone = $seqio->next_seq ) { print "cloneid is ", $clone->display_id, " ", $clone->accession_number, "\n"; } # note that get_Stream_by_version is not implemented # don't want the entire sequence or more options my $gb = Bio::DB::GenBank->new(-format => 'Fasta', -seq_start => 100, -seq_stop => 200, -strand => 1, -complexity => 4); my $seqi = $gb->get_Stream_by_query($query); =head1 DESCRIPTION Allows the dynamic retrieval of L sequence objects from the GenBank database at NCBI, via an Entrez query. WARNING: Please do B spam the Entrez web server with multiple requests. NCBI offers Batch Entrez for this purpose. Note that when querying for GenBank accessions starting with 'NT_' you will need to call $gb-Erequest_format('fasta') beforehand, because in GenBank format (the default) the sequence part will be left out (the reason is that NT contigs are rather annotation with references to clones). Some work has been done to automatically detect and retrieve whole NT_ clones when the data is in that format (NCBI RefSeq clones). The former behavior prior to bioperl 1.6 was to retrieve these from EBI, but now these are retrieved directly from NCBI. The older behavior can be regained by setting the 'redirect_refseq' flag to a value evaluating to TRUE. =head2 Running Alternate methods are described at L NOTE: strand should be 1 for plus or 2 for minus. Complexity: gi is often a part of a biological blob, containing other gis complexity regulates the display: 0 - get the whole blob 1 - get the bioseq for gi of interest (default in Entrez) 2 - get the minimal bioseq-set containing the gi of interest 3 - get the minimal nuc-prot containing the gi of interest 4 - get the minimal pub-set containing the gi of interest 'seq_start' and 'seq_stop' will not work when setting complexity to any value other than 1. 'strand' works for any setting other than a complexity of 0 (whole glob); when you try this with a GenBank return format nothing happens, whereas using FASTA works but causes display problems with the other sequences in the glob. As Tao Tao says from NCBI, "Better left it out or set it to 1." =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey, Jason Stajich Email amackey@virginia.edu Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::GenBank; use strict; use vars qw(%PARAMSTRING $DEFAULTFORMAT $DEFAULTMODE); use base qw(Bio::DB::NCBIHelper); BEGIN { $DEFAULTMODE = 'single'; $DEFAULTFORMAT = 'gbwithparts'; %PARAMSTRING = ( 'batch' => { 'db' => 'nucleotide', 'usehistory' => 'n', 'tool' => 'bioperl'}, 'query' => { 'usehistory' => 'y', 'tool' => 'bioperl', 'retmode' => 'text'}, 'gi' => { 'db' => 'nucleotide', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, 'version' => { 'db' => 'nucleotide', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, 'single' => { 'db' => 'nucleotide', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, 'webenv' => { 'query_key' => 'querykey', 'WebEnv' => 'cookie', 'db' => 'nucleotide', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, ); } # new is in NCBIHelper # helper method to get db specific options =head2 new Title : new Usage : $gb = Bio::DB::GenBank->new(@options) Function: Creates a new genbank handle Returns : a new Bio::DB::Genbank object Args : -delay number of seconds to delay between fetches (3s) NOTE: There are other options that are used internally. By NCBI policy, this module introduces a 3s delay between fetches. If you are fetching multiple genbank ids, it is a good idea to use get =cut =head2 get_params Title : get_params Usage : my %params = $self->get_params($mode) Function: Returns key,value pairs to be passed to NCBI database for either 'batch' or 'single' sequence retrieval method Returns : a key,value pair hash Args : 'single' or 'batch' mode for retrieval =cut sub get_params { my ($self, $mode) = @_; return defined $PARAMSTRING{$mode} ? %{$PARAMSTRING{$mode}} : %{$PARAMSTRING{$DEFAULTMODE}}; } # from Bio::DB::WebDBSeqI from Bio::DB::RandomAccessI =head1 Routines Bio::DB::WebDBSeqI from Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc($acc); Function: Gets a Seq object by accession numbers Returns : a Bio::Seq object Args : the accession number as a string Note : For GenBank, this just calls the same code for get_Seq_by_id(). Caveat: this normally works, but in rare cases simply passing the accession can lead to odd results, possibly due to unsynchronized NCBI ID servers. Using get_Seq_by_version() is slightly better, but using the unique identifier (GI) and get_Seq_by_id is the most consistent Throws : "id does not exist" exception =head2 get_Seq_by_gi Title : get_Seq_by_gi Usage : $seq = $db->get_Seq_by_gi('405830'); Function: Gets a Bio::Seq object by gi number Returns : A Bio::Seq object Args : gi number (as a string) Throws : "gi does not exist" exception =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Note : Caveat: this normally works, but using the unique identifier (GI) and get_Seq_by_id is the most consistent Throws : "acc.version does not exist" exception =head1 Routines implemented by Bio::DB::NCBIHelper =head2 get_Stream_by_query Title : get_Stream_by_query Usage : $seq = $db->get_Stream_by_query($query); Function: Retrieves Seq objects from Entrez 'en masse', rather than one at a time. For large numbers of sequences, this is far superior than get_Stream_by_[id/acc](). Example : Returns : a Bio::SeqIO stream object Args : $query : An Entrez query string or a Bio::DB::Query::GenBank object. It is suggested that you create a Bio::DB::Query::GenBank object and get the entry count before you fetch a potentially large stream. =cut =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id( [$uid1, $uid2] ); Function: Gets a series of Seq objects by unique identifiers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of unique identifiers for the desired sequence entries =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Stream_by_acc([$acc1, $acc2]); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut =head2 get_Stream_by_gi Title : get_Stream_by_gi Usage : $seq = $db->get_Seq_by_gi([$gi1, $gi2]); Function: Gets a series of Seq objects by gi numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of gi numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =head2 get_Stream_by_batch Title : get_Stream_by_batch Usage : $seq = $db->get_Stream_by_batch($ref); Function: Retrieves Seq objects from Entrez 'en masse', rather than one at a time. Example : Returns : a Bio::SeqIO stream object Args : $ref : either an array reference, a filename, or a filehandle from which to get the list of unique ids/accession numbers. NOTE: This method is redundant and deprecated. Use get_Stream_by_id() instead. =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: HTTP::Request Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =cut =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: Returns default sequence format for this module Returns : string Args : none =cut sub default_format { return $DEFAULTFORMAT; } 1; __END__ BioPerl-1.6.923/Bio/DB/GenericWebAgent.pm000444000765000024 2434612254227316 20016 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::GenericWebAgent # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # # Interfaces with new GenericWebAgent interface =head1 NAME Bio::DB::GenericWebAgent - helper base class for parameter-based remote server access and response retrieval. =head1 SYNOPSIS # DO NOT USE DIRECTLY See Bio::DB::EUtilities for an example implementation =head1 DESCRIPTION WARNING: Please do B spam the web servers with multiple requests. Bio::DB::GenericWebAgent is a generic wrapper around a web agent (LWP::UserAgent), an object which can retain, format, and build parameters for the user agent (Bio::ParameterBaseI), and a BioPerl class parser that processes response content received by the user agent. The Bio::ParameterBaseI object should be state-aware, e.g. know when changes occur to parameters, so that identical requests are not repeatedly sent to the server (this base class takes this into consideration). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@lists.open-bio.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web. https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::GenericWebAgent; use strict; use warnings; use base qw(Bio::Root::Root); use LWP::UserAgent; my $LAST_INVOCATION_TIME = 0; my $TIME_HIRES = 0; BEGIN { eval { use Time::HiRes; }; unless ($@) { $TIME_HIRES = 1; } } =head2 new Title : new Usage : Bio::DB::GenericWebAgent->new(@args); Function: Create new Bio::DB::GenericWebAgent instance. Returns : Args : None specific to this base class. Inheriting classes will likely set specific parameters in their constructor; Bio::DB::GenericWebAgent is primarily a test bed. =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->ua(LWP::UserAgent->new(env_proxy => 1, agent => ref($self))); $self->delay($self->delay_policy); return $self; } =head1 GenericWebAgent methods =head2 parameter_base Title : parameter_base Usage : $dbi->parameter_base($pobj); Function: Get/Set Bio::ParameterBaseI. Returns : Bio::ParameterBaseI object Args : Bio::ParameterBaseI object =cut # this will likely be overridden in subclasses sub parameter_base { my ($self, $pobj) = @_; if ($pobj) { $self->throw('Not a Bio::ParameterBaseI') if !$pobj->isa('Bio::ParameterBaseI'); $self->{'_parameter_base'} = $pobj; } return $self->{'_parameter_base'}; } =head2 ua Title : ua Usage : $dbi->ua; Function: Get/Set LWP::UserAgent. Returns : LWP::UserAgent Args : LWP::UserAgent =cut sub ua { my ($self, $ua) = @_; if( defined $ua && $ua->isa("LWP::UserAgent") ) { $self->{'_ua'} = $ua; } return $self->{'_ua'}; } =head2 get_Response Title : get_Response Usage : $agent->get_Response; Function: Get the HTTP::Response object by passing it an HTTP::Request (generated from Bio::ParameterBaseI implementation). Returns : HTTP::Response object or data if callback is used Args : (optional) -cache_response - flag to cache HTTP::Response object; Default is 1 (TRUE, caching ON) These are passed on to LWP::UserAgent::request() if stipulated -cb - use a LWP::UserAgent-compliant callback -file - dumps the response to a file (handy for large responses) Note: can't use file and callback at the same time -read_size_hint - bytes of content to read in at a time to pass to callback Note : Caching and parameter checking are set =cut # TODO deal with small state-related bug with file sub get_Response { my ($self, @args) = @_; my ($cache, $file, $cb, $size) = $self->_rearrange([qw(CACHE_RESPONSE FILE CB READ_SIZE_HINT)],@args); $self->throw("Can't have both callback and file") if $file && $cb; # make -file accept more perl-like write-append type data. $file =~ s{^>}{} if $file; my @opts = grep {defined $_} ($file || $cb, $size); $cache = (defined $cache && $cache == 0) ? 0 : 1; my $pobj = $self->parameter_base; if ($pobj->parameters_changed || !$cache || !$self->{_response_cache} || !$self->{_response_cache}->content) { my $ua = $self->ua; $self->_sleep; # institute delay policy $self->throw('No parameter object set; cannot form a suitable remote request') unless $pobj; my $request = $pobj->to_request; if ($self->authentication) { $request->proxy_authorization_basic($self->authentication) } $self->debug("Request is: \n",$request->as_string); # I'm relying on the useragent to throw the proper errors here my $response = $ua->request($request, @opts); if ($response->is_error) { $self->throw("Response Error\n".$response->message); } return $self->{_response_cache} = $response; } else { $self->debug("Returning cached HTTP::Response object\n"); if ($file) { $self->_dump_request_content($file); # size isn't passed here, as the content is completely retrieved above } elsif ($cb) { $cb && ref($cb) eq 'CODE' && $cb->($self->{_response_cache}->content); } return $self->{_response_cache}; } } =head2 get_Parser Title : get_Parser Usage : $agent->get_Parser; Function: Return HTTP::Response content (file, fh, object) attached to defined parser Returns : None Args : None Note : Abstract method; defined by implementation =cut sub get_Parser { shift->throw_not_implemented; } =head2 delay Title : delay Usage : $secs = $self->delay($secs) Function: get/set number of seconds to delay between fetches Returns : number of seconds to delay Args : new value NOTE: the default is to use the value specified by delay_policy(). This can be overridden by calling this method. =cut sub delay { my $self = shift; return $self->{'_delay'} = shift if @_; return $self->{'_delay'}; } =head2 delay_policy Title : delay_policy Usage : $secs = $self->delay_policy Function: return number of seconds to delay between calls to remote db Returns : number of seconds to delay Args : none NOTE: The default delay policy is 3s. Override in subclasses to implement delays. The timer has only second resolution, so the delay will actually be +/- 1s. =cut sub delay_policy { my $self = shift; return 3; } =head2 _sleep Title : _sleep Usage : $self->_sleep Function: sleep for a number of seconds indicated by the delay policy Returns : none Args : none NOTE: This method keeps track of the last time it was called and only imposes a sleep if it was called more recently than the delay_policy() allows. =cut sub _sleep { my $self = shift; my $last_invocation = $LAST_INVOCATION_TIME; if (time - $LAST_INVOCATION_TIME < $self->delay) { my $delay = $self->delay - (time - $LAST_INVOCATION_TIME); $self->debug("sleeping for $delay seconds\n"); if ($TIME_HIRES) { # allows precise sleep timeout (builtin only allows integer seconds) Time::HiRes::sleep($delay); } else { # allows precise sleep timeout (builtin only allows integer seconds) # I hate this hack , but needed if we support 5.6.1 and # don't want additional Time::HiRes prereq select undef, undef, undef, $delay; } } $LAST_INVOCATION_TIME = time; } =head1 LWP::UserAgent related methods =head2 proxy Title : proxy Usage : $httpproxy = $db->proxy('http') or $db->proxy(['http','ftp'], 'http://myproxy' ) Function: Get/Set a proxy for use of proxy Returns : a string indicating the proxy Args : $protocol : an array ref of the protocol(s) to set/get $proxyurl : url of the proxy to use for the specified protocol $username : username (if proxy requires authentication) $password : password (if proxy requires authentication) =cut sub proxy { my ($self,$protocol,$proxy,$username,$password) = @_; return if ( !defined $protocol || !defined $proxy ); $self->authentication($username, $password) if ($username && $password); return $self->ua->proxy($protocol,$proxy); } =head2 authentication Title : authentication Usage : $db->authentication($user,$pass) Function: Get/Set authentication credentials Returns : Array of user/pass Args : Array or user/pass =cut sub authentication{ my ($self,$u,$p) = @_; if( defined $u && defined $p ) { $self->{'_authentication'} = [ $u,$p]; } $self->{'_authentication'} && return @{$self->{'_authentication'}}; } # private method to dump any cached request data content into a passed filename sub _dump_request_content { my ($self, $file) = @_; return unless defined $self->{_response_cache}; $self->throw("Must pass file name") unless $file; require Bio::Root::IO; my $out = Bio::Root::IO->new(-file => ">$file"); $out->_print($self->{_response_cache}->content); $out->flush(); $out->close; } 1; BioPerl-1.6.923/Bio/DB/GenPept.pm000444000765000024 1452512254227330 16361 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::GenPept # # Please direct questions and support issues to # # Cared for by Aaron Mackey # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # completely reworked by Jason Stajich to use Bio::DB::WebDBSeqI 2000-12-12 =head1 NAME Bio::DB::GenPept - Database object interface to GenPept =head1 SYNOPSIS $gb = Bio::DB::GenPept->new(); $seq = $gb->get_Seq_by_id('195055'); # Unique ID # or ... $seq = $gb->get_Seq_by_acc('DEECTH'); # Accession Number my $seqio = $gb->get_Stream_by_id(['195055', 'DEECTH']); while( my $seq = $seqio->next_seq ) { print "seq is is ", $seq->display_id, "\n"; } =head1 DESCRIPTION Allows the dynamic retrieval of Sequence objects (Bio::Seq) from the GenPept database at NCBI, via an Entrez query. WARNING: Please do NOT spam the Entrez web server with multiple requests. NCBI offers Batch Entrez for this purpose. Batch Entrez support will likely be supported in a future version of DB::GenPept. Currently the only return format supported by NCBI Entrez for GenPept database is GenPept format, so any format specification passed to GenPept will be ignored still be forced to GenPept format (which is just GenBank format). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey, Jason Stajich Email amackey@virginia.edu Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::GenPept; use strict; use vars qw($DEFAULTFORMAT $DEFAULTMODE %PARAMSTRING); use base qw(Bio::DB::NCBIHelper); BEGIN { $DEFAULTMODE = 'single'; $DEFAULTFORMAT = 'gp'; %PARAMSTRING = ( 'batch' => { 'db' => 'protein', 'usehistory' => 'n', 'tool' => 'bioperl'}, # no query? 'gi' => { 'db' => 'protein', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, 'version' => { 'db' => 'protein', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, 'single' => { 'db' => 'protein', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, 'webenv' => { 'query_key' => 'querykey', 'WebEnv' => 'cookie', 'db' => 'protein', 'usehistory' => 'n', 'tool' => 'bioperl', 'retmode' => 'text'}, ); } # the new way to make modules a little more lightweight sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->request_format($self->default_format); return $self; } =head2 get_params Title : get_params Usage : my %params = $self->get_params($mode) Function: Returns key,value pairs to be passed to NCBI database for either 'batch' or 'single' sequence retrieval method Returns : a key,value pair hash Args : 'single' or 'batch' mode for retrieval =cut sub get_params { my ($self, $mode) = @_; return defined $PARAMSTRING{$mode} ? %{$PARAMSTRING{$mode}} : %{$PARAMSTRING{$DEFAULTMODE}}; } =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: Returns default sequence format for this module Returns : string Args : none =cut sub default_format { return $DEFAULTFORMAT; } # from Bio::DB::WebDBSeqI from Bio::DB::RandomAccessI =head1 Routines from Bio::DB::WebDBSeqI and Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('AAC73346'); Function: Gets a Seq objects by accession number Returns : Bio::Seq object Args : accession number to retrive by =head1 Routines implemented by Bio::DB::NCBIHelper =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: HTTP::Request Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id( [$uid1, $uid2] ); Function: Gets a series of Seq objects by unique identifiers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of unique identifiers for the desired sequence entries =head2 get_Stream_by_acc (2) Title : get_Stream_by_acc Usage : $seq = $db->get_Stream_by_acc($acc); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =head2 request_format Title : request_format Usage : my $format = $self->request_format; $self->request_format($format); Function: Get/Set sequence format retrieval Returns : string representing format Args : $format = sequence format =cut # override to force format to be GenPept regardless sub request_format { my ($self) = @_; return $self->SUPER::request_format($self->default_format()); } 1; __END__ BioPerl-1.6.923/Bio/DB/GFF.pm000444000765000024 34750512254227340 15451 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::DB::GFF -- Storage and retrieval of sequence annotation data =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi::mysqlopt', -dsn => 'dbi:mysql:elegans'); # fetch a 1 megabase segment of sequence starting at landmark "ZK909" my $segment = $db->segment('ZK909', 1 => 1000000); # pull out all transcript features my @transcripts = $segment->features('transcript'); # for each transcript, total the length of the introns my %totals; for my $t (@transcripts) { my @introns = $t->Intron; $totals{$t->name} += $_->length foreach @introns; } # Sort the exons of the first transcript by position my @exons = sort {$a->start <=> $b->start} $transcripts[0]->Exon; # Get a region 1000 bp upstream of first exon my $upstream = $exons[0]->subseq(-1000,0); # get its DNA my $dna = $upstream->seq; # and get all curated polymorphisms inside it @polymorphisms = $upstream->contained_features('polymorphism:curated'); # get all feature types in the database my @types = $db->types; # count all feature types in the segment my %type_counts = $segment->types(-enumerate=>1); # get an iterator on all curated features of type 'exon' or 'intron' my $iterator = $db->get_seq_stream(-type => ['exon:curated','intron:curated']); while (my $s = $iterator->next_seq) { print $s,"\n"; } # find all transcripts annotated as having function 'kinase' my $iterator = $db->get_seq_stream(-type=>'transcript', -attributes=>{Function=>'kinase'}); while (my $s = $iterator->next_seq) { print $s,"\n"; } =head1 DESCRIPTION Bio::DB::GFF provides fast indexed access to a sequence annotation database. It supports multiple database types (ACeDB, relational), and multiple schemas through a system of adaptors and aggregators. The following operations are supported by this module: - retrieving a segment of sequence based on the ID of a landmark - retrieving the DNA from that segment - finding all annotations that overlap with the segment - finding all annotations that are completely contained within the segment - retrieving all annotations of a particular type, either within a segment, or globally - conversion from absolute to relative coordinates and back again, using any arbitrary landmark for the relative coordinates - using a sequence segment to create new segments based on relative offsets The data model used by Bio::DB::GFF is compatible with the GFF flat file format (L). The module can load a set of GFF files into the database, and serves objects that have methods corresponding to GFF fields. The objects returned by Bio::DB::GFF are compatible with the SeqFeatureI interface, allowing their use by the Bio::Graphics and Bio::DAS modules. =head2 Auxiliary Scripts The bioperl distribution includes several scripts that make it easier to work with Bio::DB::GFF databases. They are located in the scripts directory under a subdirectory named Bio::DB::GFF: =over 4 =item * bp_load_gff.pl This script will load a Bio::DB::GFF database from a flat GFF file of sequence annotations. Only the relational database version of Bio::DB::GFF is supported. It can be used to create the database from scratch, as well as to incrementally load new data. This script takes a --fasta argument to load raw DNA into the database as well. However, GFF databases do not require access to the raw DNA for most of their functionality. load_gff.pl also has a --upgrade option, which will perform a non-destructive upgrade of older schemas to newer ones. =item * bp_bulk_load_gff.pl This script will populate a Bio::DB::GFF database from a flat GFF file of sequence annotations. Only the MySQL database version of Bio::DB::GFF is supported. It uses the "LOAD DATA INFILE" query in order to accelerate loading considerably; however, it can only be used for the initial load, and not for updates. This script takes a --fasta argument to load raw DNA into the database as well. However, GFF databases do not require access to the raw DNA for most of their functionality. =item * bp_fast_load_gff.pl This script is as fast as bp_bulk_load_gff.pl but uses Unix pipe tricks to allow for incremental updates. It only supports the MySQL database version of Bio::DB::GFF and is guaranteed not to work on non-Unix platforms. Arguments are the same as bp_load_gff.pl =item * gadfly_to_gff.pl This script will convert the GFF-like format used by the Berkeley Drosophila Sequencing project into a format suitable for use with this module. =item * sgd_to_gff.pl This script will convert the tab-delimited feature files used by the Saccharomyces Genome Database into a format suitable for use with this module. =back =head2 GFF Fundamentals The GFF format is a flat tab-delimited file, each line of which corresponds to an annotation, or feature. Each line has nine columns and looks like this: Chr1 curated CDS 365647 365963 . + 1 Transcript "R119.7" The 9 columns are as follows: =over 4 =item 1. reference sequence This is the ID of the sequence that is used to establish the coordinate system of the annotation. In the example above, the reference sequence is "Chr1". =item 2. source The source of the annotation. This field describes how the annotation was derived. In the example above, the source is "curated" to indicate that the feature is the result of human curation. The names and versions of software programs are often used for the source field, as in "tRNAScan-SE/1.2". =item 3. method The annotation method. This field describes the type of the annotation, such as "CDS". Together the method and source describe the annotation type. =item 4. start position The start of the annotation relative to the reference sequence. =item 5. stop position The stop of the annotation relative to the reference sequence. Start is always less than or equal to stop. =item 6. score For annotations that are associated with a numeric score (for example, a sequence similarity), this field describes the score. The score units are completely unspecified, but for sequence similarities, it is typically percent identity. Annotations that don't have a score can use "." =item 7. strand For those annotations which are strand-specific, this field is the strand on which the annotation resides. It is "+" for the forward strand, "-" for the reverse strand, or "." for annotations that are not stranded. =item 8. phase For annotations that are linked to proteins, this field describes the phase of the annotation on the codons. It is a number from 0 to 2, or "." for features that have no phase. =item 9. group GFF provides a simple way of generating annotation hierarchies ("is composed of" relationships) by providing a group field. The group field contains the class and ID of an annotation which is the logical parent of the current one. In the example given above, the group is the Transcript named "R119.7". The group field is also used to store information about the target of sequence similarity hits, and miscellaneous notes. See the next section for a description of how to describe similarity targets. The format of the group fields is "Class ID" with a single space (not a tab) separating the class from the ID. It is VERY IMPORTANT to follow this format, or grouping will not work properly. =back The sequences used to establish the coordinate system for annotations can correspond to sequenced clones, clone fragments, contigs or super-contigs. Thus, this module can be used throughout the lifecycle of a sequencing project. In addition to a group ID, the GFF format allows annotations to have a group class. For example, in the ACeDB representation, RNA interference experiments have a class of "RNAi" and an ID that is unique among the RNAi experiments. Since not all databases support this notion, the class is optional in all calls to this module, and defaults to "Sequence" when not provided. Double-quotes are sometimes used in GFF files around components of the group field. Strictly, this is only necessary if the group name or class contains whitespace. =head2 Making GFF files work with this module Some annotations do not need to be individually named. For example, it is probably not useful to assign a unique name to each ALU repeat in a vertebrate genome. Others, such as predicted genes, correspond to named biological objects; you probably want to be able to fetch the positions of these objects by referring to them by name. To accommodate named annotations, the GFF format places the object class and name in the group field. The name identifies the object, and the class prevents similarly-named objects, for example clones and sequences, from collding. A named object is shown in the following excerpt from a GFF file: Chr1 curated transcript 939627 942410 . + . Transcript Y95B8A.2 This object is a predicted transcript named Y95BA.2. In this case, the group field is used to identify the class and name of the object, even though no other annotation belongs to that group. It now becomes possible to retrieve the region of the genome covered by transcript Y95B8A.2 using the segment() method: $segment = $db->segment(-class=>'Transcript',-name=>'Y95B8A.2'); It is not necessary for the annotation's method to correspond to the object class, although this is commonly the case. As explained above, each annotation in a GFF file refers to a reference sequence. It is important that each reference sequence also be identified by a line in the GFF file. This allows the Bio::DB::GFF module to determine the length and class of the reference sequence, and makes it possible to do relative arithmetic. For example, if "Chr1" is used as a reference sequence, then it should have an entry in the GFF file similar to this one: Chr1 assembly chromosome 1 14972282 . + . Sequence Chr1 This indicates that the reference sequence named "Chr1" has length 14972282 bp, method "chromosome" and source "assembly". In addition, as indicated by the group field, Chr1 has class "Sequence" and name "Chr1". The object class "Sequence" is used by default when the class is not specified in the segment() call. This allows you to use a shortcut form of the segment() method: $segment = $db->segment('Chr1'); # whole chromosome $segment = $db->segment('Chr1',1=>1000); # first 1000 bp For your convenience, if, during loading a GFF file, Bio::DB::GFF encounters a line like the following: ##sequence-region Chr1 1 14972282 It will automatically generate the following entry: Chr1 reference Component 1 14972282 . + . Sequence Chr1 This is sufficient to use Chr1 as a reference point. The ##sequence-region line is frequently found in the GFF files distributed by annotation groups. =head2 Specifying the group tag A frequent problem with GFF files is the problem distinguishing which of the several tag/value pairs in the 9th column is the grouping pair. Ordinarily the first tag will be used for grouping, but some GFF manipulating tools do not preserve the order of attributes. To eliminate this ambiguity, this module provides two ways of explicitly specifying which tag to group on: =over 4 =item * Using -preferred_groups When you create a Bio::DB::GFF object, pass it a -preferred_groups=E argument. This specifies a tag that will be used for grouping. You can pass an array reference to specify a list of such tags. =item * In the GFF header The GFF file itself can specify which tags are to be used for grouping. Insert a comment like the following: ##group-tags Accession Locus This says to use the Accession tag for grouping. If it is not available, use the Locus tag. If neither tag is available, use the first pair to appear. =back These options only apply when B a GFF file into the database, and have no effect on existing databases. The group-tags comment in the GFF file will *override* the preferred groups set when you create the Bio::DB::GFF object. For backward compatibility, the tags Sequence and Transcript are always treated as grouping tags unless preferred_tags are specified. The "Target" tag is always used for grouping regardless of the preferred_groups() setting, and the tags "tstart", "tend" and "Note" cannot be used for grouping. These are historical artefacts coming from various interpretations of GFF2, and cannot be changed. =head2 Sequence alignments There are two cases in which an annotation indicates the relationship between two sequences. The first case is a similarity hit, where the annotation indicates an alignment. The second case is a map assembly, in which the annotation indicates that a portion of a larger sequence is built up from one or more smaller ones. Both cases are indicated by using the B tag in the group field. For example, a typical similarity hit will look like this: Chr1 BLASTX similarity 76953 77108 132 + 0 Target Protein:SW:ABL_DROME 493 544 The group field contains the Target tag, followed by an identifier for the biological object referred to. The GFF format uses the notation I:I for the biological object, and even though this is stylistically inconsistent, that's the way it's done. The object identifier is followed by two integers indicating the start and stop of the alignment on the target sequence. Unlike the main start and stop columns, it is possible for the target start to be greater than the target end. The previous example indicates that the the section of Chr1 from 76,953 to 77,108 aligns to the protein SW:ABL_DROME starting at position 493 and extending to position 544. A similar notation is used for sequence assembly information as shown in this example: Chr1 assembly Link 10922906 11177731 . . . Target Sequence:LINK_H06O01 1 254826 LINK_H06O01 assembly Cosmid 32386 64122 . . . Target Sequence:F49B2 6 31742 This indicates that the region between bases 10922906 and 11177731 of Chr1 are composed of LINK_H06O01 from bp 1 to bp 254826. The region of LINK_H0601 between 32386 and 64122 is, in turn, composed of the bases 5 to 31742 of cosmid F49B2. =head2 Attributes While not intended to serve as a general-purpose sequence database (see bioperl-db for that), GFF allows you to tag features with arbitrary attributes. Attributes appear in the Group field following the initial class/name pair. For example: Chr1 cur trans 939 942 . + . Transcript Y95B8A.2 ; Gene sma-3 ; Alias sma3 This line tags the feature named Transcript Y95B8A.2 as being "Gene" named sma-3 and having the Alias "sma3". Features having these attributes can be looked up using the fetch_feature_by_attribute() method. Two attributes have special meaning: "Note" is for backward compatibility and is used for unstructured text remarks. "Alias" is considered as a synonym for the feature name and will be consulted when looking up a feature by its name. =head2 Adaptors and Aggregators This module uses a system of adaptors and aggregators in order to make it adaptable to use with a variety of databases. =over 4 =item * Adaptors The core of the module handles the user API, annotation coordinate arithmetic, and other common issues. The details of fetching information from databases is handled by an adaptor, which is specified during Bio::DB::GFF construction. The adaptor encapsulates database-specific information such as the schema, user authentication and access methods. There are currently five adaptors recommended for general use: Adaptor Name Description ------------ ----------- memory A simple in-memory database suitable for testing and small data sets. berkeleydb An indexed file database based on the DB_File module, suitable for medium-sized read-only data sets. dbi::mysql An interface to a schema implemented in the Mysql relational database management system. dbi::oracle An interface to a schema implemented in the Oracle relational database management system. dbi::pg An interface to a schema implemented in the PostgreSQL relational database management system. Check the Bio/DB/GFF/Adaptor directory and subdirectories for other, more specialized adaptors, as well as experimental ones. =item * Aggregators The GFF format uses a "group" field to indicate aggregation properties of individual features. For example, a set of exons and introns may share a common transcript group, and multiple transcripts may share the same gene group. Aggregators are small modules that use the group information to rebuild the hierarchy. When a Bio::DB::GFF object is created, you indicate that it use a set of one or more aggregators. Each aggregator provides a new composite annotation type. Before the database query is generated each aggregator is called to "disaggregate" its annotation type into list of component types contained in the database. After the query is generated, each aggregator is called again in order to build composite annotations from the returned components. For example, during disaggregation, the standard "processed_transcript" aggregator generates a list of component feature types including "UTR", "CDS", and "polyA_site". Later, it aggregates these features into a set of annotations of type "processed_transcript". During aggregation, the list of aggregators is called in reverse order. This allows aggregators to collaborate to create multi-level structures: the transcript aggregator assembles transcripts from introns and exons; the gene aggregator then assembles genes from sets of transcripts. Three default aggregators are provided: transcript assembles transcripts from features of type exon, CDS, 5'UTR, 3'UTR, TSS, and PolyA clone assembles clones from Clone_left_end, Clone_right_end and Sequence features. alignment assembles gapped alignments from features of type "similarity". In addition, this module provides the optional "wormbase_gene" aggregator, which accommodates the WormBase representation of genes. This aggregator aggregates features of method "exon", "CDS", "5'UTR", "3'UTR", "polyA" and "TSS" into a single object. It also expects to find a single feature of type "Sequence" that spans the entire gene. The existing aggregators are easily customized. Note that aggregation will not occur unless you specifically request the aggregation type. For example, this call: @features = $segment->features('alignment'); will generate an array of aggregated alignment features. However, this call: @features = $segment->features(); will return a list of unaggregated similarity segments. For more informnation, see the manual pages for Bio::DB::GFF::Aggregator::processed_transcript, Bio::DB::GFF::Aggregator::clone, etc. =back =head2 Loading GFF3 Files This module will accept GFF3 files, as described at http://song.sourceforge.net/gff3.shtml. However, the implementation has some limitations. =over 4 =item GFF version string is required The GFF file B contain the version comment: ##gff-version 3 Unless this version string is present at the top of the GFF file, the loader will attempt to parse the file in GFF2 format, with less-than-desirable results. =item Only one level of nesting allowed A major restriction is that Bio::DB::GFF only allows one level of nesting of features. For nesting, the Target tag will be used preferentially followed by the ID tag, followed by the Parent tag. This means that if genes are represented like this: XXXX XXXX gene XXXX XXXX XXXX ID=myGene XXXX XXXX mRNA XXXX XXXX XXXX ID=myTranscript;Parent=myGene XXXX XXXX exon XXXX XXXX XXXX Parent=myTranscript XXXX XXXX exon XXXX XXXX XXXX Parent=myTranscript Then there will be one group called myGene containing the "gene" feature and one group called myTranscript containing the mRNA, and two exons. You can work around this restriction to some extent by using the Alias attribute literally: XXXX XXXX gene XXXX XXXX XXXX ID=myGene XXXX XXXX mRNA XXXX XXXX XXXX ID=myTranscript;Parent=myGene;Alias=myGene XXXX XXXX exon XXXX XXXX XXXX Parent=myTranscript;Alias=myGene XXXX XXXX exon XXXX XXXX XXXX Parent=myTranscript;Alias=myGene This limitation will be corrected in the next version of Bio::DB::GFF. =back =head1 API The following is the API for Bio::DB::GFF. =cut package Bio::DB::GFF; use strict; use IO::File; use File::Glob ':glob'; use Bio::DB::GFF::Util::Rearrange; use Bio::DB::GFF::RelSegment; use Bio::DB::GFF::Feature; use Bio::DB::GFF::Aggregator; use base qw(Bio::Root::Root Bio::DasI); my %valid_range_types = (overlaps => 1, contains => 1, contained_in => 1); =head1 Querying GFF Databases =head2 new Title : new Usage : my $db = Bio::DB::GFF->new(@args); Function: create a new Bio::DB::GFF object Returns : new Bio::DB::GFF object Args : lists of adaptors and aggregators Status : Public These are the arguments: -adaptor Name of the adaptor module to use. If none provided, defaults to "dbi::mysqlopt". -aggregator Array reference to a list of aggregators to apply to the database. If none provided, defaults to ['processed_transcript','alignment']. -preferred_groups When interpreteting the 9th column of a GFF2 file, the indicated group names will have preference over other attributes, even if they do not come first in the list of attributes. This can be a scalar value or an array reference. Any other named argument pairs are passed to the adaptor for processing. The adaptor argument must correspond to a module contained within the Bio::DB::GFF::Adaptor namespace. For example, the Bio::DB::GFF::Adaptor::dbi::mysql adaptor is loaded by specifying 'dbi::mysql'. By Perl convention, the adaptors names are lower case because they are loaded at run time. The aggregator array may contain a list of aggregator names, a list of initialized aggregator objects, or a string in the form "aggregator_name{subpart1,subpart2,subpart3/main_method}" (the "/main_method" part is optional, but if present a feature with the main_method must be present in order for aggregation to occur). For example, if you wish to change the components aggregated by the transcript aggregator, you could pass it to the GFF constructor this way: my $transcript = Bio::DB::Aggregator::transcript->new(-sub_parts=>[qw(exon intron utr polyA spliced_leader)]); my $db = Bio::DB::GFF->new(-aggregator=>[$transcript,'clone','alignment], -adaptor => 'dbi::mysql', -dsn => 'dbi:mysql:elegans42'); Alternatively, you could create an entirely new transcript aggregator this way: my $new_agg = 'transcript{exon,intron,utr,polyA,spliced_leader}'; my $db = Bio::DB::GFF->new(-aggregator=>[$new_agg,'clone','alignment], -adaptor => 'dbi::mysql', -dsn => 'dbi:mysql:elegans42'); See L for more details. The B<-preferred_groups> argument is used to change the default processing of the 9th column of GFF version 2 files. By default, the first tag/value pair is used to establish the group class and name. If you pass -preferred_groups a scalar, the parser will look for a tag of the indicated type and use it as the group even if it is not first in the file. If you pass this argument a list of group classes as an array ref, then the list will establish the precedence for searching. The commonly used 'dbi::mysql' adaptor recognizes the following adaptor-specific arguments: Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' If a partial name is given, such as "ens0040", the "dbi:mysql:" prefix will be added automatically. -user username for authentication -pass the password for authentication -refclass landmark Class; defaults to "Sequence" The commonly used 'dbi::mysqlopt' adaptor also recogizes the following arguments. Argument Description -------- ----------- -fasta path to a directory containing FASTA files for the DNA contained in this database (e.g. "/usr/local/share/fasta") -acedb an acedb URL to use when converting features into ACEDB objects (e.g. sace://localhost:2005) =cut #' sub new { my $package = shift; my ($adaptor,$aggregators,$args,$refclass,$preferred_groups); if (@_ == 1) { # special case, default to dbi::mysqlopt $adaptor = 'dbi::mysqlopt'; $args = {DSN => shift}; } else { ($adaptor,$aggregators,$refclass,$preferred_groups,$args) = rearrange([ [qw(ADAPTOR FACTORY)], [qw(AGGREGATOR AGGREGATORS)], 'REFCLASS', 'PREFERRED_GROUPS' ],@_); } $adaptor ||= 'dbi::mysqlopt'; my $class = "Bio::DB::GFF::Adaptor::\L${adaptor}\E"; unless ($class->can('new')) { eval "require $class;1;" or $package->throw("Unable to load $adaptor adaptor: $@"); } # this hack saves the memory adaptor, which loads the GFF file in new() $args->{PREFERRED_GROUPS} = $preferred_groups if defined $preferred_groups; my $self = $class->new($args); # handle preferred groups $self->preferred_groups($preferred_groups) if defined $preferred_groups; $self->default_class($refclass || 'Sequence'); # handle the aggregators. # aggregators are responsible for creating complex multi-part features # from the GFF "group" field. If none are provided, then we provide a # list of the two used in WormBase. # Each aggregator can be a scalar or a ref. In the former case # it is treated as a class name to call new() on. In the latter # the aggreator is treated as a ready made object. $aggregators = $self->default_aggregators unless defined $aggregators; my @a = ref($aggregators) eq 'ARRAY' ? @$aggregators : $aggregators; for my $a (@a) { $self->add_aggregator($a); } # default settings go here..... $self->automerge(1); # set automerge to true $self; } =head2 types Title : types Usage : $db->types(@args) Function: return list of feature types in range or database Returns : a list of Bio::DB::GFF::Typename objects Args : see below Status : public This routine returns a list of feature types known to the database. The list can be database-wide or restricted to a region. It is also possible to find out how many times each feature occurs. For range queries, it is usually more convenient to create a Bio::DB::GFF::Segment object, and then invoke it's types() method. Arguments are as follows: -ref ID of reference sequence -class class of reference sequence -start start of segment -stop stop of segment -enumerate if true, count the features The returned value will be a list of Bio::DB::GFF::Typename objects, which if evaluated in a string context will return the feature type in "method:source" format. This object class also has method() and source() methods for retrieving the like-named fields. If -enumerate is true, then the function returns a hash (not a hash reference) in which the keys are type names in "method:source" format and the values are the number of times each feature appears in the database or segment. The argument -end is a synonum for -stop, and -count is a synonym for -enumerate. =cut sub types { my $self = shift; my ($refseq,$start,$stop,$enumerate,$refclass,$types) = rearrange ([ [qw(REF REFSEQ)], qw(START), [qw(STOP END)], [qw(ENUMERATE COUNT)], [qw(CLASS SEQCLASS)], [qw(TYPE TYPES)], ],@_); $types = $self->parse_types($types) if defined $types; $self->get_types($refseq,$refclass,$start,$stop,$enumerate,$types); } =head2 classes Title : classes Usage : $db->classes Function: return list of landmark classes in database Returns : a list of classes Args : none Status : public This routine returns the list of reference classes known to the database, or empty if classes are not used by the database. Classes are distinct from types, being essentially qualifiers on the reference namespaces. =cut sub classes { my $self = shift; return (); } =head2 segment Title : segment Usage : $db->segment(@args); Function: create a segment object Returns : segment object(s) Args : numerous, see below Status : public This method generates a segment object, which is a Perl object subclassed from Bio::DB::GFF::Segment. The segment can be used to find overlapping features and the raw DNA. When making the segment() call, you specify the ID of a sequence landmark (e.g. an accession number, a clone or contig), and a positional range relative to the landmark. If no range is specified, then the entire extent of the landmark is used to generate the segment. You may also provide the ID of a "reference" sequence, which will set the coordinate system and orientation used for all features contained within the segment. The reference sequence can be changed later. If no reference sequence is provided, then the coordinate system is based on the landmark. Arguments: -name ID of the landmark sequence. -class Database object class for the landmark sequence. "Sequence" assumed if not specified. This is irrelevant for databases which do not recognize object classes. -start Start of the segment relative to landmark. Positions follow standard 1-based sequence rules. If not specified, defaults to the beginning of the landmark. -end Stop of the segment relative to the landmark. If not specified, defaults to the end of the landmark. -stop Same as -end. -offset For those who prefer 0-based indexing, the offset specifies the position of the new segment relative to the start of the landmark. -length For those who prefer 0-based indexing, the length specifies the length of the new segment. -refseq Specifies the ID of the reference landmark used to establish the coordinate system for the newly-created segment. -refclass Specifies the class of the reference landmark, for those databases that distinguish different object classes. Defaults to "Sequence". -absolute Return features in absolute coordinates rather than relative to the parent segment. -nocheck Don't check the database for the coordinates and length of this feature. Construct a segment using the indicated name as the reference, a start coordinate of 1, an undefined end coordinate, and a strand of +1. -force Same as -nocheck. -seq,-sequence,-sourceseq Aliases for -name. -begin,-end Aliases for -start and -stop -off,-len Aliases for -offset and -length -seqclass Alias for -class Here's an example to explain how this works: my $db = Bio::DB::GFF->new(-dsn => 'dbi:mysql:human',-adaptor=>'dbi::mysql'); If successful, $db will now hold the database accessor object. We now try to fetch the fragment of sequence whose ID is A0000182 and class is "Accession." my $segment = $db->segment(-name=>'A0000182',-class=>'Accession'); If successful, $segment now holds the entire segment corresponding to this accession number. By default, the sequence is used as its own reference sequence, so its first base will be 1 and its last base will be the length of the accession. Assuming that this sequence belongs to a longer stretch of DNA, say a contig, we can fetch this information like so: my $sourceseq = $segment->sourceseq; and find the start and stop on the source like this: my $start = $segment->abs_start; my $stop = $segment->abs_stop; If we had another segment, say $s2, which is on the same contiguous piece of DNA, we can pass that to the refseq() method in order to establish it as the coordinate reference point: $segment->refseq($s2); Now calling start() will return the start of the segment relative to the beginning of $s2, accounting for differences in strandedness: my $rel_start = $segment->start; IMPORTANT NOTE: This method can be used to return the segment spanned by an arbitrary named annotation. However, if the annotation appears at multiple locations on the genome, for example an EST that maps to multiple locations, then, provided that all locations reside on the same physical segment, the method will return a segment that spans the minimum and maximum positions. If the reference sequence occupies ranges on different physical segments, then it returns them all in an array context, and raises a "multiple segment exception" exception in a scalar context. =cut #' sub segment { my $self = shift; my @segments = Bio::DB::GFF::RelSegment->new(-factory => $self, $self->setup_segment_args(@_)); foreach (@segments) { $_->absolute(1) if $self->absolute; } $self->_multiple_return_args(@segments); } sub _multiple_return_args { my $self = shift; my @args = @_; if (@args == 0) { return; } elsif (@args == 1) { return $args[0]; } elsif (wantarray) { # more than one reference sequence return @args; } else { $self->error($args[0]->name, " has more than one reference sequence in database. Please call in a list context to retrieve them all."); $self->throw('multiple segment exception'); return; } } # backward compatibility -- don't use! # (deliberately undocumented too) sub abs_segment { my $self = shift; return $self->segment($self->setup_segment_args(@_),-absolute=>1); } sub setup_segment_args { my $self = shift; return @_ if defined $_[0] && $_[0] =~ /^-/; return (-name=>$_[0],-start=>$_[1],-stop=>$_[2]) if @_ == 3; return (-class=>$_[0],-name=>$_[1]) if @_ == 2; return (-name=>$_[0]) if @_ == 1; } =head2 features Title : features Usage : $db->features(@args) Function: get all features, possibly filtered by type Returns : a list of Bio::DB::GFF::Feature objects Args : see below Status : public This routine will retrieve features in the database regardless of position. It can be used to return all features, or a subset based on their method and source. Arguments are as follows: -types List of feature types to return. Argument is an array reference containing strings of the format "method:source" -merge Whether to apply aggregators to the generated features. -rare Turn on optimizations suitable for a relatively rare feature type, where it makes more sense to filter by feature type first, and then by position. -attributes A hash reference containing attributes to match. -iterator Whether to return an iterator across the features. -binsize A true value will create a set of artificial features whose start and stop positions indicate bins of the given size, and whose scores are the number of features in the bin. The class and method of the feature will be set to "bin", its source to "method:source", and its group to "bin:method:source". This is a handy way of generating histograms of feature density. If -iterator is true, then the method returns a single scalar value consisting of a Bio::SeqIO object. You can call next_seq() repeatedly on this object to fetch each of the features in turn. If iterator is false or absent, then all the features are returned as a list. Currently aggregation is disabled when iterating over a series of features. Types are indicated using the nomenclature "method:source". Either of these fields can be omitted, in which case a wildcard is used for the missing field. Type names without the colon (e.g. "exon") are interpreted as the method name and a source wild card. Regular expressions are allowed in either field, as in: "similarity:BLAST.*". The -attributes argument is a hashref containing one or more attributes to match against: -attributes => { Gene => 'abc-1', Note => 'confirmed' } Attribute matching is simple string matching, and multiple attributes are ANDed together. =cut sub features { my $self = shift; my ($types,$automerge,$sparse,$iterator,$refseq,$start,$end,$other); if (defined $_[0] && $_[0] =~ /^-/) { ($types,$automerge,$sparse,$iterator, $refseq,$start,$end, $other) = rearrange([ [qw(TYPE TYPES)], [qw(MERGE AUTOMERGE)], [qw(RARE SPARSE)], 'ITERATOR', [qw(REFSEQ SEQ_ID)], 'START', [qw(STOP END)], ],@_); } else { $types = \@_; } # for whole database retrievals, we probably don't want to automerge! $automerge = $self->automerge unless defined $automerge; $other ||= {}; $self->_features({ rangetype => $refseq ? 'overlaps' : 'contains', types => $types, refseq => $refseq, start => $start, stop => $end, }, { sparse => $sparse, automerge => $automerge, iterator =>$iterator, %$other, } ); } =head2 get_seq_stream Title : get_seq_stream Usage : my $seqio = $self->get_seq_sream(@args) Function: Performs a query and returns an iterator over it Returns : a Bio::SeqIO stream capable of producing sequence Args : As in features() Status : public This routine takes the same arguments as features(), but returns a Bio::SeqIO::Stream-compliant object. Use it like this: $stream = $db->get_seq_stream('exon'); while (my $exon = $stream->next_seq) { print $exon,"\n"; } NOTE: This is also called get_feature_stream(), since that's what it really does. =cut sub get_seq_stream { my $self = shift; my @args = !defined($_[0]) || $_[0] =~ /^-/ ? (@_,-iterator=>1) : (-types=>\@_,-iterator=>1); $self->features(@args); } *get_feature_stream = \&get_seq_stream; =head2 get_feature_by_name Title : get_feature_by_name Usage : $db->get_feature_by_name($class => $name) Function: fetch features by their name Returns : a list of Bio::DB::GFF::Feature objects Args : the class and name of the desired feature Status : public This method can be used to fetch a named feature from the database. GFF annotations are named using the group class and name fields, so for features that belong to a group of size one, this method can be used to retrieve that group (and is equivalent to the segment() method). Any Alias attributes are also searched for matching names. An alternative syntax allows you to search for features by name within a circumscribed region: @f = $db->get_feature_by_name(-class => $class,-name=>$name, -ref => $sequence_name, -start => $start, -end => $end); This method may return zero, one, or several Bio::DB::GFF::Feature objects. Aggregation is performed on features as usual. NOTE: At various times, this function was called fetch_group(), fetch_feature(), fetch_feature_by_name() and segments(). These names are preserved for backward compatibility. =cut sub get_feature_by_name { my $self = shift; my ($gclass,$gname,$automerge,$ref,$start,$end); if (@_ == 1) { $gclass = $self->default_class; $gname = shift; } else { ($gclass,$gname,$automerge,$ref,$start,$end) = rearrange(['CLASS','NAME','AUTOMERGE', ['REF','REFSEQ'], 'START',['STOP','END'] ],@_); $gclass ||= $self->default_class; } $automerge = $self->automerge unless defined $automerge; # we need to refactor this... It's repeated code (see below)... my @aggregators; if ($automerge) { for my $a ($self->aggregators) { push @aggregators,$a if $a->disaggregate([],$self); } } my %groups; # cache the groups we create to avoid consuming too much unecessary memory my $features = []; my $callback = sub { push @$features,$self->make_feature(undef,\%groups,@_) }; my $location = [$ref,$start,$end] if defined $ref; $self->_feature_by_name($gclass,$gname,$location,$callback); warn "aggregating...\n" if $self->debug; foreach my $a (@aggregators) { # last aggregator gets first shot $a->aggregate($features,$self) or next; } @$features; } # horrible indecision regarding proper names! *fetch_group = *fetch_feature = *fetch_feature_by_name = \&get_feature_by_name; *segments = \&segment; =head2 get_feature_by_target Title : get_feature_by_target Usage : $db->get_feature_by_target($class => $name) Function: fetch features by their similarity target Returns : a list of Bio::DB::GFF::Feature objects Args : the class and name of the desired feature Status : public This method can be used to fetch a named feature from the database based on its similarity hit. =cut sub get_feature_by_target { shift->get_feature_by_name(@_); } =head2 get_feature_by_attribute Title : get_feature_by_attribute Usage : $db->get_feature_by_attribute(attribute1=>value1,attribute2=>value2) Function: fetch segments by combinations of attribute values Returns : a list of Bio::DB::GFF::Feature objects Args : the class and name of the desired feature Status : public This method can be used to fetch a set of features from the database. Attributes are a list of name=Evalue pairs. They will be logically ANDED together. =cut sub get_feature_by_attribute { my $self = shift; my %attributes = ref($_[0]) ? %{$_[0]} : @_; # we need to refactor this... It's repeated code (see above)... my @aggregators; if ($self->automerge) { for my $a ($self->aggregators) { unshift @aggregators,$a if $a->disaggregate([],$self); } } my %groups; # cache the groups we create to avoid consuming too much unecessary memory my $features = []; my $callback = sub { push @$features,$self->make_feature(undef,\%groups,@_) }; $self->_feature_by_attribute(\%attributes,$callback); warn "aggregating...\n" if $self->debug; foreach my $a (@aggregators) { # last aggregator gets first shot $a->aggregate($features,$self) or next; } @$features; } # more indecision... *fetch_feature_by_attribute = \&get_feature_by_attribute; =head2 get_feature_by_id Title : get_feature_by_id Usage : $db->get_feature_by_id($id) Function: fetch segments by feature ID Returns : a Bio::DB::GFF::Feature object Args : the feature ID Status : public This method can be used to fetch a feature from the database using its ID. Not all GFF databases support IDs, so be careful with this. =cut sub get_feature_by_id { my $self = shift; my $id = ref($_[0]) eq 'ARRAY' ? $_[0] : \@_; my %groups; # cache the groups we create to avoid consuming too much unecessary memory my $features = []; my $callback = sub { push @$features,$self->make_feature(undef,\%groups,@_) }; $self->_feature_by_id($id,'feature',$callback); return wantarray ? @$features : $features->[0]; } *fetch_feature_by_id = \&get_feature_by_id; =head2 get_feature_by_gid Title : get_feature_by_gid Usage : $db->get_feature_by_gid($id) Function: fetch segments by feature ID Returns : a Bio::DB::GFF::Feature object Args : the feature ID Status : public This method can be used to fetch a feature from the database using its group ID. Not all GFF databases support IDs, so be careful with this. The group ID is often more interesting than the feature ID, since groups can be complex objects containing subobjects. =cut sub get_feature_by_gid { my $self = shift; my $id = ref($_[0]) eq 'ARRAY' ? $_[0] : \@_; my %groups; # cache the groups we create to avoid consuming too much unecessary memory my $features = []; my $callback = sub { push @$features,$self->make_feature(undef,\%groups,@_) }; $self->_feature_by_id($id,'group',$callback); return wantarray ? @$features : $features->[0]; } *fetch_feature_by_gid = \&get_feature_by_gid; =head2 delete_fattribute_to_features Title : delete_fattribute_to_features Usage : $db->delete_fattribute_to_features(@ids_or_features) Function: delete one or more fattribute_to_features Returns : count of fattribute_to_features deleted Args : list of features or feature ids Status : public Pass this method a list of numeric feature ids or a set of features. It will attempt to remove the fattribute_to_features rows of those features from the database and return a count of the rows removed. NOTE: This method is also called delete_fattribute_to_feature(). Also see delete_groups() and delete_features(). =cut *delete_fattribute_to_feature = \&delete_fattribute_to_features; sub delete_fattribute_to_features { my $self = shift; my @features_or_ids = @_; my @ids = map {UNIVERSAL::isa($_,'Bio::DB::GFF::Feature') ? $_->id : $_} @features_or_ids; return unless @ids; $self->_delete_fattribute_to_features(@ids); } =head2 delete_features Title : delete_features Usage : $db->delete_features(@ids_or_features) Function: delete one or more features Returns : count of features deleted Args : list of features or feature ids Status : public Pass this method a list of numeric feature ids or a set of features. It will attempt to remove the features from the database and return a count of the features removed. NOTE: This method is also called delete_feature(). Also see delete_groups(). =cut *delete_feature = \&delete_features; sub delete_features { my $self = shift; my @features_or_ids = @_; my @ids = map {UNIVERSAL::isa($_,'Bio::DB::GFF::Feature') ? $_->id : $_} @features_or_ids; return unless @ids; $self->_delete_features(@ids); } =head2 delete_groups Title : delete_groups Usage : $db->delete_groups(@ids_or_features) Function: delete one or more feature groups Returns : count of features deleted Args : list of features or feature group ids Status : public Pass this method a list of numeric group ids or a set of features. It will attempt to recursively remove the features and ALL members of their group from the database. It returns a count of the number of features (not groups) returned. NOTE: This method is also called delete_group(). Also see delete_features(). =cut *delete_group = \&delete_groupss; sub delete_groups { my $self = shift; my @features_or_ids = @_; my @ids = map {UNIVERSAL::isa($_,'Bio::DB::GFF::Feature') ? $_->group_id : $_} @features_or_ids; return unless @ids; $self->_delete_groups(@ids); } =head2 delete Title : delete Usage : $db->delete(@args) Function: delete features Returns : count of features deleted -- if available Args : numerous, see below Status : public This method deletes all features that overlap the specified region or are of a particular type. If no arguments are provided and the -force argument is true, then deletes ALL features. Arguments: -name ID of the landmark sequence. -ref ID of the landmark sequence (synonym for -name). -class Database object class for the landmark sequence. "Sequence" assumed if not specified. This is irrelevant for databases which do not recognize object classes. -start Start of the segment relative to landmark. Positions follow standard 1-based sequence rules. If not specified, defaults to the beginning of the landmark. -end Stop of the segment relative to the landmark. If not specified, defaults to the end of the landmark. -offset Zero-based addressing -length Length of region -type,-types Either a single scalar type to be deleted, or an reference to an array of types. -force Force operation to be performed even if it would delete entire feature table. -range_type Control the range type of the deletion. One of "overlaps" (default) "contains" or "contained_in" Examples: $db->delete(-type=>['intron','repeat:repeatMasker']); # remove all introns & repeats $db->delete(-name=>'chr3',-start=>1,-end=>1000); # remove annotations on chr3 from 1 to 1000 $db->delete(-name=>'chr3',-type=>'exon'); # remove all exons on chr3 The short form of this call, as described in segment() is also allowed: $db->delete("chr3",1=>1000); $db->delete("chr3"); IMPORTANT NOTE: This method only deletes features. It does *NOT* delete the names of groups that contain the deleted features. Group IDs will be reused if you later load a feature with the same group name as one that was previously deleted. NOTE ON FEATURE COUNTS: The DBI-based versions of this call return the result code from the SQL DELETE operation. Some dbd drivers return the count of rows deleted, while others return 0E0. Caveat emptor. =cut sub delete { my $self = shift; my @args = $self->setup_segment_args(@_); my ($name,$class,$start,$end,$offset,$length,$type,$force,$range_type) = rearrange([['NAME','REF'],'CLASS','START',[qw(END STOP)],'OFFSET', 'LENGTH',[qw(TYPE TYPES)],'FORCE','RANGE_TYPE'],@args); $offset = 0 unless defined $offset; $start = $offset+1 unless defined $start; $end = $start+$length-1 if !defined $end and $length; $class ||= $self->default_class; my $types = $self->parse_types($type); # parse out list of types $range_type ||= 'overlaps'; $self->throw("range type must be one of {". join(',',keys %valid_range_types). "}\n") unless $valid_range_types{lc $range_type}; my @segments; if (defined $name && $name ne '') { my @args = (-name=>$name,-class=>$class); push @args,(-start=>$start) if defined $start; push @args,(-end =>$end) if defined $end; @segments = $self->segment(@args); return unless @segments; } $self->_delete({segments => \@segments, types => $types, range_type => $range_type, force => $force} ); } =head2 absolute Title : absolute Usage : $abs = $db->absolute([$abs]); Function: gets/sets absolute mode Returns : current setting of absolute mode boolean Args : new setting for absolute mode boolean Status : public $db-Eabsolute(1) will turn on absolute mode for the entire database. All segments retrieved will use absolute coordinates by default, rather than relative coordinates. You can still set them to use relative coordinates by calling $segment-Eabsolute(0). Note that this is not the same as calling abs_segment(); it continues to allow you to look up groups that are not used directly as reference sequences. =cut sub absolute { my $self = shift; my $d = $self->{absolute}; $self->{absolute} = shift if @_; $d; } =head2 strict_bounds_checking Title : strict_bounds_checking Usage : $flag = $db->strict_bounds_checking([$flag]) Function: gets/sets strict bounds checking Returns : current setting of bounds checking flag Args : new setting for bounds checking flag Status : public This flag enables extra checks for segment requests that go beyond the ends of their reference sequences. If bounds checking is enabled, then retrieved segments will be truncated to their physical length, and their truncated() methods will return true. If the flag is off (the default), then the module will return segments that appear to extend beyond their physical boundaries. Requests for features beyond the end of the segment will, however, return empty. =cut sub strict_bounds_checking { my $self = shift; my $d = $self->{strict}; $self->{strict} = shift if @_; $d; } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception NOTE: Bio::DB::RandomAccessI compliant method =cut sub get_Seq_by_id { my $self = shift; $self->get_feature_by_name(@_); } =head2 get_Seq_by_accession Title : get_Seq_by_accession Usage : $seq = $db->get_Seq_by_accession('AL12234') Function: Gets a Bio::Seq object by its accession Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception NOTE: Bio::DB::RandomAccessI compliant method =cut sub get_Seq_by_accession { my $self = shift; $self->get_feature_by_name(@_); } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception NOTE: Bio::DB::RandomAccessI compliant method =cut sub get_Seq_by_acc { my $self = shift; $self->get_feature_by_name(@_); } =head2 get_Stream_by_name Title : get_Stream_by_name Usage : $seq = $db->get_Stream_by_name(@ids); Function: Retrieves a stream of Seq objects given their names Returns : a Bio::SeqIO stream object Args : an array of unique ids/accession numbers, or an array reference NOTE: This is also called get_Stream_by_batch() =cut sub get_Stream_by_name { my $self = shift; my @ids = @_; my $id = ref($ids[0]) ? $ids[0] : \@ids; Bio::DB::GFF::ID_Iterator->new($self,$id,'name'); } =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $seq = $db->get_Stream_by_id(@ids); Function: Retrieves a stream of Seq objects given their ids Returns : a Bio::SeqIO stream object Args : an array of unique ids/accession numbers, or an array reference NOTE: This is also called get_Stream_by_batch() =cut sub get_Stream_by_id { my $self = shift; my @ids = @_; my $id = ref($ids[0]) ? $ids[0] : \@ids; Bio::DB::GFF::ID_Iterator->new($self,$id,'feature'); } =head2 get_Stream_by_batch () Title : get_Stream_by_batch Usage : $seq = $db->get_Stream_by_batch(@ids); Function: Retrieves a stream of Seq objects given their ids Returns : a Bio::SeqIO stream object Args : an array of unique ids/accession numbers, or an array reference NOTE: This is the same as get_Stream_by_id(). =cut *get_Stream_by_batch = \&get_Stream_by_id; =head2 get_Stream_by_group () Bioperl compatibility. =cut sub get_Stream_by_group { my $self = shift; my @ids = @_; my $id = ref($ids[0]) ? $ids[0] : \@ids; Bio::DB::GFF::ID_Iterator->new($self,$id,'group'); } =head2 all_seqfeatures Title : all_seqfeatures Usage : @features = $db->all_seqfeatures(@args) Function: fetch all the features in the database Returns : an array of features, or an iterator Args : See below Status : public This is equivalent to calling $db-Efeatures() without any types, and will return all the features in the database. The -merge and -iterator arguments are recognized, and behave the same as described for features(). =cut sub all_seqfeatures { my $self = shift; my ($automerge,$iterator)= rearrange([ [qw(MERGE AUTOMERGE)], 'ITERATOR' ],@_); my @args; push @args,(-merge=>$automerge) if defined $automerge; push @args,(-iterator=>$iterator) if defined $iterator; $self->features(@args); } =head1 Creating and Loading GFF Databases =head2 initialize Title : initialize Usage : $db->initialize(-erase=>$erase,-option1=>value1,-option2=>value2); Function: initialize a GFF database Returns : true if initialization successful Args : a set of named parameters Status : Public This method can be used to initialize an empty database. It takes the following named arguments: -erase A boolean value. If true the database will be wiped clean if it already contains data. Other named arguments may be recognized by subclasses. They become database meta values that control various settable options. As a shortcut (and for backward compatibility) a single true argument is the same as initialize(-erase=E1). =cut sub initialize { my $self = shift; my ($erase,$meta) = rearrange(['ERASE'],@_); $meta ||= {}; # initialize (possibly erasing) return unless $self->do_initialize($erase); my @default = $self->default_meta_values; # this is an awkward way of uppercasing the # even-numbered values (necessary for case-insensitive SQL databases) for (my $i=0; $i<@default; $i++) { $default[$i] = uc $default[$i] if !($i % 2); } my %values = (@default,%$meta); foreach (keys %values) { $self->meta($_ => $values{$_}); } 1; } =head2 load_gff Title : load_gff Usage : $db->load_gff($file|$directory|$filehandle [,$verbose]); Function: load GFF data into database Returns : count of records loaded Args : a directory, a file, a list of files, or a filehandle Status : Public This method takes a single overloaded argument, which can be any of: =over 4 =item * a scalar corresponding to a GFF file on the system A pathname to a local GFF file. Any files ending with the .gz, .Z, or .bz2 suffixes will be transparently decompressed with the appropriate command-line utility. =item * an array reference containing a list of GFF files on the system For example ['/home/gff/gff1.gz','/home/gff/gff2.gz'] =item * directory path The indicated directory will be searched for all files ending in the suffixes .gff, .gff.gz, .gff.Z or .gff.bz2. =item * filehandle An open filehandle from which to read the GFF data. Tied filehandles now work as well. =item * a pipe expression A pipe expression will also work. For example, a GFF file on a remote web server can be loaded with an expression like this: $db->load_gff("lynx -dump -source http://stein.cshl.org/gff_test |"); =back The optional second argument, if true, will turn on verbose status reports that indicate the progress. If successful, the method will return the number of GFF lines successfully loaded. NOTE:this method used to be called load(), but has been changed. The old method name is also recognized. =cut sub load_gff { my $self = shift; my $file_or_directory = shift || '.'; my $verbose = shift; local $self->{__verbose__} = $verbose; return $self->do_load_gff($file_or_directory) if ref($file_or_directory) && tied *$file_or_directory; my $tied_stdin = tied(*STDIN); open my $SAVEIN,"<&STDIN" unless $tied_stdin; local @ARGV = $self->setup_argv($file_or_directory,'gff','gff3') or return; # to play tricks with reader my $result = $self->do_load_gff('ARGV'); open STDIN,"<", $SAVEIN unless $tied_stdin; # restore STDIN return $result; } *load = \&load_gff; =head2 load_gff_file Title : load_gff_file Usage : $db->load_gff_file($file [,$verbose]); Function: load GFF data into database Returns : count of records loaded Args : a path to a file Status : Public This is provided as an alternative to load_gff_file. It doesn't munge STDIN or play tricks with ARGV. =cut sub load_gff_file { my $self = shift; my $file = shift; my $verbose = shift; my $fh = IO::File->new($file) or return; return $self->do_load_gff($fh); } =head2 load_fasta Title : load_fasta Usage : $db->load_fasta($file|$directory|$filehandle); Function: load FASTA data into database Returns : count of records loaded Args : a directory, a file, a list of files, or a filehandle Status : Public This method takes a single overloaded argument, which can be any of: =over 4 =item * scalar corresponding to a FASTA file on the system A pathname to a local FASTA file. Any files ending with the .gz, .Z, or .bz2 suffixes will be transparently decompressed with the appropriate command-line utility. =item * array reference containing a list of FASTA files on the system For example ['/home/fasta/genomic.fa.gz','/home/fasta/genomic.fa.gz'] =item * path to a directory The indicated directory will be searched for all files ending in the suffixes .fa, .fa.gz, .fa.Z or .fa.bz2. =item * filehandle An open filehandle from which to read the FASTA data. =item * pipe expression A pipe expression will also work. For example, a FASTA file on a remote web server can be loaded with an expression like this: $db->load_gff("lynx -dump -source http://stein.cshl.org/fasta_test.fa |"); =back =cut sub load_fasta { my $self = shift; my $file_or_directory = shift || '.'; my $verbose = shift; local $self->{__verbose__} = $verbose; return $self->load_sequence($file_or_directory) if ref($file_or_directory) && tied *$file_or_directory; my $tied = tied(*STDIN); open my $SAVEIN, "<&STDIN" unless $tied; local @ARGV = $self->setup_argv($file_or_directory,'fa','dna','fasta') or return; # to play tricks with reader my $result = $self->load_sequence('ARGV'); open STDIN,"<", $SAVEIN unless $tied; # restore STDIN return $result; } =head2 load_fasta_file Title : load_fasta_file Usage : $db->load_fasta_file($file [,$verbose]); Function: load FASTA data into database Returns : count of records loaded Args : a path to a file Status : Public This is provided as an alternative to load_fasta. It doesn't munge STDIN or play tricks with ARGV. =cut sub load_fasta_file { my $self = shift; my $file = shift; my $verbose = shift; my $fh = IO::File->new($file) or return; return $self->do_load_fasta($fh); } =head2 load_sequence_string Title : load_sequence_string Usage : $db->load_sequence_string($id,$dna) Function: load a single DNA entry Returns : true if successfully loaded Args : a raw sequence string (DNA, RNA, protein) Status : Public =cut sub load_sequence_string { my $self = shift; my ($acc,$seq) = @_; my $offset = 0; $self->insert_sequence_chunk($acc,\$offset,\$seq) or return; $self->insert_sequence($acc,$offset,$seq) or return; 1; } sub setup_argv { my $self = shift; my $file_or_directory = shift; my @suffixes = @_; no strict 'refs'; # so that we can call fileno() on the argument my @argv; if (-d $file_or_directory) { # Because glob() is broken with long file names that contain spaces $file_or_directory = Win32::GetShortPathName($file_or_directory) if $^O =~ /^MSWin/i && eval 'use Win32; 1'; @argv = map { glob("$file_or_directory/*.{$_,$_.gz,$_.Z,$_.bz2}")} @suffixes; }elsif (my $fd = fileno($file_or_directory)) { open STDIN,"<&=$fd" or $self->throw("Can't dup STDIN"); @argv = '-'; } elsif (ref $file_or_directory) { @argv = @$file_or_directory; } else { @argv = $file_or_directory; } foreach (@argv) { if (/\.gz$/) { $_ = "gunzip -c $_ |"; } elsif (/\.Z$/) { $_ = "uncompress -c $_ |"; } elsif (/\.bz2$/) { $_ = "bunzip2 -c $_ |"; } } @argv; } =head2 lock_on_load Title : lock_on_load Usage : $lock = $db->lock_on_load([$lock]) Function: set write locking during load Returns : current value of lock-on-load flag Args : new value of lock-on-load-flag Status : Public This method is honored by some of the adaptors. If the value is true, the tables used by the GFF modules will be locked for writing during loads and inaccessible to other processes. =cut sub lock_on_load { my $self = shift; my $d = $self->{lock}; $self->{lock} = shift if @_; $d; } =head2 meta Title : meta Usage : $value = $db->meta($name [,$newval]) Function: get or set a meta variable Returns : a string Args : meta variable name and optionally value Status : abstract Get or set a named metavalues for the database. Metavalues can be used for database-specific settings. By default, this method does nothing! =cut sub meta { my $self = shift; my ($name,$value) = @_; return; } =head2 default_meta_values Title : default_meta_values Usage : %values = $db->default_meta_values Function: empty the database Returns : a list of tag=>value pairs Args : none Status : protected This method returns a list of tag=Evalue pairs that contain default meta information about the database. It is invoked by initialize() to write out the default meta values. The base class version returns an empty list. For things to work properly, meta value names must be UPPERCASE. =cut sub default_meta_values { my $self = shift; return (); } =head2 error Title : error Usage : $db->error( [$new error] ); Function: read or set error message Returns : error message Args : an optional argument to set the error message Status : Public This method can be used to retrieve the last error message. Errors are not reset to empty by successful calls, so contents are only valid immediately after an error condition has been detected. =cut sub error { my $self = shift; my $g = $self->{error}; $self->{error} = join '',@_ if @_; $g; } =head2 debug Title : debug Usage : $db->debug( [$flag] ); Function: read or set debug flag Returns : current value of debug flag Args : new debug flag (optional) Status : Public This method can be used to turn on debug messages. The exact nature of those messages depends on the adaptor in use. =cut sub debug { my $self = shift; my $g = $self->{debug}; $self->{debug} = shift if @_; $g; } =head2 automerge Title : automerge Usage : $db->automerge( [$new automerge] ); Function: get or set automerge value Returns : current value (boolean) Args : an optional argument to set the automerge value Status : Public By default, this module will use the aggregators to merge groups into single composite objects. This default can be changed to false by calling automerge(0). =cut sub automerge { my $self = shift; my $g = $self->{automerge}; $self->{automerge} = shift if @_; $g; } =head2 attributes Title : attributes Usage : @attributes = $db->attributes($id,$name) Function: get the "attributes" on a particular feature Returns : an array of string Args : feature ID Status : public Some GFF version 2 files use the groups column to store a series of attribute/value pairs. In this interpretation of GFF, the first such pair is treated as the primary group for the feature; subsequent pairs are treated as attributes. Two attributes have special meaning: "Note" is for backward compatibility and is used for unstructured text remarks. "Alias" is considered as a synonym for the feature name. If no name is provided, then attributes() returns a flattened hash, of attribute=Evalue pairs. This lets you do: %attributes = $db->attributes($id); If no arguments are provided, attributes() will return the list of all attribute names: @attribute_names = $db->attributes(); Normally, however, attributes() will be called by the feature: @notes = $feature->attributes('Note'); In a scalar context, attributes() returns the first value of the attribute if a tag is present, otherwise a hash reference in which the keys are attribute names and the values are anonymous arrays containing the values. =cut sub attributes { my $self = shift; my ($id,$tag) = @_; my @result = $self->do_attributes(@_) or return; return @result if wantarray; # what to do in an array context return $result[0] if $tag; my %result; while (my($key,$value) = splice(@result,0,2)) { push @{$result{$key}},$value; } return \%result; } =head2 fast_queries Title : fast_queries Usage : $flag = $db->fast_queries([$flag]) Function: turn on and off the "fast queries" option Returns : a boolean Args : a boolean flag (optional) Status : public The mysql database driver (and possibly others) support a "fast" query mode that caches results on the server side. This makes queries come back faster, particularly when creating iterators. The downside is that while iterating, new queries will die with a "command synch" error. This method turns the feature on and off. For databases that do not support a fast query, this method has no effect. =cut # override this method in order to set the mysql_use_result attribute, which is an obscure # but extremely powerful optimization for both performance and memory. sub fast_queries { my $self = shift; my $d = $self->{fast_queries}; $self->{fast_queries} = shift if @_; $d; } =head2 add_aggregator Title : add_aggregator Usage : $db->add_aggregator($aggregator) Function: add an aggregator to the list Returns : nothing Args : an aggregator Status : public This method will append an aggregator to the end of the list of registered aggregators. Three different argument types are accepted: 1) a Bio::DB::GFF::Aggregator object -- will be added 2) a string in the form "aggregator_name{subpart1,subpart2,subpart3/main_method}" -- will be turned into a Bio::DB::GFF::Aggregator object (the /main_method part is optional). 3) a valid Perl token -- will be turned into a Bio::DB::GFF::Aggregator subclass, where the token corresponds to the subclass name. =cut sub add_aggregator { my $self = shift; my $aggregator = shift; my $list = $self->{aggregators} ||= []; if (ref $aggregator) { # an object @$list = grep {$_->get_method ne $aggregator->get_method} @$list; push @$list,$aggregator; } elsif ($aggregator =~ /^(\w+)\{([^\/\}]+)\/?(.*)\}$/) { my($agg_name,$subparts,$mainpart) = ($1,$2,$3); my @subparts = split /,\s*/,$subparts; my @args = (-method => $agg_name, -sub_parts => \@subparts); if ($mainpart) { push @args,(-main_method => $mainpart, -whole_object => 1); } warn "making an aggregator with (@args), subparts = @subparts" if $self->debug; push @$list,Bio::DB::GFF::Aggregator->new(@args); } else { my $class = "Bio::DB::GFF::Aggregator::\L${aggregator}\E"; eval "require $class; 1" or $self->throw("Unable to load $aggregator aggregator: $@"); push @$list,$class->new(); } } =head2 aggregators Title : aggregators Usage : $db->aggregators([@new_aggregators]); Function: retrieve list of aggregators Returns : list of aggregators Args : a list of aggregators to set (optional) Status : public This method will get or set the list of aggregators assigned to the database. If 1 or more arguments are passed, the existing set will be cleared. =cut sub aggregators { my $self = shift; my $d = $self->{aggregators}; if (@_) { $self->clear_aggregators; $self->add_aggregator($_) foreach @_; } return unless $d; return @$d; } =head2 clear_aggregators Title : clear_aggregators Usage : $db->clear_aggregators Function: clears list of aggregators Returns : nothing Args : none Status : public This method will clear the aggregators stored in the database object. Use aggregators() or add_aggregator() to add some back. =cut sub clear_aggregators { shift->{aggregators} = [] } =head2 preferred_groups Title : preferred_groups Usage : $db->preferred_groups([$group_name_or_arrayref]) Function: get/set list of groups for altering GFF2 parsing Returns : a list of classes Args : new list (scalar or array ref) Status : public =cut sub preferred_groups { my $self = shift; my $d = $self->{preferred_groups}; if (@_) { my @v = map {ref($_) eq 'ARRAY' ? @$_ : $_} @_; $self->{preferred_groups} = \@v; delete $self->{preferred_groups_hash}; } return unless $d; return @$d; } sub _preferred_groups_hash { my $self = shift; my $gff3 = shift; return $self->{preferred_groups_hash} if exists $self->{preferred_groups_hash}; my $count = 0; my @preferred = $self->preferred_groups; # defaults if (!@preferred) { @preferred = $gff3 || $self->{load_data}{gff3_flag} ? qw(Target Parent ID) : qw(Target Sequence Transcript); } my %preferred = map {lc($_) => @preferred-$count++} @preferred; return $self->{preferred_groups_hash} = \%preferred; } =head1 Methods for use by Subclasses The following methods are chiefly of interest to subclasses and are not intended for use by end programmers. =head2 abscoords Title : abscoords Usage : $db->abscoords($name,$class,$refseq) Function: finds position of a landmark in reference coordinates Returns : ($ref,$class,$start,$stop,$strand) Args : name and class of landmark Status : public This method is called by Bio::DB::GFF::RelSegment to obtain the absolute coordinates of a sequence landmark. The arguments are the name and class of the landmark. If successful, abscoords() returns the ID of the reference sequence, its class, its start and stop positions, and the orientation of the reference sequence's coordinate system ("+" for forward strand, "-" for reverse strand). If $refseq is present in the argument list, it forces the query to search for the landmark in a particular reference sequence. =cut sub abscoords { my $self = shift; my ($name,$class,$refseq) = @_; $class ||= $self->{default_class}; $self->get_abscoords($name,$class,$refseq); } =head1 Protected API The following methods are not intended for public consumption, but are intended to be overridden/implemented by adaptors. =head2 default_aggregators Title : default_aggregators Usage : $db->default_aggregators; Function: retrieve list of aggregators Returns : array reference containing list of aggregator names Args : none Status : protected This method (which is intended to be overridden by adaptors) returns a list of standard aggregators to be applied when no aggregators are specified in the constructor. =cut sub default_aggregators { my $self = shift; return ['processed_transcript','alignment']; } =head2 do_load_gff Title : do_load_gff Usage : $db->do_load_gff($handle) Function: load a GFF input stream Returns : number of features loaded Args : A filehandle. Status : protected This method is called to load a GFF data stream. The method will read GFF features from EE and load them into the database. On exit the method must return the number of features loaded. Note that the method is responsible for parsing the GFF lines. This is to allow for differences in the interpretation of the "group" field, which are legion. You probably want to use load_gff() instead. It is more flexible about the arguments it accepts. =cut sub do_load_gff { my $self = shift; my $io_handle = shift; local $self->{load_data} = { lineend => (-t STDERR && !$ENV{EMACS} ? "\r" : "\n"), count => 0 }; $self->setup_load(); my $mode = 'gff'; while (<$io_handle>) { chomp; if ($mode eq 'gff') { if (/^>/) { # Sequence coming $mode = 'fasta'; $self->_load_sequence_start; $self->_load_sequence_line($_); } else { $self->_load_gff_line($_); } } elsif ($mode eq 'fasta') { if (/^##|\t/) { # Back to GFF mode $self->_load_sequence_finish; $mode = 'gff'; $self->_load_gff_line($_); } else { $self->_load_sequence_line($_); } } } $self->finish_load(); $self->_load_sequence_finish; return $self->{load_data}{count}; } sub _load_gff_line { my $self = shift; my $line = shift; my $lineend = $self->{load_data}{lineend}; $self->{load_data}{gff3_flag}++ if $line =~ /^\#\#\s*gff-version\s+3/; if (defined $self->{load_data}{gff3_flag} and !defined $self->{load_data}{gff3_warning}) { $self->print_gff3_warning(); $self->{load_data}{gff3_warning}=1; } $self->preferred_groups(split(/\s+/,$1)) if $line =~ /^\#\#\s*group-tags?\s+(.+)/; if ($line =~ /^\#\#\s*sequence-region\s+(\S+)\s+(-?\d+)\s+(-?\d+)/i) { # header line $self->load_gff_line( { ref => $1, class => 'Sequence', source => 'reference', method => 'Component', start => $2, stop => $3, score => undef, strand => undef, phase => undef, gclass => 'Sequence', gname => $1, tstart => undef, tstop => undef, attributes => [], } ); return $self->{load_data}{count}++; } return if /^#/; my ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) = split "\t",$line; return unless defined($ref) && defined($method) && defined($start) && defined($stop); foreach (\$score,\$strand,\$phase) { undef $$_ if $$_ eq '.'; } my ($gclass,$gname,$tstart,$tstop,$attributes) = $self->split_group($group,$self->{load_data}{gff3_flag}); # no standard way in the GFF file to denote the class of the reference sequence -- drat! # so we invoke the factory to do it my $class = $self->refclass($ref); # call subclass to do the dirty work if ($start > $stop) { ($start,$stop) = ($stop,$start); if ($strand eq '+') { $strand = '-'; } elsif ($strand eq '-') { $strand = '+'; } } # GFF2/3 transition stuff $gclass = [$gclass] unless ref $gclass; $gname = [$gname] unless ref $gname; for (my $i=0; $i<@$gname;$i++) { $self->load_gff_line({ref => $ref, class => $class, source => $source, method => $method, start => $start, stop => $stop, score => $score, strand => $strand, phase => $phase, gclass => $gclass->[$i], gname => $gname->[$i], tstart => $tstart, tstop => $tstop, attributes => $attributes} ); $self->{load_data}{count}++; } } sub _load_sequence_start { my $self = shift; my $ld = $self->{load_data}; undef $ld->{id}; $ld->{offset} = 0; $ld->{seq} = ''; } sub _load_sequence_finish { my $self = shift; my $ld = $self->{load_data}; $self->insert_sequence($ld->{id},$ld->{offset},$ld->{seq}) if defined $ld->{id}; } sub _load_sequence_line { my $self = shift; my $line = shift; my $ld = $self->{load_data}; my $lineend = $ld->{lineend}; if (/^>(\S+)/) { $self->insert_sequence($ld->{id},$ld->{offset},$ld->{seq}) if defined $ld->{id}; $ld->{id} = $1; $ld->{offset} = 0; $ld->{seq} = ''; $ld->{count}++; print STDERR $ld->{count}," sequences loaded$lineend" if $self->{__verbose__} && $ld->{count} % 1000 == 0; } else { $ld->{seq} .= $_; $self->insert_sequence_chunk($ld->{id},\$ld->{offset},\$ld->{seq}); } } =head2 load_sequence Title : load_sequence Usage : $db->load_sequence($handle) Function: load a FASTA data stream Returns : number of sequences Args : a filehandle to the FASTA file Status : protected You probably want to use load_fasta() instead. =cut # note - there is some repeated code here sub load_sequence { my $self = shift; my $io_handle = shift; local $self->{load_data} = { lineend => (-t STDERR && !$ENV{EMACS} ? "\r" : "\n"), count => 0 }; $self->_load_sequence_start; while (<$io_handle>) { chomp; $self->_load_sequence_line($_); } $self->_load_sequence_finish; return $self->{load_data}{count}; } sub insert_sequence_chunk { my $self = shift; my ($id,$offsetp,$seqp) = @_; if (my $cs = $self->dna_chunk_size) { while (length($$seqp) >= $cs) { my $chunk = substr($$seqp,0,$cs); $self->insert_sequence($id,$$offsetp,$chunk); $$offsetp += length($chunk); substr($$seqp,0,$cs) = ''; } } return 1; # the calling routine may expect success or failure } # used to store big pieces of DNA in itty bitty pieces sub dna_chunk_size { return 0; } sub insert_sequence { my $self = shift; my($id,$offset,$seq) = @_; $self->throw('insert_sequence(): must be defined in subclass'); } # This is the default class for reference points. Defaults to Sequence. sub default_class { my $self = shift; return 'Sequence' unless ref $self; my $d = $self->{default_class}; $self->{default_class} = shift if @_; $d; } # gets name of the reference sequence, and returns its class # currently just calls default_class sub refclass { my $self = shift; my $name = shift; return $self->default_class; } =head2 setup_load Title : setup_load Usage : $db->setup_load Function: called before load_gff_line() Returns : void Args : none Status : abstract This abstract method gives subclasses a chance to do any schema-specific initialization prior to loading a set of GFF records. It must be implemented by a subclass. =cut sub setup_load { # default, do nothing } =head2 finish_load Title : finish_load Usage : $db->finish_load Function: called after load_gff_line() Returns : number of records loaded Args : none Status :abstract This method gives subclasses a chance to do any schema-specific cleanup after loading a set of GFF records. =cut sub finish_load { # default, do nothing } =head2 load_gff_line Title : load_gff_line Usage : $db->load_gff_line(@args) Function: called to load one parsed line of GFF Returns : true if successfully inserted Args : see below Status : abstract This abstract method is called once per line of the GFF and passed a hashref containing parsed GFF fields. The fields are: {ref => $ref, class => $class, source => $source, method => $method, start => $start, stop => $stop, score => $score, strand => $strand, phase => $phase, gclass => $gclass, gname => $gname, tstart => $tstart, tstop => $tstop, attributes => $attributes} =cut sub load_gff_line { shift->throw("load_gff_line(): must be implemented by an adaptor"); } =head2 do_initialize Title : do_initialize Usage : $db->do_initialize([$erase]) Function: initialize and possibly erase database Returns : true if successful Args : optional erase flag Status : protected This method implements the initialize() method described above, and takes the same arguments. =cut sub do_initialize { shift->throw('do_initialize(): must be implemented by an adaptor'); } =head2 dna Title : dna Usage : $db->dna($id,$start,$stop,$class) Function: return the raw DNA string for a segment Returns : a raw DNA string Args : id of the sequence, its class, start and stop positions Status : public This method is invoked by Bio::DB::GFF::Segment to fetch the raw DNA sequence. Arguments: -name sequence name -start start position -stop stop position -class sequence class If start and stop are both undef, then the entire DNA is retrieved. So to fetch the whole dna, call like this: $db->dna($name_of_sequence); or like this: $db->dna(-name=>$name_of_sequence,-class=>$class_of_sequence); NOTE: you will probably prefer to create a Segment and then invoke its dna() method. =cut # call to return the DNA string for the indicated region # real work is done by get_dna() sub dna { my $self = shift; my ($id,$start,$stop,$class) = rearrange([ [qw(NAME ID REF REFSEQ)], qw(START), [qw(STOP END)], 'CLASS', ],@_); # return unless defined $start && defined $stop; $self->get_dna($id,$start,$stop,$class); } sub fetch_sequence { shift->dna(@_) } sub features_in_range { my $self = shift; my ($range_type,$refseq,$class,$start,$stop,$types,$parent,$sparse,$automerge,$iterator,$other) = rearrange([ [qw(RANGE_TYPE)], [qw(REF REFSEQ)], qw(CLASS), qw(START), [qw(STOP END)], [qw(TYPE TYPES)], qw(PARENT), [qw(RARE SPARSE)], [qw(MERGE AUTOMERGE)], 'ITERATOR' ],@_); $other ||= {}; # $automerge = $types && $self->automerge unless defined $automerge; $automerge = $self->automerge unless defined $automerge; $self->throw("range type must be one of {". join(',',keys %valid_range_types). "}\n") unless $valid_range_types{lc $range_type}; $self->_features({ rangetype => lc $range_type, refseq => $refseq, refclass => $class, start => $start, stop => $stop, types => $types }, { sparse => $sparse, automerge => $automerge, iterator => $iterator, %$other, }, $parent); } =head2 get_dna Title : get_dna Usage : $db->get_dna($id,$start,$stop,$class) Function: get DNA for indicated segment Returns : the dna string Args : sequence ID, start, stop and class Status : protected If start E stop and the sequence is nucleotide, then this method should return the reverse complement. The sequence class may be ignored by those databases that do not recognize different object types. =cut sub get_dna { my $self = shift; my ($id,$start,$stop,$class,) = @_; $self->throw("get_dna() must be implemented by an adaptor"); } =head2 get_features Title : get_features Usage : $db->get_features($search,$options,$callback) Function: get list of features for a region Returns : count of number of features retrieved Args : see below Status : protected The first argument is a hash reference containing search criteria for retrieving features. It contains the following keys: rangetype One of "overlaps", "contains" or "contained_in". Indicates the type of range query requested. refseq ID of the landmark that establishes the absolute coordinate system. refclass Class of this landmark. Can be ignored by implementations that don't recognize such distinctions. start Start of the range, inclusive. stop Stop of the range, inclusive. types Array reference containing the list of annotation types to fetch from the database. Each annotation type is an array reference consisting of [source,method]. The second argument is a hash reference containing certain options that affect the way information is retrieved: sort_by_group A flag. If true, means that the returned features should be sorted by the group that they're in. sparse A flag. If true, means that the expected density of the features is such that it will be more efficient to search by type rather than by range. If it is taking a long time to fetch features, give this a try. binsize A true value will create a set of artificial features whose start and stop positions indicate bins of the given size, and whose scores are the number of features in the bin. The class of the feature will be set to "bin", and its name to "method:source". This is a handy way of generating histograms of feature density. The third argument, the $callback, is a code reference to which retrieved features are passed. It is described in more detail below. This routine is responsible for getting arrays of GFF data out of the database and passing them to the callback subroutine. The callback does the work of constructing a Bio::DB::GFF::Feature object out of that data. The callback expects a list of 13 fields: $refseq The reference sequence $start feature start $stop feature stop $source feature source $method feature method $score feature score $strand feature strand $phase feature phase $groupclass group class (may be undef) $groupname group ID (may be undef) $tstart target start for similarity hits (may be undef) $tstop target stop for similarity hits (may be undef) $feature_id A unique feature ID (may be undef) These fields are in the same order as the raw GFF file, with the exception that the group column has been parsed into group class and group name fields. The feature ID, if provided, is a unique identifier of the feature line. The module does not depend on this ID in any way, but it is available via Bio::DB::GFF-Eid() if wanted. In the dbi::mysql and dbi::mysqlopt adaptor, the ID is a unique row ID. In the acedb adaptor it is not used. =cut =head2 feature_summary(), coverage_array() The DBI adaptors provide methods for rapidly fetching coverage statistics across a region of interest. Please see L for more information about these methods. =cut sub get_features{ my $self = shift; my ($search,$options,$callback) = @_; $self->throw("get_features() must be implemented by an adaptor"); } =head2 _feature_by_name Title : _feature_by_name Usage : $db->_feature_by_name($class,$name,$location,$callback) Function: get a list of features by name and class Returns : count of number of features retrieved Args : name of feature, class of feature, and a callback Status : abstract This method is used internally. The callback arguments are the same as those used by make_feature(). This method must be overidden by subclasses. =cut sub _feature_by_name { my $self = shift; my ($class,$name,$location,$callback) = @_; $self->throw("_feature_by_name() must be implemented by an adaptor"); } sub _feature_by_attribute { my $self = shift; my ($attributes,$callback) = @_; $self->throw("_feature_by_name() must be implemented by an adaptor"); } =head2 _feature_by_id Title : _feature_by_id Usage : $db->_feature_by_id($ids,$type,$callback) Function: get a feature based Returns : count of number of features retrieved Args : arrayref to feature IDs to fetch Status : abstract This method is used internally to fetch features either by their ID or their group ID. $ids is a arrayref containing a list of IDs, $type is one of "feature" or "group", and $callback is a callback. The callback arguments are the same as those used by make_feature(). This method must be overidden by subclasses. =cut sub _feature_by_id { my $self = shift; my ($ids,$type,$callback) = @_; $self->throw("_feature_by_id() must be implemented by an adaptor"); } =head2 overlapping_features Title : overlapping_features Usage : $db->overlapping_features(@args) Function: get features that overlap the indicated range Returns : a list of Bio::DB::GFF::Feature objects Args : see below Status : public This method is invoked by Bio::DB::GFF::Segment-Efeatures() to find the list of features that overlap a given range. It is generally preferable to create the Segment first, and then fetch the features. This method takes set of named arguments: -refseq ID of the reference sequence -class Class of the reference sequence -start Start of the desired range in refseq coordinates -stop Stop of the desired range in refseq coordinates -types List of feature types to return. Argument is an array reference containing strings of the format "method:source" -parent A parent Bio::DB::GFF::Segment object, used to create relative coordinates in the generated features. -rare Turn on an optimization suitable for a relatively rare feature type, where it will be faster to filter by feature type first and then by position, rather than vice versa. -merge Whether to apply aggregators to the generated features. -iterator Whether to return an iterator across the features. If -iterator is true, then the method returns a single scalar value consisting of a Bio::SeqIO object. You can call next_seq() repeatedly on this object to fetch each of the features in turn. If iterator is false or absent, then all the features are returned as a list. Currently aggregation is disabled when iterating over a series of features. Types are indicated using the nomenclature "method:source". Either of these fields can be omitted, in which case a wildcard is used for the missing field. Type names without the colon (e.g. "exon") are interpreted as the method name and a source wild card. Regular expressions are allowed in either field, as in: "similarity:BLAST.*". =cut # call to return the features that overlap the named region # real work is done by get_features sub overlapping_features { my $self = shift; $self->features_in_range(-range_type=>'overlaps',@_); } =head2 contained_features Title : contained_features Usage : $db->contained_features(@args) Function: get features that are contained within the indicated range Returns : a list of Bio::DB::GFF::Feature objects Args : see overlapping_features() Status : public This call is similar to overlapping_features(), except that it only retrieves features whose end points are completely contained within the specified range. Generally you will want to fetch a Bio::DB::GFF::Segment object and call its contained_features() method rather than call this directly. =cut # The same, except that it only returns features that are completely contained within the # range (much faster usually) sub contained_features { my $self = shift; $self->features_in_range(-range_type=>'contains',@_); } =head2 contained_in Title : contained_in Usage : @features = $s->contained_in(@args) Function: get features that contain this segment Returns : a list of Bio::DB::GFF::Feature objects Args : see features() Status : Public This is identical in behavior to features() except that it returns only those features that completely contain the segment. =cut sub contained_in { my $self = shift; $self->features_in_range(-range_type=>'contained_in',@_); } =head2 get_abscoords Title : get_abscoords Usage : $db->get_abscoords($name,$class,$refseq) Function: get the absolute coordinates of sequence with name & class Returns : ($absref,$absstart,$absstop,$absstrand) Args : name and class of the landmark Status : protected Given the name and class of a genomic landmark, this function returns a four-element array consisting of: $absref the ID of the reference sequence that contains this landmark $absstart the position at which the landmark starts $absstop the position at which the landmark stops $absstrand the strand of the landmark, relative to the reference sequence If $refseq is provided, the function searches only within the specified reference sequence. =cut sub get_abscoords { my $self = shift; my ($name,$class,$refseq) = @_; $self->throw("get_abscoords() must be implemented by an adaptor"); } =head2 get_types Title : get_types Usage : $db->get_types($absref,$class,$start,$stop,$count) Function: get list of all feature types on the indicated segment Returns : list or hash of Bio::DB::GFF::Typename objects Args : see below Status : protected Arguments are: $absref the ID of the reference sequence $class the class of the reference sequence $start the position to start counting $stop the position to end counting $count a boolean indicating whether to count the number of occurrences of each feature type If $count is true, then a hash is returned. The keys of the hash are feature type names in the format "method:source" and the values are the number of times a feature of this type overlaps the indicated segment. Otherwise, the call returns a set of Bio::DB::GFF::Typename objects. If $start or $stop are undef, then all features on the indicated segment are enumerated. If $absref is undef, then the call returns all feature types in the database. =cut sub get_types { my $self = shift; my ($refseq,$class,$start,$stop,$count,$types) = @_; $self->throw("get_types() must be implemented by an adaptor"); } =head2 make_feature Title : make_feature Usage : $db->make_feature(@args) Function: Create a Bio::DB::GFF::Feature object from string data Returns : a Bio::DB::GFF::Feature object Args : see below Status : internal This takes 14 arguments (really!): $parent A Bio::DB::GFF::RelSegment object $group_hash A hashref containing unique list of GFF groups $refname The name of the reference sequence for this feature $refclass The class of the reference sequence for this feature $start Start of feature $stop Stop of feature $source Feature source field $method Feature method field $score Feature score field $strand Feature strand $phase Feature phase $group_class Class of feature group $group_name Name of feature group $tstart For homologies, start of hit on target $tstop Stop of hit on target The $parent argument, if present, is used to establish relative coordinates in the resulting Bio::DB::Feature object. This allows one feature to generate a list of other features that are relative to its coordinate system (for example, finding the coordinates of the second exon relative to the coordinates of the first). The $group_hash allows the group_class/group_name strings to be turned into rich database objects via the make_obect() method (see above). Because these objects may be expensive to create, $group_hash is used to uniquefy them. The index of this hash is the composite key {$group_class,$group_name,$tstart,$tstop}. Values are whatever object is returned by the make_object() method. The remainder of the fields are taken from the GFF line, with the exception that "Target" features, which contain information about the target of a homology search, are parsed into their components. =cut # This call is responsible for turning a line of GFF into a # feature object. # The $parent argument is a Bio::DB::GFF::Segment object and is used # to establish the coordinate system for the new feature. # The $group_hash argument is an hash ref that holds previously- # generated group objects. # Other arguments are taken right out of the GFF table. sub make_feature { my $self = shift; my ($parent,$group_hash, # these arguments provided by generic mechanisms $srcseq, # the rest is provided by adaptor $start,$stop, $source,$method, $score,$strand,$phase, $group_class,$group_name, $tstart,$tstop, $db_id,$group_id) = @_; return unless $srcseq; # return undef if called with no arguments. This behavior is used for # on-the-fly aggregation. my $group; # undefined if (defined $group_class && defined $group_name) { $tstart ||= ''; $tstop ||= ''; if ($group_hash) { $group = $group_hash->{$group_class,$group_name,$tstart,$tstop} ||= $self->make_object($group_class,$group_name,$tstart,$tstop); } else { $group = $self->make_object($group_class,$group_name,$tstart,$tstop); } } # fix for some broken GFF files # unfortunately - has undesired side effects # if (defined $tstart && defined $tstop && !defined $strand) { # $strand = $tstart <= $tstop ? '+' : '-'; # } if (ref $parent) { # note that the src sequence is ignored return Bio::DB::GFF::Feature->new_from_parent($parent,$start,$stop, $method,$source, $score,$strand,$phase, $group,$db_id,$group_id, $tstart,$tstop); } else { return Bio::DB::GFF::Feature->new($self,$srcseq, $start,$stop, $method,$source, $score,$strand,$phase, $group,$db_id,$group_id, $tstart,$tstop); } } sub make_aggregated_feature { my $self = shift; my ($accumulated_features,$parent,$aggregators) = splice(@_,0,3); my $feature = $self->make_feature($parent,undef,@_); return [$feature] if $feature && !$feature->group; # if we have accumulated features and either: # (1) make_feature() returned undef, indicated very end or # (2) the current group is different from the previous one local $^W = 0; # irritating uninitialized value warning in next statement if (@$accumulated_features && (!defined($feature) || ($accumulated_features->[-1]->group ne $feature->group))) { foreach my $a (@$aggregators) { # last aggregator gets first shot $a->aggregate($accumulated_features,$self) or next; } my @result = @$accumulated_features; @$accumulated_features = $feature ? ($feature) : (); return unless @result; return \@result ; } push @$accumulated_features,$feature; return; } =head2 make_match_sub Title : make_match_sub Usage : $db->make_match_sub($types) Function: creates a subroutine used for filtering features Returns : a code reference Args : a list of parsed type names Status : protected This method is used internally to generate a code subroutine that will accept or reject a feature based on its method and source. It takes an array of parsed type names in the format returned by parse_types(), and generates an anonymous subroutine. The subroutine takes a single Bio::DB::GFF::Feature object and returns true if the feature matches one of the desired feature types, and false otherwise. =cut # a subroutine that matches features indicated by list of types sub make_match_sub { my $self = shift; my $types = shift; return sub { 1 } unless ref $types && @$types; my @expr; for my $type (@$types) { my ($method,$source) = @$type; $method = $method ? "\\Q$method\\E" : ".*"; $source = $source ? ":\\Q$source\\E" : "(?::.+)?"; push @expr,"${method}${source}"; } my $expr = join '|',@expr; return $self->{match_subs}{$expr} if $self->{match_subs}{$expr}; my $sub =<type =~ /^($expr)\$/i; } END warn "match sub: $sub\n" if $self->debug; undef $@; my $compiled_sub = eval $sub; $self->throw($@) if $@; return $self->{match_subs}{$expr} = $compiled_sub; } =head2 make_object Title : make_object Usage : $db->make_object($class,$name,$start,$stop) Function: creates a feature object Returns : a feature object Args : see below Status : protected This method is called to make an object from the GFF "group" field. By default, all Target groups are turned into Bio::DB::GFF::Homol objects, and everything else becomes a Bio::DB::GFF::Featname. However, adaptors are free to override this method to generate more interesting objects, such as true BioPerl objects, or Acedb objects. Arguments are: $name database ID for object $class class of object $start for similarities, start of match inside object $stop for similarities, stop of match inside object =cut # abstract call to turn a feature into an object, given its class and name sub make_object { my $self = shift; my ($class,$name,$start,$stop) = @_; return Bio::DB::GFF::Homol->new($self,$class,$name,$start,$stop) if defined $start and length $start; return Bio::DB::GFF::Featname->new($class,$name); } =head2 do_attributes Title : do_attributes Usage : $db->do_attributes($id [,$tag]); Function: internal method to retrieve attributes given an id and tag Returns : a list of Bio::DB::GFF::Feature objects Args : a feature id and a attribute tag (optional) Status : protected This method is overridden by subclasses in order to return a list of attributes. If called with a tag, returns the value of attributes of that tag type. If called without a tag, returns a flattened array of (tag=Evalue) pairs. A particular tag can be present multiple times. =cut sub do_attributes { my $self = shift; my ($id,$tag) = @_; return (); } =head2 clone The clone() method should be used when you want to pass the Bio::DB::GFF object to a child process across a fork(). The child must call clone() before making any queries. The default behavior is to do nothing, but adaptors that use the DBI interface may need to implement this in order to avoid database handle errors. See the dbi adaptor for an example. =cut sub clone { } =head1 Internal Methods The following methods are internal to Bio::DB::GFF and are not guaranteed to remain the same. =head2 _features Title : _features Usage : $db->_features($search,$options,$parent) Function: internal method Returns : a list of Bio::DB::GFF::Feature objects Args : see below Status : internal This is an internal method that is called by overlapping_features(), contained_features() and features() to create features based on a parent segment's coordinate system. It takes three arguments, a search options hashref, an options hashref, and a parent segment. The search hashref contains the following keys: rangetype One of "overlaps", "contains" or "contained_in". Indicates the type of range query requested. refseq reference sequence ID refclass reference sequence class start start of range stop stop of range types arrayref containing list of types in "method:source" form The options hashref contains zero or more of the following keys: sparse turn on optimizations for a rare feature automerge if true, invoke aggregators to merge features iterator if true, return an iterator The $parent argument is a scalar object containing a Bio::DB::GFF::RelSegment object or descendent. =cut #' sub _features { my $self = shift; my ($search,$options,$parent) = @_; (@{$search}{qw(start stop)}) = (@{$search}{qw(stop start)}) if defined($search->{start}) && $search->{start} > $search->{stop}; $search->{refseq} = $search->{seq_id} if exists $search->{seq_id}; my $types = $self->parse_types($search->{types}); # parse out list of types my @aggregated_types = @$types; # keep a copy # allow the aggregators to operate on the original my @aggregators; if ($options->{automerge}) { for my $a ($self->aggregators) { $a = $a->clone if $options->{iterator}; unshift @aggregators,$a if $a->disaggregate(\@aggregated_types,$self); } } if ($options->{iterator}) { my @accumulated_features; my $callback = $options->{automerge} ? sub { $self->make_aggregated_feature(\@accumulated_features,$parent,\@aggregators,@_) } : sub { [$self->make_feature($parent,undef,@_)] }; return $self->get_features_iterator({ %$search, types => \@aggregated_types }, { %$options, sort_by_group => $options->{automerge} }, $callback ); } my %groups; # cache the groups we create to avoid consuming too much unecessary memory my $features = []; my $callback = sub { push @$features,$self->make_feature($parent,\%groups,@_) }; $self->get_features({ %$search, types => \@aggregated_types }, $options, $callback); if ($options->{automerge}) { warn "aggregating...\n" if $self->debug; foreach my $a (@aggregators) { # last aggregator gets first shot warn "Aggregator $a:\n" if $self->debug; $a->aggregate($features,$self); } } @$features; } =head2 get_features_iterator Title : get_features_iterator Usage : $db->get_features_iterator($search,$options,$callback) Function: get an iterator on a features query Returns : a Bio::SeqIO object Args : as per get_features() Status : Public This method takes the same arguments as get_features(), but returns an iterator that can be used to fetch features sequentially, as per Bio::SeqIO. Internally, this method is simply a front end to range_query(). The latter method constructs and executes the query, returning a statement handle. This routine passes the statement handle to the constructor for the iterator, along with the callback. =cut sub get_features_iterator { my $self = shift; my ($search,$options,$callback) = @_; $self->throw('feature iteration is not implemented in this adaptor'); } =head2 split_group Title : split_group Usage : $db->split_group($group_field,$gff3_flag) Function: parse GFF group field Returns : ($gclass,$gname,$tstart,$tstop,$attributes) Args : the gff group column and a flag indicating gff3 compatibility Status : internal This is a method that is called by load_gff_line to parse out the contents of one or more group fields. It returns the class of the group, its name, the start and stop of the target, if any, and an array reference containing any attributes that were stuck into the group field, in [attribute_name,attribute_value] format. =cut sub split_group { my $self = shift; my ($group,$gff3) = @_; if ($gff3) { my @groups = split /[;&]/,$group; # so easy! return $self->_split_gff3_group(@groups); } else { # handle group parsing # protect embedded semicolons in the group; there must be faster/more elegant way # to do this. $group =~ s/\\;/$;/g; while ($group =~ s/( \"[^\"]*);([^\"]*\")/$1$;$2/) { 1 } my @groups = split(/\s*;\s*/,$group); foreach (@groups) { s/$;/;/g } return $self->_split_gff2_group(@groups); } } =head2 _split_gff2_group This is an internal method called by split_group(). =cut # this has gotten quite nasty due to transition from GFF2 to GFF2.5 # (artemis) to GFF3. sub _split_gff2_group { my $self = shift; my @groups = @_; my $target_found; my ($gclass,$gname,$tstart,$tstop,@attributes,@notes); for (@groups) { my ($tag,$value) = /^(\S+)(?:\s+(.+))?/; $value = '' unless defined $value; if ($value =~ /^\"(.+)\"$/) { #remove quotes $value = $1; } $value =~ s/\\t/\t/g; $value =~ s/\\r/\r/g; $value =~ s/\s+$//; # Any additional groups become part of the attributes hash # For historical reasons, the tag "Note" is treated as an # attribute, even if it is the only group. $tag ||= ''; if ($tag eq 'tstart' && $target_found) { $tstart = $value; } elsif ($tag eq 'tend' && $target_found) { $tstop = $value; } elsif (ucfirst $tag eq 'Note') { push @notes, [$tag => $value]; } elsif ($tag eq 'Target' && /([^:\"\s]+):([^\"\s]+)/) { # major disagreement in implementors of GFF2 here $target_found++; ($gclass,$gname) = ($1,$2); ($tstart,$tstop) = / (\d+) (\d+)/; } elsif (!defined($value)) { push @notes, [Note => $tag]; # e.g. "Confirmed_by_EST" } else { push @attributes, [$tag => $value]; } } # group assignment if (@attributes && !($gclass && $gname) ) { my $preferred = ref($self) ? $self->_preferred_groups_hash : {}; for my $pair (@attributes) { my ($c,$n) = @$pair; ($gclass,$gname) = ($c,$n) if !$gclass # pick up first one || ($preferred->{lc $gclass}||0) < ($preferred->{lc $c}||0); # pick up higher priority one } @attributes = grep {$gclass ne $_->[0]} @attributes; } push @attributes, @notes; return ($gclass,$gname,$tstart,$tstop,\@attributes); } =head2 gff3_name_munging Title : gff3_name_munging Usage : $db->gff3_name_munging($boolean) Function: get/set gff3_name_munging flag Returns : $current value of flag Args : new value of flag (optional) Status : utility If this is set to true (default false), then features identified in gff3 files with an ID in the format foo:bar will be parsed so that "foo" is the class and "bar" is the name. This is mostly for backward compatibility with GFF2. =cut sub gff3_name_munging { my $self = shift; my $d = $self->{gff3_name_munging}; $self->{gff3_name_munging} = shift if @_; $d; } =head2 _split_gff3_group This is called internally from split_group(). =cut sub _split_gff3_group { my $self = shift; my @groups = @_; my $dc = $self->default_class; my (%id,@attributes); for my $group (@groups) { my ($tag,$value) = split /=/,$group; $tag = unescape($tag); my @values = map {unescape($_)} split /,/,$value; # GFF2 traditionally did not distinguish between a feature's name # and the group it belonged to. This code is a transition between # gff2 and the new parent/ID dichotomy in gff3. if ($tag eq 'Parent') { my (@names,@classes); for (@values) { my ($name,$class) = $self->_gff3_name_munging($_,$dc); push @names,$name; push @classes,$class; } $id{$tag} = @names > 1 ? [\@names,\@classes] : [$names[0],$classes[0]]; } elsif ($tag eq 'ID' || $tag eq 'Name') { $id{$tag} = [$self->_gff3_name_munging(shift(@values),$dc)]; } elsif ($tag eq 'Target') { my ($gname,$tstart,$tstop) = split /\s+/,shift @values; $id{$tag} = [$self->_gff3_name_munging($gname,$dc),$tstart,$tstop]; } elsif ($tag =~ /synonym/i) { $tag = 'Alias'; } push @attributes,[$tag=>$_] foreach @values; } my $priorities = $self->_preferred_groups_hash(1); my ($gclass,$gname,$tstart,$tstop); for my $preferred (sort {$priorities->{lc $b}<=>$priorities->{lc $a}} keys %id) { unless (defined $gname) { ($gname,$gclass,$tstart,$tstop) = @{$id{$preferred}}; } } # set null gclass to empty string to preserve compatibility with # programs that expect a defined gclass if no gname $gclass ||= '' if defined $gname; return ($gclass,$gname,$tstart,$tstop,\@attributes); } # accomodation for wormbase style of class:name naming sub _gff3_name_munging { my $self = shift; my ($name,$default_class) = @_; return ($name,$default_class) unless $self->gff3_name_munging; if ($name =~ /^(\w+):(.+)/) { return ($2,$1); } else { return ($name,$default_class); } } =head2 _delete_features(), _delete_groups(),_delete(),_delete_fattribute_to_features() Title : _delete_features(), _delete_groups(),_delete(),_delete_fattribute_to_features() Usage : $count = $db->_delete_features(@feature_ids) $count = $db->_delete_groups(@group_ids) $count = $db->_delete(\%delete_spec) $count = $db->_delete_fattribute_to_features(@feature_ids) Function: low-level feature/group deleter Returns : count of groups removed Args : list of feature or group ids removed Status : for implementation by subclasses These methods need to be implemented in adaptors. For _delete_features, _delete_groups and _delete_fattribute_to_features, the arguments are a list of feature or group IDs to remove. For _delete(), the argument is a hashref with the three keys 'segments', 'types' and 'force'. The first contains an arrayref of Bio::DB::GFF::RelSegment objects to delete (all FEATURES within the segment are deleted). The second contains an arrayref of [method,source] feature types to delete. The two are ANDed together. If 'force' has a true value, this forces the operation to continue even if it would delete all features. =cut sub _delete_features { my $self = shift; my @feature_ids = @_; $self->throw('_delete_features is not implemented in this adaptor'); } sub _delete_groups { my $self = shift; my @group_ids = @_; $self->throw('_delete_groups is not implemented in this adaptor'); } sub _delete { my $self = shift; my $delete_options = shift; $self->throw('_delete is not implemented in this adaptor'); } sub _delete_fattribute_to_features { my $self = shift; my @feature_ids = @_; $self->throw('_delete_fattribute_to_features is not implemented in this adaptor'); } sub unescape { my $v = shift; $v =~ tr/+/ /; $v =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge; return $v; } sub print_gff3_warning { my $self = shift; print STDERR <$ids,db=>$db,type=>$type},$class; } sub next_seq { my $self = shift; my $next = shift @{$self->{ids}}; return unless $next; my $name = ref($next) eq 'ARRAY' ? Bio::DB::GFF::Featname->new(@$next) : $next; my $segment = $self->{type} eq 'name' ? $self->{db}->segment($name) : $self->{type} eq 'feature' ? $self->{db}->fetch_feature_by_id($name) : $self->{type} eq 'group' ? $self->{db}->fetch_feature_by_gid($name) : $self->throw("Bio::DB::GFF::ID_Iterator called to fetch an unknown type of identifier"); $self->throw("id does not exist") unless $segment; return $segment; } package Bio::DB::GFF::FeatureIterator; sub new { my $self = shift; my @features = @_; return bless \@features,ref $self || $self; } sub next_seq { my $self = shift; return unless @$self; return shift @$self; } 1; __END__ =head1 BUGS Features can only belong to a single group at a time. This must be addressed soon. Start coordinate can be greater than stop coordinate for relative addressing. This breaks strict BioPerl compatibility and must be fixed. =head1 SEE ALSO L, L, L, L, L, L L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/HIV.pm000555000765000024 5154312254227336 15457 0ustar00cjfieldsstaff000000000000# $Id: HIV.pm 232 2008-12-11 14:51:51Z maj $ # # BioPerl module for Bio::DB::HIV # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::HIV - Database object interface to the Los Alamos HIV Sequence Database =head1 SYNOPSIS $db = new Bio::DB::HIV; $seq = $db->get_Seq_by_id('94284'); # LANL sequence id $seq = $db->get_Seq_by_acc('EF432710'); # GenBank accession $q = new Bio::DB::Query::HIVQuery( " (C D)[subtype] SI[phenotype] (symptomatic AIDS)[patient_health] " ); $seqio = $db->get_Stream_by_query($q); $seq = $seqio->next_seq(); ($seq->annotation->get_Annotations('Virus'))[0]->{subtype} # returns 'D' ($seq->annotation->get_Annotations('Patient'))[0]->{patient_health} # returns 'AIDS' ($seq->annotation->get_Annotations('accession'))[0]->{value} # returns 'K03454' =head1 DESCRIPTION Bio::DB::HIV, along with L, provides an interface for obtaining annotated HIV and SIV sequences from the Los Alamos National Laboratory (LANL) HIV Sequence Database ( L ). Unannotated sequences can be retrieved directly from the database object, using either LANL ids or GenBank accessions. Annotations are obtained via a query object, and are attached to the correct C objects when the query is handled by C or C. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj@fortinbras.us =head1 CONTRIBUTORS Mark A. Jensen =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::HIV; use strict; use warnings; use vars qw( $LANL_BASE $LANL_MAP_DB $LANL_MAKE_SEARCH_IF $LANL_SEARCH ); # Object preamble - inherits from Bio::DB::WebDBSeqI use Bio::Root::Root; use HTTP::Request::Common; use Bio::DB::HIV::HIVAnnotProcessor; use base qw(Bio::DB::WebDBSeqI); BEGIN { # base change of 01/14/09 $LANL_BASE = "http://www.hiv.lanl.gov/components/sequence/HIV/asearch"; $LANL_MAP_DB = "map_db.comp"; $LANL_MAKE_SEARCH_IF = "make_search_if.comp"; $LANL_SEARCH = "search.comp"; @Bio::ResponseProblem::Exception::ISA = qw( Bio::Root::Exception ); @Bio::HIVSorry::Exception::ISA = qw ( Bio::Root::Exception ); @Bio::WebError::Exception::ISA = qw( Bio::Root::Exception ); } =head1 Constructor =head2 new Title : new Usage : my $obj = new Bio::DB::HIV(); Function: Builds a new Bio::DB::HIV object Returns : an instance of Bio::DB::HIV Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($lanl_base, $lanl_map_db, $lanl_make_search_if, $lanl_search) = $self->_rearrange([qw( LANL_BASE LANL_MAP_DB LANL_MAKE_SEARCH_IF LANL_SEARCH )], @args); $lanl_base && $self->lanl_base($lanl_base); $lanl_map_db && $self->map_db($lanl_map_db); $lanl_make_search_if && $self->make_search_if($lanl_make_search_if); $lanl_search && $self->search_($lanl_search); # defaults $self->lanl_base || $self->lanl_base($LANL_BASE); $self->map_db || $self->map_db($LANL_MAP_DB); $self->make_search_if || $self->make_search_if($LANL_MAKE_SEARCH_IF); $self->search_ || $self->search_($LANL_SEARCH); $self->url_base_address || $self->url_base_address($self->lanl_base); $self->request_format("fasta"); return $self; } =head1 WebDBSeqI compliance =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: returns a HTTP::Request object Returns : Args : %qualifiers = a hash of qualifiers with keys in (-ids, -format, -mode, -query) Note : Several layers of requests are performed to get to the sequence; see Bio::DB::Query::HIVQuery. =cut sub get_request { my $self = shift; my %quals = @_; my ($resp); my (@ids, $mode, @interface, @query_parms, $query); # html parsing regexps my $tags_re = qr{(?:\s*<[^>]+>\s*)}; my $session_id_re = qr{]*action=".*/search.comp"}; my $seqs_found_re = qr{Displaying$tags_re*(?:\s*[0-9-]*\s*)*$tags_re*of$tags_re*\s*([0-9]+)$tags_re*sequences found}; my $no_seqs_found_re = qr{Sorry.*no sequences found}; my $too_many_re = qr{too many records: $tags_re*([0-9]+)}; # find something like: # tables without join:
SequenceAccessions
my $tbl_no_join_re = qr{tables without join}i; # my $sorry_bud_re = qr{}; # handle "qualifiers" foreach (keys %quals) { m/mode/ && do { $mode = $quals{$_}; next; }; m/uids/ && do { $self->throw(-class=>"Bio::Root::BadParameter", -text=>"Arrayref required for qualifier \"$_\"", -value=>$quals{$_}) unless ref($quals{$_}) eq 'ARRAY'; @ids = @{$quals{$_}}; next; }; m/query/ && do { $self->throw(-class=>"Bio::Root::BadParameter", -text=>"Bio::DB::Query::HIVQuery required for qualifier \"$_\"", -value=>$quals{$_}) unless $quals{$_}->isa("Bio::DB::Query::HIVQuery"); $query = $quals{$_}; next; }; do { 1; #else stub }; } # what kind of request? for my $m ($mode) { ($m =~ m/single/) && do { @interface = ( 'sequenceentry' => 'se_sequence', 'sequenceentry' => 'se_id', 'action' => 'Search Interface' ); @query_parms = map { ('sequenceentry.se_id' => $_ ) } @ids; push @query_parms, ( 'sequenceentry.se_sequence'=>'Any', 'order' => 'sequenceentry.se_id', 'sort_dir' => 'ASC', 'action' => 'Search' ); }; ($mode =~ m/acc/) && do { @interface = ( 'sequenceentry' => 'se_sequence', 'sequenceentry' => 'se_id', 'sequenceaccessions' => 'sa_genbankaccession', 'sequenceaccessions' => 'sa_se_id', 'action' => 'Search Interface' ); @query_parms = map {('sequenceaccessions.sa_genbankaccession' => $_)} @ids; push @query_parms, ( 'sequenceentry.se_sequence' => 'Any', 'order' => 'sequenceaccessions.sa_genbankaccession', 'sort_dir' => 'ASC', 'action' => 'Search' ); }; ($mode =~ m/gi/) && do { $self->_sorry("-mode=>gi"); }; ($mode =~ m/version/) && do { $self->_sorry("-mode=>version"); }; ($mode =~ m/query/) && do { $self->throw(-class=>"Bio::Root::BadParameter", -text=>"Query ".($query->{'_RUN_LEVEL'} ? "has been run only at run level ".$query->{'_RUN_LEVEL'} : "has not been run").", run at level 2 with _do_query(2)", -value=>$query->{'_RUN_LEVEL'}) unless $query->{'_RUN_LEVEL'} == 2; @interface = ( 'sequenceentry' => 'se_sequence', 'sequenceentry' => 'se_id', 'action' => 'Search Interface' ); @query_parms = ("sequenceentry.se_id" =>sprintf("'%s'",join("\t", $query->ids))); # @query_parms = map { ( "sequenceentry.se_id" => $_ ) } $query->ids; push @query_parms, ( 'sequenceentry.se_sequence' => 'Any', 'order' => 'sequenceentry.se_id', 'sort_dir' => 'ASC', 'action' => 'Search' ); }; do { 1; # else stub }; } # web work eval { # capture web errors; throw below... # negotiate a session with lanl db if (!$self->_session_id) { $resp = $self->ua->get($self->_map_db_uri); $resp->is_success || die "Connect failed"; # get the session id if (!$self->_session_id) { ($self->{'_session_id'}) = ($resp->content =~ /$session_id_re/); $self->_session_id || die "Session not established"; } } # establish correct "interface" for this session id $resp = $self->ua->post($self->_make_search_if_uri, [@interface, id=>$self->_session_id]); $resp->is_success || die "Interface request failed (1)"; $self->_response($resp); $resp->content =~ /$search_form_re/ || die "Interface request failed (2)"; # interface successful, do the "pre-search" $resp = $self->ua()->post($self->_search_uri, [(@query_parms, 'id' => $self->_session_id)] ); unless ($resp->is_success) { die "Search post failed"; } $self->_response($resp); # check for error conditions for ($resp->content) { /$no_seqs_found_re/ && do { die "No sequences found"; last; }; /$too_many_re/ && do { die "Too many records ($1): must be <10000"; last; }; /$tbl_no_join_re/ && do { die "Some required tables went unjoined to query"; last; }; /$seqs_found_re/ && do { last; }; do { die "Unparsed failure"; last; }; } }; $self->throw(-class=>'Bio::WebError::Exception', -text=>$@, -value=>$resp->content) if $@; # "pre-search" successful, return request ### check this post update return POST $self->_search_uri, ['action Download.x' => 1, 'action Download.y'=>1, 'id'=>$self->_session_id ]; } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data ( 'type' => 'string', 'location' => \$datastr); Function: process downloaded data before loading into a Bio::SeqIO Returns : void Args : hash with two keys - 'type' can be 'string' or 'file' - 'location' either file location or string reference containing data =cut sub postprocess_data { # parse tab-separated value content from LANL db my ( $self, %args) = @_; my ($type, $loc) = ($args{type}, $args{location}); my (@data, @cols, %rec, $idkey, @flines); $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Argument hash requires values for keys \"type\" and \"location\"", -value=>\%args) unless ($type && $loc); for ($type) { m/string/ && do { @data = split(/\n|\r/, ${$loc}); last; }; m/file/ && do { local $/; undef $/; open (F, "<", $loc) or $self->throw( -class=>'Bio::Root::FileOpenException', -text=>"Error opening tempfile \"$loc\" for reading", -value=>$loc ); @data = split( /\n|\r/, ); close(F); last; }; do { 1; # else stub }; } $self->throw(-class=>'Bio::Root::BadParameter', -text=>'No data found in repsonse', -value=>%args) unless (@data); my $l; do { $l = shift @data; } while ( defined $l && $l !~ /Number/ ); # number-returned line @cols = split( /\t/, shift @data); # if Accession column is present, get_Stream_by_acc was called # otherwise, return lanl ids ($idkey) = grep /SE.id/i, @cols unless ($idkey) = grep /Accession/i, @cols; $self->throw(-class=>"Bio::ResponseProblem::Exception", -text=>"Trouble with column headers in LANL response", -value=>join(' ',@cols)) unless $idkey; foreach (@data) { chop; @rec{@cols} = split /\t/; push @flines, ">$rec{$idkey}\n".$rec{'Sequence'}."\n"; } for ($type) { m/string/ && do { ${$loc} = join("", @flines); last; }; m/file/ && do { open(F, ">", $loc) or $self->throw(-class=>'Bio::Root::FileOpenException', -text=>'Error opening tempfile \"$loc\" for writing', -value=>$loc); print F join("", @flines); close(F); last; }; do { 1; #else stub }; } return; } =head1 WebDBSeqI overrides =head2 get_seq_stream Title : get_seq_stream Usage : my $seqio = $self->get_seq_stream(%qualifiers) Function: builds a url and queries a web db Returns : a Bio::SeqIO stream capable of producing sequence Args : %qualifiers = a hash qualifiers that the implementing class will process to make a url suitable for web querying Note : Some tightening up of the baseclass version =cut sub get_seq_stream { my ($self, %qualifiers) = @_; my ($rformat, $ioformat) = $self->request_format(); my ($key) = grep /format$/, keys %qualifiers; $qualifiers{'-format'} = ($key ? $qualifiers{$key} : $rformat); ($rformat, $ioformat) = $self->request_format($qualifiers{'format'}); # web work is here/maj my $request = $self->get_request(%qualifiers); # authorization is here/maj $request->proxy_authorization_basic($self->authentication) if ( $self->authentication); $self->debug("request is ". $request->as_string(). "\n"); # workaround for MSWin systems (no forking available/maj) $self->retrieval_type('io_string') if $self->retrieval_type =~ /pipeline/ && $^O =~ /^MSWin/; if ($self->retrieval_type =~ /pipeline/) { # Try to create a stream using POSIX fork-and-pipe facility. # this is a *big* win when fetching thousands of sequences from # a web database because we can return the first entry while # transmission is still in progress. # Also, no need to keep sequence in memory or in a temporary file. # If this fails (Windows, MacOS 9), we fall back to non-pipelined access. # fork and pipe: _stream_request()=> my ($result,$stream) = $self->_open_pipe(); if (defined $result) { $DB::fork_TTY = File::Spec->devnull; # prevents complaints from debugge if (!$result) { # in child process $self->_stream_request($request,$stream); POSIX::_exit(0); #prevent END blocks from executing in this forked child } else { return Bio::SeqIO->new('-verbose' => $self->verbose, '-format' => $ioformat, '-fh' => $stream); } } else { $self->retrieval_type('io_string'); } } if ($self->retrieval_type =~ /temp/i) { my $dir = $self->io->tempdir( CLEANUP => 1); my ( $fh, $tmpfile) = $self->io()->tempfile( DIR => $dir ); close $fh; my $resp = $self->_request($request, $tmpfile); if( ! -e $tmpfile || -z $tmpfile || ! $resp->is_success() ) { $self->throw("WebDBSeqI Error - check query sequences!\n"); } $self->postprocess_data('type' => 'file','location' => $tmpfile); # this may get reset when requesting batch mode ($rformat,$ioformat) = $self->request_format(); if( $self->verbose > 0 ) { open(my $ERR, "<", $tmpfile); while(<$ERR>) { $self->debug($_);} } return Bio::SeqIO->new('-verbose' => $self->verbose, '-format' => $ioformat, '-file' => $tmpfile); } if ($self->retrieval_type =~ /io_string/i ) { my $resp = $self->_request($request); my $content = $resp->content_ref; $self->debug( "content is $$content\n"); if (!$resp->is_success() || length($$content) == 0) { $self->throw("WebDBSeqI Error - check query sequences!\n"); } ($rformat,$ioformat) = $self->request_format(); $self->postprocess_data('type'=> 'string', 'location' => $content); $self->debug( "str is $$content\n"); return Bio::SeqIO->new('-verbose' => $self->verbose, '-format' => $ioformat, '-fh' => new IO::String($$content)); } # if we got here, we don't know how to handle the retrieval type $self->throw("retrieval type " . $self->retrieval_type . " unsupported\n"); } =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Stream_by_acc([$acc1, $acc2]); Function: Gets a series of Seq objects by GenBank accession numbers Returns : a Bio::SeqIO stream object Args : an arrayref of accession numbers for the desired sequence entries Note : For LANL DB, alternative to LANL seqids =cut sub get_Stream_by_acc { my ($self, $ids ) = @_; return $self->get_seq_stream('-uids' => [$ids], '-mode' => 'acc'); } =head2 get_Stream_by_query Title : get_Stream_by_query Usage : $stream = $db->get_Stream_by_query($query); Function: Gets a series of Seq objects by way of a query string or oject Returns : a Bio::SeqIO stream object Args : $query : Currently, only a Bio::DB::Query::HIVQuery object. It's a good idea to create the query object first and interrogate it for the entry count before you fetch a potentially large stream. =cut sub get_Stream_by_query { my ($self, $query ) = @_; my $stream = $self->get_seq_stream('-query' => $query, '-mode'=>'query'); return new Bio::DB::HIV::HIVAnnotProcessor( -hiv_query=>$query, -source_stream=>$stream ); } sub _request { my ($self, $request,$tmpfile) = @_; my ($resp); if( defined $tmpfile && $tmpfile ne '' ) { $resp = $self->ua->request($request, $tmpfile); } else { $resp = $self->ua->request($request); } if( $resp->is_error ) { $self->throw("WebDBSeqI Request Error:\n".$resp->as_string); } return $resp; } =head1 Internals =head2 lanl_base Title : lanl_base Usage : $obj->lanl_base($newval) Function: get/set the base url of the LANL HIV database Example : Returns : value of lanl_base (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub lanl_base{ my $self = shift; return $self->{'lanl_base'} = shift if @_; return $self->{'lanl_base'}; } =head2 map_db Title : map_db Usage : $obj->map_db($newval) Function: get/set the cgi filename for map_db ("Database Map") Example : Returns : value of map_db (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub map_db{ my $self = shift; return $self->{'map_db'} = shift if @_; return $self->{'map_db'}; } =head2 make_search_if Title : make_search_if Usage : $obj->make_search_if($newval) Function: get/set the cgi filename for make_search_if ("Make Search Interface") Example : Returns : value of make_search_if (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub make_search_if{ my $self = shift; return $self->{'make_search_if'} = shift if @_; return $self->{'make_search_if'}; } =head2 search_ Title : search_ Usage : $obj->search_($newval) Function: get/set the cgi filename for the search query page ("Search Database") Example : Returns : value of search_ (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub search_{ my $self = shift; return $self->{'search_'} = shift if @_; return $self->{'search_'}; } =head2 _map_db_uri Title : _map_db_uri Usage : Function: return the full map_db uri ("Database Map") Example : Returns : scalar string Args : none =cut sub _map_db_uri{ my $self = shift; return $self->url_base_address."/".$self->map_db; } =head2 _make_search_if_uri Title : _make_search_if_uri Usage : Function: return the full make_search_if uri ("Make Search Interface") Example : Returns : scalar string Args : none =cut sub _make_search_if_uri{ my $self = shift; return $self->url_base_address."/".$self->make_search_if; } =head2 _search_uri Title : _search_uri Usage : Function: return the full search cgi uri ("Search Database") Example : Returns : scalar string Args : none =cut sub _search_uri{ my $self = shift; return $self->url_base_address."/".$self->search_; } =head2 _session_id Title : _session_id Usage : $obj->_session_id($newval) Function: Contains HIV db session id (initialized in _do_lanl_request) Example : Returns : value of _session_id (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _session_id{ my $self = shift; return $self->{'_session_id'} = shift if @_; return $self->{'_session_id'}; } =head2 _response Title : _response Usage : $obj->_response($newval) Function: hold the response to search post Example : Returns : value of _response (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _response{ my $self = shift; return $self->{'_response'} = shift if @_; return $self->{'_response'}; } =head2 Dude, sorry Title : _sorry Usage : $hiv->_sorry Function: Throws an exception for unsupported option or parameter Example : Returns : Args : scalar string =cut sub _sorry{ my $self = shift; my $parm = shift; $self->throw(-class=>"Bio::HIVSorry::Exception", -text=>"Sorry, option/parameter \"$parm\" not (yet) supported. See manpage to complain.", -value=>$parm); return; } 1; BioPerl-1.6.923/Bio/DB/IndexedBase.pm000444000765000024 7551212254227323 17177 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::IndexedBase # # You may distribute this module under the same terms as perl itself # =head1 NAME Bio::DB::IndexedBase - Base class for modules using indexed sequence files =head1 SYNOPSIS use Bio::DB::XXX; # a made-up class that uses Bio::IndexedBase # 1/ Bio::SeqIO-style access # Index some sequence files my $db = Bio::DB::XXX->new('/path/to/file'); # from a single file my $db = Bio::DB::XXX->new(['file1', 'file2']); # from multiple files my $db = Bio::DB::XXX->new('/path/to/files/'); # from a directory # Get IDs of all the sequences in the database my @ids = $db->get_all_primary_ids; # Get a specific sequence my $seq = $db->get_Seq_by_id('CHROMOSOME_I'); # Loop through all sequences my $stream = $db->get_PrimarySeq_stream; while (my $seq = $stream->next_seq) { # Do something... } # 2/ Access via filehandle my $fh = Bio::DB::XXX->newFh('/path/to/file'); while (my $seq = <$fh>) { # Do something... } # 3/ Tied-hash access tie %sequences, 'Bio::DB::XXX', '/path/to/file'; print $sequences{'CHROMOSOME_I:1,20000'}; =head1 DESCRIPTION Bio::DB::IndexedBase provides a base class for modules that want to index and read sequence files and provides persistent, random access to each sequence entry, without bringing the entire file into memory. This module is compliant with the Bio::SeqI interface and both. Bio::DB::Fasta and Bio::DB::Qual both use Bio::DB::IndexedBase. When you initialize the module, you point it at a single file, several files, or a directory of files. The first time it is run, the module generates an index of the content of the files using the AnyDBM_File module (BerkeleyDB preferred, followed by GDBM_File, NDBM_File, and SDBM_File). Subsequently, it uses the index file to find the sequence file and offset for any requested sequence. If one of the source files is updated, the module reindexes just that one file. You can also force reindexing manually at any time. For improved performance, the module keeps a cache of open filehandles, closing less-recently used ones when the cache is full. Entries may have any line length up to 65,536 characters, and different line lengths are allowed in the same file. However, within a sequence entry, all lines must be the same length except for the last. An error will be thrown if this is not the case! This module was developed for use with the C. elegans and human genomes, and has been tested with sequence segments as large as 20 megabases. Indexing the C. elegans genome (100 megabases of genomic sequence plus 100,000 ESTs) takes ~5 minutes on my 300 MHz pentium laptop. On the same system, average access time for any 200-mer within the C. elegans genome was E0.02s. =head1 DATABASE CREATION AND INDEXING The two constructors for this class are new() and newFh(). The former creates a Bio::DB::IndexedBase object which is accessed via method calls. The latter creates a tied filehandle which can be used Bio::SeqIO style to fetch sequence objects in a stream fashion. There is also a tied hash interface. =over =item $db = Bio::DB::IndexedBase-Enew($path [,%options]) Create a new Bio::DB::IndexedBase object from the files designated by $path $path may be a single file, an arrayref of files, or a directory containing such files. After the database is created, you can use methods like get_all_primary_ids() and get_Seq_by_id() to retrieve sequence objects. =item $fh = Bio::DB::IndexedBase-EnewFh($path [,%options]) Create a tied filehandle opened on a Bio::DB::IndexedBase object. Reading from this filehandle with EE will return a stream of sequence objects, Bio::SeqIO style. The path and the options should be specified as for new(). =item $obj = tie %db,'Bio::DB::IndexedBase', '/path/to/file' [,@args] Create a tied-hash by tieing %db to Bio::DB::IndexedBase using the indicated path to the files. The optional @args list is the same set used by new(). If successful, tie() returns the tied object, undef otherwise. Once tied, you can use the hash to retrieve an individual sequence by its ID, like this: my $seq = $db{CHROMOSOME_I}; The keys() and values() functions will return the sequence IDs and their sequences, respectively. In addition, each() can be used to iterate over the entire data set: while (my ($id,$sequence) = each %db) { print "$id => $sequence\n"; } When dealing with very large sequences, you can avoid bringing them into memory by calling each() in a scalar context. This returns the key only. You can then use tied(%db) to recover the Bio::DB::IndexedBase object and call its methods. while (my $id = each %db) { print "$id: $db{$sequence:1,100}\n"; print "$id: ".tied(%db)->length($id)."\n"; } In addition, you may invoke the FIRSTKEY and NEXTKEY tied hash methods directly to retrieve the first and next ID in the database, respectively. This allows to write the following iterative loop using just the object-oriented interface: my $db = Bio::DB::IndexedBase->new('/path/to/file'); for (my $id=$db->FIRSTKEY; $id; $id=$db->NEXTKEY($id)) { # do something with sequence } =back =head1 INDEX CONTENT Several attributes of each sequence are stored in the index file. Given a sequence ID, these attributes can be retrieved using the following methods: =over =item offset($id) Get the offset of the indicated sequence from the beginning of the file in which it is located. The offset points to the beginning of the sequence, not the beginning of the header line. =item strlen($id) Get the number of characters in the sequence string. =item length($id) Get the number of residues of the sequence. =item linelen($id) Get the length of the line for this sequence. If the sequence is wrapped, then linelen() is likely to be much shorter than strlen(). =item headerlen($id) Get the length of the header line for the indicated sequence. =item header_offset Get the offset of the header line for the indicated sequence from the beginning of the file in which it is located. This attribute is not stored. It is calculated from offset() and headerlen(). =item alphabet($id) Get the molecular type (alphabet) of the indicated sequence. This method handles residues according to the IUPAC convention. =item file($id) Get the the name of the file in which the indicated sequence can be found. =back =head1 INTERFACE COMPLIANCE NOTES Bio::DB::IndexedBase is compliant with the Bio::DB::SeqI and hence with the Bio::RandomAccessI interfaces. Database do not necessarily provide any meaningful internal primary ID for the sequences they store. However, Bio::DB::IndexedBase's internal primary IDs are the IDs of the sequences. This means that the same ID passed to get_Seq_by_id() and get_Seq_by_primary_id() will return the same sequence. Since this database index has no notion of sequence version or namespace, the get_Seq_by_id(), get_Seq_by_acc() and get_Seq_by_version() are identical. =head1 BUGS When a sequence is deleted from one of the files, this deletion is not detected by the module and removed from the index. As a result, a "ghost" entry will remain in the index and will return garbage results if accessed. Also, if you are indexing a directory, it is wise to not add or remove files from it. In case you have changed the files in a directory, or the sequences in a file, you can to rebuild the entire index, either by deleting it manually, or by passing -reindex=E1 to new() when initializing the module. =head1 SEE ALSO L L L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. Florent Angly (for the modularization) This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See DISCLAIMER.txt for disclaimers of warranty. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::DB::IndexedBase; BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File SDBM_File) if(!$INC{'AnyDBM_File.pm'}); } use strict; use IO::File; use AnyDBM_File; use Fcntl; use File::Spec; use File::Basename qw(basename dirname); use Bio::PrimarySeq; use base qw(Bio::DB::SeqI); # Store offset, strlen, linelen, headerlen, type and fileno use constant STRUCT => 'NNNnnCa*'; # 32-bit file offset and seq length use constant STRUCTBIG => 'QQQnnCa*'; # 64-bit use constant NA => 0; use constant DNA => 1; use constant RNA => 2; use constant PROTEIN => 3; use constant DIE_ON_MISSMATCHED_LINES => 1; # you can avoid dying if you want but you may get incorrect results =head2 new Title : new Usage : my $db = Bio::DB::IndexedBase->new($path, -reindex => 1); Function: Initialize a new database object Returns : A Bio::DB::IndexedBase object Args : A single file, or path to dir, or arrayref of files Optional arguments: Option Description Default ----------- ----------- ------- -glob Glob expression to search for files in directories * -makeid A code subroutine for transforming IDs None -maxopen Maximum size of filehandle cache 32 -debug Turn on status messages 0 -reindex Force the index to be rebuilt 0 -dbmargs Additional arguments to pass to the DBM routine None -index_name Name of the file that will hold the indices -clean Remove the index file when finished 0 The -dbmargs option can be used to control the format of the index. For example, you can pass $DB_BTREE to this argument so as to force the IDs to be sorted and retrieved alphabetically. Note that you must use the same arguments every time you open the index! The -makeid option gives you a chance to modify sequence IDs during indexing. For example, you may wish to extract a portion of the gi|gb|abc|xyz nonsense that GenBank Fasta files use. The original header line can be recovered later. The option value for -makeid should be a code reference that takes a scalar argument (the full header line) and returns a scalar or an array of scalars (the ID or IDs you want to assign). For example: $db = Bio::DB::IndexedBase->new('file.fa', -makeid => \&extract_gi); sub extract_gi { # Extract GI from GenBank my $header = shift; my ($id) = ($header =~ /gi\|(\d+)/m); return $id || ''; } extract_gi() will be called with the full header line, e.g. a Fasta line would include the "E", the ID and the description: >gi|352962132|ref|NG_030353.1| Homo sapiens sal-like 3 (Drosophila) (SALL3) In the database, this sequence can now be retrieved by its GI instead of its complete ID: my $seq = $db->get_Seq_by_id(352962132); The -makeid option is ignored after the index is constructed. =cut sub new { my ($class, $path, %opts) = @_; my $self = bless { debug => $opts{-debug} || 0, makeid => $opts{-makeid}, glob => $opts{-glob} || eval '$'.$class.'::file_glob' || '*', maxopen => $opts{-maxopen} || 32, clean => $opts{-clean} || 0, dbmargs => $opts{-dbmargs} || undef, fhcache => {}, cacheseq => {}, curopen => 0, openseq => 1, dirname => undef, offsets => undef, index_name => $opts{-index_name}, obj_class => eval '$'.$class.'::obj_class', offset_meth => \&{$class.'::_calculate_offsets'}, fileno2path => [], filepath2no => {}, }, $class; my ($offsets, $dirname); my $ref = ref $path || ''; if ( $ref eq 'ARRAY' ) { $offsets = $self->index_files($path, $opts{-reindex}); require Cwd; $dirname = Cwd::getcwd(); } else { if (-d $path) { # because Win32 glob() is broken with respect to long file names # that contain whitespace. $path = Win32::GetShortPathName($path) if $^O =~ /^MSWin/i && eval 'use Win32; 1'; $offsets = $self->index_dir($path, $opts{-reindex}); $dirname = $path; } elsif (-f _) { $offsets = $self->index_file($path, $opts{-reindex}); $dirname = dirname($path); } else { $self->throw( "No file or directory called '$path'"); } } @{$self}{qw(dirname offsets)} = ($dirname, $offsets); return $self; } =head2 newFh Title : newFh Usage : my $fh = Bio::DB::IndexedBase->newFh('/path/to/files/', %options); Function: Index and get a new Fh for a single file, several files or a directory Returns : Filehandle object Args : Same as new() =cut sub newFh { my ($class, @args) = @_; my $self = $class->new(@args); require Symbol; my $fh = Symbol::gensym; tie $$fh, 'Bio::DB::Indexed::Stream', $self or $self->throw("Could not tie filehandle: $!"); return $fh; } =head2 dbmargs Title : dbmargs Usage : my @args = $db->dbmargs; Function: Get stored dbm arguments Returns : Array Args : None =cut sub dbmargs { my $self = shift; my $args = $self->{dbmargs} or return; return ref($args) eq 'ARRAY' ? @$args : $args; } =head2 glob Title : glob Usage : my $glob = $db->glob; Function: Get the expression used to match files in directories Returns : String Args : None =cut sub glob { my $self = shift; return $self->{glob}; } =head2 index_dir Title : index_dir Usage : $db->index_dir($dir); Function: Index the files that match -glob in the given directory Returns : Hashref of offsets Args : Dirname Boolean to force a reindexing the directory =cut sub index_dir { my ($self, $dir, $force_reindex) = @_; my @files = glob( File::Spec->catfile($dir, $self->{glob}) ); $self->throw("No suitable files found in $dir") if scalar @files == 0; $self->{index_name} ||= File::Spec->catfile($dir, 'directory.index'); my $offsets = $self->_index_files(\@files, $force_reindex); return $offsets; } =head2 get_all_primary_ids Title : get_all_primary_ids, get_all_ids, ids Usage : my @ids = $db->get_all_primary_ids; Function: Get the IDs stored in all indexes. This is a Bio::DB::SeqI method implementation. Note that in this implementation, the internal database primary IDs are also the sequence IDs. Returns : List of ids Args : None =cut sub get_all_primary_ids { return keys %{shift->{offsets}}; } *ids = *get_all_ids = \&get_all_primary_ids; =head2 index_file Title : index_file Usage : $db->index_file($filename); Function: Index the given file Returns : Hashref of offsets Args : Filename Boolean to force reindexing the file =cut sub index_file { my ($self, $file, $force_reindex) = @_; $self->{index_name} ||= "$file.index"; my $offsets = $self->_index_files([$file], $force_reindex); return $offsets; } =head2 index_files Title : index_files Usage : $db->index_files(\@files); Function: Index the given files Returns : Hashref of offsets Args : Arrayref of filenames Boolean to force reindexing the files =cut sub index_files { my ($self, $files, $force_reindex) = @_; my @paths = map { File::Spec->rel2abs($_) } @$files; require Digest::MD5; my $digest = Digest::MD5::md5_hex( join('', sort @paths) ); $self->{index_name} ||= "fileset_$digest.index"; # unique name for the given files my $offsets = $self->_index_files($files, $force_reindex); return $offsets; } =head2 index_name Title : index_name Usage : my $indexname = $db->index_name($path); Function: Get the full name of the index file Returns : String Args : None =cut sub index_name { return shift->{index_name}; } =head2 path Title : path Usage : my $path = $db->path($path); Function: When a single file or a directory of files is indexed, this returns the file directory. When indexing an arbitrary list of files, the return value is the path of the current working directory. Returns : String Args : None =cut sub path { return shift->{dirname}; } =head2 get_PrimarySeq_stream Title : get_PrimarySeq_stream Usage : my $stream = $db->get_PrimarySeq_stream(); Function: Get a SeqIO-like stream of sequence objects. The stream supports a single method, next_seq(). Each call to next_seq() returns a new PrimarySeqI compliant sequence object, until no more sequences remain. This is a Bio::DB::SeqI method implementation. Returns : A Bio::DB::Indexed::Stream object Args : None =cut sub get_PrimarySeq_stream { my $self = shift; return Bio::DB::Indexed::Stream->new($self); } =head2 get_Seq_by_id Title : get_Seq_by_id, get_Seq_by_acc, get_Seq_by_version, get_Seq_by_primary_id Usage : my $seq = $db->get_Seq_by_id($id); Function: Given an ID, fetch the corresponding sequence from the database. This is a Bio::DB::SeqI and Bio::DB::RandomAccessI method implementation. Returns : A sequence object Args : ID =cut sub get_Seq_by_id { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; return if not exists $self->{offsets}{$id}; return $self->{obj_class}->new($self, $id); } *get_Seq_by_version = *get_Seq_by_primary_id = *get_Seq_by_acc = \&get_Seq_by_id; =head2 _calculate_offsets Title : _calculate_offsets Usage : $db->_calculate_offsets($filename, $offsets); Function: This method calculates the sequence offsets in a file based on ID and should be implemented by classes that use Bio::DB::IndexedBase. Returns : Hash of offsets Args : File to process Hashref of file offsets keyed by IDs. =cut sub _calculate_offsets { my $self = shift; $self->throw_not_implemented(); } sub _index_files { # Do the indexing of the given files using the index file on record my ($self, $files, $force_reindex) = @_; $self->_set_pack_method( @$files ); # Get name of index file my $index = $self->index_name; # If caller has requested reindexing, unlink the index file. unlink $index if $force_reindex; # Get the modification time of the index my $indextime = (stat $index)[9] || 0; # Register files and find if there has been any update my $modtime = 0; my @updated; for my $file (@$files) { # Register file $self->_path2fileno(basename($file)); # Any update? my $m = (stat $file)[9] || 0; if ($m > $modtime) { $modtime = $m; } if ($m > $indextime) { push @updated, $file; } } # Get termination length from first file $self->{termination_length} = $self->_calc_termination_length( $files->[0] ); # Reindex contents of changed files if needed my $reindex = $force_reindex || (scalar @updated > 0); $self->{offsets} = $self->_open_index($index, $reindex) or return; if ($reindex) { $self->{indexing} = $index; for my $file (@updated) { my $fileno = $self->_path2fileno(basename($file)); &{$self->{offset_meth}}($self, $fileno, $file, $self->{offsets}); } delete $self->{indexing}; } # Closing and reopening might help corrupted index file problem on Windows $self->_close_index($self->{offsets}); return $self->{offsets} = $self->_open_index($index); } sub _open_index { # Open index file in read-only or write mode my ($self, $index_file, $write) = @_; my %offsets; my $flags = $write ? O_CREAT|O_RDWR : O_RDONLY; my @dbmargs = $self->dbmargs; tie %offsets, 'AnyDBM_File', $index_file, $flags, 0644, @dbmargs or $self->throw( "Could not open index file $index_file: $!"); return \%offsets; } sub _close_index { # Close index file my ($self, $index) = @_; untie %$index; return 1; } sub _parse_compound_id { # Handle compound IDs: # $db->seq($id) # $db->seq($id, $start, $stop, $strand) # $db->seq("$id:$start,$stop") # $db->seq("$id:$start..$stop") # $db->seq("$id:$start-$stop") # $db->seq("$id:$start,$stop/$strand") # $db->seq("$id:$start..$stop/$strand") # $db->seq("$id:$start-$stop/$strand") # $db->seq("$id/$strand") my ($self, $id, $start, $stop, $strand) = @_; if ( (not defined $start ) && (not defined $stop ) && (not defined $strand) && ($id =~ /^ (.+?) (?:\:([\d_]+)(?:,|-|\.\.)([\d_]+))? (?:\/(.+))? $/x) ) { # Start, stop and strand not provided and ID looks like a compound ID ($id, $start, $stop, $strand) = ($1, $2, $3, $4); } # Start, stop and strand defaults $stop ||= $self->length($id) || 0; # 0 if sequence not found in database $start ||= ($stop > 0) ? 1 : 0; $strand ||= 1; # Convert numbers such as 1_000_000 to 1000000 $start =~ s/_//g; $stop =~ s/_//g; if ($start > $stop) { # Change the strand ($start, $stop) = ($stop, $start); $strand *= -1; } return $id, $start, $stop, $strand; } sub _guess_alphabet { # Determine the molecular type of the given sequence string: # 'dna', 'rna', 'protein' or '' (unknown/empty) my ($self, $string) = @_; # Handle IUPAC residues like PrimarySeq does my $alphabet = Bio::PrimarySeq::_guess_alphabet_from_string($self, $string, 1); return $alphabet eq 'dna' ? DNA : $alphabet eq 'rna' ? RNA : $alphabet eq 'protein' ? PROTEIN : NA; } sub _makeid { # Process the header line by applying any transformation given in -makeid my ($self, $header_line) = @_; return ref($self->{makeid}) eq 'CODE' ? $self->{makeid}->($header_line) : $1; } sub _check_linelength { # Check that the line length is valid. Generate an error otherwise. my ($self, $linelength) = @_; return if not defined $linelength; $self->throw( "Each line of the qual file must be less than 65,536 characters. Line ". "$. is $linelength chars." ) if $linelength > 65535; } sub _calc_termination_length { # Try the beginning of the file to determine termination length # Account for crlf-terminated Windows and Mac files my ($self, $file) = @_; my $fh = IO::File->new($file) or $self->throw( "Could not open $file: $!"); # In Windows, text files have '\r\n' as line separator, but when reading in # text mode Perl will only show the '\n'. This means that for a line "ABC\r\n", # "length $_" will report 4 although the line is 5 bytes in length. # We assume that all lines have the same line separator and only read current line. my $init_pos = tell($fh); my $curr_line = <$fh>; my $pos_diff = tell($fh) - $init_pos; my $correction = $pos_diff - length $curr_line; close $fh; $self->{termination_length} = ($curr_line =~ /\r\n$/) ? 2 : 1+$correction; return $self->{termination_length}; } sub _calc_offset { # Get the offset of the n-th residue of the sequence with the given ID # and termination length (tl) my ($self, $id, $n) = @_; my $tl = $self->{termination_length}; $n--; my ($offset, $seqlen, $linelen) = (&{$self->{unpackmeth}}($self->{offsets}{$id}))[0,1,3]; $n = 0 if $n < 0; $n = $seqlen-1 if $n >= $seqlen; return $offset + $linelen * int($n/($linelen-$tl)) + $n % ($linelen-$tl); } sub _fh { # Given a sequence ID, return the filehandle on which to find this sequence my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $file = $self->file($id) or return; return $self->_fhcache( File::Spec->catfile($self->{dirname}, $file) ) or $self->throw( "Can't open file $file"); } sub _fhcache { my ($self, $path) = @_; if (!$self->{fhcache}{$path}) { if ($self->{curopen} >= $self->{maxopen}) { my @lru = sort {$self->{cacheseq}{$a} <=> $self->{cacheseq}{$b};} keys %{$self->{fhcache}}; splice(@lru, $self->{maxopen} / 3); $self->{curopen} -= @lru; for (@lru) { delete $self->{fhcache}{$_}; } } $self->{fhcache}{$path} = IO::File->new($path) || return; binmode $self->{fhcache}{$path}; $self->{curopen}++; } $self->{cacheseq}{$path}++; return $self->{fhcache}{$path}; } #------------------------------------------------------------- # Methods to store and retrieve data from indexed file # =head2 offset Title : offset Usage : my $offset = $db->offset($id); Function: Get the offset of the indicated sequence from the beginning of the file in which it is located. The offset points to the beginning of the sequence, not the beginning of the header line. Returns : String Args : ID of sequence =cut sub offset { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; return (&{$self->{unpackmeth}}($offset))[0]; } =head2 strlen Title : strlen Usage : my $length = $db->strlen($id); Function: Get the number of characters in the sequence string. Returns : Integer Args : ID of sequence =cut sub strlen { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; return (&{$self->{unpackmeth}}($offset))[1]; } =head2 length Title : length Usage : my $length = $db->length($id); Function: Get the number of residues of the sequence. Returns : Integer Args : ID of sequence =cut sub length { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; return (&{$self->{unpackmeth}}($offset))[2]; } =head2 linelen Title : linelen Usage : my $linelen = $db->linelen($id); Function: Get the length of the line for this sequence. Returns : Integer Args : ID of sequence =cut sub linelen { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; return (&{$self->{unpackmeth}}($offset))[3]; } =head2 headerlen Title : headerlen Usage : my $length = $db->headerlen($id); Function: Get the length of the header line for the indicated sequence. Returns : Integer Args : ID of sequence =cut sub headerlen { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; return (&{$self->{unpackmeth}}($offset))[4]; } =head2 header_offset Title : header_offset Usage : my $offset = $db->header_offset($id); Function: Get the offset of the header line for the indicated sequence from the beginning of the file in which it is located. Returns : String Args : ID of sequence =cut sub header_offset { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; return if not $self->{offsets}{$id}; return $self->offset($id) - $self->headerlen($id); } =head2 alphabet Title : alphabet Usage : my $alphabet = $db->alphabet($id); Function: Get the molecular type of the indicated sequence: dna, rna or protein Returns : String Args : ID of sequence =cut sub alphabet { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; my $alphabet = (&{$self->{unpackmeth}}($offset))[5]; return : $alphabet == Bio::DB::IndexedBase::DNA ? 'dna' : $alphabet == Bio::DB::IndexedBase::RNA ? 'rna' : $alphabet == Bio::DB::IndexedBase::PROTEIN ? 'protein' : ''; } =head2 file Title : file Usage : my $file = $db->file($id); Function: Get the the name of the file in which the indicated sequence can be found. Returns : String Args : ID of sequence =cut sub file { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my $offset = $self->{offsets}{$id} or return; return $self->_fileno2path((&{$self->{unpackmeth}}($offset))[6]); } sub _fileno2path { my ($self, $fileno) = @_; return $self->{fileno2path}->[$fileno]; } sub _path2fileno { my ($self, $path) = @_; if ( not exists $self->{filepath2no}->{$path} ) { my $fileno = ($self->{filepath2no}->{$path} = 0+ $self->{fileno}++); $self->{fileno2path}->[$fileno] = $path; # Save path } return $self->{filepath2no}->{$path}; } sub _packSmall { return pack STRUCT, @_; } sub _packBig { return pack STRUCTBIG, @_; } sub _unpackSmall { return unpack STRUCT, shift; } sub _unpackBig { return unpack STRUCTBIG, shift; } sub _set_pack_method { # Determine whether to use 32 or 64 bit integers for the given files. my $self = shift; # Find the maximum file size: my ($maxsize) = sort { $b <=> $a } map { -s $_ } @_; my $fourGB = (2 ** 32) - 1; if ($maxsize > $fourGB) { # At least one file exceeds 4Gb - we will need to use 64 bit ints $self->{packmeth} = \&_packBig; $self->{unpackmeth} = \&_unpackBig; } else { $self->{packmeth} = \&_packSmall; $self->{unpackmeth} = \&_unpackSmall; } return 1; } #------------------------------------------------------------- # Tied hash logic # sub TIEHASH { return shift->new(@_); } sub FETCH { return shift->subseq(@_); } sub STORE { shift->throw("Read-only database"); } sub DELETE { shift->throw("Read-only database"); } sub CLEAR { shift->throw("Read-only database"); } sub EXISTS { return defined shift->offset(@_); } sub FIRSTKEY { return tied(%{shift->{offsets}})->FIRSTKEY(@_); } sub NEXTKEY { return tied(%{shift->{offsets}})->NEXTKEY(@_); } sub DESTROY { my $self = shift; # Close filehandles while (my ($file, $fh) = each %{ $self->{fhcache} }) { if (defined $fh) { $fh->close; } } $self->_close_index($self->{offsets}); if ( $self->{clean} || $self->{indexing} ) { # Indexing aborted or cleaning requested. Delete the index file. unlink $self->{index_name}; } return 1; } #------------------------------------------------------------- # stream-based access to the database # package Bio::DB::Indexed::Stream; use base qw(Tie::Handle Bio::DB::SeqI); sub new { my ($class, $db) = @_; my $key = $db->FIRSTKEY; return bless { db => $db, key => $key }, $class; } sub next_seq { my $self = shift; my ($key, $db) = @{$self}{'key', 'db'}; return if not defined $key; my $value = $db->get_Seq_by_id($key); $self->{key} = $db->NEXTKEY($key); return $value; } sub TIEHANDLE { my ($class, $db) = @_; return $class->new($db); } sub READLINE { my $self = shift; return $self->next_seq; } 1; BioPerl-1.6.923/Bio/DB/InMemoryCache.pm000444000765000024 1435312254227322 17502 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::InMemoryCache # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::DB::InMemoryCache - Abstract interface for a sequence database =head1 SYNOPSIS $cachedb = Bio::DB::InMemoryCache->new( -seqdb => $real_db, -number => 1000); # # get a database object somehow using a concrete class # $seq = $cachedb->get_Seq_by_id('ROA1_HUMAN'); # # $seq is a Bio::Seq object # =head1 DESCRIPTION This is a memory cache system which saves the objects returned by Bio::DB::RandomAccessI in memory to a hard limit of sequences. =head1 CONTACT Ewan Birney Ebirney@ebi.ac.ukE =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::InMemoryCache; use strict; use Bio::Seq; use base qw(Bio::Root::Root Bio::DB::SeqI); sub new { my ($class,@args) = @_; my $self = Bio::Root::Root->new(); bless $self,$class; my ($seqdb,$number,$agr) = $self->_rearrange([qw(SEQDB NUMBER AGRESSION)],@args); if( !defined $seqdb || !ref $seqdb || !$seqdb->isa('Bio::DB::RandomAccessI') ) { $self->throw("Must be a RandomAccess database not a [$seqdb]"); } if( !defined $number ) { $number = 1000; } $self->seqdb($seqdb); $self->number($number); $self->agr($agr); # we consider acc as the primary id here $self->{'_cache_number_hash'} = {}; $self->{'_cache_id_hash'} = {}; $self->{'_cache_acc_hash'} = {}; $self->{'_cache_number'} = 1; return $self; } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =cut sub get_Seq_by_id{ my ($self,$id) = @_; if( defined $self->{'_cache_id_hash'}->{$id} ) { my $acc = $self->{'_cache_id_hash'}->{$id}; my $seq = $self->{'_cache_acc_hash'}->{$acc}; $self->{'_cache_number_hash'}->{$seq->accession} = $self->{'_cache_number'}++; return $seq; } else { return $self->_load_Seq('id',$id); } } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut sub get_Seq_by_acc{ my ($self,$acc) = @_; #print STDERR "In cache get for $acc\n"; if( defined $self->{'_cache_acc_hash'}->{$acc} ) { #print STDERR "Returning cached $acc\n"; my $seq = $self->{'_cache_acc_hash'}->{$acc}; $self->{'_cache_number_hash'}->{$seq->accession} = $self->{'_cache_number'}++; return $seq; } else { return $self->_load_Seq('acc',$acc); } } sub number { my ($self, $number) = @_; if ($number) { $self->{'number'} = $number; } else { return $self->{'number'}; } } sub seqdb { my ($self, $seqdb) = @_; if ($seqdb) { $self->{'seqdb'} = $seqdb; } else { return $self->{'seqdb'}; } } sub agr { my ($self, $agr) = @_; if ($agr) { $self->{'agr'} = $agr; } else { return $self->{'agr'}; } } sub _load_Seq { my ($self,$type,$id) = @_; my $seq; if( $type eq 'id') { $seq = $self->seqdb->get_Seq_by_id($id); }elsif ( $type eq 'acc' ) { $seq = $self->seqdb->get_Seq_by_acc($id); } else { $self->throw("Bad internal error. Don't understand $type"); } if( ! $seq ) { # warding off bug #1628 $self->debug("could not find seq $id in seqdb\n"); return; } if( $self->agr() ) { #print STDERR "Pulling out into memory\n"; my $newseq = Bio::Seq->new( -display_id => $seq->display_id, -accession_number => $seq->accession, -seq => $seq->seq, -desc => $seq->desc, ); if( $self->agr() == 1 ) { foreach my $sf ( $seq->top_SeqFeatures() ) { $newseq->add_SeqFeature($sf); } $newseq->annotation($seq->annotation); } $seq = $newseq; } if( $self->_number_free < 1 ) { # remove the latest thing from the hash my @accs = sort { $self->{'_cache_number_hash'}->{$a} <=> $self->{'_cache_number_hash'}->{$b} } keys %{$self->{'_cache_number_hash'}}; my $acc = shift @accs; # remove this guy my $seq = $self->{'_cache_acc_hash'}->{$acc}; delete $self->{'_cache_number_hash'}->{$acc}; delete $self->{'_cache_id_hash'}->{$seq->id}; delete $self->{'_cache_acc_hash'}->{$acc}; } # up the number, register this sequence into the hash. $self->{'_cache_id_hash'}->{$seq->id} = $seq->accession; $self->{'_cache_acc_hash'}->{$seq->accession} = $seq; $self->{'_cache_number_hash'}->{$seq->accession} = $self->{'_cache_number'}++; return $seq; } sub _number_free { my $self = shift; return $self->number - scalar(keys %{$self->{'_cache_number_hash'}}); } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Seq_by_version{ my ($self,@args) = @_; $self->throw("Not implemented it"); } ## End of Package 1; BioPerl-1.6.923/Bio/DB/LocationI.pm000444000765000024 751412254227330 16660 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::LocationI # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::DB::LocationI - A RandomAccessI-like abstract interface for retrieving location data from a sequence database and returning Bio::LocationI objects =head1 SYNOPSIS # # get a database object somehow using a concrete class # $loc = $db->get_Location_by_id('123456'); # # $loc is a Bio::LocationI object # =head1 DESCRIPTION This is a pure interface class - in other words, all this does is define methods which other (concrete) classes will actually implement. The Bio::DB::LocationI class defines methods used to retrieve location data from a sequence. This is returned in the form of Bio::LocationI objects, which can include: Bio::Location::Simple Bio::Location::Fuzzy Bio::Location::Split At the moment it is just the ability to make Bio::LocationI objects from a name or unique id (id), an accession number (acc), and so on. =head1 CONTACT Ewan Birney originally wrote Bio::DB::RandomAccessI, from which this class is based. =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@lists.open-bio.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web. https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::LocationI; use strict; use Bio::Root::RootI; use base qw(Bio::Root::Root); =head2 get_Location_by_id Title : get_Location_by_id Usage : $loc = $db->get_Location_by_id('123456') Function: Gets a Bio::LocationI-implementing object by its name (id) Returns : a Bio::LocationI object or undef if not found Args : the id (as a string) of a sequence =cut sub get_Location_by_id{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Location_by_acc Title : get_Location_by_acc Usage : $loc = $db->get_Location_by_acc('X77802'); Function: Gets a Bio::LocationI object by accession number Returns : A Bio::LocationI object or undef if not found Args : accession number (as a string) Throws : "more than one sequences correspond to this accession" if the accession maps to multiple primary ids and method is called in a scalar context =cut sub get_Location_by_acc{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Location_by_version Title : get_Location_by_version Usage : $loc = $db->get_Location_by_version('X77802.1'); Function: Gets a Bio::LocationI object by sequence version Returns : A Bio::LocationI object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Location_by_version{ my ($self,@args) = @_; $self->throw_not_implemented(); } ## End of Package 1; BioPerl-1.6.923/Bio/DB/MeSH.pm000444000765000024 2127112254227333 15612 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::MeSH # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::MeSH - Term retrieval from a Web MeSH database =head1 SYNOPSIS my $mesh = Bio::DB::MeSH->new(); my $term = $mesh->get_exact_term('Butter'); print $term->description; =head1 DESCRIPTION This class retrieves a term from the Medical Subject Headings database by the National Library of Medicine of USA. See L. This class implements L and wraps its methods under L. By default, web access uses L, but in its absence falls back to bioperl module L which is a subclass of L. If not even that is not installed, it uses L. =head1 SEE ALSO L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::MeSH; use strict; use Bio::Phenotype::MeSH::Term; use Bio::Phenotype::MeSH::Twig; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); my $URL = 'http://www.nlm.nih.gov/mesh/MBrowser.html'; my $ANALYSIS_SPEC= {name => 'MeSH term retrival', type => 'Entry retrieval'}; my $INPUT_SPEC = [ {mandatory=>'true', type => 'scalar', 'name'=> 'value', }, ]; my $RESULT_SPEC = { '' => 'Bio::Phenotype::MeSH::Term', raw => 'raw output', }; sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} =$ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} =$INPUT_SPEC; $self->{'_RESULT_SPEC'} =$RESULT_SPEC; $self->{'_ANALYSIS_NAME'} = $ANALYSIS_SPEC->{'name'}; $self->_webmodule; return $self; } sub _webmodule { my ($self) = shift; $self->{'_webmodule'} = ''; eval { require WWW::Mechanize; }; unless ($@) { $self->{'_webmodule'} = 'WWW::Mechanize'; return; } eval { require LWP::UserAgent; }; unless ($@) { $self->{'_webmodule'} = 'Bio::WebAgent'; return; } require Bio::Root::HTTPget; $self->{'_webmodule'} = 'Bio::Root::HTTPget'; 1; } =head2 get_exact_term Title : get_exact_term Usage : $s = $db->get_exact_term($value); Function: Retrive a single MeSH term using a unique ID or exact name. Example : Returns : a Bio::Phenotype::MeSH::Term object Args : scalar, UID or name of a MeSH term The returned term object contains information about the immediate vincinity of the term in the terminology hierarchy. See L. =cut sub get_exact_term { my ($self, $value) = @_; $self->{'_term'} = undef; $self->run($value) if $value; $self->throw("Could not connect to the server") unless $self->status eq 'COMPLETED'; return $self->result; } sub run { my ($self, $value) = @_; # check input $self->throw("Need a MeSH name or ID as an input [$value]") if ref $value; # internal run() $self->_run($value); } sub _cgi_url { my($self, $field, $term) = @_; # we don't bother to URI::Escape $field and $term as this is an untainted private sub return 'http://www.nlm.nih.gov/cgi/mesh/2003/MB_cgi?field='.$field.'&term='.$term; } sub _run { my ($self, $value) = @_; $self->throw('Need a value [$value]') unless $value;; # delay repeated calls by default by 3 sec, set delay() to change # $self->sleep; $self->status('TERMINATED_BY_ERROR'); if ($self->{'_webmodule'} eq 'WWW::Mechanize') { $self->debug("using WWW::Mechanize...\n"); my $agent = WWW::Mechanize->new(); $agent->get($self->url); $agent->status == 200 or $self->warn("Could not connect to the server\n") and return; $agent->form_name('MB'); $agent->field("term", $value); if ($value =~ /\w\d{6}/) { $agent->field("field", 'uid'); } else { $agent->field("field", 'entry'); } $agent->click("exact"); $self->{'_content'} = $agent->content(); $self->status('COMPLETED'); return; } elsif ($self->{'_webmodule'} eq 'Bio::WebAgent') { $self->debug("using LWP::UserAgent...\n"); my $response; if ($value =~ /\w\d{6}/) { $self->{'_content'} = $response = eval { $self->get( $self->_cgi_url('uid', $value) ) }; $self->warn("Could not connect to the server\n") and return if $@; } else { $self->{'_content'} = eval { $response = $self->get( $self->_cgi_url('entry', $value) ) }; $self->warn("Could not connect to the server\n") and return if $@; } if ($response->is_success) { $self->{'_content'} = $response->content; $self->status('COMPLETED'); } return; } else { $self->debug("using Bio::Root::HTTPget...\n"); my $agent = Bio::Root::HTTPget->new(); if ($value =~ /\w\d{6}/) { $self->{'_content'} = eval { $agent->get( $self->_cgi_url('uid', $value) ) }; $self->warn("Could not connect to the server\n") and return if $@; } else { $self->{'_content'} = eval { $agent->get( $self->_cgi_url('entry', $value) ) }; $self->debug("Could not connect to the server\n") and return if $@; } $self->status('COMPLETED'); } } sub result { my ($self,$value) = @_; $self->throw("Could not retrive results") unless $self->status('COMPLETED'); # no processing return $self->{'_content'} if $value && $value eq 'raw'; # create a MeSH::Term object $_ = $self->{'_content'}; $self->debug( substr($_, 0, 100) . "\n"); my ($id) = m|Unique ID(.*?)|i; my ($name) = m|MeSH Heading([^<]+)|i; my ($desc) = m|Scope Note(.*?)|is; $self->throw("No description returned: $_") unless defined $desc; $desc =~ s/<.*?>//sg; $desc =~ s/\n/ /g; my $term = Bio::Phenotype::MeSH::Term->new(-id => $id, -name => $name, -description => $desc ); my ($trees) = $self->{'_content'} =~ /MeSH Tree Structures(.*)/s; while (m|Entry Term([^<]+)|ig) { $term->add_synonym($1); $self->debug("Synonym: |$1|\n"); } foreach (split /
/i, $trees ) { next unless /$name/; s// /sgi; s/<.*?>//sg; s/ / /sg; #print "|$_|"; my ($treeno) = /$name \[([^]]+)]/; my ($parent_treeno) = $treeno =~ /(.*)\.\d{3}/; my ($parent) = /\n +(\w.+) \[$parent_treeno\]/; my $twig = Bio::Phenotype::MeSH::Twig->new(-parent => $parent); $term->add_twig($twig); $self->debug("Parent: |$parent|\n"); while (/\n +(\w.+) \[$treeno\./g ) { $twig->add_child($1); $self->debug("Child: |$1|\n"); } while (/\n +(\w.+) \[$parent_treeno\./g ) { next if $name eq $1; $twig->add_sister($1); $self->debug("Sister: |$1|\n"); } } return $term; } 1; BioPerl-1.6.923/Bio/DB/NCBIHelper.pm000444000765000024 4350512254227325 16676 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::NCBIHelper # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # # Interfaces with new WebDBSeqI interface =head1 NAME Bio::DB::NCBIHelper - A collection of routines useful for queries to NCBI databases. =head1 SYNOPSIS # Do not use this module directly. # get a Bio::DB::NCBIHelper object somehow my $seqio = $db->get_Stream_by_acc(['J00522']); foreach my $seq ( $seqio->next_seq ) { # process seq } =head1 DESCRIPTION Provides a single place to setup some common methods for querying NCBI web databases. This module just centralizes the methods for constructing a URL for querying NCBI GenBank and NCBI GenPept and the common HTML stripping done in L(). The base NCBI query URL used is: http://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web. https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::NCBIHelper; use strict; use Bio::DB::Query::GenBank; use HTTP::Request::Common; use URI; use Bio::Root::IO; use Bio::DB::RefSeq; use URI::Escape qw(uri_unescape); use base qw(Bio::DB::WebDBSeqI Bio::Root::Root); our $HOSTBASE = 'http://eutils.ncbi.nlm.nih.gov'; our $MAX_ENTRIES = 19000; our $REQUEST_DELAY = 3; our %CGILOCATION = ( 'batch' => [ 'post' => '/entrez/eutils/epost.fcgi' ], 'query' => [ 'get' => '/entrez/eutils/efetch.fcgi' ], 'single' => [ 'get' => '/entrez/eutils/efetch.fcgi' ], 'version' => [ 'get' => '/entrez/eutils/efetch.fcgi' ], 'gi' => [ 'get' => '/entrez/eutils/efetch.fcgi' ], 'webenv' => [ 'get' => '/entrez/eutils/efetch.fcgi' ] ); our %FORMATMAP = ( 'gb' => 'genbank', 'gp' => 'genbank', 'fasta' => 'fasta', 'asn.1' => 'entrezgene', 'gbwithparts' => 'genbank', ); our $DEFAULTFORMAT = 'gb'; =head2 new Title : new Usage : Function: the new way to make modules a little more lightweight Returns : Args : =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); my ($seq_start, $seq_stop, $no_redirect, $redirect, $complexity, $strand ) = $self->_rearrange( [ qw(SEQ_START SEQ_STOP NO_REDIRECT REDIRECT_REFSEQ COMPLEXITY STRAND) ], @args ); $seq_start && $self->seq_start($seq_start); $seq_stop && $self->seq_stop($seq_stop); $no_redirect && $self->no_redirect($no_redirect); $redirect && $self->redirect_refseq($redirect); $strand && $self->strand($strand); # adjust statement to accept zero value defined $complexity && ( $complexity >= 0 && $complexity <= 4 ) && $self->complexity($complexity); return $self; } =head2 get_params Title : get_params Usage : my %params = $self->get_params($mode) Function: returns key,value pairs to be passed to NCBI database for either 'batch' or 'single' sequence retrieval method Returns : a key,value pair hash Args : 'single' or 'batch' mode for retrieval =cut sub get_params { my ($self, $mode) = @_; $self->throw("subclass did not implement get_params"); } =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: returns default sequence format for this module Returns : string Args : none =cut sub default_format { return $DEFAULTFORMAT; } =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: HTTP::Request Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =cut sub get_request { my ( $self, @qualifiers ) = @_; my ( $mode, $uids, $format, $query, $seq_start, $seq_stop, $strand, $complexity ) = $self->_rearrange( [qw(MODE UIDS FORMAT QUERY SEQ_START SEQ_STOP STRAND COMPLEXITY)], @qualifiers ); $mode = lc $mode; ($format) = $self->request_format() unless ( defined $format ); if ( !defined $mode || $mode eq '' ) { $mode = 'single'; } my %params = $self->get_params($mode); if ( !%params ) { $self->throw( "must specify a valid retrieval mode 'single' or 'batch' not '$mode'" ); } my $url = URI->new( $HOSTBASE . $CGILOCATION{$mode}[1] ); unless ( $mode eq 'webenv' || defined $uids || defined $query ) { $self->throw("Must specify a query or list of uids to fetch"); } if ( $query && $query->can('cookie') ) { @params{ 'WebEnv', 'query_key' } = $query->cookie; $params{'db'} = $query->db; } elsif ($query) { $params{'id'} = join ',', $query->ids; } # for batch retrieval, non-query style elsif ( $mode eq 'webenv' && $self->can('cookie') ) { @params{ 'WebEnv', 'query_key' } = $self->cookie; } elsif ($uids) { if ( ref($uids) =~ /array/i ) { $uids = join( ",", @$uids ); } $params{'id'} = $uids; } $seq_start && ( $params{'seq_start'} = $seq_start ); $seq_stop && ( $params{'seq_stop'} = $seq_stop ); $strand && ( $params{'strand'} = $strand ); if ( defined $complexity && ( $seq_start || $seq_stop || $strand ) ) { $self->warn( "Complexity set to $complexity; seq_start and seq_stop may not work!" ) if ( $complexity != 1 && ( $seq_start || $seq_stop ) ); $self->warn( "Complexity set to 0; expect strange results with strand set to 2" ) if ( $complexity == 0 && $strand == 2 && $format eq 'fasta' ); } defined $complexity && ( $params{'complexity'} = $complexity ); $params{'rettype'} = $format unless $mode eq 'batch'; # for now, 'post' is batch retrieval if ( $CGILOCATION{$mode}[0] eq 'post' ) { my $response = $self->ua->request( POST $url, [%params] ); $response->proxy_authorization_basic( $self->authentication ) if ( $self->authentication ); $self->_parse_response( $response->content ); my ( $cookie, $querykey ) = $self->cookie; my %qualifiers = ( '-mode' => 'webenv', '-seq_start' => $seq_start, '-seq_stop' => $seq_stop, '-strand' => $strand, '-complexity' => $complexity, '-format' => $format ); return $self->get_request(%qualifiers); } else { $url->query_form(%params); return GET $url; } } =head2 get_Stream_by_batch Title : get_Stream_by_batch Usage : $seq = $db->get_Stream_by_batch($ref); Function: Retrieves Seq objects from Entrez 'en masse', rather than one at a time. For large numbers of sequences, this is far superior than get_Stream_by_id or get_Stream_by_acc. Example : Returns : a Bio::SeqIO stream object Args : $ref : either an array reference, a filename, or a filehandle from which to get the list of unique ids/accession numbers. NOTE: deprecated API. Use get_Stream_by_id() instead. =cut *get_Stream_by_batch = sub { my $self = shift; $self->deprecated('get_Stream_by_batch() is deprecated; use get_Stream_by_id() instead'); $self->get_Stream_by_id(@_) }; =head2 get_Stream_by_query Title : get_Stream_by_query Usage : $seq = $db->get_Stream_by_query($query); Function: Retrieves Seq objects from Entrez 'en masse', rather than one at a time. For large numbers of sequences, this is far superior to get_Stream_by_id and get_Stream_by_acc. Example : Returns : a Bio::SeqIO stream object Args : An Entrez query string or a Bio::DB::Query::GenBank object. It is suggested that you create a Bio::DB::Query::GenBank object and get the entry count before you fetch a potentially large stream. =cut sub get_Stream_by_query { my ($self, $query) = @_; unless (ref $query && $query->can('query')) { $query = Bio::DB::Query::GenBank->new($query); } return $self->get_seq_stream('-query' => $query, '-mode'=>'query'); } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data ( 'type' => 'string', 'location' => \$datastr ); Function: Process downloaded data before loading into a Bio::SeqIO. This works for Genbank and Genpept, other classes should override it with their own method. Returns : void Args : hash with two keys: 'type' can be 'string' or 'file' 'location' either file location or string reference containing data =cut sub postprocess_data { # retain this in case postprocessing is needed at a future date } =head2 request_format Title : request_format Usage : my ($req_format, $ioformat) = $self->request_format; $self->request_format("genbank"); $self->request_format("fasta"); Function: Get/Set sequence format retrieval. The get-form will normally not be used outside of this and derived modules. Returns : Array of two strings, the first representing the format for retrieval, and the second specifying the corresponding SeqIO format. Args : $format = sequence format =cut sub request_format { my ( $self, $value ) = @_; if ( defined $value ) { $value = lc $value; if ( defined $FORMATMAP{$value} ) { $self->{'_format'} = [ $value, $FORMATMAP{$value} ]; } else { # Try to fall back to a default. Alternatively, we could throw # an exception $self->{'_format'} = [ $value, $value ]; } } return @{ $self->{'_format'} }; } =head2 redirect_refseq Title : redirect_refseq Usage : $db->redirect_refseq(1) Function: simple getter/setter which redirects RefSeqs to use Bio::DB::RefSeq Returns : Boolean value Args : Boolean value (optional) Throws : 'unparseable output exception' Note : This replaces 'no_redirect' as a more straightforward flag to redirect possible RefSeqs to use Bio::DB::RefSeq (EBI interface) instead of retrieving the NCBI records =cut sub redirect_refseq { my $self = shift; return $self->{'_redirect_refseq'} = shift if @_; return $self->{'_redirect_refseq'}; } =head2 complexity Title : complexity Usage : $db->complexity(3) Function: get/set complexity value Returns : value from 0-4 indicating level of complexity Args : value from 0-4 (optional); if unset server assumes 1 Throws : if arg is not an integer or falls outside of noted range above Note : From efetch docs, the complexity regulates the display: 0 - get the whole blob 1 - get the bioseq for gi of interest (default in Entrez) 2 - get the minimal bioseq-set containing the gi of interest 3 - get the minimal nuc-prot containing the gi of interest 4 - get the minimal pub-set containing the gi of interest =cut sub complexity { my ( $self, $comp ) = @_; if ( defined $comp ) { $self->throw("Complexity value must be integer between 0 and 4") if $comp !~ /^\d+$/ || $comp < 0 || $comp > 4; $self->{'_complexity'} = $comp; } return $self->{'_complexity'}; } =head2 strand Title : strand Usage : $db->strand(1) Function: get/set strand value Returns : strand value if set Args : value of 1 (plus) or 2 (minus); if unset server assumes 1 Throws : if arg is not an integer or is not 1 or 2 Note : This differs from BioPerl's use of strand: 1 = plus, -1 = minus 0 = not relevant. We should probably add in some functionality to convert over in the future. =cut sub strand { my ($self, $str) = @_; if ($str) { $self->throw("strand() must be integer value of 1 (plus strand) or 2 (minus strand) if set") if $str !~ /^\d+$/ || $str < 1 || $str > 2; $self->{'_strand'} = $str; } return $self->{'_strand'}; } =head2 seq_start Title : seq_start Usage : $db->seq_start(123) Function: get/set sequence start location Returns : sequence start value if set Args : integer; if unset server assumes 1 Throws : if arg is not an integer =cut sub seq_start { my ($self, $start) = @_; if ($start) { $self->throw("seq_start() must be integer value if set") if $start !~ /^\d+$/; $self->{'_seq_start'} = $start; } return $self->{'_seq_start'}; } =head2 seq_stop Title : seq_stop Usage : $db->seq_stop(456) Function: get/set sequence stop (end) location Returns : sequence stop (end) value if set Args : integer; if unset server assumes 1 Throws : if arg is not an integer =cut sub seq_stop { my ($self, $stop) = @_; if ($stop) { $self->throw("seq_stop() must be integer if set") if $stop !~ /^\d+$/; $self->{'_seq_stop'} = $stop; } return $self->{'_seq_stop'}; } =head2 Bio::DB::WebDBSeqI methods Overriding WebDBSeqI method to help newbies to retrieve sequences =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Stream_by_acc([$acc1, $acc2]); Function: gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut sub get_Stream_by_acc { my ( $self, $ids ) = @_; my $newdb = $self->_check_id($ids); if ( defined $newdb && ref($newdb) && $newdb->isa('Bio::DB::RefSeq') ) { return $newdb->get_seq_stream( '-uids' => $ids, '-mode' => 'single' ); } else { return $self->get_seq_stream( '-uids' => $ids, '-mode' => 'single' ); } } =head2 _check_id Title : _check_id Usage : Function: Returns : a Bio::DB::RefSeq reference or throws Args : $id(s), $string =cut sub _check_id { my ( $self, $ids ) = @_; # NT contigs can not be retrieved $self->throw("NT_ contigs are whole chromosome files which are not part of regular" . "database distributions. Go to ftp://ftp.ncbi.nih.gov/genomes/.") if $ids =~ /NT_/; # Asking for a RefSeq from EMBL/GenBank if ( $self->redirect_refseq ) { if ( $ids =~ /N._/ ) { $self->warn( "[$ids] is not a normal sequence database but a RefSeq entry." . " Redirecting the request.\n" ) if $self->verbose >= 0; return Bio::DB::RefSeq->new(); } } } =head2 delay_policy Title : delay_policy Usage : $secs = $self->delay_policy Function: NCBI requests a delay of 3 seconds between requests. This method implements that policy. Returns : number of seconds to delay Args : none =cut sub delay_policy { my $self = shift; return $REQUEST_DELAY; } =head2 cookie Title : cookie Usage : ($cookie,$querynum) = $db->cookie Function: return the NCBI query cookie, this information is used by Bio::DB::GenBank in conjunction with efetch, ripped from Bio::DB::Query::GenBank Returns : list of (cookie,querynum) Args : none =cut sub cookie { my $self = shift; if (@_) { $self->{'_cookie'} = shift; $self->{'_querynum'} = shift; } else { return @{$self}{qw(_cookie _querynum)}; } } =head2 _parse_response Title : _parse_response Usage : $db->_parse_response($content) Function: parse out response for cookie, this is a trimmed-down version of _parse_response from Bio::DB::Query::GenBank Returns : empty Args : none Throws : 'unparseable output exception' =cut sub _parse_response { my $self = shift; my $content = shift; if ( my ($warning) = $content =~ m!(.+)!s ) { $self->warn("Warning(s) from GenBank: $warning\n"); } if ( my ($error) = $content =~ /([^<]+)/ ) { $self->throw("Error from Genbank: $error"); } my ($cookie) = $content =~ m!(\S+)!; my ($querykey) = $content =~ m!(\d+)!; $self->cookie( uri_unescape($cookie), $querykey ); } =head2 no_redirect Title : no_redirect Usage : $db->no_redirect($content) Function: DEPRECATED - Used to indicate that Bio::DB::GenBank instance retrieves possible RefSeqs from EBI instead; default behavior is now to retrieve directly from NCBI Returns : None Args : None Throws : Method is deprecated in favor of positive flag method 'redirect_refseq' =cut sub no_redirect { shift->throw( "Use of no_redirect() is deprecated. Bio::DB::GenBank default is to always\n". "retrieve from NCBI. In order to redirect possible RefSeqs to EBI, set\n". "redirect_refseq flag to 1"); } 1; __END__ BioPerl-1.6.923/Bio/DB/Qual.pm000444000765000024 4005312254227317 15721 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Qual # # You may distribute this module under the same terms as perl itself # =head1 NAME Bio::DB::Qual - Fast indexed access to quality files =head1 SYNOPSIS use Bio::DB::Qual; # create database from directory of qual files my $db = Bio::DB::Qual->new('/path/to/qual/files/'); my @ids = $db->get_all_primary_ids; # Simple access my @qualarr = @{$db->qual('CHROMOSOME_I',4_000_000 => 4_100_000)}; my @revqual = @{$db->qual('CHROMOSOME_I',4_100_000 => 4_000_000)}; my $length = $db->length('CHROMOSOME_I'); my $header = $db->header('CHROMOSOME_I'); # Access to sequence objects. See Bio::PrimarySeqI. my $obj = $db->get_Qual_by_id('CHROMOSOME_I'); my @qual = @{$obj->qual}; my @subqual = @{$obj->subqual(4_000_000 => 4_100_000)}; my $length = $obj->length; # Loop through sequence objects my $stream = $db->get_PrimarySeq_stream; while (my $qual = $stream->next_seq) { # Bio::Seq::PrimaryQual operations } # Filehandle access my $fh = Bio::DB::Qual->newFh('/path/to/qual/files/'); while (my $qual = <$fh>) { # Bio::Seq::PrimaryQual operations } # Tied hash access tie %qualities,'Bio::DB::Qual','/path/to/qual/files/'; print $qualities{'CHROMOSOME_I:1,20000'}; =head1 DESCRIPTION Bio::DB::Qual provides indexed access to a single Fasta file, several files, or a directory of files. It provides random access to each quality score entry without having to read the file from the beginning. Access to subqualities (portions of a quality score) is provided, although contrary to Bio::DB::Fasta, the full quality score has to be brought in memory. Bio::DB::Qual is based on Bio::DB::IndexedBase. See this module's documentation for details. The qual files should contain decimal quality scores. Entries may have any line length up to 65,536 characters, and different line lengths are allowed in the same file. However, within a quality score entry, all lines must be the same length except for the last. An error will be thrown if this is not the case. The module uses /^E(\S+)/ to extract the primary ID of each quality score from the qual header. See -makeid in Bio::DB::IndexedBase to pass a callback routine to reversibly modify this primary ID, e.g. if you wish to extract a specific portion of the gi|gb|abc|xyz GenBank IDs. =head1 DATABASE CREATION AND INDEXING The object-oriented constructor is new(), the filehandle constructor is newFh() and the tied hash constructor is tie(). They all allow to index a single Fasta file, several files, or a directory of files. See Bio::DB::IndexedBase. =head1 SEE ALSO L L L =head1 LIMITATIONS When a quality score is deleted from one of the qual files, this deletion is not detected by the module and removed from the index. As a result, a "ghost" entry will remain in the index and will return garbage results if accessed. Currently, the only way to accommodate deletions is to rebuild the entire index, either by deleting it manually, or by passing -reindex=E1 to new() when initializing the module. All quality score lines for a given quality score must have the same length except for the last (not sure why there is this limitation). This is not problematic for sequences but could be annoying for quality scores. A workaround is to make sure that your quality scores fit on no more than 2 lines. Another solution could be to padd them with blank spaces so that each line has the same number of characters (maybe this padding should be implemented in Bio::SeqIO::qual?). =head1 AUTHOR Florent E Angly Eflorent . angly @ gmail-dot-comE. Module largely based on and adapted from Bio::DB::Fasta by Lincoln Stein. Copyright (c) 2007 Florent E Angly. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ For BioPerl-style access, the following methods are provided: =head2 get_Seq_by_id Title : get_Seq_by_id, get_Seq_by_acc, get_Seq_by_version, get_Seq_by_primary_id, get_Qual_by_id, get_qual_by_acc, get_qual_by_version, get_qual_by_primary_id, Usage : my $seq = $db->get_Seq_by_id($id); Function: Given an ID, fetch the corresponding sequence from the database. Returns : A Bio::PrimarySeq::Fasta object (Bio::PrimarySeqI compliant) Note that to save resource, Bio::PrimarySeq::Fasta sequence objects only load the sequence string into memory when requested using seq(). See L for methods provided by the sequence objects returned from get_Seq_by_id() and get_PrimarySeq_stream(). Args : ID =head2 get_PrimarySeq_stream Title : get_Seq_stream, get_PrimarySeq_stream Usage : my $stream = $db->get_Seq_stream(); Function: Get a stream of Bio::PrimarySeq::Fasta objects. The stream supports a single method, next_seq(). Each call to next_seq() returns a new Bio::PrimarySeq::Fasta sequence object, until no more sequences remain. Returns : A Bio::DB::Indexed::Stream object Args : None =head1 For simple access, the following methods are provided: =cut package Bio::DB::Qual; use strict; use IO::File; use File::Spec; use base qw(Bio::DB::IndexedBase); our $obj_class = 'Bio::Seq::PrimaryQual::Qual'; our $file_glob = '*.{qual,QUAL,qa,QA}'; =head2 new Title : new Usage : my $db = Bio::DB::Qual->new( $path, %options); Function: Initialize a new database object. When indexing a directory, files ending in .qual,qa are indexed by default. Returns : A new Bio::DB::Qual object Args : A single file, or path to dir, or arrayref of files Optional arguments: see Bio::DB::IndexedBase =cut sub _calculate_offsets { # Bio::DB::IndexedBase calls this to calculate offsets my ($self, $fileno, $file, $offsets) = @_; my $fh = IO::File->new($file) or $self->throw("Could not open $file: $!"); binmode $fh; warn "Indexing $file\n" if $self->{debug}; my ($offset, @ids, $linelen, $headerlen, $count, $qual_lines, $last_line, $numres, %offsets); my ($l3_len, $l2_len, $l_len, $blank_lines) = (0, 0, 0, 0); my $termination_length = $self->{termination_length}; while (my $line = <$fh>) { # Account for crlf-terminated Windows files if (index($line, '>') == 0) { if ($line =~ /^>(\S+)/) { print STDERR "Indexed $count quality scores...\n" if $self->{debug} && (++$count%1000) == 0; $self->_check_linelength($linelen); my $pos = tell($fh); if (@ids) { my $strlen = $pos - $offset - length($line); $strlen -= $termination_length * $qual_lines; my $ppos = &{$self->{packmeth}}($offset, $strlen, $numres, $linelen, $headerlen, Bio::DB::IndexedBase::NA, $fileno); for my $id (@ids) { $offsets->{$id} = $ppos; } $numres = 0; } @ids = $self->_makeid($line); ($offset, $headerlen, $linelen, $qual_lines) = ($pos, length $line, 0, 0); ($l3_len, $l2_len, $l_len, $blank_lines) = (0, 0, 0, 0); } else { # Catch bad header lines, bug 3172 $self->throw("FASTA header doesn't match '>(\\S+)': $line"); } } elsif ($line !~ /\S/) { # Skip blank line $blank_lines++; next; } else { # Need to check every line :( $l3_len = $l2_len; $l2_len = $l_len; $l_len = length $line; if (Bio::DB::IndexedBase::DIE_ON_MISSMATCHED_LINES) { if ( ($l3_len > 0) && ($l2_len > 0) && ($l3_len != $l2_len) ) { my $fap = substr($line, 0, 20).".."; $self->throw("Each line of the qual entry must be the same ". "length except the last. Line above #$. '$fap' is $l2_len". " != $l3_len chars."); } if ($blank_lines) { # Blank lines not allowed in entry $self->throw("Blank lines can only precede header lines, ". "found preceding line #$."); } } $linelen ||= length $line; $qual_lines++; $numres += scalar(split /\s+/, $line); } $last_line = $line; } # Process last entry $self->_check_linelength($linelen); my $pos = tell($fh); if (@ids) { my $strlen = $pos - $offset; if ($linelen == 0) { $strlen = 0; } else { if ($last_line !~ /\s$/) { $qual_lines--; } $strlen -= $termination_length * $qual_lines; } my $ppos = &{$self->{packmeth}}($offset, $strlen, $numres, $linelen, $headerlen, Bio::DB::IndexedBase::NA, $fileno); for my $id (@ids) { $offsets->{$id} = $ppos; } } return \%offsets; } # for backward compatibility sub get_PrimaryQual_stream { my $self = shift; return $self->get_PrimarySeq_stream; } # for backward compatibility sub get_Qual_by_id { my ($self, $id) = @_; return $self->get_Seq_by_id($id); } *get_qual_by_version = *get_qual_by_primary_id = *get_qual_by_acc = \&get_Qual_by_id; =head2 qual Title : qual, quality, subqual Usage : # All quality scores my @qualarr = @{$qualdb->subqual($id)}; # Subset of the quality scores my @subqualarr = @{$qualdb->subqual($id, $start, $stop, $strand)}; # or... my @subqualarr = @{$qualdb->subqual($compound_id)}; Function: Get a subqual of an entry in the database. For your convenience, the sequence to extract can be specified with any of the following compound IDs: $db->qual("$id:$start,$stop") $db->qual("$id:$start..$stop") $db->qual("$id:$start-$stop") $db->qual("$id:$start,$stop/$strand") $db->qual("$id:$start..$stop/$strand") $db->qual("$id:$start-$stop/$strand") $db->qual("$id/$strand") If $stop is less than $start, then the reverse complement of the sequence is returned. Avoid using it if possible since this goes against Bio::Seq conventions. Returns : Reference to an array of quality scores Args : Compound ID of entry to retrieve or ID, optional start (defaults to 1), optional end (defaults to the number of quality scores for this sequence), and strand (defaults to 1). =cut sub subqual { my ($self, $id, $start, $stop, $strand) = @_; # Quality values in a quality score can have 1 or 2 digits and are separated # by one (or several?) spaces. Thus contrary to Bio::DB::Fasta, here there # is no easy way match the position of a quality value to its position in # the quality string. # As a consequence, if a subqual of the quality is requested, we still need # to grab the full quality string first - performance penalty for big # quality scores :( # I think there is no way around starting at the begining of the quality # score but maybe there is a resource-efficient way of starting at the # begining of the quality score and stopping when the the position of the # last quality value requested is reached?? $self->throw('Need to provide a sequence ID') if not defined $id; ($id, $start, $stop, $strand) = $self->_parse_compound_id($id, $start, $stop, $strand); # Position in quality string my $string_start = 1; my $string_stop = $self->strlen($id); # Fetch full quality string my $fh = $self->_fh($id) or return; my $filestart = $self->_calc_offset($id, $string_start); my $filestop = $self->_calc_offset($id, $string_stop ); seek($fh, $filestart,0); my $data; read($fh, $data, $filestop-$filestart+1); # Process quality score $data =~ s/\n//g; $data =~ s/\r//g; my $subqual = 0; $subqual = 1 if ( $start || $stop ); my @data; if ( $subqual || ($strand == -1) ) { @data = split / /, $data, $stop+1; my $length = scalar(@data); $start = 1 if $start < 1; $stop = $length if $stop > $length; pop @data if ($stop != $length); splice @data, 0, $start-1; @data = reverse(@data) if $strand == -1; $data = join ' ', @data; } else { @data = split / /, $data; } return \@data; } *qual = *quality = \&subqual; =head2 header Title : header Usage : my $header = $db->header($id); Function: Get the header line (ID and description fields) of the specified entry. Returns : String Args : ID of entry =cut sub header { my ($self, $id) = @_; $self->throw('Need to provide a sequence ID') if not defined $id; my ($offset, $headerlen) = (&{$self->{unpackmeth}}($self->{offsets}{$id}))[0,4]; $offset -= $headerlen; my $data; my $fh = $self->_fh($id) or return; seek($fh, $offset, 0); read($fh, $data, $headerlen); # On Windows chomp remove '\n' but leaves '\r' # when reading '\r\n' in binary mode $data =~ s/\n//g; $data =~ s/\r//g; substr($data, 0, 1) = ''; return $data; } #------------------------------------------------------------- # Tied hash overrides # sub FETCH { return shift->subqual(@_); } #------------------------------------------------------------- # Bio::Seq::PrimaryQual compatibility # # Usage is the same as in Bio::Seq::PrimaryQual package Bio::Seq::PrimaryQual::Qual; use overload '""' => 'display_id'; use base qw(Bio::Root::Root Bio::Seq::PrimaryQual); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($db, $id, $start, $stop) = $self->_rearrange( [qw(DATABASE ID START STOP)], @args); $self->{db} = $db; $self->{id} = $id; $self->{stop} = $stop || $db->length($id); $self->{start} = $start || ($self->{stop} > 0 ? 1 : 0); # handle 0-length seqs return $self; } sub qual { my $self = shift; my $qual = $self->{db}->qual($self->{id}, $self->{start}, $self->{stop}); return $qual; } sub subqual { my ($self, $start, $stop) = @_; return $self->trunc($start, $stop)->qual; } sub trunc { # Override Bio::Seq::QualI trunc() method. This way, we create an object # that does not store the quality array in memory. my ($self, $start, $stop) = @_; $self->throw( "$stop is smaller than $stop. If you want to truncate and reverse ". "complement, you must call trunc followed by revcom." ) if $start > $stop; if ($self->{start} <= $self->{stop}) { $start = $self->{start}+$start-1; $stop = $self->{start}+$stop-1; } else { $start = $self->{start}-($start-1); $stop = $self->{start}-($stop-1); } my $obj = $self->new( -database => $self->{db}, -id => $self->{id}, -start => $start, -stop => $stop ); return $obj; } sub display_id { my $self = shift; return $self->{id}; } sub primary_id { my $self = shift; return overload::StrVal($self); } sub revcom { # Override Bio::QualI revcom() with optimized method. my $self = shift; return $self->new(@{$self}{'db', 'id', 'stop', 'start'}); } sub length { # Get length from quality location, not the quality array (too expensive) my $self = shift; return $self->{start} < $self->{stop} ? $self->{stop} - $self->{start} + 1 : $self->{start} - $self->{stop} + 1 ; } sub description { my $self = shift; my $header = $self->{'db'}->header($self->{id}); # remove the id from the header $header = (split(/\s+/, $header, 2))[2]; return $header; } *desc = \&description; 1; BioPerl-1.6.923/Bio/DB/QueryI.pm000444000765000024 753212254227327 16223 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::QueryI.pm # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::DB::QueryI - Object Interface to queryable sequence databases =head1 SYNOPSIS # using Bio::DB::Query::GenBank as an example my $query_string = 'Oryza[Organism] AND EST[Keyword]'; my $query = Bio::DB::Query::GenBank->new(-db=>'nucleotide', -query=>$query_string); my $count = $query->count; my @ids = $query->ids; # get a genbank database handle $gb = Bio::DB::GenBank->new(); my $stream = $db->get_Stream_by_query($query); while (my $seq = $stream->next_seq) { ... } # initialize the list yourself my $query = Bio::DB::Query::GenBank->new(-ids=>['X1012','CA12345']); =head1 DESCRIPTION This interface provides facilities for managing sequence queries such as those offered by Entrez. A query object is created by calling new() with a database-specific argument list. From the query object you can either obtain the list of IDs returned by the query, or a count of entries that would be returned. You can pass the query object to a Bio::DB::RandomAccessI object to return the entries themselves as a list or a stream. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::QueryI; use strict; use base qw(Bio::Root::RootI); =head2 new Title : new Usage : $db = Bio::DB::QueryI->new(@args); Function: constructor Returns : QueryI object Args : -query a query string -ids a list of ids as an arrayref Create new QueryI object. You may initialize with either a query string or with a list of ids. If both ids and a query are provided, the former takes precedence. Subclasses may recognize additional arguments. =cut =head2 count Title : count Usage : $count = $db->count; Function: return count of number of entries retrieved by query Returns : integer Args : none Returns the number of entries that are matched by the query. =cut sub count { my $self = shift; my @ids = $self->ids; scalar @ids; } =head2 ids Title : ids Usage : @ids = $db->ids([@ids]) Function: get/set matching ids Returns : array of sequence ids Args : (optional) array ref with new set of ids =cut sub ids { my $self = shift; $self->throw_not_implemented; } =head2 query Title : query Usage : $query = $db->query([$query]) Function: get/set query string Returns : string Args : (optional) new query string =cut sub query { my $self = shift; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/DB/RandomAccessI.pm000444000765000024 575512254227340 17460 0ustar00cjfieldsstaff000000000000# POD documentation - main docs before the code # # =head1 NAME Bio::DB::RandomAccessI - Abstract interface for a sequence database =head1 SYNOPSIS # # get a database object somehow using a concrete class # $seq = $db->get_Seq_by_id('ROA1_HUMAN'); # # $seq is a Bio::Seq object # =head1 DESCRIPTION This is a pure interface class - in other words, all this does is define methods which other (concrete) classes will actually implement. The Bio::DB::RandomAccessI class defines what methods a generic database class should have. At the moment it is just the ability to make Bio::Seq objects from a name (id) or an accession number. =head1 CONTACT Ewan Birney Ebirney@ebi.ac.ukE originally wrote this class. =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::RandomAccessI; use strict; use Bio::Root::RootI; use base qw(Bio::Root::Root); =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object or undef if not found Args : the id (as a string) of a sequence, =cut sub get_Seq_by_id{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); $seq = $db->get_Seq_by_acc(Locus => 'X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object or undef if not found Args : accession number (as a string), or a two element list consisting of namespace=>accession Throws : "more than one sequences correspond to this accession" if the accession maps to multiple primary ids and method is called in a scalar context NOTE: The two-element form allows you to choose the namespace for the accession number. =cut sub get_Seq_by_acc{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Seq_by_version{ my ($self,@args) = @_; $self->throw_not_implemented(); } ## End of Package 1; BioPerl-1.6.923/Bio/DB/ReferenceI.pm000444000765000024 751512254227337 17016 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::ReferenceI # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::DB::ReferenceI - A RandomAccessI-like abstract interface for retrieving Reference data from a sequence database and returning Bio::Annotation::Reference objects =head1 SYNOPSIS # # get a database object somehow using a concrete class # $ref = $db->get_Reference_by_id('123456'); # # $ref is a Bio::Annotation::Reference object # =head1 DESCRIPTION This is a pure interface class - in other words, all this does is define methods which other (concrete) classes will actually implement. The Bio::DB::ReferenceI class defines methods used to retrieve reference data from a sequence. This is returned in the form of Bio::Annotation::Reference objects. At the moment it is just the ability to make Bio::Annotation::Reference objects from a name or unique id (id), an accession number (acc), and so on. =head1 CONTACT Ewan Birney originally wrote Bio::DB::RandomAccessI, from which this class is based. =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@lists.open-bio.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web. https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::ReferenceI; use strict; =head2 get_Reference_by_id Title : get_Reference_by_id Usage : $ref = $db->get_Reference_by_id('123456') Function: Gets a Bio::Annotation::Reference-implementing object by its name (id) Returns : a Bio::Annotation::Reference object or undef if not found Args : the id (as a string) of a sequence =cut sub get_Reference_by_id{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Reference_by_acc Title : get_Reference_by_acc Usage : $ref = $db->get_Reference_by_acc('X77802'); Function: Gets a Bio::Annotation::Reference object by accession number Returns : A Bio::Annotation::Reference object or undef if not found Args : accession number (as a string) Throws : "more than one sequences correspond to this accession" if the accession maps to multiple primary ids and method is called in a scalar context =cut sub get_Reference_by_acc{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Reference_by_version Title : get_Reference_by_version Usage : $ref = $db->get_Reference_by_version('X77802.1'); Function: Gets a Bio::Annotation::Reference object by sequence version Returns : A Bio::Annotation::Reference object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Reference_by_version{ my ($self,@args) = @_; $self->throw_not_implemented(); } ## End of Package 1; BioPerl-1.6.923/Bio/DB/RefSeq.pm000444000765000024 1101212254227316 16174 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::EMBL # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::RefSeq - Database object interface for RefSeq retrieval =head1 SYNOPSIS use Bio::DB::RefSeq; $db = Bio::DB::RefSeq->new(); # most of the time RefSeq_ID eq RefSeq acc $seq = $db->get_Seq_by_id('NM_006732'); # RefSeq ID print "accession is ", $seq->accession_number, "\n"; # or changeing to accession number and Fasta format ... $db->request_format('fasta'); $seq = $db->get_Seq_by_acc('NM_006732'); # RefSeq ACC print "seq is ", $seq->seq, "\n"; # especially when using versions, you better be prepared # in not getting what what want eval { $seq = $db->get_Seq_by_version('NM_006732.1'); # RefSeq VERSION }; print "accesion is ", $seq->accession_number, "\n" unless $@; # or ... best when downloading very large files, prevents # keeping all of the file in memory # also don't want features, just sequence so let's save bandwith # and request Fasta sequence $db = Bio::DB::RefSeq->new(-retrievaltype => 'tempfile' , -format => 'fasta'); my $seqio = $db->get_Stream_by_id(['NM_006732', 'NM_005252'] ); while( my $seq = $seqio->next_seq ) { print "seqid is ", $seq->id, "\n"; } =head1 DESCRIPTION Allows the dynamic retrieval of sequence objects L from the RefSeq database using the dbfetch script at EBI: http://www.ebi.ac.uk/Tools/dbfetch/dbfetch In order to make changes transparent we have host type (currently only ebi) and location (defaults to ebi) separated out. This allows later additions of more servers in different geographical locations. The functionality of this module is inherited from L which implements L. This module retrieves entries from EBI although it retrives database entries produced at NCBI. When read into bioperl objects, the parser for GenBank format it used. RefSeq is a NONSTANDARD GenBank file so be ready for surprises. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email Heikki Lehvaslaiho Eheikki-at-bioperl-dot-orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::RefSeq; use strict; use vars qw($MODVERSION %HOSTS %FORMATMAP $DEFAULTFORMAT); $MODVERSION = '0.1'; use base qw(Bio::DB::DBFetch); BEGIN { # you can add your own here theoretically. %HOSTS = ( 'dbfetch' => { baseurl => 'http://%s/Tools/dbfetch/dbfetch?db=refseq&style=raw', hosts => { 'ebi' => 'www.ebi.ac.uk' } } ); %FORMATMAP = ( 'embl' => 'embl', 'genbank' => 'genbank', 'fasta' => 'fasta' ); $DEFAULTFORMAT = 'genbank'; } sub new { my ($class, @args ) = @_; my $self = $class->SUPER::new(@args); $self->{ '_hosts' } = {}; $self->{ '_formatmap' } = {}; $self->hosts(\%HOSTS); $self->formatmap(\%FORMATMAP); $self->{'_default_format'} = $DEFAULTFORMAT; return $self; } sub get_seq_stream { my ($self,%qualifiers) = @_; if( exists $qualifiers{'-uids'} ) { if( ref($qualifiers{'-uids'}) =~ /ARRAY/i ) { foreach my $u ( @{$qualifiers{'-uids'}} ) { $u =~ s/^(\S+)\|//; } } else { $qualifiers{'-uids'} =~ s/^(\S+)\|//; } } $self->SUPER::get_seq_stream(%qualifiers); } 1; BioPerl-1.6.923/Bio/DB/Registry.pm000444000765000024 1712412254227324 16630 0ustar00cjfieldsstaff000000000000# # POD documentation - main docs before the code =head1 NAME Bio::DB::Registry - Access to the Open Bio Database Access registry scheme =head1 SYNOPSIS use Bio::DB::Registry(); $registry = Bio::DB::Registry->new(); @available_services = $registry->services; $db = $registry->get_database('embl'); # $db is a Bio::DB::SeqI implementing class $seq = $db->get_Seq_by_acc("J02231"); =head1 DESCRIPTION This module provides access to the Open Bio Database Access (OBDA) scheme, which provides a single cross-language and cross-platform specification of how to get to databases. These databases may be accessible through the Web, they may be BioSQL databases, or they may be local, indexed flatfile databases. If the user or system administrator has not installed the default init file, seqdatabase.ini, in /etc/bioinformatics or ${HOME}/.bioinformatics then creating the first Registry object copies the default settings from the www.open-bio.org. The Registry object will attempt to store these settings in a new file, ${HOME}/.bioinformatics/seqdatabase.ini. Users can specify one or more custom locations for the init file by setting $OBDA_SEARCH_PATH to those directories, where multiple directories should be separated by ';'. Please see the OBDA Access HOWTO for more information (L). =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Registry; use vars qw($OBDA_SPEC_VERSION $OBDA_SEARCH_PATH $HOME $PRIVATE_DIR $PUBLIC_DIR $REGISTRY $FALLBACK_REGISTRY); use strict; use Bio::DB::Failover; use Bio::Root::HTTPget; use base qw(Bio::Root::Root); BEGIN { $OBDA_SPEC_VERSION = 1.0; $HOME = $ENV{HOME} if (defined $ENV{HOME}); if (defined $ENV{OBDA_SEARCH_PATH}) { $OBDA_SEARCH_PATH = $ENV{OBDA_SEARCH_PATH} || ''; } } my %implement = ('flat' => 'Bio::DB::Flat', 'biosql' => 'Bio::DB::BioSQL::OBDA', 'biofetch' => 'Bio::DB::BioFetch' # 'biocorba' => 'Bio::CorbaClient::SeqDB', ); $FALLBACK_REGISTRY = 'http://www.open-bio.org/registry/seqdatabase.ini'; $PRIVATE_DIR = '.bioinformatics'; $PUBLIC_DIR = '/etc/bioinformatics'; $REGISTRY = 'seqdatabase.ini'; sub new { my ($class,@args) = shift; my $self = $class->SUPER::new(@args); # open files in order $self->{'_dbs'} = {}; $self->_load_registry(); return $self; } =head2 _load_registry Title : _load_registry Usage : Function: Looks for seqdatabase.ini files in the expected locations and in the directories specified by $OBDA_SEARCH_PATH. If no files are found download a default file from www.open-bio.org Returns : nothing Args : none =cut sub _load_registry { my $self = shift; eval { $HOME = (getpwuid($>))[7]; } unless $HOME; if ($@) { $self->warn("This Perl doesn't implement function getpwuid(), no \$HOME"); } my @ini_files = $self->_get_ini_files(); @ini_files = $self->_make_private_registry() unless (@ini_files); my ($db,$hash) = (); for my $file (@ini_files) { open my $FH,"$file"; while( <$FH> ) { if (/^VERSION=([\d\.]+)/) { if ($1 > $OBDA_SPEC_VERSION or !$1) { $self->throw("Do not know about this version [$1] > $OBDA_SPEC_VERSION"); last; } next; } next if( /^#/ ); next if( /^\s/ ); if ( /^\[(\S+)\]/ ) { $db = $1; next; } my ($tag,$value) = split('=',$_); $value =~ s/\s//g; $tag =~ s/\s//g; $hash->{$db}->{"\L$tag"} = $value; } } for my $db ( keys %{$hash} ) { if ( !exists $self->{'_dbs'}->{$db} ) { my $failover = Bio::DB::Failover->new(); $self->{'_dbs'}->{$db} = $failover; } my $class; if (defined $implement{$hash->{$db}->{'protocol'}}) { $class = $implement{$hash->{$db}->{'protocol'}}; } else { $self->warn("Registry does not support protocol " . $hash->{$db}->{'protocol'}); next; } eval "require $class"; if ($@) { $self->warn("Couldn't load $class"); next; } else { eval { my $randi = $class->new_from_registry( %{$hash->{$db}} ); $self->{'_dbs'}->{$db}->add_database($randi); }; if ($@) { $self->warn("Couldn't call new_from_registry() on [$class]\n$@"); } } } } =head2 get_database Title : get_database Usage : my $db = $registry->get_database($dbname); Function: Retrieve a Database object which implements Bio::DB::SeqI interface Returns : Bio::DB::SeqI object Args : string describing the name of the database =cut sub get_database { my ($self,$dbname) = @_; $dbname = lc $dbname; if( !defined $dbname ) { $self->warn("must get_database with a database name"); return; } if( !exists $self->{'_dbs'}->{$dbname} ) { $self->warn("No database with name $dbname in Registry"); return; } return $self->{'_dbs'}->{$dbname}; } =head2 services Title : services Usage : my @available = $registry->services(); Function: returns list of possible services Returns : list of strings Args : none =cut sub services { my ($self) = @_; return () unless ( defined $self->{'_dbs'} && ref( $self->{'_dbs'} ) =~ /HASH/i); return keys %{$self->{'_dbs'}}; } =head2 _get_ini_files Title : _get_ini_files Usage : my @files = $self->_get_ini_files Function: To find all the seqdatabase.ini files Returns : list of seqdatabase.ini paths Args : None =cut sub _get_ini_files { my $self = shift; my @ini_files = (); if ( $OBDA_SEARCH_PATH ) { foreach my $dir ( split /;/, $OBDA_SEARCH_PATH ) { my $file = $dir . "/" . $REGISTRY; next unless -e $file; push @ini_files,$file; } } push @ini_files,"$HOME/$PRIVATE_DIR/$REGISTRY" if ( $HOME && -e "$HOME/$PRIVATE_DIR/$REGISTRY" ); push @ini_files, "$PUBLIC_DIR/$REGISTRY" if ( -e "$PUBLIC_DIR/$REGISTRY" ); @ini_files; } =head2 _make_private_registry Title : _make_private_registry Usage : Function: Make private registry in file in $HOME Returns : Path to private registry file Args : None =cut sub _make_private_registry { my $self = shift; my @ini_file; my $nor_in = $OBDA_SEARCH_PATH ? "nor in directory specified by\n$OBDA_SEARCH_PATH" : "and environment variable OBDA_SEARCH_PATH wasn't set"; $self->warn("No $REGISTRY file found in $HOME/$PRIVATE_DIR/\n" . "nor in $PUBLIC_DIR $nor_in.\n" . "Using web to get registry from\n$FALLBACK_REGISTRY"); # Last gasp. Try to use HTTPget module to retrieve the registry from # the web... my $f = Bio::Root::HTTPget::getFH($FALLBACK_REGISTRY); # store the default registry file eval { mkdir "$HOME/$PRIVATE_DIR" unless -e "$HOME/$PRIVATE_DIR"; }; $self->throw("Could not make directory $HOME/$PRIVATE_DIR, " . "no $REGISTRY file available") if $@; open(my $F,">$HOME/$PRIVATE_DIR/$REGISTRY"); print $F while (<$F>); close $F; $self->warn("Stored $REGISTRY file in $HOME/$PRIVATE_DIR"); push @ini_file,"$HOME/$PRIVATE_DIR/$REGISTRY"; @ini_file; } 1; __END__ BioPerl-1.6.923/Bio/DB/SeqFeature.pm000444000765000024 3045312254227313 17062 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature; =head1 NAME Bio::DB::SeqFeature -- Normalized feature for use with Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test'); my ($feature) = $db->get_features_by_name('ZK909'); my @subfeatures = $feature->get_SeqFeatures(); my @exons_only = $feature->get_SeqFeatures('exon'); # create a new object my $new = $db->new_feature(-primary_tag=>'gene', -seq_id => 'chr3', -start => 10000, -end => 11000); # add a new exon $feature->add_SeqFeature($db->new_feature(-primary_tag=>'exon', -seq_id => 'chr3', -start => 5000, -end => 5551)); =head1 DESCRIPTION The Bio::DB::SeqFeature object is the default SeqFeature class stored in Bio::DB::SeqFeature databases. It implements both the Bio::DB::SeqFeature::NormalizedFeatureI and Bio::DB::SeqFeature::NormalizedTableFeatureI interfaces, which means that its subfeatures, if any, are stored in the database in a normalized fashion, and that the parent/child hierarchy of features and subfeatures are also stored in the database as set of tuples. This provides efficiencies in both storage and retrieval speed. Typically you will not create Bio::DB::SeqFeature directly, but will ask the database to do so on your behalf, as described in L. =cut # just like Bio::DB::SeqFeature::NormalizedFeature except that the parent/child # relationships are stored in a table in the Bio::DB::SeqFeature::Store use strict; use Carp 'croak'; use Bio::DB::SeqFeature::Store; use base qw(Bio::DB::SeqFeature::NormalizedFeature Bio::DB::SeqFeature::NormalizedTableFeatureI); =head2 new Title : new Usage : $feature = Bio::DB::SeqFeature::NormalizedFeature->new(@args) Function: create a new feature Returns : the new seqfeature Args : see below Status : public This method creates and, if possible stores into a database, a new Bio::DB::SeqFeature::NormalizedFeature object using the specialized Bio::DB::SeqFeature class. The arguments are the same to Bio::SeqFeature::Generic-Enew() and Bio::Graphics::Feature-Enew(). The most important difference is the B<-store> option, which if present creates the object in a Bio::DB::SeqFeature::Store database, and the B<-index> option, which controls whether the feature will be indexed for retrieval (default is true). Ordinarily, you would only want to turn indexing on when creating top level features, and off only when storing subfeatures. The default is on. Arguments are as follows: -seq_id the reference sequence -start the start position of the feature -end the stop position of the feature -display_name the feature name (returned by seqname) -primary_tag the feature type (returned by primary_tag) -source the source tag -score the feature score (for GFF compatibility) -desc a description of the feature -segments a list of subfeatures (see Bio::Graphics::Feature) -subtype the type to use when creating subfeatures -strand the strand of the feature (one of -1, 0 or +1) -phase the phase of the feature (0..2) -url a URL to link to when rendered with Bio::Graphics -attributes a hashref of tag value attributes, in which the key is the tag and the value is an array reference of values -store a previously-opened Bio::DB::SeqFeature::Store object -index index this feature if true Aliases: -id an alias for -display_name -seqname an alias for -display_name -display_id an alias for -display_name -name an alias for -display_name -stop an alias for end -type an alias for primary_tag =cut sub add_segment { my $self = shift; $self->_add_segment(0,@_); } =head2 Bio::SeqFeatureI methods The following Bio::SeqFeatureI methods are supported: seq_id(), start(), end(), strand(), get_SeqFeatures(), display_name(), primary_tag(), source_tag(), seq(), location(), primary_id(), overlaps(), contains(), equals(), intersection(), union(), has_tag(), remove_tag(), add_tag_value(), get_tag_values(), get_all_tags() Some methods that do not make sense in the context of a genome annotation database system, such as attach_seq(), are not supported. Please see L for more details. =cut =head2 add_SeqFeature Title : add_SeqFeature Usage : $flag = $feature->add_SeqFeature(@features) Function: Add subfeatures to the feature Returns : true if successful Args : list of Bio::SeqFeatureI objects Status : public Add one or more subfeatures to the feature. For best results, subfeatures should be of the same class as the parent feature (i.e. do not try mixing Bio::DB::SeqFeature::NormalizedFeature with other feature types). An alias for this method is add_segment(). =cut =head2 update Title : update Usage : $flag = $feature->update() Function: Update feature in the database Returns : true if successful Args : none Status : public After changing any fields in the feature, call update() to write it to the database. This is not needed for add_SeqFeature() as update() is invoked automatically. =cut =head2 get_SeqFeatures Title : get_SeqFeature Usage : @subfeatures = $feature->get_SeqFeatures([@types]) Function: return subfeatures of this feature Returns : list of subfeatures Args : list of subfeature primary_tags (optional) Status : public This method extends the Bio::SeqFeatureI get_SeqFeatures() slightly by allowing you to pass a list of primary_tags, in which case only subfeatures whose primary_tag is contained on the list will be returned. Without any types passed all subfeatures are returned. =cut =head2 object_store Title : object_store Usage : $store = $feature->object_store([$new_store]) Function: get or set the database handle Returns : current database handle Args : new database handle (optional) Status : public This method will get or set the Bio::DB::SeqFeature::Store object that is associated with the feature. After changing the store, you should probably unset the primary_id() of the feature and call update() to ensure that the object is written into the database as a new feature. =cut =head2 overloaded_names Title : overloaded_names Usage : $overload = $feature->overloaded_names([$new_overload]) Function: get or set overloading of object strings Returns : current flag Args : new flag (optional) Status : public For convenience, when objects of this class are stringified, they are represented in the form "primary_tag(display_name)". To turn this feature off, call overloaded_names() with a false value. You can invoke this on an individual feature object or on the class: Bio::DB::SeqFeature::NormalizedFeature->overloaded_names(0); =cut =head2 segment Title : segment Usage : $segment = $feature->segment Function: return a Segment object corresponding to feature Returns : a Bio::DB::SeqFeature::Segment Args : none Status : public This turns the feature into a Bio::DB::SeqFeature::Segment object, which you can then use to query for overlapping features. See L. =cut =head2 AUTOLOADED methods @subfeatures = $feature->Exon; If you use an unknown method that begins with a capital letter, then the feature autogenerates a call to get_SeqFeatures() using the lower-cased method name as the primary_tag. In other words $feature-EExon is equivalent to: @subfeature s= $feature->get_SeqFeatures('exon') =cut =head2 load_id Title : load_id Usage : $id = $feature->load_id Function: get the GFF3 load ID Returns : the GFF3 load ID (string) Args : none Status : public For features that were originally loaded by the GFF3 loader, this method returns the GFF3 load ID. This method may not be supported in future versions of the module. =cut =head2 primary_id Title : primary_id Usage : $id = $feature->primary_id([$new_id]) Function: get/set the database ID of the feature Returns : the current primary ID Args : none Status : public This method gets or sets the primary ID of the feature in the underlying Bio::DB::SeqFeature::Store database. If you change this field and then call update(), it will have the effect of making a copy of the feature in the database under a new ID. =cut =head2 target Title : target Usage : $segment = $feature->target Function: return the segment correspondent to the "Target" attribute Returns : a Bio::DB::SeqFeature::Segment object Args : none Status : public For features that are aligned with others via the GFF3 Target attribute, this returns a segment corresponding to the aligned region. The CIGAR gap string is not yet supported. =cut =head2 Internal methods =over 4 =item $feature-Eas_string() Internal method used to implement overloaded stringification. =item $boolean = $feature-Etype_match(@list_of_types) Internal method that will return true if the primary_tag of the feature and source_tag match any of the list of types (in primary_tag:source_tag format) provided. =back =cut # This adds subfeatures. It has the property of converting the # provided features into an object like itself and storing them # into the database. If the feature already has a primary id and # an object_store() method, then it is not stored into the database, # but its primary id is reused. sub _add_segment { my $self = shift; my $normalized = shift; my $store = $self->object_store; my $store_parentage = eval{$store->can_store_parentage}; return $self->SUPER::_add_segment($normalized,@_) unless $normalized && $store_parentage; my @segments = $self->_create_subfeatures($normalized,@_); my $pos = "@{$self}{'start','stop','ref','strand'}"; # fix boundaries $self->_fix_boundaries(\@segments,1); # freakish fixing of our non-standard Target attribute $self->_fix_target(\@segments); # write our children out if ($normalized) { $store->add_SeqFeature($self,@segments); } else { push @{$self->{segments}},@segments; } # write us back to disk $self->update if $self->primary_id && $pos ne "@{$self}{'start','stop','ref','strand'}"; } # segments can be stored directly in the object (legacy behavior) # or stored in the database # an optional list of types can be used to specify which types to return sub get_SeqFeatures { my $self = shift; my @types = @_; my @inline_segs = exists $self->{segments} ? @{$self->{segments}} : (); @inline_segs = grep {$_->type_match(@types)} @inline_segs if @types; my $store = $self->object_store; my @db_segs; if ($store && $store->can_store_parentage) { if (!@types || $store->subfeature_types_are_indexed) { @db_segs = $store->fetch_SeqFeatures($self,@types); } else { @db_segs = grep {$_->type_match(@types)} $store->fetch_SeqFeatures($self); } } my @segs = (@inline_segs,@db_segs); foreach (@segs) { eval {$_->object_store($store)}; } return @segs; } sub denormalized_segments { my $self = shift; return exists $self->{segments} ? @{$self->{segments}} : (); } sub denormalized_segment_count { my $self = shift; return 0 unless exists $self->{segments}; return scalar @{$self->{segments}}; } # for Bio::LocationI compatibility sub is_remote { return } # for Bio::LocationI compatibility sub location_type { return 'EXACT' } # for Bio::DB::GFF compatibility sub feature_id {shift->primary_id} 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqHound.pm000444000765000024 5245512254227334 16555 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::DB::SeqHound # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # =head1 NAME Bio::DB::SeqHound - Database object interface to SeqHound =head1 SYNOPSIS use Bio::DB::SeqHound; $sh = Bio::DB::SeqHound->new(); $seq = $sh->get_Seq_by_acc("CAA28783"); # Accession Number # or ... $seq = $sh->get_Seq_by_gi(4557225); # GI Number =head1 VERSION 1.1 =head1 DESCRIPTION SeqHound is a database of biological sequences and structures. This script allows the retrieval of sequence objects (Bio::Seq) from the SeqHound database at the Blueprint Initiative. Bioperl extension permitting use of the SeqHound Database System developed by researchers at The Blueprint Initiative Samuel Lunenfeld Research Institute Mount Sinai Hospital Toronto, Canada =head1 FEEDBACK/BUGS known bugs: fail to get sequences for some RefSeq record with CONTIG, example GI = 34871762 Eseqhound@blueprint.orgE =head1 MAILING LISTS User feedback is an integral part of the evolution of this Bioperl module. Send your comments and suggestions preferably to seqhound.usergroup mailing lists. Your participation is much appreciated. Eseqhound.usergroup@lists.blueprint.orgE =head1 WEBSITE For more information on SeqHound http://dogboxonline.unleashedinformatics.com/ =head1 DISCLAIMER This software is provided 'as is' without warranty of any kind. =head1 AUTHOR Rong Yao, Hao Lieu, Ian Donaldson Eseqhound@blueprint.orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::SeqHound; use strict; use vars qw($HOSTBASE $CGILOCATION $LOGFILENAME); use Bio::Root::IO; use Bio::SeqIO; use IO::String; use POSIX qw(strftime); use base qw(Bio::DB::WebDBSeqI Bio::Root::Root); BEGIN { $HOSTBASE = 'http://dogboxonline.unleashedinformatics.com'; $CGILOCATION = '/cgi-bin/seqrem?fnct='; $LOGFILENAME = 'shoundlog'; } # helper method to get db specific options =head2 new Title : new Usage : $sh = Bio::DB::SeqHound->new(@options); Function: Creates a new seqhound handle Returns : New seqhound handle Args : =cut sub new { my ($class, @args ) = @_; my $self = $class->SUPER::new(@args); if ($self->_init_SeqHound eq "TRUE"){ return $self; } else { return; } } =head1 Routines Bio::DB::WebDBSeqI from Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN'); Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception Example : Each of these calls retrieves the same sequence record $seq = $db->get_Seq_by_id(56); #retrieval by GI $seq = $db->get_Seq_by_id("X02597"); #retrieval by NCBI accession $seq = $db->get_Seq_by_id("BTACHRE"); #retrieval by sequence "name" a sequence "name" is a secondary identifier (usually assigned by the submitting database external to the NCBI) that may not be visible in the GenBank flat file version of the record but is always present in the ASN.1 format. Note : Since in GenBank.pm, this function accepts a gi, an accession number or a sequence name, SeqHound also satisfies these inputs. If the input uid is a number, it is treated as a gi, if the uid is a string, it is treated as an accession number first. If the search still fails, it is treated as a sequence name. Since SeqHound stores biological data from different source sequence databases like: GenBank, GenPept, SwissProt, EMBL, RefSeq, you can pass ids from the above databases to this function. The Bio::Seq object returned by this function is identical to the Bio::Seq generated by the GenBank.pm and GenPept.pm. The Bio::Seq object returned by this function sometimes has minor difference in the SeqFeature from the Bio::Seq object generated in RefSeq.pm. The Bio::Seq objects created from this function will have the NCBI versions of the SwissProt and EMBL sequence data information. =cut sub get_Seq_by_id { my ($self, $id)= @_; if ($id =~ /^\d+$/){ my $seqio= $self-> _get_Seq_from_gbff ($id); if (defined $seqio){ return $seqio->next_seq; } } elsif ($id =~ /^\S+$/){ #print "id is string, try search by accession or name\n"; my $gi = $self ->_get_gi_from_acc ($id); if (!defined $gi){ my $gi = $self->_get_gi_from_name($id); if (defined $gi){ my $seqio = $self->_get_Seq_from_gbff($gi); if (defined $seqio){ return $seqio->next_seq; } } } else{ my $seqio = $self->_get_Seq_from_gbff($gi); if (defined $seqio){ return $seqio->next_seq; } else { my $gi = $self->_get_gi_from_name($id); if (defined $gi) { my $seqio = $self->_get_Seq_from_gbff($gi); if (defined $seqio){ return $seqio->next_seq; } } } } } else{ $self->warn("[get_Seq_by_id]: invalid input id."); return; } $self->warn("[get_Seq_by_id]: id $id does not exist"); return; } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('M34830'); Function: Gets a Seq object by accession numbers Returns : a Bio::Seq object Args : the accession number as a string Throws : "id does not exist" exception Note : Since in GenBank.pm, this function accepts an accession number or a sequence name, SeqHound also satisfies these inputs. If the input uid is a string, it is treated as an accession number first. If the search fails, it is treated as a sequence name. Since SeqHound stores biological data from different source sequence databases like: GenBank, GenPept, SwissProt, EMBL, RefSeq, you can pass ids from the above databases to this function. The Bio::Seq object returned by this function is identical to the Bio::Seq generated by the GenBank.pm and GenPept.pm. The Bio::Seq object returned by this function sometimes has minor difference in the SeqFeature from the Bio::Seq object generated in RefSeq.pm. The Bio::Seq objects created from this function will have the NCBI versions of the SwissProt and EMBL sequence data information. =cut sub get_Seq_by_acc { my ($self, $acc) = @_; #exclude $acc is a number, since function does not accept gi as input if ($acc =~ /^\d+$/) { $self->warn ("[get_Seq_by_acc]: id $acc does not exist"); return; } my ($ret, $gi); $gi= $self->_get_gi_from_acc($acc); #print "get_Seq_by_acc: gi = $gi\n"; if (defined $gi) { my $seqio = $self->_get_Seq_from_gbff($gi); if (defined $seqio){ return $seqio->next_seq; } } #else, treat input as sequence name else { $gi = $self->_get_gi_from_name($acc); #print "in get_Seq_by_acc: else gi = $gi\n"; if (defined $gi){ my $seqio = $self->_get_Seq_from_gbff($gi); if (defined $seqio){ return $seqio->next_seq; } } } $self->warn("[get_Seq_by_acc]: id $acc does not exist."); return; } =head2 get_Seq_by_gi Title : get_Seq_by_gi Usage : $seq = $sh->get_Seq_by_gi('405830'); Function: Gets a Bio::Seq object by gi number Returns : A Bio::Seq object Args : gi number (as a string) Throws : "gi does not exist" exception Note : call the same code get_Seq_by_id =cut sub get_Seq_by_gi { my ($self, $gi) = @_; return get_Seq_by_id($self, $gi); } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception Note : SeqHound only keeps the most up-to-date version of a sequence. So for the above example, use $seq = $db->get_Seq_by_acc('X77802'); instead of X77802.1 =head2 get_Stream_by_query Title : get_Stream_by_query Usage : $seq = $db->get_Stream_by_query($query); Function: Retrieves Seq objects from Entrez 'en masse', rather than one at a time. For large numbers of sequences, this is far superior than get_Stream_by_[id/acc](). Example : $query_string = 'Candida maltosa 26S ribosomal RNA gene'; $query = Bio::DB::Query::GenBank->new(-db=>'nucleotide', -query=>$query_string); $stream = $sh->get_Stream_by_query($query); or $query = Bio::DB::Query::GenBank->new (-db=> 'nucleotide', -ids=>['X02597', 'X63732', 11002, 4557284]); $stream = $sh->get_Stream_by_query($query); Returns : a Bio::SeqIO stream object Args : $query : A Bio::DB::Query::GenBank object. It is suggested that you create a Bio::DB::Query::GenBank object and get the entry count before you fetch a potentially large stream. =cut sub get_Stream_by_query{ my ($self, $query) = @_; my @ids = $query->ids; #print join ",", @ids, "\n"; return get_Stream_by_id($self, \@ids); } =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id(['J05128', 'S43442', 34996479]); Function: Gets a series of Seq objects by unique identifiers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of unique identifiers for the desired sequence entries, according to genbank.pm this function accepts gi, accession number and sequence name Note : Since in GenBank.pm, this function accepts a gi, an accession number or a sequence name, SeqHound also satisfies these inputs. If the input uid is a number, it is treated as a gi, if the uid is a string, it is treated as an accession number first. If the search still fails, it is treated as a sequence name. Since SeqHound stores biological data from different source sequence databases like: GenBank, GenPept, SwissProt, EMBL, RefSeq, you can pass ids from the above databases to this function. The Bio::Seq object returned by this function is identical to the Bio::Seq generated by the GenBank.pm and GenPept.pm. The Bio::Seq object returned by this function sometimes has minor difference in the SeqFeature from the Bio::Seq object generated in RefSeq.pm. The Bio::Seq objects created from this function will have the NCBI versions of the SwissProt and EMBL sequence data information. =cut sub get_Stream_by_id { my ($self, $id) = @_; my (@gilist, @not_exist); if(!defined $id) { $self->warn("[get_Stream_by_id]: undefined input id"); return; } if (ref($id)=~ /array/i){ foreach my $i (@$id){ if ($i =~ /^\d+$/){ push(@gilist, $i); } elsif ($i =~ /^\S+$/) { my $gi = _get_gi_from_acc($self, $i); if (!defined $gi){ $gi = _get_gi_from_name($self, $i); if (!defined $gi){ $self->warn("[get_Stream_by_id]: id $i does not exist."); push (@not_exist, $i); } else { push (@gilist, $gi); } } else { push(@gilist, $gi); } } else { $self->warn("[get_Stream_by_id]: id $i does not exist."); push (@not_exist, $i); } } my $seqio = _get_Seq_from_gbff($self, \@gilist); return $seqio; } else { return; } } =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Stream_by_acc(['M98777', 'M34830']); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For SeqHound, this just calls the same code for get_Stream_by_id() =cut sub get_Stream_by_acc { my ($self, $acc) = @_; return get_Stream_by_id($self, $acc); } =head2 get_Stream_by_gi Title : get_Stream_by_gi Usage : $seq = $db->get_Seq_by_gi([161966, 255064]); Function: Gets a series of Seq objects by gi numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of gi numbers for the desired sequence entries Note : For SeqHound, this just calls the same code for get_Stream_by_id() =cut sub get_Stream_by_gi{ my ($self, $gi) = @_; return get_Stream_by_id($self, $gi); } =head2 get_request Title : get_request Usage : my $lcontent = $self->get_request; Function: get the output from SeqHound API http call Returns : the result of the remote call from SeqHound Args : %qualifiers = a hash of qualifiers (SeqHound function name, id, query etc) Example : $lcontent = $self->get_request(-funcname=>'SeqHoundGetGenBankff', -query=>'gi', -uid=>555); Note : this function overrides the implementation in Bio::DB::WebDBSeqI. =cut sub get_request { my $self = shift; my ( @qualifiers) = @_; my ($funcname, $query, $uids, $other) = $self->_rearrange([qw(FUNCNAME QUERY UIDS OTHER)], @qualifiers); # print ("get funcname = $funcname, query = $query, uids= $uids\n"); unless( defined $funcname ne '') { $self->throw("please specify the SeqHound function for query"); } my $url = $HOSTBASE . $CGILOCATION . $funcname; unless( defined $uids ne '') { $self->throw("please specify a uid or a list of uids to fetch"); } unless ( defined $query && $query ne '') { $self->throw("please specify a valid query field"); } if (defined $uids && defined $query) { if( ref($uids) =~ /array/i ) { $uids = join(",", @$uids); } $url=$url."&".$query."=".$uids; if (defined $other){ $url=$url."&".$other; } my $ua = LWP::UserAgent->new(env_proxy => 1); my $req = HTTP::Request->new ('GET', $url); my $res = $ua->request($req); if ($res->is_success){ return $res->content; } else { my $result = "HTTP::Request error: ".$res->status_line."\n"; $self->warn("$result"); return $result; } } } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data (-funcname => $funcname, -lcontent => $lcontent, -outtype => $outtype); Function: process return String from http seqrem call output type can be a string or a Bio::SeqIO object. Returns : void Args : $funcname is the API function name of SeqHound $lcontent is a string output from SeqHound server http call $outtype is a string or a Bio::SeqIO object Example : $seqio = $self->postprocess_data ( -lcontent => $lcontent, -funcname => 'SeqHoundGetGenBankffList', -outtype => 'Bio::SeqIO'); or $gi = $self->postprocess_data( -lcontent => $lcontent, -funcname => 'SeqHoundFindAcc', -outtype => 'string'); Note : this method overrides the method works for genbank/genpept, this is for SeqHound =cut sub postprocess_data { my ($self, @args) = @_; my ($funcname, $lcontent, $outtype) = $self->_rearrange( [qw(FUNCNAME LCONTENT OUTTYPE)], @args); my $result; if (!defined $outtype){ $self->throw("please specify the output type, string, Bio::SeqIO etc"); } if (!defined $lcontent){ $self->throw("please provide the result from SeqHound call"); } if (!defined $funcname){ $self->throw("Please provide the function name"); } #set up verbosity level if need record in the log file my $log_msg = "Writing into '$LOGFILENAME' log file.\n"; my $now = strftime("%a %b %e %H:%M:%S %Y", localtime); if ($lcontent eq "") { $self->debug($log_msg); open (my $LOG, '>>', $LOGFILENAME); print $LOG "$now $funcname. No reply.\n"; return; } elsif ($lcontent =~ /HTTP::Request error/) { $self->debug($log_msg); open (my $LOG, '>>', $LOGFILENAME); print $LOG "$now $funcname. Http::Request error problem.\n"; return; } elsif ($lcontent =~ /SEQHOUND_ERROR/) { $self->debug($log_msg); open (my $LOG, '>>', $LOGFILENAME); print $LOG "$now $funcname error. SEQHOUND_ERROR found.\n"; return; } elsif ($lcontent =~ /SEQHOUND_NULL/) { $self->debug($log_msg); open (my $LOG, '>>', $LOGFILENAME); print $LOG "$now $funcname Value not found in the database. SEQHOUND_NULL found.\n"; return; } else { chomp $lcontent; my @lines = split(/\n/, $lcontent, 2); if ($lines[1] =~ /^-1/) { $self->debug($log_msg); open (my $LOG, '>>', $LOGFILENAME); print $LOG "$now $funcname Value not found in the database. -1 found.\n"; return; } elsif ($lines[1] =~ /^0/) { $self->debug($log_msg); open (my $LOG, '>>', $LOGFILENAME); print $LOG "$now $funcname failed.\n"; return; } else { $result = $lines[1]; } } #a list of functions in SeqHound which can wrap into Bio::seqIO object if ($outtype eq 'Bio::SeqIO'){ my $buf = IO::String->new($result); my $io = Bio::SeqIO->new (-format => 'genbank', -fh => $buf); if (defined $io && $io ne ''){ return $io; } else { return;} } #return a string if outtype is "string" return $result; } =head2 _get_gi_from_name Title : _get_gi_from_name Usage : $self->_get_gi_from_name('J05128'); Function: get the gene identifier from a sequence name in SeqHound database Return : gene identifier or undef Args : a string represented sequence name =cut sub _get_gi_from_name { my ($self, $name) = @_; my ($ret, $gi); $ret = $self->get_request( -funcname => 'SeqHoundFindName', -query => 'name', -uids => $name); #print "_get_gi_from_name: ret = $ret\n"; $gi = $self->postprocess_data(-lcontent => $ret, -funcname => 'SeqHoundFindName', -outtype => 'string'); #print "_get_gi_from_name: gi = $gi\n"; return $gi; } =head2 _get_gi_from_acc Title : _get_gi_from_acc Usage : $self->_get_gi_from_acc('M34830') Function: get the gene identifier from an accession number in SeqHound database Return : gene identifier or undef Args : a string represented accession number =cut sub _get_gi_from_acc { my ($self, $acc) = @_; my ($ret, $gi); $ret = $self->get_request ( -funcname => 'SeqHoundFindAcc', -query => 'acc', -uids => $acc); #print "_get_gi_from_acc: ret = $ret\n"; $gi = $self->postprocess_data( -lcontent => $ret, -funcname => 'SeqHoundFindAcc', -outtype => 'string'); #print "_get_gi_from_acc: gi = $gi\n"; return $gi; } =head2 _get_Seq_from_gbff Title : _get_Seq_from_gbff Usage : $self->_get_Seq_from_gbff($str) Function: get the Bio::SeqIO stream object from gi or a list of gi in SeqHound database Return : Bio::SeqIO or undef Args : a string represented gene identifier or a list of gene identifiers Example : $seq = $self->_get_Seq_from_gbff(141740); or $seq = $self->_get_Seq_from_gbff([141740, 255064, 45185482]); =cut sub _get_Seq_from_gbff { my ($self, $gi) = @_; if(!defined $gi) { $self->warn("[_get_Seq_from_gbff]: undefined input gi"); return; } my $lcontent; if (ref($gi) =~ /array/i){ my @copyArr = @$gi; my @tempArr; $lcontent = "SEQHOUND_OK\n"; while ($#copyArr != -1){ @tempArr =_MaxSizeArray(\@copyArr); #in order to keep the correct output order as GenBank does my $gi = join (",", reverse(@tempArr)); my $result; my $ret = $self->get_request( -funcname => 'SeqHoundGetGenBankffList', -query => 'pgi', -uids => $gi); if (defined $ret){ my @lines = split(/\n/, $ret, 2); if($lines[0] =~ /SEQHOUND_ERROR/ || $lines[0] =~ /SEQHOUND_NULL/){ } else { if ($lines[1] =~ /^(null)/ || $lines[1] eq ""){ } else{ $result = $lines[1]; } } #append genbank flat files for long list $lcontent = $lcontent.$result; } } } #else $gi is a single variable else { $lcontent = $self->get_request( -funcname => 'SeqHoundGetGenBankffList', -query => 'pgi', -uids => $gi); } my $seqio = $self->postprocess_data ( -lcontent => $lcontent, -funcname => 'SeqHoundGetGenBankffList', -outtype => 'Bio::SeqIO'); return $seqio; } =head2 _init_SeqHound Title : _init_SeqHound Usage : $self->_init_SeqHound(); Function: call SeqHoundInit at blueprint server Return : $result (TRUE or FALSE) Args : =cut sub _init_SeqHound { my $self = shift; my $ret = $self->get_request(-funcname => 'SeqHoundInit', -query => 'NetEntrezOnToo', -uids => 'true', -other => 'appname=Bioperl'); my $result = $self->postprocess_data(-lcontent => $ret, -funcname => 'SeqHoundInit', -outtype => 'string'); return $result || 'FALSE'; } =head2 _MaxSizeArray Title : _MaxSizeArray Usage : $self->_MaxSizeArray(\@arr) Function: get an array with the limit size Return : an array with the limit size Args : a reference to an array =cut sub _MaxSizeArray { my $argArr = shift; my @copyArr; my $MAXQ = 5; my $len = scalar(@$argArr); for(my $i = 0; $i < $len;){ $copyArr[$i++] = $$argArr[0]; shift(@$argArr); if($i == $MAXQ) { last; } } return @copyArr; } 1; __END__ BioPerl-1.6.923/Bio/DB/SeqI.pm000444000765000024 1115512254227313 15655 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::SeqI.pm # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # =head1 NAME Bio::DB::SeqI - Abstract Interface for Sequence databases =head1 SYNOPSIS # get a Bio::DB::SeqI somehow $seq = $seqdb->get_Seq_by_id('some-id'); $seq = $seqdb->get_Seq_by_acc('some-accession-number'); @ids = $seqdb->get_all_ids(); $stream = $seqdb->get_PrimarySeq_stream(); while((my $seq = $stream->next_seq()) { # $seq is a PrimarySeqI compliant object } =head1 DESCRIPTION Abstract interface for a sequence database =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::DB::SeqI; use strict; use base qw(Bio::DB::RandomAccessI); =head1 Methods inherited from Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =head1 Methods [that were] specific for Bio::DB::SeqI =head2 get_PrimarySeq_stream Title : get_PrimarySeq_stream Usage : $stream = get_PrimarySeq_stream Function: Makes a Bio::SeqIO compliant object which provides a single method, next_seq Returns : Bio::SeqIO Args : none =cut sub get_PrimarySeq_stream{ my ($self,@args) = @_; $self->throw("Object did not provide a PrimarySeq stream object"); } =head2 get_all_primary_ids Title : get_all_ids Usage : @ids = $seqdb->get_all_primary_ids() Function: gives an array of all the primary_ids of the sequence objects in the database. These may be ids (display style) or accession numbers or something else completely different - they *are not* meaningful outside of this database implementation. Example : Returns : an array of strings Args : none =cut sub get_all_primary_ids{ my ($self,@args) = @_; $self->throw("Object did not provide a get_all_ids method"); } =head2 get_Seq_by_primary_id Title : get_Seq_by_primary_id Usage : $seq = $db->get_Seq_by_primary_id($primary_id_string); Function: Gets a Bio::Seq object by the primary id. The primary id in these cases has to come from $db->get_all_primary_ids. There is no other way to get (or guess) the primary_ids in a database. The other possibility is to get Bio::PrimarySeqI objects via the get_PrimarySeq_stream and the primary_id field on these objects are specified as the ids to use here. Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut sub get_Seq_by_primary_id { my ($self,@args) = @_; $self->throw("Abstract database call of get_Seq_by_primary_id. Your database". " has not implemented this method!"); } 1; BioPerl-1.6.923/Bio/DB/SeqVersion.pm000444000765000024 1004612254227333 17112 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::SeqVersion # # Please direct questions and support issues to # # Cared for by Brian Osborne # # Copyright Brian Osborne 2006 # # You may distribute this module under the same terms as Perl itself # # POD documentation - main docs before the code =head1 NAME Bio::DB::SeqVersion - front end to querying databases for identifier versions =head1 SYNOPSIS use Bio::DB::SeqVersion; my $query = Bio::DB::SeqVersion->new(-type => 'gi'); my @all_gis = $query->get_all(2); my $live_gi = $query->get_recent(2); =head1 DESCRIPTION The default type is 'gi'. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Brian Osborne Email bosborne at alum.mit.edu =head1 CONTRIBUTORS Torsten Seemann - torsten.seemann AT infotech.monash.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::SeqVersion; use strict; use base qw(Bio::WebAgent Bio::Root::Root); # Private class variable my $DEFAULTIDTYPE = 'gi'; # sub default_id_type() =head2 new() Usage : my $obj = Bio::DB::SeqVersion->new(); Function: Create a Bio::DB::SeqVersion object Returns : An instance of Bio::DB::SeqVersion Args : -type Identifier namespace, default is 'gi' =cut sub new { my($class,@args) = @_; if( $class =~ /Bio::DB::SeqVersion::\S+/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys # we delete '-type' so it doesn't get passed to the sub-class constructor # note: delete() returns the value of the item deleted (undef if non-existent) my $type = lc( delete($param{'-type'}) || $DEFAULTIDTYPE ); return unless( $class->_load_seqversion_module($type) ); # we pass %param here, not @args, as we have filtered out -type return "Bio::DB::SeqVersion::$type"->new(%param); } } =head2 get_recent() Usage : Function: Example : Returns : Args : =cut sub get_recent { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_all() Usage : Function: Example : Returns : Args : =cut sub get_all { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 _load_seqversion_module Title : _load_seqversion_module Usage : Used internally Function: Loads up a module at run time on demand Example : Returns : Args : Name of identifier type =cut sub _load_seqversion_module { my ($self,$db) = @_; my $module = "Bio::DB::SeqVersion::" . $db; my $ok; eval { $ok = $self->_load_module($module) }; if ( $@ ) { print STDERR $@; print STDERR <default_id_type Function: Returns default identifier type for this module Returns : string Args : none =cut sub default_id_type { return $DEFAULTIDTYPE; } 1; BioPerl-1.6.923/Bio/DB/SwissProt.pm000444000765000024 3675012254227333 17003 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::SwissProt # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # Reworked to use Bio::DB::WebDBSeqI 2000-12-11 =head1 NAME Bio::DB::SwissProt - Database object interface to SwissProt retrieval =head1 SYNOPSIS use Bio::DB::SwissProt; $sp = Bio::DB::SwissProt->new(); $seq = $sp->get_Seq_by_id('KPY1_ECOLI'); # SwissProt ID # <4-letter-identifier>_ # or ... $seq = $sp->get_Seq_by_acc('P43780'); # SwissProt AC # [OPQ]xxxxx # In fact in this implementation # these methods call the same webscript so you can use # then interchangeably # choose a different server to query $sp = Bio::DB::SwissProt->new('-servertype' => 'expasy', '-hostlocation' => 'us'); $seq = $sp->get_Seq_by_id('BOLA_HAEIN'); # SwissProtID =head1 DESCRIPTION SwissProt is a curated database of proteins managed by the Swiss Bioinformatics Institute. Additional tools for parsing and manipulating swissprot files can be found at ftp://ftp.ebi.ac.uk/pub/software/swissprot/Swissknife/. Allows the dynamic retrieval of Sequence objects (Bio::Seq) from the SwissProt database via an Expasy retrieval. In order to make changes transparent we have host type (currently only expasy) and location (default to Switzerland) separated out. This allows the user to pick the closest Expasy mirror for running their queries. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email Jason Stajich Ejason@bioperl.org E Thanks go to Alexandre Gattiker Egattiker@isb-sib.chE of Swiss Institute of Bioinformatics for helping point us in the direction of the correct expasy scripts and for swissknife references. Also thanks to Heikki Lehvaslaiho Eheikki-at-bioperl-dot-orgE for help with adding EBI swall server. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::SwissProt; use strict; use HTTP::Request::Common; our $MODVERSION = '0.8.1'; use base qw(Bio::DB::WebDBSeqI); # global vars our $DEFAULTSERVERTYPE = 'ebi'; our $DEFAULTFORMAT = 'swissprot'; # our $DEFAULTIDTRACKER = 'http://www.expasy.ch'; # you can add your own here theoretically. our %HOSTS = ( 'expasy' => { 'default' => 'us', 'baseurl' => 'http://%s/cgi-bin/sprot-retrieve-list.pl', 'hosts' => { 'switzerland' => 'ch.expasy.org', 'canada' => 'ca.expasy.org', 'china' => 'cn.expasy.org', 'taiwan' => 'tw.expasy.org', 'australia' => 'au.expasy.org', 'korea' => 'kr.expasy.org', 'us' => 'us.expasy.org', }, # ick, CGI variables 'jointype' => ' ', 'idvar' => 'list', 'basevars' => [ ], }, 'ebi' => { 'default' => 'uk', 'baseurl' => 'http://%s/Tools/dbfetch/dbfetch', 'hosts' => { 'uk' => 'www.ebi.ac.uk', }, 'jointype' => ',', 'idvar' => 'id', 'basevars' => [ 'db' => 'UniProtKB', 'style' => 'raw' ], } ); our %ID_MAPPING_DATABASES = map {$_ => 1} qw( ACC+ID ACC ID UPARC NF50 NF90 NF100 EMBL_ID EMBL PIR UNIGENE_ID P_ENTREZGENEID P_GI P_IPI P_REFSEQ_AC PDB_ID DISPROT_ID HSSP_ID DIP_ID MEROPS_ID PEROXIBASE_ID PPTASEDB_ID REBASE_ID TCDB_ID 2DBASE_ECOLI_ID AARHUS_GHENT_2DPAGE_ID ANU_2DPAGE_ID DOSAC_COBS_2DPAGE_ID ECO2DBASE_ID WORLD_2DPAGE_ID ENSEMBL_ID ENSEMBL_PRO_ID ENSEMBL_TRS_ID P_ENTREZGENEID GENOMEREVIEWS_ID KEGG_ID TIGR_ID UCSC_ID VECTORBASE_ID AGD_ID ARACHNOSERVER_ID BURULIST_ID CGD CYGD_ID DICTYBASE_ID ECHOBASE_ID ECOGENE_ID EUHCVDB_ID FLYBASE_ID GENECARDS_ID GENEDB_SPOMBE_ID GENEFARM_ID H_INVDB_ID HGNC_ID HPA_ID LEGIOLIST_ID LEPROMA_ID LISTILIST_ID MAIZEGDB_ID MIM_ID MGI_ID MYPULIST_ID NMPDR ORPHANET_ID PHARMGKB_ID PHOTOLIST_ID PSEUDOCAP_ID RGD_ID SAGALIST_ID SGD_ID SUBTILIST_ID TAIR_ID TUBERCULIST_ID WORMBASE_ID WORMPEP_ID XENBASE_ID ZFIN_ID EGGNOG_ID OMA_ID ORTHODB_ID BIOCYC_ID REACTOME_ID CLEANEX_ID GERMONLINE_ID DRUGBANK_ID NEXTBIO_ID); # new modules should be a little more lightweight and # should use Bio::Root::Root sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($format, $hostlocation,$servertype) = $self->_rearrange([qw(FORMAT HOSTLOCATION SERVERTYPE)], @args); if( $format && $format !~ /(swiss)|(fasta)/i ) { $self->warn("Requested Format $format is ignored because only SwissProt and Fasta formats are currently supported"); $format = $self->default_format; } $servertype = $DEFAULTSERVERTYPE unless $servertype; $servertype = lc $servertype; $self->servertype($servertype); if ( $hostlocation ) { $self->hostlocation(lc $hostlocation); } $self->request_format($format); # let's always override the format, as it must be swiss or fasta return $self; } =head2 Routines from Bio::DB::RandomAccessI =cut =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =cut =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id( [$uid1, $uid2] ); Function: Gets a series of Seq objects by unique identifiers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of unique identifiers for the desired sequence entries =cut =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Seq_by_acc([$acc1, $acc2]); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut =head2 get_Stream_by_batch Title : get_Stream_by_batch Usage : $seq = $db->get_Stream_by_batch($ref); Function: Retrieves Seq objects from SwissProt 'en masse', rather than one at a time. This is implemented the same way as get_Stream_by_id, but is provided here in keeping with access methods of NCBI modules. Example : Returns : a Bio::SeqIO stream object Args : $ref : either an array reference, a filename, or a filehandle from which to get the list of unique ids/accession numbers. NOTE: deprecated API. Use get_Stream_by_id() instead. =cut *get_Stream_by_batch = sub { my $self = shift; $self->deprecated('get_Stream_by_batch() is deprecated; use get_Stream_by_id() instead'); $self->get_Stream_by_id(@_) }; =head2 Implemented Routines from Bio::DB::WebDBSeqI interface =cut =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: returns a HTTP::Request object Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =cut sub get_request { my ($self, @qualifiers) = @_; my ($uids, $format) = $self->_rearrange([qw(UIDS FORMAT)], @qualifiers); if( !defined $uids ) { $self->throw("Must specify a value for uids to query"); } my ($f,undef) = $self->request_format($format); my %vars = ( @{$HOSTS{$self->servertype}->{'basevars'}}, ( 'format' => $f ) ); my $url = $self->location_url; my $uid; my $jointype = $HOSTS{$self->servertype}->{'jointype'} || ' '; my $idvar = $HOSTS{$self->servertype}->{'idvar'} || 'id'; if( ref($uids) =~ /ARRAY/i ) { # HTTP::Request automagically converts the ' ' to %20 $uid = join($jointype, @$uids); } else { $uid = $uids; } $vars{$idvar} = $uid; return POST $url, \%vars; } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data ( 'type' => 'string', 'location' => \$datastr); Function: process downloaded data before loading into a Bio::SeqIO Returns : void Args : hash with two keys - 'type' can be 'string' or 'file' - 'location' either file location or string reference containing data =cut # don't need to do anything sub postprocess_data { my ($self, %args) = @_; return; } =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: Returns default sequence format for this module Returns : string Args : none =cut sub default_format { return $DEFAULTFORMAT; } =head2 Bio::DB::SwissProt specific routines =cut =head2 servertype Title : servertype Usage : my $servertype = $self->servertype $self->servertype($servertype); Function: Get/Set server type Returns : string Args : server type string [optional] =cut sub servertype { my ($self, $servertype) = @_; if( defined $servertype && $servertype ne '') { $self->throw("You gave an invalid server type ($servertype)". " - available types are ". keys %HOSTS) unless( $HOSTS{$servertype} ); $self->{'_servertype'} = $servertype; $self->{'_hostlocation'} = $HOSTS{$servertype}->{'default'}; # make sure format is reset properly in that different # servers have different syntaxes my ($existingformat,$seqioformat) = $self->request_format; $self->request_format($existingformat); } return $self->{'_servertype'} || $DEFAULTSERVERTYPE; } =head2 hostlocation Title : hostlocation Usage : my $location = $self->hostlocation() $self->hostlocation($location) Function: Set/Get Hostlocation Returns : string representing hostlocation Args : string specifying hostlocation [optional] =cut sub hostlocation { my ($self, $location ) = @_; my $servertype = $self->servertype; $self->throw("Must have a valid servertype defined not $servertype") unless defined $servertype; my %hosts = %{$HOSTS{$servertype}->{'hosts'}}; if( defined $location && $location ne '' ) { $location = lc $location; if( ! $hosts{$location} ) { $self->throw("Must specify a known host, not $location,". " possible values (". join(",", sort keys %hosts ). ")"); } $self->{'_hostlocation'} = $location; } return $self->{'_hostlocation'}; } =head2 location_url Title : location Usage : my $url = $self->location_url() Function: Get host url Returns : string representing url Args : none =cut sub location_url { my ($self) = @_; my $servertype = $self->servertype(); my $location = $self->hostlocation(); if( ! defined $location || !defined $servertype ) { $self->throw("must have a valid hostlocation and servertype set before calling location_url"); } return sprintf($HOSTS{$servertype}->{'baseurl'}, $HOSTS{$servertype}->{'hosts'}->{$location}); } =head2 request_format Title : request_format Usage : my ($req_format, $ioformat) = $self->request_format; $self->request_format("genbank"); $self->request_format("fasta"); Function: Get/Set sequence format retrieval. The get-form will normally not be used outside of this and derived modules. Returns : Array of two strings, the first representing the format for retrieval, and the second specifying the corresponding SeqIO format. Args : $format = sequence format =cut sub request_format { my ($self, $value) = @_; if( defined $value ) { if( $self->servertype =~ /expasy/ ) { if( $value =~ /sprot/ || $value =~ /swiss/ ) { $self->{'_format'} = [ 'sprot', 'swiss']; } elsif( $value =~ /^fa/ ) { $self->{'_format'} = [ 'fasta', 'fasta']; } else { $self->warn("Unrecognized format $value requested"); $self->{'_format'} = [ 'fasta', 'fasta']; } } elsif( $self->servertype =~ /ebi/ ) { if( $value =~ /sprot/ || $value =~ /swiss/ ) { $self->{'_format'} = [ 'swissprot', 'swiss' ]; } elsif( $value =~ /^fa/ ) { $self->{'_format'} = [ 'fasta', 'fasta']; } else { $self->warn("Unrecognized format $value requested"); $self->{'_format'} = [ 'swissprot', 'swiss']; } } } return @{$self->{'_format'}}; } =head2 idtracker Title : idtracker Usage : my ($newid) = $self->idtracker($oldid); Function: Retrieve new ID using old ID. Returns : single ID if one is found Args : ID to look for =cut sub idtracker { my ($self, $id) = @_; $self->deprecated( -message => 'The SwissProt IDTracker service is no longer available, '. 'use id_mapper() instead', -warn_version => 1.006, # warn if $VERSION is >= this version -throw_version => 1.007 # throw if $VERSION is >= this version ); } =head2 id_mapper Title : id_tracker Usage : my $map = $self->id_mapper( -from => '', -to => '', -ids => \@ids); Function: Retrieve new ID using old ID. Returns : hash reference of successfully mapped IDs Args : -from : database mapping from -to : database mapped to -ids : a single ID or array ref of IDs to map Note : For a list of valid database IDs, see: http://www.uniprot.org/faq/28#id_mapping_examples =cut sub id_mapper { my $self = shift; my ($from, $to, $ids) = $self->_rearrange([qw(FROM TO IDS)], @_); for ($from, $to) { $self->throw("$_ is not a recognized database") if !exists $ID_MAPPING_DATABASES{$_}; } my @ids = ref $ids ? @$ids : $ids; my $params = { from => $from, to => $to, format => 'tab', query => join(' ',@ids) }; my $ua = $self->ua; push @{ $ua->requests_redirectable }, 'POST'; my $response = $ua->post("http://www.uniprot.org/mapping/", $params); while (my $wait = $response->header('Retry-After')) { $self->debug("Waiting...\n"); $self->_sleep; $response = $ua->get($response->base); } my %map; if ($response->is_success) { for my $line (split("\n", $response->content)) { my ($id_from, $id_to) = split(/\s+/, $line, 2); next if $id_from eq 'From'; push @{$map{$id_from}}, $id_to; } } else { $self->throw("Error: ".$response->status_line."\n"); } \%map; } 1; __END__ BioPerl-1.6.923/Bio/DB/Taxonomy.pm000444000765000024 2463212254227323 16637 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Taxonomy # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Taxonomy - Access to a taxonomy database =head1 SYNOPSIS use Bio::DB::Taxonomy; my $db = Bio::DB::Taxonomy->new(-source => 'entrez'); # use NCBI Entrez over HTTP my $taxonid = $db->get_taxonid('Homo sapiens'); # get a taxon my $taxon = $db->get_taxon(-taxonid => $taxonid); =head1 DESCRIPTION This is a front end module for access to a taxonomy database. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Sendu Bala: bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Taxonomy; use vars qw($DefaultSource $TAXON_IIDS); use strict; use Bio::Tree::Tree; use base qw(Bio::Root::Root); $DefaultSource = 'entrez'; $TAXON_IIDS = {}; =head2 new Title : new Usage : my $obj = Bio::DB::Taxonomy->new(-source => 'entrez'); Function: Builds a new Bio::DB::Taxonomy object. Returns : an instance of Bio::DB::Taxonomy Args : -source => which database source 'entrez' (NCBI taxonomy online), 'flatfile' (local NCBI taxonomy), 'greengenes' (local GreenGenes taxonomy), 'silva' (local Silva taxonomy), or 'list' (Do-It-Yourself taxonomy) =cut sub new { my($class,@args) = @_; if( $class =~ /Bio::DB::Taxonomy::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $source = $param{'-source'} || $DefaultSource; $source = "\L$source"; # normalize capitalization to lower case # normalize capitalization return unless( $class->_load_tax_module($source) ); return "Bio::DB::Taxonomy::$source"->new(@args); } } # empty for now sub _initialize { } =head2 get_num_taxa Title : get_num_taxa Usage : my $num = $db->get_num_taxa(); Function: Get the number of taxa stored in the database. Returns : A number Args : None =cut sub get_num_taxa { shift->throw_not_implemented(); } =head2 get_taxon Title : get_taxon Usage : my $taxon = $db->get_taxon(-taxonid => $taxonid); Function: Get a Bio::Taxon object from the database. Returns : Bio::Taxon object Args : just a single value which is the database id, OR named args: -taxonid => taxonomy id (to query by taxonid) OR -name => string (to query by a taxonomy name: common name, scientific name, etc) =cut sub get_taxon { shift->throw_not_implemented(); } *get_Taxonomy_Node = \&get_taxon; =head2 get_taxonids Title : get_taxonids Usage : my @taxonids = $db->get_taxonids('Homo sapiens'); Function: Searches for a taxonid (typically ncbi_taxon_id) based on a query string. Note that multiple taxonids can match to the same supplied name. Returns : array of integer ids in list context, one of these in scalar context Args : string representing the taxon's name =cut sub get_taxonids { shift->throw_not_implemented(); } *get_taxonid = \&get_taxonids; *get_taxaid = \&get_taxonids; =head2 get_tree Title : get_tree Usage : my $tree = $db->get_tree(@species_names); Function: Generate a tree comprised of the full lineages of all the supplied species names. The nodes for the requested species are given name('supplied') values corresponding to the supplied name, such that they can be identified if the real species name in the database (stored under node_name()) is different. The nodes are also given an arbitrary branch length of 1. Returns : Bio::Tree::Tree Args : A list of species names (strings) to include in the tree. =cut sub get_tree { my ($self, @species_names) = @_; # the full lineages of the species are merged into a single tree my $tree; for my $name (@species_names) { my @ids = $self->get_taxonids($name); if (not scalar @ids) { $self->throw("Could not find species $name in the taxonomy"); } for my $id (@ids) { my $node = $self->get_taxon(-taxonid => $id); $node->name('supplied', $name); if ($tree) { $tree->merge_lineage($node); } else { $tree = Bio::Tree::Tree->new(-verbose => $self->verbose, -node => $node); } } } # add arbitrary branch length for my $node ($tree->get_nodes) { $node->branch_length(1); } return $tree; } =head2 ancestor Title : ancestor Usage : my $ancestor_taxon = $db->ancestor($taxon); Function: Retrieve the full ancestor taxon of a supplied Taxon from the database. Returns : Bio::Taxon Args : Bio::Taxon (that was retrieved from this database) =cut sub ancestor { shift->throw_not_implemented(); } =head2 each_Descendent Title : each_Descendent Usage : my @taxa = $db->each_Descendent($taxon); Function: Get all the descendents of the supplied Taxon (but not their descendents, ie. not a recursive fetchall). Returns : Array of Bio::Taxon objects Args : Bio::Taxon (that was retrieved from this database) =cut sub each_Descendent { shift->throw_not_implemented(); } =head2 get_all_Descendents Title : get_all_Descendents Usage : my @taxa = $db->get_all_Descendents($taxon); Function: Like each_Descendent(), but do a recursive fetchall Returns : Array of Bio::Taxon objects Args : Bio::Taxon (that was retrieved from this database) =cut sub get_all_Descendents { my ($self, $taxon) = @_; my @taxa; foreach my $desc_taxon ($self->each_Descendent($taxon)) { push @taxa, ($desc_taxon, $self->get_all_Descendents($desc_taxon)); } return @taxa; } =head2 _load_tax_module Title : _load_tax_module Usage : *INTERNAL Bio::DB::Taxonomy stuff* Function: Loads up (like use) a module at run time on demand =cut sub _load_tax_module { my ($self, $source) = @_; my $module = "Bio::DB::Taxonomy::" . $source; my $ok; eval { $ok = $self->_load_module($module) }; if ( $@ ) { print STDERR $@; print STDERR <throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); my $taxid = $taxon->id || return; my $name = $taxon->scientific_name || ''; my $rank = $taxon->rank || 'no rank'; my $dbh = $try_name ? $taxon->db_handle : 'any'; my $iid = $TAXON_IIDS->{taxids}->{$dbh}->{$taxid}; if ( (not defined $iid) && $try_name && $name && exists $TAXON_IIDS->{names}->{$name}) { # Search for a suitable IID based on species name and ranks my %test_ranks = map {$_ => undef} ($rank, 'no rank'); SEARCH: while (my ($test_rank, undef) = each %test_ranks) { # Search at the specified rank first, then with 'no rank' while ( my ($test_iid, $test_info) = each %{$TAXON_IIDS->{names}->{$name}->{$rank}} ) { while (my ($test_db, $test_taxid) = each %$test_info) { if ( ($test_db eq $dbh) && not($test_taxid eq $taxid) ) { # Taxa are different (same database, different taxid) next; } # IID is acceptable since taxa are from different databases, # or from the same database but have the same taxid $iid = $test_iid; $TAXON_IIDS->{taxids}->{$dbh}->{$taxid} = $iid; last SEARCH; } } } } if (defined $iid) { # Assign Bio::DB::Taxonomy IID with risky Bio::Tree::Node internal method $taxon->_creation_id($iid); } else { # Register new IID in Bio::DB::Taxonomy $iid = $taxon->internal_id; $TAXON_IIDS->{taxids}->{$dbh}->{$taxid} = $iid; if ($name) { $TAXON_IIDS->{names}->{$name}->{$rank}->{$iid}->{$taxon->db_handle} = $taxid } } return $iid; } 1; BioPerl-1.6.923/Bio/DB/TFBS.pm000444000765000024 1027112254227337 15556 0ustar00cjfieldsstaff000000000000# $Id: TFBS.pm,v 1.11 2006/08/12 11:00:03 sendu Exp $ # # BioPerl module for Bio::DB::TFBS # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::TFBS - Access to a Transcription Factor Binding Site database =head1 SYNOPSIS use Bio::DB::TFBS; my $db = Bio::DB::TFBS->new(-source => 'transfac'); my ($factor_id) = $db->get_factor_ids('PPAR-gamma1'); my ($matrix_id) = $db->get_matrix_ids('PPAR-gamma1'); # get a Bio::Map::TranscriptionFactor with all the positions of a given factor my $factor = $db->get_factor(-factor_id => $factor_id); # get a Bio::Map::GeneMap containing all the factors that bind near a given gene my $gene_map = $db->get_gene_map(-gene_name => 'AQP 7'); # get a PSM (Bio::Matrix::PSM) of a given matrix my $psm = $db->get_matrix(-matrix_id => $matrix_id); # get the aligned sequences (Bio::SimpleAlign) that were used to build a given # matrix my $align = $db->get_alignment(-matrix_id => $matrix_id); # get a specific instance sequence (Bio::LocatableSeq) my $seq = $db->get_seq($id); =head1 DESCRIPTION This is a front end module for access to a Transcription Factor Binding Site database. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Based on Bio::DB::Taxonomy by Jason Stajich =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::TFBS; use strict; use Bio::Root::Root; use base qw(Bio::Root::Root); our $DefaultSource = 'transfac'; =head2 new Title : new Usage : my $obj = Bio::DB::TFBS->new(-source => 'transfac'); Function: Builds a new Bio::DB::TFBS object. Returns : an instance of Bio::DB::TFBS Args : -source => which database source: currently only 'transfac_pro' =cut sub new { my ($class, @args) = @_; if ($class =~ /Bio::DB::TFBS::(\S+)/) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $source = $param{'-source'} || $DefaultSource; $source = "\L$source"; # normalize capitalization to lower case # normalize capitalization return unless( $class->_load_tax_module($source) ); return "Bio::DB::TFBS::$source"->new(@args); } } # empty for now sub _initialize { } =head2 _load_tax_module Title : _load_tax_module Usage : *INTERNAL Bio::DB::TFBS stuff* Function: Loads up (like use) a module at run time on demand =cut sub _load_tax_module { my ($self, $source) = @_; my $module = "Bio::DB::TFBS::" . $source; my $ok; eval { $ok = $self->_load_module($module) }; if ( $@ ) { print STDERR $@; print STDERR < # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Universal - Artificial database that delegates to specific databases =head1 SYNOPSIS $uni = Bio::DB::Universal->new(); # by default connects to web databases. We can also # substitute local databases $embl = Bio::Index::EMBL->new( -filename => '/some/index/filename/locally/stored'); $uni->use_database('embl',$embl); # treat it like a normal database. Recognises strings # like gb|XXXXXX and embl:YYYYYY $seq1 = $uni->get_Seq_by_id("embl:HSHNRNPA"); $seq2 = $uni->get_Seq_by_acc("gb|A000012"); # with no separator, tries to guess database. In this case the # _ is considered to be indicative of swissprot $seq3 = $uni->get_Seq_by_id('ROA1_HUMAN'); =head1 DESCRIPTION Artificial database that delegates to specific databases, with a "smart" (well, smartish) guessing routine for what the ids. No doubt the smart routine can be made smarter. The hope is that you can make this database and just throw ids at it - for most easy cases it will sort you out. Personally, I would be making sure I knew where each id came from and putting it into its own database first - but this is a quick and dirty solution. By default this connects to web orientated databases, with all the reliability and network bandwidth costs this implies. However you can subsistute your own local databases - they could be Bio::Index databases (DBM file and flat file) or bioperl-db based (MySQL based) or biocorba-based (whatever you like behind the corba interface). Internally the tags for the databases are genbank - ncbi dna database embl - ebi's dna database (these two share accession number space) swiss - swissprot + sptrembl (EBI's protein database) We should extend this for RefSeq and other sequence databases which are out there... ;) Inspired by Lincoln Stein, written by Ewan Birney. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bio.perl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Universal; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::DB::GenBank; use Bio::DB::SwissProt; use Bio::DB::EMBL; use base qw(Bio::DB::RandomAccessI Bio::Root::Root); # new() can be inherited from Bio::Root::Root sub new { my ($class) = @_; my $self = {}; bless $self,$class; $self->{'db_hash'} = {}; # default databases $self->use_database('embl',Bio::DB::EMBL->new); $self->use_database('genbank',Bio::DB::GenBank->new); $self->use_database('swiss',Bio::DB::GenBank->new); return $self; } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : Function: Example : Returns : Args : =cut sub get_Seq_by_id{ my ($self,$str) = @_; my ($tag,$id) = $self->guess_id($str); return $self->{'db_hash'}->{$tag}->get_Seq_by_id($id); } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : Function: Example : Returns : Args : =cut sub get_Seq_by_acc { my ($self,$str) = @_; my ($tag,$id) = $self->guess_id($str); return $self->{'db_hash'}->{$tag}->get_Seq_by_acc($id); } =head2 guess_id Title : guess_id Usage : Function: Example : Returns : Args : =cut sub guess_id{ my ($self,$str) = @_; if( $str =~ /(\S+)[:|\/;](\w+)/ ) { my $tag; my $db = $1; my $id = $2; if( $db =~ /gb/i || $db =~ /genbank/i || $db =~ /ncbi/i ) { $tag = 'genbank'; } elsif ( $db =~ /embl/i || $db =~ /emblbank/ || $db =~ /^em/i ) { $tag = 'embl'; } elsif ( $db =~ /swiss/i || $db =~ /^sw/i || $db =~ /sptr/ ) { $tag = 'swiss'; } else { # throw for the moment $self->throw("Could not guess database type $db from $str"); } return ($tag,$id); } else { my $tag; # auto-guess from just the id if( $str =~ /_/ ) { $tag = 'swiss'; } elsif ( $str =~ /^[QPR]\w+\d$/ ) { $tag = 'swiss'; } elsif ( $str =~ /[A-Z]\d+/ ) { $tag = 'genbank'; } else { # default genbank... $tag = 'genbank'; } return ($tag,$str); } } =head2 use_database Title : use_database Usage : Function: Example : Returns : Args : =cut sub use_database{ my ($self,$name,$database) = @_; $self->{'db_hash'}->{$name} = $database; } 1; BioPerl-1.6.923/Bio/DB/UpdateableSeqI.pm000444000765000024 1327312254227326 17653 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::UpdateableSeqI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # # _history # June 18, 2000 - module begun # # POD Doc - main docs before code =head1 NAME Bio::DB::UpdateableSeqI - An interface for writing to a database of sequences. =head1 SYNOPSIS # get a Bio::DB::UpdateableSeqI somehow eval { my ( @updatedseqs, @newseqs, @deadseqs); my $seq = $db->get_Seq_by_id('ROA1_HUMAN'); $seq->desc('a new description'); push @updatedseqs, $seq; $db->write_seq(\@updatedseqs, \@newseqs, \@deadseqs); }; if( $@ ) { print STDERR "an error when trying to write seq : $@\n"; } =head1 DESCRIPTION This module seeks to provide a simple method for pushing sequence changes back to a Sequence Database - which can be an SQL compliant database, a file based database, AceDB, etc. =head1 AUTHOR Jason Stajich Ejason@bioperl.orgE =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #Lets start some code package Bio::DB::UpdateableSeqI; use strict; use base qw(Bio::DB::SeqI); =head2 write_seq Title : write_seq Usage : write_seq(\@updatedseqs, \@addedseqs, \@deadseqs) Function: updates sequences in first array, adds sequences in the second array, and removes sequences in the third array. Example : Returns : Args : arrays of sequence objects that must be obtained from Bio::DB::UpdateableSeqI. =cut sub write_seq { my ($self) = @_; $self->throw("Abstract database call of write_seq. Your database has not implemented this method!"); } =head2 _add_seq Title : _add_seq Usage : _add_seq($seq) Function: Adds a new sequence Example : Returns : will throw an exception if sequences accession number already exists Args : a new seq object - should have an accession number =cut sub _add_seq { my ($self ) = @_; $self->throw("Abstract database call of _add_seq. Your database has not implemented this method!"); } =head2 _remove_seq Title : _remove_seq Usage : _remove_seq($seq) Function: Removes an existing sequence Example : Returns : will throw an exception if sequence does not exists for the primary_id Args : a seq object that was retrieved from Bio::DB::UpdateableSeqI =cut sub _remove_seq { my ($self) = @_; $self->throw("Abstract database call of _remove_seq. Your database has not implemented this method!"); } =head2 _update_seq Title : _update_seq Usage : _update_seq($seq) Function: Updates a sequence Example : Returns : will throw an exception if sequence is out of sync from expected val. Args : a seq object that was retrieved from Bio::DB::UpdateableSeqI =cut sub _update_seq { my ($self) = @_; $self->throw("Abstract database call of _update_seq. Your database has not implemented this method!"); } =head1 Methods inherieted from Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =cut =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut =head1 Methods inheirited from Bio::DB::SeqI =head2 get_PrimarySeq_stream Title : get_PrimarySeq_stream Usage : $stream = get_PrimarySeq_stream Function: Makes a Bio::DB::SeqStreamI compliant object which provides a single method, next_primary_seq Returns : Bio::DB::SeqStreamI Args : none =cut =head2 get_all_primary_ids Title : get_all_ids Usage : @ids = $seqdb->get_all_primary_ids() Function: gives an array of all the primary_ids of the sequence objects in the database. These maybe ids (display style) or accession numbers or something else completely different - they *are not* meaningful outside of this database implementation. Example : Returns : an array of strings Args : none =cut =head2 get_Seq_by_primary_id Title : get_Seq_by_primary_id Usage : $seq = $db->get_Seq_by_primary_id($primary_id_string); Function: Gets a Bio::Seq object by the primary id. The primary id in these cases has to come from $db->get_all_primary_ids. There is no other way to get (or guess) the primary_ids in a database. The other possibility is to get Bio::PrimarySeqI objects via the get_PrimarySeq_stream and the primary_id field on these objects are specified as the ids to use here. Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut 1; BioPerl-1.6.923/Bio/DB/WebDBSeqI.pm000444000765000024 6140212254227336 16526 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::WebDBSeqI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::DB::WebDBSeqI - Object Interface to generalize Web Databases for retrieving sequences =head1 SYNOPSIS # get a WebDBSeqI object somehow # assuming it is a nucleotide db my $seq = $db->get_Seq_by_id('ROA1_HUMAN') =head1 DESCRIPTION Provides core set of functionality for connecting to a web based database for retriving sequences. Users wishing to add another Web Based Sequence Dabatase will need to extend this class (see L or L for examples) and implement the get_request method which returns a HTTP::Request for the specified uids (accessions, ids, etc depending on what query types the database accepts). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web. https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email E jason@bioperl.org E =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::WebDBSeqI; use strict; use vars qw($MODVERSION %RETRIEVAL_TYPES $DEFAULT_RETRIEVAL_TYPE $DEFAULTFORMAT $LAST_INVOCATION_TIME @ATTRIBUTES); use Bio::SeqIO; use Bio::Root::IO; use LWP::UserAgent; use POSIX 'setsid'; use HTTP::Request::Common; use HTTP::Response; use File::Spec; use IO::Pipe; use IO::String; use Bio::Root::Root; use base qw(Bio::DB::RandomAccessI); BEGIN { $MODVERSION = '0.8'; %RETRIEVAL_TYPES = ('io_string' => 1, 'tempfile' => 1, 'pipeline' => 1, ); $DEFAULT_RETRIEVAL_TYPE = 'pipeline'; $DEFAULTFORMAT = 'fasta'; $LAST_INVOCATION_TIME = 0; } sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($baseaddress, $params, $ret_type, $format,$delay,$db) = $self->_rearrange([qw(BASEADDRESS PARAMS RETRIEVALTYPE FORMAT DELAY DB)], @args); $ret_type = $DEFAULT_RETRIEVAL_TYPE unless ( $ret_type); $baseaddress && $self->url_base_address($baseaddress); $params && $self->url_params($params); $db && $self->db($db); $ret_type && $self->retrieval_type($ret_type); $delay = $self->delay_policy unless defined $delay; $self->delay($delay); # insure we always have a default format set for retrieval # even though this will be immedietly overwritten by most sub classes $format = $self->default_format unless ( defined $format && $format ne '' ); $self->request_format($format); my $ua = LWP::UserAgent->new(env_proxy => 1); $ua->agent(ref($self) ."/$MODVERSION"); $self->ua($ua); $self->{'_authentication'} = []; return $self; } # from Bio::DB::RandomAccessI =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $seq = $db->get_Seq_by_id('ROA1_HUMAN') Function: Gets a Bio::Seq object by its name Returns : a Bio::Seq object Args : the id (as a string) of a sequence Throws : "id does not exist" exception =cut sub get_Seq_by_id { my ($self,$seqid) = @_; $self->_sleep; my $seqio = $self->get_Stream_by_id([$seqid]); $self->throw("id does not exist") if( !defined $seqio ) ; if ($self->can('complexity') && defined $self->complexity && $self->complexity==0) { $self->warn("When complexity is set to 0, use get_Stream_by_id\n". "Returning Bio::SeqIO object"); return $seqio; } my @seqs; while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; } $self->throw("id '$seqid' does not exist") unless @seqs; if( wantarray ) { return @seqs } else { return shift @seqs } } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $seq = $db->get_Seq_by_acc('X77802'); Function: Gets a Bio::Seq object by accession number Returns : A Bio::Seq object Args : accession number (as a string) Throws : "acc does not exist" exception =cut sub get_Seq_by_acc { my ($self,$seqid) = @_; $self->_sleep; my $seqio = $self->get_Stream_by_acc($seqid); $self->throw("acc '$seqid' does not exist") if( ! defined $seqio ); if ($self->can('complexity') && defined $self->complexity && $self->complexity==0) { $self->warn("When complexity is set to 0, use get_Stream_by_acc\n". "Returning Bio::SeqIO object"); return $seqio; } my @seqs; while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; } $self->throw("acc $seqid does not exist") unless @seqs; if( wantarray ) { return @seqs } else { return shift @seqs } } =head2 get_Seq_by_gi Title : get_Seq_by_gi Usage : $seq = $db->get_Seq_by_gi('405830'); Function: Gets a Bio::Seq object by gi number Returns : A Bio::Seq object Args : gi number (as a string) Throws : "gi does not exist" exception =cut sub get_Seq_by_gi { my ($self,$seqid) = @_; $self->_sleep; my $seqio = $self->get_Stream_by_gi($seqid); $self->throw("gi does not exist") if( !defined $seqio ); if ($self->can('complexity') && defined $self->complexity && $self->complexity==0) { $self->warn("When complexity is set to 0, use get_Stream_by_gi\n". "Returning Bio::SeqIO object"); return $seqio; } my @seqs; while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; } $self->throw("gi does not exist") unless @seqs; if( wantarray ) { return @seqs } else { return shift @seqs } } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $seq = $db->get_Seq_by_version('X77802.1'); Function: Gets a Bio::Seq object by sequence version Returns : A Bio::Seq object Args : accession.version (as a string) Throws : "acc.version does not exist" exception =cut sub get_Seq_by_version { my ($self,$seqid) = @_; $self->_sleep; my $seqio = $self->get_Stream_by_version($seqid); $self->throw("accession.version does not exist") if( !defined $seqio ); if ($self->can('complexity') && defined $self->complexity && $self->complexity==0) { $self->warn("When complexity is set to 0, use get_Stream_by_version\n". "Returning Bio::SeqIO object"); return $seqio; } my @seqs; while( my $seq = $seqio->next_seq() ) { push @seqs, $seq; } $self->throw("accession.version does not exist") unless @seqs; if( wantarray ) { return @seqs } else { return shift @seqs } } # implementing class must define these =head2 get_request Title : get_request Usage : my $url = $self->get_request Function: returns a HTTP::Request object Returns : Args : %qualifiers = a hash of qualifiers (ids, format, etc) =cut sub get_request { my ($self) = @_; my $msg = "Implementing class must define method get_request in class WebDBSeqI"; $self->throw($msg); } # class methods =head2 get_Stream_by_id Title : get_Stream_by_id Usage : $stream = $db->get_Stream_by_id( [$uid1, $uid2] ); Function: Gets a series of Seq objects by unique identifiers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of unique identifiers for the desired sequence entries =cut sub get_Stream_by_id { my ($self, $ids) = @_; my ($webfmt,$localfmt) = $self->request_format; return $self->get_seq_stream('-uids' => $ids, '-mode' => 'single', '-format' => $webfmt); } *get_Stream_by_batch = sub { my $self = shift; $self->deprecated('get_Stream_by_batch() is deprecated; use get_Stream_by_id() instead'); $self->get_Stream_by_id(@_) }; =head2 get_Stream_by_acc Title : get_Stream_by_acc Usage : $seq = $db->get_Stream_by_acc([$acc1, $acc2]); Function: Gets a series of Seq objects by accession numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut sub get_Stream_by_acc { my ($self, $ids ) = @_; return $self->get_seq_stream('-uids' => $ids, '-mode' => 'single'); } =head2 get_Stream_by_gi Title : get_Stream_by_gi Usage : $seq = $db->get_Stream_by_gi([$gi1, $gi2]); Function: Gets a series of Seq objects by gi numbers Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of gi numbers for the desired sequence entries Note : For GenBank, this just calls the same code for get_Stream_by_id() =cut sub get_Stream_by_gi { my ($self, $ids ) = @_; return $self->get_seq_stream('-uids' => $ids, '-mode' => 'gi'); } =head2 get_Stream_by_version Title : get_Stream_by_version Usage : $seq = $db->get_Stream_by_version([$version1, $version2]); Function: Gets a series of Seq objects by accession.versions Returns : a Bio::SeqIO stream object Args : $ref : a reference to an array of accession.version strings for the desired sequence entries Note : For GenBank, this is implemeted in NCBIHelper =cut sub get_Stream_by_version { my ($self, $ids ) = @_; # $self->throw("Implementing class should define this method!"); return $self->get_seq_stream('-uids' => $ids, '-mode' => 'version'); # how it should work } =head2 get_Stream_by_query Title : get_Stream_by_query Usage : $stream = $db->get_Stream_by_query($query); Function: Gets a series of Seq objects by way of a query string or oject Returns : a Bio::SeqIO stream object Args : $query : A string that uses the appropriate query language for the database or a Bio::DB::QueryI object. It is suggested that you create the Bio::DB::Query object first and interrogate it for the entry count before you fetch a potentially large stream. =cut sub get_Stream_by_query { my ($self, $query ) = @_; return $self->get_seq_stream('-query' => $query, '-mode'=>'query'); } =head2 default_format Title : default_format Usage : my $format = $self->default_format Function: Returns default sequence format for this module Returns : string Args : none =cut sub default_format { return $DEFAULTFORMAT; } # sorry, but this is hacked in because of BioFetch problems... sub db { my $self = shift; my $d = $self->{_db}; $self->{_db} = shift if @_; $d; } =head2 request_format Title : request_format Usage : my ($req_format, $ioformat) = $self->request_format; $self->request_format("genbank"); $self->request_format("fasta"); Function: Get/Set sequence format retrieval. The get-form will normally not be used outside of this and derived modules. Returns : Array of two strings, the first representing the format for retrieval, and the second specifying the corresponding SeqIO format. Args : $format = sequence format =cut sub request_format { my ($self, $value) = @_; if( defined $value ) { $self->{'_format'} = [ $value, $value]; } return @{$self->{'_format'}}; } =head2 get_seq_stream Title : get_seq_stream Usage : my $seqio = $self->get_seq_stream(%qualifiers) Function: builds a url and queries a web db Returns : a Bio::SeqIO stream capable of producing sequence Args : %qualifiers = a hash qualifiers that the implementing class will process to make a url suitable for web querying =cut sub get_seq_stream { my ($self, %qualifiers) = @_; my ($rformat, $ioformat) = $self->request_format(); my $seen = 0; foreach my $key ( keys %qualifiers ) { if( $key =~ /format/i ) { $rformat = $qualifiers{$key}; $seen = 1; } } $qualifiers{'-format'} = $rformat if( !$seen); ($rformat, $ioformat) = $self->request_format($rformat); # These parameters are implemented for Bio::DB::GenBank objects only if($self->isa('Bio::DB::GenBank')) { $self->seq_start() && ($qualifiers{'-seq_start'} = $self->seq_start()); $self->seq_stop() && ($qualifiers{'-seq_stop'} = $self->seq_stop()); $self->strand() && ($qualifiers{'-strand'} = $self->strand()); defined $self->complexity() && ($qualifiers{'-complexity'} = $self->complexity()); } my $request = $self->get_request(%qualifiers); $request->proxy_authorization_basic($self->authentication) if ( $self->authentication); $self->debug("request is ". $request->as_string(). "\n"); # workaround for MSWin systems $self->retrieval_type('io_string') if $self->retrieval_type =~ /pipeline/ && $^O =~ /^MSWin/; if ($self->retrieval_type =~ /pipeline/) { # Try to create a stream using POSIX fork-and-pipe facility. # this is a *big* win when fetching thousands of sequences from # a web database because we can return the first entry while # transmission is still in progress. # Also, no need to keep sequence in memory or in a temporary file. # If this fails (Windows, MacOS 9), we fall back to non-pipelined access. # fork and pipe: _stream_request()=> my ($result,$stream) = $self->_open_pipe(); if (defined $result) { $DB::fork_TTY = File::Spec->devnull; # prevents complaints from debugge if (!$result) { # in child process $self->_stream_request($request,$stream); POSIX::_exit(0); #prevent END blocks from executing in this forked child } else { return Bio::SeqIO->new('-verbose' => $self->verbose, '-format' => $ioformat, '-fh' => $stream); } } else { $self->retrieval_type('io_string'); } } if ($self->retrieval_type =~ /temp/i) { my $dir = $self->io->tempdir( CLEANUP => 1); my ( $fh, $tmpfile) = $self->io()->tempfile( DIR => $dir ); close $fh; my $resp = $self->_request($request, $tmpfile); if( ! -e $tmpfile || -z $tmpfile || ! $resp->is_success() ) { $self->throw("WebDBSeqI Error - check query sequences!\n"); } $self->postprocess_data('type' => 'file', 'location' => $tmpfile); # this may get reset when requesting batch mode ($rformat,$ioformat) = $self->request_format(); if( $self->verbose > 0 ) { open(my $ERR, "<", $tmpfile); while(<$ERR>) { $self->debug($_);} } return Bio::SeqIO->new('-verbose' => $self->verbose, '-format' => $ioformat, '-file' => $tmpfile); } if ($self->retrieval_type =~ /io_string/i ) { my $resp = $self->_request($request); my $content = $resp->content_ref; $self->debug( "content is $$content\n"); if (!$resp->is_success() || length($$content) == 0) { $self->throw("WebDBSeqI Error - check query sequences!\n"); } ($rformat,$ioformat) = $self->request_format(); $self->postprocess_data('type'=> 'string', 'location' => $content); $self->debug( "str is $$content\n"); return Bio::SeqIO->new('-verbose' => $self->verbose, '-format' => $ioformat, '-fh' => new IO::String($$content)); } # if we got here, we don't know how to handle the retrieval type $self->throw("retrieval type " . $self->retrieval_type . " unsupported\n"); } =head2 url_base_address Title : url_base_address Usage : my $address = $self->url_base_address or $self->url_base_address($address) Function: Get/Set the base URL for the Web Database Returns : Base URL for the Web Database Args : $address - URL for the WebDatabase =cut sub url_base_address { my $self = shift; my $d = $self->{'_baseaddress'}; $self->{'_baseaddress'} = shift if @_; $d; } =head2 proxy Title : proxy Usage : $httpproxy = $db->proxy('http') or $db->proxy(['http','ftp'], 'http://myproxy' ) Function: Get/Set a proxy for use of proxy Returns : a string indicating the proxy Args : $protocol : an array ref of the protocol(s) to set/get $proxyurl : url of the proxy to use for the specified protocol $username : username (if proxy requires authentication) $password : password (if proxy requires authentication) =cut sub proxy { my ($self,$protocol,$proxy,$username,$password) = @_; return if ( !defined $self->ua || !defined $protocol || !defined $proxy ); $self->authentication($username, $password) if ($username && $password); return $self->ua->proxy($protocol,$proxy); } =head2 authentication Title : authentication Usage : $db->authentication($user,$pass) Function: Get/Set authentication credentials Returns : Array of user/pass Args : Array or user/pass =cut sub authentication{ my ($self,$u,$p) = @_; if( defined $u && defined $p ) { $self->{'_authentication'} = [ $u,$p]; } return @{$self->{'_authentication'}}; } =head2 retrieval_type Title : retrieval_type Usage : $self->retrieval_type($type); my $type = $self->retrieval_type Function: Get/Set a proxy for retrieval_type (pipeline, io_string or tempfile) Returns : string representing retrieval type Args : $value - the value to store This setting affects how the data stream from the remote web server is processed and passed to the Bio::SeqIO layer. Three types of retrieval types are currently allowed: pipeline Perform a fork in an attempt to begin streaming while the data is still downloading from the remote server. Disk, memory and speed efficient, but will not work on Windows or MacOS 9 platforms. io_string Store downloaded database entry(s) in memory. Can be problematic for batch downloads because entire set of entries must fit in memory. Alll entries must be downloaded before processing can begin. tempfile Store downloaded database entry(s) in a temporary file. All entries must be downloaded before processing can begin. The default is pipeline, with automatic fallback to io_string if pipelining is not available. =cut sub retrieval_type { my ($self, $value) = @_; if( defined $value ) { $value = lc $value; if( ! $RETRIEVAL_TYPES{$value} ) { $self->warn("invalid retrieval type $value must be one of (" . join(",", keys %RETRIEVAL_TYPES), ")"); $value = $DEFAULT_RETRIEVAL_TYPE; } $self->{'_retrieval_type'} = $value; } return $self->{'_retrieval_type'}; } =head2 url_params Title : url_params Usage : my $params = $self->url_params or $self->url_params($params) Function: Get/Set the URL parameters for the Web Database Returns : url parameters for Web Database Args : $params - parameters to be appended to the URL for the WebDatabase =cut sub url_params { my ($self, $value) = @_; if( defined $value ) { $self->{'_urlparams'} = $value; } } =head2 ua Title : ua Usage : my $ua = $self->ua or $self->ua($ua) Function: Get/Set a LWP::UserAgent for use Returns : reference to LWP::UserAgent Object Args : $ua - must be a LWP::UserAgent =cut sub ua { my ($self, $ua) = @_; if( defined $ua && $ua->isa("LWP::UserAgent") ) { $self->{'_ua'} = $ua; } return $self->{'_ua'}; } =head2 postprocess_data Title : postprocess_data Usage : $self->postprocess_data ( 'type' => 'string', 'location' => \$datastr); Function: process downloaded data before loading into a Bio::SeqIO Returns : void Args : hash with two keys - 'type' can be 'string' or 'file' - 'location' either file location or string reference containing data =cut sub postprocess_data { my ( $self, %args) = @_; return; } # private methods sub _request { my ($self, $url,$tmpfile) = @_; my ($resp); if( defined $tmpfile && $tmpfile ne '' ) { $resp = $self->ua->request($url, $tmpfile); } else { $resp = $self->ua->request($url); } if( $resp->is_error ) { $self->throw("WebDBSeqI Request Error:\n".$resp->as_string); } return $resp; } #mod_perl-safe replacement for the open(BLEH,'-|') call. if running #under mod_perl, detects it and closes the child's STDIN and STDOUT #handles sub _open_pipe { my ($self) = @_; # is mod_perl running? Which API? my $mp = $self->mod_perl_api; if($mp and ! our $loaded_apache_sp) { my $load_api = ($mp == 1) ? 'use Apache::SubProcess': 'use Apache2::SubProcess'; eval $load_api; $@ and $self->throw("$@\n$load_api module required for running under mod_perl"); $loaded_apache_sp = 1; } my $pipe = IO::Pipe->new(); local $SIG{CHLD} = 'IGNORE'; defined(my $pid = fork) or $self->throw("Couldn't fork: $!"); unless($pid) { #CHILD $pipe->writer(); #if we're running under mod_perl, clean up some things after this fork if ($ENV{MOD_PERL} and my $r = eval{Apache->request} ) { $r->cleanup_for_exec; #don't read or write the mod_perl parent's tied filehandles close STDIN; close STDOUT; setsid() or $self->throw('Could not detach from parent'); } } else { #PARENT $pipe->reader(); } return ( $pid, $pipe ); } # send web request to specified filehandle, or stdout, for streaming purposes sub _stream_request { my $self = shift; my $request = shift; my $dest_fh = shift || \*STDOUT; # fork so as to pipe output of fetch process through to # postprocess_data method call. my ($child,$fetch) = $self->_open_pipe(); if ($child) { #PARENT local ($/) = "//\n"; # assume genbank/swiss format $| = 1; my $records = 0; while (my $record = <$fetch>) { $records++; $self->postprocess_data('type' => 'string', 'location' => \$record); print $dest_fh $record; } $/ = "\n"; # reset to be safe; close $dest_fh; #must explicitly close here, because the hard #exits don't cloes them for us } else { #CHILD $| = 1; my $resp = $self->ua->request($request, sub { print $fetch $_[0] } ); if( $resp->is_error ) { $self->throw("WebDBSeqI Request Error:\n".$resp->as_string); } close $fetch; #must explicitly close here, because the hard exists #don't close them for us POSIX::_exit(0); } } sub io { my ($self,$io) = @_; if(defined($io) || (! exists($self->{'_io'}))) { $io = Bio::Root::IO->new() unless $io; $self->{'_io'} = $io; } return $self->{'_io'}; } =head2 delay Title : delay Usage : $secs = $self->delay([$secs]) Function: get/set number of seconds to delay between fetches Returns : number of seconds to delay Args : new value NOTE: the default is to use the value specified by delay_policy(). This can be overridden by calling this method, or by passing the -delay argument to new(). =cut sub delay { my $self = shift; my $d = $self->{'_delay'}; $self->{'_delay'} = shift if @_; $d; } =head2 delay_policy Title : delay_policy Usage : $secs = $self->delay_policy Function: return number of seconds to delay between calls to remote db Returns : number of seconds to delay Args : none NOTE: The default delay policy is 0s. Override in subclasses to implement delays. The timer has only second resolution, so the delay will actually be +/- 1s. =cut sub delay_policy { my $self = shift; return 0; } =head2 _sleep Title : _sleep Usage : $self->_sleep Function: sleep for a number of seconds indicated by the delay policy Returns : none Args : none NOTE: This method keeps track of the last time it was called and only imposes a sleep if it was called more recently than the delay_policy() allows. =cut sub _sleep { my $self = shift; my $last_invocation = $LAST_INVOCATION_TIME; if (time - $LAST_INVOCATION_TIME < $self->delay) { my $delay = $self->delay - (time - $LAST_INVOCATION_TIME); warn "sleeping for $delay seconds\n" if $self->verbose > 0; sleep $delay; } $LAST_INVOCATION_TIME = time; } =head2 mod_perl_api Title : mod_perl_api Usage : $version = self->mod_perl_api Function: Returns API version of mod_perl being used based on set env. variables Returns : mod_perl API version; if mod_perl isn't loaded, returns 0 Args : none =cut sub mod_perl_api { my $self = shift; my $v = $ENV{MOD_PERL} ? ( exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} >= 2 ) ? 2 : 1 : 0; return $v; } 1; BioPerl-1.6.923/Bio/DB/Expression000755000765000024 012254227325 16440 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/Expression/geo.pm000444000765000024 1761212254227325 17734 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::Expression::geo - *** DESCRIPTION of Class =head1 SYNOPSIS *** Give standard usage here =head1 DESCRIPTION *** Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Allen Day Eallenday@ucla.eduE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a '_'. Methods are in alphabetical order for the most part. =cut # Let the code begin... package Bio::DB::Expression::geo; use strict; use base qw(Bio::DB::Expression); use Bio::Expression::Contact; use Bio::Expression::DataSet; use Bio::Expression::Platform; use Bio::Expression::Sample; use constant URL_PLATFORMS => 'http://www.ncbi.nlm.nih.gov/geo/query/browse.cgi?pgsize=100000&mode=platforms&submitter=-1&filteron=0&filtervalue=-1&private=1&sorton=pub_date&sortdir=1&start=1'; use constant URL_PLATFORM => 'http://www.ncbi.nlm.nih.gov/projects/geo/query/acc.cgi?form=text&view=full&acc='; use constant URL_DATASET => 'http://www.ncbi.nlm.nih.gov/projects/geo/query/acc.cgi?form=text&view=full&acc='; use constant URL_SAMPLE => 'http://www.ncbi.nlm.nih.gov/projects/geo/query/acc.cgi?form=text&view=full&acc='; =head2 _initialize() Usage : $obj->_initialize(%arg); Function: Internal method to initialize a new Bio::DB::Expression::geo object Returns : true on success Args : Arguments passed to new() =cut sub _initialize { my($self,%arg) = @_; foreach my $arg (keys %arg){ my $marg = $arg; $marg =~ s/^-//; $self->$marg($arg{$arg}) if $self->can($marg); } return 1; } =head2 get_platforms() Usage : Function: Example : Returns : a list of Bio::Expression::Platform objects Args : =cut sub get_platforms { my ($self,@args) = @_; my $doc = $self->_get_url( URL_PLATFORMS ); $doc =~ s!^.+?>Release date<.+?(.+)!$1!gs; my @platforms = (); my @records = split m!\s+!, $doc; foreach my $record ( @records ) { my ($platform_acc,$name,$tax_acc,$contact_acc,$contact_name) = $record =~ m!acc\.cgi\?acc=(.+?)".+?(.+?)<.+?.+?<.+?.+?href=".+?id=(.+?)".+?(.+?)new( -accession => $platform_acc, -name => $name, -_taxon_id => $tax_acc, -contact => Bio::Expression::Contact->new( -source => 'geo', -accession => $contact_acc, -name => $contact_name, -db => $self ), -db => $self, ); push @platforms, $platform; } return @platforms; } =head2 get_samples() Usage : Function: Example : Returns : a list of Bio::Expression::Sample objects Args : =cut sub get_samples { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_contacts() Usage : Function: Example : Returns : a list of Bio::Expression::Contact objects Args : =cut sub get_contacts { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_datasets() Usage : $db->get_datasets('accession'); Function: Example : Returns : a list of Bio::Expression::DataSet objects Args : =cut sub get_datasets { my ($self,$platform) = @_; my @lines = split /\n/, $self->_get_url( URL_PLATFORM . $platform->accession ); my @datasets = (); foreach my $line ( @lines ) { my ($dataset_acc) = $line =~ /^\!Platform_series_id = (\S+?)\s*$/; next unless $dataset_acc; my $dataset = Bio::Expression::DataSet->new( -accession => $dataset_acc, -platform => $platform, -db => $self, ); push @datasets, $dataset; } return @datasets; } sub fill_sample { my ( $self, $sample ) = @_; my @lines = split /\n/, $self->_get_url( URL_SAMPLE. $sample->accession ); foreach my $line ( @lines ) { if ( my ($name) = $line =~ /^\!Sample_title = (.+?)\s*$/ ) { $sample->name( $name ); } elsif ( my ($desc) = $line =~ /^\!Sample_characteristics.*? = (.+?)\s*$/ ) { $sample->description( $desc ); } elsif ( my ($source_name) = $line =~ /^\!Sample_source_name.*? = (.+?)\s*$/ ) { $sample->source_name( $source_name ); } elsif ( my ($treatment_desc) = $line =~ /^\!Sample_treatment_protocol.*? = (.+?)\s*$/ ) { $sample->treatment_description( $treatment_desc ); } } return 1; } sub fill_dataset { my ( $self, $dataset ) = @_; my @lines = split /\n/, $self->_get_url( URL_DATASET . $dataset->accession ); my @samples = (); foreach my $line ( @lines ) { if ( my ($sample_acc) = $line =~ /^\!Series_sample_id = (\S+?)\s*$/ ) { my $sample = Bio::Expression::Sample->new( -accession => $sample_acc, -dataset => $dataset, -db => $self, ); push @samples, $sample; } elsif ( my ($pubmed_acc) = $line =~ /^\!Series_pubmed_id = (.+?)\s*$/ ) { $dataset->pubmed_id( $pubmed_acc ); } elsif ( my ($web_link) = $line =~ /^\!Series_web_link = (.+?)\s*$/ ) { $dataset->web_link( $web_link ); } elsif ( my ($contact) = $line =~ /^\!Series_contact_name = (.+?)\s*$/ ) { $dataset->contact( $contact ); } elsif ( my ($name) = $line =~ /^\!Series_title = (.+?)\s*$/ ) { $dataset->name( $name ); } elsif ( my ($desc) = $line =~ /^\!Series_summary = (.+?)\s*$/ ) { $dataset->description( $desc ); } elsif ( my ($design) = $line =~ /^\!Series_type = (.+?)\s*$/ ) { $dataset->design( $design ); } elsif ( my ($design_desc) = $line =~ /^\!Series_overall_design = (.+?)\s*$/ ) { $dataset->design_description( $design_desc ); } } $dataset->samples(\@samples); } ################################################# =head2 _platforms_doc() Usage : Function: Example : Returns : an HTML document containing a table of all platforms Args : =cut sub _get_url { my ($self,$url) = @_; my $response; eval { $response = $self->get( $url ); }; if( $@ ) { $self->warn("Can't query website: $@"); return; } $self->debug( "resp is $response\n"); return $response; } 1; BioPerl-1.6.923/Bio/DB/Flat000755000765000024 012254227333 15166 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/Flat/BDB.pm000444000765000024 3225312254227333 16275 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::Flat::BDB # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat::BDB - Interface for BioHackathon standard BDB-indexed flat file =head1 SYNOPSIS #You should not be using this module directly. See L. =head1 DESCRIPTION This object provides the basic mechanism to associate positions in files with primary and secondary name spaces. Unlike Bio::Index::Abstract (see L), this is specialized to work with the BerkeleyDB-indexed "common" flat file format worked out at the 2002 BioHackathon. This object is the guts to the mechanism, which will be used by the specific objects inheriting from it. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email - lstein@cshl.org =head1 SEE ALSO L, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with an "_" (underscore). =cut # Let the code begin... package Bio::DB::Flat::BDB; use strict; use DB_File; use IO::File; use Fcntl qw(O_CREAT O_RDWR O_RDONLY); use File::Spec; use Bio::SeqIO; use Bio::DB::RandomAccessI; use Bio::Root::Root; use Bio::Root::IO; use base qw(Bio::DB::Flat); sub _initialize { my $self = shift; my ($max_open) = $self->_rearrange(['MAXOPEN'],@_); $self->{bdb_maxopen} = $max_open || 32; } # return a filehandle seeked to the appropriate place # this only works with the primary namespace sub _get_stream { my ($self,$id) = @_; my ($filepath,$offset,$length) = $self->_lookup_primary($id) or $self->throw("Unable to find a record for $id in the flat file index"); my $fh = $self->_fhcache($filepath) or $self->throw("couldn't open $filepath: $!"); seek($fh,$offset,0) or $self->throw("can't seek on $filepath: $!"); $fh; } # return records corresponding to the indicated index # if there are multiple hits will return a list in list context, # otherwise will throw an exception sub fetch_raw { my ($self,$id,$namespace) = @_; # secondary lookup if (defined $namespace && $namespace ne $self->primary_namespace) { my @hits = $self->_lookup_secondary($namespace,$id); $self->throw("Multiple records correspond to $namespace=>$id but function called in a scalar context") unless wantarray; return map {$self->_read_record(@$_)} @hits; } # primary lookup my @args = $self->_lookup_primary($id) or $self->throw("Unable to find a record for $id in the flat file index"); return $self->_read_record(@args); } # create real live Bio::Seq object sub get_Seq_by_id { my $self = shift; my $id = shift; my $fh = eval {$self->_get_stream($id)} or return; my $seqio = $self->{bdb_cached_parsers}{fileno $fh} ||= Bio::SeqIO->new( -Format => $self->file_format, -fh => $fh); return $seqio->next_seq; } # fetch array of Bio::Seq objects sub get_Seq_by_acc { my $self = shift; unshift @_,'ACC' if @_==1; my ($ns,$key) = @_; my @primary_ids = $self->expand_ids($ns => $key); $self->throw("more than one sequences correspond to this accession") if @primary_ids > 1 && ! wantarray; my @rc = map {$self->get_Seq_by_id($_)} @primary_ids; return wantarray ? @rc : $rc[0]; } # fetch array of Bio::Seq objects sub get_Seq_by_version { my $self = shift; unshift @_,'VERSION' if @_==1; my ($ns,$key) = @_; my @primary_ids = $self->expand_ids($ns => $key); $self->throw("more than one sequences correspond to this accession") if @primary_ids > 1 && !wantarray; my @rc = map {$self->get_Seq_by_id($_)} @primary_ids; return wantarray ? @rc : $rc[0]; } =head2 get_PrimarySeq_stream Title : get_PrimarySeq_stream Usage : $stream = get_PrimarySeq_stream Function: Makes a Bio::DB::SeqStreamI compliant object which provides a single method, next_primary_seq Returns : Bio::DB::SeqStreamI Args : none =cut sub get_PrimarySeq_stream { my $self = shift; my @files = $self->files || 0; my $out = Bio::SeqIO::MultiFile->new( -format => $self->file_format , -files => \@files); return $out; } sub get_all_primary_ids { my $self = shift; my $db = $self->primary_db; return keys %$db; } =head2 get_all_primary_ids Title : get_all_primary_ids Usage : @ids = $seqdb->get_all_primary_ids() Function: gives an array of all the primary_ids of the sequence objects in the database. Example : Returns : an array of strings Args : none =cut # this will perform an ID lookup on a (possibly secondary) # id, returning all the corresponding ids sub expand_ids { my $self = shift; my ($ns,$key) = @_; return $key unless defined $ns; return $key if $ns eq $self->primary_namespace; my $db = $self->secondary_db($ns) or $self->throw("invalid secondary namespace $ns"); my $record = $db->{$key} or return; # nothing there return $self->unpack_secondary($record); } # build index from files listed sub build_index { my $self = shift; my @files = @_; my $count = 0; for my $file (@files) { $file = File::Spec->rel2abs($file) unless File::Spec->file_name_is_absolute($file); $count += $self->_index_file($file); } $self->write_config; $count; } sub _index_file { my $self = shift; my $file = shift; my $fileno = $self->_path2fileno($file); defined $fileno or $self->throw("could not create a file number for $file"); my $fh = $self->_fhcache($file) or $self->throw("could not open $file for indexing: $!"); my $offset = 0; my $count = 0; while (!eof($fh)) { my ($ids,$adjustment) = $self->parse_one_record($fh) or next; $adjustment ||= 0; # prevent uninit variable warning my $pos = tell($fh) + $adjustment; $self->_store_index($ids,$file,$offset,$pos-$offset); $offset = $pos; $count++; } $count; } =head2 To Be Implemented in Subclasses The following methods MUST be implemented by subclasses. =cut =head2 May Be Overridden in Subclasses The following methods MAY be overridden by subclasses. =cut sub default_primary_namespace { return "ACC"; } sub default_secondary_namespaces { return; } sub _read_record { my $self = shift; my ($filepath,$offset,$length) = @_; my $fh = $self->_fhcache($filepath) or $self->throw("couldn't open $filepath: $!"); seek($fh,$offset,0) or $self->throw("can't seek on $filepath: $!"); my $record; read($fh,$record,$length) or $self->throw("can't read $filepath: $!"); $record } # return a list in the form ($filepath,$offset,$length) sub _lookup_primary { my $self = shift; my $primary = shift; my $db = $self->primary_db or $self->throw("no primary namespace database is open"); my $record = $db->{$primary} or return; # nothing here my($fileid,$offset,$length) = $self->unpack_primary($record); my $filepath = $self->_fileno2path($fileid) or $self->throw("no file path entry for fileid $fileid"); return ($filepath,$offset,$length); } # return a list of array refs in the form [$filepath,$offset,$length] sub _lookup_secondary { my $self = shift; my ($namespace,$secondary) = @_; my @primary = $self->expand_ids($namespace=>$secondary); return map {[$self->_lookup_primary($_)]} @primary; } # store indexing information into a primary & secondary record # $namespaces is one of: # 1. a scalar corresponding to the primary name # 2. a hashref corresponding to namespace=>id identifiers # it is valid for secondary id to be an arrayref sub _store_index { my $self = shift; my ($keys,$filepath,$offset,$length) = @_; my ($primary,%secondary); if (ref $keys eq 'HASH') { my %valid_secondary = map {$_=>1} $self->secondary_namespaces; while (my($ns,$value) = each %$keys) { if ($ns eq $self->primary_namespace) { $primary = $value; } else { $valid_secondary{$ns} or $self->throw("invalid secondary namespace $ns"); push @{$secondary{$ns}},$value; } } $primary or $self->throw("no primary namespace ID provided"); } else { $primary = $keys; } $self->throw("invalid primary ID; must be a scalar") if ref($primary) =~ /^(ARRAY|HASH)$/; # but allow stringified objects $self->_store_primary($primary,$filepath,$offset,$length); for my $ns (keys %secondary) { my @ids = ref $secondary{$ns} ? @{$secondary{$ns}} : $secondary{$ns}; $self->_store_secondary($ns,$_,$primary) foreach @ids; } 1; } # store primary index sub _store_primary { my $self = shift; my ($id,$filepath,$offset,$length) = @_; my $db = $self->primary_db or $self->throw("no primary namespace database is open"); my $fileno = $self->_path2fileno($filepath); defined $fileno or $self->throw("could not create a file number for $filepath"); my $record = $self->pack_primary($fileno,$offset,$length); $db->{$id} = $record or return; # nothing here 1; } # store a primary index name under a secondary index sub _store_secondary { my $self = shift; my ($secondary_ns,$secondary_id,$primary_id) = @_; my $db = $self->secondary_db($secondary_ns) or $self->throw("invalid secondary namespace $secondary_ns"); # first get whatever secondary ids are already stored there my @primary = $self->unpack_secondary($db->{$secondary_id}); # uniqueify my %unique = map {$_=>undef} @primary,$primary_id; my $record = $self->pack_secondary(keys %unique); $db->{$secondary_id} = $record; } # get output file handle sub _outfh { my $self = shift; #### XXXXX FINISH ##### # my $ } # unpack a primary record into fileid,offset,length sub unpack_primary { my $self = shift; my $index_record = shift; return split "\t",$index_record; } # unpack a secondary record into a list of primary ids sub unpack_secondary { my $self = shift; my $index_record = shift or return; return split "\t",$index_record; } # pack a list of fileid,offset,length into a primary id record sub pack_primary { my $self = shift; my ($fileid,$offset,$length) = @_; return join "\t",($fileid,$offset,$length); } # pack a list of primary ids into a secondary id record sub pack_secondary { my $self = shift; my @secondaries = @_; return join "\t",@secondaries; } sub primary_db { my $self = shift; # lazy opening $self->_open_bdb unless exists $self->{bdb_primary_db}; return $self->{bdb_primary_db}; } sub secondary_db { my $self = shift; my $secondary_namespace = shift or $self->throw("usage: secondary_db(\$secondary_namespace)"); $self->_open_bdb unless exists $self->{bdb_primary_db}; return $self->{bdb_secondary_db}{$secondary_namespace}; } sub _open_bdb { my $self = shift; my $flags = $self->write_flag ? O_CREAT|O_RDWR : O_RDONLY; my $primary_db = {}; tie(%$primary_db,'DB_File',$self->_catfile($self->_primary_db_name),$flags,0666,$DB_BTREE) or $self->throw("Could not open primary index file: $! (did you remember to use -write_flag=>1?)"); $self->{bdb_primary_db} = $primary_db; for my $secondary ($self->secondary_namespaces) { my $secondary_db = {}; tie(%$secondary_db,'DB_File',$self->_catfile($self->_secondary_db_name($secondary)),$flags,0666,$DB_BTREE) or $self->throw("Could not open primary index file"); $self->{bdb_secondary_db}{$secondary} = $secondary_db; } 1; } sub _primary_db_name { my $self = shift; my $pns = $self->primary_namespace or $self->throw('no primary namespace defined'); return "key_$pns"; } sub _secondary_db_name { my $self = shift; my $sns = shift; return "id_$sns"; } sub _fhcache { my $self = shift; my $path = shift; my $write = shift; if (!$self->{bdb_fhcache}{$path}) { $self->{bdb_curopen} ||= 0; if ($self->{bdb_curopen} >= $self->{bdb_maxopen}) { my @lru = sort {$self->{bdb_cacheseq}{$a} <=> $self->{bdb_cacheseq}{$b};} keys %{$self->{bdb_fhcache}}; splice(@lru, $self->{bdb_maxopen} / 3); $self->{bdb_curopen} -= @lru; for (@lru) { delete $self->{bdb_fhcache}{$_} } } if ($write) { my $modifier = $self->{bdb_fhcache_seenit}{$path}++ ? '>' : '>>'; $self->{bdb_fhcache}{$path} = IO::File->new("${modifier}${path}") or return; } else { $self->{bdb_fhcache}{$path} = IO::File->new($path) or return; } $self->{bdb_curopen}++; } $self->{bdb_cacheseq}{$path}++; $self->{bdb_fhcache}{$path} } 1; BioPerl-1.6.923/Bio/DB/Flat/BinarySearch.pm000444000765000024 12770312254227326 20307 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Flat::BinarySearch # # Please direct questions and support issues to # # Cared for by Michele Clamp > # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat::BinarySearch - BinarySearch search indexing system for sequence files =head1 SYNOPSIS TODO: SYNOPSIS NEEDED! =head1 DESCRIPTION This module can be used both to index sequence files and also to retrieve sequences from existing sequence files. This object allows indexing of sequence files both by a primary key (say accession) and multiple secondary keys (say ids). This is different from the Bio::Index::Abstract (see L) which uses DBM files as storage. This module uses a binary search to retrieve sequences which is more efficient for large datasets. =head2 Index creation my $sequencefile; # Some fasta sequence file Patterns have to be entered to define where the keys are to be indexed and also where the start of each record. E.g. for fasta my $start_pattern = '^>'; my $primary_pattern = '^>(\S+)'; So the start of a record is a line starting with a E and the primary key is all characters up to the first space after the E A string also has to be entered to defined what the primary key (primary_namespace) is called. The index can now be created using my $index = Bio::DB::Flat::BinarySearch->new( -directory => "/home/max/", -dbname => "mydb", -start_pattern => $start_pattern, -primary_pattern => $primary_pattern, -primary_namespace => "ID", -format => "fasta" ); my @files = ("file1","file2","file3"); $index->build_index(@files); The index is now ready to use. For large sequence files the perl way of indexing takes a *long* time and a *huge* amount of memory. For indexing things like dbEST I recommend using the DB_File indexer, BDB. The formats currently supported by this module are fasta, Swissprot, and EMBL. =head2 Creating indices with secondary keys Sometimes just indexing files with one id per entry is not enough. For instance you may want to retrieve sequences from swissprot using their accessions as well as their ids. To be able to do this when creating your index you need to pass in a hash of secondary_patterns which have their namespaces as the keys to the hash. e.g. For Indexing something like ID 1433_CAEEL STANDARD; PRT; 248 AA. AC P41932; DT 01-NOV-1995 (Rel. 32, Created) DT 01-NOV-1995 (Rel. 32, Last sequence update) DT 15-DEC-1998 (Rel. 37, Last annotation update) DE 14-3-3-LIKE PROTEIN 1. GN FTT-1 OR M117.2. OS Caenorhabditis elegans. OC Eukaryota; Metazoa; Nematoda; Chromadorea; Rhabditida; Rhabditoidea; OC Rhabditidae; Peloderinae; Caenorhabditis. OX NCBI_TaxID=6239; RN [1] where we want to index the accession (P41932) as the primary key and the id (1433_CAEEL) as the secondary id. The index is created as follows my %secondary_patterns; my $start_pattern = '^ID (\S+)'; my $primary_pattern = '^AC (\S+)\;'; $secondary_patterns{"ID"} = '^ID (\S+)'; my $index = Bio::DB::Flat::BinarySearch->new( -directory => $index_directory, -dbname => "ppp", -write_flag => 1, -verbose => 1, -start_pattern => $start_pattern, -primary_pattern => $primary_pattern, -primary_namespace => 'AC', -secondary_patterns => \%secondary_patterns); $index->build_index($seqfile); Of course having secondary indices makes indexing slower and use more memory. =head2 Index reading To fetch sequences using an existing index first of all create your sequence object my $index = Bio::DB::Flat::BinarySearch->new( -directory => $index_directory); Now you can happily fetch sequences either by the primary key or by the secondary keys. my $entry = $index->get_entry_by_id('HBA_HUMAN'); This returns just a string containing the whole entry. This is useful is you just want to print the sequence to screen or write it to a file. Other ways of getting sequences are my $fh = $index->get_stream_by_id('HBA_HUMAN'); This can then be passed to a seqio object for output or converting into objects. my $seq = Bio::SeqIO->new(-fh => $fh, -format => 'fasta'); The last way is to retrieve a sequence directly. This is the slowest way of extracting as the sequence objects need to be made. my $seq = $index->get_Seq_by_id('HBA_HUMAN'); To access the secondary indices the secondary namespace needs to be known $index->secondary_namespaces("ID"); Then the following call can be used my $seq = $index->get_Seq_by_secondary('ID','1433_CAEEL'); These calls are not yet implemented my $fh = $index->get_stream_by_secondary('ID','1433_CAEEL'); my $entry = $index->get_entry_by_secondary('ID','1433_CAEEL'); =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Michele Clamp Email - michele@sanger.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with an "_" (underscore). =cut package Bio::DB::Flat::BinarySearch; use strict; use Fcntl qw(SEEK_END SEEK_CUR); # rather than using tell which might be buffered sub systell { sysseek( $_[0], 0, SEEK_CUR ) } sub syseof { sysseek( $_[0], 0, SEEK_END ) } use File::Spec; use Bio::Root::RootI; use Bio::SeqIO; use Bio::Seq; use base qw(Bio::DB::RandomAccessI); use constant CONFIG_FILE_NAME => 'config.dat'; use constant HEADER_SIZE => 4; use constant DEFAULT_FORMAT => 'fasta'; my @formats = [ 'FASTA', 'SWISSPROT', 'EMBL' ]; =head2 new Title : new Usage : For reading my $index = Bio::DB::Flat::BinarySearch->new( -directory => '/Users/michele/indices/dbest', -dbname => 'mydb', -format => 'fasta'); For writing my %secondary_patterns = {"ACC" => "^>\\S+ +(\\S+)"} my $index = Bio::DB::Flat::BinarySearch->new( -directory => '/Users/michele/indices', -dbname => 'mydb', -primary_pattern => "^>(\\S+)", -secondary_patterns => \%secondary_patterns, -primary_namespace => "ID"); my @files = ('file1','file2','file3'); $index->build_index(@files); Function: create a new Bio::DB::Flat::BinarySearch object Returns : new Bio::DB::Flat::BinarySearch Args : -directory Root directory for index files -dbname Name of subdirectory containing indices for named database -write_flag Allow building index -primary_pattern Regexp defining the primary id -secondary_patterns A hash ref containing the secondary patterns with the namespaces as keys -primary_namespace A string defining what the primary key is Status : Public =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); bless $self, $class; my ( $index_dir, $dbname, $format, $write_flag, $primary_pattern, $primary_namespace, $start_pattern, $secondary_patterns ) = $self->_rearrange( [ qw(DIRECTORY DBNAME FORMAT WRITE_FLAG PRIMARY_PATTERN PRIMARY_NAMESPACE START_PATTERN SECONDARY_PATTERNS) ], @args ); $self->index_directory($index_dir); $self->dbname($dbname); if ( $self->index_directory && $self->read_config_file ) { my $fh = $self->primary_index_filehandle; my $record_width = $self->read_header($fh); $self->record_size($record_width); } $format ||= DEFAULT_FORMAT; $self->format($format); $self->write_flag($write_flag); if ( $self->write_flag && !$primary_namespace ) { ( $primary_namespace, $primary_pattern, $start_pattern, $secondary_patterns ) = $self->_guess_patterns( $self->format ); } $self->primary_pattern($primary_pattern); $self->primary_namespace($primary_namespace); $self->start_pattern($start_pattern); $self->secondary_patterns($secondary_patterns); return $self; } sub new_from_registry { my ( $self, %config ) = @_; my $dbname = $config{'dbname'}; my $location = $config{'location'}; my $index = Bio::DB::Flat::BinarySearch->new( -dbname => $dbname, -index_dir => $location, ); } =head2 get_Seq_by_id Title : get_Seq_by_id Usage : $obj->get_Seq_by_id($newval) Function: Example : Returns : value of get_Seq_by_id Args : newvalue (optional) =cut sub get_Seq_by_id { my ( $self, $id ) = @_; # too many uninit variables... local $^W = 0; my ( $fh, $length ) = $self->get_stream_by_id($id); unless ( defined( $self->format ) ) { $self->throw("Can't create sequence - format is not defined"); } return unless $fh; unless ( defined( $self->{_seqio} ) ) { $self->{_seqio} = Bio::SeqIO->new( -fh => $fh, -format => $self->format ); } else { $self->{_seqio}->fh($fh); } return $self->{_seqio}->next_seq; } =head2 get_entry_by_id Title : get_entry_by_id Usage : $obj->get_entry_by_id($newval) Function: Get a Bio::SeqI object for a unique ID Returns : Bio::SeqI Args : string =cut sub get_entry_by_id { my ( $self, $id ) = @_; my ( $fh, $length ) = $self->get_stream_by_id($id); my $entry; sysread( $fh, $entry, $length ); return $entry; } =head2 get_stream_by_id Title : get_stream_by_id Usage : $obj->get_stream_by_id($id) Function: Gets a Sequence stream for an id Returns : Bio::SeqIO stream Args : Id to lookup by =cut sub get_stream_by_id { my ( $self, $id ) = @_; unless ( $self->record_size ) { if ( $self->index_directory && $self->read_config_file ) { my $fh = $self->primary_index_filehandle; my $record_width = $self->read_header($fh); $self->record_size($record_width); } } my $indexfh = $self->primary_index_filehandle; syseof($indexfh); my $filesize = systell($indexfh); $self->throw("file was not parsed properly, record size is empty") unless $self->record_size; my $end = ( $filesize - $self->{'_start_pos'} ) / $self->record_size; my ( $newid, $rest, $fhpos ) = $self->find_entry( $indexfh, 0, $end, $id, $self->record_size ); my ( $fileid, $pos, $length ) = split( /\t/, $rest ); #print STDERR "BinarySearch Found id entry $newid $fileid $pos $length:$rest\n"; if ( !$newid ) { return; } my $file = $self->{_file}{$fileid}; open( my $IN, "<$file" ); my $entry; sysseek( $IN, $pos, 0 ); return ( $IN, $length ); } =head2 get_Seq_by_acc Title : get_Seq_by_acc Usage : $obj->get_Seq_by_acc($acc) Function: Gets a Bio::SeqI object by accession number Returns : Bio::SeqI object Args : string representing accession number =cut sub get_Seq_by_acc { my ( $self, $acc ) = @_; # too many uninit variables... local $^W = 0; if ( $self->primary_namespace eq "ACC" ) { return $self->get_Seq_by_id($acc); } else { return $self->get_Seq_by_secondary( "ACC", $acc ); } } =head2 get_Seq_by_version Title : get_Seq_by_version Usage : $obj->get_Seq_by_version($version) Function: Gets a Bio::SeqI object by accession.version number Returns : Bio::SeqI object Args : string representing accession.version number =cut sub get_Seq_by_version { my ( $self, $acc ) = @_; # too many uninit variables... local $^W = 0; if ( $self->primary_namespace eq "VERSION" ) { return $self->get_Seq_by_id($acc); } else { return $self->get_Seq_by_secondary( "VERSION", $acc ); } } =head2 get_Seq_by_secondary Title : get_Seq_by_secondary Usage : $obj->get_Seq_by_secondary($namespace,$acc) Function: Gets a Bio::SeqI object looking up secondary accessions Returns : Bio::SeqI object Args : namespace name to check secondary namespace and an id =cut sub get_Seq_by_secondary { my ( $self, $name, $id ) = @_; my @names = $self->secondary_namespaces; my $found = 0; foreach my $tmpname (@names) { if ( $name eq $tmpname ) { $found = 1; } } if ( $found == 0 ) { $self->throw("Secondary index for $name doesn't exist\n"); } my $fh = $self->open_secondary_index($name); syseof($fh); my $filesize = systell($fh); my $recsize = $self->{'_secondary_record_size'}{$name}; # print "Name " . $recsize . "\n"; my $end = ( $filesize - $self->{'_start_pos'} ) / $recsize; # print "End $end $filesize\n"; my ( $newid, $primary_id, $pos ) = $self->find_entry( $fh, 0, $end, $id, $recsize ); sysseek( $fh, $pos, 0 ); # print "Found new id $newid $primary_id\n"; # We now need to shuffle up the index file to find the top secondary entry my $record = $newid; while ( $record =~ /^$newid/ && $pos >= 0 ) { $record = $self->read_record( $fh, $pos, $recsize ); $pos = $pos - $recsize; # print "Up record = $record:$newid\n"; } $pos += $recsize; # print "Top position is $pos\n"; # Now we have to shuffle back down again to read all the secondary entries my $current_id = $newid; my %primary_id; $primary_id{$primary_id} = 1; while ( $current_id eq $newid ) { $record = $self->read_record( $fh, $pos, $recsize ); # print "Record is :$record:\n"; my ( $secid, $primary_id ) = split( /\t/, $record, 2 ); $current_id = $secid; if ( $current_id eq $newid ) { $primary_id =~ s/ //g; # print "Primary $primary_id\n"; $primary_id{$primary_id} = 1; $pos = $pos + $recsize; # print "Down record = $record\n"; } } if ( !defined($newid) ) { return; } my @entry; foreach my $id ( keys %primary_id ) { push @entry, $self->get_Seq_by_id($id); } return wantarray ? @entry : $entry[0]; } =head2 read_header Title : read_header Usage : $obj->read_header($fhl) Function: Reads the header from the db file Returns : width of a record Args : filehandle =cut sub read_header { my ( $self, $fh ) = @_; my $record_width; sysread( $fh, $record_width, HEADER_SIZE ); $self->{'_start_pos'} = HEADER_SIZE; $record_width =~ s/ //g; $record_width = $record_width * 1; return $record_width; } =head2 read_record Title : read_record Usage : $obj->read_record($fh,$pos,$len) Function: Reads a record from a filehandle Returns : String Args : filehandle, offset, and length =cut sub read_record { my ( $self, $fh, $pos, $len ) = @_; sysseek( $fh, $pos, 0 ); my $record; sysread( $fh, $record, $len ); return $record; } =head2 get_all_primary_ids Title : get_all_primary_ids Usage : @ids = $seqdb->get_all_primary_ids() Function: gives an array of all the primary_ids of the sequence objects in the database. Returns : an array of strings Args : none =cut sub get_all_primary_ids { my $self = shift; my $fh = $self->primary_index_filehandle; syseof($fh); my $filesize = systell($fh); my $recsize = $self->record_size; my $end = $filesize; my @ids; for ( my $pos = $self->{'_start_pos'} ; $pos < $end ; $pos += $recsize ) { my $record = $self->read_record( $fh, $pos, $recsize ); my ($entryid) = split( /\t/, $record ); push @ids, $entryid; } @ids; } =head2 find_entry Title : find_entry Usage : $obj->find_entry($fh,$start,$end,$id,$recsize) Function: Extract an entry based on the start,end,id and record size Returns : string Args : filehandle, start, end, id, recordsize =cut sub find_entry { my ( $self, $fh, $start, $end, $id, $recsize ) = @_; my $mid = int( ( $end + 1 + $start ) / 2 ); my $pos = ( $mid - 1 ) * $recsize + $self->{'_start_pos'}; my ($record) = $self->read_record( $fh, $pos, $recsize ); my ( $entryid, $rest ) = split( /\t/, $record, 2 ); $rest =~ s/\s+$//; # print "Mid $recsize $mid $pos:$entryid:$rest:$record\n"; # print "Entry :$id:$entryid:$rest\n"; my ( $first, $second ) = $id le $entryid ? ( $id, $entryid ) : ( $entryid, $id ); if ( $id eq $entryid ) { return ( $id, $rest, $pos - $recsize ); } elsif ( $first eq $id ) { if ( $end - $start <= 1 ) { return; } my $end = $mid; # print "Moving up $entryid $id\n"; $self->find_entry( $fh, $start, $end, $id, $recsize ); } elsif ( $second eq $id ) { # print "Moving down $entryid $id\n"; if ( $end - $start <= 1 ) { return; } $start = $mid; $self->find_entry( $fh, $start, $end, $id, $recsize ); } } =head2 build_index Title : build_index Usage : $obj->build_index(@files) Function: Build the index based on a set of files Returns : count of the number of entries Args : List of filenames =cut sub build_index { my ( $self, @files ) = @_; $self->write_flag or $self->throw('Cannot build index unless -write_flag is true'); my $rootdir = $self->index_directory; if ( !defined($rootdir) ) { $self->throw("No index directory set - can't build indices"); } if ( !-d $rootdir ) { $self->throw( "Index directory [$rootdir] is not a directory. Cant' build indices" ); } my $dbpath = File::Spec->catfile( $rootdir, $self->dbname ); if ( !-d $dbpath ) { warn "Creating directory $dbpath\n"; mkdir $dbpath, 0777 or $self->throw("Couldn't create $dbpath: $!"); } unless (@files) { $self->throw("Must enter an array of filenames to index"); } foreach my $file (@files) { $file = File::Spec->rel2abs($file) unless File::Spec->file_name_is_absolute($file); unless ( -e $file ) { $self->throw("Can't index file [$file] as it doesn't exist"); } } if ( my $filehash = $self->{_dbfile} ) { push @files, keys %$filehash; } my %seen; @files = grep { !$seen{$_}++ } @files; # Lets index $self->make_config_file( \@files ); my $entries = 0; foreach my $file (@files) { $entries += $self->_index_file($file); } # update alphabet if necessary $self->make_config_file( \@files ); # And finally write out the indices $self->write_primary_index; $self->write_secondary_indices; $entries; } =head2 _index_file Title : _index_file Usage : $obj->_index_file($newval) Function: Example : Returns : value of _index_file Args : newvalue (optional) =cut sub _index_file { my ( $self, $file ) = @_; my $v = $self->verbose; open( my $FILE, "<", $file ) || $self->throw("Can't open file [$file]"); my $recstart = 0; my $fileid = $self->get_fileid_by_filename($file); my $found = 0; my $id; my $count = 0; my $primary = $self->primary_pattern; my $start_pattern = $self->start_pattern; my $pos = 0; my $new_primary_entry; my $length; my $fh = $FILE; my $done = -1; my @secondary_names = $self->secondary_namespaces; my %secondary_id; my $last_one; # In Windows, text files have '\r\n' as line separator, but when reading in # text mode Perl will only show the '\n'. This means that for a line "ABC\r\n", # "length $_" will report 4 although the line is 5 bytes in length. # We assume that all lines have the same line separator and only read current line. my $init_pos = tell($fh); my $curr_line = <$fh>; my $pos_diff = tell($fh) - $init_pos; my $correction = $pos_diff - length $curr_line; seek $fh, $init_pos, 0; # Rewind position to proceed to read the file while (<$fh>) { $last_one = $_; $self->{alphabet} ||= $self->guess_alphabet($_); if ( $_ =~ /$start_pattern/ ) { if ( $done == 0 ) { $id = $new_primary_entry; $self->{alphabet} ||= $self->guess_alphabet($_); my $tmplen = ( tell $fh ) - length($_) - $correction; $length = $tmplen - $pos; unless ( defined($id) ) { $self->throw("No id defined for sequence"); } unless ( defined($fileid) ) { $self->throw("No fileid defined for file $file"); } unless ( defined($pos) ) { $self->throw( "No position defined for " . $id . "\n" ); } unless ( defined($length) ) { $self->throw( "No length defined for " . $id . "\n" ); } $self->_add_id_position( $id, $pos, $fileid, $length, \%secondary_id ); $pos = $tmplen; if ( $count > 0 && $count % 1000 == 0 ) { $self->debug("Indexed $count ids\n") if $v > 0; } $count++; } else { $done = 0; } } if ( $_ =~ /$primary/ ) { $new_primary_entry = $1; } my $secondary_patterns = $self->secondary_patterns; foreach my $sec (@secondary_names) { my $pattern = $secondary_patterns->{$sec}; if ( $_ =~ /$pattern/ ) { $secondary_id{$sec} = $1; } } } # Remember to add in the last one $id = $new_primary_entry; # my $tmplen = (tell $fh) - length($last_one); my $tmplen = ( tell $fh ); $length = $tmplen - $pos; if ( !defined($id) ) { $self->throw("No id defined for sequence"); } if ( !defined($fileid) ) { $self->throw("No fileid defined for file $file"); } if ( !defined($pos) ) { $self->throw( "No position defined for " . $id . "\n" ); } if ( !defined($length) ) { $self->throw( "No length defined for " . $id . "\n" ); } $self->_add_id_position( $id, $pos, $fileid, $length, \%secondary_id ); $count++; close($FILE); $count; } =head2 write_primary_index Title : write_primary_index Usage : $obj->write_primary_index($newval) Function: Example : Returns : value of write_primary_index Args : newvalue (optional) =cut sub write_primary_index { my ($self) = @_; my @ids = keys %{ $self->{_id} }; @ids = sort { $a cmp $b } @ids; open( my $INDEX, ">" . $self->primary_index_file ) || $self->throw( "Can't open primary index file [" . $self->primary_index_file . "]" ); my $recordlength = $self->{_maxidlength} + $self->{_maxfileidlength} + $self->{_maxposlength} + $self->{_maxlengthlength} + 3; print $INDEX sprintf( "%04d", $recordlength ); foreach my $id (@ids) { if ( !defined( $self->{_id}{$id}{_fileid} ) ) { $self->throw("No fileid for $id\n"); } if ( !defined( $self->{_id}{$id}{_pos} ) ) { $self->throw("No position for $id\n"); } if ( !defined( $self->{_id}{$id}{_length} ) ) { $self->throw("No length for $id"); } my $record = $id . "\t" . $self->{_id}{$id}{_fileid} . "\t" . $self->{_id}{$id}{_pos} . "\t" . $self->{_id}{$id}{_length}; print $INDEX sprintf( "%-${recordlength}s", $record ); } } =head2 write_secondary_indices Title : write_secondary_indices Usage : $obj->write_secondary_indices($newval) Function: Example : Returns : value of write_secondary_indices Args : newvalue (optional) =cut sub write_secondary_indices { my ($self) = @_; # These are the different my @names = keys( %{ $self->{_secondary_id} } ); foreach my $name (@names) { my @seconds = keys %{ $self->{_secondary_id}{$name} }; # First we need to loop over to get the longest record. my $length = 0; foreach my $second (@seconds) { my $tmplen = length($second) + 1; my @prims = keys %{ $self->{_secondary_id}{$name}{$second} }; foreach my $prim (@prims) { my $recordlen = $tmplen + length($prim); if ( $recordlen > $length ) { $length = $recordlen; } } } # Now we can print the index my $fh = $self->new_secondary_filehandle($name); print $fh sprintf( "%04d", $length ); @seconds = sort @seconds; foreach my $second (@seconds) { my @prims = keys %{ $self->{_secondary_id}{$name}{$second} }; my $tmp = $second; foreach my $prim (@prims) { my $record = $tmp . "\t" . $prim; if ( length($record) > $length ) { $self->throw( "Something has gone horribly wrong - length of record is more than we thought [$length]\n" ); } else { print $fh sprintf( "%-${length}s", $record ); } } } close($fh); } } =head2 new_secondary_filehandle Title : new_secondary_filehandle Usage : $obj->new_secondary_filehandle($newval) Function: Example : Returns : value of new_secondary_filehandle Args : newvalue (optional) =cut sub new_secondary_filehandle { my ( $self, $name ) = @_; my $indexdir = $self->_config_path; my $secindex = File::Spec->catfile( $indexdir, "id_$name.index" ); open( my $fh, ">", $secindex ) || $self->throw($!); return $fh; } =head2 open_secondary_index Title : open_secondary_index Usage : $obj->open_secondary_index($newval) Function: Example : Returns : value of open_secondary_index Args : newvalue (optional) =cut sub open_secondary_index { my ( $self, $name ) = @_; if ( !defined( $self->{_secondary_filehandle}{$name} ) ) { my $indexdir = $self->_config_path; my $secindex = $indexdir . "/id_$name.index"; if ( !-e $secindex ) { $self->throw("Index is not present for namespace [$name]\n"); } open( my $newfh, "<", $secindex ) || $self->throw($!); my $reclen = $self->read_header($newfh); $self->{_secondary_filehandle}{$name} = $newfh; $self->{_secondary_record_size}{$name} = $reclen; } return $self->{_secondary_filehandle}{$name}; } =head2 _add_id_position Title : _add_id_position Usage : $obj->_add_id_position($newval) Function: Example : Returns : value of _add_id_position Args : newvalue (optional) =cut sub _add_id_position { my ( $self, $id, $pos, $fileid, $length, $secondary_id ) = @_; if ( !defined($id) ) { $self->throw("No id defined. Can't add id position"); } if ( !defined($pos) ) { $self->throw("No position defined. Can't add id position"); } if ( !defined($fileid) ) { $self->throw("No fileid defined. Can't add id position"); } if ( !defined($length) || $length <= 0 ) { $self->throw( "No length defined or <= 0 [$length]. Can't add id position"); } $self->{_id}{$id}{_pos} = $pos; $self->{_id}{$id}{_length} = $length; $self->{_id}{$id}{_fileid} = $fileid; # Now the secondary ids foreach my $sec ( keys(%$secondary_id) ) { my $value = $secondary_id->{$sec}; $self->{_secondary_id}{$sec}{$value}{$id} = 1; } $self->{_maxidlength} = length($id) if !exists $self->{_maxidlength} or length($id) >= $self->{_maxidlength}; $self->{_maxfileidlength} = length($fileid) if !exists $self->{_maxfileidlength} or length($fileid) >= $self->{_maxfileidlength}; $self->{_maxposlength} = length($pos) if !exists $self->{_maxposlength} or length($pos) >= $self->{_maxposlength}; $self->{_maxlengthlength} = length($length) if !exists $self->{_maxlengthlength} or length($length) >= $self->{_maxlengthlength}; } =head2 make_config_file Title : make_config_file Usage : $obj->make_config_file($newval) Function: Example : Returns : value of make_config_file Args : newvalue (optional) =cut sub make_config_file { my ( $self, $files ) = @_; my @files = @$files; my $configfile = $self->_config_file; open( my $CON, ">", $configfile ) || $self->throw("Can't create config file [$configfile]"); # First line must be the type of index - in this case flat print $CON "index\tflat/1\n"; # Now the fileids my $count = 0; foreach my $file (@files) { my $size = -s $file; print $CON "fileid_$count\t$file\t$size\n"; my $fh; open( $fh, "<", $file ) || $self->throw($!); $self->{_file}{$count} = $file; $self->{_dbfile}{$file} = $count; $self->{_size}{$count} = $size; $count++; } # Now the namespaces print $CON "primary_namespace\t" . $self->primary_namespace . "\n"; # Needs fixing for the secondary stuff my $second_patterns = $self->secondary_patterns; my @second = keys %$second_patterns; if ( (@second) ) { print $CON "secondary_namespaces"; foreach my $second (@second) { print $CON "\t$second"; } print $CON "\n"; } # Now the config format unless ( defined( $self->format ) ) { $self->throw( "Format does not exist in module - can't write config file"); } else { my $format = $self->format; my $alphabet = $self->alphabet; my $alpha = $alphabet ? "/$alphabet" : ''; print $CON "format\t" . "$format\n"; } close($CON); } =head2 read_config_file Title : read_config_file Usage : $obj->read_config_file($newval) Function: Example : Returns : value of read_config_file Args : newvalue (optional) =cut sub read_config_file { my ($self) = @_; my $configfile = $self->_config_file; return unless -e $configfile; open( my $CON, "<", $configfile ) || $self->throw("Can't open configfile [$configfile]"); # First line must be type my $line = <$CON>; chomp($line); my $version; # This is hard coded as we only index flatfiles here if ( $line =~ m{index\tflat/(\d+)} ) { $version = $1; } else { $self->throw( "First line not compatible with flat file index. Should be something like\n\nindex\tflat/1" ); } $self->index_type("flat"); $self->index_version($version); while (<$CON>) { chomp; # Look for fileid lines if ( $_ =~ /^fileid_(\d+)\t(.+)\t(\d+)/ ) { my $fileid = $1; my $filename = $2; my $filesize = $3; if ( !-e $filename ) { $self->throw("File [$filename] does not exist!"); } if ( -s $filename != $filesize ) { $self->throw( "Flatfile size for $filename differs from what the index thinks it is. Real size [" . ( -s $filename ) . "] Index thinks it is [" . $filesize . "]" ); } my $fh; open( $fh, "<", $filename ) || $self->throw($!); $self->{_file}{$fileid} = $filename; $self->{_dbfile}{$filename} = $fileid; $self->{_size}{$fileid} = $filesize; } # Look for namespace lines if (/(.*)_namespaces?\t(.+)/) { if ( $1 eq "primary" ) { $self->primary_namespace($2); } elsif ( $1 eq "secondary" ) { $self->secondary_namespaces( split "\t", $2 ); } else { $self->throw("Unknown namespace name in config file [$1"); } } # Look for format lines if ( $_ =~ /format\t(\S+)/ ) { # Check the format here? my $format = $1; # handle LSID format if ( $format =~ /^URN:LSID:open-bio\.org:(\w+)(?:\/(\w+))?/ ) { $self->format($1); $self->alphabet($2); } else { # compatibility with older versions $self->format($1); } } } close($CON); # Now check we have all that we need my @fileid_keys = keys( %{ $self->{_file} } ); if ( !(@fileid_keys) ) { $self->throw( "No flatfile fileid files in config - check the index has been made correctly" ); } if ( !defined( $self->primary_namespace ) ) { $self->throw("No primary namespace exists"); } if ( !-e $self->primary_index_file ) { $self->throw( "Primary index file [" . $self->primary_index_file . "] doesn't exist" ); } 1; } =head2 get_fileid_by_filename Title : get_fileid_by_filename Usage : $obj->get_fileid_by_filename($newval) Function: Example : Returns : value of get_fileid_by_filename Args : newvalue (optional) =cut sub get_fileid_by_filename { my ( $self, $file ) = @_; if ( !defined( $self->{_dbfile} ) ) { $self->throw( "No file to fileid mapping present. Has the fileid file been read?" ); } return $self->{_dbfile}{$file}; } =head2 get_filehandle_by_fileid Title : get_filehandle_by_fileid Usage : $obj->get_filehandle_by_fileid($newval) Function: Example : Returns : value of get_filehandle_by_fileid Args : newvalue (optional) =cut sub get_filehandle_by_fileid { my ( $self, $fileid ) = @_; if ( !defined( $self->{_file}{$fileid} ) ) { $self->throw("ERROR: undefined fileid in index [$fileid]"); } my $fh; open( $fh, "<", $self->{_file}{$fileid} ) || $self->throw($!); return $fh; } =head2 primary_index_file Title : primary_index_file Usage : $obj->primary_index_file($newval) Function: Example : Returns : value of primary_index_file Args : newvalue (optional) =cut sub primary_index_file { my ($self) = @_; return File::Spec->catfile( $self->_config_path, "key_" . $self->primary_namespace . ".key" ); } =head2 primary_index_filehandle Title : primary_index_filehandle Usage : $obj->primary_index_filehandle($newval) Function: Example : Returns : value of primary_index_filehandle Args : newvalue (optional) =cut sub primary_index_filehandle { my ($self) = @_; unless ( defined( $self->{'_primary_index_handle'} ) ) { open( $self->{'_primary_index_handle'}, "<" . $self->primary_index_file ) || self->throw($@); } return $self->{'_primary_index_handle'}; } =head2 format Title : format Usage : $obj->format($newval) Function: Example : Returns : value of format Args : newvalue (optional) =cut sub format { my ( $obj, $value ) = @_; if ( defined $value ) { $obj->{'format'} = $value; } return $obj->{'format'}; } sub alphabet { my ( $obj, $value ) = @_; if ( defined $value ) { $obj->{alphabet} = $value; } return $obj->{alphabet}; } =head2 write_flag Title : write_flag Usage : $obj->write_flag($newval) Function: Example : Returns : value of write_flag Args : newvalue (optional) =cut sub write_flag { my ( $obj, $value ) = @_; if ( defined $value ) { $obj->{'write_flag'} = $value; } return $obj->{'write_flag'}; } =head2 dbname Title : dbname Usage : $obj->dbname($newval) Function: get/set database name Example : Returns : value of dbname Args : newvalue (optional) =cut sub dbname { my $self = shift; my $d = $self->{flat_dbname}; $self->{flat_dbname} = shift if @_; $d; } =head2 index_directory Title : index_directory Usage : $obj->index_directory($newval) Function: Example : Returns : value of index_directory Args : newvalue (optional) =cut sub index_directory { my ( $self, $arg ) = @_; if ( defined($arg) ) { if ( $arg !~ m{/$} ) { $arg .= "/"; } $self->{_index_directory} = $arg; } return $self->{_index_directory}; } sub _config_path { my $self = shift; my $root = $self->index_directory; my $dbname = $self->dbname; File::Spec->catfile( $root, $dbname ); } sub _config_file { my $self = shift; my $path = $self->_config_path; File::Spec->catfile( $path, CONFIG_FILE_NAME ); } =head2 record_size Title : record_size Usage : $obj->record_size($newval) Function: Example : Returns : value of record_size Args : newvalue (optional) =cut sub record_size { my $self = shift; $self->{_record_size} = shift if @_; return $self->{_record_size}; } =head2 primary_namespace Title : primary_namespace Usage : $obj->primary_namespace($newval) Function: Example : Returns : value of primary_namespace Args : newvalue (optional) =cut sub primary_namespace { my $self = shift; $self->{_primary_namespace} = shift if @_; return $self->{_primary_namespace}; } =head2 index_type Title : index_type Usage : $obj->index_type($newval) Function: Example : Returns : value of index_type Args : newvalue (optional) =cut sub index_type { my $self = shift; $self->{_index_type} = shift if @_; return $self->{_index_type}; } =head2 index_version Title : index_version Usage : $obj->index_version($newval) Function: Example : Returns : value of index_version Args : newvalue (optional) =cut sub index_version { my $self = shift; $self->{_index_version} = shift if @_; return $self->{_index_version}; } =head2 primary_pattern Title : primary_pattern Usage : $obj->primary_pattern($newval) Function: Example : Returns : value of primary_pattern Args : newvalue (optional) =cut sub primary_pattern { my $obj = shift; $obj->{'primary_pattern'} = shift if @_; return $obj->{'primary_pattern'}; } =head2 start_pattern Title : start_pattern Usage : $obj->start_pattern($newval) Function: Example : Returns : value of start_pattern Args : newvalue (optional) =cut sub start_pattern { my $obj = shift; $obj->{'start_pattern'} = shift if @_; return $obj->{'start_pattern'}; } =head2 secondary_patterns Title : secondary_patterns Usage : $obj->secondary_patterns($newval) Function: Example : Returns : value of secondary_patterns Args : newvalue (optional) =cut sub secondary_patterns { my ( $obj, $value ) = @_; if ( defined $value ) { $obj->{'secondary_patterns'} = $value; my @names = keys %$value; foreach my $name (@names) { $obj->secondary_namespaces($name); } } return $obj->{'secondary_patterns'}; } =head2 secondary_namespaces Title : secondary_namespaces Usage : $obj->secondary_namespaces($newval) Function: Example : Returns : value of secondary_namespaces Args : newvalue (optional) =cut sub secondary_namespaces { my ( $obj, @values ) = @_; if (@values) { push( @{ $obj->{'secondary_namespaces'} }, @values ); } return @{ $obj->{'secondary_namespaces'} || [] }; } ## These are indexing routines to index commonly used format - fasta ## swissprot and embl sub new_SWISSPROT_index { my ( $self, $index_dir, @files ) = @_; my %secondary_patterns; my $start_pattern = "^ID (\\S+)"; my $primary_pattern = "^AC (\\S+)\\;"; $secondary_patterns{"ID"} = $start_pattern; my $index = Bio::DB::Flat::BinarySearch->new( -index_dir => $index_dir, -format => 'swissprot', -primary_pattern => $primary_pattern, -primary_namespace => "ACC", -start_pattern => $start_pattern, -secondary_patterns => \%secondary_patterns ); $index->build_index(@files); } sub new_EMBL_index { my ( $self, $index_dir, @files ) = @_; my %secondary_patterns; my $start_pattern = "^ID (\\S+)"; my $primary_pattern = "^AC (\\S+)\\;"; my $primary_namespace = "ACC"; $secondary_patterns{"ID"} = $start_pattern; my $index = Bio::DB::Flat::BinarySearch->new( -index_dir => $index_dir, -format => 'embl', -primary_pattern => $primary_pattern, -primary_namespace => "ACC", -start_pattern => $start_pattern, -secondary_patterns => \%secondary_patterns ); $index->build_index(@files); return $index; } sub new_FASTA_index { my ( $self, $index_dir, @files ) = @_; my %secondary_patterns; my $start_pattern = "^>"; my $primary_pattern = "^>(\\S+)"; my $primary_namespace = "ACC"; $secondary_patterns{"ID"} = "^>\\S+ +(\\S+)"; my $index = Bio::DB::Flat::BinarySearch->new( -index_dir => $index_dir, -format => 'fasta', -primary_pattern => $primary_pattern, -primary_namespace => "ACC", -start_pattern => $start_pattern, -secondary_patterns => \%secondary_patterns ); $index->build_index(@files); return $index; } # EVERYTHING THAT FOLLOWS THIS # is an awful hack - in reality Michele's code needs to be rewritten # to use Bio::SeqIO, but I have too little time to do this -- LS sub guess_alphabet { my $self = shift; my $line = shift; my $format = $self->format; return 'protein' if $format eq 'swissprot'; if ( $format eq 'genbank' ) { return unless $line =~ /^LOCUS/; return 'dna' if $line =~ /\s+\d+\s+bp/i; return 'protein'; } if ( $format eq 'embl' ) { return unless $line =~ /^ID/; return 'dna' if $line =~ / DNA;/i; return 'rna' if $line =~ / RNA;/i; return 'protein'; } return; } # return (namespace,primary_pattern,start_pattern,secondary_pattern) sub _guess_patterns { my $self = shift; my $format = shift; if ( $format =~ /swiss(prot)?/i ) { return ( 'ID', "^ID (\\S+)", "^ID (\\S+)", { ACC => "^AC (\\S+);" } ); } if ($format =~ /embl/i) { return ('ID', "^ID (\\S+[^; ])", "^ID (\\S+[^; ])", { ACC => q/^AC (\S+);/, VERSION => q/^SV\s+(\S+)/ }); } if ( $format =~ /genbank/i ) { return ( 'ID', q/^LOCUS\s+(\S+)/, q/^LOCUS/, { ACC => q/^ACCESSION\s+(\S+)/, VERSION => q/^VERSION\s+(\S+)/ } ); } if ( $format =~ /fasta/i ) { return ( 'ACC', '^>(\S+)', '^>(\S+)', ); } $self->throw("I can't handle format $format"); } 1; BioPerl-1.6.923/Bio/DB/Flat/BDB000755000765000024 012254227335 15557 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/Flat/BDB/embl.pm000444000765000024 443312254227324 17173 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::Flat::BDB # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat::BDB::embl - embl adaptor for Open-bio standard BDB-indexed flat file =head1 SYNOPSIS See Bio::DB::Flat. =head1 DESCRIPTION This module allows embl files to be stored in Berkeley DB flat files using the Open-Bio standard BDB-indexed flat file scheme. You should not be using this directly, but instead use it via Bio::DB::Flat. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email - lstein@cshl.org =head1 SEE ALSO L, =cut package Bio::DB::Flat::BDB::embl; use strict; use base qw(Bio::DB::Flat::BDB); sub seq_to_ids { my $self = shift; my $seq = shift; my $display_id = $seq->display_id; my $accession = $seq->accession_number; my $version = $seq->seq_version; my %ids; $ids{ID} = $display_id; $ids{ACC} = $accession if defined $accession; $ids{VERSION} = "$accession.$version" if defined $accession && defined $version; return \%ids; } sub default_primary_namespace { return "ID"; } sub default_secondary_namespaces { return qw(ACC VERSION); } sub default_file_format { "embl" } 1; BioPerl-1.6.923/Bio/DB/Flat/BDB/fasta.pm000444000765000024 456412254227312 17354 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::Flat::BDB # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat::BDB::fasta - fasta adaptor for Open-bio standard BDB-indexed flat file =head1 SYNOPSIS See Bio::DB::Flat. =head1 DESCRIPTION This module allows fasta files to be stored in Berkeley DB flat files using the Open-Bio standard BDB-indexed flat file scheme. You should not be using this directly, but instead use it via Bio::DB::Flat. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 SEE ALSO L, =head1 AUTHOR - Lincoln Stein Email - lstein@cshl.org =cut package Bio::DB::Flat::BDB::fasta; use strict; use base qw(Bio::DB::Flat::BDB); sub default_file_format { "fasta" } sub seq_to_ids { my $self = shift; my $seq = shift; my %ids; $ids{$self->primary_namespace} = $seq->primary_id; \%ids; } sub parse_one_record { my $self = shift; my $fh = shift; # fasta parses by changing $/ to '\n>', need to adjust accordingly my $adj = -1; my $parser = $self->{cached_parsers}{fileno($fh)} ||= Bio::SeqIO->new(-fh=>$fh,-format=>$self->default_file_format); my $seq = $parser->next_seq or return; $self->{flat_alphabet} ||= $seq->alphabet; my $ids = $self->seq_to_ids($seq); return ($ids, $adj); } 1; BioPerl-1.6.923/Bio/DB/Flat/BDB/genbank.pm000444000765000024 463212254227335 17664 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::Flat::BDB # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat::BDB::genbank - genbank adaptor for Open-bio standard BDB-indexed flat file =head1 SYNOPSIS See Bio::DB::Flat. =head1 DESCRIPTION This module allows genbank files to be stored in Berkeley DB flat files using the Open-Bio standard BDB-indexed flat file scheme. You should not be using this directly, but instead use it via Bio::DB::Flat. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email - lstein@cshl.org =head1 SEE ALSO L, =cut package Bio::DB::Flat::BDB::genbank; use strict; use base qw(Bio::DB::Flat::BDB); sub seq_to_ids { my $self = shift; my $seq = shift; my $display_id = $seq->display_id; my $accession = $seq->accession_number; my $version = $seq->seq_version; my $gi = $seq->primary_id; my %ids; $ids{ID} = $display_id; $ids{ACC} = $accession if defined $accession; $ids{VERSION} = "$accession.$version" if defined $accession && defined $version; $ids{GI} = $gi if defined $gi && $gi =~ /^\d+$/; return \%ids; } sub default_primary_namespace { return "ID"; } sub default_secondary_namespaces { return qw(ACC GI VERSION); } sub default_file_format { "genbank" } 1; BioPerl-1.6.923/Bio/DB/Flat/BDB/swiss.pm000444000765000024 452512254227332 17425 0ustar00cjfieldsstaff000000000000# # # BioPerl module for Bio::DB::Flat::BDB::swiss # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Flat::BDB::swiss - swissprot adaptor for Open-bio standard BDB-indexed flat file =head1 SYNOPSIS See Bio::DB::Flat. =head1 DESCRIPTION This module allows swissprot files to be stored in Berkeley DB flat files using the Open-Bio standard BDB-indexed flat file scheme. You should not be using this directly, but instead use it via Bio::DB::Flat. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 SEE ALSO L, =head1 AUTHOR - Lincoln Stein Email - lstein@cshl.org =cut package Bio::DB::Flat::BDB::swiss; use strict; use base qw(Bio::DB::Flat::BDB); sub default_file_format { "swiss" } sub default_primary_namespace { return "ID"; } sub default_secondary_namespaces { return qw(ACC VERSION); } sub seq_to_ids { my $self = shift; my $seq = shift; my $display_id = $seq->display_id; my $accession = $seq->accession_number; my $version = $seq->seq_version; my $gi = $seq->primary_id; my %ids; $ids{ID} = $display_id; $ids{ACC} = $accession if defined $accession; $ids{VERSION} = "$accession.$version" if defined $accession && defined $version; return \%ids; } 1; BioPerl-1.6.923/Bio/DB/GFF000755000765000024 012254227336 14705 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Aggregator.pm000444000765000024 4143612254227315 17507 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator -- Aggregate GFF groups into composite features =head1 SYNOPSIS use Bio::DB::GFF; my $agg1 = Bio::DB::GFF::Aggregator->new(-method => 'cistron', -main_method => 'locus', -sub_parts => ['allele','variant'] ); my $agg2 = Bio::DB::GFF::Aggregator->new(-method => 'splice_group', -sub_parts => 'transcript'); my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -aggregator => [$agg1,$agg2], -dsn => 'dbi:mysql:elegans42', ); =head1 DESCRIPTION Bio::DB::GFF::Aggregator is used to aggregate GFF groups into composite features. Each composite feature has a "main part", the top-level feature, and a series of zero or more subparts, retrieved with the sub_SeqFeature() method. The aggregator class is designed to be subclassable, allowing a variety of GFF feature types to be supported. The base Bio::DB::GFF::Aggregator class is generic, and can be used to create specific instances to be passed to the -aggregator argument of Bio::DB::GFF-Enew() call. The various subclasses of Bio::DB::GFF::Aggregator are tuned for specific common feature types such as clones, gapped alignments and transcripts. Instances of Bio::DB::GFF::Aggregator have three attributes: =over 3 =item * method This is the GFF method field of the composite feature as a whole. For example, "transcript" may be used for a composite feature created by aggregating individual intron, exon and UTR features. =item * main method Sometimes GFF groups are organized hierarchically, with one feature logically containing another. For example, in the C. elegans schema, methods of type "Sequence:curated" correspond to regions covered by curated genes. There can be zero or one main methods. =item * subparts This is a list of one or more methods that correspond to the component features of the aggregates. For example, in the C. elegans database, the subparts of transcript are "intron", "exon" and "CDS". =back Aggregators have two main methods that can be overridden in subclasses: =over 4 =item * disaggregate() This method is called by the Adaptor object prior to fetching a list of features. The method is passed an associative array containing the [method,source] pairs that the user has requested, and it returns a list of raw features that it would like the adaptor to fetch. =item * aggregate() This method is called by the Adaptor object after it has fetched features. The method is passed a list of raw features and is expected to add its composite features to the list. =back The disaggregate() and aggregate() methods provided by the base Aggregator class should be sufficient for many applications. In this case, it suffices for subclasses to override the following methods: =over 4 =item * method() Return the default method for the composite feature as a whole. =item * main_name() Return the default main method name. =item * part_names() Return a list of subpart method names. =back Provided that method() and part_names() are overridden (and optionally main_name() as well), then the bare name of the aggregator subclass can be passed to the -aggregator of Bio::DB::GFF-Enew(). For example, this is a small subclass that will aggregate features of type "allele" and "polymorphism" into an aggregate named "mutant": package Bio::DB::GFF::Aggregator::mutant; use strict; use Bio::DB::GFF::Aggregator; use base qw(Bio::DB::GFF::Aggregator); sub method { 'mutant' } sub part_names { return qw(allele polymorphism); } 1; Once installed, this aggregator can be passed to Bio::DB::GFF-Enew() by name like so: my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -aggregator => 'mutant', -dsn => 'dbi:mysql:elegans42', ); =head1 API The remainder of this document describes the public and private methods implemented by this module. =cut package Bio::DB::GFF::Aggregator; use strict; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::GFF::Feature; use base qw(Bio::Root::Root); my $ALWAYS_TRUE = sub { 1 }; =head2 new Title : new Usage : $a = Bio::DB::GFF::Aggregator->new(@args) Function: create a new aggregator Returns : a Bio::DB::GFF::Aggregator object Args : see below Status : Public This is the constructor for Bio::DB::GFF::Aggregator. Named arguments are as follows: -method the method for the composite feature -main_method the top-level raw feature, if any -sub_parts the list of raw features that will form the subparts of the composite feature (array reference or scalar) =cut sub new { my $class = shift; my ($method,$main,$sub_parts,$whole_object) = rearrange(['METHOD', ['MAIN_PART','MAIN_METHOD'], ['SUB_METHODS','SUB_PARTS'], 'WHOLE_OBJECT' ],@_); return bless { method => $method, main_method => $main, sub_parts => $sub_parts, require_whole_object => $whole_object, },$class; } =head2 disaggregate Title : disaggregate Usage : $a->disaggregate($types,$factory) Function: disaggregate type list into components Returns : a true value if this aggregator should be called to reaggregate Args : see below Status : Public This method is called to disaggregate a list of types into the set of low-level features to be retrieved from the GFF database. The list of types is passed as an array reference containing a series of [method,source] pairs. This method synthesizes a new set of [method,source] pairs, and appends them to the list of requested types, changing the list in situ. Arguments: $types reference to an array of [method,source] pairs $factory reference to the Adaptor object that is calling this method Note that the API allows disaggregate() to remove types from the type list. This feature is probably not desirable and may be deprecated in the future. =cut # this is called at the beginning to turn the pseudo-type # into its component feature types sub disaggregate { my $self = shift; my $types = shift; my $factory = shift; my $sub_features = $factory->parse_types($self->get_part_names); my $main_feature = $factory->parse_types($self->get_main_name); if (@$types) { my (@synthetic_types,@unchanged); foreach (@$types) { my ($method,$source) = @$_; if (lc $method eq lc $self->get_method) { # e.g. "transcript" push @synthetic_types,map { [$_->[0],$_->[1] || $source] } @$sub_features,@$main_feature; } else { push @unchanged,$_; } } # remember what we're searching for $self->components(\@synthetic_types); $self->passthru(\@unchanged); @$types = (@unchanged,@synthetic_types); } # we get here when no search types are listed else { my @stypes = map { [$_->[0],$_->[1]] } @$sub_features,@$main_feature; $self->components(\@stypes); $self->passthru(undef); } return $self->component_count > 0; } =head2 aggregate Title : aggregate Usage : $features = $a->aggregate($features,$factory) Function: aggregate a feature list into composite features Returns : an array reference containing modified features Args : see below Status : Public This method is called to aggregate a list of raw GFF features into the set of composite features. The method is called an array reference to a set of Bio::DB::GFF::Feature objects. It runs through the list, creating new composite features when appropriate. The method result is an array reference containing the composite features. Arguments: $features reference to an array of Bio::DB::GFF::Feature objects $factory reference to the Adaptor object that is calling this method NOTE: The reason that the function result contains the raw features as well as the aggregated ones is to allow queries like this one: @features = $segment->features('exon','transcript:curated'); Assuming that "transcript" is the name of an aggregated feature and that "exon" is one of its components, we do not want the transcript aggregator to remove features of type "exon" because the user asked for them explicitly. =cut sub aggregate { my $self = shift; my $features = shift; my $factory = shift; my $main_method = $self->get_main_name; my $matchsub = $self->match_sub($factory) or return; my $strictmatch = $self->strict_match(); my $passthru = $self->passthru_sub($factory); my (%aggregates,@result); for my $feature (@$features) { if ($feature->group && $matchsub->($feature)) { my $key = $strictmatch->{lc $feature->method,lc $feature->source} ? join ($;,$feature->group,$feature->refseq,$feature->source) : join ($;,$feature->group,$feature->refseq); if ($main_method && lc $feature->method eq lc $main_method) { $aggregates{$key}{base} ||= $feature->clone; } else { push @{$aggregates{$key}{subparts}},$feature; } push @result,$feature if $passthru && $passthru->($feature); } else { push @result,$feature; } } # aggregate components my $pseudo_method = $self->get_method; my $require_whole_object = $self->require_whole_object; foreach (keys %aggregates) { if ($require_whole_object && $self->components) { next unless $aggregates{$_}{base}; # && $aggregates{$_}{subparts}; } my $base = $aggregates{$_}{base}; unless ($base) { # no base, so create one my $first = $aggregates{$_}{subparts}[0]; $base = $first->clone; # to inherit parent coordinate system, etc $base->score(undef); $base->phase(undef); } $base->method($pseudo_method); $base->add_subfeature($_) foreach @{$aggregates{$_}{subparts}}; $base->adjust_bounds; $base->compound(1); # set the compound flag push @result,$base; } @$features = @result; } =head2 method Title : method Usage : $string = $a->method Function: get the method type for the composite feature Returns : a string Args : none Status : Protected This method is called to get the method to be assigned to the composite feature once it is aggregated. It is called if the user did not explicitly supply a -method argument when the aggregator was created. This is the method that should be overridden in aggregator subclasses. =cut # default method - override in subclasses sub method { my $self = shift; $self->{method}; } =head2 main_name Title : main_name Usage : $string = $a->main_name Function: get the method type for the "main" component of the feature Returns : a string Args : none Status : Protected This method is called to get the method of the "main component" of the composite feature. It is called if the user did not explicitly supply a -main-method argument when the aggregator was created. This is the method that should be overridden in aggregator subclasses. =cut # no default main method sub main_name { my $self = shift; return; } =head2 part_names Title : part_names Usage : @methods = $a->part_names Function: get the methods for the non-main various components of the feature Returns : a list of strings Args : none Status : Protected This method is called to get the list of methods of the "main component" of the composite feature. It is called if the user did not explicitly supply a -main-method argument when the aggregator was created. This is the method that should be overridden in aggregator subclasses. =cut # no default part names sub part_names { my $self = shift; return; } =head2 require_whole_object Title : require_whole_object Usage : $bool = $a->require_whole_object Function: see below Returns : a boolean flag Args : none Status : Internal This method returns true if the aggregator should refuse to aggregate an object unless both its main part and its subparts are present. =cut sub require_whole_object { my $self = shift; my $d = $self->{require_whole_object}; $self->{require_whole_object} = shift if @_; $d; } =head2 match_sub Title : match_sub Usage : $coderef = $a->match_sub($factory) Function: generate a code reference that will match desired features Returns : a code reference Args : see below Status : Internal This method is used internally to generate a code sub that will quickly filter out the raw features that we're interested in aggregating. The returned sub accepts a Feature and returns true if we should aggregate it, false otherwise. =cut #' make emacs happy sub match_sub { my $self = shift; my $factory = shift; my $types_to_aggregate = $self->components() or return; # saved from disaggregate call return unless @$types_to_aggregate; return $factory->make_match_sub($types_to_aggregate); } =head2 strict_match Title : strict_match Usage : $strict = $a->strict_match Function: generate a hashref that indicates which subfeatures need to be tested strictly for matching sources before aggregating Returns : a hash ref Status : Internal =cut sub strict_match { my $self = shift; my $types_to_aggregate = $self->components(); my %strict; for my $t (@$types_to_aggregate) { $strict{lc $t->[0],lc $t->[1]}++ if defined $t->[1]; } \%strict; } sub passthru_sub { my $self = shift; my $factory = shift; my $passthru = $self->passthru() or return; return unless @$passthru; return $factory->make_match_sub($passthru); } =head2 components Title : components Usage : @array= $a->components([$components]) Function: get/set stored list of parsed raw feature types Returns : an array in list context, an array ref in scalar context Args : new arrayref of feature types Status : Internal This method is used internally to remember the parsed list of raw features that we will aggregate. The need for this subroutine is seen when a user requests a composite feature of type "clone:cosmid". This generates a list of components in which the source is appended to the method, like "clone_left_end:cosmid" and "clone_right_end:cosmid". components() stores this information for later use. =cut sub components { my $self = shift; my $d = $self->{components}; $self->{components} = shift if @_; return unless ref $d; return wantarray ? @$d : $d; } sub component_count { my @c = shift->components; scalar @c; } sub passthru { my $self = shift; my $d = $self->{passthru}; $self->{passthru} = shift if @_; return unless ref $d; return wantarray ? @$d : $d; } sub clone { my $self = shift; my %new = %{$self}; return bless \%new,ref($self); } =head2 get_part_names Title : get_part_names Usage : @array = $a->get_part_names Function: get list of sub-parts for this type of feature Returns : an array Args : none Status : Internal This method is used internally to fetch the list of feature types that form the components of the composite feature. Type names in the format "method:source" are recognized, as are "method" and Bio::DB::GFF::Typename objects as well. It checks instance variables first, and if not defined calls the part_names() method. =cut sub get_part_names { my $self = shift; if ($self->{sub_parts}) { return ref $self->{sub_parts} ? @{$self->{sub_parts}} : $self->{sub_parts}; } else { return $self->part_names; } } =head2 get_main_name Title : get_main_name Usage : $string = $a->get_main_name Function: get the "main" method type for this feature Returns : a string Args : none Status : Internal This method is used internally to fetch the type of the "main part" of the feature. It checks instance variables first, and if not defined calls the main_name() method. =cut sub get_main_name { my $self = shift; return $self->{main_method} if defined $self->{main_method}; return $self->main_name; } =head2 get_method Title : get_method Usage : $string = $a->get_method Function: get the method type for the composite feature Returns : a string Args : none Status : Internal This method is used internally to fetch the type of the method that will be assigned to the composite feature once it is synthesized. =cut sub get_method { my $self = shift; return $self->{method} if defined $self->{method}; return $self->method; } 1; =head1 BUGS None known yet. =head1 SEE ALSO L, L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Featname.pm000444000765000024 551112254227317 17121 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Featname -- The name of a feature =head1 SYNOPSIS use Bio::DB::GFF; my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42'); my $feature = Bio::DB::GFF::Featname->new(Locus => 'unc-19'); my $segment = $db->segment($feature); =head1 DESCRIPTION Bio::DB::GFF::Featname is the name of a feature. It contains two fields: name and class. It is typically used by the Bio::DB::GFF module to denote a group, and is accepted by Bio::DB::Relsegment-Enew() and Bio::DB::GFF-Esegment() as a replacement for the -name and -class arguments. =head1 METHODS =cut package Bio::DB::GFF::Featname; use strict; use base qw(Bio::Root::RootI); use overload '""' => 'asString', fallback => 1; =head2 new Title : new Usage : $name = Bio::DB::GFF::Featname->new($class,$name) Function: create a new Bio::DB::GFF::Featname object Returns : a new Bio::DB::GFF::Featname object Args : class and ID Status : Public =cut sub new { # use a blessed array for speed my $pack = shift; bless [@_],$pack; # class,name } sub _cleanup_methods { return; } =head2 id Title : id Usage : $id = $name->id Function: return a unique ID for the combination of class and name Returns : a string Args : none Status : Public This method returns a unique combination of the name and class in the form "class:name". Coincidentally, this is the same format used by AceDB. =cut sub id { my $self = shift; return join ':',@$self; } =head2 name Title : name Usage : $name = $name->name Function: return the name of the Featname Returns : a string Args : none Status : Public =cut sub name { shift->[1] } =head2 class Title : class Usage : $class = $name->class Function: return the name of the Featname Returns : a string Args : none Status : Public =cut sub class { shift->[0] } =head2 asString Title : asString Usage : $string = $name->asString Function: same as name() Returns : a string Args : none Status : Public This method is used to overload the "" operator. It is equivalent to calling name(). =cut sub asString { shift->name } =head2 clone Title : clone Usage : $new_clone = $type->clone; Function: clone this object Returns : a new Bio::DB::GFF::Featname object Args : none Status : Public This method creates an exact copy of the object. =cut sub clone { my $self = shift; return bless [@$self],ref $self; } =head1 BUGS This module is still under development. =head1 SEE ALSO L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; BioPerl-1.6.923/Bio/DB/GFF/Feature.pm000444000765000024 10656512254227333 17045 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Feature -- A relative segment identified by a feature type =head1 SYNOPSIS See L. =head1 DESCRIPTION Bio::DB::GFF::Feature is a stretch of sequence that corresponding to a single annotation in a GFF database. It inherits from Bio::DB::GFF::RelSegment, and so has all the support for relative addressing of this class and its ancestors. It also inherits from Bio::SeqFeatureI and so has the familiar start(), stop(), primary_tag() and location() methods (it implements Bio::LocationI too, if needed). Bio::DB::GFF::Feature adds new methods to retrieve the annotation type, group, and other GFF attributes. Annotation types are represented by Bio::DB::GFF::Typename objects, a simple class that has two methods called method() and source(). These correspond to the method and source fields of a GFF file. Annotation groups serve the dual purpose of giving the annotation a human-readable name, and providing higher-order groupings of subfeatures into features. The groups returned by this module are objects of the Bio::DB::GFF::Featname class. Bio::DB::GFF::Feature inherits from and implements the abstract methods of Bio::SeqFeatureI, allowing it to interoperate with other Bioperl modules. Generally, you will not create or manipulate Bio::DB::GFF::Feature objects directly, but use those that are returned by the Bio::DB::GFF::RelSegment-Efeatures() method. =head2 Important note about start() vs end() If features are derived from segments that use relative addressing (which is the default), then start() will be less than end() if the feature is on the opposite strand from the reference sequence. This breaks Bio::SeqI compliance, but is necessary to avoid having the real genomic locations designated by start() and end() swap places when changing reference points. To avoid this behavior, call $segment-Eabsolute(1) before fetching features from it. This will force everything into absolute coordinates. For example: my $segment = $db->segment('CHROMOSOME_I'); $segment->absolute(1); my @features = $segment->features('transcript'); =head1 API The remainder of this document describes the public and private methods implemented by this module. =cut package Bio::DB::GFF::Feature; use strict; use Bio::DB::GFF::Util::Rearrange; use Bio::DB::GFF::Featname; use Bio::DB::GFF::Typename; use Bio::DB::GFF::Homol; use Bio::LocationI; use Data::Dumper; use vars qw($AUTOLOAD); use base qw(Bio::DB::GFF::RelSegment Bio::SeqFeatureI Bio::Root::Root); #' *segments = *get_SeqFeatures = \&sub_SeqFeature; my %CONSTANT_TAGS = (method=>1, source=>1, score=>1, phase=>1, notes=>1, id=>1, group=>1); =head2 new_from_parent Title : new_from_parent Usage : $f = Bio::DB::GFF::Feature->new_from_parent(@args); Function: create a new feature object Returns : new Bio::DB::GFF::Feature object Args : see below Status : Internal This method is called by Bio::DB::GFF to create a new feature using information obtained from the GFF database. It is one of two similar constructors. This one is called when the feature is generated from a RelSegment object, and should inherit the coordinate system of that object. The 13 arguments are positional (sorry): $parent a Bio::DB::GFF::RelSegment object (or descendent) $start start of this feature $stop stop of this feature $method this feature's GFF method $source this feature's GFF source $score this feature's score $fstrand this feature's strand (relative to the source sequence, which has its own strandedness!) $phase this feature's phase $group this feature's group (a Bio::DB::GFF::Featname object) $db_id this feature's internal database ID $group_id this feature's internal group database ID $tstart this feature's target start $tstop this feature's target stop tstart and tstop are not used for anything at the moment, since the information is embedded in the group object. =cut # this is called for a feature that is attached to a parent sequence, # in which case it inherits its coordinate reference system and strandedness sub new_from_parent { my $package = shift; my ($parent, $start,$stop, $method,$source,$score, $fstrand,$phase, $group,$db_id,$group_id, $tstart,$tstop) = @_; ($start,$stop) = ($stop,$start) if defined($fstrand) and $fstrand eq '-'; my $class = $group ? $group->class : $parent->class; my $self = bless { factory => $parent->{factory}, sourceseq => $parent->{sourceseq}, strand => $parent->{strand}, ref => $parent->{ref}, refstart => $parent->{refstart}, refstrand => $parent->{refstrand}, absolute => $parent->{absolute}, start => $start, stop => $stop, type => Bio::DB::GFF::Typename->new($method,$source), fstrand => $fstrand, score => $score, phase => $phase, group => $group, db_id => $db_id, group_id => $group_id, class => $class, },$package; $self; } =head2 new Title : new Usage : $f = Bio::DB::GFF::Feature->new(@args); Function: create a new feature object Returns : new Bio::DB::GFF::Feature object Args : see below Status : Internal This method is called by Bio::DB::GFF to create a new feature using information obtained from the GFF database. It is one of two similar constructors. This one is called when the feature is generated without reference to a RelSegment object, and should therefore use its default coordinate system (relative to itself). The 11 arguments are positional: $factory a Bio::DB::GFF adaptor object (or descendent) $srcseq the source sequence $start start of this feature $stop stop of this feature $method this feature's GFF method $source this feature's GFF source $score this feature's score $fstrand this feature's strand (relative to the source sequence, which has its own strandedness!) $phase this feature's phase $group this feature's group $db_id this feature's internal database ID =cut # 'This is called when creating a feature from scratch. It does not have # an inherited coordinate system. sub new { my $package = shift; my ($factory, $srcseq, $start,$stop, $method,$source, $score,$fstrand,$phase, $group,$db_id,$group_id, $tstart,$tstop) = @_; my $self = bless { },$package; ($start,$stop) = ($stop,$start) if defined($fstrand) and $fstrand eq '-'; my $class = $group ? $group->class : 'Sequence'; @{$self}{qw(factory sourceseq start stop strand class)} = ($factory,$srcseq,$start,$stop,$fstrand,$class); # if the target start and stop are defined, then we use this information to create # the reference sequence # THIS SHOULD BE BUILT INTO RELSEGMENT if (0 && $tstart ne '' && $tstop ne '') { if ($tstart < $tstop) { @{$self}{qw(ref refstart refstrand)} = ($group,$start - $tstart + 1,'+'); } else { @{$self}{'start','stop'} = @{$self}{'stop','start'}; @{$self}{qw(ref refstart refstrand)} = ($group,$tstop + $stop - 1,'-'); } } else { @{$self}{qw(ref refstart refstrand)} = ($srcseq,1,'+'); } @{$self}{qw(type fstrand score phase group db_id group_id absolute)} = (Bio::DB::GFF::Typename->new($method,$source),$fstrand,$score,$phase, $group,$db_id,$group_id,$factory->{absolute}); $self; } =head2 type Title : type Usage : $type = $f->type([$newtype]) Function: get or set the feature type Returns : a Bio::DB::GFF::Typename object Args : a new Typename object (optional) Status : Public This method gets or sets the type of the feature. The type is a Bio::DB::GFF::Typename object, which encapsulates the feature method and source. The method() and source() methods described next provide shortcuts to the individual fields of the type. =cut sub type { my $self = shift; my $d = $self->{type}; $self->{type} = shift if @_; $d; } =head2 method Title : method Usage : $method = $f->method([$newmethod]) Function: get or set the feature method Returns : a string Args : a new method (optional) Status : Public This method gets or sets the feature method. It is a convenience feature that delegates the task to the feature's type object. =cut sub method { my $self = shift; my $d = $self->{type}->method; $self->{type}->method(shift) if @_; $d; } =head2 source Title : source Usage : $source = $f->source([$newsource]) Function: get or set the feature source Returns : a string Args : a new source (optional) Status : Public This method gets or sets the feature source. It is a convenience feature that delegates the task to the feature's type object. =cut sub source { my $self = shift; my $d = $self->{type}->source; $self->{type}->source(shift) if @_; $d; } =head2 score Title : score Usage : $score = $f->score([$newscore]) Function: get or set the feature score Returns : a string Args : a new score (optional) Status : Public This method gets or sets the feature score. =cut sub score { my $self = shift; my $d = $self->{score}; $self->{score} = shift if @_; $d; } =head2 phase Title : phase Usage : $phase = $f->phase([$phase]) Function: get or set the feature phase Returns : a string Args : a new phase (optional) Status : Public This method gets or sets the feature phase. =cut sub phase { my $self = shift; my $d = $self->{phase}; $self->{phase} = shift if @_; $d; } =head2 strand Title : strand Usage : $strand = $f->strand Function: get the feature strand Returns : +1, 0 -1 Args : none Status : Public Returns the strand of the feature. Unlike the other methods, the strand cannot be changed once the object is created (due to coordinate considerations). =cut sub strand { my $self = shift; return 0 unless $self->{fstrand}; if ($self->absolute) { return Bio::DB::GFF::RelSegment::_to_strand($self->{fstrand}); } return $self->SUPER::strand || Bio::DB::GFF::RelSegment::_to_strand($self->{fstrand}); } =head2 group Title : group Usage : $group = $f->group([$new_group]) Function: get or set the feature group Returns : a Bio::DB::GFF::Featname object Args : a new group (optional) Status : Public This method gets or sets the feature group. The group is a Bio::DB::GFF::Featname object, which has an ID and a class. =cut sub group { my $self = shift; my $d = $self->{group}; $self->{group} = shift if @_; $d; } =head2 display_id Title : display_id Usage : $display_id = $f->display_id([$display_id]) Function: get or set the feature display id Returns : a Bio::DB::GFF::Featname object Args : a new display_id (optional) Status : Public This method is an alias for group(). It is provided for Bio::SeqFeatureI compatibility. =cut =head2 info Title : info Usage : $info = $f->info([$new_info]) Function: get or set the feature group Returns : a Bio::DB::GFF::Featname object Args : a new group (optional) Status : Public This method is an alias for group(). It is provided for AcePerl compatibility. =cut *info = \&group; *display_id = \&group; *display_name = \&group; =head2 target Title : target Usage : $target = $f->target([$new_target]) Function: get or set the feature target Returns : a Bio::DB::GFF::Homol object Args : a new group (optional) Status : Public This method works like group(), but only returns the group if it implements the start() method. This is typical for similarity/assembly features, where the target encodes the start and stop location of the alignment. The returned object is of type Bio::DB::GFF::Homol, which is a subclass of Bio::DB::GFF::Segment. =cut sub target { my $self = shift; my $group = $self->group or return; return unless $group->can('start'); $group; } =head2 flatten_target Title : flatten_target Usage : $target = $f->flatten_target($f->target) Function: flatten a target object Returns : a string (GFF2), an array [GFF2.5] or an array ref [GFF3] Args : a target object (required), GFF version (optional) Status : Public This method flattens a target object into text for GFF dumping. If a second argument is provided, version-specific vocabulary is used for the flattened target. =cut sub flatten_target { my $self = shift; my $t = shift || return; my $v = shift; return 0 unless $t->can('start'); my $class = $t->class; my $name = $t->name; my $start = $t->start; my $stop = $t->stop; $v ||=2; if ( $v == 2.5 ) { print STDERR qq(Target "$class:$name"), "tstart $start", "tstop $stop\n"; return (qq(Target "$class:$name"), "tstart $start", "tstop $stop"); } elsif ( $v == 3 ) { return [Target=>"$name $start $stop"]; } else { return qq(Target "$class:$name" $start $stop); } } # override parent a smidgeon so that setting the ref for top-level feature # sets ref for all subfeatures sub refseq { my $self = shift; my $result = $self->SUPER::refseq(@_); if (@_) { my $newref = $self->SUPER::refseq; for my $sub ($self->get_SeqFeatures) { $sub->refseq(@_); } } $result; } =head2 hit Title : hit Usage : $hit = $f->hit([$new_hit]) Function: get or set the feature hit Returns : a Bio::DB::GFF::Featname object Args : a new group (optional) Status : Public This is the same as target(), for compatibility with Bio::SeqFeature::SimilarityPair. =cut *hit = \⌖ =head2 id Title : id Usage : $id = $f->id Function: get the feature ID Returns : a database identifier Args : none Status : Public This method retrieves the database identifier for the feature. It cannot be changed. =cut sub id { shift->{db_id} } sub primary_id { shift->{db_id} } =head2 group_id Title : group_id Usage : $id = $f->group_id Function: get the feature ID Returns : a database identifier Args : none Status : Public This method retrieves the database group identifier for the feature. It cannot be changed. Often the group identifier is more useful than the feature identifier, since it is used to refer to a complex object containing subparts. =cut sub group_id { shift->{group_id} } =head2 clone Title : clone Usage : $feature = $f->clone Function: make a copy of the feature Returns : a new Bio::DB::GFF::Feature object Args : none Status : Public This method returns a copy of the feature. =cut sub clone { my $self = shift; my $clone = $self->SUPER::clone; if (ref(my $t = $clone->type)) { my $type = $t->can('clone') ? $t->clone : bless {%$t},ref $t; $clone->type($type); } if (ref(my $g = $clone->group)) { my $group = $g->can('clone') ? $g->clone : bless {%$g},ref $g; $clone->group($group); } if (my $merged = $self->{merged_segs}) { $clone->{merged_segs} = { %$merged }; } $clone; } =head2 compound Title : compound Usage : $flag = $f->compound([$newflag]) Function: get or set the compound flag Returns : a boolean Args : a new flag (optional) Status : Public This method gets or sets a flag indicated that the feature is not a primary one from the database, but the result of aggregation. =cut sub compound { my $self = shift; my $d = $self->{compound}; $self->{compound} = shift if @_; $d; } =head2 sub_SeqFeature Title : sub_SeqFeature Usage : @feat = $feature->sub_SeqFeature([$method]) Function: get subfeatures Returns : a list of Bio::DB::GFF::Feature objects Args : a feature method (optional) Status : Public This method returns a list of any subfeatures that belong to the main feature. For those features that contain heterogeneous subfeatures, you can retrieve a subset of the subfeatures by providing a method name to filter on. This method may also be called as segments() or get_SeqFeatures(). =cut sub sub_SeqFeature { my $self = shift; my $type = shift; my $subfeat = $self->{subfeatures} or return; $self->sort_features; my @a; if ($type) { my $features = $subfeat->{lc $type} or return; @a = @{$features}; } else { @a = map {@{$_}} values %{$subfeat}; } return @a; } =head2 add_subfeature Title : add_subfeature Usage : $feature->add_subfeature($feature) Function: add a subfeature to the feature Returns : nothing Args : a Bio::DB::GFF::Feature object Status : Public This method adds a new subfeature to the object. It is used internally by aggregators, but is available for public use as well. =cut sub add_subfeature { my $self = shift; my $feature = shift; my $type = $feature->method; my $subfeat = $self->{subfeatures}{lc $type} ||= []; push @{$subfeat},$feature; } =head2 attach_seq Title : attach_seq Usage : $sf->attach_seq($seq) Function: Attaches a Bio::Seq object to this feature. This Bio::Seq object is for the *entire* sequence: ie from 1 to 10000 Example : Returns : TRUE on success Args : a Bio::PrimarySeqI compliant object =cut sub attach_seq { } =head2 location Title : location Usage : my $location = $seqfeature->location() Function: returns a location object suitable for identifying location of feature on sequence or parent feature Returns : Bio::LocationI object Args : none =cut sub location { my $self = shift; require Bio::Location::Split unless Bio::Location::Split->can('new'); require Bio::Location::Simple unless Bio::Location::Simple->can('new'); my $location; if (my @segments = $self->segments) { $location = Bio::Location::Split->new(-seq_id => $self->seq_id); foreach (@segments) { $location->add_sub_Location($_->location); } } else { $location = Bio::Location::Simple->new(-start => $self->start, -end => $self->stop, -strand => $self->strand, -seq_id => $self->seq_id); } $location; } =head2 entire_seq Title : entire_seq Usage : $whole_seq = $sf->entire_seq() Function: gives the entire sequence that this seqfeature is attached to Example : Returns : a Bio::PrimarySeqI compliant object, or undef if there is no sequence attached Args : none =cut sub entire_seq { my $self = shift; $self->factory->segment($self->sourceseq); } =head2 merged_segments Title : merged_segments Usage : @segs = $feature->merged_segments([$method]) Function: get merged subfeatures Returns : a list of Bio::DB::GFF::Feature objects Args : a feature method (optional) Status : Public This method acts like sub_SeqFeature, except that it merges overlapping segments of the same time into contiguous features. For those features that contain heterogeneous subfeatures, you can retrieve a subset of the subfeatures by providing a method name to filter on. A side-effect of this method is that the features are returned in sorted order by their start tposition. =cut #' sub merged_segments { my $self = shift; my $type = shift; $type ||= ''; # prevent uninitialized variable warnings my $truename = overload::StrVal($self); return @{$self->{merged_segs}{$type}} if exists $self->{merged_segs}{$type}; my @segs = map { $_->[0] } sort { $a->[1] <=> $b->[1] || $a->[2] cmp $b->[2] } map { [$_, $_->start, $_->type] } $self->sub_SeqFeature($type); # attempt to merge overlapping segments my @merged = (); for my $s (@segs) { my $previous = $merged[-1] if @merged; my ($pscore,$score) = (eval{$previous->score}||0,eval{$s->score}||0); if (defined($previous) && $previous->stop+1 >= $s->start && $pscore == $score && $previous->method eq $s->method ) { if ($self->absolute && $self->strand < 0) { $previous->{start} = $s->{start}; } else { $previous->{stop} = $s->{stop}; } # fix up the target too my $g = $previous->{group}; if ( ref($g) && $g->isa('Bio::DB::GFF::Homol')) { my $cg = $s->{group}; $g->{stop} = $cg->{stop}; } } elsif (defined($previous) && $previous->start == $s->start && $previous->stop == $s->stop && $previous->method eq $s->method ) { next; } else { my $copy = $s->clone; push @merged,$copy; } } $self->{merged_segs}{$type} = \@merged; @merged; } =head2 sub_types Title : sub_types Usage : @methods = $feature->sub_types Function: get methods of all sub-seqfeatures Returns : a list of method names Args : none Status : Public For those features that contain subfeatures, this method will return a unique list of method names of those subfeatures, suitable for use with sub_SeqFeature(). =cut sub sub_types { my $self = shift; my $subfeat = $self->{subfeatures} or return; return keys %$subfeat; } =head2 attributes Title : attributes Usage : @attributes = $feature->attributes($name) Function: get the "attributes" on a particular feature Returns : an array of string Args : feature ID Status : public Some GFF version 2 files use the groups column to store a series of attribute/value pairs. In this interpretation of GFF, the first such pair is treated as the primary group for the feature; subsequent pairs are treated as attributes. Two attributes have special meaning: "Note" is for backward compatibility and is used for unstructured text remarks. "Alias" is considered as a synonym for the feature name. @gene_names = $feature->attributes('Gene'); @aliases = $feature->attributes('Alias'); If no name is provided, then attributes() returns a flattened hash, of attribute=Evalue pairs. This lets you do: %attributes = $db->attributes; =cut sub attributes { my $self = shift; my $factory = $self->factory; defined(my $id = $self->id) or return; $factory->attributes($id,@_) } =head2 notes Title : notes Usage : @notes = $feature->notes Function: get the "notes" on a particular feature Returns : an array of string Args : feature ID Status : public Some GFF version 2 files use the groups column to store various notes and remarks. Adaptors can elect to store the notes in the database, or just ignore them. For those adaptors that store the notes, the notes() method will return them as a list. =cut sub notes { my $self = shift; $self->attributes('Note'); } =head2 aliases Title : aliases Usage : @aliases = $feature->aliases Function: get the "aliases" on a particular feature Returns : an array of string Args : feature ID Status : public This method will return a list of attributes of type 'Alias'. =cut sub aliases { my $self = shift; $self->attributes('Alias'); } =head2 Autogenerated Methods Title : AUTOLOAD Usage : @subfeat = $feature->Method Function: Return subfeatures using autogenerated methods Returns : a list of Bio::DB::GFF::Feature objects Args : none Status : Public Any method that begins with an initial capital letter will be passed to AUTOLOAD and treated as a call to sub_SeqFeature with the method name used as the method argument. For instance, this call: @exons = $feature->Exon; is equivalent to this call: @exons = $feature->sub_SeqFeature('exon'); =cut =head2 SeqFeatureI methods The following Bio::SeqFeatureI methods are implemented: primary_tag(), source_tag(), all_tags(), has_tag(), each_tag_value() [renamed get_tag_values()]. =cut *primary_tag = \&method; *source_tag = \&source; sub all_tags { my $self = shift; my %atts = $self->attributes; my @tags = keys %atts; # autogenerated methods #if (my $subfeat = $self->{subfeatures}) { # push @tags,keys %$subfeat; #} @tags; } *get_all_tags = \&all_tags; sub has_tag { my $self = shift; my $tag = shift; my %att = $self->attributes; my %tags = map {$_=>1} ( $self->all_tags ); return $tags{$tag}; } *each_tag_value = \&get_tag_values; sub get_tag_values { my $self = shift; my $tag = shift; return $self->$tag() if $CONSTANT_TAGS{$tag}; my $atts = $self->attributes; return @{$atts->{$tag}} if $atts && $atts->{$tag}; $tag = ucfirst $tag; return $self->$tag(); # try autogenerated tag } sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; my $sub = $AUTOLOAD; my $self = $_[0]; # ignore DESTROY calls return if $func_name eq 'DESTROY'; # fetch subfeatures if func_name has an initial cap # return sort {$a->start <=> $b->start} $self->sub_SeqFeature($func_name) if $func_name =~ /^[A-Z]/; return $self->sub_SeqFeature($func_name) if $func_name =~ /^[A-Z]/; # error message of last resort $self->throw(qq(Can't locate object method "$func_name" via package "$pack")); }#' =head2 adjust_bounds Title : adjust_bounds Usage : $feature->adjust_bounds Function: adjust the bounds of a feature Returns : ($start,$stop,$strand) Args : none Status : Public This method adjusts the boundaries of the feature to enclose all its subfeatures. It returns the new start, stop and strand of the enclosing feature. =cut # adjust a feature so that its boundaries are synched with its subparts' boundaries. # this works recursively, so subfeatures can contain other features sub adjust_bounds { my $self = shift; my $shrink = shift; my $g = $self->{group}; my $first = 0; my $tfirst = 0; if (my $subfeat = $self->{subfeatures}) { for my $list (values %$subfeat) { for my $feat (@$list) { # fix up our bounds to hold largest subfeature my($start,$stop,$strand) = $feat->adjust_bounds($shrink); if (defined($self->{fstrand})) { $self->debug("Subfeature's strand ($strand) doesn't match parent strand ($self->{fstrand})\n") if $self->{fstrand} ne $strand; } else { $self->{fstrand} = $strand; } my ($low,$high) = $start < $stop ? ($start,$stop) : ($stop,$start); if ($shrink && !$first++) { # first subfeature resets start & stop: $self->{start} = $self->{fstrand} ne '-' ? $low : $high; $self->{stop} = $self->{fstrand} ne '-' ? $high : $low; } else { if ($self->{fstrand} ne '-') { $self->{start} = $low if (!defined($self->{start})) || $low < $self->{start}; $self->{stop} = $high if (!defined($self->{stop})) || $high > $self->{stop}; } else { $self->{start} = $high if (!defined($self->{start})) || $high > $self->{start}; $self->{stop} = $low if (!defined($self->{stop})) || $low < $self->{stop}; } } # fix up endpoints of targets too (for homologies only) my $h = $feat->group; next unless $h && $h->isa('Bio::DB::GFF::Homol'); next unless $g && $g->isa('Bio::DB::GFF::Homol'); ($start,$stop) = ($h->{start},$h->{stop}); if ($shrink && !$tfirst++) { $g->{start} = $start; $g->{stop} = $stop; } else { if ($start <= $stop) { $g->{start} = $start if (!defined($g->{start})) || $start < $g->{start}; $g->{stop} = $stop if (!defined($g->{stop})) || $stop > $g->{stop}; } else { $g->{start} = $start if (!defined($g->{start})) || $start > $g->{start}; $g->{stop} = $stop if (!defined($g->{stop})) || $stop < $g->{stop}; } } } } } ($self->{start},$self->{stop},$self->strand); } =head2 sort_features Title : sort_features Usage : $feature->sort_features Function: sort features Returns : nothing Args : none Status : Public This method sorts subfeatures in ascending order by their start position. For reverse strand features, it sorts subfeatures in descending order. After this is called sub_SeqFeature will return the features in order. This method is called internally by merged_segments(). =cut # sort features sub sort_features { my $self = shift; return if $self->{sorted}++; my $strand = $self->strand or return; my $subfeat = $self->{subfeatures} or return; for my $type (keys %$subfeat) { $subfeat->{$type} = [map { $_->[0] } sort {$a->[1] <=> $b->[1] } map { [$_,$_->start] } @{$subfeat->{$type}}] if $strand > 0; $subfeat->{$type} = [map { $_->[0] } sort {$b->[1] <=> $a->[1]} map { [$_,$_->start] } @{$subfeat->{$type}}] if $strand < 0; } } =head2 asString Title : asString Usage : $string = $feature->asString Function: return human-readabled representation of feature Returns : a string Args : none Status : Public This method returns a human-readable representation of the feature and is called by the overloaded "" operator. =cut sub asString { my $self = shift; my $type = $self->type; my $name = $self->group; return "$type($name)" if $name; return $type; # my $type = $self->method; # my $id = $self->group || 'unidentified'; # return join '/',$id,$type,$self->SUPER::asString; } sub name { my $self =shift; return $self->group || $self->SUPER::name; } =head2 gff_string Title : gff_string Usage : $string = $feature->gff_string Function: return GFF2 of GFF2.5 representation of feature Returns : a string Args : none Status : Public =cut sub gff_string { my $self = shift; my $version = $self->version; # gff3_string and gff_string are synonymous if the version is set to 3 return $self->gff3_string(@_) if $version == 3; my ($start,$stop) = ($self->start,$self->stop); # the defined() tests prevent uninitialized variable warnings, when dealing with clone objects # whose endpoints may be undefined ($start,$stop) = ($stop,$start) if defined($start) && defined($stop) && $start > $stop; my ($class,$name) = ('',''); my $strand = ('-','.','+')[$self->strand+1]; my @group; if (my $t = $self->target) { push @group, $version == 2.5 ? $self->flatten_target($t,2.5) : $self->flatten_target($t); } elsif (my $g = $self->group) { $class = $g->class || ''; $name = $g->name || ''; ($name =~ /\S\s\S/)?(push @group, "$class '$name'"):(push @group,"$class $name"); } # add exhaustive list of attributes my $att = $self->attributes; for ( keys %$att ) { for my $v ( @{$att->{$_}} ) { $v = qq("$v") if $v=~ /\S\s+\S/; push @group, qq($_ $v); } } my $group_field = join ' ; ',@group; my $ref = $self->refseq; my $n = ref($ref) ? $ref->name : $ref; my $phase = $self->phase; $phase = '.' unless defined $phase; return join("\t", $n, $self->source,$self->method, (defined $start ? $start : '.'), (defined $stop ? $stop : '.'), (defined $self->score ? $self->score : '.'), (defined $strand ? $strand : '.'), $phase, $group_field); } =head2 gff3_string Title : gff3_string Usage : $string = $feature->gff3_string([$recurse]) Function: return GFF3 representation of feature Returns : a string Args : An optional flag, which if true, will cause the feature to recurse over subfeatures. Status : Public =cut sub gff3_string { my $self = shift; my ($recurse,$parent) = @_; my ($start,$stop) = ($self->start,$self->stop); # the defined() tests prevent uninitialized variable warnings, when dealing with clone objects # whose endpoints may be undefined ($start,$stop) = ($stop,$start) if defined($start) && defined($stop) && $start > $stop; my $strand = ('-','.','+')[$self->strand+1]; my $ref = $self->refseq; my $n = ref($ref) ? $ref->name : $ref; my $phase = $self->phase; $phase = '.' unless defined $phase; my ($class,$name) = ('',''); my @group; if (my $g = $self->group) { $class = $g->class || ''; $name = $g->name || ''; $name = "$class:$name" if defined $class; push @group,[ID => $name] if !defined($parent) || $name ne $parent; } push @group,[Parent => $parent] if defined $parent && $parent ne ''; if (my $t = $self->target) { $strand = '-' if $t->stop < $t->start; push @group, $self->flatten_target($t,3); } my @attributes = $self->attributes; while (@attributes) { push @group,[shift(@attributes),shift(@attributes)] } my $group_field = join ';',map {join '=',_escape($_->[0]),_escape($_->[1])} @group; my $string = join("\t",$n,$self->source,$self->method,$start||'.',$stop||'.', $self->score||'.',$strand||'.',$phase,$group_field); $string .= "\n"; if ($recurse) { foreach ($self->sub_SeqFeature) { $string .= $_->gff3_string(1,$name); } } $string; } =head2 version Title : version Usage : $feature->version() Function: get/set the GFF version to be returned by gff_string Returns : the GFF version (default is 2) Args : the GFF version (2, 2.5 of 3) Status : Public =cut sub version { my ($self, $version) = @_; $self->{version} = $version if $version; return $self->{version} || 2; } sub _escape { my $toencode = shift; $toencode =~ s/([^a-zA-Z0-9_. :?^*\(\)\[\]@!-])/uc sprintf("%%%02x",ord($1))/eg; $toencode =~ tr/ /+/; $toencode; } =head2 cmap_link() Title : cmap_link Usage : $link = $feature->cmap_link Function: returns a URL link to the corresponding feature in cmap Returns : a string Args : none Status : Public If integrated cmap/gbrowse installation, it returns a link to the map otherwise it returns a link to a feature search on the feature name. See the cmap documentation for more information. This function is intended primarily to be used in gbrowse conf files. For example: link = sub {my $self = shift; return $self->cmap_viewer_link(data_source);} =cut sub cmap_viewer_link { # Use ONLY if CMap is installed my $self = shift; my $data_source = shift; my $group_id = $self->group_id; my $factory = $self->factory; # aka adaptor my $link_str; if ($factory->can("create_cmap_viewer_link")){ $link_str = $factory->create_cmap_viewer_link( data_source => $data_source, group_id => $group_id, ); } my $name = $self->name(); $link_str = '/cgi-bin/cmap/feature_search?features=' . $name . '&search_field=feature_name&order_by=&data_source=' . $data_source . '&submit=Submit' unless $link_str; return $link_str; } =head1 A Note About Similarities The current default aggregator for GFF "similarity" features creates a composite Bio::DB::GFF::Feature object of type "gapped_alignment". The target() method for the feature as a whole will return a RelSegment object that is as long as the extremes of the similarity hit target, but will not necessarily be the same length as the query sequence. The length of each "similarity" subfeature will be exactly the same length as its target(). These subfeatures are essentially the HSPs of the match. The following illustrates this: @similarities = $segment->feature('similarity:BLASTN'); $sim = $similarities[0]; print $sim->type; # yields "gapped_similarity:BLASTN" $query_length = $sim->length; $target_length = $sim->target->length; # $query_length != $target_length @matches = $sim->Similarity; # use autogenerated method $query1_length = $matches[0]->length; $target1_length = $matches[0]->target->length; # $query1_length == $target1_length If you merge segments by calling merged_segments(), then the length of the query sequence segments will no longer necessarily equal the length of the targets, because the alignment information will have been lost. Nevertheless, the targets are adjusted so that the first and last base pairs of the query match the first and last base pairs of the target. =cut 1; =head1 BUGS This module is still under development. =head1 SEE ALSO L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Homol.pm000444000765000024 357412254227335 16466 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Homol -- A segment of DNA that is homologous to another =head1 SYNOPSIS See L. =head1 DESCRIPTION Bio::DB::GFF::Homol is a named subtype of Bio::DB::GFF::Segment. It inherits all the methods of its parent, and was created primarily to allow for isa() queries and for compatibility with Ace::Sequence::Homol. A Homol object is typically returned as the method result of the Bio::DB::GFF::Feature-Etarget() method. =head1 METHODS =cut package Bio::DB::GFF::Homol; use strict; use base qw(Bio::DB::GFF::Segment); =head2 name Title : name Usage : $name = $homol->name Function: get the ID of the homology object Returns : a string Args : none Status : Public =cut sub name { shift->refseq } =head2 asString Title : asString Usage : $name = $homol->asString Function: same as name(), for operator overloading Returns : a string Args : none Status : Public =cut sub asString { shift->name } =head2 id Title : id Usage : $id = $homol->id Function: get database ID in class:id format Returns : a string Args : none Status : Public =cut sub id { my $self = shift; return "$self->{class}:$self->{name}"; } sub new_from_segment { my $package = shift; $package = ref $package if ref $package; my $segment = shift; my $new = {}; @{$new}{qw(factory sourceseq start stop strand class ref refstart refstrand)} = @{$segment}{qw(factory sourceseq start stop strand class ref refstart refstrand)}; return bless $new,__PACKAGE__; } =head1 BUGS This module is still under development. =head1 SEE ALSO L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; BioPerl-1.6.923/Bio/DB/GFF/RelSegment.pm000444000765000024 10344512254227336 17514 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::RelSegment -- Sequence segment with relative coordinate support =head1 SYNOPSIS See L. =head1 DESCRIPTION Bio::DB::GFF::RelSegment is a stretch of sequence that can handle relative coordinate addressing. It inherits from Bio::DB::GFF::Segment, and is the base class for Bio::DB::GFF::Feature. In addition to the source sequence, a relative segment has a "reference sequence", which is used as the basis for its coordinate system. The reference sequence can be changed at will, allowing you freedom to change the "frame of reference" for features contained within the segment. For example, by setting a segment's reference sequence to the beginning of a gene, you can view all other features in gene-relative coordinates. The reference sequence and the source sequence must be on the same physical stretch of DNA, naturally. However, they do not have to be on the same strand. The strandedness of the reference sequence determines whether coordinates increase to the right or the left. Generally, you will not create or manipulate Bio::DB::GFF::RelSeg0ment objects directly, but use those that are returned by the Bio::DB::GFF module. =head2 An Example To understand how relative coordinates work, consider the following example from the C. elegans database. First we create the appropriate GFF accessor object (the factory): my $db = Bio::DB::GFF->new(-dsn => 'dbi:mysql:elegans', -adaptor=>'dbi:mysqlopt'); Now we fetch out a segment based on cosmid clone ZK909: my $seg = $db->segment('ZK909'); If we call the segment's refseq() method, we see that the base of the coordinate system is the sequence "ZK154", and that its start and stop positions are 1 and the length of the cosmid: print $seg->refseq; => ZK909 print $seg->start,' - ',$seg->stop; => 1 - 33782 As a convenience, the "" operator is overloaded in this class, to give the reference sequence, and start and stop positions: print $seg; => ZK909:1,33782 Internally, Bio::DB::GFF::RelSegment has looked up the absolute coordinates of this segment and maintains the source sequence and the absolute coordinates relative to the source sequence. We can see this information using sourceseq() (inherited from Bio::DB::GFF::Segment) and the abs_start() and abs_end() methods: print $seg->sourceseq; => CHROMOSOME_I print $seg->abs_start,' - ',$seg->abs_end; => 14839545 - 14873326 We can also put the segment into absolute mode, so that it behaves like Bio::DB::Segment, and always represents coordinates on the source sequence. This is done by passing a true value to the absolute() method: $seq->absolute(1); print $seg; => CHROMOSOME_I:14839545,14873326 We can change the reference sequence at any time. One way is to call the segment's ref() method, giving it the ID (and optionally the class) of another landmark on the genome. For example, if we know that cosmid ZK337 is adjacent to ZK909, then we can view ZK909 in ZK337-relative coordinates: $seg->refseq('ZK337'); print $seg; => ZK337:-33670,111 We can call the segment's features() method in order to get the list of contigs that overlap this segment (in the C. elegans database, contigs have feature type "Sequence:Link"): @links = $seg->features('Sequence:Link'); We can now set the reference sequence to the first of these contigs like so: $seg->refseq($links[0]); print $seg; => Sequence:Link(LINK_Y95D11A):3997326,4031107 =cut package Bio::DB::GFF::RelSegment; use strict; use Bio::DB::GFF::Feature; use Bio::DB::GFF::Util::Rearrange; use Bio::RangeI; use base qw(Bio::DB::GFF::Segment); use overload '""' => 'asString', 'bool' => sub { overload::StrVal(shift) }, fallback=>1; =head1 API The remainder of this document describes the API for Bio::DB::GFF::Segment. =cut =head2 new Title : new Usage : $s = Bio::DB::GFF::RelSegment->new(@args) Function: create a new relative segment Returns : a new Bio::DB::GFF::RelSegment object Args : see below Status : Public This method creates a new Bio::DB::GFF::RelSegment object. Generally this is called automatically by the Bio::DB::GFF module and derivatives. This function uses a named-argument style: -factory a Bio::DB::GFF::Adaptor to use for database access -seq ID of the source sequence -class class of the source sequence -start start of the desired segment relative to source sequence -stop stop of the desired segment relative to source sequence -ref ID of the reference sequence -refclass class of the reference sequence -offset 0-based offset from source sequence to start of segment -length length of desired segment -absolute, -force_absolute use absolute coordinates, rather than coordinates relative to the start of self or the reference sequence The -seq argument accepts the ID of any landmark in the database. The stored source sequence becomes whatever the GFF file indicates is the proper sequence for this landmark. A class of "Sequence" is assumed unless otherwise specified in the -class argument. If the argument to -seq is a Bio::GFF::Featname object (such as returned by the group() method), then the class is taken from that. The optional -start and -stop arguments specify the end points for the retrieved segment. For those who do not like 1-based indexing, -offset and -length are provided. If both -start/-stop and -offset/-length are provided, the latter overrides the former. Generally it is not a good idea to mix metaphors. -ref and -refclass together indicate a sequence to be used for relative coordinates. If not provided, the source sequence indicated by -seq is used as the reference sequence. If the argument to -ref is a Bio::GFF::Featname object (such as returned by the group() method), then the class is taken from that. -force_absolute should be used if you wish to skip the lookup of the absolute position of the source sequence that ordinarily occurs when you create a relative segment. In this case, the source sequence must be a sequence that has been specified as the "source" in the GFF file. =cut # Create a new Bio::DB::GFF::RelSegment Object # arguments are: # -factory => factory and DBI interface # -seq => $sequence_name # -start => $start_relative_to_sequence # -stop => $stop_relative_to_sequence # -ref => $sequence which establishes coordinate system # -offset => 0-based offset relative to sequence # -length => length of segment # -nocheck => turn off checking, force segment to be constructed # -absolute => use absolute coordinate addressing sub new { my $package = shift; my ($factory,$name,$start,$stop,$refseq,$class,$refclass,$offset,$length,$force_absolute,$nocheck) = rearrange([ 'FACTORY', [qw(NAME SEQ SEQUENCE SOURCESEQ)], [qw(START BEGIN)], [qw(STOP END)], [qw(REFSEQ REF REFNAME)], [qw(CLASS SEQCLASS)], qw(REFCLASS), [qw(OFFSET OFF)], [qw(LENGTH LEN)], [qw(ABSOLUTE)], [qw(NOCHECK FORCE)], ],@_); $package = ref $package if ref $package; $factory or $package->throw("new(): provide a -factory argument"); # to allow people to use segments as sources if (ref($name) && $name->isa('Bio::DB::GFF::Segment')) { $start = 1 unless defined $start; $stop = $name->length unless defined $stop; return $name->subseq($start,$stop); } my @object_results; # support for Featname objects if (ref($name) && $name->can('class')) { $class = $name->class; $name = $name->name; } # if the class of the landmark is not specified then default to 'Sequence' $class ||= eval{$factory->default_class} || 'Sequence'; # confirm that indicated sequence is actually in the database! my @abscoords; # abscoords() will now return an array ref, each element of which is # ($absref,$absclass,$absstart,$absstop,$absstrand) if ($nocheck) { $force_absolute++; $start = 1; } # if ($force_absolute && defined($start)) { # absolute position is given to us # @abscoords = ([$name,$class,$start,$stop,'+']); # } else { my $result = $factory->abscoords($name,$class,$force_absolute ? $name : ()) or return; @abscoords = @$result; # } foreach (@abscoords) { my ($absref,$absclass,$absstart,$absstop,$absstrand,$sname) = @$_; $sname = $name unless defined $sname; my ($this_start,$this_stop,$this_length) = ($start,$stop,$length); # partially fill in object my $self = bless { factory => $factory },$package; $absstrand ||= '+'; if ($absstart > $absstop) { # AAARGH! DATA FORMAT ERROR! FIX. ($absstart,$absstop) = ($absstop,$absstart); $absstrand = $absstrand eq '+' ? '-' : '+'; } # an explicit length overrides start and stop if (defined $offset) { warn "new(): bad idea to call new() with both a start and an offset" if defined $this_start; $this_start = $offset+1; } if (defined $this_length) { warn "new(): bad idea to call new() with both a stop and a length" if defined $this_stop; $this_stop = $this_start + $length - 1; } # this allows a SQL optimization way down deep $self->{whole}++ if $absref eq $sname and !defined($this_start) and !defined($this_stop); $this_start = 1 if !defined $this_start; $this_stop = $absstop-$absstart+1 if !defined $this_stop; $this_length = $this_stop - $this_start + 1; # now offset to correct subsegment based on desired start and stop if ($force_absolute) { # ($this_start,$this_stop) = ($absstart,$absstop); $self->absolute(1); } elsif ($absstrand eq '+') { $this_start = $absstart + $this_start - 1; $this_stop = $this_start + $this_length - 1; } else { $this_start = $absstop - ($this_start - 1); $this_stop = $absstop - ($this_stop - 1); } # handle truncation in either direction # This only happens if the segment runs off the end of # the reference sequence if ($factory->strict_bounds_checking && (($this_start < $absstart) || ($this_stop > $absstop))) { # return empty if we are completely off the end of the ref se next unless $this_start<=$absstop && $this_stop>=$absstart; if (my $a = $factory->abscoords($absref,'Sequence')) { my $refstart = $a->[0][2]; my $refstop = $a->[0][3]; if ($this_start < $refstart) { $this_start = $refstart; $self->{truncated}{start}++; } if ($this_stop > $refstop) { $this_stop = $absstop; $self->{truncated}{stop}++; } } } @{$self}{qw(sourceseq start stop strand class)} = ($absref,$this_start,$this_stop,$absstrand,$absclass); # handle reference sequence if (defined $refseq) { $refclass = $refseq->class if $refseq->can('class'); $refclass ||= 'Sequence'; my ($refref,$refstart,$refstop,$refstrand) = $factory->abscoords($refseq,$refclass); unless ($refref eq $absref) { $self->error("reference sequence is on $refref but source sequence is on $absref"); return; } $refstart = $refstop if $refstrand eq '-'; @{$self}{qw(ref refstart refstrand)} = ($refseq,$refstart,$refstrand); } else { $absstart = $absstop if $absstrand eq '-'; @{$self}{qw(ref refstart refstrand)} = ($sname,$absstart,$absstrand); } push @object_results,$self; } return wantarray ? @object_results : $object_results[0]; } # overridden methods # start, stop, length sub start { my $self = shift; return $self->strand < 0 ? $self->{stop} : $self->{start} if $self->absolute; $self->_abs2rel($self->{start}); } sub end { my $self = shift; return $self->strand < 0 ? $self->{start} : $self->{stop} if $self->absolute; $self->_abs2rel($self->{stop}); } *stop = \&end; sub length { my $self = shift; return unless defined $self->abs_end; abs($self->abs_end - $self->abs_start) + 1; } sub abs_start { my $self = shift; if ($self->absolute) { my ($a,$b) = ($self->SUPER::abs_start,$self->SUPER::abs_end); return ($a<$b) ? $a : $b; } else { return $self->SUPER::abs_start(@_); } } sub abs_end { my $self = shift; if ($self->absolute) { my ($a,$b) = ($self->SUPER::abs_start,$self->SUPER::abs_end); return ($a>$b) ? $a : $b; } else { return $self->SUPER::abs_end(@_); } } *abs_stop = \&abs_end; =head2 refseq Title : refseq Usage : $ref = $s->refseq([$newseq] [,$newseqclass]) Function: get/set reference sequence Returns : current reference sequence Args : new reference sequence and class (optional) Status : Public This method will get or set the reference sequence. Called with no arguments, it returns the current reference sequence. Called with either a sequence ID and class, a Bio::DB::GFF::Segment object (or subclass) or a Bio::DB::GFF::Featname object, it will set the current reference sequence and return the previous one. The method will generate an exception if you attempt to set the reference sequence to a sequence that isn't contained in the database, or one that has a different source sequence from the segment. =cut #' sub refseq { my $self = shift; my $g = $self->{ref}; if (@_) { my ($newref,$newclass); if (@_ == 2) { $newclass = shift; $newref = shift; } else { $newref = shift; $newclass = 'Sequence'; } defined $newref or $self->throw('refseq() called with an undef reference sequence'); # support for Featname objects $newclass = $newref->class if ref($newref) && $newref->can('class'); # $self->throw("Cannot define a segment's reference sequence in terms of itself!") # if ref($newref) and overload::StrVal($newref) eq overload::StrVal($self); my ($refsource,undef,$refstart,$refstop,$refstrand); if ($newref->isa('Bio::DB::GFF::RelSegment')) { ($refsource,undef,$refstart,$refstop,$refstrand) = ($newref->sourceseq,undef,$newref->abs_start,$newref->abs_end,$newref->abs_strand >= 0 ? '+' : '-'); } else { my $coords = $self->factory->abscoords($newref,$newclass); foreach (@$coords) { # find the appropriate one ($refsource,undef,$refstart,$refstop,$refstrand) = @$_; last if $refsource eq $self->{sourceseq}; } } $self->throw("can't set reference sequence: $newref and $self are on different sequence segments") unless $refsource eq $self->{sourceseq}; @{$self}{qw(ref refstart refstrand)} = ($newref,$refstart,$refstrand); $self->absolute(0); } return $self->absolute ? $self->sourceseq : $g; } =head2 abs_low Title : abs_low Usage : $s->abs_low Function: the absolute lowest coordinate of the segment Returns : an integer Args : none Status : Public This is for GadFly compatibility, and returns the low coordinate in absolute coordinates; =cut sub abs_low { my $self = shift; my ($a,$b) = ($self->abs_start,$self->abs_end); return ($a<$b) ? $a : $b; } =head2 abs_high Title : abs_high Usage : $s->abs_high Function: the absolute highest coordinate of the segment Returns : an integer Args : none Status : Public This is for GadFly compatibility, and returns the high coordinate in absolute coordinates; =cut sub abs_high { my $self = shift; my ($a,$b) = ($self->abs_start,$self->abs_end); return ($a>$b) ? $a : $b; } =head2 asString Title : asString Usage : $s->asString Function: human-readable representation of the segment Returns : a string Args : none Status : Public This method will return a human-readable representation of the segment. It is the overloaded method call for the "" operator. Currently the format is: refseq:start,stop =cut sub asString { my $self = shift; return $self->SUPER::asString if $self->absolute; my $label = $self->{ref}; my $start = $self->start || ''; my $stop = $self->stop || ''; if (ref($label) && overload::StrVal($self) eq overload::StrVal($label->ref)) { $label = $self->abs_ref; $start = $self->abs_start; $stop = $self->abs_end; } return "$label:$start,$stop"; } =head2 name Title : name Usage : Alias for asString() =cut sub name { shift->asString } =head2 absolute Title : absolute Usage : $abs = $s->absolute([$abs]) Function: get/set absolute coordinates Returns : a boolean flag Args : new setting for flag (optional) Status : Public Called with a boolean flag, this method controls whether to display relative coordinates (relative to the reference sequence) or absolute coordinates (relative to the source sequence). It will return the previous value of the setting. =cut sub absolute { my $self = shift; my $g = $self->{absolute}; $self->{absolute} = shift if @_; $g; } =head2 features Title : features Usage : @features = $s->features(@args) Function: get features that overlap this segment Returns : a list of Bio::DB::GFF::Feature objects Args : see below Status : Public This method will find all features that overlap the segment and return a list of Bio::DB::GFF::Feature objects. The features will use coordinates relative to the reference sequence in effect at the time that features() was called. The returned list can be limited to certain types of feature by filtering on their method and/or source. In addition, it is possible to obtain an iterator that will step through a large number of features sequentially. Arguments can be provided positionally or using the named arguments format. In the former case, the arguments are a list of feature types in the format "method:source". Either method or source can be omitted, in which case the missing component is treated as a wildcard. If no colon is present, then the type is treated as a method name. Multiple arguments are ORed together. Examples: @f = $s->features('exon:curated'); # all curated exons @f = $s->features('exon:curated','intron'); # curated exons and all introns @f = $s->features('similarity:.*EST.*'); # all similarities # having something to do # with ESTs The named parameter form gives you control over a few options: -types an array reference to type names in the format "method:source" -merge Whether to apply aggregators to the generated features (default yes) -rare Turn on an optimization suitable for a relatively rare feature type, where it will be faster to filter by feature type first and then by position, rather than vice versa. -attributes a hashref containing a set of attributes to match -range_type One of 'overlapping', 'contains', or 'contained_in' -iterator Whether to return an iterator across the features. -binsize A true value will create a set of artificial features whose start and stop positions indicate bins of the given size, and whose scores are the number of features in the bin. The class and method of the feature will be set to "bin", its source to "method:source", and its group to "bin:method:source". This is a handy way of generating histograms of feature density. -merge is a boolean flag that controls whether the adaptor's aggregators wll be applied to the features returned by this method. If -iterator is true, then the method returns a single scalar value consisting of a Bio::SeqIO object. You can call next_seq() repeatedly on this object to fetch each of the features in turn. If iterator is false or absent, then all the features are returned as a list. The -attributes argument is a hashref containing one or more attributes to match against: -attributes => { Gene => 'abc-1', Note => 'confirmed' } Attribute matching is simple string matching, and multiple attributes are ANDed together. =cut #' # return all features that overlap with this segment; # optionally modified by a list of types to filter on sub features { my $self = shift; my @args = $self->_process_feature_args(@_); return $self->factory->overlapping_features(@args); } =head2 get_SeqFeatures Title : get_SeqFeatures Usage : Function: returns the top level sequence features Returns : L objects Args : none Segments do not ordinarily return any subfeatures. =cut # A SEGMENT DOES NOT HAVE SUBFEATURES! sub get_SeqFeatures { return } =head2 feature_count Title : feature_count Usage : $seq->feature_count() Function: Return the number of SeqFeatures attached to a sequence Returns : integer representing the number of SeqFeatures Args : none This method comes through extension of Bio::FeatureHolderI. See L for more information. =cut sub feature_count { my $self = shift; my $ct = 0; my %type_counts = $self->types(-enumerate=>1); map { $ct += $_ } values %type_counts; $ct; } =head2 get_feature_stream Title : features Usage : $stream = $s->get_feature_stream(@args) Function: get a stream of features that overlap this segment Returns : a Bio::SeqIO::Stream-compliant stream Args : see below Status : Public This is the same as features(), but returns a stream. Use like this: $stream = $s->get_feature_stream('exon'); while (my $exon = $stream->next_seq) { print $exon->start,"\n"; } =cut sub get_feature_stream { my $self = shift; my @args = defined($_[0]) && $_[0] =~ /^-/ ? (@_,-iterator=>1) : (-types=>\@_,-iterator=>1); $self->features(@args); } =head2 get_seq_stream Title : get_seq_stream Usage : $stream = $s->get_seq_stream(@args) Function: get a stream of features that overlap this segment Returns : a Bio::SeqIO::Stream-compliant stream Args : see below Status : Public This is the same as feature_stream(), and is provided for Bioperl compatibility. Use like this: $stream = $s->get_seq_stream('exon'); while (my $exon = $stream->next_seq) { print $exon->start,"\n"; } =cut *get_seq_stream = \&get_feature_stream; =head2 overlapping_features Title : overlapping_features Usage : @features = $s->overlapping_features(@args) Function: get features that overlap this segment Returns : a list of Bio::DB::GFF::Feature objects Args : see features() Status : Public This is an alias for the features() method, and takes the same arguments. =cut *overlapping_features = \&features; =head2 contained_features Title : contained_features Usage : @features = $s->contained_features(@args) Function: get features that are contained by this segment Returns : a list of Bio::DB::GFF::Feature objects Args : see features() Status : Public This is identical in behavior to features() except that it returns only those features that are completely contained within the segment, rather than any that overlap. =cut # return all features completely contained within this segment sub contained_features { my $self = shift; local $self->{whole} = 0; my @args = $self->_process_feature_args(@_); return $self->factory->contained_features(@args); } # *contains = \&contained_features; =head2 contained_in Title : contained_in Usage : @features = $s->contained_in(@args) Function: get features that contain this segment Returns : a list of Bio::DB::GFF::Feature objects Args : see features() Status : Public This is identical in behavior to features() except that it returns only those features that completely contain the segment. =cut # return all features completely contained within this segment sub contained_in { my $self = shift; local $self->{whole} = 0; my @args = $self->_process_feature_args(@_); return $self->factory->contained_in(@args); } =head2 delete Title : delete Usage : $db->delete(@args) Function: delete features Returns : count of features deleted -- if available Args : numerous, see below Status : public This method deletes all features that overlap the specified region or are of a particular type. If no arguments are provided and the -force argument is true, then deletes ALL features. Arguments: -type,-types Either a single scalar type to be deleted, or an reference to an array of types. -range_type Control the range type of the deletion. One of "overlaps" (default) "contains" or "contained_in" Examples: $segment->delete(-type=>['intron','repeat:repeatMasker']); # remove all introns & repeats $segment->delete(-type=>['intron','repeat:repeatMasker'] -range_type => 'contains'); # remove all introns & repeats # strictly contained in segment IMPORTANT NOTE: This method only deletes features. It does *NOT* delete the names of groups that contain the deleted features. Group IDs will be reused if you later load a feature with the same group name as one that was previously deleted. NOTE ON FEATURE COUNTS: The DBI-based versions of this call return the result code from the SQL DELETE operation. Some dbd drivers return the count of rows deleted, while others return 0E0. Caveat emptor. =cut # return all features completely contained within this segment sub delete { my $self = shift; my ($type,$range_type) = rearrange([[qw(TYPE TYPES)],'RANGE_TYPE'],@_); my $types = $self->factory->parse_types($type); # parse out list of types $range_type ||= 'overlaps'; return $self->factory->_delete({ segments => [$self], types => $types, range_type => $range_type }); } =head2 _process_feature_args Title : _process_feature_args Usage : @args = $s->_process_feature_args(@args) Function: preprocess arguments passed to features, contained_features, and overlapping_features Returns : a list of parsed arguents Args : see feature() Status : Internal This is an internal method that is used to check and format the arguments to features() before passing them on to the adaptor. =cut sub _process_feature_args { my $self = shift; my ($ref,$class,$start,$stop,$strand,$whole) = @{$self}{qw(sourceseq class start stop strand whole)}; ($start,$stop) = ($stop,$start) if defined $strand && $strand eq '-'; my @args = (-ref=>$ref,-class=>$class); # indicating that we are fetching the whole segment allows certain # SQL optimizations. push @args,(-start=>$start,-stop=>$stop) unless $whole; if (@_) { if ($_[0] =~ /^-/) { push @args,@_; } else { my @types = @_; push @args,-types=>\@types; } } push @args,-parent=>$self; @args; } =head2 types Title : types Usage : @types = $s->types([-enumerate=>1]) Function: list feature types that overlap this segment Returns : a list of Bio::DB::GFF::Typename objects or a hash Args : see below Status : Public The types() method will return a list of Bio::DB::GFF::Typename objects, each corresponding to a feature that overlaps the segment. If the optional -enumerate parameter is set to a true value, then the method will return a hash in which the keys are the type names and the values are the number of times a feature of that type is present on the segment. For example: %count = $s->types(-enumerate=>1); =cut # wrapper for lower-level types() call. sub types { my $self = shift; my ($ref,$class,$start,$stop,$strand) = @{$self}{qw(sourceseq class start stop strand)}; ($start,$stop) = ($stop,$start) if $strand eq '-'; my @args; if (@_ && $_[0] !~ /^-/) { @args = (-type => \@_) } else { @args = @_; } $self->factory->types(-ref => $ref, -start=> $start, -stop => $stop, @args); } =head1 Internal Methods The following are internal methods and should not be called directly. =head2 new_from_segment Title : new_from_segment Usage : $s = $segment->new_from_segment(@args) Function: create a new relative segment Returns : a new Bio::DB::GFF::RelSegment object Args : see below Status : Internal This constructor is used internally by the subseq() method. It forces the new segment into the Bio::DB::GFF::RelSegment package, regardless of the package that it is called from. This causes subclass-specfic information, such as feature types, to be dropped when a subsequence is created. =cut sub new_from_segment { my $package = shift; $package = ref $package if ref $package; my $segment = shift; my $new = {}; @{$new}{qw(factory sourceseq start stop strand class ref refstart refstrand)} = @{$segment}{qw(factory sourceseq start stop strand class ref refstart refstrand)}; return bless $new,__PACKAGE__; } =head2 _abs2rel Title : _abs2rel Usage : @coords = $s->_abs2rel(@coords) Function: convert absolute coordinates into relative coordinates Returns : a list of relative coordinates Args : a list of absolute coordinates Status : Internal This is used internally to map from absolute to relative coordinates. It does not take the offset of the reference sequence into account, so please use abs2rel() instead. =cut sub _abs2rel { my $self = shift; my @result; return unless defined $_[0]; if ($self->absolute) { @result = @_; } else { my ($refstart,$refstrand) = @{$self}{qw(refstart refstrand)}; @result = defined($refstrand) && $refstrand eq '-' ? map { $refstart - $_ + 1 } @_ : map { $_ - $refstart + 1 } @_; } # if called with a single argument, caller will expect a single scalar reply # not the size of the returned array! return $result[0] if @result == 1 and !wantarray; @result; } =head2 rel2abs Title : rel2abs Usage : @coords = $s->rel2abs(@coords) Function: convert relative coordinates into absolute coordinates Returns : a list of absolute coordinates Args : a list of relative coordinates Status : Public This function takes a list of positions in relative coordinates to the segment, and converts them into absolute coordinates. =cut sub rel2abs { my $self = shift; my @result; if ($self->absolute) { @result = @_; } else { my ($abs_start,$abs_strand) = ($self->abs_start,$self->abs_strand); @result = $abs_strand < 0 ? map { $abs_start - $_ + 1 } @_ : map { $_ + $abs_start - 1 } @_; } # if called with a single argument, caller will expect a single scalar reply # not the size of the returned array! return $result[0] if @result == 1 and !wantarray; @result; } =head2 abs2rel Title : abs2rel Usage : @rel_coords = $s->abs2rel(@abs_coords) Function: convert absolute coordinates into relative coordinates Returns : a list of relative coordinates Args : a list of absolute coordinates Status : Public This function takes a list of positions in absolute coordinates and returns a list expressed in relative coordinates. =cut sub abs2rel { my $self = shift; my @result; if ($self->absolute) { @result = @_; } else { my ($abs_start,$abs_strand) = ($self->abs_start,$self->abs_strand); @result = $abs_strand < 0 ? map { $abs_start - $_ + 1 } @_ : map { $_ - $abs_start + 1 } @_; } # if called with a single argument, caller will expect a single scalar reply # not the size of the returned array! return $result[0] if @result == 1 and !wantarray; @result; } sub subseq { my $self = shift; my $obj = $self->SUPER::subseq(@_); bless $obj,__PACKAGE__; # always bless into the generic RelSegment package } sub strand { my $self = shift; if ($self->absolute) { return _to_strand($self->{strand}); } my $start = $self->start; my $stop = $self->stop; return 0 unless defined $start and defined $stop; return $stop <=> $start; } sub _to_strand { my $s = shift; return -1 if $s eq '-'; return +1 if $s eq '+'; return 0; } =head2 Bio::RangeI Methods The following Bio::RangeI methods are supported: overlaps(), contains(), equals(),intersection(),union(),overlap_extent() =cut sub intersection { my $self = shift; my (@ranges) = @_; unshift @ranges,$self if ref $self; $ranges[0]->isa('Bio::DB::GFF::RelSegment') or return $self->SUPER::intersection(@_); my $ref = $ranges[0]->abs_ref; my ($low,$high); foreach (@ranges) { return unless $_->can('abs_ref'); $ref eq $_->abs_ref or return; $low = $_->abs_low if !defined($low) or $low < $_->abs_low; $high = $_->abs_high if !defined($high) or $high > $_->abs_high; } return unless $low < $high; return Bio::DB::GFF::RelSegment->new(-factory => $self->factory, -seq => $ref, -start => $low, -stop => $high, ); } sub overlaps { my $self = shift; my($other,$so) = @_; return $self->SUPER::overlaps(@_) unless $other->isa('Bio::DB::GFF::RelSegment'); return if $self->abs_ref ne $other->abs_ref; return if $self->abs_low > $other->abs_high; return if $self->abs_high < $other->abs_low; 1; } sub contains { my $self = shift; my($other,$so) = @_; return $self->SUPER::overlaps(@_) unless $other->isa('Bio::DB::GFF::RelSegment'); return if $self->abs_ref ne $other->abs_ref; return unless $self->abs_low <= $other->abs_low; return unless $self->abs_high >= $other->abs_high; 1; } sub union { my $self = shift; my (@ranges) = @_; unshift @ranges,$self if ref $self; $ranges[0]->isa('Bio::DB::GFF::RelSegment') or return $self->SUPER::union(@_); my $ref = $ranges[0]->abs_ref; my ($low,$high); foreach (@ranges) { return unless $_->can('abs_ref'); $ref eq $_->abs_ref or return; $low = $_->abs_low if !defined($low) or $low > $_->abs_low; $high = $_->abs_high if !defined($high) or $high < $_->abs_high; } $self->new(-factory=> $self->factory, -seq => $ref, -start => $low, -stop => $high); } sub version { 0 } 1; __END__ =head1 BUGS Schemas need some work. =head1 SEE ALSO L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Segment.pm000444000765000024 4503412254227320 17021 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Segment -- Simple DNA segment object =head1 SYNOPSIS See L. =head1 DESCRIPTION Bio::DB::GFF::Segment provides the basic representation of a range of DNA contained in a GFF database. It is the base class from which the Bio::DB::GFF::RelSegment and Bio::DB::GFF::Feature classes are derived. Generally, you will not create or manipulate Bio::DB::GFF::Segment objects directly, but use those that are returned by the Bio::DB::GFF module. =cut package Bio::DB::GFF::Segment; use strict; use Bio::Annotation::Collection; use base qw(Bio::Root::Root Bio::RangeI Bio::SeqI Bio::Das::SegmentI); use overload '""' => 'asString', eq => 'equals', fallback => 1; =head1 API The remainder of this document describes the API for Bio::DB::GFF::Segment. =cut =head2 new Title : new Usage : $s = Bio::DB::GFF::Segment->new(@args) Function: create a new segment Returns : a new Bio::DB::GFF::Segment object Args : see below Status : Public This method creates a new Bio::DB::GFF::Segment object. Generally this is called automatically by the Bio::DB::GFF module and derivatives. There are five positional arguments: $factory a Bio::DB::GFF::Adaptor to use for database access $sourceseq ID of the source sequence $sourceclass class of the source sequence $start start of the desired segment relative to source sequence $stop stop of the desired segment relative to source sequence =cut sub new { my $class = shift; my ($factory,$segclass,$segname,$start,$stop) = @_; $segclass = $segname->class if ref($segname) && $segname->can('class'); $segclass ||= 'Sequence'; $factory or $class->throw("->new(): provide a factory argument"); $class = ref $class if ref $class; return bless { factory => $factory, sourceseq => $segname, class => $segclass, start => $start, stop => $stop, strand => 0, },$class; } # read-only accessors =head2 factory Title : factory Usage : $s->factory Function: get the factory object Returns : a Bio::DB::GFF::Adaptor Args : none Status : Public This is a read-only accessor for the Bio::DB::GFF::Adaptor object used to create the segment. =cut sub factory { shift->{factory} } # start, stop, length =head2 start Title : start Usage : $s->start Function: start of segment Returns : integer Args : none Status : Public This is a read-only accessor for the start of the segment. =cut sub start { shift->{start} } =head2 end Title : end Usage : $s->end Function: end of segment Returns : integer Args : none Status : Public This is a read-only accessor for the end of the segment. =cut sub end { shift->{stop} } =head2 stop Title : stop Usage : $s->stop Function: stop of segment Returns : integer Args : none Status : Public This is an alias for end(), provided for AcePerl compatibility. =cut *stop = \&end; =head2 length Title : length Usage : $s->length Function: length of segment Returns : integer Args : none Status : Public Returns the length of the segment. Always a positive number. =cut sub length { abs($_[0]->{start} - $_[0]->{stop})+1 } =head2 strand Title : strand Usage : $s->strand Function: strand of segment Returns : +1,0,-1 Args : none Status : Public Returns the strand on which the segment resides, either +1, 0 or -1. =cut sub strand { my $self = shift; 0; } =head2 low Title : low Usage : $s->low Function: return lower coordinate Returns : lower coordinate Args : none Status : Public Returns the lower coordinate, either start or end. =cut sub low { my $self = shift; my ($start,$stop) = ($self->start,$self->stop); return $start < $stop ? $start : $stop; } *abs_low = \&low; =head2 high Title : high Usage : $s->high Function: return higher coordinate Returns : higher coordinate Args : none Status : Public Returns the higher coordinate, either start or end. =cut sub high { my $self = shift; my ($start,$stop) = ($self->start,$self->stop); return $start > $stop ? $start : $stop; } *abs_high = \&high; =head2 sourceseq Title : sourceseq Usage : $s->sourceseq Function: get the segment source Returns : a string Args : none Status : Public Returns the name of the source sequence for this segment. =cut sub sourceseq { shift->{sourceseq} } =head2 class Title : class Usage : $s->class([$newclass]) Function: get the source sequence class Returns : a string Args : new class (optional) Status : Public Gets or sets the class for the source sequence for this segment. =cut sub class { my $self = shift; my $d = $self->{class}; $self->{class} = shift if @_; $d; } =head2 subseq Title : subseq Usage : $s->subseq($start,$stop) Function: generate a subsequence Returns : a Bio::DB::GFF::Segment object Args : start and end of subsequence Status : Public This method generates a new segment from the start and end positions given in the arguments. If stop E start, then the strand is reversed. =cut sub subseq { my $self = shift; my ($newstart,$newstop) = @_; my ($refseq,$start,$stop,$class) = ($self->{sourceseq}, $self->{start},$self->{stop}, $self->class); # We deliberately force subseq to return objects of type RelSegment # Otherwise, when we get a subsequence from a Feature object, # its method and source go along for the ride, which is incorrect. my $new = $self->new_from_segment($self); if ($start <= $stop) { @{$new}{qw(start stop)} = ($start + $newstart - 1, $start + $newstop - 1); } else { @{$new}{qw(start stop)} = ($start - ($newstart - 1), $start - ($newstop - 1)), } $new; } =head2 seq Title : seq Usage : $s->seq Function: get the sequence string for this segment Returns : a Bio::PrimarySeq Args : none Status : Public Returns the sequence for this segment as a Bio::PrimarySeq. (-) strand segments are automatically reverse complemented The method is called dna() return the data as a simple sequence string. =cut sub seq { my $self = shift; my $dna = $self->dna; require Bio::PrimarySeq unless Bio::PrimarySeq->can('new'); return Bio::PrimarySeq->new(-id => $self->display_name) unless $dna; return Bio::PrimarySeq->new(-seq => $dna, -id => $self->display_name); } =head2 dna Title : dna Usage : $s->dna Function: get the DNA string for this segment Returns : a string Args : none Status : Public Returns the sequence for this segment as a simple string. (-) strand segments are automatically reverse complemented The method is also called protein(). =cut sub dna { my $self = shift; my ($ref,$class,$start,$stop,$strand) = @{$self}{qw(sourceseq class start stop strand)}; return $self->factory->dna($ref,$start,$stop,$class); } *protein = \&dna; =head2 primary_seq Title : primary_seq Usage : $s->primary_seq Function: returns a Bio::PrimarySeqI compatible object Returns : a Bio::PrimarySeqI object Args : none Status : Public This is for compatibility with BioPerl's separation of SeqI from PrimarySeqI. It just returns itself. =cut #' sub primary_seq { shift } =head2 type Title : type Usage : $s->type Function: return the string "feature" Returns : the string "feature" Args : none Status : Public This is for future sequence ontology-compatibility and represents the default type of a feature on the genome =cut sub type { "feature" } =head2 equals Title : equals Usage : $s->equals($d) Function: segment equality Returns : true, if two segments are equal Args : another segment Status : Public Returns true if the two segments have the same source sequence, start and stop. =cut sub equals { my $self = shift; my $peer = shift; return unless defined $peer; return $self->asString eq $peer unless ref($peer) && $peer->isa('Bio::DB::GFF::Segment'); return $self->{start} eq $peer->{start} && $self->{stop} eq $peer->{stop} && $self->{sourceseq} eq $peer->{sourceseq}; } =head2 asString Title : asString Usage : $s->asString Function: human-readable string for segment Returns : a string Args : none Status : Public Returns a human-readable string representing this sequence. Format is: sourceseq/start,stop =cut sub asString { my $self = shift; my $label = $self->refseq; my $start = $self->start; my $stop = $self->stop; return "$label:$start,$stop"; } =head2 clone Title : clone Usage : $copy = $s->clone Function: make a copy of this segment Returns : a Bio::DB::GFF::Segment object Args : none Status : Public This method creates a copy of the segment and returns it. =cut # deep copy of the thing sub clone { my $self = shift; my %h = %$self; return bless \%h,ref($self); } =head2 error Title : error Usage : $error = $s->error([$new_error]) Function: get or set the last error Returns : a string Args : an error message (optional) Status : Public In case of a fault, this method can be used to obtain the last error message. Internally it is called to set the error message. =cut sub error { my $self = shift; my $g = $self->{error}; $self->{error} = shift if @_; $g; } =head1 Relative Addressing Methods The following methods are provided for compatibility with Bio::DB::GFF::RelSegment, which provides relative addressing functions. =head2 abs_start Title : abs_start Usage : $s->abs_start Function: the absolute start of the segment Returns : an integer Args : none Status : Public This is an alias to start(), and provided for API compatibility with Bio::DB::GFF::RelSegment. =cut *abs_start = \&start; =head2 abs_end Title : abs_end Usage : $s->abs_end Function: the absolute stop of the segment Returns : an integer Args : none Status : Public This is an alias to stop(), and provided for API compatibility with Bio::DB::GFF::RelSegment. =cut *abs_stop = \&stop; *abs_end = \&stop; =head2 abs_strand Title : abs_strand Usage : $s->abs_strand Function: the absolute strand of the segment Returns : +1,0,-1 Args : none Status : Public This is an alias to strand(), and provided for API compatibility with Bio::DB::GFF::RelSegment. =cut sub abs_strand { my $self = shift; return $self->abs_end <=> $self->abs_start; } =head2 abs_ref Title : abs_ref Usage : $s->abs_ref Function: the reference sequence for this segment Returns : a string Args : none Status : Public This is an alias to sourceseq(), and is here to provide API compatibility with Bio::DB::GFF::RelSegment. =cut *abs_ref = \&sourceseq; =head2 refseq Title : refseq Usage : $s->refseq Function: get or set the reference sequence Returns : a string Args : none Status : Public Examine or change the reference sequence. This is an alias to sourceseq(), provided here for API compatibility with Bio::DB::GFF::RelSegment. =cut *refseq = \&sourceseq; =head2 ref Title : ref Usage : $s->refseq Function: get or set the reference sequence Returns : a string Args : none Status : Public An alias for refseq() =cut sub ref { shift->refseq(@_) } =head2 seq_id Title : seq_id Usage : $ref = $s->seq_id Function: get the reference sequence in a LocationI-compatible way Returns : a string Args : none Status : Public An alias for refseq() but only allows reading. =cut sub seq_id { shift->refseq } *seqname = \&seq_id; =head2 truncated Title : truncated Usage : $truncated = $s->truncated Function: Flag indicating that the segment was truncated during creation Returns : A boolean flag Args : none Status : Public This indicates that the sequence was truncated during creation. The returned flag is undef if no truncation occured. If truncation did occur, the flag is actually an array ref in which the first element is true if truncation occurred on the left, and the second element occurred if truncation occurred on the right. =cut sub truncated { my $self = shift; my $hash = $self->{truncated} or return; CORE::ref($hash) eq 'HASH' or return [1,1]; # paranoia -- not that this would ever happen ;-) return [$hash->{start},$hash->{stop}]; } =head2 Bio::RangeI Methods The following Bio::RangeI methods are supported: overlaps(), contains(), equals(),intersection(),union(),overlap_extent() =cut sub overlaps { my $self = shift; my($other,$so) = @_; if ($other->isa('Bio::DB::GFF::RelSegment')) { return if $self->abs_ref ne $other->abs_ref; } $self->SUPER::overlaps(@_); } sub contains { my $self = shift; my($other,$so) = @_; if ($other->isa('Bio::DB::GFF::RelSegment')) { return if $self->abs_ref ne $other->abs_ref; } $self->SUPER::contains(@_); } #sub equals { # my $self = shift; # my($other,$so) = @_; # if ($other->isa('Bio::DB::GFF::RelSegment')) { # return if $self->abs_ref ne $other->abs_ref; # } # $self->SUPER::equals(@_); #} sub intersection { my $self = shift; my($other,$so) = @_; if ($other->isa('Bio::DB::GFF::RelSegment')) { return if $self->abs_ref ne $other->abs_ref; } $self->SUPER::intersection(@_); } sub union { my $self = shift; my($other) = @_; if ($other->isa('Bio::DB::GFF::RelSegment')) { return if $self->abs_ref ne $other->abs_ref; } $self->SUPER::union(@_); } sub overlap_extent { my $self = shift; my($other) = @_; if ($other->isa('Bio::DB::GFF::RelSegment')) { return if $self->abs_ref ne $other->abs_ref; } $self->SUPER::overlap_extent(@_); } =head2 Bio::SeqI implementation =cut =head2 primary_id Title : primary_id Usage : $unique_implementation_key = $obj->primary_id; Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no accession number, this method should return a stringified memory location. Returns : A string Args : None Status : Virtual =cut sub primary_id { my ($obj,$value) = @_; if( defined $value) { $obj->{'primary_id'} = $value; } if( ! exists $obj->{'primary_id'} ) { return "$obj"; } return $obj->{'primary_id'}; } =head2 display_name Title : display_name Usage : $id = $obj->display_name or $obj->display_name($newid); Function: Gets or sets the display id, also known as the common name of the Seq object. The semantics of this is that it is the most likely string to be used as an identifier of the sequence, and likely to have "human" readability. The id is equivalent to the LOCUS field of the GenBank/EMBL databanks and the ID field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convenience issues. Returns : A string Args : None or a new id Note, this used to be called display_id(), and this name is preserved for backward compatibility. The default is to return the seq_id(). =cut sub display_name { shift->seq_id } *display_id = \&display_name; =head2 accession_number Title : accession_number Usage : $unique_biological_key = $obj->accession_number; Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". Returns : A string Args : None =cut sub accession_number { return 'unknown'; } =head2 alphabet Title : alphabet Usage : if( $obj->alphabet eq 'dna' ) { /Do Something/ } Function: Returns the type of sequence being one of 'dna', 'rna' or 'protein'. This is case sensitive. This is not called because this would cause upgrade problems from the 0.5 and earlier Seq objects. Returns : a string either 'dna','rna','protein'. NB - the object must make a call of the type - if there is no type specified it has to guess. Args : none Status : Virtual =cut sub alphabet{ return 'dna'; # no way this will be anything other than dna! } =head2 desc Title : desc Usage : $seqobj->desc($string) or $seqobj->desc() Function: Sets or gets the description of the sequence Example : Returns : The description Args : The description or none =cut sub desc { shift->asString } *description = \&desc; =head2 species Title : species Usage : $species = $seq->species() or $seq->species($species) Function: Gets or sets the species Example : Returns : Bio::Species object Args : None or Bio::Species object See L for more information =cut sub species { my ($self, $species) = @_; if ($species) { $self->{'species'} = $species; } else { return $self->{'species'}; } } =head2 annotation Title : annotation Usage : $ann = $seq->annotation or $seq->annotation($annotation) Function: Gets or sets the annotation Example : Returns : Bio::Annotation object Args : None or Bio::Annotation object See L for more information =cut sub annotation { my ($obj,$value) = @_; if( defined $value || ! defined $obj->{'annotation'} ) { $value = Bio::Annotation::Collection->new() unless defined $value; $obj->{'annotation'} = $value; } return $obj->{'annotation'}; } =head2 is_circular Title : is_circular Usage : if( $obj->is_circular) { /Do Something/ } Function: Returns true if the molecule is circular Returns : Boolean value Args : none =cut sub is_circular{ return 0; } 1; __END__ =head1 BUGS Report them please. =head1 SEE ALSO L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 CONTRIBUTORS Jason Stajich Ejason@bioperl.orgE. =cut BioPerl-1.6.923/Bio/DB/GFF/Typename.pm000444000765000024 751512254227327 17172 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Typename -- The name of a feature type =head1 SYNOPSIS use Bio::DB::GFF; my $type = Bio::DB::GFF::Typename->new(similarity => 'BLAT_EST_GENOME'); my $segment = $segment->features($type); =head1 DESCRIPTION Bio::DB::GFF::Typename objects encapsulate the combination of feature method and source used by the GFF flat file format. They can be used in the Bio::DB::GFF modules wherever a feature type is called for. Since there are relatively few types and many features, this module maintains a memory cache of unique types so that two features of the same type will share the same Bio::DB::GFF::Typename object. =head1 METHODS =cut package Bio::DB::GFF::Typename; use strict; use overload '""' => 'asString', fallback => 1; use base qw(Bio::Root::Root Bio::Das::FeatureTypeI); # cut down on the number of equivalent objects we have to create my %OBJECT_CACHE; =head2 new Title : new Usage : $type = Bio::DB::GFF::Typename->new($method,$source) Function: create a new Bio::DB::GFF::Typename object Returns : a new Bio::DB::GFF::Typename object Args : method and source Status : Public =cut sub new { my $package = shift; my ($method,$source) = @_; $method ||= ''; $source ||= ''; if ($source eq '' && $method =~ /^([\w-]+):([\w-]*)$/) { $method = $1; $source = $2; } return $OBJECT_CACHE{"$method:$source"} ||= bless [$method,$source],$package; } =head2 method Title : method Usage : $method = $type->method([$newmethod]) Function: get or set the method Returns : a method name Args : new method name (optional) Status : Public =cut sub method { my $self = shift; my $d = $self->[0]; $self->[0] = shift if @_; $d; } =head2 source Title : source Usage : $source = $type->source([$newsource]) Function: get or set the source Returns : a source name Args : new source name (optional) Status : Public =cut sub source { my $self = shift; my $d = $self->[1]; $self->[1] = shift if @_; $d; } =head2 asString Title : asString Usage : $string = $type->asString Function: get the method and source as a string Returns : a string in "method:source" format Args : none Status : Public This method is used by operator overloading to overload the '""' operator. =cut sub asString { $_[0]->[1] ? join ':',@{$_[0]} : $_[0]->[0]; } =head2 clone Title : clone Usage : $new_clone = $type->clone; Function: clone this object Returns : a new Bio::DB::GFF::Typename object Args : none Status : Public This method creates an exact copy of the object. =cut sub clone { my $self = shift; return bless [@$self],ref $self; } =head2 match Title : match Usage : $boolean = $type->match($type_or_string) Function: fuzzy match on types Returns : a flag indicating that the argument matches the object Args : a Bio::DB::GFF::typename object, or a string in method:source format Status : Public This match allows Sequence:Link and Sequence: to match, but not Sequence:Link and Sequence:Genomic_canonical. =cut sub match { my $self = shift; my $target = shift; my ($method,$source); if (UNIVERSAL::isa($target,'Bio::DB::GFF::Typename')) { ($method,$source) = ($target->method,$target->source); } else { ($method,$source) = split /:/,$target; } $source ||= ''; # quash uninit variable warnings return if $method ne '' && $self->method ne '' && $method ne $self->method; return if $source ne '' && $self->source ne '' && $source ne $self->source; 1; } 1; =head1 BUGS This module is still under development. =head1 SEE ALSO L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor000755000765000024 012254227332 16273 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Adaptor/ace.pm000444000765000024 242512254227325 17523 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::ace; =head1 NAME Bio::DB::GFF::Adaptor::ace -- ace interface (for multiple inheritance) =head1 SYNOPSIS Pending See L and L =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Ace; use Bio::DB::GFF::Util::Rearrange; # for rearrange() sub dna_db { my $self = shift; my $d = $self->{dna_db}; $self->{dna_db} = shift if @_; $d; } sub acedb { my $self = shift; my $d = $self->{acedb}; $self->{acedb} = shift if @_; $d; } =head2 freshen_ace Title : freshen Usage : $flag = Bio::DB::GFF->freshen_ace; Function: Refresh internal acedb handle Returns : flag if correctly freshened Args : none Status : Public ACeDB has an annoying way of timing out, leaving dangling database handles. This method will invoke the ACeDB reopen() method, which causes dangling handles to be refreshed. It has no effect if you are not using ACeDB to create ACeDB objects. =cut sub freshen_ace { my $acedb = shift->acedb or return; $acedb->reopen(); } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/berkeleydb.pm000444000765000024 7436112254227314 21131 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::berkeleydb; =head1 NAME Bio::DB::GFF::Adaptor::berkeleydb -- Bio::DB::GFF database adaptor for in-memory databases =head1 SYNOPSIS use Bio::DB::GFF; my $db = Bio::DB::GFF->new(-adaptor=> 'berkeleydb', -create => 1, # on initial build you need this -dsn => '/usr/local/share/gff/dmel'); # initialize an empty database, then load GFF and FASTA files $db->initialize(1); $db->load_gff('/home/drosophila_R3.2.gff'); $db->load_fasta('/home/drosophila_R3.2.fa'); # do queries my $segment = $db->segment(Chromosome => '1R'); my $subseg = $segment->subseq(5000,6000); my @features = $subseg->features('gene'); See L for other methods. =head1 DESCRIPTION This adaptor implements a berkeleydb-indexed version of Bio::DB::GFF. It requires the DB_File and Storable modules. It can be used to store and retrieve short to medium-length GFF files of several million features in length. =head1 CONSTRUCTOR Use Bio::DB::GFF-Enew() to construct new instances of this class. Three named arguments are recommended: Argument Description -------- ----------- -adaptor Set to "berkeleydb" to create an instance of this class. -dsn Path to directory where the database index files will be stored (alias -db) -autoindex Monitor the indicated directory path for FASTA and GFF files, and update the indexes automatically if they change (alias -dir) -write Set to a true value in order to update the database. -create Set to a true value to create the database the first time (implies -write) -tmp Location of temporary directory for storing intermediate files during certain queries. -preferred_groups Specify the grouping tag. See L The -dsn argument selects the directory in which to store the database index files. If the directory does not exist it will be created automatically, provided that the current process has sufficient privileges. If no -dsn argument is specified, a database named "test" will be created in your system's temporary files directory. The -tmp argument specifies the temporary directory to use for storing intermediate search results. If not specified, your system's temporary files directory will be used. On Unix systems, the TMPDIR environment variable is honored. Note that some queries can require a lot of space. The -autoindex argument, if present, selects a directory to be monitored for GFF and FASTA files (which can be compressed with the gzip program if desired). Whenever any file in this directory is changed, the index files will be updated. Note that the indexing can take a long time to run: anywhere from 5 to 10 minutes for a million features. An alias for this argument is -dir, which gives this adaptor a similar flavor to the "memory" adaptor. -dsn and -dir can point to the same directory. If -dir is given but -dsn is absent the index files will be stored into the directory containing the source files. For autoindexing to work, you must specify the same -dir path each time you open the database. If you do not choose autoindexing, then you will want to load the database using the bp_load_gff.pl command-line tool. For example: bp_load_gff.pl -a berkeleydb -c -d /usr/local/share/gff/dmel dna1.fa dna2.fa features.gff =head1 METHODS See L for inherited methods =head1 BUGS The various get_Stream_* methods and the features() method with the -iterator argument only return an iterator after the query runs completely and the module has been able to generate a temporary results file on disk. This means that iteration is not as big a win as it is for the relational-database adaptors. Like the dbi::mysqlopt adaptor, this module uses a binning scheme to speed up range-based searches. The binning scheme used here imposes a hard-coded 1 gigabase (1000 Mbase) limit on the size of the largest chromosome or other reference sequence. =head1 SEE ALSO L, L =head1 AUTHORS Vsevolod (Simon) Ilyushchenko Esimonf@cshl.eduE Lincoln Stein Elstein@cshl.eduE Copyright (c) 2005 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use DB_File; use File::Path 'mkpath'; use File::Spec; use File::Temp 'tempfile'; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::GFF::Util::Binning; use Bio::DB::Fasta; use Bio::DB::GFF::Adaptor::berkeleydb::iterator; use Bio::DB::GFF::Adaptor::memory::feature_serializer; # qw(feature2string string2feature @hash2array_map); # this is the smallest bin (1 K) use constant MIN_BIN => 1000; # this is the largest that any reference sequence can be (1000 megabases) use constant MAX_BIN => 1_000_000_000; use constant MAX_SEGMENT => 1_000_000_000; # the largest a segment can get #We have to define a limit because Berkeleydb sorts in lexicografic order, #so all the numbers have to have the same length. use constant MAX_NUM_LENGTH => length(MAX_BIN); use base 'Bio::DB::GFF::Adaptor::memory'; sub new { my $class = shift ; my ($dbdir,$preferred_groups,$autoindex,$write,$create,$tmpdir) = rearrange([ [qw(DSN DB)], 'PREFERRED_GROUPS', [qw(DIR AUTOINDEX)], [qw(WRITE WRITABLE)], 'CREATE', 'TMP', ],@_); $tmpdir ||= File::Spec->tmpdir; $dbdir ||= $autoindex; $dbdir ||= "$tmpdir/test"; $write ||= $create; my $self = bless {},$class; $self->dsn($dbdir); $self->tmpdir($tmpdir); $self->preferred_groups($preferred_groups) if defined $preferred_groups; $self->_autoindex($autoindex) if $autoindex; $self->_open_databases($write,$create); return $self; } sub _autoindex { my $self = shift; my $autodir = shift; my $dir = $self->dsn; my %ignore = map {$_=>1} ($self->_index_file,$self->_data_file, $self->_fasta_file,$self->_temp_file, $self->_notes_file, $self->_timestamp_file); my $maxtime = 0; my $maxfatime = 0; opendir (my $D,$autodir) or $self->throw("Couldn't open directory $autodir for reading: $!"); while (defined (my $node = readdir($D))) { next if $node =~ /^\./; my $path = "$dir/$node"; next if $ignore{$path}; next unless -f $path; my $mtime = _mtime(\*_); # not a typo $maxtime = $mtime if $mtime > $maxtime; $maxfatime = $mtime if $mtime > $maxfatime && $node =~ /\.(?:fa|fasta|dna)(?:\.gz)?$/; } close $D; my $timestamp_time = _mtime($self->_timestamp_file) || 0; my $all_files_exist = -e $self->_index_file && -e $self->_data_file && (-e $self->_fasta_file || !$maxfatime); # to avoid rebuilding FASTA files if not changed my $spare_fasta = $maxfatime > 0 && $maxfatime < $timestamp_time && -e $self->_fasta_file; if ($maxtime > $timestamp_time || !$all_files_exist) { print STDERR __PACKAGE__,": Reindexing files in $dir. This may take a while....\n"; $self->do_initialize(1,$spare_fasta); $self->load_gff($autodir,1); $self->load_fasta($autodir,1) unless $spare_fasta; print STDERR __PACKAGE__,": Reindexing done\n"; } else { $self->_open_databases(); } } sub _open_databases { my $self = shift; my ($write,$create) = @_; my $dsn = $self->dsn; unless (-d $dsn) { # directory does not exist $create or $self->throw("Directory $dsn does not exist and you did not specify the -create flag"); mkpath($dsn) or $self->throw("Couldn't create database directory $dsn: $!"); } my %db; local $DB_BTREE->{flags} = R_DUP; $DB_BTREE->{compare} = sub { lc($_[0]) cmp lc($_[1]) }; my $flags = O_RDONLY; $flags |= O_RDWR if $write; $flags |= O_CREAT if $create; tie(%db,'DB_File',$self->_index_file,$flags,0666,$DB_BTREE) or $self->throw("Couldn't tie ".$self->_index_file.": $!"); $self->{db} = \%db; $self->{data} = FeatureStore->new($self->_data_file,$write,$create); if (-e $self->_fasta_file) { my $dna_db = Bio::DB::Fasta->new($self->_fasta_file) or $self->throw("Can't reindex sequence file: $@"); $self->dna_db($dna_db); } my $mode = $write ? "+>>" : $create ? "+>" : "<"; open (my $F,$mode,$self->_notes_file) or $self->throw($self->_notes_file.": $!"); $self->{notes} = $F; } sub _close_databases { my $self = shift; delete $self->{db}; delete $self->{data}; delete $self->{notes}; } sub _delete_features { my $self = shift; my @feature_ids = @_; my $removed = 0; my $last_id = $self->{data}->last_id; for my $id (@feature_ids) { next unless $id >= 0 && $id < $last_id; my $feat = $self->{data}->get($id) or next; $self->{data}->remove($id); $self->_bump_class_count($feat->{gclass},-1); my @keys = $self->_secondary_keys($feat); $self->db->del_dup($_,$id) foreach @keys; $removed++; } $removed; } sub _secondary_keys { my $self = shift; my $feat = shift; return ( "__name__".lc(join ":",$feat->{gclass},$feat->{gname}), "__bin__".lc("$feat->{ref}$;$feat->{bin}"), "__type__".join(':',$feat->{method},$feat->{source}), map {"__attr__".lc(join(':',$_->[0],$_->[1]))} @{$feat->{attributes}} ); } sub _delete { my $self = shift; my $delete_spec = shift; return $self->SUPER::_delete($delete_spec) if @{$delete_spec->{segments}} or @{$delete_spec->{types}}; $self->throw("This operation would delete all feature data and -force not specified") unless $delete_spec->{force}; my $deleted = $self->{db}{__count__}; $self->{data} = FeatureStore->new($self->_data_file,1,1); %{$self->{db}} = (); $deleted; } # with duplicates enabled, we cannot simply do $db->{__index__}++; sub _bump_feature_count { my $self = shift; my $db = $self->{db}; if (@_) { delete $db->{__count__}; return $db->{__count__} = shift; } else { my $index = ${db}->{__count__}; delete $db->{__count__}; $db->{__count__} = ($index || 0) + 1; return $index; } } sub _bump_class_count { my $self = shift; my ($class,$count) = @_; $count ||= 1; my $db = $self->{db}; my $key = "__class__$class"; my $newcount = ($db->{$key} || 0) + $count; delete $db->{$key}; $db->{$key} = $newcount; } sub classes { my $self = shift; my $db = $self->db; my ($key,$value) = ('__class__',undef); my %classes; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0; $status = $db->seq($key,$value,R_NEXT)) { my ($class) = $key =~ /^__class__(.+)/ or last; $classes{$class}++ if $value > 0; } my @classes = sort keys %classes; return @classes; } sub do_initialize { my $self = shift; my $erase = shift; my $spare_fasta = shift; # used internally only! if ($erase) { $self->_close_databases; unlink $self->_index_file; unlink $self->_data_file; unlink $self->_notes_file; unless ($spare_fasta) { unlink $self->_fasta_file; unlink $self->_fasta_file.'.index'; } unlink $self->_timestamp_file; $self->_open_databases(1,1); } 1; } # load_sequence($fasta_filehandle,$first_sequence_id) sub load_sequence { my $self = shift; my ($io_handle,$id) = @_; my $file = $self->_fasta_file; my $loaded = 0; open (my $F,">>$file") or $self->throw("Couldn't open $file for writing: $!"); if (defined $id) { print $F ">$id\n"; $loaded++; } while (<$io_handle>) { $loaded++ if /^>/; print $F $_; } close $F; my $dna_db = Bio::DB::Fasta->new($file) or $self->throw("Can't reindex sequence file: $@"); $self->dna_db($dna_db); $self->_touch_timestamp; return $loaded; } sub _mtime { my $file = shift; my @stat = stat($file); return $stat[9]; } sub _index_file { my $self = shift; return $self->dsn . "/bdb_features.btree"; } sub _data_file { my $self = shift; return $self->dsn . "/bdb_features.data"; } sub _fasta_file { my $self = shift; return $self->dsn . "/bdb_sequence.fa"; } sub _notes_file { my $self = shift; return $self->dsn . "/bdb_notes.idx"; } sub _temp_file { my $self = shift; local $^W=0; my (undef,$filename) = tempfile("bdb_temp_XXXXXX",DIR=>$self->tmpdir,OPEN=>0); return $filename; } sub _timestamp_file { my $self = shift; return $self->dsn ."/bdb_timestamp"; } sub db { my $db = shift()->{db} or return; return tied(%$db); } sub dsn { my $self = shift; my $d = $self->{dsn}; $self->{dsn} = shift if @_; $d; } sub tmpdir { my $self = shift; my $d = $self->{tmpdir}; $self->{tmpdir} = shift if @_; $d; } sub load_gff_line { my ($self, $feat) = @_; $feat->{strand} = '' if $feat->{strand} && $feat->{strand} eq '.'; $feat->{phase} = '' if $feat->{phase} && $feat->{phase} eq '.'; my $start = $feat->{start}; my $stop = $feat->{stop}; my $type = join(':',$feat->{method},$feat->{source}); my $bin = bin($feat->{start},$feat->{stop},MIN_BIN); $feat->{bin} = $bin; my $id = $self->{data}->put($feat); $bin = $self->normalizeNumber($bin); my $db = $self->{db}; for my $skey ($self->_secondary_keys($feat)) { $db->{$skey} = $id; } # save searchable notes to separate index my $fh = $self->{notes}; my @notes = map {$_->[1]} grep {lc $_->[0] eq 'note'} @{$feat->{attributes}}; print $fh $_,"\t",pack("u*",$id) or $self->throw("An error occurred while updating indexes: $!") foreach @notes; $self->{records_loaded}++; $self->_bump_feature_count(); $self->_bump_class_count($feat->{gclass}); } # do nothing! sub setup_load { my $self = shift; $self->{records_loaded} = 0; 1; } sub finish_load { my $self = shift; $self->db->sync && $self->throw("An error occurred while updating indexes: $!"); $self->_touch_timestamp; $self->{records_loaded}; } sub _touch_timestamp { my $self = shift; my $tsf = $self->_timestamp_file; open (my $F,">$tsf") or $self->throw("Couldn't open $tsf: $!"); print $F scalar(localtime); } # given sequence name, return (reference,start,stop,strand) sub get_abscoords { my $self = shift; my ($name,$class,$refseq) = @_; my %refs; my $regexp; if ($name =~ /[*?]/) { # uh oh regexp time $name = quotemeta($name); $name =~ s/\\\*/.*/g; $name =~ s/\\\?/.?/g; $regexp++; } # Find all features that have the requested name and class. # Sort them by reference point. my @features = @{$self->retrieve_features(-table => 'name', -key=>"$class:$name")}; if (!@features) { # nothing matched exactly, so try aliases @features = @{$self->retrieve_features(-table=>'attr',-key=>"Alias:$name")}; } foreach my $feature (@features){ push @{$refs{$feature->{ref}}},$feature; } # find out how many reference points we recovered if (! %refs) { $self->error("$name not found in database"); return; } # compute min and max my ($ref) = keys %refs; my @found = @{$refs{$ref}}; my ($strand,$start,$stop); my @found_segments; foreach my $ref (keys %refs) { next if defined($refseq) and $ref ne $refseq; my @found = @{$refs{$ref}}; my ($strand,$start,$stop,$name); foreach (@found) { $strand ||= $_->{strand}; $strand = '+' if $strand && $strand eq '.'; $start = $_->{start} if !defined($start) || $start > $_->{start}; $stop = $_->{stop} if !defined($stop) || $stop < $_->{stop}; $name ||= $_->{gname}; } push @found_segments,[$ref,$class,$start,$stop,$strand,$name]; } return \@found_segments; } sub get_types { my $self = shift; my ($srcseq,$class,$start,$stop,$want_count,$typelist) = @_; my (%obj,%result,$key,$value); $key = "__type__"; if (!$srcseq) { # optimized full type list my $db = $self->db; my $status = $db->seq($key,$value,R_CURSOR); while ($status == 0 && $key =~ /^__type__(.+)/) { my $type = $1; my ($method,$source) = split ':',$type; $obj{$type} = Bio::DB::GFF::Typename->new($method,$source); $result{$type}++; if ($want_count) { $status = $db->seq($key,$value,R_NEXT); } else { # skip to next key set $key .= "\0"; $status = $db->seq($key,$value,R_CURSOR) } } } else { # range search for my $feature (@{$self->_get_features_by_search_options( {rangetype => 'overlaps', refseq => $srcseq, refclass => ($class || undef), start => ($start || undef), stop => ($stop || undef), }, {} )} ) { my $type = Bio::DB::GFF::Typename->new($feature->{method},$feature->{source}); $obj{$type} = $type; $result{$type}++; } } return $want_count ? %result : values %obj; } # Low level implementation of fetching a named feature. # GFF annotations are named using the group class and name fields. # May return zero, one, or several Bio::DB::GFF::Feature objects. =head2 _feature_by_name Title : _feature_by_name Usage : $db->get_features_by_name($class,$name,$callback) Function: get a list of features by name and class Returns : count of number of features retrieved Args : name of feature, class of feature, and a callback Status : protected This method is used internally. The callback arguments are those used by make_feature(). =cut sub _feature_by_name { my $self = shift; my ($class,$name,$location,$callback) = @_; $callback || $self->throw('must provide a callback argument'); #use Devel::StackTrace; #warn Devel::StackTrace->new->as_string; my $count = 0; my $id = -1; my ($use_regexp, $use_glob,$using_alias_search); if ($name =~ /[*?]/) { # uh oh regexp time #If there is only one trailing *, do a range search if ($name =~ /^([^\*]+)\*$/) { $name = $1; $use_glob++; } else { $name = quotemeta($name); $name =~ s/\\\*/.*/g; $name =~ s/\\\?/.?/g; $use_regexp++; } } my @features; if ($use_glob) { my $callback = sub {my $feat = shift; $feat->{gname} =~ /^$name/i}; @features = @{$self->retrieve_features_range (-table => 'name', -start => "$class:$name", -do_while => $callback) }; } elsif ($use_regexp) { my $filter = sub {my $feat = shift; $feat->{gname} =~ /$name/i}; @features = @{$self->filter_features(-table =>'name', -filter => $filter)}; } else { @features = @{$self->retrieve_features(-table=>'name', -key => "$class:$name")}; } unless (@features) { $using_alias_search++; @features = @{$self->retrieve_features(-table=>'attr', -key=>"Alias:$name")}; } foreach my $feature (@features){ $id++; next unless $using_alias_search || $feature->{gclass} eq $class; if ($location) { next if $location->[0] ne $feature->{ref}; next if $location->[1] && $location->[1] > $feature->{stop}; next if $location->[2] && $location->[2] < $feature->{start}; } $count++; $callback->(@{$feature}{@hash2array_map},0); } return $count; } #sub get_feature_by_attribute{ sub _feature_by_attribute{ my $self = shift; my ($attributes,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $count = 0; my $feature_group_id = undef; #there could be more than one set of attributes...... while (my ($key, $value) = each %$attributes) { my @features = @{$self->retrieve_features (-table => "attr", -key => "$key:$value")}; for my $feature (@features) { $callback->(@{$feature}{@hash2array_map},$feature_group_id); $count++; } } } sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my @results; my @words = map {quotemeta($_)} $search_string =~ /(\w+)/g; my $search = join '|',@words; my (%found,$found); my $note_index = $self->{notes}; seek($note_index,0,0); # back to start while (<$note_index>) { next unless /$search/; chomp; my ($note,$uu) = split "\t"; $found{unpack("u*",$uu)}++; last if $limit && ++$found >= $limit; } my (@features, @matches); for my $idx (keys %found) { my $feature = $self->{data}->get($idx) or next; my @attributes = @{$feature->{attributes}}; my @values = map {lc $_->[0] eq 'note' ? $_->[1] : ()} @attributes; my $value = "@values"; my $hits; $hits++ while $value =~ /($search)/ig; # count the number of times we were hit push @matches,$hits; push @features,$feature; } for (my $i=0; $i<@matches; $i++) { my $feature = $features[$i]; my $matches = $matches[$i]; my $relevance = 10 * $matches; my $featname = Bio::DB::GFF::Featname->new($feature->{gclass}=>$feature->{gname}); my $type = Bio::DB::GFF::Typename->new($feature->{method}=>$feature->{source}); my $note; $note = join ' ',map {$_->[1]} grep {$_->[0] eq 'Note'} @{$feature->{attributes}}; push @results,[$featname,$note,$relevance,$type]; } return @results; } sub _get_features_by_search_options { #The $data argument is not used and is preserved for superclass compatibility my ($self, $search,$options) = @_; my $count = 0; my ($rangetype,$refseq,$class,$start,$stop,$types,$sparse,$order_by_group,$attributes,$temp_file) = (@{$search}{qw(rangetype refseq refclass start stop types)}, @{$options}{qw(sparse sort_by_group ATTRIBUTES temp_file)}) ; $start = 0 unless defined($start); $stop = MAX_BIN unless defined($stop); my $bin = bin($start,$stop,MIN_BIN); $bin = $self->normalizeNumber($bin); my ($results,@features,%found,%results_table); if ($temp_file) { local $DB_BTREE->{flags} = R_DUP; # note: there is a race condition possible here, if someone reuses the # same name between the time we get the tmpfile name and the time we # ask DB_File to open it. tie(%results_table,'DB_File',$temp_file,O_RDWR|O_CREAT,0666,$DB_BTREE) or $self->throw("Couldn't tie temporary file ".$temp_file." for writing: $!"); $results = \%results_table; } else { $results = \@features; } my $filter = sub { my $feature = shift; my $ref = $feature->{ref}; my $feature_start = $feature->{start}; my $feature_stop = $feature->{stop}; my $feature_id = $feature->{feature_id}; return 0 if $found{$feature_id}++; if (defined $refseq) { return 0 unless lc $refseq eq lc $ref; $start = 0 unless defined($start); $stop = MAX_SEGMENT unless defined($stop); if ($rangetype eq 'overlaps') { return 0 unless $feature_stop >= $start && $feature_start <= $stop; } elsif ($rangetype eq 'contains') { return 0 unless $feature_start >= $start && $feature_stop <= $stop; } elsif ($rangetype eq 'contained_in') { return 0 unless $feature_start <= $start && $feature_stop >= $stop; } else { return 0 unless $feature_start == $start && $feature_stop == $stop; } } my $feature_source = $feature->{source}; my $feature_method = $feature->{method}; if (defined $types && @$types){ return 0 unless $self->_matching_typelist($feature_method,$feature_source,$types); } my $feature_attributes = $feature->{attributes}; if (defined $attributes){ return 0 unless $self->_matching_attributes($feature_attributes,$attributes); } return 1; }; if (defined $refseq && !$sparse) { my $tier = MAX_BIN; while ($tier >= MIN_BIN) { my ($tier_start,$tier_stop) = (bin_bot($tier,$start),bin_top($tier,$stop)); # warn "Using $tier_start $tier_stop\n"; if ($tier_start == $tier_stop) { $self->retrieve_features(-table => "bin", -key => "$refseq$;$tier_start", -filter => $filter, -result => $results); } else { my $callback = sub {my $feat = shift; $feat->{bin} <= $tier_stop}; $self->retrieve_features_range(-table => "bin", -start => "$refseq$;$tier_start", -do_while => $callback, -filter => $filter, -result => $results); } $tier /= 10; } } elsif (@$types) { foreach (@$types) { my $type = join ':',@$_; $self->retrieve_features_range(-table => 'type', -start => $type, -filter => $filter, -do_while => sub { my $f = shift; lc($f->{method}) eq lc($_->[0]) && lc($f->{source}||$_->[1]||'') eq lc($_->[1]||'') }, -result => $results); } } elsif (defined $attributes) { my ($attribute_name,$attribute_value) = each %$attributes; # pick first one $self->retrieve_features(-table => 'attr', -key => "${attribute_name}:${attribute_value}", -filter => $filter, -result => $results); } else { $self->filter_features(-filter => $filter,-result=>$results); } return $results; } sub retrieve_features { my $self = shift; my ($table, $key, $filter, $result) = rearrange(['TABLE','KEY','FILTER', 'RESULT'],@_); my @result; $result ||= \@result; my $frozen; my @ids = $self->db->get_dup("__".lc($table)."__".lc($key)); my $data = $self->{data}; local $^W = 0; # because _hash_to_array() will generate lots of uninit values foreach my $id (@ids) { my $feat = $data->get($id); my $filter_result = $filter ? $filter->($feat) : 1; next unless $filter_result; if (ref $result eq 'HASH') { $result->{"$feat->{gclass}:$feat->{gname}"} = join ($;,$self->_hash_to_array($feat)); } else { push @$result, $feat; } last if $filter_result == -1; } return $result; } sub retrieve_features_range { my ($self) = shift; my ($table, $start, $do_while, $filter, $result) = rearrange(['TABLE','START','DO_WHILE', 'FILTER', 'RESULT'],@_); local $^W = 0; # because _hash_to_array will generate lots of uninit warnings my @result; $result ||= \@result; my ($id, $key, $value); $key = "__".$table."__".$start; my $db = $self->db; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0; $status = $db->seq($key,$value,R_NEXT)) { my $feat = $self->{data}->get($value); last unless $do_while->($feat,$key); my $filter_result = $filter ? $filter->($feat) : 1; next unless $filter_result; if (ref $result eq 'HASH') { $result->{"$feat->{gclass}:$feat->{gname}"} = join($;,$self->_hash_to_array($feat)); } else { push @$result,$feat; } last if $filter_result == -1; } return $result; } sub filter_features { my ($self) = shift; my ($filter,$result) = rearrange(['FILTER','RESULT'],@_); my @result; $result ||= \@result; my ($key, $frozen); my $data = $self->{data}; $data->reset; while (my $feat = $data->next) { my $filter_result = $filter ? $filter->($feat) : 1; next unless $filter_result; if (ref($result) eq 'HASH') { $result->{"$feat->{gclass}:$feat->{gname}"} = join($;,$self->_hash_to_array($feat)); } else { push @$result,$feat; } last if $filter_result == -1; } return $result; } sub _basic_features_by_id{ my $self = shift; my ($ids) = @_; $ids = [$ids] unless ref $ids =~ /ARRAY/; my @result; my $data = $self->{data}; for my $feature_id (@$ids){ push @result, $data->get($feature_id); } return wantarray() ? @result : $result[0]; } sub normalizeNumber { my ($self, $num) = @_; while ((length $num) < MAX_NUM_LENGTH) { $num = "0".$num; } return $num; } sub get_features_iterator { my $self = shift; my ($search,$options,$callback) = @_; $callback || $self->throw('must provide a callback argument'); $options->{temp_file} = $self->_temp_file; my $results = $self->_get_features_by_search_options($search,$options); return Bio::DB::GFF::Adaptor::berkeleydb::iterator->new($results,$callback,$options->{temp_file}); } #--------------------------------------------------------------------------# package FeatureStore; # This is a very specialized package that stores serialized features onto a file-based # array. The array is indexed by the physical offset to the beginning of each serialized # feature. use strict; use Fcntl qw(SEEK_SET SEEK_END); use base 'Bio::Root::Root'; use Bio::DB::GFF::Adaptor::memory::feature_serializer; # qw(feature2string string2feature @hash2array_map); sub new { my $class = shift; my $dbname = shift or $class->throw("must provide a filepath argument"); my ($write,$create) = @_; my $mode = $create ? "+>" : $write ? "+>>" : "<"; open (my $F,$mode,$dbname) or $class->throw("$dbname: $!"); my $self = bless { fh => $F, next_idx => 0, last_id => 0, },$class; return $self; } sub put { my $self = shift; my $feature = shift; my $fh = $self->{fh}; seek($fh,0,SEEK_END); my $offset = tell($fh) || 0; $self->{last_id} = $offset; my $id = pack("L",$offset); $feature->{feature_id} = $id; my $value = feature2string($feature); print $fh pack("n/a*",$value) or $self->throw("An error occurred while updating the data file: $!"); return $id; } sub last_id { shift->{last_id}; } sub get { my $self = shift; my $idx = shift; my $offset = unpack("L",$idx); my $fh = $self->{fh}; my ($value,$length); $offset ||= 0; seek($fh,$offset,SEEK_SET); return unless read($fh,$length,2); return unless read($fh,$value,unpack("n",$length)); $self->{next_idx} = tell($fh); return if substr($value,0,1) eq "\0"; return string2feature($value); } sub next { my $self = shift; my $fh = $self->{fh}; my $result; do { $result = $self->get(pack("L",$self->{next_idx})); } until $result || eof($fh); $self->{next_idx} = 0 unless $result; $result; } sub remove { my $self = shift; my $id = shift; my $offset = unpack("L",$id); my $fh = $self->{fh}; my ($value,$length); seek($fh,$offset,SEEK_SET); return unless read($fh,$length,2); print $fh "\0"x$length; # null it out 1; } sub _seek { my $self = shift; my $idx = shift; my $offset = unpack("L",$idx); seek($self->{fh},$offset,SEEK_SET); $self->{next_idx} = tell($self->{fh}); } sub reset { my $self = shift; $self->_seek(pack("L",0)); } sub _feature2string { my $feature = shift; my @a = @{$feature}{@hash2array_map}; push @a,map {@$_} @{$feature->{attributes}} if $feature->{attributes}; return join $;,@a; } sub _string2feature { my $string = shift; my (%feature,@attributes); (@feature{@hash2array_map},@attributes) = split $;,$string; while (@attributes) { my ($key,$value) = splice(@attributes,0,2); push @{$feature{attributes}},[$key,$value]; } $feature{group_id} = undef; \%feature; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/biofetch.pm000444000765000024 2343212254227312 20573 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::biofetch; #$Id$ =head1 NAME Bio::DB::GFF::Adaptor::biofetch -- Cache BioFetch objects in a Bio::DB::GFF database =head1 SYNOPSIS Proof of principle. Not for production use. =head1 DESCRIPTION This adaptor is a proof-of-principle. It is used to fetch BioFetch sequences into a Bio::DB::GFF database (currently uses a hard-coded EMBL database) as needed. This allows the Generic Genome Browser to be used as a Genbank/EMBL browser. =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::BioFetch; use Bio::SeqIO; use vars qw(%preferred_tags); # THIS IS WRONG: biofetch should delegate to an underlying # database adaptor, and not inherit from one. use base qw(Bio::DB::GFF::Adaptor::dbi::mysql); # priority for choosing names of CDS tags, higher is higher priority %preferred_tags = ( strain => 10, organism => 20, protein_id => 40, locus_tag => 50, locus => 60, gene => 70, standard_name => 80, ); =head2 new Title : new Usage : $db = Bio::DB::GFF->new(-adaptor=>'biofetch',@args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : -adaptor : required. Which adaptor to use; biofetch for mysql, biofetch_oracle for Oracle -preferred_tags : optional. A hash of {classname => weight,...} used to determine the class and name of the feature when a choice of possible feature classes is available (e.g. a feature has both a 'gene' and a 'locus' tag). Common defaults are provided that work well for eukaryotic features (but not well for viral/prokaryotic) see below for additional arguments. Status : Public This is the constructor for the adaptor. It is called automatically by Bio::DB::GFF-Enew. In addition to arguments that are common among all adaptors, the following class-specific arguments are recgonized: Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' -user username for authentication -pass the password for authentication -proxy [['http','ftp'],'http://proxy:8080'] -source source to use for loaded features ('EMBL') -dsn,-user and -pass indicate the local database to cache results in, and as are per Bio::DB::GFF::Adaptor::dbi. The -proxy argument allows you to set the biofetch web proxy, and uses the same syntax described for the proxy() method of L, except that the argument must be passed as an array reference. =cut sub new { my $class = shift; my $self = $class->SUPER::new(@_); my ($preferred,$proxy,$source) = rearrange(['PREFERRED_TAGS','PROXY','SOURCE'],@_); # if the caller sent their own preferences, then use these, otherwise use defaults. $self->_preferred_tags($preferred ? $preferred : \%preferred_tags); $self->_source($source || 'EMBL'); if ($proxy) { my @args = ref($proxy) ? @$proxy : eval $proxy; $self->{_proxy} = \@args if @args; } $self; } sub segment { my $self = shift; my @segments = $self->SUPER::segment(@_); if (!@segments) { my $refclass = $self->refclass; my %args = $self->setup_segment_args(@_); if ($args{-class} && $args{-class} =~ /$refclass/oi) { return unless $self->load_from_embl('embl'=>$args{-name}); @segments = $self->SUPER::segment(@_); } elsif ($args{-class} && $args{-class} =~ /refseq|swall|embl/i) { #hack to get refseq names return unless $self->load_from_embl(lc($args{-class})=>$args{-name}); $args{-class} = $self->refclass; @segments = $self->SUPER::segment(%args); } } $self->_multiple_return_args(@segments); } # default is to return 'Sequence' as the class of all references sub refclass { my $self = shift; my $refname = shift; 'Sequence'; } sub load_from_embl { my $self = shift; my $db = shift; my $acc = shift or $self->throw('Must provide an accession ID'); my $biofetch; if ($self->{_biofetch}{$db}) { $biofetch = $self->{_biofetch}{$db}; } else { $biofetch = $self->{_biofetch}{$db} = Bio::DB::BioFetch->new(-db=>$db); $biofetch->retrieval_type('tempfile'); $biofetch->proxy(@{$self->{_proxy}}) if $self->{_proxy}; } my $seq = eval {$biofetch->get_Seq_by_id($acc)} or return; $self->_load_embl($acc,$seq); 1; } sub load_from_file { my $self = shift; my $file = shift; my $format = $file =~ /\.(gb|genbank|gbk)$/i ? 'genbank' : 'embl'; my $seqio = Bio::SeqIO->new( '-format' => $format, -file => $file); my $seq = $seqio->next_seq; $self->_load_embl($seq->accession,$seq); 1; } sub _load_embl { my $self = shift; my $acc = shift; my $seq = shift; my $refclass = $self->refclass; my $locus = $seq->id; my $source = $self->_source; # begin loading $self->setup_load(); # first synthesize the entry for the top-level feature my @aliases; foreach ($seq->accession,$seq->get_secondary_accessions) { next if lc($_) eq lc($acc); push @aliases,[Alias => $_]; } $self->load_gff_line( { ref => $acc, class => $refclass, source => $source, # method => 'origin', method => 'region', start => 1, stop => $seq->length, score => undef, strand => '.', phase => '.', gclass => $self->refclass, gname => $acc, tstart => undef, tstop => undef, attributes => [[Note => $seq->desc],@aliases], } ); # now load each feature in turn my ($transcript_version,$mRNA_version) = (0,0); for my $feat ($seq->all_SeqFeatures) { my $attributes = $self->get_attributes($feat); my $name = $self->guess_name($attributes); my $location = $feat->location; my @segments = map {[$_->start,$_->end,$_->seq_id]} $location->can('sub_Location') ? $location->sub_Location : $location; # this changed CDS to coding, but that is the wrong thing to do, since # CDS is in SOFA and coding is not # my $type = $feat->primary_tag eq 'CDS' ? 'coding' # : $feat->primary_tag; my $type= $feat->primary_tag; next if (lc($type) eq 'contig'); # next if (lc($type) eq 'variation'); if (lc($type) eq 'variation' and $feat->length == 1) { $type = 'SNP'; } elsif (lc($type) eq 'variation' ) { $type = 'chromosome_variation'; } if ($type eq 'source') { $type = 'region'; } if ($type =~ /misc.*RNA/i) { $type = 'RNA'; } if ($type eq 'misc_feature' and $name->[1] =~ /similar/i) { $type = 'computed_feature_by_similarity'; } elsif ($type eq 'misc_feature') { warn "skipping a misc_feature\n"; next; } my $parttype = $feat->primary_tag eq 'mRNA' ? 'exon' : $feat->primary_tag; if ($type eq 'gene') { $transcript_version = 0; $mRNA_version = 0; } elsif ($type eq 'mRNA') { $name->[1] = sprintf("%s.t%02d",$name->[1],++$transcript_version); } elsif ($type eq 'CDS') { $name->[0] = 'mRNA'; $name->[1] = sprintf("%s.t%02d",$name->[1],$transcript_version); } my $strand = $feat->strand; my $str = defined $strand ? ($strand > 0 ? '+' : '-') : '.'; $self->load_gff_line( { ref => $acc, class => $refclass, source => $source, method => $type, start => $location->start, stop => $location->end, score => $feat->score || undef, strand => $str, phase => $feat->frame || '.', gclass => $name->[0], gname => $name->[1], tstart => undef, tstop => undef, attributes => $attributes, } ) if ($type && ($type ne 'CDS'||($type eq 'CDS'&&@segments==1) ) ); @$attributes = (); next if @segments == 1; for my $segment (@segments) { my $strand = $feat->strand; my $str = defined $strand ? ($strand > 0 ? '+' : '-') : '.'; $self->load_gff_line( { ref => $segment->[2] eq $locus ? $acc : $segment->[2], class => $refclass, source => $source, method => $parttype, start => $segment->[0], stop => $segment->[1], score => $feat->score || undef, strand => $str, phase => $feat->frame || '.', gclass => $name->[0], gname => $name->[1], tstart => undef, tstop => undef, attributes => $attributes, } ); } } # finish loading $self->finish_load(); # now load the DNA $self->load_sequence_string($acc,$seq->seq); 1; } sub get_attributes { my $self = shift; my $seq = shift; my @tags = $seq->all_tags or return; my @result; foreach my $tag (@tags) { foreach my $value ($seq->each_tag_value($tag)) { push @result,[$tag=>$value]; } } \@result; } sub guess_name { my $self = shift; my $attributes = shift; # remove this fix when Lincoln fixes it properly return ["Misc" => "Misc"] unless ($attributes); # these are arbitrary, and possibly destructive defaults my @ordered_attributes = sort {($self->_preferred_tags->{$a->[0]} || 0) <=> ($self->_preferred_tags->{$b->[0]} || 0)} @$attributes; my $best = pop @ordered_attributes; @$attributes = @ordered_attributes; return $best; } sub _preferred_tags { my $self = shift; $self->{preferred_tags} = shift if @_; return $self->{preferred_tags}; } sub _source { my $self = shift; $self->{source} = shift if @_; $self->{source}; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/biofetch_oracle.pm000444000765000024 2055612254227332 22126 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::biofetch_oracle; #$Id$ =head1 NAME Bio::DB::GFF::Adaptor::biofetch_oracle -- Cache BioFetch objects in a Bio::DB::GFF database =head1 SYNOPSIS Proof of principle. Not for production use. =head1 DESCRIPTION This adaptor is a proof-of-principle. It is used to fetch BioFetch sequences into a Bio::DB::GFF database (currently uses a hard-coded EMBL database) as needed. This allows the Generic Genome Browser to be used as a Genbank/EMBL browser. =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::BioFetch; use Bio::SeqIO; use vars qw(%default_preferred_tags); use base qw(Bio::DB::GFF::Adaptor::dbi::oracle); # priority for choosing names of CDS tags, higher is higher priority %default_preferred_tags = ( strain => 10, organism => 20, protein_id => 40, locus_tag => 50, locus => 60, gene => 70, standard_name => 80, ); sub _preferred_tags { my ($self, $tags) = @_; if ($tags && (ref($tags) =~ /HASH/)){ $self->{preferred_tags} = $tags; } return $self->{preferred_tags}; } =head2 new Title : new Usage : $db = Bio::DB::GFF->new(-adaptor=>'biofetch_oracle', -preferred_tags => \%preferred, @args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : -adaptor : required. Which adaptor to use; biofetch for mysql, biofetch_oracle for Oracle -preferred_tags : optional. A hash of {classname => weight,...} used to determine the class and name of the feature when a choice of possible feature classes is available (e.g. a feature has both a 'gene' and a 'locus' tag). Common defaults are provided that work well for eukaryotic features (but not well for viral/prokaryotic) see below for additional arguments. Status : Public This is the constructor for the adaptor. It is called automatically by Bio::DB::GFF-Enew. In addition to arguments that are common among all adaptors, the following class-specific arguments are recgonized: Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' -user username for authentication -pass the password for authentication -proxy [['http','ftp'],'http://proxy:8080'] -create initialize the database -dsn,-user and -pass indicate the local database to cache results in, and as are per Bio::DB::GFF::Adaptor::dbi. The -proxy argument allows you to set the biofetch web proxy, and uses the same syntax described for the proxy() method of L, except that the argument must be passed as an array reference. =cut sub new { my $class = shift; my $args = shift; my $self = $class->SUPER::new($args); my ($preferred) = rearrange(['PREFERRED_TAGS'],$args); $self->_preferred_tags($preferred?$preferred:\%default_preferred_tags); # if the caller sent their own preferences, then use these, otherwise use defaults. my ($proxy) = rearrange(['PROXY'],$args); if ($proxy) { my @args = ref($proxy) ? @$proxy : eval $proxy; $self->{_proxy} = \@args if @args; } $self; } sub segment { my $self = shift; my @segments = $self->SUPER::segment(@_); if (!@segments) { my $refclass = $self->refclass; my %args = $self->setup_segment_args(@_); if ($args{-class} && $args{-class} =~ /$refclass/oi) { return unless $self->load_from_embl('embl'=>$args{-name}); @segments = $self->SUPER::segment(@_); } elsif ($args{-class} && $args{-class} =~ /refseq|swall|embl/i) { #hack to get refseq names return unless $self->load_from_embl(lc($args{-class})=>$args{-name}); $args{-class} = $self->refclass; @segments = $self->SUPER::segment(%args); } } $self->_multiple_return_args(@segments); } # default is to return 'Sequence' as the class of all references sub refclass { my $self = shift; my $refname = shift; 'Accession'; } sub load_from_embl { my $self = shift; my $db = shift; my $acc = shift or $self->throw('Must provide an accession ID'); my $biofetch; if ($self->{_biofetch}{$db}) { $biofetch = $self->{_biofetch}{$db}; } else { $biofetch = $self->{_biofetch}{$db} = Bio::DB::BioFetch->new(-db=>$db); $biofetch->retrieval_type('tempfile'); $biofetch->proxy(@{$self->{_proxy}}) if $self->{_proxy}; } my $seq = eval {$biofetch->get_Seq_by_id($acc)} or return; $self->_load_embl($acc,$seq); 1; } sub load_from_file { my $self = shift; my $file = shift; my $format = $file =~ /\.(gb|genbank|gbk)$/i ? 'genbank' : 'embl'; my $seqio = Bio::SeqIO->new( '-format' => $format, -file => $file); my $seq = $seqio->next_seq; $self->_load_embl($seq->accession,$seq); 1; } sub _load_embl { my $self = shift; my $acc = shift; my $seq = shift; my $refclass = $self->refclass; my $locus = $seq->id; # begin loading $self->setup_load(); # first synthesize the entry for the top-level feature my @aliases; foreach ($seq->accession,$seq->get_secondary_accessions) { next if lc($_) eq lc($acc); push @aliases,[Alias => $_]; } $self->load_gff_line( { ref => $acc, class => $refclass, source => 'EMBL', method => 'origin', start => 1, stop => $seq->length, score => undef, strand => '.', phase => '.', gclass => $self->refclass, gname => $acc, tstart => undef, tstop => undef, attributes => [[Note => $seq->desc],@aliases], } ); # now load each feature in turn for my $feat ($seq->all_SeqFeatures) { my $attributes = $self->get_attributes($feat); my $name = $self->guess_name($attributes); my $location = $feat->location; my @segments = map {[$_->start,$_->end,$_->seq_id]} $location->can('sub_Location') ? $location->sub_Location : $location; my $type = $feat->primary_tag eq 'CDS' ? 'mRNA' : $feat->primary_tag; my $parttype = $feat->primary_tag eq 'gene' ? 'exon' : $feat->primary_tag; if ($feat->primary_tag =~ /^(gene|CDS)$/) { $self->load_gff_line( { ref => $acc, class => $refclass, source => 'EMBL', method => $type, start => $location->start, stop => $location->end, score => $feat->score || undef, strand => $feat->strand > 0 ? '+' : ($feat->strand < 0 ? '-' : '.'), phase => $feat->frame || '.', gclass => $name->[0], gname => $name->[1], tstart => undef, tstop => undef, attributes => $attributes, } ); @$attributes = (); } for my $segment (@segments) { $self->load_gff_line( { ref => $segment->[2] eq $locus ? $acc : $segment->[2], class => $refclass, source => 'EMBL', method => $parttype, start => $segment->[0], stop => $segment->[1], score => $feat->score || undef, strand => $feat->strand > 0 ? '+' : ($feat->strand < 0 ? '-' : '.'), phase => $feat->frame || '.', gclass => $name->[0], gname => $name->[1], tstart => undef, tstop => undef, attributes => $attributes, } ); } } # finish loading $self->finish_load(); # now load the DNA $self->load_sequence_string($acc,$seq->seq); 1; } sub get_attributes { my $self = shift; my $seq = shift; my @tags = $seq->all_tags or return; my @result; foreach my $tag (@tags) { foreach my $value ($seq->each_tag_value($tag)) { push @result,[$tag=>$value]; } } \@result; } sub guess_name { my $self = shift; my $attributes = shift; # remove this fix when Lincoln fixes it properly return ["Misc" => "Misc"] unless ($attributes); # these are arbitrary, and possibly destructive defaults my @ordered_attributes = sort {($self->_preferred_tags->{$a->[0]} || 0) <=> ($self->_preferred_tags->{$b->[0]} || 0)} @$attributes; my $best = pop @ordered_attributes; @$attributes = @ordered_attributes; return $best; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi.pm000444000765000024 22002012254227332 17560 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::DB::GFF::Adaptor::dbi -- Database adaptor for DBI (SQL) databases =head1 SYNOPSIS See L =head1 DESCRIPTION This is the base class for DBI-based adaptors. It does everything except generating the text of the queries to be used. See the section QUERIES TO IMPLEMENT for the list of methods that must be implemented. =cut package Bio::DB::GFF::Adaptor::dbi; # base class for dbi-based implementations use strict; use DBI; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::GFF::Util::Binning; use Bio::DB::GFF::Adaptor::dbi::iterator; use Bio::DB::GFF::Adaptor::dbi::caching_handle; use base qw(Bio::DB::GFF); # constants for choosing use constant MAX_SEGMENT => 1_000_000_000; # the largest a segment can get # this is the largest that any reference sequence can be (100 megabases) use constant MAX_BIN => 1_000_000_000; # this is the smallest bin (1 K) use constant MIN_BIN => 1000; # size of range over which it is faster to force the database to use the range for indexing use constant STRAIGHT_JOIN_LIMIT => 200_000; # this is the size to which DNA should be shredded use constant DNA_CHUNK_SIZE => 2000; # size of summary bins for interval coverage statistics use constant SUMMARY_BIN_SIZE => 1000; # for debugging fbin optimization use constant EPSILON => 1e-7; # set to zero if you trust mysql's floating point comparisons use constant OPTIMIZE => 1; # set to zero to turn off optimization completely ############################################################################## =head2 new Title : new Usage : $db = Bio::DB::GFF->new(@args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : see below Status : Public This is the constructor for the adaptor. It is called automatically by Bio::DB::GFF-Enew. In addition to arguments that are common among all adaptors, the following class-specific arguments are recgonized: Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' -user username for authentication -pass the password for authentication =cut # Create a new Bio::DB::GFF::Adaptor::dbi object sub new { my $class = shift; my ($features_db,$username,$auth,$other) = rearrange([ [qw(FEATUREDB DB DSN)], [qw(USERNAME USER)], [qw(PASSWORD PASSWD PASS)], ],@_); $features_db || $class->throw("new(): Provide a data source or DBI database"); if (!ref($features_db)) { my $dsn = $features_db; my @args; push @args,$username if defined $username; push @args,$auth if defined $auth; $features_db = Bio::DB::GFF::Adaptor::dbi::caching_handle->new($dsn,@args) || $class->throw("new(): Failed to connect to $dsn: " . Bio::DB::GFF::Adaptor::dbi::caching_handle->errstr); } else { $features_db->isa('DBI::db') || $class->throw("new(): $features_db is not a DBI handle"); } # fill in object return bless { features_db => $features_db },$class; } sub debug { my $self = shift; $self->features_db->debug(@_); $self->SUPER::debug(@_); } =head2 features_db Title : features_db Usage : $dbh = $db->features_db Function: get database handle Returns : a DBI handle Args : none Status : Public Note: what is returned is not really a DBI::db handle, but a subclass of one. This means that you cannot manipulate the handle's attributes directly. Instead call the attribute method: my $dbh = $db->features_db; $dbh->attribute(AutoCommit=>0); =cut sub features_db { shift->{features_db} } sub dbh { shift->{features_db} } =head2 get_dna Title : get_dna Usage : $string = $db->get_dna($name,$start,$stop,$class) Function: get DNA string Returns : a string Args : name, class, start and stop of desired segment Status : Public This method performs the low-level fetch of a DNA substring given its name, class and the desired range. It is actually a front end to the abstract method make_dna_query(), which it calls after some argument consistency checking. =cut sub get_dna { my $self = shift; my ($ref,$start,$stop,$class) = @_; my ($offset_start,$offset_stop); my $has_start = defined $start; my $has_stop = defined $stop; my $reversed; if ($has_start && $has_stop && $start > $stop) { $reversed++; ($start,$stop) = ($stop,$start); } # turn start and stop into 0-based offsets my $cs = $self->dna_chunk_size; $start -= 1; $stop -= 1; $offset_start = int($start/$cs)*$cs; $offset_stop = int($stop/$cs)*$cs; my $sth; # special case, get it all if (!($has_start || $has_stop)) { $sth = $self->dbh->do_query('select fdna,foffset from fdna where fref=? order by foffset',$ref); } elsif (!$has_stop) { $sth = $self->dbh->do_query('select fdna,foffset from fdna where fref=? and foffset>=? order by foffset', $ref,$offset_start); } else { # both start and stop defined $sth = $self->dbh->do_query('select fdna,foffset from fdna where fref=? and foffset>=? and foffset<=? order by foffset', $ref,$offset_start,$offset_stop); } my $dna = ''; while (my($frag,$offset) = $sth->fetchrow_array) { substr($frag,0,$start-$offset) = '' if $has_start && $start > $offset; $dna .= $frag; } substr($dna,$stop-$start+1) = '' if $has_stop && $stop-$start+1 < length($dna); if ($reversed) { $dna = reverse $dna; $dna =~ tr/gatcGATC/ctagCTAG/; } $sth->finish; $dna; } =head2 get_abscoords Title : get_abscoords Usage : ($refseq,$refclass,$start,$stop,$strand) = $db->get_abscoords($name,$class) Function: get absolute coordinates for landmark Returns : an array ref -- see below Args : name and class of desired landmark Status : Public This method performs the low-level resolution of a landmark into a reference sequence and position. The result is an array ref, each element of which is a five-element list containing reference sequence name, class, start, stop and strand. =cut sub get_abscoords { my $self = shift; my ($name,$class,$refseq) = @_; my $sth = $self->make_abscoord_query($name,$class,$refseq); my @result; while (my @row = $sth->fetchrow_array) { push @result,\@row } $sth->finish; if (@result == 0) { #$self->error("$name not found in database"); my $sth2 = $self->make_aliasabscoord_query($name,$class); while (my @row2 = $sth2->fetchrow_array) { push @result,\@row2 } $sth->finish; if (@result == 0){ $self->error("$name not found in database"); return; } } return \@result; } =head2 get_features Title : get_features Usage : $db->get_features($search,$options,$callback) Function: retrieve features from the database Returns : number of features retrieved Args : see below Status : Public This is the low-level method that is called to retrieve GFF lines from the database. It is responsible for retrieving features that satisfy range and feature type criteria, and passing the GFF fields to a callback subroutine. See the manual page for Bio::DB::GFF for the interpretation of the arguments and how the information retrieved by get_features is passed to the callback for processing. Internally, get_features() is a front end for range_query(). The latter method constructs the query and executes it. get_features() calls fetchrow_array() to recover the fields and passes them to the callback. =cut # Given sequence name, range, and optional filter, retrieve list of # all features. Passes features through callback. sub get_features { my $self = shift; my ($search,$options,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $sth = $self->range_query(@{$search}{qw(rangetype refseq refclass start stop types) }, @{$options}{qw( sparse sort_by_group ATTRIBUTES BINSIZE)}) or return; my $count = 0; while (my @row = $sth->fetchrow_array) { $callback->(@row); $count++; } $sth->finish; return $count; } =head2 classes Title : classes Usage : $db->classes Function: return list of landmark classes in database Returns : a list of classes Args : none Status : public This routine returns the list of reference classes known to the database, or empty if classes are not used by the database. Classes are distinct from types, being essentially qualifiers on the reference namespaces. NOTE: In the current mysql-based schema, this query takes a while to run due to the classes not being normalized. =cut sub classes { my $self = shift; my ($query,@args) = $self->make_classes_query or return; my $sth = $self->dbh->do_query($query,@args); my @classes; while (my ($c) = $sth->fetchrow_array) { push @classes,$c; } @classes; } =head2 make_classes_query Title : make_classes_query Usage : ($query,@args) = $db->make_classes_query Function: return query fragment for generating list of reference classes Returns : a query and args Args : none Status : public =cut sub make_classes_query { my $self = shift; return; } =head2 _feature_by_name Title : _feature_by_name Usage : $db->get_features_by_name($name,$class,$callback) Function: get a list of features by name and class Returns : count of number of features retrieved Args : name of feature, class of feature, and a callback Status : protected This method is used internally. The callback arguments are those used by make_feature(). Internally, it invokes the following abstract procedures: make_features_select_part make_features_from_part make_features_by_name_where_part make_features_by_alias_where_part (for aliases) make_features_join_part =cut sub _feature_by_name { my $self = shift; my ($class,$name,$location,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $select = $self->make_features_select_part; my $from = $self->make_features_from_part(undef,{sparse_groups=>1}); my ($where,@args) = $self->make_features_by_name_where_part($class,$name); my $join = $self->make_features_join_part; my $range = $self->make_features_by_range_where_part('overlaps', {refseq=>$location->[0], class =>'', start=>$location->[1], stop =>$location->[2]}) if $location; # group query my $query1 = "SELECT $select FROM $from WHERE $where AND $join"; $query1 .= " AND $range" if $range; # alias query $from = $self->make_features_from_part(undef,{attributes=>1}); ($where,@args) = $self->make_features_by_alias_where_part($class,$name); # potential bug - @args1==@args2? my $query2 = "SELECT $select FROM $from WHERE $where AND $join"; $query2 .= " AND $range" if $range; my $count = 0; for my $query ($query1,$query2) { my $sth = $self->dbh->do_query($query,@args); while (my @row = $sth->fetchrow_array) { $callback->(@row); $count++; } $sth->finish; } return $count; } =head2 _feature_by_id Title : _feature_by_id Usage : $db->_feature_by_id($ids,$type,$callback) Function: get a list of features by ID Returns : count of number of features retrieved Args : arrayref containing list of IDs to fetch and a callback Status : protected This method is used internally. The $type selector is one of "feature" or "group". The callback arguments are those used by make_feature(). Internally, it invokes the following abstract procedures: make_features_select_part make_features_from_part make_features_by_id_where_part make_features_join_part =cut sub _feature_by_id { my $self = shift; my ($ids,$type,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $select = $self->make_features_select_part; my $from = $self->make_features_from_part; my ($where,@args) = $type eq 'feature' ? $self->make_features_by_id_where_part($ids) : $self->make_features_by_gid_where_part($ids); my $join = $self->make_features_join_part; my $query = "SELECT $select FROM $from WHERE $where AND $join"; my $sth = $self->dbh->do_query($query,@args); my $count = 0; while (my @row = $sth->fetchrow_array) { $callback->(@row); $count++; } $sth->finish; return $count; } sub _feature_by_attribute { my $self = shift; my ($attributes,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $select = $self->make_features_select_part; my $from = $self->make_features_from_part(undef,{attributes=>$attributes}); my ($where,@args) = $self->make_features_by_range_where_part('',{attributes=>$attributes}); my $join = $self->make_features_join_part({attributes=>$attributes}); my $query = "SELECT $select FROM $from WHERE $where AND $join"; my $sth = $self->dbh->do_query($query,@args); my $count = 0; while (my @row = $sth->fetchrow_array) { $callback->(@row); $count++; } $sth->finish; return $count; } =head2 get_types Title : get_types Usage : $db->get_types($refseq,$refclass,$start,$stop,$count) Function: get list of types Returns : a list of Bio::DB::GFF::Typename objects Args : see below Status : Public This method is responsible for fetching the list of feature type names from the database. The query may be limited to a particular range, in which case the range is indicated by a landmark sequence name and class and its subrange, if any. These arguments may be undef if it is desired to retrieve all feature types in the database (which may be a slow operation in some implementations). If the $count flag is false, the method returns a simple list of vBio::DB::GFF::Typename objects. If $count is true, the method returns a list of $name=E$count pairs, where $count indicates the number of times this feature occurs in the range. Internally, this method calls upon the following functions to generate the SQL and its bind variables: ($q1,@args) = make_types_select_part(@args); ($q2,@args) = make_types_from_part(@args); ($q3,@args) = make_types_where_part(@args); ($q4,@args) = make_types_join_part(@args); ($q5,@args) = make_types_group_part(@args); The components are then combined as follows: $query = "SELECT $q1 FROM $q2 WHERE $q3 AND $q4 GROUP BY $q5"; If any of the query fragments contain the ? bind variable, then the same number of bind arguments must be provided in @args. The fragment-generating functions are described below. =cut sub get_types { my $self = shift; my ($srcseq,$class,$start,$stop,$want_count,$typelist) = @_; my $straight = $self->do_straight_join($srcseq,$start,$stop,[]) ? 'straight_join' : ''; my ($select,@args1) = $self->make_types_select_part($srcseq,$start,$stop,$want_count,$typelist); my ($from,@args2) = $self->make_types_from_part($srcseq,$start,$stop,$want_count,$typelist); my ($join,@args3) = $self->make_types_join_part($srcseq,$start,$stop,$want_count,$typelist); my ($where,@args4) = $self->make_types_where_part($srcseq,$start,$stop,$want_count,$typelist); my ($group,@args5) = $self->make_types_group_part($srcseq,$start,$stop,$want_count,$typelist); my $query = "SELECT $straight $select FROM $from WHERE $join AND $where"; $query .= " GROUP BY $group" if $group; my @args = (@args1,@args2,@args3,@args4,@args5); my $sth = $self->dbh->do_query($query,@args) or return; my (%result,%obj); while (my ($method,$source,$count) = $sth->fetchrow_array) { my $type = Bio::DB::GFF::Typename->new($method,$source); $result{$type} = $count; $obj{$type} = $type; } return $want_count ? %result : values %obj; } =head2 range_query Title : range_query Usage : $db->range_query($range_type,$refseq,$refclass,$start,$stop,$types,$order_by_group,$attributes,$binsize) Function: create statement handle for range/overlap queries Returns : a DBI statement handle Args : see below Status : Protected This method constructs the statement handle for this module's central query: given a range and/or a list of feature types, fetch their GFF records. The positional arguments are as follows: Argument Description $isrange A flag indicating that this is a range. query. Otherwise an overlap query is assumed. $refseq The reference sequence name (undef if no range). $refclass The reference sequence class (undef if no range). $start The start of the range (undef if none). $stop The stop of the range (undef if none). $types Array ref containing zero or feature types in the format [method,source]. $order_by_group A flag indicating that statement handler should group the features by group id (handy for iterative fetches) $attributes A hash containing select attributes. $binsize A bin size for generating tables of feature density. If successful, this method returns a statement handle. The handle is expected to return the fields described for get_features(). Internally, range_query() makes calls to the following methods, each of which is expected to be overridden in subclasses: $select = $self->make_features_select_part; $from = $self->make_features_from_part; $join = $self->make_features_join_part; ($where,@args) = $self->make_features_by_range_where_part($isrange,$srcseq,$class, $start,$stop,$types,$class); The query that is constructed looks like this: SELECT $select FROM $from WHERE $join AND $where The arguments that are returned from make_features_by_range_where_part() are passed to the statement handler's execute() method. range_query() also calls a do_straight_join() method, described below. If this method returns true, then the keyword "straight_join" is inserted right after SELECT. =cut sub range_query { my $self = shift; my($rangetype,$refseq,$class,$start,$stop,$types,$sparse,$order_by_group,$attributes,$bin) = @_; my $dbh = $self->features_db; # NOTE: straight_join is necessary in some database to force the right index to be used. my %a = (refseq=>$refseq,class=>$class,start=>$start,stop=>$stop,types=>$types,attributes=>$attributes,bin_width=>$bin); my $straight = $self->do_straight_join(\%a) ? 'straight_join' : ''; my $select = $self->make_features_select_part(\%a); my $from = $self->make_features_from_part($sparse,\%a); my $join = $self->make_features_join_part(\%a); my ($where,@args) = $self->make_features_by_range_where_part($rangetype,\%a); my ($group_by,@more_args) = $self->make_features_group_by_part(\%a); my $order_by = $self->make_features_order_by_part(\%a) if $order_by_group; my $query = "SELECT $straight $select FROM $from WHERE $join"; $query .= " AND $where" if $where; if ($group_by) { $query .= " GROUP BY $group_by"; push @args,@more_args; } $query .= " ORDER BY $order_by" if $order_by; my $sth = $self->dbh->do_query($query,@args); $sth; } =head2 make_features_by_range_where_part Title : make_features_by_range_where_part Usage : ($string,@args) = $db->make_features_select_part($isrange,$refseq,$class,$start,$stop,$types) Function: make where part of the features query Returns : the list ($query,@bind_args) Args : see below Status : Protected This method creates the part of the features query that immediately follows the WHERE keyword and is ANDed with the string returned by make_features_join_part(). The six positional arguments are a flag indicating whether to perform a range search or an overlap search, the reference sequence, class, start and stop, all of which define an optional range to search in, and an array reference containing a list [$method,$souce] pairs. The method result is a multi-element list containing the query string and the list of runtime arguments to bind to it with the execute() method. This method's job is to clean up arguments and perform consistency checking. The real work is done by the following abstract methods: Method Description refseq_query() Return the query string needed to match the reference sequence. range_query() Return the query string needed to find all features contained within a range. overlap_query() Return the query string needed to find all features that overlap a range. See Bio::DB::Adaptor::dbi::mysql for an example of how this works. =cut #' sub make_features_by_range_where_part { my $self = shift; my ($rangetype,$options) = @_; $options ||= {}; my ($refseq,$class,$start,$stop,$types,$attributes) = @{$options}{qw(refseq class start stop types attributes)}; my (@query,@args); if ($refseq) { my ($q,@a) = $self->refseq_query($refseq,$class); push @query,$q; push @args,@a; } if (defined $start or defined $stop) { $start = 0 unless defined($start); $stop = MAX_SEGMENT unless defined($stop); my ($range_query,@range_args) = $rangetype eq 'overlaps' ? $self->overlap_query($start,$stop) : $rangetype eq 'contains' ? $self->contains_query($start,$stop) : $rangetype eq 'contained_in' ? $self->contained_in_query($start,$stop) : (); push @query,$range_query; push @args,@range_args; } if (defined $types && @$types) { my ($type_query,@type_args) = $self->types_query($types); push @query,$type_query; push @args,@type_args; } if ($attributes) { my ($attribute_query,@attribute_args) = $self->make_features_by_attribute_where_part($attributes); push @query,"($attribute_query)"; push @args,@attribute_args; } my $query = join "\n\tAND ",@query; return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } =head2 do_straight_join Title : do_straight_join Usage : $boolean = $db->do_straight_join($refseq,$class,$start,$stop,$types) Function: optimization flag Returns : a flag Args : see range_query() Status : Protected This subroutine, called by range_query() returns a boolean flag. If true, range_query() will perform a straight join, which can be used to optimize certain SQL queries. The four arguments correspond to similarly-named arguments passed to range_query(). =cut sub do_straight_join { 0 } # false by default =head2 string_match Title : string_match Usage : $string = $db->string_match($field,$value) Function: create a SQL fragment for performing exact or regexp string matching Returns : query string Args : the table field and match value Status : public This method examines the passed value for meta characters. If so it produces a SQL fragment that performs a regular expression match. Otherwise, it produces a fragment that performs an exact string match. This method is not used in the module, but is available for use by subclasses. =cut sub string_match { my $self = shift; my ($field,$value) = @_; return qq($field = ?) if $value =~ /^[!@%&a-zA-Z0-9_\'\" ~-]+$/; return qq($field REGEXP ?); } =head2 exact_match Title : exact_match Usage : $string = $db->exact_match($field,$value) Function: create a SQL fragment for performing exact string matching Returns : query string Args : the table field and match value Status : public This method produces the SQL fragment for matching a field name to a constant string value. =cut sub exact_match { my $self = shift; my ($field,$value) = @_; return qq($field = ?); } =head2 search_notes Title : search_notes Usage : @search_results = $db->search_notes("full text search string",$limit) Function: Search the notes for a text string, using mysql full-text search Returns : array of results Args : full text search string, and an optional row limit Status : public This is a mysql-specific method. Given a search string, it performs a full-text search of the notes table and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 A Bio::DB::GFF::Featname object, suitable for passing to segment() column 2 The text of the note column 3 A relevance score. column 4 A Bio::DB::GFF::Typename object =cut sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my @words = $search_string =~ /(\w+)/g; my $regex = join '|',@words; my @searches = map {"fattribute_value LIKE '%${_}%'"} @words; my $search = join(' OR ',@searches); my $query = <dbh->do_query($query); my @results; while (my ($class,$name,$note,$method,$source) = $sth->fetchrow_array) { next unless $class && $name; # sorry, ignore NULL objects my @matches = $note =~ /($regex)/g; my $relevance = 10*@matches; my $featname = Bio::DB::GFF::Featname->new($class=>$name); my $type = Bio::DB::GFF::Typename->new($method,$source); push @results,[$featname,$note,$relevance,$type]; last if $limit && @results >= $limit; } @results; } =head2 meta Title : meta Usage : $value = $db->meta($name [,$newval]) Function: get or set a meta variable Returns : a string Args : meta variable name and optionally value Status : public Get or set a named metavariable for the database. Metavariables can be used for database-specific settings. This method calls two class-specific methods which must be implemented: make_meta_get_query() Returns a sql fragment which given a meta parameter name, returns its value. One bind variable. make_meta_set_query() Returns a sql fragment which takes two bind arguments, the parameter name and its value Don't make changes unless you know what you're doing! It will affect the persistent database. =cut sub meta { my $self = shift; my $param_name = uc shift; # getting if (@_) { my $value = shift; my $sql = $self->make_meta_set_query() or return; my $sth = $self->dbh->prepare_delayed($sql) or $self->error("Can't prepare $sql: ",$self->dbh->errstr), return; $sth->execute($param_name,$value) or $self->error("Can't execute $sql: ",$self->dbh->errstr), return; $sth->finish; return $self->{meta}{$param_name} = $value; } elsif (exists $self->{meta}{$param_name}) { return $self->{meta}{$param_name}; } else { undef $self->{meta}{$param_name}; # so that we don't check again my $sql = $self->make_meta_get_query() or return; my $sth = $self->dbh->prepare_delayed($sql) or $self->error("Can't prepare $sql: ",$self->dbh->errstr), return; $sth->execute($param_name) or $self->error("Can't execute $sql: ",$sth->errstr),return; my ($value) = $sth->fetchrow_array; $sth->finish; return $self->{meta}{$param_name} = $value; } } =head2 make_meta_get_query Title : make_meta_get_query Usage : $sql = $db->make_meta_get_query Function: return SQL fragment for getting a meta parameter Returns : SQL fragment Args : none Status : public By default this does nothing; meta parameters are not stored or retrieved. =cut sub make_meta_get_query { return 'SELECT fvalue FROM fmeta WHERE fname=?'; } sub dna_chunk_size { my $self = shift; $self->meta('chunk_size') || DNA_CHUNK_SIZE; } =head2 make_meta_set_query Title : make_meta_set_query Usage : $sql = $db->make_meta_set_query Function: return SQL fragment for setting a meta parameter Returns : SQL fragment Args : none Status : public By default this does nothing; meta parameters are not stored or retrieved. =cut sub make_meta_set_query { return; } =head2 default_meta_values Title : default_meta_values Usage : %values = $db->default_meta_values Function: empty the database Returns : a list of tag=>value pairs Args : none Status : protected This method returns a list of tag=Evalue pairs that contain default meta information about the database. It is invoked by initialize() to write out the default meta values. The base class version returns an empty list. For things to work properly, meta value names must be UPPERCASE. =cut sub default_meta_values { my $self = shift; my @values = $self->SUPER::default_meta_values; return ( @values, max_bin => MAX_BIN, min_bin => MIN_BIN, straight_join_limit => STRAIGHT_JOIN_LIMIT, chunk_size => DNA_CHUNK_SIZE, ); } sub min_bin { my $self = shift; return $self->meta('min_bin') || MIN_BIN; } sub max_bin { my $self = shift; return $self->meta('max_bin') || MAX_BIN; } sub straight_join_limit { my $self = shift; return $self->meta('straight_join_limit') || STRAIGHT_JOIN_LIMIT; } =head2 get_features_iterator Title : get_features_iterator Usage : $iterator = $db->get_features_iterator($search,$options,$callback) Function: create an iterator on a features() query Returns : A Bio::DB::GFF::Adaptor::dbi::iterator object Args : see get_features() Status : public This method is similar to get_features(), except that it returns an iterator across the query. See L. =cut sub get_features_iterator { my $self = shift; my ($search,$options,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $sth = $self->range_query(@{$search}{qw(rangetype refseq refclass start stop types)}, @{$options}{qw( sparse sort_by_group ATTRIBUTES BINSIZE)}) or return; return Bio::DB::GFF::Adaptor::dbi::iterator->new($sth,$callback); } ########################## loading and initialization ##################### =head2 do_initialize Title : do_initialize Usage : $success = $db->do_initialize($drop_all) Function: initialize the database Returns : a boolean indicating the success of the operation Args : a boolean indicating whether to delete existing data Status : protected This method will load the schema into the database. If $drop_all is true, then any existing data in the tables known to the schema will be deleted. Internally, this method calls schema() to get the schema data. =cut # Create the schema from scratch. # You will need create privileges for this. sub do_initialize { #shift->throw("do_initialize(): must be implemented by subclass"); my $self = shift; my $erase = shift; $self->drop_all if $erase; my $dbh = $self->features_db; my $schema = $self->schema; foreach my $table_name ($self->tables) { my $create_table_stmt = $schema->{$table_name}{table} ; $dbh->do($create_table_stmt) || warn $dbh->errstr; $self->create_other_schema_objects(\%{$schema->{$table_name}}); } 1; } =head2 finish_load Title : finish_load Usage : $db->finish_load Function: called after load_gff_line() Returns : number of records loaded Args : none Status : protected This method performs schema-specific cleanup after loading a set of GFF records. It finishes each of the statement handlers prepared by setup_load(). =cut sub finish_load { my $self = shift; my $dbh = $self->features_db or return; $dbh->do('UNLOCK TABLES') if $self->lock_on_load; foreach (keys %{$self->{load_stuff}{sth}}) { $self->{load_stuff}{sth}{$_}->finish; } my $counter = $self->{load_stuff}{counter}; delete $self->{load_stuff}; return $counter; } =head2 create_other_schema_objects Title : create_other_schema_objects Usage : $self->create_other_schema_objects($table_name) Function: create other schema objects like : indexes, sequences, triggers Returns : Args : Status : Abstract =cut sub create_other_schema_objects{ #shift->throw("create_other_schema_objects(): must be implemented by subclass"); my $self = shift ; my $table_schema = shift ; my $dbh = $self->features_db; foreach my $object_type(keys %$table_schema){ if ($object_type !~ /table/) { foreach my $object_name(keys %{$table_schema->{$object_type}}){ my $create_object_stmt = $table_schema->{$object_type}{$object_name}; $dbh->do($create_object_stmt) || warn $dbh->errstr; } } } 1; } =head2 drop_all Title : drop_all Usage : $db->drop_all Function: empty the database Returns : void Args : none Status : protected This method drops the tables known to this module. Internally it calls the abstract tables() method. =cut # Drop all the GFF tables -- dangerous! sub drop_all { #shift->throw("drop_all(): must be implemented by subclass"); my $self = shift; my $dbh = $self->features_db; my $schema = $self->schema; local $dbh->{PrintError} = 0; foreach ($self->tables) { $dbh->do("drop table $_") || warn $dbh->errstr; #when dropping a table - the indexes and triggers are being dropped automatically # sequences needs to be dropped - if there are any (Oracle, PostgreSQL) if ($schema->{$_}{sequence}){ foreach my $sequence_name(keys %{$schema->{$_}{sequence}}) { $dbh->do("drop sequence $sequence_name"); } } #$self->drop_other_schema_objects($_); } } =head2 clone The clone() method should be used when you want to pass the Bio::DB::GFF object to a child process across a fork(). The child must call clone() before making any queries. This method does two things: (1) it sets the underlying database handle's InactiveDestroy parameter to 1, thereby preventing the database connection from being destroyed in the parent when the dbh's destructor is called; (2) it replaces the dbh with the result of dbh-Eclone(), so that we now have an independent handle. =cut sub clone { my $self = shift; $self->features_db->clone; } =head1 QUERIES TO IMPLEMENT The following astract methods either return DBI statement handles or fragments of SQL. They must be implemented by subclasses of this module. See Bio::DB::GFF::Adaptor::dbi::mysql for examples. =head2 drop_other_schema_objects Title : drop_other_schema_objects Usage : $self->create_other_schema_objects($table_name) Function: create other schema objects like : indexes, sequences, triggers Returns : Args : Status : Abstract =cut sub drop_other_schema_objects{ #shift->throw("drop_other_schema_objects(): must be implemented by subclass"); } =head2 make_features_select_part Title : make_features_select_part Usage : $string = $db->make_features_select_part() Function: make select part of the features query Returns : a string Args : none Status : Abstract This abstract method creates the part of the features query that immediately follows the SELECT keyword. =cut sub make_features_select_part { shift->throw("make_features_select_part(): must be implemented by subclass"); } =head2 tables Title : tables Usage : @tables = $db->tables Function: return list of tables that belong to this module Returns : list of tables Args : none Status : protected This method lists the tables known to the module. =cut # return list of tables that "belong" to us. sub tables { my $schema = shift->schema; return keys %$schema; } =head2 schema Title : schema Usage : $schema = $db->schema Function: return the CREATE script for the schema Returns : a hashref Args : none Status : abstract This method returns an array ref containing the various CREATE statements needed to initialize the database tables. The keys are the table names, and the values are strings containing the appropriate CREATE statement. =cut sub schema { shift->throw("The schema() method must be implemented by subclass"); } =head2 DESTROY Title : DESTROY Usage : $db->DESTROY Function: disconnect database at destruct time Returns : void Args : none Status : protected This is the destructor for the class. =cut sub DESTROY { my $self = shift; $self->features_db->disconnect if defined $self->features_db; } ################## query cache ################## ######################################### ## Moved from mysql.pm and mysqlopt.pm ## ######################################### =head2 make_features_by_name_where_part Title : make_features_by_name_where_part Usage : $db->make_features_by_name_where_part Function: create the SQL fragment needed to select a feature by its group name & class Returns : a SQL fragment and bind arguments Args : see below Status : Protected =cut sub make_features_by_name_where_part { my $self = shift; my ($class,$name) = @_; if ($name =~ /\*/) { $name =~ s/%/\\%/g; $name =~ s/_/\\_/g; $name =~ tr/*/%/; return ("fgroup.gclass=? AND fgroup.gname LIKE ?",$class,$name); } else { return ("fgroup.gclass=? AND fgroup.gname=?",$class,$name); } } sub make_features_by_alias_where_part { my $self = shift; my ($class,$name) = @_; if ($name =~ /\*/) { $name =~ tr/*/%/; $name =~ s/_/\\_/g; return ("fgroup.gclass=? AND fattribute_to_feature.fattribute_value LIKE ? AND fgroup.gid=fdata.gid AND fattribute.fattribute_name in ('Alias','Name') AND fattribute_to_feature.fattribute_id=fattribute.fattribute_id AND fattribute_to_feature.fid=fdata.fid AND ftype.ftypeid=fdata.ftypeid",$class,$name) } else { return ("fgroup.gclass=? AND fattribute_to_feature.fattribute_value=? AND fgroup.gid=fdata.gid AND fattribute.fattribute_name in ('Alias','Name') AND fattribute_to_feature.fattribute_id=fattribute.fattribute_id AND fattribute_to_feature.fid=fdata.fid AND ftype.ftypeid=fdata.ftypeid",$class,$name); } } sub make_features_by_attribute_where_part { my $self = shift; my $attributes = shift; my @args; my @sql; foreach (keys %$attributes) { push @sql,"(fattribute.fattribute_name=? AND fattribute_to_feature.fattribute_value=?)"; push @args,($_,$attributes->{$_}); } return (join(' OR ',@sql),@args); } =head2 make_features_by_id_where_part Title : make_features_by_id_where_part Usage : $db->make_features_by_id_where_part($ids) Function: create the SQL fragment needed to select a set of features by their ids Returns : a SQL fragment and bind arguments Args : arrayref of IDs Status : Protected =cut sub make_features_by_id_where_part { my $self = shift; my $ids = shift; my $set = join ",",@$ids; return ("fdata.fid IN ($set)"); } =head2 make_features_by_gid_where_part Title : make_features_by_id_where_part Usage : $db->make_features_by_gid_where_part($ids) Function: create the SQL fragment needed to select a set of features by their ids Returns : a SQL fragment and bind arguments Args : arrayref of IDs Status : Protected =cut sub make_features_by_gid_where_part { my $self = shift; my $ids = shift; my $set = join ",",@$ids; return ("fgroup.gid IN ($set)"); } =head2 make_features_from_part Title : make_features_from_part Usage : $string = $db->make_features_from_part() Function: make from part of the features query Returns : a string Args : none Status : protected This method creates the part of the features query that immediately follows the FROM keyword. =cut sub make_features_from_part { my $self = shift; my $sparse = shift; my $options = shift || {}; return $options->{attributes} ? "fdata,ftype,fgroup,fattribute,fattribute_to_feature\n" : "fdata,ftype,fgroup\n"; } =head2 make_features_join_part Title : make_features_join_part Usage : $string = $db->make_features_join_part() Function: make join part of the features query Returns : a string Args : none Status : protected This method creates the part of the features query that immediately follows the WHERE keyword. =cut sub make_features_join_part { my $self = shift; my $options = shift || {}; return !$options->{attributes} ? <make_features_order_by_part() Function: make the ORDER BY part of the features() query Returns : a SQL fragment and bind arguments, if any Args : none Status : protected This method creates the part of the features query that immediately follows the ORDER BY part of the query issued by features() and related methods. =cut sub make_features_order_by_part { my $self = shift; my $options = shift || {}; return "fgroup.gname"; } =head2 make_features_group_by_part Title : make_features_group_by_part Usage : ($query,@args) = $db->make_features_group_by_part() Function: make the GROUP BY part of the features() query Returns : a SQL fragment and bind arguments, if any Args : none Status : protected This method creates the part of the features query that immediately follows the GROUP BY part of the query issued by features() and related methods. =cut sub make_features_group_by_part { my $self = shift; my $options = shift || {}; if (my $att = $options->{attributes}) { my $key_count = keys %$att; return unless $key_count > 1; return ("fdata.fid,fref,fstart,fstop,fsource, fmethod,fscore,fstrand,fphase,gclass,gname,ftarget_start, ftarget_stop,fdata.gid HAVING count(fdata.fid) > ?",$key_count-1); } elsif (my $b = $options->{bin_width}) { return "fref,fstart,fdata.ftypeid"; } } =head2 refseq_query Title : refseq_query Usage : ($query,@args) = $db->refseq_query($name,$class) Function: create SQL fragment that selects the desired reference sequence Returns : a list containing the query and bind arguments Args : reference sequence name and class Status : protected This method is called by make_features_by_range_where_part() to construct the part of the select WHERE section that selects a particular reference sequence. It returns a mult-element list in which the first element is the SQL fragment and subsequent elements are bind values. For example: sub refseq_query { my ($name,$class) = @_; return ('gff.refseq=? AND gff.refclass=?', $name,$class); } The current schema does not distinguish among different classes of reference sequence. =cut # IMPORTANT NOTE: THE MYSQL SCHEMA IGNORES THE SEQUENCE CLASS # THIS SHOULD BE FIXED sub refseq_query { my $self = shift; my ($refseq,$refclass) = @_; my $query = "fdata.fref=?"; return wantarray ? ($query,$refseq) : $self->dbh->dbi_quote($query,$refseq); } =head2 attributes Title : attributes Usage : @attributes = $db->attributes($id,$name) Function: get the attributes on a particular feature Returns : an array of string Args : feature ID Status : public Some GFF version 2 files use the groups column to store a series of attribute/value pairs. In this interpretation of GFF, the first such pair is treated as the primary group for the feature; subsequent pairs are treated as attributes. Two attributes have special meaning: "Note" is for backward compatibility and is used for unstructured text remarks. "Alias" is considered as a synonym for the feature name. If no name is provided, then attributes() returns a flattened hash, of attribute=Evalue pairs. This lets you do: %attributes = $db->attributes($id); Normally, attributes() will be called by the feature: @notes = $feature->attributes('Note'); =cut sub do_attributes { my $self = shift; my ($id,$tag) = @_; my $sth; if ($id) { my $from = 'fattribute_to_feature,fattribute'; my $join = 'fattribute.fattribute_id=fattribute_to_feature.fattribute_id'; my $where1 = 'fid=? AND fattribute_name=?'; my $where2 = 'fid=?'; $sth = defined($tag) ? $self->dbh->do_query("SELECT fattribute_value FROM $from WHERE $where1 AND $join",$id,$tag) : $self->dbh->do_query("SELECT fattribute_name,fattribute_value FROM $from WHERE $where2 AND $join",$id); } else { $sth = $self->dbh->do_query("SELECT fattribute_name FROM fattribute"); } my @result; while (my @stuff = $sth->fetchrow_array) { push @result,@stuff; } $sth->finish; return @result; } =head2 overlap_query_nobin Title : overlap_query Usage : ($query,@args) = $db->overlap_query($start,$stop) Function: create SQL fragment that selects the desired features by range Returns : a list containing the query and bind arguments Args : the start and stop of a range, inclusive Status : protected This method is called by make_features_byrange_where_part() to construct the part of the select WHERE section that selects a set of features that overlap a range. It returns a multi-element list in which the first element is the SQL fragment and subsequent elements are bind values. sub overlap_query_nobin { my ($start,$stop) = @_; return ('gff.stopE=? AND gff.startE=?', $start,$stop); =cut # find features that overlap a given range sub overlap_query_nobin { my $self = shift; my ($start,$stop) = @_; my $query = qq(fdata.fstop>=? AND fdata.fstart<=?); return wantarray ? ($query,$start,$stop) : $self->dbh->dbi_quote($query,$start,$stop); } =head2 contains_query_nobin Title : contains_query Usage : ($query,@args) = $db->contains_query_nobin($start,$stop) Function: create SQL fragment that selects the desired features by range Returns : a list containing the query and bind arguments Args : the start and stop of a range, inclusive Status : protected This method is called by make_features_byrange_where_part() to construct the part of the select WHERE section that selects a set of features entirely enclosed by a range. It returns a multi-element list in which the first element is the SQL fragment and subsequent elements are bind values. For example: sub contains_query_nobin { my ($start,$stop) = @_; return ('gff.start>=? AND gff.stop<=?', $start,$stop); =cut # find features that are completely contained within a range sub contains_query_nobin { my $self = shift; my ($start,$stop) = @_; my $query = qq(fdata.fstart>=? AND fdata.fstop<=?); return wantarray ? ($query,$start,$stop) : $self->dbh->dbi_quote($query,$start,$stop); } =head2 contained_in_query_nobin Title : contained_in_query_nobin Usage : ($query,@args) = $db->contained_in_query($start,$stop) Function: create SQL fragment that selects the desired features by range Returns : a list containing the query and bind arguments Args : the start and stop of a range, inclusive Status : protected This method is called by make_features_byrange_where_part() to construct the part of the select WHERE section that selects a set of features entirely enclosed by a range. It returns a multi-element list in which the first element is the SQL fragment and subsequent elements are bind values.For example: sub contained_in_query_nobin { my ($start,$stop) = @_; return ('gff.start<=? AND gff.stop>=?', $start,$stop); } =cut # find features that are completely contained within a range sub contained_in_query_nobin { my $self = shift; my ($start,$stop) = @_; my $query = qq(fdata.fstart<=? AND fdata.fstop>=?); return wantarray ? ($query,$start,$stop) : $self->dbh->dbi_quote($query,$start,$stop); } =head2 types_query Title : types_query Usage : ($query,@args) = $db->types_query($types) Function: create SQL fragment that selects the desired features by type Returns : a list containing the query and bind arguments Args : an array reference containing the types Status : protected This method is called by make_features_byrange_where_part() to construct the part of the select WHERE section that selects a set of features based on their type. It returns a multi-element list in which the first element is the SQL fragment and subsequent elements are bind values. The argument is an array reference containing zero or more [$method,$source] pairs. =cut # generate the fragment of SQL responsible for searching for # features with particular types and methods sub types_query { my $self = shift; my $types = shift; my @method_queries; my @args; for my $type (@$types) { my ($method,$source) = @$type; my ($mlike, $slike) = (0, 0); if ($method && $method =~ m/\.\*/) { $method =~ s/%/\\%/g; $method =~ s/_/\\_/g; $method =~ s/\.\*\??/%/g; $mlike++; } if ($source && $source =~ m/\.\*/) { $source =~ s/%/\\%/g; $source =~ s/_/\\_/g; $source =~ s/\.\*\??/%/g; $slike++; } my @pair; if (defined $method && length $method) { push @pair, $mlike ? qq(fmethod LIKE ?) : qq(fmethod = ?); push @args, $method; } if (defined $source && length $source) { push @pair, $slike ? qq(fsource LIKE ?) : qq(fsource = ?); push @args, $source; } push @method_queries,"(" . join(' AND ',@pair) .")" if @pair; } my $query = " (".join(' OR ',@method_queries).")\n" if @method_queries; return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } =head2 make_types_select_part Title : make_types_select_part Usage : ($string,@args) = $db->make_types_select_part(@args) Function: create the select portion of the SQL for fetching features type list Returns : query string and bind arguments Args : see below Status : protected This method is called by get_types() to generate the query fragment and bind arguments for the SELECT part of the query that retrieves lists of feature types. The four positional arguments are as follows: $refseq reference sequence name $start start of region $stop end of region $want_count true to return the count of this feature type If $want_count is false, the SQL fragment returned must produce a list of feature types in the format (method, source). If $want_count is true, the returned fragment must produce a list of feature types in the format (method, source, count). =cut #------------------------- support for the types() query ------------------------ sub make_types_select_part { my $self = shift; my ($srcseq,$start,$stop,$want_count) = @_; my $query = $want_count ? 'ftype.fmethod,ftype.fsource,count(fdata.ftypeid)' : 'fmethod,fsource'; return $query; } =head2 make_types_from_part Title : make_types_from_part Usage : ($string,@args) = $db->make_types_from_part(@args) Function: create the FROM portion of the SQL for fetching features type lists Returns : query string and bind arguments Args : see below Status : protected This method is called by get_types() to generate the query fragment and bind arguments for the FROM part of the query that retrieves lists of feature types. The four positional arguments are as follows: $refseq reference sequence name $start start of region $stop end of region $want_count true to return the count of this feature type If $want_count is false, the SQL fragment returned must produce a list of feature types in the format (method, source). If $want_count is true, the returned fragment must produce a list of feature types in the format (method, source, count). =cut sub make_types_from_part { my $self = shift; my ($srcseq,$start,$stop,$want_count) = @_; my $query = defined($srcseq) || $want_count ? 'fdata,ftype' : 'ftype'; return $query; } =head2 make_types_join_part Title : make_types_join_part Usage : ($string,@args) = $db->make_types_join_part(@args) Function: create the JOIN portion of the SQL for fetching features type lists Returns : query string and bind arguments Args : see below Status : protected This method is called by get_types() to generate the query fragment and bind arguments for the JOIN part of the query that retrieves lists of feature types. The four positional arguments are as follows: $refseq reference sequence name $start start of region $stop end of region $want_count true to return the count of this feature type =cut sub make_types_join_part { my $self = shift; my ($srcseq,$start,$stop,$want_count) = @_; my $query = defined($srcseq) || $want_count ? 'fdata.ftypeid=ftype.ftypeid' : ''; return $query || '1=1'; } =head2 make_types_where_part Title : make_types_where_part Usage : ($string,@args) = $db->make_types_where_part(@args) Function: create the WHERE portion of the SQL for fetching features type lists Returns : query string and bind arguments Args : see below Status : protected This method is called by get_types() to generate the query fragment and bind arguments for the WHERE part of the query that retrieves lists of feature types. The four positional arguments are as follows: $refseq reference sequence name $start start of region $stop end of region $want_count true to return the count of this feature type =cut sub make_types_where_part { my $self = shift; my ($srcseq,$start,$stop,$want_count,$typelist) = @_; my (@query,@args); if (defined($srcseq)) { push @query,'fdata.fref=?'; push @args,$srcseq; if (defined $start or defined $stop) { $start = 1 unless defined $start; $stop = MAX_SEGMENT unless defined $stop; my ($q,@a) = $self->overlap_query($start,$stop); push @query,"($q)"; push @args,@a; } } if (defined $typelist && @$typelist) { my ($q,@a) = $self->types_query($typelist); push @query,($q); push @args,@a; } my $query = @query ? join(' AND ',@query) : '1=1'; return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } =head2 make_types_group_part Title : make_types_group_part Usage : ($string,@args) = $db->make_types_group_part(@args) Function: create the GROUP BY portion of the SQL for fetching features type lists Returns : query string and bind arguments Args : see below Status : protected This method is called by get_types() to generate the query fragment and bind arguments for the GROUP BY part of the query that retrieves lists of feature types. The four positional arguments are as follows: $refseq reference sequence name $start start of region $stop end of region $want_count true to return the count of this feature type =cut sub make_types_group_part { my $self = shift; my ($srcseq,$start,$stop,$want_count) = @_; return unless $srcseq or $want_count; return 'ftype.ftypeid,ftype.fmethod,ftype.fsource'; } =head2 get_feature_id Title : get_feature_id Usage : $integer = $db->get_feature_id($ref,$start,$stop,$typeid,$groupid) Function: get the ID of a feature Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature. It is ony needed when replacing a feature with new information. =cut # this method is called when needed to look up a feature's ID sub get_feature_id { my $self = shift; my ($ref,$start,$stop,$typeid,$groupid) = @_; my $s = $self->{load_stuff}; unless ($s->{get_feature_id}) { my $dbh = $self->features_db; $s->{get_feature_id} = $dbh->prepare_delayed('SELECT fid FROM fdata WHERE fref=? AND fstart=? AND fstop=? AND ftypeid=? AND gid=?'); } my $sth = $s->{get_feature_id} or return; $sth->execute($ref,$start,$stop,$typeid,$groupid) or return; my ($fid) = $sth->fetchrow_array; return $fid; } =head2 make_abscoord_query Title : make_abscoord_query Usage : $sth = $db->make_abscoord_query($name,$class); Function: create query that finds the reference sequence coordinates given a landmark & classa Returns : a DBI statement handle Args : name and class of landmark Status : protected The statement handler should return rows containing five fields: 1. reference sequence name 2. reference sequence class 3. start position 4. stop position 5. strand ("+" or "-") This query always returns "Sequence" as the class of the reference sequence. =cut # given sequence name, return (reference,start,stop,strand) sub make_abscoord_query { my $self = shift; my ($name,$class,$refseq) = @_; #my $query = GETSEQCOORDS; my $query = $self->getseqcoords_query(); my $getforcedseqcoords = $self->getforcedseqcoords_query() ; if ($name =~ /\*/) { $name =~ s/%/\\%/g; $name =~ s/_/\\_/g; $name =~ tr/*/%/; $query =~ s/gname=\?/gname LIKE ?/; } defined $refseq ? $self->dbh->do_query($getforcedseqcoords,$name,$class,$refseq) : $self->dbh->do_query($query,$name,$class); } sub make_aliasabscoord_query { my $self = shift; my ($name,$class) = @_; #my $query = GETALIASCOORDS; my $query = $self->getaliascoords_query(); if ($name =~ /\*/) { $name =~ s/%/\\%/g; $name =~ s/_/\\_/g; $name =~ tr/*/%/; $query =~ s/gname=\?/gname LIKE ?/; } $self->dbh->do_query($query,$name,$class); } sub getseqcoords_query { shift->throw("getseqcoords_query(): must be implemented by a subclass"); } sub getaliascoords_query { shift->throw("getaliascoords_query(): must be implemented by a subclass"); } sub bin_query { my $self = shift; my ($start,$stop,$minbin,$maxbin) = @_; if ($start && $start < 0 && $stop > 0) { # split the queries my ($lower_query,@lower_args) = $self->_bin_query($start,0,$minbin,$maxbin); my ($upper_query,@upper_args) = $self->_bin_query(0,$stop,$minbin,$maxbin); my $query = "$lower_query\n\t OR $upper_query"; my @args = (@lower_args,@upper_args); return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } else { return $self->_bin_query($start,$stop,$minbin,$maxbin); } } sub _bin_query { my $self = shift; my ($start,$stop,$minbin,$maxbin) = @_; my ($query,@args); $start = 0 unless defined($start); $stop = $self->meta('max_bin') unless defined($stop); my @bins; $minbin = defined $minbin ? $minbin : $self->min_bin; $maxbin = defined $maxbin ? $maxbin : $self->max_bin; my $tier = $maxbin; while ($tier >= $minbin) { my ($tier_start,$tier_stop) = (bin_bot($tier,$start)-EPSILON(),bin_top($tier,$stop)+EPSILON()); ($tier_start,$tier_stop) = ($tier_stop,$tier_start) if $tier_start > $tier_stop; # can happen when working with negative coordinates if ($tier_start == $tier_stop) { push @bins,'fbin=?'; push @args,$tier_start; } else { push @bins,'fbin between ? and ?'; push @args,($tier_start,$tier_stop); } $tier /= 10; } $query = join("\n\t OR ",@bins); return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } # find features that overlap a given range sub overlap_query { my $self = shift; my ($start,$stop) = @_; my ($query,@args); my ($iq,@iargs) = $self->overlap_query_nobin($start,$stop); if (OPTIMIZE) { my ($bq,@bargs) = $self->bin_query($start,$stop); $query = "($bq)\n\tAND $iq"; @args = (@bargs,@iargs); } else { $query = $iq; @args = @iargs; } return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } # find features that are completely contained within a ranged sub contains_query { my $self = shift; my ($start,$stop) = @_; my ($bq,@bargs) = $self->bin_query($start,$stop,undef,bin($start,$stop,$self->min_bin)); my ($iq,@iargs) = $self->contains_query_nobin($start,$stop); my $query = "($bq)\n\tAND $iq"; my @args = (@bargs,@iargs); return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } # find features that are completely contained within a range sub contained_in_query { my $self = shift; my ($start,$stop) = @_; my ($bq,@bargs) = $self->bin_query($start,$stop,abs($stop-$start)+1,undef); my ($iq,@iargs) = $self->contained_in_query_nobin($start,$stop); my $query = "($bq)\n\tAND $iq"; my @args = (@bargs,@iargs); return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } # implement the _delete_fattribute_to_feature() method sub _delete_fattribute_to_feature { my $self = shift; my @feature_ids = @_; my $dbh = $self->features_db; my $fields = join ',',map{$dbh->quote($_)} @feature_ids; my $query = "delete from fattribute_to_feature where fid in ($fields)"; warn "$query\n" if $self->debug; my $result = $dbh->do($query); defined $result or $self->throw($dbh->errstr); $result; } # implement the _delete_features() method sub _delete_features { my $self = shift; my @feature_ids = @_; my $dbh = $self->features_db; my $fields = join ',',map{$dbh->quote($_)} @feature_ids; # delete from fattribute_to_feature $self->_delete_fattribute_to_feature(@feature_ids); my $query = "delete from fdata where fid in ($fields)"; warn "$query\n" if $self->debug; my $result = $dbh->do($query); defined $result or $self->throw($dbh->errstr); $result; } # implement the _delete_groups() method sub _delete_groups { my $self = shift; my @group_ids = @_; my $dbh = $self->features_db; my $fields = join ',',map{$dbh->quote($_)} @group_ids; foreach my $gid (@group_ids){ my @features = $self->get_feature_by_gid($gid); $self->delete_features(@features); } my $query = "delete from fgroup where gid in ($fields)"; warn "$query\n" if $self->debug; my $result = $dbh->do($query); defined $result or $self->throw($dbh->errstr); $result; } # implement the _delete() method sub _delete { my $self = shift; my $delete_spec = shift; my $ranges = $delete_spec->{segments} || []; my $types = $delete_spec->{types} || []; my $force = $delete_spec->{force}; my $range_type = $delete_spec->{range_type}; my $dbh = $self->features_db; my $query = 'delete from fdata'; my @where; my @range_part; for my $segment (@$ranges) { my $ref = $dbh->quote($segment->abs_ref); my $start = $segment->abs_start; my $stop = $segment->abs_stop; my $range = $range_type eq 'overlaps' ? $self->overlap_query($start,$stop) : $range_type eq 'contains' ? $self->contains_query($start,$stop) : $range_type eq 'contained_in' ? $self->contained_in_query($start,$stop) : $self->throw("Invalid range type '$range_type'"); push @range_part,"(fref=$ref AND $range)"; } push @where,'('. join(' OR ',@range_part).')' if @range_part; # get all the types if (@$types) { my $types_where = $self->types_query($types); my $types_query = "select ftypeid from ftype where $types_where"; my $result = $dbh->selectall_arrayref($types_query); my @typeids = map {$_->[0]} @$result; my $typelist = join ',',map{$dbh->quote($_)} @typeids; $typelist ||= "0"; # don't cause DBI to die with invalid SQL when # unknown feature types were requested. push @where,"(ftypeid in ($typelist))"; } $self->throw("This operation would delete all feature data and -force not specified") unless @where || $force; $query .= " where ".join(' and ',@where) if @where; warn "$query\n" if $self->debug; my $result = $dbh->do($query); defined $result or $self->throw($dbh->errstr); $result; } =head2 feature_summary Title : feature_summary Usage : $summary = $db->feature_summary(@args) Function: returns a coverage summary across indicated region/type Returns : a Bio::SeqFeatureI object containing the "coverage" tag Args : see below Status : public This method is used to get coverage density information across a region of interest. You provide it with a region of interest, optional a list of feature types, and a count of the number of bins over which you want to calculate the coverage density. An object is returned corresponding to the requested region. It contains a tag called "coverage" that will return an array ref of "bins" length. Each element of the array describes the number of features that overlap the bin at this postion. Arguments: Argument Description -------- ----------- -seq_id Sequence ID for the region -start Start of region -end End of region -type/-types Feature type of interest or array ref of types -bins Number of bins across region. Defaults to 1000. -iterator Return an iterator across the region Note that this method uses an approximate algorithm that is only accurate to 500 bp, so when dealing with bins that are smaller than 1000 bp, you may see some shifting of counts between adjacent bins. Although an -iterator option is provided, the method only ever returns a single feature, so this is fairly useless. =cut sub feature_summary { my $self = shift; my ($seq_name,$start,$end,$types,$bins,$iterator) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'], ['TYPES','TYPE','PRIMARY_TAG'], 'BINS', 'ITERATOR', ],@_); my ($coverage,$tag) = $self->coverage_array(-seqid=> $seq_name, -start=> $start, -end => $end, -type => $types, -bins => $bins) or return; my $score = 0; for (@$coverage) { $score += $_ } $score /= @$coverage; my $feature = Bio::SeqFeature::Lite->new(-seq_id => $seq_name, -start => $start, -end => $end, -type => $tag, -score => $score, -attributes => { coverage => [$coverage] }); return $iterator ? Bio::DB::GFF::FeatureIterator->new($feature) : $feature; } =head2 coverage_array Title : coverage_array Usage : $arrayref = $db->coverage_array(@args) Function: returns a coverage summary across indicated region/type Returns : an array reference Args : see below Status : public This method is used to get coverage density information across a region of interest. The arguments are identical to feature_summary, except that instead of returning a Bio::SeqFeatureI object, it returns an array reference of the desired number of bins. The value of each element corresponds to the number of features in the bin. Arguments: Argument Description -------- ----------- -seq_id Sequence ID for the region -start Start of region -end End of region -type/-types Feature type of interest or array ref of types -bins Number of bins across region. Defaults to 1000. Note that this method uses an approximate algorithm that is only accurate to 500 bp, so when dealing with bins that are smaller than 1000 bp, you may see some shifting of counts between adjacent bins. =cut sub coverage_array { my $self = shift; my ($seq_name,$start,$end,$types,$bins) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'], ['TYPES','TYPE','PRIMARY_TAG'],'BINS'],@_); $types = $self->parse_types($types); my $dbh = $self->features_db; $bins ||= 1000; $start ||= 1; unless ($end) { my $segment = $self->segment($seq_name) or $self->throw("unknown seq_id $seq_name"); $end = $segment->end; } my $binsize = ($end-$start+1)/$bins; my $seqid = $seq_name; return [] unless $seqid; # where each bin starts my @his_bin_array = map {$start + $binsize * $_} (0..$bins); my @sum_bin_array = map {int(($_-1)/SUMMARY_BIN_SIZE)} @his_bin_array; my $interval_stats_table = 'finterval_stats'; # pick up the type ids my ($type_from,@a) = $self->types_query($types); my $query = "select ftypeid,fmethod,fsource from ftype where $type_from"; my $sth = $dbh->prepare_delayed($query); my (@t,$report_tag); $sth->execute(@a); while (my ($t,$method,$source) = $sth->fetchrow_array) { $report_tag ||= "$method:$source"; push @t,$t; } my %bins; my $sql = <= ? LIMIT 1 END ; $sth = $dbh->prepare_delayed($sql) or warn $dbh->errstr; eval { for my $typeid (@t) { for (my $i=0;$i<@sum_bin_array;$i++) { my @args = ($typeid,$seqid,$sum_bin_array[$i]); $self->_print_query($sql,@args) if $self->debug; $sth->execute(@args) or $self->throw($sth->errstr); my ($bin,$cum_count) = $sth->fetchrow_array; push @{$bins{$typeid}},[$bin,$cum_count]; } } }; return unless %bins; my @merged_bins; my $firstbin = int(($start-1)/$binsize); for my $type (keys %bins) { my $arry = $bins{$type}; my $last_count = $arry->[0][1]; my $last_bin = -1; my $i = 0; my $delta; for my $b (@$arry) { my ($bin,$count) = @$b; $delta = $count - $last_count if $bin > $last_bin; $merged_bins[$i++] = $delta; $last_count = $count; $last_bin = $bin; } } return wantarray ? (\@merged_bins,$report_tag) : \@merged_bins; } =head2 build_summary_statistics Title : build_summary_statistics Usage : $db->build_summary_statistics Function: prepares the table needed to call feature_summary() Returns : nothing Args : none Status : public This method is used to build the summary statistics table that is used by the feature_summary() and coverage_array() methods. It needs to be called whenever the database is updated. =cut sub build_summary_statistics { my $self = shift; my $interval_stats_table = 'finterval_stats'; my $dbh = $self->dbh; $dbh->begin_work; my $sbs = SUMMARY_BIN_SIZE; my $result = eval { $self->_add_interval_stats_table; $self->disable_keys($interval_stats_table); $dbh->do("DELETE FROM $interval_stats_table"); my $insert = $dbh->prepare(<throw($dbh->errstr); INSERT INTO $interval_stats_table (ftypeid,fref,fbin,fcum_count) VALUES (?,?,?,?) END ; my $sql = 'select ftypeid,fref,fstart,fstop from fdata order by ftypeid,fref,fstart'; my $select = $dbh->prepare($sql) or $self->throw($dbh->errstr); my $current_bin = -1; my ($current_type,$current_seqid,$count); my $cum_count = 0; my (%residuals,$last_bin); my $le = -t \*STDERR ? "\r" : "\n"; $select->execute; while (my($typeid,$seqid,$start,$end) = $select->fetchrow_array) { print STDERR $count," features processed$le" if ++$count % 1000 == 0; my $bin = int($start/$sbs); $current_type ||= $typeid; $current_seqid ||= $seqid; # because the input is sorted by start, no more features will contribute to the # current bin so we can dispose of it if ($bin != $current_bin) { if ($seqid != $current_seqid or $typeid != $current_type) { # load all bins left over $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid); %residuals = () ; $cum_count = 0; } else { # load all up to current one $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid,$current_bin); } } $last_bin = $current_bin; ($current_seqid,$current_type,$current_bin) = ($seqid,$typeid,$bin); # summarize across entire spanned region my $last_bin = int(($end-1)/$sbs); for (my $b=$bin;$b<=$last_bin;$b++) { $residuals{$b}++; } } # handle tail case # load all bins left over $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid); $self->enable_keys($interval_stats_table); 1; }; if ($result) { $dbh->commit } else { warn "Can't build summary statistics: $@"; $dbh->rollback }; print STDERR "\n"; } sub _load_bins { my $self = shift; my ($insert,$residuals,$cum_count,$type,$seqid,$stop_after) = @_; for my $b (sort {$a<=>$b} keys %$residuals) { last if defined $stop_after and $b > $stop_after; $$cum_count += $residuals->{$b}; my @args = ($type,$seqid,$b,$$cum_count); $insert->execute(@args) or warn $insert->errstr; delete $residuals->{$b}; # no longer needed } } sub _add_interval_stats_table { my $self = shift; my $schema = $self->schema; my $create_table_stmt = $schema->{'finterval_stats'}{'table'}; my $dbh = $self->features_db; $dbh->do("drop table finterval_stats"); $dbh->do($create_table_stmt) || warn $dbh->errstr; } sub disable_keys { } # noop sub enable_keys { } # noop 1; __END__ =head1 BUGS Schemas need work to support multiple hierarchical groups. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Adaptor/memory.pm000444000765000024 5103112254227314 20316 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::memory; =head1 NAME Bio::DB::GFF::Adaptor::memory -- Bio::DB::GFF database adaptor for in-memory databases =head1 SYNOPSIS use Bio::DB::GFF; my $db = Bio::DB::GFF->new(-adaptor=> 'memory', -gff => 'my_features.gff', -fasta => 'my_dna.fa' ); or my $db = Bio::DB::GFF->new(-adaptor=>'memory'); $db->load_gff_file('my_features.gff'); $db->load_fasta_file('my_dna.fa'); See L for other methods. =head1 DESCRIPTION This adaptor implements an in-memory version of Bio::DB::GFF. It can be used to store and retrieve SHORT GFF files. It inherits from Bio::DB::GFF. =head1 CONSTRUCTOR Use Bio::DB::GFF-Enew() to construct new instances of this class. Three named arguments are recommended: Argument Description -adaptor Set to "memory" to create an instance of this class. -gff Read the indicated file or directory of .gff file. -fasta Read the indicated file or directory of fasta files. -dir Indicates a directory containing .gff and .fa files If you use the -dir option and the indicated directory is writable by the current process, then this library will create a FASTA file index that greatly diminishes the memory usage of this module. Alternatively you may create an empty in-memory object using just the -adaptor=E'memory' argument and then call the load_gff_file() and load_fasta_file() methods to load GFF and/or sequence information. This is recommended in CGI/mod_perl/fastCGI environments because these methods do not modify STDIN, unlike the constructor. =head1 METHODS See L for inherited methods. =head1 BUGS none ;-) =head1 SEE ALSO L, L =head1 AUTHOR Shuly Avraham Eavraham@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; # AUTHOR: Shulamit Avraham # This module needs to be cleaned up and documented # Bio::DB::GFF::Adaptor::memory -- in-memory db adaptor # implements the low level handling of data which stored in memory. # This adaptor implements a specific in memory schema that is compatible with Bio::DB::GFF. # Inherits from Bio::DB::GFF. use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::GFF::Adaptor::memory::iterator; use File::Basename 'dirname'; use Bio::DB::GFF::Adaptor::memory::feature_serializer qw(@hash2array_map); use constant MAX_SEGMENT => 1_000_000_000; # the largest a segment can get use base qw(Bio::DB::GFF); sub new { my $class = shift ; my ($file,$fasta,$dbdir,$preferred_groups) = rearrange([ [qw(GFF FILE)], 'FASTA', [qw(DSN DB DIR DIRECTORY)], 'PREFERRED_GROUPS', ],@_); # fill in object my $self = bless{ data => [] },$class; $self->preferred_groups($preferred_groups) if defined $preferred_groups; $file ||= $dbdir; $fasta ||= $dbdir; $self->load_gff($file) if $file; $self->load_or_store_fasta($fasta) if $fasta; return $self; } sub load_or_store_fasta { my $self = shift; my $fasta = shift; if ((-f $fasta && -w dirname($fasta)) or (-d $fasta && -w $fasta)) { require Bio::DB::Fasta; my $dna_db = eval {Bio::DB::Fasta->new($fasta);} or warn "$@\nCan't open sequence file(s). Use -gff instead of -dir if you wish to load features without sequence.\n"; $dna_db && $self->dna_db($dna_db); } else { $self->load_fasta($fasta); } } sub dna_db { my $self = shift; my $d = $self->{dna_db}; $self->{dna_db} = shift if @_; $d; } sub insert_sequence { my $self = shift; my($id,$offset,$seq) = @_; $self->{dna}{$id} .= $seq; } # low-level fetch of a DNA substring given its # name, class and the desired range. sub get_dna { my $self = shift; my ($id,$start,$stop,$class) = @_; if (my $dna_db = $self->dna_db) { return $dna_db->seq($id,$start=>$stop); } return '' unless $self->{dna}; return $self->{dna}{$id} unless defined $start || defined $stop; $start = 1 if !defined $start; my $reversed = 0; if ($start > $stop) { $reversed++; ($start,$stop) = ($stop,$start); } my $dna = substr($self->{dna}{$id},$start-1,$stop-$start+1); if ($reversed) { $dna =~ tr/gatcGATC/ctagCTAG/; $dna = reverse $dna; } $dna; } sub setup_load { my $self = shift; $self->{tmp} = {}; $self->{data} = []; 1; } sub finish_load { my $self = shift; my $idx = 0; foreach my $arrayref (values %{$self->{tmp}}) { foreach (@$arrayref) {$_->{feature_id} = $idx++; } push @{$self->{data}},@$arrayref; } 1; } # this method loads the feature as a hash into memory - # keeps an array of features-hashes as an in-memory db sub load_gff_line { my $self = shift; my $feature_hash = shift; $feature_hash->{strand} = '' if $feature_hash->{strand} && $feature_hash->{strand} eq '.'; $feature_hash->{phase} = '' if $feature_hash->{phase} && $feature_hash->{phase} eq '.'; $feature_hash->{gclass} = 'Sequence' unless length $feature_hash->{gclass} > 0; # sort by group please push @{$self->{tmp}{$feature_hash->{gclass},$feature_hash->{gname}}},$feature_hash; } # given sequence name, return (reference,start,stop,strand) sub get_abscoords { my $self = shift; my ($name,$class,$refseq) = @_; my %refs; my $regexp; if ($name =~ /[*?]/) { # uh oh regexp time $name = quotemeta($name); $name =~ s/\\\*/.*/g; $name =~ s/\\\?/.?/g; $regexp++; } # Find all features that have the requested name and class. # Sort them by reference point. for my $feature (@{$self->{data}}) { my $no_match_class_name; my $empty_class_name; my $class_matches = !defined($feature->{gclass}) || length($feature->{gclass}) == 0 || $feature->{gclass} eq $class; if (defined $feature->{gname}) { my $matches = $class_matches && ($regexp ? $feature->{gname} =~ /$name/i : lc($feature->{gname}) eq lc($name)); $no_match_class_name = !$matches; # to accomodate Shuly's interesting logic } else{ $empty_class_name = 1; } if ($no_match_class_name){ my $feature_attributes = $feature->{attributes}; my $attributes = {Alias => $name}; if (!$self->_matching_attributes($feature_attributes,$attributes)){ next; } } push @{$refs{$feature->{ref}}},$feature; } # find out how many reference points we recovered if (! %refs) { $self->error("$name not found in database"); return; } # compute min and max my ($ref) = keys %refs; my @found = @{$refs{$ref}}; my ($strand,$start,$stop); my @found_segments; foreach my $ref (keys %refs) { next if defined($refseq) and lc($ref) ne lc($refseq); my @found = @{$refs{$ref}}; my ($strand,$start,$stop,$name); foreach (@found) { $strand ||= $_->{strand}; $strand = '+' if $strand && $strand eq '.'; $start = $_->{start} if !defined($start) || $start > $_->{start}; $stop = $_->{stop} if !defined($stop) || $stop < $_->{stop}; $name ||= $_->{gname}; } push @found_segments,[$ref,$class,$start,$stop,$strand,$name]; } return \@found_segments; } sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my @results; my @words = map {quotemeta($_)} $search_string =~ /(\w+)/g; my $search = join '|',@words; for my $feature (@{$self->{data}}) { next unless defined $feature->{gclass} && defined $feature->{gname}; # ignore NULL objects next unless $feature->{attributes}; my @attributes = @{$feature->{attributes}}; my @values = map {$_->[1]} @attributes; my $value = "@values"; my $matches = 0; for my $w (@words) { my @hits = $value =~ /($w)/ig; $matches += @hits; } next unless $matches; my $relevance = 10 * $matches; my $featname = Bio::DB::GFF::Featname->new($feature->{gclass}=>$feature->{gname}); my $note; $note = join ' ',map {$_->[1]} grep {$_->[0] eq 'Note'} @{$feature->{attributes}}; $note .= join ' ',grep /$search/,map {$_->[1]} grep {$_->[0] ne 'Note'} @{$feature->{attributes}}; my $type = Bio::DB::GFF::Typename->new($feature->{method},$feature->{source}); push @results,[$featname,$note,$relevance,$type]; last if defined $limit && @results >= $limit; } #added result filtering so that this method returns the expected results #this section of code used to be in GBrowse's do_keyword_search method my $match_sub = 'sub {'; foreach (split /\s+/,$search_string) { $match_sub .= "return unless \$_[0] =~ /\Q$_\E/i; "; } $match_sub .= "};"; my $match = eval $match_sub; my @matches = grep { $match->($_->[1]) } @results; return @matches; } sub _delete_features { my $self = shift; my @feature_ids = sort {$b<=>$a} @_; my $removed = 0; foreach (@feature_ids) { next unless $_ >= 0 && $_ < @{$self->{data}}; $removed += defined splice(@{$self->{data}},$_,1); } $removed; } sub _delete { my $self = shift; my $delete_spec = shift; my $ranges = $delete_spec->{segments} || []; my $types = $delete_spec->{types} || []; my $force = $delete_spec->{force}; my $range_type = $delete_spec->{range_type}; my $deleted = 0; if (@$ranges) { my @args = @$types ? (-type=>$types) : (); push @args,(-range_type => $range_type); my %ids_to_remove = map {$_->id => 1} map {$_->features(@args)} @$ranges; $deleted = $self->delete_features(keys %ids_to_remove); } elsif (@$types) { my %ids_to_remove = map {$_->id => 1} $self->features(-type=>$types); $deleted = $self->delete_features(keys %ids_to_remove); } else { $self->throw("This operation would delete all feature data and -force not specified") unless $force; $deleted = @{$self->{data}}; @{$self->{data}} = (); } $deleted; } # attributes - # Some GFF version 2 files use the groups column to store a series of # attribute/value pairs. In this interpretation of GFF, the first such # pair is treated as the primary group for the feature; subsequent pairs # are treated as attributes. Two attributes have special meaning: # "Note" is for backward compatibility and is used for unstructured text # remarks. "Alias" is considered as a synonym for the feature name. # If no name is provided, then attributes() returns a flattened hash, of # attribute=>value pairs. sub do_attributes{ my $self = shift; my ($feature_id,$tag) = @_; my $attr ; #my $feature = ${$self->{data}}[$feature_id]; my $feature = $self->_basic_features_by_id($feature_id); my @result; for my $attr (@{$feature->{attributes}}) { my ($attr_name,$attr_value) = @$attr ; if (defined($tag) && lc($attr_name) eq lc($tag)){push @result,$attr_value;} elsif (!defined($tag)) {push @result,($attr_name,$attr_value);} } return @result; } #sub get_feature_by_attribute{ sub _feature_by_attribute{ my $self = shift; my ($attributes,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $count = 0; my $feature_id = -1; my $feature_group_id = undef; for my $feature (@{$self->{data}}) { $feature_id++; for my $attr (@{$feature->{attributes}}) { my ($attr_name,$attr_value) = @$attr ; #there could be more than one set of attributes...... foreach (keys %$attributes) { if (lc($_) eq lc($attr_name) && lc($attributes->{$_}) eq lc($attr_value)) { $callback->($self->_hash_to_array($feature)); $count++; } } } } } # This is the low-level method that is called to retrieve GFF lines from # the database. It is responsible for retrieving features that satisfy # range and feature type criteria, and passing the GFF fields to a # callback subroutine. sub get_features{ my $self = shift; my $count = 0; my ($search,$options,$callback) = @_; my $found_features; $found_features = $self->_get_features_by_search_options($search,$options); # only true if the sort by group option was specified @{$found_features} = sort {lc("$a->{gclass}:$a->{gname}") cmp lc("$b->{gclass}:$b->{gname}")} @{$found_features} if $options->{sort_by_group} ; for my $feature (@{$found_features}) { # only true if the sort by group option was specified $count++; $callback->( $self->_hash_to_array($feature) ); } return $count; } # Low level implementation of fetching a named feature. # GFF annotations are named using the group class and name fields. # May return zero, one, or several Bio::DB::GFF::Feature objects. =head2 _feature_by_name Title : _feature_by_name Usage : $db->get_features_by_name($name,$class,$callback) Function: get a list of features by name and class Returns : count of number of features retrieved Args : name of feature, class of feature, and a callback Status : protected This method is used internally. The callback arguments are those used by make_feature(). =cut sub _feature_by_name { my $self = shift; my ($class,$name,$location,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $count = 0; my $regexp; if ($name =~ /[*?]/) { # uh oh regexp time $name = quotemeta($name); $name =~ s/\\\*/.*/g; $name =~ s/\\\?/.?/g; $regexp++; } for my $feature (@{$self->{data}}) { next unless ($regexp && $feature->{gname} =~ /$name/i) || lc($feature->{gname}) eq lc($name); next if defined($feature->{gclass}) && length($feature->{gclass}) > 0 && $feature->{gclass} ne $class; if ($location) { next if $location->[0] ne $feature->{ref}; next if $location->[1] && $location->[1] > $feature->{stop}; next if $location->[2] && $location->[2] < $feature->{start}; } $count++; $callback->($self->_hash_to_array($feature),0); } return $count; } # Low level implementation of fetching a feature by it's id. # The id of the feature as implemented in the in-memory db, is the location of the # feature in the features hash array. sub _feature_by_id{ my $self = shift; my ($ids,$type,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $feature_group_id = undef; my $count = 0; if ($type eq 'feature'){ for my $feature_id (@$ids){ my $feature = $self->_basic_features_by_id($feature_id); $callback->($self->_hash_to_array($feature)) if $callback; $count++; } } } sub _basic_features_by_id{ my $self = shift; my ($ids) = @_; $ids = [$ids] unless ref $ids =~ /ARRAY/; my @result; for my $feature_id (@$ids){ push @result, ${$self->{data}}[$feature_id]; } return wantarray() ? @result : $result[0]; } # This method is similar to get_features(), except that it returns an # iterator across the query. # See Bio::DB::GFF::Adaptor::memory::iterator. sub get_features_iterator { my $self = shift; my ($search,$options,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my $results = $self->_get_features_by_search_options($search,$options); my $results_array = $self->_convert_feature_hash_to_array($results); return Bio::DB::GFF::Adaptor::memory::iterator->new($results_array,$callback); } # This method is responsible for fetching the list of feature type names. # The query may be limited to a particular range, in # which case the range is indicated by a landmark sequence name and # class and its subrange, if any. These arguments may be undef if it is # desired to retrieve all feature types. # If the count flag is false, the method returns a simple list of # Bio::DB::GFF::Typename objects. If $count is true, the method returns # a list of $name=>$count pairs, where $count indicates the number of # times this feature occurs in the range. sub get_types { my $self = shift; my ($srcseq,$class,$start,$stop,$want_count,$typelist) = @_; my(%result,%obj); for my $feature (@{$self->{data}}) { my $feature_start = $feature->{start}; my $feature_stop = $feature->{stop}; my $feature_ref = $feature->{ref}; my $feature_class = $feature->{class}; my $feature_method = $feature->{method}; my $feature_source = $feature->{source}; if (defined $srcseq){ next unless lc($feature_ref) eq lc($srcseq); } if (defined $class){ next unless defined $feature_class && $feature_class eq $class ; } # the requested range should OVERLAP the retrieved features if (defined $start or defined $stop) { $start = 1 unless defined $start; $stop = MAX_SEGMENT unless defined $stop; next unless $feature_stop >= $start && $feature_start <= $stop; } if (defined $typelist && @$typelist){ next unless $self->_matching_typelist($feature_method,$feature_source,$typelist); } my $type = Bio::DB::GFF::Typename->new($feature_method,$feature_source); $result{$type}++; $obj{$type} = $type; } #end features loop return $want_count ? %result : values %obj; } sub classes { my $self = shift; my %classes; for my $feature (@{$self->{data}}) { $classes{$feature->{gclass}}++; } my @classes = sort keys %classes; return @classes; } # Internal method that performs a search on the features array, # sequentialy retrieves the features, and performs a check on each feature # according to the search options. sub _get_features_by_search_options{ my $count = 0; my ($self, $search,$options) = @_; my ($rangetype,$refseq,$class,$start,$stop,$types,$sparse,$order_by_group,$attributes) = (@{$search}{qw(rangetype refseq refclass start stop types)}, @{$options}{qw(sparse sort_by_group ATTRIBUTES)}) ; my @found_features; my $data = $self->{data}; my $feature_id = -1 ; my $feature_group_id = undef; for my $feature (@{$data}) { $feature_id++; my $feature_start = $feature->{start}; my $feature_stop = $feature->{stop}; my $feature_ref = $feature->{ref}; if (defined $refseq){ next unless lc($feature_ref) eq lc($refseq); } if (defined $start or defined $stop) { $start = 0 unless defined($start); $stop = MAX_SEGMENT unless defined($stop); if ($rangetype eq 'overlaps') { next unless $feature_stop >= $start && $feature_start <= $stop; } elsif ($rangetype eq 'contains') { next unless $feature_start >= $start && $feature_stop <= $stop; } elsif ($rangetype eq 'contained_in') { next unless $feature_start <= $start && $feature_stop >= $stop; } else { next unless $feature_start == $start && $feature_stop == $stop; } } my $feature_source = $feature->{source}; my $feature_method = $feature->{method}; if (defined $types && @$types){ next unless $self->_matching_typelist($feature_method,$feature_source,$types); } my $feature_attributes = $feature->{attributes}; if (defined $attributes){ next unless $self->_matching_attributes($feature_attributes,$attributes); } # if we get here, then we have a feature that meets the criteria. # Then we just push onto an array # of found features and continue. my $found_feature = $feature ; $found_feature->{feature_id} = $feature_id; $found_feature->{group_id} = $feature_group_id; push @found_features,$found_feature; } return \@found_features; } sub _hash_to_array { my ($self,$feature_hash) = @_; my @array = @{$feature_hash}{@hash2array_map}; return wantarray ? @array : \@array; } # this subroutine is needed for convertion of the feature from hash to array in order to # pass it to the callback subroutine sub _convert_feature_hash_to_array{ my ($self, $feature_hash_array) = @_; my @features_array_array = map {scalar $self->_hash_to_array($_)} @$feature_hash_array; return \@features_array_array; } sub _matching_typelist{ my ($self, $feature_method,$feature_source,$typelist) = @_; foreach (@$typelist) { my ($search_method,$search_source) = @$_; next if lc($search_method) ne lc($feature_method); next if defined($search_source) && lc($search_source) ne lc($feature_source); return 1; } return 0; } sub _matching_attributes { my ($self, $feature_attributes,$attributes) = @_ ; foreach (keys %$attributes) { return 0 if !_match_all_attr_in_feature($_,$attributes->{$_},$feature_attributes) } return 1; } sub _match_all_attr_in_feature{ my ($attr_name,$attr_value,$feature_attributes) = @_; for my $attr (@$feature_attributes) { my ($feature_attr_name,$feature_attr_value) = @$attr ; next if ($attr_name ne $feature_attr_name || $attr_value ne $feature_attr_value); return 1; } return 0; } sub do_initialize { 1; } sub get_feature_by_group_id{ 1; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/berkeleydb000755000765000024 012254227317 20406 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Adaptor/berkeleydb/iterator.pm000444000765000024 346712254227317 22744 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Adaptor::berkeleydb::iterator - iterator for Bio::DB::GFF::Adaptor::berkeleydb =head1 SYNOPSIS For internal use only =head1 DESCRIPTION This is an internal module that is used by the Bio::DB::GFF in-memory adaptor to return an iterator across a sequence feature query. The object has a single method, next_feature(), that returns the next feature from the query. The method next_seq() is an alias for next_feature(). =head1 BUGS None known yet. =head1 SEE ALSO L, =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut package Bio::DB::GFF::Adaptor::berkeleydb::iterator; use strict; use DB_File qw(R_FIRST R_NEXT); # this module needs to be cleaned up and documented use Bio::Root::Version; *next_seq = \&next_feature; sub new { my $class = shift; my ($data,$callback,$tmpfile) = @_; return bless {data => $data, callback => $callback, tmpfile => $tmpfile, cache => []},$class; } sub next_feature { my $self = shift; return shift @{$self->{cache}} if @{$self->{cache}}; my $data = $self->{data} or return; my $callback = $self->{callback}; my $features; my $db = tied(%$data); my ($key,$value); for (my $status = $db->seq($key,$value,$self->{iter}++ ? R_NEXT : R_FIRST); $status == 0; $status = $db->seq($key,$value,R_NEXT)) { my @feature = split ($;,$value); $features = $callback->(@feature); last if $features; } unless ($features) { $features = $callback->(); undef $self->{data}; undef $self->{cache}; unlink $self->{tmpfile}; } $self->{cache} = $features or return; shift @{$self->{cache}}; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi000755000765000024 012254227333 17032 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/caching_handle.pm000444000765000024 1552512254227322 22462 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::caching_handle; use strict; use DBI; use vars '$AUTOLOAD'; use base qw(Bio::Root::Root); =head1 NAME Bio::DB::GFF::Adaptor::dbi::caching_handle -- Cache for database handles =head1 SYNOPSIS use Bio::DB::GFF::Adaptor::dbi::caching_handle; $db = Bio::DB::GFF::Adaptor::dbi::caching_handle->new('dbi:mysql:test'); $sth = $db->prepare('select * from foo'); @h = $sth->fetch_rowarray; $sth->finish =head1 DESCRIPTION This module handles a pool of database handles. It was motivated by the MYSQL driver's {mysql_use_result} attribute, which dramatically improves query speed and memory usage, but forbids additional query statements from being evaluated while an existing one is in use. This module is a plug-in replacement for vanilla DBI. It automatically activates the {mysql_use_result} attribute for the mysql driver, but avoids problems with multiple active statement handlers by creating new database handles as needed. =head1 USAGE The object constructor is Bio::DB::GFF::Adaptor::dbi::caching_handle-Enew(). This is called like DBI-Econnect() and takes the same arguments. The returned object looks and acts like a conventional database handle. In addition to all the standard DBI handle methods, this package adds the following: =head2 dbi_quote Title : dbi_quote Usage : $string = $db->dbi_quote($sql,@args) Function: perform bind variable substitution Returns : query string Args : the query string and bind arguments Status : public This method replaces the bind variable "?" in a SQL statement with appropriately quoted bind arguments. It is used internally to handle drivers that don't support argument binding. =head2 do_query Title : do_query Usage : $sth = $db->do_query($query,@args) Function: perform a DBI query Returns : a statement handler Args : query string and list of bind arguments Status : Public This method performs a DBI prepare() and execute(), returning a statement handle. You will typically call fetch() of fetchrow_array() on the statement handle. The parsed statement handle is cached for later use. =head2 debug Title : debug Usage : $debug = $db->debug([$debug]) Function: activate debugging messages Returns : current state of flag Args : optional new setting of flag Status : public =cut sub new { my $class = shift; my @dbi_args = @_; my $self = bless { dbh => [], args => \@dbi_args, debug => 0, },$class; $self->dbh || $self->throw("Can't connect to database: " . DBI->errstr); $self; } sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; return if $func_name eq 'DESTROY'; my $self = shift or return DBI->$func_name(@_); $self->dbh->$func_name(@_); } sub debug { my $self = shift; my $d = $self->{debug}; $self->{debug} = shift if @_; $d; } sub prepare { my $self = shift; my $query = shift; # find a non-busy dbh my $dbh = $self->dbh || $self->throw("Can't connect to database: " . DBI->errstr); warn "Using prepare_cache\n" if $self->debug; my $sth = $dbh->prepare_cached($query, {}, 3) || $self->throw("Couldn't prepare query $query:\n ".DBI->errstr."\n"); return $sth; } sub do_query { my $self = shift; my ($query,@args) = @_; warn $self->dbi_quote($query,@args),"\n" if $self->debug; my $sth = $self->prepare($query); $sth->execute(@args) || $self->throw("Couldn't execute query $query:\n ".DBI->errstr."\n"); $sth; } sub dbh { my $self = shift; foreach (@{$self->{dbh}}) { return $_ if $_->inuse == 0; } # if we get here, we must create a new one warn "(Re)connecting to database\n" if $self->debug; my $dbh = DBI->connect(@{$self->{args}}) or return; $dbh->{PrintError} = 0; # for Oracle - to retrieve LOBs, need to define the length (Jul 15, 2002) $dbh->{LongReadLen} = 100*65535; $dbh->{LongTruncOk} = 0; $dbh->{mysql_auto_reconnect} = 1; my $wrapper = Bio::DB::GFF::Adaptor::dbi::faux_dbh->new($dbh); push @{$self->{dbh}},$wrapper; $wrapper; } # The clone method should only be called in child processes after a fork(). # It does two things: (1) it sets the "real" dbh's InactiveDestroy to 1, # thereby preventing the database connection from being destroyed in # the parent when the dbh's destructor is called; (2) it replaces the # "real" dbh with the result of dbh->clone(), so that we now have an # independent handle. sub clone { my $self = shift; foreach (@{$self->{dbh}}) { $_->clone }; } =head2 attribute Title : attribute Usage : $value = $db->attribute(AttributeName , [$newvalue]) Function: get/set DBI::db handle attribute Returns : current state of the attribute Args : name of the attribute and optional new setting of attribute Status : public Under Bio::DB::GFF::Adaptor::dbi::caching_handle the DBI::db attributes that are usually set using hashref calls are unavailable. Use attribute() instead. For example, instead of: $dbh->{AutoCommit} = 0; use $dbh->attribute(AutoCommit=>0); =cut sub attribute { my $self = shift; my $dbh = $self->dbh->{dbh}; return $dbh->{$_[0]} = $_[1] if @_ == 2; return $dbh->{$_[0]} if @_ == 1; return; } sub disconnect { my $self = shift; $_ && $_->disconnect foreach @{$self->{dbh}}; $self->{dbh} = []; } sub dbi_quote { my $self = shift; my ($query,@args) = @_; my $dbh = $self->dbh; $query =~ s/\?/$dbh->quote(shift @args)/eg; $query; } package Bio::DB::GFF::Adaptor::dbi::faux_dbh; use vars '$AUTOLOAD'; sub new { my $class = shift; my $dbh = shift; bless {dbh=>$dbh},$class; } sub prepare { my $self = shift; my $sth = $self->{dbh}->prepare(@_) or return; $sth->{mysql_use_result} = 1 if $self->{dbh}->{Driver}{Name} eq 'mysql'; $sth; } sub prepare_delayed { my $self = shift; my $sth = $self->{dbh}->prepare(@_) or return; $sth; } sub inuse { shift->{dbh}->{ActiveKids}; } # The clone method should only be called in child processes after a fork(). # It does two things: (1) it sets the "real" dbh's InactiveDestroy to 1, # thereby preventing the database connection from being destroyed in # the parent when the dbh's destructor is called; (2) it replaces the # "real" dbh with the result of dbh->clone(), so that we now have an # independent handle. sub clone { my $self = shift; $self->{dbh}{InactiveDestroy} = 1; $self->{dbh} = $self->{dbh}->clone; } sub DESTROY { } sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; return if $func_name eq 'DESTROY'; my $self = shift; if( defined $self->{dbh} ) { $self->{dbh}->$func_name(@_); } } 1; __END__ =head1 BUGS Report to the author. =head1 SEE ALSO L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/iterator.pm000444000765000024 275712254227312 21366 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Adaptor::dbi::iterator - iterator for Bio::DB::GFF::Adaptor::dbi =head1 SYNOPSIS For internal use only =head1 DESCRIPTION This is an internal module that is used by the Bio::DB::GFF DBI adaptor to return an iterator across a sequence feature query. The object has a single method, next_feature(), that returns the next feature from the query. The method next_seq() is an alias for next_feature(). =head1 BUGS None known yet. =head1 SEE ALSO L, =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut package Bio::DB::GFF::Adaptor::dbi::iterator; use strict; use Bio::Root::Version; use constant STH => 0; use constant CALLBACK => 1; use constant CACHE => 2; *next_seq = \&next_feature; sub new { my $class = shift; my ($sth,$callback) = @_; return bless [$sth,$callback,[]],$class; } sub next_feature { my $self = shift; return shift @{$self->[CACHE]} if @{$self->[CACHE]}; my $sth = $self->[STH] or return; my $callback = $self->[CALLBACK]; my $features; while (1) { if (my @row = $sth->fetchrow_array) { $features = $callback->(@row); last if $features; } else { $sth->finish; undef $self->[STH]; $features = $callback->(); last; } } $self->[CACHE] = $features or return; shift @{$self->[CACHE]}; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/mysql.pm000444000765000024 6245412254227334 20726 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::mysql; =head1 NAME Bio::DB::GFF::Adaptor::dbi::mysql -- Database adaptor for a specific mysql schema =head1 SYNOPSIS See L =cut # a simple mysql adaptor use strict; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::GFF::Util::Binning; use base qw(Bio::DB::GFF::Adaptor::dbi); use constant MAX_SEGMENT => 100_000_000; # the largest a segment can get use constant GETSEQCOORDS =><<<< < select * from fgroup where gname='sjj_2L52.1'; +-------+-------------+------------+ | gid | gclass | gname | +-------+-------------+------------+ | 69736 | PCR_product | sjj_2L52.1 | +-------+-------------+------------+ 1 row in set (0.70 sec) mysql> select fref,fstart,fstop from fdata,fgroup where gclass='PCR_product' and gname = 'sjj_2L52.1' and fdata.gid=fgroup.gid; +---------------+--------+-------+ | fref | fstart | fstop | +---------------+--------+-------+ | CHROMOSOME_II | 1586 | 2355 | +---------------+--------+-------+ 1 row in set (0.03 sec) =item ftype This table contains the feature types, one per row. Columns are: ftypeid the feature type ID (integer) fmethod the feature type method name (string) fsource the feature type source name (string) The ftype.ftypeid field joins with the fdata.ftypeid field. Example: mysql> select fref,fstart,fstop,fmethod,fsource from fdata,fgroup,ftype where gclass='PCR_product' and gname = 'sjj_2L52.1' and fdata.gid=fgroup.gid and fdata.ftypeid=ftype.ftypeid; +---------------+--------+-------+-------------+-----------+ | fref | fstart | fstop | fmethod | fsource | +---------------+--------+-------+-------------+-----------+ | CHROMOSOME_II | 1586 | 2355 | PCR_product | GenePairs | +---------------+--------+-------+-------------+-----------+ 1 row in set (0.08 sec) =item fdna This table holds the raw DNA of the reference sequences. It has three columns: fref reference sequence name (string) foffset offset of this sequence fdna the DNA sequence (longblob) To overcome problems loading large blobs, DNA is automatically fragmented into multiple segments when loading, and the position of each segment is stored in foffset. The fragment size is controlled by the -clump_size argument during initialization. =item fattribute_to_feature This table holds "attributes", which are tag/value pairs stuffed into the GFF line. The first tag/value pair is treated as the group, and anything else is treated as an attribute (weird, huh?). CHR_I assembly_tag Finished 2032 2036 . + . Note "Right: cTel33B" CHR_I assembly_tag Polymorphism 668 668 . + . Note "A->C in cTel33B" The columns of this table are: fid feature ID (integer) fattribute_id ID of the attribute (integer) fattribute_value text of the attribute (text) The fdata.fid column joins with fattribute_to_feature.fid. =item fattribute This table holds the normalized names of the attributes. Fields are: fattribute_id ID of the attribute (integer) fattribute_name Name of the attribute (varchar) =back =head2 Data Loading Methods In addition to implementing the abstract SQL-generating methods of Bio::DB::GFF::Adaptor::dbi, this module also implements the data loading functionality of Bio::DB::GFF. =cut =head2 new Title : new Usage : $db = Bio::DB::GFF->new(@args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : see below Status : Public The new constructor is identical to the "dbi" adaptor's new() method, except that the prefix "dbi:mysql" is added to the database DSN identifier automatically if it is not there already. Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' or "ens0040" -user username for authentication -pass the password for authentication =cut #' sub new { my $class = shift; my ($dsn,$other) = rearrange([ [qw(FEATUREDB DB DSN)], ],@_); $dsn = "dbi:mysql:$dsn" if !ref($dsn) && $dsn !~ /^(?:dbi|DBI):/; my $self = $class->SUPER::new(-dsn=>$dsn,%$other); $self; } =head2 get_dna Title : get_dna Usage : $string = $db->get_dna($name,$start,$stop,$class) Function: get DNA string Returns : a string Args : name, class, start and stop of desired segment Status : Public This method performs the low-level fetch of a DNA substring given its name, class and the desired range. This should probably be moved to the parent class. =cut sub getseqcoords_query { my $self = shift; return GETSEQCOORDS ; } sub getaliascoords_query{ my $self = shift; return GETALIASCOORDS ; } sub getforcedseqcoords_query{ my $self = shift; return GETFORCEDSEQCOORDS ; } sub getaliaslike_query{ my $self = shift; return GETALIASLIKE ; } # override parent sub get_abscoords_bkup { my $self = shift; my ($name,$class,$refseq) = @_; my $result = $self->SUPER::get_abscoords(@_); return $result if $result; my $sth; if ($name =~ s/\*/%/g) { $sth = $self->dbh->do_query(GETALIASLIKE,$name,$class); } else { $sth = $self->dbh->do_query(GETALIASCOORDS,$name,$class); } my @result; while (my @row = $sth->fetchrow_array) { push @result,\@row } $sth->finish; if (@result == 0) { $self->error("$name not found in database"); return; } else { return \@result; } } sub make_features_select_part { my $self = shift; my $options = shift || {}; my $s; if (my $b = $options->{bin_width}) { $s = <{attributes} && keys %{$options->{attributes}}>1; $s; } # IMPORTANT NOTE: # WHETHER OR NOT THIS WORKS IS CRITICALLY DEPENDENT ON THE RELATIVE MAGNITUDE OF THE sub make_features_from_part { my $self = shift; my $sparse_types = shift; my $options = shift || {}; my $sparse_groups = $options->{sparse_groups}; my $index = $sparse_groups ? ' USE INDEX(gid)' : $sparse_types ? ' USE INDEX(ftypeid)' : ''; return $options->{attributes} ? "fdata${index},ftype,fgroup,fattribute,fattribute_to_feature\n" : "fdata${index},ftype,fgroup\n"; } =head2 search_notes Title : search_notes Usage : @search_results = $db->search_notes("full text search string",$limit) Function: Search the notes for a text string, using mysql full-text search Returns : array of results Args : full text search string, and an optional row limit Status : public This is a mysql-specific method. Given a search string, it performs a full-text search of the notes table and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 A Bio::DB::GFF::Featname object, suitable for passing to segment() column 2 The text of the note column 3 A relevance score. =cut sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my $query = FULLTEXTSEARCH; $query .= " limit $limit" if defined $limit; my $sth = $self->dbh->do_query($query,$search_string,$search_string); my @results; while (my ($class,$name,$note,$relevance,$method,$source) = $sth->fetchrow_array) { next unless $class && $name; # sorry, ignore NULL objects $relevance = sprintf("%.2f",$relevance); # trim long floats my $featname = Bio::DB::GFF::Featname->new($class=>$name); my $type = Bio::DB::GFF::Typename->new($method,$source); push @results,[$featname,$note,$relevance,$type]; } #added result filtering so that this method returns the expected results #this section of code used to be in GBrowse's do_keyword_search method my $match_sub = 'sub {'; foreach (split /\s+/,$search_string) { $match_sub .= "return unless \$_[0] =~ /\Q$_\E/i; "; } $match_sub .= "};"; my $match = eval $match_sub; my @matches = grep { $match->($_->[1]) } @results; return @matches; } ################################ loading and initialization ################################## =head2 schema Title : schema Usage : $schema = $db->schema Function: return the CREATE script for the schema Returns : a list of CREATE statemetns Args : none Status : protected This method returns a list containing the various CREATE statements needed to initialize the database tables. =cut sub schema { my $self = shift; my $dbh = $self->dbh; my ($version) = $dbh->selectrow_array('select version()'); my ($major, $minor) = split /\./, $version; $version = "$major.$minor"; my $engine = $version >= 4.1 ? 'ENGINE' : 'TYPE'; my %schema = ( fdata =>{ table=> qq{ create table fdata ( fid int not null auto_increment, fref varchar(100) not null, fstart int not null, fstop int not null, fbin double precision, ftypeid int not null, fscore float, fstrand enum('+','-'), fphase enum('0','1','2'), gid int not null, ftarget_start int, ftarget_stop int, primary key(fid), unique index(fref,fbin,fstart,fstop,ftypeid,gid), index(ftypeid), index(gid) ) $engine=MyISAM } # fdata table }, # fdata fgroup =>{ table=> qq{ create table fgroup ( gid int not null auto_increment, gclass varchar(100), gname varchar(100), primary key(gid), unique(gclass,gname) ) $engine=MyISAM } }, ftype => { table=> qq{ create table ftype ( ftypeid int not null auto_increment, fmethod varchar(100) not null, fsource varchar(100), primary key(ftypeid), index(fmethod), index(fsource), unique ftype (fmethod,fsource) ) $engine=MyISAM } #ftype table }, #ftype fdna => { table=> qq{ create table fdna ( fref varchar(100) not null, foffset int(10) unsigned not null, fdna longblob, primary key(fref,foffset) ) $engine=MyISAM } # fdna table },#fdna fmeta => { table=> qq{ create table fmeta ( fname varchar(255) not null, fvalue varchar(255) not null, primary key(fname) ) $engine=MyISAM } # fmeta table },#fmeta fattribute => { table=> qq{ create table fattribute ( fattribute_id int(10) unsigned not null auto_increment, fattribute_name varchar(255) not null, primary key(fattribute_id) ) $engine=MyISAM } #fattribute table },#fattribute fattribute_to_feature => { table=> qq{ create table fattribute_to_feature ( fid int(10) not null, fattribute_id int(10) not null, fattribute_value text, key(fid,fattribute_id), key(fattribute_value(48)), fulltext(fattribute_value) ) $engine=MyISAM } # fattribute_to_feature table },# fattribute_to_feature finterval_stats => { table=> qq{ create table finterval_stats ( ftypeid integer not null, fref varchar(100) not null, fbin integer not null, fcum_count integer not null, primary key(ftypeid,fref,fbin) ) $engine=MyISAM } # finterval_stats table },# finterval_stats ); return \%schema; } =head2 make_classes_query Title : make_classes_query Usage : ($query,@args) = $db->make_classes_query Function: return query fragment for generating list of reference classes Returns : a query and args Args : none Status : public =cut sub make_classes_query { my $self = shift; return 'SELECT DISTINCT gclass FROM fgroup WHERE NOT ISNULL(gclass)'; } =head2 make_meta_set_query Title : make_meta_set_query Usage : $sql = $db->make_meta_set_query Function: return SQL fragment for setting a meta parameter Returns : SQL fragment Args : none Status : public By default this does nothing; meta parameters are not stored or retrieved. =cut sub make_meta_set_query { return 'REPLACE INTO fmeta VALUES (?,?)'; } =head2 setup_load Title : setup_load Usage : $db->setup_load Function: called before load_gff_line() Returns : void Args : none Status : protected This method performs schema-specific initialization prior to loading a set of GFF records. It prepares a set of DBI statement handlers to be used in loading the data. =cut sub setup_load { my $self = shift; my $dbh = $self->features_db; if ($self->lock_on_load) { my @tables = map { "$_ WRITE"} $self->tables; my $tables = join ', ',@tables; $dbh->do("LOCK TABLES $tables"); } # for my $table (qw(fdata)) { # $dbh->do("alter table $table disable keys"); # } my $lookup_type = $dbh->prepare_delayed('SELECT ftypeid FROM ftype WHERE fmethod=? AND fsource=?'); my $insert_type = $dbh->prepare_delayed('INSERT INTO ftype (fmethod,fsource) VALUES (?,?)'); my $lookup_group = $dbh->prepare_delayed('SELECT gid FROM fgroup WHERE gname=? AND gclass=?'); my $insert_group = $dbh->prepare_delayed('INSERT INTO fgroup (gname,gclass) VALUES (?,?)'); my $lookup_attribute = $dbh->prepare_delayed('SELECT fattribute_id FROM fattribute WHERE fattribute_name=?'); my $insert_attribute = $dbh->prepare_delayed('INSERT INTO fattribute (fattribute_name) VALUES (?)'); my $insert_attribute_value = $dbh->prepare_delayed('INSERT INTO fattribute_to_feature (fid,fattribute_id,fattribute_value) VALUES (?,?,?)'); my $insert_data = $dbh->prepare_delayed(<{load_stuff}{sth}{lookup_ftype} = $lookup_type; $self->{load_stuff}{sth}{insert_ftype} = $insert_type; $self->{load_stuff}{sth}{lookup_fgroup} = $lookup_group; $self->{load_stuff}{sth}{insert_fgroup} = $insert_group; $self->{load_stuff}{sth}{insert_fdata} = $insert_data; $self->{load_stuff}{sth}{lookup_fattribute} = $lookup_attribute; $self->{load_stuff}{sth}{insert_fattribute} = $insert_attribute; $self->{load_stuff}{sth}{insert_fattribute_value} = $insert_attribute_value; $self->{load_stuff}{types} = {}; $self->{load_stuff}{groups} = {}; $self->{load_stuff}{counter} = 0; } =head2 load_gff_line Title : load_gff_line Usage : $db->load_gff_line($fields) Function: called to load one parsed line of GFF Returns : true if successfully inserted Args : hashref containing GFF fields Status : protected This method is called once per line of the GFF and passed a series of parsed data items that are stored into the hashref $fields. The keys are: ref reference sequence source annotation source method annotation method start annotation start stop annotation stop score annotation score (may be undef) strand annotation strand (may be undef) phase annotation phase (may be undef) group_class class of annotation's group (may be undef) group_name ID of annotation's group (may be undef) target_start start of target of a similarity hit target_stop stop of target of a similarity hit attributes array reference of attributes, each of which is a [tag=>value] array ref =cut sub load_gff_line { my $self = shift; my $gff = shift; my $s = $self->{load_stuff}; my $dbh = $self->features_db; local $dbh->{PrintError} = 0; defined(my $typeid = $self->get_table_id('ftype', $gff->{method} => $gff->{source})) or return; defined(my $groupid = $self->get_table_id('fgroup',$gff->{gname} => $gff->{gclass})) or return; if ($gff->{stop}-$gff->{start}+1 > $self->max_bin) { warn "$gff->{gclass}:$gff->{gname} is ",$gff->{stop}-$gff->{start}+1, " bp long, but the maximum indexable feature is set to ",$self->max_bin," bp.\n"; warn "Please set the maxbin value to a length at least as large as the largest feature you wish to store.\n"; warn "\n* You will need to reinitialize the database from scratch.\n"; warn "* With the Perl API you do this using the -max_bin argument to \$db->initialize().\n"; warn "* With the command-line tools you do with this with --maxfeature option.\n"; } my $bin = bin($gff->{start},$gff->{stop},$self->min_bin); my $result = $s->{sth}{insert_fdata}->execute($gff->{ref}, $gff->{start},$gff->{stop},$bin, $typeid, $gff->{score},$gff->{strand},$gff->{phase}, $groupid, $gff->{tstart},$gff->{tstop}); warn $dbh->errstr,"\n" && return unless $result; my $fid = $dbh->{mysql_insertid} || $self->get_feature_id($gff->{ref},$gff->{start},$gff->{stop},$typeid,$groupid); # insert attributes foreach (@{$gff->{attributes}}) { defined(my $attribute_id = $self->get_table_id('fattribute',$_->[0])) or return; $s->{sth}{insert_fattribute_value}->execute($fid,$attribute_id,$_->[1]); } if ( (++$s->{counter} % 1000) == 0) { print STDERR "$s->{counter} records loaded..."; print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; } $fid; } sub finish_load { my $self = shift; my $dbh = $self->features_db; local $dbh->{PrintError} = 0; # for my $table (qw(fdata)) { # $dbh->do("alter table $table enable keys"); # } $self->SUPER::finish_load; } sub insert_sequence { my $self = shift; my($id,$offset,$seq) = @_; my $sth = $self->{_insert_sequence} ||= $self->dbh->prepare_delayed('replace into fdna values (?,?,?)'); $sth->execute($id,$offset,$seq) or $self->throw($sth->errstr); } =head2 get_table_id Title : get_table_id Usage : $integer = $db->get_table_id($table,@ids) Function: get the ID of a group or type Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature type or group. The arguments are the name of the table, and two string identifiers. For feature types, the identifiers are the method and source. For groups, the identifiers are group name and class. This method requires that a statement handler named I, have been created previously by setup_load(). It is here to overcome deficiencies in mysql's INSERT syntax. =cut #' # get the object ID from a named table sub get_table_id { my $self = shift; my $table = shift; my @ids = @_; # irritating warning for null id my $id_key; { local $^W=0; $id_key = join ':',@ids; } my $s = $self->{load_stuff}; my $sth = $s->{sth}; my $dbh = $self->features_db; unless (defined($s->{$table}{$id_key})) { ######################################### # retrieval of the last inserted id is now located at the adaptor and not in caching_handle ####################################### if ( (my $result = $sth->{"lookup_$table"}->execute(@ids)) > 0) { $s->{$table}{$id_key} = ($sth->{"lookup_$table"}->fetchrow_array)[0]; } else { $sth->{"insert_$table"}->execute(@ids) && ($s->{$table}{$id_key} = $self->insertid($sth->{"insert_$table"})); #&& ($s->{$table}{$id_key} = $sth->{"insert_$table"}{sth}{mysql_insertid}); #&& ($s->{$table}{$id_key} = $sth->{"insert_$table"}->insertid); } } my $id = $s->{$table}{$id_key}; unless (defined $id) { warn "No $table id for $id_key ",$dbh->errstr," Record skipped.\n"; return; } $id; } sub insertid { my $self = shift; my $s = shift ; $s->{mysql_insertid}; } =head2 get_feature_id Title : get_feature_id Usage : $integer = $db->get_feature_id($ref,$start,$stop,$typeid,$groupid) Function: get the ID of a feature Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature. It is ony needed when replacing a feature with new information. =cut # this method is called when needed to look up a feature's ID sub get_feature_id { my $self = shift; my ($ref,$start,$stop,$typeid,$groupid) = @_; my $s = $self->{load_stuff}; unless ($s->{get_feature_id}) { my $dbh = $self->features_db; $s->{get_feature_id} = $dbh->prepare_delayed('SELECT fid FROM fdata WHERE fref=? AND fstart=? AND fstop=? AND ftypeid=? AND gid=?'); } my $sth = $s->{get_feature_id} or return; $sth->execute($ref,$start,$stop,$typeid,$groupid) or return; my ($fid) = $sth->fetchrow_array; return $fid; } sub _add_interval_stats_table { my $self = shift; my $schema = $self->schema; my $create_table_stmt = $schema->{'finterval_stats'}{'table'}; $create_table_stmt =~ s/create table/create table if not exists/i; my $dbh = $self->features_db; $dbh->do($create_table_stmt) || warn $dbh->errstr; } sub disable_keys { my $self = shift; my $table = shift; my $dbh = $self->dbh; $dbh->do("alter table $table disable keys"); } sub enable_keys { my $self = shift; my $table = shift; my $dbh = $self->dbh; $dbh->do("alter table $table enable keys"); } 1; __END__ =head1 BUGS none ;-) =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/mysqlace.pm000444000765000024 553012254227330 21343 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::mysqlace; =head1 NAME Bio::DB::GFF::Adaptor::dbi::mysqlace -- Unholy union between mysql GFF database and acedb database =head1 SYNOPSIS Pending See L and L =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use base qw(Bio::DB::GFF::Adaptor::dbi::mysql Bio::DB::GFF::Adaptor::ace); # Create a new Bio::DB::GFF::Adaptor::dbi object sub new { my $class = shift; my $self = $class->SUPER::new(@_); my ($dna_db,$acedb) = rearrange([[qw(DNADB DNA FASTA FASTA_DIR)],'ACEDB'],@_); if ($dna_db) { if (!ref($dna_db)) { require Bio::DB::Fasta; my $fasta_dir = $dna_db; $dna_db = Bio::DB::Fasta->new($fasta_dir); $dna_db or $class->throw("new(): Failed to create new Bio::DB::Fasta from files in $fasta_dir"); } else { $dna_db->isa('Bio::DB::Fasta') or $class->throw("new(): $dna_db is not a Bio::DB::Fasta object"); } $self->dna_db($dna_db); } if ($acedb) { $acedb->isa('Ace') or $class->throw("$acedb is not an acedb accessor object"); $self->acedb($acedb); } $self; } =head2 freshen_ace Title : freshen Usage : $flag = Bio::DB::GFF->freshen_ace; Function: Refresh internal acedb handle Returns : flag if correctly freshened Args : none Status : Public ACeDB has an annoying way of timing out, leaving dangling database handles. This method will invoke the ACeDB reopen() method, which causes dangling handles to be refreshed. It has no effect if you are not using ACeDB to create ACeDB objects. =cut ######################### # Moved from mysqlopt.pm ######################### sub make_object { my $self = shift; my ($class,$name,$start,$stop) = @_; if (my $db = $self->acedb) { # for Notes we just return a text, no database associated return $class->new(Text=>$name) if $class eq 'Note'; # for homols, we create the indicated Protein or Sequence object # then generate a bogus Homology object (for future compatability??) if ($start ne '') { require Ace::Sequence::Homol; return Ace::Sequence::Homol->new_homol($class,$name,$db,$start,$stop); } # General case: my $obj = $db->class->new($class=>$name,$self->acedb); return $obj if defined $obj; # Last resort, return a Text return $class->new(Text=>$name); } return $self->SUPER::make_object($class,$name,$start,$stop); } sub get_dna { my $self = shift; my ($ref,$start,$stop,$class) = @_; my $dna_db = $self->dna_db or return $self->SUPER::get_dna(@_); return $dna_db->seq($ref,$start,$stop,$class); } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/mysqlcmap.pm000444000765000024 10516312254227323 21600 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::mysqlcmap; =head1 NAME Bio::DB::GFF::Adaptor::dbi::mysqlcmap -- Database adaptor for an integraded CMap/GBrowse mysql schema =head1 SYNOPSIS See L =cut # a simple mysql adaptor use strict; use Data::Dumper; use Bio::DB::GFF::Adaptor::dbi; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use Bio::DB::GFF::Util::Binning; use base qw(Bio::DB::GFF::Adaptor::dbi::mysql); require Bio::DB::GFF::Adaptor::dbi::mysql; use constant GETSEQCOORDS =><<<< < select * from cmap_feature where feature_name='sjj_2L52.1'; +--------------+-------------+--------------+ | feature_id | gclass | feature_name | +--------------+-------------+--------------+ | 69736 | PCR_product | sjj_2L52.1 | +--------------+-------------+--------------+ 1 row in set (0.70 sec) mysql> select fref,fstart,fstop from fdata,cmap_feature where gclass='PCR_product' and feature_name = 'sjj_2L52.1' and fdata.feature_id=cmap_feature.feature_id; +---------------+--------+-------+ | fref | fstart | fstop | +---------------+--------+-------+ | CHROMOSOME_II | 1586 | 2355 | +---------------+--------+-------+ 1 row in set (0.03 sec) =item ftype This table contains the feature types, one per row. Columns are: ftypeid the feature type ID (integer) fmethod the feature type method name (string) fsource the feature type source name (string) The ftype.ftypeid field joins with the fdata.ftypeid field. Example: mysql> select fref,fstart,fstop,fmethod,fsource from fdata,cmap_feature,ftype where gclass='PCR_product' and feature_name = 'sjj_2L52.1' and fdata.feature_id=cmap_feature.feature_id and fdata.ftypeid=ftype.ftypeid; +---------------+--------+-------+-------------+-----------+ | fref | fstart | fstop | fmethod | fsource | +---------------+--------+-------+-------------+-----------+ | CHROMOSOME_II | 1586 | 2355 | PCR_product | GenePairs | +---------------+--------+-------+-------------+-----------+ 1 row in set (0.08 sec) =item fdna This table holds the raw DNA of the reference sequences. It has three columns: fref reference sequence name (string) foffset offset of this sequence fdna the DNA sequence (longblob) To overcome problems loading large blobs, DNA is automatically fragmented into multiple segments when loading, and the position of each segment is stored in foffset. The fragment size is controlled by the -clump_size argument during initialization. =item fattribute_to_feature This table holds "attributes", which are tag/value pairs stuffed into the GFF line. The first tag/value pair is treated as the group, and anything else is treated as an attribute (weird, huh?). CHR_I assembly_tag Finished 2032 2036 . + . Note "Right: cTel33B" CHR_I assembly_tag Polymorphism 668 668 . + . Note "A->C in cTel33B" The columns of this table are: fid feature ID (integer) fattribute_id ID of the attribute (integer) fattribute_value text of the attribute (text) The fdata.fid column joins with fattribute_to_feature.fid. =item fattribute This table holds the normalized names of the attributes. Fields are: fattribute_id ID of the attribute (integer) fattribute_name Name of the attribute (varchar) =back =head2 Data Loading Methods In addition to implementing the abstract SQL-generating methods of Bio::DB::GFF::Adaptor::dbi, this module also implements the data loading functionality of Bio::DB::GFF. =cut =head2 new Title : new Usage : $db = Bio::DB::GFF->new(@args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : see below Status : Public The new constructor is identical to the "dbi" adaptor's new() method, except that the prefix "dbi:mysql" is added to the database DSN identifier automatically if it is not there already. Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' or "ens0040" -user username for authentication -pass the password for authentication =cut #' #Defined in mysql.pm =head2 get_dna Title : get_dna Usage : $string = $db->get_dna($name,$start,$stop,$class) Function: get DNA string Returns : a string Args : name, class, start and stop of desired segment Status : Public This method performs the low-level fetch of a DNA substring given its name, class and the desired range. This should probably be moved to the parent class. =cut sub make_features_select_part { my $self = shift; my $options = shift || {}; my $s; if (my $b = $options->{bin_width}) { $s = <{attributes} && keys %{$options->{attributes}}>1; $s; } # IMPORTANT NOTE: # WHETHER OR NOT THIS WORKS IS CRITICALLY DEPENDENT ON THE RELATIVE MAGNITUDE OF THE sub make_features_from_part { my $self = shift; my $sparse_types = shift; my $options = shift || {}; my $sparse_groups = $options->{sparse_groups}; my $index = $sparse_groups ? ' USE INDEX(feature_id)' : $sparse_types ? ' USE INDEX(ftypeid)' : ''; return $options->{attributes} ? "fdata${index},ftype,cmap_feature,fattribute,fattribute_to_feature\n" : "fdata${index},ftype,cmap_feature\n"; } ################################ loading and initialization ################################## =head2 schema Title : schema Usage : $schema = $db->schema Function: return the CREATE script for the schema Returns : a list of CREATE statemetns Args : none Status : protected This method returns a list containing the various CREATE statements needed to initialize the database tables. =cut sub schema { my %schema = ( fdata =>{ table=> q{ #create table fdata ( # fid int not null auto_increment, # fref varchar(100) not null, # fstart int unsigned not null, # fstop int unsigned not null, # ftypeid int not null, # fscore float, # fstrand enum('+','-'), # fphase enum('0','1','2'), # feature_id int not null, # ftarget_start int unsigned, # ftarget_stop int unsigned, # primary key(fid), # unique index(fref,fstart,fstop,ftypeid,feature_id), # index(ftypeid), # index(feature_id) #) type=MyISAM create table fdata ( fid int not null auto_increment, fref varchar(100) not null, fstart int unsigned not null, fstop int unsigned not null, fbin double(20,6) not null, ftypeid int not null, fscore float, fstrand enum('+','-'), fphase enum('0','1','2'), feature_id int not null, ftarget_start int unsigned, ftarget_stop int unsigned, primary key(fid), unique index(fref,fbin,fstart,fstop,ftypeid,feature_id), index(ftypeid), index(feature_id) ) type=MyISAM } # fdata table }, # fdata ftype => { table=> q{ create table ftype ( ftypeid int not null auto_increment, fmethod varchar(100) not null, fsource varchar(100), primary key(ftypeid), index(fmethod), index(fsource), unique ftype (fmethod,fsource) )type=MyISAM } #ftype table }, #ftype fdna => { table=> q{ create table fdna ( fref varchar(100) not null, foffset int(10) unsigned not null, fdna longblob, primary key(fref,foffset) )type=MyISAM } # fdna table },#fdna fmeta => { table=> q{ create table fmeta ( fname varchar(255) not null, fvalue varchar(255) not null, primary key(fname) )type=MyISAM } # fmeta table },#fmeta fattribute => { table=> q{ create table fattribute ( fattribute_id int(10) unsigned not null auto_increment, fattribute_name varchar(255) not null, primary key(fattribute_id) )type=MyISAM } #fattribute table },#fattribute fattribute_to_feature => { table=> q{ create table fattribute_to_feature ( fid int(10) not null, fattribute_id int(10) not null, fattribute_value text, key(fid,fattribute_id), key(fattribute_value(48)), fulltext(fattribute_value) )type=MyISAM } # fattribute_to_feature table }, # fattribute_to_feature cmap_attribute => { table=>q{ create table cmap_attribute ( attribute_id int(11) NOT NULL default '0', table_name varchar(30) NOT NULL default '', object_id int(11) NOT NULL default '0', display_order int(11) NOT NULL default '1', is_public tinyint(4) NOT NULL default '1', attribute_name varchar(200) NOT NULL default '', attribute_value text NOT NULL, PRIMARY KEY (attribute_id), KEY table_name (table_name,object_id,display_order,attribute_name) ) TYPE=MyISAM; } # table }, cmap_correspondence_evidence => { table=>q{ create table cmap_correspondence_evidence ( correspondence_evidence_id int(11) NOT NULL default '0', accession_id varchar(20) NOT NULL default '', feature_correspondence_id int(11) NOT NULL default '0', evidence_type_accession varchar(20) NOT NULL default '0', score double(8,2) default NULL, rank int(11) NOT NULL default '0', PRIMARY KEY (correspondence_evidence_id), UNIQUE KEY accession_id (accession_id), KEY feature_correspondence_id (feature_correspondence_id) ) TYPE=MyISAM; } # table }, cmap_correspondence_lookup => { table=>q{ create table cmap_correspondence_lookup ( feature_id1 int(11) default NULL, feature_id2 int(11) default NULL, feature_correspondence_id int(11) default NULL, start_position1 double(11,2) default NULL, start_position2 double(11,2) default NULL, stop_position1 double(11,2) default NULL, stop_position2 double(11,2) default NULL, map_id1 int(11) default NULL, map_id2 int(11) default NULL, feature_type_accession1 varchar(20) default NULL, feature_type_accession2 varchar(20) default NULL, KEY feature_id1 (feature_id1), KEY corr_id (feature_correspondence_id), KEY cl_map_id1 (map_id1), KEY cl_map_id2 (map_id2), KEY cl_map_id1_map_id2 (map_id1,map_id2), KEY cl_map_id2_map_id1 (map_id2,map_id1) ) TYPE=MyISAM; } # table }, cmap_correspondence_matrix => { table=>q{ create table cmap_correspondence_matrix ( reference_map_aid varchar(20) NOT NULL default '0', reference_map_name varchar(32) NOT NULL default '', reference_map_set_aid varchar(20) NOT NULL default '0', reference_species_aid varchar(20) NOT NULL default '0', link_map_aid varchar(20) default NULL, link_map_name varchar(32) default NULL, link_map_set_aid varchar(20) NOT NULL default '0', link_species_aid varchar(20) NOT NULL default '0', no_correspondences int(11) NOT NULL default '0' ) TYPE=MyISAM; } # table }, cmap_feature => { table=>q{ create table cmap_feature ( feature_id int(11) NOT NULL default '0', accession_id varchar(20) NOT NULL default '', map_id int(11) default NULL, feature_type_accession varchar(20) NOT NULL default '0', feature_name varchar(32) NOT NULL default '', is_landmark tinyint(4) NOT NULL default '0', start_position double(11,2) NOT NULL default '0.00', stop_position double(11,2) default NULL, default_rank int(11) NOT NULL default '1', direction tinyint(4) NOT NULL default '1', gclass varchar(100) default NULL, PRIMARY KEY (feature_id), UNIQUE KEY gclass (gclass,feature_name), UNIQUE KEY accession_id (accession_id), KEY feature_name (feature_name), KEY feature_id_map_id (feature_id,map_id), KEY feature_id_map_id_start (feature_id,map_id,start_position), KEY map_id (map_id), KEY map_id_feature_id (map_id,feature_id) ) TYPE=MyISAM; } # table }, cmap_feature_alias => { table=>q{ create table cmap_feature_alias ( feature_alias_id int(11) NOT NULL default '0', feature_id int(11) NOT NULL default '0', alias varchar(255) default NULL, PRIMARY KEY (feature_alias_id), UNIQUE KEY feature_id_2 (feature_id,alias), KEY feature_id (feature_id), KEY alias (alias) ) TYPE=MyISAM; } # table }, cmap_feature_correspondence => { table=>q{ create table cmap_feature_correspondence ( feature_correspondence_id int(11) NOT NULL default '0', accession_id varchar(20) NOT NULL default '', feature_id1 int(11) NOT NULL default '0', feature_id2 int(11) NOT NULL default '0', is_enabled tinyint(4) NOT NULL default '1', PRIMARY KEY (feature_correspondence_id), UNIQUE KEY accession_id (accession_id), KEY feature_id1 (feature_id1), KEY cmap_feature_corresp_idx (is_enabled,feature_correspondence_id) ) TYPE=MyISAM; } # table }, cmap_map => { table=>q{ create table cmap_map ( map_id int(11) NOT NULL default '0', accession_id varchar(20) NOT NULL default '', map_set_id int(11) NOT NULL default '0', map_name varchar(32) NOT NULL default '', display_order int(11) NOT NULL default '1', start_position double(11,2) default NULL, stop_position double(11,2) default NULL, PRIMARY KEY (map_id), UNIQUE KEY accession_id (accession_id), UNIQUE KEY map_id (map_id,map_set_id,map_name,accession_id), KEY map_set_id_index (map_set_id) ) TYPE=MyISAM; } # table }, cmap_map_set => { table=>q{ create table cmap_map_set ( map_set_id int(11) NOT NULL default '0', accession_id varchar(20) NOT NULL default '', map_set_name varchar(64) NOT NULL default '', short_name varchar(30) NOT NULL default '', map_type_accession varchar(20) NOT NULL default '0', species_id int(11) NOT NULL default '0', published_on date default NULL, can_be_reference_map tinyint(4) NOT NULL default '1', display_order int(11) NOT NULL default '1', is_enabled tinyint(4) NOT NULL default '1', shape varchar(12) default NULL, color varchar(20) default NULL, width int(11) default NULL, map_units varchar(12) NOT NULL default '', is_relational_map tinyint(11) NOT NULL default '0', PRIMARY KEY (map_set_id), UNIQUE KEY accession_id (accession_id), UNIQUE KEY map_set_id (map_set_id,species_id,short_name,accession_id), KEY cmap_map_set_idx (can_be_reference_map,is_enabled,species_id,display_order,published_on,short_name) ) TYPE=MyISAM; } # table }, cmap_next_number => { table=>q{ create table cmap_next_number ( table_name varchar(40) NOT NULL default '', next_number int(11) NOT NULL default '0', PRIMARY KEY (table_name) ) TYPE=MyISAM; }, # table insert=>{next_num=>q[ insert into cmap_next_number (table_name,next_number) VALUES ('cmap_feature',82);]} }, cmap_species => { table=>q{ create table cmap_species ( species_id int(11) NOT NULL default '0', accession_id varchar(20) NOT NULL default '', common_name varchar(64) NOT NULL default '', full_name varchar(64) NOT NULL default '', display_order int(11) NOT NULL default '1', PRIMARY KEY (species_id), KEY acc_id_species_id (accession_id,species_id) ) TYPE=MyISAM; } # table }, cmap_xref => { table=>q{ create table cmap_xref ( xref_id int(11) NOT NULL default '0', table_name varchar(30) NOT NULL default '', object_id int(11) default NULL, display_order int(11) NOT NULL default '1', xref_name varchar(200) NOT NULL default '', xref_url text NOT NULL, PRIMARY KEY (xref_id), KEY table_name (table_name,object_id,display_order) ) TYPE=MyISAM; } # table }, ); return \%schema; } =head2 make_classes_query Title : make_classes_query Usage : ($query,@args) = $db->make_classes_query Function: return query fragment for generating list of reference classes Returns : a query and args Args : none Status : public =cut sub make_classes_query { my $self = shift; return 'SELECT DISTINCT gclass FROM cmap_feature WHERE NOT ISNULL(gclass)'; } =head2 setup_load Title : setup_load Usage : $db->setup_load Function: called before load_gff_line() Returns : void Args : none Status : protected This method performs schema-specific initialization prior to loading a set of GFF records. It prepares a set of DBI statement handlers to be used in loading the data. =cut sub setup_load { my $self = shift; my $dbh = $self->features_db; if ($self->lock_on_load) { my @tables = map { "$_ WRITE"} $self->tables; my $tables = join ', ',@tables; $dbh->do("LOCK TABLES $tables"); } #xx1 my $lookup_type = $dbh->prepare_delayed('SELECT ftypeid FROM ftype WHERE fmethod=? AND fsource=?'); my $insert_type = $dbh->prepare_delayed('INSERT INTO ftype (fmethod,fsource) VALUES (?,?)'); my $lookup_group = $dbh->prepare_delayed('SELECT feature_id FROM cmap_feature WHERE feature_name=? AND gclass=?'); my $insert_group = $dbh->prepare_delayed(' INSERT into cmap_feature (feature_id, accession_id,feature_name, gclass ) VALUES (?,feature_id,?,?)'); my $aux_insert_group = $dbh->prepare_delayed(' update cmap_next_number set next_number = next_number +1 where table_name=\'cmap_feature\''); my $next_id_group = $dbh->prepare_delayed('select next_number from cmap_next_number where table_name=\'cmap_feature\''); my $lookup_attribute = $dbh->prepare_delayed('SELECT fattribute_id FROM fattribute WHERE fattribute_name=?'); my $insert_attribute = $dbh->prepare_delayed('INSERT INTO fattribute (fattribute_name) VALUES (?)'); my $insert_attribute_value = $dbh->prepare_delayed('INSERT INTO fattribute_to_feature (fid,fattribute_id,fattribute_value) VALUES (?,?,?)'); my $insert_data = $dbh->prepare_delayed(<{load_stuff}{sth}{lookup_ftype} = $lookup_type; $self->{load_stuff}{sth}{insert_ftype} = $insert_type; #$self->{load_stuff}{sth}{lookup_fgroup} = $lookup_group; #$self->{load_stuff}{sth}{insert_fgroup} = $insert_group; $self->{load_stuff}{sth}{lookup_cmap_feature} = $lookup_group; $self->{load_stuff}{sth}{insert_cmap_feature} = $insert_group; $self->{load_stuff}{sth}{aux_insert_cmap_feature} = $aux_insert_group; $self->{load_stuff}{sth}{next_id_cmap_feature} = $next_id_group; $self->{load_stuff}{sth}{insert_fdata} = $insert_data; $self->{load_stuff}{sth}{lookup_fattribute} = $lookup_attribute; $self->{load_stuff}{sth}{insert_fattribute} = $insert_attribute; $self->{load_stuff}{sth}{insert_fattribute_value} = $insert_attribute_value; $self->{load_stuff}{types} = {}; $self->{load_stuff}{groups} = {}; $self->{load_stuff}{counter} = 0; } =head2 load_gff_line Title : load_gff_line Usage : $db->load_gff_line($fields) Function: called to load one parsed line of GFF Returns : true if successfully inserted Args : hashref containing GFF fields Status : protected This method is called once per line of the GFF and passed a series of parsed data items that are stored into the hashref $fields. The keys are: ref reference sequence source annotation source method annotation method start annotation start stop annotation stop score annotation score (may be undef) strand annotation strand (may be undef) phase annotation phase (may be undef) group_class class of annotation's group (may be undef) group_name ID of annotation's group (may be undef) target_start start of target of a similarity hit target_stop stop of target of a similarity hit attributes array reference of attributes, each of which is a [tag=>value] array ref =cut sub load_gff_line { my $self = shift; my $gff = shift; my $s = $self->{load_stuff}; my $dbh = $self->features_db; local $dbh->{PrintError} = 0; defined(my $typeid = $self->get_table_id('ftype', $gff->{method} => $gff->{source})) or return; defined(my $groupid = $self->get_table_id('cmap_feature',$gff->{gname} => $gff->{gclass})) or return; if ($gff->{stop}-$gff->{start}+1 > $self->max_bin) { warn "$gff->{gclass}:$gff->{gname} is longer than ",$self->maxbin,".\n"; warn "Please set the maxbin value to a larger length than the largest feature you wish to store.\n"; warn "With the command-line tools you do with this with --maxfeature option.\n"; } my $bin = bin($gff->{start},$gff->{stop},$self->min_bin); my $result = $s->{sth}{insert_fdata}->execute($gff->{ref}, $gff->{start},$gff->{stop},$bin, $typeid, $gff->{score},$gff->{strand},$gff->{phase}, $groupid, $gff->{tstart},$gff->{tstop}); warn $dbh->errstr,"\n" && return unless $result; my $fid = $dbh->{mysql_insertid} || $self->get_feature_id($gff->{ref},$gff->{start},$gff->{stop},$typeid,$groupid); # insert attributes foreach (@{$gff->{attributes}}) { defined(my $attribute_id = $self->get_table_id('fattribute',$_->[0])) or return; $s->{sth}{insert_fattribute_value}->execute($fid,$attribute_id,$_->[1]); } if ( (++$s->{counter} % 1000) == 0) { print STDERR "$s->{counter} records loaded..."; print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; } $fid; } =head2 get_feature_id Title : get_feature_id Usage : $integer = $db->get_feature_id($ref,$start,$stop,$typeid,$groupid) Function: get the ID of a feature Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature. It is ony needed when replacing a feature with new information. =cut # this method is called when needed to look up a feature's ID sub get_feature_id { my $self = shift; my ($ref,$start,$stop,$typeid,$groupid) = @_; my $s = $self->{load_stuff}; unless ($s->{get_feature_id}) { my $dbh = $self->features_db; $s->{get_feature_id} = $dbh->prepare_delayed('SELECT fid FROM fdata WHERE fref=? AND fstart=? AND fstop=? AND ftypeid=? AND feature_id=?'); } my $sth = $s->{get_feature_id} or return; $sth->execute($ref,$start,$stop,$typeid,$groupid) or return; my ($fid) = $sth->fetchrow_array; return $fid; } =head2 get_table_id Title : get_table_id Usage : $integer = $db->get_table_id($table,@ids) Function: get the ID of a group or type Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature type or group. The arguments are the name of the table, and two string identifiers. For feature types, the identifiers are the method and source. For groups, the identifiers are group name and class. This method requires that a statement handler named I, have been created previously by setup_load(). It is here to overcome deficiencies in mysql's INSERT syntax. =cut #' # get the object ID from a named table sub get_table_id { my $self = shift; my $table = shift; my @ids = @_; # irritating warning for null id my $id_key; { local $^W=0; $id_key = join ':',@ids; } my $s = $self->{load_stuff}; my $sth = $s->{sth}; my $dbh = $self->features_db; unless (defined($s->{$table}{$id_key})) { ######################################### # retrieval of the last inserted id is now located at the adaptor and not in caching_handle ####################################### if ( (my $result = $sth->{"lookup_$table"}->execute(@ids)) > 0) { $s->{$table}{$id_key} = ($sth->{"lookup_$table"}->fetchrow_array)[0]; } else { if (defined($sth->{"next_id_$table"})){ $sth->{"insert_$table"}->execute(3,'string1','string2'); # Can't use auto incrementing $sth->{"next_id_$table"}->execute(); $s->{$table}{$id_key} = ($sth->{"next_id_$table"}->fetchrow_array)[0]; if ($s->{$table}{$id_key}){ $sth->{"insert_$table"}->execute($s->{$table}{$id_key},@ids); $sth->{"aux_insert_$table"}->execute() if $sth->{"aux_insert_$table"}; } } else{ $sth->{"insert_$table"}->execute(@ids); $s->{$table}{$id_key} = $self->insertid($sth->{"insert_$table"}) unless $s->{$table}{$id_key}; $sth->{"aux_insert_$table"}->execute() if $sth->{"aux_insert_$table"}; } } } my $id = $s->{$table}{$id_key}; unless (defined $id) { warn "No $table id for $id_key ",$dbh->errstr," Record skipped.\n"; return; } $id; } #----------------------------------- =head2 make_features_by_name_where_part Title : make_features_by_name_where_part Usage : $db->make_features_by_name_where_part Function: create the SQL fragment needed to select a feature by its group name & class Returns : a SQL fragment and bind arguments Args : see below Status : Protected =cut sub make_features_by_name_where_part { my $self = shift; my ($class,$name) = @_; if ($name =~ /\*/) { $name =~ tr/*/%/; return ("cmap_feature.gclass=? AND cmap_feature.feature_name LIKE ?",$class,$name); } else { return ("cmap_feature.gclass=? AND cmap_feature.feature_name=?",$class,$name); } } =head2 make_features_join_part Title : make_features_join_part Usage : $string = $db->make_features_join_part() Function: make join part of the features query Returns : a string Args : none Status : protected This method creates the part of the features query that immediately follows the WHERE keyword. =cut sub make_features_join_part { my $self = shift; my $options = shift || {}; return !$options->{attributes} ? <search_notes("full text search string",$limit) Function: Search the notes for a text string, using mysql full-text search Returns : array of results Args : full text search string, and an optional row limit Status : public This is a mysql-specific method. Given a search string, it performs a full-text search of the notes table and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 A Bio::DB::GFF::Featname object, suitable for passing to segment() column 2 The text of the note column 3 A relevance score. =cut sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my @words = $search_string =~ /(\w+)/g; my $regex = join '|',@words; my @searches = map {"fattribute_value LIKE '%${_}%'"} @words; my $search = join(' OR ',@searches); my $query = <dbh->do_query($query); my @results; while (my ($class,$name,$note) = $sth->fetchrow_array) { next unless $class && $name; # sorry, ignore NULL objects my @matches = $note =~ /($regex)/g; my $relevance = 10*@matches; my $featname = Bio::DB::GFF::Featname->new($class=>$name); push @results,[$featname,$note,$relevance]; last if $limit && @results >= $limit; } @results; } # sub search_notes { # my $self = shift; # my ($search_string,$limit) = @_; # my $query = FULLTEXTSEARCH; # $query .= " limit $limit" if defined $limit; # my $sth = $self->dbh->do_query($query,$search_string,$search_string); # my @results; # while (my ($class,$name,$note,$relevance) = $sth->fetchrow_array) { # next unless $class && $name; # sorry, ignore NULL objects # $relevance = sprintf("%.2f",$relevance); # trim long floats # my $featname = Bio::DB::GFF::Featname->new($class=>$name); # push @results,[$featname,$note,$relevance]; # } # @results; # } =head2 make_features_order_by_part Title : make_features_order_by_part Usage : ($query,@args) = $db->make_features_order_by_part() Function: make the ORDER BY part of the features() query Returns : a SQL fragment and bind arguments, if any Args : none Status : protected This method creates the part of the features query that immediately follows the ORDER BY part of the query issued by features() and related methods. =cut sub make_features_order_by_part { my $self = shift; my $options = shift || {}; return "cmap_feature.feature_name"; } =head2 create_cmap_viewer_link Title : create_cmap_viewer_link Usage : $link_str = $db->create_cmap_viewer_link(data_source=>$ds,group_id=>$gid) Function: Returns : Args : Status : =cut sub create_cmap_viewer_link { my $self = shift; my %args = @_; my $data_source = $args{'data_source'}; my $gid = $args{'group_id'}; my $link_str = undef; my $db = $self->features_db; my $sql_str = qq[ select f.feature_name, f.feature_type_accession feature_type_aid, m.accession_id as map_aid, ms.accession_id as map_set_aid from cmap_feature f, cmap_map m, cmap_map_set ms where f.map_id=m.map_id and ms.map_set_id=m.map_set_id and f.feature_id=$gid ]; my $result_ref = $db->selectrow_hashref($sql_str,{ Columns => {} }); if ( $result_ref ) { $link_str='/cgi-bin/cmap/viewer?ref_map_set_aid=' . $result_ref->{'map_set_aid'} . '&ref_map_aids=' . $result_ref->{'map_aid'} . '&data_source=' . $data_source . '&highlight=' .$result_ref->{'feature_name'} . '&feature_type_' .$result_ref->{'feature_type_aid'} . '=2'; } return $link_str; } 1; __END__ =head1 BUGS none ;-) =head1 SEE ALSO L, L =head1 AUTHOR Ben Faga Efaga@cshl.orgE. Modified from mysql.pm by: Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/mysqlopt.pm000444000765000024 114612254227326 21421 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::mysqlopt; =head1 NAME Bio::DB::GFF::Adaptor::dbi::mysqlopt -- Deprecated database adaptor =head1 SYNOPSIS This adaptor has been superseded by Bio::DB::GFF::Adaptor::dbi::mysql. See L and L =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use base qw(Bio::DB::GFF::Adaptor::dbi::mysql); 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/oracle.pm000444000765000024 6773312254227322 21030 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::oracle; =head1 NAME Bio::DB::GFF::Adaptor::dbi::oracle -- Database adaptor for a specific oracle schema =head1 SYNOPSIS See L =cut # a simple oracle adaptor use strict; #use Bio::DB::GFF::Adaptor::dbi::mysql; #use Bio::DB::GFF::Adaptor::dbi::mysqlopt; use Bio::DB::GFF::Util::Binning; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use base qw(Bio::DB::GFF::Adaptor::dbi); use constant MAX_SEGMENT => 100_000_000; # the largest a segment can get use constant DEFAULT_CHUNK => 2000; use constant GETSEQCOORDS =><<<< 100_000_000; # this is the smallest bin (1 K) use constant MIN_BIN => 1000; # size of range over which it is faster to force mysql to use the range for indexing use constant STRAIGHT_JOIN_LIMIT => 200_000; ############################################################################## =head1 DESCRIPTION This adaptor implements a specific oracle database schema that is compatible with Bio::DB::GFF. It inherits from Bio::DB::GFF::Adaptor::dbi, which itself inherits from Bio::DB::GFF. The schema uses several tables: =over 4 =item fdata This is the feature data table. Its columns are: fid feature ID (integer) fref reference sequence name (string) fstart start position relative to reference (integer) fstop stop postion relative to reference (integer) ftypeid feature type ID (integer) fscore feature score (float); may be null fstrand strand; one of "+" or "-"; may be null fphase phase; one of 0, 1 or 2; may be null gid group ID (integer) ftarget_start for similarity features, the target start position (integer) ftarget_stop for similarity features, the target stop position (integer) Note that it would be desirable to normalize the reference sequence name, since there are usually many features that share the same reference feature. However, in the current schema, query performance suffers dramatically when this additional join is added. =item fgroup This is the group table. There is one row for each group. Columns: gid the group ID (integer) gclass the class of the group (string) gname the name of the group (string) The group table serves multiple purposes. As you might expect, it is used to cluster features that logically belong together, such as the multiple exons of the same transcript. It is also used to assign a name and class to a singleton feature. Finally, the group table is used to identify the target of a similarity hit. This is consistent with the way in which the group field is used in the GFF version 2 format. The fgroup.gid field joins with the fdata.gid field. Examples: sql> select * from fgroup where gname='sjj_2L52.1'; +-------+-------------+------------+ | gid | gclass | gname | +-------+-------------+------------+ | 69736 | PCR_product | sjj_2L52.1 | +-------+-------------+------------+ 1 row in set (0.70 sec) sql> select fref,fstart,fstop from fdata,fgroup where gclass='PCR_product' and gname = 'sjj_2L52.1' and fdata.gid=fgroup.gid; +---------------+--------+-------+ | fref | fstart | fstop | +---------------+--------+-------+ | CHROMOSOME_II | 1586 | 2355 | +---------------+--------+-------+ 1 row in set (0.03 sec) =item ftype This table contains the feature types, one per row. Columns are: ftypeid the feature type ID (integer) fmethod the feature type method name (string) fsource the feature type source name (string) The ftype.ftypeid field joins with the fdata.ftypeid field. Example: sql> select fref,fstart,fstop,fmethod,fsource from fdata,fgroup,ftype where gclass='PCR_product' and gname = 'sjj_2L52.1' and fdata.gid=fgroup.gid and fdata.ftypeid=ftype.ftypeid; +---------------+--------+-------+-------------+-----------+ | fref | fstart | fstop | fmethod | fsource | +---------------+--------+-------+-------------+-----------+ | CHROMOSOME_II | 1586 | 2355 | PCR_product | GenePairs | +---------------+--------+-------+-------------+-----------+ 1 row in set (0.08 sec) =item fdna This table holds the raw DNA of the reference sequences. It has three columns: fref reference sequence name (string) foffset offset of this sequence fdna the DNA sequence (longblob) To overcome problems loading large blobs, DNA is automatically fragmented into multiple segments when loading, and the position of each segment is stored in foffset. The fragment size is controlled by the -clump_size argument during initialization. =item fattribute_to_feature This table holds "attributes", which are tag/value pairs stuffed into the GFF line. The first tag/value pair is treated as the group, and anything else is treated as an attribute (weird, huh?). CHR_I assembly_tag Finished 2032 2036 . + . Note "Right: cTel33B" CHR_I assembly_tag Polymorphism 668 668 . + . Note "A->C in cTel33B" The columns of this table are: fid feature ID (integer) fattribute_id ID of the attribute (integer) fattribute_value text of the attribute (text) The fdata.fid column joins with fattribute_to_feature.fid. =item fattribute This table holds the normalized names of the attributes. Fields are: fattribute_id ID of the attribute (integer) fattribute_name Name of the attribute (varchar) =back =head2 Data Loading Methods In addition to implementing the abstract SQL-generating methods of Bio::DB::GFF::Adaptor::dbi, this module also implements the data loading functionality of Bio::DB::GFF. =cut =head2 new Title : new Usage : $db = Bio::DB::GFF->new(@args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : see below Status : Public The new constructor is identical to the "dbi" adaptor's new() method, except that the prefix "dbi:oracle" is added to the database DSN identifier automatically if it is not there already. Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:mysql:ens0040' or "ens0040" -user username for authentication -pass the password for authentication =cut #' sub new { my $class = shift; my ($dsn,$other) = rearrange([ [qw(FEATUREDB DB DSN)], ],@_); $dsn = "dbi:Oracle:$dsn" if !ref($dsn) && $dsn !~ /^(dbi|DBI):/; my $self = $class->SUPER::new(-dsn=>$dsn,%$other); $self; } =head2 schema Title : schema Usage : $schema = $db->schema Function: return the CREATE script for the schema Returns : a list of CREATE statemetns Args : none Status : protected This method returns a list containing the various CREATE statements needed to initialize the database tables. =cut sub schema { my %schema = ( fdata =>{ table=> q{ create table fdata ( fid INTEGER NOT NULL, fref VARCHAR(100) DEFAULT '' NOT NULL, fstart INTEGER DEFAULT '0' NOT NULL, fstop INTEGER DEFAULT '0' NOT NULL, fbin NUMBER DEFAULT '0.000000' NOT NULL, ftypeid INTEGER DEFAULT '0' NOT NULL, fscore NUMBER , fstrand VARCHAR2(3) CHECK (fstrand IN ('+','-')), fphase VARCHAR2(3) CHECK (fphase IN ('0','1','2')), gid INTEGER DEFAULT '0' NOT NULL, ftarget_start INTEGER , ftarget_stop INTEGER , CONSTRAINT fdata_pk PRIMARY KEY (fid) ) }, # fdata table index=>{ fdata_fref_idx => q{ CREATE UNIQUE INDEX fdata_fref_idx ON fdata (fref,fbin,fstart,fstop,ftypeid,gid) }, fdata_ftypeid_idx => q{ CREATE INDEX fdata_ftypeid_idx ON fdata (ftypeid) }, fdata_gid_idx => q{ CREATE INDEX fdata_gid_idx ON fdata (gid) } }, # fdata indexes sequence=> { fdata_fid_sq => q{ CREATE SEQUENCE fdata_fid_sq START WITH 1 } }, # fdata sequences trigger=> { fdata_fid_ai => q{ CREATE OR REPLACE TRIGGER fdata_fid_ai BEFORE INSERT ON fdata FOR EACH ROW WHEN (new.fid IS NULL OR new.fid = 0) BEGIN SELECT fdata_fid_sq.nextval INTO :new.fid FROM dual; END; } }# fdata triggers }, # fdata fgroup => { table => q{ CREATE TABLE fgroup ( gid INTEGER NOT NULL, gclass VARCHAR(100) , gname VARCHAR(100) , CONSTRAINT fgroup_pk PRIMARY KEY (gid) ) }, # fgroup table index => { fgroup_gclass_idx => q{ CREATE UNIQUE INDEX fgroup_gclass_idx ON fgroup (gclass,gname) } }, # fgroup indexes sequence => { fgroup_gid_sq => q{ CREATE SEQUENCE fgroup_gid_sq START WITH 1 } }, # fgroup sequences trigger => { fgroup_gid_ai => q{ CREATE OR REPLACE TRIGGER fgroup_gid_ai BEFORE INSERT ON fgroup FOR EACH ROW WHEN (new.gid IS NULL OR new.gid = 0) BEGIN SELECT fgroup_gid_sq.nextval INTO :new.gid FROM dual; END; } } # fgroup triggers }, # fgroup ftype => { table => q{ CREATE TABLE ftype ( ftypeid INTEGER NOT NULL, fmethod VARCHAR(100) DEFAULT '' NOT NULL, fsource VARCHAR(100), CONSTRAINT ftype_pk PRIMARY KEY (ftypeid) ) }, # ftype table index => { ftype_fmethod_idx => q{ CREATE INDEX ftype_fmethod_idx ON ftype (fmethod) }, ftype_fsource_idx => q{ CREATE INDEX ftype_fsource_idx ON ftype (fsource) }, ftype_ftype_idx => q{ CREATE UNIQUE INDEX ftype_ftype_idx ON ftype (fmethod,fsource) } }, # ftype indexes sequence => { ftype_ftypeid_sq => q{ CREATE SEQUENCE ftype_ftypeid_sq START WITH 1 } }, #ftype sequences trigger => { ftype_ftypeid_ai => q{ CREATE OR REPLACE TRIGGER ftype_ftypeid_ai BEFORE INSERT ON ftype FOR EACH ROW WHEN (new.ftypeid IS NULL OR new.ftypeid = 0) BEGIN SELECT ftype_ftypeid_sq.nextval INTO :new.ftypeid FROM dual; END; } } #ftype triggers }, # ftype fdna => { table => q{ CREATE TABLE fdna ( fref VARCHAR(100) DEFAULT '' NOT NULL, foffset INTEGER DEFAULT '0' NOT NULL, fdna LONG /* LONGBLOB */ , CONSTRAINT fdna_pk PRIMARY KEY (fref,foffset) ) } #fdna table }, #fdna fmeta => { table => q{ CREATE TABLE fmeta ( fname VARCHAR(255) DEFAULT '' NOT NULL, fvalue VARCHAR(255) DEFAULT '' NOT NULL, CONSTRAINT fmeta_pk PRIMARY KEY (fname) ) } # fmeta table }, # fmeta fattribute => { table => q{ CREATE TABLE fattribute ( fattribute_id INTEGER NOT NULL, fattribute_name VARCHAR(255) DEFAULT '' NOT NULL, CONSTRAINT fattribute_pk PRIMARY KEY (fattribute_id) ) }, # fattribute table sequence=> { fattribute_fattribute_id_sq => q{ CREATE SEQUENCE fattribute_fattribute_id_sq START WITH 1 } }, # fattribute sequences trigger => { fattribute_fattribute_id_ai => q{ CREATE OR REPLACE TRIGGER fattribute_fattribute_id_ai BEFORE INSERT ON fattribute FOR EACH ROW WHEN (new.fattribute_id IS NULL OR new.fattribute_id = 0) BEGIN SELECT fattribute_fattribute_id_sq.nextval INTO :new.fattribute_id FROM dual; END; } } # fattribute triggers }, # fattribute fattribute_to_feature => { table => q{ CREATE TABLE fattribute_to_feature ( fid INTEGER DEFAULT '0' NOT NULL, fattribute_id INTEGER DEFAULT '0' NOT NULL, fattribute_value VARCHAR2(255) /* TEXT */ ) }, # fattribute_to_feature table index => { fattribute_to_feature_fid => q{ CREATE INDEX fattribute_to_feature_fid ON fattribute_to_feature (fid,fattribute_id) } } # fattribute_to_feature indexes }, # fattribute_to_feature finterval_stats => { table=> q{ CREATE TABLE "finterval_stats" ( "ftypeid" integer DEFAULT '0' NOT NULL, "fref" VARCHAR(100) DEFAULT '' NOT NULL, "fbin" integer DEFAULT '0' NOT NULL, "fcum_count" integer DEFAULT '0' NOT NULL, CONSTRAINT finterval_stats_pk PRIMARY KEY (ftypeid,fref,fbin) ) } # finterval_stats table },# finterval_stats ); return \%schema; } =head2 do_initialize Title : do_initialize Usage : $success = $db->do_initialize($drop_all) Function: initialize the database Returns : a boolean indicating the success of the operation Args : a boolean indicating whether to delete existing data Status : protected This method will load the schema into the database. If $drop_all is true, then any existing data in the tables known to the schema will be deleted. Internally, this method calls schema() to get the schema data. =cut # Create the schema from scratch. # You will need create privileges for this. #sub do_initialize { # my $self = shift; # my $erase = shift; # $self->drop_all if $erase; # my $dbh = $self->features_db; # my $schema = $self->schema; # foreach my $table_name(keys %$schema) { # my $create_table_stmt = $$schema{$table_name}{table} ; # $dbh->do($create_table_stmt) || warn $dbh->errstr; # } # 1; #} =head2 drop_all Title : drop_all Usage : $db->drop_all Function: empty the database Returns : void Args : none Status : protected This method drops the tables known to this module. Internally it calls the abstract tables() method. =cut # Drop all the GFF tables -- dangerous! #sub drop_all { # my $self = shift; # my $dbh = $self->features_db; # local $dbh->{PrintError} = 0; # foreach ($self->tables) { # $dbh->do("drop table $_"); # } #} =head2 setup_load Title : setup_load Usage : $db->setup_load Function: called before load_gff_line() Returns : void Args : none Status : protected This method performs schema-specific initialization prior to loading a set of GFF records. It prepares a set of DBI statement handlers to be used in loading the data. =cut sub setup_load { my $self = shift; my $schema = $self->schema; my $dbh = $self->features_db; if ($self->lock_on_load) { my @tables = map { "$_ WRITE"} $self->tables; my $tables = join ', ',@tables; $dbh->do("LOCK TABLES $tables"); } my $lookup_type = $dbh->prepare_delayed('SELECT ftypeid FROM ftype WHERE fmethod=? AND fsource=?'); my $insert_type = $dbh->prepare_delayed('INSERT INTO ftype (fmethod,fsource) VALUES (?,?)'); my $sequence_type = (keys %{$schema->{ftype}{sequence}})[0]; my $insertid_type = $dbh->prepare_delayed("SELECT $sequence_type.CURRVAL FROM dual"); my $lookup_group = $dbh->prepare_delayed('SELECT gid FROM fgroup WHERE gname=? AND gclass=?'); my $insert_group = $dbh->prepare_delayed('INSERT INTO fgroup (gname,gclass) VALUES (?,?)'); my $sequence_group = (keys %{$schema->{fgroup}{sequence}})[0]; my $insertid_group = $dbh->prepare_delayed("SELECT $sequence_group.CURRVAL FROM dual"); my $lookup_attribute = $dbh->prepare_delayed('SELECT fattribute_id FROM fattribute WHERE fattribute_name=?'); my $insert_attribute = $dbh->prepare_delayed('INSERT INTO fattribute (fattribute_name) VALUES (?)'); my $sequence_attribute = (keys %{$schema->{fattribute}{sequence}})[0]; my $insertid_attribute = $dbh->prepare_delayed("SELECT $sequence_attribute.CURRVAL FROM dual"); my $insert_attribute_value = $dbh->prepare_delayed('INSERT INTO fattribute_to_feature (fid,fattribute_id,fattribute_value) VALUES (?,?,?)'); my $insert_data = $dbh->prepare_delayed(<prepare_delayed('DELETE FROM fdata WHERE fref=? AND fstart=? AND fstop=? AND fbin=? AND ftypeid=? AND GID=?'); my $sequence_data = (keys %{$schema->{fdata}{sequence}})[0]; my $insertid_data = $dbh->prepare_delayed("SELECT $sequence_data.CURRVAL FROM dual"); $self->{load_stuff}{sth}{lookup_ftype} = $lookup_type; $self->{load_stuff}{sth}{insert_ftype} = $insert_type; $self->{load_stuff}{sth}{insertid_ftype} = $insertid_type; $self->{load_stuff}{sth}{lookup_fgroup} = $lookup_group; $self->{load_stuff}{sth}{insert_fgroup} = $insert_group; $self->{load_stuff}{sth}{insertid_fgroup} = $insertid_group; $self->{load_stuff}{sth}{insert_fdata} = $insert_data; $self->{load_stuff}{sth}{insertid_fdata} = $insertid_data; $self->{load_stuff}{sth}{delete_existing_fdata} = $delete_existing_data; $self->{load_stuff}{sth}{lookup_fattribute} = $lookup_attribute; $self->{load_stuff}{sth}{insert_fattribute} = $insert_attribute; $self->{load_stuff}{sth}{insertid_fattribute} = $insertid_attribute; $self->{load_stuff}{sth}{insert_fattribute_value} = $insert_attribute_value; $self->{load_stuff}{types} = {}; $self->{load_stuff}{groups} = {}; $self->{load_stuff}{counter} = 0; } =head2 load_gff_line Title : load_gff_line Usage : $db->load_gff_line($fields) Function: called to load one parsed line of GFF Returns : true if successfully inserted Args : hashref containing GFF fields Status : protected This method is called once per line of the GFF and passed a series of parsed data items that are stored into the hashref $fields. The keys are: ref reference sequence source annotation source method annotation method start annotation start stop annotation stop score annotation score (may be undef) strand annotation strand (may be undef) phase annotation phase (may be undef) group_class class of annotation's group (may be undef) group_name ID of annotation's group (may be undef) target_start start of target of a similarity hit target_stop stop of target of a similarity hit attributes array reference of attributes, each of which is a [tag=>value] array ref =cut sub load_gff_line { my $self = shift; my $gff = shift; if (defined $gff->{phase}){ chomp($gff->{phase}); undef($gff->{phase}) if $gff->{phase} eq '.'; } if (defined $gff->{strand} && $gff->{strand} eq '.'){undef($gff->{strand})}; if (defined $gff->{score} && $gff->{score} eq '.'){undef($gff->{score})}; my $s = $self->{load_stuff}; my $dbh = $self->features_db; local $dbh->{PrintError} = 0; defined(my $typeid = $self->get_table_id('ftype', $gff->{method} => $gff->{source})) or return; defined(my $groupid = $self->get_table_id('fgroup',$gff->{gname} => $gff->{gclass})) or return; my $bin = bin($gff->{start},$gff->{stop},$self->min_bin); my $result = $s->{sth}{insert_fdata}->execute($gff->{ref}, $gff->{start},$gff->{stop},$bin, $typeid, $gff->{score},$gff->{strand},$gff->{phase}, $groupid, $gff->{tstart},$gff->{tstop}); if (defined ($dbh->errstr)){ print $dbh->errstr,"\n" ,%$gff,"\n"; if ($dbh->errstr =~ /ORA-02290: check constraint/){ print "PHASE=$gff->{phase}"."===","\n"; } if ($dbh->errstr =~ /ORA-00001: unique constraint/){ $result = $s->{sth}{delete_existing_fdata}->execute($gff->{ref}, $gff->{start},$gff->{stop},$bin, $typeid, $groupid); print "delete row result=$result\n"; $result = $s->{sth}{insert_fdata}->execute($gff->{ref}, $gff->{start},$gff->{stop},$bin, $typeid, $gff->{score},$gff->{strand},$gff->{phase}, $groupid, $gff->{tstart},$gff->{tstop}); print "insert row result=$result\n"; } } warn $dbh->errstr,"\n" and print "ref=",$gff->{ref}," start=",$gff->{start}," stop=",$gff->{stop}," bin=",$bin," typeid=",$typeid," groupid=",$groupid,"\n" and return unless $result; my $fid = $self->insertid($s->{sth},'fdata') || $self->get_feature_id($gff->{ref},$gff->{start},$gff->{stop},$typeid,$groupid); # insert attributes # print STDERR map {"$fid attribute:". $_->[0]."=".$_->[1]."\n"} @{$gff->{attributes}}; foreach (@{$gff->{attributes}}) { defined(my $attribute_id = $self->get_table_id('fattribute',$_->[0])) or return; $s->{sth}{insert_fattribute_value}->execute($fid,$attribute_id,$_->[1]); } if ( (++$s->{counter} % 1000) == 0) { print STDERR "$s->{counter} records loaded..."; print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; } $fid; } =head2 get_table_id Title : get_table_id Usage : $integer = $db->get_table_id($table,@ids) Function: get the ID of a group or type Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature type or group. The arguments are the name of the table, and two string identifiers. For feature types, the identifiers are the method and source. For groups, the identifiers are group name and class. This method requires that a statement handler named I, have been created previously by setup_load(). It is here to overcome deficiencies in mysql's INSERT syntax. =cut #' # get the object ID from a named table sub get_table_id { my $self = shift; my $table = shift; my @ids = @_; # irritating warning for null id my $id_key; { local $^W=0; $id_key = join ':',@ids; } my $s = $self->{load_stuff}; my $sth = $s->{sth}; my $dbh = $self->features_db; unless (defined($s->{$table}{$id_key})) { $sth->{"lookup_$table"}->execute(@ids); my @result = $sth->{"lookup_$table"}->fetchrow_array; if (@result > 0) { $s->{$table}{$id_key} = $result[0]; } else { $sth->{"insert_$table"}->execute(@ids) && ($s->{$table}{$id_key} = $self->insertid($sth,$table)); #&& ($s->{$table}{$id_key} = $self->insertid($sth->{"insertid_$table"})); #&& ($s->{$table}{$id_key} = $sth->{"insert_$table"}->insertid); } } my $id = $s->{$table}{$id_key}; unless (defined $id) { warn "No $table id for $id_key ",$dbh->errstr," Record skipped.\n"; return; } $id; } sub insertid { my $self = shift; my $sth = shift ; my $table = shift; my $insert_id; if ($sth->{"insertid_$table"}->execute()){ $insert_id = ($sth->{"insertid_$table"}->fetchrow_array)[0]; } else{ warn "No CURRVAL for SEQUENCE of table $table ",$sth->errstr,"\n"; return; } return $insert_id; } #sub insertid { # my $self = shift; # my $insertid_sth = shift ; # my $insert_id; # if ($insertid_sth->execute){ # $insert_id = ($insertid_sth->fetchrow_array)[0]; # } # else{ # warn "No CURRVAL for SEQUENCE ",$insertid_sth->errstr,"\n"; # return; # } # return $insert_id; #} sub insert_sequence { my $self = shift; my($id,$offset,$seq) = @_; my $sth = $self->{_insert_sequence} ||= $self->dbh->prepare_delayed('insert into fdna values (?,?,?)'); $sth->execute($id,$offset,$seq) or $self->throw($sth->errstr); } =head2 search_notes Title : search_notes Usage : @search_results = $db->search_notes("full text search string",$limit) Function: Search the notes for a text string, using mysql full-text search Returns : array of results Args : full text search string, and an optional row limit Status : public This is a mysql-specific method. Given a search string, it performs a full-text search of the notes table and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 A Bio::DB::GFF::Featname object, suitable for passing to segment() column 2 The text of the note column 3 A relevance score. column 4 A Bio::DB::GFF::Typename object =cut sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my @words = $search_string =~ /(\w+)/g; my $regex = join '|',@words; my @searches = map {"fattribute_value LIKE '%${_}%'"} @words; my $search = join(' OR ',@searches); my $query = <dbh->do_query($query); my @results; while (my ($class,$name,$note,$method,$source) = $sth->fetchrow_array) { next unless $class && $name; # sorry, ignore NULL objects my @matches = $note =~ /($regex)/g; my $relevance = 10*@matches; my $featname = Bio::DB::GFF::Featname->new($class=>$name); my $type = Bio::DB::GFF::Typename->new($method,$source); push @results,[$featname,$note,$relevance,$type]; last if $limit && @results >= $limit; } @results; } =head2 make_meta_set_query Title : make_meta_set_query Usage : $sql = $db->make_meta_set_query Function: return SQL fragment for setting a meta parameter Returns : SQL fragment Args : none Status : public By default this does nothing; meta parameters are not stored or retrieved. =cut sub make_meta_set_query { return 'INSERT INTO fmeta VALUES (?,?)'; } sub make_classes_query { my $self = shift; return 'SELECT DISTINCT gclass FROM fgroup WHERE NOT gclass IS NULL'; } sub chunk_size { my $self = shift; $self->meta('chunk_size') || DEFAULT_CHUNK; } sub getseqcoords_query { my $self = shift; return GETSEQCOORDS ; } sub getaliascoords_query{ my $self = shift; return GETALIASCOORDS ; } sub getforcedseqcoords_query{ my $self = shift; return GETFORCEDSEQCOORDS ; } sub getaliaslike_query{ my $self = shift; return GETALIASLIKE ; } sub make_features_select_part { my $self = shift; my $options = shift || {}; my $s; if (my $b = $options->{bin_width}) { $s = <{attributes} && keys %{$options->{attributes}}>1; $s; } sub make_features_from_part_bkup { my $self = shift; my $sparse = shift; my $options = shift || {}; #my $index = $sparse ? ' USE INDEX(ftypeid)': ''; my $index = ''; return $options->{attributes} ? "fdata${index},ftype,fgroup,fattribute,fattribute_to_feature\n" : "fdata${index},ftype,fgroup\n"; } #################################### # moved from mysqlopt.pm ################################### # meta values sub default_meta_values { my $self = shift; my @values = $self->SUPER::default_meta_values; return ( @values, max_bin => MAX_BIN, min_bin => MIN_BIN, straight_join_limit => STRAIGHT_JOIN_LIMIT, ); } sub min_bin { my $self = shift; return $self->meta('min_bin') || MIN_BIN; } sub max_bin { my $self = shift; return $self->meta('max_bin') || MAX_BIN; } sub straight_join_limit { my $self = shift; return $self->meta('straight_join_limit') || STRAIGHT_JOIN_LIMIT; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/oracleace.pm000444000765000024 542012254227312 21441 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::oracleace; =head1 NAME Bio::DB::GFF::Adaptor::dbi::oracleace -- Unholy union between oracle GFF database and acedb database =head1 SYNOPSIS Pending See L and L =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2002 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use base qw(Bio::DB::GFF::Adaptor::ace Bio::DB::GFF::Adaptor::dbi::oracle); # Create a new Bio::DB::GFF::Adaptor::dbi object sub new { my $class = shift; my $self = $class->SUPER::new(@_); my ($dna_db,$acedb) = rearrange([[qw(DNADB DNA FASTA FASTA_DIR)],'ACEDB'],@_); if ($dna_db) { if (!ref($dna_db)) { require Bio::DB::Fasta; my $fasta_dir = $dna_db; $dna_db = Bio::DB::Fasta->new($fasta_dir); $dna_db or $class->throw("new(): Failed to create new Bio::DB::Fasta from files in $fasta_dir"); } else { $dna_db->isa('Bio::DB::Fasta') or $class->throw("new(): $dna_db is not a Bio::DB::Fasta object"); } $self->dna_db($dna_db); } if ($acedb) { $acedb->isa('Ace') or $class->throw("$acedb is not an acedb accessor object"); $self->acedb($acedb); } $self; } sub make_object { my $self = shift; my ($class,$name,$start,$stop) = @_; if (my $db = $self->acedb) { # for Notes we just return a text, no database associated return $class->new(Text=>$name) if $class eq 'Note'; # for homols, we create the indicated Protein or Sequence object # then generate a bogus Homology object (for future compatability??) if ($start ne '') { require Ace::Sequence::Homol; return Ace::Sequence::Homol->new_homol($class,$name,$db,$start,$stop); } # General case: my $obj = $db->class->new($class=>$name,$self->acedb); return $obj if defined $obj; # Last resort, return a Text return $class->new(Text=>$name); } return $self->SUPER::make_object($class,$name,$start,$stop); } sub get_dna { my $self = shift; my ($ref,$start,$stop,$class) = @_; my $dna_db = $self->dna_db or return $self->SUPER::get_dna(@_); return $dna_db->seq($ref,$start,$stop,$class); } =head2 freshen_ace Title : freshen Usage : $flag = Bio::DB::GFF->freshen_ace; Function: Refresh internal acedb handle Returns : flag if correctly freshened Args : none Status : Public ACeDB has an annoying way of timing out, leaving dangling database handles. This method will invoke the ACeDB reopen() method, which causes dangling handles to be refreshed. It has no effect if you are not using ACeDB to create ACeDB objects. =cut 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/pg.pm000444000765000024 12264212254227325 20203 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::pg; =head1 NAME Bio::DB::GFF::Adaptor::dbi::pg -- Database adaptor for a specific postgres schema =head1 NOTES SQL commands that need to be executed before this adaptor will work: CREATE DATABASE ; Also, select permission needs to be granted for each table in the database to the owner of the httpd process (usually 'nobody', but for some RedHat systems it is 'apache') if this adaptor is to be used with the Generic Genome Browser (gbrowse): CREATE USER nobody; GRANT SELECT ON TABLE fmeta TO nobody; GRANT SELECT ON TABLE fgroup TO nobody; GRANT SELECT ON TABLE fdata TO nobody; GRANT SELECT ON TABLE fattribute_to_feature TO nobody; GRANT SELECT ON TABLE fdna TO nobody; GRANT SELECT ON TABLE fattribute TO nobody; GRANT SELECT ON TABLE ftype TO nobody; =head2 Optimizing the database PostgreSQL generally requires some tuning before you get very good performance for large databases. For general information on tuning a PostgreSQL server, see http://www.varlena.com/GeneralBits/Tidbits/perf.html Of particular importance is executing VACUUM FULL ANALYZE whenever you change the database. Additionally, for a GFF database, there are a few items you can tune. For each automatic class in your GBrowse conf file, there will be one or two searches done when searching for a feature. If there are lots of features, these search can take several seconds. To speed these searches, do two things: =over =item 1 Set 'enable_seqscan = false' in your postgresql.conf file (and restart your server). =item 2 Create 'partial' indexes for each automatic class, doing this for the example class 'Allele': CREATE INDEX partial_allele_gclass ON fgroup (lower('gname')) WHERE gclass='Allele'; And be sure to run VACUUM FULL ANALYZE after creating the indexes. =back =cut # a simple postgres adaptor use strict; use Bio::DB::GFF::Util::Binning; use Bio::DB::GFF::Util::Rearrange; # for rearrange() use base qw(Bio::DB::GFF::Adaptor::dbi); use constant MAX_SEGMENT => 100_000_000; # the largest a segment can get use constant DEFAULT_CHUNK => 2000; use constant GETSEQCOORDS =><<<< < 100_000_000; # this is the smallest bin (1 K) use constant MIN_BIN => 1000; # size of range over which it is faster to force mysql to use the range for indexing use constant STRAIGHT_JOIN_LIMIT => 200_000; ############################################################################## =head1 DESCRIPTION This adaptor implements a specific postgres database schema that is compatible with Bio::DB::GFF. It inherits from Bio::DB::GFF::Adaptor::dbi, which itself inherits from Bio::DB::GFF. The schema uses several tables: =over 4 =item fdata This is the feature data table. Its columns are: fid feature ID (integer) fref reference sequence name (string) fstart start position relative to reference (integer) fstop stop postion relative to reference (integer) ftypeid feature type ID (integer) fscore feature score (float); may be null fstrand strand; one of "+" or "-"; may be null fphase phase; one of 0, 1 or 2; may be null gid group ID (integer) ftarget_start for similarity features, the target start position (integer) ftarget_stop for similarity features, the target stop position (integer) Note that it would be desirable to normalize the reference sequence name, since there are usually many features that share the same reference feature. However, in the current schema, query performance suffers dramatically when this additional join is added. =item fgroup This is the group table. There is one row for each group. Columns: gid the group ID (integer) gclass the class of the group (string) gname the name of the group (string) The group table serves multiple purposes. As you might expect, it is used to cluster features that logically belong together, such as the multiple exons of the same transcript. It is also used to assign a name and class to a singleton feature. Finally, the group table is used to identify the target of a similarity hit. This is consistent with the way in which the group field is used in the GFF version 2 format. The fgroup.gid field joins with the fdata.gid field. Examples: sql> select * from fgroup where gname='sjj_2L52.1'; +-------+-------------+------------+ | gid | gclass | gname | +-------+-------------+------------+ | 69736 | PCR_product | sjj_2L52.1 | +-------+-------------+------------+ 1 row in set (0.70 sec) sql> select fref,fstart,fstop from fdata,fgroup where gclass='PCR_product' and gname = 'sjj_2L52.1' and fdata.gid=fgroup.gid; +---------------+--------+-------+ | fref | fstart | fstop | +---------------+--------+-------+ | CHROMOSOME_II | 1586 | 2355 | +---------------+--------+-------+ 1 row in set (0.03 sec) =item ftype This table contains the feature types, one per row. Columns are: ftypeid the feature type ID (integer) fmethod the feature type method name (string) fsource the feature type source name (string) The ftype.ftypeid field joins with the fdata.ftypeid field. Example: sql> select fref,fstart,fstop,fmethod,fsource from fdata,fgroup,ftype where gclass='PCR_product' and gname = 'sjj_2L52.1' and fdata.gid=fgroup.gid and fdata.ftypeid=ftype.ftypeid; +---------------+--------+-------+-------------+-----------+ | fref | fstart | fstop | fmethod | fsource | +---------------+--------+-------+-------------+-----------+ | CHROMOSOME_II | 1586 | 2355 | PCR_product | GenePairs | +---------------+--------+-------+-------------+-----------+ 1 row in set (0.08 sec) =item fdna This table holds the raw DNA of the reference sequences. It has three columns: fref reference sequence name (string) foffset offset of this sequence fdna the DNA sequence (longblob) To overcome problems loading large blobs, DNA is automatically fragmented into multiple segments when loading, and the position of each segment is stored in foffset. The fragment size is controlled by the -clump_size argument during initialization. =item fattribute_to_feature This table holds "attributes", which are tag/value pairs stuffed into the GFF line. The first tag/value pair is treated as the group, and anything else is treated as an attribute (weird, huh?). CHR_I assembly_tag Finished 2032 2036 . + . Note "Right: cTel33B" CHR_I assembly_tag Polymorphism 668 668 . + . Note "A->C in cTel33B" The columns of this table are: fid feature ID (integer) fattribute_id ID of the attribute (integer) fattribute_value text of the attribute (text) The fdata.fid column joins with fattribute_to_feature.fid. =item fattribute This table holds the normalized names of the attributes. Fields are: fattribute_id ID of the attribute (integer) fattribute_name Name of the attribute (varchar) =back =head2 Data Loading Methods In addition to implementing the abstract SQL-generating methods of Bio::DB::GFF::Adaptor::dbi, this module also implements the data loading functionality of Bio::DB::GFF. =cut =head2 new Title : new Usage : $db = Bio::DB::GFF->new(@args) Function: create a new adaptor Returns : a Bio::DB::GFF object Args : see below Status : Public The new constructor is identical to the "dbi" adaptor's new() method, except that the prefix "dbi:pg" is added to the database DSN identifier automatically if it is not there already. Argument Description -------- ----------- -dsn the DBI data source, e.g. 'dbi:Pg:dbname=:ens0040' or "ens0040" -user username for authentication -pass the password for authentication =cut #' sub new { my $class = shift; my ($dsn,$other) = rearrange([ [qw(FEATUREDB DB DSN)], ],@_); $dsn = "dbi:Pg:dbname=$dsn" if !ref($dsn) && $dsn !~ /^(dbi|DBI):/; my $self = $class->SUPER::new(-dsn=>$dsn,%$other); $self; } =head2 schema Title : schema Usage : $schema = $db->schema Function: return the CREATE script for the schema Returns : a list of CREATE statemetns Args : none Status : protected This method returns a list containing the various CREATE statements needed to initialize the database tables. =cut sub schema { my %schema = ( fdata =>{ table=> q{ CREATE TABLE "fdata" ( "fid" serial NOT NULL, "fref" character varying(100) DEFAULT '' NOT NULL, "fstart" integer DEFAULT '0' NOT NULL, "fstop" integer DEFAULT '0' NOT NULL, "fbin" double precision DEFAULT '0.000000' NOT NULL, "ftypeid" integer DEFAULT '0' NOT NULL, "fscore" double precision DEFAULT NULL, "fstrand" character varying(3) DEFAULT NULL, "fphase" character varying(3) DEFAULT NULL, "gid" integer DEFAULT '0' NOT NULL, "ftarget_start" integer DEFAULT NULL, "ftarget_stop" integer DEFAULT NULL, CONSTRAINT chk_fdata_fstrand CHECK (fstrand IN ('+','-')), CONSTRAINT chk_fdata_fphase CHECK (fphase IN ('0','1','2')), CONSTRAINT pk_fdata PRIMARY KEY (fid) ) }, # fdata table #CONSTRAINT fref_fdata UNIQUE (fref, fbin, fstart, fstop, ftypeid, gid) # fdata_fref_idx => q{ CREATE UNIQUE INDEX fdata_fref_idx ON fdata (fref,fbin,fstart,fstop,ftypeid,gid)}, index=>{ fdata_fref_idx => q{ CREATE INDEX fdata_fref_idx ON fdata (fref,fbin,fstart,fstop,ftypeid,gid) }, fdata_ftypeid_idx => q{ CREATE INDEX fdata_ftypeid_idx ON fdata (ftypeid) }, fdata_gid_idx => q{ CREATE INDEX fdata_gid_idx ON fdata (gid) } }, # fdata indexes }, # fdata fgroup => { table => q{ CREATE TABLE "fgroup" ( "gid" serial NOT NULL, "gclass" character varying(100) DEFAULT NULL, "gname" character varying(100) DEFAULT NULL, CONSTRAINT pk_fgroup PRIMARY KEY (gid) ) }, # fgroup table index => { fgroup_gclass_idx => q{ CREATE UNIQUE INDEX fgroup_gclass_idx ON fgroup (gclass,gname) }, fgroup_gname_idx => q{ CREATE INDEX fgroup_gname_idx ON fgroup(gname) }, fgroup_lower_gname_idx => q{ CREATE INDEX fgroup_lower_gname_idx ON fgroup (lower(gname)) }, }, # fgroup indexes }, # fgroup ftype => { table => q{ CREATE TABLE "ftype" ( "ftypeid" serial NOT NULL, "fmethod" character varying(100) DEFAULT '' NOT NULL, "fsource" character varying(100) DEFAULT NULL, CONSTRAINT pk_ftype PRIMARY KEY (ftypeid), CONSTRAINT ftype_ftype UNIQUE (fmethod, fsource) ) }, # ftype table index => { ftype_fmethod_idx => q{ CREATE INDEX ftype_fmethod_idx ON ftype (fmethod) }, ftype_fsource_idx => q{ CREATE INDEX ftype_fsource_idx ON ftype (fsource) }, ftype_ftype_idx => q{ CREATE UNIQUE INDEX ftype_ftype_idx ON ftype (fmethod,fsource) } }, # ftype indexes }, # ftype fdna => { table => q{ CREATE TABLE "fdna" ( "fref" character varying(100) DEFAULT '' NOT NULL, "foffset" integer DEFAULT '0' NOT NULL, "fdna" bytea, CONSTRAINT pk_fdna PRIMARY KEY (fref, foffset) ) } #fdna table }, #fdna fmeta => { table => q{ CREATE TABLE "fmeta" ( "fname" character varying(255) DEFAULT '' NOT NULL, "fvalue" character varying(255) DEFAULT '' NOT NULL, CONSTRAINT pk_fmeta PRIMARY KEY (fname) ) } # fmeta table }, # fmeta fattribute => { table => q{ CREATE TABLE "fattribute" ( "fattribute_id" serial NOT NULL, "fattribute_name" character varying(255) DEFAULT '' NOT NULL, CONSTRAINT pk_fattribute PRIMARY KEY (fattribute_id) ) }, # fattribute table }, # fattribute fattribute_to_feature => { table => q{ CREATE TABLE "fattribute_to_feature" ( "fid" integer DEFAULT '0' NOT NULL, "fattribute_id" integer DEFAULT '0' NOT NULL, "fattribute_value" text ) }, # fattribute_to_feature table index => { fattribute_to_feature_fid => q{ CREATE INDEX fattribute_to_feature_fid ON fattribute_to_feature (fid,fattribute_id) }, fattribute_txt_idx => q{ CREATE INDEX fattribute_txt_idx ON fattribute_to_feature (fattribute_value) }, fattribute_lower_idx => q{ CREATE INDEX fattribute_lower_idx ON fattribute_to_feature (lower(fattribute_value)) }, } # fattribute_to_feature indexes }, # fattribute_to_feature finterval_stats => { table=> q{ CREATE TABLE "finterval_stats" ( "ftypeid" integer DEFAULT '0' NOT NULL, "fref" character varying(100) DEFAULT '' NOT NULL, "fbin" integer DEFAULT '0' NOT NULL, "fcum_count" integer DEFAULT '0' NOT NULL, CONSTRAINT pk_finterval_stats PRIMARY KEY (ftypeid,fref,fbin) ) } # finterval_stats table },# finterval_stats ); return \%schema; } =head2 setup_load Title : setup_load Usage : $db->setup_load Function: called before load_gff_line() Returns : void Args : none Status : protected This method performs schema-specific initialization prior to loading a set of GFF records. It prepares a set of DBI statement handlers to be used in loading the data. =cut sub setup_load { my $self = shift; my $schema = $self->schema; my $dbh = $self->features_db; if ($self->lock_on_load) { my @tables = map { "$_ WRITE"} $self->tables; my $tables = join ', ',@tables; $dbh->do("LOCK TABLES $tables"); } my $lookup_type = $dbh->prepare_delayed('SELECT ftypeid FROM ftype WHERE fmethod=? AND fsource=?'); my $insert_type = $dbh->prepare_delayed('INSERT INTO ftype (fmethod,fsource) VALUES (?,?)'); my $insertid_type = $dbh->prepare_delayed("SELECT currval('ftype_ftypeid_seq')"); my $lookup_group = $dbh->prepare_delayed('SELECT gid FROM fgroup WHERE lower(gname)=lower(?) AND gclass=?'); my $insert_group = $dbh->prepare_delayed('INSERT INTO fgroup (gname,gclass) VALUES (?,?)'); my $insertid_group = $dbh->prepare_delayed("SELECT currval('fgroup_gid_seq')"); my $lookup_attribute = $dbh->prepare_delayed('SELECT fattribute_id FROM fattribute WHERE fattribute_name=?'); my $insert_attribute = $dbh->prepare_delayed('INSERT INTO fattribute (fattribute_name) VALUES (?)'); my $insertid_attribute = $dbh->prepare_delayed("SELECT currval('fattribute_fattribute_id_seq')"); my $insert_attribute_value = $dbh->prepare_delayed('INSERT INTO fattribute_to_feature (fid,fattribute_id,fattribute_value) VALUES (?,?,?)'); my $insert_data = $dbh->prepare_delayed(<prepare_delayed('DELETE FROM fdata WHERE fref=? AND fstart=? AND fstop=? AND fbin=? AND ftypeid=? AND GID=?'); my $insertid_data = $dbh->prepare_delayed("SELECT currval('fdata_fid_seq')"); $self->{load_stuff}{sth}{lookup_ftype} = $lookup_type; $self->{load_stuff}{sth}{insert_ftype} = $insert_type; $self->{load_stuff}{sth}{insertid_ftype} = $insertid_type; $self->{load_stuff}{sth}{lookup_fgroup} = $lookup_group; $self->{load_stuff}{sth}{insert_fgroup} = $insert_group; $self->{load_stuff}{sth}{insertid_fgroup} = $insertid_group; $self->{load_stuff}{sth}{insertid_fdata} = $insertid_data; $self->{load_stuff}{sth}{insert_fdata} = $insert_data; $self->{load_stuff}{sth}{delete_existing_fdata} = $delete_existing_data; $self->{load_stuff}{sth}{lookup_fattribute} = $lookup_attribute; $self->{load_stuff}{sth}{insert_fattribute} = $insert_attribute; $self->{load_stuff}{sth}{insertid_fattribute} = $insertid_attribute; $self->{load_stuff}{sth}{insert_fattribute_value} = $insert_attribute_value; $self->{load_stuff}{types} = {}; $self->{load_stuff}{groups} = {}; $self->{load_stuff}{counter} = 0; } =head2 load_gff_line Title : load_gff_line Usage : $db->load_gff_line($fields) Function: called to load one parsed line of GFF Returns : true if successfully inserted Args : hashref containing GFF fields Status : protected This method is called once per line of the GFF and passed a series of parsed data items that are stored into the hashref $fields. The keys are: ref reference sequence source annotation source method annotation method start annotation start stop annotation stop score annotation score (may be undef) strand annotation strand (may be undef) phase annotation phase (may be undef) group_class class of annotation's group (may be undef) group_name ID of annotation's group (may be undef) target_start start of target of a similarity hit target_stop stop of target of a similarity hit attributes array reference of attributes, each of which is a [tag=>value] array ref =cut sub load_gff_line { my $self = shift; my $gff = shift; if (defined $gff->{phase}){ chomp($gff->{phase}); undef($gff->{phase}) if $gff->{phase} eq '.'; } if (defined $gff->{strand} && $gff->{strand} eq '.'){undef($gff->{strand})}; if (defined $gff->{score} && $gff->{score} eq '.'){undef($gff->{score})}; my $s = $self->{load_stuff}; my $dbh = $self->features_db; local $dbh->{PrintError} = 0; defined(my $typeid = $self->get_table_id('ftype', $gff->{method} => $gff->{source})) or return; defined(my $groupid = $self->get_table_id('fgroup',$gff->{gname} => $gff->{gclass})) or return; my $bin = bin($gff->{start},$gff->{stop},$self->min_bin); my $result = $s->{sth}{insert_fdata}->execute($gff->{ref}, $gff->{start},$gff->{stop},$bin, $typeid, $gff->{score},$gff->{strand},$gff->{phase}, $groupid, $gff->{tstart},$gff->{tstop}); warn $dbh->errstr,"\n" and print "ref=",$gff->{ref}," start=",$gff->{start}," stop=",$gff->{stop}," bin=",$bin," typeid=",$typeid," groupid=",$groupid,"\n" and return unless $result; my $fid = $self->insertid($s->{sth},'fdata') || $self->get_feature_id($gff->{ref},$gff->{start},$gff->{stop},$typeid,$groupid); # insert attributes foreach (@{$gff->{attributes}}) { defined(my $attribute_id = $self->get_table_id('fattribute',$_->[0])) or return; $s->{sth}{insert_fattribute_value}->execute($fid,$attribute_id,$_->[1]); } if ( (++$s->{counter} % 1000) == 0) { print STDERR "$s->{counter} records loaded..."; print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; } $fid; } sub insertid { my $self = shift; my $sth = shift ; my $table = shift; my $insert_id; if ($sth->{"insertid_$table"}->execute()){ $insert_id = ($sth->{"insertid_$table"}->fetchrow_array)[0]; } else{ warn "No CURRVAL for SEQUENCE of table $table ",$sth->errstr,"\n"; return; } return $insert_id; } =head2 get_table_id Title : get_table_id Usage : $integer = $db->get_table_id($table,@ids) Function: get the ID of a group or type Returns : an integer ID or undef Args : none Status : private This internal method is called by load_gff_line to look up the integer ID of an existing feature type or group. The arguments are the name of the table, and two string identifiers. For feature types, the identifiers are the method and source. For groups, the identifiers are group name and class. This method requires that a statement handler named I, have been created previously by setup_load(). It is here to overcome deficiencies in mysql's INSERT syntax. =cut #' # get the object ID from a named table sub get_table_id { my $self = shift; my $table = shift; my @ids = @_; # irritating warning for null id my $id_key; { local $^W=0; $id_key = join ':',@ids; } my $s = $self->{load_stuff}; my $sth = $s->{sth}; my $dbh = $self->features_db; unless (defined($s->{$table}{$id_key})) { $sth->{"lookup_$table"}->execute(@ids); my @result = $sth->{"lookup_$table"}->fetchrow_array; if (@result > 0) { $s->{$table}{$id_key} = $result[0]; } else { $sth->{"insert_$table"}->execute(@ids) && ($s->{$table}{$id_key} = $self->insertid($sth,$table)); #&& ($s->{$table}{$id_key} = $self->insertid($sth->{"insertid_$table"})); #&& ($s->{$table}{$id_key} = $sth->{"insert_$table"}->insertid); } } my $id = $s->{$table}{$id_key}; unless (defined $id) { warn "No $table id for $id_key ",$dbh->errstr," Record skipped.\n"; return; } $id; } #sub insertid { # my $self = shift; # my $insertid_sth = shift ; # my $insert_id; # if ($insertid_sth->execute){ # $insert_id = ($insertid_sth->fetchrow_array)[0]; # } # else{ # warn "No CURRVAL for SEQUENCE ",$insertid_sth->errstr,"\n"; # return; # } # return $insert_id; #} sub insert_sequence { my $self = shift; my($id,$offset,$seq) = @_; my $sth = $self->{_insert_sequence} ||= $self->dbh->prepare_delayed('insert into fdna values (?,?,?)'); $sth->execute($id,$offset,$seq) or $self->throw($sth->errstr); } =head2 range_query Title : range_query Usage : $db->range_query($range_type,$refseq,$refclass,$start,$stop,$types,$order_by_group,$attributes,$binsize) Function: create statement handle for range/overlap queries Returns : a DBI statement handle Args : see below Status : Protected This method constructs the statement handle for this module's central query: given a range and/or a list of feature types, fetch their GFF records. It overrides a method in dbi.pm so that the overlaps query can write SQL optimized for Postgres. Specifically, instead of writing the bin related section as a set of ORs, each bin piece is place in a separate select and then they are UNIONed together. This subroutine requires several replacements for other subroutines in dbi.pm. In this module, they are named the same as those in dbi.pm but prefixed with "pg_". The positional arguments are as follows: Argument Description $isrange A flag indicating that this is a range. query. Otherwise an overlap query is assumed. $refseq The reference sequence name (undef if no range). $refclass The reference sequence class (undef if no range). $start The start of the range (undef if none). $stop The stop of the range (undef if none). $types Array ref containing zero or feature types in the format [method,source]. $order_by_group A flag indicating that statement handler should group the features by group id (handy for iterative fetches) $attributes A hash containing select attributes. $binsize A bin size for generating tables of feature density. =cut sub range_query { my $self = shift; my($rangetype,$refseq,$class,$start,$stop,$types,$sparse,$order_by_group,$attributes,$bin) = @_; my $dbh = $self->features_db; # my @bin_parts = split /\n\s+OR/, $self->bin_query($start,$stop); # warn "bin_part: @bin_parts\n"; my %a = (refseq=>$refseq,class=>$class,start=>$start,stop=>$stop,types=>$types,attributes=>$attributes,bin_width=>$bin); my ($query, @args, $order_by); if ($rangetype ne 'overlaps') { my $select = $self->make_features_select_part(\%a); my $from = $self->make_features_from_part($sparse,\%a); my $join = $self->make_features_join_part(\%a); my $where; ($where,@args) = $self->make_features_by_range_where_part($rangetype,\%a); my ($group_by,@more_args) = $self->make_features_group_by_part(\%a); $order_by = $self->make_features_order_by_part(\%a) if $order_by_group; $query = "SELECT $select FROM $from WHERE $join"; $query .= " AND $where" if $where; if ($group_by) { $query .= " GROUP BY $group_by"; push @args,@more_args; } } else { # most common case: overlaps query my @bin_parts = split /\s*OR/, $self->bin_query($start,$stop); my $select = $self->make_features_select_part(\%a); my $from = $self->make_features_from_part($sparse,\%a); my $join = $self->make_features_join_part(\%a); my $where; ($where,@args) = $self->pg_make_features_by_range_where_part($rangetype,\%a); my ($group_by,@more_args)= $self->make_features_group_by_part(\%a); $order_by = $self->pg_make_features_order_by_part(\%a) if $order_by_group; my @temp_args; my @query_pieces; foreach my $bin (@bin_parts) { my $temp_query = "SELECT $select FROM $from WHERE $join AND $where AND $bin\n"; push @temp_args, @args; if ($group_by) { $temp_query .= " GROUP BY $group_by"; push @temp_args,@more_args; } push @query_pieces, $temp_query; } @args = @temp_args; $query = join("UNION\n", @query_pieces); } $query .= " ORDER BY $order_by" if $order_by; $self->dbh->do('set enable_seqscan=off'); my $sth = $self->dbh->do_query($query,@args); $sth; } sub pg_make_features_by_range_where_part { my $self = shift; my ($rangetype,$options) = @_; return unless $rangetype eq 'overlaps'; $options ||= {}; my ($refseq,$class,$start,$stop,$types,$attributes) = @{$options}{qw(refseq class start stop types attributes)}; my (@query,@args); if ($refseq) { my ($q,@a) = $self->refseq_query($refseq,$class); push @query,$q; push @args,@a; } if (defined $start or defined $stop) { $start = 0 unless defined($start); $stop = MAX_SEGMENT unless defined($stop); my ($range_query,@range_args) = $self->pg_overlap_query($start,$stop); push @query,$range_query; push @args,@range_args; } if (defined $types && @$types) { my ($type_query,@type_args) = $self->types_query($types); push @query,$type_query; push @args,@type_args; } if ($attributes) { my ($attribute_query,@attribute_args) = $self->make_features_by_attribute_where_part($attributes); push @query,"($attribute_query)"; push @args,@attribute_args; } my $query = join "AND",@query; return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } sub pg_overlap_query { my $self = shift; my ($start,$stop) = @_; my ($iq,@iargs) = $self->overlap_query_nobin($start,$stop); my $query = "\n$iq\n"; my @args = @iargs; return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } sub pg_make_features_order_by_part { my $self = shift; my $options = shift || {}; return "gname"; } =head2 search_notes This PostgreSQL adaptor does not implement the search notes method because it can be very slow (although the code for the method is contained in this method but commented out). There is, however, a PostgreSQL adaptor that does implement it in a more efficient way: L, which inherits from this adaptor and uses the optional PostgreSQL module TSearch2 for full text indexing. See that adaptor's documentation for more information. See also L Title : search_notes Usage : @search_results = $db->search_notes("full text search string",$limit) Function: Search the notes for a text string, using mysql full-text search Returns : array of results Args : full text search string, and an optional row limit Status : public This is a replacement for the mysql-specific method. Given a search string, it performs a ILIKE search of the notes table and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 A Bio::DB::GFF::Featname object, suitable for passing to segment() column 2 The text of the note column 3 A relevance score. Note that for large databases this can be very slow and may result in time out or 500-cgi errors. If this is happening on a regular basis, you should look into using L which implements the TSearch2 full text indexing scheme. =cut sub search_notes{ # my $self = shift; # my ($search_string,$limit) = @_; # # $search_string =~ tr/*/%/s; # $search_string = '%'.$search_string unless $search_string =~ /^\%/; # $search_string = $search_string.'%' unless $search_string =~ /\%$/; # warn "search_string:$search_string"; # my $query = FULLTEXTWILDCARD; # $query .= " limit $limit" if defined $limit; # my $sth = $self->dbh->do_query($query,$search_string); # # my @results; # while (my ($class,$name,$note) = $sth->fetchrow_array) { # # next unless $class && $name; # sorry, ignore NULL objects # my $featname = Bio::DB::GFF::Featname->new($class=>$name); # # push @results,[$featname,$note,0]; #gbrowse expects a score, but # #pg doesn't give one, thus the 0 # } # warn @results; # # return @results; } =head2 make_meta_set_query Title : make_meta_set_query Usage : $sql = $db->make_meta_set_query Function: return SQL fragment for setting a meta parameter Returns : SQL fragment Args : none Status : public By default this does nothing; meta parameters are not stored or retrieved. =cut sub make_meta_set_query { return 'INSERT INTO fmeta VALUES (?,?)'; } sub make_classes_query { my $self = shift; return 'SELECT DISTINCT gclass FROM fgroup WHERE NOT gclass IS NULL'; } sub chunk_size { my $self = shift; $self->meta('chunk_size') || DEFAULT_CHUNK; } sub getseqcoords_query { my $self = shift; return GETSEQCOORDS ; } sub getaliascoords_query{ my $self = shift; return GETALIASCOORDS ; } sub getforcedseqcoords_query{ my $self = shift; return GETFORCEDSEQCOORDS ; } sub getaliaslike_query{ my $self = shift; return GETALIASLIKE ; } sub make_features_select_part { my $self = shift; my $options = shift || {}; my $s; if (my $b = $options->{bin_width}) { $s = <{attributes} && keys %{$options->{attributes}}>1; $s; } sub make_features_from_part_bkup { my $self = shift; my $sparse = shift; my $options = shift || {}; #my $index = $sparse ? ' USE INDEX(ftypeid)': ''; my $index = ''; return $options->{attributes} ? "fdata${index},ftype,fgroup,fattribute,fattribute_to_feature\n" : "fdata${index},ftype,fgroup\n"; } #################################### # moved from mysqlopt.pm ################################### # meta values sub default_meta_values { my $self = shift; my @values = $self->SUPER::default_meta_values; return ( @values, max_bin => MAX_BIN, min_bin => MIN_BIN, straight_join_limit => STRAIGHT_JOIN_LIMIT, ); } sub min_bin { my $self = shift; return $self->meta('min_bin') || MIN_BIN; } sub max_bin { my $self = shift; return $self->meta('max_bin') || MAX_BIN; } sub straight_join_limit { my $self = shift; return $self->meta('straight_join_limit') || STRAIGHT_JOIN_LIMIT; } sub _feature_by_name { my $self = shift; my ($class,$name,$location,$callback) = @_; $callback || $self->throw('must provide a callback argument'); my @bin_parts = split /\s*OR/, $self->bin_query($location->[1],$location->[2]) if $location; my $select = $self->make_features_select_part; my $from = $self->make_features_from_part(undef,{sparse_groups=>1}); my ($where,@args) = $self->make_features_by_name_where_part($class,$name); my $join = $self->make_features_join_part; my $range = $self->pg_make_features_by_range_where_part('overlaps', {refseq=>$location->[0], class =>'', start=>$location->[1], stop =>$location->[2]}) if $location; my @temp_args; my @query_pieces; my $query; if (@bin_parts) { foreach my $bin (@bin_parts) { my $temp_query = "SELECT $select FROM $from WHERE $join AND $where AND $range AND $bin\n"; push @temp_args, @args; push @query_pieces, $temp_query; } @args = @temp_args; $query = join("UNION\n", @query_pieces); } else { $query = "SELECT $select FROM $from WHERE $where AND $join"; } my $sth = $self->dbh->do_query($query,@args); my $count = 0; while (my @row = $sth->fetchrow_array) { $callback->(@row); $count++; } $sth->finish; return $count; } sub update_sequences { my $self = shift; my $dbh = $self->features_db; $dbh->do("SELECT setval('public.fdata_fid_seq', max(fid)+1) FROM fdata"); $dbh->do("SELECT setval('public.fattribute_fattribute_id_seq', max(fattribute_id)+1) FROM fattribute"); $dbh->do("SELECT setval('public.fgroup_gid_seq', max(gid)+1) FROM fgroup"); $dbh->do("SELECT setval('public.ftype_ftypeid_seq', max(ftypeid)+1) FROM ftype"); 1; } =head2 make_features_by_name_where_part Title : make_features_by_name_where_part Usage : $db->make_features_by_name_where_part Function: Overrides a function in Bio::DB::GFF::Adaptor::dbi to insure that searches will be case insensitive. It creates the SQL fragment needed to select a feature by its group name & class Returns : a SQL fragment and bind arguments Args : see below Status : Protected =cut sub make_features_by_name_where_part { my $self = shift; my ($class,$name) = @_; if ($name !~ /\*/) { #allows utilization of an index on lower(gname) return ("fgroup.gclass=? AND lower(fgroup.gname) = lower(?)",$class,$name); } else { $name =~ tr/*/%/; return ("fgroup.gclass=? AND lower(fgroup.gname) LIKE lower(?)",$class,$name); } } # # Methods from dbi.pm that need to be overridden to make # searching for fref case insensitive # # sub get_dna { my $self = shift; my ($ref,$start,$stop,$class) = @_; my ($offset_start,$offset_stop); my $has_start = defined $start; my $has_stop = defined $stop; my $reversed; if ($has_start && $has_stop && $start > $stop) { $reversed++; ($start,$stop) = ($stop,$start); } # turn start and stop into 0-based offsets my $cs = $self->dna_chunk_size; $start -= 1; $stop -= 1; $offset_start = int($start/$cs)*$cs; $offset_stop = int($stop/$cs)*$cs; my $sth; # special case, get it all if (!($has_start || $has_stop)) { $sth = $self->dbh->do_query('select fdna,foffset from fdna where lower(fref)=lower(?) order by foffset',$ref); } elsif (!$has_stop) { $sth = $self->dbh->do_query('select fdna,foffset from fdna where lower(fref)=lower(?) and foffset>=? order by foffset', $ref,$offset_start); } else { # both start and stop defined $sth = $self->dbh->do_query('select fdna,foffset from fdna where lower(fref)=lower(?) and foffset>=? and foffset<=? order by foffset', $ref,$offset_start,$offset_stop); } my $dna = ''; while (my($frag,$offset) = $sth->fetchrow_array) { substr($frag,0,$start-$offset) = '' if $has_start && $start > $offset; $dna .= $frag; } substr($dna,$stop-$start+1) = '' if $has_stop && $stop-$start+1 < length($dna); if ($reversed) { $dna = reverse $dna; $dna =~ tr/gatcGATC/ctagCTAG/; } $sth->finish; $dna; } sub refseq_query { my $self = shift; my ($refseq,$refclass) = @_; my $query = "lower(fdata.fref)=lower(?)"; return wantarray ? ($query,$refseq) : $self->dbh->dbi_quote($query,$refseq); } sub make_types_where_part { my $self = shift; my ($srcseq,$start,$stop,$want_count,$typelist) = @_; my (@query,@args); if (defined($srcseq)) { push @query,'lower(fdata.fref)=lower(?)'; push @args,$srcseq; if (defined $start or defined $stop) { $start = 1 unless defined $start; $stop = MAX_SEGMENT unless defined $stop; my ($q,@a) = $self->overlap_query($start,$stop); push @query,"($q)"; push @args,@a; } } if (defined $typelist && @$typelist) { my ($q,@a) = $self->types_query($typelist); push @query,($q); push @args,@a; } my $query = @query ? join(' AND ',@query) : '1=1'; return wantarray ? ($query,@args) : $self->dbh->dbi_quote($query,@args); } sub get_feature_id { my $self = shift; my ($ref,$start,$stop,$typeid,$groupid) = @_; my $s = $self->{load_stuff}; unless ($s->{get_feature_id}) { my $dbh = $self->features_db; $s->{get_feature_id} = $dbh->prepare_delayed('SELECT fid FROM fdata WHERE lower(fref)=lower(?) AND fstart=? AND fstop=? AND ftypeid=? AND gid=?'); } my $sth = $s->{get_feature_id} or return; $sth->execute($ref,$start,$stop,$typeid,$groupid) or return; my ($fid) = $sth->fetchrow_array; return $fid; } sub _delete { my $self = shift; my $delete_spec = shift; my $ranges = $delete_spec->{segments} || []; my $types = $delete_spec->{types} || []; my $force = $delete_spec->{force}; my $range_type = $delete_spec->{range_type}; my $dbh = $self->features_db; my $query = 'delete from fdata'; my @where; my @range_part; for my $segment (@$ranges) { my $ref = $dbh->quote($segment->abs_ref); my $start = $segment->abs_start; my $stop = $segment->abs_stop; my $range = $range_type eq 'overlaps' ? $self->overlap_query($start,$stop) : $range_type eq 'contains' ? $self->contains_query($start,$stop) : $range_type eq 'contained_in' ? $self->contained_in_query($start,$stop) : $self->throw("Invalid range type '$range_type'"); push @range_part,"(lower(fref)=lower($ref) AND $range)"; } push @where,'('. join(' OR ',@range_part).')' if @range_part; # get all the types if (@$types) { my $types_where = $self->types_query($types); my $types_query = "select ftypeid from ftype where $types_where"; my $result = $dbh->selectall_arrayref($types_query); my @typeids = map {$_->[0]} @$result; my $typelist = join ',',map{$dbh->quote($_)} @typeids; $typelist ||= "0"; # don't cause DBI to die with invalid SQL when # unknown feature types were requested. push @where,"(ftypeid in ($typelist))"; } $self->throw("This operation would delete all feature data and -force not specified") unless @where || $force; $query .= " where ".join(' and ',@where) if @where; warn "$query\n" if $self->debug; my $result = $dbh->do($query); defined $result or $self->throw($dbh->errstr); $result; } sub make_abscoord_query { my $self = shift; my ($name,$class,$refseq) = @_; #my $query = GETSEQCOORDS; my $query = $self->getseqcoords_query(); my $getforcedseqcoords = $self->getforcedseqcoords_query() ; if ($name =~ /\*/) { $name =~ s/%/\\%/g; $name =~ s/_/\\_/g; $name =~ tr/*/%/; $query =~ s/gname\) = lower/gname) LIKE lower/; } defined $refseq ? $self->dbh->do_query($getforcedseqcoords,$name,$class,$refseq) : $self->dbh->do_query($query,$name,$class); } sub make_aliasabscoord_query { my $self = shift; my ($name,$class) = @_; #my $query = GETALIASCOORDS; my $query = $self->getaliascoords_query(); if ($name =~ /\*/) { $name =~ s/%/\\%/g; $name =~ s/_/\\_/g; $name =~ tr/*/%/; $query =~ s/gname\) = lower/gname) LIKE lower/; } $self->dbh->do_query($query,$name,$class); } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/dbi/pg_fts.pm000444000765000024 2417412254227317 21041 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::dbi::pg_fts; =head1 NAME Bio::DB::GFF::Adaptor::dbi::pg_fts -- Database adaptor for a specific postgres schema with a TSearch2 implementation =head1 SYNOPSIS #create new GFF database connection my $db = Bio::DB::GFF->new( -adaptor => 'dbi::pg_fts', -dsn => 'dbi:Pg:dbname=worm'); #add full text indexing 'stuff' #assumes that TSearch2 is available to PostgreSQL #this will take a VERY long time for a reasonably large database $db->install_TSearch2(); ...some time later... #we don't like full text searching... $db->remove_TSearch2(); =head1 DESCRIPTION This adaptor is based on Bio::DB::GFF::Adaptor::dbi::pg but it implements the TSearch2 PostgreSQL contrib module for fast full text searching. To use this module with your PostgreSQL GFF database, you need to make TSearch2 available in the database. To use this adaptor, follow these steps: =over =item Install TSearch2 contrib module for Pg Can be as easy as `sudo yum install postgresql-contrib`, or you may need to recompile PostgreSQL to include it. See L for more details =item Load the TSearch2 functions to you database % cat tsearch2.sql | psql =item Load your data using the pg adaptor: % bp_pg_bulk_load_gff.pl -c -d yeast saccharomyces_cerevisiae.gff or % bp_load_gff.pl -c -d yeast -a dbi::pg saccharomyces_cerevisiae.gff =item Add GFF/TSearch2 specific modifications Execute a perl script like this one: #!/usr/bin/perl -w use strict; use Bio::DB::GFF; my $db = Bio::DB::GFF->new( -adaptor => 'dbi::pg_fts', -dsn => 'dbi:Pg:dbname=yeast', -user => 'scott', ); print "Installing TSearch2 columns...\n"; $db->install_TSearch2(); print "Done\n"; =back Note that this last step will take a long time. For a S. cerevisiae database with 15K rows, it took over an hour on my laptop, and with a C. elegans database (~10 million rows) it took well over a day. If at some point you add more data you your database, you need to run a similar script to the one above, only executing the update_TSearch2() method. Finally, if you want to remove the TSearch2 columns from your database and go back to using the pg adaptor, you can execute a script like the one above, only executing the remove_TSearch2() method. =head1 NOTES ABOUT TSearch2 SEARCHING You should know a few things about how searching with TSearch2 works in the GBrowse environment: =over =item 1 TSearch2 does not do wild cards, so you should encourage your users not to use them. If wild cards are used, the adaptor will fall back on an ILIKE search, which will be much slower. =item 2 However, TSearch2 does do 'word stemming'. That is, if you search for 'copy', it will find 'copy', 'copies', and 'copied'. =item 3 TSearch2 does not do phrase searching; all of the terms in the search string are ANDed together. =back =head1 ACKNOWLEDGEMENTS Special thanks to Russell Smithies and Paul Smale at AgResearch in New Zealand for giving me their recipe for doing full text indexing in a GFF database. =head1 BUGS Please report bugs to the BioPerl and/or GBrowse mailing lists (L and L respectively). =head1 SEE ALSO Please see L for more information about tuning your PostgreSQL server for GFF data, and for general information about GFF database access, see L. =head1 AUTHOR Scott Cain, cain@cshl.edu =head1 APPENDIX =cut # a simple postgres adaptor use strict; use Bio::DB::GFF::Adaptor::dbi; use base qw(Bio::DB::GFF::Adaptor::dbi::pg); use constant FULLTEXTSEARCH => < <SUPER::new(@_); return $self; } =head2 search_notes Title : search_notes Usage : @search_results = $db->search_notes("full text string",$limit) Function: Search the notes for a text string, using PostgreSQL TSearch2 Returns : array of results Args : full text search string, and an optional row limit Status : public This is based on the mysql-specific method that makes use of the TSearch2 functionality in PosgreSQL's contrib directory. Given a search string, it performs a full-text search of the notes table and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 A Bio::DB::GFF::Featname object, for passing to segment() column 2 The text of the note column 3 A relevance score. =cut sub search_notes { my $self = shift; my ($search_string,$limit) = @_; my @terms = split /\s+/, $search_string; my $sth; if ($search_string =~ /\*/) { $search_string =~ tr/*/%/s; my $query = FULLTEXTWILDCARD; $query .= " limit $limit" if defined $limit; $sth = $self->dbh->do_query($query,$search_string); } elsif (@terms == 1) { my $query = FULLTEXTSEARCH; $query .= " limit $limit" if defined $limit; $sth = $self->dbh->do_query($query,$search_string); } else { my $query = FULLTEXTSEARCH; my $andstring = join (' & ', @terms); # $query .= qq{ AND (fattribute_to_feature.fattribute_value ILIKE '\%$search_string%')}; $query .= " LIMIT $limit" if defined $limit; $sth = $self->dbh->do_query($query,$andstring); } my @results; while (my ($class,$name,$note,$method,$source) = $sth->fetchrow_array) { next unless $class && $name; # sorry, ignore NULL objects my $featname = Bio::DB::GFF::Featname->new($class=>$name); my $type = Bio::DB::GFF::Typename->new($method,$source); push @results,[$featname,$note,0,$type]; #gbrowse expects a score, but #pg doesn't give one, thus the 0 } return @results; } =head2 make_features_by_name_where_part Title : make_features_by_name_where_part Function: constructs a TSearch2-compliant WHERE clause for a name search Status : protected =cut #need a make_features_by_name_where_part method to override pg sub make_features_by_name_where_part { my $self = shift; my ($class,$name) = @_; my @terms = split /\s+/, $name; if ($name =~ /\*/) { $name =~ tr/*/%/s; return ("fgroup.gclass=? AND lower(fgroup.gname) LIKE lower(?)",$class,$name); } else { my $where_str = "fgroup.gclass=? AND (fgroup.idxfti @@ to_tsquery('default', ?)) "; if (@terms == 1) { return ($where_str,$class,$name); } else { my $andstring = join (' & ', @terms); # $where_str .= qq{ AND (fgroup.gname ILIKE '\%$name%')}; return ($where_str,$class,$andstring); } } } =head2 install_TSearch2 Title : install_TSearch2 Function: installs schema modifications for use with TSearch2 Usage : $db->install_TSearch2 Status : public =cut #needs method for installing TSearch2 (does that mean that the SQL for #creating the tables and functions should go in here? That would be #the safest and easiest thing to do sub install_TSearch2 { my $self = shift; my $dbh = $self->features_db; $dbh->do('ALTER TABLE fattribute_to_feature ADD COLUMN idxFTI tsvector') or $self->throw('adding FTI column to f_to_f failed'); $dbh->do('ALTER TABLE fgroup ADD COLUMN idxFTI tsvector') or $self->throw('adding FTI column to fgroup failed'); $self->update_TSearch2(); return; } =head2 update_TSearch2 Title : update_TSearch2 Function: Updates TSearch2 columns Usage : $db->update_TSearch2 Status : public =cut sub update_TSearch2 { my $self = shift; my $dbh = $self->features_db; $self->warn('updating full text column; this may take a very long time...'); $dbh->do("UPDATE fattribute_to_feature " ."SET idxFTI= to_tsvector('default', fattribute_value) " ."WHERE idxFTI IS NULL") or $self->throw('updating fti column failed'); $dbh->do("UPDATE fgroup " ."SET idxFTI= to_tsvector('default', gname) " ."WHERE idxFTI IS NULL") or $self->throw('updating fgroup fti column failed'); $self->warn('Preliminary optimization of database; this may also take a long time...'); $dbh->do('VACUUM FULL ANALYZE') or $self->throw('vacuum failed'); $self->warn('Updating full text index; again, this may take a long time'); $dbh->do('CREATE INDEX idxFTI_idx ON fattribute_to_feature ' .'USING gist(idxFTI)') or $self->warn('creating full text index failed'); $dbh->do('CREATE INDEX fgroup_idxFTI_idx ON fgroup ' .'USING gist(idxFTI)') or $self->warn('creating fgroup full text index failed'); $self->warn('Optimizing database; hopefully, this will not take as long as other steps'); $dbh->do('VACUUM FULL ANALYZE'); $dbh->do("SELECT set_curcfg('default')"); return; } =head2 remove_TSearch2 Title : remove_TSearch2 Function: Removes TSearch2 columns Usage : $db->remove_TSearch2 Status : public =cut sub remove_TSearch2 { my $self = shift; my $dbh = $self->features_db; $self->warn('Removing full text search capabilities'); $dbh->do('DROP INDEX idxFTI_idx') or $self->throw('dropping full text index failed'); $dbh->do('DROP INDEX fgroup_idxFTI_idx') or $self->throw('dropping full text index failed'); $dbh->do('ALTER TABLE fattribute_to_feature DROP COLUMN idxFTI') or $self->throw('dropping full text column failed'); $dbh->do('ALTER TABLE fgroup DROP COLUMN idxFTI') or $self->throw('dropping full text column failed'); return; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/memory000755000765000024 012254227335 17606 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Adaptor/memory/feature_serializer.pm000444000765000024 170012254227335 24163 0ustar00cjfieldsstaff000000000000package Bio::DB::GFF::Adaptor::memory::feature_serializer; =head1 NAME Bio::DB::GFF::Adaptor::memory::feature_serializer - utility methods for serializing and deserializing GFF features =cut use strict; require Exporter; use vars qw(@EXPORT @EXPORT_OK @hash2array_map); use base qw(Exporter); @EXPORT_OK = qw(feature2string string2feature @hash2array_map); @EXPORT = @EXPORT_OK; @hash2array_map = qw(ref start stop source method score strand phase gclass gname tstart tstop feature_id group_id bin); sub feature2string { my $feature = shift; local $^W = 0; my @a = @{$feature}{@hash2array_map}; push @a,map {join "\0",@$_} @{$feature->{attributes}} if $feature->{attributes}; return join $;,@a; } sub string2feature { my $string = shift; my (@attributes,%feature); (@feature{@hash2array_map},@attributes) = split $;,$string; $feature{attributes} = [map {[split "\0",$_]} @attributes]; undef $feature{group_id}; \%feature; } 1; BioPerl-1.6.923/Bio/DB/GFF/Adaptor/memory/iterator.pm000444000765000024 324512254227321 22131 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Adaptor::memory::iterator - iterator for Bio::DB::GFF::Adaptor::memory =head1 SYNOPSIS For internal use only =head1 DESCRIPTION This is an internal module that is used by the Bio::DB::GFF in-memory adaptor to return an iterator across a sequence feature query. The object has a single method, next_feature(), that returns the next feature from the query. The method next_seq() is an alias for next_feature(). =head1 BUGS None known yet. =head1 SEE ALSO L, =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut package Bio::DB::GFF::Adaptor::memory::iterator; use strict; # this module needs to be cleaned up and documented use Bio::Root::Version; *next_seq = \&next_feature; sub new { my $class = shift; my ($data,$callback) = @_; my $pos = 0; return bless {data => $data, pos => $pos, callback => $callback, cache => []},$class; #return bless [$sth,$callback,[]],$class; } sub next_feature { my $self = shift; return shift @{$self->{cache}} if @{$self->{cache}}; my $data = $self->{data} or return; my $callback = $self->{callback}; my $features; while (1) { my $feature = $data->[$self->{pos}++]; if ($feature) { $features = $callback->(@{$feature}); last if $features; } else { $features = $callback->(); undef $self->{pos}; undef $self->{data}; undef $self->{cache}; last; } } $self->{cache} = $features or return; shift @{$self->{cache}}; } 1; BioPerl-1.6.923/Bio/DB/GFF/Aggregator000755000765000024 012254227334 16765 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Aggregator/alignment.pm000444000765000024 704512254227322 21441 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::alignment -- Alignment aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['alignment'], ); ----------------------------- Aggregator method: alignment Main method: (none) Sub methods: nucleotide_match,EST_match,cDNA_match,expressed_sequence_match, translated_nucleotide_match,protein_match,HSP ----------------------------- =head1 DESCRIPTION Bio::DB::GFF::Aggregator::alignment is one of the default aggregators, and was written to be compatible with the C elegans GFF files. It aggregates raw "similarity" features into composite features of type "alignment". A better name for this class might be "gapped_alignment." This aggregator does not insist that there be a single top-level feature that spans one end of the alignment to the other. As a result, it can produce truncated alignments if the entire alignment is not contained within the segment of interest. =cut package Bio::DB::GFF::Aggregator::alignment; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 aggregate Title : aggregate Usage : $features = $a->aggregate($features,$factory) Function: aggregate a feature list into composite features Returns : an array reference containing modified features Args : see L Status : Public Because of the large number of similarity features, the aggregate() method is overridden in order to perform some optimizations. =cut # we look for features of type Sequence and add them to a pseudotype transcript sub aggregate { my $self = shift; my $features = shift; my $factory = shift; my $matchsub = $self->match_sub($factory) or return; my $passthru = $self->passthru_sub($factory); my $method = $self->get_method; my (%alignments,%targets,@result); warn "running alignment aggregator" if $factory->debug; for my $feature (@$features) { if ($matchsub->($feature)) { my $group = $feature->{group}; my $source = $feature->source; unless (exists $alignments{$group,$source}) { my $type = Bio::DB::GFF::Typename->new($method,$source); my $f = $feature->clone; # this is a violation of OO encapsulation, but need to do it this way # to achieve desired performance @{$f}{qw(type score phase)} = ($type,undef,undef); $alignments{$group,$source} = $f or next; } my $main = $alignments{$group,$source}; $main->add_subfeature($feature); push @result,$feature if $passthru && $passthru->($feature); } else { push @result,$feature; } } warn "running aligner adjuster" if $factory->debug; for my $alignment (values %alignments) { $alignment->adjust_bounds; $alignment->compound(1); push @result,$alignment; } warn "aligner done" if $factory->debug; @$features = @result; } =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "alignment" Args : none Status : Public =cut sub method { 'alignment' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the full list of aggregated methods Args : none Status : Public =cut sub part_names { my $self = shift; return qw(nucleotide_match EST_match cDNA_match expressed_sequence_match translated_nucleotide_match protein_match HSP); } 1; BioPerl-1.6.923/Bio/DB/GFF/Aggregator/clone.pm000444000765000024 1040012254227332 20571 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::clone -- Clone aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ---------------------------------------------------------------------------- Aggregator method: clone Main method: -none- Sub methods: Clone_left_end Clone_right_end region:Genomic_canonical ---------------------------------------------------------------------------- =head1 DESCRIPTION Bio::DB::GFF::Aggregator::clone is one of the default aggregators, and was written to be compatible with the C elegans GFF files. It aggregates raw "Clone_left_end", "Clone_right_end", and "region:Genomic_canonical" features into composite features of type "clone". =cut package Bio::DB::GFF::Aggregator::clone; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 aggregate Title : aggregate Usage : $features = $a->aggregate($features,$factory) Function: aggregate a feature list into composite features Returns : an array reference containing modified features Args : see L Status : Public The WormBase GFF model is unusual in that clones aren't identified as a single feature with start and stop positions, but as two features, a "left end" and a "right end". One or both of these features may be absent. In order to accommodate this, the aggregator will return undef for the start and/or stop if one or both of the ends are missing. =cut #' # we look for features of type Sequence and add them to a pseudotype transcript sub aggregate { my $self = shift; my $features = shift; my $factory = shift; my $matchsub = $self->match_sub($factory) or return; my $passthru = $self->passthru_sub($factory); my $method = $self->get_method; my (%clones,%types,@result); for my $feature (@$features) { if ($feature->group && $matchsub->($feature)) { if ($feature->method =~ /^region|Sequence$/ && $feature->source eq 'Genomic_canonical') { $clones{$feature->group}{canonical} = $feature; } elsif ($feature->method eq 'Clone_left_end') { $clones{$feature->group}{left} = $feature; } elsif ($feature->method eq 'Clone_right_end') { $clones{$feature->group}{right} = $feature; } push @result,$feature if $passthru && $passthru->($feature); } else { push @result,$feature; } } for my $clone (keys %clones) { my $canonical = $clones{$clone}{canonical} or next; # the genomic_canonical doesn't tell us where the clone starts and stops # so don't assume it my $duplicate = $canonical->clone; # make a duplicate of the feature # munge the method and source fields my $source = $duplicate->source; my $type = $types{$method,$source} ||= Bio::DB::GFF::Typename->new($method,$source); $duplicate->type($type); my ($start,$stop) = $duplicate->strand > 0 ? ('start','stop') : ('stop','start'); @{$duplicate}{$start,$stop} =(undef,undef); $duplicate->{$start} = $clones{$clone}{left}{$start} if exists $clones{$clone}{left}; $duplicate->{$stop} = $clones{$clone}{right}{$stop} if exists $clones{$clone}{right}; $duplicate->method($self->method); push @result,$duplicate; } @$features = @result; } =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "clone" Args : none Status : Public =cut sub method { 'clone' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list ("Clone_left_end", "Clone_right_end", "region:Genomic_canonical") Args : none Status : Public =cut sub part_names { my $self = shift; return qw(Clone_left_end Clone_right_end region:Genomic_canonical Sequence:Genomic_canonical); } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/coding.pm000444000765000024 366612254227320 20731 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::coding -- The Coding Region Aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['coding'], ); ------------------------------------------------------------------------ Aggregator method: coding Main method: mRNA Sub methods: CDS ------------------------------------------------------------------------ =head1 DESCRIPTION Bio::DB::GFF::Aggregator::coding aggregates "CDS" features into a feature called "coding" and was written to be compatible with the Sequence Ontology canonical gene. The CDS features are expected to belong to a parent of type "mRNA," but the aggregator will work even if this isn't the case. =cut package Bio::DB::GFF::Aggregator::coding; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "coding" Args : none Status : Public =cut sub method { 'coding' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list (CDS cds) Args : none Status : Public =cut sub part_names { return qw(CDS cds); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "mRNA" Args : none Status : Public =cut sub main_name { return 'mRNA'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/gene.pm000444000765000024 456312254227325 20406 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::gene -- Sequence Ontology Geene =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['gene'], ); ------------------------------------------------------------------------ Aggregator method: gene Main method: mRNA Sub methods: CDS exon five_prime_UTR three_prime_UTR transcription_start_site polyA_site ------------------------------------------------------------------------ =head1 DESCRIPTION Bio::DB::GFF::Aggregator::gene is identical to so_transcript, but is used in those cases where you would like the name of the aggregated feature to be "gene" rather than "processed_transcript". It aggregates raw "exon," "CDS", "five_prime_UTR", "three_prime_UTR", "transcription_start_site" and "polyA_site" features into "mRNA" features. The UTRs may also be named "untranslated_region," "five_prime_untranslated_region," "three_prime_untranslated_region,", "5'-UTR," and other synonyms. =cut package Bio::DB::GFF::Aggregator::gene; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "gene" Args : none Status : Public =cut sub method { 'gene' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list CDS 5'-UTR 3'-UTR transcription_start_site polyA_site Args : none Status : Public =cut sub part_names { return qw(CDS transcription_start_site polyA_site UTR five_prime_untranslated_region three_prime_untranslated_region five_prime_UTR three_prime_UTR exon); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "mRNA" Args : none Status : Public =cut sub main_name { return 'mRNA'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2008 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/match.pm000444000765000024 360112254227315 20553 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::match -- Match aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['match'], ); ------------------------------------------------- Aggregator method: match Main method: match Sub methods: similarity HSP ------------------------------------------------- =head1 DESCRIPTION This aggregator is used for Sequence Ontology-compatible gapped alignments, in which there is a single top-level alignment called "match" and a series of subalignments called either "similarity" or "HSP". Also see the "alignment" aggregator. =cut package Bio::DB::GFF::Aggregator::match; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "match" Args : none Status : Public =cut sub method { 'match' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list "similarity", "HSP" Args : none Status : Public =cut sub part_names { return qw(similarity HSP); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "match" Args : none Status : Public =cut sub main_name { return 'match'; } sub require_whole_object {1} 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/none.pm000444000765000024 150712254227330 20416 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::none -- No aggregation =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => 'none' ); =head1 DESCRIPTION Bio::DB::GFF::Aggregator::none can be used to indicate that you do not want any aggregation performed. It is equivalent to providing undef to the B<-aggregator> argument. It overrides disaggregate() and aggregate() so that they do exactly nothing. =cut package Bio::DB::GFF::Aggregator::none; use strict; use base qw(Bio::DB::GFF::Aggregator); sub disaggregate { my $self = shift; my $types = shift; # no change } sub aggregate { my $self = shift; my $features = shift; return; # no change } 1; BioPerl-1.6.923/Bio/DB/GFF/Aggregator/orf.pm000444000765000024 330412254227334 20246 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::orf -- An aggregator for orf regions =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['orf','clone'], ); --------------------------- Aggregator method: orf Main method: -none- Sub methods: ORF --------------------------- =head1 DESCRIPTION Bio::DB::GFF::Aggregator::orf was written to work with the "cds" glyph. GFF files. It aggregates raw "ORF" features into "coding" features. This is basically identical to the "coding" aggregator, except that it looks for features of type "ORF" rather than "cds". =cut package Bio::DB::GFF::Aggregator::orf; use strict; use Bio::DB::GFF::Aggregator; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "orf" Args : none Status : Public =cut sub method { 'orf' } # sub require_whole_object { 1; } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list "CDS" Args : none Status : Public =cut sub part_names { return qw(ORF); } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/processed_transcript.pm000444000765000024 472112254227313 23721 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::processed_transcript -- Sequence Ontology Transcript =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['processed_transcript'], ); ------------------------------------------------------------------------ Aggregator method: processed_transcript Main method: mRNA Sub methods: CDS exon five_prime_UTR three_prime_UTR transcription_start_site polyA_site 5'-UTR 3'-UTR ------------------------------------------------------------------------ =head1 DESCRIPTION Bio::DB::GFF::Aggregator::processed_transcript is one of the default aggregators, and was written to be compatible with the Sequence Ontology canonical gene. It aggregates raw "exon," "CDS", "five_prime_UTR", "three_prime_UTR", "transcription_start_site" and "polyA_site" features into "mRNA" features. The UTRs may also be named "untranslated_region," "five_prime_untranslated_region," "three_prime_untranslated_region,", "5'-UTR," and other synonyms. =cut package Bio::DB::GFF::Aggregator::processed_transcript; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "processed_transcript" Args : none Status : Public =cut sub method { 'processed_transcript' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list CDS 5'-UTR 3'-UTR transcription_start_site polyA_site Args : none Status : Public =cut sub part_names { return qw(CDS 5'-UTR 3'-UTR transcription_start_site polyA_site UTR five_prime_untranslated_region three_prime_untranslated_region five_prime_UTR three_prime_UTR exon); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "mRNA" Args : none Status : Public =cut sub main_name { return 'mRNA'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/so_transcript.pm000444000765000024 506112254227324 22353 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::so_transcript -- Sequence Ontology Transcript =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['so_transcript'], ); ------------------------------------------------------------------------ Aggregator method: processed_transcript Main method: mRNA Sub methods: CDS exon five_prime_UTR three_prime_UTR transcription_start_site polyA_site 5'-UTR 3'-UTR ------------------------------------------------------------------------ =head1 DESCRIPTION Bio::DB::GFF::Aggregator::so_transcript is identical to the processed_transcript aggregator, which was designed to be compatible with the Sequence Ontology canonical gene. It aggregates raw "exon," "CDS", "five_prime_UTR", "three_prime_UTR", "transcription_start_site" and "polyA_site" features into "mRNA" features. The UTRs may also be named "untranslated_region," "five_prime_untranslated_region," "three_prime_untranslated_region,", "5'-UTR," and other synonyms. The processed_transcript aggregator is loaded by default, so this is only needed for backward compatibility. =cut package Bio::DB::GFF::Aggregator::so_transcript; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "processed_transcript" Args : none Status : Public =cut sub method { 'so_transcript' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list CDS 5'-UTR 3'-UTR transcription_start_site polyA_site Args : none Status : Public =cut sub part_names { return qw(CDS 5'-UTR 3'-UTR transcription_start_site polyA_site UTR five_prime_untranslated_region three_prime_untranslated_region five_prime_UTR three_prime_UTR exon); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "mRNA" Args : none Status : Public =cut sub main_name { return 'mRNA'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/transcript.pm000444000765000024 477112254227332 21660 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::transcript -- Transcript aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: transcript Main method: transcript Sub methods: exon CDS 5'UTR 3'UTR TSS PolyA ------------------------------------------------- =head1 DESCRIPTION Bio::DB::GFF::Aggregator::transcript is one of the default aggregators, and was written to be compatible with the C elegans GFF files. It aggregates raw ""exon", "CDS", "5'UTR", "3'UTR", "polyA" and "TSS" features into "transcript" features. For compatibility with the idiosyncrasies of the Sanger GFF format, it expects that the full range of the transcript is contained in a main feature of type "Transcript" (notice the capital "T"). Internally this module is very simple. To override it with one that recognizes a main feature named "gene", simply follow this template: my $db = Bio::DB::GFF->new(...etc...) my $aggregator = Bio::DB::GFF::Aggregator->new(-method => 'transcript', -main_method => 'gene', -sub_parts => ['exon','CDS']); $db->add_aggregator($aggregator); =cut package Bio::DB::GFF::Aggregator::transcript; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "transcript" Args : none Status : Public =cut sub method { 'transcript' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : the list "intron", "exon" and "CDS" Args : none Status : Public =cut sub part_names { return qw(exon CDS 5'UTR 3'UTR TSS PolyA); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript" Args : none Status : Public =cut sub main_name { return 'transcript'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_acembly.pm000444000765000024 334212254227317 22114 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_acembly -- UCSC acembly aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: transcript Main method: transcript Sub methods: exon CDS 5'UTR 3'UTR TSS PolyA ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_acembly; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "acembly" Args : none Status : Public =cut sub method { 'acembly' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:acembly" Args : none Status : Public =cut sub main_name { return 'transcript:acembly'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_ensgene.pm000444000765000024 331012254227324 22115 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_ensgene -- UCSC ensGene aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: ensgene Main method: transcript Sub methods: ensGene ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_ensgene; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "ensgene" Args : none Status : Public =cut sub method { 'ensgene' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:ensGene" Args : none Status : Public =cut sub main_name { return 'transcript:ensGene'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_genscan.pm000444000765000024 330712254227314 22114 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_genscan -- UCSC genscan aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: genscan Main method: transcript Sub methods: genscan ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_genscan; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "genscan" Args : none Status : Public =cut sub method { 'genscan' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:genscan" Args : none Status : Public =cut sub main_name { return 'transcript:genscan'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_refgene.pm000444000765000024 330712254227313 22110 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_refgene -- UCSC refGene aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: refgene Main method: transcript Sub methods: refGene ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_refgene; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "refgene" Args : none Status : Public =cut sub method { 'refgene' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:refGene" Args : none Status : Public =cut sub main_name { return 'transcript:refGene'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_sanger22.pm000444000765000024 332112254227327 22121 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_sanger22 -- UCSC sanger22 aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: sanger22 Main method: transcript Sub methods: sanger22 ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_sanger22; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "sanger22" Args : none Status : Public =cut sub method { 'sanger22' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:sanger22" Args : none Status : Public =cut sub main_name { return 'transcript:sanger22'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_sanger22pseudo.pm000444000765000024 340712254227323 23342 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_sanger22pseudo -- UCSC sanger22pseudo aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: sanger22pseudo Main method: transcript Sub methods: sanger22pseudo ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_sanger22pseudo; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "sanger22pseudo" Args : none Status : Public =cut sub method { 'sanger22pseudo' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:sanger22pseudo" Args : none Status : Public =cut sub main_name { return 'transcript:sanger22pseudo'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_softberry.pm000444000765000024 334512254227323 22517 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_softberry -- UCSC softberry aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: softberry Main method: transcript Sub methods: softberryGene ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_softberry; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "softberry" Args : none Status : Public =cut sub method { 'softberry' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:softberryGene" Args : none Status : Public =cut sub main_name { return 'transcript:softberryGene'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_twinscan.pm000444000765000024 332012254227326 22322 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_twinscan -- UCSC twinscan aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: twinscan Main method: transcript Sub methods: twinscan ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_twinscan; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "twinscan" Args : none Status : Public =cut sub method { 'twinscan' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript:twinscan" Args : none Status : Public =cut sub main_name { return 'transcript:twinscan'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Aggregator/ucsc_unigene.pm000444000765000024 332012254227326 22126 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Aggregator::ucsc_unigene -- UCSC UniGene aggregator =head1 SYNOPSIS use Bio::DB::GFF; # Open the sequence database my $db = Bio::DB::GFF->new( -adaptor => 'dbi:mysql', -dsn => 'dbi:mysql:elegans42', -aggregator => ['transcript','clone'], ); ------------------------------------------------- Aggregator method: unigene Main method: transcript Sub methods: unigene_2 ------------------------------------------------- =head1 DESCRIPTION L =cut package Bio::DB::GFF::Aggregator::ucsc_unigene; use strict; use base qw(Bio::DB::GFF::Aggregator); =head2 method Title : method Usage : $aggregator->method Function: return the method for the composite object Returns : the string "unigene" Args : none Status : Public =cut sub method { 'unigene' } =head2 part_names Title : part_names Usage : $aggregator->part_names Function: return the methods for the sub-parts Returns : empty list Args : none Status : Public =cut sub part_names { return (); } =head2 main_name Title : main_name Usage : $aggregator->main_name Function: return the method for the main component Returns : the string "transcript" Args : none Status : Public =cut sub main_name { #transcript return 'transcript:uniGene_2'; } 1; __END__ =head1 BUGS None reported. =head1 SEE ALSO L, L =head1 AUTHOR Allen Day Eallenday@ucla.eduE. Copyright (c) 2002 Allen Day, University of California, Los Angeles. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Util000755000765000024 012254227333 15617 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/GFF/Util/Binning.pm000444000765000024 461412254227333 17703 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Util::Binning - binning utility for Bio::DB::GFF index =head1 SYNOPSIS use Bio::DB::GFF::Util::Binning qw(bin bin_bot bin_top); my $tier = bin($start,$stop,$min); =head1 DESCRIPTION This is a utility module that exports the functions bin(), bin_bot() and bin_top(). These functions translate a range on the genome into a named bin that is used as an index in the Bio::DB::GFF schema. The index makes certain range retrieval queries much faster. =head1 API The remainder of the document describes the function calls. No calls are exported by default, but must be imported explicitly. =over 4 =cut package Bio::DB::GFF::Util::Binning; use strict; require Exporter; use vars qw(@EXPORT @EXPORT_OK); use base qw(Exporter); @EXPORT_OK = qw(bin bin_bot bin_top); @EXPORT = @EXPORT_OK; use Bio::Root::Version; =item $bin_name = bin($start,$stop,$bin_size) Given a start, stop and bin size on the genome, translate this location into a bin name. In a list context, returns the bin tier name and the position that the bin begins. =cut sub bin { my ($start,$stop,$min) = @_; $start = abs($start); # to allow negative coordinates $stop = abs($stop); my $tier = $min; my ($bin_start,$bin_end); while (1) { $bin_start = int $start/$tier; $bin_end = int $stop/$tier; last if $bin_start == $bin_end; $tier *= 10; } return wantarray ? ($tier,$bin_start) : bin_name($tier,$bin_start); } =item $bottom = bin_bot($tier,$start) Given a tier name and a range start position, returns the lower end of the bin range. =cut sub bin_bot { my $tier = shift; my $pos = shift; bin_name($tier,int(abs($pos)/$tier)); } =item $top = bin_top($tier,$end) Given a tier name and the end of a range, returns the upper end of the bin range. =cut sub bin_top { my $tier = shift; my $pos = shift; bin_name($tier,int(abs($pos)/$tier)); # bin_name($tier,int($pos/$tier),+1); } sub bin_name { my ($tier, $int, $fudge) = @_; my $pos = abs($int) + ($fudge || 0); $pos = 0 if $pos < 0; sprintf("%d.%06d",$tier, $pos); } sub log10 { my $i = shift; log($i)/log(10); } 1; =back =head1 BUGS None known yet. =head1 SEE ALSO L, =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/GFF/Util/Rearrange.pm000444000765000024 507612254227312 20225 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::DB::GFF::Util::Rearrange - rearrange utility =head1 SYNOPSIS use Bio::DB::GFF::Util::Rearrange 'rearrange'; my ($arg1,$arg2,$arg3,$others) = rearrange(['ARG1','ARG2','ARG3'],@args); =head1 DESCRIPTION This is a different version of the _rearrange() method from Bio::Root::Root. It runs as a function call, rather than as a method call, and it handles unidentified parameters slightly differently. It exports a single function call: =over 4 =item @rearranged_args = rearrange(\@parameter_names,@parameters); The first argument is an array reference containing list of parameter names in the desired order. The second and subsequent arguments are a list of parameters in the format: (-arg1=>$arg1,-arg2=>$arg2,-arg3=>$arg3...) The function calls returns the parameter values in the order in which they were specified in @parameter_names. Any parameters that were not found in @parameter_names are returned in the form of a hash reference in which the keys are the uppercased forms of the parameter names, and the values are the parameter values. =back =head1 BUGS None known yet. =head1 SEE ALSO L, =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2001 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut package Bio::DB::GFF::Util::Rearrange; use strict; require Exporter; use vars qw(@EXPORT @EXPORT_OK); use base qw(Exporter); @EXPORT_OK = qw(rearrange); @EXPORT = qw(rearrange); use Bio::Root::Version; # default export sub rearrange { my($order,@param) = @_; return unless @param; my %param; if (ref $param[0] eq 'HASH') { %param = %{$param[0]}; } else { return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-'); my $i; for ($i=0;$i<@param;$i+=2) { $param[$i]=~s/^\-//; # get rid of initial - if present $param[$i]=~tr/a-z/A-Z/; # parameters are upper case } %param = @param; # convert into associative array } my(@return_array); local($^W) = 0; my($key)=''; foreach $key (@$order) { my($value); if (ref($key) eq 'ARRAY') { foreach (@$key) { last if defined($value); $value = $param{$_}; delete $param{$_}; } } else { $value = $param{$key}; delete $param{$key}; } push(@return_array,$value); } push (@return_array,\%param) if %param; return @return_array; } 1; BioPerl-1.6.923/Bio/DB/HIV000755000765000024 012254227323 14725 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/HIV/HIVAnnotProcessor.pm000555000765000024 1224112254227313 20770 0ustar00cjfieldsstaff000000000000# $Id: HIVAnnotProcessor.pm 221 2008-12-11 13:05:24Z maj $ # # BioPerl module for HIVAnnotProcessor # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME HIVAnnotProcessor - Adds HIV-specific annotations to Bio::SeqIO streams =head1 SYNOPSIS sub get_Stream_by_query { my ($self, $query ) = @_; my $stream = $self->get_seq_stream('-query' => $query, '-mode'=>'query'); return new Bio::DB::HIV::HIVAnnotProcessor( -hiv_query=>$query, -source_stream=>$stream ); } =head1 DESCRIPTION Bio::DB::HIV::HIVAnnotProcessor is chained to the C of a sequence stream returned from a query to the Los Alamos HIV sequence database made using L and L. It adds the annotations obtained in the C to the Bio::Seq objects themselves via the C<$seq-Eannotation> method. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj@fortinbras.us =head1 CONTRIBUTORS Mark A. Jensen =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::HIV::HIVAnnotProcessor; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use base qw( Bio::Root::Root); =head1 Constructor =head2 new Title : new Usage : my $obj = new HIVAnnotProcessor(); Function: Builds a new HIVAnnotProcessor object Returns : an instance of HIVAnnotProcessor Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hiv_query, $source_stream) = $self->_rearrange([qw(HIV_QUERY SOURCE_STREAM)], @args); $hiv_query && $self->hiv_query($hiv_query); $source_stream && $self->source_stream($source_stream); return $self; } =head1 Bio::Factory::SequenceProcessorI compliance =head2 source_stream Title : source_stream Usage : $hap->source_stream($newval) Function: Example : Returns : value of source_stream (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source_stream{ my $self = shift; if (@_) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Requires a Bio::SeqIO as argument', -value=>$_[0]) unless $_[0]->isa('Bio::SeqIO'); } return $self->{'source_stream'} = shift if @_; return $self->{'source_stream'}; } =head2 next_seq Title : next_seq Usage : $seqobj = stream->next_seq Function: Reads the next sequence object from the stream, : adds annotations from the HIVQuery object according : to the sequence id, and returns sequence object Returns : a Bio::Seq sequence object Args : none =cut sub next_seq { my $self = shift; my $q = $self->hiv_query; my $seqo = $self->source_stream->next_seq; return $seqo unless ($q && $seqo); my $ac = $q->get_annotations_by_id($seqo->primary_id); $seqo->annotation($ac) if $ac; my $acc = $q->get_accessions_by_id($seqo->primary_id); $seqo->accession_number($acc) if $acc; return $seqo; } =head2 write_seq Title : write_seq Usage : $seqobj->write_seq Function: for HIVAnnotProcessor, throw an exception Example : Returns : Bio::Root::IOException Args : =cut sub write_seq{ my ($self,@args) = @_; $self->throw(-class=>'Bio::Root::IOException', -text=>'This stream is read-only', -value=>""); } =head1 HIVAnnotProcessor-specific methods =head2 hiv_query Title : hiv_query Usage : $obj->hiv_query($newval) Function: Example : Returns : value of hiv_query (a Bio::DB::Query::HIVQuery object) Args : on set, new value (an HIVQuery object, optional) =cut sub hiv_query{ my $self = shift; if (@_) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Requires a Bio::DB::Query::HIVQuery as argument', -value=>$_[0]) unless ref $_[0] && $_[0]->isa('Bio::DB::Query::HIVQuery'); } return $self->{'hiv_query'} = shift if @_; return $self->{'hiv_query'}; } 1; BioPerl-1.6.923/Bio/DB/HIV/HIVQueryHelper.pm000555000765000024 15361412254227320 20306 0ustar00cjfieldsstaff000000000000# $Id: HIVQueryHelper.pm 231 2008-12-11 14:32:00Z maj $ # # BioPerl module for Bio::DB::HIV::HIVQueryHelper # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::HIV::HIVQueryHelper - Routines and packages used by Bio::DB::HIV and Bio::DB::Query::HIVQuery =head1 SYNOPSIS Used in Bio::DB::Query::HIVQuery. No need to use directly. =head1 DESCRIPTION C contains a number of packages for use by L. Package C parses the C file, and allows access to it in the context of the relational database it represents (see APPENDIX for excruciating detail). Packages C, C, and C together create the query string parser that enables NCBI-like queries to be understood by C. They provide objects and operators to perform and simplify logical expressions involving C, C, and C<()> and return hash structures that can be handled by C routines. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj@fortinbras.us =head1 CONTRIBUTORS Mark A. Jensen =head1 APPENDIX The rest of the documentation details each of the contained packages. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::HIV::HIVQueryHelper; use strict; use Bio::Root::Root; # globals BEGIN { #exceptions @Bio::QueryStringSyntax::Exception::ISA = qw( Bio::Root::Exception); } 1; =head2 HIVSchema - objects/methods to manipulate a version of the LANL HIV DB schema =head3 HIVSchema SYNOPSIS $schema = new HIVSchema( 'lanl-schema.xml' ); @tables = $schema->tables; @validFields = $schema->fields; @validAliases = $schema->aliases; @query_aliases_for_coreceptor = $schema->aliases( 'SEQ_SAMple.SSAM_second_receptor' ); $pk_for_SequenceEntry = $schema->primarykey('SequenceEntry'); # returns 'SequenceEntry.SE_id' $fk_for_SEQ_SAMple_to_SequenceEntry = $schema->foreignkey('SEQ_SAMple', 'SequenceEntry'); # returns 'SEQ_SAMple.SSAM_SE_id' $table = $schema->tablepart('SEQ_SAMple.SSAM_badseq'); # returns 'SEQ_SAMple' $column = $schema->columnpart('SEQ_SAMple.SSAM_badseq'); # returns 'SSAM_badseq' =head3 HIVSchema DESCRIPTION HIVSchema methods are used in L for table, column, primary/foreign key manipulations based on the observed Los Alamos HIV Sequence Database (LANL DB) naming conventions for their CGI parameters. The schema is contained in an XML file (C) which is read into an HIVSchema object, in turn a property of the HIVQuery object. HIVSchema methods are used to build correct cgi queries in a way that attempts to preserve the context of the relational database the query parameters represent. =cut package # hide from PAUSE HIVSchema; # objects/methods to manipulate a version of the LANL HIV DB schema # stored in XML use XML::Simple; use Bio::Root::Root; use strict; ### constructor =head3 HIVSchema CONSTRUCTOR =head4 HIVSchema::new Title : new Usage : $schema = new HIVSchema( "lanl-schema.xml "); Function: Example : Returns : an HIVSchema object Args : XML filename =cut sub new { my $class = shift; my @args = @_; my $self = {}; if ($args[0]) { $self->{schema_ref} = loadHIVSchema($args[0]); } bless($self, $class); return $self; } ### object methods =head3 HIVSchema INSTANCE METHODS =head4 HIVSchema tables Title : tables Usage : $schema->tables() Function: get all table names in schema Example : Returns : array of table names Args : none =cut sub tables { # return array of all tables in schema local $_; my $self = shift; my $sref = $self->{schema_ref}; Bio::Root::Root->throw("schema not initialized") unless $sref; my @k = grep(/\./, keys %$sref); my %ret; foreach (@k) { s/\..*$//; $ret{$_}++; } @k = sort keys %ret; return @k; } =head4 HIVSchema columns Title : columns Usage : $schema->columns( [$tablename] ); Function: return array of columns for specified table, or all columns in schema, if called w/o args Example : Returns : Args : tablename or fieldname string =cut sub columns { # return array of columns for specified table # all columns in schema, if called w/o args local $_; my $self = shift; my ($tbl) = @_; my $sref = $self->{schema_ref}; Bio::Root::Root->throw("schema not initialized") unless $sref; # trim column name $tbl =~ s/\..*$//; # check if table exists return () unless grep(/^$tbl$/i, $self->tables); my @k = sort keys %$sref; @k = grep (/^$tbl\./i, @k); foreach (@k) { s/^$tbl\.//; } return @k; } =head4 HIVSchema fields Title : fields Usage : $schema->fields(); Function: return array of all fields in schema, in format "table.column" Example : Returns : array of all fields Args : none =cut sub fields { # return array of all fields (Table.Column format) in schema my $self = shift; my $sref = $self->{schema_ref}; Bio::Root::Root->throw("schema not initialized") unless $sref; my @k = sort keys %{$sref}; return @k; } =head4 HIVSchema options Title : options Usage : $schema->options(@fieldnames) Function: get array of options (i.e., valid match data strings) available to specified field Example : Returns : array of match data strings Args : [array of] fieldname string[s] in "table.column" format =cut sub options { # return array of options available to specified field my $self = shift; my ($sfield) = @_; my $sref = $self->{schema_ref}; Bio::Root::Root->throw("schema not initialized") unless $sref; return $$sref{$sfield}{option} ? @{$$sref{$sfield}{option}} : (); } =head4 HIVSchema aliases Title : aliases Usage : $schema->aliases(@fieldnames) Function: get array of aliases to specified field[s] Example : Returns : array of valid query aliases for fields as spec'd in XML file Args : [an array of] fieldname[s] in "table.column" format =cut sub aliases { # return array of aliases to specified field my $self = shift; my ($sfield) = @_; my $sref = $self->{schema_ref}; my @ret; Bio::Root::Root->throw("schema not initialized") unless $sref; if ($sfield) { return $$sref{$sfield}{alias} ? @{$$sref{$sfield}{alias}} : (); } else { # all valid aliases map {push @ret, @{$$sref{$_}{alias}} if $$sref{$_}{alias}} $self->fields; return @ret; } } =head4 HIVSchema ankh Title : ankh (annotation key hash) Usage : $schema->ankh(@fieldnames) Function: return a hash translating fields to annotation keys for the spec'd fields. (Annotation keys are used for parsing the tab-delimited response to Bio::DB::Query::HIVQuery::_do_lanl_request.) Example : Returns : hash ref Args : [an array of] fieldname[s] in "table.column" format =cut sub ankh { # return hash translating sfields to annotation keys for specified sfield(s) my $self = shift; my %ret = (); my @sfields = @_; my $sref = $self->{schema_ref}; Bio::Root::Root->throw("schema not initialized") unless $sref; foreach (@sfields) { next unless $$sref{$_}{ankey}; $ret{$_} = {'ankey'=>$$sref{$_}{ankey},'antype'=>$$sref{$_}{antype}}; } return %ret; } =head4 HIVSchema tablepart Title : tablepart (alias: tbl) Usage : $schema->tbl(@fieldnames) Function: return the portion of the fieldname[s] that refer to the db table Example : $schema->tbl('SequenceEntry.SE_id'); # returns 'SequenceEntry' Returns : table name as string Args : [an array of] fieldname[s] in "table.column" format =cut sub tablepart { # return the 'Table' part of the specified field(s) my $self = shift; my @sfields = @_; Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref}; my ($squish,@ret, %ret); if ($sfields[0] eq '-s') { # squish : remove duplicates from the returned array $squish=1; shift @sfields; } foreach (@sfields) { push @ret, /^(.*)\./; } if ($squish) { # arg order is clobbered @ret{@ret} = undef; @ret = keys %ret; } return (wantarray ? @ret : $ret[0]); } sub tbl { # tablepart alias shift->tablepart(@_); } =head4 HIVSchema columnpart Title : columnpart (alias: col) Usage : $schema->col(@fieldnames) Function: return the portion of the fieldname[s] that refer to the db column Example : $schema->col('SequenceEntry.SE_id'); # returns 'SE_id' Returns : column name as string Args : [an array of] fieldname[s] in "table.column" format =cut sub columnpart { # return the 'Column' part of the specified field(s) my $self = shift; my @sfields = @_; Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref}; my @ret; foreach (@sfields) { push @ret, /\.(.*)$/; } return (wantarray ? @ret : $ret[0]); } sub col { # columnpart alias shift->columnpart(@_); } =head4 HIVSchema primarykey Title : primarykey [alias: pk] Usage : $schema->pk(@tablenames); Function: return the primary key of the specified table[s], as judged by the syntax of the table's[s'] fieldnames Example : $schema->pk('SequenceEntry') # returns 'SequenceEntry.SE_id' Returns : primary key fieldname[s] in "table.column" format, or null if no pk exists Args : [an array of] table name[s] (fieldnames are ok, table part used) =cut sub primarykey { # return the primary key (in Table.Column format) of specified table(s) my $self = shift; my @tbl = @_; my @ret; Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref}; foreach my $tbl (@tbl) { # trim column name $tbl =~ s/\..*$//; grep(/^$tbl$/i, $self->tables) ? push(@ret, grep(/\.[0-9a-zA-Z]+_id/, grep(/$tbl/i,$self->fields))) : push(@ret, ""); } return (wantarray ? @ret : $ret[0]); } sub pk { # primarykey alias shift->primarykey(@_); } =head4 HIVSchema foreignkey Title : foreignkey [alias: fk] Usage : $schema->fk($intable [, $totable]) Function: return foreign key fieldname in table $intable referring to table $totable, or all foreign keys in $intable if $totable unspec'd Example : $schema->fk('AUthor', 'SequenceEntry'); # returns 'AUthor_AU_SE_id' Returns : foreign key fieldname[s] in "table.column" format Args : tablename [, optional foreign table name] (fieldnames are ok, table part used) =cut sub foreignkey { # return foreign key in in-table ($intbl) to to-table ($totbl) # or all foreign keys in in-table if to-table not specified # keys returned in Table.Column format my $self = shift; my ($intbl, $totbl) = @_; Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref}; # trim col names $intbl =~ s/\..*$//; $totbl =~ s/\..*$// if $totbl; # check if in-table exists return () unless grep( /^$intbl/i, $self->tables); my @ret = grep( /$intbl\.(?:[0-9a-zA-Z]+_){2,}id/i, $self->fields); if ($totbl) { my $tpk = $self->primarykey($totbl); return (wantarray ? () : "") unless grep( /^$totbl/i, $self->tables) && $tpk; ($tpk) = ($tpk =~ /\.(.*)$/); @ret = grep( /$tpk$/, @ret); return (wantarray ? @ret : $ret[0]); } else { # return all foreign keys in in-table return @ret; } } sub fk { # foreignkey alias shift->foreignkey(@_); } =head4 HIVSchema foreigntable Title : foreigntable [alias ftbl] Usage : $schema->ftbl( @foreign_key_fieldnames ); Function: return tablename of table that foreign keys points to Example : $schema->ftbl( 'AUthor.AU_SE_id' ); # returns 'SequenceEntry' Returns : tablename Args : [an array of] fieldname[s] in "table.column" format =cut sub foreigntable { # return table name that foreign key(s) point(s) to my $self = shift; my @fk = @_; my @ret; Bio::Root::Root->throw("schema not initialized") unless $self->{schema_ref}; foreach (@fk) { my ($mnem, $fmnem) = /\.([0-9a-zA-Z]+)_([0-9a-zA-Z]+)_.*$/; next unless $mnem && $fmnem; # lookup based on Table.Column format of fields my $sf = [grep( /^[0-9a-zA-Z]+\.$fmnem\_/, $self->fields )]->[0]; next unless $sf; ($sf) = ($sf =~ /^([0-9a-zA-Z]+)\./); push @ret, $sf; } return (wantarray ? @ret : $ret[0]); } sub ftbl { # foreigntable alias shift->foreigntable(@_); } =head4 HIVSchema find_join Title : find_join Usage : $sch->find_join('Table1', 'Table2') Function: Retrieves a set of foreign and primary keys (in table.column format) that represents a join path from Table1 to Table2 Example : Returns : an array of keys (as table.column strings) -or- an empty array if Table1 == Table2 -or- undef if no path exists Args : two table names as strings =cut sub find_join { my $self = shift; my ($tgt, $tbl) = @_; my ($stack, $revstack, $found, $revcut) = ([],[], 0, 4); $self->_find_join_guts($tgt, $tbl, $stack, \$found); if ($found) { if (@$stack > $revcut) { # reverse order of tables, see if a shorter path emerges $found = 0; $self->_find_join_guts($tgt, $tbl, $revstack, \$found, 1); return (@$stack <= @$revstack ? @$stack : @$revstack); } return @$stack; } else { return undef; } } =head4 HIVSchema _find_join_guts Title : _find_join_guts Usage : $sch->_find_join_guts($table1, $table2, $stackref, \$found, $reverse) (call with $stackref = [], $found=0) Function: recursive guts of find_join Example : Returns : if a path is found, $found==1 and @$stackref contains the keys in table.column format representing the path; if a path is not found, $found == 0 and @$stackref contains garbage Args : $table1, $table2 : table names as strings $stackref : an arrayref to an empty array \$found : a scalar ref to the value 0 $rev : if $rev==1, the arrays of table names will be reversed; this can give a shorter path if cycles exist in the schema graph =cut sub _find_join_guts { my $self = shift; my ($tbl, $tgt, $stack, $found, $rev) = @_; return () if $tbl eq $tgt; my $k = $self->pk($tbl); if ($k) { # all fks pointing to pk my @fk2pk = map { $self->fk($_, $k) || () } ($rev ? reverse $self->tables : $self->tables); # skip keys already on stack if (@$stack) { (@$stack == 1) && do { @fk2pk = grep (!/$$stack[0]/, @fk2pk); }; (@$stack > 1 ) && do { @fk2pk = map { my $f=$_; grep(/$f/, @$stack) ? () : $f } @fk2pk; }; } foreach my $f2p (@fk2pk) { # tables with fks pointing to pk push @$stack, $f2p; if ($self->tbl($f2p) eq $tgt) { # this fk's table is the target # found it $$found = 1; return; } else { #keep looking $self->_find_join_guts($self->tbl($f2p), $tgt, $stack, $found, $rev); return if $$found; } } } # all fks in $tbl my @fks = ($rev ? reverse $self->fk($tbl) : $self->fk($tbl)); #skip keys already on stack if (@$stack) { (@$stack == 1) && do { @fks = grep(!/$$stack[0]/, @fks); }; (@$stack > 1) && do { @fks = map { my $f=$_; grep(/$f/, @$stack) ? () : $f } @fks; }; } # all fks in table if (@fks) { for my $f (@fks) { push @$stack, $f; if ($self->ftbl($f) eq $tgt) { #found it $$found = 1; return; } else { $self->_find_join_guts($self->ftbl($f), $tgt, $stack, $found, $rev); $$found ? return : pop @$stack; } } } else { pop @$stack; return; } } =head4 HIVSchema loadSchema Title : loadHIVSchema [alias: loadSchema] Usage : $schema->loadSchema( $XMLfilename ) Function: read (LANL DB) schema spec from XML Example : $schema->loadSchema('lanl-schema.xml'); Returns : hashref to schema data Keys are fieldnames in "table.column" format. Each value is a hashref with the following properties: {name} : HIVWEB 'table.column' format fieldname, can be used directly in the cgi query {aliases} : ref to array containing valid aliases/shortcuts for {name}; can be used in routines creating the HTML query {options} : ref to array containing valid matchdata for this field can be used directly in the HTML query {ankey} : contains the annotation key for this field used with Bioperl annotation objects {..attr..}: ..value_of_attr.. for this field (app-specific metadata) Args : =cut sub loadHIVSchema { my $fn = shift; Bio::Root::Root->throw("loadHIVSchema: schema file not found") unless -e $fn; my $q = XML::Simple->new(ContentKey=>'name',NormalizeSpace=>2,ForceArray=>1); my %ret; my $ref = $q->XMLin($fn); my @sf = keys %{$$ref{sfield}}; foreach (@sf) { my $h = $$ref{sfield}{$_}; $ret{$_} = $h; foreach my $ptr ($$h{option}, $$h{alias}) { if ($ptr) { # kludge for XMLin: appears to convert to arrays, if there # exists a tag without content, but to convert to hashes # with content as key, if all tags possess content if (ref($ptr) eq 'HASH') { my @k = keys %{$ptr}; if (grep /desc/, keys %{$ptr->{$k[0]}}) { # slurp the desc's $$h{desc} = [ map { $$ptr{$_}->{desc} } @k ]; } # now overwrite with keys (descs in same order...) $ptr = [@k]; } elsif (ref($ptr) eq 'ARRAY') { $ptr = [map { ref eq 'HASH' ? $_->{name} : $_ } @{$ptr}] } else { 1; # stub : doh! } } } for my $ptr ($$h{ankey}) { # flatten my $ank = [keys %{$ptr}]->[0]; if (!defined $ank) { delete $$h{ankey}; } else { $h->{antype} = $ptr->{$ank}{antype}; $ptr = $ank; } } } return \%ret; } sub loadSchema { my $self = shift; $self->{schema_ref} = loadHIVSchema(shift); } # below, dangerous =head4 HIVSchema _sfieldh Title : _sfieldh Usage : $schema->_sfieldh($fieldname) Function: get hashref to the specified field hash Example : Returns : hashref Args : fieldname in "table.column" format =cut sub _sfieldh { # return reference to the specified field hash my $self = shift; my ($sfield) = @_; return ${$self->{schema_ref}}{$sfield}; } 1; =head2 Class QRY - a query algebra for HIVQuery =head3 QRY SYNOPSIS $Q = new QRY( new R( new Q('coreceptor', 'CXCR4'), new Q('country', 'ZA') ) ); QRY::Eq(QRY::And($Q, $Q), $Q); # returns 1 QRY::Eq(QRY::Or($Q, $Q), $Q); # returns 1 $Q2 = $Q1->clone; $Q2 = new QRY( new R( new Q( 'coreceptor', 'CCR5' ), new Q( 'country', 'ZA') ) ); (QRY::And($Q, $Q2))->isnull; # returns 1 $Q3 = QRY::Or($Q, $Q2); print $Q3->A; # prints '(CCR5 CXCR4)[coreceptor] (ZA)[country]' =head3 QRY DESCRIPTION The QRY package provides a query parser for L. Currently, the parser supports AND, OR, and () operations. The structure of the LANL cgi makes it tricky to perform NOTs, though this could be implemented if the desire were great. Two class methods do the work. C does a first-pass parse of the query string. C interprets the parse tree as returned by C and produces an array of hash structures that can be used directly by C query execution methods. Validation of query fields and options is performed at the C level, not here. C objects are collections of C (or request) objects, which are in turn collections of C (or atomic query) objects. C objects represent a query on a single field, with match data options Ced together, e.g. C<(A B)[subtype]>. C objects collect C objects that could be processed in a single HTTP request; i.e., a set of atomic queries each having different fields Ced together, such as (A B)[subtype] AND ('CCR5')[coreceptor] AND (US CA)[country] The C object collects Cs that cannot be reduced (through logical operations) to a single HTTP request, e.g. ((C)[subtype] AND (SI)[phenotype]) OR ( (D)[subtype] AND (NSI)[phenotype] ), which cannot be got in one go through the current LANL cgi implementation (as far as I can tell). The parser will simplify something like ((C)[subtype] AND (SI)[phenotype]) OR ((C)[subtype] AND (NSI)[phenotype]) to the single request (C)[subtype] AND (NSI SI)[phenotype] however. The operators C<&> and C<|> are overloaded to C and C, to get Perl precedence and grouping for free. C is overloaded to get symbolic tests such as C. C<==> is overloaded with C for convenience. No overloading is done for C or C. =cut # a query algebra for HIVQuery # # Each Q object is an 'atomic' query, written as (data)[field] # (a b ...)[X] equals (a)[X] | (b)[X] | ... # Each R object represents a single HTTP request to the db # contains an array of Q (atomic) objects (q1, q2, ...) # the R object is interpreted as q1 & q2 & ... # Each QRY object represents a series of HTTP requests to the db # contains an array of R (request) objects (R1, R2, ...) # the QRY object is interpreted as R1 | R2 | ... # # & and | operations are specified for each type package # hide from PAUSE QRY; use strict; $QRY::NULL = new QRY(); use overload "|" => \&Or, "&" => \&And, "bool" => \&Bool, "==" => \&Eq; # query language emulator # supports only AND and OR, any groupings # # syntax rules: # query atom: bareword [field] OR (bareword ...) [field] # only single bareword allowed between [] # annotation fields in {} (only bareword lists allowed between {}) # () can group query atoms joined by operators (AND or OR) # () containing only barewords MUST be followed by a field descriptor [field] # empty [] not allowed # query atoms joined with AND by default # barewords are associated (ORed within) the next field descriptor in the line # follow the parse tree, creating new QRY objects as needed in @q, and # construct a logical expression using & and | symbols. # These are overloaded for doing ands and ors on QRY objects; # to get the final QRY object, eval the resulting expression $q_expr. # QRY object will be translated into (possibly multiple) hashes # conforming to HIVQuery parameter requirements. =head4 QRY _make_q Title : _make_q Usage : QRY::_make_q($parsetree) Function: creates hash structures suitable for HIVQuery from parse tree returned by QRY::_parse_q Example : Returns : array of hashrefs of query specs Args : a hashref =cut sub _make_q { my $ptree = shift; my ($q_expr, @q, @an, $query, @dbq); _make_q_guts($ptree, \$q_expr, \@q, \@an); $query = eval $q_expr; throw Bio::Root::Root(-class=>'Bio::Root::Exception', -text=>$@, -value=>$q_expr) if $@; return {} if $query->isnull; foreach my $rq ($query->requests) { my $h = {'query'=>{}}; foreach ($rq->atoms) { my @d = split(/\s+/, $_->dta); foreach my $d (@d) { $d =~ s/[+]/ /g; ###! _ to [+] $d =~ s/'//g; } $h->{'query'}{$_->fld} = (@d == 1) ? $d[0] : [@d]; } $h->{'annot'} = [@an] if @an; push @dbq, $h; } return @dbq; } =head4 QRY _make_q_guts Title : _make_q_guts (Internal class method) Usage : _make_q_guts($ptree, $q_expr, $qarry, $anarry) Function: traverses the parse tree returned from QRY::_parse_q, checking syntax and creating HIVQuery-compliant query structures Example : Returns : Args : $parse_tree (hashref), $query_expression (scalar string ref), $query_array (array ref : stack for returning query structures), $annotation_array (array ref : stack for returning annotation fields) =cut sub _make_q_guts { my ($ptree, $q_expr, $qarry, $anarry) = @_; my (@words, $o); eval { # catch foreach (@{$ptree->{cont}}) { m{^AND$} && do { $$q_expr .= "&"; next; }; m{^OR$} && do { $$q_expr .= "|"; next; }; m{^HASH} && do { for my $dl ($_->{delim}) { ($dl =~ m{\(}) && do { if (grep /^HASH/, @{$_->{cont}}) { $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/); $$q_expr .= "("; _make_q_guts($_,$q_expr,$qarry,$anarry); $$q_expr .= ")"; } else { my @c; my $c = join(' ',@{$_->{cont}}); $c =~ s/,/ /g; Bio::Root::Root->throw("query syntax error: unmatched ['\"]") if (@c = ($c =~ /(['"])/g)) % 2; @c = split(/\s*(['"])\s*/, $c); do { $c = shift @c; if ($c =~ m{['"]}) { $c = join('', ($c, shift @c, shift @c)); $c =~ s/\s+/+/g; ###! _ to + push @words, $c; } else { push @words, split(/\s+/,$c); } } while @c; } last; }; ($dl =~ m{\[}) && do { Bio::Root::Root->throw("syntax error: empty field descriptor") unless @{$_->{cont}}; Bio::Root::Root->throw("syntax error: more than one field descriptor in square brackets") unless @{$_->{cont}} == 1; push @{$qarry}, new QRY( new R( new Q( $_->{cont}->[0], @words))); # add default operation if nec $$q_expr .= "&" unless !$$q_expr || !length($$q_expr) || (substr($$q_expr, -1, 1) =~ /[&|(]/); $$q_expr .= "\$q[".$#$qarry."]"; @words = (); last; }; ($dl =~ m{\{}) && do { foreach my $an (@{$_->{cont}}) { ($an =~ /^HASH/) && do { if ($an->{delim} eq '[') { push @$anarry, @{$an->{cont}}; } else { Bio::Root::Root->throw("query syntax error: only field descriptors (with or without square brackets) allowed in annotation spec"); } next; }; do { #else push @$anarry, $an; next; }; } last; }; do { 1; #else stub }; } next; }; do { # else, bareword if ($o) { $words[-1] .= "+$_"; ####! _ to + } else { push @words, $_; } m/['"]/ && ($o = !$o); }; } # @{ptree->{cont}} Bio::Root::Root->throw("query syntax error: no search fields specified") unless $$q_expr =~ /q\[[0-9]+\]/; }; $@ ? throw Bio::Root::Root(-class=>'Bio::QueryStringSyntax::Exception', -text=>$@, -value=>$$q_expr) : return 1; } =head4 QRY _parse_q Title : _parse_q Usage : QRY::_parse_q($query_string) Function: perform first pass parse of a query string with some syntax checking, return a parse tree suitable for QRY::_make_q Example : QRY::_parse_q(" to[be] OR (not to)[be] "); Returns : hashref Args : query string =cut # parse qry string into a branching tree structure # each branch tagged by the opening delimiter ( key 'delim' ) # content (tokens and subbranch hashes) placed in l2r order in # @{p->{cont}} sub _parse_q { local $_; my $qstr = shift; my $illegal = qr/[^a-zA-Z0-9-_<>=,\.\(\[\{\}\]\)\s'"]/; my $pdlm = qr/[\{\[\(\)\]\}]/; my %md = ('('=>')', '['=>']','{'=>'}'); my @tok = grep !/^\s*$/, split /($pdlm)/, $qstr; return {} unless @tok; my @pstack = (); my @dstack = (); my ($ptree, $p); eval { #catch Bio::Root::Root->throw("query syntax error: illegal character") if $qstr =~ /$illegal/; $ptree = $p = {'delim'=>'*'}; foreach (@tok) { #trim whsp s/^\s+//; s/\s+$//; m{[\(\[\{]} && do { my $new = {'delim'=>$_}; $p->{cont} = [] unless $p->{cont}; push @{$p->{cont}}, $new; push @pstack, $p; push @dstack, $_; $p = $new; next; }; m{[\)\]\}]} && do { my $d = pop @dstack; if ($md{$d} eq $_) { $p = pop @pstack; Bio::Root::Root->throw("query syntax error: unmatched \"$_\"") unless $p; } else { Bio::Root::Root->throw("query syntax error: saw \"$_\" before matching \"$md{$d}\""); } next; }; do { # else $p->{cont} = [] unless $p->{cont}; push @{$p->{cont}}, split(/\s+/); }; } }; $@ ? throw Bio::Root::Root(-class=>'Bio::QueryStringSyntax::Exception', -text=>$@, -value=>"") : return $ptree; } ## QRY constructor =head3 QRY CONSTRUCTOR =head4 QRY Constructor Title : QRY constructor Usage : $QRY = new QRY() Function: Example : Returns : Args : array of R objects, optional =cut sub new { my $class = shift; my @args = @_; my $self = {}; $self->{requests} = []; bless($self, $class); $self->put_requests(@args) if @args; return $self; } ## QRY instance methods =head3 QRY INSTANCE METHODS =head4 QRY requests Title : requests Usage : $QRY->requests Function: get/set array of requests comprising this QRY object Example : Returns : Args : array of class R objects =cut sub requests { my $self = shift; $self->put_requests(@_) if @_; return @{$self->{'requests'}}; } =head4 QRY put_requests Title : put_requests Usage : $QRY->put_request(@R) Function: add object of class R to $QRY Example : Returns : Args : [an array of] of class R object[s] =cut sub put_requests { my $self = shift; my @args = @_; foreach (@args) { Bio::Root::Root->throw('requires type R (request)') unless ref && $_->isa('R'); push @{$self->{requests}}, $_; } return @args; } =head4 QRY isnull Title : isnull Usage : $QRY->isnull Function: test if QRY object is null Example : Returns : 1 if null, 0 otherwise Args : =cut sub isnull { my $self = shift; return ($self->requests) ? 0 : 1; } =head4 QRY A Title : A Usage : print $QRY->A Function: get a string representation of QRY object Example : Returns : string scalar Args : =cut sub A { my $self = shift; return join( "\n", map {$_->A} $self->requests ); } =head4 QRY len Title : len Usage : $QRY->len Function: get number of class R objects contained by QRY object Example : Returns : scalar Args : =cut sub len { my $self = shift; return scalar @{$self->{'requests'}}; } =head4 QRY clone Title : clone Usage : $QRY2 = $QRY1->clone; Function: create and return a clone of the object Example : Returns : object of class QRY Args : =cut sub clone { local $_; my $self = shift; my $ret = QRY->new(); foreach ($self->requests) { $ret->put_requests($_->clone); } return $ret; } ## QRY class methods =head3 QRY CLASS METHODS =head4 QRY Or Title : Or Usage : $QRY3 = QRY::Or($QRY1, $QRY2) Function: logical OR for QRY objects Example : Returns : a QRY object Args : two class QRY objects =cut sub Or { local $_; my ($q, $r, $rev_f) = @_; Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY'); Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY'); if ($q->isnull) { return $r->clone; } elsif ($r->isnull) { return $q->clone; } do {my $qq = $q; $q=$r; $r=$qq} if ($q->len > $r->len); my @rq_r = $r->requests; my @rq_q = $q->requests; my (@cand_rq, @ret_rq); # search for simplifications my @now = @rq_q; my @nxt =(); foreach (@rq_r) { my $found = 0; while (my $rq = pop @now) { my @result = R::Or($rq, $_); if (@result==1) { push @cand_rq, $result[0]->clone; $found = 1; last; } else { push @nxt, $rq; } } push @cand_rq, $_->clone unless ($found); # @now becomes unexamined @rq_q's plus failed @rq_q's @now = (@now, @nxt); } push @cand_rq, map {$_->clone} @now; # add all failed @rq_q's # squeeze out redundant requests while (my $rq = pop @cand_rq) { push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq; } return new QRY( @ret_rq ); } =head4 QRY And Title : And Usage : $QRY3 = QRY::And($QRY1, $QRY2) Function: logical AND for QRY objects Example : Returns : a QRY object Args : two class QRY objects =cut sub And { my ($q, $r, $rev_f) = @_; Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY'); Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY'); return ($QRY::NULL) if ($q->isnull || $r->isnull); my (@cand_rq, @ret_rq); foreach my $rq_r ($r->requests) { foreach my $rq_q ($q->requests) { my ($rq) = R::And($rq_r, $rq_q); push @cand_rq, $rq unless $rq->isnull; } } return $QRY::NULL unless @cand_rq; # squeeze out redundant requests while (my $rq = pop @cand_rq) { push @ret_rq, $rq unless @cand_rq && grep {R::Eq($rq, $_)} @cand_rq; } return new QRY( @ret_rq ); } =head4 QRY Bool Title : Bool Usage : QRY::Bool($QRY1) Function: allows symbolic testing of QRY object when bool overloaded Example : do {stuff} if $QRY1 *same as* do {stuff} if !$QRY1->isnull Returns : Args : a class QRY object =cut sub Bool { my $q = shift; Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY'); return $q->isnull ? 0 : 1; } =head4 QRY Eq Title : Eq Usage : QRY::Eq($QRY1, $QRY2) Function: test if R objects in two QRY objects are the same (irrespective of order) Example : Returns : 1 if equal, 0 otherwise Args : two class QRY objects =cut sub Eq { my ($q, $r, $rev_f) = @_; Bio::Root::Root->throw('requires type QRY') unless ref($q) && $q->isa('QRY'); Bio::Root::Root->throw('requires type QRY') unless ref($r) && $r->isa('QRY'); return 0 unless $q->len == $r->len; foreach my $rq_q ($q->requests) { my $found = 0; foreach my $rq_r ($r->requests) { if (R::Eq($rq_q,$rq_r)) { $found = 1; last; } } return 0 unless $found; } return 1; } 1; =head2 Class R - request objects for QRY algebra =head3 R SYNOPSIS $R = new R( $q1, $q2 ); $R->put_atoms($q3); $R->del_atoms('coreceptor', 'phenotype'); return $R->clone; $R1 = new R( new Q('subtype', 'B') ); $R2 = new R( new Q('subtype', 'B C'), new Q('country', 'US') ); R::Eq( (R::And($R1, $R2))[0], new R( new Q('subtype', 'B' ), new Q('country', 'US') )); # returns 1 QRY::Eq( new QRY(R::Or($R1, $R2)), new QRY($R1, $R2) ); # returns 1 R::In( (R::And($R1, $R2))[0], $R1 ); # returns 1 =head3 R DESCRIPTION Class R objects contain a list of atomic queries (class Q objects). Each class R object represents a single HTTP request to the LANL DB. When converted to a DB query, the class Q objects contained by an R object are effectively Ced. =cut package # hide from PAUSE R; use strict; $R::NULL = R->new(); ## R constructor =head3 R CONSTRUCTOR =head4 R constructor Title : R constructor Usage : $R = new R() Function: create a new R (request) object Example : Returns : class R (request) object Args : optional, array of class Q objects =cut sub new { my $class = shift; my @args = @_; my $self = {}; $self->{atoms} = {}; bless($self, $class); $self->put_atoms(@args) if @args; return $self; } ## R instance methods =head3 R INSTANCE METHODS =head4 R len Title : len Usage : $R->len Function: get number of class Q objects contained in R object Example : Returns : scalar Args : =cut sub len { my $self = shift; return scalar @{[keys %{$self->{'atoms'}}]}; } =head4 R atoms Title : atoms Usage : $R->atoms( [optional $field]) Function: get array of class Q (atomic query) objects in class R object Example : $R->atoms(); $R->atoms('coreceptor') Returns : array of class Q objects (all Qs or those corresponding to $field if present) Args : optional, scalar string =cut sub atoms { local $_; # returns an array of atoms # no arg: all atoms; # args: atoms with specified fields my $self = shift; my @flds = (@_ ? @_ : keys %{$self->{'atoms'}}); return wantarray ? map { $self->{'atoms'}->{$_} } @flds : $self->{'atoms'}->{$flds[0]}; } =head4 R fields Title : fields Usage : $R->fields Function: get array of fields of all Q objects contained in $R Example : Returns : array of scalars Args : =cut sub fields { my $self = shift; return keys %{$self->{'atoms'}}; } =head4 R put_atoms Title : put_atoms Usage : $R->put_atoms( @q ) Function: AND an atomic query (class Q object) to the class R object's list Example : Returns : void Args : an [array of] class Q object[s] =cut sub put_atoms { # AND this atom to the request local $_; my $self = shift; my @args = @_; foreach (@args) { Bio::Root::Root->throw('requires type Q (atom)') unless ref && $_->isa('Q'); if ($self->atoms($_->fld)) { my $a = Q::qand( $self->atoms($_->fld), $_ ); if ($a->isnull) { delete $self->{'atoms'}->{$_->fld}; } else { $self->{atoms}->{$_->fld} = $a->clone; } } else { $self->{atoms}->{$_->fld} = $_->clone; } } return; } =head4 R del_atoms Title : del_atoms Usage : $R->del_atoms( @qfields ) Function: removes class Q objects from R object's list according to the field names given in arguments Example : Returns : the class Q objects deleted Args : scalar array of field names =cut sub del_atoms { # remove atoms by field from request local $_; my $self = shift; my @args = @_; return () unless @args; my @ret; foreach (@args) { push @ret, delete $self->{'atoms'}->{$_}; } return @ret; } =head4 R isnull Title : isnull Usage : $R->isnull Function: test if class R object is null Example : Returns : 1 if null, 0 otherwise Args : =cut sub isnull { my $self = shift; return ($self->len) ? 0 : 1; } =head4 R A Title : A Usage : print $R->A Function: get a string representation of class R object Example : Returns : string scalar Args : =cut sub A { my $self = shift; my @a = sort {$a->fld cmp $b->fld} $self->atoms; return join(" ", map {$_->A} @a); } =head4 R clone Title : clone Usage : $R2 = $R1->clone; Function: create and return a clone of the object Example : Returns : object of class R Args : =cut sub clone { local $_; my $self = shift; my $ret = R->new(); foreach ($self->atoms) { $ret->put_atoms($_->clone); } return $ret; } ## R class methods =head3 R CLASS METHODS =head4 R In Title : In Usage : R::In($R1, $R2) Function: tests whether the query represented by $R1 would return a subset of items returned by the query represented by $R2 Example : print "R2 gets those and more" if R::In($R1, $R2); Returns : 1 if R1 is subset of R2, 0 otherwise Args : two class R objects =cut sub In { local $_; my ($s, $t) = @_; Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R'); Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R'); return 1 if ($s->isnull); # common fields my @cf = grep {defined} map {my $f=$_; grep /^$f$/,$s->fields} $t->fields; return 0 unless @cf==$t->len; foreach (@cf) { my @sd = split(/\s+/, $s->atoms($_)->dta); my @td = split(/\s+/, $t->atoms($_)->dta); my @cd = grep {defined} map {my $d=$_; grep /^$d$/, @td} @sd; return 0 unless @cd==@sd; } return 1; } =head4 R And Title : And Usage : @Rresult = R::And($R1, $R2) Function: logical AND for R objects Example : Returns : an array containing class R objects Args : two class R objects =cut sub And { local $_; my ($s, $t) = @_; Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R'); Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R'); return ($R::NULL) if ($s->isnull || $t->isnull); do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len ); # $t has at least as many fields defined than $s ($t is more restrictive) # common fields my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields; my $ret = R->new(); my $v = $t->clone; $v->del_atoms(@cf); my $u = $s->clone; $u->del_atoms(@cf); # And the atoms with identical fields foreach (@cf) { my ($a) = Q::qand($s->atoms($_), $t->atoms($_)); if ($a->isnull) { return $R::NULL; } else { $ret->put_atoms($a); } } # put the private atoms $ret->put_atoms($u->atoms, $v->atoms); return ($ret); } =head4 R Or Title : Or Usage : @Rresult = R::Or($R1, $R2) Function: logical OR for R objects Example : Returns : an array containing class R objects Args : two class R objects =cut sub Or { local $_; my ($s, $t) = @_; Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R'); Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R'); if ($s->isnull) { return $t->clone; } elsif ($t->isnull) { return $s->clone; } return $s->clone if (R::In($t, $s)); return $t->clone if (R::In($s, $t)); # try simplifying do { my $ss = $s; $s = $t; $t = $ss } if ( $s->len > $t->len ); # common fields my @cf = grep {defined} map {my $sf = $_; grep /$sf/, $t->fields } $s->fields; # if ($t->len == @cf) { # all atoms equal within fields but one? If yes, simplify... my @df = grep {!Q::qeq($s->atoms($_), $t->atoms($_))} @cf; if (@df == 1) { my ($a) = Q::qor($s->atoms($df[0]), $t->atoms($df[0])); my $ret = $s->clone; $ret->del_atoms($df[0]); $ret->put_atoms($a); return ($ret); } } # neither request contains the other, and the requests cannot be # simplified; reflect back (clones of) the input... return ($s->clone, $t->clone); } =head4 R Eq Title : Eq Usage : R::Eq($R1, $R2) Function: test if class Q objects in two R objects are the same (irrespective of order) Example : Returns : 1 if equal, 0 otherwise Args : two class R objects =cut sub Eq { local $_; my ($s, $t) = @_; Bio::Root::Root->throw('requires type R (request)') unless ref($s) && $s->isa('R'); Bio::Root::Root->throw('requires type R (request)') unless ref($t) && $t->isa('R'); my @sf = $s->fields; my @tf = $t->fields; return 0 unless @sf==@tf; my @cf = grep {defined} map {my $f=$_; grep /^$f$/,@sf} @tf; return 0 unless @cf==@tf; foreach (@cf) { return 0 unless Q::qeq($s->atoms($_), $t->atoms($_)); } return 1; } 1; =head2 Class Q - atomic query objects for QRY algebra =head3 Q SYNOPSIS $q = new Q('coreceptor', 'CXCR4 CCR5'); $u = new Q('coreceptor', 'CXCR4'); $q->fld; # returns 'coreceptor' $q->dta; # returns 'CXCR4 CCR5' print $q->A; # prints '(CXCR4 CCR5)[coreceptor] Q::qeq($q, $u); # returns 0 Q::qeq( Q::qor($q, $q), $q ); # returns 1 Q::qin($u, $q) # returns 1 Q::qeq(Q::qand($u, $q), $u ); # returns 1 =head3 Q DESCRIPTION Class Q objects represent atomic queries, that can be described by a single LANL cgi parameter=value pair. Class R objects (requests) are built from class Qs. The logical operations at the higher levels (C) ultimately depend on the lower level operations on Qs: C. =cut package # hide from PAUSE Q; use strict; $Q::NULL = Q->new(); ## Q constructor =head3 Q CONSTRUCTOR =head4 Q constructor Title : Q constructor Usage : $q = new Q($field, $data) Function: create a new Q (atomic query) object Example : Returns : class Q object Args : optional $field, $data strings =cut sub new { local $_; my ($class,@args) = @_; my $self={}; foreach (@args) { s/^\s+//; s/\s+$//; } my ($fld, @dta) = @args; $self->{fld}=$fld; $self->{dta}=join(" ", @dta); bless($self, $class); return $self; } ## Q instance methods =head3 Q INSTANCE METHODS =head4 Q isnull Title : isnull Usage : $q->isnull Function: test if class Q object is null Example : Returns : 1 if null, 0 otherwise Args : =cut sub isnull { my $self = shift; Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q'); return 1 unless (($self->fld && length($self->fld)) || ($self->dta && length($self->dta))); return 0; } =head4 Q fld Title : fld Usage : $q->fld($field) Function: get/set fld (field name) property Example : Returns : scalar Args : scalar =cut sub fld { my $self = shift; Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q'); my $f = shift; if ($f) { $f =~ s/^\s+//; $f =~ s/\s+$//; return $self->{fld}=$f; } return $self->{fld}; } =head4 Q dta Title : dta Usage : $q->dta($data) Function: get/set dta (whsp-separated data string) property Example : Returns : scalar Args : scalar =cut sub dta { my $self = shift; Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q'); my $d = join(" ", @_); if ($d) { $d =~ s/^\s+//; $d =~ s/\s+$//; return $self->{dta} = $d; } return $self->{dta}; } =head4 Q A Title : A Usage : print $q->A Function: get a string representation of class Q object Example : Returns : string scalar Args : =cut sub A { my $self = shift; Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q'); my @a = split(/\s+/, $self->dta); return "(".join(' ', sort {$a cmp $b} @a).")[".$self->fld."]"; } =head4 Q clone Title : clone Usage : $q2 = $q1->clone; Function: create and return a clone of the object Example : Returns : object of class Q Args : =cut sub clone { my $self = shift; Bio::Root::Root->throw("requires type Q (atom)") unless ref($self) && $self->isa('Q'); my $ret = Q->new($self->fld, $self->dta); return $ret; } ### Q class methods =head3 Q CLASS METHODS =head4 Q qin Title : qin Usage : Q::qin($q1, $q2) Function: tests whether the query represented by $q1 would return a subset of items returned by the query represented by $q2 Example : print "q2 gets those and more" if Q::qin($q1, $q2); Returns : 1 if q1 is subset of q2, 0 otherwise Args : two class Q objects =cut sub qin { my ($a, $b) = @_; Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q'); return 0 unless $a->fld eq $b->fld; return Q::qeq( $b, Q::qor($a, $b) ); } =head4 Q qeq Title : qeq Usage : Q::qeq($q1, $q2) Function: test if fld and dta properties in two class Q objects are the same (irrespective of order) Example : Returns : 1 if equal, 0 otherwise Args : two class Q objects =cut sub qeq { local $_; my ($a, $b) = @_; Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q'); return 0 unless $a->fld eq $b->fld; my @ad = unique(split(/\s+/,$a->dta)); my @bd = unique(split(/\s+/,$b->dta)); return 0 unless @ad==@bd; my @cd = grep {defined} map {my $f = $_; grep /^$f$/, @ad} @bd; return @cd == @bd; } =head4 Q qor Title : qor Usage : @qresult = Q::qor($q1, $q2) Function: logical OR for Q objects Example : Returns : an array of class Q objects Args : two class Q objects =cut sub qor { local $_; my @a = @_; foreach (@a) { Bio::Root::Root->throw("requires type Q (atom)") unless ref && $_->isa('Q'); } my @ret; my (%f, @f); @a = grep {!$_->isnull} @a; return ($Q::NULL) unless @a > 0; # list of unique flds @f = unique(map {$_->fld} @a); foreach my $f (@f) { my @fobjs = grep {$_->fld eq $f} @a; my @d = unique(map {split(/\s/, $_->dta)} @fobjs ); my $r = Q->new($f, @d); push @ret, $r; } return @ret; } =head4 Q qand Title : qand Usage : @qresult = Q::And($q1, $q2) Function: logical AND for R objects Example : Returns : an array of class Q objects Args : two class Q objects =cut sub qand { local $_; my ($a, $b) = @_; Bio::Root::Root->throw('requires type Q (atom)') unless (ref $a) && $a->isa('Q') && (ref $b) && $b->isa('Q'); my @ret; if (ref $a eq 'ARRAY') { foreach my $ea (@$a) { push @ret, qand( $ea, $b ); } return qor(@ret); # simplify } elsif (ref $b eq 'ARRAY') { foreach my $eb (@$b) { push @ret, qand( $a, $eb); 1; } return qor(@ret); # simplify } else { return ($Q::NULL) if ($a->isnull || $b->isnull); if ($a->fld eq $b->fld) { # find intersection of data my (%ad, @ad, @bd); @ad = split(/\s+/, $a->dta); @ad{@ad} = (1) x @ad; @bd = split(/\s+/, $b->dta); foreach (@bd) { $ad{$_}++; } my $r = Q->new($a->fld, grep {$_} map {$ad{$_} == 2 ? $_ : undef} keys %ad); return (length($r->dta) > 0) ? ($r) : ($Q::NULL); } else { return ($a, $b); } } } =head3 Q INTERNALS =head4 Q unique Title : unique Usage : @ua = unique(@a) Function: return contents of @a with duplicates removed Example : Returns : Args : an array =cut sub unique { my @a = @_; my %a; @a{@a} = undef; return keys %a; } 1; =head2 Additional tools for Bio::AnnotationCollectionI =head3 Bio::AnnotationCollectionI SYNOPSIS (additional methods) $seq->annotation->put_value('patient_id', 1401) $seq->annotation->get_value('patient_ids') # returns 1401 $seq->annotation->put_value('patient_group', 'MassGenH') $seq->annotation->put_value(['clinical', 'cd4count'], 503); $seq->annotation->put_value(['clinical', 'virus_load'], 150805); foreach ( qw( cd4count virus_load ) ) { $blood_readings{$_} = $seq->annonation->get_value(['clinical', $_]); } =head3 Bio::AnnotationCollectionI DESCRIPTION (additional methods) C and C allow easy creation of and access to an annotation collection tree with nodes of L. These methods obiviate direct accession of the SimpleValue objects. =cut package Bio::AnnotationCollectionI; use strict; use Bio::Annotation::SimpleValue; =head2 get_value Title : get_value Usage : $ac->get_value($tagname) -or- $ac->get_value( $tag_level1, $tag_level2,... ) Function: access the annotation value assocated with the given tags Example : Returns : a scalar Args : an array of tagnames that descend into the annotation tree =cut sub get_value { local $_; my $self = shift; my @args = @_; my @h; return "" unless @_; while ($_ = shift @args) { @h = $self->get_Annotations($_); if (ref($h[0]->{value})) { $self = $h[0]->{value}; # must be another Bio::AnnotationCollectionI } else { last; } } return $h[0] && $h[0]->{value} ; # now the last value. } =head2 put_value Title : put_value Usage : $ac->put_value($tagname, $value) -or- $ac->put_value([$tag_level1, $tag_level2, ...], $value) -or- $ac->put_value( [$tag_level1, $tag_level2, ...] ) Function: create a node in an annotation tree, and assign a scalar value to it if a value is specified Example : Returns : scalar or a Bio::AnnotationCollection object Args : $tagname, $value scalars (can be specified as -KEYS=>$tagname, -VALUE=>$value) -or- \@tagnames, $value (or as -KEYS=>\@tagnames, -VALUE=>$value ) Note : If intervening nodes do not exist, put_value creates them, replacing existing nodes. So if $ac->put_value('x', 10) was done, then later, $ac->put_value(['x', 'y'], 20), the original value of 'x' is trashed, and $ac->get_value('x') will now return the annotation collection with tagname 'y'. =cut sub put_value { local $_; my $self = shift; my @args = @_; my ($keys, $value) = $self->_rearrange([qw( KEYS VALUE )], @args); my (@keys, $lastkey); # $value ||= new Bio::Annotation::Collection; @keys = (ref($keys) eq 'ARRAY') ? @$keys : ($keys); $lastkey = pop @keys; foreach (@keys) { my $a = $self->get_value($_); if (ref($a) && $a->isa('Bio::Annotation::Collection')) { $self = $a; } else { # replace an old value $self->remove_Annotations($_) if $a; my $ac = Bio::Annotation::Collection->new(); $self->add_Annotation(Bio::Annotation::SimpleValue->new( -tagname => $_, -value => $ac ) ); $self = $ac; } } if ($self->get_value($lastkey)) { # replace existing value ($self->get_Annotations($lastkey))[0]->{value} = $value; } else { $self->add_Annotation(Bio::Annotation::SimpleValue->new( -tagname=>$lastkey, -value=>$value )); } return $value; } =head2 get_keys Title : get_keys Usage : $ac->get_keys($tagname_level_1, $tagname_level_2,...) Function: Get an array of tagnames underneath the named tag nodes Example : # prints the values of the members of Category 1... print map { $ac->get_value($_) } $ac->get_keys('Category 1') ; Returns : array of tagnames or empty list if the arguments represent a leaf Args : [array of] tagname[s] =cut sub get_keys { my $self = shift; my @keys = @_; foreach (@keys) { my $a = $self->get_value($_); if (ref($a) && $a->isa('Bio::Annotation::Collection')) { $self = $a; } else { return (); } } return $self->get_all_annotation_keys(); } 1; BioPerl-1.6.923/Bio/DB/HIV/lanl-schema.xml000555000765000024 21643212254227323 20043 0ustar00cjfieldsstaff000000000000 author.au_authornumberau_authornumber author_number authornumber author.au_per_idau_per_id per_id(au) per_id author.au_pub_idau_pub_id pub_id(au) location2.loc_descriptionloc_description description(loc) description location2.loc_entryfeaturetypeloc_entryfeaturetype feature_type(loc) entryfeaturetype location2.loc_idloc_id loc_id id location2.loc_se_idloc_se_id se_id(loc) mapimage.mi_se_idmi_se_id map_image(se_id) mapimage.mi_startmi_start mi_start mapimage.mi_stopmi_stop mi_stop max_rec order patient.pat_codepat_code patient_code code patient.pat_commentpat_comment patient_comment patient.pat_ethnicitypat_ethnicity patient_ethnicity ethnicity patient.pat_hla_typepat_hla_type hla_type hla_type patient.pat_id pat_id patient.pat_infection_citypat_infection_city infection_city infection_city patient.pat_infection_countrypat_infection_country infection_country infection_country patient.pat_infection_yearpat_infection_year infection_year infection_year patient.pat_num_seqpat_num_seq #_of_patient_seqs num_seq patient.pat_num_timepointspat_num_timepoints #_of_patient_timepoints num_timepoints patient.pat_progressionpat_progression progression progression patient.pat_projectpat_project project project patient.pat_risk_factorpat_risk_factor risk_factor risk_factor patient.pat_sexpat_sex patient_sex sex patient.pat_speciespat_species host_species species person.per_id per_id person.per_lnameper_lname last_name lname publication.pub_articletitlepub_articletitle title articletitle publication.pub_consortiumpub_consortium consortium consortium publication.pub_id pub_id publication.pub_pubmedentrypub_pubmedentry pubmed_id pubmedentry publication.pub_sourcetitlepub_sourcetitle journal sourcetitle se_pub_link.spl_pub_idspl_pub_id pub_id(spl) pub_id se_pub_link.spl_pubnumberspl_pubnumber publication_number pubnumber se_pub_link.spl_se_idspl_se_id se_id(spl) se_id select_all seq_sample.ssam_amplification_strategyssam_amplification_strategy amplification_strategy amplification_strategy seq_sample.ssam_annotatedssam_annotated annotated annotated seq_sample.ssam_badseqssam_badseq problematic badseq seq_sample.ssam_cd4countssam_cd4count cd4_count cd4count seq_sample.ssam_cd8countssam_cd8count cd8_count cd8count seq_sample.ssam_clone_name_numberssam_clone_name_number clone_name clone_name_number seq_sample.ssam_common_namessam_common_name name common_name seq_sample.ssam_culture_methodssam_culture_method culture_method culture_method seq_sample.ssam_drug_naivessam_drug_naive drug_naive drug_naive seq_sample.ssam_fiebigssam_fiebig fiebig_stage fiebig seq_sample.ssam_health_statusssam_health_status patient_health health_status seq_sample.ssam_isolate_name_numberssam_isolate_name_number isolate_name isolate_name_number seq_sample.ssam_locus_namessam_locus_name locus_name locus_name seq_sample.ssam_molecule_typessam_molecule_type molecule_type molecule_type seq_sample.ssam_organismssam_organism organism organism seq_sample.ssam_pat_idssam_pat_id pat_id(ssam) pat_id seq_sample.ssam_patient_agessam_patient_age patient_age patient_age seq_sample.ssam_phenotypessam_phenotype phenotype phenotype seq_sample.ssam_postendtreatment_daysssam_postendtreatment_days days_from_treatment_end postendtreatment_days seq_sample.ssam_postfirstsample_daysssam_postfirstsample_days days_from_first_sample postfirstsample_days seq_sample.ssam_postinfect_daysssam_postinfect_days days_from_infection postinfect_days seq_sample.ssam_postseroconv_daysssam_postseroconv_days days_from_seroconversion postseroconv_days seq_sample.ssam_poststarttreatment_daysssam_poststarttreatment_days days_from_treatment_start poststarttreatment_days seq_sample.ssam_sample_cityssam_sample_city sampling_city sample_city seq_sample.ssam_sample_countryssam_sample_country country sample_country country seq_sample.ssam_sample_georegionssam_sample_georegion georegion sample_georegion seq_sample.ssam_sample_tissuessam_sample_tissue sample_tissue sample_tissue seq_sample.ssam_sample_yearssam_sample_year sampling_year sample_year year seq_sample.ssam_sample_year_upperssam_sample_year_upper sampling_year_upper sample_year_upper seq_sample.ssam_se_idssam_se_id se_id(ssam) seq_sample.ssam_second_receptorcoreceptor coreceptor ssam_second_receptor second_receptor seq_sample.ssam_sequencing_methodssam_sequencing_method sequencing_method sequencing_method seq_sample.ssam_subtypessam_subtype subtype subtype seq_sample.ssam_viralloadssam_viralload viral_load viralload seqentryfeature.sef_descriptionsef_description description(sef) seqentryfeature.sef_entryfeaturetypesef_entryfeaturetype feature_type(sef) seqentryfeature.sef_pub_idsef_pub_id pub_id(sef) seqentryfeature.sef_se_idsef_se_id se_id(sef) sequenceaccessions.sa_genbankaccessionsa_genbankaccession accession genbankaccession accession sequenceaccessions.sa_gisa_gi gi_number gi sequenceaccessions.sa_se_idsa_se_id se_id(sa) sequenceaccessions.sa_versionsa_version version version sequenceentry.se_db_commentse_db_comment db_comment db_comment comment sequenceentry.se_gb_commentse_gb_comment gb_comment gb_comment sequenceentry.se_gb_createse_gb_create gb_create_date gb_create sequenceentry.se_gb_updatese_gb_update gb_update_date gb_update sequenceentry.se_id se_id sequenceentry.se_sequencese_sequence sequence sequence sequenceentry.se_sequencelengthse_sequencelength sequence_length sequencelength sequencefeature2.sf_featuretypesf_featuretype feature_type(sf) featuretype sequencefeature2.sf_featurevaluesf_featurevalue feature_value(sf) featurevalue sequencefeature2.sf_loc_idsf_loc_id loc_id(sf) sequencemap.sm_se_idsm_se_id se_id(sm) sequencemap.sm_startsm_start start hxb2_start sequencemap.sm_stopsm_stop stop hxb2_stop show_sql sort_dir COMMAND.CLIP COMMAND.genomic_regiongenegenomic_region BioPerl-1.6.923/Bio/DB/Query000755000765000024 012254227324 15405 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/Query/GenBank.pm000444000765000024 2311412254227317 17430 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Query::GenBank.pm # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::DB::Query::GenBank - Build a GenBank Entrez Query =head1 SYNOPSIS use Bio::DB::Query::GenBank; use Bio::DB::GenBank; my $query_string = 'Oryza[Organism] AND EST[Keyword]'; my $query = Bio::DB::Query::GenBank->new(-db => 'nucleotide', -query => $query_string, -mindate => '2001', -maxdate => '2002'); print $query->count,"\n"; # get a Genbank database handle my $gb = Bio::DB::GenBank->new(); my $stream = $gb->get_Stream_by_query($query); while (my $seq = $stream->next_seq) { # do something with the sequence object } # initialize the list yourself my $query = Bio::DB::Query::GenBank->new(-ids=>[195052,2981014,11127914]); =head1 DESCRIPTION This class encapsulates NCBI Entrez queries. It can be used to store a list of GI numbers, to translate an Entrez query expression into a list of GI numbers, or to count the number of terms that would be returned by a query. Once created, the query object can be passed to a Bio::DB::GenBank object in order to retrieve the entries corresponding to the query. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Query::GenBank; use strict; use URI::Escape 'uri_unescape'; use Bio::DB::NCBIHelper; use constant EPOST => $Bio::DB::NCBIHelper::HOSTBASE . '/entrez/eutils/epost.fcgi'; use constant ESEARCH => $Bio::DB::NCBIHelper::HOSTBASE . '/entrez/eutils/esearch.fcgi'; use constant DEFAULT_DB => 'protein'; use constant MAXENTRY => 100; use vars qw(@ATTRIBUTES); use base qw(Bio::DB::Query::WebQuery); BEGIN { @ATTRIBUTES = qw(db reldate mindate maxdate datetype maxids); for my $method (@ATTRIBUTES) { eval <{'_$method'}; \$self->{'_$method'} = shift if \@_; \$d; } END } } =head2 new Title : new Usage : $db = Bio::DB::Query::GenBank->new(@args) Function: create new query object Returns : new query object Args : -db database (see below for allowable values) -query query string -mindate minimum date to retrieve from (YYYY/MM/DD) -maxdate maximum date to retrieve from (YYYY/MM/DD) -reldate relative date to retrieve from (days) -datetype date field to use ('edat' or 'mdat') -ids array ref of gids (overrides query) -maxids the maximum number of IDs you wish to collect (defaults to 100) This method creates a new query object. Typically you will specify a -db and a -query argument, possibly modified by -mindate, -maxdate, or -reldate. -mindate and -maxdate specify minimum and maximum dates for entries you are interested in retrieving, expressed in the form YYYY/MM/DD. -reldate is used to fetch entries that are more recent than the indicated number of days. If you provide an array reference of IDs in -ids, the query will be ignored and the list of IDs will be used when the query is passed to a Bio::DB::GenBank object's get_Stream_by_query() method. A variety of IDs are automatically recognized, including GI numbers, Accession numbers, Accession.version numbers and locus names. By default, the query will collect only the first 100 IDs and will generate an exception if you call the ids() method and the query returned more than that number. To increase this maximum, set -maxids to a number larger than the number of IDs you expect to obtain. This only affects the list of IDs you obtain when you call the ids() method, and does not affect in any way the number of entries you receive when you generate a SeqIO stream from the query. -db option values: The most commonly used databases are: protein nucleotide nuccore nucgss nucest unigene An up to date list of database names supported by NCBI eUtils is always available at: http://eutils.ncbi.nlm.nih.gov/entrez/eutils/einfo.fcgi? However, note that not all of these databases return datatypes that are parsable by Bio::DB::GenBank =cut sub new { my $class = shift; my $self = $class->SUPER::new(@_); my ($query,$db,$reldate,$mindate,$maxdate,$datetype,$ids,$maxids) = $self->_rearrange([qw(QUERY DB RELDATE MINDATE MAXDATE DATETYPE IDS MAXIDS)],@_); $self->db($db || DEFAULT_DB); $reldate && $self->reldate($reldate); $mindate && $self->mindate($mindate); $maxdate && $self->maxdate($maxdate); $maxids && $self->maxids($maxids); $datetype ||= 'mdat'; $datetype && $self->datetype($datetype); $self; } =head2 cookie Title : cookie Usage : ($cookie,$querynum) = $db->cookie Function: return the NCBI query cookie Returns : list of (cookie,querynum) Args : none NOTE: this information is used by Bio::DB::GenBank in conjunction with efetch. =cut sub cookie { my $self = shift; if (@_) { $self->{'_cookie'} = shift; $self->{'_querynum'} = shift; } else { $self->_run_query; @{$self}{qw(_cookie _querynum)}; } } =head2 _request_parameters Title : _request_parameters Usage : ($method,$base,@params = $db->_request_parameters Function: return information needed to construct the request Returns : list of method, url base and key=>value pairs Args : none =cut sub _request_parameters { my $self = shift; my ($method,$base); my @params = map {eval("\$self->$_") ? ($_ => eval("\$self->$_")) : () } @ATTRIBUTES; push @params,('usehistory'=>'y','tool'=>'bioperl'); $method = 'get'; $base = ESEARCH; push @params,('term' => $self->query); # Providing 'retmax' limits queries to 500 sequences ?? I don't think so LS push @params,('retmax' => $self->maxids || MAXENTRY); # And actually, it seems that we need 'retstart' equal to 0 ?? I don't think so LS # push @params, ('retstart' => 0); ($method,$base,@params); } =head2 count Title : count Usage : $count = $db->count; Function: return count of number of entries retrieved by query Returns : integer Args : none Returns the number of entries that are matched by the query. =cut sub count { my $self = shift; if (@_) { my $d = $self->{'_count'}; $self->{'_count'} = shift; return $d; } else { $self->_run_query; return $self->{'_count'}; } } =head2 ids Title : ids Usage : @ids = $db->ids([@ids]) Function: get/set matching ids Returns : array of sequence ids Args : (optional) array ref with new set of ids =cut =head2 query Title : query Usage : $query = $db->query([$query]) Function: get/set query string Returns : string Args : (optional) new query string =cut =head2 _parse_response Title : _parse_response Usage : $db->_parse_response($content) Function: parse out response Returns : empty Args : none Throws : 'unparseable output exception' =cut sub _parse_response { my $self = shift; my $content = shift; if (my ($warning) = $content =~ m!(.+)!s) { $self->warn("Warning(s) from GenBank: $warning\n"); } if (my ($error) = $content =~ /([^<]+)/) { $self->throw("Error from Genbank: $error"); } my ($count) = $content =~ /(\d+)/; my ($max) = $content =~ /(\d+)/; my $truncated = $count > $max; $self->count($count); if (!$truncated) { my @ids = $content =~ /(\d+)/g; $self->ids(\@ids); } else { $self->debug("ids truncated at $max\n"); } $self->_truncated($truncated); my ($cookie) = $content =~ m!(\S+)!; my ($querykey) = $content =~ m!(\d+)!; $self->cookie(uri_unescape($cookie),$querykey); } =head2 _generate_id_string Title : _generate_id_string Usage : $string = $db->_generate_id_string Function: joins IDs together in string (possibly implementation-dependent) Returns : string of concatenated IDs Args : array ref of ids (normally passed into the constructor) =cut sub _generate_id_string { my ($self, $ids) = @_; # this attempts to separate out accs (alphanumeric) from UIDs (numeric only) # recent changes to esearch has wrought this upon us.. cjf 4/19/07 return sprintf('%s',join('|',map { ($_ =~ m{^\d+$}) ? $_.'[UID]' : $_.'[PACC]' } @$ids)); } 1; BioPerl-1.6.923/Bio/DB/Query/HIVQuery.pm000555000765000024 12537112254227316 17631 0ustar00cjfieldsstaff000000000000# to do: support for comment, reference annotations # $Id: HIVQuery.pm 232 2008-12-11 14:51:51Z maj $ # # BioPerl module for Bio::DB::Query::LANLQuery # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Query::HIVQuery - Query interface to the Los Alamos HIV Sequence Database =head1 SYNOPSIS $q = new Bio::DB::Query::HIVQuery(" C[subtype] ZA[country] CXCR4[coreceptor] "); $q = new Bio::DB::Query::HIVQuery( -query=>{'subtype'=>'C', 'country'=>'ZA', 'coreceptor'=>'CXCR4'}); $ac = $q->get_annotations_by_id(($q->ids)[0]); $ac->get_value('Geo', 'country') # returns 'SOUTH AFRICA' $db = new Bio::DB::HIV(); $seqio = $db->get_Stream_by_query($q); # returns annotated Bio::Seqs # get subtype C sequences from South Africa and Brazil, # with associated info on patient health, coreceptor use, and # infection period: $q = new Bio::DB::Query::HIVQuery( -query => { 'query' => {'subtype'=>'C', 'country'=>['ZA', 'BR']}, 'annot' => ['patient_health', 'coreceptor', 'days_post_infection'] }); =head1 DESCRIPTION Bio::DB::Query::HIVQuery provides a query-like interface to the cgi-based Los Alamos National Laboratory (LANL) HIV Sequence Database. It uses Bioperl facilities to capture both sequences and annotations in batch in an automated and computable way. Use with L to create C objects and annotated C streams. =head2 Query format The interface implements a simple query language emulation that understands AND, OR, and parenthetical nesting. The basic query unit is (match1 match2 ...)[fieldname] Sequences are returned for which C equals C. These units can be combined with AND, OR and parentheses. For example: (B, C)[subtype] AND (2000, 2001, 2002, 2003)[year] AND ((CN)[country] OR (ZA)[country]) which can be shortened to (B C)[subtype] (2000 2001 2002 2003)[year] (CN ZA)[country] The user can specify annotation fields, that do not restrict the query, but arrange for the return of the associated field data for each sequence returned. Specify annotation fields between curly braces, as in: (B C)[subtype] 2000[year] {country cd4_count cd8_count} Annotations can be accessed off the query using methods described in APPENDIX. =head2 Hash specifications for query construction Single query specifications can be made as hash references provided to the C<-query> argument of the constructor. There are two forms: -query => { 'country'=>'BR', 'phenotype'=>'NSI', 'cd4_count'=>'Any' } equivalent to -query => [ 'country'=>'BR', 'phenotype'=>'NSI', 'cd4_count'=>'Any' ] or -query => { 'query' => {'country'=>'BR', 'phenotype'=>'NSI'}, 'annot' => ['cd4_count'] } In both cases, the CD4 count is included in the annotations returned, but does not restrict the rest of the query. To 'OR' multiple values of a field, use an anonymous array ref: -query => { 'country'=>['ZA','BR','NL'], 'subtype'=>['A', 'C', 'D'] } =head2 Valid query field names An attempt was made to make the query field names natural and easy to remember. Aliases are specified in an XML file (C) that is part of the distribution. Custom field aliases can be set up by modifying this file. An HTML cheatsheet with valid field names, aliases, and match data can be generated from the XML by using Chelp('help.html')>. A query can also be validated locally before it is unleashed on the server; see below. =head2 Annotations LANL DB annotations have been organized into a number of natural groupings, tagged C, C, C, and C. After a successful query, each id is associated with a tree of L objects. These can be accessed with methods C and C described in APPENDIX. =head2 Delayed/partial query runs Accessing the LANL DB involves multiple HTTP requests. The query can be instructed to proceed through all (the default) or only some of them, using the named parameter C. To validate a query locally, use $q = new Bio::DB::Query::HIVQuery( -query => {...}, -RUN_OPTION=>0 ) which will throw an exception if a field name or option is invalid. To get a query count only, you can save a server hit by using $q = new Bio::DB::Query::HIVQuery( -query => {...}, -RUN_OPTION=>1 ) and asking for C<$q-Ecount>. To finish the query, do $q->_do_query(2) which picks up where you left off. C<-RUN_OPTION=E2>, the default, runs the full query, returning ids and annotations. =head2 Query re-use You can clear the query results, retaining the same LANL session and query spec, by doing C<$q-E_reset>. Change the query, and rerun with C<$q-E_do_query($YOUR_RUN_OPTION)>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj@fortinbras.us =head1 CONTRIBUTORS Mark A. Jensen =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Query::HIVQuery; use strict; use vars qw( $LANL_BASE $LANL_MAP_DB $LANL_MAKE_SEARCH_IF $LANL_SEARCH $SCHEMA_FILE $RUN_OPTION ); # Object preamble - inherits from Bio::DB::QueryI use Bio::Root::Root; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::WebAgent; use XML::Simple; use CGI; use Bio::DB::HIV::HIVQueryHelper; use base qw(Bio::Root::Root Bio::DB::QueryI); # globals BEGIN { # change base to new search page 01/14/09 /maj $LANL_BASE = "http://www.hiv.lanl.gov/components/sequence/HIV/asearch"; $LANL_MAP_DB = "map_db.comp"; $LANL_MAKE_SEARCH_IF = "make_search_if.comp"; $LANL_SEARCH = "search.comp"; $SCHEMA_FILE = Bio::Root::IO->catfile(qw(Bio DB HIV lanl-schema.xml)); $RUN_OPTION = 2; # execute query # exceptions @Bio::SchemaNotInit::Exception::ISA = qw( Bio::Root::Exception ); @Bio::WebError::Exception::ISA = qw( Bio::Root::Exception ); @Bio::QueryNotMade::Exception::ISA = qw( Bio::Root::Exception ); @Bio::QueryStringException::Exception::ISA = qw( Bio::Root::Exception ); @Bio::HIVSorry::Exception::ISA = qw ( Bio::Root::Exception ); } =head1 Constructor =head2 new Title : new Usage : my $hiv_query = new Bio::DB::Query::HIVQuery(); Function: Builds a new Bio::DB::Query::HIVQuery object, running a sequence query against the Los Alamos HIV sequence database Returns : an instance of Bio::DB::Query::HIVQuery Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); # constructor option for web agent parameter spec: added 01/14/09 /maj my ($query, $ids, $lanl_base, $lanl_map_db, $lanl_make_search_if, $lanl_search, $schema_file,$run_option, $uahash) = $self->_rearrange([ qw(QUERY IDS LANL_BASE LANL_MAP_DB LANL_MAKE_SEARCH_IF LANL_SEARCH SCHEMA_FILE RUN_OPTION USER_AGENT_HASH )], @args); # default globals $lanl_base||= $LANL_BASE; $lanl_map_db||=$LANL_MAP_DB; $lanl_make_search_if||=$LANL_MAKE_SEARCH_IF; $lanl_search||=$LANL_SEARCH; $schema_file||=$SCHEMA_FILE; $uahash ||= {timeout => 90}; defined $run_option || ($run_option = $RUN_OPTION); $self->lanl_base($lanl_base); $self->map_db($lanl_map_db); $self->make_search_if($lanl_make_search_if); $self->search_($lanl_search); $self->_run_option($run_option); $self->_ua_hash($uahash); # catch this at the top if (-e $schema_file) { $self->_schema_file($schema_file); } else { # look around my ($p) = $self->_schema_file( [grep {$_} map { my $p = Bio::Root::IO->catfile($_, $schema_file); $p if -e $p } (@INC,"")]->[0]); $self->throw(-class=>"Bio::Root::NoSuchThing", -text=>"Schema file \"".$self->_schema_file."\" cannot be found", -value=>$self->_schema_file) unless -e $self->_schema_file; } $self->count(0); $self->{_schema} = HIVSchema->new($self->_schema_file); # internal storage and flags $self->{'_lanl_query'} = []; $self->{'_lanl_response'} = []; $self->{'_annotations'} = {}; # container for annotation collections assoc. with ids $self->{'_RUN_LEVEL'} = undef; # set in _do_query() # work defined $query && $self->query($query); defined $ids && $self->ids($ids); # exec query $self->_do_query($self->_run_option) if $self->query; return $self; } =head1 QueryI compliance =head2 count Title : count Usage : $hiv_query->count($newval) Function: return number of sequences found Example : Returns : value of count (a scalar) Args : on set, new value (a scalar or undef, optional) Note : count warns if it is accessed for reading before query has been executed to at least level 1 =cut sub count{ my $self = shift; return $self->{'count'} = shift if @_; if (!$self->{'_RUN_LEVEL'} || ($self->{'_RUN_LEVEL'} < 1)) { $self->warn('Query not yet run at > level 1'); } return $self->{'count'}; } =head2 ids Title : ids Usage : $hiv_query->ids($newval) Function: LANL ids of returned sequences Example : Returns : value of ids (an arrayref of sequence accessions/ids) Args : on set, new value (an arrayref or undef, optional) =cut sub ids{ my $self = shift; if (@_) { my $a = shift; $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Arrayref required', -value=> ref $a) unless ref($a) eq 'ARRAY'; if (@$a) { @{$self->{'ids'}}{@$a} = (1) x @$a; return $a; } else { #with empty arrayref, clear the hash $self->{'ids'} = {}; } } return keys %{$self->{'ids'}} if $self->{'ids'}; } =head2 query Title : query Usage : $hiv_query->query Function: Get/set the submitted query hash or string Example : Returns : hashref or string Args : query in hash or string form (see DESCRIPTION) =cut sub query { my $self = shift; return $self->{'query'} = shift if @_; return $self->{'query'}; } =head1 Bio::DB::Query::HIVQuery specific methods =head2 help Title : help Usage : $hiv_query->help("help.html") Function: get html-formatted listing of valid fields/aliases/options based on current schema xml Example : perl -MBio::DB::Query::HIVQuery -e "new Bio::DB::Query::HIVQuery()->help" | lynx -stdin Returns : HTML Args : optional filename; otherwise prints to stdout =cut sub help{ my ($self, $fname) = @_; my (@ret, @tok); my $schema = $self->_schema; my $h = CGI->new(); my (@tbls, @flds, @als, @opts, $fh); if ($fname) { open ($fh, ">", $fname) or $self->throw(-class=>'Bio::Root::IOException', -text=>"Error opening help html file $fname for writing", -value=>$!); } else { open($fh, ">&1"); } @tbls = $schema->tables; @tbls = ('COMMAND', grep !/COMMAND/,@tbls); print $fh ( $h->start_html(-title=>"HIVQuery Help") ); print $fh $h->a({-id=>'TOP'}, $h->h2("Valid HIVQuery query fields and match data")); print $fh "Fields are organized below according to their Los Alamos HIV database tables. Use aliases in place of full field names in queries; for example:
"; print $fh "
(CCR5 CXCR4)[coreceptor]
"; print $fh "rather than"; print $fh "
(CCR5 CXCR4)[seq_sample.ssam_second_receptor]
"; print $fh "(which does work, however). Click hyperlinks to see valid search options within the field. The token Any is the wildcard for all fields.

"; print $fh $h->start_table({-style=>"font-family:sans-serif;"}) ; foreach my $tbl (@tbls) { @flds = grep /^$tbl/, $schema->fields; @flds = grep !/_id/, @flds; print $fh ( $h->start_Tr({-style=>"background-color: lightblue;"}), $h->td([$h->a({-id=>$tbl},$tbl), $h->span({-style=>"font-style:italic"},"fields"), $h->span({-style=>"font-style:italic"}, "aliases")]), $h->end_Tr ); foreach my $fld (@flds) { @als = reverse $schema->aliases($fld); print $fh ( # note that aliases can sometimes be empty $h->Tr( $h->td( ["", $h->a({-href=>"#opt$fld"}, shift @als || '???'), $h->code(join(',',@als))] )) ); my @tmp = grep {$_} $schema->options($fld); @tmp = sort {(($a =~ /^[0-9]+$/) && $b =~ /^[0-9]+$/) ? $a<=>$b : $a cmp $b} @tmp; if (grep /Any/,@tmp) { @tmp = grep !/Any/, @tmp; unshift @tmp, 'Any'; } #print STDERR join(', ',@tmp)."\n"; push @opts, $h->div( {-style=>"font-family:sans-serif;font-size:small"}, $h->hr, $h->a( {-id=>"opt$fld"}, "Valid options for $fld: " ), $h->blockquote( @tmp ? $h->code(join(", ", @tmp)) : $h->i("free text") ), $h->span( "Other aliases: " ), $h->blockquote( @als ? $h->code(join(",",@als)) : "none" ), " ", $h->table( $h->Tr( $h->td([ $h->a({-href=>"#$tbl"}, $h->small('BACK')), $h->a({-href=>"#TOP"}, $h->small('TOP')) ]) ) ) ); } } print $fh $h->end_table; print $fh @opts; print $fh $h->end_html; close($fh); return 1; } =head1 Annotation manipulation methods =head2 get_annotations_by_ids Title : get_annotations_by_ids (or ..._by_id) Usage : $ac = $hiv_query->get_annotations_by_ids(@ids) Function: Get the Bio::Annotation::Collection for these sequence ids Example : Returns : A Bio::Annotation::Collection object Args : an array of sequence ids =cut sub get_annotations_by_ids{ my $self = shift; my @ids = @_; my @ret; if (!$self->{'_RUN_LEVEL'} || ($self->{'_RUN_LEVEL'} < 2)) { $self->warn('Requires query run at level 2'); return (); } @ret = map {$self->{'_annotations'}->{$_}} @ids if exists($self->{'_annotations'}); return (wantarray ? @ret : $ret[0]) if @ret; return {}; } # singular alias sub get_annotations_by_id { shift->get_annotations_by_ids(@_); } =head2 add_annotations_for_id Title : add_annotations_for_id Usage : $hiv_query->add_annotations_for_id( $id ) to create a new empty collection for $id $hiv_query->add_annotations_for_id( $id, $ac ) to associate $ac with $id Function: Associate a Bio::Annotation::Collection with this sequence id Example : Returns : a Bio::Annotation::Collection object Args : sequence id [, Bio::Annotation::Collection object] =cut sub add_annotations_for_id{ my $self = shift; my ($id, $ac) = @_; $id = "" unless defined $id; # avoid warnings $ac = Bio::Annotation::Collection->new() unless defined $ac; $self->throw(-class=>'Bio::Root::BadParameter' -text=>'Bio::Annotation::Collection required at arg 2', -value=>"") unless ref($ac) eq 'Bio::Annotation::Collection'; $self->{'_annotations'}->{$id} = $ac unless exists($self->{'_annotations'}->{$id}); return $ac; } =head2 remove_annotations_for_ids Title : remove_annotations_for_ids (or ..._for_id) Usage : $hiv_query->remove_annotations_for_ids( @ids) Function: Remove annotation collection for this sequence id Example : Returns : An array of the previous annotation collections for these ids Args : an array of sequence ids =cut sub remove_annotations_for_ids { my $self = shift; my @ids = @_; my @ac; foreach (@ids) { push @ac, delete $self->{'_annotations'}->{$_}; } return @ac; } # singular alias sub remove_annotations_for_id { shift->remove_annotations_for_ids(@_); } =head2 remove_annotations Title : remove_annotations Usage : $hiv_query->remove_annotations() Function: Remove all annotation collections for this object Example : Returns : The previous annotation collection hash for this object Args : none =cut sub remove_annotations { my $self = shift; my $ach = $self->{'_annotations'}; $self->{'_annotations'} = {}; return $ach; } =head2 get_value Title : get_value Usage : $ac->get_value($tagname) -or- $ac->get_value( $tag_level1, $tag_level2,... ) Function: access the annotation value assocated with the given tags Example : Returns : a scalar Args : an array of tagnames that descend into the annotation tree Note : this is a L method added in L =cut =head2 put_value Title : put_value Usage : $ac->put_value($tagname, $value) -or- $ac->put_value([$tag_level1, $tag_level2, ...], $value) -or- $ac->put_value( [$tag_level1, $tag_level2, ...] ) Function: create a node in an annotation tree, and assign a scalar value to it if a value is specified Example : Returns : scalar or a Bio::AnnotationCollection object Args : $tagname, $value scalars (can be specified as -KEYS=>$tagname, -VALUE=>$value) -or- \@tagnames, $value (or as -KEYS=>\@tagnames, -VALUE=>$value ) Notes : This is a L method added in L. If intervening nodes do not exist, put_value creates them, replacing existing nodes. So if $ac->put_value('x', 10) was done, then later, $ac->put_value(['x', 'y'], 20), the original value of 'x' is trashed, and $ac->get_value('x') will now return the annotation collection with tagname 'y'. =cut =head2 get_keys Title : get_keys Usage : $ac->get_keys($tagname_level_1, $tagname_level_2,...) Function: Get an array of tagnames underneath the named tag nodes Example : # prints the values of the members of Category 1... print map { $ac->get_value($_) } $ac->get_keys('Category 1') ; Returns : array of tagnames or empty list if the arguments represent a leaf Args : [array of] tagname[s] =cut =head1 GenBank accession manipulation methods =head2 get_accessions Title : get_accessions Usage : $hiv_query->get_accessions() Function: Return an array of GenBank accessions associated with these sequences (available only after a query is subjected to a full run (i.e., when $RUN_OPTION == 2) Example : Returns : array of gb accession numbers, or () if none found for this query Args : none =cut sub get_accessions{ my $self = shift; my @ret; if (!$self->{'_RUN_LEVEL'} || ($self->{'_RUN_LEVEL'} < 2)) { $self->warn('Requires query run at level 2'); return (); } my @ac = $self->get_annotations_by_ids($self->ids); foreach (@ac) { push @ret, $_->get_value('Special','accession'); }; return @ret; } =head2 get_accessions_by_ids Title : get_accessions_by_ids (or ..._by_id) Usage : $hiv_query->get_accessions_by_ids(@ids) Function: Return an array of GenBank accessions associated with these LANL ids (available only after a query is subjected to a full run (i.e., when $RUN_OPTION == 2) Example : Returns : array of gb accession numbers, or () if none found for this query Args : none =cut sub get_accessions_by_ids { my $self = shift; my @ids = @_; my @ret; if (!$self->{'_RUN_LEVEL'} || ($self->{'_RUN_LEVEL'} < 2)) { $self->warn('Requires query run at level 2'); return (); } my @ac = $self->get_annotations_by_ids(@ids); foreach (@ac) { push @ret, $_->get_value('Special', 'accession'); }; return wantarray ? @ret : $ret[0]; } # singular alias sub get_accessions_by_id { shift->get_accessions_by_ids(@_); } ########## =head1 Query control methods =head2 _do_query Title : _do_query Usage : $hiv_query->_do_query or $hiv_query->_do_query($run_level) Function: Execute the query according to argument or $RUN_OPTION and set _RUN_LEVEL extent of query reflects the value of argument 0 : validate only (no HTTP action) 1 : return sequence count only 2 : return sequence ids (full query, returns with annotations) noop if current _RUN_LEVEL of query is >= argument or $RUN_OPTION, Example : Returns : actual _RUN_LEVEL (0, 1, or 2) achieved Args : desired run level (optional, global $RUN_OPTION is default) =cut sub _do_query{ my ($self,$rl) = @_; $rl = $RUN_OPTION unless defined $rl; $self->throw(-class=>"Bio::Root::BadParameter", -text=>"Invalid run option \"$RUN_OPTION\"", -value=>$RUN_OPTION) unless grep /^$RUN_OPTION$/, (0, 1, 2); (!defined($self->{'_RUN_LEVEL'})) && do { $self->_create_lanl_query(); $self->{'_RUN_LEVEL'} = 0; }; ($rl > 0) && (!defined($self->{'_RUN_LEVEL'}) || ($self->{'_RUN_LEVEL'} <= 0)) && do { $self->_do_lanl_request(); $self->{'_RUN_LEVEL'} = 1; }; ($rl > 1) && (!defined($self->{'_RUN_LEVEL'}) || ($self->{'_RUN_LEVEL'} <= 1)) && do { $self->_parse_lanl_response(); $self->{'_RUN_LEVEL'} = 2; }; return $self->{'_RUN_LEVEL'}; } =head2 _reset Title : _reset Usage : $hiv_query->_reset Function: Resets query storage, count, and ids, while retaining session id, original query string, and db schema Example : Returns : void Args : none =cut sub _reset{ my $self = shift; $self->ids([]); $self->count(0); $self->{'_annotations'} = {}; $self->{'_lanl_response'} = []; $self->{'_lanl_query'} = []; $self->{'_RUN_LEVEL'} = undef; return; } =head2 _session_id Title : _session_id Usage : $hiv_query->_session_id($newval) Function: Get/set HIV db session id (initialized in _do_lanl_request) Example : Returns : value of _session_id (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _session_id{ my $self = shift; return $self->{'_session_id'} = shift if @_; return $self->{'_session_id'}; } =head2 _run_level Title : _run_level Usage : $obj->_run_level($newval) Function: returns the level at which the query has so far been run Example : Returns : value of _run_level (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _run_level{ my $self = shift; return $self->{'_RUN_LEVEL'} = shift if @_; return $self->{'_RUN_LEVEL'}; } =head2 _run_option Title : _run_option Usage : $hiv_query->_run_option($newval) Function: Get/set HIV db query run option (see _do_query for values) Example : Returns : value of _run_option (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _run_option{ my $self = shift; return $self->{'_run_option'} = shift if @_; return $self->{'_run_option'}; } =head2 _ua_hash Title : _ua_hash Usage : $obj->_ua_hash($newval) Function: Example : Returns : value of _ua_hash (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _ua_hash{ my $self = shift; if (@_) { for (ref $_[0]) { $_ eq 'HASH' && do { $self->{'_ua_hash'} = $_[0]; last; }; !$_ && do { $self->{'_ua_hash'} = {@_}; last; }; do { $self->throw("Type ".ref($_)." unsupported as arg in _ua_hash"); }; } } return %{$self->{'_ua_hash'}}; } ####### =head1 Internals =head2 add_id Title : add_id Usage : $hiv_query->add_id($id) Function: Add new id to ids Example : Returns : the new id Args : a sequence id =cut sub add_id { my $self = shift; my $id = shift; $id = "" unless defined $id; # avoid warnings ${$self->{'ids'}}{$id}++; return $id; } sub lanl_base{ my $self = shift; return $self->{'lanl_base'} = shift if @_; return $self->{'lanl_base'}; } =head2 map_db Title : map_db Usage : $obj->map_db($newval) Function: Example : Returns : value of map_db (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub map_db{ my $self = shift; return $self->{'map_db'} = shift if @_; return $self->{'map_db'}; } =head2 make_search_if Title : make_search_if Usage : $obj->make_search_if($newval) Function: Example : Returns : value of make_search_if (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub make_search_if{ my $self = shift; return $self->{'make_search_if'} = shift if @_; return $self->{'make_search_if'}; } =head2 search_ Title : search_ Usage : $obj->search_($newval) Function: Example : Returns : value of search_ (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub search_{ my $self = shift; return $self->{'search_'} = shift if @_; return $self->{'search_'}; } =head2 _map_db_uri Title : _map_db_uri Usage : Function: return the full map_db uri ("Database Map") Example : Returns : scalar string Args : none =cut sub _map_db_uri{ my $self = shift; return $self->lanl_base."/".$self->map_db; } =head2 _make_search_if_uri Title : _make_search_if_uri Usage : Function: return the full make_search_if uri ("Make Search Interface") Example : Returns : scalar string Args : none =cut sub _make_search_if_uri{ my $self = shift; return $self->lanl_base."/".$self->make_search_if; } =head2 _search_uri Title : _search_uri Usage : Function: return the full search cgi uri ("Search Database") Example : Returns : scalar string Args : none =cut sub _search_uri{ my $self = shift; return $self->lanl_base."/".$self->search_; } =head2 _schema_file Title : _schema_file Usage : $hiv_query->_schema_file($newval) Function: Example : Returns : value of _schema_file (an XML string or filename) Args : on set, new value (an XML string or filename, or undef, optional) =cut sub _schema_file { my $self = shift; return $self->{'_schema_file'} = shift if @_; return $self->{'_schema_file'}; } =head2 _schema Title : _schema Usage : $hiv_query->_schema($newVal) Function: Example : Returns : value of _schema (an HIVSchema object in package L) Args : none (field set directly in new()) =cut sub _schema{ my $self = shift; $self->{'_schema'} ? return $self->{'_schema'} : $self->throw(-class=>'Bio::SchemaNotInit::Exception', -text=>"DB schema not initialized", -value=>""); } =head2 _lanl_query Title : _lanl_query Usage : $hiv_query->_lanl_query(\@query_parms) Function: pushes \@query_parms onto @{$self->{'_lanl_query'} Example : Returns : value of _lanl_query (an arrayref) Args : on set, new value (an arrayref or undef, optional) =cut sub _lanl_query{ my $self = shift; my $a = shift; return $self->{'_lanl_query'} unless $a; if (ref $a eq 'ARRAY') { push @{$self->{'_lanl_query'}}, $a; return $a; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Array ref required for argument.', -value=>$a); } } =head2 _lanl_response Title : _lanl_response Usage : $hiv_query->_lanl_response($response) Function: pushes $response onto @{$hiv_query->{'_lanl_response'}} Example : Returns : value of _lanl_response (an arrayref of HTTP::Response objects) Args : on set, new value (an HTTP::Response object or undef, optional) =cut sub _lanl_response{ my $self = shift; if (@_) { my $r = shift; $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Requires an HTTP::Response object', -value=> ref $r) unless ref($r) eq 'HTTP::Response'; push @{$self->{'_lanl_response'}}, $r; return $r; } return $self->{'_lanl_response'}; } =head2 _create_lanl_query Title : _create_lanl_query Usage : $hiv_query->_create_lanl_query() Function: validate query hash or string, prepare for _do_lanl_request Example : Returns : 1 if successful; throws exception on invalid query Args : =cut sub _create_lanl_query { my $self = shift; my (%inhash, @query, @qhashes); my ($schema, @validFields, @validAliases); for ($self->query) { !defined && do { $self->throw(-class=>'Bio::Root::NoSuchThing', -text=>'Query not specified', -value=>''); last; }; ref eq 'HASH' && do { %inhash = %$_; if ( grep /HASH/, map {ref} values %inhash ) { # check for {query=>{},annot=>[]} style $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Query style unrecognized', -value=>"") unless defined $inhash{query}; push @qhashes, $_; } last; }; ref eq 'ARRAY' && do { $inhash{'query'} = {@$_}; push @qhashes, \%inhash; last; }; #else do { @qhashes = $self->_parse_query_string($_); }; } $schema = $self->_schema; @validFields = $schema->fields; @validAliases = $schema->aliases; # validate args based on the xml specification file # only checks blanks and fields with explicitly specified options # text fields can put anything, and the query will be run before # an error is caught in these foreach my $qh (@qhashes) { @query=(); foreach my $k (keys %{$$qh{'query'}}) { my $fld; # validate field if (grep /^$k$/, @validFields) { $fld = $k; } elsif (grep /^$k$/, @validAliases) { foreach (@validFields) { if (grep (/^$k$/, $schema->aliases($_))) { $fld = $_; last; } # $fld contains the field corresp. to the alias } } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Invalid field or alias \"$k\"", -value=>$qh); } # validate matchdata my $vf = $schema->_sfieldh($fld); my @md = (ref($qh->{'query'}{$k}) eq 'ARRAY') ? @{$qh->{'query'}{$k}} : $qh->{'query'}{$k}; if ($$vf{type} eq 'text') { foreach (@md) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>'Value for field \"$k\" cannot be empty', -value=>$qh) if ($_ eq "") && ($$vf{blank_ok} eq 'false'); } } elsif ($$vf{type} eq 'option') { foreach my $md (@md) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Invalid value \"".$md."\" for field \"$fld\"", -value=>$md) unless $$vf{option} && grep {defined $_ && /^$md$/} @{$$vf{option}}; } } # validated; add to query foreach (@md) { push @query, ($fld => $_); } } if ($qh->{'annot'}) { # validate the column names to be included in the query # to obtain annotations my @annot_cols = @{$qh->{'annot'}}; foreach my $k (@annot_cols) { my $fld; # validate field if (grep /^$k$/, @validFields) { $fld = $k; } elsif (grep /^$k$/, @validAliases) { foreach (@validFields) { if (grep (/^$k$/, $schema->aliases($_))) { $fld = $_; last; } # $fld should contain the field corresp. to the alias } } else { $self->throw(-class=>'Bio::Root::NoSuchThing', -text=>"Invalid field or alias \"$k\"", -value=>$k); } # lazy: 'Any' may not be the right default (but appears to # be, based on the lanl html) push @query, ($fld => 'Any'); } } # insure that LANL and GenBank ids are retrieved push @query, ('sequenceentry.se_id' => 'Any') unless grep /SequenceEntry\.SE_id/, @query; push @query, ('sequenceaccessions.sa_genbankaccession' => 'Any') unless grep /SequenceAccessions\.SA_GenBankAccession/, @query; # an "order" field is required by the LANL CGI # if not specified, default to SE_id push @query, ('order'=>'sequenceentry.se_id') unless grep /order/, @query; # @query now contains sfield=>matchdata pairs, as specified by user # include appropriate indexes to create correct automatic joins # established by the LANL CGI my (@qtbl, @qpk, @qfk); # the tables represented in query: my %q = @query; # squish the tables in the current query into hash keys @qtbl = $schema->tbl('-s', keys %q); if (@qtbl > 1) { # more than one table, see if they can be connected # get primary keys of query tables @qpk = $schema->pk(@qtbl); # we need to get each query table to join to # SequenceEntry. # # The schema is a graph with tables as nodes and # foreign keys<->primary keys as branches. To get a # join that works, need to include in the query # all branches along a path from SequenceEntry # to each query table. # # find_join does it... my @joink = map { my @k = $schema->find_join($_,'sequenceentry'); map {$_ || ()} @k } @qtbl; # squish the keys in @joink my %j; @j{@joink} = (1) x @joink; @joink = keys %j; # add the fields not currently in the query foreach (@qpk, @joink) { my $fld = $_; if (!grep(/^$fld$/,keys %q)) { # lazy: 'Any' may not be the right default (but appears to # be, based on the lanl html) push @query, ($_ => 'Any'); } } } # set object property $self->_lanl_query([@query]); } return 1; } # _do_lanl_request : post the queries created by _create_lanl_query # # @args (or {@args}) should be unaliased Table.Column=>Matchdata # pairs (these will be used directly in the POSTs) =head2 _do_lanl_request Title : _do_lanl_request Usage : $hiv_query->_do_lanl_request() Function: Perform search request on _create_lanl_query-validated query Example : Returns : 1 if successful Args : =cut sub _do_lanl_request { my $self = shift; my (@queries, @query, @interface,$interfGet,$searchGet,$response); my ($numseqs, $count); # handle args if (!$self->_lanl_query) { $self->throw(-class=>"Bio::Root::BadParameter", -text=>"_lanl_query empty, run _create_lanl_request first", -value=>""); } else { @queries = @{$self->_lanl_query}; } ## utility vars ## search site specific CGI parms my @search_pms = ('action'=>'Search'); my @searchif_pms = ('action'=>'Search Interface'); # don't get the actual sequence data here (i.e., the cgi parm # 'incl_seq' remains undefined... my @download_pms = ('action Download.x'=>1, 'action Download.y'=>1); ## HTML-testing regexps my $tags_re = qr{(?:\s*<[^>]+>\s*)}; my $session_id_re = qr{]*action=".*/search.comp"}; my $seqs_found_re = qr{Displaying$tags_re*(?:\s*[0-9-]*\s*)*$tags_re*of$tags_re*\s*([0-9]+)$tags_re*sequences found}; my $no_seqs_found_re = qr{Sorry.*no sequences found}; my $too_many_re = qr{too many records: $tags_re*([0-9]+)}; my $sys_error_re = qr{[Ss]ystem error}; my $sys_error_extract_re = qr{${tags_re}error:.*?]+>${tags_re}(.*?)
}; # find something like: # tables without join:
SequenceAccessions
my $tbl_no_join_re = qr{tables without join}i; # my $sorry_bud_re = qr{}; foreach my $q (@queries) { @query = @$q; # default query control parameters my %qctrl = ( max_rec=>100, sort_dir=>'ASC', translate=>'FALSE' # nucleotides ); # do work... # pull out commands, designated by the COMMAND pseudo-table... my @commands = map { $query[$_] =~ s/^COMMAND\.// ? @query[$_..$_+1] : () } (0..$#query-1); @query = map { $query[$_] =~ /^COMMAND/ ? () : @query[2*$_..2*$_+1] } (0..($#query-1)/2); # set control parameters explicitly made in query foreach my $cp (keys %qctrl) { if (!grep( /^$cp$/, @query)) { push @query, ($cp, $qctrl{$cp}); } } # note that @interface must be an array, since a single 'key' (the table) # can be associated with multiple 'values' (the columns) in the POST # squish fieldnames into hash keys my %q = @query; @interface = grep {defined} map {my ($tbl,$col) = /^(.*)\.(.*)$/} keys %q; my $err_val = ""; # to contain informative (ha!) value if error is parsed eval { # encapsulate communication errors here, defer biothrows... #mark the useragent should be setable from outside (so we can modify timeouts, etc) my $ua = Bio::WebAgent->new($self->_ua_hash); my $idPing = $ua->get($self->_map_db_uri); $idPing->is_success || do { $response=$idPing; die "Connect failed"; }; # get the session id if (!$self->_session_id) { ($self->{'_session_id'}) = ($idPing->content =~ /$session_id_re/); $self->_session_id || do { $response=$idPing; die "Session not established"; }; } # 10/07/08: # strange bug: if action=>'Search+Interface' below (note "+"), # the response to the search (in $searchGet) shows the correct # >number< of sequences found, but also an error "No sequences # match" and an SQL barf. Changing the "+" to a " " sets up the # interface to lead to the actual sequences being delivered as # expected. maj $interfGet = $ua->post($self->_make_search_if_uri, [@interface, @searchif_pms, id=>$self->_session_id]); $interfGet->is_success || do { $response=$interfGet; die "Interface request failed"; }; # see if a search form was returned... $interfGet->content =~ /$search_form_re/ || do { $response=$interfGet; die "Interface request failed"; }; $searchGet = $ua->post($self->_search_uri, [@query, @commands, @search_pms, id=>$self->_session_id]); $searchGet->is_success || do { $response = $searchGet; die "Search failed"; }; $response = $searchGet; for ($searchGet->content) { /$no_seqs_found_re/ && do { $err_val = 0; die "No sequences found"; last; }; /$too_many_re/ && do { $err_val = $1; die "Too many records ($1): must be <10000"; last; }; /$tbl_no_join_re/ && do { die "Some required tables went unjoined to query"; last; }; /$sys_error_re/ && do { /$sys_error_extract_re/; $err_val = $1; die "LANL system error"; }; /$seqs_found_re/ && do { $numseqs = $1; $count += $numseqs; last; }; # else... do { die "Search failed (response not parsed)"; }; } $response = $ua->post($self->_search_uri, [@download_pms, id=>$self->_session_id]); $response->is_success || die "Query failed"; # $response->content is a tab-separated value table of sequences # and metadata, first line starts with \# and contains fieldnames }; $self->_lanl_response($response); # throw, if necessary if ($@) { ($@ !~ "No sequences found") && do { $self->throw(-class=>'Bio::WebError::Exception', -text=>$@, -value=>$err_val); }; } } $self->warn("No sequences found for this query") unless $count; $self->count($count); return 1; # made it. } =head2 _parse_lanl_response Title : _parse_lanl_response Usage : $hiv_query->_parse_lanl_response() Function: Parse the tab-separated-value response obtained by _do_lanl_request for sequence ids, accessions, and annotations Example : Returns : 1 if successful Args : =cut sub _parse_lanl_response { ### handle parsing and merging multiple responses into the query object ### (ids and annotations) my $self = shift; my ($seqGet) = (@_); my (@data, @cols, %antbl, %antype); my $numseq = 0; my ($schema, @retseqs, %rec, $ac); $schema = $self->_schema; $self->_lanl_response || $self->throw(-class=>"Bio::QueryNotMade::Exception", -text=>"Query not yet performed; call _do_lanl_request()", -value=>""); foreach my $rsp (@{$self->_lanl_response}) { @data = split(/\r|\n/, $rsp->content); my $l; do { $l = shift @data; } while ($l !~ /Number/); $numseq += ( $l =~ /Number.*:\s([0-9]+)/ )[0]; @cols = split(/\t/, shift(@data)); # mappings from column headings to annotation keys # squish into hash keys my %q = @{ shift @{$self->_lanl_query} }; %antbl = $schema->ankh(keys %q); # get the category for each annotation map { $antype{ $_->{ankey} } = $_->{antype} } values %antbl; # normalize column headers map { tr/ /_/; $_ = lc; } @cols; foreach (@data) { @rec{@cols} = split /\t/; my $id = $rec{'se_id'}; $self->add_id($id); $ac = Bio::Annotation::Collection->new(); #create annotations foreach (@cols) { next if $_ eq '#'; my $t = $antype{$_} || "Unclassified"; my $d = $rec{$_}; # the data $ac->put_value(-KEYS=>[$t, $_], -VALUE=>$d); } $self->add_annotations_for_id($id, $ac); } 1; } return 1; # made it. } =head2 _parse_query_string Title : _parse_query_string Usage : $hiv_query->_parse_query_string($str) Function: Parses a query string using query language emulator QRY : in L Example : Returns : arrayref of hash structures suitable for passing to _create_lanl_query Args : a string scalar =cut sub _parse_query_string { my $self = shift; my $qstring = shift; my ($ptree, @ret); #syntax errors thrown in QRY (in HIVQueryHelper module) $ptree = QRY::_parse_q( $qstring ); @ret = QRY::_make_q($ptree); return @ret; } =head1 Dude, sorry- =head2 _sorry Title : _sorry Usage : $hiv_query->_sorry("-president=>Powell") Function: Throws an exception for unsupported option or parameter Example : Returns : Args : scalar string =cut sub _sorry{ my $self = shift; my $parm = shift; $self->throw(-class=>"Bio::HIVSorry::Exception", -text=>"Sorry, option/parameter \"$parm\" not (yet) supported. See manpage to complain.", -value=>$parm); return; } 1; BioPerl-1.6.923/Bio/DB/Query/WebQuery.pm000444000765000024 2145212254227324 17667 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::WebQuery.pm # # Please direct questions and support issues to # # Cared for by Lincoln Stein # # Copyright Lincoln Stein # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # =head1 NAME Bio::DB::Query::WebQuery - Helper class for web-based sequence queryies =head1 SYNOPSIS # Do not use this class directly. See Bio::DB::QueryI and one of # the implementor classes (such as Bio::DB::GenBankQuery) for # information. See L, L =head1 DESCRIPTION Do not use this class directly. See Bio::DB::QueryI and one of the implementor classes (such as Bio::DB::Query::GenBank) for information. Those writing subclasses must define _get_params() and _parse_response(), and possibly override _request_method(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein Email lstein@cshl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Query::WebQuery; use strict; use URI; use LWP::UserAgent; use HTTP::Request::Common; use base qw(Bio::Root::Root Bio::DB::QueryI); =head2 new Title : new Usage : $db = Bio::DB::WebQuery->new(@args) Function: create new query object Returns : new query object Args : -db database (e.g. 'protein') -ids array ref of ids (overrides query) -verbose turn on verbose debugging This method creates a new query object. Typically you will specify a -db and a -query argument. The value of -query is a database-specific string. If you provide an array reference of IDs in -ids, the query will be ignored and the list of IDs will be used when the query is passed to the database. =cut # Borrowed shamelessly from WebDBSeqI. Some of this code should be # refactored. sub new { my $class = shift; my $self = $class->SUPER::new(@_); my ($query,$ids,$verbose) = $self->_rearrange(['QUERY','IDS','VERBOSE'],@_); $self->throw('must provide one of the the -query or -ids arguments') unless defined($query) || defined($ids); if ($ids) { $query = $self->_generate_id_string($ids); } $self->query($query); $verbose && $self->verbose($verbose); my $ua = LWP::UserAgent->new(env_proxy => 1); $ua->agent(ref($self) ."/".($Bio::DB::Query::WebQuery::VERSION || '0.1')); $self->ua($ua); $self->{'_authentication'} = []; $self; } =head2 ua Title : ua Usage : my $ua = $self->ua or $self->ua($ua) Function: Get/Set a LWP::UserAgent for use Returns : reference to LWP::UserAgent Object Args : $ua - must be a LWP::UserAgent =cut sub ua { my ($self, $ua) = @_; my $d = $self->{'_ua'}; if( defined $ua && $ua->isa("LWP::UserAgent") ) { $self->{'_ua'} = $ua; } $d; } =head2 proxy Title : proxy Usage : $httpproxy = $db->proxy('http') or $db->proxy(['http','ftp'], 'http://myproxy' ) Function: Get/Set a proxy for use of proxy Returns : a string indicating the proxy Args : $protocol : an array ref of the protocol(s) to set/get $proxyurl : url of the proxy to use for the specified protocol $username : username (if proxy requires authentication) $password : password (if proxy requires authentication) =cut sub proxy { my ($self,$protocol,$proxy,$username,$password) = @_; return undef if ( !defined $self->ua || !defined $protocol || !defined $proxy ); $self->authentication($username, $password) if ($username && $password); return $self->ua->proxy($protocol,$proxy); } =head2 authentication Title : authentication Usage : $db->authentication($user,$pass) Function: Get/Set authentication credentials Returns : Array of user/pass Args : Array or user/pass =cut sub authentication{ my ($self,$u,$p) = @_; if( defined $u && defined $p ) { $self->{'_authentication'} = [ $u,$p]; } return @{$self->{'_authentication'}}; } =head2 ids Title : ids Usage : @ids = $db->ids([@ids]) Function: get/set matching ids Returns : array of sequence ids Args : (optional) array ref with new set of ids =cut sub ids { my $self = shift; if (@_) { my $d = $self->{'_ids'}; my $arg = shift; $self->{'_ids'} = ref $arg ? $arg : [$arg]; return $d ? @$d : (); } else { $self->_fetch_ids; return @{$self->{'_ids'} || []}; } } =head2 query Title : query Usage : $query = $db->query([$query]) Function: get/set query string Returns : string Args : (optional) new query string =cut sub query { my $self = shift; my $d = $self->{'_query'}; $self->{'_query'} = shift if @_; $d; } =head2 _fetch_ids Title : _fetch_ids Usage : @ids = $db->_fetch_ids Function: run query, get ids Returns : array of sequence ids Args : none =cut sub _fetch_ids { my $self = shift; $self->_run_query; $self->_run_query(1) if $self->_truncated; $self->throw('Id list has been truncated even after maxids requested') if $self->_truncated; return @{$self->{'_ids'}} if $self->{'_ids'}; } =head2 _run_query Title : _run_query Usage : $success = $db->_run_query Function: run query, parse results Returns : true if successful Args : none =cut sub _run_query { my $self = shift; my $force = shift; # allow the query to be run one extra time if truncated return $self->{'_ran_query'} if $self->{'_ran_query'}++ && !$force; my $request = $self->_get_request; $self->debug("request is ".$request->url."\n"); my $response = $self->ua->request($request); return unless $response->is_success; $self->debug("response is ".$response->content."\n"); $self->_parse_response($response->content); 1; } =head2 _truncated Title : _truncated Usage : $flag = $db->_truncated([$newflag]) Function: get/set truncation flag Returns : boolean Args : new flag Some databases will truncate output unless explicitly asked not to. This flag allows a "two probe" attempt. =cut sub _truncated { my $self = shift; my $d = $self->{'_truncated'}; $self->{'_truncated'} = shift if @_; $d; } =head2 _get_request Title : _get_request Usage : $http_request = $db->_get_request(@params) Function: create an HTTP::Request with indicated parameters Returns : HTTP::Request object Args : CGI parameter list =cut sub _get_request { my $self = shift; my ($method,$base,@params) = $self->_request_parameters; my $uri = URI->new($base); my $request; if ($method eq 'get') { $uri->query_form(@params); $request = GET $uri; } else { $request = POST $uri,\@params; } $request->proxy_authorization_basic($self->authentication) if $self->authentication; $request; } =head2 _parse_response Title : _parse_response Usage : $db->_parse_response($content) Function: parse out response Returns : empty Args : none Throws : 'unparseable output exception' NOTE: This method must be implemented by subclass. =cut sub _parse_response { my $self = shift; my $content = shift; $self->throw_not_implemented; } =head2 _request_parameters Title : _request_parameters Usage : ($method,$base,@params = $db->_request_parameters Function: return information needed to construct the request Returns : list of method, url base and key=>value pairs Args : none NOTE: This method must be implemented by subclass. =cut sub _request_parameters { my $self = shift; $self->throw_not_implemented; } =head2 _generate_id_string Title : _generate_id_string Usage : $string = $db->_generate_id_string Function: joins IDs together in string (implementation-dependent) Returns : string of concatenated IDs Args : array ref of ids (normally passed into the constructor) NOTE: This method must be implemented by subclass. =cut sub _generate_id_string { my $self = shift; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/DB/SeqFeature000755000765000024 012254227337 16350 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/SeqFeature/NormalizedFeature.pm000444000765000024 5351412254227315 22507 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::NormalizedFeature; =head1 NAME Bio::DB::SeqFeature::NormalizedFeature -- Normalized feature for use with Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test'); my ($feature) = $db->get_features_by_name('ZK909'); my @subfeatures = $feature->get_SeqFeatures(); my @exons_only = $feature->get_SeqFeatures('exon'); # create a new object $db->seqfeature_class('Bio::DB::SeqFeature::NormalizedFeature'); my $new = $db->new_feature(-primary_tag=>'gene', -seq_id => 'chr3', -start => 10000, -end => 11000); # add a new exon $feature->add_SeqFeature($db->new_feature(-primary_tag=>'exon', -seq_id => 'chr3', -start => 5000, -end => 5551)); =head1 DESCRIPTION The Bio::DB::SeqFeature::NormalizedFeature object is an alternative representation of SeqFeatures for use with Bio::DB::SeqFeature::Store database system. It is identical to Bio::DB::SeqFeature, except that instead of storing feature/subfeature relationships in a database table, the information is stored in the object itself. This actually makes the objects somewhat inconvenient to work with from SQL, but does speed up access somewhat. To use this class, pass the name of the class to the Bio::DB::SeqFeature::Store object's seqfeature_class() method. After this, $db-Enew_feature() will create objects of type Bio::DB::SeqFeature::NormalizedFeature. If you are using the GFF3 loader, pass Bio::DB::SeqFeature::Store::GFF3Loader-Enew() the -seqfeature_class argument: use Bio::DB::SeqFeature::Store::GFF3Loader; my $store = connect_to_db_somehow(); my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new( -store=>$db, -seqfeature_class => 'Bio::DB::SeqFeature::NormalizedFeature' ); =cut use strict; use Carp 'croak'; use base 'Bio::SeqFeature::Lite'; use base 'Bio::DB::SeqFeature::NormalizedFeatureI'; use overload '""' => \&as_string, eq => \&eq, ne => \&ne, fallback => 1; use vars '$AUTOLOAD'; my $USE_OVERLOADED_NAMES = 1; # some of this is my fault and some of it is changing bioperl API *get_all_SeqFeatures = *sub_SeqFeature = *merged_segments = \&segments; ##### CLASS METHODS #### =head2 new Title : new Usage : $feature = Bio::DB::SeqFeature::NormalizedFeature->new(@args) Function: create a new feature Returns : the new seqfeature Args : see below Status : public This method creates and, if possible stores into a database, a new Bio::DB::SeqFeature::NormalizedFeature object using the specialized Bio::DB::SeqFeature class. The arguments are the same to Bio::SeqFeature::Generic-Enew() and Bio::Graphics::Feature-Enew(). The most important difference is the B<-store> option, which if present creates the object in a Bio::DB::SeqFeature::Store database, and he B<-index> option, which controls whether the feature will be indexed for retrieval (default is true). Ordinarily, you would only want to turn indexing on when creating top level features, and off only when storing subfeatures. The default is on. Arguments are as follows: -seq_id the reference sequence -start the start position of the feature -end the stop position of the feature -display_name the feature name (returned by seqname) -primary_tag the feature type (returned by primary_tag) -source the source tag -score the feature score (for GFF compatibility) -desc a description of the feature -segments a list of subfeatures (see Bio::Graphics::Feature) -subtype the type to use when creating subfeatures -strand the strand of the feature (one of -1, 0 or +1) -phase the phase of the feature (0..2) -url a URL to link to when rendered with Bio::Graphics -attributes a hashref of tag value attributes, in which the key is the tag and the value is an array reference of values -store a previously-opened Bio::DB::SeqFeature::Store object -index index this feature if true Aliases: -id an alias for -display_name -seqname an alias for -display_name -display_id an alias for -display_name -name an alias for -display_name -stop an alias for end -type an alias for primary_tag =cut sub new { my $class = shift; my %args = @_; my $db = $args{-store} || $args{-factory}; my $index = exists $args{-index} ? $args{-index} : 1; my $self = $class->SUPER::new(@_); if ($db) { if ($index) { $db->store($self); # this will set the primary_id } else { $db->store_noindex($self); # this will set the primary_id } $self->object_store($db); } $self; } =head2 Bio::SeqFeatureI methods The following Bio::SeqFeatureI methods are supported: seq_id(), start(), end(), strand(), get_SeqFeatures(), display_name(), primary_tag(), source_tag(), seq(), location(), primary_id(), overlaps(), contains(), equals(), intersection(), union(), has_tag(), remove_tag(), add_tag_value(), get_tag_values(), get_all_tags() Some methods that do not make sense in the context of a genome annotation database system, such as attach_seq(), are not supported. Please see L for more details. =cut sub seq { my $self = shift; require Bio::PrimarySeq unless Bio::PrimarySeq->can('new'); my ($start,$end) = ($self->start,$self->end); if ($self->strand < 0) { ($start,$end) = ($end,$start); } if (my $store = $self->object_store) { return Bio::PrimarySeq->new(-seq => $store->fetch_sequence($self->seq_id,$start,$end) || '', -id => $self->display_name); } else { return $self->SUPER::seq($self->seq_id,$start,$end); } } sub subseq { my $self = shift; my ($newstart,$newstop) = @_; my $store = $self->object_store or return; my ($start,$stop) = ($self->start+$newstart-1,$self->end+$newstop-1); if ($self->strand < 0) { ($start,$stop) = ($stop,$start); } my $seq = $store->fetch_sequence($self->seq_id,$start,$stop); return Bio::PrimarySeq->new($seq); } =head2 add_SeqFeature Title : add_SeqFeature Usage : $flag = $feature->add_SeqFeature(@features) Function: Add subfeatures to the feature Returns : true if successful Args : list of Bio::SeqFeatureI objects Status : public Add one or more subfeatures to the feature. For best results, subfeatures should be of the same class as the parent feature (i.e. don't try mixing Bio::DB::SeqFeature::NormalizedFeature with other feature types). An alias for this method is add_segment(). =cut sub add_SeqFeature { my $self = shift; $self->_add_segment(1,@_); } =head2 update Title : update Usage : $flag = $feature->update() Function: Update feature in the database Returns : true if successful Args : none Status : public After changing any fields in the feature, call update() to write it to the database. This is not needed for add_SeqFeature() as update() is invoked automatically. =cut sub update { my $self = shift; my $store = $self->object_store or return; $store->store($self); } =head2 get_SeqFeatures Title : get_SeqFeature Usage : @subfeatures = $feature->get_SeqFeatures([@types]) Function: return subfeatures of this feature Returns : list of subfeatures Args : list of subfeature primary_tags (optional) Status : public This method extends the Bio::SeqFeatureI get_SeqFeatures() slightly by allowing you to pass a list of primary_tags, in which case only subfeatures whose primary_tag is contained on the list will be returned. Without any types passed all subfeatures are returned. =cut # segments can be either normalized IDs or ordinary feature objects sub get_SeqFeatures { my $self = shift; my @types = @_; my $s = $self->{segments} or return; my $store = $self->object_store; my (@ordinary,@ids); for (@$s) { if (ref ($_)) { push @ordinary,$_; } else { push @ids,$_; } } my @r = grep {$_->type_match(@types)} (@ordinary,$store->fetch_many(\@ids)); for my $r (@r) { eval {$r->object_store($store) }; } return @r; } =head2 object_store Title : object_store Usage : $store = $feature->object_store([$new_store]) Function: get or set the database handle Returns : current database handle Args : new database handle (optional) Status : public This method will get or set the Bio::DB::SeqFeature::Store object that is associated with the feature. After changing the store, you should probably unset the feature's primary_id() and call update() to ensure that the object is written into the database as a new feature. =cut sub object_store { my $self = shift; my $d = $self->{store}; $self->{store} = shift if @_; $d; } =head2 overloaded_names Title : overloaded_names Usage : $overload = $feature->overloaded_names([$new_overload]) Function: get or set overloading of object strings Returns : current flag Args : new flag (optional) Status : public For convenience, when objects of this class are stringified, they are represented in the form "primary_tag(display_name)". To turn this feature off, call overloaded_names() with a false value. You can invoke this on an individual feature object or on the class: Bio::DB::SeqFeature::NormalizedFeature->overloaded_names(0); =cut sub overloaded_names { my $class = shift; my $d = $USE_OVERLOADED_NAMES; $USE_OVERLOADED_NAMES = shift if @_; $d; } =head2 segment Title : segment Usage : $segment = $feature->segment Function: return a Segment object corresponding to feature Returns : a Bio::DB::SeqFeature::Segment Args : none Status : public This turns the feature into a Bio::DB::SeqFeature::Segment object, which you can then use to query for overlapping features. See L. =cut sub segment { my $self = shift; return Bio::DB::SeqFeature::Segment->new($self); } ### instance methods =head2 AUTOLOADED methods @subfeatures = $feature->Exon; If you use an unknown method that begins with a capital letter, then the feature autogenerates a call to get_SeqFeatures() using the lower-cased method name as the primary_tag. In other words $feature-EExon is equivalent to: @subfeature s= $feature->get_SeqFeatures('exon') If you use an unknown method that begins with Tag_(tagname), Att_(tagname) Is_(tagname), then it will be the same as calling the each_tag_value() method with the tagname. In a list context, these autogenerated procedures return the list of results. In scalar context, they return the first item in the list!! =cut sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; my $sub = $AUTOLOAD; my $self = $_[0]; # ignore DESTROY calls return if $func_name eq 'DESTROY'; # call attributes if func_name begins with "Tag_" or "Att_": if ($func_name =~ /^(Tag|Att|Is)_(\w+)/) { my @result = $self->each_tag_value($2); return wantarray ? @result : $result[0]; } # fetch subfeatures if func_name has an initial cap if ($func_name =~ /^[A-Z]/) { return $self->get_SeqFeatures(lc $func_name); } # error message of last resort $self->throw(qq(Can't locate object method "$func_name" via package "$pack")); }#' sub add_segment { my $self = shift; $self->_add_segment(0,@_); } # This adds subfeatures. It has the property of converting the # provided features into an object like itself and storing them # into the database. If the feature already has a primary id and # an object_store() method, then it is not stored into the database, # but its primary id is reused. sub _add_segment { my $self = shift; my $normalized = shift; my $store = $self->object_store; my @segments = $self->_create_subfeatures($normalized,@_); # fix boundaries $self->_fix_boundaries(\@segments); # freakish fixing of our non-standard Target attribute $self->_fix_target(\@segments); for my $seg (@segments) { my $id = $normalized ? $seg->primary_id : $seg; defined $id or $self->throw("No primary ID when there should be"); push @{$self->{segments}},$id; }; $self->update if $self->primary_id; # write us back to disk } sub _fix_boundaries { my $self = shift; my $segments = shift; my $normalized = shift; my $min_start = $self->start || 999_999_999_999; my $max_stop = $self->end || -999_999_999_999; for my $seg (@$segments) { $min_start = $seg->start if $seg->start < $min_start; $max_stop = $seg->end if $seg->end > $max_stop; } # adjust our boundaries, etc. $self->start($min_start) if $min_start < $self->start; $self->end($max_stop) if $max_stop > $self->end; $self->{ref} ||= $segments->[0]->seq_id; $self->{strand} ||= $segments->[0]->strand; } sub _fix_target { my $self = shift; my $segs = shift; my $normalized = shift; # ignored for now # freakish fixing of our non-standard Target attribute if (my $t = ($self->attributes('Target'))[0]) { my ($seqid,$tstart,$tend,$strand) = split /\s+/,$t; if (defined $tstart && defined $tend) { my $min_tstart = $tstart; my $max_tend = $tend; for my $seg (@$segs) { my $st = ($seg->attributes('Target'))[0] or next; (undef,$tstart,$tend) = split /\s+/,$st; next unless defined $tstart && defined $tend; $min_tstart = $tstart if $tstart < $min_tstart; $max_tend = $tend if $tend > $max_tend; } if ($min_tstart < $tstart or $max_tend > $tend) { $self->{attributes}{Target}[0] = join ' ',($seqid,$min_tstart,$max_tend,$strand||''); } } } } # undo the load_id and Target hacks on the way out sub format_attributes { my $self = shift; my $parent = shift; my $fallback_id = shift; my $load_id = $self->load_id || ''; my $targobj = ($self->attributes('Target'))[0]; # was getting an 'Use of uninitialized value with split' here, changed to cooperate -cjf 7/10/07 my ($target) = $targobj ? split /\s+/,($self->attributes('Target'))[0] : (''); my @tags = $self->all_tags; my @result; for my $t (@tags) { my @values = $self->each_tag_value($t); # This line prevents Alias from showing up if it matches the load id, but this is not good # @values = grep {$_ ne $load_id && $_ ne $target} @values if $t eq 'Alias'; # these are hacks, which we don't want to appear in the file next if $t eq 'load_id'; next if $t eq 'parent_id'; foreach (@values) { s/\s+$// } # get rid of trailing whitespace push @result,join '=',$self->escape($t),join(',', map {$self->escape($_)} @values) if @values; } my $id = $self->primary_id || $fallback_id; my $parent_id; if (@$parent) { $parent_id = join (',',map {$self->escape($_)} @$parent); } my $name = $self->display_name; unshift @result,"ID=".$self->escape($id) if defined $id; unshift @result,"Parent=".$parent_id if defined $parent_id; unshift @result,"Name=".$self->escape($name) if defined $name; return join ';',@result; } sub _create_subfeatures { my $self = shift; my $normalized = shift; my $type = $self->{subtype} || $self->{type}; my $ref = $self->seq_id; my $name = $self->name; my $class = $self->class; my $store = $self->object_store; my $source = $self->source; if ($normalized) { $store or $self->throw("Feature must be associated with a Bio::DB::SeqFeature::Store database before attempting to add subfeatures to a normalized object"); } my $index_subfeatures_policy = eval{$store->index_subfeatures}; my @segments; for my $seg (@_) { if (UNIVERSAL::isa($seg,ref $self)) { if (!$normalized) { # make sure the object has no lazy behavior $seg->primary_id(undef); $seg->object_store(undef); } push @segments,$seg; } elsif (ref($seg) eq 'ARRAY') { my ($start,$stop) = @{$seg}; next unless defined $start && defined $stop; # fixes an obscure bug somewhere above us my $strand = $self->{strand}; if ($start > $stop) { ($start,$stop) = ($stop,$start); $strand = -1; } push @segments,$self->new(-start => $start, -stop => $stop, -strand => $strand, -ref => $ref, -type => $type, -name => $name, -class => $class, -source => $source, ); } elsif (UNIVERSAL::isa($seg,'Bio::SeqFeatureI')) { my $score = $seg->score if $seg->can('score'); my $f = $self->new(-start => $seg->start, -end => $seg->end, -strand => $seg->strand, -seq_id => $seg->seq_id, -name => $seg->display_name, -primary_tag => $seg->primary_tag, -source_tag => $seg->source, -score => $score, -source => $source, ); for my $tag ($seg->get_all_tags) { my @values = $seg->get_tag_values($tag); $f->{attributes}{$tag} = \@values; } push @segments,$f; } else { croak "$seg is neither a Bio::SeqFeatureI object nor an arrayref"; } } return unless @segments; if ($normalized && $store) { # parent/child data is going to be stored in the database my @need_loading = grep {!defined $_->primary_id || $_->object_store ne $store} @segments; if (@need_loading) { my $result; if ($index_subfeatures_policy) { $result = $store->store(@need_loading); } else { $result = $store->store_noindex(@need_loading); } $result or croak "Couldn't store one or more subseqfeatures"; } } return @segments; } =head2 load_id Title : load_id Usage : $id = $feature->load_id Function: get the GFF3 load ID Returns : the GFF3 load ID (string) Args : none Status : public For features that were originally loaded by the GFF3 loader, this method returns the GFF3 load ID. This method may not be supported in future versions of the module. =cut sub load_id { return (shift->attributes('load_id'))[0]; } =head2 notes Title : notes Usage : @notes = $feature->notes Function: get contents of the GFF3 Note tag Returns : List of GFF3 Note tags Args : none Status : public For features that were originally loaded by the GFF3 loader, this method returns the contents of the Note tag as a list. This is a convenience for Bio::Graphics, which looks for notes() when it constructs a default description line. =cut sub notes { return shift->attributes('Note'); } =head2 primary_id Title : primary_id Usage : $id = $feature->primary_id([$new_id]) Function: get/set the feature's database ID Returns : the current primary ID Args : none Status : public This method gets or sets the primary ID of the feature in the underlying Bio::DB::SeqFeature::Store database. If you change this field and then call update(), it will have the effect of making a copy of the feature in the database under a new ID. =cut sub primary_id { my $self = shift; my $d = $self->{primary_id}; $self->{primary_id} = shift if @_; $d; } =head2 target Title : target Usage : $segment = $feature->target Function: return the segment correspondent to the "Target" attribute Returns : a Bio::DB::SeqFeature::Segment object Args : none Status : public For features that are aligned with others via the GFF3 Target attribute, this returns a segment corresponding to the aligned region. The CIGAR gap string is not yet supported. =cut sub target { my $self = shift; my @targets = $self->attributes('Target'); my @result; for my $t (@targets) { my ($seqid,$start,$end,$strand) = split /\s+/,$t; $strand ||= ''; $strand = $strand eq '+' ? 1 : $strand eq '-' ? -1 : 0; push @result,Bio::DB::SeqFeature::Segment->new($self->object_store, $seqid, $start, $end, $strand); } return wantarray ? @result : $result[0]; } =head2 Internal methods =over 4 =item $feature-Eas_string() Internal method used to implement overloaded stringification. =item $boolean = $feature-Etype_match(@list_of_types) Internal method that will return true if the feature's primary_tag and source_tag match any of the list of types (in primary_tag:source_tag format) provided. =back =cut sub as_string { my $self = shift; return overload::StrVal($self) unless $self->overloaded_names; my $name = $self->display_name || $self->load_id; $name ||= "id=".$self->primary_id if $self->primary_id; $name ||= ""; my $method = $self->primary_tag; my $source= $self->source_tag; my $type = $source ? "$method:$source" : $method; return "$type($name)"; } sub eq { my $self = shift; my $b = shift; my $store1 = $self->object_store; my $store2 = eval {$b->object_store} || ''; return $store1 eq $store2 && $self->primary_id eq $b->primary_id; } sub ne { my $self = shift; return !$self->eq(shift); } # completely case insensitive sub type_match { my $self = shift; my @types = @_; my $method = lc $self->primary_tag; my $source = lc $self->source_tag; for my $t (@types) { my ($m,$s) = map {lc $_} split /:/,$t; return 1 if $method eq $m && (!defined $s || $source eq $s); } return; } sub segments { shift->get_SeqFeatures(@_) } 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/NormalizedFeatureI.pm000444000765000024 223112254227320 22562 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::NormalizedFeatureI; =head1 NAME Bio::DB::SeqFeature::NormalizedFeatureI -- Interface for normalized features =head1 SYNOPSIS none =head1 DESCRIPTION This is an extremely simple interface that contains a single method, subfeatures_are_normalized(). This method returns a true value. Bio::DB::SeqFeature::Store feature classes will inherit this interface to flag that they are able to store subfeatures in a normalized way such that the subfeature is actually contained in the Bio::DB::SeqFeature::Store database and the parent feature contains only the subfeatures primary ID. =head1 BUGS None, but the whole class design might be flawed. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut sub subfeatures_are_normalized { 1 } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/NormalizedTableFeatureI.pm000444000765000024 254212254227337 23547 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::NormalizedTableFeatureI; =head1 NAME Bio::DB::SeqFeature::NormalizedTableFeatureI -- Interface for normalized features whose hierarchy is stored in a table =head1 SYNOPSIS none =head1 DESCRIPTION This is an extremely simple interface that contains a single method, subfeatures_are_stored_in_a_table(). This method returns a true value. Bio::DB::SeqFeature::Store feature classes will inherit this interface to flag that in addition to being able to store features in a normalized way, they will use the Bio::DB::SeqFeature::Store database to record their parent/child relationships. A class that inherits from NormalizedTableFeatureI will also inherit from NormalizedFeatureI, as the first is a subclass of the second. =head1 BUGS None, but the whole class design might be flawed. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use base 'Bio::DB::SeqFeature::NormalizedFeatureI'; sub subfeatures_are_stored_in_a_table { 1 } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/Segment.pm000444000765000024 3376012254227314 20471 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Segment; =head1 NAME Bio::DB::SeqFeature::Segment -- Location-based access to genome annotation data =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test'); my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features('mRNA','match'); =head1 DESCRIPTION The segment object simplifies access to Bio::DB::SeqFeature store by acting as a placeholder for a region of the genome. You can replace this statement: @features = $db->features(-seq_id=>'Chr1', -start=>5000, -end=>6000, -types=>['mRNA','match','repeat_region']); with these statements: $segment = $db->segment('Chr1',5000=>6000); @features = $segment->features('mRNA','match','repeat_region'); You can also initialize a segment from an existing SeqFeature object. The range will be picked up from the SeqFeature boundaries: $segment = Bio::DB::SeqFeature::Segment->new($feature); # for Bio::DB::SeqFeature $segment = Bio::DB::SeqFeature::Segment->new($feature,$store); # for other Bio::SeqFeatureI objects The segment object implements the full Bio::SeqFeature::CollectionI interface, thereby allowing you to iterate over all features in the range. =cut use strict; use base 'Bio::SeqFeature::CollectionI','Bio::RangeI'; use Bio::DB::GFF::Util::Rearrange; use overload '""' => \&as_string, fallback => 1; =head1 PUBLIC METHODS The following are public methods intended for external use. =head2 new Title : new Usage : $segment = Bio::DB::SeqFeature::Segment->new(@options) Function: create a new Segment object Returns : A Bio::DB::SeqFeature::Segment object Args : several - see below Status : public This class method creates a Bio::DB::SeqFeature::Segment object. You must provide a Bio::DB::SeqFeature::Store as well as the coordinates of the segment. These arguments can be provided explicitly or indirectly. First form: $segment = Bio::DB::SeqFeature::Segment->new($store,$seqid,$start,$end,$strand) In this form a segment is defined by a Bio::DB::SeqFeature::Store, the sequence ID, the start, end and strand. This is the form that is invoked internally by Bio::DB::SeqFeature::Store when you call its segment() method. Second form: $segment = Bio::DB::SeqFeature::Segment->new($seqfeature [,$store]); In this form, you pass new() a Bio::SeqFeatureI object. The segment is constructed from the seq_id and coordinates are taken from the object. If you pass a store-aware seqfeature object (e.g. Bio::DB::SeqFeature) then the store database is also derived from the feature. Otherwise you will have to pass the store as a second argument. =cut ### # new() # # Call as Bio::DB::SeqFeature::Segment->new($seqfeature,$store) # # or # Bio::DB::SeqFeature::Segment->new(-seqid=>$seqid,-start=>$start,-end=>$end,-strand=>$strand,-store=>$store) # sub new { my $class = shift; my ($store,$seqid,$start,$end,$strand,$id); if (ref $_[0] && UNIVERSAL::isa($_[0],'Bio::SeqFeatureI')) { my $seqfeature = shift; $store = shift; $store ||= eval {$seqfeature->object_store}; $class->throw("I could not derive the Bio::DB::SeqFeature::Store object from the arguments passed to Bio::DB::SeqFeature::Segment->new(). Please pass the Store object as the second argument") unless $store; $seqid = $seqfeature->seq_id; $start = $seqfeature->start; $end = $seqfeature->end; $strand= $seqfeature->strand; $id = eval{$seqfeature->primary_id}; } else { ($store,$seqid,$start,$end,$strand,$id) = @_; } return bless { store => $store, seqid => $seqid, start => $start, end => $end, strand => $strand, primary_id => $id, },ref($class) || $class; } =head2 features Title : features Usage : @features = $segment->features(@args) Function: fetch seqfeatures that overlap the segment Returns : list of features Args : see below Status : Public This is the workhorse for feature query and retrieval. It takes a series of -name=E$value arguments filter arguments. Features that match all the filters are returned. Argument Value -------- ----- Location filters: -strand Strand -range_type Type of range match ('overlaps','contains','contained_in') Name filters: -name Name of feature (may be a glob expression) -aliases If true, match aliases as well as display names -class Archaic argument for backward compatibility. (-class=>'Clone',-name=>'ABC123') is equivalent to (-name=>'Clone:ABC123') Type filters: -types List of feature types (array reference) or one type (scalar) -type Synonym for the above -primary_tag Synonym for the above -attributes Hashref of attribute=>value pairs as per get_features_by_attribute(). Multiple alternative values can be matched by providing an array reference. -attribute synonym for -attributes This is identical to the Bio::DB::SeqFeature::Store-Efeatures() method, except that the -seq_id, -start, and -end arguments are provided by the segment object. If a simple list of arguments is provided, then the list is taken to be the set of feature types (primary tags) to filter on. Examples: All features that overlap the current segment: @features = $segment->features; All features of type mRNA that overlap the current segment: @features = $segment->features('mRNA'); All features that are completely contained within the current segment: @features = $segment->features(-range_type=>'contains'); All "confirmed" mRNAs that overlap the current segment: @features = $segment->features(-attributes=>{confirmed=>1},-type=>'mRNA'); =cut sub features { my $self = shift; my @args; if (@_ == 0) { @args = (); } elsif ($_[0] !~/^-/) { my @types = @_; @args = (-type=>\@types); } else { @args = @_; } $self->{store}->features(@args,-seqid=>$self->{seqid},-start=>$self->{start},-end=>$self->{end}); } sub types { my $self = shift; my %types; my $iterator = $self->get_seq_stream(@_); while (my $f = $iterator->next_seq) { $types{$f->type}++; } return %types; } =head2 get_seq_stream Title : get_seq_stream Usage : $iterator = $segment->get_seq_stream(@args) Function: return an iterator across all features in the database Returns : a Bio::DB::SeqFeature::Store::Iterator object Args : (optional) the feature() method Status : public This is identical to Bio::DB::SeqFeature::Store-Eget_seq_stream() except that the location filter is always automatically applied so that the iterator you receive returns features that overlap the segment's region. When called without any arguments this method will return an iterator object that will traverse all indexed features in the database that overlap the segment's region. Call the iterator's next_seq() method to step through them (in no particular order): my $iterator = $db->get_seq_stream; while (my $feature = $iterator->next_seq) { print $feature->primary_tag,' ',$feature->display_name,"\n"; } You can select a subset of features by passing a series of filter arguments. The arguments are identical to those accepted by $segment-Efeatures(). get_feature_stream() ican be used as a synonym for this method. =cut #' sub get_seq_stream { my $self = shift; $self->{store}->get_seq_stream(@_,-seqid=>$self->{seqid},-start=>$self->{start},-end=>$self->{end}); } sub get_feature_stream { shift->get_seq_stream(@_) } =head2 store Title : store Usage : $store = $segment->store Function: return the Bio::DB::SeqFeature::Store object associated with the segment Returns : a Bio::DB::SeqFeature::Store: object Args : none Status : public =cut sub factory { shift->{store} } sub store { shift->{store} } =head2 primary_tag, type, Title : primary_tag,type Usage : $primary_tag = $segment->primary_tag Function: returns the string "region" Returns : "region" Args : none Status : public The primary_tag method returns the constant tag "region". type() is a synonym for this method. =cut sub type { shift->primary_tag } =head2 as_string Title : as_string Usage : $name = $segment->as_string Function: expands the object into a human-readable string Returns : "seq_id:start..end" Args : none Status : public The as_string() method is overloaded into the "" operator so that the object is represented as a human readable string in the form "seq_id:start..end" when used in a string context. =cut sub as_string { my $self = shift; my $label = $self->seq_id; my $start = $self->start || ''; my $end = $self->end || ''; return "$label:$start..$end"; } =head2 rel2abs Title : rel2abs Usage : @coords = $s->rel2abs(@coords) Function: convert relative coordinates into absolute coordinates Returns : a list of absolute coordinates Args : a list of relative coordinates Status : Public This function takes a list of positions in relative coordinates to the segment, and converts them into absolute coordinates. =cut sub rel2abs { my $self = shift; my @result; my ($start,$strand) = ($self->start,$self->strand); @result = $strand < 0 ? map { $start - $_ + 1 } @_ : map { $_ + $start - 1 } @_; # if called with a single argument, caller will expect a single scalar reply # not the size of the returned array! return $result[0] if @result == 1 and !wantarray; @result; } =head2 abs2rel Title : abs2rel Usage : @rel_coords = $s->abs2rel(@abs_coords) Function: convert absolute coordinates into relative coordinates Returns : a list of relative coordinates Args : a list of absolute coordinates Status : Public This function takes a list of positions in absolute coordinates and returns a list expressed in relative coordinates. =cut sub abs2rel { my $self = shift; my @result; my ($start,$strand) = ($self->start,$self->abs_strand); @result = $strand < 0 ? map { $start - $_ + 1 } @_ : map { $_ - $start + 1 } @_; # if called with a single argument, caller will expect a single scalar reply # not the size of the returned array! return $result[0] if @result == 1 and !wantarray; @result; } =head2 Bio::SeqFeatureI compatibility methods For convenience, segments are interchangeable with Bio::SeqFeature objects in many cases. This means that segments can be passed to BioPerl modules that expect Bio::SeqFeature objects and they should work as expected. The primary tag of segment objects is "region" (SO:0000001 "Continous sequence E=1 base pair"). All these methods are read-only except for the primary_id, which can be get or set. The following Bio::SeqFeatureI methods are supported: =over 4 =item start =item end =item seq_id =item strand =item length =item display_name =item primary_id =item primary_tag (always returns "region") =item source_tag (always returns "Bio::DB::SeqFeature::Segment") =item get_SeqFeatures (always returns an empty list) =item seq =item entire_seq =item location =item All Bio::RangeI methods =back =cut sub start { shift->{start} } sub end { shift->{end} } sub seq_id { shift->{seqid} } sub strand { shift->{strand} } sub ref { shift->seq_id } *refseq = \&ref; sub length { my $self = shift; return abs($self->end - $self->start) +1; } sub primary_tag { 'region' } sub source_tag { __PACKAGE__ } sub display_name { shift->as_string } sub name { shift->display_name } sub class { 'region' } sub abs_ref { shift->ref} sub abs_start { shift->start} sub abs_end { shift->end} sub abs_strand { shift->strand} sub get_SeqFeatures { } sub get_all_tags { } sub get_tag_values { } sub add_tag_value { } sub remove_tag { } sub has_tag { } sub seq { my $self = shift; require Bio::PrimarySeq unless Bio::PrimarySeq->can('new'); my ($start,$end) = ($self->start,$self->end); if ($self->strand < 0) { ($start,$end) = ($end,$start); } return Bio::PrimarySeq->new( -seq => $self->store->fetch_sequence($self->seq_id,$start,$end), -id => $self->display_name); } sub subseq { my $self = shift; my ($newstart,$newstop) = @_; my $store = $self->store or return; my $seq = $store->fetch_sequence($self->seq_id,$self->start+$newstart-1,$self->end+$newstop-1); return Bio::PrimarySeq->new(-seq=>$seq); } sub dna { my $seq = shift->seq; $seq = $seq->seq if CORE::ref($seq); return $seq; } sub entire_seq { my $self = shift; require Bio::PrimarySeq unless Bio::PrimarySeq->can('new'); return Bio::PrimarySeq->new( -seq => $self->store->fetch_sequence($self->seq_id), -id => $self->seq_id); } sub location { my $self = shift; require Bio::Location::Simple unless Bio::Location::Simple->can('new'); my $loc = Bio::Location::Simple->new(-start => $self->start, -end => $self->end, -strand => $self->strand); $loc->strand($self->strand); return $loc; } sub primary_id { my $self = shift; my $d = $self->{primary_id}; $self->{primary_id} = shift if @_; $d; } sub target { return } sub score { return } sub stop { shift->end } sub absolute { return 1 } sub desc { shift->as_string } sub display_id { shift->display_name } sub primary_seq { shift->seq } sub accession_number { return undef } # intended return undef sub alphabet { return undef } # intended return undef 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store.pm000444000765000024 23714612254227316 20211 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store; =head1 NAME Bio::DB::SeqFeature::Store -- Storage and retrieval of sequence annotation data =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the feature database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test', -create => 1 ); # Get a feature from somewhere my $feature = Bio::SeqFeature::Generic->new(...); # Store it $db->store($feature) or die "Couldn't store!"; # If absent, a primary ID is added to the feature when it is stored in the # database. Retrieve the primary ID my $id = $feature->primary_id; # Get the feature back out my $feature = $db->fetch($id); # .... which is identical to my $feature = $db->get_feature_by_primary_id($id); # Change the feature and update it $f->start(100); $db->store($f) or die "Couldn't update!"; # Get all features at once my @features = $db->features( ); # Retrieve multiple features by primary id my @features = $db->fetch_many(@list_of_ids); # ...by name @features = $db->get_features_by_name('ZK909'); # ...by alias @features = $db->get_features_by_alias('sma-3'); # ...by type @features = $db->get_features_by_type('gene'); # ...by location @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000); # ...by attribute @features = $db->get_features_by_attribute({description => 'protein kinase'}) # ...by the GFF "Note" field @result_list = $db->search_notes('kinase'); # ...by arbitrary combinations of selectors @features = $db->features(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); # Loop through the features using an iterator my $iterator = $db->get_seq_stream(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); while (my $feature = $iterator->next_seq) { # do something with the feature } # ...limiting the search to a particular region my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features(-type=>['mRNA','match']); # Getting coverage statistics across a region my $summary = $db->feature_summary('Chr1',10_000=>1_110_000); my ($bins) = $summary->get_tag_values('coverage'); my $first_bin = $bins->[0]; # Getting & storing sequence information # Warning: this returns a string, and not a PrimarySeq object $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...'); my $sequence = $db->fetch_sequence('Chr1',5000=>6000); # What feature types are defined in the database? my @types = $db->types; # Create a new feature in the database my $feature = $db->new_feature(-primary_tag => 'mRNA', -seq_id => 'chr3', -start => 10000, -end => 11000); # Load an entire GFF3 file, using the GFF3 loader... my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(-store => $db, -verbose => 1, -fast => 1); $loader->load('./my_genome.gff3'); =head1 DESCRIPTION Bio::DB::SeqFeature::Store implements the Bio::SeqFeature::CollectionI interface to allow you to persistently store Bio::SeqFeatureI objects in a database and to later to retrieve them by a variety of searches. This module is similar to the older Bio::DB::GFF module, with the following differences: =over 4 =item 1. No limitation on Bio::SeqFeatureI implementations Unlike Bio::DB::GFF, Bio::DB::SeqFeature::Store works with any Bio::SeqFeatureI object. =item 2. No limitation on nesting of features & subfeatures Bio::DB::GFF is limited to features that have at most one level of subfeature. Bio::DB::SeqFeature::Store can work with features that have unlimited levels of nesting. =item 3. No aggregators The aggregator architecture, which was necessary to impose order on the GFF2 files that Bio::DB::GFF works with, does not apply to Bio::DB::SeqFeature::Store. It is intended to store features that obey well-defined ontologies, such as the Sequence Ontology (http://song.sourceforge.net). =item 4. No relative locations All locations defined by this module are relative to an absolute sequence ID, unlike Bio::DB::GFF which allows you to define the location of one feature relative to another. =back We'll discuss major concepts in Bio::DB::SeqFeature::Store and then describe how to use the module. =head2 Adaptors Bio::DB::SeqFeature::Store is designed to work with a variety of storage back ends called "adaptors." Adaptors are subclasses of Bio::DB::SeqFeature::Store and provide the interface between the store() and fetch() methods and the physical database. Currently the number of adaptors is quite limited, but the number will grow soon. =over 4 =item memory An implementation that stores all data in memory. This is useful for small data sets of no more than 10,000 features (more or less, depending on system memory). =item DBI::mysql A full-featured implementation on top of the MySQL relational database system. =item berkeleydb A full-feature implementation that runs on top of the BerkeleyDB database. See L. =back If you do not explicitly specify the adaptor, then DBI::mysql will be used by default. =head2 Serializers When Bio::DB::SeqFeature::Store stores a Bio::SeqFeatureI object into the database, it serializes it into binary or text form. When it later fetches the feature from the database, it unserializes it. Two serializers are available: Recent versions of =over 4 =item Storable This is a fast binary serializer. It is available in Perl versions 5.8.7 and higher and is used when available. =item Data::Dumper This is a slow text serializer that is available in Perl 5.8.0 and higher. It is used when Storable is unavailable. =back If you do not specify the serializer, then Storable will be used if available; otherwise Data::Dumper. =head2 Loaders and Normalized Features The Bio::DB::SeqFeature::Store::GFF3Loader parses a GFF3-format file and loads the annotations and sequence data into the database of your choice. The script bp_seqfeature_load.pl (found in the scripts/Bio-SeqFeature-Store/ subdirectory) is a thin front end to the GFF3Loader. Other loaders may be written later. Although Bio::DB::SeqFeature::Store should work with any Bio::SeqFeatureI object, there are some disadvantages to using Bio::SeqFeature::Generic and other vanilla implementations. The major issue is that if two vanilla features share the same subfeature (e.g. two transcripts sharing an exon), the shared subfeature will be cloned when stored into the database. The special-purpose L class is able to normalize its subfeatures in the database, so that shared subfeatures are stored only once. This minimizes wasted storage space. In addition, when in-memory caching is turned on, each shared subfeature will usually occupy only a single memory location upon restoration. =cut use strict; use warnings; use base 'Bio::SeqFeature::CollectionI'; use Carp 'croak'; use Bio::DB::GFF::Util::Rearrange; use Bio::DB::SeqFeature::Segment; use Scalar::Util 'blessed'; # this probably shouldn't be here use Bio::DB::SeqFeature; *dna = *get_dna = *get_sequence = \&fetch_sequence; *get_SeqFeatures = \&fetch_SeqFeatures; # local version sub api_version { 1.2 } =head1 Methods for Connecting and Initializating a Database ## TODO: http://iowg.brcdevel.org/gff3.html#a_fasta is a dead link =head2 new Title : new Usage : $db = Bio::DB::SeqFeature::Store->new(@options) Function: connect to a database Returns : A descendent of Bio::DB::Seqfeature::Store Args : several - see below Status : public This class method creates a new database connection. The following -name=E$value arguments are accepted: Name Value ---- ----- -adaptor The name of the Adaptor class (default DBI::mysql) -serializer The name of the serializer class (default Storable) -index_subfeatures Whether or not to make subfeatures searchable (default false) -cache Activate LRU caching feature -- size of cache -compress Compresses features before storing them in database using Compress::Zlib -create (Re)initialize the database. The B<-index_subfeatures> argument, if true, tells the module to create indexes for a feature and all its subfeatures (and its subfeatures' subfeatures). Indexing subfeatures means that you will be able to search for the gene, its mRNA subfeatures and the exons inside each mRNA. It also means when you search the database for all features contained within a particular location, you will get the gene, the mRNAs and all the exons as individual objects as well as subfeatures of each other. NOTE: this option is only honored when working with a normalized feature class such as Bio::DB::SeqFeature. The B<-cache> argument, if true, tells the module to try to create a LRU (least-recently-used) object cache using the Tie::Cacher module. Caching will cause two objects that share the same primary_id to (often, but not always) share the same memory location, and may improve performance modestly. The argument is taken as the desired size for the cache. If you pass "1" as the cache value, a reasonable default cache size will be chosen. Caching requires the Tie::Cacher module to be installed. If the module is not installed, then caching will silently be disabled. The B<-compress> argument, if true, will cause the feature data to be compressed before storing it. This will make the database somewhat smaller at the cost of decreasing performance. The B<-create> argument, if true, will either initialize or reinitialize the database. It is needed the first time a database is used. The new() method of individual adaptors recognize additional arguments. The default DBI::mysql adaptor recognizes the following ones: Name Value ---- ----- -dsn DBI data source (default dbi:mysql:test) -autoindex A flag that controls whether or not to update all search indexes whenever a feature is stored or updated (default true). -namespace A string that will be used to qualify each table, thereby allowing you to store several independent sequence feature databases in a single Mysql database. -dumpdir The path to a temporary directory that will be used during "fast" loading. See L for a description of this. Default is the current directory. -write Make the database writable (implied by -create) -fasta Provide an alternative DNA accessor object or path. By default the database will store DNA sequences internally. However, you may override this behavior by passing either a path to a FASTA file, or any Perl object that recognizes the seq($seqid,$start,$end) method. In the former case, the FASTA path will be passed to Bio::DB::Fasta, possibly causing an index to be constructed. Suitable examples of the latter type of object include the Bio::DB::Sam and Bio::DB::Sam::Fai classes. =cut ### # object constructor # sub new { my $self = shift; my ($adaptor,$serializer,$index_subfeatures,$cache,$compress,$debug,$create,$fasta,$args); if (@_ == 1) { $args = {DSN => shift} } else { ($adaptor,$serializer,$index_subfeatures,$cache,$compress,$debug,$create,$fasta,$args) = rearrange(['ADAPTOR', 'SERIALIZER', 'INDEX_SUBFEATURES', 'CACHE', 'COMPRESS', 'DEBUG', 'CREATE', 'FASTA', ],@_); } $adaptor ||= 'DBI::mysql'; $args->{WRITE}++ if $create; $args->{CREATE}++ if $create; my $class = "Bio::DB::SeqFeature::Store::$adaptor"; eval "require $class " or croak $@; $cache &&= eval "require Tie::Cacher; 1"; my $obj = $class->new_instance(); $obj->debug($debug) if defined $debug; $obj->init($args); $obj->init_cache($cache) if $cache; $obj->do_compress($compress); $obj->serializer($serializer) if defined $serializer; $obj->index_subfeatures($index_subfeatures) if defined $index_subfeatures; $obj->seqfeature_class('Bio::DB::SeqFeature'); $obj->set_dna_accessor($fasta) if defined $fasta; $obj->post_init($args); $obj; } =head2 init_database Title : init_database Usage : $db->init_database([$erase_flag]) Function: initialize a database Returns : true Args : (optional) flag to erase current data Status : public Call this after Bio::DB::SeqFeature::Store-Enew() to initialize a new database. In the case of a DBI database, this method installs the schema but does B create the database. You have to do this offline using the appropriate command-line tool. In the case of the "berkeleydb" adaptor, this creates an empty BTREE database. If there is any data already in the database, init_database() called with no arguments will have no effect. To permanently erase the data already there and prepare to receive a fresh set of data, pass a true argument. =cut ### # wipe database clean and reinstall schema # sub init_database { my $self = shift; $self->_init_database(@_); } =head2 post_init This method is invoked after init_database for use by certain adaptors (currently only the memory adaptor) to do automatic data loading after initialization. It is passed a copy of the init_database() args. =cut sub post_init { } =head2 add_features Title : add_features Usage : $success = $db->add_features(\@features) Function: store one or more features into the database Returns : true if successful Args : array reference of Bio::SeqFeatureI objects Status : public =cut sub add_features { my ($self, $feats) = @_; my $result = $self->store_and_cache(1, @$feats); } =head2 store Title : store Usage : $success = $db->store(@features) Function: store one or more features into the database Returns : true if successful Args : list of Bio::SeqFeatureI objects Status : public This method stores a list of features into the database. Each feature is updated so that its primary_id becomes the primary ID of the serialized feature stored in the database. If all features were successfully stored, the method returns true. In the DBI implementation, the store is performed as a single transaction and the transaction is rolled back if one or more store operations failed. In most cases, you should let the database assign the primary id. If the object you store already has a primary_id, then the ID must adhere to the datatype expected by the adaptor: an integer in the case of the various DB adaptors, and a string in the case of the memory and berkeley adaptors. You can find out what the primary ID of the feature has become by calling the feature's primary_id() method: $db->store($my_feature) or die "Oh darn"; my $id = $my_feature->primary_id; If the feature contains subfeatures, they will all be stored recursively. In the case of Bio::DB::SeqFeature and Bio::DB::SeqFeature::Store::NormalizedFeature, the subfeatures will be stored in a normalized way so that each subfeature appears just once in the database. Subfeatures will be indexed for separate retrieval based on the current value of index_subfeatures(). If you call store() with one or more features that already have valid primary_ids, then any existing objects will be B. Note that when using normalized features such as Bio::DB::SeqFeature, the subfeatures are not recursively updated when you update the parent feature. You must manually update each subfeatures that has changed. =cut ### # store one or more Bio::SeqFeatureI objects # if they already have a primary_id will replace into the database # otherwise will insert and primary_id will be added # # this version stores the object and flags it to be indexed # for search via attributes, name, type or location sub store { my ($self, @feats) = @_; for my $feat (@feats) { if ( (not ref $feat) || (not $feat->isa('Bio::SeqFeatureI')) ) { die "Cannot store non-Bio::SeqFeatureI object '$feat'\n"; } } my $result = $self->store_and_cache(1,@feats); } =head2 store_noindex Title : store_noindex Usage : $success = $db->store_noindex(@features) Function: store one or more features into the database without indexing Returns : true if successful Args : list of Bio::SeqFeatureI objects Status : public This method stores a list of features into the database but does not make them searchable. The only way to access the features is via their primary IDs. This method is ordinarily only used internally to store subfeatures that are not indexed. =cut # this version stores the object and flags it so that it is # not searchable via attributes, name, type or location # (typically used only for subfeatures) sub store_noindex { my $self = shift; $self->store_and_cache(0,@_); } =head2 no_blobs Title : no_blobs Usage : $db->no_blobs(1); Function: decide if objects should be stored in the database as blobs. Returns : boolean (default false) Args : boolean (true to no longer store objects; when the corresponding feature is retrieved it will instead be a minimal representation of the object that was stored, as some simple Bio::SeqFeatureI object) Status : dubious (new) This method saves lots of space in the database, which may in turn lead to large performance increases in extreme cases (over 7 million features in the db). =cut sub no_blobs { my $self = shift; if (@_) { $self->{no_blobs} = shift } return $self->{no_blobs} || 0; } =head2 new_feature Title : new_feature Usage : $feature = $db->new_feature(@args) Function: create a new Bio::DB::SeqFeature object in the database Returns : the new seqfeature Args : see below Status : public This method creates and stores a new Bio::SeqFeatureI object using the specialized Bio::DB::SeqFeature class. This class is able to store its subfeatures in a normalized fashion, allowing subfeatures to be shared among multiple parents (e.g. multiple exons shared among several mRNAs). The arguments are the same as for Bio::DB::SeqFeature-Enew(), which in turn are similar to Bio::SeqFeature::Generic-Enew() and Bio::Graphics::Feature-Enew(). The most important difference is the B<-index> option, which controls whether the feature will be indexed for retrieval (default is true). Ordinarily, you would only want to turn indexing off when creating subfeatures, because features stored without indexes will only be reachable via their primary IDs or their parents. Arguments are as follows: -seq_id the reference sequence -start the start position of the feature -end the stop position of the feature -display_name the feature name (returned by seqname) -primary_tag the feature type (returned by primary_tag) -source the source tag -score the feature score (for GFF compatibility) -desc a description of the feature -segments a list of subfeatures (see Bio::Graphics::Feature) -subtype the type to use when creating subfeatures -strand the strand of the feature (one of -1, 0 or +1) -phase the phase of the feature (0..2) -url a URL to link to when rendered with Bio::Graphics -attributes a hashref of tag value attributes, in which the key is the tag and the value is an array reference of values -index index this feature if true Aliases: -id an alias for -display_name -seqname an alias for -display_name -display_id an alias for -display_name -name an alias for -display_name -stop an alias for end -type an alias for primary_tag You can change the seqfeature implementation generated by new() by passing the name of the desired seqfeature class to $db-Eseqfeature_class(). =cut sub new_feature { my $self = shift; return $self->seqfeature_class->new(-store=>$self,@_); } =head2 delete Title : delete Usage : $success = $db->delete(@features) Function: delete a list of feature from the database Returns : true if successful Args : list of features Status : public This method looks up the primary IDs from a list of features and deletes them from the database, returning true if all deletions are successful. WARNING: The current DBI::mysql implementation has some issues that need to be resolved, namely (1) normalized subfeatures are NOT recursively deleted; and (2) the deletions are not performed in a transaction. =cut sub delete { my $self = shift; my $success = 1; for my $object (@_) { my $id = $object->primary_id; if ( not defined $id ) { warn "Could not delete feature without primary_id: $object"; $success = 0; next; } my $result = $self->_deleteid($id); warn "Could not delete feature with id=$id" unless $result; $success &&= $result; } $success; } =head2 fetch / get_feature_by_id / get_feature_by_primary_id Title : fetch get_feature_by_id get_feature_by_primary_id Usage : $feature = $db->fetch($primary_id) Function: fetch a feature from the database using its primary ID Returns : a feature Args : primary ID of desired feature Status : public This method returns a previously-stored feature from the database using its primary ID. If the primary ID is invalid, it returns undef. Use fetch_many() to rapidly retrieve multiple features. =cut ### # Fetch a Bio::SeqFeatureI from database using its primary_id # sub fetch { my $self = shift; @_ or croak "usage: fetch(\$primary_id)"; my $primary_id = shift; if (my $cache = $self->cache()) { return $cache->fetch($primary_id) if $cache->exists($primary_id); my $object = $self->_fetch($primary_id); $cache->store($primary_id,$object); return $object; } else { return $self->_fetch($primary_id); } } *get_feature_by_id = *get_feature_by_primary_id = \&fetch; =head2 fetch_many Title : fetch_many Usage : @features = $db->fetch_many($primary_id,$primary_id,$primary_id...) Function: fetch many features from the database using their primary ID Returns : list of features Args : a list of primary IDs or an array ref of primary IDs Status : public Same as fetch() except that you can pass a list of primary IDs or a ref to an array of IDs. =cut ### # Efficiently fetch a series of IDs from the database # Can pass an array or an array ref # sub fetch_many { my $self = shift; @_ or croak 'usage: fetch_many($id1,$id2,$id3...)'; my @ids = map {ref($_) ? @$_ : $_} @_ or return; $self->_fetch_many(@ids); } =head2 get_seq_stream Title : get_seq_stream Usage : $iterator = $db->get_seq_stream(@args) Function: return an iterator across all features in the database Returns : a Bio::DB::SeqFeature::Store::Iterator object Args : feature filters (optional) Status : public When called without any arguments this method will return an iterator object that will traverse all indexed features in the database. Call the iterator's next_seq() method to step through them (in no particular order): my $iterator = $db->get_seq_stream; while (my $feature = $iterator->next_seq) { print $feature->primary_tag,' ',$feature->display_name,"\n"; } You can select a subset of features by passing a series of filter arguments. The arguments are identical to those accepted by $db-Efeatures(). =cut ### # Return an iterator across all features that are indexable # sub get_seq_stream { my $self = shift; $self->_features(-iterator=>1,@_); } =head2 get_features_by_name Title : get_features_by_name Usage : @features = $db->get_features_by_name($name) Function: looks up features by their display_name Returns : a list of matching features Args : the desired name Status : public This method searches the display_name of all features for matches against the provided name. GLOB style wildcares ("*", "?") are accepted, but may be slow. The method returns the list of matches, which may be zero, 1 or more than one features. Be prepared to receive more than one result, as display names are not guaranteed to be unique. For backward compatibility with gbrowse, this method is also known as get_feature_by_name(). =cut ### # get_feature_by_name() return 0 or more features using a name lookup # uses the Bio::DB::GFF API # sub get_features_by_name { my $self = shift; my ($class,$name,$types,$allow_alias); if (@_ == 1) { # get_features_by_name('name'); $name = shift; } else { # get_features_by_name('class'=>'name'), get_feature_by_name(-name=>'name') ($class,$name,$allow_alias,$types) = rearrange([qw(CLASS NAME ALIASES),[qw(TYPE TYPES)]],@_); } # hacky workaround for assumption in Bio::DB::GFF that unclassed reference points were of type "Sequence" undef $class if $class && $class eq 'Sequence'; $self->_features(-name=>$name,-class=>$class,-aliases=>$allow_alias,-type=>$types); } =head2 get_feature_by_name Title : get_feature_by_name Usage : @features = $db->get_feature_by_name($name) Function: looks up features by their display_name Returns : a list of matching features Args : the desired name Status : Use get_features_by_name instead. This method is provided for backward compatibility with gbrowse. =cut sub get_feature_by_name { shift->get_features_by_name(@_) } =head2 get_features_by_alias Title : get_features_by_alias Usage : @features = $db->get_features_by_alias($name) Function: looks up features by their display_name or alias Returns : a list of matching features Args : the desired name Status : public This method is similar to get_features_by_name() except that it will also search through the feature aliases. Aliases can be created by storing features that contain one or more Alias tags. Wildards are accepted. =cut sub get_features_by_alias { my $self = shift; my @args = @_; if (@_ == 1) { @args = (-name=>shift); } push @args,(-aliases=>1); $self->get_features_by_name(@args); } =head2 get_features_by_type Title : get_features_by_type Usage : @features = $db->get_features_by_type(@types) Function: looks up features by their primary_tag Returns : a list of matching features Args : list of primary tags Status : public This method will return a list of features that have any of the primary tags given in the argument list. For compatibility with gbrowse and Bio::DB::GFF, types can be qualified using a colon: primary_tag:source_tag in which case only features that match both the primary_tag B the indicated source_tag will be returned. If the database was loaded from a GFF3 file, this corresponds to the third and second columns of the row, in that order. For example, given the GFF3 lines: ctg123 geneFinder exon 1300 1500 . + . ID=exon001 ctg123 fgenesH exon 1300 1520 . + . ID=exon002 exon001 and exon002 will be returned by searching for type "exon", but only exon001 will be returned by searching for type "exon:fgenesH". =cut sub get_features_by_type { my $self = shift; my @types = @_; $self->_features(-type=>\@types); } =head2 get_features_by_location Title : get_features_by_location Usage : @features = $db->get_features_by_location(@args) Function: looks up features by their location Returns : a list of matching features Args : see below Status : public This method fetches features based on a location range lookup. You call it using a positional list of arguments, or a list of (-argument=E$value) pairs. The positional form is as follows: $db->get_features_by_location($seqid [[,$start,]$end]) The $seqid is the name of the sequence on which the feature resides, and start and end are optional endpoints for the match. If the endpoints are missing then any feature on the indicated seqid is returned. Examples: get_features_by_location('chr1'); # all features on chromosome 1 get_features_by_location('chr1',5000); # features between 5000 and the end get_features_by_location('chr1',5000,8000); # features between 5000 and 8000 Location lookups are overlapping. A feature will be returned if it partially or completely overlaps the indicated range. The named argument form gives you more control: Argument Value -------- ----- -seq_id The name of the sequence on which the feature resides -start Start of the range -end End of the range -strand Strand of the feature -range_type Type of range to search over The B<-strand> argument, if present, can be one of "0" to find features that are on both strands, "+1" to find only plus strand features, and "-1" to find only minus strand features. Specifying a strand of undef is the same as not specifying this argument at all, and retrieves all features regardless of their strandedness. The B<-range_type> argument, if present, can be one of "overlaps" (the default), to find features whose positions overlap the indicated range, "contains," to find features whose endpoints are completely contained within the indicated range, and "contained_in" to find features whose endpoints are both outside the indicated range. =cut sub get_features_by_location { my $self = shift; my ($seqid,$start,$end,$strand,$rangetype) = rearrange([['SEQ_ID','SEQID','REF'],'START',['STOP','END'],'STRAND','RANGE_TYPE'],@_); $self->_features(-seqid=>$seqid, -start=>$start||undef, -end=>$end||undef, -strand=>$strand||undef, -range_type=>$rangetype); } =head2 get_features_by_attribute Title : get_features_by_attribute Usage : @features = $db->get_features_by_attribute(@args) Function: looks up features by their attributes/tags Returns : a list of matching features Args : see below Status : public This implements a simple tag filter. Pass a list of tag names and their values. The module will return a list of features whose tag names and values match. Tag names are case insensitive. If multiple tag name/value pairs are present, they will be ANDed together. To match any of a list of values, use an array reference for the value. Examples: # return all features whose "function" tag is "GO:0000123" @features = $db->get_features_by_attribute(function => 'GO:0000123'); # return all features whose "function" tag is "GO:0000123" or "GO:0000555" @features = $db->get_features_by_attribute(function => ['GO:0000123','GO:0000555']); # return all features whose "function" tag is "GO:0000123" or "GO:0000555" # and whose "confirmed" tag is 1 @features = $db->get_features_by_attribute(function => ['GO:0000123','GO:0000555'], confirmed => 1); =cut sub get_features_by_attribute { my $self = shift; my %attributes = ref($_[0]) ? %{$_[0]} : @_; %attributes or $self->throw("Usage: get_feature_by_attribute(attribute_name=>\$attribute_value...)"); $self->_features(-attributes=>\%attributes); } ### # features() call -- main query interface # =head2 features Title : features Usage : @features = $db->features(@args) Function: generalized query & retrieval interface Returns : list of features Args : see below Status : Public This is the workhorse for feature query and retrieval. It takes a series of -name=E$value arguments filter arguments. Features that match all the filters are returned. Argument Value -------- ----- Location filters: -seq_id Chromosome, contig or other DNA segment -seqid Synonym for -seq_id -ref Synonym for -seqid -start Start of range -end End of range -stop Synonym for -end -strand Strand -range_type Type of range match ('overlaps','contains','contained_in') Name filters: -name Name of feature (may be a glob expression) -aliases If true, match aliases as well as display names -class Archaic argument for backward compatibility. (-class=>'Clone',-name=>'ABC123') is equivalent to (-name=>'Clone:ABC123') Type filters: -types List of feature types (array reference) or one type (scalar) -type Synonym for the above -primary_tag Synonym for the above -attributes Hashref of attribute=>value pairs as per get_features_by_attribute(). Multiple alternative values can be matched by providing an array reference. -attribute synonym for -attributes You may also provide features() with a list of scalar values (the first element of which must B begin with a dash), in which case it will treat the list as a feature type filter. Examples: All features: @features = $db->features( ); All features on chromosome 1: @features = $db->features(-seqid=>'Chr1'); All features on chromosome 1 between 5000 and 6000: @features = $db->features(-seqid=>'Chr1',-start=>5000,-end=>6000); All mRNAs on chromosome 1 between 5000 and 6000: @features = $db->features(-seqid=>'Chr1',-start=>5000,-end=>6000,-types=>'mRNA'); All confirmed mRNAs and repeats on chromosome 1 that overlap the range 5000..6000: @features = $db->features(-seqid => 'Chr1',-start=>5000,-end=>6000, -types => ['mRNA','repeat'], -attributes=> {confirmed=>1} ); All confirmed mRNAs and repeats on chromosome 1 strictly contained within the range 5000..6000: @features = $db->features(-seqid => 'Chr1',-start=>5000,-end=>6000, -types => ['mRNA','repeat'], -attributes=> {confirmed=>1} -range_type => 'contained_in', ); All genes and repeats: @features = $db->features('gene','repeat_region'); =cut # documentation of args # my ($seq_id,$start,$end,$strand, # $name,$class,$allow_aliases, # $types, # $attributes, # $range_type, # $iterator, # ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND', # 'NAME','CLASS','ALIASES', # ['TYPES','TYPE','PRIMARY_TAG'], # ['ATTRIBUTES','ATTRIBUTE'], # 'RANGE_TYPE', # ],@_); # $range_type ||= 'overlaps'; sub features { my $self = shift; my @args; if (@_ == 0) { @args = (); } elsif ($_[0] !~/^-/) { my @types = @_; @args = (-type=>\@types); } else { @args = @_; } $self->_features(@args); } =head2 get_all_features Title : get_all_features Usage : @features = $db->get_all_features() Function: get all feature in the database Returns : list of features Args : none Status : Public =cut # for compatibility with Bio::SeqFeature::Collection sub get_all_features { shift->features(); } =head2 seq_ids Title : seq_ids Usage : @ids = $db->seq_ids() Function: Return all sequence IDs contained in database Returns : list of sequence Ids Args : none Status : public =cut sub seq_ids { my $self = shift; return $self->_seq_ids(); } =head2 search_attributes Title : search_attributes Usage : @result_list = $db->search_attributes("text search string",[$tag1,$tag2...],$limit) Function: Search attributes for keywords occurring in a text string Returns : array of results Args : full text search string, array ref of attribute names, and an optional feature limit Status : public Given a search string, this method performs a full-text search of the specified attributes and returns an array of results. You may pass a scalar attribute name to search the values of one attribute (e.g. "Note") or you may pass an array reference to search inside multiple attributes (['Note','Alias','Parent']).Each row of the returned array is a arrayref containing the following fields: column 1 The display name of the feature column 2 The text of the note column 3 A relevance score. column 4 The feature type column 5 The unique ID of the feature NOTE: This search will fail to find features that do not have a display name! You can use fetch() or fetch_many() with the returned IDs to get to the features themselves. =cut sub search_attributes { my $self = shift; my ($search_string,$attribute_names,$limit) = @_; my $attribute_array = ref $attribute_names && ref $attribute_names eq 'ARRAY' ? $attribute_names : [$attribute_names]; return $self->_search_attributes($search_string,$attribute_array,$limit); } =head2 search_notes Title : search_notes Usage : @result_list = $db->search_notes("full text search string",$limit) Function: Search the notes for a text string Returns : array of results Args : full text search string, and an optional feature limit Status : public Given a search string, this method performs a full-text search of the "Notes" attribute and returns an array of results. Each row of the returned array is a arrayref containing the following fields: column 1 The display_name of the feature, suitable for passing to get_feature_by_name() column 2 The text of the note column 3 A relevance score. column 4 The type NOTE: This is equivalent to $db-Esearch_attributes('full text search string','Note',$limit). This search will fail to find features that do not have a display name! =cut ### # search_notes() # sub search_notes { my $self = shift; my ($search_string,$limit) = @_; return $self->_search_attributes($search_string,['Note'],$limit); } =head2 types Title : types Usage : @type_list = $db->types Function: Get all the types in the database Returns : array of Bio::DB::GFF::Typename objects Args : none Status : public =cut sub types { shift->throw_not_implemented; } =head2 insert_sequence Title : insert_sequence Usage : $success = $db->insert_sequence($seqid,$sequence_string,$offset) Function: Inserts sequence data into the database at the indicated offset Returns : true if successful Args : see below Status : public This method inserts the DNA or protein sequence fragment $sequence_string, identified by the ID $seq_id, into the database at the indicated offset $offset. It is used internally by the GFF3Loader to load sequence data from the files. =cut ### # insert_sequence() # # insert a bit of primary sequence into the database # sub insert_sequence { my $self = shift; my ($seqid,$seq,$offset) = @_; $offset ||= 0; $self->_insert_sequence($seqid,$seq,$offset); } =head2 fetch_sequence Title : fetch_sequence Usage : $sequence = $db->fetch_sequence(-seq_id=>$seqid,-start=>$start,-end=>$end) Function: Fetch the indicated subsequene from the database Returns : The sequence string (not a Bio::PrimarySeq object!) Args : see below Status : public This method retrieves a portion of the indicated sequence. The arguments are: Argument Value -------- ----- -seq_id Chromosome, contig or other DNA segment -seqid Synonym for -seq_id -name Synonym for -seq_id -start Start of range -end End of range -class Obsolete argument used for Bio::DB::GFF compatibility. If specified will qualify the seq_id as "$class:$seq_id". -bioseq Boolean flag; if true, returns a Bio::PrimarySeq object instead of a sequence string. You can call fetch_sequence using the following shortcuts: $seq = $db->fetch_sequence('chr3'); # entire chromosome $seq = $db->fetch_sequence('chr3',1000); # position 1000 to end of chromosome $seq = $db->fetch_sequence('chr3',undef,5000); # position 1 to 5000 $seq = $db->fetch_sequence('chr3',1000,5000); # positions 1000 to 5000 =cut ### # fetch_sequence() # # equivalent to old Bio::DB::GFF->dna() method # sub fetch_sequence { my $self = shift; my ($seqid,$start,$end,$class,$bioseq) = rearrange([['NAME','SEQID','SEQ_ID'], 'START',['END','STOP'],'CLASS','BIOSEQ'],@_); $seqid = "$seqid:$class" if defined $class; my $seq = $self->seq($seqid,$start,$end); return $seq unless $bioseq; require Bio::Seq unless Bio::Seq->can('new'); my $display_id = defined $start ? "$seqid:$start..$end" : $seqid; return Bio::Seq->new(-display_id=>$display_id,-seq=>$seq); } =head2 segment Title : segment Usage : $segment = $db->segment($seq_id [,$start] [,$end] [,$absolute]) Function: restrict the database to a sequence range Returns : a Bio::DB::SeqFeature::Segment object Args : sequence id, start and end ranges (optional) Status : public This is a convenience method that can be used when you are interested in the contents of a particular sequence landmark, such as a contig. Specify the ID of a sequence or other landmark in the database and optionally a start and endpoint relative to that landmark. The method will look up the region and return a Bio::DB::SeqFeature::Segment object that spans it. You can then use this segment object to make location-restricted queries on the database. Example: $segment = $db->segment('contig23',1,1000); # first 1000 bp of contig23 my @mRNAs = $segment->features('mRNA'); # all mRNAs that overlap segment Although you will usually want to fetch segments that correspond to physical sequences in the database, you can actually use any feature in the database as the sequence ID. The segment() method will perform a get_features_by_name() internally and then transform the feature into the appropriate coordinates. The named feature should exist once and only once in the database. If it exists multiple times in the database and you attempt to call segment() in a scalar context, you will get an exception. A workaround is to call the method in a list context, as in: my ($segment) = $db->segment('contig23',1,1000); or my @segments = $db->segment('contig23',1,1000); However, having multiple same-named features in the database is often an indication of underlying data problems. If the optional $absolute argument is a true value, then the specified coordinates are relative to the reference (absolute) coordinates. =cut ### # Replacement for Bio::DB::GFF->segment() method # sub segment { my $self = shift; my (@features,@args); if (@_ == 1 && blessed($_[0])) { @features = @_; @args = (); } else { @args = $self->setup_segment_args(@_); @features = $self->get_features_by_name(@args); } if (!wantarray && @features > 1) { $self->throw(<seq_id; my $strand = $f->strand; my ($start,$end); if ($abs) { $start = $rel_start; $end = defined $rel_end ? $rel_end : $start + $f->length - 1; } else { my $re = defined $rel_end ? $rel_end : $f->end - $f->start + 1; if ($strand >= 0) { $start = $f->start + $rel_start - 1; $end = $f->start + $re - 1; } else { $start = $f->end - $re + 1; $end = $f->end - $rel_start + 1; } } my $id = eval{$f->primary_id}; push @segments,Bio::DB::SeqFeature::Segment->new($self,$seqid,$start,$end,$strand,$id); } return wantarray ? @segments : $segments[0]; } =head2 seqfeature_class Title : seqfeature_class Usage : $classname = $db->seqfeature_class([$new_classname]) Function: get or set the name of the Bio::SeqFeatureI class generated by new_feature() Returns : name of class Args : new classname (optional) Status : public =cut sub seqfeature_class { my $self = shift; my $d = $self->{seqfeatureclass}; if (@_) { my $class = shift; eval "require $class"; $self->throw("$class does not implement the Bio::SeqFeatureI interface") unless $class->isa('Bio::SeqFeatureI'); $self->{seqfeatureclass} = $class; } $d; } =head2 reindex Title : reindex Usage : $db->reindex Function: reindex the database Returns : nothing Args : nothing Status : public This method will force the secondary indexes (name, location, attributes, feature types) to be recalculated. It may be useful to rebuild a corrupted database. =cut ### # force reindexing # sub reindex { my $self = shift; my $count = 0; my $now; my $last_time = time(); $self->_start_reindexing; my $iterator = $self->get_seq_stream; while (my $f = $iterator->next_seq) { if (++$count %1000 == 0) { $now = time(); my $elapsed = sprintf(" in %5.2fs",$now - $last_time); $last_time = $now; print STDERR "$count features indexed$elapsed...",' 'x60; print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; } $self->_update_indexes($f); } $self->_end_reindexing; } =head2 attributes Title : attributes Usage : @a = $db->attributes Function: Returns list of all known attributes Returns : Returns list of all known attributes Args : nothing Status : public =cut sub attributes { my $self = shift; shift->throw_not_implemented; } =head2 start_bulk_update,finish_bulk_update Title : start_bulk_update,finish_bulk_update Usage : $db->start_bulk_update $db->finish_bulk_update Function: Activate optimizations for large number of insertions/updates Returns : nothing Args : nothing Status : public With some adaptors (currently only the DBI::mysql adaptor), these methods signal the adaptor that a large number of insertions or updates are to be performed, and activate certain optimizations. These methods are called automatically by the Bio::DB::SeqFeature::Store::GFF3Loader module. Example: $db->start_bulk_update; for my $f (@features) { $db->store($f); } $db->finish_bulk_update; =cut sub start_bulk_update { shift->_start_bulk_update(@_) } sub finish_bulk_update { shift->_finish_bulk_update(@_) } =head2 add_SeqFeature Title : add_SeqFeature Usage : $count = $db->add_SeqFeature($parent,@children) Function: store a parent/child relationship between a $parent and @children features that are already stored in the database Returns : number of children successfully stored Args : parent feature or primary ID and children features or primary IDs Status : OPTIONAL; MAY BE IMPLEMENTED BY ADAPTORS If can_store_parentage() returns true, then some store-aware features (e.g. Bio::DB::SeqFeature) will invoke this method to store feature/subfeature relationships in a normalized table. =cut # these two are called only if _can_store_subFeatures() returns true # _add_SeqFeature ($parent,@children) sub add_SeqFeature { shift->_add_SeqFeature(@_) } =head2 fetch_SeqFeatures Title : fetch_SeqFeatures Usage : @children = $db->fetch_SeqFeatures($parent_feature) Function: return the immediate subfeatures of the indicated feature Returns : list of subfeatures Args : the parent feature and an optional list of children types Status : OPTIONAL; MAY BE IMPLEMENTED BY ADAPTORS If can_store_parentage() returns true, then some store-aware features (e.g. Bio::DB::SeqFeature) will invoke this method to retrieve feature/subfeature relationships from the database. =cut # _get_SeqFeatures($parent,@child_types) sub fetch_SeqFeatures { my ($self, $parent, @child_types) = @_; return unless defined $parent->primary_id; $self->_fetch_SeqFeatures($parent,@child_types); } =head1 Changing the Behavior of the Database These methods allow you to modify the behavior of the database. =head2 debug Title : debug Usage : $debug_flag = $db->debug([$new_flag]) Function: set the debug flag Returns : current debug flag Args : new debug flag Status : public This method gets/sets a flag that turns on verbose progress messages. Currently this will not do very much. =cut sub debug { my $self = shift; my $d = $self->{debug}; $self->{debug} = shift if @_; $d; } =head2 serializer Title : serializer Usage : $serializer = $db->serializer([$new_serializer]) Function: get/set the name of the serializer Returns : the name of the current serializer class Args : (optional) the name of a new serializer Status : public You can use this method to set the serializer, but do not attempt to change the serializer once the database is initialized and populated. =cut ### # serializer # sub serializer { my $self = shift; my $d = $self->setting('serializer'); if (@_) { my $serializer = shift; eval "require $serializer; 1" or croak $@; $self->setting(serializer=>$serializer); if ($serializer eq 'Storable') { $Storable::forgive_me =1; $Storable::Deparse = 1; $Storable::Eval = 1; } } $d; } =head2 dna_accessor Title : dna_accessor Usage : $dna_accessor = $db->dna_accessor([$new_dna_accessor]) Function: get/set the name of the dna_accessor Returns : the current dna_accessor object, if any Args : (optional) the dna_accessor object Status : public You can use this method to request or set the DNA accessor. =cut ### # dna_accessor # sub dna_accessor { my $self = shift; my $d = $self->{dna_accessor}; $self->{dna_accessor} = shift if @_; $d; } sub can_do_seq { my $self = shift; my $obj = shift; return UNIVERSAL::can($obj,'seq') || UNIVERSAL::can($obj,'fetch_sequence'); } sub set_dna_accessor { my $self = shift; my $accessor = shift; if (-e $accessor) { # a file, assume it is a fasta file eval "require Bio::DB::Fasta" unless Bio::DB::Fasta->can('new'); my $a = Bio::DB::Fasta->new($accessor) or croak "Can't open FASTA file $accessor: $!"; $self->dna_accessor($a); } if (ref $accessor && $self->can_do_seq($accessor)) { $self->dna_accessor($accessor); # already built } return; } sub do_compress { my $self = shift; if (@_) { my $do_compress = shift; $self->setting(compress => $do_compress); } my $d = $self->setting('compress'); if ($d) { eval "use Compress::Zlib; 1" or croak $@ unless Compress::Zlib->can('compress'); } $d; } =head2 index_subfeatures Title : index_subfeatures Usage : $flag = $db->index_subfeatures([$new_value]) Function: flag whether to index subfeatures Returns : current value of the flag Args : (optional) new value of the flag Status : public If true, the store() method will add a searchable index to both the top-level feature and all its subfeatures, allowing the search functions to return features at any level of the containment hierarchy. If false, only the top level feature will be indexed, meaning that you will only be able to get at subfeatures by fetching the top-level feature and then traversing downward using get_SeqFeatures(). You are free to change this setting at any point during the creation and population of a database. One database can contain both indexed and unindexed subfeatures. =cut ### # whether to index subfeatures by default # sub index_subfeatures { my $self = shift; my $d = $self->setting('index_subfeatures'); $self->setting('index_subfeatures'=>shift) if @_; $d; } =head2 clone The clone() method should be used when you want to pass the Bio::DB::SeqFeature::Store object to a child process across a fork(). The child must call clone() before making any queries. The default behavior is to do nothing, but adaptors that use the DBI interface may need to implement this in order to avoid database handle errors. See the dbi adaptor for an example. =cut sub clone { } ################################# TIE interface #################### =head1 TIE Interface This module implements a full TIEHASH interface. The keys are the primary IDs of the features in the database. Example: tie %h,'Bio::DB::SeqFeature::Store',-adaptor=>'DBI::mysql',-dsn=>'dbi:mysql:elegans'; $h{123} = $feature1; $h{124} = $feature2; print $h{123}->display_name; =cut sub TIEHASH { my $class = shift; return $class->new(@_); } sub STORE { my $self = shift; my ($key,$feature) = @_; $key =~ /^\d+$/ && $key > 0 or croak "keys must be positive integers"; $self->load_class($feature); $feature->primary_id($key); $self->store($feature); } sub FETCH { my $self = shift; $self->fetch(@_); } sub FIRSTKEY { my $self = shift; $self->_firstid; } sub NEXTKEY { my $self = shift; my $lastkey = shift; $self->_nextid($lastkey); } sub EXISTS { my $self = shift; my $key = shift; $self->existsid($key); } sub DELETE { my $self = shift; my $key = shift; $self->_deleteid($key); } sub CLEAR { my $self = shift; $self->_clearall; } sub SCALAR { my $self = shift; $self->_featurecount; } ###################### TO BE IMPLEMENTED BY ADAPTOR ########## =head2 _init_database Title : _init_database Usage : $success = $db->_init_database([$erase]) Function: initialize an empty database Returns : true on success Args : optional boolean flag to erase contents of an existing database Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY AN ADAPTOR This method is the back end for init_database(). It must be implemented by an adaptor that inherits from Bio::DB::SeqFeature::Store. It returns true on success. @features = $db->features(-seqid=>'Chr1'); =cut sub _init_database { shift->throw_not_implemented } =head2 _store Title : _store Usage : $success = $db->_store($indexed,@objects) Function: store seqfeature objects into database Returns : true on success Args : a boolean flag indicating whether objects are to be indexed, and one or more objects Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY AN ADAPTOR This method is the back end for store() and store_noindex(). It should write the seqfeature objects into the database. If indexing is requested, the features should be indexed for query and retrieval. Otherwise the features should be stored without indexing (it is not required that adaptors respect this). If the object has no primary_id (undef), then the object is written into the database and assigned a new primary_id. If the object already has a primary_id, then the system will perform an update, replacing whatever was there before. In practice, the implementation will serialize each object using the freeze() method and then store it in the database under the corresponding primary_id. The object is then updated with the primary_id. =cut # _store($indexed,@objs) sub _store { my $self = shift; my $indexed = shift; my @objs = @_; $self->throw_not_implemented; } =head2 _fetch Title : _fetch Usage : $feature = $db->_fetch($primary_id) Function: fetch feature from database Returns : feature Args : primary id Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY AN ADAPTOR This method is the back end for fetch(). It accepts a primary_id and returns a feature object. It must be implemented by the adaptor. In practice, the implementation will retrieve the serialized Bio::SeqfeatureI object from the database and pass it to the thaw() method to unserialize it and synchronize the primary_id. =cut # _fetch($id) sub _fetch { shift->throw_not_implemented } =head2 _fetch_many Title : _fetch_many Usage : $feature = $db->_fetch_many(@primary_ids) Function: fetch many features from database Returns : feature Args : primary id Status : private -- does not need to be implemented This method fetches many features specified by a list of IDs. The default implementation simply calls _fetch() once for each primary_id. Implementors can override it if needed for efficiency. =cut # _fetch_many(@ids) # this one will fall back to many calls on fetch() if you don't # override it sub _fetch_many { my $self = shift; return map {$self->_fetch($_)} @_; } =head2 _update_indexes Title : _update_indexes Usage : $success = $db->_update_indexes($feature) Function: update the indexes for a feature Returns : true on success Args : A seqfeature object Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY AN ADAPTOR This method is called by reindex() to update the searchable indexes for a feature object that has changed. =cut # this is called to index a feature sub _update_indexes { shift->throw_not_implemented } =head2 _start_reindexing, _end_reindexing Title : _start_reindexing, _end_reindexing Usage : $db->_start_reindexing() $db->_end_reindexing Function: flag that a series of reindexing operations is beginning/ending Returns : true on success Args : none Status : MAY BE IMPLEMENTED BY AN ADAPTOR (optional) These methods are called by reindex() before and immediately after a series of reindexing operations. The default behavior is to do nothing, but these methods can be overridden by an adaptor in order to perform optimizations, turn off autocommits, etc. =cut # these do not necessary have to be overridden # they are called at beginning and end of reindexing process sub _start_reindexing {} sub _end_reindexing {} =head2 _features Title : _features Usage : @features = $db->_features(@args) Function: back end for all get_feature_by_*() queries Returns : list of features Args : see below Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY ADAPTOR This is the backend for features(), get_features_by_name(), get_features_by_location(), etc. Arguments are as described for the features() method, except that only the named-argument form is recognized. =cut # bottleneck query generator sub _features { shift->throw_not_implemented } =head2 _search_attributes Title : _search_attributes Usage : @result_list = $db->_search_attributes("text search string",[$tag1,$tag2...],$limit) Function: back end for the search_attributes() method Returns : results list Args : as per search_attributes() Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY ADAPTOR See search_attributes() for the format of the results list. The only difference between this and the public method is that the tag list is guaranteed to be an array reference. =cut sub _search_attributes { shift->throw_not_implemented } =head2 can_store_parentage Title : can_store_parentage Usage : $flag = $db->can_store_parentage Function: return true if this adaptor can store parent/child relationships Returns : boolean Args : none Status : OPTIONAL; MAY BE IMPLEMENTED BY ADAPTORS Override this method and return true if this adaptor supports the _add_SeqFeature() and _get_SeqFeatures() methods, which are used for storing feature parent/child relationships in a normalized fashion. Default is false (parent/child relationships are stored in denormalized form in each feature). =cut # return true here if the storage engine is prepared to store parent/child # relationships using _add_SeqFeature and return them using _fetch_SeqFeatures sub can_store_parentage { return; } =head2 _add_SeqFeature Title : _add_SeqFeature Usage : $count = $db->_add_SeqFeature($parent,@children) Function: store a parent/child relationship between $parent and @children Returns : number of children successfully stored Args : parent feature and one or more children Status : OPTIONAL; MAY BE IMPLEMENTED BY ADAPTORS If can_store_parentage() returns true, then some store-aware features (e.g. Bio::DB::SeqFeature) will invoke this method to store feature/subfeature relationships in a normalized table. =cut sub _add_SeqFeature { shift->throw_not_implemented } =head2 _fetch_SeqFeatures Title : _fetch_SeqFeatures Usage : @children = $db->_fetch_SeqFeatures($parent_feature) Function: return the immediate subfeatures of the indicated feature Returns : list of subfeatures Args : the parent feature Status : OPTIONAL; MAY BE IMPLEMENTED BY ADAPTORS If can_store_parentage() returns true, then some store-aware features (e.g. Bio::DB::SeqFeature) will invoke this method to retrieve feature/subfeature relationships from the database. =cut # _get_SeqFeatures($parent,@list_of_child_types) sub _fetch_SeqFeatures {shift->throw_not_implemented } =head2 _insert_sequence Title : _insert_sequence Usage : $success = $db->_insert_sequence($seqid,$sequence_string,$offset) Function: Inserts sequence data into the database at the indicated offset Returns : true if successful Args : see below Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY ADAPTOR This is the back end for insert_sequence(). Adaptors must implement this method in order to store and retrieve nucleotide or protein sequence. =cut sub _insert_sequence { shift->throw_not_implemented } # _fetch_sequence() is similar to old dna() method =head2 _fetch_sequence Title : _fetch_sequence Usage : $sequence = $db->_fetch_sequence(-seq_id=>$seqid,-start=>$start,-end=>$end) Function: Fetch the indicated subsequence from the database Returns : The sequence string (not a Bio::PrimarySeq object!) Args : see below Status : ABSTRACT METHOD; MUST BE IMPLEMENTED BY ADAPTOR This is the back end for fetch_sequence(). Adaptors must implement this method in order to store and retrieve nucleotide or protein sequence. =cut sub _fetch_sequence { shift->throw_not_implemented } sub seq { my $self = shift; my ($seq_id,$start,$end) = @_; if (my $a = $self->dna_accessor) { return $a->can('seq') ? $a->seq($seq_id,$start,$end) :$a->can('fetch_sequence')? $a->fetch_sequence($seq_id,$start,$end) : undef; } else { return $self->_fetch_sequence($seq_id,$start,$end); } } =head2 _seq_ids Title : _seq_ids Usage : @ids = $db->_seq_ids() Function: Return all sequence IDs contained in database Returns : list of sequence Ids Args : none Status : TO BE IMPLEMENTED BY ADAPTOR This method is invoked by seq_ids() to return all sequence IDs (coordinate systems) known to the database. =cut sub _seq_ids { shift->throw_not_implemented } =head2 _start_bulk_update,_finish_bulk_update Title : _start_bulk_update, _finish_bulk_update Usage : $db->_start_bulk_update $db->_finish_bulk_update Function: Activate optimizations for large number of insertions/updates Returns : nothing Args : nothing Status : OPTIONAL; MAY BE IMPLEMENTED BY ADAPTOR These are the backends for start_bulk_update() and finish_bulk_update(). The default behavior of both methods is to do nothing. =cut # Optional flags to change behavior to optimize bulk updating. sub _start_bulk_update { } sub _finish_bulk_update { } # for full TIE() interface - not necessary to implement in most cases =head2 Optional methods needed to implement full TIEHASH interface The core TIEHASH interface will work if just the _store() and _fetch() methods are implemented. To support the full TIEHASH interface, including support for keys(), each(), and exists(), the following methods should be implemented: =over 4 =item $id = $db-E_firstid() Return the first primary ID in the database. Needed for the each() function. =item $next_id = $db-E_nextid($id) Given a primary ID, return the next primary ID in the series. Needed for the each() function. =item $boolean = $db-E_existsid($id) Returns true if the indicated primary ID is in the database. Needed for the exists() function. =item $db-E_deleteid($id) Delete the feature corresponding to the given primary ID. Needed for delete(). =item $db-E_clearall() Empty the database. Needed for %tied_hash = (). =item $count = $db-E_featurecount() Return the number of features in the database. Needed for scalar %tied_hash. =back =cut sub _firstid { shift->throw_not_implemented } sub _nextid { shift->throw_not_implemented } sub _existsid { shift->throw_not_implemented } sub _deleteid { shift->throw_not_implemented } sub _clearall { shift->throw_not_implemented } sub _featurecount { shift->throw_not_implemented } =head1 Internal Methods These methods are internal to Bio::DB::SeqFeature::Store and adaptors. =head2 new_instance Title : new_instance Usage : $db = $db->new_instance() Function: class constructor Returns : A descendent of Bio::DB::SeqFeature::Store Args : none Status : internal This method is called internally by new() to create a new uninitialized instance of Bio::DB::SeqFeature::Store. It is used internally and should not be called by application software. =cut sub new_instance { my $class = shift; return bless {},ref($class) || $class; } =head2 init Title : init Usage : $db->init(@args) Function: initialize object Returns : none Args : Arguments passed to new() Status : private This method is called internally by new() to initialize a newly-created object using the arguments passed to new(). It is to be overridden by Bio::DB::SeqFeature::Store adaptors. =cut sub init { my $self = shift; $self->default_settings(); } =head2 default_settings Title : default_settings Usage : $db->default_settings() Function: set up default settings for the adaptor Returns : none Args : none Status : private This method is may be overridden by adaptors. It is responsible for setting up object default settings. =cut ### # default settings -- set up whatever are the proper default settings # sub default_settings { my $self = shift; $self->serializer($self->default_serializer); $self->index_subfeatures(1); } =head2 default_serializer Title : default_serializer Usage : $serializer = $db->default_serializer Function: finds an available serializer Returns : the name of an available serializer Args : none Status : private This method returns the name of an available serializer module. =cut ### # choose a serializer # sub default_serializer { my $self = shift; # try Storable eval "require Storable; 1" and return 'Storable'; eval "require Data::Dumper; 1" and return 'Data::Dumper'; croak "Unable to load either Storable or Data::Dumper. Please provide a serializer using -serializer"; } =head2 setting Title : setting Usage : $value = $db->setting('setting_name' [=> $new_value]) Function: get/set the value of a setting Returns : the value of the current setting Args : the name of the setting and optionally a new value for the setting Status : private This is a low-level procedure for persistently storing database settings. It can be overridden by adaptors. =cut # persistent settings # by default we store in the object sub setting { my $self = shift; my $variable_name = shift; my $d = $self->{setting}{$variable_name}; $self->{setting}{$variable_name} = shift if @_; $d; } =head2 subfeatures_are_indexed Title : subfeatures_are_indexed Usage : $flag = $db->subfeatures_are_indexed([$new_value]) Function: flag whether subfeatures are indexed Returns : a flag indicating that all subfeatures are indexed Args : (optional) new value of the flag Status : private This method is used internally by the Bio::DB::SeqFeature class to optimize some of its operations. It returns true if all of the subfeatures in the database are indexed; it returns false if at least one of the subfeatures is not indexed. Do not attempt to change the value of this setting unless you are writing an adaptor. =cut ### # whether subfeatures are all indexed # sub subfeatures_are_indexed { my $self = shift; my $d = $self->setting('subfeatures_are_indexed'); $self->setting(subfeatures_are_indexed => shift) if @_; $d; } =head2 subfeature_types_are_indexed Title : subfeature_types_are_indexed Usage : $flag = $db->subfeature_types_are_indexed Function: whether subfeatures are indexed by type Returns : a flag indicating that all subfeatures are indexed Args : none Status : private This method returns true if subfeature types are indexed. Default is to return the value of subfeatures_are_indexed(). =cut sub subfeature_types_are_indexed { my $self = shift; return $self->subfeatures_are_indexed; } =head2 subfeature_locations_are_indexed Title : subfeature_locations_are_indexed Usage : $flag = $db->subfeature_locations_are_indexed Function: whether subfeatures are indexed by type Returns : a flag indicating that all subfeatures are indexed Args : none Status : private This method returns true if subfeature locations are indexed. Default is to return the value of subfeatures_are_indexed(). =cut sub subfeature_locations_are_indexed { my $self = shift; return $self->subfeatures_are_indexed; } =head2 setup_segment_args Title : setup_segment_args Usage : @args = $db->setup_segment_args(@args) Function: munge the arguments to the segment() call Returns : munged arguments Args : see below Status : private This method is used internally by segment() to translate positional arguments into named argument=Evalue pairs. =cut sub setup_segment_args { my $self = shift; return @_ if defined $_[0] && $_[0] =~ /^-/; return (-name=>$_[0],-start=>$_[1],-end=>$_[2]) if @_ == 3; return (-class=>$_[0],-name=>$_[1]) if @_ == 2; return (-name=>$_[0]) if @_ == 1; return; } =head2 store_and_cache Title : store_and_cache Usage : $success = $db->store_and_cache(@features) Function: store features into database and update cache Returns : number of features stored Args : index the features? (0 or 1) and list of features Status : private This private method stores the list of Bio::SeqFeatureI objects into the database and caches them in memory for retrieval. =cut sub store_and_cache { my $self = shift; my $indexit = shift; my $result = $self->_store($indexit,@_); if (my $cache = $self->cache) { for my $obj (@_) { defined (my $id = eval {$obj->primary_id}) or next; $cache->store($id,$obj); } } $result; } =head2 init_cache Title : init_cache Usage : $db->init_cache($size) Function: initialize the in-memory feature cache Returns : the Tie::Cacher object Args : desired size of the cache Status : private This method is used internally by new() to create the Tie::Cacher instance used for the in-memory feature cache. =cut sub init_cache { my $self = shift; my $cache_size = shift; $cache_size = 5000 if $cache_size == 1; # in case somebody treats it as a flag $self->{cache} = Tie::Cacher->new($cache_size) or $self->throw("Couldn't tie cache: $!"); } =head2 cache Title : cache Usage : $cache = $db->cache Function: return the cache object Returns : the Tie::Cacher object Args : none Status : private This method returns the Tie::Cacher object used for the in-memory feature cache. =cut sub cache { shift->{cache} } =head2 load_class Title : load_class Usage : $db->load_class($blessed_object) Function: loads the module corresponding to a blessed object Returns : empty Args : a blessed object Status : private This method is used by thaw() to load the code for a blessed object. This ensures that all the object's methods are available. =cut sub load_class { my $self = shift; my $obj = shift; return unless defined $obj; return if $self->{class_loaded}{ref $obj}++; unless ($obj && $obj->can('primary_id')) { my $class = ref $obj; eval "require $class"; } } #################################### Internal methods #################### =head2 freeze Title : freeze Usage : $serialized_object = $db->freeze($feature) Function: serialize a feature object into a string Returns : serialized feature object Args : a seqfeature object Status : private This method converts a Bio::SeqFeatureI object into a serialized form suitable for storage into a database. The feature's primary ID is set to undef before it is serialized. This avoids any potential mismatch between the primary ID used as the database key and the primary ID stored in the serialized object. =cut sub freeze { my $self = shift; my $obj = shift; # Bio::SeqFeature::Generic contains cleanup methods, so we need to # localize the methods to undef temporarily so that we can serialize local $obj->{'_root_cleanup_methods'} if exists $obj->{'_root_cleanup_methods'}; my ($id,$store); $id = $obj->primary_id(); $obj->primary_id(undef); # don't want primary ID to be stored in object eval { $store = $obj->object_store; $obj->object_store(undef); # don't want a copy of the store in the object }; my $serializer = $self->serializer; my $data; if ($serializer eq 'Data::Dumper') { my $d = Data::Dumper->new([$obj]); $d->Terse(1); $d->Deepcopy(1); $data = $d->Dump; } elsif ($serializer eq 'Storable') { $data = Storable::nfreeze($obj); } $obj->primary_id($id); # restore to original state eval { $obj->object_store($store); }; $data = compress($data) if $self->do_compress; return $data; } =head2 thaw Title : thaw Usage : $feature = $db->thaw($serialized_object,$primary_id) Function: unserialize a string into a feature object Returns : Bio::SeqFeatureI object Args : serialized form of object from freeze() and primary_id of object Status : private This method is the reverse of the freeze(). The supplied primary_id becomes the primary_id() of the returned Bio::SeqFeatureI object. This implementation checks for a deserialized object in the cache before it calls thaw_object() to do the actual deserialization. =cut sub thaw { my $self = shift; my ($obj,$primary_id) = @_; if (my $cache = $self->cache) { return $cache->fetch($primary_id) if $cache->exists($primary_id); my $object = $self->thaw_object($obj,$primary_id) or return; $cache->store($primary_id,$object); return $object; } else { return $self->thaw_object($obj,$primary_id); } } =head2 thaw_object Title : thaw_object Usage : $feature = $db->thaw_object($serialized_object,$primary_id) Function: unserialize a string into a feature object Returns : Bio::SeqFeatureI object Args : serialized form of object from freeze() and primary_id of object Status : private After thaw() checks the cache and comes up empty, this method is invoked to thaw the object. =cut sub thaw_object { my $self = shift; my ($obj,$primary_id) = @_; my $serializer = $self->serializer; my $object; $obj = uncompress($obj) if $self->do_compress; if ($serializer eq 'Data::Dumper') { $object = eval $obj; } elsif ($serializer eq 'Storable') { $object = Storable::thaw($obj); } # remember the primary ID of this object as well as the # identity of the store, so that we can do lazy loading; # both of these are wrapped in an eval because not all # bioseqfeatures support them (or want to) $self->load_class($object); eval { $object->primary_id($primary_id); $object->object_store($self); }; $object; } =head2 feature_names Title : feature_names Usage : ($names,$aliases) = $db->feature_names($feature) Function: get names and aliases for a feature Returns : an array of names and an array of aliases Args : a Bio::SeqFeatureI object Status : private This is an internal utility function which, given a Bio::SeqFeatureI object, returns two array refs. The first is a list of official names for the feature, and the second is a list of aliases. This is slightly skewed towards GFF3 usage, so the official names are the display_name(), plus all tag values named 'Name', plus all tag values named 'ID'. The aliases are all tag values named 'Alias'. =cut sub feature_names { my $self = shift; my $obj = shift; my $primary_id = $obj->primary_id; my @names; push @names,$obj->display_name if defined $obj->display_name; push @names,$obj->get_tag_values('Name') if $obj->has_tag('Name'); push @names,$obj->get_tag_values('ID') if $obj->has_tag('ID'); # don't think this is desired behavior # @names = grep {defined $_ && $_ ne $primary_id} @names; my @aliases = grep {defined} $obj->get_tag_values('Alias') if $obj->has_tag('Alias'); return (\@names,\@aliases); } =head2 feature_summary Title : feature_summary Usage : $summary = $db->feature_summary(@args) Function: returns a coverage summary across indicated region/type Returns : a Bio::SeqFeatureI object containing the "coverage" tag Args : see below Status : public This method is used to get coverage density information across a region of interest. You provide it with a region of interest, optional a list of feature types, and a count of the number of bins over which you want to calculate the coverage density. An object is returned corresponding to the requested region. It contains a tag called "coverage" that will return an array ref of "bins" length. Each element of the array describes the number of features that overlap the bin at this postion. Arguments: Argument Description -------- ----------- -seq_id Sequence ID for the region -start Start of region -end End of region -type/-types Feature type of interest or array ref of types -bins Number of bins across region. Defaults to 1000. -iterator Return an iterator across the region Note that this method uses an approximate algorithm that is only accurate to 500 bp, so when dealing with bins that are smaller than 1000 bp, you may see some shifting of counts between adjacent bins. Although an -iterator option is provided, the method only ever returns a single feature, so this is fairly useless. =cut sub feature_summary { my $self = shift; my ($seq_name,$start,$end,$types,$bins,$iterator) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'], ['TYPES','TYPE','PRIMARY_TAG'], 'BINS', 'ITERATOR', ],@_); my ($coverage,$tag) = $self->coverage_array(-seqid=> $seq_name, -start=> $start, -end => $end, -type => $types, -bins => $bins) or return; my $score = 0; for (@$coverage) { $score += $_ } $score /= @$coverage; my $feature = Bio::SeqFeature::Lite->new(-seq_id => $seq_name, -start => $start, -end => $end, -type => $tag, -score => $score, -attributes => { coverage => [$coverage] }); return $iterator ? Bio::DB::SeqFeature::Store::FeatureIterator->new($feature) : $feature; } =head2 coverage_array Title : coverage_array Usage : $arrayref = $db->coverage_array(@args) Function: returns a coverage summary across indicated region/type Returns : an array reference Args : see below Status : public This method is used to get coverage density information across a region of interest. The arguments are identical to feature_summary, except that instead of returning a Bio::SeqFeatureI object, it returns an array reference of the desired number of bins. The value of each element corresponds to the number of features in the bin. Arguments: Argument Description -------- ----------- -seq_id Sequence ID for the region -start Start of region -end End of region -type/-types Feature type of interest or array ref of types -bins Number of bins across region. Defaults to 1000. Note that this method uses an approximate algorithm that is only accurate to 500 bp, so when dealing with bins that are smaller than 1000 bp, you may see some shifting of counts between adjacent bins. =cut sub coverage_array { shift->throw_not_implemented; } package Bio::DB::SeqFeature::Store::FeatureIterator; sub new { my $self = shift; my @features = @_; return bless \@features,ref $self || $self; } sub next_seq { my $self = shift; return unless @$self; return shift @$self; } sub begin_work { }# noop sub commit { }# noop sub rollback { }# noop 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store000755000765000024 012254227333 17440 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/SeqFeature/Store/bdb.pm000444000765000024 464312254227312 20666 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::bdb; =head1 NAME Bio::DB::SeqFeature::Store::bdb - fetch and store objects from a BerkeleyDB =head1 DESCRIPTION This is a partial implementation -- just enough has been implemented so that we can fetch and store objects. It is used as a temporary failsafe store by the GFF3Loader module =cut use strict; use base 'Bio::DB::SeqFeature::Store'; use Bio::DB::GFF::Util::Rearrange 'rearrange'; use DB_File; use Fcntl qw(O_RDWR O_CREAT); use File::Temp 'tempdir'; use File::Path 'rmtree'; ### # object initialization # sub init { my $self = shift; my ($directory, $is_temporary) = rearrange([['DSN','DIR','DIRECTORY'], ['TMP','TEMP','TEMPORARY'] ],@_); $directory ||= $is_temporary ? File::Spec->tmpdir : '.'; $directory = tempdir(__PACKAGE__.'_XXXXXX',TMPDIR=>1,CLEANUP=>1,DIR=>$directory) if $is_temporary; -d $directory && -w _ or $self->throw("Can't write into the directory $directory"); $self->default_settings; $self->directory($directory); $self->temporary($is_temporary); my %h; tie (%h,'DB_File',$self->path,O_RDWR|O_CREAT,0666,$DB_HASH) or $self->throw("Couldn't tie: $!"); $self->db(\%h); $h{'.next_id'} ||= 1; } sub _store { my $self = shift; my $indexed = shift; my $db = $self->db; my $count = 0; for my $obj (@_) { my $primary_id = $obj->primary_id; $primary_id = $db->{'.next_id'}++ unless defined $primary_id; $db->{$primary_id} = $self->freeze($obj); $obj->primary_id($primary_id); $count++; } $count; } sub _update { my $self = shift; my ($object,$primary_id) = @_; my $db = $self->db; $self->throw("$object is not in database") unless exists $db->{$primary_id}; $db->{$primary_id} = $self->freeze($object); } sub _fetch { my $self = shift; my $id = shift; my $db = $self->db; my $obj = $self->thaw($db->{$id},$id); $obj; } sub db { my $self = shift; my $d = $self->setting('db'); $self->setting(db=>shift) if @_; $d; } sub directory { my $self = shift; my $d = $self->setting('directory'); $self->setting(directory=>shift) if @_; $d; } sub temporary { my $self = shift; my $d = $self->setting('temporary'); $self->setting(temporary=>shift) if @_; $d; } sub path { my $self = shift; return $self->directory .'/' . 'feature.bdb'; } sub DESTROY { my $self = shift; my $db = $self->db; untie %$db; rmtree($self->directory,0,1) if $self->temporary; } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/Store/berkeleydb.pm000444000765000024 12566612254227327 22326 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::berkeleydb; use strict; use base 'Bio::DB::SeqFeature::Store'; use Bio::DB::GFF::Util::Rearrange 'rearrange'; use DB_File; use Fcntl qw(O_RDWR O_CREAT :flock); use IO::File; use File::Temp 'tempdir'; use File::Path 'rmtree','mkpath'; use File::Basename; use File::Spec; use Carp 'carp','croak'; use constant BINSIZE => 10_000; use constant MININT => -999_999_999_999; use constant MAXINT => 999_999_999_999; =head1 NAME Bio::DB::SeqFeature::Store::berkeleydb -- Storage and retrieval of sequence annotation data in Berkeleydb files =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Create a database from the feature files located in /home/fly4.3 and store # the database index in the same directory: my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dir => '/home/fly4.3'); # Create a database that will monitor the files in /home/fly4.3, but store # the indexes in /var/databases/fly4.3 $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dir => '/home/fly4.3', -dsn => '/var/databases/fly4.3'); # Create a feature database from scratch $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dsn => '/var/databases/fly4.3', -create => 1); # get a feature from somewhere my $feature = Bio::SeqFeature::Generic->new(...); # store it $db->store($feature) or die "Couldn't store!"; # primary ID of the feature is changed to indicate its primary ID # in the database... my $id = $feature->primary_id; # get the feature back out my $f = $db->fetch($id); # change the feature and update it $f->start(100); $db->update($f) or $self->throw("Couldn't update!"); # use the GFF3 loader to do a bulk write: my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(-store => $db, -verbose => 0, -fast => 1); $loader->load('/home/fly4.3/dmel-all.gff'); # searching... # ...by id my @features = $db->fetch_many(@list_of_ids); # ...by name @features = $db->get_features_by_name('ZK909'); # ...by alias @features = $db->get_features_by_alias('sma-3'); # ...by type @features = $db->get_features_by_type('gene'); # ...by location @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000); # ...by attribute @features = $db->get_features_by_attribute({description => 'protein kinase'}) # ...by the GFF "Note" field @result_list = $db->search_notes('kinase'); # ...by arbitrary combinations of selectors @features = $db->features(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); # ...using an iterator my $iterator = $db->get_seq_stream(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); while (my $feature = $iterator->next_seq) { # do something with the feature } # ...limiting the search to a particular region my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features(-type=>['mRNA','match']); # what feature types are defined in the database? my @types = $db->types; # getting & storing sequence information # Warning: this returns a string, and not a PrimarySeq object $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...'); my $sequence = $db->fetch_sequence('Chr1',5000=>6000); # create a new feature in the database my $feature = $db->new_feature(-primary_tag => 'mRNA', -seq_id => 'chr3', -start => 10000, -end => 11000); =head1 DESCRIPTION Bio::DB::SeqFeature::Store::berkeleydb is the Berkeleydb adaptor for Bio::DB::SeqFeature::Store. You will not create it directly, but instead use Bio::DB::SeqFeature::Store-Enew() to do so. See L for complete usage instructions. =head2 Using the berkeleydb adaptor The Berkeley database consists of a series of Berkeleydb index files, and a couple of special purpose indexes. You can create the index files from scratch by creating a new database and calling new_feature() repeatedly, you can create the database and then bulk populate it using the GFF3 loader, or you can monitor a directory of preexisting GFF3 and FASTA files and rebuild the indexes whenever one or more of the fields changes. The last mode is probably the most convenient. Note that the indexer will only pay attention to files that end with .gff3, .wig and .fa. =over 4 =item The new() constructor The new() constructor method all the arguments recognized by Bio::DB::SeqFeature::Store, and a few additional ones. Standard arguments: Name Value ---- ----- -adaptor The name of the Adaptor class (default DBI::mysql) -serializer The name of the serializer class (default Storable) -index_subfeatures Whether or not to make subfeatures searchable (default true) -cache Activate LRU caching feature -- size of cache -compress Compresses features before storing them in database using Compress::Zlib Adaptor-specific arguments Name Value ---- ----- -dsn Where the index files are stored -dir Where the source (GFF3, FASTA) files are stored -autoindex An alias for -dir. -write Pass true to open the index files for writing. -create Pass true to create the index files if they don't exist (implies -write=>1) -locking Use advisory locking to avoid one process trying to read from the database while another is updating it (may not work properly over NFS). -temp Pass true to create temporary index files that will be deleted once the script exits. -verbose Pass true to report autoindexing operations on STDERR. (default is true). Examples: To create an empty database which will be populated using calls to store() or new_feature(), or which will be bulk-loaded using the GFF3 loader: $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dsn => '/var/databases/fly4.3', -create => 1); To open a preexisting database in read-only mode: $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dsn => '/var/databases/fly4.3'); To open a preexisting database in read/write (update) mode: $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dsn => '/var/databases/fly4.3', -write => 1); To monitor a set of GFF3 and FASTA files located in a directory and create/update the database indexes as needed. The indexes will be stored in a new subdirectory named "indexes": $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dir => '/var/databases/fly4.3'); As above, but store the source files and index files in separate directories: $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dsn => '/var/databases/fly4.3', -dir => '/home/gff3_files/fly4.3'); To be indexed, files must end with one of .gff3 (GFF3 format), .fa (FASTA format) or .wig (WIG format). B<-autoindex> is an alias for B<-dir>. You should specify B<-locking> in a multiuser environment, including the case in which the database is being used by a web server at the same time another user might be updating it. =back See L for all the access methods supported by this adaptor. The various methods for storing and updating features and sequences into the database are supported, but there is no locking. If two processes try to update the same database simultaneously, the database will likely become corrupted. =cut ### # object initialization # sub init { my $self = shift; my ($directory, $autoindex, $is_temporary, $write, $create, $verbose, $locking, ) = rearrange([['DSN','DB'], [qw(DIR AUTOINDEX)], ['TMP','TEMP','TEMPORARY'], [qw(WRITE WRITABLE)], 'CREATE', 'VERBOSE', [qw(LOCK LOCKING)], ],@_); $verbose = 1 unless defined $verbose; if ($autoindex) { -d $autoindex or $self->throw("Invalid directory $autoindex"); $directory ||= "$autoindex/indexes"; } $directory ||= $is_temporary ? File::Spec->tmpdir : '.'; # my $pacname = __PACKAGE__; if ($^O =~ /mswin/i) { $pacname =~ s/:+/_/g; } $directory = tempdir($pacname.'_XXXXXX', TMPDIR => 1, CLEANUP => 1, DIR => $directory) if $is_temporary; mkpath($directory); -d $directory or $self->throw("Invalid directory $directory"); $create++ if $is_temporary; $write ||= $create; $self->throw("Can't write into the directory $directory") if $write && !-w $directory; $self->default_settings; $self->directory($directory); $self->temporary($is_temporary); $self->verbose($verbose); $self->locking($locking); $self->_delete_databases() if $create; if ($autoindex && -d $autoindex) { $self->auto_reindex($autoindex); } $self->lock('shared'); # this step may rebless $self into a subclass # to preserve backward compatibility with older # databases while providing better performance for # new databases. $self->possibly_rebless($create); $self->_open_databases($write,$create,$autoindex); $self->_permissions($write,$create); return $self; } sub version { return 2.0 }; sub possibly_rebless { my $self = shift; my $create = shift; my $do_rebless; if ($create) { $do_rebless++; } else { # probe database my %h; tie (%h,'DB_File',$self->_features_path,O_RDONLY,0666,$DB_HASH) or return; $do_rebless = $h{'.version'} >= 3.0; } if ($do_rebless) { eval "require Bio::DB::SeqFeature::Store::berkeleydb3"; bless $self,'Bio::DB::SeqFeature::Store::berkeleydb3'; } } sub can_store_parentage { 1 } sub auto_reindex { my $self = shift; my $autodir = shift; my $result = $self->needs_auto_reindexing($autodir); if ($result && %$result) { $self->flag_autoindexing(1); $self->lock('exclusive'); $self->reindex_wigfiles($result->{wig},$autodir) if $result->{wig}; $self->reindex_ffffiles($result->{fff},$autodir) if $result->{fff}; $self->reindex_gfffiles($result->{gff},$autodir) if $result->{gff}; $self->dna_db(Bio::DB::Fasta::Subdir->new($autodir)); $self->unlock; $self->flag_autoindexing(0); } else { $self->dna_db(Bio::DB::Fasta::Subdir->new($autodir)); } } sub autoindex_flagfile { return File::Spec->catfile(shift->directory,'autoindex.pid'); } sub auto_index_in_process { my $self = shift; my $flag_file = $self->autoindex_flagfile; return unless -e $flag_file; # if flagfile exists, then check that PID still exists open my $fh,$flag_file or die "Couldn't open $flag_file: $!"; my $pid = <$fh>; close $fh; return 1 if kill 0=>$pid; warn "Autoindexing seems to be running in another process, but the process has gone away. Trying to override..."; if (unlink $flag_file) { warn "Successfully removed stale PID file." if $self->verbose; warn "Assuming partial reindexing process. Rebuilding indexes from scratch..." if $self->verbose; my $glob = File::Spec->catfile($self->directory,'*'); unlink glob($glob); return; } else { croak ("Cannot recover from apparent aborted autoindex process. Please remove files in ", $self->directory, " and allow the adaptor to reindex"); return 1; } } sub flag_autoindexing { my $self = shift; my $doit = shift; my $flag_file = $self->autoindex_flagfile; if ($doit) { open my $fh,'>',$flag_file or die "Couldn't open $flag_file: $!"; print $fh $$; close $fh; } else { unlink $flag_file; } } sub reindex_gfffiles { my $self = shift; my $files = shift; my $autodir = shift; warn "Reindexing GFF files...\n" if $self->verbose; my $exists = -e $self->_features_path; $self->_permissions(1,1); $self->_close_databases(); $self->_open_databases(1,!$exists); require Bio::DB::SeqFeature::Store::GFF3Loader unless Bio::DB::SeqFeature::Store::GFF3Loader->can('new'); my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(-store => $self, -sf_class => $self->seqfeature_class, -verbose => $self->verbose, ) or $self->throw("Couldn't create GFF3Loader"); my %seen; $loader->load(grep {!$seen{$_}++} @$files); $self->_touch_timestamp; } sub reindex_ffffiles { my $self = shift; my $files = shift; my $autodir = shift; warn "Reindexing FFF files...\n" if $self->verbose; $self->_permissions(1,1); $self->_close_databases(); $self->_open_databases(1,1); require Bio::DB::SeqFeature::Store::FeatureFileLoader unless Bio::DB::SeqFeature::Store::FeatureFileLoader->can('new'); my $loader = Bio::DB::SeqFeature::Store::FeatureFileLoader->new(-store => $self, -sf_class => $self->seqfeature_class, -verbose => $self->verbose, ) or $self->throw("Couldn't create FeatureFileLoader"); my %seen; $loader->load(grep {!$seen{$_}++} @$files); $self->_touch_timestamp; } sub reindex_wigfiles { my $self = shift; my $files = shift; my $autodir = shift; warn "Reindexing wig files...\n" if $self->verbose; unless (Bio::Graphics::Wiggle::Loader->can('new')) { eval "require Bio::Graphics::Wiggle::Loader; 1" or return; } for my $wig (@$files) { warn "Reindexing $wig...\n" if $self->verbose; my ($wib_name) = fileparse($wig,qr/\.[^.]*/); my $gff3_name = "$wib_name.gff3"; # unlink all wib files that share the basename my $wib_glob = File::Spec->catfile($self->directory,"$wib_name*.wib"); unlink glob($wib_glob); my $loader = Bio::Graphics::Wiggle::Loader->new($self->directory,$wib_name); my $fh = IO::File->new($wig) or die "Can't open $wig: $!"; $loader->load($fh); # will create one or more .wib files $fh->close; my $gff3_data = $loader->featurefile('gff3','microarray_oligo',$wib_name); my $gff3_path = File::Spec->catfile($autodir,$gff3_name); $fh = IO::File->new($gff3_path,'>') or die "Can't open $gff3_path for writing: $!"; $fh->print($gff3_data); $fh->close; my $conf_path = File::Spec->catfile($autodir,"$wib_name.conf"); $fh = IO::File->new($conf_path,'>'); $fh->print($loader->conf_stanzas('microarray_oligo',$wib_name)); $fh->close; } } # returns the following hashref # empty hash if nothing needs reindexing # {fasta => 1} if DNA database needs reindexing # {gff => [list,of,gff,paths]} if gff3 files need reindexing # {wig => [list,of,wig,paths]} if wig files need reindexing sub needs_auto_reindexing { my $self = shift; my $autodir = shift; my $result = {}; # don't allow two processes to reindex simultaneously $self->auto_index_in_process and croak "Autoindexing in process. Try again later"; # first interrogate the GFF3 files, using the timestamp file # as modification comparison my (@gff3,@fff,@wig,$fasta,$fasta_index_time); opendir (my $D,$autodir) or $self->throw("Couldn't open directory $autodir for reading: $!"); my $maxtime = 0; my $timestamp_time = _mtime($self->_mtime_path) || 0; while (defined (my $node = readdir($D))) { next if $node =~ /^\./; my $path = File::Spec->catfile($autodir,$node); next unless -f $path; if ($path =~ /\.gff\d?$/i) { my $mtime = _mtime(\*_); # not a typo $maxtime = $mtime if $mtime > $maxtime; push @gff3,$path; } elsif ($path =~ /\.fff?$/i) { my $mtime = _mtime(\*_); # not a typo $maxtime = $mtime if $mtime > $maxtime; push @fff,$path; } elsif ($path =~ /\.wig$/i) { my $wig = $path; (my $gff_file = $wig) =~ s/\.wig$/\.gff3/i; next if -e $gff_file && _mtime($gff_file) > _mtime($path); push @wig,$wig; push @gff3,$gff_file; $maxtime = time(); } elsif ($path =~ /\.(fa|fasta|dna)$/i) { $fasta_index_time = _mtime(File::Spec->catfile($self->directory,'fasta.index'))||0 unless defined $fasta_index_time; $fasta++ if _mtime($path) > $fasta_index_time; } } closedir $D; $result->{gff} = \@gff3 if $maxtime > $timestamp_time; $result->{wig} = \@wig if @wig; $result->{fff} = \@fff if @fff; $result->{fasta}++ if $fasta; return $result; } sub verbose { my $self = shift; my $d = $self->{verbose}; $self->{verbose} = shift if @_; return $d; } sub locking { my $self = shift; my $d = $self->{locking}; $self->{locking} = shift if @_; return $d; } sub lockfile { my $self = shift; return File::Spec->catfile($self->directory,'lock'); } sub lock { my $self = shift; my $mode = shift; return unless $self->locking; my $flag = $mode eq 'exclusive' ? LOCK_EX : LOCK_SH; my $lockfile = $self->lockfile; my $fh = $self->_flock_fh; unless ($fh) { my $open = -e $lockfile ? '<' : '>'; $fh = IO::File->new($lockfile,$open) or die "Cannot open $lockfile: $!"; } flock($fh,$flag); $self->_flock_fh($fh); } sub unlock { my $self = shift; return unless $self->locking; my $fh = $self->_flock_fh or return; flock($fh,LOCK_UN); undef $self->{flock_fh}; } sub _flock_fh { my $self = shift; my $d = $self->{flock_fh}; $self->{flock_fh} = shift if @_; $d; } sub _open_databases { my $self = shift; my ($write,$create,$ignore_errors) = @_; return if $self->db; # already open - don't reopen my $directory = $self->directory; unless (-d $directory) { # directory does not exist $create or $self->throw("Directory $directory does not exist and you did not specify the -create flag"); mkpath($directory) or $self->throw("Couldn't create database directory $directory: $!"); } my $flags = O_RDONLY; $flags |= O_RDWR if $write; $flags |= O_CREAT if $create; # Create the main database; this is a DB_HASH implementation my %h; my $result = tie (%h,'DB_File',$self->_features_path,$flags,0666,$DB_HASH); unless ($result) { return if $ignore_errors; # autoindex set, so defer this $self->throw("Couldn't tie: ".$self->_features_path . " $!"); } if ($create) { %h = (); $h{'.next_id'} = 1; $h{'.version'} = $self->version; } $self->db(\%h); $self->open_index_dbs($flags,$create); $self->open_parentage_db($flags,$create); $self->open_notes_db($write,$create); $self->open_seq_db($flags,$create) if -e $self->_fasta_path; } sub open_index_dbs { my $self = shift; my ($flags,$create) = @_; # Create the index databases; these are DB_BTREE implementations with duplicates allowed. $DB_BTREE->{flags} = R_DUP; $DB_BTREE->{compare} = sub { lc($_[0]) cmp lc($_[1]) }; for my $idx ($self->_index_files) { my $path = $self->_qualify("$idx.idx"); my %db; my $result = tie(%db,'DB_File',$path,$flags,0666,$DB_BTREE); # for backward compatibility, allow a failure when trying to open the is_indexed index. $self->throw("Couldn't tie $path: $!") unless $result || $idx eq 'is_indexed'; %db = () if $create; $self->index_db($idx=>\%db); } } sub open_parentage_db { my $self = shift; my ($flags,$create) = @_; # Create the parentage database my %p; tie (%p,'DB_File',$self->_parentage_path,$flags,0666,$DB_BTREE) or $self->throw("Couldn't tie: ".$self->_parentage_path . $!); %p = () if $create; $self->parentage_db(\%p); } sub open_notes_db { my $self = shift; my ($write,$create) = @_; my $mode = $write ? "+>>" : $create ? "+>" : "<"; open (my $F,$mode,$self->_notes_path) or $self->throw($self->_notes_path.": $!"); $self->notes_db($F); } sub open_seq_db { my $self = shift; if (-e $self->_fasta_path) { my $dna_db = Bio::DB::Fasta::Subdir->new($self->_fasta_path) or $self->throw("Can't reindex sequence file: $@"); $self->dna_db($dna_db); } } sub commit { # reindex fasta files my $self = shift; if (my $fh = $self->{fasta_fh}) { $fh->close; $self->dna_db(Bio::DB::Fasta::Subdir->new($self->{fasta_file})); } elsif (-d $self->directory) { $self->dna_db(Bio::DB::Fasta::Subdir->new($self->directory)); } } sub _close_databases { my $self = shift; $self->db(undef); $self->dna_db(undef); $self->notes_db(undef); $self->parentage_db(undef); $self->index_db($_=>undef) foreach $self->_index_files; } # do nothing -- new() with -create=>1 will do the trick sub _init_database { } sub _delete_databases { my $self = shift; for my $idx ($self->_index_files) { my $path = $self->_qualify("$idx.idx"); unlink $path; } unlink $self->_parentage_path; unlink $self->_fasta_path; unlink $self->_features_path; unlink $self->_mtime_path; } sub _touch_timestamp { my $self = shift; my $tsf = $self->_mtime_path; open (F,">$tsf") or $self->throw("Couldn't open $tsf: $!"); print F scalar(localtime); close F; } sub _store { my $self = shift; my $indexed = shift; my $db = $self->db; my $is_indexed = $self->index_db('is_indexed'); my $count = 0; for my $obj (@_) { my $primary_id = $obj->primary_id; $self->_delete_indexes($obj,$primary_id) if $indexed && $primary_id; $primary_id = $db->{'.next_id'}++ unless defined $primary_id; $db->{$primary_id} = $self->freeze($obj); $is_indexed->{$primary_id} = $indexed if $is_indexed; $obj->primary_id($primary_id); $self->_update_indexes($obj) if $indexed; $count++; } $count; } sub _delete_indexes { my $self = shift; my ($obj,$id) = @_; # the additional "1" causes the index to be deleted $self->_update_name_index($obj,$id,1); $self->_update_type_index($obj,$id,1); $self->_update_location_index($obj,$id,1); $self->_update_attribute_index($obj,$id,1); $self->_update_note_index($obj,$id,1); } sub _fetch { my $self = shift; my $id = shift; my $db = $self->db; my $obj = $self->thaw($db->{$id},$id); $obj; } sub _add_SeqFeature { my $self = shift; my $parent = shift; my @children = @_; my $parent_id = (ref $parent ? $parent->primary_id : $parent) or $self->throw("$parent should have a primary_id"); my $p = $self->parentage_db; for my $child (@children) { my $child_id = ref $child ? $child->primary_id : $child; defined $child_id or $self->throw("no primary ID known for $child"); $p->{$parent_id} = $child_id if tied(%$p)->find_dup($parent_id,$child_id); } return scalar @children; } sub _fetch_SeqFeatures { my $self = shift; my $parent = shift; my @types = @_; my $parent_id = $parent->primary_id or $self->throw("$parent should have a primary_id"); my $index = $self->parentage_db; my $db = tied %$index; my @children_ids = $db->get_dup($parent_id); my @children = map {$self->fetch($_)} @children_ids; if (@types) { foreach (@types) { my ($a,$b) = split ':',$_,2; $_ = quotemeta($a); if (length $b) { $_ .= ":".quotemeta($b).'$'; } else { $_ .= ':'; } } my $regexp = join '|', @types; return grep {($_->primary_tag.':'.$_->source_tag) =~ /^($regexp)/i} @children; } else { return @children; } } sub _update_indexes { my $self = shift; my $obj = shift; defined (my $id = $obj->primary_id) or return; $self->_update_name_index($obj,$id); $self->_update_type_index($obj,$id); $self->_update_location_index($obj,$id); $self->_update_attribute_index($obj,$id); $self->_update_note_index($obj,$id); } sub _update_name_index { my $self = shift; my ($obj,$id,$delete) = @_; my $db = $self->index_db('names') or $self->throw("Couldn't find 'names' index file"); my ($names,$aliases) = $self->feature_names($obj); # little stinky - needs minor refactoring foreach (@$names) { my $key = lc $_; $self->update_or_delete($delete,$db,$key,$id); } foreach (@$aliases) { my $key = lc($_)."_2"; # the _2 indicates a secondary (alias) ID $self->update_or_delete($delete,$db,$key,$id); } } sub _update_type_index { my $self = shift; my ($obj,$id,$delete) = @_; my $db = $self->index_db('types') or $self->throw("Couldn't find 'types' index file"); my $primary_tag = $obj->primary_tag; my $source_tag = $obj->source_tag || ''; return unless defined $primary_tag; $primary_tag .= ":$source_tag"; my $key = lc $primary_tag; $self->update_or_delete($delete,$db,$key,$id); } # Note: this indexing scheme is space-inefficient because it stores the # denormalized sequence ID followed by the bin in XXXXXX zero-leading # format. It should be replaced with a binary numeric encoding and the # BTREE {compare} attribute changed accordingly. sub _update_location_index { my $self = shift; my ($obj,$id,$delete) = @_; my $db = $self->index_db('locations') or $self->throw("Couldn't find 'locations' index file"); my $seq_id = $obj->seq_id || ''; my $start = $obj->start || ''; my $end = $obj->end || ''; my $strand = $obj->strand; my $bin_min = int $start/BINSIZE; my $bin_max = int $end/BINSIZE; for (my $bin = $bin_min; $bin <= $bin_max; $bin++ ) { my $key = sprintf("%s.%06d",lc($seq_id),$bin); $self->update_or_delete($delete,$db,$key,pack("i4",$id,$start,$end,$strand)); } } sub _update_attribute_index { my $self = shift; my ($obj,$id,$delete) = @_; my $db = $self->index_db('attributes') or $self->throw("Couldn't find 'attributes' index file"); for my $tag ($obj->get_all_tags) { for my $value ($obj->get_tag_values($tag)) { my $key = "${tag}:${value}"; $self->update_or_delete($delete,$db,$key,$id); } } } sub _update_note_index { my $self = shift; my ($obj,$id,$delete) = @_; return if $delete; # we don't know how to do this my $fh = $self->notes_db; my @notes = $obj->get_tag_values('Note') if $obj->has_tag('Note'); print $fh $_,"\t",pack("u*",$id) or $self->throw("An error occurred while updating note index: $!") foreach @notes; } sub update_or_delete { my $self = shift; my ($delete,$db,$key,$id) = @_; if ($delete) { tied(%$db)->del_dup($key,$id); } else { $db->{$key} = $id; } } # these methods return pointers to.... # the database that stores serialized objects sub db { my $self = shift; my $d = $self->setting('db'); $self->setting(db=>shift) if @_; $d; } sub parentage_db { my $self = shift; my $d = $self->setting('parentage_db'); $self->setting(parentage_db=>shift) if @_; $d; } # the Bio::DB::Fasta object sub dna_db { my $self = shift; my $d = $self->setting('dna_db'); $self->setting(dna_db=>shift) if @_; $d; } # the specialized notes database sub notes_db { my $self = shift; my $d = $self->setting('notes_db'); $self->setting(notes_db=>shift) if @_; $d; } # the is_indexed_db sub is_indexed_db { my $self = shift; my $d = $self->setting('is_indexed_db'); $self->setting(is_indexed_db=>shift) if @_; $d; } # The indicated index berkeley db sub index_db { my $self = shift; my $index_name = shift; my $d = $self->setting($index_name); $self->setting($index_name=>shift) if @_; $d; } sub _mtime { my $file = shift; my @stat = stat($file); return $stat[9]; } # return names of all the indexes sub _index_files { return qw(names types locations attributes is_indexed); } # the directory in which we store our indexes sub directory { my $self = shift; my $d = $self->setting('directory'); $self->setting(directory=>shift) if @_; $d; } # flag indicating that we are a temporary database sub temporary { my $self = shift; my $d = $self->setting('temporary'); $self->setting(temporary=>shift) if @_; $d; } sub _permissions { my $self = shift; my $d = $self->setting('permissions') or return; if (@_) { my ($write,$create) = @_; $self->setting(permissions=>[$write,$create]); } @$d; } # file name utilities... sub _qualify { my $self = shift; my $file = shift; return $self->directory .'/' . $file; } sub _features_path { shift->_qualify('features.bdb'); } sub _parentage_path { shift->_qualify('parentage.bdb'); } sub _type_path { shift->_qualify('types.idx'); } sub _location_path { shift->_qualify('locations.idx'); } sub _attribute_path { shift->_qualify('attributes.idx'); } sub _notes_path { shift->_qualify('notes.idx'); } sub _fasta_path { shift->_qualify('sequence.fa'); } sub _mtime_path { shift->_qualify('mtime.stamp'); } ########################################### # searching ########################################### sub _features { my $self = shift; my ($seq_id,$start,$end,$strand, $name,$class,$allow_aliases, $types, $attributes, $range_type, $iterator ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND', 'NAME','CLASS','ALIASES', ['TYPES','TYPE','PRIMARY_TAG'], ['ATTRIBUTES','ATTRIBUTE'], 'RANGE_TYPE', 'ITERATOR', ],@_); my (@from,@where,@args,@group); $range_type ||= 'overlaps'; my @result; unless (defined $name or defined $seq_id or defined $types or defined $attributes) { my $is_indexed = $self->index_db('is_indexed'); @result = $is_indexed ? grep {$is_indexed->{$_}} keys %{$self->db} : grep { !/^\./ }keys %{$self->db}; } my %found = (); my $result = 1; if (defined($name)) { # hacky backward compatibility workaround undef $class if $class && $class eq 'Sequence'; $name = "$class:$name" if defined $class && length $class > 0; $result &&= $self->filter_by_name($name,$allow_aliases,\%found); } if (defined $seq_id) { $result &&= $self->filter_by_location($seq_id,$start,$end,$strand,$range_type,\%found); } if (defined $types) { $result &&= $self->filter_by_type($types,\%found); } if (defined $attributes) { $result &&= $self->filter_by_attribute($attributes,\%found); } push @result,keys %found if $result; return $iterator ? Bio::DB::SeqFeature::Store::berkeleydb::Iterator->new($self,\@result) : map {$self->fetch($_)} @result; } sub filter_by_name { my $self = shift; my ($name,$allow_aliases,$filter) = @_; my $index = $self->index_db('names'); my $db = tied(%$index); my ($stem,$regexp) = $self->glob_match($name); $stem ||= $name; $regexp ||= $name; $regexp .= "(?:_2)?" if $allow_aliases; my $key = $stem; my $value; my @results; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0 and $key =~ /^$regexp$/i; $status = $db->seq($key,$value,R_NEXT)) { next if %$filter && !$filter->{$value}; # don't bother push @results,$value; } $self->update_filter($filter,\@results); } sub filter_by_type { my $self = shift; my ($types,$filter) = @_; my @types = ref $types eq 'ARRAY' ? @$types : $types; my $index = $self->index_db('types'); my $db = tied(%$index); my @results; for my $type (@types) { my ($primary_tag,$source_tag); if (ref $type && $type->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type->method; $source_tag = $type->source; } else { ($primary_tag,$source_tag) = split ':',$type,2; } my $match = defined $source_tag ? "^$primary_tag:$source_tag\$" : "^$primary_tag:"; $source_tag ||= ''; my $key = lc "$primary_tag:$source_tag"; my $value; # If filter is already provided, then it is usually faster to # fetch each object. if (%$filter) { for my $id (keys %$filter) { my $obj = $self->_fetch($id) or next; push @results,$id if $obj->type =~ /$match/i; } } else { for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0 && $key =~ /$match/i; $status = $db->seq($key,$value,R_NEXT)) { next if %$filter && !$filter->{$value}; # don't even bother push @results,$value; } } } $self->update_filter($filter,\@results); } sub filter_by_location { my $self = shift; my ($seq_id,$start,$end,$strand,$range_type,$filter) = @_; $strand ||= 0; my $index = $self->index_db('locations'); my $db = tied(%$index); my $binstart = defined $start ? sprintf("%06d",int $start/BINSIZE) : ''; my $binend = defined $end ? sprintf("%06d",int $end/BINSIZE) : 'z'; # beyond a number my %seenit; my @results; $start = MININT if !defined $start; $end = MAXINT if !defined $end; my $version_2 = $self->db_version > 1; if ($range_type eq 'overlaps' or $range_type eq 'contains') { my $key = $version_2 ? "\L$seq_id\E.$binstart" : "\L$seq_id\E$binstart"; my $keystop = $version_2 ? "\L$seq_id\E.$binend" : "\L$seq_id\E$binend"; my $value; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0 && $key le $keystop; $status = $db->seq($key,$value,R_NEXT)) { my ($id,$fstart,$fend,$fstrand) = unpack("i4",$value); next if $seenit{$id}++; next if $strand && $fstrand != $strand; if ($range_type eq 'overlaps') { next unless $fend >= $start && $fstart <= $end; } elsif ($range_type eq 'contains') { next unless $fstart >= $start && $fend <= $end; } next if %$filter && !$filter->{$id}; # don't bother push @results,$id; } } # for contained in, we look for features originating and terminating outside the specified range # this is incredibly inefficient, but fortunately the query is rare (?) elsif ($range_type eq 'contained_in') { my $key = $version_2 ? "\L$seq_id." : "\L$seq_id"; my $keystop = $version_2 ? "\L$seq_id\E.$binstart" : "\L$seq_id\E$binstart"; my $value; # do the left part of the range for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0 && $key le $keystop; $status = $db->seq($key,$value,R_NEXT)) { my ($id,$fstart,$fend,$fstrand) = unpack("i4",$value); next if $seenit{$id}++; next if $strand && $fstrand != $strand; next unless $fstart <= $start && $fend >= $end; next if %$filter && !$filter->{$id}; # don't bother push @results,$id; } # do the right part of the range $key = "\L$seq_id\E.$binend"; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0; $status = $db->seq($key,$value,R_NEXT)) { my ($id,$fstart,$fend,$fstrand) = unpack("i4",$value); next if $seenit{$id}++; next if $strand && $fstrand != $strand; next unless $fstart <= $start && $fend >= $end; next if %$filter && !$filter->{$id}; # don't bother push @results,$id; } } $self->update_filter($filter,\@results); } sub attributes { my $self = shift; my $index = $self->index_db('attributes'); my %a = map {s/:.+$//; $_=> 1} keys %$index; return keys %a; } sub filter_by_attribute { my $self = shift; my ($attributes,$filter) = @_; my $index = $self->index_db('attributes'); my $db = tied(%$index); my $result; for my $att_name (keys %$attributes) { my @result; my @search_terms = ref($attributes->{$att_name}) && ref($attributes->{$att_name}) eq 'ARRAY' ? @{$attributes->{$att_name}} : $attributes->{$att_name}; for my $v (@search_terms) { my ($stem,$regexp) = $self->glob_match($v); $stem ||= $v; $regexp ||= $v; my $key = "\L${att_name}:${stem}\E"; my $value; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0 && $key =~ /^$att_name:$regexp$/i; $status = $db->seq($key,$value,R_NEXT)) { next if %$filter && !$filter->{$value}; # don't bother push @result,$value; } } $result ||= $self->update_filter($filter,\@result); } $result; } sub _search_attributes { my $self = shift; my ($search_string,$attribute_array,$limit) = @_; $search_string =~ tr/*?//d; my @words = map {quotemeta($_)} $search_string =~ /(\w+)/g; my $search = join '|',@words; my $index = $self->index_db('attributes'); my $db = tied(%$index); my (%results,%notes); for my $tag (@$attribute_array) { my $id; my $key = "\L$tag:\E"; for (my $status = $db->seq($key,$id,R_CURSOR); $status == 0 and $key =~ /^$tag:(.*)/i; $status = $db->seq($key,$id,R_NEXT)) { my $text = $1; next unless $text =~ /$search/; for my $w (@words) { my @hits = $text =~ /($w)/ig or next; $results{$id} += @hits; } $notes{$id} .= "$text "; } } my @results; for my $id (keys %results) { my $hits = $results{$id}; my $note = $notes{$id}; $note =~ s/\s+$//; my $relevance = 10 * $hits; my $feature = $self->fetch($id) or next; my $name = $feature->display_name or next; my $type = $feature->type; push @results,[$name,$note,$relevance,$type,$id]; } return @results; } sub search_notes { my $self = shift; my ($search_string,$limit) = @_; $search_string =~ tr/*?//d; my @results; my @words = map {quotemeta($_)} $search_string =~ /(\w+)/g; my $search = join '|',@words; my (%found,$found); my $note_index = $self->notes_db; seek($note_index,0,0); # back to start while (<$note_index>) { next unless /$search/; chomp; my ($note,$uu) = split "\t"; $found{unpack("u*",$uu)}++; last if $limit && ++$found >= $limit; } my (@features, @matches); for my $idx (keys %found) { my $feature = $self->fetch($idx) or next; my @values = $feature->get_tag_values('Note') if $feature->has_tag('Note'); my $value = "@values"; my $hits; $hits++ while $value =~ /($search)/ig; # count the number of times we were hit push @matches,$hits; push @features,$feature; } for (my $i=0; $i<@matches; $i++) { my $feature = $features[$i]; my $matches = $matches[$i]; my $relevance = 10 * $matches; my $note; $note = join ' ',$feature->get_tag_values('Note') if $feature->has_tag('Note'); push @results,[$feature->display_name,$note,$relevance]; } return @results; } sub glob_match { my $self = shift; my $term = shift; return unless $term =~ /([^*?]*)(?:^|[^\\])?[*?]/; my $stem = $1; $term =~ s/(^|[^\\])([+\[\]^{}\$|\(\).])/$1\\$2/g; $term =~ s/(^|[^\\])\*/$1.*/g; $term =~ s/(^|[^\\])\?/$1./g; return ($stem,$term); } sub update_filter { my $self = shift; my ($filter,$results) = @_; return unless @$results; if (%$filter) { my @filtered = grep {$filter->{$_}} @$results; %$filter = map {$_=>1} @filtered; } else { %$filter = map {$_=>1} @$results; } } sub types { my $self = shift; eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new'); my $index = $self->index_db('types'); my $db = tied(%$index); return map {Bio::DB::GFF::Typename->new($_)} keys %$index; } # this is ugly sub _insert_sequence { my $self = shift; my ($seqid,$seq,$offset) = @_; my $dna_fh = $self->private_fasta_file or return; if ($offset == 0) { # start of the sequence print $dna_fh ">$seqid\n"; } print $dna_fh $seq,"\n"; } sub _fetch_sequence { my $self = shift; my ($seqid,$start,$end) = @_; my $db = $self->dna_db or return; return $db->seq($seqid,$start,$end); } sub private_fasta_file { my $self = shift; return $self->{fasta_fh} if exists $self->{fasta_fh}; $self->{fasta_file} = $self->_qualify("sequence.fa"); return $self->{fasta_fh} = IO::File->new($self->{fasta_file},">"); } sub finish_bulk_update { my $self = shift; if (my $fh = $self->{fasta_fh}) { $fh->close; $self->{fasta_db} = Bio::DB::Fasta::Subdir->new($self->{fasta_file}); } } sub db_version { my $self = shift; my $db = $self->db; return $db->{'.version'} || 1.00; } sub DESTROY { my $self = shift; $self->_close_databases(); $self->private_fasta_file->close; rmtree($self->directory,0,1) if $self->temporary && -e $self->directory; } # TIE interface -- a little annoying because we are storing magic ".variable" # meta-variables in the same data structure as the IDs, so these variables # must be skipped. sub _firstid { my $self = shift; my $db = $self->db; my ($key,$value); while ( ($key,$value) = each %{$db}) { last unless $key =~ /^\./; } $key; } sub _nextid { my $self = shift; my $id = shift; my $db = $self->db; my ($key,$value); while ( ($key,$value) = each %$db) { last unless $key =~ /^\./; } $key; } sub _existsid { my $self = shift; my $id = shift; return exists $self->db->{$id}; } sub _deleteid { my $self = shift; my $id = shift; my $obj = $self->fetch($id) or return; $self->_delete_indexes($obj,$id); delete $self->db->{$id}; 1; } sub _clearall { my $self = shift; $self->_close_databases(); $self->_delete_databases(); my ($write,$create) = $self->_permissions; $self->_open_databases($write,$create); } sub _featurecount { my $self = shift; return scalar %{$self->db}; } package Bio::DB::SeqFeature::Store::berkeleydb::Iterator; sub new { my $class = shift; my $store = shift; my $ids = shift; return bless {store => $store, ids => $ids},ref($class) || $class; } sub next_seq { my $self = shift; my $store = $self->{store} or return; my $id = shift @{$self->{ids}}; defined $id or return; return $store->fetch($id); } package Bio::DB::Fasta::Subdir; use base 'Bio::DB::Fasta'; # alter calling arguments so that the index file is placed in a subdirectory # named "indexes" sub new { my ($class, $path, %opts) = @_; if (-d $path) { $opts{-index_name} = File::Spec->catfile($path,'indexes','fasta.index'); } return Bio::DB::Fasta->new($path, %opts); } sub _calculate_offsets { my ($self, @args) = @_; return $self->SUPER::_calculate_offsets(@args); } 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store/berkeleydb3.pm000444000765000024 5111312254227312 22344 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::berkeleydb3; # $Id: berkeleydb3.pm 15987 2009-08-18 21:08:55Z lstein $ # faster implementation of berkeleydb =head1 NAME Bio::DB::SeqFeature::Store::berkeleydb3 -- Storage and retrieval of sequence annotation data in Berkeleydb files =head1 SYNOPSIS # Create a feature database from scratch $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'berkeleydb', -dsn => '/var/databases/fly4.3', -create => 1); # get a feature from somewhere my $feature = Bio::SeqFeature::Generic->new(...); # store it $db->store($feature) or die "Couldn't store!"; =head1 DESCRIPTION This is a faster version of the berkeleydb storage adaptor for Bio::DB::SeqFeature::Store. It is used automatically when you create a new database with the original berkeleydb adaptor. When opening a database created under the original adaptor, the old code is used for backward compatibility. Please see L for full usage instructions. =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein Elincoln.stein@gmail.comE. Copyright (c) 2009 Ontario Institute for Cancer Research This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use base 'Bio::DB::SeqFeature::Store::berkeleydb'; use DB_File; use Fcntl qw(O_RDWR O_CREAT :flock); use Bio::DB::GFF::Util::Rearrange 'rearrange'; # can't have more sequence ids than this use constant MAX_SEQUENCES => 1_000_000_000; # used to construct the bin key use constant C1 => 500_000_000; # limits chromosome length to 500 megabases use constant C2 => 1000*C1; # at most 1000 chromosomes use constant BINSIZE => 10_000; use constant MININT => -999_999_999_999; use constant MAXINT => 999_999_999_999; use constant SUMMARY_BIN_SIZE => 1000; sub version { return 3.0 } sub open_index_dbs { my $self = shift; my ($flags,$create) = @_; # Create the main index databases; these are DB_BTREE implementations with duplicates allowed. $DB_BTREE->{flags} = R_DUP; my $string_cmp = DB_File::BTREEINFO->new; $string_cmp->{flags} = R_DUP; $string_cmp->{compare} = sub { lc $_[0] cmp lc $_[1] }; my $numeric_cmp = DB_File::BTREEINFO->new; $numeric_cmp->{flags} = R_DUP; $numeric_cmp->{compare} = sub { $_[0] <=> $_[1] }; for my $idx ($self->_index_files) { my $path = $self->_qualify("$idx.idx"); my %db; my $dbtype = $idx eq 'locations' ? $numeric_cmp :$idx eq 'summary' ? $numeric_cmp :$idx eq 'types' ? $numeric_cmp :$idx eq 'seqids' ? $DB_HASH :$idx eq 'typeids' ? $DB_HASH :$string_cmp; tie(%db,'DB_File',$path,$flags,0666,$dbtype) or $self->throw("Couldn't tie $path: $!"); %db = () if $create; $self->index_db($idx=>\%db); } } sub seqid_db { shift->index_db('seqids') } sub typeid_db { shift->index_db('typeids') } sub _delete_databases { my $self = shift; $self->SUPER::_delete_databases; } # given a seqid (name), return its denormalized numeric representation sub seqid_id { my $self = shift; my $seqid = shift; my $db = $self->seqid_db; return $db->{lc $seqid}; } sub add_seqid { my $self = shift; my $seqid = shift; my $db = $self->seqid_db; my $key = lc $seqid; $db->{$key} = ++$db->{'.nextid'} unless exists $db->{$key}; die "Maximum number of sequence ids exceeded. This module can handle up to ", MAX_SEQUENCES," unique ids" if $db->{$key} > MAX_SEQUENCES; return $db->{$key}; } # given a seqid (name), return its denormalized numeric representation sub type_id { my $self = shift; my $typeid = shift; my $db = $self->typeid_db; return $db->{$typeid}; } sub add_typeid { my $self = shift; my $typeid = shift; my $db = $self->typeid_db; my $key = lc $typeid; $db->{$key} = ++$db->{'.nextid'} unless exists $db->{$key}; return $db->{$key}; } sub _seq_ids { my $self = shift; if (my $fa = $self->{fasta_db}) { if (my @s = eval {$fa->ids}) { return @s; } } my $l = $self->seqid_db or return; return grep {!/^\./} keys %$l; } sub _index_files { return (shift->SUPER::_index_files,'seqids','typeids','summary'); } sub _update_indexes { my $self = shift; my $obj = shift; defined (my $id = $obj->primary_id) or return; $self->SUPER::_update_indexes($obj); $self->_update_seqid_index($obj,$id); } sub _update_seqid_index { my $self = shift; my ($obj,$id,$delete) = @_; my $seq_name = $obj->seq_id; $self->add_seqid(lc $seq_name); } sub _update_type_index { my $self = shift; my ($obj,$id,$delete) = @_; my $db = $self->index_db('types') or $self->throw("Couldn't find 'types' index file"); my $key = $self->_obj_to_type($obj); my $typeid = $self->add_typeid($key); $self->update_or_delete($delete,$db,$typeid,$id); } sub _obj_to_type { my $self = shift; my $obj = shift; my $tag = $obj->primary_tag; my $source_tag = $obj->source_tag || ''; return unless defined $tag; $tag .= ":$source_tag"; return lc $tag; } sub types { my $self = shift; eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new'); my $db = $self->typeid_db; return grep {!/^\./} map {Bio::DB::GFF::Typename->new($_)} keys %$db; } sub _id2type { my $self = shift; my $wanted_id = shift; my $db = $self->typeid_db; while (my($key,$id) = each %$db) { next if $key =~ /^\./; return $key if $id == $wanted_id; } return; } # return a hash of typeids that match a human-readable type sub _matching_types { my $self = shift; my $types = shift; my @types = ref $types eq 'ARRAY' ? @$types : $types; my $db = $self->typeid_db; my %result; my @all_types; for my $type (@types) { my ($primary_tag,$source_tag); if (ref $type && $type->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type->method; $source_tag = $type->source; } else { ($primary_tag,$source_tag) = split ':',$type,2; } if (defined $source_tag) { my $id = $db->{lc "$primary_tag:$source_tag"}; $result{$id}++ if defined $id; } else { @all_types = $self->types unless @all_types; $result{$db->{$_}}++ foreach grep {/^$primary_tag:/} @all_types; } } return \%result; } sub _update_location_index { my $self = shift; my ($obj,$id,$delete) = @_; my $db = $self->index_db('locations') or $self->throw("Couldn't find 'locations' index file"); my $seq_id = $obj->seq_id || ''; my $start = $obj->start || ''; my $end = $obj->end || ''; my $strand = $obj->strand; my $bin_min = int $start/BINSIZE; my $bin_max = int $end/BINSIZE; my $typeid = $self->add_typeid($self->_obj_to_type($obj)); my $seq_no = $self->add_seqid($seq_id); for (my $bin = $bin_min; $bin <= $bin_max; $bin++ ) { my $key = $seq_no * MAX_SEQUENCES + $bin; $self->update_or_delete($delete,$db,$key,pack("i5",$id,$start,$end,$strand,$typeid)); } } sub _features { my $self = shift; my ($seq_id,$start,$end,$strand, $name,$class,$allow_aliases, $types, $attributes, $range_type, $iterator ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND', 'NAME','CLASS','ALIASES', ['TYPES','TYPE','PRIMARY_TAG'], ['ATTRIBUTES','ATTRIBUTE'], 'RANGE_TYPE', 'ITERATOR', ],@_); my (@from,@where,@args,@group); $range_type ||= 'overlaps'; my @result; unless (defined $name or defined $seq_id or defined $types or defined $attributes) { my $is_indexed = $self->index_db('is_indexed'); @result = $is_indexed ? grep {$is_indexed->{$_}} keys %{$self->db} : grep { !/^\./ }keys %{$self->db}; } my %found = (); my $result = 1; if (defined($name)) { # hacky backward compatibility workaround undef $class if $class && $class eq 'Sequence'; $name = "$class:$name" if defined $class && length $class > 0; $result &&= $self->filter_by_name($name,$allow_aliases,\%found); } if (defined $seq_id) { # location with or without types my $typelist = defined $types ? $self->_matching_types($types) : undef; $result &&= $self->filter_by_type_and_location( $seq_id, $start, $end, $strand, $range_type, $typelist, \%found ); } elsif (defined $types) { # types without location $result &&= $self->filter_by_type($types,\%found); } if (defined $attributes) { $result &&= $self->filter_by_attribute($attributes,\%found); } push @result,keys %found if $result; return $iterator ? Bio::DB::SeqFeature::Store::berkeleydb::Iterator->new($self,\@result) : map {$self->fetch($_)} @result; } sub filter_by_type { my $self = shift; my ($types,$filter) = @_; my @types = ref $types eq 'ARRAY' ? @$types : $types; my $index = $self->index_db('types'); my $db = tied(%$index); my @results; for my $type (@types) { my ($primary_tag,$source_tag); if (ref $type && $type->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type->method; $source_tag = $type->source; } else { ($primary_tag,$source_tag) = split ':',$type,2; } $source_tag ||= ''; $primary_tag = quotemeta($primary_tag); $source_tag = quotemeta($source_tag); my $match = length $source_tag ? "^$primary_tag:$source_tag\$" : "^$primary_tag:"; my $key = lc "$primary_tag:$source_tag"; my $value; # If filter is already provided, then it is usually faster to # fetch each object. if (%$filter) { for my $id (keys %$filter) { my $obj = $self->_fetch($id) or next; push @results,$id if $obj->type =~ /$match/i; } } else { my $types = $self->typeid_db; my @typeids = map {$types->{$_}} grep {/$match/} keys %$types; for my $t (@typeids) { my $k = $t; for (my $status = $db->seq($k,$value,R_CURSOR); $status == 0 && $k == $t; $status = $db->seq($k,$value,R_NEXT)) { next if %$filter && !$filter->{$value}; # don't even bother push @results,$value; } } } } $self->update_filter($filter,\@results); } sub filter_by_type_and_location { my $self = shift; my ($seq_id,$start,$end,$strand,$range_type,$typelist,$filter) = @_; $strand ||= 0; my $index = $self->index_db('locations'); my $db = tied(%$index); my $binstart = defined $start ? int $start/BINSIZE : 0; my $binend = defined $end ? int $end/BINSIZE : MAX_SEQUENCES-1; my %seenit; my @results; $start = MININT if !defined $start; $end = MAXINT if !defined $end; my $seq_no = $self->seqid_id($seq_id); return unless defined $seq_no; if ($range_type eq 'overlaps' or $range_type eq 'contains') { my $keystart = $seq_no * MAX_SEQUENCES + $binstart; my $keystop = $seq_no * MAX_SEQUENCES + $binend; my $value; for (my $status = $db->seq($keystart,$value,R_CURSOR); $status == 0 && $keystart <= $keystop; $status = $db->seq($keystart,$value,R_NEXT)) { my ($id,$fstart,$fend,$fstrand,$ftype) = unpack("i5",$value); next if $seenit{$id}++; next if $strand && $fstrand != $strand; next if $typelist && !$typelist->{$ftype}; if ($range_type eq 'overlaps') { next unless $fend >= $start && $fstart <= $end; } elsif ($range_type eq 'contains') { next unless $fstart >= $start && $fend <= $end; } next if %$filter && !$filter->{$id}; # don't bother push @results,$id; } } # for contained in, we look for features originating and terminating outside the specified range # this is incredibly inefficient, but fortunately the query is rare (?) elsif ($range_type eq 'contained_in') { my $keystart = $seq_no * MAX_SEQUENCES; my $keystop = $seq_no * MAX_SEQUENCES + $binstart; my $value; # do the left part of the range for (my $status = $db->seq($keystart,$value,R_CURSOR); $status == 0 && $keystart <= $keystop; $status = $db->seq($keystart,$value,R_NEXT)) { my ($id,$fstart,$fend,$fstrand,$ftype) = unpack("i5",$value); next if $seenit{$id}++; next if $strand && $fstrand != $strand; next if $typelist && !$typelist->{$ftype}; next unless $fstart <= $start && $fend >= $end; next if %$filter && !$filter->{$id}; # don't bother push @results,$id; } # do the right part of the range $keystart = $seq_no*MAX_SEQUENCES+$binend; for (my $status = $db->seq($keystart,$value,R_CURSOR); $status == 0; $status = $db->seq($keystart,$value,R_NEXT)) { my ($id,$fstart,$fend,$fstrand,$ftype) = unpack("i5",$value); next if $seenit{$id}++; next if $strand && $fstrand != $strand; next unless $fstart <= $start && $fend >= $end; next if $typelist && !$typelist->{$ftype}; next if %$filter && !$filter->{$id}; # don't bother push @results,$id; } } $self->update_filter($filter,\@results); } sub build_summary_statistics { my $self = shift; my $insert = $self->index_db('summary'); %$insert = (); my $current_bin = -1; my (%residuals,$last_bin); my $le = -t \*STDERR ? "\r" : "\n"; print STDERR "\n"; # iterate through all the indexed features my $sbs = SUMMARY_BIN_SIZE; # Sadly we have to do this in two steps. In the first step, we sort # features by typeid,seqid,start. In the second step, we read through # this sorted list. To avoid running out of memory, we use a db_file # temporary database my $fh = File::Temp->new() or $self->throw("Could not create temporary file '$name' for sorting: $!"); my $name = $fh->filename; my %sort; my $num_cmp_tre = DB_File::BTREEINFO->new; $num_cmp_tree->{compare} = sub { $_[0] <=> $_[1] }; $num_cmp_tree->{flags} = R_DUP; my $s = tie %sort, 'DB_File', $name, O_CREAT|O_RDWR, 0666, $num_cmp_tree or $self->throw("Could not create Berkeley DB in temporary file '$name': $!"); my $index = $self->index_db('locations'); my $db = tied(%$index); my $keystart = 0; my ($value,$count); my %seenit; for (my $status = $db->seq($keystart,$value,R_CURSOR); $status == 0; $status = $db->seq($keystart,$value,R_NEXT)) { my ($id,$start,$end,$strand,$typeid) = unpack('i5',$value); next if $seenit{$id}++; print STDERR $count," features sorted$le" if ++$count % 1000 == 0; my $seqid = int($keystart / MAX_SEQUENCES); my $key = $self->_encode_summary_key($typeid,$seqid,$start-1); $sort{$key}=$end; } print STDERR "COUNT = $count\n"; my ($current_type,$current_seqid,$end); my $cum_count = 0; $keystart = 0; $count = 0; # the second step allows us to iterate through this for (my $status = $s->seq($keystart,$end,R_CURSOR); $status == 0; $status = $s->seq($keystart,$end,R_NEXT)) { print STDERR $count," features processed$le" if ++$count % 1000 == 0; my ($typeid,$seqid,$start) = $self->_decode_summary_key($keystart); my $bin = int($start/$sbs); # because the input is sorted by start, no more features will contribute to the # current bin so we can dispose of it if ($bin != $current_bin) { if ($seqid != $current_seqid or $typeid != $current_type) { # load all bins left over $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid); %residuals = () ; $cum_count = 0; } else { # load all up to current one $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid,$current_bin); } } $last_bin = $current_bin; ($current_seqid,$current_type,$current_bin) = ($seqid,$typeid,$bin); # summarize across entire spanned region my $last_bin = int(($end-1)/$sbs); for (my $b=$bin;$b<=$last_bin;$b++) { $residuals{$b}++; } } # handle tail case # load all bins left over $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid); undef %sort; undef $fh; } sub _load_bins { my $self = shift; my ($insert,$residuals,$cum_count,$typeid,$seqid,$stop_after) = @_; for my $b (sort {$a<=>$b} keys %$residuals) { last if defined $stop_after and $b > $stop_after; $$cum_count += $residuals->{$b}; my $key = $self->_encode_summary_key($typeid,$seqid,$b); $insert->{$key} = $$cum_count; delete $residuals->{$b}; # no longer needed } } sub coverage_array { my $self = shift; my ($seq_name,$start,$end,$types,$bins) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'], ['TYPES','TYPE','PRIMARY_TAG'],'BINS'],@_); $bins ||= 1000; $start ||= 1; unless ($end) { my $segment = $self->segment($seq_name) or $self->throw("unknown seq_id $seq_name"); $end = $segment->end; } my $binsize = ($end-$start+1)/$bins; my $seqid = $self->seqid_id($seq_name) || 0; return [] unless $seqid; # where each bin starts my @his_bin_array = map {$start + $binsize * $_} (0..$bins); my @sum_bin_array = map {int(($_-1)/SUMMARY_BIN_SIZE)} @his_bin_array; my $interval_stats_idx = $self->index_db('summary'); my $db = tied(%$interval_stats_idx); my $t = $self->_matching_types($types); my (%bins,$report_tag); for my $typeid (sort keys %$t) { $report_tag ||= $typeid; for (my $i=0;$i<@sum_bin_array;$i++) { my $cum_count; my $bin = $sum_bin_array[$i]; my $key = $self->_encode_summary_key($typeid,$seqid,$bin); my $status = $db->seq($key,$cum_count,R_CURSOR); next unless $status == 0; push @{$bins{$typeid}},[$bin,$cum_count]; } } my @merged_bins; my $firstbin = int(($start-1)/$binsize); for my $type (keys %bins) { my $arry = $bins{$type}; my $last_count = $arry->[0][1]-1; my $last_bin = -1; my $i = 0; my $delta; for my $b (@$arry) { my ($bin,$count) = @$b; $delta = $count - $last_count if $bin > $last_bin; $merged_bins[$i++] = $delta; $last_count = $count; $last_bin = $bin; } } my $returned_type = $self->_id2type($report_tag); return wantarray ? (\@merged_bins,$returned_type) : \@merged_bins; } sub _encode_summary_key { my $self = shift; my ($typeid,$seqid,$bin) = @_; $self->throw('Cannot index chromosomes larger than '.C1*SUMMARY_BIN_SIZE/1e6.' megabases') if $bin > C1; return ($typeid-1)*C2 + ($seqid-1)*C1 + $bin; } sub _decode_summary_key { my $self = shift; my $key = shift; my $typeid = int($key/C2); my $residual = $key%C2; my $seqid = int($residual/C1); my $bin = $residual%C1; return ($typeid+1,$seqid+1,$bin); } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/Store/FeatureFileLoader.pm000444000765000024 6162312254227314 23504 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::FeatureFileLoader; =head1 NAME Bio::DB::SeqFeature::Store::FeatureFileLoader -- feature file loader for Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; use Bio::DB::SeqFeature::Store::FeatureFileLoader; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test', -write => 1 ); my $loader = Bio::DB::SeqFeature::Store::FeatureFileLoader->new(-store => $db, -verbose => 1, -fast => 1); $loader->load('./my_genome.fff'); =head1 DESCRIPTION The Bio::DB::SeqFeature::Store::FeatureFileLoader object parsers FeatureFile-format sequence annotation files and loads Bio::DB::SeqFeature::Store databases. For certain combinations of SeqFeature classes and SeqFeature::Store databases it features a "fast load" mode which will greatly accelerate the loading of databases by a factor of 5-10. FeatureFile Format (.fff) is very simple: mRNA B0511.1 Chr1:1..100 Type=UTR;Note="putative primase" mRNA B0511.1 Chr1:101..200,300..400,500..800 Type=CDS mRNA B0511.1 Chr1:801..1000 Type=UTR reference = Chr3 Cosmid B0511 516..619 Cosmid B0511 3185..3294 Cosmid B0511 10946..11208 Cosmid B0511 13126..13511 Cosmid B0511 11394..11539 EST yk260e10.5 15569..15724 EST yk672a12.5 537..618,3187..3294 EST yk595e6.5 552..618 EST yk595e6.5 3187..3294 EST yk846e07.3 11015..11208 EST yk53c10 yk53c10.3 15000..15500,15700..15800 yk53c10.5 18892..19154 EST yk53c10.5 16032..16105 SwissProt PECANEX 13153-13656 Note="Swedish fish" FGENESH "Predicted gene 1" 1-205,518-616,661-735,3187-3365,3436-3846 "Pfam domain" # file ends There are up to four columns of WHITESPACE (not necessarily tab) delimited text. Embedded whitespace must be escaped using shell escaping rules (quoting the column or backslashing whitespace). Column 1: The feature type. You may use type:subtype as a convention for method:source. Column 2: The feature name/ID. Column 3: The position of this feature in base pair coordinates. Ranges can be given as either start-end or start..end. A chromosome position can be specified using the format "reference:start..end". A discontinuous feature can be specified by giving multiple ranges separated by commas. Minus-strand features are indicated by specifying a start > end. Column 4: Comment/attribute field. A single Note can be given, or a series of attribute=value pairs, separated by spaces or semicolons, as in "score=23;type=transmembrane" =head2 Specifying Positions and Ranges A feature position is specified using a sequence ID (a genbank accession number, a chromosome name, a contig, or any other meaningful reference system, followed by a colon and a position range. Ranges are two integers separated by double dots or the hyphen. Examples: "Chr1:516..11208", "ctgA:1-5000". Negative coordinates are allowed, as in "Chr1:-187..1000". A discontinuous range ("split location") uses commas to separate the ranges. For example: Gene B0511.1 Chr1:516..619,3185..3294,10946..11208 In the case of a split location, the sequence id only has to appear in front of the first range. Alternatively, a split location can be indicated by repeating the features type and name on multiple adjacent lines: Gene B0511.1 Chr1:516..619 Gene B0511.1 Chr1:3185..3294 Gene B0511.1 Chr1:10946..11208 If all the locations are on the same reference sequence, you can specify a default chromosome using a "reference=EseqidE": reference=Chr1 Gene B0511.1 516..619 Gene B0511.1 3185..3294 Gene B0511.1 10946..11208 The default seqid is in effect until the next "reference" line appears. =head2 Feature Tags Tags can be added to features by adding a fourth column consisting of "tag=value" pairs: Gene B0511.1 Chr1:516..619,3185..3294 Note="Putative primase" Tags and their values take any form you want, and multiple tags can be separated by semicolons. You can also repeat tags multiple times: Gene B0511.1 Chr1:516..619,3185..3294 GO_Term=GO:100;GO_Term=GO:2087 Several tags have special meanings: Tag Meaning --- ------- Type The primary tag for a subfeature. Score The score of a feature or subfeature. Phase The phase of a feature or subfeature. URL A URL to link to (via the Bio::Graphics library). Note A note to attach to the feature for display by the Bio::Graphics library. For example, in the common case of an mRNA, you can use the "Type" tag to distinguish the parts of the mRNA into UTR and CDS: mRNA B0511.1 Chr1:1..100 Type=UTR mRNA B0511.1 Chr1:101..200,300..400,500..800 Type=CDS mRNA B0511.1 Chr1:801..1000 Type=UTR The top level feature's primary tag will be "mRNA", and its subparts will have types UTR and CDS as indicated. Additional tags that are placed in the first line of the feature will be applied to the top level. In this example, the note "Putative primase" will be applied to the mRNA at the top level of the feature: mRNA B0511.1 Chr1:1..100 Type=UTR;Note="Putative primase" mRNA B0511.1 Chr1:101..200,300..400,500..800 Type=CDS mRNA B0511.1 Chr1:801..1000 Type=UTR =head2 Feature Groups Features can be grouped so that they are rendered by the "group" glyph. To start a group, create a two-column feature entry showing the group type and a name for the group. Follow this with a list of feature entries with a blank type. For example: EST yk53c10 yk53c10.3 15000-15500,15700-15800 yk53c10.5 18892-19154 This example is declaring that the ESTs named yk53c10.3 and yk53c10.5 belong to the same group named yk53c10. =head2 Comments and the #include Directive Lines that begin with the # sign are treated as comments and ignored. When a # sign appears within a line, everything to the right of the symbol is also ignored, unless it looks like an HTML fragment or an HTML color, e.g.: # this is ignored [Example] glyph = generic # this comment is ignored bgcolor = #FF0000 link = http://www.google.com/search?q=$name#results Be careful, because the processing of # signs uses a regexp heuristic. To be safe, always put a space after the # sign to make sure it is treated as a comment. The special comment "#include 'filename'" acts like the C preprocessor directive and will insert the comments of a named file into the position at which it occurs. Relative paths will be treated relative to the file in which the #include occurs. Nested #include directives are allowed: #include "/usr/local/share/my_directives.txt" #include 'my_directives.txt' #include chromosome3_features.gff3 You can enclose the file path in single or double quotes as shown above. If there are no spaces in the filename the quotes are optional. Include file processing is not very smart. Avoid creating circular #include references. You have been warned! =head2 Caveats Note that this loader always creates denormalized features such that subfeatures and their parents are stored as one big database object. The GFF3 format and its loader is usually preferred for both space and execution efficiency. =head1 METHODS =cut use strict; use Carp 'croak'; use File::Spec; use Text::ParseWords 'shellwords','quotewords'; use base 'Bio::DB::SeqFeature::Store::Loader'; =head2 new Title : new Usage : $loader = Bio::DB::SeqFeature::Store::FeatureFileLoader->new(@options) Function: create a new parser Returns : a Bio::DB::SeqFeature::Store::FeatureFileLoader parser and loader Args : several - see below Status : public This method creates a new FeatureFile loader and establishes its connection with a Bio::DB::SeqFeature::Store database. Arguments are -name=E$value pairs as described in this table: Name Value ---- ----- -store A writable Bio::DB::SeqFeature::Store database handle. -seqfeature_class The name of the type of Bio::SeqFeatureI object to create and store in the database (Bio::DB::SeqFeature by default) -sf_class A shorter alias for -seqfeature_class -verbose Send progress information to standard error. -fast If true, activate fast loading (see below) -chunk_size Set the storage chunk size for nucleotide/protein sequences (default 2000 bytes) -tmp Indicate a temporary directory to use when loading non-normalized features. When you call new(), a connection to a Bio::DB::SeqFeature::Store database should already have been established and the database initialized (if appropriate). Some combinations of Bio::SeqFeatures and Bio::DB::SeqFeature::Store databases support a fast loading mode. Currently the only reliable implementation of fast loading is the combination of DBI::mysql with Bio::DB::SeqFeature. The other important restriction on fast loading is the requirement that a feature that contains subfeatures must occur in the FeatureFile file before any of its subfeatures. Otherwise the subfeatures that occurred before the parent feature will not be attached to the parent correctly. This restriction does not apply to normal (slow) loading. If you use an unnormalized feature class, such as Bio::SeqFeature::Generic, then the loader needs to create a temporary database in which to cache features until all their parts and subparts have been seen. This temporary databases uses the "bdb" adaptor. The -tmp option specifies the directory in which that database will be created. If not present, it defaults to the system default tmp directory specified by File::Spec-Etmpdir(). The -chunk_size option allows you to tune the representation of DNA/Protein sequence in the Store database. By default, sequences are split into 2000 base/residue chunks and then reassembled as needed. This avoids the problem of pulling a whole chromosome into memory in order to fetch a short subsequence from somewhere in the middle. Depending on your usage patterns, you may wish to tune this parameter using a chunk size that is larger or smaller than the default. =cut # sub new {} inherited =head2 load Title : load Usage : $count = $loader->load(@ARGV) Function: load the indicated files or filehandles Returns : number of feature lines loaded Args : list of files or filehandles Status : public Once the loader is created, invoke its load() method with a list of FeatureFile or FASTA file paths or previously-opened filehandles in order to load them into the database. Compressed files ending with .gz, .Z and .bz2 are automatically recognized and uncompressed on the fly. Paths beginning with http: or ftp: are treated as URLs and opened using the LWP GET program (which must be on your path). FASTA files are recognized by their initial "E" character. Do not feed the loader a file that is neither FeatureFile nor FASTA; I don't know what will happen, but it will probably not be what you expect. =cut # sub load {} inherited =head2 accessors The following read-only accessors return values passed or created during new(): store() the long-term Bio::DB::SeqFeature::Store object tmp_store() the temporary Bio::DB::SeqFeature::Store object used during loading sfclass() the Bio::SeqFeatureI class fast() whether fast loading is active seq_chunk_size() the sequence chunk size verbose() verbose progress messages =cut # sub store {} inherited # sub tmp_store {} inherited # sub sfclass {} inherited # sub fast {} inherited # sub seq_chunk_size {} inherited # sub verbose {} inherited =head2 default_seqfeature_class $class = $loader->default_seqfeature_class Return the default SeqFeatureI class (Bio::Graphics::Feature). =cut sub default_seqfeature_class { #override my $self = shift; return 'Bio::Graphics::Feature'; } =head2 load_fh $count = $loader->load_fh($filehandle) Load the FeatureFile data at the other end of the filehandle and return true if successful. Internally, load_fh() invokes: start_load(); do_load($filehandle); finish_load(); =cut # sub load_fh { } inherited =head2 start_load, finish_load These methods are called at the start and end of a filehandle load. =cut sub create_load_data { my $self = shift; $self->SUPER::create_load_data(); $self->{load_data}{mode} = 'fff'; $self->{load_data}{CurrentGroup} = undef; } sub finish_load { my $self = shift; $self->_store_group; $self->SUPER::finish_load; } =head2 load_line $loader->load_line($data); Load a line of a FeatureFile file. You must bracket this with calls to start_load() and finish_load()! $loader->start_load(); $loader->load_line($_) while ; $loader->finish_load(); =cut sub load_line { my $self = shift; my $line = shift; chomp($line); return unless $line =~ /\S/; # blank line my $load_data = $self->{load_data}; $load_data->{mode} = 'fff' if /\s/; # if it has any whitespace in # it, then back to fff mode if ($line =~ /^\#\s?\#\s*([\#]+)/) { ## meta instruction $load_data->{mode} = 'fff'; $self->handle_meta($1); } elsif ($line =~ /^\#/) { $load_data->{mode} = 'fff'; # just to be safe return; # comment } elsif ($line =~ /^>\s*(\S+)/) { # FASTA lines are coming $load_data->{mode} = 'fasta'; $self->start_or_finish_sequence($1); } elsif ($load_data->{mode} eq 'fasta') { $self->load_sequence($line); } elsif ($load_data->{mode} eq 'fff') { $self->handle_feature($line); if (++$load_data->{count} % 1000 == 0) { my $now = $self->time(); my $nl = -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; $self->msg(sprintf("%d features loaded in %5.2fs...$nl", $load_data->{count},$now - $load_data->{start_time})); $load_data->{start_time} = $now; } } else { $self->throw("I don't know what to do with this line:\n$line"); } } =head2 handle_meta $loader->handle_meta($meta_directive) This method is called to handle meta-directives such as ##sequence-region. The method will receive the directive with the initial ## stripped off. =cut # sub handle_meta { } inherited =head2 handle_feature $loader->handle_feature($gff3_line) This method is called to process a single FeatureFile line. It manipulates information stored a data structure called $self-E{load_data}. =cut sub handle_feature { my $self = shift; local $_ = shift; my $ld = $self->{load_data}; # handle reference line if (/^reference\s*=\s*(.+)/) { $ld->{reference} = $1; return; } # parse data lines my @tokens = quotewords('\s+',1,$_); for (0..2) { # remove quotes from everything but last column next unless defined $tokens[$_]; $tokens[$_] =~ s/^"//; $tokens[$_] =~ s/"$//; } if (@tokens < 3) { # short line; assume a group identifier $self->store_current_feature(); my $type = shift @tokens; my $name = shift @tokens; $ld->{CurrentGroup} = $self->_make_indexed_feature($name,$type,'',{_ff_group=>1}); $self->_indexit($name => 1); return; } my($type,$name,$strand,$bounds,$attributes); if ($tokens[2] =~ /^([+-.]|[+-]?[01])$/) { # old version ($type,$name,$strand,$bounds,$attributes) = @tokens; } else { # new version ($type,$name,$bounds,$attributes) = @tokens; } # handle case of there only being one value in the last column, # in which case we treat it the same as Note="value" my $attr = $self->parse_attributes($attributes); # @parts is an array of ([ref,start,end],[ref,start,end],...) my @parts = map { [/(?:(\w+):)?(-?\d+)(?:-|\.\.)(-?\d+)/]} split /(?:,| )\s*/,$bounds; # deal with groups -- a group is ending if $type is defined # and CurrentGroup is set if ($type && $ld->{CurrentGroup}) { $self->_store_group(); } $type = '' unless defined $type; $name = '' unless defined $name; $type ||= $ld->{CurrentGroup}->primary_tag if $ld->{CurrentGroup}; my $reference = $ld->{reference} || 'ChrUN'; foreach (@parts) { if (defined $_ && ref($_) eq 'ARRAY' && defined $_->[1] && defined $_->[2]) { $strand ||= $_->[1] <= $_->[2] ? '+' : '-'; ($_->[1],$_->[2]) = ($_->[2],$_->[1]) if $_->[1] > $_->[2]; } $reference = $_->[0] if defined $_->[0]; $_ = [@{$_}[1,2]]; # strip off the reference. } # now @parts is an array of [start,end] and $reference contains the seqid # apply coordinate mapper if ($self->{coordinate_mapper} && $reference) { my @remapped = $self->{coordinate_mapper}->($reference,@parts); ($reference,@parts) = @remapped if @remapped; } # either create a new feature or add a segment to it my $feature = $ld->{CurrentFeature}; $ld->{OldPartType} = $ld->{PartType}; if (exists $attr->{Type} || exists $attr->{type}) { $ld->{PartType} = $attr->{Type}[0] || $attr->{type}[0]; } else { $ld->{PartType} = $type; } if ($feature) { local $^W = 0; # avoid uninit warning when display_name() is called # if this is a different feature from what we have now, then we # store the current one, and create a new one if ($feature->display_name ne $name || $feature->method ne $type) { $self->store_current_feature; # new feature, store old one undef $feature; } else { # create a new multipart feature $self->_multilevel_feature($feature,$ld->{OldPartType}) unless $feature->get_SeqFeatures; my $part = $self->_make_feature($name, $ld->{PartType}, $strand, $attr, $reference, @{$parts[0]}); $feature->add_SeqFeature($part); } } $feature ||= $self->_make_indexed_feature($name, $type, # side effect is to set CurrentFeature $strand, $attr, $reference, @{$parts[0]}); # add more segments to the current feature if (@parts > 1) { for my $part (@parts) { $type ||= $feature->primary_tag; my $sp = $self->_make_feature($name, $ld->{PartType}, $strand, $attr, $reference, @{$part}); $feature->add_SeqFeature($sp); } } } sub _multilevel_feature { # turn a single-level feature into a multilevel one my $self = shift; my $f = shift; my $type = shift; my %attributes = $f->attributes; $attributes{Score} = [$f->score] if defined $f->score; $attributes{Phase} = [$f->phase] if defined $f->phase; my @args = ($f->display_name, $type||$f->type, $f->strand, \%attributes, $f->seq_id, $f->start, $f->end); my $subpart = $self->_make_feature(@args); $f->add_SeqFeature($subpart); } sub _make_indexed_feature { my $self = shift; my $f = $self->_make_feature(@_); my $name = $f->display_name; $self->{load_data}{CurrentFeature} = $f; $self->{load_data}{CurrentID} = $name; $self->_indexit($name => 1); return $f; } sub _make_feature { my $self = shift; my ($name,$type,$strand,$attributes,$ref,$start,$end) = @_; # some basic error checking $self->throw("syntax error at line $.: '$_'") if ($ref && !defined $start) or ($ref && !defined $end) or ($start && $start !~ /^[-\d]+$/) or ($end && $end !~ /^[-\d]+$/) or !defined $type or !defined $name; $strand ||= ''; my @args = (-name => $name, -strand => $strand eq '+' ? 1 :$strand eq '-' ? -1 :$strand eq '' ? 0 :$strand eq '.' ? 0 :$strand == 1 ? 1 :$strand == -1 ? -1 :0, -attributes => $attributes, ); if (my ($method,$source) = $type =~ /(\S+):(\S+)/) { push @args,(-primary_tag => $method, -source => $source); } else { push @args,(-primary_tag => $type); } push @args,(-seq_id => $ref) if defined $ref; push @args,(-start => $start) if defined $start; push @args,(-end => $end) if defined $end; # pull out special attributes if (my $score = $attributes->{Score} || $attributes->{score}) { push @args,(-score => $score->[0]); delete $attributes->{$_} foreach qw(Score score); } if (my $note = $attributes->{Note} || $attributes->{note}) { push @args,(-desc => join '; ',@$note); delete $attributes->{$_} foreach qw(Note note); } if (my $url = $attributes->{url} || $attributes->{Url}) { push @args,(-url => $url->[0]); delete $attributes->{$_} foreach qw (Url url); } if (my $phase = $attributes->{phase} || $attributes->{Phase}) { push @args,(-phase => $phase->[0]); delete $attributes->{$_} foreach qw (Phase phase); } $self->_indexit($name=>1) if $self->index_subfeatures && $name; return $self->sfclass->new(@args); } =head2 store_current_feature $loader->store_current_feature() This method is called to store the currently active feature in the database. It uses a data structure stored in $self-E{load_data}. =cut sub store_current_feature { # overridden my $self = shift; # handle open groups # if there is an open group, then we simply add the current # feature to the group. my $ld = $self->{load_data}; if ($ld->{CurrentGroup} && $ld->{CurrentFeature}) { $ld->{CurrentGroup}->add_SeqFeature($ld->{CurrentFeature}) unless $ld->{CurrentGroup} eq $ld->{CurrentFeature}; # paranoia - shouldn't happen return; } else { $self->SUPER::store_current_feature(); } } sub _store_group { my $self = shift; my $ld = $self->{load_data}; my $group = $ld->{CurrentGroup} or return; # if there is an unattached feature, then add it $self->store_current_feature() if $ld->{CurrentFeature}; $ld->{CurrentFeature} = $group; $ld->{CurrentID} = $group->display_name; $self->_indexit($ld->{CurrentID} => 1); undef $ld->{CurrentGroup}; $self->store_current_feature(); } =head2 build_object_tree $loader->build_object_tree() This method gathers together features and subfeatures and builds the graph that connects them. =cut ### # put objects together # sub build_object_tree { croak "We shouldn't be building an object tree in the FeatureFileLoader"; } =head2 build_object_tree_in_tables $loader->build_object_tree_in_tables() This method gathers together features and subfeatures and builds the graph that connects them, assuming that parent/child relationships will be stored in a database table. =cut sub build_object_tree_in_tables { croak "We shouldn't be building an object tree in the FeatureFileLoader"; } =head2 build_object_tree_in_features $loader->build_object_tree_in_features() This method gathers together features and subfeatures and builds the graph that connects them, assuming that parent/child relationships are stored in the seqfeature objects themselves. =cut sub build_object_tree_in_features { croak "We shouldn't be building an object tree in the FeatureFileLoader"; } =head2 attach_children $loader->attach_children($store,$load_data,$load_id,$feature) This recursively adds children to features and their subfeatures. It is called when subfeatures are directly contained within other features, rather than stored in a relational table. =cut sub attach_children { croak "We shouldn't be attaching children in the FeatureFileLoader!"; } =head2 parse_attributes @attributes = $loader->parse_attributes($attribute_line) This method parses the information contained in the $attribute_line into a flattened hash (array). It may return one element, in which case it is an implicit =cut 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) { unless ($pair =~ /=/) { push @{$attributes{Note}},(quotewords('',0,$pair))[0] || $pair; } else { my ($tag,$value) = quotewords('\s*=\s*',0,$pair); $tag = 'Note' if $tag eq 'description'; push @{$attributes{$tag}},$value; } } return \%attributes; } =head2 start_or_finish_sequence $loader->start_or_finish_sequence('Chr9') This method is called at the beginning and end of a fasta section. =cut 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store/GFF2Loader.pm000444000765000024 3277212254227330 21776 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::GFF2Loader; # $Id: GFF2Loader.pm 11755 2007-11-08 02:19:29Z cjfields $ =head1 NAME Bio::DB::SeqFeature::Store::GFF2Loader -- GFF2 file loader for Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; use Bio::DB::SeqFeature::Store::GFF2Loader; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test', -write => 1 ); my $loader = Bio::DB::SeqFeature::Store::GFF2Loader->new(-store => $db, -verbose => 1, -fast => 1); $loader->load('./my_genome.gff'); =head1 DESCRIPTION The Bio::DB::SeqFeature::Store::GFF2Loader object parsers GFF2-format sequence annotation files and loads Bio::DB::SeqFeature::Store databases. For certain combinations of SeqFeature classes and SeqFeature::Store databases it features a "fast load" mode which will greatly accelerate the loading of GFF2 databases by a factor of 5-10. The GFF2 file format has been extended very slightly to accommodate Bio::DB::SeqFeature::Store. First, the loader recognizes is a new directive: # #index-subfeatures [0|1] Note that you can place a space between the two #'s in order to prevent GFF2 validators from complaining. If this is true, then subfeatures are indexed (the default) so that they can be retrieved with a query. See L for an explanation of this. If false, then subfeatures can only be accessed through their parent feature. The default is to index all subfeatures. Second, the loader recognizes a new attribute tag called index, which if present, controls indexing of the current feature. Example: ctg123 . TF_binding_site 1000 1012 . + . ID=tfbs00001;index=1 You can use this to turn indexing on and off, overriding the default for a particular feature. =cut # load utility - incrementally load the store based on GFF2 file # # two modes: # slow mode -- features can occur in any order in the GFF2 file # fast mode -- all features with same ID must be contiguous in GFF2 file use strict; use Carp 'croak'; use Bio::DB::GFF::Util::Rearrange; use Text::ParseWords 'quotewords'; use base 'Bio::DB::SeqFeature::Store::GFF3Loader'; my %Special_attributes =( Gap => 1, Target => 1, Parent => 1, Name => 1, Alias => 1, ID => 1, index => 1, Index => 1, ); =head2 new Title : new Usage : $loader = Bio::DB::SeqFeature::Store::GFF2Loader->new(@options) Function: create a new parser Returns : a Bio::DB::SeqFeature::Store::GFF2Loader gff2 parser and loader Args : several - see below Status : public This method creates a new GFF2 loader and establishes its connection with a Bio::DB::SeqFeature::Store database. Arguments are -name=E$value pairs as described in this table: Name Value ---- ----- -store A writable Bio::DB::SeqFeature::Store database handle. -seqfeature_class The name of the type of Bio::SeqFeatureI object to create and store in the database (Bio::DB::SeqFeature by default) -sf_class A shorter alias for -seqfeature_class -verbose Send progress information to standard error. -fast If true, activate fast loading (see below) -chunk_size Set the storage chunk size for nucleotide/protein sequences (default 2000 bytes) -tmp Indicate a temporary directory to use when loading non-normalized features. When you call new(), a connection to a Bio::DB::SeqFeature::Store database should already have been established and the database initialized (if appropriate). Some combinations of Bio::SeqFeatures and Bio::DB::SeqFeature::Store databases support a fast loading mode. Currently the only reliable implementation of fast loading is the combination of DBI::mysql with Bio::DB::SeqFeature. The other important restriction on fast loading is the requirement that a feature that contains subfeatures must occur in the GFF2 file before any of its subfeatures. Otherwise the subfeatures that occurred before the parent feature will not be attached to the parent correctly. This restriction does not apply to normal (slow) loading. If you use an unnormalized feature class, such as Bio::SeqFeature::Generic, then the loader needs to create a temporary database in which to cache features until all their parts and subparts have been seen. This temporary databases uses the "berkeleydb" adaptor. The -tmp option specifies the directory in which that database will be created. If not present, it defaults to the system default tmp directory specified by File::Spec-Etmpdir(). The -chunk_size option allows you to tune the representation of DNA/Protein sequence in the Store database. By default, sequences are split into 2000 base/residue chunks and then reassembled as needed. This avoids the problem of pulling a whole chromosome into memory in order to fetch a short subsequence from somewhere in the middle. Depending on your usage patterns, you may wish to tune this parameter using a chunk size that is larger or smaller than the default. =cut # sub new { } inherited =head2 load Title : load Usage : $count = $loader->load(@ARGV) Function: load the indicated files or filehandles Returns : number of feature lines loaded Args : list of files or filehandles Status : public Once the loader is created, invoke its load() method with a list of GFF2 or FASTA file paths or previously-opened filehandles in order to load them into the database. Compressed files ending with .gz, .Z and .bz2 are automatically recognized and uncompressed on the fly. Paths beginning with http: or ftp: are treated as URLs and opened using the LWP GET program (which must be on your path). FASTA files are recognized by their initial "E" character. Do not feed the loader a file that is neither GFF2 nor FASTA; I don't know what will happen, but it will probably not be what you expect. =cut # sub load { } inherited =head2 accessors The following read-only accessors return values passed or created during new(): store() the long-term Bio::DB::SeqFeature::Store object tmp_store() the temporary Bio::DB::SeqFeature::Store object used during loading sfclass() the Bio::SeqFeatureI class fast() whether fast loading is active seq_chunk_size() the sequence chunk size verbose() verbose progress messages =cut # sub store inherited # sub tmp_store inherited # sub sfclass inherited # sub fast inherited # sub seq_chunk_size inherited # sub verbose inherited =head2 Internal Methods The following methods are used internally and may be overidden by subclasses. =over 4 =item default_seqfeature_class $class = $loader->default_seqfeature_class Return the default SeqFeatureI class (Bio::DB::SeqFeature). =cut # sub default_seqfeature_class { } inherited =item subfeatures_normalized $flag = $loader->subfeatures_normalized([$new_flag]) Get or set a flag that indicates that the subfeatures are normalized. This is deduced from the SeqFeature class information. =cut # sub subfeatures_normalized { } inherited =item subfeatures_in_table $flag = $loader->subfeatures_in_table([$new_flag]) Get or set a flag that indicates that feature/subfeature relationships are stored in a table. This is deduced from the SeqFeature class and Store information. =cut # sub subfeatures_in_table { } inherited =item load_fh $count = $loader->load_fh($filehandle) Load the GFF2 data at the other end of the filehandle and return true if successful. Internally, load_fh() invokes: start_load(); do_load($filehandle); finish_load(); =cut # sub load_fh { } inherited =item start_load, finish_load These methods are called at the start and end of a filehandle load. =cut # sub create_load_data { } #inherited # sub finish_load { } #inherite =item do_load $count = $loader->do_load($fh) This is called by load_fh() to load the GFF2 file's filehandle and return the number of lines loaded. =cut # sub do_load { } inherited =item load_line $loader->load_line($data); Load a line of a GFF2 file. You must bracket this with calls to start_load() and finish_load()! $loader->start_load(); $loader->load_line($_) while ; $loader->finish_load(); =cut # sub load_line { } # inherited =item handle_meta $loader->handle_meta($meta_directive) This method is called to handle meta-directives such as ##sequence-region. The method will receive the directive with the initial ## stripped off. =cut # sub handle_meta {} # inherited =item handle_feature $loader->handle_feature($gff2_line) This method is called to process a single GFF2 line. It manipulates information stored a data structure called $self-E{load_data}. =cut # sub handle_feature { } # inherited =item store_current_feature $loader->store_current_feature() This method is called to store the currently active feature in the database. It uses a data structure stored in $self-E{load_data}. =cut # sub store_current_feature { } inherited =item build_object_tree $loader->build_object_tree() This method gathers together features and subfeatures and builds the graph that connects them. =cut # sub build_object_tree { } # inherited =item build_object_tree_in_tables $loader->build_object_tree_in_tables() This method gathers together features and subfeatures and builds the graph that connects them, assuming that parent/child relationships will be stored in a database table. =cut # sub build_object_tree_in_tables { } # inherited =item build_object_tree_in_features $loader->build_object_tree_in_features() This method gathers together features and subfeatures and builds the graph that connects them, assuming that parent/child relationships are stored in the seqfeature objects themselves. =cut # sub build_object_tree_in_features { } # inherited =item attach_children $loader->attach_children($store,$load_data,$load_id,$feature) This recursively adds children to features and their subfeatures. It is called when subfeatures are directly contained within other features, rather than stored in a relational table. =cut # sub attach_children { } # inherited =item fetch my $feature = $loader->fetch($load_id) Given a load ID (from the ID= attribute) this method returns the feature from the temporary database or the permanent one, depending on where it is stored. =cut # sub fetch { } # inherited =item add_segment $loader->add_segment($parent,$child) This method is used to add a split location to the parent. =cut # sub add_segment { } # inherited =item parse_attributes ($reserved,$unreserved) = $loader->parse_attributes($attribute_line) This method parses the information contained in the $attribute_line into two hashrefs, one containing the values of reserved attribute tags (e.g. ID) and the other containing the values of unreserved ones. =cut sub parse_attributes { # overridden my $self = shift; my $att = shift; my @groups = quotewords('\s*;\s*',0,$att); my (%reserved,%unreserved); my $found_name; for (@groups) { my ($tag,$value); if (/^(\S+)\s+(.+)/) { # Tag value pair ($tag,$value) = ($1,$2); } else { $tag = 'Note'; $value = $_; } if ($tag eq 'Target') { my ($target,$start,$end) = split /\s+/,$value; push @{$reserved{ID}},$target; $found_name++; if ($start <= $end) { $value .= ' +' } else { $value .= ' -' } } if (!$found_name++) { push @{$reserved{Alias}},$value; $value = "$tag:$value"; push @{$reserved{ID}},$value; $tag = 'Name'; } if ($Special_attributes{$tag}) { # reserved attribute push @{$reserved{$tag}},$value; } else { push @{$unreserved{$tag}},$value; } } return (\%reserved,\%unreserved); } =item start_or_finish_sequence $loader->start_or_finish_sequence('Chr9') This method is called at the beginning and end of a fasta section. =cut # sub start_or_finish_sequence { } inherited =item load_sequence $loader->load_sequence('gatttcccaaa') This method is called to load some amount of sequence after start_or_finish_sequence() is first called. =cut # sub load_sequence { } inherited =item open_fh my $io_file = $loader->open_fh($filehandle_or_path) This method opens up the indicated file or pipe, using some intelligence to recognized compressed files and URLs and doing the right thing. =cut # sub open_fh { } inherited # sub msg { } inherited =item time my $time = $loader->time This method returns the current time in seconds, using Time::HiRes if available. =cut # sub time { } inherited =item unescape my $unescaped = GFF2Loader::unescape($escaped) This is an internal utility. It is the same as CGI::Util::unescape, but doesn't change pluses into spaces and ignores unicode escapes. =cut # sub unescape { } inherited 1; __END__ =back =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store/GFF3Loader.pm000444000765000024 7423512254227326 22004 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::GFF3Loader; =head1 NAME Bio::DB::SeqFeature::Store::GFF3Loader -- GFF3 file loader for Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; use Bio::DB::SeqFeature::Store::GFF3Loader; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test', -write => 1 ); my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(-store => $db, -verbose => 1, -fast => 1); $loader->load('./my_genome.gff3'); =head1 DESCRIPTION The Bio::DB::SeqFeature::Store::GFF3Loader object parsers GFF3-format sequence annotation files and loads Bio::DB::SeqFeature::Store databases. For certain combinations of SeqFeature classes and SeqFeature::Store databases it features a "fast load" mode which will greatly accelerate the loading of GFF3 databases by a factor of 5-10. The GFF3 file format has been extended very slightly to accommodate Bio::DB::SeqFeature::Store. First, the loader recognizes is a new directive: # #index-subfeatures [0|1] Note that you can place a space between the two #'s in order to prevent GFF3 validators from complaining. If this is true, then subfeatures are indexed (the default) so that they can be retrieved with a query. See L for an explanation of this. If false, then subfeatures can only be accessed through their parent feature. Second, the loader recognizes a new attribute tag called index, which if present, controls indexing of the current feature. Example: ctg123 . TF_binding_site 1000 1012 . + . ID=tfbs00001;index=1 You can use this to turn indexing on and off, overriding the default for a particular feature. Note that the loader keeps a record -- in memory -- of each feature that it has processed. If you find the loader running out of memory on particularly large GFF3 files, please split the input file into smaller pieces and do the load in steps. =cut # load utility - incrementally load the store based on GFF3 file # # two modes: # slow mode -- features can occur in any order in the GFF3 file # fast mode -- all features with same ID must be contiguous in GFF3 file use strict; use Carp 'croak'; use Bio::DB::GFF::Util::Rearrange; use Bio::DB::SeqFeature::Store::LoadHelper; use base 'Bio::DB::SeqFeature::Store::Loader'; my %Special_attributes =( Gap => 1, Target => 1, Parent => 1, Name => 1, Alias => 1, ID => 1, index => 1, Index => 1, ); my %Strandedness = ( '+' => 1, '-' => -1, '.' => 0, '' => 0, 0 => 0, 1 => 1, -1 => -1, +1 => 1, undef => 0, ); =head2 new Title : new Usage : $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(@options) Function: create a new parser Returns : a Bio::DB::SeqFeature::Store::GFF3Loader gff3 parser and loader Args : several - see below Status : public This method creates a new GFF3 loader and establishes its connection with a Bio::DB::SeqFeature::Store database. Arguments are -name=E$value pairs as described in this table: Name Value ---- ----- -store A writable Bio::DB::SeqFeature::Store database handle. -seqfeature_class The name of the type of Bio::SeqFeatureI object to create and store in the database (Bio::DB::SeqFeature by default) -sf_class A shorter alias for -seqfeature_class -verbose Send progress information to standard error. -fast If true, activate fast loading (see below) -chunk_size Set the storage chunk size for nucleotide/protein sequences (default 2000 bytes) -tmp Indicate a temporary directory to use when loading non-normalized features. -ignore_seqregion Ignore ##sequence-region directives. The default is to create a feature corresponding to the directive. -noalias_target Don't create an Alias attribute for a target_id named in a Target attribute. The default is to create an Alias attribute containing the target_id found in a Target attribute. When you call new(), a connection to a Bio::DB::SeqFeature::Store database should already have been established and the database initialized (if appropriate). Some combinations of Bio::SeqFeatures and Bio::DB::SeqFeature::Store databases support a fast loading mode. Currently the only reliable implementation of fast loading is the combination of DBI::mysql with Bio::DB::SeqFeature. The other important restriction on fast loading is the requirement that a feature that contains subfeatures must occur in the GFF3 file before any of its subfeatures. Otherwise the subfeatures that occurred before the parent feature will not be attached to the parent correctly. This restriction does not apply to normal (slow) loading. If you use an unnormalized feature class, such as Bio::SeqFeature::Generic, then the loader needs to create a temporary database in which to cache features until all their parts and subparts have been seen. This temporary databases uses the "berkeleydb" adaptor. The -tmp option specifies the directory in which that database will be created. If not present, it defaults to the system default tmp directory specified by File::Spec-Etmpdir(). The -chunk_size option allows you to tune the representation of DNA/Protein sequence in the Store database. By default, sequences are split into 2000 base/residue chunks and then reassembled as needed. This avoids the problem of pulling a whole chromosome into memory in order to fetch a short subsequence from somewhere in the middle. Depending on your usage patterns, you may wish to tune this parameter using a chunk size that is larger or smaller than the default. =cut sub new { my $class = shift; my $self = $class->SUPER::new(@_); my ($ignore_seqregion) = rearrange(['IGNORE_SEQREGION'],@_); $self->ignore_seqregion($ignore_seqregion); my ($noalias_target) = rearrange(['NOALIAS_TARGET'],@_); $self->noalias_target($noalias_target); $self; } =head2 ignore_seqregion $ignore_it = $loader->ignore_seqregion([$new_flag]) Get or set the ignore_seqregion flag, which if true, will cause GFF3 ##sequence-region directives to be ignored. The default behavior is to create a feature corresponding to the region. =cut sub ignore_seqregion { my $self = shift; my $d = $self->{ignore_seqregion}; $self->{ignore_seqregion} = shift if @_; $d; } =head2 noalias_target $noalias_target = $loader->noalias_target([$new_flag]) Get or set the noalias_target flag, which if true, will disable the creation of an Alias attribute for a target_id named in a Target attribute. The default is to create an Alias attribute containing the target_id found in a Target attribute. =cut sub noalias_target { my $self = shift; my $d = $self->{noalias_target}; $self->{noalias_target} = shift if @_; $d; } =head2 load Title : load Usage : $count = $loader->load(@ARGV) Function: load the indicated files or filehandles Returns : number of feature lines loaded Args : list of files or filehandles Status : public Once the loader is created, invoke its load() method with a list of GFF3 or FASTA file paths or previously-opened filehandles in order to load them into the database. Compressed files ending with .gz, .Z and .bz2 are automatically recognized and uncompressed on the fly. Paths beginning with http: or ftp: are treated as URLs and opened using the LWP GET program (which must be on your path). FASTA files are recognized by their initial "E" character. Do not feed the loader a file that is neither GFF3 nor FASTA; I don't know what will happen, but it will probably not be what you expect. =cut # sub load { } inherited =head2 accessors The following read-only accessors return values passed or created during new(): store() the long-term Bio::DB::SeqFeature::Store object tmp_store() the temporary Bio::DB::SeqFeature::Store object used during loading sfclass() the Bio::SeqFeatureI class fast() whether fast loading is active seq_chunk_size() the sequence chunk size verbose() verbose progress messages =cut # sub store inherited # sub tmp_store inherited # sub sfclass inherited # sub fast inherited # sub seq_chunk_size inherited # sub verbose inherited =head2 Internal Methods The following methods are used internally and may be overidden by subclasses. =over 4 =item default_seqfeature_class $class = $loader->default_seqfeature_class Return the default SeqFeatureI class (Bio::DB::SeqFeature). =cut # sub default_seqfeature_class { } inherited =item subfeatures_normalized $flag = $loader->subfeatures_normalized([$new_flag]) Get or set a flag that indicates that the subfeatures are normalized. This is deduced from the SeqFeature class information. =cut # sub subfeatures_normalized { } inherited =item subfeatures_in_table $flag = $loader->subfeatures_in_table([$new_flag]) Get or set a flag that indicates that feature/subfeature relationships are stored in a table. This is deduced from the SeqFeature class and Store information. =cut # sub subfeatures_in_table { } inherited =item load_fh $count = $loader->load_fh($filehandle) Load the GFF3 data at the other end of the filehandle and return true if successful. Internally, load_fh() invokes: start_load(); do_load($filehandle); finish_load(); =cut # sub load_fh { } inherited =item start_load, finish_load These methods are called at the start and end of a filehandle load. =cut sub create_load_data { #overridden my $self = shift; $self->SUPER::create_load_data; $self->{load_data}{TemporaryID} = "GFFLoad0000000"; $self->{load_data}{IndexSubfeatures} = $self->index_subfeatures(); $self->{load_data}{mode} = 'gff'; $self->{load_data}{Helper} = Bio::DB::SeqFeature::Store::LoadHelper->new($self->{tmpdir}); } sub finish_load { #overridden my $self = shift; $self->store_current_feature(); # during fast loading, we will have a feature left at the very end $self->start_or_finish_sequence(); # finish any half-loaded sequences $self->msg("Building object tree..."); my $start = $self->time(); $self->build_object_tree; $self->msg(sprintf "%5.2fs\n",$self->time()-$start); if ($self->fast) { $self->msg("Loading bulk data into database..."); $start = $self->time(); $self->store->finish_bulk_update; $self->msg(sprintf "%5.2fs\n",$self->time()-$start); } eval {$self->store->commit}; # don't delete load data so that caller can ask for the loaded IDs # $self->delete_load_data; } =item do_load $count = $loader->do_load($fh) This is called by load_fh() to load the GFF3 file's filehandle and return the number of lines loaded. =cut # sub do_load { } inherited =item load_line $loader->load_line($data); Load a line of a GFF3 file. You must bracket this with calls to start_load() and finish_load()! $loader->start_load(); $loader->load_line($_) while ; $loader->finish_load(); =cut sub load_line { #overridden my $self = shift; my $line = shift; chomp($line); my $load_data = $self->{load_data}; $load_data->{line}++; return unless $line =~ /^\S/; # blank line # if it has a tab in it or looks like a chrom.sizes file, switch to gff mode $load_data->{mode} = 'gff' if $line =~ /\t/ or $line =~ /^\w+\s+\d+\s*$/; if ($line =~ /^\#\s?\#\s*(.+)/) { ## meta instruction $load_data->{mode} = 'gff'; $self->handle_meta($1); } elsif ($line =~ /^\#/) { $load_data->{mode} = 'gff'; # just to be safe return; # comment } elsif ($line =~ /^>\s*(\S+)/) { # FASTA lines are coming $load_data->{mode} = 'fasta'; $self->start_or_finish_sequence($1); } elsif ($load_data->{mode} eq 'fasta') { $self->load_sequence($line); } elsif ($load_data->{mode} eq 'gff') { $self->handle_feature($line); if (++$load_data->{count} % 1000 == 0) { my $now = $self->time(); my $nl = -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; local $^W = 0; # kill uninit variable warning $self->msg(sprintf("%d features loaded in %5.2fs (%5.2fs/1000 features)...%s$nl", $load_data->{count},$now - $load_data->{start_time}, $now - $load_data->{millenium_time}, ' ' x 80 )); $load_data->{millenium_time} = $now; } } else { $self->throw("I don't know what to do with this line:\n$line"); } } =item handle_meta $loader->handle_meta($meta_directive) This method is called to handle meta-directives such as ##sequence-region. The method will receive the directive with the initial ## stripped off. =cut sub handle_meta { my $self = shift; my $instruction = shift; if ( $instruction =~ /^#$/ ) { $self->store_current_feature() ; # during fast loading, we will have a feature left at the very end $self->start_or_finish_sequence(); # finish any half-loaded sequences if ( $self->store->can('handle_resolution_meta') ) { $self->store->handle_resolution_meta($instruction); } return; } if ($instruction =~ /sequence-region\s+(.+)\s+(-?\d+)\s+(-?\d+)/i && !$self->ignore_seqregion()) { my($ref,$start,$end,$strand) = $self->_remap($1,$2,$3,+1); my $feature = $self->sfclass->new(-name => $ref, -seq_id => $ref, -start => $start, -end => $end, -strand => $strand, -primary_tag => 'region'); $self->store->store($feature); return; } if ($instruction =~/index-subfeatures\s+(\S+)/i) { $self->{load_data}{IndexSubfeatures} = $1; $self->store->index_subfeatures($1); return; } if ( $self->store->can('handle_unrecognized_meta') ) { $self->store->handle_unrecognized_meta($instruction); return; } } =item handle_feature $loader->handle_feature($gff3_line) This method is called to process a single GFF3 line. It manipulates information stored a data structure called $self-E{load_data}. =cut sub handle_feature { #overridden my $self = shift; my $gff_line = shift; my $ld = $self->{load_data}; my $allow_whitespace = $self->allow_whitespace; # special case for a chrom.sizes-style line my @columns; if ($gff_line =~ /^(\w+)\s+(\d+)\s*$/) { @columns = ($1,undef,'chromosome',1,$2,undef,undef,undef,"Name=$1"); } else { $gff_line =~ s/\s+/\t/g if $allow_whitespace; @columns = map {$_ eq '.' ? undef : $_ } split /\t/,$gff_line; } $self->invalid_gff($gff_line) if @columns < 4; $self->invalid_gff($gff_line) if @columns > 9 && $allow_whitespace; { local $^W = 0; if (@columns > 9) { #oops, split too much due to whitespace $columns[8] = join(' ',@columns[8..$#columns]); } } my ($refname,$source,$method,$start,$end,$score,$strand,$phase,$attributes) = @columns; $self->invalid_gff($gff_line) unless defined $refname; $self->invalid_gff($gff_line) unless !defined $start || $start =~ /^[\d.-]+$/; $self->invalid_gff($gff_line) unless !defined $end || $end =~ /^[\d.-]+$/; $self->invalid_gff($gff_line) unless defined $method; $strand = $Strandedness{$strand||0}; my ($reserved,$unreserved) = $attributes ? $self->parse_attributes($attributes) : (); my $name = ($reserved->{Name} && $reserved->{Name}[0]); my $has_loadid = defined $reserved->{ID}[0]; my $feature_id = defined $reserved->{ID}[0] ? $reserved->{ID}[0] : $ld->{TemporaryID}++; my @parent_ids = @{$reserved->{Parent}} if defined $reserved->{Parent}; my $index_it = $ld->{IndexSubfeatures}; if (exists $reserved->{Index} || exists $reserved->{index}) { $index_it = $reserved->{Index}[0] || $reserved->{index}[0]; } # Everything in the unreserved hash becomes an attribute, so we copy # some attributes over $unreserved->{Note} = $reserved->{Note} if exists $reserved->{Note}; $unreserved->{Alias} = $reserved->{Alias} if exists $reserved->{Alias}; $unreserved->{Target} = $reserved->{Target} if exists $reserved->{Target}; $unreserved->{Gap} = $reserved->{Gap} if exists $reserved->{Gap}; $unreserved->{load_id}= $reserved->{ID} if exists $reserved->{ID}; # mec@stowers-institute.org, wondering why not all attributes are # carried forward, adds ID tag in particular service of # round-tripping ID, which, though present in database as load_id # attribute, was getting lost as itself # $unreserved->{ID}= $reserved->{ID} if exists $reserved->{ID}; # TEMPORARY HACKS TO SIMPLIFY DEBUGGING $feature_id = '' unless defined $feature_id; $name = '' unless defined $name; # prevent uninit variable warnings # push @{$unreserved->{Alias}},$feature_id if $has_loadid && $feature_id ne $name; $unreserved->{parent_id} = \@parent_ids if @parent_ids; # POSSIBLY A PERMANENT HACK -- TARGETS BECOME ALIASES # THIS IS TO ALLOW FOR TARGET-BASED LOOKUPS if (exists $reserved->{Target} && !$self->{noalias_target}) { my %aliases = map {$_=>1} @{$unreserved->{Alias}}; for my $t (@{$reserved->{Target}}) { (my $tc = $t) =~ s/\s+.*$//; # get rid of coordinates $name ||= $tc; push @{$unreserved->{Alias}},$tc unless $name eq $tc || $aliases{$tc}; } } ($refname,$start,$end,$strand) = $self->_remap($refname,$start,$end,$strand) or return; my @args = (-display_name => $name, -seq_id => $refname, -start => $start, -end => $end, -strand => $strand || 0, -score => $score, -phase => $phase, -primary_tag => $method || 'feature', -source => $source, -tag => $unreserved, -attributes => $unreserved, ); # Here's where we handle feature lines that have the same ID (multiple locations, not # parent/child relationships) my $old_feat; # Current feature is the same as the previous feature, which hasn't yet been loaded if (defined $ld->{CurrentID} && $ld->{CurrentID} eq $feature_id) { $old_feat = $ld->{CurrentFeature}; } # Current feature is the same as a feature that was loaded earlier elsif (defined(my $id = $self->{load_data}{Helper}->local2global($feature_id))) { $old_feat = $self->fetch($feature_id) or $self->warn(<{TemporaryID}++; # AND they have a Parent attribute, this causes an undesirable } # additional layer of aggregation. Changing the ID fixes this. elsif ( $old_feat->seq_id ne $refname || $old_feat->start != $start || $old_feat->end != $end # make sure endpoints are distinct ) { $self->add_segment($old_feat,$self->sfclass->new(@args)); return; } } # we get here if this is a new feature # first of all, store the current feature if it is there $self->store_current_feature() if defined $ld->{CurrentID}; # now create the new feature # (index top-level features only if policy asks us to) my $feature = $self->sfclass->new(@args); $feature->object_store($self->store) if $feature->can('object_store'); # for lazy table features $ld->{CurrentFeature} = $feature; $ld->{CurrentID} = $feature_id; my $top_level = !@parent_ids; my $has_id = defined $reserved->{ID}[0]; $index_it ||= $top_level; my $helper = $ld->{Helper}; $helper->indexit($feature_id=>1) if $index_it; $helper->toplevel($feature_id=>1) if !$self->{fast} && $top_level; # need to track top level features # remember parentage for my $parent (@parent_ids) { $helper->add_children($parent=>$feature_id); } } sub invalid_gff { my $self = shift; my $line = shift; $self->throw("invalid GFF line at line $self->{load_data}{line}.\n".$line); } =item allow_whitespace $allow_it = $loader->allow_whitespace([$newvalue]); Get or set the allow_whitespace flag. If true, then GFF3 files are allowed to be delimited with whitespace in addition to tabs. =cut sub allow_whitespace { my $self = shift; my $d = $self->{allow_whitespace}; $self->{allow_whitespace} = shift if @_; $d; } =item store_current_feature $loader->store_current_feature() This method is called to store the currently active feature in the database. It uses a data structure stored in $self-E{load_data}. =cut # sub store_current_feature { } inherited =item build_object_tree $loader->build_object_tree() This method gathers together features and subfeatures and builds the graph that connects them. =cut ### # put objects together # sub build_object_tree { my $self = shift; $self->subfeatures_in_table ? $self->build_object_tree_in_tables : $self->build_object_tree_in_features; } =item build_object_tree_in_tables $loader->build_object_tree_in_tables() This method gathers together features and subfeatures and builds the graph that connects them, assuming that parent/child relationships will be stored in a database table. =cut sub build_object_tree_in_tables { my $self = shift; my $store = $self->store; my $helper = $self->{load_data}{Helper}; while (my ($load_id,$children) = $helper->each_family()) { my $parent_id = $helper->local2global($load_id); die $self->throw("$load_id doesn't have a primary id") unless defined $parent_id; my @children = map {$helper->local2global($_)} @$children; # this updates the table that keeps track of parent/child relationships, # but does not update the parent object -- so (start,end) had better be right!!! $store->add_SeqFeature($parent_id,@children); } } =item build_object_tree_in_features $loader->build_object_tree_in_features() This method gathers together features and subfeatures and builds the graph that connects them, assuming that parent/child relationships are stored in the seqfeature objects themselves. =cut sub build_object_tree_in_features { my $self = shift; my $store = $self->store; my $tmp = $self->tmp_store; my $ld = $self->{load_data}; my $normalized = $self->subfeatures_normalized; my $helper = $ld->{Helper}; while (my $load_id = $helper->each_toplevel) { my $feature = $self->fetch($load_id) or $self->throw("$load_id (id=" .$helper->local2global($load_id) ." should have a database entry, but doesn't"); $self->attach_children($store,$ld,$load_id,$feature); # Indexed objects are updated, not created anew $feature->primary_id(undef) unless $helper->indexit($load_id); $store->store($feature); } } =item attach_children $loader->attach_children($store,$load_data,$load_id,$feature) This recursively adds children to features and their subfeatures. It is called when subfeatures are directly contained within other features, rather than stored in a relational table. =cut sub attach_children { my $self = shift; my ($store,$ld,$load_id,$feature) = @_; my $children = $ld->{Helper}->children() or return; for my $child_id (@$children) { my $child = $self->fetch($child_id) or $self->throw("$child_id should have a database entry, but doesn't"); $self->attach_children($store,$ld,$child_id,$child); # recursive call $feature->add_SeqFeature($child); } } =item fetch my $feature = $loader->fetch($load_id) Given a load ID (from the ID= attribute) this method returns the feature from the temporary database or the permanent one, depending on where it is stored. =cut sub fetch { my $self = shift; my $load_id = shift; my $helper = $self->{load_data}{Helper}; my $id = $helper->local2global($load_id); return ($self->subfeatures_normalized || $helper->indexit($load_id) ? $self->store->fetch($id) : $self->tmp_store->fetch($id) ); } =item add_segment $loader->add_segment($parent,$child) This method is used to add a split location to the parent. =cut sub add_segment { my $self = shift; my ($parent,$child) = @_; if ($parent->can('add_segment')) { # probably a lazy table feature my $segment_count = $parent->can('denormalized_segment_count') ? $parent->denormalized_segment_count : $parent->can('denormalized_segments ') ? $parent->denormalized_segments : $parent->can('segments') ? $parent->segments : 0; unless ($segment_count) { # convert into a segmented object my $segment; if ($parent->can('clone')) { $segment = $parent->clone; } else { my %clone = %$parent; $segment = bless \%clone,ref $parent; } delete $segment->{segments}; eval {$segment->object_store(undef) }; $segment->primary_id(undef); # this updates the object and expands its start and end positions without writing # the segments into the database as individual objects $parent->add_segment($segment); } $parent->add_segment($child); 1; # for debugging } # a conventional Bio::SeqFeature::Generic object - create a split location else { my $current_location = $parent->location; if ($current_location->can('add_sub_Location')) { $current_location->add_sub_Location($child->location); } else { eval "require Bio::Location::Split" unless Bio::Location::Split->can('add_sub_Location'); my $new_location = Bio::Location::Split->new(); $new_location->add_sub_Location($current_location); $new_location->add_sub_Location($child->location); $parent->location($new_location); } } } =item parse_attributes ($reserved,$unreserved) = $loader->parse_attributes($attribute_line) This method parses the information contained in the $attribute_line into two hashrefs, one containing the values of reserved attribute tags (e.g. ID) and the other containing the values of unreserved ones. =cut sub parse_attributes { my $self = shift; my $att = shift; unless ($att =~ /=/) { # ouch! must be a GFF line require Bio::DB::SeqFeature::Store::GFF2Loader unless Bio::DB::SeqFeature::Store::GFF2Loader->can('parse_attributes'); return $self->Bio::DB::SeqFeature::Store::GFF2Loader::parse_attributes($att); } my @pairs = map { my ($name,$value) = split '='; [$self->unescape($name) => $value]; } split ';',$att; my (%reserved,%unreserved); foreach (@pairs) { my $tag = $_->[0]; unless (defined $_->[1]) { warn "$tag does not have a value at GFF3 file line $.\n"; next; } my @values = split ',',$_->[1]; map {$_ = $self->unescape($_);} @values; if ($Special_attributes{$tag}) { # reserved attribute push @{$reserved{$tag}},@values; } else { push @{$unreserved{$tag}},@values } } return (\%reserved,\%unreserved); } =item start_or_finish_sequence $loader->start_or_finish_sequence('Chr9') This method is called at the beginning and end of a fasta section. =cut # sub start_or_finish_sequence { } inherited =item load_sequence $loader->load_sequence('gatttcccaaa') This method is called to load some amount of sequence after start_or_finish_sequence() is first called. =cut # sub load_sequence { } inherited =item open_fh my $io_file = $loader->open_fh($filehandle_or_path) This method opens up the indicated file or pipe, using some intelligence to recognized compressed files and URLs and doing the right thing. =cut # sub open_fh { } inherited # sub msg { } inherited =item time my $time = $loader->time This method returns the current time in seconds, using Time::HiRes if available. =cut # sub time { } inherited =item unescape my $unescaped = GFF3Loader::unescape($escaped) This is an internal utility. It is the same as CGI::Util::unescape, but doesn't change pluses into spaces and ignores unicode escapes. =cut # sub unescape { } inherited sub _remap { my $self = shift; my ($ref,$start,$end,$strand) = @_; my $mapper = $self->coordinate_mapper; return ($ref,$start,$end,$strand) unless $mapper; my ($newref,$coords) = $mapper->($ref,[$start,$end]); return unless defined $coords->[0]; if ($coords->[0] > $coords->[1]) { @{$coords} = reverse(@{$coords}); $strand *= -1; } return ($newref,@{$coords},$strand); } sub _indexit { # override my $self = shift; return $self->{load_data}{Helper}->indexit(@_); } sub _local2global { # override my $self = shift; return $self->{load_data}{Helper}->local2global(@_); } =item local_ids my $ids = $self->local_ids; my $id_cnt = @$ids; After performing a load, this returns an array ref containing all the load file IDs that were contained within the file just loaded. =cut sub local_ids { # override my $self = shift; return $self->{load_data}{Helper}->local_ids(@_); } =item loaded_ids my $ids = $loader->loaded_ids; my $id_cnt = @$ids; After performing a load, this returns an array ref containing all the feature primary ids that were created during the load. =cut sub loaded_ids { # override my $self = shift; return $self->{load_data}{Helper}->loaded_ids(@_); } 1; __END__ =back =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store/Loader.pm000444000765000024 5053512254227323 21370 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::Loader; =head1 NAME Bio::DB::SeqFeature::Store::Loader -- Loader =head1 SYNOPSIS # non-instantiable base class =head1 DESCRIPTION This is the base class for Bio::DB::SeqFeature::Loader::GFF3Loader, Bio::DB::SeqFeature::Loader::GFFLoader, and Bio::DB::SeqFeature::FeatureFileLoader. Please see the manual pages for these modules. =cut # load utility - incrementally load the store based on GFF3 file # # two modes: # slow mode -- features can occur in any order in the GFF3 file # fast mode -- all features with same ID must be contiguous in GFF3 file use strict; use Carp 'croak'; use IO::File; use Bio::DB::GFF::Util::Rearrange; use Bio::DB::SeqFeature::Store; use File::Spec; use File::Temp 'tempdir'; use base 'Bio::Root::Root'; use constant DEFAULT_SEQ_CHUNK_SIZE => 2000; =head2 new Title : new Usage : $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(@options) Function: create a new parser Returns : a Bio::DB::SeqFeature::Store::GFF3Loader gff3 parser and loader Args : several - see below Status : public This method creates a new GFF3 loader and establishes its connection with a Bio::DB::SeqFeature::Store database. Arguments are -name=E$value pairs as described in this table: Name Value ---- ----- -store A writable Bio::DB::SeqFeature::Store database handle. -seqfeature_class The name of the type of Bio::SeqFeatureI object to create and store in the database (Bio::DB::SeqFeature by default) -sf_class A shorter alias for -seqfeature_class -verbose Send progress information to standard error. -fast If true, activate fast loading (see below) -chunk_size Set the storage chunk size for nucleotide/protein sequences (default 2000 bytes) -tmp Indicate a temporary directory to use when loading non-normalized features. -map_coords A code ref that will transform a list of ($ref,[$start1,$end1]...) coordinates into a list of ($newref,[$newstart1,$newend1]...) -index_subfeatures Indicate true if subfeatures should be indexed. Default is true. -summary_stats Rebuild summary stats at the end of loading (not incremental, so takes a long time) When you call new(), a connection to a Bio::DB::SeqFeature::Store database should already have been established and the database initialized (if appropriate). Some combinations of Bio::SeqFeatures and Bio::DB::SeqFeature::Store databases support a fast loading mode. Currently the only reliable implementation of fast loading is the combination of DBI::mysql with Bio::DB::SeqFeature. The other important restriction on fast loading is the requirement that a feature that contains subfeatures must occur in the GFF3 file before any of its subfeatures. Otherwise the subfeatures that occurred before the parent feature will not be attached to the parent correctly. This restriction does not apply to normal (slow) loading. If you use an unnormalized feature class, such as Bio::SeqFeature::Generic, then the loader needs to create a temporary database in which to cache features until all their parts and subparts have been seen. This temporary databases uses the "berkeleydb" adaptor. The -tmp option specifies the directory in which that database will be created. If not present, it defaults to the system default tmp directory specified by File::Spec-Etmpdir(). The -chunk_size option allows you to tune the representation of DNA/Protein sequence in the Store database. By default, sequences are split into 2000 base/residue chunks and then reassembled as needed. This avoids the problem of pulling a whole chromosome into memory in order to fetch a short subsequence from somewhere in the middle. Depending on your usage patterns, you may wish to tune this parameter using a chunk size that is larger or smaller than the default. =cut sub new { my $self = shift; my ($store,$seqfeature_class,$tmpdir,$verbose,$fast, $seq_chunk_size,$coordinate_mapper,$index_subfeatures,$summary_stats) = rearrange(['STORE', ['SF_CLASS','SEQFEATURE_CLASS'], ['TMP','TMPDIR'], 'VERBOSE', 'FAST', 'CHUNK_SIZE', 'MAP_COORDS', 'INDEX_SUBFEATURES', 'SUMMARY_STATS' ],@_); $seqfeature_class ||= $self->default_seqfeature_class; eval "require $seqfeature_class" unless $seqfeature_class->can('new'); $self->throw($@) if $@; my $normalized = $seqfeature_class->can('subfeatures_are_normalized') && $seqfeature_class->subfeatures_are_normalized; my $in_table = $seqfeature_class->can('subfeatures_are_stored_in_a_table') && $seqfeature_class->subfeatures_are_stored_in_a_table; if ($fast) { my $canfast = $normalized && $in_table; warn <tmpdir(); my ($tmp_store,$temp_load); unless ($normalized) { # remember the temporary directory in order to delete it on exit $temp_load = tempdir( 'BioDBSeqFeature_XXXXXXX', DIR=>$tmpdir, CLEANUP=>1 ); $tmp_store = Bio::DB::SeqFeature::Store->new(-adaptor => 'berkeleydb', -temporary=> 1, -dsn => $temp_load, -cache => 1, -write => 1) unless $normalized; } $index_subfeatures = 1 unless defined $index_subfeatures; return bless { store => $store, tmp_store => $tmp_store, seqfeature_class => $seqfeature_class, fast => $fast, seq_chunk_size => $seq_chunk_size || DEFAULT_SEQ_CHUNK_SIZE, verbose => $verbose, load_data => {}, tmpdir => $tmpdir, temp_load => $temp_load, subfeatures_normalized => $normalized, subfeatures_in_table => $in_table, coordinate_mapper => $coordinate_mapper, index_subfeatures => $index_subfeatures, summary_stats => $summary_stats, },ref($self) || $self; } sub coordinate_mapper { my $self = shift; my $d = $self->{coordinate_mapper}; $self->{coordinate_mapper} = shift if @_; $d; } sub index_subfeatures { my $self = shift; my $d = $self->{index_subfeatures}; $self->{index_subfeatures} = shift if @_; $d; } sub summary_stats { my $self = shift; my $d = $self->{summary_stats}; $self->{summary_stats} = shift if @_; $d; } =head2 load Title : load Usage : $count = $loader->load(@ARGV) Function: load the indicated files or filehandles Returns : number of feature lines loaded Args : list of files or filehandles Status : public Once the loader is created, invoke its load() method with a list of GFF3 or FASTA file paths or previously-opened filehandles in order to load them into the database. Compressed files ending with .gz, .Z and .bz2 are automatically recognized and uncompressed on the fly. Paths beginning with http: or ftp: are treated as URLs and opened using the LWP GET program (which must be on your path). FASTA files are recognized by their initial "E" character. Do not feed the loader a file that is neither GFF3 nor FASTA; I don't know what will happen, but it will probably not be what you expect. =cut sub load { my $self = shift; my $start = $self->time(); my $count = 0; for my $file_or_fh (@_) { $self->msg("loading $file_or_fh...\n"); my $fh = $self->open_fh($file_or_fh) or $self->throw("Couldn't open $file_or_fh: $!"); $count += $self->load_fh($fh); $self->msg(sprintf "load time: %5.2fs\n",$self->time()-$start); } if ($self->summary_stats) { $self->msg("Building summary statistics for coverage graphs..."); my $start = $self->time(); $self->build_summary; $self->msg(sprintf "coverage graph build time: %5.2fs\n",$self->time()-$start); } $self->msg(sprintf "total load time: %5.2fs\n",$self->time()-$start); $count; } =head2 accessors The following read-only accessors return values passed or created during new(): store() the long-term Bio::DB::SeqFeature::Store object tmp_store() the temporary Bio::DB::SeqFeature::Store object used during loading sfclass() the Bio::SeqFeatureI class fast() whether fast loading is active seq_chunk_size() the sequence chunk size verbose() verbose progress messages =cut sub store { shift->{store} } sub tmp_store { shift->{tmp_store} } sub sfclass { shift->{seqfeature_class} } sub fast { shift->{fast} } sub seq_chunk_size { shift->{seq_chunk_size} } sub verbose { shift->{verbose} } =head2 Internal Methods The following methods are used internally and may be overidden by subclasses. =over 4 =item default_seqfeature_class $class = $loader->default_seqfeature_class Return the default SeqFeatureI class (Bio::DB::SeqFeature). =cut sub default_seqfeature_class { my $self = shift; return 'Bio::DB::SeqFeature'; } =item subfeatures_normalized $flag = $loader->subfeatures_normalized([$new_flag]) Get or set a flag that indicates that the subfeatures are normalized. This is deduced from the SeqFeature class information. =cut sub subfeatures_normalized { my $self = shift; my $d = $self->{subfeatures_normalized}; $self->{subfeatures_normalized} = shift if @_; $d; } =item subfeatures_in_table $flag = $loader->subfeatures_in_table([$new_flag]) Get or set a flag that indicates that feature/subfeature relationships are stored in a table. This is deduced from the SeqFeature class and Store information. =cut sub subfeatures_in_table { my $self = shift; my $d = $self->{subfeatures_in_table}; $self->{subfeatures_in_table} = shift if @_; $d; } =item load_fh $count = $loader->load_fh($filehandle) Load the GFF3 data at the other end of the filehandle and return true if successful. Internally, load_fh() invokes: start_load(); do_load($filehandle); finish_load(); =cut sub load_fh { my $self = shift; my $fh = shift; $self->start_load(); my $count = $self->do_load($fh); $self->finish_load(); $count; } =item start_load, finish_load These methods are called at the start and end of a filehandle load. =cut sub start_load { my $self = shift; $self->create_load_data; $self->store->start_bulk_update() if $self->fast; } sub create_load_data { my $self = shift; $self->{load_data}{CurrentFeature} = undef; $self->{load_data}{CurrentID} = undef; $self->{load_data}{IndexIt} = {}; $self->{load_data}{Local2GlobalID} = {}; $self->{load_data}{count} = 0; $self->{load_data}{mode} = undef; $self->{load_data}{start_time} = 0; } sub delete_load_data { my $self = shift; delete $self->{load_data}; } sub finish_load { my $self = shift; $self->store_current_feature(); # during fast loading, we will have a feature left at the very end $self->start_or_finish_sequence(); # finish any half-loaded sequences if ($self->fast) { $self->{load_data}{start_time} = $self->time(); $self->store->finish_bulk_update; } $self->msg(sprintf "%5.2fs\n",$self->time()-$self->{load_data}{start_time}); eval {$self->store->commit}; # don't delete load data so that caller can ask for the loaded IDs # $self->delete_load_data; } =item build_summary $loader->build_summary Call this to rebuild the summary coverage statistics. This is done automatically if new() was passed a true value for -summary_stats at create time. =cut sub build_summary { my $self = shift; $self->store->build_summary_statistics; } =item do_load $count = $loader->do_load($fh) This is called by load_fh() to load the GFF3 file's filehandle and return the number of lines loaded. =cut sub do_load { my $self = shift; my $fh = shift; $self->{load_data}{start_time} = $self->time(); $self->{load_data}->{millenium_time} = $self->{load_data}{start_time}; $self->load_line($_) while <$fh>; $self->msg(sprintf "%d features loaded in %5.2fs%s\r", $self->{load_data}->{count}, $self->time()-$self->{load_data}{start_time}, ' 'x80 ); $self->{load_data}{count}; } =item load_line $loader->load_line($data); Load a line of a GFF3 file. You must bracket this with calls to start_load() and finish_load()! $loader->start_load(); $loader->load_line($_) while ; $loader->finish_load(); =cut sub load_line { my $self = shift; my $line = shift; # don't do anything } =item handle_feature $loader->handle_feature($data_line) This method is called to process a single data line. It manipulates information stored a data structure called $self-E{load_data}. =cut sub handle_feature { my $self = shift; my $line = shift; # do nothing } =item handle_meta $loader->handle_meta($data_line) This method is called to process a single data line. It manipulates information stored a data structure called $self-E{load_data}. =cut sub handle_meta { my $self = shift; my $line = shift; # do nothing } sub _indexit { my $self = shift; my $id = shift; $id ||= ''; # avoid uninit warnings my $indexhash = $self->{load_data}{IndexIt}; $indexhash->{$id} = shift if @_; return $indexhash->{$id}; } sub _local2global { my $self = shift; my $id = shift; $id ||= ''; # avoid uninit warnings my $indexhash = $self->{load_data}{Local2GlobalID}; $indexhash->{$id} = shift if @_; return $indexhash->{$id}; } =item store_current_feature $loader->store_current_feature() This method is called to store the currently active feature in the database. It uses a data structure stored in $self-E{load_data}. =cut sub store_current_feature { my $self = shift; my $ld = $self->{load_data}; defined $ld->{CurrentFeature} or return; my $f = $ld->{CurrentFeature}; my $normalized = $self->subfeatures_normalized; my $indexed = $self->_indexit($ld->{CurrentID}); # logic is as follows: # 1. If the feature is an indexed feature, then we store it into the main database # so that it can be searched. It doesn't matter whether it is a top-level feature # or a subfeature. # 2. If the feature class is normalized, but not indexed, then we store it into the # main database using the "no_index" method. This will make it accessible to # queries on the top level parent, but it won't come up by itself in range or # attribute searches. # 3. Otherwise, this is an unindexed subfeature; we store it in the temporary database # until the object build step, at which point it gets integrated into its object tree # and copied into the main database. if ($indexed) { $self->store->store($f); } elsif ($normalized) { $self->store->store_noindex($f) } else { $self->tmp_store->store_noindex($f) } my $id = $f->primary_id; # assigned by store() $self->_local2global($ld->{CurrentID} => $id); $self->_indexit($ld->{CurrentID} => 0)if $normalized; # no need to remember this undef $ld->{CurrentID}; undef $ld->{CurrentFeature}; } =item parse_attributes ($reserved,$unreserved) = $loader->parse_attributes($attribute_line) This method parses the information contained in the $attribute_line into two hashrefs, one containing the values of reserved attribute tags (e.g. ID) and the other containing the values of unreserved ones. =cut sub parse_attributes { my $self = shift; my $att = shift; # do nothing } =item start_or_finish_sequence $loader->start_or_finish_sequence('Chr9') This method is called at the beginning and end of a fasta section. =cut # this gets called at the beginning and end of a fasta section sub start_or_finish_sequence { my $self = shift; my $seqid = shift; if (my $sl = $self->{fasta_load}) { if (defined $sl->{seqid}) { $self->store->insert_sequence($sl->{seqid},$sl->{sequence},$sl->{offset}); delete $self->{fasta_load}; } } if (defined $seqid) { $self->{fasta_load} = {seqid => $seqid, offset => 0, sequence => ''}; } } =item load_sequence $loader->load_sequence('gatttcccaaa') This method is called to load some amount of sequence after start_or_finish_sequence() is first called. =cut sub load_sequence { my $self = shift; my $seq = shift; my $sl = $self->{fasta_load} or return; my $cs = $self->seq_chunk_size; $sl->{sequence} .= $seq; while (length $sl->{sequence} >= $cs) { my $chunk = substr($sl->{sequence},0,$cs); $self->store->insert_sequence($sl->{seqid},$chunk,$sl->{offset}); $sl->{offset} += length $chunk; substr($sl->{sequence},0,$cs) = ''; } } =item open_fh my $io_file = $loader->open_fh($filehandle_or_path) This method opens up the indicated file or pipe, using some intelligence to recognized compressed files and URLs and doing the right thing. =cut sub open_fh { my $self = shift; my $thing = shift; no strict 'refs'; return $thing if defined fileno($thing); return IO::File->new("gunzip -c $thing |") if $thing =~ /\.gz$/; return IO::File->new("uncompress -c $thing |") if $thing =~ /\.Z$/; return IO::File->new("bunzip2 -c $thing |") if $thing =~ /\.bz2$/; return IO::File->new("GET $thing |") if $thing =~ /^(http|ftp):/; return $thing if ref $thing && $thing->isa('IO::String'); return IO::File->new($thing); } sub msg { my $self = shift; my @msg = @_; return unless $self->verbose; print STDERR @msg; } =item loaded_ids my $ids = $loader->loaded_ids; my $id_cnt = @$ids; After performing a load, this returns an array ref containing all the feature primary ids that were created during the load. =cut sub loaded_ids { my $self = shift; my @ids = values %{$self->{load_data}{Local2GlobalID}} if $self->{load_data}; return \@ids; } =item local_ids my $ids = $self->local_ids; my $id_cnt = @$ids; After performing a load, this returns an array ref containing all the load file IDs that were contained within the file just loaded. =cut sub local_ids { my $self = shift; my @ids = keys %{$self->{load_data}{Local2GlobalID}} if $self->{load_data}; return \@ids; } =item time my $time = $loader->time This method returns the current time in seconds, using Time::HiRes if available. =cut sub time { return Time::HiRes::time() if Time::HiRes->can('time'); return time(); } =item unescape my $unescaped = GFF3Loader::unescape($escaped) This is an internal utility. It is the same as CGI::Util::unescape, but doesn't change pluses into spaces and ignores unicode escapes. =cut sub unescape { my $self = shift; my $todecode = shift; $todecode =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge; return $todecode; } sub DESTROY { my $self = shift; # Close filehandles, so temporal files can be properly deleted my $store = $self->store; if ( $store->isa('Bio::DB::SeqFeature::Store::memory') or $store->isa('Bio::DB::SeqFeature::Store::berkeleydb3') ) { $store->private_fasta_file->close; if ($store->{fasta_db}) { while (my ($file, $fh) = each %{ $store->{fasta_db}->{fhcache} }) { $fh->close; } $store->{fasta_db}->_close_index($store->{fasta_db}->{offsets}); } } elsif ($store->isa('Bio::DB::SeqFeature::Store::DBI::SQLite')) { if (%DBI::installed_drh) { DBI->disconnect_all; %DBI::installed_drh = (); } undef $store->{dbh}; } if (my $ld = $self->{temp_load}) { unlink $ld; } } 1; __END__ =back =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store/LoadHelper.pm000444000765000024 1131212254227333 22170 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::LoadHelper; =head1 NAME Bio::DB::SeqFeature::Store::LoadHelper -- Internal utility for Bio::DB::SeqFeature::Store =head1 SYNOPSIS # For internal use only. =head1 DESCRIPTION For internal use only =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut use strict; use DB_File; use File::Path 'rmtree'; use File::Temp 'tempdir'; use File::Spec; use Fcntl qw(O_CREAT O_RDWR); our $VERSION = '1.10'; my %DBHandles; sub new { my $class = shift; my $tmpdir = shift; my $template = 'SeqFeatureLoadHelper_XXXXXX'; my @tmpargs = $tmpdir ? ($template,DIR=>$tmpdir) : ($template); my $tmppath = tempdir(@tmpargs,CLEANUP=>1); my $self = $class->create_dbs($tmppath); $self->{tmppath} = $tmppath; return bless $self,$class; } sub DESTROY { my $self = shift; # Destroy all filehandle references # before trying to delete files and folder %DBHandles = (); undef $self->{IndexIt}; undef $self->{TopLevel}; undef $self->{Local2Global}; undef $self->{Parent2Child}; rmtree $self->{tmppath}; # File::Temp::cleanup() unless $self->{keep}; } sub create_dbs { my $self = shift; my $tmp = shift; my %self; # experiment with caching these handles in memory my $hash_options = DB_File::HASHINFO->new(); # Each of these hashes allow only unique keys for my $dbname (qw(IndexIt TopLevel Local2Global)) { unless ($DBHandles{$dbname}) { my %h; tie(%h,'DB_File',File::Spec->catfile($tmp,$dbname), O_CREAT|O_RDWR,0666,$hash_options); $DBHandles{$dbname} = \%h; } $self{$dbname} = $DBHandles{$dbname}; %{$self{$dbname}} = (); } # The Parent2Child hash allows duplicate keys, so we # create it with the R_DUP flag. my $btree_options = DB_File::BTREEINFO->new(); $btree_options->{flags} = R_DUP; unless ($DBHandles{'Parent2Child'}) { my %h; tie(%h,'DB_File',File::Spec->catfile($tmp,'Parent2Child'), O_CREAT|O_RDWR,0666,$btree_options); $DBHandles{'Parent2Child'} = \%h; } $self{Parent2Child} = $DBHandles{'Parent2Child'}; %{$self{Parent2Child}} = (); return \%self; } sub indexit { my $self = shift; my $id = shift; $self->{IndexIt}{$id} = shift if @_; return $self->{IndexIt}{$id}; } sub toplevel { my $self = shift; my $id = shift; $self->{TopLevel}{$id} = shift if @_; return $self->{TopLevel}{$id}; } sub each_toplevel { my $self = shift; my ($id) = each %{$self->{TopLevel}}; $id; } sub local2global { my $self = shift; my $id = shift; $self->{Local2Global}{$id} = shift if @_; return $self->{Local2Global}{$id}; } sub add_children { my $self = shift; my $parent_id = shift; # (@children) = @_; $self->{Parent2Child}{$parent_id} = shift while @_; } sub children { my $self = shift; my $parent_id = shift; my @children; my $db = tied(%{$self->{Parent2Child}}); my $key = $parent_id; my $value = ''; for (my $status = $db->seq($key,$value,R_CURSOR); $status == 0 && $key eq $parent_id; $status = $db->seq($key,$value,R_NEXT) ) { push @children,$value; } return wantarray ? @children: \@children; } # this acts like each() and returns each parent id and an array ref of children sub each_family { my $self = shift; my $db = tied(%{$self->{Parent2Child}}); if ($self->{_cursordone}) { undef $self->{_cursordone}; undef $self->{_parent}; undef $self->{_child}; return; } # do a slightly tricky cursor search unless (defined $self->{_parent}) { return unless $db->seq($self->{_parent},$self->{_child},R_FIRST) == 0; } my $parent = $self->{_parent}; my @children = $self->{_child}; my $status; while (($status = $db->seq($self->{_parent},$self->{_child},R_NEXT)) == 0 && $self->{_parent} eq $parent ) { push @children,$self->{_child}; } $self->{_cursordone}++ if $status != 0; return ($parent,\@children); } sub local_ids { my $self = shift; my @ids = keys %{$self->{Local2Global}} if $self->{Local2Global}; return \@ids; } sub loaded_ids { my $self = shift; my @ids = values %{$self->{Local2Global}} if $self->{Local2Global}; return \@ids; } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/Store/memory.pm000444000765000024 5433412254227317 21476 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::memory; =head1 NAME Bio::DB::SeqFeature::Store::memory -- In-memory implementation of Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory', -dsn => '/var/databases/test'); # search... by id my @features = $db->fetch_many(@list_of_ids); # ...by name @features = $db->get_features_by_name('ZK909'); # ...by alias @features = $db->get_features_by_alias('sma-3'); # ...by type @features = $db->get_features_by_type('gene'); # ...by location @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000); # ...by attribute @features = $db->get_features_by_attribute({description => 'protein kinase'}) # ...by the GFF "Note" field @result_list = $db->search_notes('kinase'); # ...by arbitrary combinations of selectors @features = $db->features(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); # ...using an iterator my $iterator = $db->get_seq_stream(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); while (my $feature = $iterator->next_seq) { # do something with the feature } # ...limiting the search to a particular region my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features(-type=>['mRNA','match']); # getting & storing sequence information # Warning: this returns a string, and not a PrimarySeq object $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...'); my $sequence = $db->fetch_sequence('Chr1',5000=>6000); # what feature types are defined in the database? my @types = $db->types; # create a new feature in the database my $feature = $db->new_feature(-primary_tag => 'mRNA', -seq_id => 'chr3', -start => 10000, -end => 11000); =head1 DESCRIPTION Bio::DB::SeqFeature::Store::memory is the in-memory adaptor for Bio::DB::SeqFeature::Store. You will not create it directly, but instead use Bio::DB::SeqFeature::Store-Enew() to do so. See L for complete usage instructions. =head2 Using the memory adaptor Before using the memory adaptor, populate a readable-directory on the file system with annotation and/or sequence files. The annotation files must be in GFF3 format, and sholud end in the extension .gff or .gff3. They may be compressed with "compress", "gzip" or "bzip2" (in which case the appropriate compression extension must be present as well.) You may include sequence data inline in the GFF3 files, or put the sequence data in one or more separate FASTA-format files. These files must end with .fa or .fasta and may be compressed. Because of the way the adaptor works, you will get much better performance if you keep the sequence data in separate FASTA files. Initialize the database using the -dsn option. This should point to the directory creating the annotation and sequence files, or to a single GFF3 file. Examples: # load all GFF3 and FASTA files located in /var/databases/test directory $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory', -dsn => '/var/databases/test'); # load the data in a single compressed GFF3 file located at # /usr/annotations/worm.gf33.gz $db = Bio::DB::SeqFeature::Store->new( -adaptor => 'memory', -dsn => '/usr/annotations/worm.gff3.gz'); For compatibility with the Bio::DB::GFF memory adaptor, -gff is recognized as an alias for -dsn. See L for all the access methods supported by this adaptor. The various methods for storing and updating features and sequences into the database are supported, including GFF3 loading support, but since this is an in-memory adaptor all changes you make will be lost when the script exits. =cut use strict; use base 'Bio::DB::SeqFeature::Store'; use Bio::DB::SeqFeature::Store::GFF3Loader; use Bio::DB::GFF::Util::Rearrange 'rearrange'; use File::Temp 'tempdir'; use IO::File; use Bio::DB::Fasta; use File::Glob ':glob'; use constant BINSIZE => 10_000; ### # object initialization # sub init { my ($self, $args) = @_; $self->SUPER::init($args); $self->{_data} = {}; $self->{_children} = {}; $self->{_index} = {}; $self; } sub post_init { my $self = shift; my ($file_or_dir) = rearrange([['DIR','DSN','FILE','GFF']],@_); return unless $file_or_dir; my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new(-store => $self, -sf_class => $self->seqfeature_class) or $self->throw("Couldn't create GFF3Loader"); my @argv; if (-d $file_or_dir) { @argv = ( bsd_glob("$file_or_dir/*.size*"), bsd_glob("$file_or_dir/*.gff"), bsd_glob("$file_or_dir/*.gff3"), bsd_glob("$file_or_dir/*.gff.{gz,Z,bz2}"), bsd_glob("$file_or_dir/*.gff3.{gz,Z,bz2}") ); } else { @argv = $file_or_dir; } local $self->{file_or_dir} = $file_or_dir; $loader->load(@argv); warn $@ if $@; } sub commit { # reindex fasta files my $self = shift; my $db; if (my $fh = $self->{fasta_fh}) { $fh->close; $db = Bio::DB::Fasta->new($self->{fasta_file}); } elsif (exists $self->{file_or_dir} && -d $self->{file_or_dir}) { $db = Bio::DB::Fasta->new($self->{file_or_dir}); } $self->{fasta_db} = $db if $db; } sub can_store_parentage { 1 } # return a hash ref in which each key is primary id sub data { shift->{_data}; } sub _init_database { shift->init } sub _store { my $self = shift; my $indexed = shift; my @objs = @_; my $data = $self->data; my $count = 0; for my $obj (@objs) { # Add unique ID to feature if needed my $primary_id = $self->_autoid($obj); # Store feature (overwriting any existing feature with the same primary ID # as required by Bio::DB::SF::Store) $data->{$primary_id} = $obj; if ($indexed) { $self->{_index}{ids}{$primary_id} = undef; $self->_update_indexes($obj); } $count++; } return $count; } sub _autoid { # If a feature has no ID, assign it a unique ID my ($self, $obj) = @_; my $data = $self->data; my $primary_id = $obj->primary_id; if (not defined $primary_id) { # Create a unique ID $primary_id = 1 + scalar keys %{$data}; while (exists $data->{$primary_id}) { $primary_id++; } $obj->primary_id($primary_id); } return $primary_id; } sub _deleteid { my ($self, $id) = @_; if (exists $self->{_index}{ids}{$id}) { # $indexed was true $self->_update_indexes( $self->fetch($id), 1 ); delete $self->{_index}{ids}{$id}; } delete $self->data->{$id}; return 1; } sub _fetch { my ($self, $id) = @_; return $self->data->{$id}; } sub _add_SeqFeature { my ($self, $parent, @children) = @_; my $count = 0; my $parent_id = ref $parent ? $parent->primary_id : $parent; defined $parent_id or $self->throw("Parent $parent should have a primary ID"); for my $child (@children) { my $child_id = ref $child ? $child->primary_id : $child; defined $child_id or $self->throw("Child $child should have a primary ID"); $self->{_children}{$parent_id}{$child_id}++; $count++; } return $count; } sub _fetch_SeqFeatures { my ($self, $parent, @types) = @_; my $parent_id = $parent->primary_id; defined $parent_id or $self->throw("Parent $parent should have a primary ID"); my @children_ids = keys %{$self->{_children}{$parent_id}}; my @children = map {$self->fetch($_)} @children_ids; if (@types) { my $data; for my $c (@children) { push @{$$data{$c->primary_tag}{$c->source_tag||''}}, $c; } @children = (); for my $type (@types) { $type .= ':' if (not $type =~ m/:/); my ($primary_tag, undef, $source_tag) = ($type =~ m/^(.*?)(:(.*?))$/); $source_tag ||= ''; if ($source_tag eq '') { for my $source (keys %{$$data{$primary_tag}}) { if (exists $$data{$primary_tag}{$source_tag}) { push @children, @{$$data{$primary_tag}{$source_tag}}; } } } else { if (exists $$data{$primary_tag}{$source_tag}) { push @children, @{$$data{$primary_tag}{$source_tag}}; } } } } return @children; } sub _update_indexes { my ($self, $obj, $del) = @_; defined (my $id = $obj->primary_id) or return; $del ||= 0; $self->_update_name_index($obj,$id, $del); $self->_update_type_index($obj,$id, $del); $self->_update_location_index($obj, $id, $del); $self->_update_attribute_index($obj,$id, $del); } sub _update_name_index { my ($self, $obj, $id, $del) = @_; my ($names, $aliases) = $self->feature_names($obj); foreach (@$names) { if (not $del) { $self->{_index}{name}{lc $_}{$id} = 1; } else { delete $self->{_index}{name}{lc $_}{$id}; if (scalar keys %{ $self->{_index}{name}{lc $_} } == 0) { delete $self->{_index}{name}{lc $_}; } }; } foreach (@$aliases) { if (not $del) { $self->{_index}{name}{lc $_}{$id} ||= 2; } else { delete $self->{_index}{name}{lc $_}{$id}; if (scalar keys %{ $self->{_index}{name}{lc $_} } == 0) { delete $self->{_index}{name}{lc $_}; } } } } sub _update_type_index { my ($self, $obj, $id, $del) = @_; my $primary_tag = lc($obj->primary_tag) || return; my $source_tag = lc($obj->source_tag || ''); if (not $del) { $self->{_index}{type}{$primary_tag}{$source_tag}{$id} = undef; } else { delete $self->{_index}{type}{$primary_tag}{$source_tag}{$id}; if ( scalar keys %{$self->{_index}{type}{$primary_tag}{$source_tag}} == 0 ) { delete $self->{_index}{type}{$primary_tag}{$source_tag}; if (scalar keys %{$self->{_index}{type}{$primary_tag}} == 0 ) { delete $self->{_index}{type}{$primary_tag}; } } } } sub _update_location_index { my ($self, $obj, $id, $del) = @_; my $seq_id = $obj->seq_id || ''; my $start = $obj->start || 0; my $end = $obj->end || 0; my $strand = $obj->strand; my $bin_min = int $start/BINSIZE; my $bin_max = int $end/BINSIZE; for (my $bin = $bin_min; $bin <= $bin_max; $bin++ ) { if (not $del) { $self->{_index}{location}{lc $seq_id}{$bin}{$id} = undef; } else { delete $self->{_index}{location}{lc $seq_id}{$bin}{$id}; if (scalar keys %{$self->{_index}{location}{lc $seq_id}{$bin}{$id}} == 0) { delete $self->{_index}{location}{lc $seq_id}{$bin}{$id}; } if (scalar keys %{$self->{_index}{location}{lc $seq_id}{$bin}} == 0) { delete $self->{_index}{location}{lc $seq_id}{$bin}; } if (scalar keys %{$self->{_index}{location}{lc $seq_id}} == 0) { delete $self->{_index}{location}{lc $seq_id}; } } } } sub _update_attribute_index { my ($self, $obj, $id, $del) = @_; for my $tag ($obj->get_all_tags) { for my $value ($obj->get_tag_values($tag)) { if (not $del) { $self->{_index}{attribute}{lc $tag}{lc $value}{$id} = undef; } else { delete $self->{_index}{attribute}{lc $tag}{lc $value}{$id}; if ( scalar keys %{$self->{_index}{attribute}{lc $tag}{lc $value}} == 0) { delete $self->{_index}{attribute}{lc $tag}{lc $value}; } if ( scalar keys %{$self->{_index}{attribute}{lc $tag}} == 0) { delete $self->{_index}{attribute}{lc $tag}; } if ( scalar keys %{$self->{_index}{attribute}} == 0) { delete $self->{_index}{attribute}; } } } } } sub _features { my $self = shift; my ($seq_id,$start,$end,$strand, $name,$class,$allow_aliases, $types, $attributes, $range_type, $iterator ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND', 'NAME','CLASS','ALIASES', ['TYPES','TYPE','PRIMARY_TAG'], ['ATTRIBUTES','ATTRIBUTE'], 'RANGE_TYPE', 'ITERATOR', ],@_); my (@from,@where,@args,@group); $range_type ||= 'overlaps'; my @result; unless (defined $name or defined $seq_id or defined $types or defined $attributes) { @result = keys %{$self->{_index}{ids}}; } my %found = (); my $result = 1; if (defined($name)) { # hacky backward compatibility workaround undef $class if $class && $class eq 'Sequence'; $name = "$class:$name" if defined $class && length $class > 0; $result &&= $self->filter_by_name($name,$allow_aliases,\%found); } if (defined $seq_id) { $result &&= $self->filter_by_location($seq_id,$start,$end,$strand,$range_type,\%found); } if (defined $types) { $result &&= $self->filter_by_type($types,\%found); } if (defined $attributes) { $result &&= $self->filter_by_attribute($attributes,\%found); } push @result,keys %found if $result; return $iterator ? Bio::DB::SeqFeature::Store::memory::Iterator->new($self,\@result) : map {$self->fetch($_)} @result; } sub filter_by_type { my ($self, $types_req, $filter) = @_; my @types_req = ref $types_req eq 'ARRAY' ? @$types_req : $types_req; my $types = $self->{_index}{type}; my @types_found = $self->find_types(\@types_req); my @results; for my $type_found (@types_found) { my ($primary_tag, undef, $source_tag) = ($type_found =~ m/^(.*?)(:(.*?))$/); next unless exists $types->{$primary_tag}{$source_tag}; push @results, keys %{$types->{$primary_tag}{$source_tag}}; } $self->update_filter($filter,\@results); } sub find_types { my ($self, $types_req) = @_; my @types_found; my $types = $self->{_index}{type}; for my $type_req (@$types_req) { # Type is the primary tag and an optional source tag my ($primary_tag, $source_tag); if (ref $type_req && $type_req->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type_req->method; $source_tag = $type_req->source; } else { ($primary_tag, undef, $source_tag) = ($type_req =~ m/^(.*?)(:(.*))?$/); } ($primary_tag, $source_tag) = (lc $primary_tag, lc($source_tag || '')); next if not exists $$types{$primary_tag}; if ($source_tag eq '') { # Match all sources for this primary_tag push @types_found, map {"$primary_tag:$_"} (keys %{ $$types{$primary_tag} }); } else { # Match only the requested source push @types_found, "$primary_tag:$source_tag"; } } return @types_found; } sub attributes { my $self = shift; return keys %{$self->{_index}{attribute}}; } sub filter_by_attribute { my ($self, $attributes, $filter) = @_; my $index = $self->{_index}{attribute}; my $result; for my $att_name (keys %$attributes) { my @result; my @matching_values; my @search_terms = ref($attributes->{$att_name}) && ref($attributes->{$att_name}) eq 'ARRAY' ? @{$attributes->{$att_name}} : $attributes->{$att_name}; my @regexp_terms; my @terms; for my $v (@search_terms) { if (my $regexp = $self->glob_match($v)) { @regexp_terms = keys %{$index->{lc $att_name}} unless @regexp_terms; push @terms,grep {/^$v$/i} @regexp_terms; } else { push @terms,lc $v; } } for my $v (@terms) { push @result,keys %{$index->{lc $att_name}{$v}}; } $result ||= $self->update_filter($filter,\@result); } $result; } sub filter_by_location { my ($self, $seq_id, $start, $end, $strand, $range_type, $filter) = @_; $strand ||= 0; my $index = $self->{_index}{location}{lc $seq_id}; my @bins; if (!defined $start or !defined $end or $range_type eq 'contained_in') { @bins = sort {$a<=>$b} keys %{$index}; $start = $bins[0] * BINSIZE unless defined $start; $end = (($bins[-1] + 1) * BINSIZE) - 1 unless defined $end; } my %seenit; my $bin_min = int $start/BINSIZE; my $bin_max = int $end/BINSIZE; my @bins_in_range = $range_type eq 'contained_in' ? ($bins[0]..$bin_min,$bin_max..$bins[-1]) : ($bin_min..$bin_max); my @results; for my $bin (@bins_in_range) { next unless exists $index->{$bin}; my @found = keys %{$index->{$bin}}; for my $f (@found) { next if $seenit{$f}++; my $feature = $self->_fetch($f) or next; next if $strand && $feature->strand != $strand; if ($range_type eq 'overlaps') { next unless $feature->end >= $start && $feature->start <= $end; } elsif ($range_type eq 'contains') { next unless $feature->start >= $start && $feature->end <= $end; } elsif ($range_type eq 'contained_in') { next unless $feature->start <= $start && $feature->end >= $end; } push @results,$f; } } $self->update_filter($filter,\@results); } sub filter_by_name { my ($self, $name, $allow_aliases, $filter) = @_; my $index = $self->{_index}{name}; my @names_to_fetch; if (my $regexp = $self->glob_match($name)) { @names_to_fetch = grep {/^$regexp$/i} keys %{$index}; } else { @names_to_fetch = lc $name; } my @results; for my $n (@names_to_fetch) { if ($allow_aliases) { push @results,keys %{$index->{$n}}; } else { push @results,grep {$index->{$n}{$_} == 1} keys %{$index->{$n}}; } } $self->update_filter($filter,\@results); } sub glob_match { my ($self, $term) = @_; return unless $term =~ /(?:^|[^\\])[*?]/; $term =~ s/(^|[^\\])([+\[\]^{}\$|\(\).])/$1\\$2/g; $term =~ s/(^|[^\\])\*/$1.*/g; $term =~ s/(^|[^\\])\?/$1./g; return $term; } sub update_filter { my ($self, $filter, $results) = @_; return unless @$results; if (%$filter) { my @filtered = grep {$filter->{$_}} @$results; %$filter = map {$_=>1} @filtered; } else { %$filter = map {$_=>1} @$results; } } sub _search_attributes { my ($self, $search_string, $attribute_array, $limit) = @_; $search_string =~ tr/*?//d; my @words = map {quotemeta($_)} $search_string =~ /(\w+)/g; my $search = join '|',@words; my (%results,%notes); my $index = $self->{_index}{attribute}; for my $tag (@$attribute_array) { my $attributes = $index->{lc $tag}; for my $value (keys %{$attributes}) { next unless $value =~ /$search/i; my @ids = keys %{$attributes->{$value}}; for my $w (@words) { my @hits = $value =~ /($w)/ig or next; $results{$_} += @hits foreach @ids; } $notes{$_} .= "$value " foreach @ids; } } my @results; for my $id (keys %results) { my $hits = $results{$id}; my $note = $notes{$id}; $note =~ s/\s+$//; my $relevance = 10 * $hits; my $feature = $self->fetch($id); my $name = $feature->display_name or next; my $type = $feature->type; push @results,[$name,$note,$relevance,$type,$id]; } return @results; } =head2 types Title : types Usage : @type_list = $db->types Function: Get all the types in the database Returns : array of Bio::DB::GFF::Typename objects (arrayref in scalar context) Args : none Status : public =cut sub types { my $self = shift; eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new'); my @types; for my $primary_tag ( keys %{$$self{_index}{type}} ) { for my $source_tag ( keys %{$$self{_index}{type}{$primary_tag}} ) { push @types, Bio::DB::GFF::Typename->new($primary_tag,$source_tag); } } return @types; } # this is ugly sub _insert_sequence { my ($self, $seqid, $seq, $offset) = @_; my $dna_fh = $self->private_fasta_file or return; if ($offset == 0) { # start of the sequence print $dna_fh ">$seqid\n"; } print $dna_fh $seq,"\n"; } sub _fetch_sequence { my ($self, $seqid, $start, $end) = @_; my $db = $self->{fasta_db} or return; $db->seq($seqid,$start,$end); } sub private_fasta_file { my $self = shift; return $self->{fasta_fh} if exists $self->{fasta_fh}; my $dir = tempdir (CLEANUP => 1); $self->{fasta_file} = "$dir/sequence.$$.fasta"; return $self->{fasta_fh} = IO::File->new($self->{fasta_file},">"); } # summary support sub coverage_array { my $self = shift; my ($seq_name,$start,$end,$types,$bins) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'], ['TYPES','TYPE','PRIMARY_TAG'],'BINS'],@_); my @features = $self->_features(-seq_id=> $seq_name, -start => $start, -end => $end, -types => $types); my $binsize = ($end-$start+1)/$bins; my $report_tag; my @coverage_array = (0) x $bins; for my $f (@features) { $report_tag ||= $f->primary_tag; my $fs = $f->start; my $fe = $f->end; my $start_bin = int(($fs-$start)/$binsize); my $end_bin = int(($fe-$start)/$binsize); $start_bin = 0 if $start_bin < 0; $end_bin = $bins-1 if $end_bin >= $bins; $coverage_array[$_]++ for ($start_bin..$end_bin); } return wantarray ? (\@coverage_array,$report_tag) : \@coverage_array; } sub _seq_ids { my $self = shift; if (my $fa = $self->{fasta_db}) { if (my @s = eval {$fa->ids}) { return @s; } } my $l = $self->{_index}{location} or return; return keys %$l; } package Bio::DB::SeqFeature::Store::memory::Iterator; sub new { my ($class, $store, $ids) = @_; return bless {store => $store, ids => $ids},ref($class) || $class; } sub next_seq { my $self = shift; my $store = $self->{store} or return; my $id = shift @{$self->{ids}}; defined $id or return; return $store->fetch($id); } 1; __END__ =head1 BUGS This is an early version, so there are certainly some bugs. Please use the BioPerl bug tracking system to report bugs. =head1 SEE ALSO L, L, L, L, L, L, L =head1 AUTHOR Lincoln Stein Elstein@cshl.orgE. Copyright (c) 2006 Cold Spring Harbor Laboratory. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut BioPerl-1.6.923/Bio/DB/SeqFeature/Store/DBI000755000765000024 012254227336 20041 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/SeqFeature/Store/DBI/Iterator.pm000444000765000024 115212254227336 22324 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::DBI::Iterator; =head1 NAME Bio::DB::SeqFeature::Store::DBI::Iterator - utility methods for creating and iterating over SeqFeature records =cut sub new { my $class = shift; my ($sth,$store) = @_; return bless {sth => $sth, store => $store },ref($class) || $class; } sub next_seq { my $self = shift; my $sth = $self->{sth} or return; my $store = $self->{store} or return; my $obj = $store->_sth2obj($sth); if (!$obj) { $self->{sth}->finish; undef $self->{sth}; undef $self->{store}; return; } return $obj; } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/Store/DBI/mysql.pm000444000765000024 16675612254227334 21764 0ustar00cjfieldsstaff000000000000package Bio::DB::SeqFeature::Store::DBI::mysql; =head1 NAME Bio::DB::SeqFeature::Store::DBI::mysql -- Mysql implementation of Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new(-adaptor => 'DBI::mysql', -dsn => 'dbi:mysql:test'); # get a feature from somewhere my $feature = Bio::SeqFeature::Generic->new(...); # store it $db->store($feature) or die "Couldn't store!"; # primary ID of the feature is changed to indicate its primary ID # in the database... my $id = $feature->primary_id; # get the feature back out my $f = $db->fetch($id); # change the feature and update it $f->start(100); $f->update($f) or die "Couldn't update!"; # searching... # ...by id my @features = $db->fetch_many(@list_of_ids); # ...by name @features = $db->get_features_by_name('ZK909'); # ...by alias @features = $db->get_features_by_alias('sma-3'); # ...by type @features = $db->get_features_by_name('gene'); # ...by location @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000); # ...by attribute @features = $db->get_features_by_attribute({description => 'protein kinase'}) # ...by the GFF "Note" field @result_list = $db->search_notes('kinase'); # ...by arbitrary combinations of selectors @features = $db->features(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); # ...using an iterator my $iterator = $db->get_seq_stream(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); while (my $feature = $iterator->next_seq) { # do something with the feature } # ...limiting the search to a particular region my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features(-type=>['mRNA','match']); # getting & storing sequence information # Warning: this returns a string, and not a PrimarySeq object $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...'); my $sequence = $db->fetch_sequence('Chr1',5000=>6000); # what feature types are defined in the database? my @types = $db->types; # create a new feature in the database my $feature = $db->new_feature(-primary_tag => 'mRNA', -seq_id => 'chr3', -start => 10000, -end => 11000); =head1 DESCRIPTION Bio::DB::SeqFeature::Store::mysql is the Mysql adaptor for Bio::DB::SeqFeature::Store. You will not create it directly, but instead use Bio::DB::SeqFeature::Store-Enew() to do so. See L for complete usage instructions. =head2 Using the Mysql adaptor Before you can use the adaptor, you must use the mysqladmin tool to create a database and establish a user account with write permission. In order to use "fast" loading, the user account must have "file" privileges. To establish a connection to the database, call Bio::DB::SeqFeature::Store-Enew(-adaptor=E'DBI::mysql',@more_args). The additional arguments are as follows: Argument name Description ------------- ----------- -dsn The database name. You can abbreviate "dbi:mysql:foo" as "foo" if you wish. -user Username for authentication. -pass Password for authentication. -namespace A prefix to attach to each table. This allows you to have several virtual databases in the same physical database. -temp Boolean flag. If true, a temporary database will be created and destroyed as soon as the Store object goes out of scope. (synonym -temporary) -autoindex Boolean flag. If true, features in the database will be reindexed every time they change. This is the default. -tmpdir Directory in which to place temporary files during "fast" loading. Defaults to File::Spec->tmpdir(). (synonyms -dump_dir, -dumpdir, -tmp) -dbi_options A hashref to pass to DBI->connect's 4th argument, the "attributes." (synonyms -options, -dbi_attr) -write Pass true to open database for writing or updating. If successful, a new instance of Bio::DB::SeqFeature::Store::DBI::mysql will be returned. In addition to the standard methods supported by all well-behaved Bio::DB::SeqFeature::Store databases, several following adaptor-specific methods are provided. These are described in the next sections. =cut use strict; use base 'Bio::DB::SeqFeature::Store'; use Bio::DB::SeqFeature::Store::DBI::Iterator; use DBI; use Memoize; use Cwd 'abs_path'; use Bio::DB::GFF::Util::Rearrange 'rearrange'; use Bio::SeqFeature::Lite; use File::Spec; use Carp 'carp','cluck','croak'; use constant DEBUG=>0; # from the MySQL documentation... # WARNING: if your sequence uses coordinates greater than 2 GB, you are out of luck! use constant MAX_INT => 2_147_483_647; use constant MIN_INT => -2_147_483_648; use constant MAX_BIN => 1_000_000_000; # size of largest feature = 1 Gb use constant MIN_BIN => 1000; # smallest bin we'll make - on a 100 Mb chromosome, there'll be 100,000 of these use constant SUMMARY_BIN_SIZE => 1000; # tier 0 == 1000 bp bins # tier 1 == 10,000 bp bins # etc. memoize('_typeid'); memoize('_locationid'); memoize('_attributeid'); memoize('dump_path'); ### # object initialization # sub init { my $self = shift; my ($dsn, $is_temporary, $autoindex, $namespace, $dump_dir, $user, $pass, $dbi_options, $writeable, $create, ) = rearrange(['DSN', ['TEMP','TEMPORARY'], 'AUTOINDEX', 'NAMESPACE', ['DUMP_DIR','DUMPDIR','TMP','TMPDIR'], 'USER', ['PASS','PASSWD','PASSWORD'], ['OPTIONS','DBI_OPTIONS','DBI_ATTR'], ['WRITE','WRITEABLE'], 'CREATE', ],@_); $dbi_options ||= {}; $writeable = 1 if $is_temporary or $dump_dir; $dsn or $self->throw("Usage: ".__PACKAGE__."->init(-dsn => \$dbh || \$dsn)"); my $dbh; if (ref $dsn) { $dbh = $dsn; } else { $dsn = "dbi:mysql:$dsn" unless $dsn =~ /^dbi:/; $dbh = DBI->connect($dsn,$user,$pass,$dbi_options) or $self->throw($DBI::errstr); $dbh->{mysql_auto_reconnect} = 1; } $self->{dbh} = $dbh; $self->{is_temp} = $is_temporary; $self->{namespace} = $namespace; $self->{writeable} = $writeable; $self->default_settings; $self->autoindex($autoindex) if defined $autoindex; $self->dumpdir($dump_dir) if $dump_dir; if ($self->is_temp) { $self->init_tmp_database(); } elsif ($create) { $self->init_database('erase'); } } sub writeable { shift->{writeable} } sub can_store_parentage { 1 } sub table_definitions { my $self = shift; return { feature => < < < < < < < < < <maybe_create_meta(); $self->SUPER::default_settings; $self->autoindex(1); $self->dumpdir(File::Spec->tmpdir); } ### # retrieve database handle # sub dbh { my $self = shift; my $d = $self->{dbh}; $self->{dbh} = shift if @_; $d; } sub clone { my $self = shift; $self->{dbh}{InactiveDestroy} = 1; $self->{dbh} = $self->{dbh}->clone unless $self->is_temp; } ### # get/set directory for bulk load tables # sub dumpdir { my $self = shift; my $d = $self->{dumpdir}; $self->{dumpdir} = abs_path(shift) if @_; $d; } ### # table namespace (multiple dbs in one mysql db) # sub namespace { my $self = shift; my $d = $self->{namespace}; $self->{namespace} = shift if @_; $d; } ### # Required for Pg not mysql # sub remove_namespace { return; } ### # find a path that corresponds to a dump table # sub dump_path { my $self = shift; my $table = $self->_qualify(shift); return "$self->{dumpdir}/$table.$$"; } ### # make a filehandle (writeable) that corresponds to a dump table # sub dump_filehandle { my $self = shift; my $table = shift; eval "require IO::File" unless IO::File->can('new'); my $path = $self->dump_path($table); my $fh = $self->{filehandles}{$path} ||= IO::File->new(">$path"); $fh; } ### # find the next ID for a feature (used only during bulk loading) # sub next_id { my $self = shift; $self->{max_id} ||= $self->max_id; return ++$self->{max_id}; } ### # find the maximum ID for a feature (used only during bulk loading) # sub max_id { my $self = shift; my $features = $self->_feature_table; my $sth = $self->_prepare("SELECT max(id) from $features"); $sth->execute or $self->throw($sth->errstr); my ($id) = $sth->fetchrow_array; $id; } ### # wipe database clean and reinstall schema # sub _init_database { my $self = shift; my $erase = shift; my $dbh = $self->dbh; my $tables = $self->table_definitions; for my $t (keys %$tables) { next if $t eq 'meta'; # don't get rid of meta data! my $table = $self->_qualify($t); $dbh->do("DROP table IF EXISTS $table") if $erase; my $query = "CREATE TABLE IF NOT EXISTS $table $tables->{$t}"; $self->_create_table($dbh,$query); } $self->subfeatures_are_indexed(1) if $erase; 1; } sub init_tmp_database { my $self = shift; my $dbh = $self->dbh; my $tables = $self->table_definitions; for my $t (keys %$tables) { next if $t eq 'meta'; # done earlier my $table = $self->_qualify($t); my $query = "CREATE TEMPORARY TABLE $table $tables->{$t}"; $self->_create_table($dbh,$query); } 1; } sub _create_table { my $self = shift; my ($dbh,$query) = @_; for my $q (split ';',$query) { chomp($q); next unless $q =~ /\S/; $dbh->do("$q;\n") or $self->throw($dbh->errstr); } } sub maybe_create_meta { my $self = shift; return unless $self->writeable; my $meta = $self->_meta_table; my $tables = $self->table_definitions; my $temporary = $self->is_temp ? 'TEMPORARY' : ''; $self->dbh->do("CREATE $temporary TABLE IF NOT EXISTS $meta $tables->{meta}"); } ### # use temporary tables # sub is_temp { shift->{is_temp}; } sub attributes { my $self = shift; my $dbh = $self->dbh; my $attributelist_table = $self->_attributelist_table; my $a = $dbh->selectcol_arrayref("SELECT tag FROM $attributelist_table") or $self->throw($dbh->errstr); return @$a; } sub _store { my $self = shift; # special case for bulk updates return $self->_dump_store(@_) if $self->{bulk_update_in_progress}; my $indexed = shift; my $count = 0; my $autoindex = $self->autoindex; my $dbh = $self->dbh; local $dbh->{RaiseError} = 1; $self->begin_work; eval { for my $obj (@_) { $self->replace($obj,$indexed); $self->_update_indexes($obj) if $indexed && $autoindex; $count++; } }; if ($@) { warn "Transaction aborted because $@"; $self->rollback; } else { $self->commit; } # remember whether we are have ever stored a non-indexed feature unless ($indexed or $self->{indexed_flag}++) { $self->subfeatures_are_indexed(0); } $count; } # we memoize this in order to avoid making zillions of calls sub autoindex { my $self = shift; # special case for bulk update -- need to build the indexes # at the same time we build the main feature table return 1 if $self->{bulk_update_in_progress}; my $d = $self->setting('autoindex'); $self->setting(autoindex=>shift) if @_; $d; } sub _start_bulk_update { my $self = shift; my $dbh = $self->dbh; $self->begin_work; $self->{bulk_update_in_progress}++; } sub _finish_bulk_update { my $self = shift; my $dbh = $self->dbh; my $dir = $self->{dumpdir} || '.'; for my $table ($self->_feature_table,$self->index_tables) { my $fh = $self->dump_filehandle($table); my $path = $self->dump_path($table); $fh->close; #print STDERR "$path\n"; $dbh->do("LOAD DATA LOCAL INFILE '$path' REPLACE INTO TABLE $table FIELDS OPTIONALLY ENCLOSED BY '\\''") or $self->throw($dbh->errstr); unlink $path; } delete $self->{bulk_update_in_progress}; delete $self->{ filehandles}; $self->commit; } ### # Add a subparts to a feature. Both feature and all subparts must already be in database. # sub _add_SeqFeature { my $self = shift; # special purpose method for case when we are doing a bulk update return $self->_dump_add_SeqFeature(@_) if $self->{bulk_update_in_progress}; my $parent = shift; my @children = @_; my $dbh = $self->dbh; local $dbh->{RaiseError} = 1; my $parent2child = $self->_parent2child_table(); my $count = 0; my $sth = $self->_prepare(<primary_id : $parent) or $self->throw("$parent should have a primary_id"); $self->begin_work or $self->throw($dbh->errstr); eval { for my $child (@children) { my $child_id = ref $child ? $child->primary_id : $child; defined $child_id or die "no primary ID known for $child"; $sth->execute($parent_id,$child_id); $count++; } }; if ($@) { warn "Transaction aborted because $@"; $self->rollback; } else { $self->commit; } $sth->finish; $count; } sub _fetch_SeqFeatures { my $self = shift; my $parent = shift; my @types = @_; my $parent_id = $parent->primary_id or $self->throw("$parent should have a primary_id"); my $features = $self->_feature_table; my $parent2child = $self->_parent2child_table(); my @from = ("$features as f","$parent2child as c"); my @where = ('f.id=c.child','c.id=?'); my @args = $parent_id; if (@types) { my ($from,$where,undef,@a) = $self->_types_sql(\@types,'f'); push @from,$from if $from; push @where,$where if $where; push @args,@a; } my $from = join ', ',@from; my $where = join ' AND ',@where; my $query = <_print_query($query,@args) if DEBUG || $self->debug; my $sth = $self->_prepare($query) or $self->throw($self->dbh->errstr); $sth->execute(@args) or $self->throw($sth->errstr); return $self->_sth2objs($sth); } ### # get primary sequence between start and end # sub _fetch_sequence { my $self = shift; my ($seqid,$start,$end) = @_; # backward compatibility to the old days when I liked reverse complementing # dna by specifying $start > $end my $reversed; if (defined $start && defined $end && $start > $end) { $reversed++; ($start,$end) = ($end,$start); } $start-- if defined $start; $end-- if defined $end; my $id = $self->_locationid($seqid); my $offset1 = $self->_offset_boundary($id,$start || 'left'); my $offset2 = $self->_offset_boundary($id,$end || 'right'); my $sequence_table = $self->_sequence_table; my $sql = <= ? AND s.offset <= ? ORDER BY s.offset END my $sth = $self->_prepare($sql); my $seq = ''; $self->_print_query($sql,$id,$offset1,$offset2) if DEBUG || $self->debug; $sth->execute($id,$offset1,$offset2) or $self->throw($sth->errstr); while (my($frag,$offset) = $sth->fetchrow_array) { substr($frag,0,$start-$offset) = '' if defined $start && $start > $offset; $seq .= $frag; } substr($seq,$end-$start+1) = '' if defined $end && $end-$start+1 < length($seq); if ($reversed) { $seq = reverse $seq; $seq =~ tr/gatcGATC/ctagCTAG/; } $sth->finish; $seq; } sub _offset_boundary { my $self = shift; my ($seqid,$position) = @_; my $sequence_table = $self->_sequence_table; my $locationlist_table = $self->_locationlist_table; my $sql; $sql = $position eq 'left' ? "SELECT min(offset) FROM $sequence_table as s WHERE s.id=?" :$position eq 'right' ? "SELECT max(offset) FROM $sequence_table as s WHERE s.id=?" :"SELECT max(offset) FROM $sequence_table as s WHERE s.id=? AND offset<=?"; my $sth = $self->_prepare($sql); my @args = $position =~ /^-?\d+$/ ? ($seqid,$position) : ($seqid); $self->_print_query($sql,@args) if DEBUG || $self->debug; $sth->execute(@args) or $self->throw($sth->errstr); my $boundary = $sth->fetchall_arrayref->[0][0]; $sth->finish; return $boundary; } ### # add namespace to tablename # sub _qualify { my $self = shift; my $table_name = shift; my $namespace = $self->namespace; return $table_name if (!defined $namespace || # is namespace already present in table name? index($table_name, $namespace) == 0); return "${namespace}_${table_name}"; } ### # Fetch a Bio::SeqFeatureI from database using its primary_id # sub _fetch { my $self = shift; @_ or $self->throw("usage: fetch(\$primary_id)"); my $primary_id = shift; my $features = $self->_feature_table; my $sth = $self->_prepare(<execute($primary_id) or $self->throw($sth->errstr); my $obj = $self->_sth2obj($sth); $sth->finish; $obj; } ### # Efficiently fetch a series of IDs from the database # Can pass an array or an array ref # sub _fetch_many { my $self = shift; @_ or $self->throw('usage: fetch_many($id1,$id2,$id3...)'); my $ids = join ',',map {ref($_) ? @$_ : $_} @_ or return; my $features = $self->_feature_table; my $sth = $self->_prepare(<execute() or $self->throw($sth->errstr); return $self->_sth2objs($sth); } sub _features { my $self = shift; my ($seq_id,$start,$end,$strand, $name,$class,$allow_aliases, $types, $attributes, $range_type, $fromtable, $iterator, $sources, ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND', 'NAME','CLASS','ALIASES', ['TYPES','TYPE','PRIMARY_TAG'], ['ATTRIBUTES','ATTRIBUTE'], 'RANGE_TYPE', 'FROM_TABLE', 'ITERATOR', ['SOURCE','SOURCES'], ],@_); my (@from,@where,@args,@group); $range_type ||= 'overlaps'; my $features = $self->_feature_table; @from = "$features as f"; if (defined $name) { # hacky backward compatibility workaround undef $class if $class && $class eq 'Sequence'; $name = "$class:$name" if defined $class && length $class > 0; # last argument is the join field my ($from,$where,$group,@a) = $self->_name_sql($name,$allow_aliases,'f.id'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined $seq_id) { # last argument is the name of the features table my ($from,$where,$group,@a) = $self->_location_sql($seq_id,$start,$end,$range_type,$strand,'f'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined($sources)) { my @sources = ref($sources) eq 'ARRAY' ? @{$sources} : ($sources); if (defined($types)) { my @types = ref($types) eq 'ARRAY' ? @{$types} : ($types); my @final_types; foreach my $type (@types) { # *** not sure what to do if user supplies both -source and -type # where the type includes a source! if ($type =~ /:/) { push(@final_types, $type); } else { foreach my $source (@sources) { push(@final_types, $type.':'.$source); } } } $types = \@final_types; } else { $types = [map { ':'.$_ } @sources]; } } if (defined($types)) { # last argument is the name of the features table my ($from,$where,$group,@a) = $self->_types_sql($types,'f'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined $attributes) { # last argument is the join field my ($from,$where,$group,@a) = $self->_attributes_sql($attributes,'f.id'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined $fromtable) { # last argument is the join field my ($from,$where,$group,@a) = $self->_from_table_sql($fromtable,'f.id'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } # if no other criteria are specified, then # only fetch indexed (i.e. top level objects) @where = 'indexed=1' unless @where; my $from = join ', ',@from; my $where = join ' AND ',map {"($_)"} @where; my $group = join ', ',@group; $group = "GROUP BY $group" if @group; my $query = <_print_query($query,@args) if DEBUG || $self->debug; my $sth = $self->_prepare($query) or $self->throw($self->dbh->errstr); $sth->execute(@args) or $self->throw($sth->errstr); return $iterator ? Bio::DB::SeqFeature::Store::DBI::Iterator->new($sth,$self) : $self->_sth2objs($sth); } sub _aggregate_bins { my $self = shift; my $sth = shift; my (%types,$binsize,$binstart); while (my ($type,$seqname,$bin,$count,$bins,$start,$end) = $sth->fetchrow_array) { $binsize ||= ($end-$start+1)/$bins; $binstart ||= int($start/$binsize); $types{$type}{seqname} ||= $seqname; $types{$type}{min} ||= $start; $types{$type}{max} ||= $end; $types{$type}{bins} ||= [(0) x $bins]; $types{$type}{bins}[$bin-$binstart] = $count; $types{$type}{count} += $count; } my @results; for my $type (keys %types) { my $min = $types{$type}{min}; my $max = $types{$type}{max}; my $seqid= $types{$type}{seqname}; my $f = Bio::SeqFeature::Lite->new(-seq_id => $seqid, -start => $min, -end => $max, -type => "$type:bins", -score => $types{$type}{count}, -attributes => {coverage => join ',',@{$types{$type}{bins}}}); push @results,$f; } return @results; } sub _name_sql { my $self = shift; my ($name,$allow_aliases,$join) = @_; my $name_table = $self->_name_table; my $from = "$name_table as n"; my ($match,$string) = $self->_match_sql($name); my $where = "n.id=$join AND n.name $match"; $where .= " AND n.display_name>0" unless $allow_aliases; return ($from,$where,'',$string); } sub _search_attributes { my $self = shift; my ($search_string,$attribute_names,$limit) = @_; my @words = map {quotemeta($_)} split /\s+/,$search_string; my $name_table = $self->_name_table; my $attribute_table = $self->_attribute_table; my $attributelist_table = $self->_attributelist_table; my $type_table = $self->_type_table; my $typelist_table = $self->_typelist_table; my @tags = @$attribute_names; my $tag_sql = join ' OR ',("al.tag=?") x @tags; my $perl_regexp = join '|',@words; my $sql_regexp = join ' OR ',("a.attribute_value REGEXP ?") x @words; my $sql = <_print_query($sql,@tags,@words) if DEBUG || $self->debug; my $sth = $self->_prepare($sql); $sth->execute(@tags,@words) or $self->throw($sth->errstr); my @results; while (my($name,$value,$type,$id) = $sth->fetchrow_array) { my (@hits) = $value =~ /$perl_regexp/ig; my @words_in_row = split /\b/,$value; my $score = int(@hits * 10); push @results,[$name,$value,$score,$type,$id]; } $sth->finish; @results = sort {$b->[2]<=>$a->[2]} @results; return @results; } sub _match_sql { my $self = shift; my $name = shift; my ($match,$string); if ($name =~ /(?:^|[^\\])[*?]/) { $name =~ s/(^|[^\\])([%_])/$1\\$2/g; $name =~ s/(^|[^\\])\*/$1%/g; $name =~ s/(^|[^\\])\?/$1_/g; $match = "LIKE ?"; $string = $name; } else { $match = "= ?"; $string = $name; } return ($match,$string); } sub _from_table_sql { my $self = shift; my ($from_table,$join) = @_; my $from = "$from_table as ft"; my $where = "ft.id=$join"; return ($from,$where,''); } sub _attributes_sql { my $self = shift; my ($attributes,$join) = @_; my ($wf,@bind_args) = $self->_make_attribute_where('a','al',$attributes); my ($group_by,@group_args)= $self->_make_attribute_group('a',$attributes); my $attribute_table = $self->_attribute_table; my $attributelist_table = $self->_attributelist_table; my $from = "$attribute_table as a use index(attribute_id), $attributelist_table as al"; my $where = <_typelist_table; my $from = "$typelist AS tl"; my (@matches,@args); for my $type (@types) { if (ref $type && $type->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type->method; $source_tag = $type->source; } else { ($primary_tag,$source_tag) = split ':',$type,2; } if (defined $source_tag && length $source_tag) { if (defined $primary_tag && length($primary_tag)) { push @matches,"tl.tag=?"; push @args,"$primary_tag:$source_tag"; } else { push @matches,"tl.tag LIKE ?"; push @args,"%:$source_tag"; } } else { push @matches,"tl.tag LIKE ?"; push @args,"$primary_tag:%"; } } my $matches = join ' OR ',@matches; my $where = <_locationid_nocreate($seq_id) || 0; # zero is an invalid primary ID, so will return empty $start = MIN_INT unless defined $start; $end = MAX_INT unless defined $end; my ($bin_where,@bin_args) = $self->bin_where($start,$end,$location); my ($range,@range_args); if ($range_type eq 'overlaps') { $range = "$location.end>=? AND $location.start<=? AND ($bin_where)"; @range_args = ($start,$end,@bin_args); } elsif ($range_type eq 'contains') { $range = "$location.start>=? AND $location.end<=? AND ($bin_where)"; @range_args = ($start,$end,@bin_args); } elsif ($range_type eq 'contained_in') { $range = "$location.start<=? AND $location.end>=?"; @range_args = ($start,$end); } else { $self->throw("range_type must be one of 'overlaps', 'contains' or 'contained_in'"); } if (defined $strand) { $range .= " AND strand=?"; push @range_args,$strand; } my $where = <dbh; my $count = 0; my $now; # try to bring in highres time() function eval "require Time::HiRes"; my $last_time = $self->time(); # tell _delete_index() not to bother removing the index rows corresponding # to each individual feature local $self->{reindexing} = 1; $self->begin_work; eval { my $update = $from_update_table; for my $table ($self->index_tables) { my $query = $from_update_table ? "DELETE $table FROM $table,$update WHERE $table.id=$update.id" : "DELETE FROM $table"; $dbh->do($query); $self->_disable_keys($dbh,$table); } my $iterator = $self->get_seq_stream(-from_table=>$from_update_table ? $update : undef); while (my $f = $iterator->next_seq) { if (++$count %1000 == 0) { $now = $self->time(); my $elapsed = sprintf(" in %5.2fs",$now - $last_time); $last_time = $now; print STDERR "$count features indexed$elapsed...",' 'x60; print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n"; } $self->_update_indexes($f); } }; for my $table ($self->index_tables) { $self->_enable_keys($dbh,$table); } if (@_) { warn "Couldn't complete transaction: $@"; $self->rollback; return; } else { $self->commit; return 1; } } sub optimize { my $self = shift; $self->dbh->do("ANALYZE TABLE $_") foreach $self->index_tables; } sub all_tables { my $self = shift; my @index_tables = $self->index_tables; my $features = $self->_feature_table; return ($features,@index_tables); } sub index_tables { my $self = shift; return map {$self->_qualify($_)} qw(name attribute parent2child) } sub _firstid { my $self = shift; my $features = $self->_feature_table; my $query = <_prepare($query); $sth->execute(); my ($first) = $sth->fetchrow_array; $sth->finish; $first; } sub _nextid { my $self = shift; my $lastkey = shift; my $features = $self->_feature_table; my $query = <? END my $sth=$self->_prepare($query); $sth->execute($lastkey); my ($next) = $sth->fetchrow_array; $sth->finish; $next; } sub _existsid { my $self = shift; my $key = shift; my $features = $self->_feature_table; my $query = <_prepare($query); $sth->execute($key); my ($count) = $sth->fetchrow_array; $sth->finish; $count > 0; } sub _deleteid { my $self = shift; my $key = shift; my $dbh = $self->dbh; my $parent2child = $self->_parent2child_table; my $query = "SELECT child FROM $parent2child WHERE id=?"; my $sth=$self->_prepare($query); $sth->execute($key); my $success = 0; while (my ($cid) = $sth->fetchrow_array) { # Backcheck looking for multiple parents, delete only if one is present. I'm # sure there is a nice way to left join the parent2child table onto itself # to get this in one query above, just haven't worked it out yet... my $sth2 = $self->_prepare("SELECT count(id) FROM $parent2child WHERE child=?"); $sth2->execute($cid); my ($count) = $sth2->fetchrow_array; if ($count == 1) { $self->_deleteid($cid) || warn "An error occurred while removing subfeature id=$cid. Perhaps it was previously deleted?\n"; } } for my $table ($self->all_tables) { $success += $dbh->do("DELETE FROM $table WHERE id=$key") || 0; } return $success; } sub _clearall { my $self = shift; my $dbh = $self->dbh; for my $table ($self->all_tables) { $dbh->do("DELETE FROM $table"); } } sub _featurecount { my $self = shift; my $dbh = $self->dbh; my $features = $self->_feature_table; my $query = <_prepare($query); $sth->execute(); my ($count) = $sth->fetchrow_array; $sth->finish; $count; } sub _seq_ids { my $self = shift; my $dbh = $self->dbh; my $location = $self->_locationlist_table; my $sth = $self->_prepare("SELECT DISTINCT seqname FROM $location"); $sth->execute() or $self->throw($sth->errstr); my @result; while (my ($id) = $sth->fetchrow_array) { push @result,$id; } return @result; } sub setting { my $self = shift; my ($variable_name,$value) = @_; my $meta = $self->_meta_table; if (defined $value && $self->writeable) { my $query = <_prepare($query); $sth->execute($variable_name,$value) or $self->throw($sth->errstr); $sth->finish; $self->{settings_cache}{$variable_name} = $value; } else { return $self->{settings_cache}{$variable_name} if exists $self->{settings_cache}{$variable_name}; my $query = <_prepare($query); $sth->execute($variable_name) or $self->throw($sth->errstr); my ($value) = $sth->fetchrow_array; $sth->finish; return $self->{settings_cache}{$variable_name} = $value; } } ### # Replace Bio::SeqFeatureI into database. # sub replace { my $self = shift; my $object = shift; my $index_flag = shift || undef; # ?? shouldn't need to do this # $self->_load_class($object); my $id = $object->primary_id; my $features = $self->_feature_table; my $sth = $self->_prepare(<_get_location_and_bin($object) : (undef)x6; my $primary_tag = $object->primary_tag; my $source_tag = $object->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); my $frozen = $self->no_blobs() ? 0 : $self->freeze($object); $sth->execute($id,$frozen,$index_flag||0,@location,$typeid) or $self->throw($sth->errstr); my $dbh = $self->dbh; $object->primary_id($dbh->{mysql_insertid}) unless defined $id; $self->flag_for_indexing($dbh->{mysql_insertid}) if $self->{bulk_update_in_progress}; } # doesn't work with this schema, since we have to update name and attribute # tables which need object ids, which we can only know by replacing feats in # the feature table one by one sub bulk_replace { my $self = shift; my $index_flag = shift || undef; my @objects = @_; my $features = $self->_feature_table; my @insert_values; foreach my $object (@objects) { my $id = $object->primary_id; my @location = $index_flag ? $self->_get_location_and_bin($object) : (undef)x6; my $primary_tag = $object->primary_tag; my $source_tag = $object->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); push(@insert_values, ($id,0,$index_flag||0,@location,$typeid)); } my @value_blocks; for (1..@objects) { push(@value_blocks, '(?,?,?,?,?,?,?,?,?,?)'); } my $value_blocks = join(',', @value_blocks); my $sql = qq{REPLACE INTO $features (id,object,indexed,seqid,start,end,strand,tier,bin,typeid) VALUES $value_blocks}; my $sth = $self->_prepare($sql); $sth->execute(@insert_values) or $self->throw($sth->errstr); } ### # Insert one Bio::SeqFeatureI into database. primary_id must be undef # sub insert { my $self = shift; my $object = shift; my $index_flag = shift || 0; $self->_load_class($object); defined $object->primary_id and $self->throw("$object already has a primary id"); my $features = $self->_feature_table; my $sth = $self->_prepare(<execute(undef,$self->freeze($object),$index_flag) or $self->throw($sth->errstr); my $dbh = $self->dbh; $object->primary_id($dbh->{mysql_insertid}); $self->flag_for_indexing($dbh->{mysql_insertid}) if $self->{bulk_update_in_progress}; } =head2 types Title : types Usage : @type_list = $db->types Function: Get all the types in the database Returns : array of Bio::DB::GFF::Typename objects Args : none Status : public =cut sub types { my $self = shift; eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new'); my $typelist = $self->_typelist_table; my $sql = <_print_query($sql) if DEBUG || $self->debug; my $sth = $self->_prepare($sql); $sth->execute() or $self->throw($sth->errstr); my @results; while (my($tag) = $sth->fetchrow_array) { push @results,Bio::DB::GFF::Typename->new($tag); } $sth->finish; return @results; } =head2 toplevel_types Title : toplevel_types Usage : @type_list = $db->toplevel_types Function: Get the toplevel types in the database Returns : array of Bio::DB::GFF::Typename objects Args : none Status : public This is similar to types() but only returns the types of INDEXED (toplevel) features. =cut sub toplevel_types { my $self = shift; eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new'); my $typelist = $self->_typelist_table; my $features = $self->_feature_table; my $sql = <_print_query($sql) if DEBUG || $self->debug; my $sth = $self->_prepare($sql); $sth->execute() or $self->throw($sth->errstr); my @results; while (my($tag) = $sth->fetchrow_array) { push @results,Bio::DB::GFF::Typename->new($tag); } $sth->finish; return @results; } ### # Insert a bit of DNA or protein into the database # sub _insert_sequence { my $self = shift; my ($seqid,$seq,$offset) = @_; my $id = $self->_locationid($seqid); my $sequence = $self->_sequence_table; my $sth = $self->_prepare(<execute($id,$offset,$seq) or $self->throw($sth->errstr); } ### # This subroutine flags the given primary ID for later reindexing # sub flag_for_indexing { my $self = shift; my $id = shift; my $needs_updating = $self->_update_table; my $sth = $self->_prepare("REPLACE INTO $needs_updating VALUES (?)"); $sth->execute($id) or $self->throw($self->dbh->errstr); } ### # Update indexes for given object # sub _update_indexes { my $self = shift; my $obj = shift; defined (my $id = $obj->primary_id) or return; if ($self->{bulk_update_in_progress}) { $self->_dump_update_name_index($obj,$id); $self->_dump_update_attribute_index($obj,$id); } else { $self->_update_name_index($obj,$id); $self->_update_attribute_index($obj,$id); } } sub _update_name_index { my $self = shift; my ($obj,$id) = @_; my $name = $self->_name_table; my $primary_id = $obj->primary_id; $self->_delete_index($name,$id); my ($names,$aliases) = $self->feature_names($obj); my $sth = $self->_prepare("INSERT INTO $name (id,name,display_name) VALUES (?,?,?)"); $sth->execute($id,$_,1) or $self->throw($sth->errstr) foreach @$names; $sth->execute($id,$_,0) or $self->throw($sth->errstr) foreach @$aliases; $sth->finish; } sub _update_attribute_index { my $self = shift; my ($obj,$id) = @_; my $attribute = $self->_attribute_table; $self->_delete_index($attribute,$id); my $sth = $self->_prepare("INSERT INTO $attribute (id,attribute_id,attribute_value) VALUES (?,?,?)"); for my $tag ($obj->get_all_tags) { my $tagid = $self->_attributeid($tag); for my $value ($obj->get_tag_values($tag)) { $sth->execute($id,$tagid,$value) or $self->throw($sth->errstr); } } $sth->finish; } sub _genericid { my $self = shift; my ($table,$namefield,$name,$add_if_missing) = @_; my $qualified_table = $self->_qualify($table); my $sth = $self->_prepare(<execute($name) or die $sth->errstr; my ($id) = $sth->fetchrow_array; $sth->finish; return $id if defined $id; return unless $add_if_missing; $sth = $self->_prepare(<execute($name) or die $sth->errstr; my $dbh = $self->dbh; return $dbh->{mysql_insertid}; } sub _typeid { shift->_genericid('typelist','tag',shift,1); } sub _locationid { shift->_genericid('locationlist','seqname',shift,1); } sub _locationid_nocreate { shift->_genericid('locationlist','seqname',shift,0); } sub _attributeid { shift->_genericid('attributelist','tag',shift,1); } sub _get_location_and_bin { my $self = shift; my $feature = shift; my $seqid = $self->_locationid($feature->seq_id||''); my $start = $feature->start; my $end = $feature->end; my $strand = $feature->strand || 0; my ($tier,$bin) = $self->get_bin($start,$end); return ($seqid,$start,$end,$strand,$tier,$bin); } sub get_bin { my $self = shift; my ($start,$end) = @_; my $binsize = MIN_BIN; my ($bin_start,$bin_end,$tier); $tier = 0; while (1) { $bin_start = int $start/$binsize; $bin_end = int $end/$binsize; last if $bin_start == $bin_end; $binsize *= 10; $tier++; } return ($tier,$bin_start); } sub bin_where { my $self = shift; my ($start,$end,$f) = @_; my (@bins,@args); my $tier = 0; my $binsize = MIN_BIN; while ($binsize <= MAX_BIN) { my $bin_start = int($start/$binsize); my $bin_end = int($end/$binsize); push @bins,"($f.tier=? AND $f.bin between ? AND ?)"; push @args,($tier,$bin_start,$bin_end); $binsize *= 10; $tier++; } my $query = join ("\n\t OR ",@bins); return wantarray ? ($query,@args) : substitute($query,@args); } sub _delete_index { my $self = shift; my ($table_name,$id) = @_; return if $self->{reindexing}; my $sth = $self->_prepare("DELETE FROM $table_name WHERE id=?") or $self->throw($self->dbh->errstr); $sth->execute($id); } # given a statement handler that is expected to return rows of (id,object) # unthaw each object and return a list of 'em sub _sth2objs { my $self = shift; my $sth = shift; my @result; while (my ($id,$o,$typeid,$seqid,$start,$end,$strand) = $sth->fetchrow_array) { my $obj; if ($o eq '0') { # rebuild a new feat object from the data stored in the db $obj = $self->_rebuild_obj($id,$typeid,$seqid,$start,$end,$strand); } else { $obj = $self->thaw($o,$id); } push @result,$obj; } $sth->finish; return @result; } # given a statement handler that is expected to return rows of (id,object) # unthaw each object and return a list of 'em sub _sth2obj { my $self = shift; my $sth = shift; my ($id,$o,$typeid,$seqid,$start,$end,$strand) = $sth->fetchrow_array; return unless defined $o; my $obj; if ($o eq '0') { # I don't understand why an object ever needs to be rebuilt! # rebuild a new feat object from the data stored in the db $obj = $self->_rebuild_obj($id,$typeid,$seqid,$start,$end,$strand); } else { $obj = $self->thaw($o,$id); } $obj; } sub _rebuild_obj { my ($self, $id, $typeid, $db_seqid, $start, $end, $strand) = @_; my ($type, $source, $seqid); # convert typeid to type and source if (exists $self->{_type_cache}->{$typeid}) { ($type, $source) = @{$self->{_type_cache}->{$typeid}}; } else { my $sql = qq{ SELECT `tag` FROM typelist WHERE `id` = ? }; my $sth = $self->_prepare($sql) or $self->throw($self->dbh->errstr); $sth->execute($typeid); my $result; $sth->bind_columns(\$result); while ($sth->fetch()) { # there should be only one row returned, but we ensure to get all rows } ($type, $source) = split(':', $result); $self->{_type_cache}->{$typeid} = [$type, $source]; } # convert the db seqid to the sequence name if (exists $self->{_seqid_cache}->{$db_seqid}) { $seqid = $self->{_seqid_cache}->{$db_seqid}; } else { my $sql = qq{ SELECT `seqname` FROM locationlist WHERE `id` = ? }; my $sth = $self->_prepare($sql) or $self->throw($self->dbh->errstr); $sth->execute($db_seqid); $sth->bind_columns(\$seqid); while ($sth->fetch()) { # there should be only one row returned, but we ensure to get all rows } $self->{_seqid_cache}->{$db_seqid} = $seqid; } # get the names from name table? # get the attributes and store those in obj my $sql = qq{ SELECT attribute_id,attribute_value FROM attribute WHERE `id` = ? }; my $sth = $self->_prepare($sql) or $self->throw($self->dbh->errstr); $sth->execute($id); my ($attribute_id, $attribute_value); $sth->bind_columns(\($attribute_id, $attribute_value)); my %attribs; while ($sth->fetch()) { # convert the attribute_id to its real name my $attribute; if (exists $self->{_attribute_cache}->{$attribute_id}) { $attribute = $self->{_attribute_cache}->{$attribute_id}; } else { my $sql = qq{ SELECT `tag` FROM attributelist WHERE `id` = ? }; my $sth2 = $self->_prepare($sql) or $self->throw($self->dbh->errstr); $sth2->execute($attribute_id); $sth2->bind_columns(\$attribute); while ($sth2->fetch()) { # there should be only one row returned, but we ensure to get all rows } $self->{_attribute_cache}->{$attribute_id} = $attribute; } if ($source && $attribute eq 'source' && $attribute_value eq $source) { next; } $attribs{$attribute} = $attribute_value; } # if we weren't called with all the params, pull those out of the database too if ( not ( grep { defined($_) } ( $typeid, $db_seqid, $start, $end, $strand ))) { my $sql = qq{ SELECT start,end,tag,strand,seqname FROM feature,feature_location,typelist,locationlist WHERE feature.id=feature_location.id AND feature.typeid=typelist.id AND seqid=locationlist.id AND feature.id = ? }; my $sth = $self->_prepare($sql) or $self->throw($self->dbh->errstr); $sth->execute($id); my ($feature_start, $feature_end, $feature_type, $feature_strand,$feature_seqname); $sth->bind_columns(\($feature_start, $feature_end, $feature_type, $feature_strand, $feature_seqname)); while ($sth->fetch()) { # there should be only one row returned, but we call like this to # ensure we get all rows } $start ||= $feature_start; $end ||= $feature_end; $strand ||= $feature_strand; $seqid ||= $feature_seqname; my( $feature_typename , $feature_typesource ) = split /:/ , $feature_type; $type ||= $feature_typename; $source ||= $feature_typesource; } my $obj = Bio::SeqFeature::Lite->new(-primary_id => $id, $type ? (-type => $type) : (), $source ? (-source => $source) : (), $seqid ? (-seq_id => $seqid) : (), defined $start ? (-start => $start) : (), defined $end ? (-end => $end) : (), defined $strand ? (-strand => $strand) : (), keys %attribs ? (-attributes => \%attribs) : ()); return $obj; } sub _prepare { my $self = shift; my $query = shift; my $dbh = $self->dbh; my $sth = $dbh->prepare_cached($query, {}, 3) or $self->throw($dbh->errstr); $sth; } #################################################################################################### # SQL Fragment generators #################################################################################################### sub _attribute_table { shift->_qualify('attribute') } sub _attributelist_table { shift->_qualify('attributelist') } sub _feature_table { shift->_qualify('feature') } sub _interval_stats_table { shift->_qualify('interval_stats') } sub _location_table { shift->_qualify('location') } sub _locationlist_table { shift->_qualify('locationlist') } sub _meta_table { shift->_qualify('meta') } sub _name_table { shift->_qualify('name') } sub _parent2child_table { shift->_qualify('parent2child') } sub _sequence_table { shift->_qualify('sequence') } sub _type_table { shift->_qualify('feature') } sub _typelist_table { shift->_qualify('typelist') } sub _update_table { shift->_qualify('update_table') } sub _make_attribute_where { my $self = shift; my ($attributetable,$attributenametable,$attributes) = @_; my @args; my @sql; my $dbh = $self->dbh; foreach (keys %$attributes) { my @match_values; my @values = ref($attributes->{$_}) && ref($attributes->{$_}) eq 'ARRAY' ? @{$attributes->{$_}} : $attributes->{$_}; foreach (@values) { # convert * into % for wildcard matches s/\*/%/g; } my $match = join ' OR ',map { /%/ ? "$attributetable.attribute_value LIKE ?" : "$attributetable.attribute_value=?" } @values; push @sql,"($attributenametable.tag=? AND ($match))"; push @args,($_,@values); } return (join(' OR ',@sql),@args); } sub _make_attribute_group { my $self = shift; my ($table_name,$attributes) = @_; my $key_count = keys %$attributes or return; return "f.id,f.object,f.typeid,f.seqid,f.start,f.end,f.strand HAVING count(f.id)>?",$key_count-1; } sub _print_query { my $self = shift; my ($query,@args) = @_; while ($query =~ /\?/) { my $arg = $self->dbh->quote(shift @args); $query =~ s/\?/$arg/; } warn $query,"\n"; } ### # special-purpose store for bulk loading - write to a file rather than to the db # sub _dump_store { my $self = shift; my $indexed = shift; my $count = 0; my $store_fh = $self->dump_filehandle('feature'); my $dbh = $self->dbh; my $autoindex = $self->autoindex; for my $obj (@_) { my $id = $self->next_id; my ($seqid,$start,$end,$strand,$tier,$bin) = $indexed ? $self->_get_location_and_bin($obj) : (undef)x6; my $primary_tag = $obj->primary_tag; my $source_tag = $obj->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); print $store_fh join("\t",$id,$typeid,$seqid,$start,$end,$strand,$tier,$bin,$indexed,$dbh->quote($self->freeze($obj))),"\n"; $obj->primary_id($id); $self->_update_indexes($obj) if $indexed && $autoindex; $count++; } # remember whether we are have ever stored a non-indexed feature unless ($indexed or $self->{indexed_flag}++) { $self->subfeatures_are_indexed(0); } $count; } sub _dump_add_SeqFeature { my $self = shift; my $parent = shift; my @children = @_; my $dbh = $self->dbh; my $fh = $self->dump_filehandle('parent2child'); my $parent_id = (ref $parent ? $parent->primary_id : $parent) or $self->throw("$parent should have a primary_id"); my $count = 0; for my $child_id (@children) { print $fh join("\t",$parent_id,$child_id),"\n"; $count++; } $count; } sub _dump_update_name_index { my $self = shift; my ($obj,$id) = @_; my $fh = $self->dump_filehandle('name'); my $dbh = $self->dbh; my ($names,$aliases) = $self->feature_names($obj); print $fh join("\t",$id,$dbh->quote($_),1),"\n" foreach @$names; print $fh join("\t",$id,$dbh->quote($_),0),"\n" foreach @$aliases; } sub _dump_update_attribute_index { my $self = shift; my ($obj,$id) = @_; my $fh = $self->dump_filehandle('attribute'); my $dbh = $self->dbh; for my $tag ($obj->all_tags) { my $tagid = $self->_attributeid($tag); for my $value ($obj->each_tag_value($tag)) { print $fh join("\t",$id,$tagid,$dbh->quote($value)),"\n"; } } } sub coverage_array { my $self = shift; my ($seq_name,$start,$end,$types,$bins) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'], ['TYPES','TYPE','PRIMARY_TAG'],'BINS'],@_); $bins ||= 1000; $start ||= 1; unless ($end) { my $segment = $self->segment($seq_name) or $self->throw("unknown seq_id $seq_name"); $end = $segment->end; } my $binsize = ($end-$start+1)/$bins; my $seqid = $self->_locationid_nocreate($seq_name) || 0; return [] unless $seqid; # where each bin starts my @his_bin_array = map {$start + $binsize * $_} (0..$bins-1); my @sum_bin_array = map {int(($_-1)/SUMMARY_BIN_SIZE)} @his_bin_array; my $interval_stats = $self->_interval_stats_table; my ($sth,@a); if ($types) { # pick up the type ids my ($from,$where,$group); ($from,$where,$group,@a) = $self->_types_sql($types,'b'); $where =~ s/.+AND//s; $sth = $self->_prepare(<_prepare(<execute(@a); while (my ($t,$tag) = $sth->fetchrow_array) { $report_tag ||= $tag; push @t,$t; } my %bins; my $sql = <= ? LIMIT 1 END ; $sth = $self->_prepare($sql); eval { for my $typeid (@t) { for (my $i=0;$i<@sum_bin_array;$i++) { my @args = ($typeid,$seqid,$sum_bin_array[$i]); $self->_print_query($sql,@args) if $self->debug; $sth->execute(@args) or $self->throw($sth->errstr); my ($bin,$cum_count) = $sth->fetchrow_array; push @{$bins{$typeid}},[$bin,$cum_count]; } } }; return unless %bins; my @merged_bins; my $firstbin = int(($start-1)/$binsize); for my $type (keys %bins) { my $arry = $bins{$type}; my $last_count = $arry->[0][1]; my $last_bin = -1; my $i = 0; my $delta; for my $b (@$arry) { my ($bin,$count) = @$b; $delta = $count - $last_count if $bin > $last_bin; $merged_bins[$i++] += $delta; $last_count = $count; $last_bin = $bin; } } return wantarray ? (\@merged_bins,$report_tag) : \@merged_bins; } sub build_summary_statistics { my $self = shift; my $interval_stats = $self->_interval_stats_table; my $dbh = $self->dbh; $self->begin_work; my $sbs = SUMMARY_BIN_SIZE; my $result = eval { $self->_add_interval_stats_table; $self->_disable_keys($dbh,$interval_stats); $dbh->do("DELETE FROM $interval_stats"); my $insert = $dbh->prepare(<throw($dbh->errstr); INSERT INTO $interval_stats (typeid,seqid,bin,cum_count) VALUES (?,?,?,?) END my $sql = $self->_fetch_indexed_features_sql; my $select = $dbh->prepare($sql) or $self->throw($dbh->errstr); my $current_bin = -1; my ($current_type,$current_seqid,$count); my $cum_count = 0; my (%residuals,$last_bin); my $le = -t \*STDERR ? "\r" : "\n"; print STDERR "\n"; $select->execute; while (my($typeid,$seqid,$start,$end) = $select->fetchrow_array) { print STDERR $count," features processed$le" if ++$count % 1000 == 0; my $bin = int($start/$sbs); $current_type ||= $typeid; $current_seqid ||= $seqid; # because the input is sorted by start, no more features will contribute to the # current bin so we can dispose of it if ($bin != $current_bin) { if ($seqid != $current_seqid or $typeid != $current_type) { # load all bins left over $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid); %residuals = () ; $cum_count = 0; } else { # load all up to current one $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid,$current_bin); } } $last_bin = $current_bin; ($current_seqid,$current_type,$current_bin) = ($seqid,$typeid,$bin); # summarize across entire spanned region my $last_bin = int(($end-1)/$sbs); for (my $b=$bin;$b<=$last_bin;$b++) { $residuals{$b}++; } } # handle tail case # load all bins left over $self->_load_bins($insert,\%residuals,\$cum_count,$current_type,$current_seqid); $self->_enable_keys($dbh,$interval_stats); 1; }; if ($result) { $self->commit } else { warn "Can't build summary statistics: $@"; $self->rollback }; print STDERR "\n"; } sub _load_bins { my $self = shift; my ($insert,$residuals,$cum_count,$type,$seqid,$stop_after) = @_; for my $b (sort {$a<=>$b} keys %$residuals) { last if defined $stop_after and $b > $stop_after; $$cum_count += $residuals->{$b}; my @args = ($type,$seqid,$b,$$cum_count); $insert->execute(@args); delete $residuals->{$b}; # no longer needed } } sub _add_interval_stats_table { my $self = shift; my $tables = $self->table_definitions; my $interval_stats = $self->_interval_stats_table; $self->dbh->do("CREATE TABLE IF NOT EXISTS $interval_stats $tables->{interval_stats}"); } sub _fetch_indexed_features_sql { my $self = shift; my $features = $self->_feature_table; return <do("ALTER TABLE $table DISABLE KEYS"); } sub _enable_keys { my $self = shift; my ($dbh,$table) = @_; $dbh->do("ALTER TABLE $table ENABLE KEYS"); } sub time { return Time::HiRes::time() if Time::HiRes->can('time'); return time(); } sub DESTROY { my $self = shift; if ($self->{bulk_update_in_progress}) { # be sure to remove temp files for my $table ($self->_feature_table,$self->index_tables) { my $path = $self->dump_path($table); unlink $path; } } } sub begin_work { my $self = shift; return if $self->{_in_transaction}++; my $dbh = $self->dbh; return unless $dbh->{AutoCommit}; $dbh->begin_work; } sub commit { my $self = shift; return unless $self->{_in_transaction}; delete $self->{_in_transaction}; $self->dbh->commit; } sub rollback { my $self = shift; return unless $self->{_in_transaction}; delete $self->{_in_transaction}; $self->dbh->rollback; } 1; BioPerl-1.6.923/Bio/DB/SeqFeature/Store/DBI/Pg.pm000444000765000024 7130312254227327 21126 0ustar00cjfieldsstaff000000000000 package Bio::DB::SeqFeature::Store::DBI::Pg; use DBD::Pg qw(:pg_types); use MIME::Base64; # $Id: Pg.pm 14656 2008-04-14 15:05:37Z lstein $ =head1 NAME Bio::DB::SeqFeature::Store::DBI::Pg -- PostgreSQL implementation of Bio::DB::SeqFeature::Store =head1 SYNOPSIS use Bio::DB::SeqFeature::Store; # Open the sequence database my $db = Bio::DB::SeqFeature::Store->new(-adaptor => 'DBI::Pg', -dsn => 'dbi:Pg:test'); # get a feature from somewhere my $feature = Bio::SeqFeature::Generic->new(...); # store it $db->store($feature) or die "Couldn't store!"; # primary ID of the feature is changed to indicate its primary ID # in the database... my $id = $feature->primary_id; # get the feature back out my $f = $db->fetch($id); # change the feature and update it $f->start(100); $db->update($f) or die "Couldn't update!"; # searching... # ...by id my @features = $db->fetch_many(@list_of_ids); # ...by name @features = $db->get_features_by_name('ZK909'); # ...by alias @features = $db->get_features_by_alias('sma-3'); # ...by type @features = $db->get_features_by_name('gene'); # ...by location @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000); # ...by attribute @features = $db->get_features_by_attribute({description => 'protein kinase'}) # ...by the GFF "Note" field @result_list = $db->search_notes('kinase'); # ...by arbitrary combinations of selectors @features = $db->features(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); # ...using an iterator my $iterator = $db->get_seq_stream(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); while (my $feature = $iterator->next_seq) { # do something with the feature } # ...limiting the search to a particular region my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features(-type=>['mRNA','match']); # getting & storing sequence information # Warning: this returns a string, and not a PrimarySeq object $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...'); my $sequence = $db->fetch_sequence('Chr1',5000=>6000); # what feature types are defined in the database? my @types = $db->types; # create a new feature in the database my $feature = $db->new_feature(-primary_tag => 'mRNA', -seq_id => 'chr3', -start => 10000, -end => 11000); =head1 DESCRIPTION Bio::DB::SeqFeature::Store::Pg is the Pg adaptor for Bio::DB::SeqFeature::Store. You will not create it directly, but instead use Bio::DB::SeqFeature::Store-Enew() to do so. See L for complete usage instructions. =head2 Using the Pg adaptor Before you can use the adaptor, you must use the Pgadmin tool to create a database and establish a user account with write permission. In order to use "fast" loading, the user account must have "file" privileges. To establish a connection to the database, call Bio::DB::SeqFeature::Store-Enew(-adaptor=E'DBI::Pg',@more_args). The additional arguments are as follows: Argument name Description ------------- ----------- -dsn The database name. You can abbreviate "dbi:Pg:foo" as "foo" if you wish. -user Username for authentication. -pass Password for authentication. -namespace Creates a SCHEMA for the tables. This allows you to have several virtual databases in the same physical database. -temp Boolean flag. If true, a temporary database will be created and destroyed as soon as the Store object goes out of scope. (synonym -temporary) -autoindex Boolean flag. If true, features in the database will be reindexed every time they change. This is the default. -tmpdir Directory in which to place temporary files during "fast" loading. Defaults to File::Spec->tmpdir(). (synonyms -dump_dir, -dumpdir, -tmp) -dbi_options A hashref to pass to DBI->connect's 4th argument, the "attributes." (synonyms -options, -dbi_attr) -write Pass true to open database for writing or updating. If successful, a new instance of Bio::DB::SeqFeature::Store::DBI::Pg will be returned. In addition to the standard methods supported by all well-behaved Bio::DB::SeqFeature::Store databases, several following adaptor-specific methods are provided. These are described in the next sections. =cut use strict; use base 'Bio::DB::SeqFeature::Store::DBI::mysql'; use Bio::DB::SeqFeature::Store::DBI::Iterator; use DBI; use Memoize; use Cwd 'abs_path'; use Bio::DB::GFF::Util::Rearrange 'rearrange'; use File::Spec; use constant DEBUG=>0; use constant MAX_INT => 2_147_483_647; use constant MIN_INT => -2_147_483_648; use constant MAX_BIN => 1_000_000_000; # size of largest feature = 1 Gb use constant MIN_BIN => 1000; # smallest bin we'll make - on a 100 Mb chromosome, there'll be 100,000 of these ### # object initialization # # NOTE: most of this code can be refactored and inherited from DBI or DBI::mysql adapter # sub init { my $self = shift; my ($dsn, $is_temporary, $autoindex, $namespace, $dump_dir, $user, $pass, $dbi_options, $writeable, $create, $schema, ) = rearrange(['DSN', ['TEMP','TEMPORARY'], 'AUTOINDEX', 'NAMESPACE', ['DUMP_DIR','DUMPDIR','TMP','TMPDIR'], 'USER', ['PASS','PASSWD','PASSWORD'], ['OPTIONS','DBI_OPTIONS','DBI_ATTR'], ['WRITE','WRITEABLE'], 'CREATE', 'SCHEMA' ],@_); $dbi_options ||= {pg_server_prepare => 0}; $writeable = 1 if $is_temporary or $dump_dir; $dsn or $self->throw("Usage: ".__PACKAGE__."->init(-dsn => \$dbh || \$dsn)"); my $dbh; if (ref $dsn) { $dbh = $dsn; } else { $dsn = "dbi:Pg:$dsn" unless $dsn =~ /^dbi:/; $dbh = DBI->connect($dsn,$user,$pass,$dbi_options) or $self->throw($DBI::errstr); } $dbh->do('set client_min_messages=warning') if $dbh; $self->{'original_arguments'} = { 'dsn' => $dsn, 'user' => $user, 'pass' => $pass, 'dbh_options' => $dbi_options, }; $self->{dbh} = $dbh; $self->{dbh}->{InactiveDestroy} = 1; $self->{is_temp} = $is_temporary; $self->{writeable} = $writeable; $self->{namespace} = $namespace || $schema || 'public'; $self->schema($self->{namespace}); $self->default_settings; $self->autoindex($autoindex) if defined $autoindex; $self->dumpdir($dump_dir) if $dump_dir; if ($self->is_temp) { # warn "creating a temp database isn't supported"; #$self->init_tmp_database(); $self->init_database('erase'); } elsif ($create) { $self->init_database('erase'); } } sub table_definitions { my $self = shift; return { feature => < < < < < < < < < <{'schema'} = $schema if defined($schema); if ($schema) { $self->_check_for_namespace(); $self->dbh->do("SET search_path TO " . $self->{'schema'} ); } else { $self->dbh->do("SET search_path TO public"); } return $self->{'schema'}; } ### # wipe database clean and reinstall schema # sub _init_database { my $self = shift; my $erase = shift; my $dbh = $self->dbh; my $namespace = $self->namespace; my $tables = $self->table_definitions; my $temporary = $self->is_temp ? 'TEMPORARY' : ''; foreach (keys %$tables) { next if $_ eq 'meta'; # don't get rid of meta data! my $table = $self->_qualify($_); $dbh->do("DROP TABLE IF EXISTS $table") if $erase; my @table_exists = $dbh->selectrow_array("SELECT * FROM pg_tables WHERE tablename = '$table' AND schemaname = '$self->namespace'"); if (!scalar(@table_exists)) { my $query = "CREATE $temporary TABLE $table $tables->{$_}"; $dbh->do($query) or $self->throw($dbh->errstr); } } $self->subfeatures_are_indexed(1) if $erase; 1; } sub maybe_create_meta { my $self = shift; return unless $self->writeable; my $namespace = $self->namespace; my $table = $self->_qualify('meta'); my $tables = $self->table_definitions; my $temporary = $self->is_temp ? 'TEMPORARY' : ''; my @table_exists = $self->dbh->selectrow_array("SELECT * FROM pg_tables WHERE tablename = 'meta' AND schemaname = '$namespace'"); $self->dbh->do("CREATE $temporary TABLE $table $tables->{meta}") unless @table_exists; } ### # check if the namespace/schema exists, if not create it # sub _check_for_namespace { my $self = shift; my $namespace = $self->namespace; return if $namespace eq 'public'; my $dbh = $self->dbh; my @schema_exists = $dbh->selectrow_array("SELECT * FROM pg_namespace WHERE nspname = '$namespace'"); if (!scalar(@schema_exists)) { my $query = "CREATE SCHEMA $namespace"; $dbh->do($query) or $self->throw($dbh->errstr); # if temp parameter is set and schema created for this process then enable removal in remove_namespace() if ($self->is_temp) { $self->{delete_schema} = 1; } } } ### # Overiding inherited mysql _qualify (We do not need to qualify for PostgreSQL as we have set the search_path above) # sub _qualify { my $self = shift; my $table_name = shift; return $table_name; } ### # when is_temp is set and the schema did not exist beforehand then we are able to remove it # sub remove_namespace { my $self = shift; if ($self->{delete_schema}) { my $namespace = $self->namespace; $self->dbh->do("DROP SCHEMA $namespace") or $self->throw($self->dbh->errstr); } } ####Overiding the inherited mysql function _prepare sub _prepare { my $self = shift; my $query = shift; my $dbh = $self->dbh; my $schema = $self->{namespace}; if ($schema) { $self->_check_for_namespace(); $dbh->do("SET search_path TO " . $self->{'schema'} ); } else { $dbh->do("SET search_path TO public"); } my $sth = $dbh->prepare_cached($query, {}, 3) or $self->throw($dbh->errstr); $sth; } sub _finish_bulk_update { my $self = shift; my $dbh = $self->dbh; my $dir = $self->{dumpdir} || '.'; for my $table ('feature',$self->index_tables) { my $fh = $self->dump_filehandle($table); my $path = $self->dump_path($table); $fh->close; my $qualified_table = $self->_qualify($table); system "cp $path $path.bak"; # Get stuff from file into STDIN so we don't have to be superuser open FH, $path; print STDERR "Loading file $path\n"; $dbh->do("COPY $qualified_table FROM STDIN CSV QUOTE '''' DELIMITER '\t'") or $self->throw($dbh->errstr); while (my $line = ) { $dbh->pg_putline($line); } $dbh->pg_endcopy() or $self->throw($dbh->errstr); close FH; #unlink $path; } delete $self->{bulk_update_in_progress}; delete $self->{filehandles}; } ### # Add a subparts to a feature. Both feature and all subparts must already be in database. # sub _add_SeqFeature { my $self = shift; # special purpose method for case when we are doing a bulk update return $self->_dump_add_SeqFeature(@_) if $self->{bulk_update_in_progress}; my $parent = shift; my @children = @_; my $dbh = $self->dbh; local $dbh->{RaiseError} = 1; my $child_table = $self->_parent2child_table(); my $count = 0; my $querydel = "DELETE FROM $child_table WHERE id = ? AND child = ?"; my $query = "INSERT INTO $child_table (id,child) VALUES (?,?)"; my $sthdel = $self->_prepare($querydel); my $sth = $self->_prepare($query); my $parent_id = (ref $parent ? $parent->primary_id : $parent) or $self->throw("$parent should have a primary_id"); $self->begin_work or $self->throw($dbh->errstr); eval { for my $child (@children) { my $child_id = ref $child ? $child->primary_id : $child; defined $child_id or die "no primary ID known for $child"; $sthdel->execute($parent_id, $child_id); $sth->execute($parent_id,$child_id); $count++; } }; if ($@) { warn "Transaction aborted because $@"; $self->rollback; } else { $self->commit; } $sth->finish; $count; } # because this is a reserved word in postgresql ### # get primary sequence between start and end # sub _fetch_sequence { my $self = shift; my ($seqid,$start,$end) = @_; # backward compatibility to the old days when I liked reverse complementing # dna by specifying $start > $end my $reversed; if (defined $start && defined $end && $start > $end) { $reversed++; ($start,$end) = ($end,$start); } $start-- if defined $start; $end-- if defined $end; my $offset1 = $self->_offset_boundary($seqid,$start || 'left'); my $offset2 = $self->_offset_boundary($seqid,$end || 'right'); my $sequence_table = $self->_sequence_table; my $locationlist_table = $self->_locationlist_table; my $sth = $self->_prepare(<= ? AND "offset" <= ? ORDER BY "offset" END my $seq = ''; $sth->execute($seqid,$offset1,$offset2) or $self->throw($sth->errstr); while (my($frag,$offset) = $sth->fetchrow_array) { substr($frag,0,$start-$offset) = '' if defined $start && $start > $offset; $seq .= $frag; } substr($seq,$end-$start+1) = '' if defined $end && $end-$start+1 < length($seq); if ($reversed) { $seq = reverse $seq; $seq =~ tr/gatcGATC/ctagCTAG/; } $sth->finish; $seq; } sub _offset_boundary { my $self = shift; my ($seqid,$position) = @_; my $sequence_table = $self->_sequence_table; my $locationlist_table = $self->_locationlist_table; my $sql; $sql = $position eq 'left' ? "SELECT min(\"offset\") FROM $sequence_table as s,$locationlist_table as ll WHERE s.id=ll.id AND ll.seqname=?" :$position eq 'right' ? "SELECT max(\"offset\") FROM $sequence_table as s,$locationlist_table as ll WHERE s.id=ll.id AND ll.seqname=?" :"SELECT max(\"offset\") FROM $sequence_table as s,$locationlist_table as ll WHERE s.id=ll.id AND ll.seqname=? AND \"offset\"<=?"; my $sth = $self->_prepare($sql); my @args = $position =~ /^-?\d+$/ ? ($seqid,$position) : ($seqid); $sth->execute(@args) or $self->throw($sth->errstr); my $boundary = $sth->fetchall_arrayref->[0][0]; $sth->finish; return $boundary; } sub _name_sql { my $self = shift; my ($name,$allow_aliases,$join) = @_; my $name_table = $self->_name_table; my $from = "$name_table as n"; my ($match,$string) = $self->_match_sql($name); my $where = "n.id=$join AND lower(n.name) $match"; $where .= " AND n.display_name>0" unless $allow_aliases; return ($from,$where,'',$string); } sub _search_attributes { my $self = shift; my ($search_string,$attribute_names,$limit) = @_; my @words = map {quotemeta($_)} split /\s+/,$search_string; my $name_table = $self->_name_table; my $attribute_table = $self->_attribute_table; my $attributelist_table = $self->_attributelist_table; my $type_table = $self->_type_table; my $typelist_table = $self->_typelist_table; my @tags = @$attribute_names; my $tag_sql = join ' OR ',("al.tag=?") x @tags; my $perl_regexp = join '|',@words; my @wild_card_words = map { "%$_%" } @words; my $sql_regexp = join ' OR ',("a.attribute_value SIMILAR TO ?") x @words; my $sql = <_print_query($sql,@tags,@wild_card_words) if DEBUG || $self->debug; my $sth = $self->_prepare($sql); $sth->execute(@tags,@wild_card_words) or $self->throw($sth->errstr); my @results; while (my($name,$value,$type,$id) = $sth->fetchrow_array) { my (@hits) = $value =~ /$perl_regexp/ig; my @words_in_row = split /\b/,$value; my $score = int(@hits*100/@words/@words_in_row); push @results,[$name,$value,$score,$type,$id]; } $sth->finish; @results = sort {$b->[2]<=>$a->[2]} @results; return @results; } # overridden here because the mysql adapter uses # a non-standard query hint sub _attributes_sql { my $self = shift; my ($attributes,$join) = @_; my ($wf,@bind_args) = $self->_make_attribute_where('a','al',$attributes); my ($group_by,@group_args)= $self->_make_attribute_group('a',$attributes); my $attribute_table = $self->_attribute_table; my $attributelist_table = $self->_attributelist_table; my $from = "$attribute_table as a, $attributelist_table as al"; my $where = <_typelist_table; my $from = "$typelist AS tl"; my (@matches,@args); for my $type (@types) { if (ref $type && $type->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type->method; $source_tag = $type->source; } else { ($primary_tag,$source_tag) = split ':',$type,2; } if ($source_tag) { push @matches,"lower(tl.tag)=lower(?)"; push @args,"$primary_tag:$source_tag"; } else { push @matches,"tl.tag ILIKE ?"; push @args,"$primary_tag:%"; } } my $matches = join ' OR ',@matches; my $where = <_meta_table; if (defined $value && $self->writeable) { my $querydel = "DELETE FROM $meta WHERE name = ?"; my $query = "INSERT INTO $meta (name,value) VALUES (?,?)"; my $sthdel = $self->_prepare($querydel); my $sth = $self->_prepare($query); $sthdel->execute($variable_name); $sth->execute($variable_name,$value) or $self->throw($sth->errstr); $sth->finish; $self->{settings_cache}{$variable_name} = $value; } else { return $self->{settings_cache}{$variable_name} if exists $self->{settings_cache}{$variable_name}; my $query = "SELECT value FROM $meta as m WHERE m.name=?"; my $sth = $self->_prepare($query); # $sth->execute($variable_name) or $self->throw($sth->errstr); unless ($sth->execute($variable_name)) { my $errstr = $sth->errstr; $sth = $self->_prepare("SHOW search_path"); $sth->execute(); $errstr .= "With search_path " . $sth->fetchrow_arrayref->[0] . "\n"; $self->throw($errstr); } my ($value) = $sth->fetchrow_array; $sth->finish; return $self->{settings_cache}{$variable_name} = $value; } } # overridden because of use of REPLACE in mysql adapter ### # Replace Bio::SeqFeatureI into database. # sub replace { my $self = shift; my $object = shift; my $index_flag = shift || undef; # ?? shouldn't need to do this # $self->_load_class($object); my $id = $object->primary_id; my $features = $self->_feature_table; my $query = "INSERT INTO $features (id,object,indexed,seqid,start,\"end\",strand,tier,bin,typeid) VALUES (?,?,?,?,?,?,?,?,?,?)"; my $query_noid = "INSERT INTO $features (object,indexed,seqid,start,\"end\",strand,tier,bin,typeid) VALUES (?,?,?,?,?,?,?,?,?)"; my $querydel = "DELETE FROM $features WHERE id = ?"; my $sthdel = $self->_prepare($querydel); my $sth = $self->_prepare($query); my $sth_noid = $self->_prepare($query_noid); my @location = $index_flag ? $self->_get_location_and_bin($object) : (undef)x6; my $primary_tag = $object->primary_tag; my $source_tag = $object->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); if ($id) { $sthdel->execute($id); $sth->execute($id,encode_base64($self->freeze($object), ''),$index_flag||0,@location,$typeid) or $self->throw($sth->errstr); } else { $sth_noid->execute(encode_base64($self->freeze($object), ''),$index_flag||0,@location,$typeid) or $self->throw($sth->errstr); } my $dbh = $self->dbh; $object->primary_id($dbh->last_insert_id(undef, undef, undef, undef, {sequence=>$features."_id_seq"})) unless defined $id; $self->flag_for_indexing($dbh->last_insert_id(undef, undef, undef, undef, {sequence=>$features."_id_seq"})) if $self->{bulk_update_in_progress}; } =head2 types Title : types Usage : @type_list = $db->types Function: Get all the types in the database Returns : array of Bio::DB::GFF::Typename objects Args : none Status : public =cut # overridden because "offset" is reserved in postgres ### # Insert a bit of DNA or protein into the database # sub _insert_sequence { my $self = shift; my ($seqid,$seq,$offset) = @_; my $id = $self->_locationid($seqid); my $seqtable = $self->_sequence_table; my $sthdel = $self->_prepare("DELETE FROM $seqtable WHERE id = ? AND \"offset\" = ?"); my $sth = $self->_prepare(<execute($id,$offset); $sth->execute($id,$offset,$seq) or $self->throw($sth->errstr); } # overridden because of mysql adapter's use of REPLACE ### # This subroutine flags the given primary ID for later reindexing # sub flag_for_indexing { my $self = shift; my $id = shift; my $needs_updating = $self->_update_table; my $querydel = "DELETE FROM $needs_updating WHERE id = ?"; my $query = "INSERT INTO $needs_updating VALUES (?)"; my $sthdel = $self->_prepare($querydel); my $sth = $self->_prepare($query); $sthdel->execute($id); $sth->execute($id) or $self->throw($self->dbh->errstr); } # overridden because of the different ways that mysql and postgres # handle id sequences sub _genericid { my $self = shift; my ($table,$namefield,$name,$add_if_missing) = @_; my $qualified_table = $self->_qualify($table); my $sth = $self->_prepare(<execute($name) or die $sth->errstr; my ($id) = $sth->fetchrow_array; $sth->finish; return $id if defined $id; return unless $add_if_missing; $sth = $self->_prepare(<execute($name) or die $sth->errstr; my $dbh = $self->dbh; return $dbh->last_insert_id(undef, undef, undef, undef, {sequence=>$qualified_table."_id_seq"}); } # overridden because of differences in binding between mysql and postgres adapters # given a statement handler that is expected to return rows of (id,object) # unthaw each object and return a list of 'em sub _sth2objs { my $self = shift; my $sth = shift; my @result; my ($id, $o); $sth->bind_col(1, \$id); $sth->bind_col(2, \$o, { pg_type => PG_BYTEA}); #while (my ($id,$o) = $sth->fetchrow_array) { while ($sth->fetch) { my $obj = $self->thaw(decode_base64($o) ,$id); push @result,$obj; } $sth->finish; return @result; } # given a statement handler that is expected to return rows of (id,object) # unthaw each object and return a list of 'em sub _sth2obj { my $self = shift; my $sth = shift; my ($id,$o) = $sth->fetchrow_array; return unless $o; my $obj = $self->thaw(decode_base64($o) ,$id); $obj; } #################################################################################################### # SQL Fragment generators #################################################################################################### # overridden because of base64 encoding needed here ### # special-purpose store for bulk loading - write to a file rather than to the db # sub _dump_store { my $self = shift; my $indexed = shift; my $count = 0; my $store_fh = $self->dump_filehandle('feature'); my $dbh = $self->dbh; my $autoindex = $self->autoindex; for my $obj (@_) { my $id = $self->next_id; my ($seqid,$start,$end,$strand,$tier,$bin) = $indexed ? $self->_get_location_and_bin($obj) : (undef)x6; my $primary_tag = $obj->primary_tag; my $source_tag = $obj->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); my $frozen_object = encode_base64($self->freeze($obj), ''); # TODO: Fix this, why does frozen object start with quote but not end with one print $store_fh join("\t",$id,$typeid,$seqid,$start,$end,$strand,$tier,$bin,$indexed,$frozen_object),"\n"; $obj->primary_id($id); $self->_update_indexes($obj) if $indexed && $autoindex; $count++; } # remember whether we are have ever stored a non-indexed feature unless ($indexed or $self->{indexed_flag}++) { $self->subfeatures_are_indexed(0); } $count; } sub _enable_keys { } # nullop sub _disable_keys { } # nullop sub _add_interval_stats_table { my $self = shift; my $tables = $self->table_definitions; my $interval_stats = $self->_interval_stats_table; ##check to see if it exists yet; if it does, just return because ##there is a drop from in the next step my $dbh = $self->dbh; my @table_exists = $dbh->selectrow_array("SELECT * FROM pg_tables WHERE tablename = '$interval_stats' AND schemaname = '".$self->namespace."'"); if (!scalar(@table_exists)) { my $query = "CREATE TABLE $interval_stats $tables->{interval_stats}"; $dbh->do($query) or $self->throw($dbh->errstr); } } sub _fetch_indexed_features_sql { my $self = shift; my $features = $self->_feature_table; return <new(-adaptor => 'DBI::SQLite', -dsn => '/path/to/database.db'); # get a feature from somewhere my $feature = Bio::SeqFeature::Generic->new(...); # store it $db->store($feature) or die "Couldn't store!"; # primary ID of the feature is changed to indicate its primary ID # in the database... my $id = $feature->primary_id; # get the feature back out my $f = $db->fetch($id); # change the feature and update it $f->start(100); $db->update($f) or die "Couldn't update!"; # searching... # ...by id my @features = $db->fetch_many(@list_of_ids); # ...by name @features = $db->get_features_by_name('ZK909'); # ...by alias @features = $db->get_features_by_alias('sma-3'); # ...by type @features = $db->get_features_by_name('gene'); # ...by location @features = $db->get_features_by_location(-seq_id=>'Chr1',-start=>4000,-end=>600000); # ...by attribute @features = $db->get_features_by_attribute({description => 'protein kinase'}) # ...by the GFF "Note" field @result_list = $db->search_notes('kinase'); # ...by arbitrary combinations of selectors @features = $db->features(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); # ...using an iterator my $iterator = $db->get_seq_stream(-name => $name, -type => $types, -seq_id => $seqid, -start => $start, -end => $end, -attributes => $attributes); while (my $feature = $iterator->next_seq) { # do something with the feature } # ...limiting the search to a particular region my $segment = $db->segment('Chr1',5000=>6000); my @features = $segment->features(-type=>['mRNA','match']); # getting & storing sequence information # Warning: this returns a string, and not a PrimarySeq object $db->insert_sequence('Chr1','GATCCCCCGGGATTCCAAAA...'); my $sequence = $db->fetch_sequence('Chr1',5000=>6000); # what feature types are defined in the database? my @types = $db->types; # create a new feature in the database my $feature = $db->new_feature(-primary_tag => 'mRNA', -seq_id => 'chr3', -start => 10000, -end => 11000); =head1 DESCRIPTION Bio::DB::SeqFeature::Store::SQLite is the SQLite adaptor for Bio::DB::SeqFeature::Store. You will not create it directly, but instead use Bio::DB::SeqFeature::Store-Enew() to do so. See L for complete usage instructions. =head2 Using the SQLite adaptor To establish a connection to the database, call Bio::DB::SeqFeature::Store-Enew(-adaptor=E'DBI::SQLite',@more_args). The additional arguments are as follows: Argument name Description ------------- ----------- -dsn The path to the SQLite database file. -namespace A prefix to attach to each table. This allows you to have several virtual databases in the same physical database. -temp Boolean flag. If true, a temporary database will be created and destroyed as soon as the Store object goes out of scope. (synonym -temporary) -autoindex Boolean flag. If true, features in the database will be reindexed every time they change. This is the default. -tmpdir Directory in which to place temporary files during "fast" loading. Defaults to File::Spec->tmpdir(). (synonyms -dump_dir, -dumpdir, -tmp) -dbi_options A hashref to pass to DBI->connect's 4th argument, the "attributes." (synonyms -options, -dbi_attr) -write Pass true to open database for writing or updating. If successful, a new instance of Bio::DB::SeqFeature::Store::DBI::SQLite will be returned. In addition to the standard methods supported by all well-behaved Bio::DB::SeqFeature::Store databases, several following adaptor-specific methods are provided. These are described in the next sections. =cut use strict; use base 'Bio::DB::SeqFeature::Store::DBI::mysql'; use Bio::DB::SeqFeature::Store::DBI::Iterator; use DBI qw(:sql_types); use Memoize; use Cwd qw(abs_path getcwd); use Bio::DB::GFF::Util::Rearrange 'rearrange'; use Bio::SeqFeature::Lite; use File::Spec; use constant DEBUG=>0; use constant EXPERIMENTAL_COVERAGE=>1; # Using same limits as MySQL adaptor so I don't have to make something up. use constant MAX_INT => 2_147_483_647; use constant MIN_INT => -2_147_483_648; use constant SUMMARY_BIN_SIZE => 1000; # we checkpoint coverage this often, about 20 meg overhead per feature type on hg use constant USE_SPATIAL=>0; # The binning scheme places each feature into a bin. # Bins are variably sized as powers of two. For example, # there are 585 bins of size 2**17 (131072 bases) my (@BINS,%BINS); { @BINS = map {2**$_} (17, 20, 23, 26, 29); # TO DO: experiment with different bin sizes my $start=0; for my $b (sort {$b<=>$a} @BINS) { $BINS{$b} = $start; $start += $BINS[-1]/$b; } } # my %BINS = ( # 2**11 => 37449, # 2**14 => 4681, # 2**17 => 585, # 2**20 => 73, # 2**23 => 9, # 2**26 => 1, # 2**29 => 0 # ); # my @BINS = sort {$a<=>$b} keys %BINS; sub calculate_bin { my $self = shift; my ($start,$end) = @_; my $len = $end - $start; for my $bin (@BINS) { next if $len > $bin; # possibly fits here my $binstart = int $start/$bin; my $binend = int $end/$bin; return $binstart+$BINS{$bin} if $binstart == $binend; } die "unreasonable coordinates ",$start+1,"..$end"; } sub search_bins { my $self = shift; my ($start,$end) = @_; my @results; for my $bin (@BINS) { my $binstart = int $start/$bin; my $binend = int $end/$bin; push @results,$binstart+$BINS{$bin}..$binend+$BINS{$bin}; } return @results; } ### # object initialization # sub init { my $self = shift; my ($dsn, $is_temporary, $autoindex, $namespace, $dump_dir, $user, $pass, $dbi_options, $writeable, $create, ) = rearrange(['DSN', ['TEMP','TEMPORARY'], 'AUTOINDEX', 'NAMESPACE', ['DUMP_DIR','DUMPDIR','TMP','TMPDIR'], 'USER', ['PASS','PASSWD','PASSWORD'], ['OPTIONS','DBI_OPTIONS','DBI_ATTR'], ['WRITE','WRITEABLE'], 'CREATE', ],@_); $dbi_options ||= {}; $writeable = 1 if $is_temporary or $dump_dir; $dsn or $self->throw("Usage: ".__PACKAGE__."->init(-dsn => \$dbh || \$dsn)"); my $dbh; if (ref $dsn) { $dbh = $dsn; } else { $dsn = "dbi:SQLite:$dsn" unless $dsn =~ /^dbi:/; $dbh = DBI->connect($dsn,$user,$pass,$dbi_options) or $self->throw($DBI::errstr); $dbh->do("PRAGMA synchronous = OFF;"); # makes writes much faster $dbh->do("PRAGMA temp_store = MEMORY;"); # less disk I/O; some speedup $dbh->do("PRAGMA cache_size = 20000;"); # less disk I/O; some speedup # Keep track of database file location my $cwd = getcwd; my ($db_file) = ($dsn =~ m/(?:db(?:name)?|database)=(.+)$/); $self->{dbh_file} = "$cwd/$db_file"; } $self->{dbh} = $dbh; $self->{is_temp} = $is_temporary; $self->{namespace} = $namespace; $self->{writeable} = $writeable; $self->default_settings; $self->autoindex($autoindex) if defined $autoindex; $self->dumpdir($dump_dir) if $dump_dir; if ($self->is_temp) { $self->init_tmp_database(); } elsif ($create) { $self->init_database('erase'); } } sub table_definitions { my $self = shift; my $defs = { feature => < < < < < < < < <_has_spatial_index) { $defs->{feature_location} = <{interval_stats} = <_create_spatial_index; $self->SUPER::_init_database(@_); } sub init_tmp_database { my $self = shift; my $erase = shift; $self->_create_spatial_index; $self->SUPER::init_tmp_database(@_); } sub _create_spatial_index{ my $self = shift; my $dbh = $self->dbh; local $dbh->{PrintError} = 0; $dbh->do("DROP TABLE IF EXISTS feature_index"); # spatial index if (USE_SPATIAL) { $dbh->do("CREATE VIRTUAL TABLE feature_index USING RTREE(id,seqid,bin,start,end)"); } } sub _has_spatial_index { my $self = shift; return $self->{'_has_spatial_index'} if exists $self->{'_has_spatial_index'}; my $dbh = $self->dbh; my ($count) = $dbh->selectrow_array("select count(*) from sqlite_master where name='feature_index'"); return $self->{'_has_spatial_index'} = $count; } sub _finish_bulk_update { my $self = shift; my $dbh = $self->dbh; my $dir = $self->{dumpdir} || '.'; $self->begin_work; # making this a transaction greatly improves performance for my $table ('feature', $self->index_tables) { my $fh = $self->dump_filehandle($table); my $path = $self->dump_path($table); $fh->close; open($fh, $path); my $qualified_table = $self->_qualify($table); my $sth; if ($table =~ /feature$/) { $sth = $dbh->prepare("REPLACE INTO $qualified_table VALUES (?,?,?,?,?)"); while (<$fh>) { chomp(); my ($id,$typeid,$strand,$indexed,$obj) = split(/\t/); $sth->bind_param(1, $id); $sth->bind_param(2, $typeid); $sth->bind_param(3, $strand); $sth->bind_param(4, $indexed); $sth->bind_param(5, pack('H*',$obj), {TYPE => SQL_BLOB}); $sth->execute(); } } else { my $feature_index = $self->_feature_index_table; if ($table =~ /parent2child$/) { $sth = $dbh->prepare("REPLACE INTO $qualified_table VALUES (?,?)"); } elsif ($table =~ /$feature_index$/) { $sth = $dbh->prepare( $self->_has_spatial_index ?"REPLACE INTO $qualified_table VALUES (?,?,?,?,?)" :"REPLACE INTO $qualified_table (id,seqid,bin,start,end) VALUES (?,?,?,?,?)" ); } else { # attribute or name $sth = $dbh->prepare("REPLACE INTO $qualified_table VALUES (?,?,?)"); } while (<$fh>) { chomp(); $sth->execute(split(/\t/)); } } $fh->close(); unlink $path; } $self->commit; # commit the transaction delete $self->{bulk_update_in_progress}; delete $self->{filehandles}; } sub index_tables { my $self = shift; my @t = $self->SUPER::index_tables; return (@t,$self->_feature_index_table); } sub _enable_keys { } # nullop sub _disable_keys { } # nullop sub _fetch_indexed_features_sql { my $self = shift; my $location_table = $self->_qualify('feature_location'); my $feature_table = $self->_qualify('feature'); return < $end my $reversed; if (defined $start && defined $end && $start > $end) { $reversed++; ($start,$end) = ($end,$start); } $start-- if defined $start; $end-- if defined $end; my $offset1 = $self->_offset_boundary($seqid,$start || 'left'); my $offset2 = $self->_offset_boundary($seqid,$end || 'right'); my $sequence_table = $self->_sequence_table; my $locationlist_table = $self->_locationlist_table; # CROSS JOIN gives a hint to the SQLite query optimizer -- mucho speedup! my $sth = $self->_prepare(<= ? AND offset <= ? ORDER BY offset END my $seq = ''; $sth->execute($seqid,$offset1,$offset2) or $self->throw($sth->errstr); while (my($frag,$offset) = $sth->fetchrow_array) { substr($frag,0,$start-$offset) = '' if defined $start && $start > $offset; $seq .= $frag; } substr($seq,$end-$start+1) = '' if defined $end && $end-$start+1 < length($seq); if ($reversed) { $seq = reverse $seq; $seq =~ tr/gatcGATC/ctagCTAG/; } $sth->finish; $seq; } sub _offset_boundary { my $self = shift; my ($seqid,$position) = @_; my $sequence_table = $self->_sequence_table; my $locationlist_table = $self->_locationlist_table; my $sql; # use "CROSS JOIN" to give a hint to the SQLite query optimizer. $sql = $position eq 'left' ? "SELECT min(offset) FROM $locationlist_table as ll CROSS JOIN $sequence_table as s ON ll.id=s.id WHERE ll.seqname=?" :$position eq 'right' ? "SELECT max(offset) FROM $locationlist_table as ll CROSS JOIN $sequence_table as s ON ll.id=s.id WHERE ll.seqname=?" :"SELECT max(offset) FROM $locationlist_table as ll CROSS JOIN $sequence_table as s ON ll.id=s.id WHERE ll.seqname=? AND offset<=?"; my $sth = $self->_prepare($sql); my @args = $position =~ /^-?\d+$/ ? ($seqid,$position) : ($seqid); $sth->execute(@args) or $self->throw($sth->errstr); my $boundary = $sth->fetchall_arrayref->[0][0]; $sth->finish; return $boundary; } ### # Efficiently fetch a series of IDs from the database # Can pass an array or an array ref # sub _fetch_many { my $self = shift; @_ or $self->throw('usage: fetch_many($id1,$id2,$id3...)'); my $ids = join ',',map {ref($_) ? @$_ : $_} @_ or return; my $features = $self->_feature_table; my $sth = $self->_prepare(<execute() or $self->throw($sth->errstr); return $self->_sth2objs($sth); } sub _features { my $self = shift; my ($seq_id,$start,$end,$strand, $name,$class,$allow_aliases, $types, $attributes, $range_type, $fromtable, $iterator, $sources ) = rearrange([['SEQID','SEQ_ID','REF'],'START',['STOP','END'],'STRAND', 'NAME','CLASS','ALIASES', ['TYPES','TYPE','PRIMARY_TAG'], ['ATTRIBUTES','ATTRIBUTE'], 'RANGE_TYPE', 'FROM_TABLE', 'ITERATOR', ['SOURCE','SOURCES'] ],@_); my (@from,@where,@args,@group); $range_type ||= 'overlaps'; my $feature_table = $self->_feature_table; @from = "$feature_table as f"; if (defined $name) { # hacky backward compatibility workaround undef $class if $class && $class eq 'Sequence'; $name = "$class:$name" if defined $class && length $class > 0; # last argument is the join field my ($from,$where,$group,@a) = $self->_name_sql($name,$allow_aliases,'f.id'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined $seq_id) { # last argument is the name of the features table my ($from,$where,$group,@a) = $self->_location_sql($seq_id,$start,$end,$range_type,$strand,'f'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined($sources)) { my @sources = ref($sources) eq 'ARRAY' ? @{$sources} : ($sources); if (defined($types)) { my @types = ref($types) eq 'ARRAY' ? @{$types} : ($types); my @final_types; foreach my $type (@types) { # *** not sure what to do if user supplies both -source and -type # where the type includes a source! if ($type =~ /:/) { push(@final_types, $type); } else { foreach my $source (@sources) { push(@final_types, $type.':'.$source); } } } $types = \@final_types; } else { $types = [map { ':'.$_ } @sources]; } } if (defined($types)) { # last argument is the name of the features table my ($from,$where,$group,@a) = $self->_types_sql($types,'f'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined $attributes) { # last argument is the join field my ($from,$where,$group,@a) = $self->_attributes_sql($attributes,'f.id'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } if (defined $fromtable) { # last argument is the join field my ($from,$where,$group,@a) = $self->_from_table_sql($fromtable,'f.id'); push @from,$from if $from; push @where,$where if $where; push @group,$group if $group; push @args,@a; } # if no other criteria are specified, then # only fetch indexed (i.e. top level objects) @where = '"indexed"=1' unless @where; my $from = join ', ',@from; my $where = join ' AND ',map {"($_)"} @where; my $group = join ', ',@group; $group = "GROUP BY $group" if @group; my $query = <_print_query($query,@args) if DEBUG || $self->debug; my $sth = $self->_prepare($query); $sth->execute(@args) or $self->throw($sth->errstr); return $iterator ? Bio::DB::SeqFeature::Store::DBI::Iterator->new($sth,$self) : $self->_sth2objs($sth); } sub _make_attribute_group { my $self = shift; my ($table_name,$attributes) = @_; my $key_count = keys %$attributes or return; my $count = $key_count-1; return "f.id HAVING count(f.id)>$count"; } sub _location_sql { my $self = shift; my ($seq_id,$start,$end,$range_type,$strand,$location) = @_; # the additional join on the location_list table badly impacts performance # so we build a copy of the table in memory my $seqid = $self->_locationid_nocreate($seq_id) || 0; # zero is an invalid primary ID, so will return empty my $feature_index = $self->_feature_index_table; my $from = "$feature_index as fi"; my ($bin_where,@bin_args); if (defined $start && defined $end && !$self->_has_spatial_index) { my @bins = $self->search_bins($start,$end); $bin_where = ' AND bin in ('.join(',',@bins).')'; } $start = MIN_INT unless defined $start; $end = MAX_INT unless defined $end; my ($range,@range_args); if ($range_type eq 'overlaps') { $range = "fi.end>=? AND fi.start<=?".$bin_where; @range_args = ($start,$end,@bin_args); } elsif ($range_type eq 'contains') { $range = "fi.start>=? AND fi.end<=?".$bin_where; @range_args = ($start,$end,@bin_args); } elsif ($range_type eq 'contained_in') { $range = "fi.start<=? AND fi.end>=?"; @range_args = ($start,$end); } else { $self->throw("range_type must be one of 'overlaps', 'contains' or 'contained_in'"); } if (defined $strand) { $range .= " AND strand=?"; push @range_args,$strand; } my $where = <_has_spatial_index ? $self->_qualify('feature_index') : $self->_qualify('feature_location') } # Do a case-insensitive search a la the PostgreSQL adaptor sub _name_sql { my $self = shift; my ($name,$allow_aliases,$join) = @_; my $name_table = $self->_name_table; my $from = "$name_table as n"; my ($match,$string) = $self->_match_sql($name); my $where = "n.id=$join AND lower(n.name) $match"; $where .= " AND n.display_name>0" unless $allow_aliases; return ($from,$where,'',$string); } sub _search_attributes { my $self = shift; my ($search_string,$attribute_names,$limit) = @_; my @words = map {quotemeta($_)} split /\s+/,$search_string; my $name_table = $self->_name_table; my $attribute_table = $self->_attribute_table; my $attributelist_table = $self->_attributelist_table; my $type_table = $self->_type_table; my $typelist_table = $self->_typelist_table; my @tags = @$attribute_names; my $tag_sql = join ' OR ',("al.tag=?") x @tags; my $perl_regexp = join '|',@words; my @wild_card_words = map { "%$_%" } @words; my $sql_regexp = join ' OR ',("a.attribute_value LIKE ?") x @words; # CROSS JOIN disables SQLite's table reordering optimization my $sql = <_print_query($sql,@tags,@words) if DEBUG || $self->debug; my $sth = $self->_prepare($sql); $sth->execute(@tags,@wild_card_words) or $self->throw($sth->errstr); my @results; while (my($name,$value,$type,$id) = $sth->fetchrow_array) { my (@hits) = $value =~ /$perl_regexp/ig; my @words_in_row = split /\b/,$value; my $score = int(@hits*100/@words/@words_in_row); push @results,[$name,$value,$score,$type,$id]; } $sth->finish; @results = sort {$b->[2]<=>$a->[2]} @results; return @results; } sub _match_sql { my $self = shift; my $name = shift; my ($match,$string); if ($name =~ /(?:^|[^\\])[*?]/) { $name =~ s/(^|[^\\])([%_])/$1\\$2/g; $name =~ s/(^|[^\\])\*/$1%/g; $name =~ s/(^|[^\\])\?/$1_/g; $match = "LIKE ?"; $string = $name; } else { $match = "= lower(?)"; $string = lc($name); } return ($match,$string); } sub _attributes_sql { my $self = shift; my ($attributes,$join) = @_; my ($wf,@bind_args) = $self->_make_attribute_where('a','al',$attributes); my ($group_by,@group_args)= $self->_make_attribute_group('a',$attributes); my $attribute_table = $self->_attribute_table; my $attributelist_table = $self->_attributelist_table; my $from = "$attribute_table AS a INDEXED BY index_attribute_id, $attributelist_table AS al"; my $where = <_typelist_table; my $from = "$typelist AS tl"; my (@matches,@args); for my $type (@types) { if (ref $type && $type->isa('Bio::DB::GFF::Typename')) { $primary_tag = $type->method; $source_tag = $type->source; } else { ($primary_tag,$source_tag) = split ':',$type,2; } if (length $source_tag) { push @matches,"lower(tl.tag)=lower(?)"; push @args,"$primary_tag:$source_tag"; } else { push @matches,"tl.tag LIKE ?"; push @args,"$primary_tag:%"; } } my $matches = join ' OR ',@matches; my $where = <dbh->do("ANALYZE $_") foreach $self->index_tables; } ### # Replace Bio::SeqFeatureI into database. # sub replace { my $self = shift; my $object = shift; my $index_flag = shift || undef; # ?? shouldn't need to do this # $self->_load_class($object); my $id = $object->primary_id; my $features = $self->_feature_table; my $sth = $self->_prepare(<_get_location_and_bin($object) : (undef)x6; my $primary_tag = $object->primary_tag; my $source_tag = $object->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); my $frozen = $self->no_blobs() ? 0 : $self->freeze($object); $sth->bind_param(1, $id); $sth->bind_param(2, $frozen, {TYPE => SQL_BLOB}); $sth->bind_param(3, $index_flag||0); $sth->bind_param(4, $strand); $sth->bind_param(5, $typeid); $sth->execute() or $self->throw($sth->errstr); my $dbh = $self->dbh; $object->primary_id($dbh->func('last_insert_rowid')) unless defined $id; $self->flag_for_indexing($dbh->func('last_insert_rowid')) if $self->{bulk_update_in_progress}; } # doesn't work with this schema, since we have to update name and attribute # tables which need object ids, which we can only know by replacing feats in # the feature table one by one sub bulk_replace { my $self = shift; my $index_flag = shift || undef; my @objects = @_; my $features = $self->_feature_table; my @insert_values; foreach my $object (@objects) { my $id = $object->primary_id; my (undef,undef,undef,$strand) = $index_flag ? $self->_get_location_and_bin($object) : (undef)x4; my $primary_tag = $object->primary_tag; my $source_tag = $object->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); push(@insert_values, ($id,0,$index_flag||0,$strand,$typeid)); } my @value_blocks; for (1..@objects) { push(@value_blocks, '(?,?,?,?,?)'); } my $value_blocks = join(',', @value_blocks); my $sql = qq{REPLACE INTO $features (id,object,"indexed",strand,typeid) VALUES $value_blocks}; my $sth = $self->_prepare($sql); $sth->execute(@insert_values) or $self->throw($sth->errstr); } sub _get_location_and_bin { my $self = shift; my $obj = shift; my $seqid = $self->_locationid($obj->seq_id||''); my $start = $obj->start; my $end = $obj->end; my $strand = $obj->strand; return ($seqid,$start,$end,$strand,$self->calculate_bin($start,$end)); } ### # Insert one Bio::SeqFeatureI into database. primary_id must be undef # sub insert { my $self = shift; my $object = shift; my $index_flag = shift || 0; $self->_load_class($object); defined $object->primary_id and $self->throw("$object already has a primary id"); my $features = $self->_feature_table; my $sth = $self->_prepare(<execute(undef,$self->freeze($object),$index_flag) or $self->throw($sth->errstr); my $dbh = $self->dbh; $object->primary_id($dbh->func('last_insert_rowid')); $self->flag_for_indexing($dbh->func('last_insert_rowid')) if $self->{bulk_update_in_progress}; } =head2 toplevel_types Title : toplevel_types Usage : @type_list = $db->toplevel_types Function: Get the toplevel types in the database Returns : array of Bio::DB::GFF::Typename objects Args : none Status : public This is similar to types() but only returns the types of INDEXED (toplevel) features. =cut sub toplevel_types { my $self = shift; eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new'); my $typelist_table = $self->_typelist_table; my $feature_table = $self->_feature_table; my $sql = <_print_query($sql) if DEBUG || $self->debug; my $sth = $self->_prepare($sql); $sth->execute() or $self->throw($sth->errstr); my @results; while (my($tag) = $sth->fetchrow_array) { push @results,Bio::DB::GFF::Typename->new($tag); } $sth->finish; return @results; } sub _genericid { my $self = shift; my ($table,$namefield,$name,$add_if_missing) = @_; my $qualified_table = $self->_qualify($table); my $sth = $self->_prepare(<execute($name) or die $sth->errstr; my ($id) = $sth->fetchrow_array; $sth->finish; return $id if defined $id; return unless $add_if_missing; $sth = $self->_prepare(<execute($name) or die $sth->errstr; my $dbh = $self->dbh; return $dbh->func('last_insert_rowid'); } ### # special-purpose store for bulk loading - write to a file rather than to the db # sub _dump_store { my $self = shift; my $indexed = shift; my $count = 0; my $store_fh = $self->dump_filehandle('feature'); my $dbh = $self->dbh; my $autoindex = $self->autoindex; for my $obj (@_) { my $id = $self->next_id; my ($seqid,$start,$end,$strand) = $indexed ? $self->_get_location_and_bin($obj) : (undef)x4; my $primary_tag = $obj->primary_tag; my $source_tag = $obj->source_tag || ''; $primary_tag .= ":$source_tag"; my $typeid = $self->_typeid($primary_tag,1); # Encode BLOB in hex so we can more easily import it into SQLite print $store_fh join("\t",$id,$typeid,$strand,$indexed, unpack('H*', $self->freeze($obj))),"\n"; $obj->primary_id($id); $self->_update_indexes($obj) if $indexed && $autoindex; $count++; } # remember whether we are have ever stored a non-indexed feature unless ($indexed or $self->{indexed_flag}++) { $self->subfeatures_are_indexed(0); } $count; } sub _dump_update_name_index { my $self = shift; my ($obj,$id) = @_; my $fh = $self->dump_filehandle('name'); my $dbh = $self->dbh; my ($names,$aliases) = $self->feature_names($obj); # unlike DBI::mysql, don't quote, as quotes will be quoted when loaded print $fh join("\t",$id,lc($_),1),"\n" foreach @$names; print $fh join("\t",$id,lc($_),0),"\n" foreach @$aliases; } sub _update_name_index { my $self = shift; my ($obj,$id) = @_; my $name = $self->_name_table; my $primary_id = $obj->primary_id; $self->_delete_index($name,$id); my ($names,$aliases) = $self->feature_names($obj); my $sth = $self->_prepare("INSERT INTO $name (id,name,display_name) VALUES (?,?,?)"); $sth->execute($id,lc $_,1) or $self->throw($sth->errstr) foreach @$names; $sth->execute($id,lc $_,0) or $self->throw($sth->errstr) foreach @$aliases; $sth->finish; } sub _dump_update_attribute_index { my $self = shift; my ($obj,$id) = @_; my $fh = $self->dump_filehandle('attribute'); my $dbh = $self->dbh; for my $tag ($obj->all_tags) { my $tagid = $self->_attributeid($tag); for my $value ($obj->each_tag_value($tag)) { # unlike DBI::mysql, don't quote, as quotes will be quoted when loaded print $fh join("\t",$id,$tagid,$value),"\n"; } } } sub _update_indexes { my $self = shift; my $obj = shift; defined (my $id = $obj->primary_id) or return; $self->SUPER::_update_indexes($obj); if ($self->{bulk_update_in_progress}) { $self->_dump_update_location_index($obj,$id); } else { $self->_update_location_index($obj,$id); } } sub _update_location_index { my $self = shift; my ($obj,$id) = @_; my ($seqid,$start,$end,$strand,$bin) = $self->_get_location_and_bin($obj); my $table = $self->_feature_index_table; $self->_delete_index($table,$id); my ($sql,@args); if ($self->_has_spatial_index) { $sql = "INSERT INTO $table (id,seqid,bin,start,end) values (?,?,?,?,?)"; @args = ($id,$seqid,$bin,$start,$end); } else { $sql = "INSERT INTO $table (id,seqid,bin,start,end) values (?,?,?,?,?)"; @args = ($id,$seqid,$bin,$start,$end); } my $sth = $self->_prepare($sql); $sth->execute(@args); $sth->finish; } sub _dump_update_location_index { my $self = shift; my ($obj,$id) = @_; my $table = $self->_feature_index_table; my $fh = $self->dump_filehandle($table); my $dbh = $self->dbh; my ($seqid,$start,$end,$strand,$bin) = $self->_get_location_and_bin($obj); my @args = $self->_has_spatial_index ? ($id,$seqid,$bin,$start,$end) : ($id,$seqid,$bin,$start,$end); print $fh join("\t",@args),"\n"; } sub DESTROY { my $self = shift; # Remove filehandles, so temporal files can be properly deleted if (%DBI::installed_drh) { DBI->disconnect_all; %DBI::installed_drh = (); } undef $self->{dbh}; } 1; =head1 AUTHOR Nathan Weeks - Nathan.Weeks@ars.usda.gov Copyright (c) 2009 Nathan Weeks Modified 2010 to support cumulative statistics by Lincoln Stein . This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See the Bioperl license for more details. =cut BioPerl-1.6.923/Bio/DB/SeqVersion000755000765000024 012254227320 16372 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/SeqVersion/gi.pm000444000765000024 1733712254227320 17517 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::SeqVersion::gi # # Please direct questions and support issues to # # Cared for by Brian Osborne # # Copyright Brian Osborne 2006 # # You may distribute this module under the same terms as Perl itself # # POD documentation - main docs before the code =head1 NAME Bio::DB::SeqVersion::gi - interface to NCBI Sequence Revision History page =head1 SYNOPSIS Do not use this module directly, use Bio::DB::SeqVersion. use Bio::DB::SeqVersion; my $query = Bio::DB::SeqVersion->new(-type => 'gi'); # all GIs, which will include the GI used to query my @all_gis = $query->get_all(2); # the most recent GI, which may or may not be the GI used to query my $live_gi = $query->get_recent(2); # get all the visible data on the Sequence Revision page my $array_ref = $query->get_history(11111111); These methods can also take accession numbers as arguments, just like the Sequence Revision page itself. =head1 DESCRIPTION All sequence entries at GenBank are identified by a pair of identifiers, an accession and a numeric identifier, and this number is frequently called a GI number (BenInfo Bdentifier). The accession is stable, but each new version of the sequence entry for the accession receives a new GI number (see L for more information on GenBank identifiers). One accession can have one or more GI numbers and the highest of these is the most recent, or "live", GI. Information on an accession and its associated GI numbers is available at the Sequence Revision History page at NCBI, L, this information is not available in file format. This module queries the Web page and retrieves GI numbers and related data given an accession (e.g. NP_111111, A11111, P12345) or a GI number (e.g. 2, 11111111) as query. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Brian Osborne Email E osborne at optonline dot net E =head1 CONTRIBUTORS Torsten Seemann - torsten.seemann AT infotech.monash.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::SeqVersion::gi; use strict; use Encode; use HTML::TableExtract; use base qw(Bio::DB::SeqVersion); # Private class variables # TODO: this may be an unstable setting (text is actually minimal XHTML) my $URL = 'http://www.ncbi.nlm.nih.gov/nuccore/%s?report=girevhist&format=text'; =head2 new Title : new Usage : $gb = Bio::DB::SeqVersion::gi->new Function: Creates a new query object Returns : New query object =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); $self->_initialize; return $self; } =head2 get_all Title : get_all Usage : my @gis = $q->get_all(2) Function: Get all GI numbers given a GI number Returns : An array of GI numbers, earliest GI number is the 0 element Args : A single GI number (string) =cut sub get_all { my ( $self, $id ) = @_; my ( @arr, $ref ); $id eq $self->{_last_id} ? $ref = $self->{_last_result} : $ref = $self->get_history($id); for my $row ( @{$ref} ) { push @arr, $$row[0]; } @arr; } =head2 get_recent Title : get_recent Usage : my $newest_gi = $q->get_recent(2) Function: Get most recent GI given a single GI Returns : String Args : A single GI number (string) =cut sub get_recent { my ( $self, $id ) = @_; my $ref; $id eq $self->{_last_id} ? $ref = $self->{_last_result} : $ref = $self->get_history($id); $ref->[0]->[0]; } =head2 get_status Title : get_status Usage : my $newest_gi = $q->get_status(2) Function: Get most recent GI given a single GI Returns : String Args : A single GI number (string) =cut sub get_status { my ( $self, $id ) = @_; $self->throw("Must pass an ID") if !defined $id; if ($id ne $self->{_last_id} ) { $self->get_history($id); } $self->{_last_status}; } =head2 get_history Title : get_history Usage : my $ref = $query_obj->get_history() Function: Queries the NCBI Revision page, gets the data from the HTML table Returns : Reference to an array of arrays where element 0 refers to the most recent version and the last element refers to the oldest version. In the second dimension the elements are: 0 GI number 1 Version 2 Update Date For example, to get the GI number of the first version: $ref->[$#{@$ref}]->[0] To get the Update Date of the latest version: $ref->[0]->[2] Args : One identifier (string) Note : Status of the GI was returned here previously as the last element in the row of elemnts above; however the status is currently only returned for the GI requested (e.g. a single value). One can get the status for this using the get_status() method above =cut sub get_history { my ( $self, $id ) = @_; my $html = $self->_get_request($id); my ( $ref, $status ) = $self->_process_data($html); # store the very last result in case some other methods # are called using the same identifier $self->{_last_result} = $ref; $self->{_last_id} = $id; $self->{_last_status} = $status; $ref; } =head2 _get_request Title : _get_request Usage : my $url = $self->_get_request Function: GET using NCBI Revision page URL, uses Root::HTTPget Returns : HTML Args : One identifier (string) =cut sub _get_request { my ( $self, $id ) = @_; $self->throw("Must specify a single id to query") if ( !defined($id) || ref($id) ); my $url = sprintf( $URL, $id ); my $response = $self->get($url); if ( not $response->is_success ) { $self->throw( "Can't query $url: " . $response->status_line . "\n" . "ID likely does not exist" ); } return $response->content; } =head2 _process_data Title : _process_data Usage : $self->_process_data($html) Function: extract data from HTML Args : HTML from Revision History page Returns : reference to an array of arrays =cut sub _process_data { my ( $self, $html ) = @_; # Only one status is returned (not one per revision). Setting once my $status; if ($html =~ /
Current status:\s+(\S+)<\/div>/) { $status = $1; } else { $self->warn("No current status found, setting to 'unknown'"); $status = 'unknown'; } my $te = HTML::TableExtract->new( headers => ['Gi', 'Version', 'Update Date'] , depth => 0); $te->parse(decode_utf8($html)); my $table = $te->first_table_found; $self->throw("No table found") unless defined $table; my $t = [$table->rows]; ($t, $status); } 1; __END__ BioPerl-1.6.923/Bio/DB/Taxonomy000755000765000024 012254227340 16114 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/Taxonomy/entrez.pm000444000765000024 5206312254227334 20147 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Taxonomy::entrez # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Taxonomy::entrez - Taxonomy Entrez driver =head1 SYNOPSIS # Do not use this object directly, rather through the Bio::DB::Taxonomy # interface use Bio::DB::Taxonomy; my $db = Bio::DB::Taxonomy->new(-source => 'entrez'); my $taxonid = $db->get_taxonid('Homo sapiens'); my $node = $db->get_Taxonomy_Node(-taxonid => $taxonid); my $gi = 71836523; my $node = $db->get_Taxonomy_Node(-gi => $gi, -db => 'protein'); print $node->binomial, "\n"; my ($species,$genus,$family) = $node->classification; print "family is $family\n"; # Can also go up 4 levels my $p = $node; for ( 1..4 ) { $p = $db->get_Taxonomy_Node(-taxonid => $p->parent_id); } print $p->rank, " ", ($p->classification)[0], "\n"; # could then classify a set of BLAST hits based on their GI numbers # into taxonomic categories. It is not currently possibly to query a node for its children so we cannot completely replace the advantage of the flatfile Bio::DB::Taxonomy::flatfile module. =head1 DESCRIPTION A driver for querying NCBI Entrez Taxonomy database. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Sendu Bala: bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Taxonomy::entrez; use vars qw($EntrezLocation $UrlParamSeparatorValue %EntrezParams $EntrezGet $EntrezSummary $EntrezFetch %SequenceParams $XMLTWIG $DATA_CACHE $RELATIONS); use strict; use Bio::Taxon; use Bio::DB::NCBIHelper; eval { require XML::Twig; $XMLTWIG = 1; }; if( $@ ) { $XMLTWIG = 0; } use base qw(Bio::WebAgent Bio::DB::Taxonomy); $EntrezLocation = $Bio::DB::NCBIHelper::HOSTBASE . '/entrez/eutils/'; $EntrezGet = 'esearch.fcgi'; $EntrezFetch = 'efetch.fcgi'; $EntrezSummary = 'esummary.fcgi'; $DATA_CACHE = {}; $RELATIONS = {}; %EntrezParams = ( 'db' => 'taxonomy', 'report' => 'xml', 'retmode'=> 'xml', 'tool' => 'Bioperl'); %SequenceParams = ( 'db' => 'nucleotide', # or protein 'retmode' => 'xml', 'tool' => 'Bioperl'); $UrlParamSeparatorValue = '&'; =head2 new Title : new Usage : my $obj = Bio::DB::Taxonomy::entrez->new(); Function: Builds a new Bio::DB::Taxonomy::entrez object Returns : an instance of Bio::DB::Taxonomy::entrez Args : -location => URL to Entrez (if you want to override the default) -params => Hashref of URL params if you want to override the default =cut sub new { my ($class, @args) = @_; # need to initialise Bio::WebAgent... my ($self) = $class->SUPER::new(@args); # ... as well as our normal Bio::DB::Taxonomy selves: $self->_initialize(@args); return $self; } sub _initialize { my($self) = shift; $self->SUPER::_initialize(@_); my ($location,$params) = $self->_rearrange([qw(LOCATION PARAMS)],@_); if( $params ) { if( ref($params) !~ /HASH/i ) { $self->warn("Must have provided a valid HASHref for -params"); $params = \%EntrezParams; } } else { $params = \%EntrezParams; } $self->entrez_params($params); $self->entrez_url($location || $EntrezLocation ); } =head2 get_num_taxa Title : get_num_taxa Usage : my $num = $db->get_num_taxa(); Function: Get the number of taxa stored in the database. Returns : A number Args : None =cut sub get_num_taxa { my ($self) = @_; # Use this URL query to get the ID of all the taxa in the NCBI Taxonomy database: # http://eutils.ncbi.nlm.nih.gov/entrez/eutils/esearch.fcgi?db=taxonomy&term=all[Filter] # Only the first 20 taxa IDs are returned (good because the list is long), # and the total number is reported as well (which is what we are interested # in). my %p = $self->entrez_params; $p{'term'} = 'all[Filter]'; my $twig = $self->_run_query($self->_build_url($EntrezGet, \%p)); my $count = $twig->root->first_child('Count')->first_child->text; return $count; } =head2 get_taxon Title : get_taxon Usage : my $taxon = $db->get_taxon(-taxonid => $taxonid) Function: Get a Bio::Taxon object from the database. Returns : Bio::Taxon object Args : just a single value which is the database id, OR named args: -taxonid => taxonomy id (to query by taxonid) OR -name => string (to query by a taxonomy name: common name, scientific name, etc) OR To retrieve a taxonomy node for a GI number provide the -gi option with the gi number and -db with either 'nucleotide' or 'protein' to define the db. AND optionally, -full => 1 (to force retrieval of full information - sometimes minimal information about your taxon may have been cached, which is normally used to save database accesses) =cut sub get_taxon { my $self = shift; if (! $XMLTWIG) { eval { require XML::Twig }; $self->throw("Could not load XML::Twig for get_taxon(): $@") if $@; } my %p = $self->entrez_params; # convert input request to one or more ids my (@taxonids, $taxonid, $want_full); if (@_ > 1) { my %params = @_; if ($params{'-taxonid'}) { $taxonid = $params{'-taxonid'}; } elsif ($params{'-gi'}) { my $db = $params{'-db'}; # we're going to do all the work here and then redirect # the call based on the TaxId my %p = %SequenceParams; my %items; if( ref($params{'-gi'}) =~ /ARRAY/i ) { $p{'id'} = join(',', @{$params{'-gi'}}); } else { $p{'id'} = $params{'-gi'}; } $p{'db'} = $db if defined $db; my $url = $self->_build_url($EntrezSummary, \%p); my @ids; if (exists $DATA_CACHE->{gi_to_ids}->{$url}) { @ids = @{$DATA_CACHE->{gi_to_ids}->{$url}}; } else { my $twig = $self->_run_query($url); my $root = $twig->root; for my $topnode ( $root->children('DocSum') ) { for my $child ( $topnode->children('Item') ) { if( uc($child->{att}->{'Name'}) eq 'TAXID' ) { push @ids, $child->text; } } } $DATA_CACHE->{gi_to_ids}->{$url} = \@ids; } return $self->get_taxon(-taxonid => \@ids); } elsif ($params{'-name'}) { @taxonids = $self->get_taxonid($params{'-name'}); } else { $self->warn("Need to have provided either a -taxonid or -name value to get_taxon"); } if ($params{'-full'}) { $want_full = 1; } } else { $taxonid = shift; } if (ref($taxonid) =~ /ARRAY/i ) { @taxonids = @{$taxonid}; } else { push(@taxonids, $taxonid) if $taxonid; } # return answer(s) from the cache if possible my @results; my @uncached; foreach my $taxonid (@taxonids) { $taxonid || $self->throw("In taxonids list one was undef! '@taxonids'\n"); if (defined $DATA_CACHE->{full_info}->{$taxonid}) { push(@results, $self->_make_taxon($DATA_CACHE->{full_info}->{$taxonid})); } elsif (! $want_full && defined $DATA_CACHE->{minimal_info}->{$taxonid}) { push(@results, $self->_make_taxon($DATA_CACHE->{minimal_info}->{$taxonid})); } else { push(@uncached, $taxonid); } } if (@uncached > 0) { $taxonid = join(',', @uncached); $p{'id'} = $taxonid; $self->debug("id is $taxonid\n"); my $twig = $self->_run_query($self->_build_url($EntrezFetch, \%p)); my $root = $twig->root; for my $taxon ( $root->children('Taxon') ) { my $taxid = $taxon->first_child_text('TaxId'); $self->throw("Got a result with no TaxId!") unless $taxid; my $data = {}; if (exists $DATA_CACHE->{minimal_info}->{$taxid}) { $data = $DATA_CACHE->{minimal_info}->{$taxid}; } $data->{id} = $taxid; $data->{rank} = $taxon->first_child_text('Rank'); my $other_names = $taxon->first_child('OtherNames'); my @other_names = $other_names->children_text() if $other_names; my $sci_name = $taxon->first_child_text('ScientificName'); my $orig_sci_name = $sci_name; $sci_name =~ s/ \(class\)$//; push(@other_names, $orig_sci_name) if $orig_sci_name ne $sci_name; $data->{scientific_name} = $sci_name; $data->{common_names} = \@other_names; $data->{division} = $taxon->first_child_text('Division'); $data->{genetic_code} = $taxon->first_child('GeneticCode')->first_child_text('GCId'); $data->{mitochondrial_genetic_code} = $taxon->first_child('MitoGeneticCode')->first_child_text('MGCId'); $data->{create_date} = $taxon->first_child_text('CreateDate'); $data->{update_date} = $taxon->first_child_text('UpdateDate'); $data->{pub_date} = $taxon->first_child_text('PubDate'); # since we have some information about all the ancestors of our # requested node, we may as well cache data for the ancestors to # reduce the number of accesses to website in future my $lineage_ex = $taxon->first_child('LineageEx'); my ($ancestor, $lineage_data, @taxa); foreach my $lineage_taxon ($lineage_ex->children) { my $lineage_taxid = $lineage_taxon->first_child_text('TaxId'); if (exists $DATA_CACHE->{minimal_info}->{$lineage_taxid} || exists $DATA_CACHE->{full_info}->{$lineage_taxid}) { $lineage_data = $DATA_CACHE->{minimal_info}->{$lineage_taxid} || $DATA_CACHE->{full_info}->{$lineage_taxid}; next; } else { $lineage_data = {}; } $lineage_data->{id} = $lineage_taxid; $lineage_data->{scientific_name} = $lineage_taxon->first_child_text('ScientificName'); $lineage_data->{rank} = $lineage_taxon->first_child_text('Rank'); $RELATIONS->{ancestors}->{$lineage_taxid} = $ancestor->{id} if $ancestor; $DATA_CACHE->{minimal_info}->{$lineage_taxid} = $lineage_data; } continue { $ancestor = $lineage_data; unshift(@taxa, $lineage_data); } $RELATIONS->{ancestors}->{$taxid} = $ancestor->{id} if $ancestor; # go through the lineage in reverse so we can remember the children my $child = $data; foreach my $lineage_data (@taxa) { $RELATIONS->{children}->{$lineage_data->{id}}->{$child->{id}} = 1; } continue { $child = $lineage_data; } delete $DATA_CACHE->{minimal_info}->{$taxid}; $DATA_CACHE->{full_info}->{$taxid} = $data; push(@results, $self->_make_taxon($data)); } } wantarray() ? @results : shift @results; } *get_Taxonomy_Node = \&get_taxon; =head2 get_taxonids Title : get_taxonids Usage : my $taxonid = $db->get_taxonids('Homo sapiens'); Function: Searches for a taxonid (typically ncbi_taxon_id) based on a query string. Note that multiple taxonids can match to the same supplied name. Returns : array of integer ids in list context, one of these in scalar context Args : string representing taxon's name =cut sub get_taxonids { my ($self,$query) = @_; my %p = $self->entrez_params; # queries don't work correctly with special characters, so get rid of them. if ($query =~ /<.+>/) { # queries with will fail, so workaround by removing, doing # the query, getting multiple taxonids, then picking the one id that # has a parent node with a scientific_name() or common_names() # case-insensitive matching to the word(s) within <> $query =~ s/ <(.+?)>//; my $desired_parent_name = lc($1); ID: foreach my $start_id ($self->get_taxonids($query)) { my $node = $self->get_taxon($start_id) || next ID; # walk up the parents until we hit a node with a named rank while (1) { my $parent_node = $self->ancestor($node) || next ID; my $parent_sci_name = $parent_node->scientific_name || next ID; my @parent_common_names = $parent_node->common_names; unless (@parent_common_names) { # ensure we're not using a minimal-info cached version $parent_node = $self->get_taxon(-taxonid => $parent_node->id, -full => 1); @parent_common_names = $parent_node->common_names; } foreach my $name ($parent_sci_name, @parent_common_names) { if (lc($name) eq $desired_parent_name) { return wantarray() ? ($start_id) : $start_id; } } my $parent_rank = $parent_node->rank || 'no rank'; if ($parent_rank ne 'no rank') { last; } else { $node = $parent_node; } } } return; } $query =~ s/[\"\(\)]//g; # not an exhaustive list; these are just the ones I know cause problems $query =~ s/\s/+/g; my @data; if (defined $DATA_CACHE->{name_to_id}->{$query}) { @data = @{$DATA_CACHE->{name_to_id}->{$query}}; } else { $p{'term'} = $query; my $twig = $self->_run_query($self->_build_url($EntrezGet, \%p)); my $root = $twig->root; my $list = $root->first_child('IdList'); @data = map { $_->text } $list->children('Id'); $DATA_CACHE->{name_to_id}->{$query} = [@data]; } wantarray() ? @data : shift @data; } *get_taxonid = \&get_taxonids; =head2 ancestor Title : ancestor Usage : my $ancestor_taxon = $db->ancestor($taxon) Function: Retrieve the ancestor taxon of a supplied Taxon from the database. Note that unless the ancestor has previously been directly requested with get_taxon(), the returned Taxon object will only have a minimal amount of information. Returns : Bio::Taxon Args : Bio::Taxon (that was retrieved from this database) =cut sub ancestor { my ($self, $taxon) = @_; $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); $self->throw("The supplied Taxon must belong to this database") unless $taxon->db_handle && $taxon->db_handle eq $self; my $id = $taxon->id || $self->throw("The supplied Taxon is missing its id!"); my $ancestor_id = $RELATIONS->{ancestors}->{$id} || return; return $self->_make_taxon($DATA_CACHE->{full_info}->{$ancestor_id} || $DATA_CACHE->{minimal_info}->{$ancestor_id}); } =head2 each_Descendent Title : each_Descendent Usage : my @taxa = $db->each_Descendent($taxon); Function: Get all the descendents of the supplied Taxon (but not their descendents, ie. not a recursive fetchall). Note that this implementation is unable to return a taxon that hasn't previously been directly fetched with get_taxon(), or wasn't an ancestor of such a fetch. Returns : Array of Bio::Taxon objects Args : Bio::Taxon (that was retrieved from this database) =cut sub each_Descendent { my ($self, $taxon) = @_; $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); $self->throw("The supplied Taxon must belong to this database") unless $taxon->db_handle && $taxon->db_handle eq $self; my $id = $taxon->id || $self->throw("The supplied Taxon is missing its id!"); my @children_ids = keys %{$RELATIONS->{children}->{$id} || {}}; my @children; foreach my $child_id (@children_ids) { push(@children, $self->_make_taxon($DATA_CACHE->{full_info}->{$child_id} || $DATA_CACHE->{minimal_info}->{$child_id})); } return @children; } =head2 Some Get/Setter methods =head2 entrez_url Title : entrez_url Usage : $obj->entrez_url($newval) Function: Get/set entrez URL Returns : value of entrez url (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub entrez_url{ my $self = shift; return $self->{'_entrez_url'} = shift if @_; return $self->{'_entrez_url'}; } =head2 entrez_params Title : entrez_params Usage : $obj->entrez_params($newval) Function: Get/set entrez params Returns : value of entrez_params (a hashref) Args : on set, new value Hashref =cut sub entrez_params{ my $self = shift; my $f; if( @_ ) { $f = $self->{'_entrez_params'} = shift; } else { $f = $self->{'_entrez_params'}; } return %$f; } =head2 Bio::DB::WebBase methods =head2 proxy_string Title : proxy_string Usage : my $proxy_string = $self->proxy_string($protocol) Function: Get the proxy string (plus user/pass ) Returns : string Args : protocol ('http' or 'ftp'), default 'http' =head2 proxy Title : proxy Usage : $httpproxy = $db->proxy('http') or $db->proxy(['http','ftp'], 'http://myproxy' ) Function: Get/Set a proxy for use of proxy Returns : a string indicating the proxy Args : $protocol : an array ref of the protocol(s) to set/get $proxyurl : url of the proxy to use for the specified protocol $username : username (if proxy requires authentication) $password : password (if proxy requires authentication) =head2 authentication Title : authentication Usage : $db->authentication($user,$pass) Function: Get/Set authentication credentials Returns : Array of user/pass Args : Array or user/pass =cut # make a Taxon object from data hash ref sub _make_taxon { my ($self, $data) = @_; my $taxon = Bio::Taxon->new(); my $taxid; while (my ($method, $value) = each %{$data}) { if ($method eq 'id') { $method = 'ncbi_taxid'; # since this is a real ncbi taxid, explicitly set it as one $taxid = $value; } $taxon->$method(ref($value) eq 'ARRAY' ? @{$value} : $value); } # we can't use -dbh or the db_handle() method ourselves or we'll go # infinite on the merge attempt $taxon->{'db_handle'} = $self; $self->_handle_internal_id($taxon); return $taxon; } sub _build_url { # Given a eutility (esearch.fcgi, efetch.fcgi or esummary.fcgi) and a # hashref or parameters, build a url suitable for eutil query my ($self, $eutility, $p) = @_; my $params = join($UrlParamSeparatorValue, map { $_.'='.$p->{$_} } keys %$p); my $url = $self->entrez_url.$eutility.'?'.$params; $self->debug("url is $url\n"); return $url; } sub _run_query { # Given an eutil url, run the eutil query and parse the response into an # XML Twig object my ($self, $url) = @_; my $response = $self->get($url); if ($response->is_success) { $response = $response->content; }else { $self->throw("Can't query website: ".$response->status_line); } $self->debug("response is $response\n"); my $twig = XML::Twig->new; $twig->parse($response); return $twig; } 1; BioPerl-1.6.923/Bio/DB/Taxonomy/flatfile.pm000444000765000024 4110312254227340 20414 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Taxonomy::flatfile # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Taxonomy::flatfile - Use the NCBI taxonomy from local indexed flat files =head1 SYNOPSIS use Bio::DB::Taxonomy; my $db = Bio::DB::Taxonomy->new(-source => 'flatfile' , -nodesfile => 'nodes.dmp', -namesfile => 'names.dmp'); =head1 DESCRIPTION This is an implementation of Bio::DB::Taxonomy which stores and accesses the NCBI taxonomy using flat files stored locally on disk and indexed using the DB_File module RECNO data structure for fast retrieval. The required database files, nodes.dmp and names.dmp can be obtained from ftp://ftp.ncbi.nih.gov/pub/taxonomy/taxdump.tar.gz =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Sendu Bala: bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Taxonomy::flatfile; use vars qw($DEFAULT_INDEX_DIR $DEFAULT_NODE_INDEX $DEFAULT_NAME2ID_INDEX $DEFAULT_ID2NAME_INDEX $DEFAULT_PARENT_INDEX @DIVISIONS); use strict; use DB_File; use Bio::Taxon; use File::Spec::Functions; use constant SEPARATOR => ':'; $DEFAULT_INDEX_DIR = $Bio::Root::IO::TEMPDIR; # /tmp $DEFAULT_NODE_INDEX = 'nodes'; $DEFAULT_NAME2ID_INDEX = 'names2id'; $DEFAULT_ID2NAME_INDEX = 'id2names'; $DEFAULT_PARENT_INDEX = 'parents'; $DB_BTREE->{'flags'} = R_DUP; # allow duplicate values in DB_File BTREEs @DIVISIONS = ([qw(BCT Bacteria)], [qw(INV Invertebrates)], [qw(MAM Mammals)], [qw(PHG Phages)], [qw(PLN Plants)], # (and fungi) [qw(PRI Primates)], [qw(ROD Rodents)], [qw(SYN Synthetic)], [qw(UNA Unassigned)], [qw(VRL Viruses)], [qw(VRT Vertebrates)], [qw(ENV 'Environmental samples')]); use base qw(Bio::DB::Taxonomy); =head2 new Title : new Usage : my $obj = Bio::DB::Taxonomy::flatfile->new(); Function: Builds a new Bio::DB::Taxonomy::flatfile object Returns : an instance of Bio::DB::Taxonomy::flatfile Args : -directory => name of directory where index files should be created -nodesfile => name of file containing nodes (nodes.dmp from NCBI) -namesfile => name of the file containing names(names.dmp from NCBI) -force => 1 to replace current indexes even if they exist =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($dir,$nodesfile,$namesfile,$force) = $self->_rearrange([qw(DIRECTORY NODESFILE NAMESFILE FORCE)], @args); $self->index_directory($dir || $DEFAULT_INDEX_DIR); if ( $nodesfile ) { $self->_build_index($nodesfile,$namesfile,$force); } $self->_db_connect; return $self; } =head2 Bio::DB::Taxonomy interface implementation =head2 get_num_taxa Title : get_num_taxa Usage : my $num = $db->get_num_taxa(); Function: Get the number of taxa stored in the database. Returns : A number Args : None =cut sub get_num_taxa { my ($self) = @_; if (not exists $self->{_num_taxa}) { my $num = 0; while ( my ($parent, undef) = each %{$self->{_parent2children}} ) { $num++; } $self->{_num_taxa} = $num; } return $self->{_num_taxa}; } =head2 get_taxon Title : get_taxon Usage : my $taxon = $db->get_taxon(-taxonid => $taxonid) Function: Get a Bio::Taxon object from the database. Returns : Bio::Taxon object Args : just a single value which is the database id, OR named args: -taxonid => taxonomy id (to query by taxonid) OR -name => string (to query by a taxonomy name: common name, scientific name, etc) =cut sub get_taxon { my ($self) = shift; my ($taxonid, $name); if (@_ > 1) { ($taxonid, $name) = $self->_rearrange([qw(TAXONID NAME)],@_); if ($name) { ($taxonid, my @others) = $self->get_taxonids($name); $self->warn("There were multiple ids ($taxonid @others) matching '$name', using '$taxonid'") if @others > 0; } } else { $taxonid = shift; } return unless $taxonid; $taxonid =~ /^\d+$/ || return; my $node = $self->{'_nodes'}->[$taxonid] || return; length($node) || return; my ($taxid, undef, $rank, $code, $divid, $gen_code, $mito) = split(SEPARATOR,$node); last unless defined $taxid; my ($taxon_names) = $self->{'_id2name'}->[$taxid]; my ($sci_name, @common_names) = split(SEPARATOR, $taxon_names); my $taxon = Bio::Taxon->new( -name => $sci_name, -common_names => [@common_names], -ncbi_taxid => $taxid, # since this is a real ncbi taxid, explicitly set it as one -rank => $rank, -division => $DIVISIONS[$divid]->[1], -genetic_code => $gen_code, -mito_genetic_code => $mito ); # we can't use -dbh or the db_handle() method ourselves or we'll go # infinite on the merge attempt $taxon->{'db_handle'} = $self; $self->_handle_internal_id($taxon); return $taxon; } *get_Taxonomy_Node = \&get_taxon; =head2 get_taxonids Title : get_taxonids Usage : my @taxonids = $db->get_taxonids('Homo sapiens'); Function: Searches for a taxonid (typically ncbi_taxon_id) based on a query string. Note that multiple taxonids can match to the same supplied name. Returns : array of integer ids in list context, one of these in scalar context Args : string representing taxon's name =cut sub get_taxonids { my ($self, $query) = @_; my $ids = $self->{'_name2id'}->{lc($query)}; unless ($ids) { if ($query =~ /_/) { # try again converting underscores to spaces $query =~ s/_/ /g; $ids = $self->{'_name2id'}->{lc($query)}; } $ids || return; } my @ids = split(SEPARATOR, $ids); return wantarray() ? @ids : shift @ids; } *get_taxonid = \&get_taxonids; =head2 get_Children_Taxids Title : get_Children_Taxids Usage : my @childrenids = $db->get_Children_Taxids Function: Get the ids of the children of a node in the taxonomy Returns : Array of Ids Args : Bio::Taxon or a taxon_id Status : deprecated (use each_Descendent()) =cut sub get_Children_Taxids { my ($self, $node) = @_; $self->warn("get_Children_Taxids is deprecated, use each_Descendent instead"); my $id; if( ref($node) ) { if( $node->can('object_id') ) { $id = $node->object_id; } elsif( $node->can('ncbi_taxid') ) { $id = $node->ncbi_taxid; } else { $self->warn("Don't know how to extract a taxon id from the object of type ".ref($node)."\n"); return; } } else { $id = $node } my @vals = $self->{'_parentbtree'}->get_dup($id); return @vals; } =head2 ancestor Title : ancestor Usage : my $ancestor_taxon = $db->ancestor($taxon) Function: Retrieve the full ancestor taxon of a supplied Taxon from the database. Returns : Bio::Taxon Args : Bio::Taxon (that was retrieved from this database) =cut sub ancestor { my ($self, $taxon) = @_; $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); $self->throw("The supplied Taxon must belong to this database") unless $taxon->db_handle && $taxon->db_handle eq $self; my $id = $taxon->id || $self->throw("The supplied Taxon is missing its id!"); my $node = $self->{'_nodes'}->[$id]; if (length($node)) { my (undef, $parent_id) = split(SEPARATOR,$node); $parent_id || return; $parent_id eq $id && return; # one of the roots return $self->get_taxon($parent_id); } return; } =head2 each_Descendent Title : each_Descendent Usage : my @taxa = $db->each_Descendent($taxon); Function: Get all the descendents of the supplied Taxon (but not their descendents, ie. not a recursive fetchall). Returns : Array of Bio::Taxon objects Args : Bio::Taxon (that was retrieved from this database) =cut sub each_Descendent { my ($self, $taxon) = @_; $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); $self->throw("The supplied Taxon must belong to this database") unless $taxon->db_handle && $taxon->db_handle eq $self; my $id = $taxon->id || $self->throw("The supplied Taxon is missing its id!"); my @desc_ids = $self->{'_parentbtree'}->get_dup($id); my @descs; foreach my $desc_id (@desc_ids) { push(@descs, $self->get_taxon($desc_id) || next); } return @descs; } =head2 Helper methods =cut # internal method which does the indexing sub _build_index { my ($self, $nodesfile, $namesfile, $force) = @_; my $dir = $self->index_directory; my $nodeindex = catfile($dir, $DEFAULT_NODE_INDEX); my $name2idindex = catfile($dir, $DEFAULT_NAME2ID_INDEX); my $id2nameindex = catfile($dir, $DEFAULT_ID2NAME_INDEX); my $parent2childindex = catfile($dir, $DEFAULT_PARENT_INDEX); $self->{'_nodes'} = []; $self->{'_id2name'} = []; $self->{'_name2id'} = {}; $self->{'_parent2children'} = {}; if (! -e $nodeindex || $force) { my (%parent2children,@nodes); open(NODES,$nodesfile) || $self->throw("Cannot open node file '$nodesfile' for reading"); unlink $nodeindex; unlink $parent2childindex; my $nh = tie ( @nodes, 'DB_File', $nodeindex, O_RDWR|O_CREAT, 0644, $DB_RECNO) || $self->throw("Cannot open file '$nodeindex': $!"); my $btree = tie( %parent2children, 'DB_File', $parent2childindex, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot tie to file '$parent2childindex': $!"); while () { next if /^$/; chomp; my ($taxid,$parent,$rank,$code,$divid,undef,$gen_code,undef,$mito) = split(/\t\|\t/,$_); # don't include the fake root node 'root' with id 1; we essentially have multiple roots here next if $taxid == 1; if ($parent == 1) { $parent = $taxid; } # keep this stringified $nodes[$taxid] = join(SEPARATOR, ($taxid,$parent,$rank,$code,$divid,$gen_code,$mito)); $btree->put($parent,$taxid); } close(NODES); $nh = $btree = undef; untie @nodes ; untie %parent2children; } if ((! -e $name2idindex || -z $name2idindex) || (! -e $id2nameindex || -z $id2nameindex) || $force) { open(NAMES,$namesfile) || $self->throw("Cannot open names file '$namesfile' for reading"); unlink $name2idindex; unlink $id2nameindex; my (@id2name,%name2id); my $idh = tie (@id2name, 'DB_File', $id2nameindex, O_RDWR|O_CREAT, 0644, $DB_RECNO) || $self->throw("Cannot tie to file '$id2nameindex': $!"); my $nameh = tie ( %name2id, 'DB_File', $name2idindex, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot tie to file '$name2idindex': $!"); while () { next if /^$/; chomp; my ($taxid, $name, $unique_name, $class) = split(/\t\|\t/,$_); # don't include the fake root node 'root' or 'all' with id 1 next if $taxid == 1; $class =~ s/\s+\|\s*$//; my $lc_name = lc($name); my $orig_name = $name; # unique names aren't always in the correct column, sometimes they # are uniqued by adding bracketed rank names to the normal name; # store the uniqued version then fix the name for normal use if ($lc_name =~ /\(class\)$/) { # it seems that only rank of class is ever used in this situation $name2id{$lc_name} = $taxid; $name =~ s/\s+\(class\)$//; $lc_name = lc($name); } # handle normal names which aren't necessarily unique my $taxids = $name2id{$lc_name} || ''; my %taxids = map { $_ => 1 } split(SEPARATOR, $taxids); unless (exists $taxids{$taxid}) { $taxids{$taxid} = 1; $name2id{$lc_name} = join(SEPARATOR, keys %taxids); } # store unique names in name2id if ($unique_name) { $name2id{lc($unique_name)} = $taxid; } # store all names in id2name array my $names = $id2name[$taxid] || ''; my @names = split(SEPARATOR, $names); if ($class && $class eq 'scientific name') { # the scientific name should be the first name stored unshift(@names, $name); push(@names, $orig_name) if ($orig_name ne $name); push(@names, $unique_name) if $unique_name; } else { # all other ('common' in this simplification) names get added after push(@names, $name); push(@names, $orig_name) if ($orig_name ne $name); push(@names, $unique_name) if $unique_name; } $id2name[$taxid] = join(SEPARATOR, @names); } close(NAMES); $idh = $nameh = undef; untie( %name2id); untie( @id2name); } } # connect the internal db handle sub _db_connect { my $self = shift; return if $self->{'_initialized'}; my $dir = $self->index_directory; my $nodeindex = catfile($dir, $DEFAULT_NODE_INDEX); my $name2idindex = catfile($dir, $DEFAULT_NAME2ID_INDEX); my $id2nameindex = catfile($dir, $DEFAULT_ID2NAME_INDEX); my $parent2childindex = catfile($dir, $DEFAULT_PARENT_INDEX); $self->{'_nodes'} = []; $self->{'_id2name'} = []; $self->{'_name2id'} = {}; $self->{'_parent2children'} = {}; if( ! -e $nodeindex || ! -e $name2idindex || ! -e $id2nameindex ) { $self->warn("Index files have not been created"); return 0; } tie ( @{$self->{'_nodes'}}, 'DB_File', $nodeindex, O_RDWR,undef, $DB_RECNO) || $self->throw("$! $nodeindex"); tie (@{$self->{'_id2name'}}, 'DB_File', $id2nameindex,O_RDWR, undef, $DB_RECNO) || $self->throw("$! $id2nameindex"); tie ( %{$self->{'_name2id'}}, 'DB_File', $name2idindex, O_RDWR,undef, $DB_HASH) || $self->throw("$! $name2idindex"); $self->{'_parentbtree'} = tie( %{$self->{'_parent2children'}}, 'DB_File', $parent2childindex, O_RDWR, 0644, $DB_BTREE); $self->{'_initialized'} = 1; } =head2 index_directory Title : index_directory Funtion : Get/set the location that index files are stored. (this module will index the supplied database) Usage : $obj->index_directory($newval) Returns : value of index_directory (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub index_directory { my $self = shift; return $self->{'index_directory'} = shift if @_; return $self->{'index_directory'}; } 1; BioPerl-1.6.923/Bio/DB/Taxonomy/greengenes.pm000444000765000024 1121312254227323 20750 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Taxonomy::greengenes # # Please direct questions and support issues to # # Cared for by Florent Angly # # Copyright Florent Angly # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Taxonomy::greengenes - Use the Greengenes taxonomy =head1 SYNOPSIS use Bio::DB::Taxonomy; my $db = Bio::DB::Taxonomy->new( -source => 'greengenes', -taxofile => 'taxonomy_16S_candiv_gg_2011_1.txt' ); =head1 DESCRIPTION I Bio::DB::Taxonomy::greengenes is an implementation of Bio::DB::Taxonomy which stores and accesses the Greengenes taxonomy of Bacteria and Archaea. Internally, it keeps the taxonomy into memory by using Bio::DB::Taxonomy::list. As a consequence, note that the IDs assigned to the taxonomy nodes, e.g. gg123, are arbitrary, contrary to the pre-defined IDs that NCBI assigns to taxons. The latest release of the Greengene taxonomy (2011) contains about 4,600 taxa and occupies about 4MB of memory once parsed into a Bio::DB::Taxonomy::greengenes object. The taxonomy files taxonomy_16S_all_gg_2011_1.txt and taxonomy_16S_candiv_gg_2011_1.txt that this module can use are available from L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Florent Angly florent.angly@gmail.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Taxonomy::greengenes; use strict; use base qw(Bio::DB::Taxonomy Bio::DB::Taxonomy::list); $Bio::DB::Taxonomy::list::prefix = 'gg'; =head2 new Title : new Usage : my $obj = Bio::DB::Taxonomy::greengenes->new(); Function: Builds a new Bio::DB::Taxonomy::greengenes object Returns : an instance of Bio::DB::Taxonomy::greengenes Args : -taxofile => name of the file containing the taxonomic information, typically 'taxonomy_16S_candiv_gg_2011_1.txt' (mandatory) =cut sub new { # Override Bio::DB::Taxonomy my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($taxofile) = $self->_rearrange([qw(TAXOFILE)], @args); if ( $taxofile ) { $self = $self->_build_taxonomy($taxofile); } return $self; } sub _build_taxonomy { my ($self, $taxofile) = @_; my $all_ranks = ['kingdom', 'phylum', 'class', 'order', 'family', 'genus', 'species']; my $taxonomy = Bio::DB::Taxonomy::list->new(); open my $fh, '<', $taxofile or $self->throw("Could not read file $taxofile: $!"); # Will skip header line: prokMSA_id taxonomy my $prev_taxo_string = 'taxonomy'; my $line; # Parse taxonomy lines. Example: # 348902 k__Bacteria; p__Bacteroidetes; c__Bacteroidia; o__Bacteroidales; f__Bacteroidaceae; g__Bacteroides; s__Bacteroides plebeius while ($line = <$fh>) { chomp $line; my ($prokmsa_id, $taxo_string) = split "\t", $line; # Skip taxonomy string already seen on previous line (much faster!) next if $taxo_string eq $prev_taxo_string; $prev_taxo_string = $taxo_string; # Remove ambiguous taxons, i.e. go from: # k__Archaea; p__pMC2A384; c__; o__; f__; g__; s__ # to: # k__Archaea; p__pMC2A384 my $names = [split /;\s*/, $taxo_string]; while ( ($names->[-1] || '') =~ m/__$/) { pop @$names; } my $nof_ranks = scalar @$names; next if $nof_ranks < 1; $taxonomy->add_lineage( -ranks => [ @{$all_ranks}[0..$nof_ranks-1] ], -names => $names, ); } close $fh; return $taxonomy; } 1; BioPerl-1.6.923/Bio/DB/Taxonomy/list.pm000444000765000024 3702112254227332 17606 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Taxonomy::list # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::Taxonomy::list - An implementation of Bio::DB::Taxonomy that accepts lists of words to build a database =head1 SYNOPSIS use Bio::DB::Taxonomy; my $db = Bio::DB::Taxonomy->new( -source => 'list' ); my @ranks = ('superkingdom', 'class', 'genus', 'species'); my @names = ('Eukaryota', 'Mammalia', 'Homo', 'Homo sapiens'); $db->add_lineage(-names => \@names, -ranks => \@ranks); @names = ('Eukaryota', 'Mammalia', 'Mus', 'Mus musculus'); $db->add_lineage(-names => \@names, -ranks => \@ranks); =head1 DESCRIPTION This is an implementation which uses supplied lists of words to create a database from which you can extract Bio::Taxon objects. =head1 TODO It is possible this module could do something like store the data it builds up to disc. Would that be useful? At any rate, this is why the module is called 'list' and not 'in_memory' or similar. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::Taxonomy::list; use strict; use Bio::Taxon; use base qw(Bio::DB::Taxonomy); our $prefix = 'list'; =head2 new Title : new Usage : my $obj = Bio::DB::Taxonomy::list->new(); Function: Builds a new Bio::DB::Taxonomy::list object Returns : an instance of Bio::DB::Taxonomy::list Args : optional, as per the add_lineage() method. =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my %args = @args; delete $args{'-source'}; $self->add_lineage(%args) if %args; return $self; } =head2 add_lineage Title : add_lineage Usage : my @names = ('Eukaryota', 'Mammalia', 'Homo', 'Homo sapiens'); my @ranks = ('superkingdom', 'class', 'genus', 'species'); $db->add_lineage( -names => \@names, -ranks => \@ranks ); Function: Add a lineage to the database, where the lineage is described by a list of scientific names in the order root->leaf. The rank of each name can optionally be described by supplying an additional list of rank names in the same order (eg. superkingdom->species). Returns : 1 for success Args : -names => [] : array ref of scientific names, REQUIRED -ranks => [] : array ref of rank names, same order as above, OPTIONAL =cut sub add_lineage { my ($self, @args) = @_; my ($names, $ranks) = $self->_rearrange([qw (NAMES RANKS)], @args); $self->throw("-names must be supplied and its value must be an array reference") unless $names && ref($names) eq 'ARRAY'; my $names_idx = scalar @$names - 1; if ($ranks) { $self->throw("-ranks must be an array reference") unless ref($ranks) eq 'ARRAY'; $self->throw("The -names and -ranks lists must be of equal length") unless $names_idx == scalar @$ranks - 1; } # This is non-trivial because names are not guaranteed unique in a taxonomy, # and neither are name&rank combinations. Furthermore, different name&rank # combinations can actually refer to the same taxon, eg. when one time # 'Homo'&'genus' is supplied, while another time 'Homo'&'no rank'. # # name&rank&ancestor could well be unique (or good enough 99.9999% of the # time), but we have the added complication that lineages could sometimes be # supplied with differing numbers of taxa. Ideally we want to realise that # the first of these two lineages shares all its nodes with the second: # ('Mammalia', 'Homo', 'Homo sapiens') # ('Mammalia', 'Hominidae', 'Homo', 'Homo sapiens') # # Clearly with limited information we can't do a perfect job, but we can try # and do a reasonable one. So, let's just do the trivial implementation now # and see how bad it is! (assumes ranks are unique except for 'no rank') my $ancestors = $self->{ancestors}; my $node_data = $self->{node_data}; my $name_to_id = $self->{name_to_id}; my $children = $self->{children}; my $my_ancestor_id = ''; my @node_ids; for my $i (0 .. $names_idx) { my $name = $names->[$i]; my $rank = $ranks->[$i]; # if undef, this node has 'no rank' # This is a new node with a new id if we haven't seen this name before. # It's also always a new node if this is the first lineage going into # the db. # # We need to handle, however, situations in the future where we try to # merge in a new lineage but we have non-unique names in the lineage # and possible missing classes in some lineages, e.g. # '... Anophelinae, Anopheles, Anopheles, Angusticorn, Anopheles...' # merged with # '... Anophelinae, Anopheles, Angusticorn, Anopheles...'), # but still need the 'tree' to be correct # Look for a node that is consistent with this lineage my $node_id; SAME_NAMED: for my $same_id (@{$name_to_id->{$name}}) { # Taxa are the same if it they have the same ancestor or none my $this_ancestor_id = $ancestors->{$same_id} || ''; if ($my_ancestor_id eq $this_ancestor_id) { $node_id = $same_id; last SAME_NAMED; } # Compare children next if $i >= $names_idx; # this taxon has no child my $my_child_name = $names->[$i + 1]; #while ( my ($this_child_id, undef) = each %{$children->{$same_id}} ) { for my $this_child_id (keys %{$children->{$same_id}}) { if ($my_child_name eq $node_data->{$this_child_id}->[0]) { # both children have same name if ($my_ancestor_id) { my @s_ancestors; while ($this_ancestor_id = $ancestors->{$this_ancestor_id}) { if ($my_ancestor_id eq $this_ancestor_id) { $my_ancestor_id = $ancestors->{$same_id}; push @node_ids, @s_ancestors, $my_ancestor_id; $node_id = $same_id; last SAME_NAMED; } unshift @s_ancestors, $this_ancestor_id; } } else { # This new lineage (@$names) doesn't start at the # same root as the existing lineages. Assuming # '$name' corresponds to node $same_id"); $node_id = $same_id; last SAME_NAMED; } } } } if (not defined $node_id) { # This is a new node. Add it to the database, using the prefix 'list' # for its ID to distinguish it from the IDs from other taxonomies. my $next_num = ++$self->{node_ids}; $node_id = $prefix.$next_num; push @{$self->{name_to_id}->{$name}}, $node_id; $self->{node_data}->{$node_id}->[0] = $name; } if ( (defined $rank) && (not defined $node_data->{$node_id}->[1]) ) { # Save rank if node in database has no rank but the current node has one $self->{node_data}->{$node_id}->[1] = $rank; } if ($my_ancestor_id) { if ($self->{ancestors}->{$node_id} && $self->{ancestors}->{$node_id} ne $my_ancestor_id) { $self->throw("The lineage '".join(', ', @$names)."' and a ". "previously stored lineage share a node name but have ". "different ancestries for that node. Can't cope!"); } $self->{ancestors}->{$node_id} = $my_ancestor_id; } $my_ancestor_id = $node_id; push @node_ids, $node_id; } # Go through the lineage in reverse so we can remember the children for (my $i = $names_idx - 1; $i >= 0; $i--) { $self->{children}->{$node_ids[$i]}->{$node_ids[$i+1]} = undef; } return 1; } =head2 Bio::DB::Taxonomy Interface implementation =head2 get_num_taxa Title : get_num_taxa Usage : my $num = $db->get_num_taxa(); Function: Get the number of taxa stored in the database. Returns : A number Args : None =cut sub get_num_taxa { my ($self) = @_; return $self->{node_ids} || 0; } =head2 get_taxon Title : get_taxon Usage : my $taxon = $db->get_taxon(-taxonid => $taxonid) Function: Get a Bio::Taxon object from the database. Returns : Bio::Taxon object Args : A single value which is the ID of the taxon to retrieve OR named args, as follows: -taxonid => Taxonomy ID (NB: these are not NCBI taxonomy ids but 'list' pre-fixed ids unique to the list database). OR -name => String (to query by a taxonomy name). A given taxon name can match different taxonomy objects. When that is the case, a warning is displayed and the first matching taxon is reported. See get_taxonids() to get all matching taxon IDs. OR -names => Array ref of lineage names, like in add_lineage(). To overcome the limitations of -name, you can use -names to provide the full lineage of the taxon you want and get a unique, unambiguous taxon object. =cut sub get_taxon { my ($self, @args) = @_; my $taxonid; if (scalar @args == 1) { # Argument is a taxon ID $taxonid = $args[0]; } else { # Got named arguments my ($name, $names); ($taxonid, $name, $names) = $self->_rearrange([qw(TAXONID NAME NAMES)], @args); if ($name) { $names = [$name]; } if ($names) { $name = $names->[-1]; my @taxonids = $self->get_taxonids($name); $taxonid = $taxonids[0]; # Use provided lineage to find correct ID amongst several matching IDs if ( (scalar @taxonids > 1) && (scalar @$names > 1) ) { for my $query_taxonid (@taxonids) { my $matched = 1; my $db_ancestor = $self->get_taxon($query_taxonid); for (my $i = $#$names-1; $i >= 0; $i--) { my $query_ancestor_name = $names->[$i]; $db_ancestor = $db_ancestor->ancestor; my $db_ancestor_name = ''; if ($db_ancestor) { $db_ancestor_name = $db_ancestor->node_name; } if (not ($query_ancestor_name eq $db_ancestor_name) ) { $matched = 0; last; # done testing this taxonid } } if ($matched == 1) { @taxonids = [$query_taxonid]; $taxonid = $query_taxonid; last; # done testing all taxonids } } } # Warn if several taxon IDs matched if (scalar @taxonids > 1) { $self->warn("There were multiple ids (@taxonids) matching '$name',". " using '$taxonid'") if scalar @taxonids > 1; } } } # Now that we have the taxon ID, retrieve the corresponding Taxon object my $taxon; my $node = $self->{node_data}->{$taxonid}; if ($node) { my ($sci_name, $rank) = @$node; $taxon = Bio::Taxon->new( -name => $sci_name, -object_id => $taxonid, # not an ncbi taxid, simply an object id ); if ($rank) { $taxon->rank($rank); } # we can't use -dbh or the db_handle() method ourselves or we'll go # infinite on the merge attempt $taxon->{'db_handle'} = $self; $self->_handle_internal_id($taxon, 1); } return $taxon; } *get_Taxonomy_Node = \&get_taxon; =head2 get_taxonids Title : get_taxonids Usage : my @taxonids = $db->get_taxonids('Homo sapiens'); Function: Searches for a taxonid (generated by the list module) based on a query string. Note that multiple taxonids can match to the same supplied name. Returns : array of integer ids in list context, one of these in scalar context Args : string representing taxon's name =cut sub get_taxonids { my ($self, $name) = @_; return wantarray() ? @{$self->{name_to_id}->{$name} || []} : $self->{name_to_id}->{$name}->[0]; } *get_taxonid = \&get_taxonids; =head2 ancestor Title : ancestor Usage : my $ancestor_taxon = $db->ancestor($taxon) Function: Retrieve the full ancestor taxon of a supplied Taxon from the database. Returns : Bio::Taxon Args : Bio::Taxon (that was retrieved from this database) =cut sub ancestor { my ($self, $taxon) = @_; $taxon || return; # for bug 2092, or something similar to it at least: shouldn't need this! $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); $self->throw("The supplied Taxon must belong to this database") unless $taxon->db_handle && $taxon->db_handle eq $self; my $id = $taxon->id || $self->throw("The supplied Taxon is missing its id!"); my $ancestor_id = $self->{ancestors}->{$id} || return; return $self->get_taxon($ancestor_id); } =head2 each_Descendent Title : each_Descendent Usage : my @taxa = $db->each_Descendent($taxon); Function: Get all the descendents of the supplied Taxon (but not their descendents, ie. not a recursive fetchall). Returns : Array of Bio::Taxon objects Args : Bio::Taxon (that was retrieved from this database) =cut sub each_Descendent { my ($self, $taxon) = @_; $self->throw("Must supply a Bio::Taxon") unless ref($taxon) && $taxon->isa('Bio::Taxon'); $self->throw("The supplied Taxon must belong to this database") unless $taxon->db_handle && $taxon->db_handle eq $self; my $id = $taxon->id || $self->throw("The supplied Taxon is missing its id!"); my @children; while ( my ($child_id, undef) = each %{$self->{children}->{$id}} ) { push @children, ($self->get_taxon($child_id) || next); } return @children; } 1; BioPerl-1.6.923/Bio/DB/Taxonomy/silva.pm000444000765000024 1110712254227315 17747 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::DB::Taxonomy::silva # # Please direct questions and support issues to # # Copyright Florent Angly # # You may distribute this module under the same terms as perl itself =head1 NAME Bio::DB::Taxonomy::silva - Use the Silva taxonomy =head1 SYNOPSIS use Bio::DB::Taxonomy; my $db = Bio::DB::Taxonomy->new( -source => 'silva', -taxofile => 'SSURef_108_tax_silva_trunc.fasta', ); =head1 DESCRIPTION This is an implementation of Bio::DB::Taxonomy which stores and accesses the Silva taxonomy. Internally, Bio::DB::Taxonomy::silva keeps the taxonomy into memory by using Bio::DB::Taxonomy::list. As a consequence, note that the IDs assigned to the taxonomy nodes, e.g. sv72, are arbitrary, contrary to the pre-defined IDs that NCBI assigns to taxons. Note also that no rank names or common names are assigned to the taxa of Bio::DB::Taxonomy::silva. The latest Silva taxonomy (2011) contains about 126,000 taxa and occupies about 124 MB of memory once parsed into a Bio::DB::Taxonomy::silva object. Obviously, it can take a little while to load. The taxonomy file SSURef_108_tax_silva_trunc.fasta that this module uses is available from L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Florent Angly florent.angly@gmail.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::DB::Taxonomy::silva; use strict; use Bio::SeqIO; use base qw(Bio::DB::Taxonomy Bio::DB::Taxonomy::list); $Bio::DB::Taxonomy::list::prefix = 'sv'; =head2 new Title : new Usage : my $obj = Bio::DB::Taxonomy::silva->new(); Function: Builds a new Bio::DB::Taxonomy::silva object Returns : an instance of Bio::DB::Taxonomy::silva Args : -taxofile => name of the FASTA file containing the taxonomic information, typically 'SSURef_108_tax_silva_trunc.fasta' (mandatory) =cut sub new { # Override Bio::DB::Taxonomy my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($taxofile) = $self->_rearrange([qw(TAXOFILE)], @args); if ( $taxofile ) { $self = $self->_build_taxonomy($taxofile); } return $self; } sub _build_taxonomy { my ($self, $taxofile) = @_; my $taxonomy = Bio::DB::Taxonomy::list->new(); my %taxas; my $desc_re = qr/^>\S+?(?:\s+(.+))?$/; # One could open the file using Bio::SeqIO::fasta, but it is slower and we # only need the sequence descriptions open my $in, '<', $taxofile or $self->throw("Could not read file '$taxofile': $!\n"); # Populate taxonomy with taxonomy obtained from sequence description while (my $line = <$in>) { next if $line !~ $desc_re; my $taxo_string = $1; next if not $taxo_string; # Example of taxonomy string: # 1/ Bacteria;Firmicutes;Bacilli;Lactobacillales;Enterococcaceae;Enterococcus;Enterococcus faecium DO # 2/ Eukaryota;Metazoa;Chordata;Craniata;Vertebrata;Euteleostomi;Mammalia;Eutheria;Euarchontoglires;Glires; # Rodentia;Sciurognathi;Muroidea;Muridae;Murinae;Rattus;;Rattus norvegicus (Norway rat) # Skip already seen taxas next if exists $taxas{$taxo_string}; $taxas{$taxo_string} = undef; # Strip the common name (could save it if Bio::DB::Taxonomy::list supported it) $taxo_string =~ s/ \(.*\)$//; # Save lineage # Unfortunately, we cannot easily add ranks since they vary from 2 to 23 for every entry my @names = split /;/, $taxo_string; $taxonomy->add_lineage( -names => \@names, ); } close $in; return $taxonomy; } 1; BioPerl-1.6.923/Bio/DB/TFBS000755000765000024 012254227316 15037 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/DB/TFBS/transfac_pro.pm000444000765000024 23456012254227316 20265 0ustar00cjfieldsstaff000000000000# $Id: transfac_pro.pm,v 1.15 2006/08/12 11:00:03 sendu Exp $ # # BioPerl module for Bio::DB::TFBS::transfac_pro # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::DB::TFBS::transfac_pro - An implementation of Bio::DB::TFBS which uses local flat files for transfac pro =head1 SYNOPSIS use Bio::DB::Taxonomy; my $db = new Bio::DB::Taxonomy(-source => 'transfac_pro' -dat_dir => $directory); # we're interested in the gene P5 my ($gene_id) = $db->get_gene_ids(-name => 'P5'); # G000001 # we want all the transcription factors that bind to our gene my @factor_ids = $db->get_factor_ids(-gene => $gene_id); # get info about those TFs foreach my $factor_id (@factor_ids) { my $factor = $db->get_factor($factor_id); my $name = $factor->universal_name; # etc. - see Bio::Map::TranscriptionFactor, eg. find out where it binds } # get a matrix my $matrix = $db->get_matrix('M00001'); # get a binding site sequence my $seq = $db->get_site('R00001'); =head1 DESCRIPTION This is an implementation which uses local flat files and the DB_File module RECNO data structures to manage a local copy of the Transfac Pro TFBS database. Required database files require a license which can be obtained via http://www.biobase-international.com/pages/index.php?id=170 Within the linux installation tarball you will find a cgibin tar ball, and inside that is a data directory containing the .dat files needed by this module. Point to that data directory with -dat_dir =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Based on Bio::DB::Taxonomy::flatfile by Jason Stajich =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::DB::TFBS::transfac_pro; use strict; use Bio::Annotation::Reference; use Bio::Annotation::SimpleValue; use Bio::LocatableSeq; use Bio::SimpleAlign; use Bio::Matrix::PSM::SiteMatrix; use Bio::AlignIO; use Bio::Map::GeneMap; use Bio::Map::TranscriptionFactor; use Bio::Map::Position; use Bio::Map::Relative; use DB_File; use constant SEPARATOR => ':!:'; use constant INTERNAL_SEPARATOR => '!:!'; $DB_BTREE->{'flags'} = R_DUP; # allow duplicate values in DB_File BTREEs use base qw(Bio::DB::TFBS); =head2 new Title : new Usage : my $obj = new Bio::DB::TFBS::transfac_pro(); Function: Builds a new Bio::DB::TFBS::transfac_pro object Returns : an instance of Bio::DB::TTFBS::transfac_pro Args : -dat_dir => name of directory where Transfac Pro .dat files (required to initially build indexes) -tax_db => Bio::DB::Taxonomy object, used when initially building indexes, gives better results for species information but not required. -index_dir => name of directory where index files should be created or already exist. (defaults to -dat_dir, required if -dat_dir not supplied) -force => 1 replace current indexes even if they exist =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($dat_dir, $index_dir, $tax_db, $force) = $self->_rearrange([qw(DAT_DIR INDEX_DIR TAX_DB FORCE)], @args); $self->throw("At least one of -dat_dir and -index_dir must be supplied") unless ($dat_dir || $index_dir); $self->index_directory($index_dir || $dat_dir); $self->{_tax_db} = $tax_db if $tax_db; if ($dat_dir) { $self->_build_index($dat_dir, $force); } $self->_db_connect; return $self; } =head2 Bio::DB::TFBS Interface implementation =cut sub _get_ids { my ($self, $dat, @args) = @_; @args % 2 == 0 || $self->throw("Must provide key => value pairs"); my $hash = $self->{$dat} || $self->throw("Unknown .dat type '$dat'"); if (@args) { # get a subset corresponding to args my @final; my %args = @args; my $multiple = 0; while (my ($type, $value) = each %args) { unless ($value) { $self->warn("Arguement '$type' has no value, ignored"); next; } $type =~ s/-//; $type = lc($type); my $converter = $hash->{$type}; unless ($converter) { $self->warn("Unknown search type '$type' for .dat type '$dat'"); next; } my @ids = $converter->get_dup($value); unless (@ids) { @ids = $converter->get_dup(lc($value)); } if ($multiple) { # we can have multiple types given at once, find the ids that # satisfy all criteria @final || return; my %final = map { $_ => 1 } @final; @final = grep { $final{$_} } @ids; } else { @final = @ids; $multiple++; } } return @final; } else { # get them all my $db_file_hash = $self->{$dat}->{id}; my ($key, $prev_key, $value) = ('_!_', '!_!'); my @ids; while (1) { $db_file_hash->seq($key, $value, R_NEXT); last if $prev_key eq $key; push(@ids, $value); # confusing? when creating objects we store # $value as accession and $key as id, but from # this method we return $value as id given $id! $prev_key = $key; } return @ids; } } =head2 get_reference Title : get_reference Usage : my $ref = $obj->get_reference($id); Function: Get a literature reference. Returns : Bio::Annotation::Reference Args : string - a reference id ('RE...') =cut sub get_reference { my ($self, $id) = @_; $id || return; my $data = $self->{reference}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); return Bio::Annotation::Reference->new(-pubmed => $data[0], -authors => $data[1], -title => $data[2], -location => $data[3] ); } =head2 get_genemap Title : get_genemap Usage : my $map = $obj->get_genemap($id); Function: Get a GeneMap for a gene. Returns : Bio::Map::GeneMap Args : string - a gene id ('G...'), and optionally int (number of bp upstream) =cut sub get_genemap { my ($self, $id, $upstream) = @_; $id || return; return $self->{got_map}->{$id} if defined $self->{got_map}->{$id}; $upstream ||= 1000; my $data = $self->{gene}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); # accession = id name description species_tax_id_or_raw_string my $taxon = $self->{_tax_db} ? $self->{_tax_db}->get_taxon($data[3]) || $data[3] : $data[3]; my $map = Bio::Map::GeneMap->get(-uid => $id, -gene => $data[1], -species => $taxon, -description => $data[2], -upstream => $upstream); $self->{got_map}->{$id} = $map; # prevents infinite recurse when we call get_factor below # spawn all the factors that belong on this gene map # get_factor_ids(-gene => ...) only works for genes that encode factors; # have to go via sites foreach my $sid ($self->get_site_ids(-gene => $id)) { foreach my $fid ($self->get_factor_ids(-site => $sid)) { # it is quite deliberate that we deeply recurse to arrive at the # correct answer, which involves pulling in most of the database no warnings "recursion"; $self->get_factor($fid); } } return $map; } =head2 get_seq Title : get_seq Usage : my $seq = $obj->get_seq($id); Function: Get the sequence of a site. The sequence will be annotated with the the tags 'relative_start', 'relative_end', 'relative_type' and 'relative_to'. Returns : Bio::Seq Args : string - a site id ('R...') =cut sub get_seq { my ($self, $id) = @_; $id || return; my $data = $self->{site}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); my $seq = Bio::Seq->new(-seq => $data[2], -accession_number => $id, -description => $data[6] ? 'Genomic sequence' : 'Consensus or artificial sequence', -id => $data[0], -strand => 1, -alphabet => $data[7] || 'dna', -species => $data[6]); my $annot = $seq->annotation; my $sv = Bio::Annotation::SimpleValue->new(-tagname => 'relative_start', -value => $data[4] || 1); $annot->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'relative_end', -value => $data[5] || ($data[4] || 1 + length($data[2]) - 1)); $annot->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'relative_type', -value => $data[3] || 'artificial'); $annot->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'relative_to', -value => $data[1]); $annot->add_Annotation($sv); return $seq; } =head2 get_fragment Title : get_fragment Usage : my $seq = $obj->get_fragment($id); Function: Get the sequence of a fragment. Returns : Bio::Seq Args : string - a site id ('FR...') =cut sub get_fragment { my ($self, $id) = @_; $id || return; my $data = $self->{fragment}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); # accession = id gene_id1 gene_id2 species_tax_id_or_raw_string sequence source return new Bio::Seq( -seq => $data[4], -accession_number => $id, -description => 'Between genes '.$data[1].' and '.$data[2], -species => $data[3], -id => $data[0], -alphabet => 'dna' ); } =head2 get_matrix Title : get_matrix Usage : my $matrix = $obj->get_matrix($id); Function: Get a matrix that describes a binding site. Returns : Bio::Matrix::PSM::SiteMatrix Args : string - a matrix id ('M...'), optionally a sequence string from which base frequencies will be calcualted for the matrix model (default 0.25 each) =cut sub get_matrix { my ($self, $id, $seq) = @_; $id || return; $seq ||= 'atgc'; $seq = lc($seq); my $data = $self->{matrix}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); $data[4] || $self->throw("Matrix data missing for $id"); my ($a, $c, $g, $t); foreach my $position (split(INTERNAL_SEPARATOR, $data[4])) { my ($a_count, $c_count, $g_count, $t_count) = split("\t", $position); push(@{$a}, $a_count); push(@{$c}, $c_count); push(@{$g}, $g_count); push(@{$t}, $t_count); } # our psms include a simple background model so we can use # sequence_match_weight() if desired my $a_freq = ($seq =~ tr/a//) / length($seq); my $c_freq = ($seq =~ tr/c//) / length($seq); my $g_freq = ($seq =~ tr/g//) / length($seq); my $t_freq = ($seq =~ tr/t//) / length($seq); my $psm = Bio::Matrix::PSM::SiteMatrix->new(-pA => $a, -pC => $c, -pG => $g, -pT => $t, -id => $data[0], -accession_number => $id, -sites => $data[3], -width => scalar(@{$a}), -correction => 1, -model => { A => $a_freq, C => $c_freq, G => $g_freq, T => $t_freq } ); #*** used to make a Bio::Matrix::PSM::Psm and add references, but it # didn't seem worth it. You can get references from the database by: #foreach my $ref_id ($db->get_reference_ids(-matrix => $id)) { # my $ref = $db->get_reference($ref_id); #} return $psm; } =head2 get_aln Title : get_aln Usage : my $aln = $obj->get_aln($id); Function: Get the alignment that was used to generate a matrix. Each sequence in the alignment will have an accession_number corresponding to the Transfac site id, and id() based on that but unique within the alignment. Returns : Bio::SimpleAlign Args : string - a matrix id ('M...'), optionally true to, when a matrix lists no sequences, search for sequences via the matrix's factors, picking the sites that best match the matrix =cut my %VALID_STRAND = map {$_ => 1} qw(-1 0 1); sub get_aln { my ($self, $id, $via_factors) = @_; $id || return; my $data = $self->{matrix}->{data}->{$id} || $self->throw("matrix '$id' had no data in DB_File"); my @data = split(SEPARATOR, $data); if (! $data[5] && $via_factors) { # This is a matrix with no site sequences given in matrix.dat. # Find some matching site sequences via factors. # First, check its factors for sites my %site_seqs; my %factor_ids; foreach my $factor_id ($self->get_factor_ids(-matrix => $id)) { $factor_ids{$factor_id} = 1; foreach my $site_id ($self->get_site_ids(-factor => $factor_id)) { next if defined $site_seqs{$site_id}; my $seq = $self->get_seq($site_id); # skip sites that have no sequence, or have IUPAC symbols in # their sequence (most probably the 'consensus' sequence itself # that was used to make and exactly corresponds to the matrix) my $seq_str = $seq->seq || next; $seq_str =~ /[MRWSYKVHDB]/ and next; $site_seqs{$site_id} = $seq; } } my @seqs = values %site_seqs; if (@seqs > 1) { # pick the sub-seqs that match to the matrix with the best scores my $matrix = $self->get_matrix($id); my $desired_sequences = $matrix->sites; return if @seqs < $desired_sequences; my $desired_length = $matrix->width; my %best_seqs; foreach my $seq (@seqs) { my $for_str = $seq->seq; next if length($for_str) < $desired_length; my $rev_str = $seq->revcom->seq; my $best_score = 0; my $best_subseq = ''; my $best_i = 0; my $best_subseq_caps = 0; my $best_revcom; my $revcom = 0; foreach my $seq_str ($for_str, $rev_str) { for my $i (0..(length($seq_str) - $desired_length)) { my $subseq = substr($seq_str, $i, $desired_length); $subseq =~ s/[^ACGTacgt]//g; # can only score atcg next unless length($subseq) == $desired_length; # short or 0-length seqs could get the highest scores! my $score = $matrix->sequence_match_weight($subseq); # caps represent the author-chosen bit of a site # sequence so we would prefer to choose a subseq that # contains it my $caps = $subseq =~ tr/ACGT//; #*** (don't know why numeric == fails for comparing # scores, when the string eq works) if ($score > $best_score || ("$score" eq "$best_score" && $caps > $best_subseq_caps)) { $best_score = $score; $best_subseq_caps = $caps; $best_subseq = $subseq; $best_i = $i; $best_revcom = $revcom; } } $revcom++; } if ($best_score) { $best_seqs{$seq->accession_number} = [$best_subseq, $seq->accession_number, ($best_i + 1), $revcom ? -1 : 1, $best_score]; } } my @sorted = sort { $best_seqs{$b}->[-1] <=> $best_seqs{$a}->[-1] } keys %best_seqs; return if @sorted < $desired_sequences; splice(@sorted, $desired_sequences); my %wanted = map { $_ => 1 } @sorted; my @site_data; foreach my $seq (@seqs) { next unless exists $wanted{$seq->accession_number}; my @data = @{$best_seqs{$seq->accession_number}}; pop(@data); push(@site_data, join('_', @data)); } $data[5] = join(INTERNAL_SEPARATOR, @site_data); $self->{matrix}->{data}->{$id} = join(SEPARATOR, @data); } } $data[5] || return; my @blocks = split(INTERNAL_SEPARATOR, $data[5]); # append gap chars to all sequences to make them the same length # (applies to sequences found via factors, presumably, since we already # do this for matrix alignments in transfac_pro.pm) my $longest = 0; foreach (@blocks) { my ($seq) = split('_', $_); my $length = length($seq); if ($length > $longest) { $longest = $length; } } foreach my $i (0..$#blocks) { my $block = $blocks[$i]; my ($seq, $seq_id) = split('_', $block); my $length = length($seq); if ($length < $longest) { my $orig_seq = $seq; $seq .= '-'x($longest - $length); $block =~ s/^${orig_seq}_/${seq}_/; $blocks[$i] = $block; } } # build the alignment my $aln = Bio::SimpleAlign->new(-source => 'transfac_pro'); my %done_ids; foreach (@blocks) { my ($seq, $seq_acc, $start, $strand) = split('_', $_); $self->throw("Invalid strand $strand found in block $_") unless exists $VALID_STRAND{$strand}; # we can get back multiple different subparts of the same site (sequence), # so $seq_acc isn't unique across this loop. Can't use it as the seq id # of the alignment (ids must be unique in SimpleAlign), so we # uniquify the id and store the original id as the accession_number my $seq_id; $done_ids{$seq_acc}++; if ($done_ids{$seq_acc} > 1) { $seq_id = $seq_acc.'_'.$done_ids{$seq_acc}; } else { $seq_id = $seq_acc; } my $gaps = $seq =~ tr/-//; my $length = length($seq) - $gaps; $self->throw("seq '$seq_id' for matrix '$id' had seq '$seq'") unless $length; $aln->add_seq(Bio::LocatableSeq->new(-seq => $seq, -id => $seq_id, -accession_number => $seq_acc, -start => $start, -end => $start + $length - 1, -strand => $strand)); } $aln->id($id); # could also store score? of? return $aln; } =head2 get_factor Title : get_factor Usage : my $factor = $obj->get_factor($id); Function: Get the details of a transcription factor. Returns : Bio::Map::TranscriptionFactor Args : string - a factor id ('T...') =cut sub get_factor { my ($self, $id) = @_; $id || return; return $self->{got_factor}->{$id} if defined $self->{got_factor}->{$id}; my $data = $self->{factor}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); # accession = id name species sequence my $tf = Bio::Map::TranscriptionFactor->get(-id => $id, -universal_name => $data[1]); #*** not sure what to do with species and sequence, since we don't want to # confuse the idea that a TF is a general thing that could bind to any # species... then again, you might want to model species-specific variants # of a TF with different binding abilities... #*** idea of having inclusion and exclusion species so you can prevent/ # ignore a tf that binds to the wrong species (a species that doesn't even # have the tf), and associating sequence with each species/tf combo so you # can see how diverged the tf is and make assumptions about site difference # allowance # place it on all its genemaps foreach my $sid ($self->get_site_ids(-factor => $id)) { my $s_data = $self->{site}->{data}->{$sid} || next; my @s_data = split(SEPARATOR, $s_data); # accession = id gene_id sequence relative_to first_position last_position species_tax_id_or_raw_string $s_data[1] || next; # site isn't relative to a gene, meaningless $s_data[4] || next; # don't know where its supposed to be, can't model it $s_data[5] ||= $s_data[4] + ($s_data[2] ? length($s_data[2]) - 1 : 0); # it is quite deliberate that we deeply recurse to arrive at the # correct answer, which involves pulling in most of the database no warnings "recursion"; my $gene_map = $self->get_genemap($s_data[1]) || next; return $self->{got_factor}->{$id} if defined $self->{got_factor}->{$id}; #*** not always relative to gene start... # we need Bio::Map::Gene s to have some default tss and atg positions # that we can be relative to my $rel = Bio::Map::Relative->new(-element => $gene_map->gene, -description => $s_data[3]); Bio::Map::Position->new(-map => $gene_map, -element => $tf, -start => $s_data[4], -end => $s_data[5], -relative => $rel); } $self->{got_factor}->{$id} = $tf; return $tf; } # since get_factor() is uncertain, just have direct access methods to factor # information sub get_factor_name { my ($self, $id) = @_; my $details = $self->_get_factor_details($id) || return; return $details->{name}; } sub get_factor_species { my ($self, $id) = @_; my $details = $self->_get_factor_details($id) || return; return $details->{species}; } sub get_factor_sequence { my ($self, $id) = @_; my $details = $self->_get_factor_details($id) || return; return $details->{sequence}; } sub _get_factor_details { my ($self, $id) = @_; $id || return; return $self->{factor_details}->{$id} if defined $self->{factor_details}->{$id}; my $data = $self->{factor}->{data}->{$id} || return; my @data = split(SEPARATOR, $data); # accession = id name species sequence my %details = (name => $data[1], species => $data[2], sequence => $data[3]); $self->{factor_details}->{$id} = \%details; return \%details; } =head2 get_reference_ids Title : get_reference_ids Usage : my @ids = $obj->get_reference_ids(-key => $value); Function: Get all the reference ids that are associated with the supplied args. Returns : list of strings (ids) Args : -key => value, where value is a string id, and key is one of: -pubmed -site -gene -matrix -factor =cut sub get_reference_ids { my $self = shift; return $self->_get_ids('reference', @_); } # -id -name -species -site -factor -reference sub get_gene_ids { my $self = shift; return $self->_get_ids('gene', @_); } =head2 get_site_ids Title : get_site_ids Usage : my @ids = $obj->get_site_ids(-key => $value); Function: Get all the site ids that are associated with the supplied args. Returns : list of strings (ids) Args : -key => value, where value is a string id, and key is one of: -id -species -gene -matrix -factor -reference =cut sub get_site_ids { my $self = shift; return $self->_get_ids('site', @_); } =head2 get_matrix_ids Title : get_matrix_ids Usage : my @ids = $obj->get_matrix_ids(-key => $value); Function: Get all the matrix ids that are associated with the supplied args. Returns : list of strings (ids) Args : -key => value, where value is a string id, and key is one of: -id -name -site -factor -reference =cut sub get_matrix_ids { my $self = shift; return $self->_get_ids('matrix', @_); } =head2 get_factor_ids Title : get_factor_ids Usage : my @ids = $obj->get_factor_ids(-key => $value); Function: Get all the factor ids that are associated with the supplied args. Returns : list of strings (ids) Args : -key => value, where value is a string id, and key is one of: -id -name -species -interactors -gene -matrix -site -reference NB: -gene only gets factor ids for genes that encode factors =cut sub get_factor_ids { my $self = shift; return $self->_get_ids('factor', @_); } =head2 get_fragment_ids Title : get_fragment_ids Usage : my @ids = $obj->get_fragment_ids(-key => $value); Function: Get all the fragment ids that are associated with the supplied args. Returns : list of strings (ids) Args : -key => value, where value is a string id, and key is one of: -id -species -gene -factor -reference =cut sub get_fragment_ids { my $self = shift; return $self->_get_ids('fragment', @_); } =head2 Helper methods =cut # internal method which does the indexing sub _build_index { my ($self, $dat_dir, $force) = @_; # MLDBM would give us transparent complex data structures with DB_File, # allowing just one index file, but its yet another requirment and we # don't strictly need it my $index_dir = $self->index_directory; my $gene_index = "$index_dir/gene.dat.index"; my $reference_index = "$index_dir/reference.dat.index"; my $matrix_index = "$index_dir/matrix.dat.index"; my $factor_index = "$index_dir/factor.dat.index"; my $fragment_index = "$index_dir/fragment.dat.index"; my $site_index = "$index_dir/site.dat.index"; my $reference_dat = "$dat_dir/reference.dat"; if (! -e $reference_index || $force) { open(REF, $reference_dat) || $self->throw("Cannot open reference file '$reference_dat' for reading"); my %references; unlink $reference_index; my $ref = tie(%references, 'DB_File', $reference_index, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$reference_index': $!"); my %pubmed; my $reference_pubmed = $reference_index.'.pubmed'; unlink $reference_pubmed; my $pub = tie(%pubmed, 'DB_File', $reference_pubmed, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_pubmed': $!"); my %gene; my $reference_gene = $gene_index.'.reference'; unlink $reference_gene; my $gene = tie(%gene, 'DB_File', $reference_gene, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_gene': $!"); my %site; my $reference_site = $site_index.'.reference'; unlink $reference_site; my $site = tie(%site, 'DB_File', $reference_site, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_site': $!"); my %fragment; my $reference_fragment = $fragment_index.'.reference'; unlink $reference_fragment; my $fragment = tie(%fragment, 'DB_File', $reference_fragment, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_fragment': $!"); my %factor; my $reference_factor = $factor_index.'.reference'; unlink $reference_factor; my $factor = tie(%factor, 'DB_File', $reference_factor, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_factor': $!"); my %matrix; my $reference_matrix = $matrix_index.'.reference'; unlink $reference_matrix; my $matrix = tie(%matrix, 'DB_File', $reference_matrix, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_matrix': $!"); # skip the first three header lines ; ; ; my @data; while () { if (/^AC (\S+)/) { $data[0] = $1; } elsif (/^RX PUBMED: (\d+)/) { $data[1] = $1; $pub->put("$1", $data[0]); } elsif (/^RA (.+)\n$/) { $data[2] = $1; } elsif (/^RT (.+?)\.?\n$/) { $data[3] = $1; } elsif (/^RL (.+?)\.?\n$/) { $data[4] = $1; } elsif (/^GE TRANSFAC: (\w\d+)/) { $gene->put($data[0], "$1"); } elsif (/^BS TRANSFAC: (\w\d+)/) { $site->put($data[0], "$1"); } elsif (/^FA TRANSFAC: (\w\d+)/) { $factor->put($data[0], "$1"); } elsif (/^FR TRANSFAC: (FR\d+)/) { $fragment->put($data[0], "$1"); } elsif (/^MX TRANSFAC: (\w\d+)/) { $matrix->put($data[0], "$1"); } elsif (/^\/\//) { # end of a record, store previous data and reset # accession = pubmed authors title location $references{$data[0]} = join(SEPARATOR, ($data[1] || '', $data[2] || '', $data[3] || '', $data[4] || '')); @data = (); } } close(REF); $ref = $pub = $gene = $site = $fragment = $factor = $matrix = undef; untie %references; untie %pubmed; untie %gene; untie %site; untie %fragment; untie %factor; untie %matrix; } my $gene_dat = "$dat_dir/gene.dat"; if (! -e $gene_index || $force) { open(GEN, $gene_dat) || $self->throw("Cannot open gene file '$gene_dat' for reading"); my %genes; unlink $gene_index; my $gene = tie(%genes, 'DB_File', $gene_index, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$gene_index': $!"); my %id; my $gene_id = $gene_index.'.id'; unlink $gene_id; my $id = tie(%id, 'DB_File', $gene_id, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_id': $!"); my %name; my $gene_name = $gene_index.'.name'; unlink $gene_name; my $name = tie(%name, 'DB_File', $gene_name, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_name': $!"); my %species; my $gene_species = $gene_index.'.species'; unlink $gene_species; my $species = tie(%species, 'DB_File', $gene_species, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_species': $!"); my %site; my $gene_site = $site_index.'.gene'; unlink $gene_site; my $site = tie(%site, 'DB_File', $gene_site, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_site': $!"); my %factor; my $gene_factor = $factor_index.'.gene'; unlink $gene_factor; my $factor = tie(%factor, 'DB_File', $gene_factor, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_factor': $!"); my %fragment; my $gene_fragment = $fragment_index.'.gene'; unlink $gene_fragment; my $fragment = tie(%fragment, 'DB_File', $gene_fragment, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_fragment': $!"); my %reference; my $gene_reference = $reference_index.'.gene'; unlink $gene_reference; my $reference = tie(%reference, 'DB_File', $gene_reference, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$gene_reference': $!"); # skip the first three header lines ; ; ; my @data; while () { if (/^AC (\S+)/) { $data[0] = $1; } elsif (/^ID (\S+)/) { $data[1] = $1; $id->put("$1", $data[0]); } elsif (/^SD (.+)$/) { $data[2] = lc("$1"); $name->put(lc("$1"), $data[0]); } elsif (/^SY (.+)\.$/) { foreach (split('; ', lc("$1"))) { $name->put($_, $data[0]); } } elsif (/^DE (.+)$/) { $data[3] = $1; } elsif (/^OS (.+)$/) { my $raw_species = $1; my $taxid = $self->_species_to_taxid($raw_species); $data[4] = $taxid || $raw_species; $species->put($data[4], $data[0]); } elsif (/^RN .+?(RE\d+)/) { $reference->put($data[0], "$1"); } elsif (/^BS .+?(R\d+)/) { $site->put($data[0], "$1"); } elsif (/^FA (T\d+)/) { $factor->put($data[0], "$1"); } elsif (/^BR (FR\d+)/) { $fragment->put($data[0], "$1"); } elsif (/^\/\//) { # end of a record, store previous data and reset # accession = id name description species_tax_id_or_raw_string $genes{$data[0]} = join(SEPARATOR, ($data[1] || '', $data[2] || '', $data[3] || '', $data[4] || '')); @data = (); } } close(GEN); $gene = $id = $name = $species = $site = $factor = $reference = undef; untie %genes; untie %id; untie %name; untie %species; untie %site; untie %factor; untie %reference; } my $site_dat = "$dat_dir/site.dat"; if (! -e $site_index || $force) { open(SIT, $site_dat) || $self->throw("Cannot open site file '$site_dat' for reading"); my %sites; unlink $site_index; my $site = tie(%sites, 'DB_File', $site_index, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$site_index': $!"); my %id; my $site_id = $site_index.'.id'; unlink $site_id; my $id = tie(%id, 'DB_File', $site_id, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$site_id': $!"); my %species; my $site_species = $site_index.'.species'; unlink $site_species; my $species = tie(%species, 'DB_File', $site_species, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$site_species': $!"); my %qualities; my $site_qualities = $site_index.'.qual'; unlink $site_qualities; my $quality = tie(%qualities, 'DB_File', $site_qualities, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$site_qualities': $!"); my %gene; my $site_gene = $gene_index.'.site'; unlink $site_gene; my $gene = tie(%gene, 'DB_File', $site_gene, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$site_gene': $!"); my %matrix; my $site_matrix = $matrix_index.'.site'; unlink $site_matrix; my $matrix = tie(%matrix, 'DB_File', $site_matrix, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$site_matrix': $!"); my %factor; my $site_factor = $factor_index.'.site'; unlink $site_factor; my $factor = tie(%factor, 'DB_File', $site_factor, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$site_factor': $!"); my %reference; my $site_reference = $reference_index.'.site'; unlink $site_reference; my $reference = tie(%reference, 'DB_File', $site_reference, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$site_reference': $!"); # skip the first three header lines ; ; ; my @data; while () { if (/^AC (\S+)/) { $data[0] = $1; } elsif (/^ID (\S+)/) { $data[1] = $1; $id->put("$1", $data[0]); } elsif (/^TY (.+)$/) { $data[8] = $1; } elsif (/^DE .*Gene: (G\d+)/) { $data[2] = $1; $gene->put($data[0], "$1"); # if it has no gene it is an artificial sequence, unless it # has a species (OS line), in which case it is unassigned # genomic; either way we won't be able to make a # Bio::Map::PositionI later on, so such sites won't be # on any MapI. } elsif (/^OS (.+)$/) { # Since not all sites in site.dat with a species have a gene, # (small handful are unassigned 'genomic') can't delegate to # gene.dat and must parse species here (effectively again) my $raw_species = $1; my $taxid = $self->_species_to_taxid($raw_species); $data[7] = $taxid || $raw_species; $species->put($data[7], $data[0]); } elsif (/^SQ (.+)\.$/) { $data[3] = $1; # there can actually be more than one SQ line, seemingly with # variations of the sequence (not a long sequence split over # two lines); not sure what to do with data; currently we end # up storing only the last variant. } elsif (/^S1 (.+)$/) { $data[4] = $1; # if S1 not present, means transcriptional start } elsif (/^SF (.+)$/) { $data[5] = $1; } elsif (/^ST (.+)$/) { $data[6] = $1; } elsif (/^RN .+?(RE\d+)/) { $reference->put($data[0], "$1"); } elsif (/^MX (M\d+)/) { $matrix->put($data[0], "$1"); } elsif (/^BF (T\d+); .+?; Quality: (\d)/) { $factor->put($data[0], "$1"); $qualities{$data[0].SEPARATOR.$1} = $2; } elsif (/^\/\//) { # end of a record, store previous data and reset # accession = id gene_id sequence relative_to first_position last_position species_tax_id_or_raw_string type $sites{$data[0]} = join(SEPARATOR, ($data[1] || '', $data[2] || '', $data[3] || '', $data[4] || 'TSS', $data[5] || '', $data[6] || '', $data[7] || '', $data[8] || '')); @data = (); } } close(SIT); $site = $id = $species = $quality = $gene = $matrix = $factor = $reference = undef; untie %sites; untie %id; untie %species; untie %qualities; untie %gene; untie %matrix; untie %factor; untie %reference; } my $matrix_dat = "$dat_dir/matrix.dat"; if (! -e $matrix_index || $force) { open(MAT, $matrix_dat) || $self->throw("Cannot open matrix file '$matrix_dat' for reading"); my %matrices; unlink $matrix_index; my $matrix = tie(%matrices, 'DB_File', $matrix_index, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$matrix_index': $!"); my %id; my $matrix_id = $matrix_index.'.id'; unlink $matrix_id; my $id = tie(%id, 'DB_File', $matrix_id, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$matrix_id': $!"); my %name; my $matrix_name = $matrix_index.'.name'; unlink $matrix_name; my $name = tie(%name, 'DB_File', $matrix_name, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$matrix_name': $!"); my %site; my $matrix_site = $site_index.'.matrix'; unlink $matrix_site; my $site = tie(%site, 'DB_File', $matrix_site, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$matrix_site': $!"); my %factor; my $matrix_factor = $factor_index.'.matrix'; unlink $matrix_factor; my $factor = tie(%factor, 'DB_File', $matrix_factor, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$matrix_factor': $!"); my %reference; my $matrix_reference = $reference_index.'.matrix'; unlink $matrix_reference; my $reference = tie(%reference, 'DB_File', $matrix_reference, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$matrix_reference': $!"); # skip the first three header lines ; ; ; my @data; my @matrix_data; my @site_data; while () { if (/^AC (\S+)/) { $data[0] = $1; } elsif (/^ID (\S+)/) { $data[1] = $1; $id->put("$1", $data[0]); } elsif (/^NA (.+)$/) { $data[2] = $1; $name->put("$1", $data[0]); } elsif (/^DE (.+)$/) { $data[3] = $1; } elsif (/^\d\d \s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { # a, c, g, t counts/weights push(@matrix_data, join("\t", ($1, $2, $3, $4))); # Work out the number of sites as the largest number of # sites amongst all positions in the sequences. (The BA # line isn't reliable for telling us the correct number of # sites all the time) my $num = $1 + $2 + $3 + $4; $data[4] ||= 0; if ($num > $data[4]) { $data[4] = $num; } } elsif (/^BS ([\sa-zA-Z]+); (.+?); (-?\d+); \d+;.*; ([np])/) { # sequence id start strand push(@site_data, join('_', ($1, $2, $3, $4 eq 'p' ? 1 : -1))); $site->put($data[0], $2); } elsif (/^BF (T\d+)/) { $factor->put($data[0], "$1"); } elsif (/^RN .+?(RE\d+)/) { $reference->put($data[0], "$1"); } elsif (/^\/\//) { # end of a record, store previous data and reset my $matrix_data = join(INTERNAL_SEPARATOR, @matrix_data) || ''; # sites of a matrix are pre-aligned but padded with spaces on # the left and no padding on the right; pad with -s both sides my $longest_seq = 0; # For all the work, does anything meaningful actually get passed # on here? Commenting out fixes the latest crashes on trunk. # 5-10-10 cjfields #foreach my $site_seq (map {my ($seq) = split("_", $_ ,2); $seq;} @site_data) { # $site_seq =~ s/ /-/g; # my $length = length($site_seq); # if ($length > $longest_seq) { # $longest_seq = $length; # } #} #foreach my $site (@site_data) { # my ($site_seq) = split("_", $site ,2); # my $length = length($site_seq); # if ($length < $longest_seq) { # $site_seq .= '-' x ($longest_seq - $length); # } #} my $site_data = join(INTERNAL_SEPARATOR, @site_data) || ''; # accession = id name description num_of_sites matrix_data site_data $matrices{$data[0]} = join(SEPARATOR, ($data[1] || '', $data[2] || '', $data[3] || '', $data[4], $matrix_data, $site_data)); @data = @matrix_data = @site_data = (); } } close(MAT); $matrix = $id = $name = $site = $factor = $reference = undef; untie %matrices; untie %id; untie %name; untie %site; untie %factor; untie %reference; } my $factor_dat = "$dat_dir/factor.dat"; if (! -e $factor_index || $force) { open(FAC, $factor_dat) || $self->throw("Cannot open factor file '$factor_dat' for reading"); my %factors; unlink $factor_index; my $factor = tie(%factors, 'DB_File', $factor_index, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$factor_index': $!"); my %id; my $factor_id = $factor_index.'.id'; unlink $factor_id; my $id = tie(%id, 'DB_File', $factor_id, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file 'factor_id': $!"); my %name; my $factor_name = $factor_index.'.name'; unlink $factor_name; my $name = tie(%name, 'DB_File', $factor_name, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_name': $!"); my %species; my $factor_species = $factor_index.'.species'; unlink $factor_species; my $species = tie(%species, 'DB_File', $factor_species, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_species': $!"); my %interactors; my $factor_interactors = $factor_index.'.interactors'; unlink $factor_interactors; my $interact = tie(%interactors, 'DB_File', $factor_interactors, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_interactors': $!"); my %gene; my $factor_gene = $gene_index.'.factor'; unlink $factor_gene; my $gene = tie(%gene, 'DB_File', $factor_gene, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_gene': $!"); my %matrix; my $factor_matrix = $matrix_index.'.factor'; unlink $factor_matrix; my $matrix = tie(%matrix, 'DB_File', $factor_matrix, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_matrix': $!"); my %site; my $factor_site = $site_index.'.factor'; unlink $factor_site; my $site = tie(%site, 'DB_File', $factor_site, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_site': $!"); my %fragment; my $factor_fragment = $fragment_index.'.factor'; unlink $factor_fragment; my $fragment = tie(%fragment, 'DB_File', $factor_fragment, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_fragment': $!"); my %reference; my $factor_reference = $reference_index.'.factor'; unlink $factor_reference; my $reference = tie(%reference, 'DB_File', $factor_reference, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$factor_reference': $!"); # skip the first three header lines ; ; ; my @data; my $sequence = ''; while () { if (/^AC (\S+)/) { $data[0] = $1; } elsif (/^ID (\S+)/) { # IDs are always the same as AC? Is this needed? $data[1] = $1; $id->put("$1", $data[0]); } elsif (/^FA (.+)$/) { $data[2] = $1; $name->put("$1", $data[0]); } elsif (/^OS (.+)$/) { # This is the species the actual factor came from, which may # differ from the species of any sequences it is described as # binding to. Not all factors that have a species have a gene, # so can't delegate species to a gene lookup. my $raw_species = $1; my $taxid = $self->_species_to_taxid($raw_species); $data[3] = $taxid || $raw_species; $species->put($data[3], $data[0]); } elsif (/^GE (G\d+)/) { $gene->put($data[0], "$1"); } elsif (/^SQ (.+)$/) { $sequence .= $1; } elsif (/^IN (T\d+)/) { $interact->put($data[0], "$1"); } elsif (/^MX (M\d+)/) { $matrix->put($data[0], "$1"); } elsif (/^BS (R\d+)/) { $site->put($data[0], "$1"); } elsif (/^BR (FR\d+)/) { $fragment->put($data[0], "$1"); } elsif (/^RN .+?(RE\d+)/) { $reference->put($data[0], "$1"); } elsif (/^\/\//) { # end of a record, store previous data and reset # accession = id name species sequence $factors{$data[0]} = join(SEPARATOR, ($data[1] || '', $data[2] || '', $data[3] || '', $sequence)); @data = (); $sequence = ''; } } close(FAC); $factor = $id = $name = $species = $interact = $gene = $matrix = $site = $fragment = $reference = undef; untie %factors; untie %id; untie %name; untie %species; untie %interactors; untie %gene; untie %matrix; untie %site; untie %fragment; untie %reference; } my $fragment_dat = "$dat_dir/fragment.dat"; if (! -e $fragment_index || $force) { if (open(FRA, $fragment_dat)) { my %fragments; unlink $fragment_index; my $fragment = tie(%fragments, 'DB_File', $fragment_index, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$fragment_index': $!"); my %id; my $fragment_id = $fragment_index.'.id'; unlink $fragment_id; my $id = tie(%id, 'DB_File', $fragment_id, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$fragment_id': $!"); my %qualities; my $fragment_qualities = $fragment_index.'.qual'; unlink $fragment_qualities; my $quality = tie(%qualities, 'DB_File', $fragment_qualities, O_RDWR|O_CREAT, 0644, $DB_HASH) || $self->throw("Cannot open file '$fragment_qualities': $!"); my %species; my $fragment_species = $fragment_index.'.species'; unlink $fragment_species; my $species = tie(%species, 'DB_File', $fragment_species, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$fragment_species': $!"); my %gene; my $fragment_gene = $gene_index.'.fragment'; unlink $fragment_gene; my $gene = tie(%gene, 'DB_File', $fragment_gene, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$fragment_gene': $!"); my %factor; my $fragment_factor = $factor_index.'.fragment'; unlink $fragment_factor; my $factor = tie(%factor, 'DB_File', $fragment_factor, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$fragment_factor': $!"); my %reference; my $fragment_reference = $reference_index.'.fragment'; unlink $fragment_reference; my $reference = tie(%reference, 'DB_File', $fragment_reference, O_RDWR|O_CREAT, 0644, $DB_BTREE) || $self->throw("Cannot open file '$fragment_reference': $!"); # skip the first three header lines ; ; ; my @data; while () { if (/^AC (\S+)/) { $data[0] = $1; } elsif (/^ID (\S+)/) { # IDs are always the same as AC? Is this needed? $data[1] = $1; $id->put("$1", $data[0]); } elsif (/^DE Gene: (G\d+)(?:.+Gene: (G\d+))?/) { my ($gene1, $gene2) = ($1, $2); $data[2] = $gene1; $data[3] = $gene2; # could be undef $gene->put($data[0], $gene1); $gene->put($data[0], $gene2) if $gene2; } elsif (/^OS (.+)$/) { # As per the site.dat parsing my $raw_species = $1; my $taxid = $self->_species_to_taxid($raw_species); $data[4] = $taxid || $raw_species; $species->put($data[4], $data[0]); } elsif (/^SQ [atcgn]*([ATCGN]+)[atcgn]*/) { $data[5] .= $1; # there can be (usually are) multiple SQ lines with a single # long seq split over them. The 'real' sequence is in caps } elsif (/^SC Build (\S+):$/) { $data[6] = $1; # maybe parse it out a little more? We have build, # chromosomal coords and strand, eg. # SC Build HSA_May2004: Chr.2 43976692..43978487 (FORWARD). } elsif (/^RN .+?(RE\d+)/) { $reference->put($data[0], "$1"); } elsif (/^BF (T\d+); .+?; Quality: (\d)/) { $factor->put($data[0], "$1"); $qualities{$data[0].SEPARATOR.$1} = $2; } elsif (/^\/\//) { # end of a record, store previous data and reset # accession = id gene_id1 gene_id2 species_tax_id_or_raw_string sequence source $fragments{$data[0]} = join(SEPARATOR, ($data[1] || '', $data[2] || '', $data[3] || '', $data[4] || '', $data[5] || '', $data[6] || '')); @data = (); } } close(FRA); $fragment = $id = $species = $quality = $gene = $factor = $reference = undef; untie %fragments; untie %id; untie %species; untie %qualities; untie %gene; untie %factor; untie %reference; } else { $self->warn("Cannot open fragment file '$fragment_dat' for reading, assuming you have an old version of Transfac Pro with no fragment.dat file."); } } } # connect the internal db handle sub _db_connect { my $self = shift; return if $self->{'_initialized'}; my $index_dir = $self->index_directory; my $gene_index = "$index_dir/gene.dat.index"; my $reference_index = "$index_dir/reference.dat.index"; my $matrix_index = "$index_dir/matrix.dat.index"; my $factor_index = "$index_dir/factor.dat.index"; my $site_index = "$index_dir/site.dat.index"; my $fragment_index = "$index_dir/fragment.dat.index"; foreach ($gene_index, $reference_index, $matrix_index, $factor_index, $site_index, $fragment_index) { if (! -e $_) { #$self->warn("Index files have not been created"); #return 0; } } # reference { $self->{reference}->{data} = {}; tie (%{$self->{reference}->{data}}, 'DB_File', $reference_index, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$reference_index': $!"); my $reference_pubmed = $reference_index.'.pubmed'; $self->{reference}->{pubmed} = tie (%{$self->{reference}->{pubmed}}, 'DB_File', $reference_pubmed, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$reference_pubmed': $!"); my $reference_gene = $gene_index.'.reference'; $self->{gene}->{reference} = tie (%{$self->{gene}->{reference}}, 'DB_File', $reference_gene, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$reference_gene': $!"); my $reference_site = $site_index.'.reference'; $self->{site}->{reference} = tie (%{$self->{site}->{reference}}, 'DB_File', $reference_site, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$reference_site': $!"); my $reference_fragment = $fragment_index.'.reference'; $self->{fragment}->{reference} = tie (%{$self->{fragment}->{reference}}, 'DB_File', $reference_fragment, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$reference_fragment': $!"); my $reference_factor = $factor_index.'.reference'; $self->{factor}->{reference} = tie (%{$self->{factor}->{reference}}, 'DB_File', $reference_factor, undef, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_factor': $!"); my $reference_matrix = $matrix_index.'.reference'; $self->{matrix}->{reference} = tie (%{$self->{matrix}->{reference}}, 'DB_File', $reference_matrix, undef, 0644, $DB_BTREE) || $self->throw("Cannot open file '$reference_matrix': $!"); } # gene { $self->{gene}->{data} = {}; tie (%{$self->{gene}->{data}}, 'DB_File', $gene_index, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$gene_index': $!"); my $gene_id = $gene_index.'.id'; $self->{gene}->{id} = tie(%{$self->{gene}->{id}}, 'DB_File', $gene_id, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_id': $!"); my $gene_name = $gene_index.'.name'; $self->{gene}->{name} = tie(%{$self->{gene}->{name}}, 'DB_File', $gene_name, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_name': $!"); my $gene_species = $gene_index.'.species'; $self->{gene}->{species} = tie(%{$self->{gene}->{species}}, 'DB_File', $gene_species, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_species': $!"); my $gene_site = $site_index.'.gene'; $self->{site}->{gene} = tie(%{$self->{site}->{gene}}, 'DB_File', $gene_site, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_site': $!"); my $gene_fragment = $fragment_index.'.gene'; $self->{fragment}->{gene} = tie(%{$self->{fragment}->{gene}}, 'DB_File', $gene_fragment, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_fragment': $!"); my $gene_factor = $factor_index.'.gene'; $self->{factor}->{gene} = tie(%{$self->{factor}->{gene}}, 'DB_File', $gene_factor, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_factor': $!"); my $gene_reference = $reference_index.'.gene'; $self->{reference}->{gene} = tie(%{$self->{reference}->{gene}}, 'DB_File', $gene_reference, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$gene_reference': $!"); } # site { $self->{site}->{data} = {}; tie (%{$self->{site}->{data}}, 'DB_File', $site_index, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$site_index': $!"); my $site_id = $site_index.'.id'; $self->{site}->{id} = tie(%{$self->{site}->{id}}, 'DB_File', $site_id, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$site_id': $!"); my $site_species = $site_index.'.species'; $self->{site}->{species} = tie(%{$self->{site}->{species}}, 'DB_File', $site_species, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file $site_species': $!"); #*** quality not actually used by anything (yet) my $site_qualities = $site_index.'.qual'; $self->{quality} = {}; tie(%{$self->{quality}}, 'DB_File', $site_qualities, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$site_qualities': $!"); my $site_gene = $gene_index.'.site'; $self->{gene}->{site} = tie(%{$self->{gene}->{site}}, 'DB_File', $site_gene, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$site_gene': $!"); my $site_matrix = $matrix_index.'.site'; $self->{matrix}->{site} = tie(%{$self->{matrix}->{site}}, 'DB_File', $site_matrix, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$site_matrix': $!"); my $site_factor = $factor_index.'.site'; $self->{factor}->{site} = tie(%{$self->{factor}->{site}}, 'DB_File', $site_factor, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$site_factor': $!"); my $site_reference = $reference_index.'.site'; $self->{reference}->{site} = tie(%{$self->{reference}->{site}}, 'DB_File', $site_reference, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$site_reference': $!"); } # fragment (may not be in older databases) if (-e $fragment_index) { $self->{fragment}->{data} = {}; tie (%{$self->{fragment}->{data}}, 'DB_File', $fragment_index, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$fragment_index': $!"); my $fragment_id = $fragment_index.'.id'; $self->{fragment}->{id} = tie(%{$self->{fragment}->{id}}, 'DB_File', $fragment_id, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$fragment_id': $!"); my $fragment_species = $fragment_index.'.species'; $self->{fragment}->{species} = tie(%{$self->{fragment}->{species}}, 'DB_File', $fragment_species, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file $fragment_species': $!"); #*** quality not actually used by anything (yet) my $fragment_qualities = $fragment_index.'.qual'; $self->{fragment_quality} = {}; tie(%{$self->{fragment_quality}}, 'DB_File', $fragment_qualities, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$fragment_qualities': $!"); my $fragment_gene = $gene_index.'.fragment'; $self->{gene}->{fragment} = tie(%{$self->{gene}->{fragment}}, 'DB_File', $fragment_gene, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$fragment_gene': $!"); my $fragment_factor = $factor_index.'.fragment'; $self->{factor}->{fragment} = tie(%{$self->{factor}->{fragment}}, 'DB_File', $fragment_factor, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$fragment_factor': $!"); my $fragment_reference = $reference_index.'.fragment'; $self->{reference}->{fragment} = tie(%{$self->{reference}->{fragment}}, 'DB_File', $fragment_reference, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$fragment_reference': $!"); } else { die "no fragment_index at '$fragment_index'\n"; } # matrix { $self->{matrix}->{data} = {}; tie (%{$self->{matrix}->{data}}, 'DB_File', $matrix_index, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$matrix_index': $!"); my $matrix_id = $matrix_index.'.id'; $self->{matrix}->{id} = tie(%{$self->{matrix}->{id}}, 'DB_File', $matrix_id, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$matrix_id': $!"); my $matrix_name = $matrix_index.'.name'; $self->{matrix}->{name} = tie(%{$self->{matrix}->{name}}, 'DB_File', $matrix_name, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$matrix_name': $!"); my $matrix_site = $site_index.'.matrix'; $self->{site}->{matrix} = tie(%{$self->{site}->{matrix}}, 'DB_File', $matrix_site, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$matrix_site': $!"); my $matrix_factor = $factor_index.'.matrix'; $self->{factor}->{matrix} = tie(%{$self->{factor}->{matrix}}, 'DB_File', $matrix_factor, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$matrix_factor': $!"); my $matrix_reference = $reference_index.'.matrix'; $self->{reference}->{matrix} = tie(%{$self->{reference}->{matrix}}, 'DB_File', $matrix_reference, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$matrix_reference': $!"); } # factor { $self->{factor}->{data} = {}; tie (%{$self->{factor}->{data}}, 'DB_File', $factor_index, O_RDWR, undef, $DB_HASH) || $self->throw("Cannot open file '$factor_index': $!"); my $factor_id = $factor_index.'.id'; $self->{factor}->{id} = tie(%{$self->{factor}->{id}}, 'DB_File', $factor_id, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file 'factor_id': $!"); my $factor_name = $factor_index.'.name'; $self->{factor}->{name} = tie(%{$self->{factor}->{name}}, 'DB_File', $factor_name, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_name': $!"); my $factor_species = $factor_index.'.species'; $self->{factor}->{species} = tie(%{$self->{factor}->{species}}, 'DB_File', $factor_species, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_species': $!"); my $factor_interactors = $factor_index.'.interactors'; $self->{factor}->{interactors} = tie(%{$self->{factor}->{interactors}}, 'DB_File', $factor_interactors, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_interactors': $!"); my $factor_gene = $gene_index.'.factor'; $self->{gene}->{factor} = tie(%{$self->{gene}->{factor}}, 'DB_File', $factor_gene, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_gene': $!"); my $factor_matrix = $matrix_index.'.factor'; $self->{matrix}->{factor} = tie(%{$self->{matrix}->{factor}}, 'DB_File', $factor_matrix, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_matrix': $!"); my $factor_site = $site_index.'.factor'; $self->{site}->{factor} = tie(%{$self->{site}->{factor}}, 'DB_File', $factor_site, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_site': $!"); my $factor_fragment = $fragment_index.'.factor'; $self->{fragment}->{factor} = tie(%{$self->{fragment}->{factor}}, 'DB_File', $factor_fragment, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_fragment': $!"); my $factor_reference = $reference_index.'.factor'; $self->{reference}->{factor} = tie(%{$self->{reference}->{factor}}, 'DB_File', $factor_reference, O_RDWR, undef, $DB_BTREE) || $self->throw("Cannot open file '$factor_reference': $!"); } $self->{'_initialized'} = 1; } =head2 index_directory Title : index_directory Funtion : Get/set the location that index files are stored. (this module will index the supplied database) Usage : $obj->index_directory($newval) Returns : value of index_directory (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub index_directory { my $self = shift; return $self->{'index_directory'} = shift if @_; return $self->{'index_directory'}; } # resolve a transfac species string into an ncbi taxid sub _species_to_taxid { my ($self, $raw_species) = @_; $raw_species or return; my $species_string; my @split = split(', ', $raw_species); (@split > 1) ? ($species_string = $split[1]) : ($species_string = $split[0]); my $ncbi_taxid; if ($species_string =~ /^[A-Z]\S+ \S+$/) { SWITCH: for ($species_string) { # some species don't classify so custom handling /^Darnel ryegrass/ && do { $ncbi_taxid = 34176; last; }; /^Coix lacryma/ && do { $ncbi_taxid = 4505; last; }; /^Rattus spec/ && do { $ncbi_taxid = 10116; last; }; /^Mus spec/ && do { $ncbi_taxid = 10090; last; }; /^Equus spec/ && do { $ncbi_taxid = 9796; last; }; /^Cavia sp/ && do { $ncbi_taxid = 10141; last; }; /^Marsh marigold/ && do { $ncbi_taxid = 3449; last; }; /^Phalaenopsis sp/ && do { $ncbi_taxid = 36900; last; }; /^Anthirrhinum majus/ && do { $ncbi_taxid = 4151; last; }; /^Equus spec/ && do { $ncbi_taxid = 9796; last; }; /^Lycopodium spec/ && do { $ncbi_taxid = 13840; last; }; /^Autographa californica/ && do { $ncbi_taxid = 307456; last; }; /^E26 AEV/ && do { $ncbi_taxid = 31920; last; }; /^Pseudocentrotus miliaris/ && do { $ncbi_taxid = 7677; last; }; # the genus is 7677 but this species isn't there /^SL3-3 (?:retro)?virus/ && do { $ncbi_taxid = 53454; last; }; # 53454 is unclassified MLV-related, SL3-3 a variant of that? /^Petunia sp/ && do { $ncbi_taxid = 4104; last; }; } if (! $ncbi_taxid && defined $self->{_tax_db}) { ($ncbi_taxid) = $self->{_tax_db}->get_taxonids($species_string); } } else { # some species lines are poorly formated so custom handling SWITCH: for ($raw_species) { # for speed, go by common first letters my $first_letter = substr($raw_species, 0, 1); $first_letter eq 'A' && do { /^Adiantum raddianum/ && do { $ncbi_taxid = 32168; last; }; /^Avian sarcoma virus \(strain 17\)/ && do { $ncbi_taxid = 11877; last; }; /^AMV/ && do { $ncbi_taxid = 11866; last; }; /^AEV/ && do { $ncbi_taxid = 11861; last; }; /^AS42|^Avian musculoaponeurotic/ && do { $ncbi_taxid = 11873; last; }; /^Avian myelocytomatosis/ && do { $ncbi_taxid = 11869; last; }; /^ASV 31/ && do { $ncbi_taxid = 35270; last; }; /^A-MuLV/ && do { $ncbi_taxid = 188539; last; }; /^Asparagus officinalis/ && do { $ncbi_taxid = 4686; last; }; /^Agrobacterium tumefaciens/ && do { $ncbi_taxid = 358; last; }; /^ALV/ && do { $ncbi_taxid = 11864; last; }; /^AAV/ && do { $ncbi_taxid = 272636; last; }; /^AKV MLV/ && do { $ncbi_taxid = 11791; last; }; last; }; $first_letter eq 'B' && do { /^BPV-1/ && do { $ncbi_taxid = 10559; last; }; /^BKV/ && do { $ncbi_taxid = 10629; last; }; /^Bolivian squirrel monkey/ && do { $ncbi_taxid = 39432; last; }; last; }; $first_letter eq 'C' && do { /^Cauliflower/ && do { $ncbi_taxid = 3715; last; }; /^Chamek/ && do { $ncbi_taxid = 118643; last; }; /^Candida albicans/ && do { $ncbi_taxid = 5476; last; }; /^CaMV/ && do { $ncbi_taxid = 10641; last; }; last; }; $first_letter eq 'E' && do { /^Eucalyptus gunnii/ && do { $ncbi_taxid = 3933; last; }; /^EBV, Epstein-Barr virus/ && do { $ncbi_taxid = 10376; last; }; /^Eucalyptus globulus subsp. bicostata/ && do { $ncbi_taxid = 71272; last; }; /^Eucalyptus globulus subsp. globulus/ && do { $ncbi_taxid = 71271; last; }; last; }; $first_letter eq 'F' && do { /^FBR MuLV/ && do { $ncbi_taxid = 11806; last; }; /^FBJ MuLV/ && do { $ncbi_taxid = 11805; last; }; /^FeLV|Feline leukemia/ && do { $ncbi_taxid = 11923; last; }; /^Flaveria trinervia/ && do { $ncbi_taxid = 4227; last; }; /^FSV/ && do { $ncbi_taxid = 11885; last; }; /^F-MuLV/ && do { $ncbi_taxid = 11795; last; }; last; }; $first_letter eq 'H' && do { /^HSV-1/ && do { $ncbi_taxid = 10298; last; }; /^HTLV-I/ && do { $ncbi_taxid = 11908; last; }; /^HIV-1/ && do { $ncbi_taxid = 11676; last; }; /^HPV-16/ && do { $ncbi_taxid = 333760; last; }; /^HBV/ && do { $ncbi_taxid = 10407; last; }; /^HBI/ && do { $ncbi_taxid = 11867; last; }; /^HPV-8/ && do { $ncbi_taxid = 10579; last; }; /^HPV-11/ && do { $ncbi_taxid = 10580; last; }; /^HPV-18/ && do { $ncbi_taxid = 333761; last; }; /^HCMV/ && do { $ncbi_taxid = 10359; last; }; /^HSV/ && do { $ncbi_taxid = 126283; last; }; /^HSV-2/ && do { $ncbi_taxid = 10310; last; }; /^HCV/ && do { $ncbi_taxid = 11108; last; }; /^HIV-2/ && do { $ncbi_taxid = 11709; last; }; last; }; $first_letter eq 'M' && do { /^MMTV/ && do { $ncbi_taxid = 11757; last; }; /^Mo-MuLV/ && do { $ncbi_taxid = 11801; last; }; /^MuLV/ && do { $ncbi_taxid = 11786; last; }; /^MSV/ && do { $ncbi_taxid = 11802; last; }; /^MC29/ && do { $ncbi_taxid = 11868; last; }; /^MVM/ && do { $ncbi_taxid = 10794; last; }; /^MH2E21/ && do { $ncbi_taxid = 11955; last; }; # 11955 is a species, presumably MH2E21 is the strain last; }; $first_letter eq 'R' && do { /^Raphanus sativus/ && do { $ncbi_taxid = 3726; last; }; /^REV-T/ && do { $ncbi_taxid = 11636; last; }; /^RAV-0/ && do { $ncbi_taxid = 11867; last; }; # should be rous-associated virus 0 variant /^RSV/ && do { $ncbi_taxid = 11886; last; }; /^RadLV/ && do { $ncbi_taxid = 31689; last; }; /^RTBV/ && do { $ncbi_taxid = 10654; last; }; last; }; $first_letter eq 'S' && do { /^SV40/ && do { $ncbi_taxid = 10633; last; }; /^Sesbania rostrata/ && do { $ncbi_taxid = 3895; last; }; /^SIV/ && do { $ncbi_taxid = 11723; last; }; /^Spinacia oleracea/ && do { $ncbi_taxid = 3562; last; }; /^SCMV/ && do { $ncbi_taxid = 10364; last; }; # supposed to be AGM isolate last; }; # and lower case $first_letter eq 'a' && do { /^adenovirus type 5/ && do { $ncbi_taxid = 28285; last; }; /^adenovirus type 2/ && do { $ncbi_taxid = 10515; last; }; /^adenovirus/ && do { $ncbi_taxid = 189831; last; }; # 189831 ('unclassified Adenoviridae') is the closest I can get, but this has no genus and is not a species last; }; $first_letter eq 'b' && do { /^bell pepper/ && do { $ncbi_taxid = 4072; last; }; /^baculovirus, Autographa californica/ && do { $ncbi_taxid = 46015; last; }; /^broccoli/ && do { $ncbi_taxid = 36774; last; }; /^barley/ && do { $ncbi_taxid = 112509; last; }; last; }; $first_letter eq 'c' && do { /^clawed frog/ && do { $ncbi_taxid = 8355; last; }; /^chipmunk/ && do { $ncbi_taxid = 64680; last; }; /^common tree shrew/ && do { $ncbi_taxid = 37347; last; }; /^cat/ && do { $ncbi_taxid = 9685; last; }; last; }; # and misc /^NK24/ && do { $ncbi_taxid = 11955; last; }; /^OK10/ && do { $ncbi_taxid = 11871; last; }; /^Dendrobium grex/ && do { $ncbi_taxid = 84618; last; }; /^KSHV/ && do { $ncbi_taxid = 37296; last; }; /^Oncidium/ && do { $ncbi_taxid = 96474; last; }; /^Japanese quail/ && do { $ncbi_taxid = 93934; last; }; /^Nile tilapia/ && do { $ncbi_taxid = 8128; last; }; /^GALV/ && do { $ncbi_taxid = 11840; last; }; /^JCV/ && do { $ncbi_taxid = 10632; last; }; /^LPV/ && do { $ncbi_taxid = 10574; last; }; /^Py,/ && do { $ncbi_taxid = 36362; last; }; /^DHBV/ && do { $ncbi_taxid = 12639; last; }; /^VZV/ && do { $ncbi_taxid = 10335; last; }; /^Vicia faba/ && do { $ncbi_taxid = 3906; last; }; /^hamster/ && do { $ncbi_taxid = 10029; last; }; /^sea urchin/ && do { $ncbi_taxid = 7668; last; }; /^fruit fly/ && do { $ncbi_taxid = 7227; last; }; /^halibut/ && do { $ncbi_taxid = 8267; last; }; /^vaccinia virus/ && do { $ncbi_taxid = 10245; last; }; /^taxonomic class Mammalia/ && do { $ncbi_taxid = 40674; last; }; # not a species /^taxonomic class Vertebrata/ && do { $ncbi_taxid = 7742; last; }; # not a species /^dog/ && do { $ncbi_taxid = 9615; last; }; /^parsley/ && do { $ncbi_taxid = 4043; last; }; /^mouse, Mus domesticus Torino/ && do { $ncbi_taxid = 10092; last; }; # 10092 is domesticus subspecies, but not the Torino strain /^lemur, Eulemur fulvus collaris/ && do { $ncbi_taxid = 47178; last; }; /^red sea bream/ && do { $ncbi_taxid = 143350; last; }; /^zebra finch/ && do { $ncbi_taxid = 59729; last; }; /^mung bean/ && do { $ncbi_taxid = 3916; last; }; /^soybean/ && do { $ncbi_taxid = 3847; last; }; /^oat/ && do { $ncbi_taxid = 4498; last; }; /^pseudorabies virus/ && do { $ncbi_taxid = 10345; last; }; } } $self->warn("Didn't know what species '$raw_species' was, unable to classify") unless $ncbi_taxid; return $ncbi_taxid; } 1; BioPerl-1.6.923/Bio/Draw000755000765000024 012254227317 14712 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Draw/Pictogram.pm000444000765000024 3334412254227317 17361 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Draw::Pictogram # # Please direct questions and support issues to # # Cared for by Shawn Hoon # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Draw::Pictogram - generate SVG output of Pictogram display for consensus motifs =head1 SYNOPSIS use Bio::Draw::Pictogram; use Bio::SeqIO; my $sio = Bio::SeqIO->new(-file=>$ARGV[0],-format=>'fasta'); my @seq; while(my $seq = $sio->next_seq){ push @seq, $seq; } my $picto = Bio::Draw::Pictogram->new(-width=>"800", -height=>"500", -fontsize=>"60", -plot_bits=>1, -background=>{ 'A'=>0.25, 'C'=>0.18, 'T'=>0.32, 'G'=>0.25}, -color=>{'A'=>'red', 'G'=>'blue', 'C'=>'green', 'T'=>'magenta'}); my $svg = $picto->make_svg(\@seq); print $svg->xmlify."\n"; #Support for Bio::Matrix::PSM::SiteMatrix now included use Bio::Matrix::PSM::IO; my $picto = Bio::Draw::Pictogram->new(-width=>"800", -height=>"500", -fontsize=>"60", -plot_bits=>1, -background=>{ 'A'=>0.25, 'C'=>0.18, 'T'=>0.32, 'G'=>0.25}, -color=>{'A'=>'red', 'G'=>'blue', 'C'=>'green', 'T'=>'magenta'}); my $psm = $psmIO->next_psm; my $svg = $picto->make_svg($psm); print $svg->xmlify; =head1 DESCRIPTION A module for generating SVG output of Pictogram display for consensus motifs. This method of representation was describe by Burge and colleagues: (Burge, C.B.,Tuschl, T., Sharp, P.A. in The RNA world II, 525-560, CSHL press, 1999) This is a simple module that takes in an array of sequences (assuming equal lengths) and calculates relative base frequencies where the height of each letter reflects the frequency of each nucleotide at a given position. It can also plot the information content at each position scaled by the background frequencies of each nucleotide. It requires the SVG-2.26 or later module by Ronan Oger available at http://www.cpan.org Recommended viewing of the SVG is the plugin available at Adobe: http://www.adobe.com/svg =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut package Bio::Draw::Pictogram; use strict; use SVG 2.26; use Bio::SeqIO; use base qw(Bio::Root::Root); use constant MAXBITS => 2; =head2 new Title : new Usage : my $picto = Bio::Draw::Pictogram->new(-width=>"800", -height=>"500", -fontsize=>"60", -plot_bits=>1, -background=>{ 'A'=>0.25, 'C'=>0.18, 'T'=>0.32, 'G'=>0.25}, -color=>{'A'=>'red', 'G'=>'blue', 'C'=>'green', 'T'=>'magenta'}); Function: Constructor for Pictogram Object Returns : L =cut sub new { my ($caller,@args) = @_; my $self = $caller->SUPER::new(@args); my ($width,$height,$fontsize,$color,$background,$bit,$normalize) = $self->_rearrange([qw(WIDTH HEIGHT FONTSIZE COLOR BACKGROUND PLOT_BITS NORMALIZE)],@args); $width||=800; $height||=600; my $svg = SVG->new(width=>$width,height=>$height); $self->svg_obj($svg); $fontsize ||= 80; $self->fontsize($fontsize) if $fontsize; $color = $color || {'T'=>'black','C'=>'blue','G'=>'green','A'=>'red'}; $self->color($color); $background = $background || {'T'=>0.25,'C'=>0.25,'G'=>0.25,'A'=>0.25}; $self->background($background); $self->plot_bits($bit) if $bit; $self->normalize($normalize) if $normalize; return $self; } =head2 make_svg Title : make_svg Usage : $picto->make_svg(); Function: make the SVG object Returns : L Arguments: A fasta file or array ref of L objects or a L =cut sub make_svg { my ($self,$input) = @_; my $fontsize = $self->fontsize; my $size = $fontsize * 0.75; my $width= $size; my $height= $size+40; my $color = $self->color; #starting x coordinate for pictogram my $x = 45+$size/2; my $pos_y = $size * 2; my $bit_y = $pos_y+40; my @pwm; my $bp = 1; #input can be file or array ref of sequences if(ref($input) eq 'ARRAY'){ @pwm = @{$self->_make_pwm($input)}; } elsif(ref($input) && $input->isa("Bio::Matrix::PSM::SiteMatrixI")){ @pwm = $self->_make_pwm_from_site_matrix($input); } else { my $sio = Bio::SeqIO->new(-file=>$input,-format=>"fasta"); my @seq; while (my $seq = $sio->next_seq){ push @seq, $seq; } @pwm = @{$self->_make_pwm(\@seq)}; } my $svg = $self->svg_obj; my $seq_length = scalar(@pwm + 1) * $width + $x + $x; my $seq_grp; #scale the svg if length greater than svg width if($seq_length > $svg->{-document}->{'width'}){ my $ratio = $svg->{-document}->{'width'}/($seq_length); $seq_grp = $svg->group(transform=>"scale($ratio,1)"); } else { $seq_grp= $svg->group(); } #do the drawing, each set is a base position foreach my $set(@pwm){ my ($A,$C,$G,$T,$bits) = @$set; my @array; push @array, ['a',($A)]; push @array, ['g',($G)]; push @array, ['c',($C)]; push @array, ['t',($T)]; @array = sort {$b->[1]<=>$a->[1]}@array; my $count = 1; my $pos_group = $seq_grp->group(id=>"bp $bp"); my $prev_size; my $y_trans; #draw each letter at each position foreach my $letter(@array){ my $scale; if($self->normalize){ $scale = $letter->[1]; } else { $scale = $letter->[1] * ($bits / MAXBITS); } if($count == 1){ if($self->normalize){ $y_trans = 0; } else { $y_trans = (1 - ($bits / MAXBITS)) * $size; } } else { $y_trans += $prev_size; } $pos_group->text('id'=> uc($letter->[0]).$bp,height=>$height, 'width'=>$width,x=>$x,y=>$size, 'transform'=>"translate(0,$y_trans),scale(1,$scale)", 'style'=>{"font-size"=>$fontsize, 'text-anchor'=>'middle', 'font-family'=>'Verdana', 'fill'=>$color->{uc $letter->[0]}})->cdata(uc $letter->[0]) if $scale > 0; $prev_size = $scale * $size; $count++; } #plot the bit if required if($self->plot_bits){ $seq_grp->text('x'=>$x, 'y'=>$bit_y, 'style'=>{"font-size"=>'10', 'text-anchor'=>'middle', 'font-family'=>'Verdana', 'fill'=>'black'})->cdata($bits); } $bp++; $x+=$width; } #plot the tags $seq_grp->text(x=>int($width/2),y=>$bit_y,style=>{"font-size"=>'10','text-anchor'=>'middle','font-family'=>'Verdana','fill'=>'black'})->cdata("Bits:") if $self->plot_bits; $seq_grp->text(x=>int($width/2),y=>$pos_y,style=>{"font-size"=>'10','text-anchor'=>'middle','font-family'=>'Verdana','fill'=>'black'})->cdata("Position:"); #plot the base positions $x = 45+$size/2-int($width/2); foreach my $nbr(1..($bp-1)){ $seq_grp->text(x=>$x+int($width/2),y=>$pos_y,style=>{"font-size"=>'10','text-anchor'=>'left','font-family'=>'Verdana','fill'=>'black'})->cdata($nbr); $x+=$width; } # $seq_grp->transform("scale(2,2)"); return $self->svg_obj($svg); } sub _make_pwm_from_site_matrix{ my ($self,$matrix) = @_; my $bgd = $self->background; my @pwm; my $consensus = $matrix->consensus; foreach my $i(1..length($consensus)){ my %base = $matrix->next_pos; my $bits; $bits+=($base{pA} * log2($base{pA}/$bgd->{'A'})); $bits+=($base{pC} * log2($base{pC}/$bgd->{'C'})); $bits+=($base{pG} * log2($base{pG}/$bgd->{'G'})); $bits+=($base{pT} * log2($base{pT}/$bgd->{'T'})); push @pwm, [$base{pA},$base{pC},$base{pG},$base{pT},abs(sprintf("%.3f",$bits))]; } return @pwm; } sub _make_pwm { my ($self,$input) = @_; my $count = 1; my %hash; my $bgd = $self->background; #sum up the frequencies at each base pair foreach my $seq(@$input){ my $string = $seq->seq; $string = uc $string; my @motif = split('',$string); my $pos = 1; foreach my $t(@motif){ $hash{$pos}{$t}++; $pos++; } $count++; } #calculate relative freq my @pwm; #decrement last count $count--; foreach my $pos(sort{$a<=>$b} keys %hash){ my @array; push @array,($hash{$pos}{'A'}||0)/$count; push @array,($hash{$pos}{'C'}||0)/$count; push @array,($hash{$pos}{'G'}||0)/$count; push @array,($hash{$pos}{'T'}||0)/$count; #calculate bits # relative entropy (RelEnt) or Kullback-Liebler distance # relent = sum fk * log2(fk/gk) where fk is frequency of nucleotide k and # gk the background frequency of nucleotide k my $bits; $bits+=(($hash{$pos}{'A'}||0) / $count) * log2((($hash{$pos}{'A'}||0)/$count) / ($bgd->{'A'})); $bits+=(($hash{$pos}{'C'}||0) / $count) * log2((($hash{$pos}{'C'}||0)/$count) / ($bgd->{'C'})); $bits+=(($hash{$pos}{'G'}||0) / $count) * log2((($hash{$pos}{'G'}||0)/$count) / ($bgd->{'G'})); $bits+=(($hash{$pos}{'T'}||0) / $count) * log2((($hash{$pos}{'T'}||0)/$count) / ($bgd->{'T'})); push @array, abs(sprintf("%.3f",$bits)); push @pwm,\@array; } return $self->pwm(\@pwm); } ###various get/sets =head2 fontsize Title : fontsize Usage : $picto->fontsize(); Function: get/set for fontsize Returns : int Arguments: int =cut sub fontsize { my ($self,$obj) = @_; if($obj){ $self->{'_fontsize'} = $obj; } return $self->{'_fontsize'}; } =head2 color Title : color Usage : $picto->color(); Function: get/set for color Returns : a hash reference Arguments: a hash reference =cut sub color { my ($self,$obj) = @_; if($obj){ $self->{'_color'} = $obj; } return $self->{'_color'}; } =head2 svg_obj Title : svg_obj Usage : $picto->svg_obj(); Function: get/set for svg_obj Returns : L Arguments: L =cut sub svg_obj { my ($self,$obj) = @_; if($obj){ $self->{'_svg_obj'} = $obj; } return $self->{'_svg_obj'}; } =head2 plot_bits Title : plot_bits Usage : $picto->plot_bits(); Function: get/set for plot_bits to indicate whether to plot information content at each base position Returns :1/0 Arguments: 1/0 =cut sub plot_bits { my ($self,$obj) = @_; if($obj){ $self->{'_plot_bits'} = $obj; } return $self->{'_plot_bits'}; } =head2 normalize Title : normalize Usage : $picto->normalize($newval) Function: get/set to make all columns the same height. default is to scale height with information content. Returns : value of normalize (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub normalize{ my $self = shift; return $self->{'normalize'} = shift if @_; return $self->{'normalize'}; } =head2 background Title : background Usage : $picto->background(); Function: get/set for hash reference of nucleodtide bgd frequencies Returns : hash reference Arguments: hash reference =cut sub background { my ($self,$obj) = @_; if($obj){ $self->{'_background'} = $obj; } return $self->{'_background'}; } =head2 pwm Title : pwm Usage : $picto->pwm(); Function: get/set for pwm Returns : int Arguments: int =cut sub pwm { my ($self,$pwm) = @_; if($pwm){ $self->{'_pwm'} = $pwm; } return $self->{'_pwm'}; } #utility method for returning log 2 sub log2 { my ($val) = @_; return 0 if $val==0; return log($val)/log(2); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Event���������������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 15072� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Event/EventGeneratorI.pm��������������������������������������������������������000444��000765��000024�� 4330�12254227330� 20625� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Event::EventGeneratorI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Event::EventGeneratorI - This interface describes the basic event generator class. =head1 SYNOPSIS # Do not use this object directly # This object has the basic methods for describing an event generator =head1 DESCRIPTION This object describes the basic event generator system. It basically allows one to attach one or many event handlers. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Event::EventGeneratorI; use strict; use base qw(Bio::Root::RootI); =head2 attach_EventHandler Title : attach_EventHandler Usage : $parser->attatch_EventHandler($handler) Function: Adds an event handler to listen for events Returns : none Args : Bio::Event::EventHandlerI =cut sub attach_EventHandler{ my ($self) = @_; $self->throw_not_implemented(); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Event/EventHandlerI.pm����������������������������������������������������������000444��000765��000024�� 21554�12254227340� 20304� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Event::EventHandlerI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Event::EventHandlerI - An Event Handler Interface =head1 SYNOPSIS # do not use this module directly # See Bio::SearchIO::SearchResultEventHandler for an example of # implementation. =head1 DESCRIPTION This interface describes the basic methods required for EventHandlers. These are essentially SAX methods. =head1 Developer Notes EventHandlerI implementations are used in the BioPerl IO systems to decouple the task of tokenizing the input stream into data elements and their attributes, which is format-specific, and the task of collecting those elements and attributes into whatever is the result of a parser, which is specific to the kind of result to be produced, such as BioPerl objects, a tabular or array data structure, etc. You can think of EventHandlerI-compliant parsers as faking a SAX XML parser, making their input (typically a non-XML document) behave as if it were XML. The overhead to do this can be quite substantial, at the gain of not having to duplicate the parsing code in order to change the parsing result, and not having to duplicate the logic of instantiating objects between parsers for different formats that all give rise to the same types of objects. This is perhaps best illustrated by the Bio::SearchIO system, where many different formats exist for sequence similarity and pairwise sequence alignment exist that essentially all result in Bio::Search objects. The method names and their invocation semantics follow their XML SAX equivalents, see http://www.saxproject.org/apidoc/, especially the org.xml.sax.ContentHandler interface. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Event::EventHandlerI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 will_handle Title : will_handle Usage : if( $handler->will_handle($event_type) ) { ... } Function: Tests if this event builder knows how to process a specific event Returns : boolean Args : event type name =cut sub will_handle{ my ($self,$type) = @_; $self->throw_not_implemented(); } =head2 SAX methods =cut =head2 start_document Title : start_document Usage : $resultObj = $parser->start_document(); Function: Receive notification of the beginning of a document (the input file of a parser). The parser will invoke this method only once, before any other event callbacks. Usually, a handler will reset any internal state structures when this method is called. Returns : none Args : none =cut sub start_document{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 end_document Title : end_document Usage : $parser->end_document(); Function: Receive notification of the end of a document (normally the input file of a parser). The parser will invoke this method only once, and it will be the last method invoked during the parse of the document. The parser shall not invoke this method until it has either abandoned parsing (because of an unrecoverable error) or reached the end of input. Unlike the XML SAX signature of this method, this method is expected to return the object representing the result of parsing the document. Returns : The object representing the result of parsing the input stream between the calls to start_document() and this method. Args : none =cut sub end_document{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 start_element Title : start_element Usage : $parser->start_element Function: Receive notification of the beginning of an element. The Parser will invoke this method at the beginning of every element in the input stream; there will be a corresponding end_element() event for every start_element() event (even when the element is empty). All of the element's content will be reported, in order, before the corresponding end_element() event. Returns : none Args : A hashref with at least 2 keys: 'Data' and 'Name'. The value for 'Name' is expected to be the type of element being encountered; the understood values will depend on the IO parser to which this interface is being applied. Likewise, the value for 'Data' will be specific to event handler implementions, and the specific data chunking needs of input formats to be handled efficiently. =cut sub start_element{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 end_element Title : end_element Usage : $parser->end_element Function: Receive notification of the end of an element. The parser will invoke this method at the end of every element in the input stream; there will be a corresponding start_element() event for every end_element() event (even when the element is empty). Returns : none Args : hashref with at least 2 keys, 'Data' and 'Name'. The semantics are the same as for start_element(). =cut sub end_element{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 in_element Title : in_element Usage : if( $handler->in_element($element) ) {} Function: Test if we are in a particular element. Normally, in_element() will test for particular attributes, or nested elements, within a containing element. Conversely, the containing element can be queries with within_element(). The names understood as argument should be the same as the ones understood for the 'Name' key in start_element() and end_element(). Typically, handler implementations will call this method from within the characters() method to determine the context of the data that were passed to characters(). Returns : boolean Args : A string, the name of the element (normally an attribute name or nested sub-element name). =cut sub in_element{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 within_element Title : within_element Usage : if( $handler->within_element($element) ) {} Function: Test if we are within a particular kind of element. Normally, the element type names understood as argument values will be for containing elements or data chunks. Conversely, in_element() can be used to test whether an attribute or nested element is the ccurrent context. Typically, a handler will call this method from within the characters() method to determine the context for the data that were passed to characters(). Returns : boolean Args : string element name =cut sub within_element{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 characters Title : characters Usage : $parser->characters($str) Function: Receive notification of character data. The parser will call this method to report values of attributes, or larger data chunks, depending on the IO subsystem and event handler implementation. Values may be whitespace-padded even if the whitespace is insignificant for the format. The context of the character data being passed can be determined by calling the in_element() and within_element() methods. Returns : none Args : string, the character data =cut sub characters{ my ($self,@args) = @_; $self->throw_not_implemented; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory�������������������������������������������������������������������������000755��000765��000024�� 0�12254227336� 15425� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/AnalysisI.pm������������������������������������������������������������000444��000765��000024�� 7740�12254227320� 20015� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::AnalysisI # # Please direct questions and support issues to # # Cared for by Martin Senger # For copyright and disclaimer see below. # # POD documentation - main docs before the code =head1 NAME Bio::Factory::AnalysisI - An interface to analysis tool factory =head1 SYNOPSIS This is an interface module - you do not instantiate it. Use I module: use Bio::Tools::Run::AnalysisFactory; my $list = Bio::Tools::Run::AnalysisFactory->new->available_analyses; =head1 DESCRIPTION This interface contains all public methods for showing available analyses and for creating objects representing them. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Martin Senger (martin.senger@gmail.com) =head1 COPYRIGHT Copyright (c) 2003, Martin Senger and EMBL-EBI. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO =over =item * http://www.ebi.ac.uk/Tools/webservices/soaplab/guide =back =head1 APPENDIX This is actually the main documentation... If you try to call any of these methods directly on this C object you will get a I error message. You need to call them on a C object instead. =cut # Let the code begin... package Bio::Factory::AnalysisI; use strict; use base qw(Bio::Root::RootI); # ----------------------------------------------------------------------------- =head2 available_categories Usage : $factory->available_categories; Returns : an array reference with the names of available categories Args : none The analysis tools may be grouped into categories by their functional similarity, or by the similar data types they deal with. This method shows all available such categories. =cut sub available_categories { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 available_analyses Usage : $factory->available_analyses; $factory->available_analyses ($category); Returns : an array reference with the names of all available analyses, or the analyses available in the given '$category' Args : none || category_name Show available analyses. Their names usually consist of category analysis names, separated by C<::>. =cut sub available_analyses { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- =head2 create_analysis Usage : $factory->create_analysis ($name); Returns : a Bio::Tools::Run::Analyis object Args : analysis name A real I method creating an analysis object. The created object gets all access and location information from the factory object. =cut sub create_analysis { shift->throw_not_implemented(); } # ----------------------------------------------------------------------------- 1; __END__ ��������������������������������BioPerl-1.6.923/Bio/Factory/ApplicationFactoryI.pm��������������������������������������������������000444��000765��000024�� 4107�12254227332� 22022� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::ApplicationFactoryI # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Factory::ApplicationFactoryI - Interface class for Application Factories =head1 SYNOPSIS You wont be using this as an object, but using a derived class. =head1 DESCRIPTION Holds common Application Factory attributes in place. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::ApplicationFactoryI; use strict; use base qw(Bio::Root::RootI); =head2 version Title : version Usage : exit if $prog->version() < 1.8 Function: Determine the version number of the program Example : Returns : float or undef Args : none =cut sub version { shift->throw_not_implemented(); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/DriverFactory.pm��������������������������������������������������������000444��000765��000024�� 11121�12254227323� 20713� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::DriverFactory # # Please direct questions and support issues to # # Cared for by Jason Stajich and # Hilmar Lapp # # Copyright Jason Stajich, Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Factory::DriverFactory - Base class for factory classes loading drivers =head1 SYNOPSIS #this class is not instantiable =head1 DESCRIPTION This a base class for factory classes that load drivers. Normally, you don't instantiate this class directly. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email Jason Stajich Ejason@bioperl.orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' package Bio::Factory::DriverFactory; use strict; use File::Spec; use vars qw(%DRIVERS); use base qw(Bio::Root::Root); BEGIN { %DRIVERS = (); } sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 register_driver Title : register_driver Usage : $factory->register_driver("genscan", "Bio::Tools::Genscan"); Function: Registers a driver a factory class should be able to instantiate. This method can be called both as an instance and as a class method. Returns : Args : Key of the driver (string) and the module implementing the driver (string). =cut sub register_driver { my ($self, @args) = @_; my %drivers = @args; foreach my $drv (keys(%drivers)) { # note that this doesn't care whether $self is the class or the object $self->driver_table()->{$drv} = $drivers{$drv}; } } =head2 driver_table Title : driver_table Usage : $table = $factory->driver_table(); Function: Returns a reference to the hash table storing associations of methods with drivers. You use this table to look up registered methods (keys) and drivers (values). In this implementation the table is class-specific and therefore shared by all instances. You can override this in a derived class, but note that this method can be called both as an instance and a class method. This will be the table used by the object internally. You should definitely know what you're doing if you modify the table's contents. Modifications are shared by _all_ instances, those present and those yet to be created. Returns : A reference to a hash table. Args : =cut sub driver_table { my ($self, @args) = @_; return \%DRIVERS; } =head2 get_driver Title : get_driver Usage : $module = $factory->get_driver("genscan"); Function: Returns the module implementing a driver registered under the given key. Example : Returns : A string. Args : Key of the driver (string). =cut sub get_driver { my ($self, $key) = @_; if(exists($self->driver_table()->{$key})) { return $self->driver_table()->{$key}; } return; } =head2 _load_module Title : _load_module Usage : $self->_load_module("Bio::Tools::Genscan"); Function: Loads up (like use) a module at run time on demand. Example : Returns : TRUE on success Args : =cut sub _load_module { my ($self, $name) = @_; my ($module, $load, $m); $module = "_<$name.pm"; return 1 if $main::{$module}; $load = "$name.pm"; $load = File::Spec->catfile((split(/::/,$load))); eval { require $load; }; if ( $@ ) { $self->throw("$load: $name cannot be found: ".$@); } return 1; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/FTLocationFactory.pm����������������������������������������������������000444��000765��000024�� 30566�12254227316� 21502� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::FTLocationFactory # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gnf.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Factory::FTLocationFactory - A FeatureTable Location Parser =head1 SYNOPSIS # parse a string into a location object $loc = Bio::Factory::FTLocationFactory->from_string("join(100..200, 400..500"); =head1 DESCRIPTION Implementation of string-encoded location parsing for the Genbank feature table encoding of locations. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl-dot-org Chris Fields, cjfields-at-uiuc-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::FTLocationFactory; use vars qw($LOCREG); use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Location::Simple; use Bio::Location::Split; use Bio::Location::Fuzzy; use base qw(Bio::Root::Root Bio::Factory::LocationFactoryI); BEGIN { # the below is an optimized regex obj. from J. Freidl's Mastering Reg Exp. $LOCREG = qr{ (?> [^()]+ | \( (??{$LOCREG}) \) )* }x; } =head2 new Title : new Usage : my $obj = Bio::Factory::FTLocationFactory->new(); Function: Builds a new Bio::Factory::FTLocationFactory object Returns : an instance of Bio::Factory::FTLocationFactory Args : =cut =head2 from_string Title : from_string Usage : $loc = $locfactory->from_string("100..200"); Function: Parses the given string and returns a Bio::LocationI implementing object representing the location encoded by the string. This implementation parses the Genbank feature table encoding of locations. Example : Returns : A Bio::LocationI implementing object. Args : A string. =cut sub from_string { my ($self,$locstr,$op) = @_; my $loc; #$self->debug("$locstr\n"); # $op for operator (error handling) # run on first pass only # Note : These location types are now deprecated in GenBank (Oct. 2006) if (!defined($op)) { # convert all (X.Y) to [X.Y] $locstr =~ s{\((\d+\.\d+)\)}{\[$1\]}g; # convert ABC123:(X..Y) to ABC123:[X..Y] # we should never see the above $locstr =~ s{:\((\d+\.{2}\d+)\)}{:\[$1\]}g; } if ($locstr =~ m{(.*?)\(($LOCREG)\)(.*)}o) { # any matching parentheses? my ($beg, $mid, $end) = ($1, $2, $3); my (@sublocs) = (split(q(,),$beg), $mid, split(q(,),$end)); my @loc_objs; my $loc_obj; my @gl_subloc_strands; SUBLOCS: while (@sublocs) { my $subloc = shift @sublocs; next if !$subloc; my $oparg = ($subloc eq 'join' || $subloc eq 'bond' || $subloc eq 'order' || $subloc eq 'complement') ? $subloc : undef; # has operator, requires further work (recurse) if ($oparg) { my $sub = shift @sublocs; # simple split operators (no recursive calls needed) if (($oparg eq 'join' || $oparg eq 'order' || $oparg eq 'bond' ) && $sub !~ m{(?:join|order|bond)}) { my @splitlocs = split(q(,), $sub); $loc_obj = Bio::Location::Split->new(-verbose => 1, -splittype => $oparg); # Store strand values for later consistency check my @subloc_strands; my @s_objs; foreach my $splitloc (@splitlocs) { next unless $splitloc; my $sobj; if ($splitloc =~ m{\(($LOCREG)\)}) { my $comploc = $1; $sobj = $self->_parse_location($comploc); $sobj->strand(-1); push @subloc_strands, -1; push @gl_subloc_strands, -1; } else { $sobj = $self->_parse_location($splitloc); push @subloc_strands, 1; push @gl_subloc_strands, 1; } push @s_objs, $sobj; } # Sublocations strand values consistency check to set # Guide Strand and sublocations adding order if (scalar @s_objs > 0) { my $identical = 0; my $gl_identical = 0; my $first_value = $subloc_strands[0]; foreach my $strand (@subloc_strands) { $identical++ if ($strand == $first_value); } my $first_gl_value = $gl_subloc_strands[0]; foreach my $gl_strand (@gl_subloc_strands) { $gl_identical++ if ($gl_strand == $first_gl_value); } if ($identical == scalar @subloc_strands) { # Set guide_strand if all sublocations have the same strand $loc_obj->guide_strand($first_value); # Reverse sublocation order for negative strand locations in cases like this: # join(1..11,join(complement(40..50),complement(60..70))) # But not this: # join(complement(10..20),complement(30..40)) if ( $gl_identical != scalar @gl_subloc_strands and $first_value == -1 ) { @s_objs = reverse @s_objs; } } else { # Mixed strand values $loc_obj->guide_strand(undef); } # Add sublocations foreach my $s_obj (@s_objs) { $loc_obj->add_sub_Location($s_obj); } } } else { $loc_obj = $self->from_string($sub, $oparg); # reinsure the operator is set correctly for this level # unless it is complement $loc_obj->splittype($oparg) unless $oparg eq 'complement'; } } # no operator, simple or fuzzy else { $loc_obj = $self->from_string($subloc,1); } if ($op && $op eq 'complement') { $loc_obj->strand(-1); push @gl_subloc_strands, -1; } else { push @gl_subloc_strands, 1; } push @loc_objs, $loc_obj; } my $ct = @loc_objs; if ($op && !($op eq 'join' || $op eq 'order' || $op eq 'bond') && $ct > 1 ) { $self->throw("Bad operator $op: had multiple locations ". scalar(@loc_objs).", should be SplitLocationI"); } if ($ct > 1) { $loc = Bio::Location::Split->new(); $loc->add_sub_Location(shift @loc_objs) while (@loc_objs); return $loc; } else { $loc = shift @loc_objs; return $loc; } } else { # simple location(s) $loc = $self->_parse_location($locstr); $loc->strand(-1) if ($op && $op eq 'complement'); } return $loc; } =head2 _parse_location Title : _parse_location Usage : $loc = $locfactory->_parse_location( $loc_string) Function: Parses the given location string and returns a location object with start() and end() and strand() set appropriately. Note that this method is private. Returns : A Bio::LocationI implementing object or undef on failure Args : location string =cut sub _parse_location { my ($self, $locstr) = @_; my ($loc, $seqid); #$self->debug( "Location parse, processing $locstr\n"); # 'remote' location? if($locstr =~ m{^(\S+):(.*)$}o) { # yes; memorize remote ID and strip from location string $seqid = $1; $locstr = $2; } # split into start and end my ($start, $end) = split(/\.\./, $locstr); # remove enclosing parentheses if any; note that because of parentheses # possibly surrounding the entire location the parentheses around start # and/or may be asymmetrical # Note: these are from X.Y fuzzy locations, which are deprecated! $start =~ s/(?:^\[+|\]+$)//g if $start; $end =~ s/(?:^\[+|\]+$)//g if $end; # Is this a simple (exact) or a fuzzy location? Simples have exact start # and end, or is between two adjacent bases. Everything else is fuzzy. my $loctype = ".."; # exact with start and end as default $loctype = '?' if ( ($locstr =~ /\?/) && ($locstr !~ /\?\d+/) ); my $locclass = "Bio::Location::Simple"; if(! defined($end)) { if($locstr =~ /(\d+)([\.\^])(\d+)/) { $start = $1; $end = $3; $loctype = $2; $locclass = "Bio::Location::Fuzzy" unless (abs($end-$start) <= 1) && ($loctype eq "^"); } else { $end = $start; } } # start_num and end_num are for the numeric only versions of # start and end so they can be compared # in a few lines my ($start_num, $end_num) = ($start,$end); if ( ($start =~ /[\>\<\?\.\^]/) || ($end =~ /[\>\<\?\.\^]/) ) { $locclass = 'Bio::Location::Fuzzy'; if($start =~ /(\d+)/) { ($start_num) = $1; } else { $start_num = 0 } if ($end =~ /(\d+)/) { ($end_num) = $1; } else { $end_num = 0 } } my $strand = 1; if( $start_num > $end_num && $loctype ne '?') { ($start,$end,$strand) = ($end,$start,-1); } # instantiate location and initialize $loc = $locclass->new(-verbose => $self->verbose, -start => $start, -end => $end, -strand => $strand, -location_type => $loctype); # set remote ID if remote location if($seqid) { $loc->is_remote(1); $loc->seq_id($seqid); } # done (hopefully) return $loc; } 1; ������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/LocationFactoryI.pm�����������������������������������������������������000444��000765��000024�� 6410�12254227314� 21326� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::LocationFactoryI # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gnf.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Factory::LocationFactoryI - A factory interface for generating locations from a string =head1 SYNOPSIS # Do not use directly, see Bio::Factory::LocationFactory for example use Bio::Factory::FTLocationFactory; my $locfact = Bio::Factory::FTLocationFactory->new(); my $location = $locfact->from_string("1..200"); print $location->start(), " ", $location->end(), " ", $location->strand,"\n"; =head1 DESCRIPTION An interface for Location Factories which generate Bio::LocationI objects from a string. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::LocationFactoryI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 from_string Title : from_string Usage : $loc = $locfactory->from_string("100..200"); Function: Parses the given string and returns a Bio::LocationI implementing object representing the location encoded by the string. Different implementations may support different encodings. An example of a commonly used encoding is the Genbank feature table encoding of locations. Example : Returns : A Bio::LocationI implementing object. Args : A string. =cut sub from_string{ my ($self,@args) = @_; $self->throw_not_implemented(); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/MapFactoryI.pm����������������������������������������������������������000444��000765��000024�� 5010�12254227331� 20265� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::MapFactoryI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Factory::MapFactoryI - A Factory for getting markers =head1 SYNOPSIS # get a Map Factory somehow likely from Bio::MapIO system while( my $map = $mapin->next_map ) { print "map name is ", $map->name, " length is ", $map->length, " ", $map->units, "\n"; $mapout->write_map($map); } =head1 DESCRIPTION This interface describes the necessary minimum methods for getting Maps from a data stream. It also supports writing Map data back to a stream. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::MapFactoryI; use strict; use base qw(Bio::Root::RootI); =head2 next_map Title : next_map Usage : my $map = $factory->next_map; Function: Get a map from the factory Returns : L Args : none =cut sub next_map{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 write_map Title : write_map Usage : $factory->write_map($map); Function: Write a map out through the factory Returns : none Args : L =cut sub write_map{ my ($self,@args) = @_; $self->throw_not_implemented(); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/ObjectBuilderI.pm�������������������������������������������������������000444��000765��000024�� 13100�12254227313� 20754� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::ObjectBuilderI # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Factory::ObjectBuilderI - Interface for an object builder =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION An object builder is different from an object factory in that it accumulates information for the object and finally, or constantly, depending on the implementation, builds the object. It also allows for implementations that can tell the information feed in which kind of information the builder is interested in which not. In addition, the implementation may choose to filter, transform, or completely ignore certain content it is fed for certain slots. Implementations will hence be mostly used by stream-based parsers to parse only desired content, and/or skip over undesired entries. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::ObjectBuilderI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 want_slot Title : want_slot Usage : Function: Whether or not the object builder wants to populate the specified slot of the object to be built. The slot can be specified either as the name of the respective method, or the initialization parameter that would be otherwise passed to new() of the object to be built. Example : Returns : TRUE if the object builder wants to populate the slot, and FALSE otherwise. Args : the name of the slot (a string) =cut sub want_slot{ shift->throw_not_implemented(); } =head2 add_slot_value Title : add_slot_value Usage : Function: Adds one or more values to the specified slot of the object to be built. Naming the slot is the same as for want_slot(). The object builder may further filter the content to be set, or even completely ignore the request. If this method reports failure, the caller should not add more values to the same slot. In addition, the caller may find it appropriate to abandon the object being built altogether. Example : Returns : TRUE on success, and FALSE otherwise Args : the name of the slot (a string) parameters determining the value to be set =cut sub add_slot_value{ shift->throw_not_implemented(); } =head2 want_object Title : want_object Usage : Function: Whether or not the object builder is still interested in continuing with the object being built. If this method returns FALSE, the caller should not add any more values to slots, or otherwise risks that the builder throws an exception. In addition, make_object() is likely to return undef after this method returned FALSE. Example : Returns : TRUE if the object builder wants to continue building the present object, and FALSE otherwise. Args : none =cut sub want_object{ shift->throw_not_implemented(); } =head2 make_object Title : make_object Usage : Function: Get the built object. This method is allowed to return undef if no value has ever been added since the last call to make_object(), or if want_object() returned FALSE (or would have returned FALSE) before calling this method. For an implementation that allows consecutive building of objects, a caller must call this method once, and only once, between subsequent objects to be built. I.e., a call to make_object implies 'end_object.' Example : Returns : the object that was built Args : none =cut sub make_object{ shift->throw_not_implemented(); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/ObjectFactory.pm��������������������������������������������������������000444��000765��000024�� 16142�12254227321� 20674� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::ObjectFactory # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Factory::ObjectFactory - Instantiates a new Bio::Root::RootI (or derived class) through a factory =head1 SYNOPSIS use Bio::Factory::ObjectFactory; my $factory = Bio::Factory::ObjectFactory->new(-type => 'Bio::Ontology::GOterm'); my $term = $factory->create_object(-name => 'peroxisome', -ontology => 'Gene Factory', -identifier => 'GO:0005777'); =head1 DESCRIPTION This object will build L objects generically. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 CONTRIBUTORS This is mostly copy-and-paste with subsequent adaptation from Bio::Seq::SeqFactory by Jason Stajich. Most credits should in fact go to him. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::ObjectFactory; use strict; use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI); =head2 new Title : new Usage : my $obj = Bio::Factory::ObjectFactory->new(); Function: Builds a new Bio::Factory::ObjectFactory object Returns : Bio::Factory::ObjectFactory Args : -type => string, name of a L derived class. There is no default. -interface => string, name of the interface or class any type specified needs to at least implement. The default is Bio::Root::RootI. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type,$interface) = $self->_rearrange([qw(TYPE INTERFACE)], @args); $self->{'_loaded_types'} = {}; $self->interface($interface || "Bio::Root::RootI"); $self->type($type) if $type; return $self; } =head2 create_object Title : create_object Usage : my $seq = $factory->create_object(); Function: Instantiates a new object of the previously set type. This object allows us to genericize the instantiation of objects. You must have provided -type at instantiation, or have called type($mytype) before you can call this method. Returns : an object of the type returned by type() The return type is configurable using new(-type =>"..."), or by calling $self->type("My::Fancy::Class"). Args : Initialization parameters specific to the type of object we want. Check the POD of the class you set as type. =cut sub create_object { my ($self,@args) = @_; my $type = $self->type(); # type has already been loaded upon set return $type->new(-verbose => $self->verbose, @args); } =head2 type Title : type Usage : $obj->type($newval) Function: Get/set the type of object to be created. This may be changed at any time during the lifetime of this factory. Returns : value of type (a string) Args : newvalue (optional, a string) =cut sub type{ my $self = shift; if(@_) { my $type = shift; if($type && (! $self->{'_loaded_types'}->{$type})) { eval { $self->_load_module($type); }; if( $@ ) { $self->throw("module for '$type' failed to load: ". $@); } my $o = bless {},$type; if(!$self->_validate_type($o)) { # this may throw an exception $self->throw("'$type' is not valid for factory ".ref($self)); } $self->{'_loaded_types'}->{$type} = 1; } return $self->{'type'} = $type; } return $self->{'type'}; } =head2 interface Title : interface Usage : $obj->interface($newval) Function: Get/set the interface or base class that supplied types must at least implement (inherit from). Example : Returns : value of interface (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub interface{ my $self = shift; my $interface = shift; if($interface) { return $self->{'interface'} = $interface; } return $self->{'interface'}; } =head2 _validate_type Title : _validate_type Usage : $factory->_validate_type($object) Function: Called to let derived factories validate the type set via type(). The default implementation here checks whether the supplied object skeleton implements the interface set via -interface upon factory instantiation. Example : Returns : TRUE if the type is to be considered valid, and FALSE otherwise. Instead of returning FALSE this method may also just throw an informative exception. The default implementation here will throw an exception if the supplied object does not inherit from the interface provided by the interface() method. Args : A hash reference blessed into the specified type, allowing queries like isa(). =cut sub _validate_type{ my ($self,$obj) = @_; if(! $obj->isa($self->interface())) { $self->throw("invalid type: '".ref($obj). "' does not implement '".$self->interface()."'"); } return 1; } ##################################################################### # aliases for naming consistency or other reasons # ##################################################################### *create = \&create_object; 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/ObjectFactoryI.pm�������������������������������������������������������000444��000765��000024�� 5172�12254227331� 20767� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::ObjectFactoryI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Factory::ObjectFactoryI - A General object creator factory =head1 SYNOPSIS # see the implementations of this interface for details but # basically my $obj = $factory->create(%args); =head1 DESCRIPTION This interface is the basic structure for a factory which creates new objects. In this case it is up to the implementer to check arguments and initialize whatever new object the implementing class is designed for. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Factory::ObjectFactoryI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 create Title : create Usage : $factory->create(%args) Function: Create a new object Returns : a new object Args : hash of initialization parameters =cut sub create{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 create_object Title : create_object Usage : $obj = $factory->create_object(%args) Function: Create a new object. This is supposed to supercede create(). Right now it only delegates to create(). Returns : a new object Args : hash of initialization parameters =cut sub create_object{ my ($self,@args) = @_; return $self->create(@args); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Factory/SeqAnalysisParserFactory.pm���������������������������������������������000444��000765��000024�� 15502�12254227324� 23101� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Factory::SeqAnalysisParserFactory # # Please direct questions and support issues to # # Cared for by Jason Stajich , # and Hilmar Lapp # # Copyright Jason Stajich, Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Factory::SeqAnalysisParserFactory - class capable of creating SeqAnalysisParserI compliant parsers =head1 SYNOPSIS # initialize an object implementing this interface, e.g. $factory = Bio::Factory::SeqAnalysisParserFactory->new(); # find out the methods it knows about print "registered methods: ", join(', ', keys %{$factory->driver_table}), "\n"; # obtain a parser object $parser = $factory->get_parser(-input=>$inputobj, -params=>[@params], -method => $method); # $parser is an object implementing Bio::SeqAnalysisParserI # annotate sequence with features produced by parser while(my $feat = $parser->next_feature()) { $seq->add_SeqFeature($feat); } =head1 DESCRIPTION This is a factory class capable of instantiating SeqAnalysisParserI implementing parsers. The concept behind this class and the interface it implements (Bio::Factory::SeqAnalysisParserFactoryI) is a generic analysis result parsing in high-throughput automated sequence annotation pipelines. See Bio::SeqAnalysisParserI for more documentation of this concept. You can always find out the methods an instance of this class knows about by the way given in the SYNOPSIS section. By default, and assuming that the documentation is up-to-date, this will comprise of genscan, mzef, estscan, blast, hmmer, gff, and sim4 (all case-insensitive). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Jason Stajich Email Hilmar Lapp Ehlapp@gmx.netE, Jason Stajich Ejason@bioperl.orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Factory::SeqAnalysisParserFactory; use strict; use base qw(Bio::Factory::DriverFactory Bio::Factory::SeqAnalysisParserFactoryI); BEGIN { Bio::Factory::DriverFactory->register_driver ( "genscan" => "Bio::Tools::Genscan", "mzef" => "Bio::Tools::MZEF", "estscan" => "Bio::Tools::ESTScan", "hmmer" => "Bio::Tools::HMMER::Result", "gff" => "Bio::Tools::GFF", "sim4" => "Bio::Tools::Sim4::Results", "epcr" => "Bio::Tools::EPCR", "exonerate" => "Bio::Tools::Exonerate", ); } sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); # no per-object initialization right now - registration of default drivers # is only done once when the module is loaded return $self; } =head2 get_parser Title : get_parser Usage : $factory->get_parser(-input=>$inputobj, [ -params=>[@params] ], -method => $method) Function: Creates and returns a parser object for the given input and method. Both file names and streams (filehandles) are allowed. Parameters (-params argument) are passed on to the parser object and therefore are specific to the parser to be created. Example : Returns : A Bio::SeqAnalysisParserI implementing object. Exception if creation of the parser object fails. Args : B
\n"; my $afterdist = $self->mutation->prelabel - $firstexon->start; my $beforedist = $firstexon->end - $self->mutation->postlabel; my $exonvalue = $i + 1; $self->dnamut->region('exon'); $self->dnamut->region_value($exonvalue); if ($afterdist < $beforedist) { $afterdist++; $afterdist++; $self->dnamut->region_dist($afterdist); #print "splice site $afterdist nt upstream!
"; } else { $self->dnamut->region_dist($beforedist); #print "splice site $beforedist nt downstream!
"; } } else { #print "first exon : ", $firstexon->start, " - ", $firstexon->end, "
\n"; foreach $i (0..$#exons) { $after=$exons[$i]->start; #proximity test for intronic mutations if ( ($strand == 1 and $self->mutation->prelabel >= $before and $self->mutation->postlabel <= $after) or ($strand == -1 and $self->mutation->prelabel <= $before and $self->mutation->postlabel >= $after) ) { $self->dnamut->region('intron'); #$self->dnamut->region_value($i); my $afterdist = $self->mutation->prelabel - $before; my $beforedist = $after - $self->mutation->postlabel; my $intronvalue = $i + 1; if ($afterdist < $beforedist) { $afterdist++; $self->dnamut->region_value($intronvalue); $self->dnamut->region_dist($afterdist); #print "splice site $afterdist nt upstream!
"; } else { $self->dnamut->region_value($intronvalue); $self->dnamut->region_dist($beforedist * -1); #print "splice site $beforedist nt downstream!
"; } $self->rnachange(undef); last; } #proximity test for exon mutations #proximity test for exon mutations elsif ( ( $strand == 1 and $exons[$i]->start < $self->mutation->prelabel and $exons[$i]->end > $self->mutation->prelabel) or ( $strand == 1 and $exons[$i]->start < $self->mutation->postlabel and $exons[$i]->end > $self->mutation->postlabel) or ( $strand == -1 and $exons[$i]->start > $self->mutation->prelabel and $exons[$i]->end < $self->mutation->prelabel) or ( $strand == -1 and $exons[$i]->start > $self->mutation->postlabel and $exons[$i]->end < $self->mutation->postlabel) ) { $rnaAffected = 1; my $afterdist = $self->mutation->prelabel - $exons[$i]->start; my $beforedist = $exons[$i]->end - $self->mutation->postlabel; my $exonvalue = $i + 1; $self->dnamut->region('exon'); if ($afterdist < $beforedist) { $afterdist++; $self->dnamut->region_value($exonvalue+1); $self->dnamut->region_dist($afterdist); #print "splice site $afterdist nt upstream!
"; } else { #$beforedist; $self->dnamut->region_value($exonvalue+1); $self->dnamut->region_dist($beforedist * -1); #print "splice site $beforedist nt downstream!
"; } last; } $before=$exons[$i]->end; } } } } #$self->warn("RNA not affected because change occurs inside an intron"); #return(0); # if still not returned, then not affected, return 0 return $rnaAffected; } # # ### Creation of RNA and AA variation objects # =head2 _set_effects Title : _set_effects Usage : Function: Stores RNA and AA level mutation attributes before mutation into Bio::Variation::RNAChange and Bio::Variation::AAChange objects. Links them to SeqDiff object. Example : Returns : Args : Bio::Variation::SeqDiff object Bio::Variation::DNAMutation object See L, L, L, and L. =cut sub _set_effects { my ($self, $seqDiff, $dnamut) = @_; my ($rnapos_end, $upstreamseq, $dnstreamseq); my $flanklen = $self->{'flanklen'}; ($self->mutation->len == 0) ? ($rnapos_end = $self->mutation->transpos) : ($rnapos_end = $self->mutation->transpos + $self->mutation->len -1); my $rnachange = Bio::Variation::RNAChange->new(-start => $self->mutation->transpos, -end => $rnapos_end ); $rnachange->isMutation(1); # setting proof if ($seqDiff->numbering eq "coding") { $rnachange->proof('experimental'); } else { $rnachange->proof('computed'); } $seqDiff->add_Variant($rnachange); $self->rnachange($rnachange); $rnachange->DNAMutation($dnamut); $dnamut->RNAChange($rnachange); $rnachange->mut_number($self->mutation->issue); # setting the codon_position of the "start" nucleotide of the change $rnachange->codon_pos(($self->RNA->frame($self->mutation->label))+1); # codon_pos=frame+1 my @exons=$self->RNA->all_Exons; $self->exons(\@exons); #print `date`, " before flank, after exons. RNAObj query\n"; # if cannot retrieve from Transcript, Transcript::upstream_seq will be used # before "fac7 g 65" bug discovered # $uplabel=$self->RNA->label(1-$flanklen,$prelabel); my $RNAprelabel=$self->RNA->label(-1,$self->mutation->label); # to fix fac7g65 bug # for the fix, all prelabel used in the next block have been changed to RNAprelabel my $uplabel=$self->RNA->label(1-$flanklen,$RNAprelabel); if ($self->RNA->valid($uplabel)) { $upstreamseq = $self->RNA->labelsubseq($uplabel, undef, $RNAprelabel); } else { $upstreamseq = $self->RNA->labelsubseq($self->RNA->start, undef, $RNAprelabel) if $self->RNA->valid($RNAprelabel); my $lacking=$flanklen-length($upstreamseq); # how many missing my $upstream_atg=$exons[0]->subseq(-$lacking,-1); $upstreamseq=$upstream_atg . $upstreamseq; } $rnachange->upStreamSeq($upstreamseq); # won't work OK if postlabel NOT in Transcript # now added RNApostlabel but this has to be /fully tested/ # for the fix, all postlabel used in the next block have been changed to RNApostlabel my $RNApostlabel; # to fix fac7g64 bug if ($self->mutation->len == 0) { $RNApostlabel=$self->mutation->label; } else { my $mutlen = 1 + $self->mutation->len; $RNApostlabel=$self->RNA->label($mutlen,$self->mutation->label); } $dnstreamseq=$self->RNA->labelsubseq($RNApostlabel, $flanklen); if ($dnstreamseq eq '-1') { # if out of transcript was requested my $lastexon=$exons[-1]; my $lastexonlength=$lastexon->length; $dnstreamseq=$self->RNA->labelsubseq($RNApostlabel); # retrieves till RNAend my $lacking=$flanklen-length($dnstreamseq); # how many missing my $downstream_stop=$lastexon->subseq($lastexonlength+1,undef,$lacking); $dnstreamseq .= $downstream_stop; } else { $rnachange->dnStreamSeq($dnstreamseq); } # AAChange creation my $AAobj=$self->RNA->get_Translation; # storage of prelabel here, to be used in create_mut_objs_after my $aachange = Bio::Variation::AAChange->new(-start => $RNAprelabel ); $aachange->isMutation(1); $aachange->proof('computed'); $seqDiff->add_Variant($aachange); $self->aachange($aachange); $rnachange->AAChange($aachange); $aachange->RNAChange($rnachange); $aachange->mut_number($self->mutation->issue); # $before_mutation{aachange}=$aachange; my $ra_o = Bio::Variation::Allele->new; $ra_o->seq($dnamut->allele_ori->seq) if $dnamut->allele_ori->seq; $rnachange->allele_ori($ra_o); $rnachange->length(CORE::length $rnachange->allele_ori->seq); my $ra_m = Bio::Variation::Allele->new; $ra_m->seq($self->mutation->seq) if $self->mutation->seq; $rnachange->allele_mut($ra_m); $rnachange->add_Allele($ra_m); #$rnachange->allele_mut($seq); $rnachange->end($rnachange->start) if $rnachange->length == 0; # this holds the aminoacid sequence that will be affected by the mutation my $aa_allele_ori=$AAobj->labelsubseq($self->mutation->label,undef, $self->mutation->lastlabel); my $aa_o = Bio::Variation::Allele->new; $aa_o->seq($aa_allele_ori) if $aa_allele_ori; $aachange->allele_ori($aa_o); #$aachange->allele_ori($aa_allele_ori); my $aa_length_ori = length($aa_allele_ori); $aachange->length($aa_length_ori); #print "==========$aa_length_ori\n"; $aachange->end($aachange->start + $aa_length_ori - 1 ); } =head2 _untranslated Title : _untranslated Usage : Function: Stores RNA change attributes before mutation into Bio::Variation::RNAChange object. Links it to SeqDiff object. Example : Returns : Args : Bio::Variation::SeqDiff object Bio::Variation::DNAMutation object See L, L and L for details. =cut sub _untranslated { my ($self, $seqDiff, $dnamut) = @_; my $rnapos_end; ($self->mutation->len == 0) ? ($rnapos_end = $self->mutation->transpos) : ($rnapos_end = $self->mutation->transpos + $self->mutation->len -1); my $rnachange = Bio::Variation::RNAChange->new(-start => $self->mutation->transpos, -end => $rnapos_end ); #my $rnachange = Bio::Variation::RNAChange->new; $rnachange->isMutation(1); my $ra_o = Bio::Variation::Allele->new; $ra_o->seq($dnamut->allele_ori->seq) if $dnamut->allele_ori->seq; $rnachange->allele_ori($ra_o); my $ra_m = Bio::Variation::Allele->new; $ra_m->seq($dnamut->allele_mut->seq) if $dnamut->allele_mut->seq; $rnachange->allele_mut($ra_m); $rnachange->add_Allele($ra_m); $rnachange->upStreamSeq($dnamut->upStreamSeq); $rnachange->dnStreamSeq($dnamut->dnStreamSeq); $rnachange->length($dnamut->length); $rnachange->mut_number($dnamut->mut_number); # setting proof if ($seqDiff->numbering eq "coding") { $rnachange->proof('experimental'); } else { $rnachange->proof('computed'); } my $dist; if ($rnachange->end < 0) { $rnachange->region('5\'UTR'); $dnamut->region('5\'UTR'); my $dist = $dnamut->end ; $dnamut->region_dist($dist); $dist = $seqDiff->offset - $self->gene->maxtranscript->start + 1 + $dist; $rnachange->region_dist($dist); return if $dist < 1; # if mutation is not in mRNA } else { $rnachange->region('3\'UTR'); $dnamut->region('3\'UTR'); my $dist = $dnamut->start - $seqDiff->cds_end + $seqDiff->offset; $dnamut->region_dist($dist); $dist = $seqDiff->cds_end - $self->gene->maxtranscript->end -1 + $dist; $rnachange->region_dist($dist); return if $dist > 0; # if mutation is not in mRNA } $seqDiff->add_Variant($rnachange); $self->rnachange($rnachange); $rnachange->DNAMutation($dnamut); $dnamut->RNAChange($rnachange); } # args: reference to label changearray, reference to position changearray # Function: take care of the creation of mutation objects, with # information AFTER the change takes place sub _post_mutation { my ($self, $seqDiff) = @_; if ($self->rnachange and $self->rnachange->region eq 'coding') { #$seqDiff->add_Variant($self->rnachange); my $aachange=$self->aachange; my ($AAobj,$aa_start_prelabel,$aa_start,$mut_translation); $AAobj=$self->RNA->get_Translation; $aa_start_prelabel=$aachange->start; $aa_start=$AAobj->position($self->RNA->label(2,$aa_start_prelabel)); $aachange->start($aa_start); $mut_translation=$AAobj->seq; # this now takes in account possible preinsertions my $aa_m = Bio::Variation::Allele->new; $aa_m->seq(substr($mut_translation,$aa_start-1)) if substr($mut_translation,$aa_start-1); $aachange->allele_mut($aa_m); $aachange->add_Allele($aa_m); #$aachange->allele_mut(substr($mut_translation,$aa_start-1)); #$aachange->allele_mut($mut_translation); my ($rlenori, $rlenmut); $rlenori = CORE::length($aachange->RNAChange->allele_ori->seq); $rlenmut = CORE::length($aachange->RNAChange->allele_mut->seq); #point mutation if ($rlenori == 1 and $rlenmut == 1 and $aachange->allele_ori->seq ne '*') { my $alleleseq; if ($aachange->allele_mut->seq) { $alleleseq = substr($aachange->allele_mut->seq, 0, 1); $aachange->allele_mut->seq($alleleseq); } $aachange->end($aachange->start); $aachange->length(1); } elsif ( $rlenori == $rlenmut and $aachange->allele_ori->seq ne '*' ) { #complex inframe mutation $aachange->allele_mut->seq(substr $aachange->allele_mut->seq, 0, length($aachange->allele_ori->seq)); } #inframe mutation elsif ((int($rlenori-$rlenmut))%3 == 0) { if ($aachange->RNAChange->allele_mut->seq and $aachange->RNAChange->allele_ori->seq ) { # complex my $rna_len = length ($aachange->RNAChange->allele_mut->seq); my $len = $rna_len/3; $len++ unless $rna_len%3 == 0; $aachange->allele_mut->seq(substr $aachange->allele_mut->seq, 0, $len ); } elsif ($aachange->RNAChange->codon_pos == 1){ # deletion if ($aachange->RNAChange->allele_mut->seq eq '') { $aachange->allele_mut->seq(''); $aachange->end($aachange->start + $aachange->length - 1 ); } # insertion elsif ($aachange->RNAChange->allele_ori->seq eq '' ) { $aachange->allele_mut->seq(substr $aachange->allele_mut->seq, 0, length ($aachange->RNAChange->allele_mut->seq) / 3); $aachange->allele_ori->seq(''); $aachange->end($aachange->start + $aachange->length - 1 ); $aachange->length(0); } } else { #elsif ($aachange->RNAChange->codon_pos == 2){ # deletion if (not $aachange->RNAChange->allele_mut->seq ) { $aachange->allele_mut->seq(substr $aachange->allele_mut->seq, 0, 1); } # insertion elsif (not $aachange->RNAChange->allele_ori->seq) { $aachange->allele_mut->seq(substr $aachange->allele_mut->seq, 0, length ($aachange->RNAChange->allele_mut->seq) / 3 +1); } } } else { #frameshift #my $pos = index $aachange->allele_mut #$aachange->allele_mut(substr($aachange->allele_mut, 0, 1)); $aachange->length(CORE::length($aachange->allele_ori->seq)); my $aaend = $aachange->start + $aachange->length -1; $aachange->end($aachange->start); } # splicing site deletion check my @beforeexons=@{$self->exons}; my @afterexons=$self->RNA->all_Exons; my $i; if (scalar(@beforeexons) ne scalar(@afterexons)) { my $mut_number = $self->mutation->issue; $self->warn("Exons have been modified at mutation n.$mut_number!"); $self->rnachange->exons_modified(1); } else { EXONCHECK: foreach $i (0..$#beforeexons) { if ($beforeexons[$i] ne $afterexons[$i]) { my $mut_number = $self->mutation->issue; $self->warn("Exons have been modified at mutation n.$mut_number!"); $self->rnachange->exons_modified(1); last EXONCHECK; } } } } else { #$seqDiff->rnachange(undef); #print "getting here?"; } return 1; } 1; BioPerl-1.6.923/Bio/LiveSeq/Prim_Transcript.pm000444000765000024 256112254227324 21202 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::Prim_Transcript # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::Prim_Transcript - Prim_Transcript class for LiveSeq =head1 SYNOPSIS # documentation needed =head1 DESCRIPTION Class for PRIM_TRANSCRIPT objects. They consist of a beginlabel, an endlabel (both referring to a LiveSeq DNA object) and a strand. The strand could be 1 (forward strand, default), -1 (reverse strand). =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::Prim_Transcript; use strict; use base qw(Bio::LiveSeq::Range); =head2 new Title : new Usage : $intron1=Bio::LiveSeq::Prim_Transcript->new(-seq => $objref, -start => $startlabel, -end => $endlabel, -strand => 1 ); Function: generates a new Bio::LiveSeq::Prim_Transcript Returns : reference to a new object of class Prim_Transcript Errorcode -1 Args : two labels and an integer =cut 1; BioPerl-1.6.923/Bio/LiveSeq/Range.pm000444000765000024 600212254227315 17110 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::Range # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::Range - Range abstract class for LiveSeq =head1 SYNOPSIS # documentation needed =head1 DESCRIPTION This is used as parent for exon and intron classes. =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::Range; use strict; use base qw(Bio::LiveSeq::SeqI); =head2 new Title : new Usage : $range1 = Bio::LiveSeq::Range->new(-seq => $obj_ref, -start => $beginlabel, -end => $endlabel, -strand => 1); Function: generates a new Bio::LiveSeq::Range Returns : reference to a new object of class Range Errorcode -1 Args : two labels, an obj_ref and an integer strand 1=forward strand, strand -1=reverse strand if strand not specified, it defaults to 1 the -seq argument must point to the underlying DNA LiveSeq object =cut sub new { my ($thing, %args) = @_; my $class = ref($thing) || $thing; my ($obj,%range); my ($seq,$start,$end,$strand)=($args{-seq},$args{-start},$args{-end},$args{-strand}); $obj = \%range; $obj = bless $obj, $class; unless ($seq->valid($start)) { $obj->warn("$class not initialised because start label not valid"); return (-1); } unless ($seq->valid($end)) { $obj->warn("$class not initialised because end label not valid"); return (-1); } unless (defined $strand) { $strand = 1; } if (($strand != 1)&&($strand != -1)) { $obj->warn("$class not initialised because strand identifier not valid. Use 1 (forward strand) or -1 (reverse strand)."); return (-1); } if ($start eq $end) { $obj->warn("$class reports: start and end label are the same...."); } else { unless ($seq->follows($start,$end,$strand)==1) { $obj->warn("Fatal: end label $end doesn't follow start label $start for strand $strand!"); return (-1); } } #if ($strand == 1) { # unless ($seq->is_downstream($start,$end)==1) { # croak "Fatal: end label not downstream of start label for forward strand!"; # } #} else { # unless ($seq->is_upstream($start,$end)==1) { # croak "Fatal: end label not upstream of start label for reverse strand!"; # } #} $obj->{'seq'}=$seq; $obj->{'start'}=$start; $obj->{'end'}=$end; $obj->{'strand'}=$strand; return $obj; } =head2 valid Title : valid Usage : $boolean = $obj->valid($label) Function: tests if a label exists AND is part of the object Returns : boolean Args : label =cut 1; BioPerl-1.6.923/Bio/LiveSeq/Repeat_Region.pm000444000765000024 253212254227330 20600 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::Repeat_Region # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::Repeat_Region - Repeat_Region class for LiveSeq =head1 SYNOPSIS # documentation needed =head1 DESCRIPTION Class for REPEAT_REGION objects. They consist of a beginlabel, an endlabel (both referring to a LiveSeq DNA object) and a strand. The strand could be 1 (forward strand, default), -1 (reverse strand). =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::Repeat_Region; use strict; use base qw(Bio::LiveSeq::Range); =head2 new Title : new Usage : $intron1=Bio::LiveSeq::Repeat_Region->new(-seq => $objref, -start => $startlabel, -end => $endlabel, -strand => 1); Function: generates a new Bio::LiveSeq::Repeat_Region Returns : reference to a new object of class Repeat_Region Errorcode -1 Args : two labels and an integer =cut 1; BioPerl-1.6.923/Bio/LiveSeq/Repeat_Unit.pm000444000765000024 252112254227331 20273 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::Repeat_Unit # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::Repeat_Unit - Repeat_Unit class for LiveSeq =head1 SYNOPSIS # documentation needed =head1 DESCRIPTION Class for REPEAT_UNIT objects. They consist of a beginlabel, an endlabel (both referring to a LiveSeq DNA object) and a strand. The strand could be 1 (forward strand, default), -1 (reverse strand). =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::Repeat_Unit; use strict; use base qw(Bio::LiveSeq::Repeat_Region); =head2 new Title : new Usage : $intron1=Bio::LiveSeq::Repeat_Unit->new(-seq => $objref, -start => $startlabel, -end => $endlabel, -strand => 1); Function: generates a new Bio::LiveSeq::Repeat_Unit Returns : reference to a new object of class Repeat_Unit Errorcode -1 Args : two labels and an integer =cut 1; BioPerl-1.6.923/Bio/LiveSeq/SeqI.pm000444000765000024 10457712254227313 16773 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::SeqI # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::SeqI - Abstract sequence interface class for LiveSeq =head1 SYNOPSIS # documentation needed =head1 DESCRIPTION This class implements BioPerl PrimarySeqI interface for Live Seq objects. One of the main difference in LiveSequence compared to traditional "string" sequences is that coordinate systems are flexible. Typically gene nucleotide numbering starts from 1 at the first character of the initiator codon (A in ATG). This means that negative positions are possible and common! Secondly, the sequence manipulation methods do not return a new sequence object but change the current object. The current status can be written out to BioPerl sequence objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ Some note on the terminology/notation of method names: label: a unique pointer to a single nucleotide position: the position of a nucleotide according to a particular coordinate system (e.g. counting downstream from a particular label taken as number 1) base: the one letter code for a nucleotide (i.e.: "a" "t" "c" "g") a base is the "value" that an "element" of a "chain" can assume (see documentation on the Chain datastructure if interested) =cut #' # Let the code begin... package Bio::LiveSeq::SeqI; use strict; use Bio::Tools::CodonTable; # for the translate() function use base qw(Bio::Root::Root Bio::LiveSeq::ChainI Bio::PrimarySeqI); =head2 seq Title : seq Usage : $string = $obj->seq() Function: Returns the complete sequence of an object as a string of letters. Suggested cases are upper case for proteins and lower case for DNA sequence (IUPAC standard), Returns : a string =cut sub seq { my $self = shift; my ($start,$end) = ($self->start(),$self->end()); if ($self->strand() == 1) { return $self->{'seq'}->down_chain2string($start,undef,$end); } else { # reverse strand my $str = $self->{'seq'}->up_chain2string($start,undef,$end); $str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; return $str; } } =head2 all_labels Title : all_labels Usage : @labels = $obj->all_labels() Function: all the labels of every nucleotide an object is composed of Returns : an array of labels Args : none =cut sub all_labels { my $self = shift; my ($start,$end) = ($self->start(),$self->end()); my $labels; if ($self->strand() == 1) { $labels=$self->{'seq'}->down_labels($start,$end); } else { $labels=$self->{'seq'}->up_labels($start,$end); } return (@{$labels}); } =head2 labelsubseq Title : labelsubseq Usage : $dna->labelsubseq(); : $dna->labelsubseq($startlabel); : $dna->labelsubseq($startlabel,$length); : $dna->labelsubseq($startlabel,undef,$endlabel); e.g. : $dna->labelsubseq(4,undef,8); Function: prints the sequence as string. The difference between labelsubseq and normal subseq is that it uses /labels/ as arguments, instead than positions. This allows for faster and more efficient lookup, skipping the (usually) lengthy conversion of positions into labels. This is especially useful for manipulating with high power LiveSeq objects, knowing the labels and exploiting their usefulness. Returns : a string Errorcode -1 Args : without arguments it returns the entire sequence with a startlabel it returns the sequence downstream that label if a length is specified, it returns only that number of bases if an endlabel is specified, it overrides the length argument and prints instead up to that label (included) Defaults: $startlabel defaults to the beginning of the entire sequence $endlabel defaults to the end of the entire sequence =cut # NOTE: unsecuremode is to be used /ONLY/ if sure of the start and end labels, especially that they follow each other in the correct order!!!! sub labelsubseq { my ($self,$start,$length,$end,$unsecuremode) = @_; if (defined $unsecuremode && $unsecuremode eq "unsecuremoderequested") { # to skip security checks (faster) unless ($start) { $start=$self->start; } if ($end) { if ($end == $start) { $length=1; undef $end; } else { undef $length; } } else { unless ($length) { $end=$self->end; } } } else { if ($start) { unless ($self->{'seq'}->valid($start)) { $self->warn("Start label not valid"); return (-1); } } if ($end) { if ($end == $start) { $length=1; undef $end; } else { unless ($self->{'seq'}->valid($end)) { $self->warn("End label not valid"); return (-1); } unless ($self->follows($start,$end) == 1) { $self->warn("End label does not follow Start label!"); return (-1); } undef $length; } } } if ($self->strand() == 1) { return $self->{'seq'}->down_chain2string($start,$length,$end); } else { # reverse strand my $str = $self->{'seq'}->up_chain2string($start,$length,$end); $str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; return $str; } } =head2 subseq Title : subseq Usage : $substring = $obj->subseq(10,40); : $substring = $obj->subseq(10,undef,4); Function: returns the subseq from start to end, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence Start cannot be larger than end but can be equal. Allows for negative numbers $obj->subseq(-10,-1). By definition, there is no 0! -5 -1 1 5 gctagcgcccaac atggctcgctg This allows one to retrieve sequences upstream from given position. The precedence is from left to right: if END is given LENGTH is ignored. Examples: $obj->subseq(-10,undef,10) returns 10 elements before position 1 $obj->subseq(4,8) returns elements from the 4th to the 8th, inclusive Returns : a string Errorcode: -1 Args : start, integer, defaults to start of the sequence end, integer, '' or undef, defaults to end of the sequence length, integer, '' or undef an optional strand (1 or -1) 4th argument if strand argument is not given, it will default to the object argment. This argument is useful when a call is issued from a child of a parent object containing the subseq method =cut #' # check the fact about reverse strand! # is it feasible? Is it correct? Should we do it? How about exons? Does it # work when you ask subseq of an exon? # eliminated now (Mon night) sub subseq { ##my ($self,$pos1,$pos2,$length,$strand) = @_; my ($self,$pos1,$pos2,$length,$strand) = @_; ##unless (defined ($strand)) { # if optional [strand] argument not given ## $strand=$self->strand; ##} $strand=$self->strand; my ($str,$startlabel,$endlabel); if (defined ($length)) { if ($length < 1) { $self->warn("No sense asking for a subseq of length < 1"); return (-1); } } unless (defined ($pos1)) { #print "\n##### DEBUG pos1 not defined\n"; $startlabel=$self->start; } else { if ($pos1 == 0) { # if position = 0 complain $self->warn("Position cannot be 0!"); return (-1); } ##if ($strand == 1) { # CHECK THIS! if ((defined ($pos2))&&($pos1>$pos2)) { $self->warn("1st position($pos1) cannot be > 2nd position($pos2)!"); return (-1); } ##} else { # CHECK THIS! ## if ((defined ($pos2))&&($pos1<$pos2)) { ## $self->warn("1st position($pos1) cannot be < 2nd position($pos2) on reverse strand!)"; return (-1); ## } ##} $startlabel=$self->label($pos1); if ($startlabel < 1) { $self->warn("position $pos1 not valid as start of subseq!"); return (-1); } } unless (defined ($pos2)) { #print "\n##### pos2 not defined\n"; unless (defined ($length)) { $endlabel=$self->end; } } else { if ($pos2 == 0) { # if position = 0 complain $self->warn("Position cannot be 0!"); return (-1); } undef $length; ##if ($strand == 1) { # CHECK THIS! if ((defined ($pos1))&&($pos1>$pos2)) { $self->warn("1st position($pos1) cannot be > 2nd position($pos2)!"); return (-1); } ##} else { # CHECK THIS! ## if ((defined ($pos1))&&($pos1<$pos2)) { ## $self->warn("1st position($pos1) cannot be < 2nd position($pos2) on reverse strand!"); return (-1); ## } ##} $endlabel=$self->label($pos2); if ($endlabel < 1) { $self->warn("position $pos2 not valid as end of subseq!"); return (-1); } } #print "\n ####DEBUG: start $startlabel end $endlabel length $length strand $strand\n"; if ($strand == 1) { $str = $self->{'seq'}->down_chain2string($startlabel,$length,$endlabel); } else { # reverse strand $str = $self->{'seq'}->up_chain2string($startlabel,$length,$endlabel); $str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; } return $str; } =head2 length Title : length Usage : $seq->length(); Function: returns the number of nucleotides (or the number of aminoacids) in the entire sequence Returns : an integer Errorcode -1 Args : none =cut sub length { my $self=shift; my ($start,$end,$strand)=($self->start(),$self->end(),$self->strand()); if ($strand == 1) { return $self->{'seq'}->down_subchain_length($start,$end); } else { return $self->{'seq'}->up_subchain_length($start,$end); } } =head2 display_id Title : display_id Usage : $id_string = $obj->display_id(); Function: returns the display id, alias the common name of the object The semantics of this is that it is the most likely string to be used as an identifier of the sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. See also: accession_number Returns : a string Args : none =cut sub display_id { my ($self,$value) = @_; if(defined $value) { $self->{'display_id'} = $value; } return $self->{'display_id'}; } =head2 accession_number Title : accession_number Usage : $unique_biological_key = $obj->accession_number; Function: Returns the unique biological id for a sequence, commonly called the accession_number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For objects with no accession_number this method returns "unknown". Returns : a string Args : none =cut sub accession_number { my ($self,$value) = @_; if (defined $value) { $self->{'accession_number'} = $value; } unless (exists $self->{'accession_number'}) { return "unknown"; } else { return $self->{'accession_number'}; } } =head2 primary_id Title : primary_id Usage : $unique_implementation_key = $obj->primary_id; Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementation can control. Clients can expect one id to map to one object. For sequences with no primary_id, this method returns a stringified memory location. Returns : A string Args : None =cut sub primary_id { my ($self,$value) = @_; if(defined $value) { $self->{'primary_id'} = $value; } unless (exists $self->{'primary_id'}) { return "$self"; } else { return $self->{'primary_id'}; } } =head2 change Title : change Usage : $substring = $obj->change('AA', 10); Function: changes, modifies, mutates the LiveSequence Examples: $obj->change('', 10); delete nucleotide #10 $obj->change('', 10, 2); delete two nucleotides starting from #10 $obj->change('G', 10); change nuc #10 to 'G' $obj->change('GA', 10, 4); replace #10 and 3 following with 'GA' $obj->change('GA', 10, 2)); is same as $obj->change('GA', 10); $obj->change('GA', 10, 0 ); insert 'GA' before nucleotide at #10 $obj->change('GA', 10, 1); GA inserted before #10, #10 deleted $obj->change('GATC', 10, 2); GATC inserted before #10, #10 deleted $obj->change('GATC', 10, 6); GATC inserted before #10, #10-#15 deleted Returns : a string of deleted bases (if any) or 1 (everything OK) Errorcode: -1 Args : seq, string, or '' ('' = undef = 0 = deletion) start, integer length, integer (optional) =cut sub change { &positionchange; } =head2 positionchange Title : positionchange Function: Exactly like change. I.e. change() defaults to positionchange() =cut sub positionchange { my ($self,$newseq,$position,$length)=@_; unless ($position) { $self->warn("Position not given or position 0"); return (-1); } my $label=$self->label($position); unless ($label > 0) { # label not found or error $self->warn("No valid label found at that position!"); return (-1); } return ($self->labelchange($newseq,$label,$length)); } =head2 labelchange Title : labelchange Function: Exactly like change but uses a /label/ instead than a position as second argument. This allows for multiple changes in a LiveSeq without the burden of recomputing positions. I.e. for a multiple change in two different points of the LiveSeq, the approach would be the following: fetch the correct labels out of the two different positions (method: label($position)) and then use the labelchange() method to modify the sequence using those labels instead than relying on the positions (that would have modified after the first change). =cut sub labelchange { my ($self,$newseq,$label,$length)=@_; unless ($self->valid($label)) { if ($self->{'seq'}->valid($label)) { #$self->warn("Label \'$label\' not valid for executing a LiveSeq change for the object asked but it's ok for DNAlevel change, reverting to that"); shift @_; return($self->{'seq'}->labelchange(@_)); } else { $self->warn("Label \'$label\' not valid for executing a LiveSeq change"); return (-1); } } unless ($newseq) { # it means this is a simple deletion if (defined($length)) { unless ($length >= 0) { $self->warn("No sense having length < 0 in a deletion"); return (-1); } } else { $self->warn("Length not defined for deletion!"); return (-1); } return $self->_delete($label,$length); } my $newseqlength=CORE::length($newseq); if (defined($length)) { unless ($length >= 0) { $self->warn("No sense having length < 0 in a change()"); return (-1); } } else { $length=$newseqlength; # defaults to pointmutation(s) } if ($length == 0) { # it means this is a simple insertion, length def&==0 my ($insertbegin,$insertend)=$self->_praeinsert($label,$newseq); if ($insertbegin == -1) { return (-1); } else { return (1); } } if ($newseqlength == $length) { # it means this is simple pointmutation(s) return $self->_mutate($label,$newseq,$length); } # if we arrived here then change is complex mixture my $strand=$self->strand(); my $afterendlabel=$self->label($length+1,$label,$strand); # get the label at $length+1 positions after $label unless ($afterendlabel > 0) { # label not found or error $self->warn("No valid afterendlabel found for executing the complex mutation!"); return (-1); } my $deleted=$self->_delete($label,$length); # first delete length nucs if ($deleted eq -1) { # if errors return (-1); } else { # then insert the newsequence my ($insertbegin,$insertend)=$self->_praeinsert($afterendlabel,$newseq); if ($insertbegin == -1) { return (-1); } else { return (1); } } } # internal methods for change() # arguments: label for beginning of deletion, new sequence to insert # returns: labels of beginning and end of the inserted sequence # errorcode: -1 sub _praeinsert { my ($self,$label,$newseq)=@_; my ($insertbegin,$insertend); my $strand=$self->strand(); if ($strand == 1) { ($insertbegin,$insertend)=($self->{'seq'}->praeinsert_string($newseq,$label)); } else { # since it's reverse strand and we insert in forward direction.... $newseq=reverse($newseq); $newseq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; # since it's reverse strand we get the complementary bases ($insertend,$insertbegin)=($self->{'seq'}->postinsert_string($newseq,$label)); } if (($insertbegin==0)||($insertend==0)) { $self->warn("Some error occurred while inserting!"); return (-1); } else { return ($insertbegin,$insertend); } } # arguments: label for beginning of deletion, length of deletion # returns: string of deleted bases # errorcode: -1 sub _delete { my ($self,$label,$length)=@_; my $strand=$self->strand(); my $endlabel=$self->label($length,$label,$strand); # get the label at $length positions after $label unless ($endlabel > 0) { # label not found or error $self->warn("No valid endlabel found for executing the deletion!"); return (-1); } # this is important in Transcript to fix exon structure $self->_deletecheck($label,$endlabel); my $deletedseq; if ($strand == 1) { $deletedseq=$self->{'seq'}->splice_chain($label,undef,$endlabel); } else { $deletedseq=$self->{'seq'}->splice_chain($endlabel,undef,$label); $deletedseq=reverse($deletedseq); # because we are on reverse strand and we cut anyway # in forward direction $deletedseq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; # since it's reverse strand we get the complementary bases } return ($deletedseq); } # empty function, overridden in Transcript, not useful here sub _deletecheck { } # arguments: label for beginning of mutation, newsequence, number of mutations # returns: 1 all OK # errorcode: -1 sub _mutate { my ($self,$label,$newseq,$length)=@_; # length is equal to length(newseq) my ($i,$base,$nextlabel); my @labels; # array of labels my $strand=$self->strand(); if ($length == 1) { # special cases first @labels=($label); } else { my $endlabel=$self->label($length,$label,$strand); # get the label at $length positions after $label unless ($endlabel > 0) { # label not found or error $self->warn("No valid endlabel found for executing the mutation!"); return (-1); } if ($length == 2) { # another special case @labels=($label,$endlabel); } else { # more than 3 bases changed # this wouldn't work for Transcript #my $labelsarrayref; #if ($strand == 1) { #$labelsarrayref=$self->{'seq'}->down_labels($label,$endlabel); #} else { #$labelsarrayref=$self->{'seq'}->up_labels($label,$endlabel); #} #@labels=@{$labelsarrayref}; #if ($length != scalar(@labels)) { # not enough labels returned #$self->warn("Not enough valid labels found for executing the mutation!"); #return (-1); #} # this should be more general @labels=($label); # put the first one while ($label != $endlabel) { $nextlabel=$self->label(2,$label,$strand); # retrieve the next label push (@labels,$nextlabel); $label=$nextlabel; # move on reference } } } if ($strand == -1) { # only for reverse strand $newseq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; # since it's reverse strand we get the complementary bases } my $errorcheck; # if not equal to $length after summing for all changes, error did occurr $i = 0; foreach $base (split(//,$newseq)) { $errorcheck += $self->{'seq'}->set_value_at_label($base,$labels[$i]); $i++; } if ($errorcheck != $length) { $self->warn("Some error occurred while mutating!"); return (-1); } else { return (1); } } =head2 valid Title : valid Usage : $boolean = $obj->valid($label) Function: tests if a label exists inside the object Returns : boolean Args : label =cut # argument: label # returns: 1 YES 0 NO sub valid { my ($self,$label)=@_; my $checkme; my @labels=$self->all_labels; foreach $checkme (@labels) { if ($label == $checkme) { return (1); # found } } return (0); # not found } =head2 start Title : start Usage : $startlabel=$obj->start() Function: returns the label of the first nucleotide of the object (exon, CDS) Returns : label Args : none =cut sub start { my ($self) = @_; return $self->{'start'}; # common for all classes BUT DNA (which redefines it) and Transcript (that takes the information from the Exons) } =head2 end Title : end Usage : $endlabel=$obj->end() Function: returns the label of the last nucleotide of the object (exon, CDS) Returns : label Args : none =cut sub end { my ($self) = @_; return $self->{'end'}; } =head2 strand Title : strand Usage : $strand=$obj->strand() $obj->strand($strand) Function: gets or sets strand information, being 1 or -1 (forward or reverse) Returns : -1 or 1 Args : none OR -1 or 1 =cut sub strand { my ($self,$strand) = @_; if ($strand) { if (($strand != 1)&&($strand != -1)) { $self->warn("strand information not changed because strand identifier not valid"); } else { $self->{'strand'} = $strand; } } return $self->{'strand'}; } =head2 alphabet Title : alphabet Usage : if( $obj->alphabet eq 'dna' ) { /Do Something/ } Function: Returns the type of sequence being one of 'dna', 'rna' or 'protein'. This is case sensitive. Returns : a string either 'dna','rna','protein'. Args : none =cut sub alphabet { my %valid_type = map {$_, 1} qw( dna rna protein ); my ($self,$value) = @_; if (defined $value) { $value = 'dna' if $value =~ /dna/i; $value = 'rna' if $value =~ /rna/i; unless ( $valid_type{$value} ) { $self->warn("Molecular type '$value' is not a valid type"); } $self->{'alphabet'} = $value; } return $self->{'alphabet'}; } =head2 coordinate_start Title : coordinate_start Usage : $coordstartlabel=$obj->coordinate_start() : $coordstartlabel=$obj->coordinate_start($label) Function: returns and optionally sets the first label of the coordinate system used For some objects only labels inside the object or in frame (for Translation objects) will be allowed to get set as coordinate start Returns : label. It returns 0 if label not found. Errorcode -1 Args : an optional reference $label that is position 1 =cut sub coordinate_start { my ($self,$label) = @_; if ($label) { if ($self->valid($label)) { $self->{'coordinate_start'} = $label; } else { $self->warn("The label you are trying to set as coordinate_start is not valid for this object"); } } my $coord_start = $self->{'coordinate_start'}; if ($coord_start) { return $coord_start; } else { return $self->start(); } } =head2 label Title : label Usage : $seq->label($position) : $seq->label($position,$firstlabel) Examples: $nextlabel=$seq->label(2,$label) -> retrieves the following label : $prevlabel=$seq->label(-1,$label) -> retrieves the preceding label Function: returns the label of the nucleotide at $position from current coordinate start Returns : a label. It returns 0 if label not found. Errorcode -1 Args : a position, an optional reference $firstlabel that is to be used as position 1 an optional strand (1 or -1) argument if strand argument is not given, it will default to the object argument. This argument is useful when a call is issued from a child of a parent object containing the subseq method =cut sub label { my ($self,$position,$firstlabel,$strand)=@_; my $label; unless (defined ($firstlabel)) { $firstlabel=$self->coordinate_start; } unless ($position) { # if position = 0 complain ? $self->warn("Position not given or position 0"); return (-1); } unless (defined ($strand)) { # if optional [strand] argument not given $strand=$self->strand; } if ($strand == 1) { if ($position > 0) { $label=$self->{'seq'}->down_get_label_at_pos($position,$firstlabel) } else { # if < 0 $label=$self->{'seq'}->up_get_label_at_pos(1 - $position,$firstlabel) } } else { if ($position > 0) { $label=$self->{'seq'}->up_get_label_at_pos($position,$firstlabel) } else { # if < 0 $label=$self->{'seq'}->down_get_label_at_pos(1 - $position,$firstlabel) } } return $label; } =head2 position Title : position Usage : $seq->position($label) : $seq->position($label,$firstlabel) Function: returns the position of nucleotide at $label Returns : the position of the label from current coordinate start Errorcode 0 Args : a label pointing to a certain nucleotide (e.g. start of exon) an optional "firstlabel" as reference to count from an optional strand (1 or -1) argument if strand argument is not given, it will default to the object argument. This argument is useful when a call is issued from a child of a parent object containing the subseq method =cut sub position { my ($self,$label,$firstlabel,$strand)=@_; unless (defined ($strand)) { # if optional [strand] argument not given $strand=$self->strand; } unless (defined ($firstlabel)) { $firstlabel=$self->coordinate_start; } unless ($self->valid($label)) { $self->warn("label not valid"); return (0); } if ($firstlabel == $label) { return (1); } my ($coordpos,$position0,$position); $position0=$self->{'seq'}->down_get_pos_of_label($label); $coordpos=$self->{'seq'}->down_get_pos_of_label($firstlabel); $position=$position0-$coordpos+1; if ($position <= 0) { $position--; } if ($strand == -1) { #print "\n----------DEBUGSEQPOS label $label firstlabel $firstlabel strand $strand: position=",1-$position; return (1-$position); } else { #print "\n----------DEBUGSEQPOS label $label firstlabel $firstlabel strand $strand: position=",$position; return ($position); } } =head2 follows Title : follows Usage : $seq->follows($firstlabel,$secondlabel) : $seq->follows($firstlabel,$secondlabel,$strand) Function: checks if SECONDlabel follows FIRSTlabel, undependent of the strand i.e. it checks downstream for forward strand and upstream for reverse strand Returns : 1 or 0 Errorcode -1 Args : two labels an optional strand (1 or -1) argument if strand argument is not given, it will default to the object argument. This argument is useful when a call is issued from a child of a parent object containing the subseq method =cut #' # wraparound to is_downstream and is_upstream that chooses the correct one # depending on the strand sub follows { my ($self,$firstlabel,$secondlabel,$strand)=@_; unless (defined ($strand)) { # if optional [strand] argument not given $strand=$self->strand; } if ($strand == 1) { return ($self->{'seq'}->is_downstream($firstlabel,$secondlabel)); } else { return ($self->{'seq'}->is_upstream($firstlabel,$secondlabel)); } } # #=head2 translate # # Title : translate # Usage : $protein_seq = $obj->translate # Function: Provides the translation of the DNA sequence # using full IUPAC ambiguities in DNA/RNA and amino acid codes. # # The resulting translation is identical to EMBL/TREMBL database # translations. # # Returns : a string # Args : character for terminator (optional) defaults to '*' # character for unknown amino acid (optional) defaults to 'X' # frame (optional) valid values 0, 1, 3, defaults to 0 # codon table id (optional) defaults to 1 # #=cut # #sub translate { # my ($self) = shift; # return ($self->translate_string($self->seq,@_)); #} # #=head2 translate_string # # Title : translate_string # Usage : $protein_seq = $obj->translate_string("attcgtgttgatcgatta"); # Function: Like translate, but can be used to translate subsequences after # having retrieved them as string. # Args : 1st argument is a string. Optional following arguments: like in # the translate method # #=cut # # #sub translate_string { # my($self) = shift; # my($seq) = shift; # my($stop, $unknown, $frame, $tableid) = @_; # my($i, $len, $output) = (0,0,''); # my($codon) = ""; # my $aa; # # # ## User can pass in symbol for stop and unknown codons # unless(defined($stop) and $stop ne '') { $stop = "*"; } # unless(defined($unknown) and $unknown ne '') { $unknown = "X"; } # unless(defined($frame) and $frame ne '') { $frame = 0; } # # ## the codon table ID # if ($self->translation_table) { # $tableid = $self->translation_table; # } # unless(defined($tableid) and $tableid ne '') { $tableid = 1; } # # ##Error if monomer is "Amino" # $self->warn("Can't translate an amino acid sequence.") # if (defined $self->alphabet && $self->alphabet eq 'protein'); # # ##Error if frame is not 0, 1 or 2 # $self->warn("Valid values for frame are 0, 1, 2, not [$frame].") # unless ($frame == 0 or $frame == 1 or $frame == 2); # # #thows a warning if ID is invalid # my $codonTable = Bio::Tools::CodonTable->new( -id => $tableid); # # # deal with frame offset. # if( $frame ) { # $seq = substr ($seq,$frame); # } # # for $codon ( grep { CORE::length == 3 } split(/(.{3})/, $seq) ) { # my $aa = $codonTable->translate($codon); # if ($aa eq '*') { # $output .= $stop; # } # elsif ($aa eq 'X') { # $output .= $unknown; # } # else { # $output .= $aa ; # } # } # #if( substr($output,-1,1) eq $stop ) { # # chop $output; # #} # # return ($output); #} =head2 gene Title : gene Usage : my $gene=$obj->gene; Function: Gets or sets the reference to the LiveSeq::Gene object. Objects that are features of a LiveSeq Gene will have this attribute set automatically. Returns : reference to an object of class Gene Note : if Gene object is not set, this method will return 0; Args : none or reference to object of class Bio::LiveSeq::Gene =cut sub gene { my ($self,$value) = @_; if (defined $value) { $self->{'gene'} = $value; } unless (exists $self->{'gene'}) { return (0); } else { return $self->{'gene'}; } } =head2 obj_valid Title : obj_valid Usage : if ($obj->obj_valid) {do something;} Function: Checks if start and end labels are still valid for the ojbect, i.e. tests if the LiveSeq object is still valid Returns : boolean Args : none =cut sub obj_valid { my $self=shift; unless (($self->{'seq'}->valid($self->start()))&&($self->{'seq'}->valid($self->end()))) { return (0); } return (1); } =head2 name Title : name Usage : $name = $obj->name; : $name = $obj->name("ABCD"); Function: Returns or sets the name of the object. If there is no name, it will return "unknown"; Returns : A string Args : None =cut sub name { my ($self,$value) = @_; if (defined $value) { $self->{'name'} = $value; } unless (exists $self->{'name'}) { return "unknown"; } else { return $self->{'name'}; } } =head2 desc Title : desc Usage : $desc = $obj->desc; : $desc = $obj->desc("ABCD"); Function: Returns or sets the description of the object. If there is no description, it will return "unknown"; Returns : A string Args : None =cut sub desc { my ($self,$value) = @_; if (defined $value) { $self->{'desc'} = $value; } unless (exists $self->{'desc'}) { return "unknown"; } else { return $self->{'desc'}; } } =head2 source Title : source Usage : $name = $obj->source; : $name = $obj->source("Homo sapiens"); Function: Returns or sets the organism that is source of the object. If there is no source, it will return "unknown"; Returns : A string Args : None =cut sub source { my ($self,$value) = @_; if (defined $value) { $self->{'source'} = $value; } unless (exists $self->{'source'}) { return "unknown"; } else { return $self->{'source'}; } } sub delete_Obj { my $self = shift; my @values= values %{$self}; my @keys= keys %{$self}; foreach my $key ( @keys ) { delete $self->{$key}; } foreach my $value ( @values ) { if (index(ref($value),"LiveSeq") != -1) { # object case eval { # delete $self->{$value}; $value->delete_Obj; }; } elsif (index(ref($value),"ARRAY") != -1) { # array case my @array=@{$value}; my $element; foreach $element (@array) { eval { $element->delete_Obj; }; } } elsif (index(ref($value),"HASH") != -1) { # object case my %hash=%{$value}; my $element; foreach $element (%hash) { eval { $element->delete_Obj; }; } } } return(1); } 1; BioPerl-1.6.923/Bio/LiveSeq/Transcript.pm000444000765000024 6057212254227337 20245 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::Transcript # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::Transcript - Transcript class for LiveSeq =head1 SYNOPSIS # documentation needed =head1 DESCRIPTION This stores information about coding sequences (CDS). The implementation is that a Transcript object accesses a collection of Exon objects, inferring from them the nucleotide structure and sequence. =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::Transcript; use strict; # use Carp qw(carp cluck); use Bio::LiveSeq::Exon; # uses Exon to create new exon in case of deletion use base qw(Bio::LiveSeq::SeqI); =head2 new Title : new Usage : $transcript = Bio::LiveSeq::Transcript->new(-exons => \@obj_refs); Function: generates a new Bio::LiveSeq::Transcript Returns : reference to a new object of class Transcript Errorcode -1 Args : reference to an array of Exon object references =cut sub new { my ($thing, %args) = @_; my $class = ref($thing) || $thing; my ($obj,%transcript); my @exons=@{$args{-exons}}; $obj = \%transcript; $obj = bless $obj, $class; unless (@exons) { $obj->warn("$class not initialised because exons array empty"); return(-1); } # now useless, after start and end methods have been overridden here my $firstexon = $exons[0]; #my $lastexon = $exons[-1]; #my $start = $firstexon->start; #my $end = $lastexon->end; my $strand = $firstexon->strand; my $seq = $firstexon->{'seq'}; $obj->alphabet('rna'); unless (_checkexons(\@exons)) { $obj->warn("$class not initialised because of problems in the exon structure"); return(-1); } $obj->{'strand'}=$strand; $obj->{'exons'}=\@exons; $obj->{'seq'}=$seq; # set Transcript into each Exon my $exon; foreach $exon (@exons) { $exon->{'transcript'}=$obj; } return $obj; } =head2 all_Exons Title : all_Exons Usage : $transcript_obj->all_Exons() Function: returns references to all Exon objects the Transcript is composed of Example : foreach $exon ($transcript->all_Exons()) { do_something } Returns : array of object references Args : none =cut sub all_Exons { my $self=shift; my $exonsref=$self->{'exons'}; my @exons=@{$exonsref}; my @newexons; my $exon; foreach $exon (@exons) { unless ($exon->obj_valid) { $self->warn("$exon no more valid, start or end label lost, skipping....",1); # ignorable } else { push(@newexons,$exon); } } if ($#exons != $#newexons) { # update exons field $self->{'exons'}=\@newexons; } return (@newexons); } =head2 downstream_seq Title : downstream_seq Usage : $transcript_obj->downstream_seq() : $transcript_obj->downstream_seq(64) Function: returns a string of nucleotides downstream of the end of the CDS. If there is some information of the real mRNA, from features in an attached Gene object, it will return up to those boundaries. Otherwise it will return 1000 nucleotides. If an argument is given it will override the default 1000 number and return instead /that/ requested number of nucleotides. But if a Gene object is attached, this argument will be ignored. Returns : string Args : an optional integer number of nucleotides to be returned instead of the default if no gene attached =cut sub downstream_seq { my ($self,$howmany)=@_; my $str; if (defined ($howmany)) { unless ($howmany > 0) { $self->throw("No sense in asking less than 1 downstream nucleotides!"); } } else { unless ($self->{'seq'}->alphabet eq 'rna') { # if rna retrieve until the end #$str=$DNAobj->labelsubseq($self->end,undef,undef,"unsecuremoderequested"); #return(substr($str,1)); # delete first nucleotide that is the last of Transcript if ($self->gene) { # if there is Gene object attached fetch relevant info $str=$self->{'seq'}->labelsubseq($self->end,undef,$self->gene->maxtranscript->end); # retrieve from end of this Transcript to end of the maxtranscript $str=substr($str,1); # delete first nucleotide that is the last of Transcript if (CORE::length($str) > 0) { return($str); } else { # if there was no downstream through the gene's maxtranscript, go the usual way $howmany = 1000; } } else { $howmany = 1000; } } } my @exons=$self->all_Exons; my $strand=$self->strand(); my $lastexon=$exons[-1]; my $lastexonlength=$lastexon->length; # $howmany nucs after end of last exon #my $downstream_seq=$lastexon->subseq($lastexonlength+1,undef,$howmany); my $downstream_seq; if ($howmany) { $downstream_seq=substr($lastexon->labelsubseq($self->end,$howmany,undef,"unsecuremoderequested"),1); } else { if ($strand == 1) { $downstream_seq=substr($lastexon->labelsubseq($self->end,undef,$self->{'seq'}->end,"unsecuremoderequested"),1); } else { $downstream_seq=substr($lastexon->labelsubseq($self->end,undef,$self->{'seq'}->start,"unsecuremoderequested"),1); } } return $downstream_seq; } =head2 upstream_seq Title : upstream_seq Usage : $transcript_obj->upstream_seq() : $transcript_obj->upstream_seq(64) Function: just like downstream_seq but returns nucleotides before the ATG Note : the default, if no Gene information present and no nucleotides number given, is to return up to 400 nucleotides. =cut sub upstream_seq { my ($self,$howmany)=@_; if (defined ($howmany)) { unless ($howmany > 0) { $self->throw("No sense in asking less than 1 upstream nucleotides!"); } } else { unless ($self->{'seq'}->alphabet eq 'rna') { # if rna retrieve from the start if ($self->gene) { # if there is Gene object attached fetch relevant info my $str=$self->{'seq'}->labelsubseq($self->gene->maxtranscript->start,undef,$self->start); # retrieve from start of maxtranscript to start of this Transcript chop $str; # delete last nucleotide that is the A of starting ATG if (length($str) > 0) { return($str); } else { # if there was no upstream through the gene's maxtranscript, go the usual way $howmany = 400; } } else { $howmany = 400; } } } my @exons=$self->all_Exons; my $firstexon=$exons[0]; my $upstream_seq; my $strand=$self->strand(); if ($howmany) {# $howmany nucs before begin of first exon my $labelbefore=$firstexon->label(-$howmany,$firstexon->start); if ($labelbefore < 1) { if ($strand == 1) { $labelbefore=$self->{'seq'}->start; } else { $labelbefore=$self->{'seq'}->end; } } $upstream_seq=$firstexon->labelsubseq($labelbefore,undef,$firstexon->start,"unsecuremoderequested"); chop $upstream_seq; } else { if ($strand == 1) { $upstream_seq=$firstexon->labelsubseq($self->{'seq'}->start,undef,$self->start,"unsecuremoderequested"); chop $upstream_seq; # delete last nucleotide that is the A of starting ATG } else { $upstream_seq=$firstexon->labelsubseq($self->{'seq'}->end,undef,$self->start,"unsecuremoderequested"); chop $upstream_seq; # delete last nucleotide that is the A of starting ATG } } return $upstream_seq; } # These get redefined here, overriding the SeqI one because they draw their # information from the Exons a Transcript is built of # optional argument: firstlabel. If not given, it checks coordinate_start # This is useful when called by Translation # also used by _delete sub label { my ($self,$position,$firstlabel)=@_; unless ($position) { # if position = 0 complain ? $self->warn("Position not given or position 0"); return (-1); } my ($start,$end,$strand)=($self->start(),$self->end(),$self->strand()); my ($label,@labels,$length,$arraypos); unless (defined ($firstlabel)) { $firstlabel=$self->coordinate_start; # this is inside Transcript obj } my $coord_pos=$self->_inside_position($firstlabel); $length=$self->length; #if ($strand == 1) { if ($position < 1) { $position++; # to account for missing of 0 position } $arraypos=$position+$coord_pos-2; #print "\n=-=-=-=-DEBUG: arraypos $arraypos, pos $position, coordpos: $coord_pos"; if ($arraypos < 0) { $label=$self->{'seq'}->label($arraypos,$start,$strand); #? } elsif ($arraypos >= $length) { $label=$self->{'seq'}->label($arraypos-$length+2,$end,$strand); #? } else { # inside the Transcript @labels=$self->all_labels; $label=$labels[$arraypos]; } #} } # argument: label # returns: position of label according to coord_start # errorcode: 0 label not found # optional argument: firstlabel. If not given, it checks coordinate_start # This is useful when called by Translation sub position { my ($self,$label,$firstlabel)=@_; unless ($self->{'seq'}->valid($label)) { $self->warn("label is not valid"); return (0); } unless (defined ($firstlabel)) { $firstlabel=$self->coordinate_start; # this is inside Transcript obj } if ($label == $firstlabel) { return (1); } my ($start,$end,$strand)=($self->start(),$self->end(),$self->strand()); my ($position,$in_pos,$out_pos,$coord_pos); my $length=$self->length; $coord_pos=$self->_inside_position($firstlabel); if ($self->valid($label)) { # if label is inside the Transcript $in_pos=$self->_inside_position($label); $position=$in_pos-$coord_pos+1; if ($position <= 0) { return ($position-1); # accounts for the missing of the 0 position } } else { if ($self->follows($end,$label)) { # label after end of transcript $out_pos=$self->{'seq'}->position($label,$end,$strand); #print "\n+++++++++DEBUG label $label FOLLOWS end $end outpos $out_pos coordpos $coord_pos"; $position=$out_pos+$length-$coord_pos; } elsif ($self->follows($label,$start)) { # label before begin of transcript #print "\n+++++++++DEBUG label $label BEFORE start $start outpos $out_pos coordpos $coord_pos"; $out_pos=$self->{'seq'}->position($label,$start,$strand); $position=$out_pos-$coord_pos+1; } else { # label is in intron (not valid, not after, not before)! $self->warn("Cannot give position of label pointing to intron according to CDS numbering!",1); return (0); } } return ($position); } sub seq { my $self=shift; my ($exon,$str); my @exons=$self->all_Exons(); foreach $exon (@exons) { $str .= $exon->seq(); } return $str; } sub length { my $self=shift; my ($exon,$length); my @exons=$self->all_Exons(); foreach $exon (@exons) { $length += $exon->length(); } return $length; } sub all_labels { my $self=shift; my ($exon,@labels); my @exons=$self->all_Exons(); foreach $exon (@exons) { push (@labels,$exon->all_labels()); } return @labels; } # redefined here so that it will retrieve effective subseq without introns # otherwise it would have retrieved an underlying DNA (possibly with introns) # subsequence # Drawback: this is really bulky, label->position and then a call to # subseq that will do the opposite position-> label # # one day this can be rewritten as the main one so that the normal subseq # will rely on this one and hence avoid this double (useless and lengthy) # conversion between labels and positions sub old_labelsubseq { my ($self,$start,$length,$end)=@_; my ($pos1,$pos2); if ($start) { unless ($self->valid($start)) { $self->warn("Start label not valid"); return (-1); } $pos1=$self->position($start); } if ($end) { if ($end == $start) { $length=1; } else { unless ($self->valid($end)) { $self->warn("End label not valid"); return (-1); } unless ($self->follows($start,$end) == 1) { $self->warn("End label does not follow Start label!"); return (-1); } $pos2=$self->position($end); undef $length; } } return ($self->subseq($pos1,$pos2,$length)); } # rewritten, eventually sub labelsubseq { my ($self,$start,$length,$end,$unsecuremode)=@_; unless (defined $unsecuremode && $unsecuremode eq "unsecuremoderequested") { # to skip security checks (faster) if ($start) { unless ($self->valid($start)) { $self->warn("Start label not valid"); return (-1); } } else { $start=$self->start; } if ($end) { if ($end == $start) { $length=1; undef $end; } else { undef $length; # end argument overrides length argument unless ($self->valid($end)) { $self->warn("End label not valid"); return (-1); } unless ($self->follows($start,$end) == 1) { $self->warn("End label does not follow Start label!"); return (-1); } } } else { $end=$self->end; } } my ($seq,$exon,$startexon,$endexon); my @exonlabels; my @exons=$self->all_Exons; EXONCHECK: foreach $exon (@exons) { if ((!(defined($startexon)))&&($exon->valid($start))) { # checks only if not yet found $startexon=$exon; } if ($exon->valid($end)) { $endexon=$exon; } if ((!(defined($seq)) && (defined($startexon)))) { # initializes only once if ((defined($endexon)) && ($endexon eq $startexon)) { # then perfect, we are finished if ($length) { $seq = $startexon->labelsubseq($start,$length,undef,"unsecuremoderequested"); last EXONCHECK; } else { $seq = $startexon->labelsubseq($start,undef,$end,"unsecuremoderequested"); } last EXONCHECK; } else { # get up to the end of the exon $seq = $startexon->labelsubseq($start,undef,undef,"unsecuremoderequested"); } } if (($startexon)&&($exon ne $startexon)) { if (defined($endexon)) { # we arrived to the last exon $seq .= $endexon->labelsubseq(undef,undef,$end,"unsecuremoderequested"); # get from the start of the exon last EXONCHECK; } elsif (defined($startexon)) { # we are in a whole-exon-in-the-middle case $seq .= $exon->seq; # we add it completely to the seq } # else, we still have to reach the start point, exon useless, we move on if ($length) { # if length argument specified if (($seq && (CORE::length($seq) >= $length))) { last EXONCHECK; } } } } if ($length) { return (substr($seq,0,$length)); } else { return ($seq); } } # argument: label # returns: the objref and progressive number of the Exon containing that label # errorcode: -1 sub in_which_Exon { my ($self,$label)=@_; my ($count,$exon); my @exons=$self->all_Exons; foreach $exon (@exons) { $count++; # 1st exon is numbered "1" if ($exon->valid($label)) { return ($exon,$count) } } return (-1); # if nothing found } # recoded to exploit the new fast labelsubseq() # valid only inside Transcript sub subseq { my ($self,$pos1,$pos2,$length) = @_; my ($str,$startlabel,$endlabel); if (defined ($pos1)) { if ($pos1 == 0) { # if position = 0 complain $self->warn("Position cannot be 0!"); return (-1); } if ((defined ($pos2))&&($pos1>$pos2)) { $self->warn("1st position($pos1) cannot be > 2nd position($pos2)!"); return (-1); } $startlabel=$self->label($pos1); unless ($self->valid($startlabel)) { $self->warn("Start label not valid"); return (-1); } if ($startlabel < 1) { $self->warn("position $pos1 not valid as start of subseq!"); return (-1); } } else { $startlabel=$self->start; } if (defined ($pos2)) { if ($pos2 == 0) { # if position = 0 complain $self->warn("Position cannot be 0!"); return (-1); } undef $length; if ((defined ($pos1))&&($pos1>$pos2)) { $self->warn("1st position($pos1) cannot be > 2nd position($pos2)!"); return (-1); } $endlabel=$self->label($pos2); unless ($self->valid($endlabel)) { $self->warn("End label not valid"); return (-1); } if ($endlabel < 1) { $self->warn("position $pos2 not valid as end of subseq!"); return (-1); } } else { unless (defined ($length)) { $endlabel=$self->end; } } return ($self->labelsubseq($startlabel,$length,$endlabel,"unsecuremoderequested")); } # works only inside the transcript, complains if asked outside sub old_subseq { my ($self,$pos1,$pos2,$length) = @_; my ($str,$startcount,$endcount,$seq,$seqlength); if (defined ($length)) { if ($length < 1) { $self->warn("No sense asking for a subseq of length < 1"); return (-1); } } my $firstlabel=$self->coordinate_start; # this is inside Transcript obj my $coord_pos=$self->_inside_position($firstlabel); # TESTME old $seq=$self->seq; $seqlength=CORE::length($seq); unless (defined ($pos1)) { $startcount=1+$coord_pos-1; # i.e. coord_pos } else { if ($pos1 == 0) { # if position = 0 complain $self->warn("Position cannot be 0!"); return (-1); } elsif ($pos1 < 0) { $pos1++; } if ((defined ($pos2))&&($pos1>$pos2)) { $self->warn("1st position ($pos1) cannot be > 2nd position ($pos2)!"); return (-1); } $startcount=$pos1+$coord_pos-1; } unless (defined ($pos2)) { ; } else { if ($pos2 == 0) { # if position = 0 complain $self->warn("Position cannot be 0!"); return (-1); } elsif ($pos2 < 0) { $pos2++; } if ((defined ($pos1))&&($pos1>$pos2)) { $self->warn("1st position ($pos1) cannot be > 2nd position ($pos2)!"); return (-1); } $endcount=$pos2+$coord_pos-1; if ($endcount > $seqlength) { #print "\n###DEBUG###: pos1 $pos1 pos2 $pos2 coordpos $coord_pos endcount $endcount seqln $seqlength\n"; $self->warn("Cannot access end position after the end of Transcript"); return (-1); } $length=$endcount-$startcount+1; } #print "\n###DEBUG pos1 $pos1 pos2 $pos2 start $startcount end $endcount length $length coordpos $coord_pos\n"; my $offset=$startcount-1; if ($offset < 0) { $self->warn("Cannot access startposition before the beginning of Transcript, returning from start",1); # ignorable return (substr($seq,0,$length)); } elsif ($offset >= $seqlength) { $self->warn("Cannot access startposition after the end of Transcript"); return (-1); } else { $str=substr($seq,$offset,$length); if (CORE::length($str) < $length) { $self->warn("Attention, cannot return the length requested ". "for subseq",1) if $self->verbose > 0; # ignorable } return $str; } } # redefined so that it doesn't require other methods (after deletions) to # reset it. sub start { my $self = shift; my $exonsref=$self->{'exons'}; my @exons=@{$exonsref}; return ($exons[0]->start); } sub end { my $self = shift; my $exonsref=$self->{'exons'}; my @exons=@{$exonsref}; return ($exons[-1]->end); } # internal methods begin here # returns: position of label in transcript's all_labels # with STARTlabel == 1 # errorcode 0 -> label not found # argument: label sub _inside_position { my ($self,$label)=@_; my ($start,$end,$strand)=($self->start(),$self->end(),$self->strand()); my ($position,$checkme); my @labels=$self->all_labels; foreach $checkme (@labels) { $position++; if ($label == $checkme) { return ($position); } } return (0); } # returns 1 OK or 0 ERROR # arguments: reference to array of Exon object references sub _checkexons { my ($exon,$thisstart); my $self=$exon; my $exonsref=$_[0]; my @exons=@{$exonsref}; my $firstexon = $exons[0]; unless (ref($firstexon) eq "Bio::LiveSeq::Exon") { $self->warn("Object not of class Exon"); return (0); } my $strand = $firstexon->strand; my $prevend = $firstexon->end; shift @exons; # skip first one foreach $exon (@exons) { unless (ref($exon) eq "Bio::LiveSeq::Exon") { # object class check $self->warn("Object not of class Exon"); return (0); } if ($exon->strand != $strand) { # strand consistency check $self->warn("Exons' strands not consistent when trying to create Transcript"); return (0); } $thisstart = $exon->start; unless ($exon->{'seq'}->follows($prevend,$thisstart,$strand)) { $self->warn("Exons not in correct order when trying to create Transcript"); return (0); } $prevend = $exon->end; } return (1); } =head2 get_Translation Title : valid Usage : $translation = $obj->get_Translation() Function: retrieves the reference to the object of class Translation (if any) attached to a LiveSeq object Returns : object reference Args : none =cut sub get_Translation { my $self=shift; return ($self->{'translation'}); # this is set when Translation->new is called } # this checks so that deletion spanning multiple exons is # handled accordingly and correctly # arguments: begin and end label of a deletion # this is called BEFORE any deletion in the chain sub _deletecheck { my ($self,$startlabel,$endlabel)=@_; my $exonsref=$self->{'exons'}; my @exons=@{$exonsref}; my ($startexon,$endexon,$exon); $startexon=$endexon=0; foreach $exon (@exons) { if (($startexon == 0)&&($exon->valid($startlabel))) { $startexon=$exon; # exon containing start of deletion } if (($endexon == 0)&&($exon->valid($endlabel))) { $endexon=$exon; # exon containing end of deletion } if (($startexon)&&($endexon)) { last; # don't check further } } my $nextend=$self->label(2,$endlabel); # retrieve the next label my $prevstart=$self->label(-1,$startlabel); # retrieve the prev label if ($startexon eq $endexon) { # intra-exon deletion if (($startexon->start eq $startlabel) && ($startexon->end eq $endlabel)) { # let's delete the entire exon my @newexons; foreach $exon (@exons) { unless ($exon eq $startexon) { push(@newexons,$exon); } } $self->{'exons'}=\@newexons; } elsif ($startexon->start eq $startlabel) { # special cases $startexon->{'start'}=$nextend; # set a new start of exon } elsif ($startexon->end eq $endlabel) { $startexon->{'end'}=$prevstart; # set a new end of exon } else { return; # no problem } } else { # two new exons to be created, inter-exons deletion my @newexons; my $exonobj; my $dna=$self->{'seq'}; my $strand=$self->strand; my $notmiddle=1; # flag for skipping exons in the middle of deletion foreach $exon (@exons) { if ($exon eq $startexon) { $exonobj=Bio::LiveSeq::Exon->new('-seq'=>$dna,'-start'=>$exon->start,'-end'=>$prevstart,'-strand'=>$strand); # new partial exon push(@newexons,$exonobj); $notmiddle=0; # now we enter totally deleted exons } elsif ($exon eq $endexon) { $exonobj=Bio::LiveSeq::Exon->new('-seq'=>$dna,'-start'=>$nextend,'-end'=>$exon->end,'-strand'=>$strand); # new partial exon push(@newexons,$exonobj); $notmiddle=1; # exiting totally deleted exons } else { if ($notmiddle) { # if before or after exons with deletion push(@newexons,$exon); }# else skip them } } $self->{'exons'}=\@newexons; } } =head2 translation_table Title : translation_table Usage : $name = $obj->translation_table; : $name = $obj->translation_table(11); Function: Returns or sets the translation_table used for translating the transcript. If it has never been set, it will return undef. Returns : an integer =cut sub translation_table { my ($self,$value) = @_; if (defined $value) { $self->{'translation_table'} = $value; } unless (exists $self->{'translation_table'}) { return; } else { return $self->{'translation_table'}; } } =head2 frame Title : frame Usage : $frame = $transcript->frame($label); Function: Returns the frame of a particular nucleotide. Frame can be 0 1 or 2 and means the position in the codon triplet of the particulat nucleotide. 0 is the first codon_position. Codon_position (1 2 3) is simply frame+1. If the label asked for is not inside the Transcript, -1 will be returned. Args : a label Returns : 0 1 or 2 Errorcode -1 =cut # args: label # returns: frame of nucleotide (0 1 2) # errorcode: -1 sub frame { my ($self,$inputlabel)=@_; my @labels=$self->all_labels; my ($label,$frame,$count); foreach $label (@labels) { if ($inputlabel == $label) { return ($count % 3); } $count++; # 0 1 2 3 4.... } return (-1); # label not found amid Transcript labels } 1; BioPerl-1.6.923/Bio/LiveSeq/Translation.pm000444000765000024 2136312254227325 20402 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::Translation # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::Translation - Translation class for LiveSeq =head1 SYNOPSIS #documentation needed =head1 DESCRIPTION This stores information about aminoacids translations of transcripts. The implementation is that a Translation object is the translation of a Transcript object, with different possibilities of manipulation, different coordinate system and eventually its own ranges (protein domains). =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::Translation; use strict; #use Carp qw(croak carp cluck); use Bio::LiveSeq::SeqI; # uses SeqI, inherits from it use Bio::PrimarySeq; use base qw(Bio::LiveSeq::Transcript); =head2 new Title : new Usage : $protein = Bio::LiveSeq::Translation->new(-transcript => $transcr); Function: generates a new Bio::LiveSeq::Translation Returns : reference to a new object of class Translation Errorcode -1 Args : reference to an object of class Transcript =cut sub new { my ($thing, %args) = @_; my $class = ref($thing) || $thing; my ($obj,%translation); my $transcript=$args{-transcript}; $obj = \%translation; $obj = bless $obj, $class; unless ($transcript) { $obj->throw("$class not initialised because no -transcript given"); } unless (ref($transcript) eq "Bio::LiveSeq::Transcript") { $obj->throw("$class not initialised because no object of class Transcript given"); } #my $startbase = $transcript->start; #my $endbase = $transcript->end; my $strand = $transcript->strand; my $seq = $transcript->{'seq'}; $obj->{'strand'}=$strand; $obj->{'seq'}=$seq; $obj->{'transcript'}=$transcript; $obj->{'alphabet'}="protein"; $transcript->{'translation'}=$obj;# set the Translation ref into its Transcript return $obj; } =head2 get_Transcript Title : valid Usage : $transcript = $obj->get_Transcript() Function: retrieves the reference to the object of class Transcript (if any) attached to a LiveSeq object Returns : object reference Args : none =cut sub get_Transcript { my $self=shift; return ($self->{'transcript'}); } # These get redefined here, overriding the SeqI ones sub change { my ($self)=@_; $self->warn("Cannot change a Translation object!\nChanges have to be issued at the nucleotide level!"); return (-1); } sub positionchange { my ($self)=@_; $self->warn("Cannot change a Translation object!\nChanges have to be issued at the nucleotide level!"); return (-1); } sub labelchange { my ($self)=@_; $self->warn("Cannot change a Translation object!\nChanges have to be issued at the nucleotide level!"); return (-1); } # this just returns the translation of the transcript, without checking for # stop codons sub transl_seq { my $self=shift; my $transcript=$self->get_Transcript; my $translation=$transcript->translate(undef, undef, undef, $self->translation_table)->seq; return $translation; } # version 1.74 -> now the "*" is printed sub seq { my $self=shift; my $proteinseq; my $transcript=$self->get_Transcript; my $translation=$transcript->translate(undef, undef, undef, $self->translation_table)->seq; my $stop_pos=index($translation,"*"); if ($stop_pos == -1) { # no stop present, continue downstream my $downstreamseq=$transcript->downstream_seq(); #carp "the downstream is: $downstreamseq"; # debug my $cdnaseq=$transcript->seq(); my $extendedseq = Bio::PrimarySeq->new(-seq => "$cdnaseq$downstreamseq", -alphabet => 'dna' ); $translation=$extendedseq->translate(undef, undef, undef, $self->translation_table)->seq; #carp "the new translation is: $translation"; # debug $stop_pos=index($translation,"*"); if ($stop_pos == -1) { # still no stop present, return warning $self->warn("Warning: no stop codon found in the retrieved sequence downstream of Transcript ",1); undef $stop_pos; $proteinseq=$translation; } else { $proteinseq=substr($translation,0,$stop_pos+1); #carp "the new stopped translation is: $proteinseq, because the stop is at position $stop_pos"; # debug } } else { $proteinseq=substr($translation,0,$stop_pos+1); } return $proteinseq; } sub length { my $self=shift; my $seq=$self->seq; my $length=length($seq); return $length; } sub all_labels { my $self=shift; return $self->get_Transcript->all_labels; } # counts in triplet. Only a label matching the beginning of a triplet coding # for an aminoacid is considered valid when setting coordinate_start # (i.e. only in frame!) sub valid { my ($self,$label)=@_; my $i; my @labels=$self->get_Transcript->all_labels; my $length=$#labels; while ($i <= $length) { if ($label == $labels[$i]) { return (1); # found } $i=$i+3; } return (0); # not found } # returns the label to the first nucleotide of the triplet coding for $position aminoacid sub label { my ($self,$position)=@_; my $firstlabel=$self->coordinate_start; # this is in_frame checked if ($position > 0) { $position=$position*3-2; } else { # if position = 0 this will be caught by Transcript, error thrown $position=$position*3; } return $self->get_Transcript->label($position,$firstlabel); # check for coord_start different } # returns position (aminoacids numbering) of a particular label # used to return 0 for not in frame labels # now returns the position anyway (after version 1.66) sub position { my ($self,$label)=@_; my $firstlabel=$self->coordinate_start; # this is in_frame checked my $position=$self->get_Transcript->position($label,$firstlabel); use integer; my $modulus=$position % 3; if ($position == 0) { return (0); } elsif ($position > 0) { if ($modulus != 1) { $self->warn("Attention! Label $label is not in frame ". "(1st position of triplet) with protein",1) if $self->verbose > 0; # ignorable if ($modulus == 2) { return ($position / 3 + 1); } else { # i.e. modulus == 0 return ($position / 3); } } return ($position / 3 + 1); } else { # pos < 0 if ($modulus != 0) { $self->warn("Attention! Label $label is not in frame ". "(1st position of triplet) with protein",1) if $self->verbose > 0; # ignorable return ($position / 3 - 1); # ok for both other positions } return ($position / 3); } $self->throw( "WEIRD: execution shouldn't have reached here"); return (0); # this should never happen, but just in case } # note: it inherits subseq and labelsubseq from Transcript! sub start { my $self=shift; return ($self->{'transcript'}->start); } sub end { my $self=shift; return ($self->{'transcript'}->end); } =head2 aa_ranges Title : aa_ranges Usage : @proteinfeatures = $translation->aa_ranges() Function: to retrieve all the LiveSeq AARange objects attached to a Translation, usually created out of a SwissProt database entry crossreferenced from an EMBL CDS feature. Returns : an array Args : none =cut # returns an array of obj_ref of AARange objects attached to the Translation sub aa_ranges { my $self=shift; return ($self->{'aa_ranges'}); } sub translation_table { my $self=shift; $self->get_Transcript->translation_table(@_); } # returns all aminoacids "affected" i.e. all aminoacids coded by any codon # "touched" by the range selected between the labels, even if only partially. # it's not optimized for performance but it's useful sub labelsubseq { my ($self,$start,$length,$end)=@_; my ($pos1,$pos2); my $transcript=$self->get_Transcript; if ($start) { unless ($transcript->valid($start)) { $self->warn("Start label not valid"); return (-1); } $pos1=$self->position($start); } if ($end) { if ($end == $start) { $length=1; } else { unless ($transcript->valid($end)) { $self->warn("End label not valid"); return (-1); } unless ($transcript->follows($start,$end) == 1) { $self->warn("End label does not follow Start label!"); return (-1); } $pos2=$self->position($end); $length=$pos2-$pos1+1; } } my $sequence=$self->seq; return (substr($sequence,$pos1-1,$length)); } # return the offset in aminoacids from LiveSeq protein sequence and SwissProt # sequence (usually as a result of an INIT_MET or a gap) sub offset { my $self=shift; return ($self->{'offset'}); } 1; BioPerl-1.6.923/Bio/LiveSeq/IO000755000765000024 012254227340 15670 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/LiveSeq/IO/BioPerl.pm000444000765000024 3335112254227327 17751 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::IO::BioPerl # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::IO::BioPerl - Loader for LiveSeq from EMBL entries with BioPerl =head1 SYNOPSIS my $db="EMBL"; my $file="../data/M20132"; my $id="HSANDREC"; my $loader=Bio::LiveSeq::IO::BioPerl->load(-db=>"$db", -file=>"$file"); # or my $loader=Bio::LiveSeq::IO::BioPerl->load(-db=>"$db", -id=>"$id"); my @translationobjects=$loader->entry2liveseq(); my $genename="AR"; my $gene=$loader->gene2liveseq(-gene_name => "$genename", -getswissprotinfo => 0); #NOTE1: The only -db now supported is EMBL. Hence it defaults to EMBL. #NOTE2: -file requires a filename (and path if necessary) containing an # EMBL entry # -id will use Bio::DB::EMBL.pm to fetch the sequence from the web, # (bioperl wraparound to [w]getz from SRS) #NOTE3: To retrieve the swissprot (if possible) attached to the embl entry # (to get protein domains at dna level), only Bio::DB::EMBL.pm # is supported under BioPerl. Refer to Bio::LiveSeq::IO::SRS # otherwise. #NOTE4: NOTE3 is not implemented yet for bioperl, working on it =head1 DESCRIPTION This package uses BioPerl (SeqIO) to fetch a sequence database entry, analyse it and create LiveSeq objects out of it. A filename (or an ID that will fetch entry through the web) has to be passed to this package which will return references to all translation objects created from the EMBL entry. References to Transcription, DNA and Exon objects can all be retrieved departing from these. Alternatively, a specific "gene" name can be specified, together with the embl-acc ID. This will create a LiveSeq::Gene object with all relevant gene features attached/created. ATTENTION: if web fetching is requested, the package HTTP::Request needs to be installed. =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::IO::BioPerl; # TODO->TOCHECK # each_secondary_access not working # why array from each_tag_value($qual) ? When will there be more than one # element in such array? # what is the annotation object? ($seqobj->annotation) # unsatisfied by both BioPerl binomial and SRS "org" to retrieve Organism info use strict; use Carp qw(cluck croak carp); use vars qw($DBEMBLLOADED); use Bio::SeqIO; # for -file entry loading # Note, the following requires HTTP::Request. If the modules are not installed # uncomment the following and use only -filename and don't request swissprotinfo eval { require Bio::DB::EMBL; # for -id entry loading $DBEMBLLOADED = 1; }; use base qw(Bio::LiveSeq::IO::Loader); # This package can in the future host other databases loading subroutines. # e.g. ensembl2hash =head2 load Title : load Usage : my $filename="../data/M20132"; $loader=Bio::LiveSeq::IO::BioPerl->load(-db=>"EMBL", -file=>"$filename"); or $loader=Bio::LiveSeq::IO::BioPerl->load(-db=>"EMBL", -id=>"HSANDREC"); Function: loads an entry with BioPerl from a database into a hash Returns : reference to a new object of class IO::BioPerl holding an entry Errorcode 0 Args : an filename containing an EMBL entry OR an ID or ACCESSION code =cut sub load { my ($thing, %args) = @_; my $class = ref($thing) || $thing; my ($obj,%loader); my ($db,$filename,$id)=($args{-db},$args{-file},$args{-id}); if (defined($db)) { unless ($db eq "EMBL") { carp "Note: only EMBL now supported!"; return(0); } } else { $db="EMBL"; } if (defined($id) && defined($filename)) { carp "You can either specify a -id or a -filename!"; return(0); } unless (defined($id) || defined($filename)) { carp "You must specify either a -id or a -filename!"; return(0); } my $hashref; if ($db eq "EMBL") { my $test_transl=0; # change to 0 to avoid comparison of translation # these can be changed for future needs my @embl_valid_feature_names=qw(CDS CDS_span exon prim_transcript intron repeat_unit repeat_region mRNA); my @embl_valid_qual_names=qw(gene codon_start db_xref product note number rpt_family transl_table); # dunno yet how to implement test_transl again.... # probably on a one-on-one basis with each translation? if ($test_transl) { push (@embl_valid_qual_names,"translation"); # needed for test_transl } my $seqobj; # bioperl sequence object, to be passed to embl2hash if (defined($filename)) { my $stream = Bio::SeqIO->new('-file' => $filename, '-format' => 'EMBL'); $seqobj = $stream->next_seq(); } else { # i.e. if -id if( $DBEMBLLOADED ) { my $embl = Bio::DB::EMBL->new(); $seqobj = $embl->get_Seq_by_id($id); # EMBL ID or ACC } else { my $root = Bio::Root::Root->new(); $root->warn("Must have HTTP::Request::Common installed, cannot run load without the -filename option specified, see docs for Bio::LiveSeq::IO::BioPerl"); return; } } $hashref=&embl2hash($seqobj,\@embl_valid_feature_names,\@embl_valid_qual_names); } unless ($hashref) { return (0); } %loader = (db => $db, filename => $filename, id => $id, hash => $hashref); $obj = \%loader; $obj = bless $obj, $class; return $obj; } =head2 embl2hash Title : embl2hash Function: retrieves with BioPerl an EMBL entry, parses it and creates a hash that contains all the information. Returns : a reference to a hash Errorcode: 0 Args : a BioPerl Sequence Object (from file or web fetching) two array references to skip features and qualifiers (for performance) Example: @valid_features=qw(CDS exon prim_transcript mRNA); @valid_qualifiers=qw(gene codon_start db_xref product rpt_family); $hashref=&embl2hash($seqobj,\@valid_features,\@valid_qualifiers); =cut # arguments: Bioperl $seqobj # to skip features and qualifiers (for performance), two array # references must be passed (this can change into string arguments to # be passed....) # returns: a reference to a hash containing the important features requested sub embl2hash { my $seqobj=$_[0]; my %valid_features; my %valid_names; if ($_[1]) { %valid_features = map {$_, 1} @{$_[1]}; # to skip features } if ($_[2]) { %valid_names = map {$_, 1} @{$_[2]}; # to skip qualifiers } my $annobj = $seqobj->annotation(); # what's this? my $entry_Sequence = lc($seqobj->seq()); # SRS returns lowercase my $entry_ID = $seqobj->display_id; my $entry_AccNumber = $seqobj->accession; # or maybe accession_number ? my $secondary_acc; # to fetch the other acc numbers foreach $secondary_acc ($seqobj->get_secondary_accessions) { # not working! $entry_AccNumber .= " $secondary_acc"; } my $entry_Molecule = $seqobj->molecule; # this alone returns molec+division my $entry_Division = $seqobj->division; # fixed: now Molecule works in BioPerl, no need for next lines #my @Molecule=split(" ",$entry_Molecule); #my $entry_Division = pop(@Molecule); # only division #$entry_Molecule = join(" ",@Molecule); # only molecule my $entry_Description = $seqobj->desc; my $speciesobj = $seqobj->species; my $entry_Organism = $speciesobj->binomial; my $entry_SeqLength = $seqobj->length; # put into the hash my %entryhash; $entryhash{ID}=$entry_ID; $entryhash{AccNumber}=$entry_AccNumber; $entryhash{Molecule}=$entry_Molecule; $entryhash{Division}=$entry_Division; $entryhash{Description}=$entry_Description; $entryhash{Organism}=$entry_Organism; $entryhash{Sequence}=$entry_Sequence; $entryhash{SeqLength}=$entry_SeqLength; my @topfeatures=$seqobj->top_SeqFeatures(); # create features array my $featuresnumber= scalar(@topfeatures); $entryhash{FeaturesNumber}=$featuresnumber; my $feature_name; my @feature_qual_names; my @feature_qual_value; my ($feature_qual_name,$feature_qual_number); my @features; my ($feat,$qual,$subfeat); my @subfeat; my $i=0; foreach $feat (@topfeatures) { my %feature; $feature_name = $feat->primary_tag; unless ($valid_features{$feature_name}) { #print "skipping $feature_name\n"; next; } # works ok with 0.6.2 # if ($feature_name eq "CDS_span") { # case of CDS with various exons 0.6.2 # $feature_name="CDS"; # 0.6.2 my $featlocation=$feat->location; # 0.7 if (($feature_name eq "CDS")&&($featlocation->isa('Bio::Location::SplitLocationI'))) { # case of CDS with various exons BioPerl 0.7 # @subfeat=$feat->sub_SeqFeature; # 0.6.2 @subfeat=$featlocation->sub_Location(); # 0.7 my @transcript; foreach $subfeat (@subfeat) { my @range; if ($subfeat->strand == -1) { @range=($subfeat->end,$subfeat->start,$subfeat->strand); } else { @range=($subfeat->start,$subfeat->end,$subfeat->strand); } push (@transcript,\@range); } $feature{range}=\@transcript; } else { my @range; ($feat->strand == -1) ? (@range = ($feat->end, $feat->start, $feat->strand) ) : (@range = ( $feat->start,$feat->end,$feat->strand) ); # works ok with 0.6.2 if ($feature_name eq "CDS") { # case of single exon CDS (CDS name but not split location) my @transcript=(\@range); $feature{range}=\@transcript; } else { # all other range features $feature{range}=\@range; } } $feature{location}="deprecated"; $feature{position}=$i; $feature{name}=$feature_name; @feature_qual_names= $feat->all_tags(); $feature_qual_number= scalar(@feature_qual_names); $feature{qual_number}=$feature_qual_number; my %feature_qualifiers; for $qual (@feature_qual_names) { $feature_qual_name=$qual; unless ($valid_names{$feature_qual_name}) { next; } @feature_qual_value=$feat->each_tag_value($qual); #print "$qual => @feature_qual_value \n"; $feature_qualifiers{$feature_qual_name}=$feature_qual_value[0]; # ? # maybe the whole array should be entered, not just the 1st element? # what could be the other elements? TOCHECK! } $feature{qualifiers}=\%feature_qualifiers; push (@features,\%feature); # array of features $i++; } $entryhash{Features}=\@features; # put this also into the hash my @cds; # array just of CDSs for $i (0..$#features) { if ($features[$i]->{'name'} eq "CDS") { push(@cds,$features[$i]); } } $entryhash{CDS}=\@cds; # put this also into the hash return (\%entryhash); } =head2 novelaasequence2gene Title : novelaasequence2gene Usage : $gene=Bio::LiveSeq::IO::BioPerl->novelaasequence2gene(-aasequence => "MGLAAPTRS*"); : $gene=Bio::LiveSeq::IO::BioPerl->novelaasequence2gene(-aasequence => "MGLAAPTRS*", -cusg_data => "58 44 7 29 3 3 480 267 105 143 122 39 144 162 14 59 53 25 233 292 19 113 88 246 28 68 161 231 27 102 128 151 67 60 138 131 48 61 153 19 233 73 150 31 129 38 147 71 138 43 181 81 44 15 255 118 312 392 236 82 20 10 14 141"); : $gene=Bio::LiveSeq::IO::BioPerl->novelaasequence2gene(-aasequence => "MGLAAPTRS*", -cusg_data => "58 44 7 29 3 3 480 267 105 143 122 39 144 162 14 59 53 25 233 292 19 113 88 246 28 68 161 231 27 102 128 151 67 60 138 131 48 61 153 19 233 73 150 31 129 38 147 71 138 43 181 81 44 15 255 118 312 392 236 82 20 10 14 141", -translation_table => "2", -gene_name => "tyr-kinase"); Function: creates LiveSeq objects from a novel amino acid sequence, using codon usage information (loaded from a file) to choose codons according to relative frequencies. If a codon_usage information is not specified, the default is to use Homo sapiens data (taxonomy ID 9606). If a translation_table ID is not specified, it will default to 1 (standard code). Returns : reference to a Gene object containing references to LiveSeq objects Errorcode 0 Args : string containing an amino acid sequence string (optional) with codon usage data (64 integer numbers) string (optional) specifying a gene_name integer (optional) specifying a translation_table ID =cut sub novelaasequence2gene { my ($self, %args) = @_; my ($gene_name,$cusg_data,$aasequence,$ttabid)=($args{-gene_name},$args{-cusg_data},$args{-aasequence},$args{-translation_table}); my @species_codon_usage; unless ($aasequence) { carp "aasequence not given"; return (0); } unless ($gene_name) { $gene_name="Novel Unknown"; } unless ($ttabid) { $ttabid=1; } unless ($cusg_data) { @species_codon_usage= qw(68664 118404 126679 51100 125600 123646 75667 210903 435317 139009 79303 135218 128429 192616 49456 161556 211962 131222 162837 213626 69346 140780 182506 219428 76684 189374 173010 310626 82647 202329 180955 250410 180001 118798 76398 160764 317359 119013 262630 359627 218376 186915 130857 377006 162826 113684 317703 441298 287040 245435 174805 133427 134523 108740 225633 185619 78463 240138 174021 244236 142435 8187 5913 14381); # updated 21Jul2000 } else { @species_codon_usage=split(/ /,$cusg_data); } my $gene=Bio::LiveSeq::IO::Loader::_common_novelaasequence2gene(\@species_codon_usage,$ttabid,$aasequence,$gene_name); return ($gene); } 1; BioPerl-1.6.923/Bio/LiveSeq/IO/Loader.pm000444000765000024 10345312254227313 17637 0ustar00cjfieldsstaff000000000000# # bioperl module for Bio::LiveSeq::IO::Loader # # Please direct questions and support issues to # # Cared for by Joseph Insana # # Copyright Joseph Insana # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::LiveSeq::IO::Loader - Parent Loader for LiveSeq =head1 SYNOPSIS #documentation needed =head1 DESCRIPTION This package holds common methods used by BioPerl and file loaders. It contains methods to create LiveSeq objects out of entire entries or from a localized sequence region surrounding a particular gene. =head1 AUTHOR - Joseph A.L. Insana Email: Insana@ebi.ac.uk, jinsana@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::LiveSeq::IO::Loader; use strict; use Carp qw(cluck croak carp); use Bio::LiveSeq::DNA; use Bio::LiveSeq::Exon; use Bio::LiveSeq::Transcript ; use Bio::LiveSeq::Translation; use Bio::LiveSeq::Gene; use Bio::LiveSeq::Intron; use Bio::LiveSeq::Prim_Transcript; use Bio::LiveSeq::Repeat_Region; use Bio::LiveSeq::Repeat_Unit; use Bio::LiveSeq::AARange; use Bio::Tools::CodonTable; =head2 entry2liveseq Title : entry2liveseq Usage : @translationobjects=$loader->entry2liveseq(); : @translationobjects=$loader->entry2liveseq(-getswissprotinfo => 0); Function: creates LiveSeq objects from an entry previously loaded Returns : array of references to objects of class Translation Errorcode 0 Args : optional boolean flag to avoid the retrieval of SwissProt information for all Transcripts containing SwissProt x-reference default is 1 (to retrieve those information and create AARange LiveSeq objects) Note : this method can get really slow for big entries. The lightweight gene2liveseq method is recommended =cut sub entry2liveseq { my ($self, %args) = @_; my ($getswissprotinfo)=($args{-getswissprotinfo}); if (defined($getswissprotinfo)) { if (($getswissprotinfo ne 0)&&($getswissprotinfo ne 1)) { carp "-getswissprotinfo argument can take only boolean (1 or 0) values. Setting it to 0, i.e. not trying to retrieve SwissProt information...."; $getswissprotinfo=0; } } else { $getswissprotinfo=1; } my $hashref=$self->{'hash'}; unless ($hashref) { return (0); } my @translationobjects=$self->hash2liveseq($hashref,$getswissprotinfo); my $test_transl=0; if ($test_transl) { $self->test_transl($hashref,\@translationobjects);} return @translationobjects; } =head2 novelaasequence2gene Title : novelaasequence2gene Usage : $gene=$loader->novelaasequence2gene(-aasequence => "MGLAAPTRS*"); : $gene=$loader->novelaasequence2gene(-aasequence => "MGLAAPTRS*"); -taxon => 9606, -gene_name => "tyr-kinase"); Function: creates LiveSeq objects from a novel amino acid sequence, using codon usage database to choose codons according to relative frequencies. If a taxon ID is not specified, the default is to use the human one (taxonomy ID 9606). Returns : reference to a Gene object containing references to LiveSeq objects Errorcode 0 Args : string containing an amino acid sequence integer (optional) with a taxonomy ID string specifying a gene name =cut =head2 gene2liveseq Title : gene2liveseq Usage : $gene=$loader->gene2liveseq(-gene_name => "gene name"); : $gene=$loader->gene2liveseq(-gene_name => "gene name", -flanking => 64); : $gene=$loader->gene2liveseq(-gene_name => "gene name", -getswissprotinfo => 0); : $gene=$loader->gene2liveseq(-position => 4); Function: creates LiveSeq objects from an entry previously loaded It is a "light weight" creation because it creates a LiveSequence just for the interesting region in an entry (instead than for the total entry, like in entry2liveseq) and for the flanking regions up to 500 nucleotides (default) or up to the specified amount of nucleotides (given as argument) around the Gene. Returns : reference to a Gene object containing possibly alternative Transcripts. Errorcode 0 Args : string containing the gene name as in the EMBL feature qualifier integer (optional) "flanking": amount of flanking bases to be kept boolean (optional) "getswissprotinfo": if set to "0" it will avoid trying to fetch information from a crossreference to a SwissProt entry, avoding the process of creation of AARange objects It is "1" (on) by default Alternative to a gene_name, a position can be given: an integer (1-) containing the position of the desired CDS in the loaded entry =cut sub gene2liveseq { my ($self, %args) = @_; my ($gene_name,$flanking,$getswissprotinfo,$cds_position)=($args{-gene_name},$args{-flanking},$args{-getswissprotinfo},$args{-position}); my $input; unless (($gene_name)||($cds_position)) { carp "Gene_Name or Position not specified for gene2liveseq loading function"; return (0); } if (($gene_name)&&($cds_position)) { carp "Gene_Name and Position cannot be given together"; return (0); } elsif ($gene_name) { $input=$gene_name; } else { $input="cds-position:".$cds_position; } if (defined($getswissprotinfo)) { if (($getswissprotinfo ne 0)&&($getswissprotinfo ne 1)) { carp "-getswissprotinfo argument can take only boolean (1 or 0) values. Setting it to 0, i.e. not trying to retrieve SwissProt information...."; $getswissprotinfo=0; } } else { $getswissprotinfo=1; } if (defined($flanking)) { unless ($flanking >= 0) { carp "No sense in specifying a number < 0 for flanking regions to be created for gene2liveseq loading function"; return (0); } } else { $flanking=500; # the default flanking length } my $hashref=$self->{'hash'}; unless ($hashref) { return (0); } my $gene=$self->hash2gene($hashref,$input,$flanking,$getswissprotinfo); unless ($gene) { # if $gene == 0 it means problems in hash2gene carp "gene2liveseq produced error"; return (0); } return $gene; } # TODO: update so that it will work even if CDS is not only accepted FEATURE!! # this method is for now deprecated and not supported sub test_transl { my ($self,$entry)=@_; my @features=@{$entry->{'Features'}}; my @translationobjects=@{$_[1]}; my ($i,$translation); my ($obj_transl,$hash_transl); my @cds=@{$entry->{'CDS'}}; foreach $translation (@translationobjects) { $obj_transl=$translation->seq; $hash_transl=$cds[$i]->{'qualifiers'}->{'translation'}; #before seq was changed in Translation 1.4# chop $obj_transl; # to remove trailing "*" unless ($obj_transl eq $hash_transl) { cluck "Serious error: Translation from the Entry does not match Translation from object's seq for CDS at position $i"; carp "\nEntry's transl: ",$hash_transl,"\n"; carp "\nObject's transl: ",$obj_transl,"\n"; exit; } $i++; } } # argument: hashref containing the EMBL entry datas, # getswissprotinfo boolean flag # creates the liveseq objects # returns: an array of Translation object references sub hash2liveseq { my ($self,$entry,$getswissprotinfo)=@_; my $i; my @transcripts; my $dna=Bio::LiveSeq::DNA->new(-seq => $entry->{'Sequence'} ); $dna->alphabet(lc($entry->{'Molecule'})); $dna->display_id($entry->{'ID'}); $dna->accession_number($entry->{'AccNumber'}); $dna->desc($entry->{'Description'}); my @cds=@{$entry->{'CDS'}}; my ($swissacc,$swisshash); my @swisshashes; for $i (0..$#cds) { #my @transcript=@{$cds[$i]->{'range'}}; #$transcript=\@transcript; #push (@transcripts,$transcript); push (@transcripts,$cds[$i]->{'range'}); if ($getswissprotinfo) { $swissacc=$cds[$i]->{'qualifiers'}->{'db_xref'}; $swisshash=$self->get_swisshash($swissacc); #$self->printswissprot($swisshash); # DEBUG push (@swisshashes,$swisshash); } } my @translations=($self->transexonscreation($dna,\@transcripts)); my $translation; my $j=0; foreach $translation (@translations) { if ($swisshashes[$j]) { # if not 0 $self->swisshash2liveseq($swisshashes[$j],$translation); } $j++; } return (@translations); } # only features pertaining to a specified gene are created # only the sequence of the gene and appropriate context flanking regions # are created as chain # arguments: hashref, gene_name (OR: cds_position), length_of_flanking_sequences, getswissprotinfo boolean flag # returns: reference to Gene object # # Note: if entry contains just one CDS, all the features get added # this is useful because often the features in these entries do not # carry the /gene qualifier # # errorcode: 0 sub hash2gene { my ($self,$entry,$input,$flanking,$getswissprotinfo)=@_; my $entryfeature; my $genefeatureshash; my @cds=@{$entry->{'CDS'}}; # checking if a position has been given instead than a gene_name if (index($input,"cds-position:") == 0 ) { my $cds_position=substr($input,13); # extracting the cds position if (($cds_position >= 1)&&($cds_position <= scalar(@cds))) { $genefeatureshash=$self->_findgenefeatures($entry,undef,$cds_position,$getswissprotinfo); } } else { $genefeatureshash=$self->_findgenefeatures($entry,$input,undef,$getswissprotinfo); } unless (($genefeatureshash)&&(scalar(@{$genefeatureshash->{'genefeatures'}}))) { # array empty, no gene features found my @genes=$self->genes($entry); my $cds_number=scalar(@cds); warn "Warning! Not even one genefeature found for /$input/.... The genes present in this entry are:\n\t@genes\n The number of CDS in this entry is:\n\t$cds_number\n"; return(0); } # get max and min, check flankings my ($min,$max)=$self->rangeofarray(@{$genefeatureshash->{'labels'}}); # gene "boundaries" my $seqlength=$entry->{'SeqLength'}; my ($mindna,$maxdna); # some flanking region next to the gene "boundaries" if ($min-$flanking < 1) { $mindna=1; } else { $mindna=$min-$flanking; } if ($max+$flanking > $seqlength) { $maxdna=$seqlength; } else { $maxdna=$max+$flanking; } my $subseq=substr($entry->{'Sequence'},$mindna-1,$maxdna-$mindna+1); # create LiveSeq objects # create DNA my $dna=Bio::LiveSeq::DNA->new(-seq => $subseq, -offset => $mindna); $dna->alphabet(lc($entry->{'Molecule'})); $dna->source($entry->{'Organism'}); $dna->display_id($entry->{'ID'}); $dna->accession_number($entry->{'AccNumber'}); $dna->desc($entry->{'Description'}); my @transcripts=@{$genefeatureshash->{'transcripts'}}; # create Translations, Transcripts, Exons out of the CDS unless (@transcripts) { cluck "no CDS feature found for /$input/...."; return(0); } my @translationobjs=$self->transexonscreation($dna,\@transcripts); my @transcriptobjs; # get the Transcript obj_refs my $translation; my $j=0; my @ttables=@{$genefeatureshash->{'ttables'}}; my @swisshashes=@{$genefeatureshash->{'swisshashes'}}; foreach $translation (@translationobjs) { push(@transcriptobjs,$translation->get_Transcript); if ($ttables[$j]) { # if not undef $translation->get_Transcript->translation_table($ttables[$j]); #} else { # DEBUG # print "\n\t\tno translation table information....\n"; } if ($swisshashes[$j]) { # if not 0 $self->swisshash2liveseq($swisshashes[$j],$translation); } $j++; } my %gene; # this is the hash to store created object references $gene{DNA}=$dna; $gene{Transcripts}=\@transcriptobjs; $gene{Translations}=\@translationobjs; my @exonobjs; my @intronobjs; my @repeatunitobjs; my @repeatregionobjs; my @primtranscriptobjs; my ($object,$range,$start,$end,$strand); my @exons=@{$genefeatureshash->{'exons'}}; my @exondescs=@{$genefeatureshash->{'exondescs'}}; if (@exons) { my $exoncount = 0; foreach $range (@exons) { ($start,$end,$strand)=@{$range}; $object = Bio::LiveSeq::Exon->new(-seq=>$dna,-start=>$start,-end=>$end,-strand=>$strand); if ($object != -1) { $object->desc($exondescs[$exoncount]) if defined $exondescs[$exoncount]; $exoncount++; push (@exonobjs,$object); } else { $exoncount++; } } $gene{Exons}=\@exonobjs; } my @introns=@{$genefeatureshash->{'introns'}}; my @introndescs=@{$genefeatureshash->{'introndescs'}}; if (@introns) { my $introncount = 0; foreach $range (@introns) { ($start,$end,$strand)=@{$range}; $object=Bio::LiveSeq::Intron->new(-seq=>$dna,-start=>$start,-end=>$end,-strand=>$strand); if ($object != -1) { $object->desc($introndescs[$introncount]); $introncount++; push (@intronobjs,$object); } else { $introncount++; } } $gene{Introns}=\@intronobjs; } my @prim_transcripts=@{$genefeatureshash->{'prim_transcripts'}}; if (@prim_transcripts) { foreach $range (@prim_transcripts) { ($start,$end,$strand)=@{$range}; $object=Bio::LiveSeq::Prim_Transcript->new(-seq=>$dna,-start=>$start,-end=>$end,-strand=>$strand); if ($object != -1) { push (@primtranscriptobjs,$object); } } $gene{Prim_Transcripts}=\@primtranscriptobjs; } my @repeat_regions=@{$genefeatureshash->{'repeat_regions'}}; my @repeat_regions_family=@{$genefeatureshash->{'repeat_regions_family'}}; if (@repeat_regions) { my $k=0; foreach $range (@repeat_regions) { ($start,$end,$strand)=@{$range}; $object=Bio::LiveSeq::Repeat_Region->new(-seq=>$dna,-start=>$start,-end=>$end,-strand=>$strand); if ($object != -1) { $object->desc($repeat_regions_family[$k]); $k++; push (@repeatregionobjs,$object); } else { $k++; } } $gene{Repeat_Regions}=\@repeatregionobjs; } my @repeat_units=@{$genefeatureshash->{'repeat_units'}}; my @repeat_units_family=@{$genefeatureshash->{'repeat_units_family'}}; if (@repeat_units) { my $k=0; foreach $range (@repeat_units) { ($start,$end,$strand)=@{$range}; $object=Bio::LiveSeq::Repeat_Unit->new(-seq=>$dna,-start=>$start,-end=>$end,-strand=>$strand); if ($object != -1) { $object->desc($repeat_units_family[$k]); $k++; push (@repeatunitobjs,$object); } else { $k++; } } $gene{Repeat_Units}=\@repeatunitobjs; } # create the Gene my $gene_name=$genefeatureshash->{'gene_name'}; # either a name or a cdspos return (Bio::LiveSeq::Gene->new(-name=>$gene_name,-features=>\%gene, -upbound=>$min,-downbound=>$max)); } # maybe this function will be moved to general utility package # argument: array of numbers # returns: (min,max) numbers in the array sub rangeofarray { my $self=shift; my @array=@_; #print "\n-=-=-=-=-=-=-=-=-=-=array: @array\n"; my ($max,$min,$element); $min=$max=shift(@array); foreach $element (@array) { $element = 0 unless defined $element; if ($element < $min) { $min=$element; } if ($element > $max) { $max=$element; } } #print "\n-=-=-=-=-=-=-=-=-=-=min: $min\tmax: $max\n"; return ($min,$max); } # argument: reference to DNA object, reference to array of transcripts # returns: an array of Translation object references sub transexonscreation { my $self=shift; my $dna=$_[0]; my @transcripts=@{$_[1]}; my (@transexons,$start,$end,$strand,$exonref,$exonobj,$transcript,$transcriptobj); my $translationobj; my @translationobjects; foreach $transcript (@transcripts) { foreach $exonref (@{$transcript}) { ($start,$end,$strand)=@{$exonref}; #print "Creating Exon: start $start end $end strand $strand\n"; $exonobj=Bio::LiveSeq::Exon->new(-seq=>$dna,-start=>$start,-end=>$end,-strand=>$strand); #push (@exonobjects,$exonobj); push (@transexons,$exonobj); } $transcriptobj=Bio::LiveSeq::Transcript->new(-exons => \@transexons ); if ($transcriptobj != -1) { $translationobj=Bio::LiveSeq::Translation->new(-transcript=>$transcriptobj); @transexons=(); # cleans it #push (@transcriptobjects,$transcriptobj); push (@translationobjects,$translationobj); } } return (@translationobjects); } #sub printgene { # deleted. Some functionality placed in Gene->printfeaturesnum =head2 printswissprot Title : printswissprot Usage : $loader->printswissprot($hashref); Function: prints out all information loaded from a database entry into the loader. Mainly used for testing purposes. Args : a hashref containing the SWISSPROT entry datas Note : the hashref can be obtained with a call to the method $loader->get_swisshash() (BioPerl via Bio::DB::EMBL.pm) that takes as argument a string like "SWISS-PROT:P10275" =cut # argument: hashref containing the SWISSPROT entry datas # prints out that hash, showing the information loaded sub printswissprot { my ($self,$entry)=@_; unless ($entry) { return; } printf "ID: %s\n", $entry->{'ID'}; printf "ACC: %s\n", $entry->{'AccNumber'}; printf "GENE: %s\n", $entry->{'Gene'}; printf "DES: %s\n", $entry->{'Description'}; printf "ORG: %s\n", $entry->{'Organism'}; printf "SEQLN: %s\n", $entry->{'SeqLength'}; printf "SEQ: %s\n", substr($entry->{'Sequence'},0,64); if ($entry->{'Features'}) { my @features=@{$entry->{'Features'}}; my $i; for $i (0..$#features) { print "|",$features[$i]->{'name'},"|"; print " at ",$features[$i]->{'location'},": "; print "",$features[$i]->{'desc'},"\n"; } } } =head2 printembl Title : printembl Usage : $loader->printembl(); Function: prints out all information loaded from a database entry into the loader. Mainly used for testing purposes. Args : none =cut # argument: hashref containing the EMBL entry datas # prints out that hash, showing the information loaded sub printembl { my ($self,$entry)=@_; unless ($entry) { $entry=$self->{'hash'}; } my ($i,$featurename); printf "ID: %s\n", $entry->{'ID'}; printf "ACC: %s\n", $entry->{'AccNumber'}; printf "MOL: %s\n", $entry->{'Molecule'}; printf "DIV: %s\n", $entry->{'Division'}; printf "DES: %s\n", $entry->{'Description'}; printf "ORG: %s\n", $entry->{'Organism'}; printf "SEQLN: %s\n", $entry->{'SeqLength'}; printf "SEQ: %s\n", substr($entry->{'Sequence'},0,64); my @features=@{$entry->{'Features'}}; my @cds=@{$entry->{'CDS'}}; print "\nFEATURES\nNumber of CDS: ",scalar(@cds)," (out of ",$entry->{'FeaturesNumber'}, " total features)\n"; my ($exonref,$transcript); my ($qualifiernumber,$qualifiers,$key); my ($start,$end,$strand); my $j=0; for $i (0..$#features) { $featurename=$features[$i]->{'name'}; if ($featurename eq "CDS") { print "|CDS| number $j at feature position: $i\n"; #print $features[$i]->{'location'},"\n"; $transcript=$features[$i]->{'range'}; foreach $exonref (@{$transcript}) { ($start,$end,$strand)=@{$exonref}; print "\tExon: start $start end $end strand $strand\n"; } $j++; } else { print "|$featurename| at feature position: $i\n"; print "\trange: "; print join("\t",@{$features[$i]->{'range'}}),"\n"; #print $features[$i]->{'location'},"\n"; } $qualifiernumber=$features[$i]->{'qual_number'}; $qualifiers=$features[$i]->{'qualifiers'}; # hash foreach $key (keys (%{$qualifiers})) { print "\t\t",$key,": "; print $qualifiers->{$key},"\n"; } } } =head2 genes Title : genes Usage : $loader->genes(); Function: Returns an array of gene_names (strings) contained in the loaded entry. Args : none =cut # argument: entryhashref # returns: array of genenames found in the entry sub genes { my ($self,$entry)=@_; unless ($entry) { $entry=$self->{'hash'}; } my @entryfeatures=@{$entry->{'Features'}}; my ($genename,$genenames,$entryfeature); for $entryfeature (@entryfeatures) { $genename=$entryfeature->{'qualifiers'}->{'gene'}; if ($genename) { if (index($genenames,$genename) == -1) { # if name is new $genenames .= $genename . " "; # add the name } } } return (split(/ /,$genenames)); # assumes no space inbetween each genename } # arguments: swisshash, translation objref # adds information to the Translation, creates AARange objects, sets the # aa_range attribute on the Translation, pointing to those objects sub swisshash2liveseq { my ($self,$entry,$translation)=@_; my $translength=$translation->length; $translation->desc($translation->desc . $entry->{'Description'}); $translation->display_id("SWISSPROT:" . $entry->{'ID'}); $translation->accession_number("SWISSPROT:" . $entry->{'AccNumber'}); $translation->name($entry->{'Gene'}); $translation->source($entry->{'Organism'}); my @aarangeobjects; my ($start,$end,$aarangeobj,$feature); my @features; my @newfeatures; if ($entry->{'Features'}) { @features=@{$entry->{'Features'}}; } my $cleavedmet=0; # check for cleaved Met foreach $feature (@features) { if (($feature->{'name'} eq "INIT_MET")&&($feature->{'location'} eq "0 0")) { $cleavedmet=1; $translation->{'offset'}="1"; # from swissprot to liveseq protein sequence } else { push(@newfeatures,$feature); } } my $swissseq=$entry->{'Sequence'}; my $liveseqtransl=$translation->seq; chop $liveseqtransl; # to take away the trailing STOP "*" my $translated=substr($liveseqtransl,$cleavedmet); my ($liveseq_aa,$swiss_aa,$codes_aa)=$self->_get_alignment($translated,$swissseq); # alignment after cleavage of possible initial met if ((index($liveseq_aa,"-") != -1)||(index($swiss_aa,"-") != -1)) { # there are gaps, how to proceed? print "LIVE-SEQ=\'$liveseq_aa\'\nIDENTITY=\'$codes_aa\'\nSWS-PROT=\'$swiss_aa\'\n"; carp "Nucleotides translation and SwissProt translation are different in size, cannot attach the SwissSequence to the EMBL one, cannot add any AminoAcidRange object/Domain information!"; return; } #my $i=0; # debug @features=@newfeatures; foreach $feature (@features) { #print "Processing SwissProtFeature: $i\n"; # debug ($start,$end)=split(/ /,$feature->{'location'}); # Note: cleavedmet is taken in account for updating numbering $aarangeobj=Bio::LiveSeq::AARange->new(-start => $start+$cleavedmet, -end => $end+$cleavedmet, -name => $feature->{'name'}, -description => $feature->{'description'}, -translation => $translation, -translength => $translength); if ($aarangeobj != -1) { push(@aarangeobjects,$aarangeobj); } # $i++; # debug } $translation->{'aa_ranges'}=\@aarangeobjects; } # if there is no SRS support, the default will be to return 0 # i.e. this function is overridden in SRS package sub get_swisshash { return (0); } # Args: $entry hashref, gene_name OR cds_position (undef is used to # choose between the two), getswissprotinfo boolean flag # Returns: an hash holding various arrayref used in the hash2gene method # Function: examines the nucleotide entry, identifying features belonging # to the gene (defined either by its name or by the position of its CDS in # the entry) sub _findgenefeatures { my ($self,$entry,$gene_name,$cds_position,$getswissprotinfo)=@_; my @entryfeatures=@{$entry->{'Features'}}; my @exons; my @introns; my @prim_transcripts; my @transcripts; my @repeat_units; my @repeat_regions; my @repeat_units_family; my @repeat_regions_family; my $rpt_family; my $entryfeature; my @genefeatures; my $desc; my @exondescs; my @introndescs; # for swissprot xreference my ($swissacc,$swisshash); my @swisshashes; # for translation_tables my @ttables; # to create labels my ($name,$exon); my @range; my @cdsexons; my @labels; # maybe here also could be added special case when there is no CDS feature # in the entry (e.g. tRNA entry -> TOCHECK). # let's deal with the special case in which there is just one gene per entry # usually without /gene qualifier my @cds=@{$entry->{'CDS'}}; my $skipgenematch=0; if (scalar(@cds) == 1) { #carp "Note: only one CDS in this entry. Treating all features found in entry as Gene features."; $skipgenematch=1; } my ($cds_begin,$cds_end,$proximity); if ($cds_position) { # if a position has been requested my @cds_exons=@{$cds[$cds_position-1]->{'range'}}; ($cds_begin,$cds_end)=($cds_exons[0]->[0],$cds_exons[-1]->[1]); # begin and end of CDS $gene_name=$cds[$cds_position-1]->{'qualifiers'}->{'gene'}; # DEBUG unless ($skipgenematch) { carp "--DEBUG-- cdsbegin $cds_begin cdsend $cds_end--------"; } $proximity=100; # proximity CONSTANT to decide whether a feature "belongs" to the CDS } for $entryfeature (@entryfeatures) { # get only features for the desired gene if (($skipgenematch)||(($cds_position)&&($self->_checkfeatureproximity($entryfeature->{'range'},$cds_begin,$cds_end,$proximity)))||(!($cds_position)&&($entryfeature->{'qualifiers'}->{'gene'} eq "$gene_name"))) { push(@genefeatures,$entryfeature); my @range=@{$entryfeature->{'range'}}; $name=$entryfeature->{'name'}; my %qualifierhash=%{$entryfeature->{'qualifiers'}}; if ($name eq "CDS") { # that has range containing array of exons # swissprot crossindexing (if without SRS support it will fill array # with zeros and do nothing if ($getswissprotinfo) { $swissacc=$entryfeature->{'qualifiers'}->{'db_xref'}; $swisshash=$self->get_swisshash($swissacc); #$self->printswissprot($swisshash); # DEBUG push (@swisshashes,$swisshash); } push (@ttables,$entryfeature->{'qualifiers'}->{'transl_table'}); # undef if not specified # create labels array for $exon (@range) { push(@labels,$exon->[0],$exon->[1]); # start and end of every exon of the CDS } push (@transcripts,$entryfeature->{'range'}); } else { # "simplifying" the joinedlocation features. I.e. changing them from # multijoined ones to simple plain start-end features, taking only # the start of the first "exon" and the end of the last "exon" as # start and end of the entire feature if ($entryfeature->{'locationtype'} && $entryfeature->{'locationtype'} eq "joined") { # joined location @range=($range[0]->[0],$range[-1]->[1]); } push(@labels,$range[0],$range[1]); # start and end of every feature if ($name eq "exon") { $desc=$entryfeature->{'qualifiers'}->{'number'}; if ($entryfeature->{'qualifiers'}->{'note'}) { if ($desc) { $desc .= "|" . $entryfeature->{'qualifiers'}->{'note'}; } else { $desc = $entryfeature->{'qualifiers'}->{'note'}; } } push (@exondescs,$desc || "unknown"); push(@exons,\@range); } if ($name eq "intron") { $desc=$entryfeature->{'qualifiers'}->{'number'}; if ($desc) { $desc .= "|" . $entryfeature->{'qualifiers'}->{'note'}; } else { $desc = $entryfeature->{'qualifiers'}->{'note'}; } push (@introndescs,$desc || "unknown"); push(@introns,\@range); } if (($name eq "prim_transcript")||($name eq "mRNA")) { push(@prim_transcripts,\@range); } if ($name eq "repeat_unit") { push(@repeat_units,\@range); $rpt_family=$entryfeature->{'qualifiers'}->{'rpt_family'}; push (@repeat_units_family,$rpt_family || "unknown"); } if ($name eq "repeat_region") { push(@repeat_regions,\@range); $rpt_family=$entryfeature->{'qualifiers'}->{'rpt_family'}; push (@repeat_regions_family,$rpt_family || "unknown"); } } } } unless ($gene_name) { $gene_name="cds-position:".$cds_position; } my %genefeatureshash; $genefeatureshash{gene_name}=$gene_name; $genefeatureshash{genefeatures}=\@genefeatures; $genefeatureshash{labels}=\@labels; $genefeatureshash{ttables}=\@ttables; $genefeatureshash{swisshashes}=\@swisshashes; $genefeatureshash{transcripts}=\@transcripts; $genefeatureshash{exons}=\@exons; $genefeatureshash{exondescs}=\@exondescs; $genefeatureshash{introns}=\@introns; $genefeatureshash{introndescs}=\@introndescs; $genefeatureshash{prim_transcripts}=\@prim_transcripts; $genefeatureshash{repeat_units}=\@repeat_units; $genefeatureshash{repeat_regions}=\@repeat_regions; $genefeatureshash{repeat_units_family}=\@repeat_units_family; $genefeatureshash{repeat_regions_family}=\@repeat_regions_family; return (\%genefeatureshash); } # used by _findgenefeatures, when a CDS at a certain position is requested, # to retrieve only features quite close to the wanted CDS. # Args: range hashref, begin and end positions of the CDS, $proximity # $proximity holds the maximum distance between the extremes of the CDS # and of the feature under exam. # Returns: boolean sub _checkfeatureproximity { my ($self,$range,$cds_begin,$cds_end,$proximity)=@_; my @range=@{$range}; my ($begin,$end,$strand); if (ref($range[0]) eq "ARRAY") { # like in CDS, whose range equivals to exons ($begin,$end,$strand)=($range[0]->[0],$range[-1]->[1],$range[0]->[2]); } else { ($begin,$end,$strand)=@range; } if ($cds_begin > $cds_end) { # i.e. reverse strand CDS ($cds_begin,$cds_end)=($cds_end,$cds_begin); # swap boundaries } if ($strand == -1) { # reverse strand ($begin,$end)=($end,$begin); # swap boundaries } if (($cds_begin-$end)>$proximity) { carp "--DEBUG-- feature rejected: begin $begin end $end -------"; return (0); } if (($begin-$cds_end)>$proximity) { carp "--DEBUG-- feature rejected: begin $begin end $end -------"; return (0); } carp "--DEBUG-- feature accepted: begin $begin end $end -------"; return (1); # otherwise ok, feature considered next to CDS } # function that calls the external program "align" (on the fasta2 package) # to create an alignment between two sequences, returning the aligned # strings and the codes for the identity (:: ::::) sub _get_alignment { my ($self,$seq1,$seq2)=@_; my $fastafile1="/tmp/tmpfastafile1"; my $fastafile2="/tmp/tmpfastafile2"; my $grepcut='egrep -v "[[:digit:]]|^ *$|sequences" | cut -c8-'; # grep/cut my $alignprogram="/usr/local/etc/bioinfo/fasta2/align -s /usr/local/etc/bioinfo/fasta2/idnaa.mat $fastafile1 $fastafile2 2>/dev/null | $grepcut"; # ALIGN open my $TMPFASTAFILE1,">$fastafile1" || croak "Cannot write into $fastafile1 for aa alignment"; open my $TMPFASTAFILE2,">$fastafile2" || croak "Cannot write into $fastafile1 for aa alignment"; print $TMPFASTAFILE1 ">firstseq\n$seq1\n"; print $TMPFASTAFILE2 ">secondseq\n$seq2\n"; close $TMPFASTAFILE1; close $TMPFASTAFILE2; my $alignment=`$alignprogram`; my @alignlines=split(/\n/,$alignment); my ($linecount,$seq1_aligned,$seq2_aligned,$codes); for ($linecount=0; $linecount < @alignlines; $linecount+=3) { $seq1_aligned .= $alignlines[$linecount]; $codes .= $alignlines[$linecount+1]; $seq2_aligned .= $alignlines[$linecount+2]; } return ($seq1_aligned,$seq2_aligned,$codes); } # common part of the function to create a novel liveseq gene structure # from an amino acid sequence, using codon usage frequencies # args: codon_usage_array transltableid aasequence gene_name sub _common_novelaasequence2gene { my ($species_codon_usage,$ttabid,$aasequence,$gene_name)=@_; my @species_codon_usage=@{$species_codon_usage}; my @codon_usage_label= qw (cga cgc cgg cgt aga agg cta ctc ctg ctt tta ttg tca tcc tcg tct agc agt aca acc acg act cca ccc ccg cct gca gcc gcg gct gga ggc ggg ggt gta gtc gtg gtt aaa aag aac aat caa cag cac cat gaa gag gac gat tac tat tgc tgt ttc ttt ata atc att atg tgg taa tag tga); my ($i,$j); my %codon_usage_value; my $aa_codon_total; for ($i=0;$i<64;$i++) { $codon_usage_value{$codon_usage_label[$i]}=$species_codon_usage[$i]; } my $CodonTable = Bio::Tools::CodonTable->new ( -id => $ttabid ); my @aminoacids = split(//,uc($aasequence)); my @alt_codons; my ($relativeusage,$dnasequence,$chosen_codon,$dice,$partial,$thiscodon); for $i (@aminoacids) { @alt_codons = $CodonTable->revtranslate($i); unless (@alt_codons) { carp "No reverse translation possible for aminoacid \'$i\'"; $dnasequence .= "???"; } else { $aa_codon_total=0; for $j (@alt_codons) { $aa_codon_total+=$codon_usage_value{$j}; } # print "aminoacid $i, codonchoice: "; # verbose #$partial=0; #for $j (@alt_codons) { #printf "%s %.2f ",$j,$partial+$codon_usage_value{$j}/$aa_codon_total; #$partial+=($codon_usage_value{$j}/$aa_codon_total); #} #print "\n"; $dice=rand(1); #print "roulette: $dice\n"; # verbose $partial=0; $chosen_codon=""; CODONCHOICE: for $j (0..@alt_codons) { # last one not accounted $thiscodon=$alt_codons[$j]; $relativeusage=($codon_usage_value{$thiscodon}/$aa_codon_total); if ($dice < $relativeusage+$partial) { $chosen_codon=$thiscodon; last CODONCHOICE; } else { $partial += $relativeusage; } } unless ($chosen_codon) { $chosen_codon = $alt_codons[-1]; # the last one } # print ".....adding $chosen_codon\n"; # verbose $dnasequence .= $chosen_codon; } } my $dna = Bio::LiveSeq::DNA->new(-seq => $dnasequence); my $min=1; my $max=length($dnasequence); my $exon = Bio::LiveSeq::Exon->new(-seq => $dna, -start => $min, -end => $max, -strand => 1); my @exons=($exon); my $transcript = Bio::LiveSeq::Transcript->new(-exons => \@exons); $transcript->translation_table($ttabid); my @transcripts=($transcript); my $translation = Bio::LiveSeq::Translation->new(-transcript => $transcript); my @translations=($translation); my %features=(DNA => $dna, Transcripts => \@transcripts, Translations => \@translations); my $gene = Bio::LiveSeq::Gene->new(-name => $gene_name, -features => \%features, -upbound => $min, -downbound => $max); # creation of gene unless ($gene) { # if $gene == 0 it means problems in hash2gene carp "Error in Gene creation phase"; return (0); } return $gene; } 1; BioPerl-1.6.923/Bio/LiveSeq/IO/README000444000765000024 172412254227340 16711 0ustar00cjfieldsstaff000000000000# $Id$ README for Bio::LiveSeq::IO LiveSeq objects representing known gene structures and their sequences have to be created from nucleotide sequence files. The current IO files do it by reading in EMBL entries and parsing out sequences as well as CDS, exon and primary_transcript features from the feature table. Bio::LiveSeq::IO::Loader is a superclass holding methods common to other methods. Bio::LiveSeq::IO::BioPerl is the preferred method which uses Bio::DB::EMBL to retrive sequences over the Web by accession number. Bio::LiveSeq::IO::SRS outdated, removed from distribution 13 Jan 2006 retrieves sequences from a local installation of SRS. It needs srsperl.pm which is part of SRS. SRS is short for Sequence Retrieval System, a comprehensive program suite for indexing and serving biological databases. SRS is a product of Lion BioSciences (http://www.lionbio.co.uk/). The license for academic users is free. BioPerl-1.6.923/Bio/Location000755000765000024 012254227333 15563 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Location/Atomic.pm000444000765000024 3374412254227323 17524 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::Atomic # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::Atomic - Implementation of a Atomic Location on a Sequence =head1 SYNOPSIS use Bio::Location::Atomic; my $location = Bio::Location::Atomic->new(-start => 1, -end => 100, -strand => 1 ); if( $location->strand == -1 ) { printf "complement(%d..%d)\n", $location->start, $location->end; } else { printf "%d..%d\n", $location->start, $location->end; } =head1 DESCRIPTION This is an implementation of Bio::LocationI to manage simple location information on a Sequence. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::Atomic; use strict; use Bio::Location::WidestCoordPolicy; use base qw(Bio::Root::Root Bio::LocationI); our $coord_policy = Bio::Location::WidestCoordPolicy->new(); sub new { my ($class, @args) = @_; $class = ref $class || $class; my $self = {}; # This is for the case when we've done something like this # get a 2 features from somewhere (like Bio::Tools::GFF) # Do # my $location = $f1->location->union($f2->location); # We get an error without the following code which # explictly loads the Bio::Location::Simple class unless( $class->can('start') ) { eval { Bio::Root::Root->_load_module($class) }; if ( $@ ) { Bio::Root::Root->throw("$class cannot be found\nException $@"); } } bless $self,$class; my ($v,$start,$end,$strand,$seqid) = $self->_rearrange([qw(VERBOSE START END STRAND SEQ_ID)],@args); defined $v && $self->verbose($v); defined $strand && $self->strand($strand); defined $start && $self->start($start); defined $end && $self->end($end); if( defined $self->start && defined $self->end && $self->start > $self->end && $self->strand != -1 ) { $self->warn("When building a location, start ($start) is expected to be less than end ($end), ". "however it was not. Switching start and end and setting strand to -1"); $self->strand(-1); my $e = $self->end; my $s = $self->start; $self->start($e); $self->end($s); } $seqid && $self->seq_id($seqid); return $self; } =head2 start Title : start Usage : $start = $loc->start(); Function: get/set the start of this range Returns : the start of this range Args : optionaly allows the start to be set : using $loc->start($start) =cut sub start { my ($self, $value) = @_; $self->min_start($value) if( defined $value ); return $self->SUPER::start(); } =head2 end Title : end Usage : $end = $loc->end(); Function: get/set the end of this range Returns : the end of this range Args : optionaly allows the end to be set : using $loc->end($start) =cut sub end { my ($self, $value) = @_; $self->min_end($value) if( defined $value ); return $self->SUPER::end(); } =head2 strand Title : strand Usage : $strand = $loc->strand(); Function: get/set the strand of this range Returns : the strandidness (-1, 0, +1) Args : optionaly allows the strand to be set : using $loc->strand($strand) =cut sub strand { my $self = shift; if ( @_ ) { my $value = shift; if ( defined($value) ) { if ( $value eq '+' ) { $value = 1; } elsif ( $value eq '-' ) { $value = -1; } elsif ( $value eq '.' ) { $value = 0; } elsif ( $value != -1 && $value != 1 && $value != 0 ) { $self->throw("$value is not a valid strand info"); } $self->{'_strand'} = $value; } } # do not pretend the strand has been set if in fact it wasn't return $self->{'_strand'}; #return $self->{'_strand'} || 0; } =head2 flip_strand Title : flip_strand Usage : $location->flip_strand(); Function: Flip-flop a strand to the opposite Returns : None Args : None =cut sub flip_strand { my $self= shift; # Initialize strand if necessary to flip it if (not defined $self->strand) { $self->strand(1) } $self->strand($self->strand * -1); } =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to Returns : seq_id (a string) Args : [optional] seq_id value to set =cut sub seq_id { my ($self, $seqid) = @_; if( defined $seqid ) { $self->{'_seqid'} = $seqid; } return $self->{'_seqid'}; } =head2 length Title : length Usage : $len = $loc->length(); Function: get the length in the coordinate space this location spans Example : Returns : an integer Args : none =cut sub length { my ($self) = @_; return abs($self->end() - $self->start()) + 1; } =head2 min_start Title : min_start Usage : my $minstart = $location->min_start(); Function: Get minimum starting location of feature startpoint Returns : integer or undef if no minimum starting point. Args : none =cut sub min_start { my ($self,$value) = @_; if(defined($value)) { $self->{'_start'} = $value; } return $self->{'_start'}; } =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get maximum starting location of feature startpoint. In this implementation this is exactly the same as min_start(). Returns : integer or undef if no maximum starting point. Args : none =cut sub max_start { my ($self,@args) = @_; return $self->min_start(@args); } =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get start position type (ie <,>, ^). In this implementation this will always be 'EXACT'. Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut sub start_pos_type { my($self) = @_; return 'EXACT'; } =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get minimum ending location of feature endpoint Returns : integer or undef if no minimum ending point. Args : none =cut sub min_end { my($self,$value) = @_; if(defined($value)) { $self->{'_end'} = $value; } return $self->{'_end'}; } =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get maximum ending location of feature endpoint In this implementation this is exactly the same as min_end(). Returns : integer or undef if no maximum ending point. Args : none =cut sub max_end { my($self,@args) = @_; return $self->min_end(@args); } =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get end position type (ie <,>, ^) In this implementation this will always be 'EXACT'. Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut sub end_pos_type { my($self) = @_; return 'EXACT'; } =head2 location_type Title : location_type Usage : my $location_type = $location->location_type(); Function: Get location type encoded as text Returns : string ('EXACT', 'WITHIN', 'IN-BETWEEN') Args : none =cut sub location_type { my ($self) = @_; return 'EXACT'; } =head2 is_remote Title : is_remote Usage : $is_remote_loc = $loc->is_remote() Function: Whether or not a location is a remote location. A location is said to be remote if it is on a different 'object' than the object which 'has' this location. Typically, features on a sequence will sometimes have a remote location, which means that the location of the feature is on a different sequence than the one that is attached to the feature. In such a case, $loc->seq_id will be different from $feat->seq_id (usually they will be the same). While this may sound weird, it reflects the location of the kind of AL445212.9:83662..166657 which can be found in GenBank/EMBL feature tables. Example : Returns : TRUE if the location is a remote location, and FALSE otherwise Args : Value to set to =cut sub is_remote { my $self = shift; if( @_ ) { my $value = shift; $self->{'is_remote'} = $value; } return $self->{'is_remote'}; } =head2 each_Location Title : each_Location Usage : @locations = $locObject->each_Location($order); Function: Conserved function call across Location:: modules - will return an array containing the component Location(s) in that object, regardless if the calling object is itself a single location or one containing sublocations. Returns : an array of Bio::LocationI implementing objects - for Simple locations, the return value is just itself. Args : =cut sub each_Location { my ($self) = @_; return ($self); } =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: returns the FeatureTable string of this location Returns : string Args : none =cut sub to_FTstring { my($self) = @_; if( $self->start == $self->end ) { return $self->start; } my $str = $self->start . ".." . $self->end; if( $self->strand == -1 ) { $str = sprintf("complement(%s)", $str); } return $str; } =head2 valid_Location Title : valid_Location Usage : if ($location->valid_location) {...}; Function: boolean method to determine whether location is considered valid (has minimum requirements for Simple implementation) Returns : Boolean value: true if location is valid, false otherwise Args : none =cut sub valid_Location { my ($self) = @_; return 1 if $self->{'_start'} && $self->{'_end'}; return 0; } =head2 coordinate_policy Title : coordinate_policy Usage : $policy = $location->coordinate_policy(); $location->coordinate_policy($mypolicy); # set may not be possible Function: Get the coordinate computing policy employed by this object. See L for documentation about the policy object and its use. The interface *does not* require implementing classes to accept setting of a different policy. The implementation provided here does, however, allow to do so. Implementors of this interface are expected to initialize every new instance with a L object. The implementation provided here will return a default policy object if none has been set yet. To change this default policy object call this method as a class method with an appropriate argument. Note that in this case only subsequently created Location objects will be affected. Returns : A L implementing object. Args : On set, a L implementing object. See L for more information =cut sub coordinate_policy { my ($self, $policy) = @_; if(defined($policy)) { if(! $policy->isa('Bio::Location::CoordinatePolicyI')) { $self->throw("Object of class ".ref($policy)." does not implement". " Bio::Location::CoordinatePolicyI"); } if(ref($self)) { $self->{'_coordpolicy'} = $policy; } else { # called as class method $coord_policy = $policy; } } return (ref($self) && exists($self->{'_coordpolicy'}) ? $self->{'_coordpolicy'} : $coord_policy); } =head2 trunc Title : trunc Usage : $trunc_location = $location->trunc($start, $end, $relative_ori); Function: To truncate a location and keep annotations and features within the truncated segment intact. This might do things differently where the truncation splits the location in half. CAVEAT : As yet, this is an untested and unannounced method. Use with caution! Returns : A L object. Args : The start and end position for the trunction, and the relative orientation. =cut sub trunc { my ($self,$start,$end,$relative_ori) = @_; my $newstart = $self->start - $start+1; my $newend = $self->end - $start+1; my $newstrand = $relative_ori * $self->strand; my $out; if( $newstart < 1 || $newend > ($end-$start+1) ) { $out = Bio::Location::Atomic->new(); $out->start($self->start); $out->end($self->end); $out->strand($self->strand); $out->seq_id($self->seqid); $out->is_remote(1); } else { $out = Bio::Location::Atomic->new(); $out->start($newstart); $out->end($newend); $out->strand($newstrand); $out->seq_id(); } return $out; } 1; BioPerl-1.6.923/Bio/Location/AvWithinCoordPolicy.pm000444000765000024 727612254227314 22171 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::AvWithinCoordPolicy # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # and Jason Stajich # # Copyright Hilmar Lapp, Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::AvWithinCoordPolicy - class implementing Bio::Location::CoordinatePolicy as the average for WITHIN and the widest possible and reasonable range otherwise =head1 SYNOPSIS See Bio::Location::CoordinatePolicyI =head1 DESCRIPTION CoordinatePolicyI implementing objects are used by Bio::LocationI implementing objects to determine integer-valued coordinates when asked for it. This class will compute the coordinates such that for fuzzy locations of type WITHIN and BETWEEN the average of the two limits will be returned, and for all other locations it will return the widest possible range, but by using some common sense. This means that e.g. locations like "E5..100" (start before position 5) will return 5 as start (returned values have to be positive integers). =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Jason Stajich Email Ehlapp-at-gmx-dot-netE, Ejason-at-bioperl-dot-orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::AvWithinCoordPolicy; use strict; use base qw(Bio::Location::WidestCoordPolicy); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 start Title : start Usage : $start = $policy->start($location); Function: Get the integer-valued start coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub start { my ($self,$loc) = @_; if(($loc->start_pos_type() eq 'WITHIN') || ($loc->start_pos_type() eq 'BETWEEN')) { my ($min, $max) = ($loc->min_start(), $loc->max_start()); return int(($min+$max)/2) if($min && $max); } return $self->SUPER::start($loc); } =head2 end Title : end Usage : $end = $policy->end($location); Function: Get the integer-valued end coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub end { my ($self,$loc) = @_; if(($loc->end_pos_type() eq 'WITHIN') || ($loc->end_pos_type() eq 'BETWEEN')) { my ($min, $max) = ($loc->min_end(), $loc->max_end()); return int(($min+$max)/2) if($min && $max); } return $self->SUPER::end($loc); } 1; BioPerl-1.6.923/Bio/Location/CoordinatePolicyI.pm000444000765000024 706312254227323 21643 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::CoordinatePolicyI # Please direct questions and support issues to # # Cared for by Hilmar Lapp # and Jason Stajich # # Copyright Hilmar Lapp, Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::CoordinatePolicyI - Abstract interface for objects implementing a certain policy of computing integer-valued coordinates of a Location =head1 SYNOPSIS # get a location, e.g., from a SeqFeature $location = $feature->location(); # examine its coordinate computation policy print "Location of feature ", $feature->primary_tag(), " employs a ", ref($location->coordinate_policy()), " instance for coordinate computation\n"; # change the policy, e.g. because the user chose to do so $location->coordinate_policy(Bio::Location::NarrowestCoordPolicy->new()); =head1 DESCRIPTION Objects implementing this interface are used by Bio::LocationI implementing objects to determine integer-valued coordinates when asked for it. While this may seem trivial for simple locations, there are different ways to do it for fuzzy or compound (split) locations. Classes implementing this interface implement a certain policy, like 'always widest range', 'always smallest range', 'mean for BETWEEN locations', etc. By installing a different policy object in a Location object, the behaviour of coordinate computation can be changed on-the-fly, and with a single line of code client-side. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Jason Stajich Email hlapp@gmx.net, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::CoordinatePolicyI; use strict; use base qw(Bio::Root::RootI); =head2 start Title : start Usage : $start = $policy->start($location); Function: Get the integer-valued start coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub start { my ($self) = @_; $self->throw_not_implemented(); } =head2 end Title : end Usage : $end = $policy->end($location); Function: Get the integer-valued end coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub end { my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Location/Fuzzy.pm000444000765000024 4577212254227333 17444 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::Fuzzy # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::Fuzzy - Implementation of a Location on a Sequence which has unclear start and/or end locations =head1 SYNOPSIS use Bio::Location::Fuzzy; my $fuzzylocation = Bio::Location::Fuzzy->new( -start => '<30', -end => 90, -location_type => '..'); print "location string is ", $fuzzylocation->to_FTstring(), "\n"; print "location is of the type ", $fuzzylocation->location_type, "\n"; =head1 DESCRIPTION This module contains the necessary methods for representing a Fuzzy Location, one that does not have clear start and/or end points. This will initially serve to handle features from Genbank/EMBL feature tables that are written as 1^100 meaning between bases 1 and 100 or E100..300 meaning it starts somewhere before 100. Advanced implementations of this interface may be able to handle the necessary logic of overlaps/intersection/contains/union. It was constructed to handle fuzzy locations that can be represented in Genbank/EMBL and Swissprot. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::Fuzzy; use strict; use base qw(Bio::Location::Atomic Bio::Location::FuzzyLocationI); our @LOCATIONCODESBSANE = (undef, 'EXACT', 'WITHIN', 'BETWEEN', 'UNCERTAIN', 'BEFORE', 'AFTER'); our %FUZZYCODES = ( 'EXACT' => '..', # Position is 'exact # Exact position is unknown, but is within the range specified, ((1.2)..100) 'WITHIN' => '.', # 1^2 'BETWEEN' => '^', 'IN-BETWEEN' => '^', 'UNCERTAIN' => '?', # <100 'BEFORE' => '<', # >10 'AFTER' => '>'); # The following regular expressions map to fuzzy location types. Every # expression must match the complete encoded point string, and must # contain two groups identifying min and max. Empty matches are automatic. # converted to undef, except for 'EXACT', for which max is set to equal # min. our %FUZZYPOINTENCODE = ( '\>(\d+)(.{0})' => 'AFTER', '\<(.{0})(\d+)' => 'BEFORE', '(\d+)' => 'EXACT', '\?(\d*)' => 'UNCERTAIN', '(\d+)(.{0})\>' => 'AFTER', '(.{0})(\d+)\<' => 'BEFORE', '(\d+)\.(\d+)' => 'WITHIN', '(\d+)\^(\d+)' => 'BETWEEN', ); our %FUZZYRANGEENCODE = ( '\.' => 'WITHIN', '\.\.' => 'EXACT', '\^' => 'IN-BETWEEN' ); =head2 new Title : new Usage : my $fuzzyloc = Bio::Location::Fuzzy->new( @args); Function: Returns : Args : -start => value for start (initialize by superclass) -end => value for end (initialize by superclass) -strand => value for strand (initialize by superclass) -location_type => either ('EXACT','WITHIN','IN-BETWEEN', 'UNCERTAIN') OR ( 1,2,3,4) -start_ext=> extension for start - defaults to 0, -start_fuz= fuzzy code for start can be ('EXACT','WITHIN','BETWEEN','BEFORE','AFTER', 'UNCERTAIN' ) OR a value 1 - 5 corresponding to index+1 above -end_ext=> extension for end - defaults to 0, -end_fuz= fuzzy code for end can be ('EXACT','WITHIN','BETWEEN','BEFORE','AFTER', 'UNCERTAIN') OR a value 1 - 5 corresponding to index+1 above =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($location_type, $start_ext, $start_fuz, $end_ext, $end_fuz) = $self->_rearrange([ qw(LOCATION_TYPE START_EXT START_FUZ END_EXT END_FUZ ) ], @args); $location_type && $self->location_type($location_type); $start_ext && $self->max_start($self->min_start + $start_ext); $end_ext && $self->max_end($self->min_end + $end_ext); $start_fuz && $self->start_pos_type($start_fuz); $end_fuz && $self->end_pos_type($end_fuz); return $self; } =head2 location_type Title : location_type Usage : my $location_type = $location->location_type(); Function: Get location type encoded as text Returns : string ('EXACT', 'WITHIN', 'IN-BETWEEN', 'UNCERTAIN') Args : none =cut sub location_type { my ($self,$value) = @_; if( defined $value || ! defined $self->{'_location_type'} ) { $value = 'EXACT' unless defined $value; if(! defined $FUZZYCODES{$value} ) { $value = uc($value); if( $value =~ /\.\./ ) { $value = 'EXACT'; } elsif( $value =~ /^\.$/ ) { $value = 'WITHIN'; } elsif( $value =~ /\^/ ) { $value = 'IN-BETWEEN'; $self->throw("Use Bio::Location::Simple for IN-BETWEEN locations [". $self->start. "] and [". $self->end. "]") if defined $self->start && defined $self->end && ($self->end - 1 == $self->start); } elsif( $value =~ /\?/ ) { $value = 'UNCERTAIN'; } elsif( $value ne 'EXACT' && $value ne 'WITHIN' && $value ne 'IN-BETWEEN' ) { $self->throw("Did not specify a valid location type"); } } $self->{'_location_type'} = $value; } return $self->{'_location_type'}; } =head1 LocationI methods =head2 length Title : length Usage : $length = $fuzzy_loc->length(); Function: Get the length of this location. Note that the length of a fuzzy location will always depend on the currently active interpretation of start and end. The result will therefore vary for different CoordinatePolicy objects. Returns : an integer Args : none =cut #sub length { # my($self) = @_; # return $self->SUPER::length() if( !$self->start || !$self->end); # $self->warn('Length is not valid for a FuzzyLocation'); # return 0; #} =head2 start Title : start Usage : $start = $fuzzy->start(); Function: get/set start of this range, handling fuzzy_starts Returns : a positive integer representing the start of the location Args : start location on set (can be fuzzy point string) =cut sub start { my($self,$value) = @_; if( defined $value ) { my ($encode,$min,$max) = $self->_fuzzypointdecode($value); $self->start_pos_type($encode); $self->min_start($min); $self->max_start($max); } $self->throw("Use Bio::Location::Simple for IN-BETWEEN locations [" . $self->SUPER::start. "] and [". $self->SUPER::end. "]") if $self->location_type eq 'IN-BETWEEN' && defined $self->SUPER::end && ($self->SUPER::end - 1 == $self->SUPER::start); return $self->SUPER::start(); } =head2 end Title : end Usage : $end = $fuzzy->end(); Function: get/set end of this range, handling fuzzy_ends Returns : a positive integer representing the end of the range Args : end location on set (can be fuzzy string) =cut sub end { my($self,$value) = @_; if( defined $value ) { my ($encode,$min,$max) = $self->_fuzzypointdecode($value); $self->end_pos_type($encode); $self->min_end($min); $self->max_end($max); } $self->throw("Use Bio::Location::Simple for IN-BETWEEN locations [". $self->SUPER::start. "] and [". $self->SUPER::end. "]") if $self->location_type eq 'IN-BETWEEN' && defined $self->SUPER::start && ($self->SUPER::end - 1 == $self->SUPER::start); return $self->SUPER::end(); } =head2 min_start Title : min_start Usage : $min_start = $fuzzy->min_start(); Function: get/set the minimum starting point Returns : the minimum starting point from the contained sublocations Args : integer or undef on set =cut sub min_start { my ($self,@args) = @_; if(@args) { $self->{'_min_start'} = $args[0]; # the value may be undef! } return $self->{'_min_start'}; } =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get/set maximum starting location of feature startpoint Returns : integer or undef if no maximum starting point. Args : integer or undef on set =cut sub max_start { my ($self,@args) = @_; if(@args) { $self->{'_max_start'} = $args[0]; # the value may be undef! } return $self->{'_max_start'}; } =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get/set start position type. Returns : type of position coded as text ('BEFORE','AFTER','EXACT','WITHIN','BETWEEN','UNCERTAIN') Args : a string on set =cut sub start_pos_type { my ($self,$value) = @_; if(defined $value && $value =~ /^\d+$/ ) { if( $value == 0 ) { $value = 'EXACT'; } else { my $v = $LOCATIONCODESBSANE[$value]; if( ! defined $v ) { $self->warn("Provided value $value which I don't understand,". " reverting to 'EXACT'"); $v = 'EXACT'; } $value = $v; } } if(defined($value)) { $self->{'_start_pos_type'} = $value; } return $self->{'_start_pos_type'}; } =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get/set minimum ending location of feature endpoint Returns : integer or undef if no minimum ending point. Args : integer or undef on set =cut sub min_end { my ($self,@args) = @_; if(@args) { $self->{'_min_end'} = $args[0]; # the value may be undef! } return $self->{'_min_end'}; } =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get/set maximum ending location of feature endpoint Returns : integer or undef if no maximum ending point. Args : integer or undef on set =cut sub max_end { my ($self,@args) = @_; if(@args) { $self->{'_max_end'} = $args[0]; # the value may be undef! } return $self->{'_max_end'}; } =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get/set end position type. Returns : type of position coded as text ('BEFORE','AFTER','EXACT','WITHIN','BETWEEN','UNCERTAIN') Args : a string on set =cut sub end_pos_type { my ($self,$value) = @_; if( defined $value && $value =~ /^\d+$/ ) { if( $value == 0 ) { $value = 'EXACT'; } else { my $v = $LOCATIONCODESBSANE[$value]; if( ! defined $v ) { $self->warn("Provided value $value which I don't understand,". " reverting to 'EXACT'"); $v = 'EXACT'; } $value = $v; } } if(defined($value)) { $self->{'_end_pos_type'} = $value; } return $self->{'_end_pos_type'}; } =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to Returns : seq_id Args : [optional] seq_id value to set =cut =head2 coordinate_policy Title : coordinate_policy Usage : $policy = $location->coordinate_policy(); $location->coordinate_policy($mypolicy); # set may not be possible Function: Get the coordinate computing policy employed by this object. See Bio::Location::CoordinatePolicyI for documentation about the policy object and its use. The interface *does not* require implementing classes to accept setting of a different policy. The implementation provided here does, however, allow to do so. Implementors of this interface are expected to initialize every new instance with a CoordinatePolicyI object. The implementation provided here will return a default policy object if none has been set yet. To change this default policy object call this method as a class method with an appropriate argument. Note that in this case only subsequently created Location objects will be affected. Returns : A Bio::Location::CoordinatePolicyI implementing object. Args : On set, a Bio::Location::CoordinatePolicyI implementing object. See L =cut =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: Get/Set seq_id that location refers to Returns : seq_id Args : [optional] seq_id value to set =cut sub to_FTstring { my ($self) = @_; my (%vals) = ( 'start' => $self->start, 'min_start' => $self->min_start, 'max_start' => $self->max_start, 'start_code' => $self->start_pos_type, 'end' => $self->end, 'min_end' => $self->min_end, 'max_end' => $self->max_end, 'end_code' => $self->end_pos_type ); my (%strs) = ( 'start' => '', 'end' => ''); my ($delimiter) = $FUZZYCODES{$self->location_type}; $delimiter = $FUZZYCODES{'EXACT'} if ($self->location_type eq 'UNCERTAIN'); my $policy = ref($self->coordinate_policy); # I'm lazy, lets do this in a loop since behaviour will be the same for # start and end # The CoordinatePolicy now dictates start/end data here (bug 992) - cjf foreach my $point ( qw(start end) ) { if( ($vals{$point."_code"} ne 'EXACT') && ($vals{$point."_code"} ne 'UNCERTAIN') ) { # must have max and min defined to use 'WITHIN', 'BETWEEN' if ((!defined $vals{"min_$point"} || !defined $vals{"max_$point"}) && ( $vals{$point."_code"} eq 'WITHIN' || $vals{$point."_code"} eq 'BETWEEN')) { $vals{"min_$point"} = '' unless defined $vals{"min_$point"}; $vals{"max_$point"} = '' unless defined $vals{"max_$point"}; $self->warn("Fuzzy codes for start are in a strange state, (". join(",", ($vals{"min_$point"}, $vals{"max_$point"}, $vals{$point."_code"})). ")"); return ''; } if (defined $vals{$point."_code"} && ($vals{$point."_code"} eq 'BEFORE' || $vals{$point."_code"} eq 'AFTER')) { $strs{$point} .= $FUZZYCODES{$vals{$point."_code"}}; $strs{$point} .= $vals{"$point"}; } if( defined $vals{$point."_code"} && ($vals{$point."_code"} eq 'WITHIN' || $vals{$point."_code"} eq 'BETWEEN')) { # Expect odd results with anything but WidestCoordPolicy for now $strs{$point} .= ($point eq 'start') ? $vals{"$point"}. $FUZZYCODES{$vals{$point."_code"}}. $vals{'max_'.$point} : $vals{'min_'.$point}. $FUZZYCODES{$vals{$point."_code"}}. $vals{"$point"}; $strs{$point} = "(".$strs{$point}.")"; } } elsif ($vals{$point."_code"} eq 'UNCERTAIN') { $strs{$point} = $FUZZYCODES{$vals{$point."_code"}}; $strs{$point} .= $vals{$point} if defined $vals{$point}; } else { $strs{$point} = $vals{$point}; } } my $str = $strs{'start'} . $delimiter . $strs{'end'}; if($self->is_remote() && $self->seq_id()) { $str = $self->seq_id() . ":" . $str; } if( defined $self->strand && $self->strand == -1 && $self->location_type() ne "UNCERTAIN") { $str = "complement(" . $str . ")"; } elsif($self->location_type() eq "WITHIN") { $str = "(".$str.")"; } return $str; } =head2 valid_Location Title : valid_Location Usage : if ($location->valid_location) {...}; Function: boolean method to determine whether location is considered valid (has minimum requirements for Simple implementation) Returns : Boolean value: true if location is valid, false otherwise Args : none =cut =head2 _fuzzypointdecode Title : _fuzzypointdecode Usage : ($type,$min,$max) = $self->_fuzzypointdecode('<5'); Function: Decode a fuzzy string. Returns : A 3-element array consisting of the type of location, the minimum integer, and the maximum integer describing the range of coordinates this start or endpoint refers to. Minimum or maximum coordinate may be undefined. : Returns empty array on fail. Args : fuzzypoint string =cut sub _fuzzypointdecode { my ($self, $string) = @_; return () if( !defined $string); # strip off leading and trailing space $string =~ s/^\s*(\S+)\s*/$1/; foreach my $pattern ( keys %FUZZYPOINTENCODE ) { if( $string =~ /^$pattern$/ ) { my ($min,$max) = ($1,$2) unless (($1 eq '') && (!defined $2)); if( ($FUZZYPOINTENCODE{$pattern} eq 'EXACT') || ($FUZZYPOINTENCODE{$pattern} eq 'UNCERTAIN') ) { $max = $min; } else { $max = undef if((defined $max) && (length($max) == 0)); $min = undef if((defined $min) && (length($min) == 0)); } return ($FUZZYPOINTENCODE{$pattern},$min,$max); } } if( $self->verbose >= 1 ) { $self->warn("could not find a valid fuzzy encoding for $string"); } return (); } 1; BioPerl-1.6.923/Bio/Location/FuzzyLocationI.pm000444000765000024 1350512254227312 21230 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::FuzzyLocationI # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::FuzzyLocationI - Abstract interface of a Location on a Sequence which has unclear start/end location =head1 SYNOPSIS # Get a FuzzyLocationI object somehow print "Fuzzy FT location string is ", $location->to_FTstring(); print "location is of the type ", $location->loc_type, "\n"; =head1 DESCRIPTION This interface encapsulates the necessary methods for representing a Fuzzy Location, one that does not have clear start and/or end points. This will initially serve to handle features from Genbank/EMBL feature tables that are written as 1^100 meaning between bases 1 and 100 or E100..300 meaning it starts somewhere before 100. Advanced implementations of this interface may be able to handle the necessary logic of overlaps/intersection/contains/union. It was constructed to handle fuzzy locations that can be represented in Genbank/EMBL. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::FuzzyLocationI; use strict; use base qw(Bio::LocationI); =head1 LocationI methods =head2 location_type Title : loc_type Usage : my $location_type = $location->location_type(); Function: Get location type encoded as text Returns : string ('EXACT', 'WITHIN', 'IN-BETWEEN') Args : none =cut sub location_type { my ($self) = @_; $self->throw_not_implemented(); } =head1 Bio::LocationI methods Bio::LocationI methods follow =head2 min_start Title : min_start Usage : my $minstart = $location->min_start(); Function: Get minimum starting location of feature startpoint Returns : integer or undef if no maximum starting point. Args : none =cut =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get maximum starting location of feature startpoint Returns : integer or undef if no maximum starting point. Args : none =cut =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get start position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get minimum ending location of feature endpoint Returns : integer or undef if no minimum ending point. Args : none =cut =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get maximum ending location of feature endpoint Returns : integer or undef if no maximum ending point. Args : none =cut =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get end position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to Returns : seq_id Args : [optional] seq_id value to set =cut =head2 coordinate_policy Title : coordinate_policy Usage : $policy = $location->coordinate_policy(); $location->coordinate_policy($mypolicy); # set may not be possible Function: Get the coordinate computing policy employed by this object. See Bio::Location::CoordinatePolicyI for documentation about the policy object and its use. The interface *does not* require implementing classes to accept setting of a different policy. The implementation provided here does, however, allow to do so. Implementors of this interface are expected to initialize every new instance with a CoordinatePolicyI object. The implementation provided here will return a default policy object if none has been set yet. To change this default policy object call this method as a class method with an appropriate argument. Note that in this case only subsequently created Location objects will be affected. Returns : A Bio::Location::CoordinatePolicyI implementing object. Args : On set, a Bio::Location::CoordinatePolicyI implementing object. =cut =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: returns the FeatureTable string of this location Returns : string Args : none =cut 1; BioPerl-1.6.923/Bio/Location/NarrowestCoordPolicy.pm000444000765000024 724312254227331 22415 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::NarrowestCoordPolicy # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # and Jason Stajich # # Copyright Hilmar Lapp, Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::NarrowestCoordPolicy - class implementing Bio::Location::CoordinatePolicy as the narrowest possible and reasonable range =head1 SYNOPSIS See Bio::Location::CoordinatePolicyI =head1 DESCRIPTION CoordinatePolicyI implementing objects are used by Bio::LocationI implementing objects to determine integer-valued coordinates when asked for it. This class will compute the coordinates such that always the narrowest possible range is returned, but by using some common sense. This means that e.g. locations like "E5..100" (start before position 5) will return 5 as start (returned values have to be positive integers). =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Jason Stajich Email Ehlapp-at-gmx.netE, Ejason@bioperl.orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::NarrowestCoordPolicy; use strict; use base qw(Bio::Root::Root Bio::Location::CoordinatePolicyI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 start Title : start Usage : $start = $policy->start($location); Function: Get the integer-valued start coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub start { my ($self,$loc) = @_; # For performance reasons we don't check that it's indeed a Bio::LocationI # object. Hopefully, Location-object programmers are smart enough. my $pos = $loc->max_start(); # if max is not defined or equals 0 we resort to min $pos = $loc->min_start() if(! $pos); return $pos; } =head2 end Title : end Usage : $end = $policy->end($location); Function: Get the integer-valued end coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub end { my ($self,$loc) = @_; # For performance reasons we don't check that it's indeed a Bio::LocationI # object. Hopefully, Location-object programmers are smart enough. my $pos = $loc->min_end(); # if min is not defined or equals 0 we resort to max $pos = $loc->max_end() if(! $pos); return $pos; } 1; BioPerl-1.6.923/Bio/Location/Simple.pm000444000765000024 2610412254227323 17531 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::Simple # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::Simple - Implementation of a Simple Location on a Sequence =head1 SYNOPSIS use Bio::Location::Simple; my $location = Bio::Location::Simple->new( -start => 1, -end => 100, -strand => 1, ); if( $location->strand == -1 ) { printf "complement(%d..%d)\n", $location->start, $location->end; } else { printf "%d..%d\n", $location->start, $location->end; } =head1 DESCRIPTION This is an implementation of Bio::LocationI to manage exact location information on a Sequence: '22' or '12..15' or '16^17'. You can test the type of the location using length() function () or directly location_type() which can one of two values: 'EXACT' or 'IN-BETWEEN'. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::Simple; use strict; use base qw(Bio::Location::Atomic); our %RANGEENCODE = ('\.\.' => 'EXACT', '\^' => 'IN-BETWEEN' ); our %RANGEDECODE = ('EXACT' => '..', 'IN-BETWEEN' => '^' ); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($locationtype) = $self->_rearrange([qw(LOCATION_TYPE)],@args); $locationtype && $self->location_type($locationtype); return $self; } =head2 start Title : start Usage : $start = $loc->start(); Function: get/set the start of this range Returns : the start of this range Args : optionaly allows the start to be set using $loc->start($start) =cut sub start { my ($self, $value) = @_; $self->{'_start'} = $value if defined $value ; $self->throw("Only adjacent residues when location type ". "is IN-BETWEEN. Not [". $self->{'_start'}. "] and [". $self->{'_end'}. "]" ) if defined $self->{'_start'} && defined $self->{'_end'} && $self->location_type eq 'IN-BETWEEN' && ($self->{'_end'} - 1 != $self->{'_start'}); return $self->{'_start'}; } =head2 end Title : end Usage : $end = $loc->end(); Function: get/set the end of this range Returns : the end of this range Args : optionaly allows the end to be set : using $loc->end($start) Note : If start is set but end is undefined, this now assumes that start is the same as end but throws a warning (i.e. it assumes this is a possible error). If start is undefined, this now throws an exception. =cut sub end { my ($self, $value) = @_; $self->{'_end'} = $value if defined $value ; # Assume end is the same as start if not defined if (!defined $self->{'_end'}) { if (!defined $self->{'_start'}) { $self->warn('Can not set Bio::Location::Simple::end() equal to start; start not set'); return; } $self->warn('Setting end to equal start['. $self->{'_start'}. ']'); $self->{'_end'} = $self->{'_start'}; } $self->throw("Only adjacent residues when location type ". "is IN-BETWEEN. Not [". $self->{'_start'}. "] and [". $self->{'_end'}. "]" ) if defined $self->{'_start'} && defined $self->{'_end'} && $self->location_type eq 'IN-BETWEEN' && ($self->{'_end'} - 1 != $self->{'_start'}); return $self->{'_end'}; } =head2 strand Title : strand Usage : $strand = $loc->strand(); Function: get/set the strand of this range Returns : the strandedness (-1, 0, +1) Args : optionaly allows the strand to be set : using $loc->strand($strand) =cut =head2 length Title : length Usage : $len = $loc->length(); Function: get the length in the coordinate space this location spans Example : Returns : an integer Args : none =cut sub length { my ($self) = @_; if ($self->location_type eq 'IN-BETWEEN' ) { return 0; } else { return abs($self->end - $self->start) + 1; } } =head2 min_start Title : min_start Usage : my $minstart = $location->min_start(); Function: Get minimum starting location of feature startpoint Returns : integer or undef if no minimum starting point. Args : none =cut =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get maximum starting location of feature startpoint. In this implementation this is exactly the same as min_start(). Returns : integer or undef if no maximum starting point. Args : none =cut =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get start position type (ie <,>, ^). Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get minimum ending location of feature endpoint Returns : integer or undef if no minimum ending point. Args : none =cut =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get maximum ending location of feature endpoint In this implementation this is exactly the same as min_end(). Returns : integer or undef if no maximum ending point. Args : none =cut =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get end position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut =head2 location_type Title : location_type Usage : my $location_type = $location->location_type(); Function: Get location type encoded as text Returns : string ('EXACT' or 'IN-BETWEEN') Args : 'EXACT' or '..' or 'IN-BETWEEN' or '^' =cut sub location_type { my ($self, $value) = @_; if( defined $value || ! defined $self->{'_location_type'} ) { $value = 'EXACT' unless defined $value; $value = uc $value; if (! defined $RANGEDECODE{$value}) { $value = '\^' if $value eq '^'; $value = '\.\.' if $value eq '..'; $value = $RANGEENCODE{$value}; } $self->throw("Did not specify a valid location type. [$value] is no good") unless defined $value; $self->{'_location_type'} = $value; } $self->throw("Only adjacent residues when location type ". "is IN-BETWEEN. Not [". $self->{'_start'}. "] and [". $self->{'_end'}. "]" ) if $self->{'_location_type'} eq 'IN-BETWEEN' && defined $self->{'_start'} && defined $self->{'_end'} && ($self->{'_end'} - 1 != $self->{'_start'}); return $self->{'_location_type'}; } =head2 is_remote Title : is_remote Usage : $is_remote_loc = $loc->is_remote() Function: Whether or not a location is a remote location. A location is said to be remote if it is on a different 'object' than the object which 'has' this location. Typically, features on a sequence will sometimes have a remote location, which means that the location of the feature is on a different sequence than the one that is attached to the feature. In such a case, $loc->seq_id will be different from $feat->seq_id (usually they will be the same). While this may sound weird, it reflects the location of the kind of AL445212.9:83662..166657 which can be found in GenBank/EMBL feature tables. Example : Returns : TRUE if the location is a remote location, and FALSE otherwise Args : Value to set to =cut =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: returns the FeatureTable string of this location Returns : string Args : none =cut sub to_FTstring { my($self) = @_; my $str; if( $self->start == $self->end ) { $str = $self->start; } else { $str = $self->start . $RANGEDECODE{$self->location_type} . $self->end; } if($self->is_remote() && $self->seq_id()) { $str = $self->seq_id() . ":" . $str; } if( defined $self->strand && $self->strand == -1 ) { $str = "complement(".$str.")"; } return $str; } =head2 valid_Location Title : valid_Location Usage : if ($location->valid_location) {...}; Function: boolean method to determine whether location is considered valid (has minimum requirements for Simple implementation) Returns : Boolean value: true if location is valid, false otherwise Args : none =cut # comments, not function added by jason # # trunc is untested, and as of now unannounced method for truncating a # location. This is to eventually be part of the procedure to # truncate a sequence with annotation and properly remap the location # of all the features contained within the truncated segment. # presumably this might do things a little differently for the case # where the truncation splits the location in half # # in short- you probably don't want to use this method. sub trunc { my ($self,$start,$end,$relative_ori) = @_; my $newstart = $self->start - $start+1; my $newend = $self->end - $start+1; my $newstrand = $relative_ori * $self->strand; my $out; if( $newstart < 1 || $newend > ($end-$start+1) ) { $out = Bio::Location::Simple->new(); $out->start($self->start); $out->end($self->end); $out->strand($self->strand); $out->seq_id($self->seqid); $out->is_remote(1); } else { $out = Bio::Location::Simple->new(); $out->start($newstart); $out->end($newend); $out->strand($newstrand); $out->seq_id(); } return $out; } 1; BioPerl-1.6.923/Bio/Location/Split.pm000444000765000024 5032312254227331 17372 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::Split # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::Split - Implementation of a Location on a Sequence which has multiple locations (start/end points) =head1 SYNOPSIS use Bio::Location::Split; my $splitlocation = Bio::Location::Split->new(); $splitlocation->add_sub_Location(Bio::Location::Simple->new(-start=>1, -end=>30, -strand=>1)); $splitlocation->add_sub_Location(Bio::Location::Simple->new(-start=>50, -end=>61, -strand=>1)); my @sublocs = $splitlocation->sub_Location(); my $count = 1; # print the start/end points of the sub locations foreach my $location ( sort { $a->start <=> $b->start } @sublocs ) { printf "sub feature %d [%d..%d]\n", $count, $location->start,$location->end, "\n"; $count++; } =head1 DESCRIPTION This implementation handles locations which span more than one start/end location, or and/or lie on different sequences, and can work with split locations that depend on the specific order of the sublocations ('join') or don't have a specific order but represent a feature spanning noncontiguous sublocations ('order', 'bond'). Note that the order in which sublocations are added may be very important, depending on the specific split location type. For instance, a 'join' must have the sublocations added in the order that one expects to join the sublocations, whereas all other types are sorted based on the sequence location. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-AT-bioperl_DOT_org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::Split; # as defined by BSANE 0.03 our @CORBALOCATIONOPERATOR = ('NONE','JOIN', undef, 'ORDER');; use Bio::Root::Root; use base qw(Bio::Location::Atomic Bio::Location::SplitLocationI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); # initialize $self->{'_sublocations'} = []; my ( $type, $seqid, $locations ) = $self->_rearrange([qw(SPLITTYPE SEQ_ID LOCATIONS )], @args); if( defined $locations && ref($locations) =~ /array/i ) { $self->add_sub_Location(@$locations); } $seqid && $self->seq_id($seqid); $type ||= 'JOIN'; $type = lc ($type); $self->splittype($type); return $self; } =head2 each_Location Title : each_Location Usage : @locations = $locObject->each_Location($order); Function: Conserved function call across Location:: modules - will return an array containing the component Location(s) in that object, regardless if the calling object is itself a single location or one containing sublocations. Returns : an array of Bio::LocationI implementing objects Args : Optional sort order to be passed to sub_Location() =cut sub each_Location { my ($self, $order) = @_; my @locs = (); foreach my $subloc ($self->sub_Location($order)) { # Recursively check to get hierarchical split locations: push @locs, $subloc->each_Location($order); } return @locs; } =head2 sub_Location Title : sub_Location Usage : @sublocs = $splitloc->sub_Location(); Function: Returns the array of sublocations making up this compound (split) location. Those sublocations referring to the same sequence as the root split location will be sorted by start position (forward sort) or end position (reverse sort) and come first (before those on other sequences). The sort order can be optionally specified or suppressed by the value of the first argument. The default is no sort. Returns : an array of Bio::LocationI implementing objects Args : Optionally 1, 0, or -1 for specifying a forward, no, or reverse sort order =cut sub sub_Location { my ($self, $order) = @_; $order = 0 unless defined $order; if( defined($order) && ($order !~ /^-?\d+$/) ) { $self->throw("value $order passed in to sub_Location is $order, an invalid value"); } $order = 1 if($order > 1); $order = -1 if($order < -1); my @sublocs = defined $self->{'_sublocations'} ? @{$self->{'_sublocations'}} : (); # return the array if no ordering requested return @sublocs if( ($order == 0) || (! @sublocs) ); # sort those locations that are on the same sequence as the top (`master') # if the top seq is undefined, we take the first defined in a sublocation my $seqid = $self->seq_id(); my $i = 0; while((! defined($seqid)) && ($i <= $#sublocs)) { $seqid = $sublocs[$i++]->seq_id(); } if((! $self->seq_id()) && $seqid) { $self->warn("sorted sublocation array requested but ". "root location doesn't define seq_id ". "(at least one sublocation does!)"); } my @locs = ($seqid ? grep { $_->seq_id() eq $seqid; } @sublocs : @sublocs); if(@locs) { if($order == 1) { # Schwartzian transforms for performance boost @locs = map { $_->[0] } sort { (defined $a && defined $b) ? $a->[1] <=> $b->[1] : $a ? -1 : 1 } map { [$_, (defined $_->start ? $_->start : $_->end)] } @locs;; } else { # $order == -1 @locs = map { $_->[0]} sort { (defined $a && defined $b) ? $b->[1] <=> $a->[1] : $a ? -1 : 1 } map { [$_, (defined $_->end ? $_->end : $_->start)] } @locs; } } # push the rest unsorted if($seqid) { push(@locs, grep { $_->seq_id() ne $seqid; } @sublocs); } # done! return @locs; } =head2 add_sub_Location Title : add_sub_Location Usage : $splitloc->add_sub_Location(@locationIobjs); Function: add an additional sublocation Returns : number of current sub locations Args : list of Bio::LocationI implementing object(s) to add =cut sub add_sub_Location { my ($self,@args) = @_; my @locs; foreach my $loc ( @args ) { if( !ref($loc) || ! $loc->isa('Bio::LocationI') ) { $self->throw("Trying to add $loc as a sub Location but it doesn't implement Bio::LocationI!"); next; } push @{$self->{'_sublocations'}}, $loc; } return scalar @{$self->{'_sublocations'}}; } =head2 splittype Title : splittype Usage : $splittype = $location->splittype(); Function: get/set the split splittype Returns : the splittype of split feature (join, order) Args : splittype to set =cut sub splittype { my ($self, $value) = @_; if( defined $value || ! defined $self->{'_splittype'} ) { $value = 'JOIN' unless( defined $value ); $self->{'_splittype'} = uc ($value); } return $self->{'_splittype'}; } =head2 is_single_sequence Title : is_single_sequence Usage : if($splitloc->is_single_sequence()) { print "Location object $splitloc is split ". "but only across a single sequence\n"; } Function: Determine whether this location is split across a single or multiple sequences. This implementation ignores (sub-)locations that do not define seq_id(). The same holds true for the root location. Returns : TRUE if all sublocations lie on the same sequence as the root location (feature), and FALSE otherwise. Args : none =cut sub is_single_sequence { my ($self) = @_; my $seqid = $self->seq_id(); foreach my $loc ($self->sub_Location(0)) { $seqid = $loc->seq_id() if(! $seqid); if(defined($loc->seq_id()) && ($loc->seq_id() ne $seqid)) { return 0; } } return 1; } =head2 guide_strand Title : guide_strand Usage : $str = $loc->guide_strand(); Function: Get/Set the guide strand. Of use only if the split type is a 'join' (this helps determine the order of sublocation retrieval) Returns : value of guide strand (1, -1, or undef) Args : new value (-1 or 1, optional) =cut sub guide_strand { my $self = shift; return $self->{'strand'} = shift if @_; # Sublocations strand values consistency check to set Guide Strand my @subloc_strands; foreach my $loc ($self->sub_Location(0)) { push @subloc_strands, $loc->strand || 1; } if ($self->isa('Bio::Location::SplitLocationI')) { my $identical = 0; my $first_value = $subloc_strands[0]; foreach my $strand (@subloc_strands) { $identical++ if ($strand == $first_value); } if ($identical == scalar @subloc_strands) { $self->{'strand'} = $first_value; } else { $self->{'strand'} = undef; } } return $self->{'strand'}; } =head1 LocationI methods =head2 strand Title : strand Usage : $obj->strand($newval) Function: For SplitLocations, setting the strand of the container (this object) is a short-cut for setting the strand of all sublocations. In get-mode, checks if no sub-location is remote, and if all have the same strand. If so, it returns that shared strand value. Otherwise it returns undef. Example : Returns : on get, value of strand if identical between sublocations (-1, 1, or undef) Args : new value (-1 or 1, optional) =cut sub strand{ my ($self,$value) = @_; if( defined $value) { $self->{'strand'} = $value; # propagate to all sublocs foreach my $loc ($self->sub_Location(0)) { $loc->strand($value); } } else { my ($strand, $lstrand); foreach my $loc ($self->sub_Location(0)) { # we give up upon any location that's remote or doesn't have # the strand specified, or has a differing one set than # previously seen. # calling strand() is potentially expensive if the subloc is also # a split location, so we cache it $lstrand = $loc->strand(); if((! $lstrand) || ($strand && ($strand != $lstrand)) || $loc->is_remote()) { $strand = undef; last; } elsif(! $strand) { $strand = $lstrand; } } return $strand; } } =head2 flip_strand Title : flip_strand Usage : $location->flip_strand(); Function: Flip-flop a strand to the opposite. Also sets Split strand to be consistent with the sublocation strands (1, -1 or undef for mixed strand values) Returns : None Args : None =cut sub flip_strand { my $self = shift; my @sublocs; my @subloc_strands; for my $loc ( $self->sub_Location(0) ) { # Atomic "flip_strand" now initialize strand if necessary my $new_strand = $loc->flip_strand; # Store strand values for later consistency check push @sublocs, $loc; push @subloc_strands, $new_strand; } # Sublocations strand values consistency check to set Guide Strand if ($self->isa('Bio::Location::SplitLocationI')) { my $identical = 0; my $first_value = $subloc_strands[0]; foreach my $strand (@subloc_strands) { $identical++ if ($strand == $first_value); } if ($identical == scalar @subloc_strands) { $self->guide_strand($first_value); } else { # Mixed strand values, must reverse the sublocations order $self->guide_strand(undef); @{ $self->{_sublocations} } = reverse @sublocs; } } } =head2 start Title : start Usage : $start = $location->start(); Function: get the starting point of the first (sorted) sublocation Returns : integer Args : none =cut sub start { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set the starting point of a split location, ". "that is not possible, try manipulating the sub Locations"); } return $self->SUPER::start(); } =head2 end Title : end Usage : $end = $location->end(); Function: get the ending point of the last (sorted) sublocation Returns : integer Args : none =cut sub end { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set the ending point of a split location, ". "that is not possible, try manipulating the sub Locations"); } return $self->SUPER::end(); } =head2 min_start Title : min_start Usage : $min_start = $location->min_start(); Function: get the minimum starting point Returns : the minimum starting point from the contained sublocations Args : none =cut sub min_start { my ($self, $value) = @_; if( defined $value ) { $self->throw("Trying to set the minimum starting point of a split ". "location, that is not possible, try manipulating the sub Locations"); } my @locs = $self->sub_Location(1); return $locs[0]->min_start() if @locs; return; } =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get maximum starting location of feature startpoint Returns : integer or undef if no maximum starting point. Args : none =cut sub max_start { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set the maximum starting point of a split ". "location, that is not possible, try manipulating the sub Locations"); } my @locs = $self->sub_Location(1); return $locs[0]->max_start() if @locs; return; } =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get start position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut sub start_pos_type { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set the start_pos_type of a split location, ". "that is not possible, try manipulating the sub Locations"); } my @locs = $self->sub_Location(); return ( @locs ) ? $locs[0]->start_pos_type() : undef; } =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get minimum ending location of feature endpoint Returns : integer or undef if no minimum ending point. Args : none =cut sub min_end { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set the minimum end point of a split location, ". "that is not possible, try manipulating the sub Locations"); } # reverse sort locations by largest ending to smallest ending my @locs = $self->sub_Location(-1); return $locs[0]->min_end() if @locs; return; } =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get maximum ending location of feature endpoint Returns : integer or undef if no maximum ending point. Args : none =cut sub max_end { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set the maximum end point of a split location, ". "that is not possible, try manipulating the sub Locations"); } # reverse sort locations by largest ending to smallest ending my @locs = $self->sub_Location(-1); return $locs[0]->max_end() if @locs; return; } =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get end position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut sub end_pos_type { my ($self,$value) = @_; if( defined $value ) { $self->throw("Trying to set end_pos_type of a split location, ". "that is not possible, try manipulating the sub Locations"); } my @locs = $self->sub_Location(); return ( @locs ) ? $locs[0]->end_pos_type() : undef; } =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to We override this here in order to propagate to all sublocations which are not remote (provided this root is not remote either) Returns : seq_id Args : [optional] seq_id value to set =cut sub seq_id { my $self = shift; if(@_ && !$self->is_remote()) { foreach my $subloc ($self->sub_Location(0)) { $subloc->seq_id(@_) if !$subloc->is_remote(); } } return $self->SUPER::seq_id(@_); } =head2 coordinate_policy Title : coordinate_policy Usage : $policy = $location->coordinate_policy(); $location->coordinate_policy($mypolicy); # set may not be possible Function: Get the coordinate computing policy employed by this object. See Bio::Location::CoordinatePolicyI for documentation about the policy object and its use. The interface *does not* require implementing classes to accept setting of a different policy. The implementation provided here does, however, allow to do so. Implementors of this interface are expected to initialize every new instance with a CoordinatePolicyI object. The implementation provided here will return a default policy object if none has been set yet. To change this default policy object call this method as a class method with an appropriate argument. Note that in this case only subsequently created Location objects will be affected. Returns : A Bio::Location::CoordinatePolicyI implementing object. Args : On set, a Bio::Location::CoordinatePolicyI implementing object. =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: returns the FeatureTable string of this location Returns : string Args : none =cut sub to_FTstring { my ($self) = @_; my @strs; my $strand = $self->strand() || 0; my $stype = lc($self->splittype()); if( $strand < 0 ) { $self->flip_strand; # this will recursively set the strand # to +1 for all the sub locations } foreach my $loc ( $self->sub_Location(0) ) { $loc->verbose($self->verbose); my $str = $loc->to_FTstring(); # we only append the remote seq_id if it hasn't been done already # by the sub-location (which it should if it knows it's remote) # (and of course only if it's necessary) if( (! $loc->is_remote) && defined($self->seq_id) && defined($loc->seq_id) && ($loc->seq_id ne $self->seq_id) ) { $str = sprintf("%s:%s", $loc->seq_id, $str); } push @strs, $str; } $self->flip_strand if $strand < 0; my $str; if( @strs == 1 ) { ($str) = @strs; } elsif( @strs == 0 ) { $self->warn("no Sublocations for this splitloc, so not returning anything\n"); } else { $str = sprintf("%s(%s)",lc $self->splittype, join(",", @strs)); } if( $strand < 0 ) { # wrap this in a complement if it was unrolled $str = sprintf("%s(%s)",'complement',$str); } return $str; } =head2 valid_Location Title : valid_Location Usage : if ($location->valid_location) {...}; Function: boolean method to determine whether location is considered valid (has minimum requirements for Simple implementation) Returns : Boolean value: true if location is valid, false otherwise Args : none =cut # we'll probably need to override the RangeI methods since our locations will # not be contiguous. 1; BioPerl-1.6.923/Bio/Location/SplitLocationI.pm000444000765000024 1510012254227317 21172 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::SplitLocationI # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::SplitLocationI - Abstract interface of a Location on a Sequence which has multiple locations (start/end points) =head1 SYNOPSIS # get a SplitLocationI somehow print $splitlocation->start, "..", $splitlocation->end, "\n"; my @sublocs = $splitlocation->sub_Location(); my $count = 1; # print the start/end points of the sub locations foreach my $location ( sort { $a->start <=> $b->start } @sublocs ) { printf "sub feature %d [%d..%d]\n", $location->start,$location->end; $count++; } =head1 DESCRIPTION This interface encapsulates the necessary methods for representing the location of a sequence feature that has more that just a single start/end pair. Some examples of this are the annotated exons in a gene or the annotated CDS in a sequence file. =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::SplitLocationI; use strict; use Carp; use base qw(Bio::LocationI); =head2 sub_Location Title : sub_Location Usage : @locations = $feat->sub_Location(); Function: Returns an array of LocationI objects Returns : An array Args : none =cut sub sub_Location { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 splittype Title : splittype Usage : $splittype = $fuzzy->splittype(); Function: get/set the split splittype Returns : the splittype of split feature (join, order) Args : splittype to set =cut sub splittype { my($self) = @_; $self->throw_not_implemented(); } =head2 is_single_sequence Title : is_single_sequence Usage : if($splitloc->is_single_sequence()) { print "Location object $splitloc is split ". "but only across a single sequence\n"; } Function: Determine whether this location is split across a single or multiple sequences. Returns : TRUE if all sublocations lie on the same sequence as the root location (feature), and FALSE otherwise. Args : none =cut sub is_single_sequence { my ($self) = @_; $self->throw_not_implemented(); } =head1 Bio::LocationI methods Bio::LocationI inherited methods follow =head2 min_start Title : min_start Usage : my $minstart = $location->min_start(); Function: Get minimum starting location of feature startpoint Returns : integer or undef if no maximum starting point. Args : none =cut =head2 max_start Title : max_start Usage : my $maxstart = $location->max_start(); Function: Get maximum starting location of feature startpoint Returns : integer or undef if no maximum starting point. Args : none =cut =head2 start_pos_type Title : start_pos_type Usage : my $start_pos_type = $location->start_pos_type(); Function: Get start position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut =head2 min_end Title : min_end Usage : my $minend = $location->min_end(); Function: Get minimum ending location of feature endpoint Returns : integer or undef if no minimum ending point. Args : none =cut =head2 max_end Title : max_end Usage : my $maxend = $location->max_end(); Function: Get maximum ending location of feature endpoint Returns : integer or undef if no maximum ending point. Args : none =cut =head2 end_pos_type Title : end_pos_type Usage : my $end_pos_type = $location->end_pos_type(); Function: Get end position type (ie <,>, ^) Returns : type of position coded as text ('BEFORE', 'AFTER', 'EXACT','WITHIN', 'BETWEEN') Args : none =cut =head2 seq_id Title : seq_id Usage : my $seqid = $location->seq_id(); Function: Get/Set seq_id that location refers to Returns : seq_id Args : [optional] seq_id value to set =cut =head2 coordinate_policy Title : coordinate_policy Usage : $policy = $location->coordinate_policy(); $location->coordinate_policy($mypolicy); # set may not be possible Function: Get the coordinate computing policy employed by this object. See Bio::Location::CoordinatePolicyI for documentation about the policy object and its use. The interface *does not* require implementing classes to accept setting of a different policy. The implementation provided here does, however, allow to do so. Implementors of this interface are expected to initialize every new instance with a CoordinatePolicyI object. The implementation provided here will return a default policy object if none has been set yet. To change this default policy object call this method as a class method with an appropriate argument. Note that in this case only subsequently created Location objects will be affected. Returns : A Bio::Location::CoordinatePolicyI implementing object. Args : On set, a Bio::Location::CoordinatePolicyI implementing object. =cut =head2 to_FTstring Title : to_FTstring Usage : my $locstr = $location->to_FTstring() Function: returns the FeatureTable string of this location Returns : string Args : none =cut 1; BioPerl-1.6.923/Bio/Location/WidestCoordPolicy.pm000444000765000024 724012254227333 21667 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Location::WidestCoordPolicy # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # and Jason Stajich # # Copyright Hilmar Lapp, Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Location::WidestCoordPolicy - class implementing Bio::Location::CoordinatePolicy as the widest possible and reasonable range =head1 SYNOPSIS See Bio::Location::CoordinatePolicyI =head1 DESCRIPTION CoordinatePolicyI implementing objects are used by Bio::LocationI implementing objects to determine integer-valued coordinates when asked for it. This class will compute the coordinates such that always the widest possible range is returned, but by using some common sense. This means that e.g. locations like "E5..100" (start before position 5) will return 5 as start (returned values have to be positive integers). =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Jason Stajich Email Ehlapp-at-gmx-dot-netE, Ejason-at-bioperl-dot-orgE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Location::WidestCoordPolicy; use strict; use base qw(Bio::Root::Root Bio::Location::CoordinatePolicyI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 start Title : start Usage : $start = $policy->start($location); Function: Get the integer-valued start coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub start { my ($self,$loc) = @_; # For performance reasons we don't check that it's indeed a Bio::LocationI # object. Hopefully, Location-object programmers are smart enough. my $pos = $loc->min_start(); # if min is not defined or equals 0 we resort to max $pos = $loc->max_start() if(! $pos); return $pos; } =head2 end Title : end Usage : $end = $policy->end($location); Function: Get the integer-valued end coordinate of the given location as computed by this computation policy. Returns : A positive integer number. Args : A Bio::LocationI implementing object. =cut sub end { my ($self,$loc) = @_; # For performance reasons we don't check that it's indeed a Bio::LocationI # object. Hopefully, Location-object programmers are smart enough. my $pos = $loc->max_end(); # if max is not defined or equals 0 we resort to min $pos = $loc->min_end() if(! $pos); return $pos; } 1; BioPerl-1.6.923/Bio/Map000755000765000024 012254227337 14534 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Map/Clone.pm000444000765000024 2750412254227320 16307 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::clone # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Gaurav Gupta # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Clone - An central map object representing a clone =head1 SYNOPSIS # get the clone object of $clone from the Bio::Map::Clone my $cloneobj = $physical->get_cloneobj($clone); # acquire all the markers that hit this clone foreach my $marker ($cloneobj->each_markerid()) { print " +++$marker\n"; } See L and L for more information. =head1 DESCRIPTION This object handles the notion of a clone. This clone will have a name and a position in a map. This object is intended to be used by a map parser like fpc.pm. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Gaurav Gupta Email gaurav@genome.arizona.edu =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk =head1 PROJECT LEADERS Jamie Hatfield jamie@genome.arizona.edu Dr. Cari Soderlund cari@genome.arizona.edu =head1 PROJECT DESCRIPTION The project was done in Arizona Genomics Computational Laboratory (AGCoL) at University of Arizona. This work was funded by USDA-IFAFS grant #11180 titled "Web Resources for the Computation and Display of Physical Mapping Data". For more information on this project, please refer: http://www.genome.arizona.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Clone; use strict; use Bio::Map::Position; use base qw(Bio::Root::Root Bio::Map::MappableI); =head2 new Title : new Usage : my $clone = Bio::Map::Clone->new ( -name => $clone, -markers => \@markers, -contig => $contig, -type => $type, -bands => $bands, -gel => $gel, -group => $group, -remark => $remark, -fpnumber=> $fp_number, -sequencetype => $seq_type, -sequencestatus=> $seq_status, -fpcremark => $fpc_remark, -matche => \@ematch, -matcha => \@amatch, -matchp => \@pmatch, -range => Bio::Range->new(-start => $startrange, -end => $endrange) ); Function: Initialize a new Bio::Map::Clone object Most people will not use this directly but get Clones through L Returns : L object Args : -name => marker name string, -markers => array ref of markers, -contig => contig name string, -type => type string, -bands => band string, -gel => gel string, -group => group name string, -remark => remark string, -fpnumber=> FP number string, -sequencetype => seq type string, -sequencestatus=> seq status string, -fpcremark => FPC remark, -matche => array ref, -matcha => array ref, -matchp => array ref, -range => L object, =cut sub new { my ($class,@args) = @_; my $self= $class->SUPER::new(@args); my ($name,$markers,$contig,$type,$bands,$gel,$group, $remark,$fpnumber,$seqtype,$seqstatus,$fpcremark, $matche,$matcha,$matchp, $range) = $self->_rearrange([qw(NAME MARKERS CONTIG TYPE BANDS GEL GROUP REMARK FPNUMBER SEQUENCETYPE SEQUENCESTATUS FPCREMARK MATCHE MATCHA MATCHP RANGE)],@args); $self->name($name) if defined $name; $self->markers($markers) if defined $markers; $self->contigid($contig) if defined $contig; $self->type($type) if defined $type; $self->bands($bands) if defined $bands; $self->gel($gel) if defined $gel; $self->group($group) if defined $group; $self->remark($remark) if defined $remark; $self->fp_number($fpnumber) if defined $fpnumber; $self->sequence_type($seqtype) if defined $seqtype; $self->sequence_status($seqstatus) if defined $seqstatus; $self->fpc_remark($fpcremark) if defined $fpcremark; $self->range($range) if defined $range; $self->set_match('approx', $matcha) if defined $matcha; $self->set_match('pseudo', $matchp) if defined $matchp; $self->set_match('exact', $matche) if defined $matche; return $self; } =head1 Access Methods These methods let you get and set the member variables =head2 name Title : name Usage : my $name = $cloneobj->name(); Function: Get/set the name for this Clone Returns : scalar representing the current name of this clone Args : none to get, OR string to set =cut sub name { my ($self) = shift; return $self->{'_name'} = shift if @_; return $self->{'_name'}; } =head2 type Title : type Usage : my $type = $cloneobj->type(); Function: Get/set the type for this clone Returns : scalar representing the current type of this clone Args : none to get, OR string to set =cut sub type { my ($self) = shift; return $self->{'_type'} = shift if @_; return $self->{'_type'}; } =head2 range Title : range Usage : my $range = $cloneobj->range(); Function: Get/set the range of the contig that this clone covers Returns : Bio::Range representing the current range of this contig, start and end of the contig can be thus found using: my $start = $contigobj->range()->start(); my $end = $contigobj->range()->end(); Args : none to get, OR Bio::Range to set =cut sub range { my ($self) = shift; return $self->{'_range'} = shift if @_; return $self->{'_range'}; } =head2 match Title : match Usage : @eclone = $cloneobj->match('exact'); @aclone = $cloneobj->match('approximate'); @pclone = $cloneobj->match('pseudo'); Function: get all matching clones Returns : list Args : scalar representing the type of clone to be queried. =cut sub match { my ($self,$type) = @_; $type = "_match" . lc(substr($type, 0, 1)); return @{$self->{$type} || []}; } =head2 each_match Title : each_match Function: Synonym of the match() method. =cut *each_match = \&match; =head2 set_match Title : set_match Usage : $clone->set_match($type,$values); Function: Set the Matches per type Returns : None Args : type (one of 'exact' 'approx' 'pseudo') array ref of match values =cut sub set_match{ my ($self,$type,$val) = @_; $type = "_match" . lc(substr($type, 0, 1)); $self->{$type} = $val; } =head2 gel Title : gel Usage : $clonegel = $cloneobj->gel(); Function: Get/set the gel number for this clone Returns : scalar representing the gel number of this clone Args : none to get, OR string to set =cut sub gel { my ($self) = shift; return $self->{'_gel'} = shift if @_; return $self->{'_gel'}; } =head2 remark Title : remark Usage : $cloneremark = $cloneobj->remark(); Function: Get/set the remark for this clone Returns : scalar representing the current remark of this clone Args : none to get, OR string to set =cut sub remark { my ($self) = shift; return $self->{'_remark'} = shift if @_; return $self->{'_remark'}; } =head2 fp_number Title : fp_number Usage : $clonefpnumber = $cloneobj->fp_number(); Function: Get/set the fp number for this clone Returns : scalar representing the fp number of this clone Args : none to get, OR string to set =cut sub fp_number { my ($self) = shift; return $self->{'_fpnumber'} = shift if @_; return $self->{'_fpnumber'}; } =head2 sequence_type Title : sequence_type Usage : $cloneseqtype = $cloneobj->sequence_type(); Function: Get/set the sequence type for this clone Returns : scalar representing the sequence type of this clone Args : none to get, OR string to set =cut sub sequence_type { my ($self) = shift; return $self->{'_sequencetype'} = shift if @_; return $self->{'_sequencetype'}; } =head2 sequence_status Title : sequence_status Usage : $cloneseqstatus = $cloneobj->sequence_status(); Function: Get/set the sequence status for this clone Returns : scalar representing the sequence status of this clone Args : none to get, OR string to set =cut sub sequence_status { my ($self) = shift; return $self->{'_sequencestatus'} = shift if @_; return $self->{'_sequencestatus'}; } =head2 fpc_remark Title : fpc_remark Usage : $clonefpcremark = $cloneobj->fpc_remark(); Function: Get/set the fpc remark for this clone Returns : scalar representing the fpc remark of this clone Args : none to get, OR string to set =cut sub fpc_remark { my ($self) = shift; return $self->{'_fpcremark'} = shift if @_; return $self->{'_fpcremark'}; } =head2 bands Title : bands Usage : @clonebands = $cloneobj->bands(); Function: Get/set the bands for this clone Returns : liat representing the band of this clone, if readcor = 1 while creating the MapIO object and the .cor exists Args : none to get, OR string to set =cut sub bands { my ($self) = shift; return $self->{'_bands'} = shift if @_; return $self->{'_bands'}; } =head2 group Title : group Usage : $cloneobj->group($chrno); Function: Get/set the group number for this clone. This is a generic term, used for Linkage-Groups as well as for Chromosomes. Returns : scalar representing the group number of this clone Args : none to get, OR string to set =cut sub group { my ($self) = shift; return $self->{'_group'} = shift if @_; return $self->{'_group'}; } =head2 contigid Title : contigid Usage : my $ctg = $cloneobj->contigid(); Function: Get/set the contig this clone belongs to Returns : scalar representing the contig Args : none to get, OR string to set =cut sub contigid { my ($self) = shift; $self->{'_contig'} = shift if @_; return $self->{'_contig'} || 0; } =head2 each_markerid Title : each_markerid Usage : @markers = $cloneobj->each_markerid(); Function: retrieves all the elements in a map unordered Returns : list of strings (ids) Args : none *** This only supplies the ids set with the set_markers method *** *** It has nothing to do with actual Bio::Map::MarkerI objects *** =cut sub each_markerid { my ($self,$value) = @_; return @{$self->{"_markers"}}; } =head2 set_markers Title : markers Usage : $obj->set_markers($newval) Function: Set list of Marker ids (arrayref) Returns : None Args : arrayref of strings (ids) *** This only sets a list of ids *** *** It has nothing to do with actual Bio::Map::MarkerI objects *** =cut sub set_markers { my ($self,$markers) = @_; if( defined $markers && ref($markers) =~ /ARRAY/ ) { $self->{'_markers'} = $markers; } } 1; BioPerl-1.6.923/Bio/Map/Contig.pm000555000765000024 2543112254227331 16474 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::Contig # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Gaurav Gupta # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Contig - A MapI implementation handling the contigs of a Physical Map (such as FPC) =head1 SYNOPSIS # get the contig object of $contig from the Bio::Map::Physical my $ctgobj = $physical->get_contigobj($contig); # acquire all the markers that lie in this contig foreach my $marker ($ctgobj->each_markerid()) { print " +++$marker\n"; } # find the group of this contig print "Group: ",$ctgobj->group(),"\n"; # find the range of this contig print "RANGE: start:",$ctgobj->range()->start(),"\tend: ", $ctgobj->range()->end(),"\n"; # find the position of this contig in $group (chromosome) print "Position in Group $group"," = ",$ctgobj->position($group),"\n"; =head1 DESCRIPTION This is an implementation of Bio::Map::MapI. It handles the essential storage of name, species, type, and units as well as in memory representation of the elements of a map. Bio::Map::Contig has been tailored to work for FPC physical maps, but could probably be used for others as well (with the appropriate MapIO module). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Gaurav Gupta Email gaurav@genome.arizona.edu =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk =head1 PROJECT LEADERS Jamie Hatfield jamie@genome.arizona.edu Dr. Cari Soderlund cari@genome.arizona.edu =head1 PROJECT DESCRIPTION The project was done in Arizona Genomics Computational Laboratory (AGCoL) at University of Arizona. This work was funded by USDA-IFAFS grant #11180 titled "Web Resources for the Computation and Display of Physical Mapping Data". For more information on this project, please refer: http://www.genome.arizona.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Contig; use vars qw($MAPCOUNT); use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Range; use base qw(Bio::Map::SimpleMap); BEGIN { $MAPCOUNT = 1; } =head2 new Title : new Usage : my $clone = Bio::Map::Contig->new ( -name => $name, -chr_remark => $cremark, -user_remark => $uremark, -trace_remark => $tremark, -group => $group, -subgroup=> $subgroup, -anchor => $anchor, -markers => \%markers, -clones => \%clones, -position => $pos -range => Bio::Range->new(-start =>$s,-end=>$e), ); Function: Initialize a new Bio::Map::Contig object Most people will not use this directly but get Markers through L Returns : L object Args : ( -name => name string, -chr_remark => chr remark string, -user_remark => userremark string, -trace_remark => tremark string, -group => group string, -subgroup=> subgroup string, -anchor => boolean if this is anchored or not, -markers => hashref of contained markers, -clones => hashref of contained clones, -position => position -range => L =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($name,$cremark,$uremark,$tremark, $group,$subgroup, $anchor,$markers, $clones, $position,$range) = $self->_rearrange([qw(NAME CHR_REMARK USER_REMARK TRACE_REMARK GROUP SUBGROUP ANCHOR MARKERS CLONES POSITION RANGE)],@args); $self->name($name) if defined $name; $self->chr_remark($cremark) if defined $cremark; $self->user_remark($uremark) if defined $uremark; $self->trace_remark($tremark) if defined $tremark; $self->group($group) if defined $group; $self->subgroup($group) if defined $subgroup; $self->anchor($anchor) if defined $anchor; $self->set_markers($markers) if defined $markers; $self->set_clones($clones) if defined $clones; $self->range($range) if defined $range; $self->position($position) if defined $position; return $self; } =head2 Modifier methods All methods present in L are implemented by this class. Most of the methods are inherited from SimpleMap. The following methods have been modified to reflect the needs of physical maps. =head2 chr_remark Title : chr_remark Usage : my $chrremark = $contigobj->chr_remark(); Function: Get/set the group remark for this contig Returns : scalar representing the current group_remark of this contig Args : none to get, OR string to set =cut sub chr_remark { my ($self) = shift; $self->{'_cremark'} = shift if @_; return defined $self->{'_cremark'} ? $self->{'_cremark'} : ''; } =head2 user_remark Title : user_remark Usage : my $userremark = $contigobj->user_remark(); Function: Get/set the user remark for this contig Returns : scalar representing the current user_remark of this contig Args : none to get, OR string to set =cut sub user_remark { my ($self) = shift; $self->{'_uremark'} = shift if @_; return defined $self->{'_uremark'} ? $self->{'_uremark'} : ''; } =head2 trace_remark Title : trace_remark Usage : my $traceremark = $contigobj->trace_remark(); Function: Get/set the trace remark for this contig Returns : scalar representing the current trace_remark of this contig Args : none to get, OR string to set =cut sub trace_remark { my ($self) = shift; $self->{'_tremark'} = shift if @_; return defined $self->{'_tremark'} ? $self->{'_tremark'} : ''; } =head2 range Title : range Usage : my $range = $contigobj->range(); Function: Get/set the range for this Contig Returns : Bio::Range representing the current range of this contig, start and end of the contig can be thus found using: my $start = $contigobj->range()->start(); my $end = $contigobj->range()->end(); Args : none to get, OR Bio::Range to set =cut sub range { my ($self) = shift; return $self->{'_range'} = shift if @_; return $self->{'_range'}; } =head2 position Title : position Usage : $ctgpos = $contigobj->position(); Function: Get/set the position of the contig in the group Returns : scalar representing the position of the contig in the group Args : none to get, OR string to set =cut sub position { my ($self) = shift; $self->{'_position'} = shift if @_; return $self->{'_position'} || 0; } =head2 anchor Title : anchor Usage : $ctganchor = $contig->anchor(); Function: Get/set the anchor value for this Contig (True | False) Returns : scalar representing the anchor (1 | 0) for this contig Args : none to get, OR string to set =cut sub anchor { my ($self) = shift; return $self->{'_anchor'} = shift if @_; return $self->{'_anchor'}; } =head2 group Title : group Usage : $groupno = $contigobj->group(); Function: Get/set the group number for this contig. This is a generic term, used for Linkage-Groups as well as for Chromosomes. Returns : scalar representing the group number of this contig Args : none =cut sub group { my ($self) = shift; $self->{'_group'} = shift if @_; return $self->{'_group'} || 0; } =head2 subgroup Title : subgroup Usage : $subgroup = $contig->subgroup(); Function: Get/set the subgroup for this contig. This is a generic term: subgroup here could represent subgroup of a Chromosome or of a Linkage Group. The user must take care of which subgroup he/she is querying for. Returns : A scalar representing the subgroup of this contig Args : none =cut sub subgroup { my ($self) = @_; return $self->{'_subgroup'} = shift if @_; return $self->{'_subgroup'} || 0; } =head2 each_cloneid Title : each_cloneid Usage : my @clones = $map->each_cloneid(); Function: retrieves all the clone ids in a map unordered Returns : list of strings (ids) Args : none *** This only supplies the ids set with the set_clones method *** *** It has nothing to do with actual Bio::Map::MappableI objects *** =cut sub each_cloneid { my ($self) = @_; return $self->_each_element('clones'); } =head2 each_markerid Title : each_markerid Usage : my @markers = $map->each_markerid(); Function: retrieves all the marker ids in a map unordered Returns : list of strings (ids) Args : none *** This only supplies the ids set with the set_markers method *** *** It has nothing to do with actual Bio::Map::MarkerI objects *** =cut sub each_markerid { my ($self) = @_; return $self->_each_element('markers'); } sub _each_element { my ($self, $type) = @_; $type = 'clones' if (!defined($type)); $type = lc("_$type"); return keys %{$self->{$type} || {}}; } =head2 set_clones Title : set_clones Usage : $marker->set_clones(\%clones) Function: Set the clones hashref Returns : None Args : Hashref of clone ids *** This only sets a hash of ids *** *** It has nothing to do with actual Bio::Map::MappableI objects *** =cut sub set_clones { my ($self,$clones) = @_; if( defined $clones && ref($clones) =~ /HASH/ ) { $self->{'_clones'} = $clones; } } =head2 set_markers Title : markers Usage : $obj->set_markers($newval) Function: Set list of Markers (hashref) Returns : None Args : Hashref of marker ids *** This only sets a hash of ids *** *** It has nothing to do with actual Bio::Map::MarkerI objects *** =cut sub set_markers { my ($self,$markers) = @_; if( defined $markers && ref($markers) =~ /HASH/ ) { $self->{'_markers'} = $markers; } } 1;BioPerl-1.6.923/Bio/Map/CytoMap.pm000444000765000024 671212254227334 16606 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::CytoMap # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::CytoMap - A Bio::MapI compliant map implementation handling cytogenic bands =head1 SYNOPSIS use Bio::Map::CytoMap; my $map = Bio::Map::CytoMap->new(-name => 'human1', -species => $human); foreach my $marker ( @markers ) { # get a list of markers somewhere $map->add_element($marker); } =head1 DESCRIPTION This is the simple implementation of cytogenetic maps based on L. It handles the essential storage of name, species, type, and units as well as in memory representation of the elements of a map. For CytoMaps type is hard coded to be 'cytogeneticmap' and units are set to '' but can be set to something else. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Jason Stajich jason@bioperl.org Lincoln Stein lstein@cshl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Map::CytoMap; use vars qw($MAPCOUNT); use strict; use base qw(Bio::Map::SimpleMap); BEGIN { $MAPCOUNT = 1; } =head2 new Title : new Usage : my $obj = Bio::Map::CytoMap->new(); Function: Builds a new Bio::Map::CytoMap object Returns : Bio::Map::CytoMap Args : -name => name of map (string) -species => species for this map (Bio::Species) [optional] -elements=> elements to initialize with (arrayref of Bio::Map::MappableI objects) [optional] -uid => Unique Id =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->{'_uid'} = $MAPCOUNT++; my ($uid) = $self->_rearrange([qw(UID)], @args); defined $uid && $self->unique_id($uid); return $self; } =head2 type Title : type Usage : my $type = $map->type Function: Get hard-coded Map type Returns : String coding Map type (always 'cyto') Args : none =cut sub type { return 'cyto'; } =head2 length Title : length Usage : my $length = $map->length(); Function: Retrieves the length of the map, Returns : 0 since length is not calculatable for cytogenetic maps Args : none =cut sub length { return 0; } 1; BioPerl-1.6.923/Bio/Map/CytoMarker.pm000444000765000024 722512254227314 17310 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::CytoMarker # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::CytoMarker - An object representing a marker. =head1 SYNOPSIS $o_usat = Bio::Map::CytoMarker->new(-name=>'Chad Super Marker 2', -position => $pos); =head1 DESCRIPTION This object handles markers with a positon in a cytogenetic map known. This marker will have a name and a position. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Chad Matsalla bioinformatics1@dieselwurks.com Lincoln Stein lstein@cshl.org Jason Stajich jason@bioperl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::CytoMarker; use strict; use Bio::Map::CytoPosition; use base qw(Bio::Map::Marker); =head2 Bio::Map::MarkerI methods =cut =head2 get_position_object Title : get_position_class Usage : my $position = $marker->get_position_object(); Function: To get an object of the default Position class for this Marker. Subclasses should redefine this method. The Position returned needs to be a L with -element set to self. Returns : L Args : none for an 'empty' PositionI object, optionally Bio::Map::MapI and value string to set the Position's -map and -value attributes. =cut sub get_position_object { my ($self, $map, $value) = @_; $map ||= $self->default_map; if ($value) { $self->throw("Value better be scalar, not [$value]") unless ref($value) eq ''; } my $pos = Bio::Map::CytoPosition->new(); $pos->map($map) if $map; $pos->value($value) if $value; $pos->element($self); return $pos; } =head2 Comparison methods The numeric values for cutogeneic loctions go from the p tip of chromosome 1, down to the q tip and similarly throgh consecutive chromosomes, through X and end the the q tip of X. See L for more details. =cut =head2 New methods =cut =head2 get_chr Title : get_chr Usage : my $mychr = $marker->get_chr(); Function: Read only method for the chromosome string of the location. A shortcut to $marker->position->chr(). Returns : chromosome value Args : [optional] new chromosome value =cut sub get_chr { my ($self) = @_; return unless $self->position; return $self->position->chr; } 1; BioPerl-1.6.923/Bio/Map/CytoPosition.pm000444000765000024 3651412254227316 17720 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::CytoPosition # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::CytoPosition - Marker class with cytogenetic band storing attributes =head1 SYNOPSIS $m1 = Bio::Map::CytoPosition->new ( '-id' => 'A1', '-value' => '2q1-3' ); $m2 = Bio::Map::CytoPosition->new ( '-id' => 'A2', '-value' => '2q2' ); if ($m1->cytorange->overlaps($m2->cytorange)) { print "Makers overlap\n"; } =head1 DESCRIPTION CytoPosition is marker (Bio::Map::MarkerI compliant) with a location in a cytogenetic map. See L for more information. Cytogenetic locations are names of bands visible in stained mitotic eucaryotic chromosomes. The naming follows strict rules which are consistant at least in higher vertebates, e.g. mammals. The chromosome name preceds the band names. The shorter arm of the chromosome is called 'p' ('petit') and usually drawn pointing up. The lower arm is called 'q' ('queue'). The bands are named from the region separting these, a centromere (cen), towards the tips or telomeric regions (ter) counting from 1 upwards. Depending of the resolution used the bands are identified with one or more digit. The first digit determines the major band and subsequent digits sub bands: p1 band can be divided into subbands p11, p12 and 13 and p11 can furter be divided into subbands p11.1 and p11.2. The dot after second digit makes it easier to read the values. A region between ands is given from the centromere outwards towards the telomere (e.g. 2p2-5 or 3p21-35) or from a band in the p arm to a band in the q arm. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::CytoPosition; use strict; use integer; use Bio::Range; use base qw(Bio::Map::Position); =head2 cytorange Title : cytorange Usage : my $range = $obj->cytorange(); Function: Converts cytogenetic location set by value method into an integer range. The chromosome number determines the "millions" in the values. Human X and Y chromosome symbols are represented by values 100 and 101. The localization within chromosomes are converted into values between the range of 0 and 200,000: pter cen qter |------------------------|-------------------------| 0 100,000 200,000 The values between -100,000 through 0 for centromere to 100,000 would have reflected the band numbering better but use of positive integers was chosen since the transformation is very easy. These values are not metric. Each band defines a range in a chromosome. A band string is converted into a range by padding it with lower and and higher end digits (for q arm: '0' and '9') to the length of five. The arm and chromosome values are added to these: e.g. 21000 & 21999 (band 21) + 100,000 (q arm) + 2,000,000 (chromosome 2) => 2q21 : 2,121,000 .. 2,121,999. Note that this notation breaks down if there is a band or a subband using digit 9 in its name! This is not the case in human karyotype. The full algorithm used for bands: if arm is 'q' then pad char for start is '0', for end '9' range is chromosome + 100,000 + padded range start or end elsif arm is 'p' then pad char for start is '9', for end '0' range is chromosome + 100,000 - padded range start or end Returns : Bio::Range object or undef Args : none =cut sub cytorange { my ($self) = @_; my ($chr, $r, $band, $band2, $arm, $arm2, $lc, $uc, $lcchar, $ucchar); return $r if not defined $self->{_value}; # returns undef $self->{_value} =~ # -----1----- --------2--------- -----3----- -------4------- ---6--- m/([XY]|[0-9]+)(cen|qcen|pcen|[pq])?(ter|[.0-9]+)?-?([pq]?(cen|ter)?)?([.0-9]+)?/; $self->warn("Not a valid value: ". $self->{_value}), return $r if not defined $1 ; # returns undef $chr = uc $1; $self->chr($chr); $chr = 100 if $chr eq 'X'; $chr = 101 if $chr eq 'Y'; $chr *= 1000000; $r = Bio::Range->new(); $band = ''; if (defined $3 ) { $2 || $self->throw("$& does not make sense: 'arm' or 'cen' missing"); $band = $3; $band =~ tr/\.//d; } if (defined $6 ) { $arm2 = $4; $arm2 = $2 if $4 eq ''; # it is not necessary to repeat the arm [p|q] $band2 = $6; $band2 =~ tr/\.//d; #find the correct order #print STDERR "-|$&|----2|$2|-----3|$band|---4|$4|--------arm2|$arm2|-------------\n"; if ($band ne '' and (defined $arm2 and $2 ne $arm2 and $arm2 eq 'q') ) { $lc = 'start'; $lcchar = '9'; $uc = 'end'; $ucchar = '9'; } elsif ($band ne 'ter' and $2 ne $arm2 and $arm2 eq 'p') { $lc = 'end'; $lcchar = '9'; $uc = 'start'; $ucchar = '9'; } elsif ($band eq 'ter' and $arm2 eq 'p') { $uc = 'start'; $ucchar = '9'; } # $2 eq $arm2 elsif ($arm2 eq 'q') { if (_pad($band, 5, '0') < _pad($band2, 5, '0')) { $lc = 'start'; $lcchar = '0'; $uc = 'end'; $ucchar = '9'; } else { $lc = 'end'; $lcchar = '9'; $uc = 'start'; $ucchar = '0'; } } elsif ($arm2 eq 'p') { if (_pad($band, 5, '0') < _pad($band2, 5, '0')) { $lc = 'end'; $lcchar = '0'; $uc = 'start'; $ucchar = '9'; } else { $lc = 'start'; $lcchar = '9'; $uc = 'end'; $ucchar = '0'; } } else { $self->throw("How did you end up here? $&"); } #print STDERR "-------$arm2--------$band2---------$ucchar--------------\n"; if ( (defined $arm2 and $arm2 eq 'p') or (defined $arm2 and $arm2 eq 'p') ) { $r->$uc(-(_pad($band2, 5, $ucchar)) + 100000 + $chr ); if (defined $3 and $3 eq 'ter') { $r->end(200000 + $chr); } elsif ($2 eq 'cen' or $2 eq 'qcen' or $2 eq 'pcen'){ $r->$lc(100000 + $chr); } elsif ($2 eq 'q') { $r->$lc(_pad($band, 5, $lcchar) + 100000 + $chr ); } else { $r->$lc(-(_pad($band, 5, $lcchar)) + 100000 + $chr ); } } else { #if:$arm2=q e.g. 9p22-q32 #print STDERR "-------$arm2--------$band2---------$ucchar--------------\n"; $r->$uc(_pad($band2, 5, $ucchar) + 100000 + $chr); if ($2 eq 'cen' or $2 eq 'pcen') { $r->$lc(100000 + $chr); } elsif ($2 eq 'p') { if ($3 eq 'ter') { $r->$lc(200000 + $chr); } else { $r->$lc(-(_pad($band, 5, $lcchar)) + 100000 + $chr); } } else { #$2.==q $r->$lc(_pad($band, 5, $lcchar) + 100000 + $chr); } } } # # e.g. 10p22.1-cen # elsif (defined $4 and $4 ne '') { #print STDERR "$4-----$&----\n"; if ($4 eq 'cen' || $4 eq 'qcen' || $4 eq 'pcen') { # e.g. 10p22.1-cen; # '10pcen-qter' does not really make sense but lets have it in anyway $r->end(100000 + $chr); if ($2 eq 'p') { if ($3 eq 'ter') { $r->start($chr); } else { $r->start(_pad($band, 5, '9') + $chr); } } elsif ($2 eq 'cen') { $self->throw("'cen-cen' does not make sense: $&"); } else { $self->throw("Only order p-cen is valid: $&"); } } elsif ($4 eq 'qter' || $4 eq 'ter') { # e.g. 10p22.1-qter, 1p21-qter, 10pcen-qter, 7q34-qter $r->end(200000 + $chr); if ($2 eq 'p'){ $r->start(-(_pad($band, 5, '9')) + 100000 + $chr); #??? OK? } elsif ($2 eq 'q') { $r->start(_pad($band, 5, '0') + 100000 + $chr); } elsif ($2 eq 'cen' || $2 eq 'qcen' || $2 eq 'pcen' ) { $r->start(100000 + $chr); } } elsif ($4 eq 'pter' ) { #print STDERR "$2,$3--$4-----$&----\n"; $r->start( $chr); if ($2 eq 'p'){ $r->end(-(_pad($band, 5, '0')) + 100000 + $chr); } elsif ($2 eq 'q') { $r->end(_pad($band, 5, '9') + 100000 + $chr); } elsif ($2 eq 'cen' || $2 eq 'qcen' || $2 eq 'pcen' ) { $r->end(100000 + $chr); } } else { # -p or -q at the end of the range $self->throw("lone '$4' in $& does not make sense"); } } # # e.g 10p22.1, 10pter # elsif (defined $3 ) { if ($2 eq 'p') { if ($3 eq 'ter') { # e.g. 10pter $r = Bio::Range->new('-start' => $chr, '-end' => $chr, ); } else { # e.g 10p22.1 $r = Bio::Range->new('-start' => -(_pad($band, 5, '9')) + 100000 + $chr, '-end' => -(_pad($band, 5, '0')) + 100000 + $chr, ); } } elsif ($2 eq 'q') { if ($3 eq 'ter') { # e.g. 10qter $r = Bio::Range->new('-start' => 200000 + $chr, '-end' => 200000 + $chr, ); } else { # e.g 10q22.1 $r = Bio::Range->new('-start' => _pad($band, 5, '0') + 100000 + $chr, '-end' => _pad($band, 5, '9') + 100000 + $chr, ); } } else { # e.g. 10qcen1.1 ! $self->throw("'cen' in $& does not make sense"); } } # # e.g. 10p # elsif (defined $2 ) { # e.g. 10p if ($2 eq 'p' ) { $r = Bio::Range->new('-start' => $chr, '-end' => 100000 + $chr ); } elsif ($2 eq 'q' ) { $r = Bio::Range->new('-start' => 100000 + $chr, '-end' => 200000 + $chr ); } else { # $2 eq 'cen' || 'qcen' $r = Bio::Range->new('-start' => 100000 + $chr, '-end' => 100000 + $chr ); } } # # chr only, e.g. X # else { $r = Bio::Range->new('-start' => $chr, '-end' => 200000 + $chr ); } if ($r) { $self->start($r->start); $self->end($r->end); } return $r; } sub _pad { my ($string, $len, $pad_char) = @_; __PACKAGE__->throw("function _pad needs a positive integer length, not [$len]") unless $len =~ /^\+?\d+$/; __PACKAGE__->throw("function _pad needs a single character pad_char, not [$pad_char]") unless length $pad_char == 1; $string ||= ''; return $string . $pad_char x ( $len - length( $string ) ); } =head2 range2value Title : range2value Usage : my $value = $obj->range2value($range); Function: Sets and returns the value string based on start and end values of the Bio::Range object passes as an argument. Returns : string or false Args : Bio::Range object =cut sub range2value { my ($self,$value) = @_; if( defined $value) { if( ! $value->isa('Bio::Range') ) { $self->throw("Is not a Bio::Range object but a [$value]"); return; } if( ! $value->start ) { $self->throw("Start is not defined in [$value]"); return; } if( ! $value->end ) { $self->throw("End is not defined in [$value]"); return; } if( $value->start < 100000 ) { $self->throw("Start value has to be in millions, not ". $value->start); return; } if( $value->end < 100000 ) { $self->throw("End value has to be in millions, not ". $value->end); return; } my ($chr, $arm, $band) = $value->start =~ /(\d+)(\d)(\d{5})/; my ($chr2, $arm2, $band2) = $value->end =~ /(\d+)(\d)(\d{5})/; my ($chrS, $armS, $bandS, $arm2S, $band2S, $sep) = ('', '', '', '', '', '' ); LOC: { # # chromosome # if ($chr == 100) { $chrS = 'X'; } elsif ($chr == 100) { $chrS = 'Y'; } else { $chrS = $chr; } last LOC if $arm == 0 and $arm2 == 2 and $band == 0 and $band2 == 0 ; # # arm # if ($arm == $arm2 ) { if ($arm == 0) { $armS = 'p'; #$armS = 'pter' if $band == 0 and $band2 == 0; $bandS = 'ter' if $band == 0; #$arm2S = 'p'; #? } elsif ($arm == 2) { $armS = 'q'; $bandS = 'ter' if $band == 0; } else { $armS = 'q'; #$arm2S = 'q'; #? $armS = 'cen', if $band == 0;# and $band2 == 0; } } else { if ($arm == 0) { $armS = 'p'; $arm2S = 'q'; $arm2S = '' if $band == 0 and $band2 == 0; } else { $armS = 'q'; $arm2S = 'p'; $arm2S = '' if $arm2 == 2 and $band == 0 and $band2 == 0; } } last LOC if $band == $band2 ; my $c; # # first band (ter is hadled with the arm) # if ($bandS ne 'ter') { if ($armS eq 'p') { $band = 100000 - $band; $c = '9'; } else { $c = '0'; } $band =~ s/$c+$//; $bandS = $band; $bandS = substr($band, 0, 2). '.'. substr($band, 2) if length $band > 2; } last LOC unless $band2; # # second band # if ($arm2 == 0) { $arm2S = 'p'; $band2 = 100000 - $band2; $c = '0'; } else { # 1 or 2 $arm2S = 'q'; $c = '9'; } if ($band2 == 0) { if ($arm2 == 1) { $arm2S = 'p'; $band2S = 'cen'; } else { $band2S = 'ter'; } last LOC; } last LOC if $band eq $band2 and $arm == $arm2; $band2 =~ s/$c+$//; $band2S = $band2; $band2S = substr($band2, 0, 2). '.'. substr($band2, 2) if length $band2 > 2; } # end of LOC: if ($armS eq 'p' and $arm2S eq 'p') { my $tmp = $band2S; $band2S = $bandS; $bandS = $tmp; } $band2S = '' if $bandS eq $band2S ; $armS = '' if $bandS eq 'cen'; $arm2S = '' if $armS eq $arm2S and $band2S ne 'ter'; $sep = '-' if $arm2S || $band2S; $self->value( $chrS. $armS. $bandS. $sep. $arm2S. $band2S); } return $self->value; } =head2 value Title : value Usage : my $pos = $position->value; Function: Get/Set the value for this postion Returns : scalar, value Args : none to get, OR scalar to set =cut sub value { my ($self,$value) = @_; if( defined $value ) { $self->{'_value'} = $value; $self->cytorange; } return $self->{'_value'}; } =head2 numeric Title : numeric Usage : my $num = $position->numeric; Function: Read-only method that is guarantied to return a numeric representation of the start of this position. Returns : int (the start of the range) Args : optional Bio::RangeI object =cut sub numeric { my $self = shift; return $self->start(@_); } =head2 chr Title : chr Usage : my $mychr = $position->chr(); Function: Get/Set method for the chromosome string of the location. Returns : chromosome value Args : none to get, OR scalar to set =cut sub chr { my ($self,$chr) = @_; if( defined $chr ) { $self->{'_chr'} = $chr; } return $self->{'_chr'}; } 1; BioPerl-1.6.923/Bio/Map/EntityI.pm000555000765000024 510012254227314 16606 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::EntityI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::EntityI - An Entity Interface =head1 SYNOPSIS # do not use this module directly =head1 DESCRIPTION This interface describes the basic methods required for entities. An Entity is a kind of Bio::Map object that holds instance-specific data but relies on registering itself with a PositionHandler to handle its relationships with other entities. These relationships between objects are based around shared Positions, so Bio::Map::PositionI objects are a special kind of EntityI, along with Bio::Map::MappableI and Bio::Map::MapI objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::EntityI; use strict; use base qw(Bio::Root::RootI); =head2 get_position_handler Title : get_position_handler Usage : my $position_handler = $entity->get_position_handler(); Function: Gets a PositionHandlerI that $entity is registered with. Returns : Bio::Map::PositionHandlerI object Args : none =cut sub get_position_handler { my $self = shift; $self->throw_not_implemented(); } =head2 PositionHandlerI-based methods Any methods related to interation with other entities should be implemented as a call to the PositionHandler =cut 1; BioPerl-1.6.923/Bio/Map/FPCMarker.pm000444000765000024 2600212254227317 17017 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::fpcmarker # # Please direct questions and support issues to # # Cared for by Gaurav Gupta # # Copyright Gaurav Gupta # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::FPCMarker - An central map object representing a marker =head1 SYNOPSIS # get the marker object of $marker from the Bio::Map::FPCMarker my $markerobj = $physical->get_markerobj($marker); # acquire all the clones that hit this marker foreach my $clone ($markerobj->each_cloneid()) { print " +++$clone\n"; } # find the position of this marker in $contig print "Position in contig $contig"," = ",$markerobj->position($contig), "\n"; # find the group of the marker print "Group : ",$markerobj->group(); See L and L for more information. =head1 DESCRIPTION This object handles the notion of a marker. This object is intended to be used by a map parser like fpc.pm. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Gaurav Gupta Email gaurav@genome.arizona.edu =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk =head1 PROJECT LEADERS Jamie Hatfield jamie@genome.arizona.edu Dr. Cari Soderlund cari@genome.arizona.edu =head1 PROJECT DESCRIPTION The project was done in Arizona Genomics Computational Laboratory (AGCoL) at University of Arizona. This work was funded by USDA-IFAFS grant #11180 titled "Web Resources for the Computation and Display of Physical Mapping Data". For more information on this project, please refer: http://www.genome.arizona.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::FPCMarker; use strict; use Bio::Map::Position; use Time::Local; use base qw(Bio::Root::Root Bio::Map::MappableI); =head2 new Title : new Usage : my $clone = Bio::Map::FPCMarker->new ( -name => $marker, -type => $type, -global => $global, -frame => $frame, -group => $group, -subgroup=> $subgroup, -anchor => $anchor, -clones => \%clones, -contigs => \%contigs, -position => \%markerpos, -remark => $remark ); Function: Initialize a new Bio::Map::FPCMarker object Most people will not use this directly but get Markers through L Returns : L object Args : -name => marker name string, -type => type string, -global => global position for marker, -frame => boolean if marker is framework or placement, -group => group number for marker, -subgroup => subgroup number of marker, -anchor => boolean if marker is anchored, -clones => all the clone elements in map (hashref), -contigs => all the contig elements (hasref), -position => mapping of marker names to map position (hasref), -remark => remarks, separated by newlines =cut sub new { my ($class,@args) = @_; my $self= $class->SUPER::new(@args); my ($name,$type,$global,$frame,$group, $subgroup, $anchor, $clones,$contigs, $positions, $remark) = $self->_rearrange([qw(NAME TYPE GLOBAL FRAME GROUP SUBGROUP ANCHOR CLONES CONTIGS POSITIONS REMARK)],@args); $self->name($name) if defined $name; $self->type($type) if defined $type; $self->global($global) if defined $global; $self->group($group) if defined $group; $self->subgroup($group) if defined $subgroup; $self->anchor($anchor) if defined $anchor; $self->remark($remark) if defined $remark; $self->set_clones($clones) if defined $clones; $self->set_contigs($contigs) if defined $contigs; $self->set_positions($positions) if defined $positions; return $self; } =head1 Access Methods These methods let you get and set the member variables =head2 name Title : name Usage : my $name = $markerobj->name(); Function: Get/set the name for this marker Returns : scalar representing the current name of this marker Args : none to get, OR string to set =cut sub name { my ($self) = shift; return $self->{'_name'} = shift if @_; return $self->{'_name'}; } =head2 type Title : type Usage : my $type = $markerobj->type(); Function: Get/set the type for this marker Returns : scalar representing the current type of this marker Args : none to get, OR string to set =cut sub type { my ($self) = shift; return $self->{'_type'} = shift if @_; return $self->{'_type'}; } =head2 global Title : global Usage : my $type = $markerobj->global(); Function: Get/set the global position for this marker Returns : scalar representing the current global position of this marker Args : none to get, OR string to set =cut sub global { my ($self) = shift; return $self->{'_global'} = shift if @_; return $self->{'_global'}; } =head2 anchor Title : anchor Usage : my $anchor = $markerobj->anchor(); Function: indicate if the Marker is anchored or not (True | False) Returns : scalar representing the anchor (1 | 0) for this marker Args : none to get, OR 1|0 to set =cut sub anchor { my ($self) = shift; return $self->{'_anchor'} = shift if @_; return $self->{'_anchor'}; } =head2 framework Title : framework Usage : $frame = $markerobj->framework(); Function: indicate if the Marker is framework or placement (1 | 0) Returns : scalar representing if the marker is framework (1 if framework, 0 if placement) Args : none to get, OR 1|0 to set =cut sub framework { my ($self) = shift; return $self->{'_frame'} = shift if @_; return $self->{'_frame'}; } =head2 group Title : group Usage : $grpno = $markerobj->group(); Function: Get/set the group number for this marker. This is a generic term, used for Linkage-Groups as well as for Chromosomes. Returns : scalar representing the group number of this marker Args : none to get, OR string to set =cut sub group { my ($self) = shift; $self->{'_group'} = shift if @_; return $self->{'_group'} || 0; } =head2 subgroup Title : subgroup Usage : $subgroup = $marker->subgroup(); Function: Get/set the subgroup for this marker. This is a generic term: subgroup here could represent subgroup of a Chromosome or of a Linkage Group. The user must take care of which subgroup he/she is querying for. Returns : scalar representing the subgroup of this marker Args : none to get, OR string to set =cut sub subgroup { my ($self) = shift; $self->{'_subgroup'} = shift if @_; return $self->{'_subgroup'} || 0; } =head2 position Title : position Usage : $markerpos = $markerobj->position($ctg); Function: get the position of the marker in the contig Returns : scalar representing the position of the markernumber of the contig Args : $ctg is necessary to look for the position of the marker in that contig. *** This has nothing to do with an actual Bio::Map::PositionI object *** =cut sub position { my ($self,$ctg) = @_; return 0 unless defined $ctg; return 0 unless( defined $self->{'_position'} && defined $self->{'_position'}{$ctg}); return $self->{'_position'}{$ctg}; } =head2 remark Title : remark Usage : $markerremark = $markerobj->remark(); Function: get the remarks for this marker Returns : scalar of newline-separated markers Args : none =cut sub remark { my ($self) = shift; return $self->{'_remark'} = shift if @_; return $self->{'_remark'}; } =head2 each_cloneid Title : each_cloneid Usage : my @clones = $map->each_cloneid(); Function: retrieves all the clone ids in a map unordered Returns : list of strings (ids) Args : none *** This only supplies the ids set with the set_clones method *** *** It has nothing to do with actual Bio::Map::MappableI objects *** =cut sub each_cloneid { my ($self) = @_; return $self->_each_element('clones'); } =head2 each_contigid Title : each_contigid Usage : my @contigs = $map->each_contigid(); Function: retrieves all the contig ids in a map unordered Returns : list of strings (ids) Args : none *** This only supplies the ids set with the set_contigs method *** *** It has nothing to do with actual Bio::Map::MapI objects *** =cut sub each_contigid { my ($self) = @_; return $self->_each_element('contigs'); } sub _each_element{ my ($self, $type) = @_; $type = 'clones' unless defined $type; $type = lc("_$type"); return keys %{$self->{$type} || {}}; } =head2 set_clones Title : set_clones Usage : $marker->set_clones(\%clones) Function: Set the clone ids hashref Returns : None Args : Hashref of clone ids *** This only sets a hash of ids *** *** It has nothing to do with actual Bio::Map::MappableI objects *** =cut sub set_clones{ my ($self,$clones) = @_; if( defined $clones && ref($clones) =~ /HASH/ ) { $self->{'_clones'} = $clones; } } =head2 set_contigs Title : set_contigs Usage : $marker->set_contigs(\%contigs) Function: Set the contig ids hashref Returns : None Args : Hashref of contig ids *** This only sets a hash of ids *** *** It has nothing to do with actual Bio::Map::MapI objects *** =cut sub set_contigs{ my ($self,$contigs) = @_; if( defined $contigs && ref($contigs) =~ /HASH/ ) { $self->{'_contigs'} = $contigs; } } =head2 set_positions Title : set_positions Usage : $marker->set_positions(\%markerpos) Function: Set the positions hashref Returns : None Args : Hashref of marker positions *** This only sets a hash of numbers *** *** It has nothing to do with actual Bio::Map::PositionI objects *** =cut sub set_positions{ my ($self,$pos) = @_; if( defined $pos && ref($pos) =~ /HASH/ ) { $self->{'_positions'} = $pos; } } 1;BioPerl-1.6.923/Bio/Map/Gene.pm000555000765000024 10476612254227336 16165 0ustar00cjfieldsstaff000000000000# $Id: Gene.pm,v 1.6 2006/07/17 14:16:53 sendu Exp $ # # BioPerl module for Bio::Map::Gene # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Gene - An gene modelled as a mappable element. =head1 SYNOPSIS use Bio::Map::Gene; my $gene = Bio::Map::Gene->get(-universal_name => 'BRCA2', -description => 'breast cancer 2, early onset'); # Normally you get Gene objects from GeneMaps use Bio::Map::GeneMap; # Model a gene with its orthologous versions found in different species, # but at abstract locations within each genome my $map1 = Bio::Map::GeneMap->get(-universal_name => 'BRCA2', -species => $human); my $map2 = Bio::Map::GeneMap->get(-universal_name => 'BRCA2', -species => $mouse); $gene = $map1->gene; # Genes can have special kinds of positions (Bio::Map::GenePosition) that # define where various sub-regions of the gene are, relative to one of the # normal Positions the gene has placing it on a map. my $trans = Bio::Map::GenePosition->new(-start => 0, -length => 700, -map => $map1, -type => 'transcript'); $gene->add_transcript_position($trans); my $exon = Bio::Map::GenePosition->new(-start => 0, -length => 100, -map => $map1, -type => 'exon'); $gene->add_exon_position($exon, 1); # (so now the gene has 1 transcript 700bp long which starts at the beginning # of the gene, and we've defined the first of many exons which starts at the # start of the transcript and is 100bp long) =head1 DESCRIPTION Model a gene as an abstract mappable element. This is for when you don't care exactly where a gene is in a genome, but just want to model other things (like transcription factor binding sites) that are near it so you can answer questions like "what binds near this gene?", or "which genes does this bind near?". See t/Map/Map.t for more example usage. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Gene; use strict; use Bio::Map::GenePosition; use base qw(Bio::Map::Mappable); our $USE_ENSEMBL; our $GENES = {}; our $SET_FROM_DB = 0; BEGIN { # Bio::Tools::Run::Ensembl is in bioperl-run package which may not be # installed, but its functionality is only optional here eval {require Bio::Tools::Run::Ensembl;}; $USE_ENSEMBL = ! $@; } =head2 new Title : new Usage : my $gene = Bio::Map::Gene->new(); Function: Builds a new Bio::Map::Gene object Returns : Bio::Map::Gene Args : -universal_name => string : name of the gene (in a form common to all species that have the gene, but unique amongst non-orthologous genes), REQUIRED -description => string : free text description of the gene =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($u_name, $desc) = $self->_rearrange([qw(UNIVERSAL_NAME DESCRIPTION)], @args); $u_name || $self->throw("You must supply a -universal_name"); $self->universal_name($u_name); defined $desc && $self->description($desc); return $self; } =head2 get Title : get Usage : my $gene = Bio::Map::Gene->get(); Function: Builds a new Bio::Map::Gene object (like new()), or gets a pre-existing one that shares the same universal_name. Returns : Bio::Map::Gene Args : -universal_name => string, name of the gene (in a form common to all species that have the gene, but unique amongst non-orthologous genes), REQUIRED -description => string, free text description of the gene =cut sub get { my ($class, @args) = @_; my ($u_name, $desc) = Bio::Root::Root->_rearrange([qw(UNIVERSAL_NAME DESCRIPTION)], @args); if ($u_name && defined $GENES->{$u_name}) { $GENES->{$u_name}->description($desc) if $desc; return $GENES->{$u_name}; } return $class->new(@args); } =head2 universal_name Title : universal_name Usage : my $name = $gene->universal_name Function: Get/Set Mappable name, corresponding to the name of the gene in a form shared by orthologous versions of the gene in different species, but otherwise unique. Returns : string Args : none to get, OR string to set =cut sub universal_name { my ($self, $value) = @_; if (defined $value) { delete $GENES->{$self->{'_uname'}} if $self->{'_uname'}; $self->{'_uname'} = $value; $GENES->{$value} = $self; } return $self->{'_uname'}; } =head2 description Title : description Usage : my $description = $gene->description(); $gene->description($description); Function: Get/set information relating to the gene, in this case the description (eg. 'full name of gene') Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub description { my $self = shift; return $self->_gene_data('description', @_); } =head2 display_id Title : display_id Usage : my $display_id = $gene->display_id(); $gene->display_id($display_id); Function: Get/set information relating to the gene, in this case the display_id (eg. 'ENSG00000155287') Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub display_id { my $self = shift; return $self->_gene_data('display_id', @_); } =head2 display_xref Title : display_xref Usage : my $display_xref = $gene->display_xref(); $gene->display_xref($display_xref); Function: Get/set information relating to the gene, in this case the display_xref (eg. 'HUGO:23472'). Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub display_xref { my $self = shift; return $self->_gene_data('display_xref', @_); } =head2 external_db Title : external_db Usage : my $external_db = $gene->external_db(); $gene->external_db($external_db); Function: Get/set information relating to the gene, in this case the external_db (eg. 'HUGO'). Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub external_db { my $self = shift; return $self->_gene_data('external_db', @_); } =head2 external_name Title : external_name Usage : my $external_name = $gene->external_name(); $gene->external_name($external_name); Function: Get/set information relating to the gene, in this case the (eg. 'gene_name', probably the same as or similar to what you set universal_name() to, but could be a species-specific alternative). Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub external_name { my $self = shift; return $self->_gene_data('external_name', @_); } =head2 biotype Title : biotype Usage : my $biotype = $gene->biotype(); $gene->biotype($biotype); Function: Get/set information relating to the gene, in this case the biotype (eg. 'protein_coding'). Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub biotype { my $self = shift; return $self->_gene_data('biotype', @_); } =head2 source Title : source Usage : my $source = $gene->source(); $gene->source($source); Function: Get/set information relating to the gene, in this case the source (eg. '??'). Returns : string (empty string if not defined) Args : none to get general version, OR Bio::Map::GeneMap to get map-specific version. string to set general version, optionally AND Bio::Map::GeneMap to set map-specific version =cut sub source { my $self = shift; return $self->_gene_data('source', @_); } =head2 position Title : position Usage : my $position = $mappable->position($map); Function: Get the main Position of this Mappable on a given map. (A gene may have many positions on a map, but all but one of them are Bio::Map::GenePosition objects that describe sub-regions of the gene which are relative to the 'main' Bio::Map::Position position, which is the only one that is directly relative to the map - this is the Position returned by this method.) Returns : Bio::Map::Position Args : L object. =cut sub position { my ($self, $map) = @_; ($map && $self->in_map($map)) || return; foreach my $pos ($self->get_positions($map, 1)) { next if $pos->isa('Bio::Map::GenePosition'); return $pos; #*** could do sanity checking; there should only be 1 non-GenePosition # object here, and it should have a relative of type 'map', and it # should sort before or equal to all other positions } } =head2 add_transcript_position Title : add_transcript_position Usage : $gene->add_transcript_position($position); Function: Set the bounds of a transcript on a map (that of the supplied position). All transcript positions added this way must have coordinates relative to the main position of the 'gene' mappable on this transcript's map. The first position added using this method must have a start of 0. The supplied Position will be given a type of 'transcript' and relative of (gene => 0). The active_transcript for the Position's map will be set to this one. Returns : n/a Args : Bio::Map::GenePosition (which must have its map() defined, and be for a map this gene is on) =cut sub add_transcript_position { my ($self, $pos) = @_; ($pos && $pos->isa('Bio::Map::GenePosition')) || return; my $map = $pos->map || $self->throw("Supplied GenePosition has no map"); $self->in_map($map) || $self->throw("Supplied GenePosition is not on a map that this gene belong to"); my @transcripts = $self->get_transcript_positions($map); if (@transcripts == 0) { # first transcript needs start of 0 if ($pos->start != 0) { $self->warn("The first transcript position added to a map needs a start of 0, not adding"); return; } } $pos->type('transcript'); $pos->relative->gene(0); $self->SUPER::add_position($pos); # need to remember the order these were added, but remember what we store # here could become invalid if positions are purged outside of this class push(@{$self->{t_order}->{$map}}, $pos); # adjust main position's length to hold this transcript my $main_pos = $self->position($map); my $increase = ($pos->length + $pos->start($pos->absolute_relative)) - ($main_pos->end + 1); if ($increase > 0) { $main_pos->end($main_pos->end + $increase); } # make this new transcript the active one $self->active_transcript($map, scalar(@transcripts) + 1); } =head2 active_transcript Title : active_transcript Usage : my $active = $gene->active_transcript($map); $gene->active_transcript($map, $int); Function: Get/set the active transcript number (an int of 1 would mean the 1st transcript position added to the object for the given map, ie. would correspond to the the 1st Position object in the list returned by get_transcript_positions($map)). The active transcript is the one considered by other methods and objects when dealing with positions relative to 'the' transcript. Returns : int, 0 means there were no transcript positions on the given map, undef is some other problem Args : Just Bio::Map::GeneMap to get Bio::Map::GeneMap AND int to set =cut sub active_transcript { my ($self, $map, $int) = @_; $map or return; my @transcripts = $self->get_transcript_positions($map); if (@transcripts > 0) { if (defined($int)) { if ($int > 0 && $int <= @transcripts) { $self->{active_transcript}->{$map} = $int; return $int; } else { $self->warn("Supplied int '$int' not a good number (higher than the number of transcripts on the map?)"); return; } } else { if (defined $self->{active_transcript}->{$map}) { return $self->{active_transcript}->{$map}; } else { # default to the total number of transcripts on the map, ie. the # most recently added $self->{active_transcript}->{$map} = @transcripts; return $self->{active_transcript}->{$map}; } } } return 0; } =head2 get_transcript_positions Title : get_transcript_positions Usage : my @transcript_positions = $gene->get_transcript_positions($map); Function: Get all the transcript positions of this gene on the given map, in the order they were added to the map. Returns : list of Bio::Map::GenePosition Args : Bio::Map::GeneMap =cut sub get_transcript_positions { my ($self, $map) = @_; $map or return; $map->isa('Bio::Map::GeneMap') or return; return $self->_get_typed_positions($map, 'transcript'); } =head2 get_transcript_position Title : get_transcript_position Usage : my $position = $gene->get_transcript_position($map, $int); Function: Get the $int'th transcript position added to the map. If no transcripts have been added to the map, and the default transcript was requested, $gene->position is returned, as that will have the same start and end as the first transcript. Returns : Bio::Map::GenePosition Args : Bio::Map::GeneMap AND int (if int not supplied, or 0, returns the currently active transcript position) =cut sub get_transcript_position { my ($self, $map, $value) = @_; $map or return; $value ||= $self->active_transcript($map); my @transcripts = $self->get_transcript_positions($map); if (@transcripts == 0 && $value == 0) { return $self->position($map); } return $self->_get_list_element($value, @transcripts); } =head2 coding_position Title : coding_position Usage : $gene->coding_position($position, $transcript_number); $gene->coding_position($map, $transcript_number); Function: Get/set the bounds of a coding region of a given transcript on a map (that of the supplied position). When setting, coordinates must be relative to the transcript start. The supplied position will be given a type 'coding' and a relative (-transcript => $transcript_number). There can be only one coding position per transcript (hence this is a get/set). When getting, if a coding region has not been defined for the requested transcript, $gene->get_transcript_position($map, $transcript_number) is returned, as if assuming the entirety of the transcript is coding. Returns : Bio::Map::GenePosition Args : Bio::Map::GeneMap AND int (the transcript number) to get, OR to set: Bio::Map::GenePosition (which must have its map() defined, and be for a map this gene is on) AND int (the transcript number) In both cases, if transcript number not supplied or 0 this will be resolved to the current active transcript number - there must be at least one transcript on the map =cut sub coding_position { my ($self, $thing, $transcript_num) = @_; ref($thing) || return; $transcript_num ||= 0; # deliberate test for PositionI so _add_type_position can do nothing if # its not a GenePosition if ($thing->isa('Bio::Map::PositionI')) { my $map = $thing->map || return; my ($existing_pos) = $self->_get_typed_positions($map, 'coding', $transcript_num); if ($existing_pos) { # purge it $self->purge_positions($existing_pos); } $self->_add_type_position('coding', $thing, $transcript_num); $thing = $map; } my ($pos) = $self->_get_typed_positions($thing, 'coding', $transcript_num); return $pos || $self->get_transcript_position($thing, $transcript_num); } =head2 add_exon_position Title : add_exon_position Usage : $gene->add_exon_position($position, $transcript_number); Function: Set the bounds of an exon of a given transcript on a map (that of the supplied position). Coordinates must be relative to the transcript start. The supplied position will be given a type 'exon' and a relative (-transcript => $transcript_number). Returns : n/a Args : Bio::Map::GenePosition (which must have its map() defined, and be for a map this gene is on) AND int (the transcript number; if not supplied or 0 this will be resolved to the current active transcript number - there must be at least one transcript on the map) =cut sub add_exon_position { my $self = shift; $self->_add_type_position('exon', @_); } =head2 get_exon_positions Title : get_exon_positions Usage : my @positions = $gene->get_exon_positions($map, $int); Function: Get all the exon positions that are relative to the $int'th transcript position added to the map. Exons are returned sorted by their start positions. Returns : array of Bio::Map::GenePosition Args : Bio::Map::GeneMap AND int (the transcript number; if second int not supplied, or 0, considers the currently active transcript) =cut sub get_exon_positions { my ($self, $map, $value) = @_; $map || return; $value ||= 0; return $self->_get_typed_positions($map, 'exon', $value); } =head2 get_exon_position Title : get_exon_position Usage : my $position = $gene->get_exon_position($map, $exon_num, $int); Function: Get the $exon_num'th exon position that is relative to the $int'th transcript position added to the map. Exons are numbered in Position order, not the order they were added to the map. If no exons have been added to the map, and the first exon was requested, $gene->get_transcript_position($map, $int) is returned, as that will have the same start as the first exon, and could have the same end for a single exon gene. Returns : Bio::Map::GenePosition Args : Bio::Map::GeneMap AND int (the exon you want) AND int (the transcript number; if second int not supplied, or 0, considers the currently active transcript) =cut sub get_exon_position { my ($self, $map, $exon_num, $value) = @_; my @exons = $self->get_exon_positions($map, $value); if (@exons == 0 && $exon_num == 1) { return $self->get_transcript_position($map, $value); } return $self->_get_list_element($exon_num, @exons); } =head2 add_intron_position Title : add_intron_position Usage : $gene->add_intron_position($position, $transcript_number); Function: Set the bounds of an intron of a given transcript on a map (that of the supplied position). Coordinates must be relative to the transcript start. The supplied position will be given a type 'intron' and a relative (-transcript => $transcript_number). Returns : n/a Args : Bio::Map::GenePosition (which must have its map() defined, and be for a map this gene is on) AND int (the transcript number; if not supplied or 0 this will be resolved to the current active transcript number - there must be at least one transcript on the map) =cut sub add_intron_position { my $self = shift; $self->_add_type_position('intron', @_); } =head2 get_intron_positions Title : get_intron_positions Usage : my @positions = $gene->get_intron_positions($map, $int); Function: Get all the intron positions that are relative to the $int'th transcript position added to the map. Introns are returned sorted by their start positions. Returns : array of Bio::Map::GenePosition Args : Bio::Map::GeneMap AND int (the transcript number; if second int not supplied, or 0, considers the currently active transcript) =cut sub get_intron_positions { my ($self, $map, $value) = @_; $map || return; $value ||= 0; return $self->_get_typed_positions($map, 'intron', $value); } =head2 get_intron_position Title : get_intron_position Usage : my $position = $gene->get_intron_position($map, $intron_num, $int); Function: Get the $intron_num'th intron position that is relative to the $int'th transcript position added to the map. Introns are numbered in Position order, not the order they were added to the map. Returns : Bio::Map::GenePosition Args : Bio::Map::GeneMap AND int (the intron you want) AND int (the transcript number; if second int not supplied, or 0, considers the currently active transcript) =cut sub get_intron_position { my ($self, $map, $intron_num, $value) = @_; my @introns = $self->get_intron_positions($map, $value); return $self->_get_list_element($intron_num, @introns); } =head2 set_from_db Title : set_from_db Usage : $gene->set_from_db(); # for an instance only Bio::Map::Gene->set_from_db(); # decide that all future genes added # to maps will be set from db Function: Creates all the various types of positions (transcripts, coding, exons, introns) for this gene on all its maps. The information comes from an Ensembl database via Bio::Tools::Run::Ensembl. NB: will purge any existing Bio::Map::GenePosition objects that were previously on the maps this gene is one. Returns : undef on failure, otherwise the number of maps that successfully had positions added to them Args : boolean (no argument/undef is treated as 1, ie. do set from db; supply 0 to turn off) NB: Bio::Tools::Run::Ensembl is available in the bioperl-run package; see it for details on setting up a database to use. Once set, any new maps (species) this gene is added to will automatically also have their positions set_from_db =cut sub set_from_db { my ($self, $bool) = @_; return unless $USE_ENSEMBL; return unless Bio::Tools::Run::Ensembl->registry_setup(); defined($bool) || ($bool = 1); unless (ref($self)) { $SET_FROM_DB = $bool; return 0; } $self->{_set_from_db} = $bool; my $success = 0; foreach my $map ($self->known_maps) { $success += $self->_set_from_db($map); } return $success; } # set from db for a particular map (species) sub _set_from_db { my ($self, $map) = @_; my $gene_name = $self->universal_name || return 0; $SET_FROM_DB || $self->{_set_from_db} || return; my $species = $map->species; my $slice_adaptor = Bio::Tools::Run::Ensembl->get_adaptor($species, 'Slice') || return 0; my $gene = Bio::Tools::Run::Ensembl->get_gene_by_name(-species => $species, -name => $gene_name, -use_orthologues => 'Homo sapiens', -use_swiss_lookup => 1, -use_entrez_lookup => 1) || return 0; # attach species(map)-specific gene info to self $self->description($gene->description, $map); $self->display_id($gene->display_id, $map); $self->display_xref($gene->display_xref->display_id, $map); $self->external_db($gene->external_db, $map); $self->external_name($gene->external_name, $map); $self->biotype($gene->biotype, $map); $self->source($gene->source, $map); # get the transcripts for this map my $trans_ref = $gene->get_all_Transcripts; unless ($trans_ref && @{$trans_ref} > 0) { return 0; } # purge all existing GenePositions from the map my $handler = $map->get_position_handler(); foreach my $pos ($map->get_positions) { if ($pos->isa('Bio::Map::GenePosition')) { $handler->purge_positions($pos); } } # assume all transcripts on the same strand, sort them my $strand = ${$trans_ref}[0]->strand; my @transcripts = sort { $strand == -1 ? ($b->end <=> $a->end) : ($a->start <=> $b->start) } @{$trans_ref}; # store slice of first transcript so we can use it to get seq data, and # add chromosome info to our map if not set my $primary_slice = $slice_adaptor->fetch_by_transcript_stable_id($transcripts[0]->stable_id, 0); my $uid = $map->unique_id; @{$self->{_ensembl}->{$uid}} = ($slice_adaptor, $primary_slice, $strand); #my $cyto = $map->location || Bio::Map::CytoPosition->new(); #unless ($cyto->chr) { # $cyto->chr($primary_slice->seq_region_name); #} #$map->location($cyto); # adjustment needed to make all transcript coords relative to the start of # the first transcript which must start at 0 my $adjust = $strand == -1 ? $transcripts[0]->end : $transcripts[0]->start; my $orig_adjust = $adjust; my $adjustment = sub { return $strand == -1 ? $adjust - shift() : shift() - $adjust; }; # go through all the transcripts, remembering the longest my $longest_trans = 0; my $longest = 1; my $count = 1; foreach my $transcript (@transcripts) { # length is the total number of bases the exons cover, not genomic span my $length = $transcript->length(); if ($length > $longest_trans) { $longest_trans = $length; $longest = $count; } # make positions for this transcript my $slice = $slice_adaptor->fetch_by_transcript_stable_id($transcript->stable_id, 0); my $start = &$adjustment($slice->start()); my $end = &$adjustment($slice->end()); ($start, $end) = ($end, $start) if $start > $end; my $trans_pos = Bio::Map::GenePosition->new(-map => $map, -start => $start, -end => $end, -type => 'transcript'); $self->add_transcript_position($trans_pos); # all subsequent coordinates need to be relative to the start of this # transcript $adjust = $strand == -1 ? $slice->end : $slice->start; # there may not be a coding region if (defined($transcript->coding_region_start)) { my $atg = &$adjustment($transcript->coding_region_start()); my $stop = &$adjustment($transcript->coding_region_end()); ($atg, $stop) = ($stop, $atg) if $atg > $stop; my $cod_pos = Bio::Map::GenePosition->new(-map => $map, -start => $atg, -end => $stop, -type => 'coding'); $self->coding_position($cod_pos); } # exons foreach my $exon (@{$transcript->get_all_Exons}) { my $start = &$adjustment($exon->start()); my $end = &$adjustment($exon->end()); ($start, $end) = ($end, $start) if $start > $end; my $throw_species = ref($species) ? $species->scientific_name : $species; defined($end) || $self->throw("gene $gene_name in species $throw_species (".$gene->display_id.") had exon $start with no end"); my $pos = Bio::Map::GenePosition->new(-map => $map, -start => $start, -end => $end, -type => 'exon'); $self->add_exon_position($pos); } # introns foreach my $intron (@{$transcript->get_all_Introns}) { my $start = &$adjustment($intron->start()); my $end = &$adjustment($intron->end()); ($start, $end) = ($end, $start) if $start > $end; my $pos = Bio::Map::GenePosition->new(-map => $map, -start => $start, -end => $end, -type => 'intron'); $self->add_intron_position($pos); } $adjust = $orig_adjust; } continue { $count++ }; $self->active_transcript($map, $longest); return 1; } # get safely sorted positions of a certain type sub _get_typed_positions { my ($self, $map, $type, $transcript_number) = @_; if (defined $transcript_number && $transcript_number == 0) { $transcript_number = $self->active_transcript($map); } my @positions; foreach my $pos ($self->get_positions($map, 1)) { $pos->isa('Bio::Map::GenePosition') || next; $pos->type eq $type || next; if (defined $transcript_number) { my $rel = $pos->relative || next; $rel->type eq 'transcript' || next; my $rel_transcript_num = $rel->transcript || $self->active_transcript($map); $rel_transcript_num == $transcript_number || next; } push(@positions, $pos); } # avoid sorting using $pos->sortable since we would go infinite from the # call to absolute_conversion - we don't need absolute_conversion here # since we know the raw starts are all relative to the same thing, or in # the case of transcripts, we want them sorted in the way they were added if (defined $transcript_number) { # ensure we get raw start; ask for starts relative to the things # the positions are relative to. Precompute answer for efficiency my @sort = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_->start($_->relative), $_] } @positions; return @sort; } else { my @known_order = @{$self->{t_order}->{$map} || []}; @known_order || return; # transcripts might have been removed, so known_order could be invalid return @known_order if @known_order == @positions; #*** dangerous assumption? my %exists = map { $_ => $_ } @positions; my @new_order; foreach my $pos (@known_order) { exists $exists{$pos} || next; push(@new_order, $pos); } @{$self->{t_order}->{$map}} = @new_order; return @new_order; } } # get a certain element from an array, checking the array has that element sub _get_list_element { my ($self, $wanted, @list) = @_; ($wanted && $wanted > 0) || return; @list > 0 || return; my $index = $wanted - 1; if ($index >= 0 && $index <= $#list) { return $list[$index]; } return; } # add a certain type of posiiton sub _add_type_position { my ($self, $type, $pos, $transcript_num) = @_; ($pos && $pos->isa('Bio::Map::GenePosition')) || return; my $map = $pos->map || $self->throw("Supplied GenePosition has no map"); $self->in_map($map) || $self->throw("Supplied GenePosition is not on a map that this gene belong to"); $transcript_num ||= $self->active_transcript($map) || $self->throw("Asked to be relative to the active transcript, but there is no transcript"); # sanity check - must be within the transcript my $transcript_pos = $self->get_transcript_position($map, $transcript_num) || $self->throw("Asked to be relative to transcript $transcript_num, but there is no such transcript"); $transcript_pos->end || ($self->warn("no transcript pos end for pos for gene ".$self->universal_name." and species ".$pos->map->species."!") && exit); $pos->end || ($self->warn("no pos end for pos for gene ".$self->universal_name." and species ".$pos->map->species."!") && exit); unless ($transcript_pos->contains($pos)) { $self->warn("$type coordinates must lie within those of the transcript, not adding $type"); return; } $pos->type($type); $pos->relative->transcript($transcript_num); $self->SUPER::add_position($pos); } # get/setter for general/map-specific data sub _gene_data { my ($self, $type, $thing, $map) = @_; $thing or return ($self->{$type}->{general} || ''); if (ref($thing) && $thing->isa('Bio::Map::GeneMap')) { return $self->{$type}->{$thing} || ''; } if ($map && $map->isa('Bio::Map::GeneMap')) { $self->{$type}->{$map} = $thing; } else { $self->{$type}->{general} = $thing; } return $thing; } # for exclusive use by GeneMap so it can get sequence data sub _get_slice { my ($self, $map) = @_; $map || return; my $uid = $map->unique_id || return; if (defined $self->{_ensembl}->{$uid}) { return @{$self->{_ensembl}->{$uid}}; } return; } 1; BioPerl-1.6.923/Bio/Map/GeneMap.pm000444000765000024 5111512254227332 16561 0ustar00cjfieldsstaff000000000000# $Id: GeneMap.pm,v 1.17 2006/07/17 14:16:53 sendu Exp $ # # BioPerl module for Bio::Map::GeneMap # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::GeneMap - A MapI implementation to represent the area around a gene =head1 SYNOPSIS use Bio::Map::GeneMap; use Bio::Map::Gene; use Bio::Map::TranscriptionFactor; use Bio::Map::GeneRelative; # make some maps that will represent an area around a particular gene in # particular species (by default, the map represents the area in the genome # 1000bp upstream of the gene) my $map1 = Bio::Map::GeneMap->get(-gene => 'BRCA2', -species => 'human', -description => 'breast cancer 2, early onset'); my $map2 = Bio::Map::GeneMap->get(-gene => 'BRCA2', -species => 'mouse'); # model a TF that binds 500bp upstream of the BRCA2 gene in humans and # 250bp upstream of BRCA2 in mice my $rel = Bio::Map::GeneRelative->new(-description => "gene start"); my $tf = Bio::Map::TranscriptionFactor->get(-universal_name => 'tf1'); Bio::Map::Position->new(-map => $map1, -element => $tf, -start => -500, -length => 10, -relative => $rel); Bio::Map::Position->new(-map => $map2, -element => $tf, -start => -250, -length => 10, -relative => $rel); # find out all the things that map near BRCA2 in all species foreach my $map ($gene->known_maps) { foreach my $thing ($map->get_elements) { next if $thing eq $gene; foreach my $pos ($thing->get_positions($map)) { print "In species ", $map->species, ", ", $thing->universal_name, " maps at ", $pos->value, " relative to ", $pos->relative->description, " of gene ", $gene->universal_name, "\n"; } } } # a GeneMap isa PrimarySeq and so can have sequence associated with it $map1->seq('ATGC'); my $subseq = $map1->subseq(2,3); # TG =head1 DESCRIPTION Model the abstract notion of the area around a gene - you don't care exactly where this area is in the genome, you just want to be able to say "something binds upstream of gene X" and "something else binds 20bp upstream of the first something" etc. It's useful for modelling transcription factor bindings sites, letting you find out which transcription factors bind near a gene of interest, or which genes are bound by a transcription factor of interest. See t/Map/Map.t for more example usage. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::GeneMap; use strict; use Bio::Map::Gene; use Bio::Map::Position; use base qw(Bio::Map::SimpleMap Bio::PrimarySeq); our $GENEMAPS = {}; =head2 new Title : new Usage : my $obj = Bio::Map::GeneMap->new(); Function: Builds a new Bio::Map::GeneMap object (that has placed on it a mappable element (Bio::Map::Gene) representing a gene). Returns : Bio::Map::GeneMap Args : -gene => string name of the gene this map will be for (in a form common to all species that have the gene, but unique amongst non-orthologous genes) or a Bio::Map::Gene object, REQUIRED -species => Bio::Taxon or string representing species, REQUIRED -uid => string, unique identifier for this map (must be unique amongst all gene/species combinations) -description => string, free text description of the gene -upstream => int, the number of bases the map extends before the start of the gene element (default 1000). -downstream => int, the number of bases the map extends beyond the end of the gene element (default 0). -seq => string, the sequence of the map, presumably the genomic sequence -upstream bases of the gene, including the gene, and -downstream bases of the gene =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($uid, $gene, $species, $desc, $up, $down, $seq) = $self->_rearrange([qw(UID GENE SPECIES DESCRIPTION UPSTREAM DOWNSTREAM SEQ)], @args); unless (defined $gene && defined $species) { $self->throw("You must supply both -species and -gene"); } $self->gene(-gene => $gene, -description => $desc, -upstream => $up, -downstream => $down); $self->seq($seq) if $seq; unless (defined($uid)) { # trigger the special behaviour in our unique_id method by supplying it # the unique_id we got from our parent class $self->unique_id($self->unique_id); } return $self; } =head2 get Title : get Usage : my $map = Bio::Map::GeneMap->get(); Function: Builds a new Bio::Map::GeneMap object (like new()), or gets a pre-existing one that corresponds to your arguments. Returns : Bio::Map::GeneMap Args : -gene => string name of the gene this map will be for (in a form common to all species that have the gene, but unique amongst non-orthologous genes) or a Bio::Map::Gene object, REQUIRED -species => Bio::Taxon or string representing species, REQUIRED -uid => string, unique identifier for this map (must be unique amongst all gene/species combinations) -description => string, free text description of the gene -upstream => int, the number of bases the map extends before the start of the gene element (default 1000). -downstream => int, the number of bases the map extends beyond the end of the gene element (default 0). -seq => string, the sequence of the map, presumably the genomic sequence -upstream bases of the gene, including the gene, and -downstream bases of the gene If you supply a -uid, and a map had previously been created and given that uid, that same map object will be returned. Otherwise, the combination of -gene and -species will be used to determine if the same map had previously been made. If a corresponding map hadn't previously been made, a new map object will be created and returned. =cut sub get { my ($class, @args) = @_; my ($uid, $gene, $species, $desc, $up, $down, $seq) = Bio::Root::Root->_rearrange([qw(UID GENE SPECIES DESCRIPTION UPSTREAM DOWNSTREAM SEQ)], @args); my $gene_map; if ($uid && defined $GENEMAPS->{by_uid}->{$uid}) { $gene_map = $GENEMAPS->{by_uid}->{$uid}; } elsif ($gene && $species) { my $name = ref($gene) ? $gene->universal_name : $gene; if (defined $GENEMAPS->{by_ns}->{$name}->{$species}) { $gene_map = $GENEMAPS->{by_ns}->{$name}->{$species}; } } if ($gene_map) { $gene_map->gene->description($desc) if $desc; $gene_map->upstream($up) if defined($up); $gene_map->downstream($down) if defined($down); $gene_map->seq($seq) if $seq; return $gene_map; } return $class->new(@args); } =head2 unique_id Title : unique_id Usage : my $id = $map->unique_id; Function: Get/set the unique ID for this map Returns : string Args : none to get, OR string to set =cut sub unique_id { my ($self, $id) = @_; if (defined $id) { delete $GENEMAPS->{by_uid}->{$self->{'_uid'}}; $self->{'_uid'} = $id; $GENEMAPS->{by_uid}->{$id} = $self; } return $self->{'_uid'}; } =head2 species Title : species Usage : my $species = $map->species; Function: Get/set Species for a map. It is not recommended to change this once set. Returns : Bio::Taxon object or string Args : none to get, OR Bio::Taxon or string to set =cut sub species { my ($self, $value) = @_; if ($value) { my $old_species = $self->{_species}; $self->{'_species'} = $value; my $name = $self->universal_name || return $value; if ($old_species) { delete $GENEMAPS->{by_ns}->{$name}->{$old_species}; } $GENEMAPS->{by_ns}->{$name}->{$value} = $self; } return $self->{'_species'}; } =head2 type Title : type Usage : my $type = $map->type Function: Get Map type Returns : string 'gene' Args : none =cut sub type { return 'gene'; } =head2 gene Title : gene Usage : my $gene = $map->gene; $map->gene(-gene => $gene); Function: Get/set the mappable element on this map that represents the gene this map is for. Once set, it is not recommended to re-set the gene to something else. Behaviour in that case is undefined. Returns : Bio::Map::Gene Args : none to get, OR to set: -gene => Bio::Map::Gene or string of the universal name (see Bio::Map::Gene docs), REQUIRED -description => string, applied to the Bio::Map::Gene -upstream => int, the number of bases the map extends before the start of the gene element (default 1000). -downstream => int, the number of bases the map extends beyond the end of the gene element (default 0). =cut sub gene { my ($self, @args) = @_; if (@args > 0) { my ($gene, $desc, $up, $down) = $self->_rearrange([qw(GENE DESCRIPTION UPSTREAM DOWNSTREAM)], @args); $self->throw("You must supply -gene") unless $gene; my $gene_obj = ref($gene) ? $gene : Bio::Map::Gene->get(-universal_name => $gene, -description => $desc); if (defined $self->{gene}) { if ($self->{gene} ne $gene_obj) { $self->warn("Changing the gene that this map is for, which could be bad"); $self->purge_positions($self->{gene}); delete $GENEMAPS->{by_ns}->{$self->universal_name}->{$self->species}; $self->{gene} = $gene_obj; } # change the gene's position on us if necessary $self->upstream($up) if defined $up; $self->downstream($down) if defined $down; } else { # give the gene object a position on us $up ||= 1000; $up >= 0 || $self->throw("-upstream must be a positive integer"); Bio::Map::Position->new(-map => $self, -start => ($up + 1), -element => $gene_obj); $self->{gene} = $gene_obj; $self->downstream($down || 0); # set other gene positions from db if already user-requested $gene_obj->_set_from_db($self); } $GENEMAPS->{by_ns}->{$self->universal_name}->{$self->species} = $self; } return $self->{gene}; } =head2 universal_name Title : universal_name Usage : my $name = $map->universal_name Function: Get/set the name of Bio::Map::Gene object associated with this map. It is not recommended to change this once set. Returns : string Args : none to get, OR string to set =cut sub universal_name { my ($self, $value) = @_; $self->gene || return; if ($value) { my $species = $self->species; delete $GENEMAPS->{by_ns}->{$self->gene->universal_name}->{$species}; $self->gene->universal_name($value); $GENEMAPS->{by_ns}->{$value}->{$species} = $self; } return $self->gene->universal_name; } =head2 upstream Title : upstream Usage : my $distance = $map->upstream; $map->upstream($distance); Function: Get/set how long the map is before the start of the Bio::Map::Gene object on this map. Returns : int Args : none to get, OR int to set (the number of bases the map extends before the start of the gene) =cut sub upstream { my ($self, $value) = @_; my $pos = $self->gene->position($self); if (defined($value)) { $value >= 0 || $self->throw("Supplied value must be a positive integer"); $pos->start($value + 1); } return $pos->start - 1; } =head2 downstream Title : downstream Usage : my $distance = $map->downstream; $map->downstream($distance); Function: Get/set the nominal end of the map relative to the end of the Bio::Map::Gene object on this map. Returns : int Args : none to get, OR int to set (the number of bases the map extends beyond the end of the gene) =cut sub downstream { my $self = shift; if (@_) { $self->{_downstream} = shift } return $self->{_downstream} || 0; } =head2 length Title : length Usage : my $length = $map->length(); Function: Retrieves the length of the map. This is normally the length of the upstream region + length of the gene + length of the downstream region, but may be longer if positions have been placed on the map beyond the end of the nominal downstream region. Returns : int Args : none =cut sub length { my $self = shift; my $expected_length = $self->gene->position($self)->length + $self->upstream + $self->downstream; my $actual_length = $self->SUPER::length; return $actual_length > $expected_length ? $actual_length : $expected_length; } =head2 seq Title : seq Usage : $string = $obj->seq() Function: Get/set the sequence as a string of letters. When getting, If the GeneMap object didn't have sequence attached directly to it for the region requested, the map's gene's database will be asked for the sequence, and failing that, the map's gene's positions will be asked for their sequences. Areas for which no sequence could be found will be filled with Ns, unless no sequence was found anywhere, in which case undef is returned. Returns : string Args : Optionally on set the new value (a string). An optional second argument presets the alphabet (otherwise it will be guessed). =cut sub seq { my ($self, @args) = @_; my $seq = $self->SUPER::seq(@args); my $expected_length = $self->length; if (! $seq || CORE::length($seq) < $expected_length) { my @have = split('', $seq || ''); my @result; for (0..($expected_length - 1)) { $result[$_] = shift(@have) || 'N'; } # build map sequence by asking gene or positions my @slice_stuff = $self->gene->_get_slice($self); if (@slice_stuff) { my ($slice_adaptor, $slice, $strand) = @slice_stuff; my ($start, $end, $gene_start) = (CORE::length($seq || '') + 1, $expected_length, $self->upstream + 1); # convert map coords to genomic coords my $adjust = $strand == -1 ? $slice->end : $slice->start; my $adjustment = sub { return $strand == -1 ? $adjust - shift() : shift() + $adjust; }; my $converted_start = &$adjustment($start - $gene_start); my $converted_end = &$adjustment($end - $gene_start); ($converted_start, $converted_end) = ($converted_end, $converted_start) if $converted_start > $converted_end; # get sequence from a new slice of desired region #*** what happens if desired region starts or ends off end of chromo?... my $new_slice = $slice_adaptor->fetch_by_region($slice->coord_system_name, $slice->seq_region_name, $converted_start, $converted_end); if ($new_slice && (my $seq_str = $new_slice->seq)) { if ($strand == -1) { $seq_str = $self->_revcom($seq_str); } splice(@result, CORE::length($seq || ''), CORE::length($seq_str), split('', $seq_str)); } } else { foreach my $pos ($self->get_positions) { next unless $pos->can('seq'); my @pos_seq = split('', $pos->seq(undef, undef, 1) || next); for my $i ($pos->start($pos->absolute_relative)..$pos->end($pos->absolute_relative)) { $i--; my $base = shift(@pos_seq); if ($result[$i] eq 'N') { $result[$i] = $base; } } } } $seq = join('', @result); } return $seq; } =head2 subseq Title : subseq Usage : $substring = $obj->subseq(10, 40); Function: Returns the subseq from start to end, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. If the GeneMap object didn't have sequence attached directly to it for the region requested, the map's gene's database will be asked for the sequence, and failing that, the map's gene's positions will be asked for their sequences. Areas for which no sequence could be found will be filled with Ns, unless no sequence was found anywhere, in which case undef is returned. subseq requests that extend beyond the end of the map will throw. Returns : string Args : integer for start position AND integer for end position OR Bio::LocationI location for subseq (strand honored) OR Bio::RangeI (eg. a Bio::Map::PositionI) =cut sub subseq { my ($self, $start, $end) = @_; if ($start && ref($start) && $start->isa('Bio::RangeI')) { my $thing = $start; if ($start->isa('Bio::Map::Position')) { ($start, $end) = ($thing->start($thing->absolute_relative), $thing->end($thing->absolute_relative)); } else { ($start, $end) = ($thing->start, $thing->end); } } # *** this implementation potentially wastefull? Should duplicate code # from seq() to do this just for the desired region?? my $orig_seq = $self->{seq}; $self->{seq} = $self->seq(); my $subseq = $self->{seq} ? $self->SUPER::subseq($start, $end) : ''; $self->{seq} = $orig_seq; return $subseq; } # quick revcom for strings (silly to create a PrimarySeq just to revcom and then # return a string again) sub _revcom { my ($self, $seq) = @_; $seq or return; $seq = reverse($seq); $seq =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; return $seq; } 1; BioPerl-1.6.923/Bio/Map/GenePosition.pm000555000765000024 2130212254227325 17650 0ustar00cjfieldsstaff000000000000# $Id: GenePosition.pm,v 1.19 2006/09/20 10:20:01 sendu Exp $ # # BioPerl module for Bio::Map::GenePosition # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::GenePosition - A typed position, suitable for modelling the various regions of a gene. =head1 SYNOPSIS use Bio::Map::GenePosition; use Bio::Map::GeneMap; # say that the first transcript of a particular gene on a particular map # (species) is 1000bp long my $map = Bio::Map:GeneMap->get(-universal_name => 'BRCA2', -species => 'human'); my $gene = $map->gene; Bio::Map::GenePosition->new(-map => $map, -element => $gene, -start => 0, -length => 1000, -type => 'transcript'); # say that the coding region of the gene starts 30bp into the first # transcript Bio::Map::GenePosition->new(-map => $map, -element => $gene, -start => 30, -length => 600, -type => 'coding'); # A GenePosition isa PositionWithSequence, so can have sequence associated # with it my $exon = Bio::Map::GenePosition->new(-map => $map, -element => $gene, -start => 0, -type => 'exon', -seq => 'ATGGGGTGGG'); my $length = $exon->length; # $length is 10 =head1 DESCRIPTION Define where various sub-regions (transcripts, exons, introns etc.) of a gene are. Do this so that you can then go onto to model other mappable elements as having positions 20bp upstream of transcript 2, or 10bp into intron 3 etc., all without having to know the absolute position of anything. See Bio::Map::GeneRelative and t/Map/Map.t for more example usage. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::GenePosition; use strict; use Bio::Map::GeneRelative; use base qw(Bio::Map::PositionWithSequence); =head2 new Title : new Usage : my $obj = Bio::Map::GenePosition->new(); Function: Builds a new Bio::Map::GenePosition object Returns : Bio::Map::GenePosition Args : -map => Bio::Map::GeneMap object -element => Bio::Map::Gene object -relative => Bio::Map::GeneRelative object -type => 'transcript|coding|exon|intron', REQUIRED -seq => string, length of this string will set the length of this position's range * If this position has no range, or if a single value can describe the range * -value => scalar : something that describes the single point position or range of this Position, most likely an int * Or if this position has a range, at least two of * -start => int : value of the start co-ordinate -end => int : value of the end co-ordinate -length => int : length of the range =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($type) = $self->_rearrange([qw( TYPE )], @args); $type || $self->throw("type must be supplied"); $self->type($type); $self->{_relative_not_implicit} = 1; return $self; } =head2 map Title : map Usage : my $map = $position->map(); $position->map($map); Function: Get/set the map the position is in. Returns : L Args : none to get new L to set =cut sub map { my ($self, $map) = @_; if ($map) { $map->isa('Bio::Map::GeneMap') || $self->throw("This is [$map], not a Bio::Map::GeneMap"); } return $self->SUPER::map($map); } =head2 element Title : element Usage : my $element = $position->element(); $position->element($element); Function: Get/set the element the position is for. Returns : L Args : none to get new L to set =cut sub element { my ($self, $element) = @_; if ($element) { $element->isa('Bio::Map::Gene') || $self->throw("This is [$element], not a Bio::Map::Gene"); } return $self->SUPER::element($element); } =head2 type Title : type Usage : my $type = $position->type(); $position->type($type); Function: Get/set the type of this position. Returns : string Args : none to get, OR string transcript|coding|exon|intron to set =cut sub type { my $self = shift; if (@_) { my $type = shift; if ($type !~ /transcript|coding|exon|intron/i) { $self->throw("type must be supplied and be one of 'transcript', 'coding', 'exon', 'intron'"); } $self->{type} = $type; } return $self->{type}; } =head2 relative Title : relative Usage : my $relative = $position->relative(); $position->relative($relative); Function: Get/set the thing this Position's coordinates (numerical(), start(), end()) are relative to, as described by a RelativeI object. Returns : Bio::Map::GeneRelative. The default GeneRelative returned has a meaning that depends on the type() of GenePosition this is: 'transcript' : "relative to the start of the gene on the Position's map" 'coding|exon|intron' : "relative to the start of the default transcript of the gene on the Position's map" Args : none to get, OR Bio::Map::GeneRelative to set =cut sub relative { my ($self, $relative) = @_; if ($relative) { $self->throw("Must supply an object") unless ref($relative); $self->throw("This is [$relative], not a Bio::Map::GeneRelative") unless $relative->isa('Bio::Map::GeneRelative'); $self->{_relative} = $relative; } return $self->{_relative} || $self->_default_relative; } =head2 seq Title : seq Usage : my $string = $position->seq(); Function: Get/set the sequence as a string of letters. If no sequence is manually set by you, the position's map will be asked for the sequence, and if available, that will be returned. Returns : scalar Args : Optionally on set the new value (a string). An optional second argument presets the alphabet (otherwise it will be guessed). =cut sub seq { # $shortcut is internal-use only by GeneMap my ($self, $str, $alpha, $shortcut) = @_; my $seq = $self->SUPER::seq($str, $alpha); if ($seq) { $self->length(CORE::length($seq)); return $seq; } elsif (! $shortcut && defined(my $map = $self->map) && ! defined $self->{_getting_seq}) { $self->{_getting_seq} = 1; $seq = $map->subseq($self); delete $self->{_getting_seq}; return $seq; } return; } # return a Relative that is suitable for the type sub _default_relative { my $self = shift; my $type = $self->type; if ($type eq 'transcript') { return Bio::Map::GeneRelative->new(-gene => 0, -description => 'start of gene'); } else { return Bio::Map::GeneRelative->new(-transcript => 0, -description => 'start of default transcript'); } } 1; BioPerl-1.6.923/Bio/Map/GeneRelative.pm000555000765000024 2720212254227321 17620 0ustar00cjfieldsstaff000000000000# $Id: GeneRelative.pm,v 1.6 2006/09/20 11:53:29 sendu Exp $ # # BioPerl module for Bio::Map::GeneRelative # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::GeneRelative - Represents being relative to named sub-regions of a gene. =head1 SYNOPSIS use Bio::Map::GeneRelative; # say that a somthing will have a position relative to the start of the # gene on map my $rel = Bio::Map::GeneRelative->new(-gene => 0); # or that something will be relative to the third transcript of a gene # on a map $rel = Bio::Map::GeneRelative->new(-transcript => 3); # or to the 5th intron of the default transcript $rel = Bio::Map::GeneRelative->new(-intron => [0, 5]); # use the $rel as normal; see L =head1 DESCRIPTION Be able to say that a given position is relative to some standard part of a gene. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::GeneRelative; use strict; use Scalar::Util qw(looks_like_number); use base qw(Bio::Map::Relative); =head2 new Title : new Usage : my $relative = Bio::Map::Relative->new(); Function: Build a new Bio::Map::Relative object. Returns : Bio::Map::Relative object Args : -gene => int : coordinates are relative to the int'th base downstream of the Position's map's gene [default is gene => 0, ie. relative to the start of the gene], -transcript => int : or relative to the start of the int'th transcript of the Position's map's gene, -exon => [i, n] : or relative to the start of the n'th transcript's i'th exon, -intron => [i, n] : or intron, -coding => int : or the start of the int'th transcript's coding region. -description => string : Free text description of what this relative describes (To say a Position is relative to something and upstream of it, the Position's start() co-ordinate should be set negative) In all cases, a transcript number of 0 means the active transcript. =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($gene, $transcript, $exon, $intron, $coding) = $self->_rearrange([qw( GENE TRANSCRIPT EXON INTRON CODING )], @args); my $set = (defined $gene) + (defined $transcript) + (defined $exon) + (defined $intron) + (defined $coding); if ($set > 1) { $self->throw("-gene, -transcript, -exon, -intron and -coding are mutually exclusive"); } if ($exon && (! ref($exon) || ref($exon) ne 'ARRAY')) { $self->throw("-exon takes an array ref"); } if ($intron && (! ref($intron) || ref($intron) ne 'ARRAY')) { $self->throw("-intron takes an array ref"); } if ($set == 0) { # type could have been set already in the call to SUPER::new if ($self->type) { $self->warn("You set a type of relative not supported by GeneRelative; resetting to type 'gene'"); } $gene = 0; } $self->gene($gene) if defined $gene; $self->transcript($transcript) if defined $transcript; $self->exon(@{$exon}) if defined $exon; $self->intron(@{$intron}) if defined $intron; $self->coding($coding) if defined $coding; return $self; } =head2 absolute_conversion Title : absolute_conversion Usage : my $absolute_coord = $relative->absolute_conversion($pos); Function: Convert the start co-ordinate of the supplied position into a number relative to the start of its map. Returns : scalar number Args : Bio::Map::PositionI object =cut sub absolute_conversion { my ($self, $pos) = @_; $self->throw("Must supply an object") unless ref($pos); $self->throw("This is [$pos], not a Bio::Map::PositionI") unless $pos->isa('Bio::Map::PositionI'); # get the raw start position of our position my $raw = $pos->start($pos->relative); $self->throw("Can't convert co-ordinates when start isn't set") unless defined($raw); #*** needed? return undef? # what are we relative to? my $type = $self->type; my $value = $self->$type; $self->throw("Details not yet set for this Relative, cannot convert") unless defined($value); # get the absolute start of the thing we're relative to if ($type =~ /gene|transcript|exon|intron|coding/) { my $map = $pos->map; my $throw_desc = $type eq 'gene' ? 'gene' : "gene's transcript"; $self->throw("Relative to a map's $throw_desc, but the Position has no map") unless $map; $self->throw("Relative to a map's $throw_desc, but the Position's map isn't a Bio::Map::GeneMap") unless $map->isa('Bio::Map::GeneMap'); my $gene = $map->gene; if ($type eq 'gene') { my $gene_pos = $gene->position($map); my $rel = $gene_pos->relative; my $start = $rel->absolute_conversion($gene_pos); $value += $start; } else { my @values = ref($value) ? @{$value} : ($value); my $trans = ref($value) ? $values[1] : $value; my $throw_txt = $trans == 0 ? 'default/active transcript' : "transcript $trans"; my $throw_txt2 = ref($value) ? ", or no $type $values[0]" : ''; my $method = $type eq 'coding' ? 'coding_position' : "get_${type}_position"; $value = $gene->$method($map, @values) || $self->throw("Relative to $throw_txt of the map's gene, but there is no such transcript$throw_txt2"); } } else { return $self->SUPER::absolute_conversion($pos); } if (ref($value)) { # psuedo-recurse my $rel = $value->relative; $value = $rel->absolute_conversion($value); } if (defined($value)) { return $value + $raw; } return; } =head2 type Title : type Usage : my $type = $relative->type(); Function: Get the type of thing we are relative to. The types correspond to a method name, so the value of what we are relative to can subsequently be found by $value = $relative->$type; Note that type is set by the last method that was set, or during new(). Returns : 'gene', 'transcript', 'exon', 'intron' or 'coding' Args : none =cut =head2 gene Title : gene Usage : my $int = $relative->gene(); $relative->gene($int); Function: Get/set the distance from the start of the gene that the Position's co-ordiantes are relative to. Returns : int Args : none to get, OR int to set; a value of 0 means relative to the start of the gene. =cut sub gene { my ($self, $num) = @_; if (defined($num)) { $self->throw("This is [$num], not a number") unless looks_like_number($num); $self->{_use} = 'gene'; $self->{_gene} = $num; } return defined($self->{_gene}) ? $self->{_gene} : return; } =head2 transcript Title : transcript Usage : my $int = $relative->transcript(); $relative->transcript($int); Function: Get/set which transcript of the Position's map's gene the Position's co-ordinates are relative to. Returns : int Args : none to get, OR int to set; a value of 0 means the active (default) transcript. =cut sub transcript { my ($self, $num) = @_; if (defined($num)) { $self->throw("This is [$num], not a number") unless looks_like_number($num); $self->{_use} = 'transcript'; $self->{_transcript} = $num; } return defined($self->{_transcript}) ? $self->{_transcript} : return; } =head2 exon Title : exon Usage : my ($exon_number, $transcript_number) = @{$relative->exon()}; $relative->exon($exon_number, $transcript_number); Function: Get/set which exon of which transcript of the Position's map's gene the Position's co-ordinates are relative to. Returns : reference to list with two ints, exon number and transcript number Args : none to get, OR int (exon number) AND int (transcript number) to set. The second int is optional and defaults to 0 (meaning default/active transcript). =cut sub exon { my ($self, $num, $t_num) = @_; if (defined($num)) { if (defined($t_num)) { $self->throw("This is [$t_num], not a number") unless looks_like_number($t_num); } $t_num ||= 0; $self->throw("This is [$num], not a number") unless looks_like_number($num); $self->{_use} = 'exon'; $self->{_exon} = [$num, $t_num]; } return $self->{_exon} || return; } =head2 intron Title : intron Usage : my ($intron_number, $transcript_number) = @{$relative->intron()}; $relative->intron($intron_number, $transcript_number); Function: Get/set which intron of which transcript of the Position's map's gene the Position's co-ordinates are relative to. Returns : reference to list with two ints, intron number and transcript number Args : none to get, OR int (intron number) AND int (transcript number) to set. The second int is optional and defaults to 0 (meaning default/active transcript). =cut sub intron { my ($self, $num, $t_num) = @_; if (defined($num)) { if (defined($t_num)) { $self->throw("This is [$t_num], not a number") unless looks_like_number($t_num); } $t_num ||= 0; $self->throw("This is [$num], not a number") unless looks_like_number($num); $self->{_use} = 'intron'; $self->{_intron} = [$num, $t_num]; } return $self->{_intron} || return; } =head2 coding Title : coding Usage : my $transcript_number = $relative->coding; $relative->coding($transcript_number); Function: Get/set which transcript's coding region of the Position's map's gene the Position's co-ordinates are relative to. Returns : int Args : none to get, OR int to set (the transcript number, see transcript()) =cut sub coding { my ($self, $num) = @_; if (defined($num)) { $self->throw("This is [$num], not a number") unless looks_like_number($num); $self->{_use} = 'coding'; $self->{_coding} = $num; } return defined($self->{_coding}) ? $self->{_coding} : return; } 1; BioPerl-1.6.923/Bio/Map/LinkageMap.pm000444000765000024 1317512254227316 17263 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Map::LinkageMap # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::LinkageMap - A representation of a genetic linkage map. =head1 SYNOPSIS use Bio::Map::LinkageMap; # create a new map my $map = Bio::Map::LinkageMap->new(-name => 'Chads Superterriffic Map', -type => 'Linkage', -units=> 'cM'); # create the location of a marker for that map my $position = Bio::Map::LinkagePosition->new( -positions => 1, -distance => "22.3"); # create a marker and place it at that position my $marker = Bio::Map::Marker::Microsatellite->new( -name => 'SuuuperMarker', -position => $position); # place that marker on that map $map->add_element($marker); # done! =head1 DESCRIPTION This object describes the basic functionality of a genetic linkage map in Bioperl. Each 'position' can have one or more markers that map some number of units from the markers at the previous position. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Lincoln Stein lstein@cshl.org Heikki Lehvaslaiho heikki-at-bioperl-dot-org Jason Stajich jason@bioperl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::LinkageMap; use strict; use base qw(Bio::Map::SimpleMap); =head2 new Title : new Usage : my $linkage_map = Bio::Map::LinkageMap->new(); Function: Builds a new Bio::Map::LinkageMap object Returns : Bio::Map::LinkageMap Args : -name => the name of the map (string) [optional] -type => the type of this map (string, defaults to Linkage) [optional] -species => species for this map (Bio::Species) [optional] -units => the map units (string, defaults to cM) [optional] -elements=> elements to initialize with (arrayref of Bio::Map::MappableI objects) [optional] -uid => Unique ID of this map =cut =head2 length Title : length Usage : my $length = $map->length(); Function: Retrieves the length of the map. In the case of a LinkageMap, the length is the sum of all marker distances. Returns : An integer representing the length of this LinkageMap. Will return 0 if length is not calculateable Args : None. =cut sub length { my ($self) = @_; $self->throw("Not yet implemented correctly"); my $total_distance; foreach my $element (@{$self->get_elements}) { #*** there is no such method ->each_position_value! $total_distance += ($element->position->each_position_value($self))[0]; } return $total_distance; } =head2 add_element($marker) Title : add_element($marker) Usage : $map->add_element($marker) Function: Add a Bio::Map::MappableI object to the Map Returns : none Args : Bio::Map::MappableI object Notes : It is strongly recommended that you use a Bio::Map::LinkagePosition as the position in any Bio::Map::Mappable that you create to place on this map. Using some other Bio::Map::Position might work but might be unpredictable. N.B. I've added Bio::Map::OrderedPosition which should achieve similar things from LinkagePosition and will work for RH markers too. =cut #*** what is this? what calls it? note that it seems to be private sub _add_element_will_be_deleted { my ($self,$marker) = @_; my $o_position = $marker->position(); $self->debug( "marker position is ". $marker->position()); # print("add_element: \$o_position is $o_position\n"); # print("add_element: \$marker is $marker\n"); my $position; unless ( $o_position->isa('Bio::Map::LinkagePosition') || $o_position->isa('Bio::Map::OrderedPosition') ) { $self->warn("You really should use a Linkage Position for this object. This insures that there is only one position. Trying anyway..."); my @p = ( $o_position->each_position_value($self)); $position = shift @p; if( ! defined $position ) { $self->throw("This marker ($marker) does not have a position in this map ($self)"); } } else { $position = $o_position->order; } if ($self->{'_elements'}[$position]) { $self->warn("Replacing the marker in position $position because in a linkage map the position is a key."); } $self->{'_elements'}[$position] = $marker; } 1; BioPerl-1.6.923/Bio/Map/LinkagePosition.pm000444000765000024 562012254227333 20325 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Map::LinkagePosition # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::LinkagePosition - Create a Position for a Marker that will be placed on a Bio::Map::LinkageMap =head1 SYNOPSIS use Bio::Map::Position; my $position = Bio::Map::LinkagePosition->new(-positions => 1, -distance => 22.1 ); # can get listing of positions my @positions = $position->each_position; =head1 DESCRIPTION Position for a Bio::Map::MarkerI compliant object that will be placed on a Bio::Map::LinkageMap. See L and L for details =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Lincoln Stein, lstein@cshl.org Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Jason Stajich jason@bioperl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::LinkagePosition; use strict; use base qw(Bio::Map::OrderedPosition); =head2 new Title : new Usage : my $obj = Bio::Map::LinkagePosition->new(-positions => $position, -distance => $distance); Function: Builds a new Bio::Map::LinkagePosition object Returns : Bio::Map::LinkagePosition Args : -order => the relative order of this marker on a linkage map -positions => positions on a map =cut =head2 Bio::Map::PositionI methods =cut =head2 order Title : order Usage : $o_position->order($order) my $order = $o_position->order() Function: get/set the order position of this position in a map Returns : int Args : none to get, int to set =cut 1; BioPerl-1.6.923/Bio/Map/MapI.pm000444000765000024 2211512254227314 16071 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::MapI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::MapI - Interface for describing Map objects in bioperl =head1 SYNOPSIS # get a MapI somehow my $name = $map->name(); # string my $length = $map->length(); # integer my $species= $map->species; # Bio::Species my $type = $map->type(); # genetic/sts/rh/ =head1 DESCRIPTION This object describes the basic functionality of a Map in bioperl. Maps are anything from Genetic Map to Sequence Map to Assembly Map to Restriction Enzyme to FPC. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Lincoln Stein, lstein@cshl.org Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::MapI; use strict; use Bio::Map::PositionHandler; use base qw(Bio::Map::EntityI Bio::AnnotatableI); =head2 EntityI methods These are fundamental to coordination of Maps and other entities, so are implemented at the interface level =cut =head2 get_position_handler Title : get_position_handler Usage : my $position_handler = $entity->get_position_handler(); Function: Gets a PositionHandlerI that $entity is registered with. Returns : Bio::Map::PositionHandlerI object Args : none =cut sub get_position_handler { my $self = shift; unless (defined $self->{_eh}) { my $ph = Bio::Map::PositionHandler->new(-self => $self); $self->{_eh} = $ph; $ph->register; } return $self->{_eh}; } =head2 PositionHandlerI-related methods These are fundamental to coordination of Maps and other entities, so are implemented at the interface level =cut =head2 get_positions Title : get_positions Usage : my @positions = $mappable->get_positions(); Function: Get all the Positions on this Map (sorted). Returns : Array of L objects Args : none for all, OR L object for positions of the given Mappable =cut sub get_positions { my ($self, $mappable) = @_; my @positions = $self->get_position_handler->get_positions($mappable); # precompute sortable for effieciency and to avoid bugs @positions = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_->sortable, $_] } @positions; return @positions; } =head2 each_position Title : each_position Function: Synonym of the get_positions() method. Status : deprecated, will be removed in next version =cut *each_position = \&get_positions; =head2 purge_positions Title : purge_positions Usage : $map->purge_position(); Function: Remove all positions from this map. Notifies the positions they are no longer on this map. Returns : n/a Args : none to remove all positions, OR L object to remove just that Position, OR L object to remove only those positions of the given mappable =cut sub purge_positions { my ($self, $thing) = @_; $self->get_position_handler->purge_positions($thing); } =head2 get_elements Title : get_elements Usage : my @elements = $map->get_elements; Function: Retrieves all the elements on a map (unordered) Returns : Array of Map elements (L) Args : none =cut sub get_elements { my $self = shift; return $self->get_position_handler->get_other_entities; } =head2 each_element Title : each_element Function: Synonym of the get_elements() method. Status : deprecated, will be removed in the next version =cut =head2 common_elements Title : common_elements Usage : my @common_elements = $map->common_elements(\@other_maps); my @common_elements = Bio::Map::SimpleMap->common_elements(\@maps); Function: Find the elements that are common to multiple maps. Returns : array of Bio::Map::MappableI Args : arg #1 = L to compare this one to, or an array ref of such objects (mandatory) arg #2 = optionally, one or more of the key => value pairs below -min_num => int : the minimum number of input maps an element must be found on before before returned [default is 1] -min_percent => number : as above, but the minimum percentage of input maps [default is 100 - note that this will effectively override all other options] -require_self => 1|0 : require that all output elements at least be on the calling map [default is 1, has no effect when the second usage form is used] -required => \@maps : require that all output elements be on at least all the maps supplied here =cut sub common_elements { my ($self, $maps_ref, @extra_args) = @_; $self->throw("Must supply a reference first argument") unless ref($maps_ref); my @maps; if (ref($maps_ref) eq 'ARRAY') { @maps = @{$maps_ref}; } elsif ($maps_ref->isa('Bio::Map::MapI')) { @maps = ($maps_ref); } if (ref($self)) { unshift(@maps, $self); } $self->throw("Need at least 2 maps") unless @maps >= 2; my %args = (-min_num => 1, -min_percent => 100, -require_self => 1, -required => undef, @extra_args); my $min_num = $args{-min_num}; if ($args{-min_percent}) { my $mn = @maps / 100 * $args{-min_percent}; if ($mn > $min_num) { $min_num = $mn; } } my %required = map { $_ => 1 } $args{-required} ? @{$args{-required}} : (); $required{$self} = 1 if ref($self) && $args{-require_self}; my @required = keys %required; my %map_elements; my %elements; my %count; foreach my $map (@maps) { $map_elements{$map} = {}; foreach my $element ($map->get_elements) { $map_elements{$map}->{$element} = 1; $elements{$element} = $element; $count{$element}++; } } my @elements; ELEMENT: while (my ($key, $value) = each %elements) { $count{$key} >= $min_num or next; foreach my $required (@required) { exists $map_elements{$required}->{$key} or next ELEMENT; } push(@elements, $value); } return @elements; } =head2 MapI-specific methods =cut =head2 species Title : species Usage : my $species = $map->species; Function: Get/Set Species for a map Returns : L object Args : (optional) Bio::Species =cut sub species{ my $self = shift; $self->throw_not_implemented(); } =head2 units Title : units Usage : $map->units('cM'); Function: Get/Set units for a map Returns : units for a map Args : units for a map (string) =cut sub units{ my $self = shift; $self->throw_not_implemented(); } =head2 type Title : type Usage : my $type = $map->type Function: Get/Set Map type Returns : String coding map type Args : (optional) string =cut sub type { my $self = shift; $self->throw_not_implemented(); } =head2 name Title : name Usage : my $name = $map->name Function: Get/Set Map name Returns : Map name Args : (optional) string =cut sub name { my $self = shift; $self->throw_not_implemented(); } =head2 length Title : length Usage : my $length = $map->length(); Function: Retrieves the length of the map. It is possible for the length to be unknown for maps such as Restriction Enzyme, will return 0 in that case Returns : integer representing length of map in current units will return undef if length is not calculateable Args : none =cut sub length { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Map/Mappable.pm000555000765000024 6736312254227320 17002 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::Mappable # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Mappable - An object representing a generic map element that can have multiple locations in several maps. =head1 SYNOPSIS # a map element in two different positions on the same map $map1 = Bio::Map::SimpleMap->new(); $position1 = Bio::Map::Position->new(-map => $map1, -value => 100); $position2 = Bio::Map::Position->new(-map => $map1, -value => 200); $mappable = Bio::Map::Mappable->new(-positions => [$position1, $position2] ); # add another position on a different map $map2 = Bio::Map::SimpleMap->new(); $position3 = Bio::Map::Position->new(-map => $map2, $value => 50); $mappable->add_position($position3); # get all the places our map element is found, on a particular map of interest foreach $pos ($mappable->get_positions($map1)) { print $pos->value, "\n"; } =head1 DESCRIPTION This object handles the notion of a generic map element. Mappables are entities with one or more positions on one or more maps. This object is a pure perl implementation of L. That interface implements some of its own methods so check the docs there for those. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Mappable; use strict; use Bio::Map::Relative; use Bio::Map::Position; use base qw(Bio::Root::Root Bio::Map::MappableI); =head2 new Title : new Usage : my $mappable = Bio::Map::Mappable->new(); Function: Builds a new Bio::Map::Mappable object Returns : Bio::Map::Mappable Args : -name => string : name of the mappable element -id => string : id of the mappable element =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($name, $id) = $self->_rearrange([qw(NAME ID)], @args); $self->name($name) if $name; $self->id($id) if $id; return $self; } =head2 name Title : name Usage : $mappable->name($new_name); my $name = $mappable->name(); Function: Get/Set the name for this Mappable Returns : A scalar representing the current name of this Mappable Args : none to get string to set =cut sub name { my $self = shift; if (@_) { $self->{_name} = shift } return $self->{_name} || ''; } =head2 id Title : id Usage : my $id = $mappable->id(); $mappable->id($new_id); Function: Get/Set the id for this Mappable. Returns : A scalar representing the current id of this Mappable Args : none to get string to set =cut sub id { my $self = shift; if (@_) { $self->{_id} = shift } return $self->{_id} || return; } =head2 in_map Title : in_map Usage : if ($mappable->in_map($map)) {...} Function: Tests if this mappable is found on a specific map Returns : boolean Args : L =cut sub in_map { my ($self, $query_map) = @_; $self->throw("Must supply an argument") unless $query_map; $self->throw("This is [$query_map], not an object") unless ref($query_map); $self->throw("This is [$query_map], not a Bio::Map::MapI object") unless $query_map->isa('Bio::Map::MapI'); foreach my $map ($self->known_maps) { ($map eq $query_map) && return 1; } return 0; } =head2 Comparison methods =cut =head2 equals Title : equals Usage : if ($mappable->equals($other_mappable)) {...} my @equal_positions = $mappable->equals($other_mappable); Function: Finds the positions in this mappable that are equal to any comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative =cut sub equals { my $self = shift; return $self->_compare('equals', @_); } =head2 less_than Title : less_than Usage : if ($mappable->less_than($other_mappable)) {...} my @lesser_positions = $mappable->less_than($other_mappable); Function: Finds the positions in this mappable that are less than all comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative =cut sub less_than { my $self = shift; return $self->_compare('less_than', @_); } =head2 greater_than Title : greater_than Usage : if ($mappable->greater_than($other_mappable)) {...} my @greater_positions = $mappable->greater_than($other_mappable); Function: Finds the positions in this mappable that are greater than all comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative =cut sub greater_than { my $self = shift; return $self->_compare('greater_than', @_); } =head2 overlaps Title : overlaps Usage : if ($mappable->overlaps($other_mappable)) {...} my @overlapping_positions = $mappable->overlaps($other_mappable); Function: Finds the positions in this mappable that overlap with any comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative =cut sub overlaps { my $self = shift; return $self->_compare('overlaps', @_); } =head2 contains Title : contains Usage : if ($mappable->contains($other_mappable)) {...} my @container_positions = $mappable->contains($other_mappable); Function: Finds the positions in this mappable that contain any comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative =cut sub contains { my $self = shift; return $self->_compare('contains', @_); } =head2 overlapping_groups Title : overlapping_groups Usage : my @groups = $mappable->overlapping_groups($other_mappable); my @groups = Bio::Map::Mappable->overlapping_groups(\@mappables); Function: Look at all the positions of all the supplied mappables and group them according to overlap. Returns : array of array refs, each ref containing the Bio::Map::PositionI objects that overlap with each other Args : arg #1 = L OR L to compare this one to, or an array ref of such objects (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative -min_pos_num => int : the minimum number of positions that must be in a group before it will be returned [default is 1] -min_mappables_num => int : the minimum number of different mappables represented by the positions in a group before it will be returned [default is 1] -min_mappables_percent => number : as above, but the minimum percentage of input mappables [default is 0] -min_map_num => int : the minimum number of different maps represented by the positions in a group before it will be returned [default is 1] -min_map_percent => number : as above, but the minimum percentage of maps known by the input mappables [default is 0] -require_self => 1|0 : require that at least one of the calling object's positions be in each group [default is 1, has no effect when the second usage form is used] -required => \@mappables : require that at least one position for each mappable supplied in this array ref be in each group =cut sub overlapping_groups { my $self = shift; return $self->_compare('overlapping_groups', @_); } =head2 disconnected_intersections Title : disconnected_intersections Usage : @positions = $mappable->disconnected_intersections($other_mappable); @positions = Bio::Map::Mappable->disconnected_intersections(\@mappables); Function: Make the positions that are at the intersection of each group of overlapping positions, considering all the positions of the supplied mappables. Returns : new Bio::Map::Mappable who's positions on maps are the calculated disconnected unions Args : arg #1 = L OR L to compare this one to, or an array ref of such objects (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative -min_pos_num => int : the minimum number of positions that must be in a group before the intersection will be calculated and returned [default is 1] -min_mappables_num => int : the minimum number of different mappables represented by the positions in a group before the intersection will be calculated and returned [default is 1] -min_mappables_percent => number : as above, but the minimum percentage of input mappables [default is 0] -min_map_num => int : the minimum number of different maps represented by the positions in a group before the intersection will be calculated and returned [default is 1] -min_map_percent => number : as above, but the minimum percentage of maps known by the input mappables [default is 0] -require_self => 1|0 : require that at least one of the calling object's positions be in each group [default is 1, has no effect when the second usage form is used] -required => \@mappables : require that at least one position for each mappable supplied in this array ref be in each group =cut sub disconnected_intersections { my $self = shift; return $self->_compare('intersection', @_); } =head2 disconnected_unions Title : disconnected_unions Usage : my @positions = $mappable->disconnected_unions($other_mappable); my @positions = Bio::Map::Mappable->disconnected_unions(\@mappables); Function: Make the positions that are the union of each group of overlapping positions, considering all the positions of the supplied mappables. Returns : new Bio::Map::Mappable who's positions on maps are the calculated disconnected unions Args : arg #1 = L OR L to compare this one to, or an array ref of such objects (mandatory) arg #2 = optionally, one or more of the key => value pairs below -map => MapI : a Bio::Map::MapI to only consider positions on the given map -relative => RelativeI : a Bio::Map::RelativeI to calculate in terms of each Position's relative position to the thing described by that Relative -min_pos_num => int : the minimum number of positions that must be in a group before the union will be calculated and returned [default is 1] -min_mappables_num => int : the minimum number of different mappables represented by the positions in a group before the union will be calculated and returned [default is 1] -min_mappables_percent => number : as above, but the minimum percentage of input mappables [default is 0] -min_map_num => int : the minimum number of different maps represented by the positions in a group before the union will be calculated and returned [default is 1] -min_map_percent => number : as above, but the minimum percentage of maps known by the input mappables [default is 0] -require_self => 1|0 : require that at least one of the calling object's positions be in each group [default is 1, has no effect when the second usage form is used] -required => \@mappables : require that at least one position for each mappable supplied in this array ref be in each group =cut sub disconnected_unions { my $self = shift; return $self->_compare('union', @_); } # do a RangeI-related comparison by calling the corresponding PositionI method # on all the requested Positions of our Mappables sub _compare { my ($self, $method, $input, @extra_args) = @_; $self->throw("Must supply an object or array ref of them") unless ref($input); $self->throw("Wrong number of extra args (should be key => value pairs)") unless @extra_args % 2 == 0; my @compares = ref($input) eq 'ARRAY' ? @{$input} : ($input); my %args = (-map => undef, -relative => undef, -min_pos_num => 1, -min_mappables_num => 1, -min_mappables_percent => 0, -min_map_num => 1, -min_map_percent => 0, -require_self => 0, -required => undef, -min_overlap_percent => 0, @extra_args); my $map = $args{-map}; my $rel = $args{-relative}; my $overlap = $args{-min_overlap_percent}; my $min_pos_num = $args{-min_pos_num}; my $min_pables_num = $args{-min_mappables_num}; if ($args{-min_mappables_percent}) { my $mn = (@compares + (ref($self) ? 1 : 0)) / 100 * $args{-min_mappables_percent}; if ($mn > $min_pables_num) { $min_pables_num = $mn; } } my $min_map_num = $args{-min_map_num}; if ($args{-min_map_percent}) { my %known_maps; foreach my $pable (@compares, ref($self) ? ($self) : ()) { foreach my $known ($pable->known_maps) { $known_maps{$known->unique_id} = 1; } } my $mn = scalar(keys %known_maps) / 100 * $args{-min_map_percent}; if ($mn > $min_map_num) { $min_map_num = $mn; } } my %required = map { $_ => 1 } $args{-required} ? @{$args{-required}} : (); my (@mine, @yours); if (ref($self)) { @mine = $self->get_positions($map); if ($args{-require_self}) { @mine > 0 or return; $required{$self} = 1; } } my @required = sort keys %required; foreach my $compare (@compares) { if ($compare->isa('Bio::Map::PositionI')) { push(@yours, $compare); } elsif ($compare->isa('Bio::Map::MappableI')) { push(@yours, $compare->get_positions($map)); } else { $self->throw("This is [$compare], not a Bio::Map::MappableI or Bio::Map::PositionI"); } } @yours > 0 or return; my @ok; SWITCH: for ($method) { /equals|overlaps|contains/ && do { @mine > 0 or return; foreach my $my_pos (@mine) { foreach my $your_pos (@yours) { if ($my_pos->$method($your_pos, undef, $rel)) { push(@ok, $my_pos); last; } } } last SWITCH; }; /less_than|greater_than/ && do { @mine > 0 or return; if ($method eq 'greater_than') { @mine = map { $_->[1] } sort { $b->[0] <=> $a->[0] } map { [$_->end($_->absolute_relative), $_] } @mine; @yours = map { $_->[1] } sort { $b->[0] <=> $a->[0] } map { [$_->end($_->absolute_relative), $_] } @yours; } my $test_pos = shift(@yours); foreach my $my_pos (@mine) { if ($my_pos->$method($test_pos, $rel)) { push(@ok, $my_pos); } else { last; } } if ($method eq 'greater_than') { @ok = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_->sortable, $_] } @ok; } last SWITCH; }; /overlapping_groups|intersection|union/ && do { my @positions = (@mine, @yours); my $start_pos = shift(@positions); my $dr_able = $start_pos->disconnected_ranges(\@positions, $rel, $overlap) || return; my @disconnected_ranges = $dr_able->get_positions; #print "got ", scalar(@disconnected_ranges), " disconnected_ranges, first has range ", $disconnected_ranges[0]->toString, "\n"; #use Benchmark qw(:all); #my $t0 = new Benchmark; my %all_groups; my %done_ranges; for my $i (0..$#disconnected_ranges) { my $range = $disconnected_ranges[$i]; my $range_string = $range->toString; next if $done_ranges{$range_string}; $done_ranges{$range_string} = 1; foreach my $pos ($start_pos, @positions) { if ($pos->overlaps($range, undef, $rel)) { $all_groups{$range_string}->{$pos} = $pos; } } } #my $t1 = new Benchmark; #my $td = timediff($t1, $t0); #print "grouping took: ",timestr($td),"\n"; # purge the temporary working (not $dr_able->purge_positions since # that removes the element from each position, but leaves it on # the map. *** need complete purge that removes position from # memory... foreach my $pos (@disconnected_ranges) { my $map = $pos->map || next; $map->purge_positions($pos); } my @groups; GROUPS: foreach my $group_range (sort keys %all_groups) { my $group = $all_groups{$group_range}; my @group = sort values %{$group}; #print "* in group $group_range, there are ", scalar(@group), " members\n"; @group >= $min_pos_num or next; @group >= $min_pables_num or next; # shortcut before having to work it out properly @group >= $min_map_num or next; # shortcut before having to work it out properly my %mappables; foreach my $pos (@group) { my $mappable = $pos->element || next; $mappables{$mappable} = 1; } keys %mappables >= $min_pables_num || next; my %maps; foreach my $pos (@group) { my $map = $pos->map || next; $maps{$map->unique_id} = 1; } keys %maps >= $min_map_num || next; foreach my $required (@required) { exists $mappables{$required} or next GROUPS; } my @sorted = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_->sortable, $_] } @group; push(@groups, \@sorted); } if ($method eq 'overlapping_groups') { return @groups; } else { foreach my $group (@groups) { my $start_pos = shift(@{$group}); unless (@{$group}) { # we'll consider the 'intersection' or 'union' of just # one position as the position itself push(@ok, Bio::Map::Position->new(-map => $start_pos->map, -start => $start_pos->start, -end => $start_pos->end)); } else { my @rel_arg = $method eq 'intersection' ? (undef, $rel) : ($rel); my $result = $start_pos->$method($group, @rel_arg) || next; push(@ok, $result->get_positions); } } # assign all the positions to a result mappable my $result = $self->new(); $result->add_position(@ok) if @ok; # add_position can actually take a list return $result; } last SWITCH; }; $self->throw("Unknown method '$method'"); } return @ok; } =head2 tuple Title : tuple Usage : Do Not Use! Function: tuple was supposed to be a private method; this method no longer does anything Returns : warning Args : none Status : deprecated, will be removed in next version =cut sub tuple { my $self = shift; $self->warn("The tuple method was supposed to be a private method, don't call it!"); } =head2 annotation Title : annotation Usage : $mappable->annotation($an_col); my $an_col = $mappable->annotation(); Function: Get the annotation collection (see Bio::AnnotationCollectionI) for this annotatable object. Returns : a Bio::AnnotationCollectionI implementing object, or undef Args : none to get, OR a Bio::AnnotationCollectionI implementing object to set =cut sub annotation { my $self = shift; if (@_) { $self->{_annotation} = shift } return $self->{_annotation} || return; } 1; BioPerl-1.6.923/Bio/Map/MappableI.pm000444000765000024 2717712254227313 17111 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::MappableI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::MappableI - An object that can be placed in a map =head1 SYNOPSIS # do not use this module directly # See Bio::Map::Mappable for an example of # implementation. =head1 DESCRIPTION This object handles the generic notion of an element placed on a (linear) Map. A Mappable can have multiple positions in multiple maps, such as is the case of Restriction enzyme cut sites on sequence maps. For exact information about a mappable's position in a map one must query the associate PositionI objects which are accessible through the get_positions() method. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Heikki Lehvaslaiho heikki-at-bioperl-dot-org Lincoln Stein lstein@cshl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::MappableI; use strict; use Bio::Map::PositionHandler; use base qw(Bio::Map::EntityI Bio::AnnotatableI); =head2 EntityI methods These are fundamental to coordination of Mappables and other entities, so are implemented at the interface level =cut =head2 get_position_handler Title : get_position_handler Usage : my $position_handler = $entity->get_position_handler(); Function: Gets a PositionHandlerI that $entity is registered with. Returns : Bio::Map::PositionHandlerI object Args : none =cut sub get_position_handler { my $self = shift; unless (defined $self->{_eh}) { my $ph = Bio::Map::PositionHandler->new(-self => $self); $self->{_eh} = $ph; $ph->register; } return $self->{_eh}; } =head2 PositionHandlerI-related methods These are fundamental to coordination of Mappables and other entities, so are implemented at the interface level =cut =head2 add_position Title : add_position Usage : $mappable->add_position($position); Function: Add a position to this mappable (defining where on which map it is). Returns : n/a Args : L object =cut sub add_position { my $self = shift; # actually, we allow multiple positions to be set at once $self->get_position_handler->add_positions(@_); } =head2 get_positions Title : get_positions Usage : my @positions = $mappable->get_positions(); Function: Get all the Positions of this Mappable (sorted). Returns : Array of L objects Args : none for all, OR L object for positions on the given map, AND/OR some other true value to avoid sorting =cut sub get_positions { my ($self, $thing, $no_sort) = @_; my $map; if (ref($thing) && $thing->isa('Bio::Map::MapI')) { $map = $thing; } else { $no_sort = $thing; } my @positions = $self->get_position_handler->get_positions($map); return @positions if @positions == 1; unless ($no_sort) { # don't do # @positions = sort { $a->sortable <=> $b->sortable } @positions; # directly since sortable() can result in the call of another sort # routine and cause problems; pre-compute sortable values instead # (which is also more efficient) @positions = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_->sortable, $_] } @positions; } return @positions; } =head2 each_position Title : each_position Function: Synonym of the get_positions() method. Status : deprecated, will be removed in next version =cut *each_position = \&get_positions; =head2 purge_positions Title : purge_positions Usage : $mappable->purge_positions(); Function: Remove positions from this mappable. Returns : n/a Args : none to remove all positions, OR L object to remove just that Position, OR L object to remove only those positions on the given map =cut sub purge_positions { my ($self, $thing) = @_; $self->get_position_handler->purge_positions($thing); } =head2 known_maps Title : known_maps Usage : my @maps = $marker->known_maps() Function: Returns the maps that this mappable is found on Returns : Array of L objects Args : none =cut sub known_maps { my $self = shift; return $self->get_position_handler->get_other_entities; } =head2 MappableI-specific methods =cut =head2 name Title : name Usage : my $name = $marker->name(); $marker->name($new_name); Function: Get/Set the name for this Mappable. Returns : A scalar representing the current name of this Mappable Args : none to get string to set =cut sub name { my $self = shift; $self->throw_not_implemented(); } =head2 id Title : id Usage : my $id = $marker->id(); $marker->id($new_id); Function: Get/Set the id for this Mappable. Returns : A scalar representing the current id of this Mappable Args : none to get string to set =cut sub id { my $self = shift; $self->throw_not_implemented(); } =head2 in_map Title : in_map Usage : if ($marker->in_map($map)) {...} Function: Tests if this mappable is found on a specific map Returns : boolean Args : L =cut sub in_map { my $self = shift; $self->throw_not_implemented(); } =head1 RangeI-related Methods They throw an error if start and end are not defined in the Positions of the Mappables supplied. =cut =head2 equals Title : equals Usage : if ($mappable->equals($other_mappable)) {...} my @equal_positions = $mappable->equals($other_mappable); Function: Finds the positions in this mappable that are equal to any comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, the key => value pairs below -map => Bio::Map::MapI : optionally a Map to only consider positions on the given map -relative => Bio::Map::RelativeI : optionally a Relative to ask if the Positions equal in terms of their relative position to the thing described by that Relative =cut sub equals { my $self = shift; $self->throw_not_implemented(); } =head2 overlaps Title : overlaps Usage : if ($mappable->overlaps($other_mappable)) {...} my @overlapping_positions = $mappable->overlaps($other_mappable); Function: Finds the positions in this mappable that overlap with any comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, the key => value pairs below -map => Bio::Map::MapI : optionally a Map to only consider positions on the given map -relative => Bio::Map::RelativeI : optionally a Relative to ask if the Positions overlap in terms of their relative position to the thing described by that Relative =cut sub overlaps { my $self = shift; $self->throw_not_implemented(); } =head2 contains Title : contains Usage : if ($mappable->contains($other_mappable)) {...} my @container_positions = $mappable->contains($other_mappable); Function: Finds the positions in this mappable that contain any comparison positions. Returns : array of L objects Args : arg #1 = L OR L to compare this one to (mandatory) arg #2 = optionally, the key => value pairs below -map => Bio::Map::MapI : optionally a Map to only consider positions on the given map -relative => Bio::Map::RelativeI : optionally a Relative to ask if the Positions contains in terms of their relative position to the thing described by that Relative =cut sub contains { my $self = shift; $self->throw_not_implemented(); } =head2 intersection Title : intersection Usage : my $position = $mappable->intersection($other_mappable); my $position = Bio::Map::Mappable->intersection(\@mappables); Function: Make the position that is at the intersection of all positions of all supplied mappables. Returns : L object or undef (if not all positions overlap) Args : arg #1 = L OR L to compare this one to, or an array ref of such objects (mandatory) arg #2 = optionally, the key => value pairs below -map => Bio::Map::MapI : optionally a Map to only consider positions on the given map -relative => Bio::Map::RelativeI : optionally a Relative to to ask how the Positions intersect in terms of their relative position to the thing described by that Relative =cut sub intersection { my $self = shift; $self->throw_not_implemented(); } =head2 union Title : union Usage : my $position = $mappable->union($other_mappable); my $position = Bio::Map::Mappable->union(@mappables); Function: Make the minimal position that contains all of the positions of all supplied mappables. Returns : L object or undef (if not all positions overlap) Args : arg #1 = L OR L to compare this one to, or an array ref of such objects (mandatory) arg #2 = optionally, the key => value pairs below -map => Bio::Map::MapI : optionally a Map to only consider positions on the given map -relative => Bio::Map::RelativeI : optionally a Relative to to ask if the union of the Positions in terms of their relative position to the thing described by that Relative =cut sub union { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Map/Marker.pm000444000765000024 2352012254227326 16470 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::Marker # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Marker - An central map object representing a generic marker that can have multiple location in several maps. =head1 SYNOPSIS # get map objects somehow # a marker with complex localisation $o_usat = Bio::Map::Marker->new(-name=>'Chad Super Marker 2', -positions => [ [$map1, $position1], [$map1, $position2] ] ); # The markers deal with Bio::Map::Position objects which can also # be explicitly created and passed on to markers as an array ref: $o_usat2 = Bio::Map::Marker->new(-name=>'Chad Super Marker 3', -positions => [ $pos1, $pos2 ] ); # a marker with unique position in a map $marker1 = Bio::Map::Marker->new(-name=>'hypervariable1', -map => $map1, -position => 100 ); # another way of creating a marker with unique position in a map: $marker2 = Bio::Map::Marker->new(-name=>'hypervariable2'); $map1->add_element($marker2); $marker2->position(100); # position method is a short cut for get/setting unique positions # which overwrites previous values # to place a marker to other maps or to have multiple positions # for a map within the same map use add_position() $marker2->add_position(200); # new position in the same map $marker2->add_position($map2,200); # new map # setting a map() in a marker or adding a marker into a map are # identical mathods. Both set the bidirectional connection which is # used by the marker to remember its latest, default map. # Regardes of how marker positions are created, they are stored and # returned as Bio::Map::PositionI objects: # unique position print $marker1->position->value, "\n"; # several positions foreach $pos ($marker2->each_position($map1)) { print $pos->value, "\n"; } See L and L for more information. =head1 DESCRIPTION A Marker is a Bio::Map::Mappable with some properties particular to markers. It also offers a number of convienience methods to make dealing with map elements easier. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Heikki Lehvaslaiho heikki-at-bioperl-dot-org Lincoln Stein lstein@cshl.org Jason Stajich jason@bioperl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Marker; use strict; use Bio::Map::Position; use base qw(Bio::Map::Mappable Bio::Map::MarkerI); =head2 new Title : new Usage : my $marker = Bio::Map::Marker->new( -name => 'Whizzy marker', -position => $position); Function: Builds a new Bio::Map::Marker object Returns : Bio::Map::Marker Args : -name => name of this microsatellite [optional], string,default 'Unknown' -default_map => the default map for this marker, a Bio::Map::MapI -position => map position for this marker, a Bio::Map::PositionI -positions => array ref of Bio::Map::PositionI objects position and positions can also take as values anything the corresponding methods can take =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); bless($self, ref $class || $class); my ($name, $default_map, $map, $position, $positions) = $self->_rearrange([qw(NAME DEFAULT_MAP MAP POSITION POSITIONS )], @args); if ($name) { $self->name($name); } else {$self->name('Unnamed marker'); } $map && $self->default_map($map); $default_map && $self->default_map($default_map); $position && $self->position($position); $positions && $self->positions($positions); return $self; } =head2 default_map Title : default_map Usage : my $map = $marker->default_map(); Function: Get/Set the default map for the marker. Returns : L Args : [optional] new L =cut sub default_map { my ($self, $map) = @_; if (defined $map) { $self->thow("This is [$map], not Bio::Map::MapI object") unless $map->isa('Bio::Map::MapI'); $self->{'_default_map'} = $map; } return $self->{'_default_map'} || return; } =head2 map Title : map Function: This is a synonym of the default_map() method *** does not actually add this marker to the map! *** Status : deprecated, will be removed in next version =cut *map = \&default_map; =head2 get_position_object Title : get_position_class Usage : my $position = $marker->get_position_object(); Function: To get an object of the default Position class for this Marker. Subclasses should redefine this method. The Position returned needs to be a L with -element set to self. Returns : L Args : none for an 'empty' PositionI object, optionally Bio::Map::MapI and value string to set the Position's -map and -value attributes. =cut sub get_position_object { my ($self, $map, $value) = @_; $map ||= $self->default_map; if ($value) { $self->throw("Value better be scalar, not [$value]") unless ref($value) eq ''; } my $pos = Bio::Map::Position->new(); $pos->map($map) if $map; $pos->value($value) if defined($value); $pos->element($self); return $pos; } =head2 position Title : position Usage : my $position = $mappable->position(); $mappable->position($position); Function: Get/Set the Position of this Marker (where it is on which map), purging all other positions before setting. Returns : L Args : Bio::Map::PositionI OR Bio::Map::MapI AND scalar OR scalar, but only if the marker has a default map =cut sub position { my ($self, $pos, $pos_actual) = @_; if ($pos) { $self->purge_positions; $self->add_position($pos, $pos_actual); } my @positions = $self->each_position; $self->warn('This marker has more than one Position, returning the most recently added') if scalar @positions > 1; return pop(@positions); } =head2 add_position Title : add_position Usage : $marker->add_position($position); Function: Add a Position to this marker Returns : n/a Args : Bio::Map::PositionI OR Bio::Map::MapI AND scalar OR scalar, but only if the marker has a default map =cut sub add_position { my ($self, $pos, $pos_actual) = @_; $self->throw("Must give a Position") unless defined $pos; my $map = $self->default_map; my $pos_map; if (ref($pos)) { if (ref($pos) eq 'ARRAY') { ($pos, $pos_actual) = @{$pos}; unless ($pos && $pos_actual && ref($pos)) { $self->throw("Supplied an array ref but did not contain two values, the first an object"); } } if ($pos->isa('Bio::Map::PositionI')) { $pos_map = $pos->map; $self->default_map($pos_map) unless $map; $map = $pos_map if $pos_map; } elsif ($pos->isa('Bio::Map::MapI')) { $self->default_map($pos) unless $map; $map = $pos; $pos = $pos_actual; } else { $self->throw("This is [$pos], not a Bio::Map::PositionI or Bio::Map::MapI object"); } } $self->throw("You need to give a marker a default map before you can set positions without explicit map!" ) unless $map; if (ref($pos) && $pos->isa('Bio::Map::PositionI')) { $pos->map($map) unless $pos_map; $self->SUPER::add_position($pos); } else { $self->get_position_object($map, $pos); # adds position to us } } =head2 positions Title : positions Usage : $marker->positions([$pos1, $pos2, $pos3]); Function: Add multiple Bio::Map::PositionI to this marker Returns : n/a Args : array ref of $map/value tuples or array ref of Bio::Map::PositionI =cut sub positions { my ($self, $args_ref) = @_; foreach my $arg (@{$args_ref}) { if (ref($arg) eq 'ARRAY') { $self->add_position(@{$arg}); } else { $self->add_position($arg); } } } =head2 in_map Title : in_map Usage : if ( $marker->in_map($map) ) {} Function: Tests if this marker is found on a specific map Returns : boolean Args : a map unique id OR Bio::Map::MapI =cut sub in_map { my ($self, $query) = @_; $self->throw("Must supply an argument") unless defined($query); if (ref($query) eq '') { foreach my $map ($self->known_maps) { my $uid = $map->unique_id; if ($uid) { ($uid eq $query) && return 1; } } } else { return $self->SUPER::in_map($query); } return 0; } 1; BioPerl-1.6.923/Bio/Map/MarkerI.pm000444000765000024 1007112254227322 16572 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::MarkerI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::MarkerI - Interface for basic marker functionality =head1 SYNOPSIS # do not use this module directly # See Bio::Map::Marker for an example of # implementation. =head1 DESCRIPTION A Marker is a Bio::Map::Mappable with some properties particular to markers. It also offers a number of convienience methods to make dealing with map elements easier. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Heikki Lehvaslaiho heikki-at-bioperl-dot-org Lincoln Stein lstein@cshl.org Jason Stajich jason@bioperl.org Chad Matsalla bioinformatics1@dieselwurks.com Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Map::MarkerI; use strict; use base qw(Bio::Map::MappableI); =head2 get_position_object Title : get_position_class Usage : my $position = $marker->get_position_object(); Function: To get an object of the default Position class for this Marker. Subclasses should redefine this method. The Position returned needs to be a L with -element set to self. Returns : L Args : none for an 'empty' PositionI object, optionally Bio::Map::MapI and value string to set the Position's -map and -value attributes. =cut sub get_position_object { my $self = shift; $self->throw_not_implemented(); } =head2 position Title : position Usage : my $position = $mappable->position(); $mappable->position($position); Function: Get/Set the Position of this Marker (where it is on which map), purging all other positions before setting. Returns : L Args : Bio::Map::PositionI OR Bio::Map::MapI AND scalar OR scalar, but only if the marker has a default map =cut sub position { my $self = shift; $self->throw_not_implemented(); } =head2 positions Title : positions Usage : $marker->positions([$pos1, $pos2, $pos3]); Function: Add multiple Bio::Map::PositionI to this marker Returns : n/a Args : array ref of $map/value tuples or array ref of Bio::Map::PositionI =cut sub positions { my $self = shift; $self->throw_not_implemented(); } =head2 default_map Title : default_map Usage : my $map = $marker->default_map(); Function: Get/Set the default map for the marker. Returns : L Args : [optional] new L =cut sub default_map { my $self = shift; $self->throw_not_implemented(); } =head2 in_map Title : in_map Usage : if ( $marker->in_map($map) ) {} Function: Tests if this marker is found on a specific map Returns : boolean Args : a map unique id OR Bio::Map::MapI =cut 1; BioPerl-1.6.923/Bio/Map/Microsatellite.pm000444000765000024 2317212254227315 20230 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Map::Microsatellite # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Microsatellite - An object representing a Microsatellite marker. =head1 SYNOPSIS $o_usat = Bio::Map::Microsatellite->new (-name=>'Chad Super Marker 2', -sequence => 'gctgactgatcatatatatatatatatatatatatatatatcgcgatcgtga', -motif => 'at', -repeats => 15, -repeat_start_position => 11 ); $sequence_before_usat = $o_usat->get_leading_flank(); $sequence_after_usat = $o_usat->get_trailing_flank(); =head1 DESCRIPTION This object handles the notion of an Microsatellite. This microsatellite can be placed on a (linear) Map or used on its own. If this Microsatellites will be used in a mapping context (it doesn't have to, you know) it can have multiple positions in a map. For information about a Microsatellite's position in a map one must query the associate PositionI object which is accessible through the position() method. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Heikki Lehvaslaiho heikki-at-bioperl-dot-org Lincoln Stein lstein@cshl.org Jason Stajich jason@bioperl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Microsatellite; use strict; use base qw(Bio::Map::Marker); =head2 new Title : new Usage : $o_usat = Function: Builds a new Bio::Map::Microsatellite object Returns : Bio::Map::Microsatellite Args : -name => name of this microsatellite (optional, string, default 'Unknown microsatellite') -positions => position(s) for this marker in maps[optional], An array reference of tuples (array refs themselves) Each tuple conatins a Bio::Map::MapI-inherited object and a Bio::Map::PositionI-inherited obj, no default) -sequence => the sequence of this microsatellite (optional, scalar, no default) -motif => the repeat motif of this microsatellite (optional, scalar, no default) -repeats => the number of motif repeats for this microsatellite (optional, scalar, no default) -repeat_start_position => the starting position of the microsatellite in this sequence. The first base of the sequence is position "1". (optional, scalar, no default) Note : Creating a Bio::Map::Microsatellite object with no position might be useful for microsatellite people wanting to embrace and extend this module. Me! Me! Me! - using repeat_start_position will trigger a mechinism to calculate a value for repeat_end_position. =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($map, $position, $sequence, $motif, $repeats, $start) = $self->_rearrange([qw(MAP POSITION SEQUENCE MOTIF REPEATS REPEAT_START_POSITION )], @args); if( ! $self->name ) { $self->name('Unnamed microsatellite'); } $map && $self->map($map); $position && $self->position($position); $sequence && $self->sequence($sequence); $self->motif(defined $motif ? $motif : 'Unknown motif'); $repeats && $self->repeats($repeats); $start && $self->repeat_start_position($start); return $self; } =head2 motif Title : motif Usage : $o_usat->motif($new_motif); my $motif = $o_usat->motif(); Function: Get/Set the repeat motif for this Microsatellite. Returns : A scalar representing the current repeat motif of this Microsatellite. Args : none to get, OR string to set =cut sub motif { my ($self,$motif) = @_; if ($motif) { $self->{'_motif'} = $motif; } return $self->{'_motif'}; } =head2 sequence Title : sequence Usage : $o_usat->sequence($new_sequence); my $sequence = $o_usat->sequence(); Function: Get/Set the sequence for this Microsatellite. Returns : A scalar representing the current sequence of this Microsatellite. Args : none to get, OR string to set =cut sub sequence { my ($self,$sequence) = @_; if ($sequence) { $self->{'_sequence'} = $sequence; } return $self->{'_sequence'}; } =head2 repeats Title : repeats Usage : $o_usat->repeats($new_repeats); my $repeats = $o_usat->repeats() Function: Get/Set the repeat repeats for this Microsatellite. Returns : A scalar representing the current number of repeats of this Microsatellite. Args : none to get, OR int to set =cut sub repeats { my ($self,$repeats) = @_; if ($repeats) { $self->{'_repeats'} = $repeats; } return $self->{'_repeats'}; } =head2 repeat_start_position Title : repeat_start_position Usage : $o_usat->repeat_start_position($new_repeat_start_position); my $repeat_start_position = $o_usat->repeat_start_position(); Function: Get/Set the repeat repeat_start_position for this Microsatellite Returns : A scalar representing the repeat start position for this Microsatellite. Args : none to get, OR string to set This method will also try to set the repeat end position. This depends on having information for the motif and the number of repeats. If you want to use methods like get_trailing_flank or get_leading flank, be careful to include the right information. =cut sub repeat_start_position { my ($self,$repeat_start_position) = @_; if ($repeat_start_position) { $self->{'_repeat_start_position'} = $repeat_start_position; $self->repeat_end_position("set"); } return $self->{'_repeat_start_position'}; } =head2 repeat_end_position Title : repeat_end_position Usage : $o_usat->repeat_end_position("set"); $o_usat->repeat_end_position($value); $current_repeat_end_position = $o_usat->repeat_end_position(); Function: Get/set the end position of the repeat in this sequence. Returns : A scalar representing the base index of the end of the repeat in this Microsatellite. The first base in the sequence is base 1. Args : A scalar representing a value, the string "set", or no argument (see Notes). Notes : If you do not provide an argument to this method, the current end position of the repeat in this Microsatellite will be returned (a scalar). If you provide the string "set" to this method it will set the end position based on the start position, the length of the motif, and the number of repeats. If you specify a value the current end position of the repeat will be set to that value. This is a really bad idea. Don't do it. =cut sub repeat_end_position { my ($self,$caller) = @_; if( defined $caller ) { if ($caller eq "set") { $self->{'_repeat_end_position'} = $self->{'_repeat_start_position'} + (length($self->motif()) * $self->repeats()); } elsif ($caller) { $self->{'_repeat_end_position'} = $caller; } } return $self->{'_repeat_end_position'}; } =head2 equals Title : equals Usage : if ($mappable->equals($mapable2)) {...} Function: Test if a position is equal to another position Returns : boolean Args : Bio::Map::MappableI =cut sub equals { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 less_than Title : less_than Usage : if ($mappable->less_than($m2)) {...} Function: Tests if a position is less than another position Returns : boolean Args : Bio::Map::MappableI =cut sub less_than { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 greater_than Title : greater_than Usage : if ($mappable->greater_than($m2)) {...} Function: Tests if position is greater than another position Returns : boolean Args : Bio::Map::MappableI =cut sub greater_than { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_leading_flank Title : get_leading_flank Usage : $leading_sequence = $o_usat->get_leading_flank(); Returns : A scalar representing the sequence before the repeats in this Microsatellite. Args : none =cut sub get_leading_flank { my $self = shift; return substr $self->sequence(),0,$self->repeat_start_position-1; } =head2 get_trailing_flank Title : get_trailing_flank Usage : $trailing_flank = $o_usat->get_trailing_flank(); Returns : A scalar representing the sequence after the repeats in this Microsatellite. Args : none =cut sub get_trailing_flank { my $self = shift; return substr $self->sequence(),$self->repeat_end_position()-1; } 1; BioPerl-1.6.923/Bio/Map/OrderedPosition.pm000444000765000024 1346312254227327 20366 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Map::OrderedPosition # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::OrderedPosition - Abstracts the notion of a member of an ordered list of markers. Each marker is a certain distance from the one in the ordered list before it. =head1 SYNOPSIS use Bio::Map::OrderedPosition; # the first marker in the sequence my $position = Bio::Map::OrderedPosition->new(-order => 1, -positions => [ [ $map, 22.3] ] ); # the second marker in the sequence, 15.6 units from the fist one my $position2 = Bio::Map::OrderedPosition->new(-order => 2, -positions => [ [ $map, 37.9] ] ); # the third marker in the sequence, coincidental with the second # marker my $position3 = Bio::Map::OrderedPosition->new(-order => 3, -posititions => [ [ $map, 37.9]] ); =head1 DESCRIPTION This object is an implementation of the PositionI interface and the Position object handles the specific values of a position. OrderedPosition is intended to be slightly more specific then Position but only specific enough for a parser from the MarkerIO subsystem to create and then pass to a client application to bless into the proper type. For an example of how this is intended to work, see the Mapmaker.pm. No units are assumed here - units are handled by context of which Map a position is placed in. Se Bio::Map::Position for additional information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Lincoln Stein, lstein@cshl.org Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Jason Stajich, jason@bioperl.org Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::OrderedPosition; use strict; use base qw(Bio::Map::Position); =head2 new Title : new Usage : my $obj = Bio::Map::OrderedPosition->new(); Function: Builds a new Bio::Map::OrderedPosition object Returns : Bio::Map::OrderedPosition Args : -order : The order of this position =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($order) = $self->_rearrange([qw(ORDER)], @args); $order && $self->order($order); return $self; } =head2 order Title : order Usage : $o_position->order($new_order); my $order = $o_position->order(); Function: Get/set the order position of this position in a map. Returns : int, the order of this position Args : none to get, OR int to set =cut sub order { my ($self, $order) = @_; if ($order) { $self->{'_order'} = $order; } return $self->{'_order'} || return; } =head2 sortable Title : sortable Usage : my $num = $position->sortable(); Function: Read-only method that is guaranteed to return a value suitable for correctly sorting this kind of position amongst other positions of the same kind on the same map. Note that sorting different kinds of position together is unlikely to give sane results. Returns : numeric Args : none =cut sub sortable { my $self = shift; return $self->order; } =head2 equals Title : equals Usage : if ($mappable->equals($mapable2)) {...} Function: Test if a position is equal to another position. Returns : boolean Args : Bio::Map::PositionI =cut sub equals { my ($self,$compare) = @_; return 0 if (! defined $compare || ! $compare->isa('Bio::Map::OrderedPosition')); return ($compare->order == $self->order); } # admittedly these aren't really the best comparisons in the world # but it is a first pass we'll need to refine the algorithm or not # provide general comparisions and require these to be implemented # by objects closer to the specific type of data =head2 less_than Title : less_than Usage : if ($mappable->less_than($m2)) {...} Function: Tests if a position is less than another position It is assumed that 2 positions are in the same map. Returns : boolean Args : Bio::Map::PositionI =cut sub less_than { my ($self,$compare) = @_; return 0 if (! defined $compare || ! $compare->isa('Bio::Map::OrderedPosition')); return ($compare->order < $self->order); } =head2 greater_than Title : greater_than Usage : if ($mappable->greater_than($m2)) {...} Function: Tests if position is greater than another position. It is assumed that 2 positions are in the same map. Returns : boolean Args : Bio::Map::PositionI =cut sub greater_than { my ($self,$compare) = @_; return 0 if (! defined $compare || ! $compare->isa('Bio::Map::OrderedPosition')); return ($compare->order > $self->order); } 1;BioPerl-1.6.923/Bio/Map/OrderedPositionWithDistance.pm000444000765000024 1066212254227336 22673 0ustar00cjfieldsstaff000000000000### TO BE DELETED ### # BioPerl module for Bio::Map::OrderedPositionWithDistance # # Please direct questions and support issues to # # Cared for by Chad Matsalla # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::OrderedPositionWithDistance - Abstracts the notion of a member of an ordered list of markers. Each marker is a certain distance from the one in the ordered list before it. =head1 SYNOPSIS use Bio::Map::OrderedPositionWithDistance; # the first marker in the sequence my $position = Bio::Map::OrderedPositionWithDistance->new(-positions => 1, -distance => 22.3 ); # the second marker in the sequence, 15.6 units from the fist one my $position2 = Bio::Map::OrderedPositionWithDistance->new(-positions => 2, -distance => 15.6 ); # the third marker in the sequence, coincidental with the second # marker my $position3 = Bio::Map::OrderedPositionWithDistance->new(-positions => 3, -distance => 0 ); =head1 DESCRIPTION This object is an implementation of the PositionI interface and the Position object handles the specific values of a position. OrderedPositionWithDistance is intended to be slightly more specific then Position but only specific enough for a parser from the MarkerIO subsystem to create and then pass to a client application to bless into the proper type. For an example of how this is intended to work, see the Mapmaker.pm. No units are assumed here - units are handled by context of which Map a position is placed in. Se Bio::Map::Position for additional information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Lincoln Stein, lstein@cshl.org Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::OrderedPositionWithDistance; use strict; use base qw(Bio::Map::Position); =head2 new Title : new Usage : my $obj = Bio::Map::OrderedPositionWithDistance->new(); Function: Builds a new Bio::Map::OrderedPositionWithDistance object Returns : Bio::Map::OrderedPositionWithDistance Args : -positions - Should be a single value representing the order of this marker within the list of markers -distance - The distance this marker is from the marker before it. 0 reflects coincidentality. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_positions'} = []; my ($positions,$distance) = $self->_rearrange([qw(POSITIONS DISTANCE)], @args); if( ref($positions) =~ /array/i ) { foreach my $p ( @$positions ) { $self->add_position($p); } } else { $self->add_position($positions); } $distance && $self->distance($distance); return $self; } =head2 distance($new_distance) Title : distance($new_distance) Usage : $position->distance(new_distance) _or_ $position->distance() Function: get/set the distance of this position from the previous marker Returns : A scalar representing the current distance for this position. Args : If $new_distance is provided the distance of this Position will be set to $new_distance =cut sub distance { my ($self,$distance) = @_; if ($distance) { $self->{'_distance'} = $distance; } return $self->{'_distance'}; } 1; BioPerl-1.6.923/Bio/Map/Physical.pm000555000765000024 10503212254227333 17043 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::Physical # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright AGCoL # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Physical - A class for handling a Physical Map (such as FPC) =head1 SYNOPSIS use Bio::MapIO; # accquire a Bio::Map::Physical using Bio::MapIO::fpc my $mapio = Bio::MapIO->new(-format => "fpc",-file => "rice.fpc", -readcor => 0); my $physical = $mapio->next_map(); # get all the markers ids foreach my $marker ( $physical->each_markerid() ) { print "Marker $marker\n"; # acquire the marker object using Bio::Map::FPCMarker my $markerobj = $physical->get_markerobj($marker); # get all the clones hit by this marker foreach my $clone ($markerobj->each_cloneid() ) { print " +++$clone\n"; } } =head1 DESCRIPTION This class is basically a continer class for a collection of Contig maps and other physical map information. Bio::Map::Physical has been tailored to work for FPC physical maps, but could probably be used for others as well (with the appropriate MapIO module). This class also has some methods with specific functionalities: print_gffstyle() : Generates GFF; either Contigwise[Default] or Groupwise print_contiglist() : Prints the list of Contigs, markers that hit the contig, the global position and whether the marker is a placement (

) or a Framework () marker. print_markerlist() : Prints the markers list; contig and corresponding number of clones. matching_bands() : Given two clones [and tolerence], this method calculates how many matching bands do they have. coincidence_score() : Given two clones [,tolerence and gellen], this method calculates the Sulston Coincidence score. For faster access and better optimization, the data is stored internally in hashes. The corresponding objects are created on request. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Gaurav Gupta Email gaurav@genome.arizona.edu =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk =head1 PROJECT LEADERS Jamie Hatfield jamie@genome.arizona.edu Dr. Cari Soderlund cari@genome.arizona.edu =head1 PROJECT DESCRIPTION The project was done in Arizona Genomics Computational Laboratory (AGCoL) at University of Arizona. This work was funded by USDA-IFAFS grant #11180 titled "Web Resources for the Computation and Display of Physical Mapping Data". For more information on this project, please refer: http://www.genome.arizona.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Physical; use vars qw($MAPCOUNT); use strict; use POSIX; use Bio::Map::Clone; use Bio::Map::Contig; use Bio::Map::FPCMarker; use base qw(Bio::Map::SimpleMap); BEGIN { $MAPCOUNT = 1; } =head1 Access Methods These methods let you get and set the member variables =head2 version Title : version Usage : my $version = $map->version(); Function: Get/set the version of the program used to generate this map Returns : scalar representing the version Args : none to get, OR string to set =cut sub version { my ($self,$value) = @_; if (defined($value)) { $self->{'_version'} = $value; } return $self->{'_version'}; } =head2 modification_user Title : modification_user Usage : my $modification_user = $map->modification_user(); Function: Get/set the name of the user who last modified this map Returns : scalar representing the username Args : none to get, OR string to set =cut sub modification_user { my ($self,$value) = @_; if (defined($value)) { $self->{'_modification_user'} = $value; } return $self->{'_modification_user'}; } =head2 group_type Title : group_type Usage : $map->group_type($grptype); my $grptype = $map->group_type(); Function: Get/set the group type of this map Returns : scalar representing the group type Args : none to get, OR string to set =cut sub group_type { my ($self,$value) = @_; if (defined($value)) { $self->{'_grouptype'} = $value; } return $self->{'_grouptype'}; } =head2 group_abbr Title : group_abbr Usage : $map->group_abbr($grpabbr); my $grpabbr = $map->group_abbr(); Function: get/set the group abbrev of this map Returns : string representing the group abbrev Args : none to get, OR string to set =cut sub group_abbr { my ($self,$value) = @_; if (defined($value)) { $self->{'_groupabbr'} = $value; } return $self->{'_groupabbr'}; } =head2 core_exists Title : core_exists Usage : my $core_exists = $map->core_exists(); Function: Get/set if the FPC file is accompanied by COR file Returns : boolean Args : none to get, OR 1|0 to set =cut sub core_exists { my ($self,$value) = @_; if (defined($value)) { $self->{'_corexists'} = $value ? 1 : 0; } return $self->{'_corexists'}; } =head2 each_cloneid Title : each_cloneid Usage : my @clones = $map->each_cloneid(); Function: returns an array of clone names Returns : list of clone names Args : none =cut sub each_cloneid { my ($self) = @_; return keys %{$self->{'_clones'}}; } =head2 get_cloneobj Title : get_cloneobj Usage : my $cloneobj = $map->get_cloneobj('CLONEA'); Function: returns an object of the clone given in the argument Returns : object of the clone Args : scalar representing the clone name =cut sub get_cloneobj { my ($self,$clone) = @_; return 0 if(!defined($clone)); return if($clone eq ""); return if(!exists($self->{'_clones'}{$clone})); my ($type,$contig,$bands,$gel,$group,$remark,$fp_number); my ($sequence_type,$sequence_status,$fpc_remark,@amatch,@pmatch,@ematch, $startrange,$endrange); my %clones = %{$self->{'_clones'}{$clone}}; my @markers; if (ref($clones{'clone'}) eq 'Bio::Map::Clone') { return $clones{'clone'}; } $type = $clones{'type'} if (exists($clones{'type'})); @markers = (keys %{$clones{'markers'}}) if (exists($clones{'markers'})); $contig = $clones{'contig'} if (exists($clones{'contig'})); $bands = $clones{'bands'} if (exists($clones{'bands'})); $gel = $clones{'gel'} if (exists($clones{'gel'})); $group = $clones{'group'} if (exists($clones{'group'})); $remark = $clones{'remark'} if (exists($clones{'remark'})); $fp_number = $clones{'fp_number'} if (exists($clones{'fp_number'})); $fpc_remark = $clones{'fpc_remark'} if (exists($clones{'fpc_remark'})); $sequence_type = $clones{'sequence_type'} if (exists($clones{'sequence_type'})); $sequence_status = $clones{'sequence_status'} if (exists($clones{'sequence_status'} )); @amatch = (keys %{$clones{'matcha'}}) if (exists($clones{'matcha'})); @ematch = (keys %{$clones{'matche'}}) if (exists($clones{'matche'})); @pmatch = (keys %{$clones{'matchp'}}) if (exists($clones{'matchp'})); $startrange = $clones{'range'}{'start'} if (exists($clones{'range'}{'start'})); $endrange = $clones{'range'}{'end'} if (exists($clones{'range'}{'end'})); #*** why doesn't it call Bio::Map::Clone->new ? Seems dangerous... my $cloneobj = bless( { _name => $clone, _markers => \@markers, _contig => $contig, _type => $type, _bands => $bands, _gel => $gel, _group => $group, _remark => $remark, _fpnumber => $fp_number, _sequencetype => $sequence_type, _sequencestatus => $sequence_status, _fpcremark => $fpc_remark, _matche => \@ematch, _matcha => \@amatch, _matchp => \@pmatch, _range => Bio::Range->new(-start => $startrange, -end => $endrange), }, 'Bio::Map::Clone'); $self->{'_clones'}{$clone}{'clone'} = $cloneobj; return $cloneobj; } =head2 each_markerid Title : each_markerid Usage : my @markers = $map->each_markerid(); Function: returns list of marker names Returns : list of marker names Args : none =cut sub each_markerid { my ($self) = @_; return keys (%{$self->{'_markers'}}); } =head2 get_markerobj Title : get_markerobj Usage : my $markerobj = $map->get_markerobj('MARKERA'); Function: returns an object of the marker given in the argument Returns : object of the marker Args : scalar representing the marker name =cut sub get_markerobj { my ($self,$marker) = @_; return 0 if(!defined($marker)); return if($marker eq ""); return if(!exists($self->{'_markers'}{$marker})); my ($global,$framework,$group,$anchor,$remark,$type,$linkage,$subgroup); my %mkr = %{$self->{'_markers'}{$marker}}; return $mkr{'marker'} if (ref($mkr{'marker'}) eq 'Bio::Map::FPCMarker'); $type = $mkr{'type'} if(exists($mkr{'type'})); $global = $mkr{'global'} if(exists($mkr{'global'} )); $framework = $mkr{'framework'} if(exists($mkr{'framework'})); $anchor = $mkr{'anchor'} if(exists($mkr{'anchor'})); $group = $mkr{'group'} if(exists($mkr{'group'})); $subgroup = $mkr{'subgroup'} if(exists($mkr{'subgroup'})); $remark = $mkr{'remark'} if(exists($mkr{'remark'})); my %clones = %{$mkr{'clones'}}; my %contigs = %{$mkr{'contigs'}}; my %markerpos = %{$mkr{'posincontig'}} if(exists($mkr{'posincontig'})); #*** why doesn't it call Bio::Map::FPCMarker->new ? Seems dangerous... my $markerobj = bless( { _name => $marker, _type => $type, _global => $global, _frame => $framework, _group => $group, _subgroup => $subgroup, _anchor => $anchor, _remark => $remark, _clones => \%clones, _contigs => \%contigs, _position => \%markerpos, }, 'Bio::Map::FPCMarker'); $self->{'_markers'}{$marker}{'marker'} = $markerobj; return $markerobj; } =head2 each_contigid Title : each_contigid Usage : my @contigs = $map->each_contigid(); Function: returns a list of contigs (numbers) Returns : list of contigs Args : none =cut sub each_contigid { my ($self) = @_; return keys (%{$self->{'_contigs'}}); } =head2 get_contigobj Title : get_contigobj Usage : my $contigobj = $map->get_contigobj('CONTIG1'); Function: returns an object of the contig given in the argument Returns : object of the contig Args : scalar representing the contig number =cut sub get_contigobj { my ($self,$contig) = @_; return 0 if(!defined($contig)); return if($contig eq ""); return if(!exists($self->{'_contigs'}{$contig})); my ($group,$anchor,$uremark,$tremark,$cremark,$startrange,$endrange, $linkage,$subgroup); my %ctg = %{$self->{'_contigs'}{$contig}}; my (%position, %pos); return $ctg{'contig'} if (ref($ctg{'contig'}) eq 'Bio::Map::Contig'); $group = $ctg{'group'} if (exists($ctg{'group'})); $subgroup = $ctg{'subgroup'} if (exists($ctg{'subgroup'})); $anchor = $ctg{'anchor'} if (exists($ctg{'anchor'})); $cremark = $ctg{'chr_remark'} if (exists($ctg{'chr_remark'})); $uremark = $ctg{'usr_remark'} if (exists($ctg{'usr_remark'})); $tremark = $ctg{'trace_remark'} if (exists($ctg{'trace_remark'})); $startrange = $ctg{'range'}{'start'} if (exists($ctg{'range'}{'start'})); $endrange = $ctg{'range'}{'end'} if (exists($ctg{'range'}{'end'})); my %clones = %{$ctg{'clones'}} if (exists($ctg{'clones'})); my %markers = %{$ctg{'markers'}} if (exists($ctg{'markers'})); my $pos = $ctg{'position'}; #*** why doesn't it call Bio::Map::Contig->new ? Seems dangerous... my $contigobj = bless( { _group => $group, _subgroup => $subgroup, _anchor => $anchor, _markers => \%markers, _clones => \%clones, _name => $contig, _cremark => $cremark, _uremark => $uremark, _tremark => $tremark, _position => $pos, _range => Bio::Range->new(-start => $startrange, -end => $endrange), }, 'Bio::Map::Contig'); $self->{'_contigs'}{$contig}{'contig'} = $contigobj; return $contigobj; } =head2 matching_bands Title : matching_bands Usage : $self->matching_bands('cloneA','cloneB',[$tol]); Function: given two clones [and tolerence], this method calculates how many matching bands do they have. (this method is ported directly from FPC) Returns : scalar representing the number of matching bands Args : names of the clones ('cloneA', 'cloneB') [Default tolerence=7] =cut sub matching_bands { my($self,$cloneA,$cloneB,$tol) = @_; my($lstart,$kband,$match,$diff,$i,$j); return 0 if(!defined($cloneA) || !defined($cloneB) || !($self->core_exists())); $tol = 7 if (!defined($tol)); my %_clones = %{$self->{'_clones'}}; my @bandsA = @{$_clones{$cloneA}{'bands'}}; my @bandsB = @{$_clones{$cloneB}{'bands'}}; $match = 0; $lstart = 0; for ($i=0; $icoincidence_score('cloneA','cloneB'[,$tol,$gellen]); Function: given two clones [,tolerence and gellen], this method calculates the Sulston Coincidence score. (this method is ported directly from FPC) Returns : scalar representing the Sulston coincidence score. Args : names of the clones ('cloneA', 'cloneB') [Default tol=7 gellen=3300.0] =cut sub coincidence_score { my($self,$cloneA,$cloneB,$tol,$gellen) = @_; return 0 if(!defined($cloneA) || !defined($cloneB) || !($self->core_exists())); my %_clones = %{$self->{'_clones'}}; my $numbandsA = scalar(@{$_clones{$cloneA}{'bands'}}); my $numbandsB = scalar(@{$_clones{$cloneB}{'bands'}}); my ($nL,$nH,$m,$i,$psmn,$pp,$pa,$pb,$t,$c,$a,$n); my @logfact; my $score; $gellen = 3300.0 if (!defined($gellen)); $tol = 7 if (!defined($tol)); if ($numbandsA > $numbandsB) { $nH = $numbandsA; $nL = $numbandsB; } else { $nH = $numbandsB; $nL = $numbandsA; } $m = $self->matching_bands($cloneA, $cloneB,$tol); $logfact[0] = 0.0; $logfact[1] = 0.0; for ($i=2; $i<=$nL; $i++) { $logfact[$i] = $logfact[$i - 1] + log($i); } $psmn = 1.0 - ((2*$tol)/$gellen); $pp = $psmn ** $nH; $pa = log($pp); $pb = log(1 - $pp); $t = 1e-37; for ($n = $m; $n <= $nL; $n++) { $c = $logfact[$nL] - $logfact[$nL - $n] - $logfact[$n]; $a = exp($c + ($n * $pb) + (($nL - $n) * $pa)); $t += $a; } $score = sprintf("%.e",$t); return $score; } =head2 print_contiglist Title : print_contiglist Usage : $map->print_contiglist([showall]); #[Default 0] Function: prints the list of contigs, markers that hit the contig, the global position and whether the marker is a placement (P) or a Framework (F) marker. Returns : none Args : [showall] [Default 0], 1 includes all the discrepant markers =cut sub print_contiglist{ my ($self,$showall) = @_; my $pos; $showall = 0 if (!defined($showall)); my %_contigs = %{$self->{'_contigs'}}; my %_markers = %{$self->{'_markers'}}; my %_clones = %{$self->{'_clones'}}; my @contigs = $self->each_contigid(); my @sortedcontigs = sort {$a <=> $b } @contigs; print "\n\nContig List\n\n"; foreach my $contig (@sortedcontigs) { my %list; my %alist; my $ctgAnchor = $_contigs{$contig}{'anchor'}; my $ctgGroup = $_contigs{$contig}{'group'}; my @mkr = keys ( %{$_contigs{$contig}{'markers'}} ); foreach my $marker (@mkr) { my $mrkGroup = $_markers{$marker}{'group'}; my $mrkGlobal = $_markers{$marker}{'global'}; my $mrkFramework = $_markers{$marker}{'framework'}; my $mrkAnchor = $_markers{$marker}{'anchor'}; if($ctgGroup =~ /\d+|\w/ && $ctgGroup != 0) { if ($mrkGroup eq $ctgGroup) { if ($mrkFramework == 0) { $pos = $mrkGlobal."P"; } else { $pos = $mrkGlobal."F"; } $list{$marker} = $pos; } elsif ($showall == 1) { my $chr = $self->group_abbr().$mrkGroup; $alist{$marker} = $chr; } } elsif ($showall == 1 && $ctgGroup !~ /\d+/) { my $chr = $self->group_abbr().$mrkGroup; $alist{$marker} = $chr; } } my $chr = $ctgGroup; $chr = $self->group_abbr().$ctgGroup if ($ctgGroup =~ /\d+|\w/); if ($showall == 1 ) { print " ctg$contig ", $chr, " " if ($_contigs{$contig}{'group'} !~ /\d+|\w/); } elsif ($ctgGroup =~ /\d+|\w/ && $ctgGroup ne 0){ print " ctg",$contig, " ",$chr, " "; } while (my ($k,$v) = each %list) { print "$k/$v "; } print "\n" if ($showall == 0 && $ctgGroup =~ /\d+|\w/ && $ctgGroup ne 0 ); if ($showall == 1) { while (my ($k,$v) = each %alist) { print "$k/$v "; } print "\n"; } } } =head2 print_markerlist Title : print_markerlist Usage : $map->print_markerlist(); Function : prints the marker list; contig and corresponding number of clones for each marker. Returns : none Args : none =cut sub print_markerlist { my ($self) = @_; my %_contigs = %{$self->{'_contigs'}}; my %_markers = %{$self->{'_markers'}}; my %_clones = %{$self->{'_clones'}}; print "Marker List\n\n"; foreach my $marker ($self->each_markerid()) { print " ",$marker, " "; my %list; my %mclones = %{$_markers{$marker}{'clones'}}; foreach my $clone (%mclones) { if (exists($_clones{$clone}{'contig'}) ) { my $ctg = $_clones{$clone}{'contig'}; if (exists($list{$ctg})) { my $clonehits = $list{$ctg}; $clonehits++; $list{$ctg} = $clonehits; } else { $list{$ctg} = 1; } } } while (my ($k,$v) = each %list) { print "$k/$v "; } print "\n"; } } =head2 print_gffstyle Title : print_gffstyle Usage : $map->print_gffstyle([style]); Function : prints GFF; either Contigwise (default) or Groupwise Returns : none Args : [style] default = 0 contigwise, else 1 groupwise (chromosome-wise). =cut sub print_gffstyle { my ($self,$style) = @_; $style = 0 if(!defined($style)); my %_contigs = %{$self->{'_contigs'}}; my %_markers = %{$self->{'_markers'}}; my %_clones = %{$self->{'_clones'}}; my $i; my ($depth, $save_depth); my ($x, $y); my @stack; my ($k, $j, $s); my $pos; my $contig; # Calculate the position for the marker in the contig my @contigs = $self->each_contigid(); my @sortedcontigs = sort {$a <=> $b } @contigs; my $offset = 0; my %gffclones; my %gffcontigs; my %gffmarkers; my $basepair = 4096; foreach my $contig (@sortedcontigs) { if($_contigs{$contig}{'range'} ) { $offset = $_contigs{$contig}{'range'}{'start'}; if ($offset <= 0){ $offset = $offset * -1; $gffcontigs{$contig}{'start'} = 1; $gffcontigs{$contig}{'end'} = ($_contigs{$contig}{'range'}{'end'} + $offset ) * $basepair + 1; } else { $offset = 0; $gffcontigs{$contig}{'start'} = $_contigs{$contig}{'range'}{'start'} * $basepair; $gffcontigs{$contig}{'end'} = $_contigs{$contig}{'range'}{'end'} * $basepair; } } else { $gffcontigs{$contig}{'start'} = 1; $gffcontigs{$contig}{'end'} = 1; } my @clones = keys %{$_contigs{$contig}{'clones'}}; foreach my $clone (@clones) { if(exists ($_clones{$clone}{'range'}) ) { my $gffclone = $clone; $gffclone =~ s/sd1$//; $gffclones{$gffclone}{'start'} = (($_clones{$clone}{'range'}{'start'} + $offset) * $basepair + 1); $gffclones{$gffclone}{'end'} = (($_clones{$clone}{'range'}{'end'} + $offset) * $basepair + 1); } if(!$contig) { my %markers = %{$_clones{$clone}{'markers'}} if (exists($_clones{$clone}{'markers'})); while (my ($k,$v) = each %markers) { $gffmarkers{$contig}{$k} = ( ( $_clones{$clone}{'range'}{'start'} + $_clones{$clone}{'range'}{'end'} ) / 2 ) * $basepair + 1 ; } } } if($contig) { my %markers = %{$_contigs{$contig}{'markers'}} if (exists($_contigs{$contig}{'markers'})); while (my ($k,$v) = each %markers) { $gffmarkers{$contig}{$k} = ($v + $offset) * $basepair + 1; } } } if (!$style) { foreach my $contig (@sortedcontigs) { if(exists ($_contigs{$contig}{'range'} ) ) { print join("\t","ctg$contig","assembly","contig", $gffcontigs{$contig}{'start'}, $gffcontigs{$contig}{'end'},".",".",".", "Sequence \"ctg$contig\"; Name \"ctg$contig\"\n" ); } my @clones = (keys %{$_contigs{$contig}{'clones'}} ); foreach my $clone (@clones) { if(exists ($_clones{$clone}{'range'}) ) { print join("\t","ctg$contig","FPC"); my $type = $_clones{$clone}{'type'}; if($clone =~ /sd1$/) { $clone =~ s/sd1$//; $type = "sequenced"; } print join ("\t","\t$type",$gffclones{$clone}{'start'}, $gffclones{$clone}{'end'},".",".",".", "$type \"$clone\"; Name \"$clone\""); my @markers = keys %{$_clones{$clone}{'markers'}}; print "; Marker_hit" if (scalar(@markers)); foreach my $mkr(@markers) { if (exists($_markers{$mkr}{'framework'})) { print " \"$mkr ",$_markers{$mkr}{'group'}," ", $_markers{$mkr}{'global'},"\""; } else { print " \"$mkr 0 0\""; } } print "; Contig_hit \"",$_clones{$clone}{'contig'},"\" " if (defined($_clones{$clone}{'contig'})); } print "\n"; } if (exists ($_contigs{$contig}{'markers'}) ) { my %list = %{$_contigs{$contig}{'markers'}}; while (my ($k,$v) = each %list) { print "ctg", $contig, "\tFPC\t"; my $position = $gffmarkers{$contig}{$k}; my $type = "marker"; $type = "electronicmarker" if ($_markers{$k}{'type'} eq "eMRK"); if( exists($_markers{$k}{'framework'})) { $type = "frameworkmarker" if($_markers{$k}{'framework'} == 1); $type = "placementmarker" if($_markers{$k}{'framework'} == 0); } print join ("\t","$type",$position,$position,".",".", ".","$type \"$k\"; Name \"$k\""); my @clonelist; my @clones = keys %{$_markers{$k}{'clones'}}; foreach my $cl (@clones) { push (@clonelist, $cl) if($_clones{$cl}{'contig'} == $contig); } $" = " "; print("; Contig_hit \"ctg$contig - ",scalar(@clonelist), "\" (@clonelist)\n"); } } } } else { my %_groups; my $margin = 2 * $basepair; my $displacement = 0; my @grouplist; foreach my $contig (@sortedcontigs) { my $recordchr; my $chr = $_contigs{$contig}{'group'}; $chr = 0 if ($chr !~ /\d+|\w+/); $recordchr->{group} = $chr; $recordchr->{contig} = $contig; $recordchr->{position} = $_contigs{$contig}{'position'}; push @grouplist, $recordchr; } my @chr = keys (%{$_groups{'group'}}); my @sortedchr; if ($self->group_type eq 'Chromosome') { @sortedchr = sort { $a->{'group'} <=> $b->{'group'} || $a->{'contig'} <=> $b->{'contig'} } @grouplist; } else { @sortedchr = sort { $a->{'group'} cmp $b->{'group'} || $a->{'contig'} cmp $b->{'contig'} } @grouplist; } my $lastchr = -1; my $chrend = 0; foreach my $chr (@sortedchr) { my $chrname = $self->group_abbr().$chr->{'group'}; if ($lastchr eq -1 || $chr->{'group'} ne $lastchr ) { $lastchr = $chr->{'group'} if ($lastchr eq -1); $displacement = 0; # caluclate the end position of the contig my $ctgcount = 0; my $prevchr = 0; $chrend = 0; if ($chr->{contig} != 0) { foreach my $ch (@sortedchr) { if ($ch->{'group'} eq $chr->{'group'}) { if($ch->{'contig'} != 0) { my $ctg = $ch->{'contig'} if($ch->{'contig'} != 0); $chrend += $gffcontigs{$ctg}->{'end'}; ++$ctgcount; } } } $chrend += ($ctgcount-1) * $margin; } else { $chrend = $gffcontigs{'0'}->{'end'}; } $chrname = $self->group_abbr()."ctg0" if ($chr->{'contig'} == 0); print join ("\t", $chrname,"assembly","Chromosome",1, "$chrend",".",".",".", "Sequence \"$chrname\"; Name \"$chrname\"\n"); } print join ("\t", $chrname,"assembly","Chromosome",1, "$chrend",".",".",".", "Sequence \"$chrname\"; Name \"$chrname\"\n") if ($chr->{'group'} ne $lastchr && $chr->{'group'} eq 0 ); $lastchr = $chr->{'group'}; $lastchr = -1 if ($chr->{'contig'} == 0); my $contig = $chr->{'contig'}; if(exists ($_contigs{$contig}{'range'} ) ) { print join ("\t",$chrname, "FPC","contig", $gffcontigs{$contig}{'start'}+$displacement, $gffcontigs{$contig}{'end'}+$displacement, ".",".",".", "contig \"ctg$contig\"; Name \"ctg$contig\"\n"); } my @clones = (keys %{$_contigs{$contig}{'clones'}} ); foreach my $clone (@clones) { if(exists ($_clones{$clone}{'range'}) ) { print join ("\t",$chrname,"FPC"); my $type = $_clones{$clone}{'type'}; if ($clone =~ /sd1$/) { $clone =~ s/sd1$//; $type = "sequenced"; } print join ("\t","\t$type",$gffclones{$clone}{'start'} +$displacement,$gffclones{$clone}{'end'} +$displacement,".",".",".", "$type \"$clone\"; Name \"$clone\""); my @markers = keys %{$_clones{$clone}{'markers'}}; print "; Marker_hit" if (scalar(@markers)); foreach my $mkr(@markers) { if (exists($_markers{$mkr}{'framework'})) { print " \"$mkr ",$_markers{$mkr}{'group'}," ", $_markers{$mkr}{'global'},"\""; } else { print (" \"$mkr 0 0\""); } } print "; Contig_hit \"",$_clones{$clone}{'contig'},"\" " if (defined($_clones{$clone}{'contig'})); } print "\n"; } if (exists ($_contigs{$contig}{'markers'}) ) { my %list = %{$_contigs{$contig}{'markers'}}; while (my ($k,$v) = each %list) { print join ("\t",$chrname,"FPC"); my $type = "marker"; $type = "electronicmarker" if ($_markers{$k}{'type'} eq "eMRK"); if( exists($_markers{$k}{'framework'})) { $type = "frameworkmarker" if($_markers{$k}{'framework'} == 1); $type = "placementmarker" if($_markers{$k}{'framework'} == 0); } print join ("\t","\t$type",$gffmarkers{$contig}{$k} + $displacement,$gffmarkers{$contig}{$k} + $displacement,".",".",".", "$type \"$k\"; Name \"$k\""); my @clonelist; my @clones = keys %{$_markers{$k}{'clones'}}; foreach my $cl (@clones) { push (@clonelist, $cl) if($_clones{$cl}{'contig'} == $contig); } $" = " "; print("; Contig_hit \"ctg$contig - ", scalar(@clonelist),"\" (@clonelist)\n"); } } $displacement += $margin + $gffcontigs{$contig}{'end'}; } } } =head2 _calc_markerposition Title : _calc_markerposition Usage : $map->_calc_markerposition(); Function: Calculates the position of the marker in the contig Returns : none Args : none =cut sub _calc_markerposition { my ($self) = @_; my %_contigs = %{$self->{'_contigs'}}; my %_markers = %{$self->{'_markers'}}; my %_clones = %{$self->{'_clones'}}; my $i; my ($depth, $save_depth); my ($x, $y); my @stack; my ($k, $j, $s); my $pos; my $contig; # Calculate the position for the marker in the contig my @contigs = $self->each_contigid(); my @sortedcontigs = sort {$a <=> $b } @contigs; my $offset; my %gffclones; my %gffcontigs; foreach my $marker ($self->each_markerid()) { my (@ctgmarker, @sortedctgmarker); my @clones = (keys %{$_markers{$marker}{'clones'}}) if (exists ($_markers{$marker}{'clones'} )); foreach my $clone (@clones) { my $record; $record->{contig} = $_clones{$clone}{'contig'}; $record->{start} = $_clones{$clone}{'range'}{'start'}; $record->{end} = $_clones{$clone}{'range'}{'end'}; push @ctgmarker,$record; } # sorting by contig and left position @sortedctgmarker = sort { $a->{'contig'} <=> $b->{'contig'} || $b->{'start'} <=> $a->{'start'} } @ctgmarker; my $ctg = -1; for ($i=0; $i < scalar(@sortedctgmarker); $i++) { if ($ctg != $sortedctgmarker[$i]->{'contig'}) { if ($ctg == -1) { $ctg = $sortedctgmarker[$i]->{'contig'}; } else { if ($depth > $save_depth){ $pos = ($x + $y) >> 1; $_contigs{$ctg}{'markers'}{$marker} = $pos; $_markers{$marker}{'posincontig'}{$ctg} = $pos; } } $ctg = $sortedctgmarker[$i]->{'contig'}; $x = $sortedctgmarker[$i]->{'start'}; $y = $sortedctgmarker[$i]->{'end'}; $stack[0] = $y; $pos = ($x + $y) >> 1; $_contigs{$ctg}{'markers'}{$marker} = $pos; $_markers{$marker}{'posincontig'}{$ctg} = $pos; $depth = $save_depth = 1; } elsif ($sortedctgmarker[$i] <= $y) { $stack[$depth++] = $sortedctgmarker[$i]->{'end'}; # MAX if ($x < $sortedctgmarker[$i]->{'start'} ) { $x = $sortedctgmarker[$i]->{'start'}; } # MIN if ($y > $sortedctgmarker[$i]->{'end'}) { $y = $sortedctgmarker[$i]->{'end'}; } } else { if ($depth > $save_depth) { $save_depth = $depth; $pos = ($x + $y) >> 1; $_contigs{$ctg}{'markers'}{$marker} = $pos; $_markers{$marker}{'posincontig'}{$ctg} = $pos; } $x = $sortedctgmarker[$i]->{'start'}; $y = $sortedctgmarker[$i]->{'end'}; $stack[$depth++] = $y; for($j=-1, $k=0, $s=0; $s<$depth; $s++) { if ($stack[$s] <$x) { $stack[$s] = -1; $j = $s if ($j == -1); } else { $k++; # MIN $y = $stack[$s] if ($y > $stack[$s]); if ($stack[$j] == -1) { $stack[$j] = $stack[$s]; $stack[$s] = -1; while ($stack[$j] != -1) {$j++;} } else { $j = $s; } } $depth = $k; } } if ($depth > $save_depth) { $pos = ($x + $y) >> 1; $_contigs{$ctg}{'markers'}{$marker} = $pos; $_markers{$marker}{'posincontig'}{$ctg} = $pos; } } } } =head2 _calc_contigposition Title : _calc_contigposition Usage : $map->_calc_contigposition(); Function: calculates the position of the contig in the group Returns : none Args : none =cut sub _calc_contigposition{ my ($self) = @_; my %_contigs = %{$self->{'_contigs'}}; my %_markers = %{$self->{'_markers'}}; my %_clones = %{$self->{'_clones'}}; my @contigs = $self->each_contigid(); my @sortedcontigs = sort {$a <=> $b } @contigs; foreach my $contig (@sortedcontigs) { my $position = 0; my $group; if (exists($_contigs{$contig}{'group'}) ) { my %weightedmarkers; my @mkrs = keys (%{$_contigs{$contig}{'markers'}}) if (exists($_contigs{$contig}{'markers'})) ; my $chr = $_contigs{$contig}{'group'}; $chr = 0 if ($_contigs{$contig}{'group'} =~ /\?/); foreach my $mkr (@mkrs) { if (exists($_markers{$mkr}{'group'})) { if ( $_markers{$mkr}{'group'} == $chr ) { my @mkrclones = keys( %{$_markers{$mkr}{'clones'}}); my $clonescount = 0; foreach my $clone (@mkrclones) { ++$clonescount if ($_clones{$clone}{'contig'} == $contig); } $weightedmarkers{$_markers{$mkr}{'global'}} = $clonescount; } } } my $weightedctgsum = 0; my $totalhits = 0; while (my ($mpos,$hits) = each %weightedmarkers) { $weightedctgsum += ($mpos * $hits); $totalhits += $hits; } $position = sprintf("%.2f",$weightedctgsum / $totalhits) if ($totalhits != 0); $_contigs{$contig}{'position'} = $position; } } } =head2 _calc_contiggroup Title : _calc_contiggroup Usage : $map->_calc_contiggroup(); Function: calculates the group of the contig Returns : none Args : none =cut sub _calc_contiggroup { my ($self) = @_; my %_contig = %{$self->{'_contigs'}}; my @contigs = $self->each_contigid(); foreach my $ctg (@contigs) { my $chr = floor($ctg/1000); $_contig{$ctg}{'group'} = $chr; } } =head2 _setITypeE>Ref Title : _setRef Usage : These are used for initializing the reference of the hash in Bio::MapIO (fpc.pm) to the corresponding hash in Bio::Map (physical.pm). Should be used only from Bio::MapIO System. $map->setCloneRef(\%_clones); $map->setMarkerRef(\%_markers); $map->setContigRef(\%_contigs); Function: sets the hash references to the corresponding hashes Returns : none Args : reference of the hash. =cut sub _setCloneRef { my ($self, $ref) = @_; %{$self->{'_clones'}} = %{$ref}; } sub _setMarkerRef { my ($self, $ref) = @_; %{$self->{'_markers'}} = %{$ref}; } sub _setContigRef { my ($self, $ref) = @_; %{$self->{'_contigs'}} = %{$ref}; } 1;BioPerl-1.6.923/Bio/Map/Position.pm000444000765000024 3431012254227312 17045 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::Position # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Position - A single position of a Marker, or the range over which that marker lies, in a Map =head1 SYNOPSIS use Bio::Map::Position; my $position = Bio::Map::Position->new(-map => $map, -element => $marker, -value => 100 ); my $position_with_range = Bio::Map::Position->new(-map => $map, -element => $marker, -start => 100, -length => 10 ); =head1 DESCRIPTION This object is an implementation of the PositionI interface that handles the specific values of a position. This allows a map element (e.g. Marker) to have multiple positions within a map and still be treated as a single entity. This handles the concept of a relative map in which the order of elements and the distance between them is known, but does not directly handle the case when distances are unknown - in that case arbitrary values must be assigned for position values. No units are assumed here - units are handled by context of which Map a position is placed in or the subclass of this Position. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Lincoln Stein, lstein@cshl.org Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Chad Matsalla, bioinformatics1@dieselwurks.com Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Position; use strict; use Scalar::Util qw(looks_like_number); use Bio::Map::Relative; use base qw(Bio::Root::Root Bio::Map::PositionI); =head2 new Title : new Usage : my $obj = Bio::Map::Position->new(); Function: Builds a new Bio::Map::Position object Returns : Bio::Map::Position Args : -map => Bio::Map::MapI object -element => Bio::Map::MappableI object -relative => Bio::Map::RelativeI object * If this position has no range, or if a single value can describe the range * -value => scalar : something that describes the single point position or range of this Position, most likely an int * Or if this position has a range, at least two of * -start => int : value of the start co-ordinate -end => int : value of the end co-ordinate -length => int : length of the range =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($map, $marker, $element, $value, $start, $end, $length, $relative) = $self->_rearrange([qw( MAP MARKER ELEMENT VALUE START END LENGTH RELATIVE )], @args); my $do_range = defined($start) || defined($end); if ($value && $do_range) { $self->warn("-value and (-start|-end|-length) are mutually exclusive, ignoring value"); $value = undef; } $map && $self->map($map); $marker && $self->element($marker); # backwards compatibility $element && $self->element($element); $relative && $self->relative($relative); defined($value) && $self->value($value); if ($do_range) { defined($start) && $self->start($start); defined($end) && $self->end($end); if ($length) { if (defined($start) && ! defined($end)) { $self->end($start + $length - 1); } elsif (! defined($start)) { $self->start($end - $length + 1); } } defined($self->end) || $self->end($start); } return $self; } =head2 relative Title : relative Usage : my $relative = $position->relative(); $position->relative($relative); Function: Get/set the thing this Position's coordinates (numerical(), start(), end()) are relative to, as described by a Relative object. Returns : Bio::Map::RelativeI (default is one describing "relative to the start of the Position's map") Args : none to get, OR Bio::Map::RelativeI to set =cut sub relative { my ($self, $relative) = @_; if ($relative) { $self->throw("Must supply an object") unless ref($relative); $self->throw("This is [$relative], not a Bio::Map::RelativeI") unless $relative->isa('Bio::Map::RelativeI'); $self->{_relative_not_implicit} = 1; $self->{_relative} = $relative; } return $self->{_relative} || $self->absolute_relative; } =head2 absolute Title : absolute Usage : my $absolute = $position->absolute(); $position->absolute($absolute); Function: Get/set how this Position's co-ordinates (numerical(), start(), end()) are reported. When absolute is off, co-ordinates are relative to the thing described by relative(). Ie. the value returned by start() will be the same as the value you set start() to. When absolute is on, co-ordinates are converted to be relative to the start of the map. So if relative() currently points to a Relative object describing "relative to another position which is 100 bp from the start of the map", this Position's start() had been set to 50 and absolute() returns 1, $position->start() will return 150. If absolute() returns 0 in the same situation, $position->start() would return 50. Returns : boolean (default 0) Args : none to get, OR boolean to set =cut sub absolute { my $self = shift; if (@_) { $self->{_absolute} = shift } return $self->{_absolute} || 0; } =head2 value Title : value Usage : my $pos = $position->value; Function: Get/Set the value for this postion Returns : scalar, value Args : [optional] new value to set =cut sub value { my ($self, $value) = @_; if (defined $value) { $self->{'_value'} = $value; $self->start($self->numeric) unless defined($self->start); $self->end($self->numeric) unless defined($self->end); } return $self->{'_value'}; } =head2 numeric Title : numeric Usage : my $num = $position->numeric; Function: Read-only method that is guaranteed to return a numeric representation of the start of this position. Returns : scalar numeric Args : none to get the co-ordinate normally (see absolute() method), OR Bio::Map::RelativeI to get the co-ordinate converted to be relative to what this Relative describes. =cut sub numeric { my ($self, $value) = @_; my $num = $self->{'_value'}; $self->throw("The value has not been set, can't convert to numeric") unless defined($num); $self->throw("This value [$num] is not numeric") unless looks_like_number($num); if (ref($value) && $value->isa('Bio::Map::RelativeI')) { # get the value after co-ordinate conversion my $raw = $num; my ($abs_start, $rel_start) = $self->_relative_handler($value); return $abs_start + $raw - $rel_start; } # get the value as per absolute if ($self->{_relative_not_implicit} && $self->absolute) { # this actually returns the start, but should be the same thing... return $self->relative->absolute_conversion($self); } return $num; } =head2 start Title : start Usage : my $start = $position->start(); $position->start($start); Function: Get/set the start co-ordinate of this position. Returns : the start of this position Args : scalar numeric to set, OR none to get the co-ordinate normally (see absolute() method), OR Bio::Map::RelativeI to get the co-ordinate converted to be relative to what this Relative describes. =cut sub start { my ($self, $value) = @_; if (defined $value) { if (ref($value) && $value->isa('Bio::Map::RelativeI')) { # get the value after co-ordinate conversion my $raw = $self->{start}; defined $raw || return; my ($abs_start, $rel_start) = $self->_relative_handler($value); return $abs_start + $raw - $rel_start; } else { # set the value $self->throw("This is [$value], not a number") unless looks_like_number($value); $self->{start} = $value; $self->value($value) unless defined($self->value); } } # get the value as per absolute if ($self->{_relative_not_implicit} && $self->absolute) { return $self->relative->absolute_conversion($self); } return defined($self->{start}) ? $self->{start} : return; } =head2 end Title : end Usage : my $end = $position->end(); $position->end($end); Function: Get/set the end co-ordinate of this position. Returns : the end of this position Args : scalar numeric to set, OR none to get the co-ordinate normally (see absolute() method), OR Bio::Map::RelativeI to get the co-ordinate converted to be relative to what this Relative describes. =cut sub end { my ($self, $value) = @_; if (defined $value) { if (ref($value) && $value->isa('Bio::Map::RelativeI')) { # get the value after co-ordinate conversion my $raw = $self->{end}; defined $raw || return; my ($abs_start, $rel_start) = $self->_relative_handler($value); return $abs_start + $raw - $rel_start; } else { # set the value $self->throw("This value [$value] is not numeric!") unless looks_like_number($value); $self->{end} = $value; } } # get the value as per absolute if ($self->{_relative_not_implicit} && $self->absolute) { my $raw = $self->{end} || return; my $abs_start = $self->relative->absolute_conversion($self) || return; return $abs_start + ($raw - $self->{start}); } return defined($self->{end}) ? $self->{end} : return; } =head2 length Title : length Usage : $length = $position->length(); Function: Get/set the length of this position's range, changing the end() if necessary. Getting and even setting the length will fail if both start() and end() are not already defined. Returns : the length of this range Args : none to get, OR scalar numeric (>0) to set. =cut sub length { my ($self, $length) = @_; if ($length) { $length > 0 || return; my $existing_length = $self->length || return; return $length if $existing_length == $length; $self->end($self->{start} + $length - 1); } if (defined($self->start) && defined($self->end)) { return $self->end - $self->start + 1; } return; } =head2 sortable Title : sortable Usage : my $num = $position->sortable(); Function: Read-only method that is guaranteed to return a value suitable for correctly sorting this kind of position amongst other positions of the same kind on the same map. Note that sorting different kinds of position together is unlikely to give sane results. Returns : numeric Args : none =cut sub sortable { my ($self, $given_map) = @_; my $answer = $self->numeric($self->absolute_relative); return $answer; } =head2 toString Title : toString Usage : print $position->toString(), "\n"; Function: stringifies this range Returns : a string representation of the range of this Position Args : optional Bio::Map::RelativeI to have the co-ordinates reported relative to the thing described by that Relative =cut sub toString { my ($self, $rel) = @_; if (defined($self->start) && defined($self->end)) { return $self->start($rel).'..'.$self->end($rel); } return ''; } =head2 absolute_relative Title : absolute_relative Usage : my $rel = $position->absolute_relative(); Function: Get a relative describing the start of the map. This is useful for supplying to the coordinate methods (start(), end() etc.) to get the temporary effect of having set absolute(1). Returns : Bio::Map::Relative Args : none =cut sub absolute_relative { return Bio::Map::Relative->new(-map => 0, -description => 'start of map'); } # get our own absolute start and that of the thing we want as a frame of # reference sub _relative_handler { my ($self, $value) = @_; my $own_relative = $self->relative; # if the requested relative position is the same as the actual # relative, the current co-ordinate values are correct so shortcut my ($own_type, $req_type) = ($own_relative->type, $value->type); if ($own_type && $req_type && $own_type eq $req_type && $own_relative->$own_type eq $value->$req_type) { return (0, 0); } my $abs_start = $own_relative->absolute_conversion($self); my $rel_start = $value->absolute_conversion($self); $self->throw("Unable to resolve co-ordinate because relative to something that ultimately isn't relative to the map start") unless defined($abs_start) && defined($rel_start); return ($abs_start, $rel_start); } 1; BioPerl-1.6.923/Bio/Map/PositionHandler.pm000555000765000024 3040312254227333 20350 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::PositionHandler # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::PositionHandler - A Position Handler Implementation =head1 SYNOPSIS # This is used by modules when they want to implement being a # Position or being something that has Positions (when they are # a L) # Make a PositionHandler that knows about you my $ph = Bio::Map::PositionHandler->new($self); # Register with it so that it handles your Position-related needs $ph->register; # If you are a position, get/set the map you are on and the marker you are # for $ph->map($map); $ph->element($marker); my $map = $ph->map; my $marker = $ph->element; # If you are a marker, add a new position to yourself $ph->add_positions($pos); # And then get all your positions on a particular map foreach my $pos ($ph->get_positions($map)) { # do something with this Bio::Map::PositionI } # Or find out what maps you exist on my @maps = $ph->get_other_entities; # The same applies if you were a map =head1 DESCRIPTION A Position Handler copes with the coordination of different Bio::Map::EntityI objects, adding and removing them from each other and knowning who belongs to who. These relationships between objects are based around shared Positions, hence PositionHandler. This PositionHandler is able to cope with Bio::Map::PositionI objects, Bio::Map::MappableI objects and Bio::Map::MapI objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::PositionHandler; use strict; use base qw(Bio::Root::Root Bio::Map::PositionHandlerI); # globally accessible hash, via private instance methods my $RELATIONS = {}; =head2 General methods =cut =head2 new Title : new Usage : my $position_handler = Bio::Map::PositionHandler->new(-self => $self); Function: Get a Bio::Map::PositionHandler that knows who you are. Returns : Bio::Map::PositionHandler object Args : -self => Bio::Map::EntityI that is you =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($you) = $self->_rearrange([qw(SELF)], @args); $self->throw('Must supply -self') unless $you; $self->throw('-self must be a reference (object)') unless ref($you); $self->throw('This is [$you], not a Bio::Map::EntityI object') unless $you->isa('Bio::Map::EntityI'); $self->{_who} = $you; $self->{_rel} = $RELATIONS; return $self; } =head2 register Title : register Usage : $position_handler->register(); Function: Ask this Position Handler to look after your entity relationships. Returns : n/a Args : none =cut sub register { my $self = shift; my $you = $self->{_who}; $self->throw("Trying to re-register [$you], which could be bad") if $you->get_position_handler->index; $self->{_index} = ++$self->{_rel}->{assigned_indices}; $self->{_rel}->{registered}->{$self->{_index}} = $you; } =head2 index Title : index Usage : my $index = $position_handler->index(); Function: Get the unique registry index for yourself, generated during the resistration process. Returns : int Args : none =cut sub index { my $self = shift; return $self->{_index}; } =head2 get_entity Title : get_entity Usage : my $entity = $position_handler->get_entity($index); Function: Get the entity that corresponds to the supplied registry index. Returns : Bio::Map::EntityI object Args : int =cut sub get_entity { my ($self, $index) = @_; return $self->{_rel}->{registered}->{$index} || $self->throw("Requested registy index '$index' but that index isn't in the registry"); } =head2 Methods for Bio::Map::PositionI objects =cut =head2 map Title : map Usage : my $map = $position_handler->map(); $position_handler->map($map); Function: Get/Set the map you are on. You must be a Position. Returns : L Args : none to get, OR new L to set =cut sub map { my ($self, $entity) = @_; return $self->_pos_get_set($entity, 'position_maps', 'Bio::Map::MapI'); } =head2 element Title : element Usage : my $element = $position_handler->element(); $position_handler->element($element); Function: Get/Set the map element you are for. You must be a Position. Returns : L Args : none to get, OR new L to set =cut sub element { my ($self, $entity) = @_; return $self->_pos_get_set($entity, 'position_elements', 'Bio::Map::MappableI'); } =head2 Methods for all other Bio::Map::EntityI objects =cut =head2 add_positions Title : add_positions Usage : $position_handler->add_positions($pos1, $pos2, ...); Function: Add some positions to yourself. You can't be a position. Returns : n/a Args : Array of Bio::Map::PositionI objects =cut sub add_positions { my $self = shift; $self->throw('Must supply at least one Bio::Map::EntityI') unless @_ > 0; my $you_index = $self->_get_you_index(0); my $kind = $self->_get_kind; foreach my $pos (@_) { $self->_check_object($pos, 'Bio::Map::PositionI'); my $pos_index = $self->_get_other_index($pos); $self->_pos_set($pos_index, $you_index, $kind); } } =head2 get_positions Title : get_positions Usage : my @positions = $position_handler->get_positions(); Function: Get all your positions. You can't be a Position. Returns : Array of Bio::Map::PositionI objects Args : none for all, OR Bio::Map::EntityI object to limit the Positions to those that are shared by you and this other entity. =cut sub get_positions { my ($self, $entity) = @_; my $you_index = $self->_get_you_index(0); my @positions = keys %{$self->{_rel}->{has}->{$you_index}}; if ($entity) { my $entity_index = $self->_get_other_index($entity); my $pos_ref = $self->{_rel}->{has}->{$entity_index}; @positions = grep { $pos_ref->{$_} } @positions; } return map { $self->get_entity($_) } @positions; } =head2 purge_positions Title : purge_positions Usage : $position_handler->purge_positions(); Function: Remove all positions from yourself. You can't be a Position. Returns : n/a Args : none to remove all, OR Bio::Map::PositionI object to remove only that entity, OR Bio::Map::EntityI object to limit the removal to those Positions that are shared by you and this other entity. =cut sub purge_positions { my ($self, $thing) = @_; my $you_index = $self->_get_you_index(0); my $kind = $self->_get_kind; my @pos_indices; if ($thing) { $self->throw("Must supply an object") unless ref($thing); if ($thing->isa("Bio::Map::PositionI")) { @pos_indices = ($self->_get_other_index($thing)); } else { my $entity_index = $self->_get_other_index($thing); my $pos_ref = $self->{_rel}->{has}->{$entity_index}; @pos_indices = grep { $pos_ref->{$_} } keys %{$self->{_rel}->{has}->{$you_index}}; } } else { @pos_indices = keys %{$self->{_rel}->{has}->{$you_index}}; } foreach my $pos_index (@pos_indices) { $self->_purge_pos_entity($pos_index, $you_index, $kind); } } =head2 get_other_entities Title : get_other_entities Usage : my @entities = $position_handler->get_other_entities(); Function: Get all the entities that share your Positions. You can't be a Position. Returns : Array of Bio::Map::EntityI objects Args : none =cut sub get_other_entities { my $self = shift; my $you_index = $self->_get_you_index(0); my $kind = $self->_get_kind; my $want = $kind eq 'position_elements' ? 'position_maps' : 'position_elements'; my %entities; while (my ($pos_index) = each %{$self->{_rel}->{has}->{$you_index}}) { my $entity_index = $self->{_rel}->{$want}->{$pos_index}; $entities{$entity_index} = 1 if $entity_index; } return map { $self->get_entity($_) } keys %entities; } # do basic check on an object, make sure it is the right type sub _check_object { my ($self, $object, $interface) = @_; $self->throw("Must supply an arguement") unless $object; $self->throw("This is [$object], not an object") unless ref($object); $self->throw("This is [$object], not a $interface") unless $object->isa($interface); } # get the object we are the handler of, its index, and throw depending on if # we're a Position sub _get_you_index { my ($self, $should_be_pos) = @_; my $you = $self->{_who}; if ($should_be_pos) { $self->throw("This is not a Position, method invalid") unless $you->isa('Bio::Map::PositionI'); } else { $self->throw("This is a Position, method invalid") if $you->isa('Bio::Map::PositionI'); } return $self->index; } # check an entity is registered and get its index sub _get_other_index { my ($self, $entity) = @_; $self->throw("Must supply an object") unless ref($entity); my $index = $entity->get_position_handler->index; $self->throw("Entity doesn't seem like it's been registered") unless $index; $self->throw("Entity may have been registered with a different PositionHandler, can't deal with it") unless $entity eq $self->get_entity($index); return $index; } # which of the position hashes should we be recorded under? sub _get_kind { my $self = shift; my $you = $self->{_who}; return $you->isa('Bio::Map::MapI') ? 'position_maps' : $you->isa('Bio::Map::MappableI') ? 'position_elements' : $self->throw("This is [$you] which is an unsupported kind of entity"); } # get/set position entity sub _pos_get_set { my ($self, $entity, $kind, $interface) = @_; my $you_index = $self->_get_you_index(1); my $entity_index; if ($entity) { $self->_check_object($entity, $interface); my $new_entity_index = $self->_get_other_index($entity); $entity_index = $self->_pos_set($you_index, $new_entity_index, $kind); } $entity_index ||= $self->{_rel}->{$kind}->{$you_index} || 0; if ($entity_index) { return $self->get_entity($entity_index); } return; } # set position entity sub _pos_set { my ($self, $pos_index, $new_entity_index, $kind) = @_; my $current_entity_index = $self->{_rel}->{$kind}->{$pos_index} || 0; if ($current_entity_index) { if ($current_entity_index == $new_entity_index) { return $current_entity_index; } $self->_purge_pos_entity($pos_index, $current_entity_index, $kind); } $self->{_rel}->{has}->{$new_entity_index}->{$pos_index} = 1; $self->{_rel}->{$kind}->{$pos_index} = $new_entity_index; return $new_entity_index; } # disassociate position from one of its current entities sub _purge_pos_entity { my ($self, $pos_index, $entity_index, $kind) = @_; delete $self->{_rel}->{has}->{$entity_index}->{$pos_index}; delete $self->{_rel}->{$kind}->{$pos_index}; } 1; BioPerl-1.6.923/Bio/Map/PositionHandlerI.pm000555000765000024 1272212254227315 20465 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::PositionHandlerI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::PositionHandlerI - A Position Handler Interface =head1 SYNOPSIS # do not use this module directly # See Bio::Map::PositionHandler for an example of # implementation. =head1 DESCRIPTION This interface describes the basic methods required for Position Handlers. A Position Handler copes with the coordination of different Bio::Map::EntityI objects, adding and removing them from each other and knowning who belongs to who. These relationships between objects are based around shared Positions, hence PositionHandler. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::PositionHandlerI; use strict; use base qw(Bio::Root::RootI); =head2 General methods =cut =head2 register Title : register Usage : $position_handler->register(); Function: Ask this Position Handler to look after your entity relationships. Returns : n/a Args : none =cut sub register { my $self = shift; $self->throw_not_implemented(); } =head2 index Title : index Usage : my $index = $position_handler->index(); Function: Get the unique registry index for yourself, generated during the resistration process. Returns : int Args : none =cut sub index { my $self = shift; $self->throw_not_implemented(); } =head2 get_entity Title : get_entity Usage : my $entity = $position_handler->get_entity($index); Function: Get the entity that corresponds to the supplied registry index. Returns : Bio::Map::EntityI object Args : int =cut sub get_entity { my $self = shift; $self->throw_not_implemented(); } =head2 Methods for Bio::Map::PositionI objects =cut =head2 map Title : map Usage : my $map = $position_handler->map(); $position_handler->map($map); Function: Get/Set the map you are on. You must be a Position. Returns : L Args : none to get, OR new L to set =cut sub map { my $self = shift; $self->throw_not_implemented(); } =head2 element Title : element Usage : my $element = $position_handler->element(); $position_handler->element($element); Function: Get/Set the map element you are for. You must be a Position. Returns : L Args : none to get, OR new L to set =cut sub element { my $self = shift; $self->throw_not_implemented(); } =head2 Methods for all other Bio::Map::EntityI objects =cut =head2 add_positions Title : add_positions Usage : $position_handler->add_positions($pos1, $pos2, ...); Function: Add some positions to yourself. You can't be a position. Returns : n/a Args : Array of Bio::Map::PositionI objects =cut sub add_positions { my $self = shift; $self->throw_not_implemented(); } =head2 get_positions Title : get_positions Usage : my @positions = $position_handler->get_positions(); Function: Get all your positions. You can't be a Position. Returns : Array of Bio::Map::PositionI objects Args : none for all, OR Bio::Map::EntityI object to limit the Positions to those that are shared by you and this other entity. =cut sub get_positions { my $self = shift; $self->throw_not_implemented(); } =head2 purge_positions Title : purge_positions Usage : $position_handler->purge_positions(); Function: Remove all positions from yourself. You can't be a Position. Returns : n/a Args : none to remove all, OR Bio::Map::PositionI object to remove only that entity, OR Bio::Map::EntityI object to limit the removal to those Positions that are shared by you and this other entity. =cut sub purge_positions { my $self = shift; $self->throw_not_implemented(); } =head2 get_other_entities Title : get_other_entities Usage : my @entities = $position_handler->get_other_entities(); Function: Get all the entities that share your Positions. You can't be a Position. Returns : Array of Bio::Map::EntityI objects Args : none =cut sub get_other_entities { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Map/PositionI.pm000444000765000024 7563212254227312 17172 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::PositionI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::PositionI - Abstracts the notion of a position having a value in the context of a marker and a Map =head1 SYNOPSIS # do not use this module directly # See Bio::Map::Position for an example of # implementation. =head1 DESCRIPTION This object stores one of the postions that a mappable object (e.g. Marker) may have in a map. Positions can have non-numeric values or other methods to store the locations, so they have a method numeric() which does the conversion. numeric() returns the position in a form that can be compared between other positions of the same type. It is not necessarily a value suitable for sorting positions (it may be the distance from the previous position); for that purpose the result of sortable() should be used. A 'position', in addition to being a single point, can also be an area and so can be imagined as a range and compared with other positions on the basis of overlap, intersection etc. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Lincoln Stein, lstein-at-cshl.org Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::PositionI; use strict; use Bio::Map::PositionHandler; use Bio::Map::Mappable; use Scalar::Util qw(looks_like_number); use base qw(Bio::Map::EntityI Bio::RangeI); =head2 EntityI methods These are fundamental to coordination of Positions and other entities, so are implemented at the interface level =cut =head2 get_position_handler Title : get_position_handler Usage : my $position_handler = $entity->get_position_handler(); Function: Gets a PositionHandlerI that $entity is registered with. Returns : Bio::Map::PositionHandlerI object Args : none =cut sub get_position_handler { my $self = shift; unless (defined $self->{_eh}) { my $ph = Bio::Map::PositionHandler->new(-self => $self); $self->{_eh} = $ph; $ph->register; } return $self->{_eh}; } =head2 PositionHandlerI-related methods These are fundamental to coordination of Positions and other entities, so are implemented at the interface level =cut =head2 map Title : map Usage : my $map = $position->map(); $position->map($map); Function: Get/Set the map the position is in. Returns : L Args : none to get new L to set =cut sub map { my ($self, $map) = @_; return $self->get_position_handler->map($map); } =head2 element Title : element Usage : my $element = $position->element(); $position->element($element); Function: Get/Set the element the position is for. Returns : L Args : none to get new L to set =cut sub element { my ($self, $element) = @_; return $self->get_position_handler->element($element); } =head2 marker Title : marker Function: This is a synonym of the element() method Status : deprecated, will be removed in the next version =cut *marker = \&element; =head2 PositionI-specific methods =cut =head2 value Title : value Usage : my $pos = $position->value(); Function: Get/Set the value for this position Returns : scalar, value Args : [optional] new value to set =cut sub value { my $self = shift; $self->throw_not_implemented(); } =head2 numeric Title : numeric Usage : my $num = $position->numeric; Function: Read-only method that is guaranteed to return a numeric representation of the start of this position. Returns : scalar numeric Args : none to get the co-ordinate normally (see absolute() method), OR Bio::Map::RelativeI to get the co-ordinate converted to be relative to what this Relative describes. =cut sub numeric { my $self = shift; $self->throw_not_implemented(); } =head2 sortable Title : sortable Usage : my $num = $position->sortable(); Function: Read-only method that is guaranteed to return a value suitable for correctly sorting this kind of position amongst other positions of the same kind on the same map. Note that sorting different kinds of position together is unlikely to give sane results. Returns : numeric Args : none =cut sub sortable { my $self = shift; $self->throw_not_implemented(); } =head2 relative Title : relative Usage : my $relative = $position->relative(); $position->relative($relative); Function: Get/set the thing this Position's coordinates (numerical(), start(), end()) are relative to, as described by a Relative object. Returns : Bio::Map::RelativeI (default is one describing "relative to the start of the Position's map") Args : none to get, OR Bio::Map::RelativeI to set =cut sub relative { my $self = shift; $self->throw_not_implemented(); } =head2 absolute Title : absolute Usage : my $absolute = $position->absolute(); $position->absolute($absolute); Function: Get/set how this Position's co-ordinates (numerical(), start(), end()) are reported. When absolute is off, co-ordinates are relative to the thing described by relative(). Ie. the value returned by start() will be the same as the value you set start() to. When absolute is on, co-ordinates are converted to be relative to the start of the map. So if relative() currently points to a Relative object describing "relative to another position which is 100 bp from the start of the map", this Position's start() had been set to 50 and absolute() returns 1, $position->start() will return 150. If absolute() returns 0 in the same situation, $position->start() would return 50. Returns : boolean (default 0) Args : none to get, OR boolean to set =cut sub absolute { my $self = shift; $self->throw_not_implemented(); } =head2 RangeI-based methods =cut =head2 start Title : start Usage : my $start = $position->start(); $position->start($start); Function: Get/set the start co-ordinate of this position. Returns : the start of this position Args : scalar numeric to set, OR none to get the co-ordinate normally (see absolute() method), OR Bio::Map::RelativeI to get the co-ordinate converted to be relative to what this Relative describes. =cut =head2 end Title : end Usage : my $end = $position->end(); $position->end($end); Function: Get/set the end co-ordinate of this position. Returns : the end of this position Args : scalar numeric to set, OR none to get the co-ordinate normally (see absolute() method), OR Bio::Map::RelativeI to get the co-ordinate converted to be relative to what this Relative describes. =cut =head2 length Title : length Usage : $length = $position->length(); Function: Get the length of this position. Returns : the length of this position Args : none =cut =head2 strand Title : strand Usage : $strand = $position->strand(); Function: Get the strand of this position; it is always 1 since maps to not have strands. Returns : 1 Args : none =cut sub strand { return 1; } =head2 toString Title : toString Usage : print $position->toString(), "\n"; Function: stringifies this range Returns : a string representation of the range of this Position Args : optional Bio::Map::RelativeI to have the co-ordinates reported relative to the thing described by that Relative =cut sub toString { my $self = shift; $self->throw_not_implemented(); } =head1 RangeI-related methods These methods work by considering only the values of start() and end(), as modified by considering every such co-ordinate relative to the start of the map (ie. absolute(1) is set temporarily during the calculation), or any supplied Relative. For the boolean methods, when the comparison Position is on the same map as the calling Position, there is no point supplying a Relative since the answer will be the same as without. Relative is most useful when comparing Positions on different maps and you have a Relative that describes some special place on each map like 'the start of the gene', where the actual start of the gene relative to the start of the map is different for each map. The methods do not consider maps during their calculations - things on different maps can overlap/contain/intersect/etc. each other. The geometrical methods (intersect, union etc.) do things to the geometry of ranges, and return Bio::Map::PositionI compliant objects or triplets (start, stop, strand) from which new positions could be built. When a PositionI is made it will have a map transferred to it if all the arguments shared the same map. If a Relative was supplied the result will have that same Relative. Note that the strand-testing args are there for compatibility with the RangeI interface. They have no meaning when only using PositionI objects since maps do not have strands. Typically you will just set the argument to undef if you want to supply the argument after it. =head2 equals Title : equals Usage : if ($p1->equals($p2)) {...} Function: Test whether $p1 has the same start, end, length as $p2. Returns : true if they are describing the same position (regardless of map) Args : arg #1 = a Bio::RangeI (eg. a Bio::Map::Position) to compare this one to (mandatory) arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') arg #3 = optional Bio::Map::RelativeI to ask if the Positions equal in terms of their relative position to the thing described by that Relative =cut sub equals { # overriding the RangeI implementation so we can handle Relative my ($self, $other, $so, $rel) = @_; my ($own_start, $own_end) = $self->_pre_rangei($self, $rel); my ($other_start, $other_end) = $self->_pre_rangei($other, $rel); return ($self->_testStrand($other, $so) and $own_start == $other_start and $own_end == $other_end); } =head2 less_than Title : less_than Usage : if ($position->less_than($other_position)) {...} Function: Ask if this Position ends before another starts. Returns : boolean Args : arg #1 = a Bio::RangeI (eg. a Bio::Map::Position) to compare this one to (mandatory) arg #2 = optional Bio::Map::RelativeI to ask if the Position is less in terms of their relative position to the thing described by that Relative =cut sub less_than { my ($self, $other, $rel) = @_; my ($own_start, $own_end) = $self->_pre_rangei($self, $rel); my ($other_start, $other_end) = $self->_pre_rangei($other, $rel); return $own_end < $other_start; } =head2 greater_than Title : greater_than Usage : if ($position->greater_than($other_position)) {...} Function: Ask if this Position starts after another ends. Returns : boolean Args : arg #1 = a Bio::RangeI (eg. a Bio::Map::Position) to compare this one to (mandatory) arg #2 = optional Bio::Map::RelativeI to ask if the Position is greater in terms of their relative position to the thing described by that Relative =cut sub greater_than { my ($self, $other, $rel) = @_; my ($own_start, $own_end) = $self->_pre_rangei($self, $rel); my ($other_start, $other_end) = $self->_pre_rangei($other, $rel); return $own_start > $other_end; } =head2 overlaps Title : overlaps Usage : if ($p1->overlaps($p2)) {...} Function: Tests if $p1 overlaps $p2. Returns : True if the positions overlap (regardless of map), false otherwise Args : arg #1 = a Bio::RangeI (eg. a Bio::Map::Position) to compare this one to (mandatory) arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') arg #3 = optional Bio::Map::RelativeI to ask if the Positions overlap in terms of their relative position to the thing described by that Relative arg #4 = optional minimum percentage length of the overlap before reporting an overlap exists (default 0) =cut sub overlaps { # overriding the RangeI implementation so we can handle Relative my ($self, $other, $so, $rel, $min_percent) = @_; $min_percent ||= 0; my ($own_min, $other_min) = (0, 0); if ($min_percent > 0) { $own_min = (($self->length / 100) * $min_percent) - 1; $other_min = (($other->length / 100) * $min_percent) - 1; } my ($own_start, $own_end) = $self->_pre_rangei($self, $rel); my ($other_start, $other_end) = $self->_pre_rangei($other, $rel); return ($self->_testStrand($other, $so) and not (($own_start + $own_min > $other_end or $own_end - $own_min < $other_start) || ($own_start > $other_end - $other_min or $own_end < $other_start + $other_min))); } =head2 contains Title : contains Usage : if ($p1->contains($p2)) {...} Function: Tests whether $p1 totally contains $p2. Returns : true if the argument is totally contained within this position (regardless of map), false otherwise Args : arg #1 = a Bio::RangeI (eg. a Bio::Map::Position) to compare this one to, or scalar number (mandatory) arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') arg #3 = optional Bio::Map::RelativeI to ask if the Position is contained in terms of their relative position to the thing described by that Relative =cut sub contains { # overriding the RangeI implementation so we can handle Relative my ($self, $other, $so, $rel) = @_; my ($own_start, $own_end) = $self->_pre_rangei($self, $rel); my ($other_start, $other_end) = $self->_pre_rangei($other, $rel); return ($self->_testStrand($other, $so) and $other_start >= $own_start and $other_end <= $own_end); } =head2 intersection Title : intersection Usage : ($start, $stop, $strand) = $p1->intersection($p2) ($start, $stop, $strand) = Bio::Map::Position->intersection(\@positions); $mappable = $p1->intersection($p2, undef, $relative); $mappable = Bio::Map::Position->intersection(\@positions); Function: gives the range that is contained by all ranges Returns : undef if they do not overlap, OR Bio::Map::Mappable object who's positions are the cross-map-calculated intersection of the input positions on all the maps that the input positions belong to, OR, in list context, a three element array (start, end, strand) Args : arg #1 = [REQUIRED] a Bio::RangeI (eg. a Bio::Map::Position) to compare this one to, or an array ref of Bio::RangeI arg #2 = optional strand-testing arg ('strong', 'weak', 'ignore') arg #3 = optional Bio::Map::RelativeI to ask how the Positions intersect in terms of their relative position to the thing described by that Relative =cut sub intersection { # overriding the RangeI implementation so we can transfer map and handle # Relative my ($self, $given, $so, $rel) = @_; $self->throw("missing arg: you need to pass in another argument") unless $given; my @positions; if ($self eq "Bio::Map::PositionI") { $self = "Bio::Map::Position"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } if (ref $self) { push(@positions, $self); } ref($given) eq 'ARRAY' ? push(@positions, @{$given}) : push(@positions, $given); $self->throw("Need at least 2 Positions") unless @positions >= 2; my ($intersect, $i_start, $i_end, $c_start, $c_end, %known_maps); while (@positions > 0) { unless ($intersect) { $intersect = shift(@positions); ($i_start, $i_end) = $self->_pre_rangei($intersect, $rel); my $map = $intersect->map; $known_maps{$map->unique_id} = $map; } my $compare = shift(@positions); ($c_start, $c_end) = $self->_pre_rangei($compare, $rel); return unless $compare->_testStrand($intersect, $so); if ($compare->isa('Bio::Map::PositionI')) { my $this_map = $compare->map; if ($this_map) { $known_maps{$this_map->unique_id} = $this_map; } } else { $self->throw("Only Bio::Map::PositionI objects are supported, not [$compare]"); } my @starts = sort {$a <=> $b} ($i_start, $c_start); my @ends = sort {$a <=> $b} ($i_end, $c_end); my $start = pop @starts; # larger of the 2 starts my $end = shift @ends; # smaller of the 2 ends my $intersect_strand; # strand for the intersection if (defined($intersect->strand) && defined($compare->strand) && $intersect->strand == $compare->strand) { $intersect_strand = $compare->strand; } else { $intersect_strand = 0; } if ($start > $end) { return; } else { $intersect = $self->new(-start => $start, -end => $end, -strand => $intersect_strand); } } $intersect || return; my ($start, $end, $strand) = ($intersect->start, $intersect->end, $intersect->strand); my @intersects; foreach my $known_map (values %known_maps) { my $new_intersect = $intersect->new(-start => $start, -end => $end, -strand => $strand, -map => $known_map); $new_intersect->relative($rel) if $rel; push(@intersects, $new_intersect); } unless (@intersects) { $intersect->relative($rel) if $rel; @intersects = ($intersect); } my $result = Bio::Map::Mappable->new(); $result->add_position(@intersects); # sneaky, add_position can take a list of positions return $result; } =head2 union Title : union Usage : ($start, $stop, $strand) = $p1->union($p2); ($start, $stop, $strand) = Bio::Map::Position->union(@positions); my $mappable = $p1->union($p2); my $mappable = Bio::Map::Position->union(@positions); Function: finds the minimal position/range that contains all of the positions Returns : Bio::Map::Mappable object who's positions are the cross-map-calculated union of the input positions on all the maps that the input positions belong to, OR, in list context, a three element array (start, end, strand) Args : a Bio::Map::PositionI to compare this one to, or a list of such OR a single Bio::Map::PositionI or array ref of such AND a Bio::Map::RelativeI to ask for the Position's union in terms of their relative position to the thing described by that Relative =cut sub union { # overriding the RangeI implementation so we can transfer map and handle # Relative my ($self, @args) = @_; $self->throw("Not enough arguments") unless @args >= 1; my @positions; my $rel; if ($self eq "Bio::Map::PositionI") { $self = "Bio::Map::Position"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } if (ref $self) { push(@positions, $self); } if (ref $args[0] eq 'ARRAY') { push(@positions, @{shift(@args)}); } else { push(@positions, shift(@args)); } if ($args[0] && $args[0]->isa('Bio::Map::RelativeI')) { $rel = shift(@args); } foreach my $arg (@args) { # avoid pushing undefined values into @positions push(@positions, $arg) if $arg; } $self->throw("Need at least 2 Positions") unless @positions >= 2; my (@starts, @ends, %known_maps, $union_strand); foreach my $compare (@positions) { # RangeI union allows start or end to be undefined; however _pre_rangei # will throw my ($start, $end) = $self->_pre_rangei($compare, $rel); if ($compare->isa('Bio::Map::PositionI')) { my $this_map = $compare->map; if ($this_map) { $known_maps{$this_map->unique_id} = $this_map; } } else { $self->throw("Only Bio::Map::PositionI objects are supported, not [$compare]"); } if (! defined $union_strand) { $union_strand = $compare->strand; } else { if (! defined $compare->strand or $union_strand ne $compare->strand) { $union_strand = 0; } } push(@starts, $start); push(@ends, $end); } @starts = sort { $a <=> $b } @starts; @ends = sort { $a <=> $b } @ends; my $start = shift @starts; my $end = pop @ends; my @unions; foreach my $known_map (values %known_maps) { my $new_union = $self->new(-start => $start, -end => $end, -strand => $union_strand, -map => $known_map); $new_union->relative($rel) if $rel; push(@unions, $new_union); } unless (@unions) { @unions = ($self->new(-start => $start, -end => $end, -strand => $union_strand)); $unions[0]->relative($rel) if $rel; } my $result = Bio::Map::Mappable->new(); $result->add_position(@unions); # sneaky, add_position can take a list of positions return $result; } =head2 overlap_extent Title : overlap_extent Usage : ($a_unique,$common,$b_unique) = $a->overlap_extent($b) Function: Provides actual amount of overlap between two different positions Example : Returns : array of values containing the length unique to the calling position, the length common to both, and the length unique to the argument position Args : a position =cut #*** should this be overridden from RangeI? =head2 disconnected_ranges Title : disconnected_ranges Usage : my @disc_ranges = Bio::Map::Position->disconnected_ranges(@ranges); Function: Creates the minimal set of positions such that each input position is fully contained by at least one output position, and none of the output positions overlap. Returns : Bio::Map::Mappable with the calculated disconnected ranges Args : a Bio::Map::PositionI to compare this one to, or a list of such, OR a single Bio::Map::PositionI or array ref of such AND a Bio::Map::RelativeI to consider all Position's co-ordinates in terms of their relative position to the thing described by that Relative, AND, optionally, an int for the minimum percentage of overlap that must be present before considering two ranges to be overlapping (default 0) =cut sub disconnected_ranges { # overriding the RangeI implementation so we can transfer map and handle # Relative my ($self, @args) = @_; $self->throw("Not enough arguments") unless @args >= 1; my @positions; my $rel; my $overlap = 0; if ($self eq "Bio::Map::PositionI") { $self = "Bio::Map::Position"; $self->warn("calling static methods of an interface is deprecated; use $self instead"); } if (ref $self) { push(@positions, $self); } if (ref $args[0] eq 'ARRAY') { push(@positions, @{shift(@args)}); } else { push(@positions, shift(@args)); } if ($args[0] && $args[0]->isa('Bio::Map::RelativeI')) { $rel = shift(@args); $overlap = shift(@args); } foreach my $arg (@args) { push(@positions, $arg) if $arg; } $self->throw("Need at least 2 Positions") unless @positions >= 2; my %known_maps; foreach my $pos (@positions) { $pos->isa('Bio::Map::PositionI') || $self->throw("Must supply only Bio::Map::PositionI objects, not [$pos]"); my $map = $pos->map || next; $known_maps{$map->unique_id} = $map; } my %prior_positions; foreach my $map (values %known_maps) { foreach my $pos ($map->get_positions) { $prior_positions{$pos} = 1; } } my @outranges = (); foreach my $inrange (@positions) { my @outranges_new = (); my %overlapping_ranges = (); for (my $i=0; $i<@outranges; $i++) { my $outrange = $outranges[$i]; if ($inrange->overlaps($outrange, undef, $rel, $overlap)) { my $union_able = $inrange->union($outrange, $rel); # using $inrange->union($outrange, $rel); gives >6x speedup, # but different answer, not necessarily incorrect... foreach my $pos ($union_able->get_positions) { $overlapping_ranges{$pos->toString} = $pos; # we flatten down to a result on a single map # to avoid creating 10s of thousands of positions during this process; # we then apply the final answer to all maps at the very end last; } } else { push(@outranges_new, $outrange); } } @outranges = @outranges_new; my @overlappers = values %overlapping_ranges; if (@overlappers) { if (@overlappers > 1) { my $merged_range_able = shift(@overlappers)->union(\@overlappers, $rel); push(@outranges, $merged_range_able->get_positions); } else { push(@outranges, @overlappers); } } else { push(@outranges, $self->new(-start => $inrange->start($rel), -end => $inrange->end($rel), -strand => $inrange->strand, -map => $inrange->map, -relative => $rel)); } } # purge positions that were created whilst calculating the answer, but # aren't the final answer and weren't there previously my %answers = map { $_ => 1 } @outranges; foreach my $map (values %known_maps) { foreach my $pos ($map->get_positions) { if (! exists $prior_positions{$pos} && ! exists $answers{$pos}) { $map->purge_positions($pos); } } } my %post_positions; foreach my $map (values %known_maps) { foreach my $pos ($map->get_positions) { $post_positions{$pos} = 1; } } @outranges || return; # make an outrange on all known maps my @final_positions; foreach my $map (values %known_maps) { foreach my $pos (@outranges) { if ($pos->map eq $map) { push(@final_positions, $pos); } else { push(@final_positions, $pos->new(-start => $pos->start, -end => $pos->end, -relative => $pos->relative, -map => $map)); } } } # assign the positions to a result mappable my $result = Bio::Map::Mappable->new(); $result->add_position(@final_positions); # sneaky, add_position can take a list of positions return $result; } # get start & end suitable for rangeI methods, taking relative into account sub _pre_rangei { my ($self, $other, $rel) = @_; $self->throw("Must supply an object") unless $other; if ($rel) { $self->throw("Must supply an object for the Relative argument") unless ref($rel); $self->throw("This is [$rel], not a Bio::Map::RelativeI") unless $rel->isa('Bio::Map::RelativeI'); } my ($other_start, $other_end); if (ref($other)) { if (ref($other) eq 'ARRAY') { $self->throw("_pre_rangei got an array"); } $self->throw("This is [$other], not a Bio::RangeI object") unless defined $other && $other->isa('Bio::RangeI'); if ($other->isa('Bio::Map::PositionI')) { # to get the desired start/end we need the position to be on a map; # if it isn't on one temporarily place it on self's map # - this lets us have 'generic' positions that aren't on any map # but have a relative defined and can thus be usefully compared to # positions that /are/ on maps my $other_map = $other->map; unless ($other_map) { my $self_map = $self->map || $self->throw("Trying to compare two positions but neither had been placed on a map"); $other->map($self_map); } # want start and end positions relative to the supplied rel or map start $rel ||= $other->absolute_relative; $other_start = $other->start($rel); $other_end = $other->end($rel); unless ($other_map) { $self->map->purge_positions($other); } } else { $other_start = $other->start; $other_end = $other->end; } } else { $self->throw("not a number") unless looks_like_number($other); $other_start = $other_end = $other; } $other->throw("start is undefined") unless defined $other_start; $other->throw("end is undefined") unless defined $other_end; return ($other_start, $other_end); } 1; BioPerl-1.6.923/Bio/Map/PositionWithSequence.pm000444000765000024 1034512254227334 21400 0ustar00cjfieldsstaff000000000000# $Id: PositionWithSequence.pm,v 1.19 2006/09/20 10:20:01 sendu Exp $ # # BioPerl module for Bio::Map::PositionWithSequence # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::PositionWithSequence - A position with a sequence. =head1 SYNOPSIS use Bio::Map::PositionWithSequence; my $pos = Bio::Map::PositionWithSequence->new(-map => $map, -element => $element, -start => 0, -seq => 'ATGC'); =head1 DESCRIPTION Have a position with a sequence, eg. define what the binding site sequence of a certain transcription factor binding site is by modelling it as one of these objects with the -element assigned to a Bio::Map::TranscriptionFactor instance. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::PositionWithSequence; use strict; use base qw(Bio::Map::Position Bio::LocatableSeq); =head2 new Title : new Usage : my $obj = Bio::Map::PositionWithSequence->new(); Function: Builds a new Bio::Map::PositionWithSequence object Returns : Bio::Map::PositionWithSequence Args : -map => Bio::Map::GeneMap object -element => Bio::Map::Gene object -relative => Bio::Map::GeneRelative object -seq => string, length of this string will set the length of this position's range * If this position has no range, or if a single value can describe the range * -value => scalar : something that describes the single point position or range of this Position, most likely an int * Or if this position has a range, at least two of * -start => int : value of the start co-ordinate -end => int : value of the end co-ordinate -length => int : length of the range =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($seq) = $self->_rearrange([qw( SEQ )], @args); $self->seq($seq) if $seq; return $self; } =head2 seq Title : seq Usage : my $string = $obj->seq(); Function: Get/set the sequence as a string of letters. Returns : scalar Args : Optionally on set the new value (a string). An optional second argument presets the alphabet (otherwise it will be guessed). =cut sub seq { my ($self, $str, $alpha) = @_; # done like this because SUPER will set seq to undef if undef supplied, # but GeneMap wants to send undef, undef, 1 to decendants of this method my $seq; if ($str) { $alpha ? ($seq = $self->SUPER::seq($str, $alpha)) : ($seq = $self->SUPER::seq($str)); } else { $seq = $self->SUPER::seq; } if ($seq) { $self->length(length($seq)); return $seq; } return; } 1; BioPerl-1.6.923/Bio/Map/Prediction.pm000444000765000024 1154112254227312 17342 0ustar00cjfieldsstaff000000000000# $Id: Prediction.pm,v 1.10 2006/09/28 14:09:40 sendu Exp $ # # BioPerl module for Bio::Map::Prediction # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Prediction - An object representing the predictions of something that can have multiple locations in several maps. =head1 SYNOPSIS use Bio::Map::Prediction; use Bio::Map::Position; # normally you would get predictions from a run wrapper like # Bio::Tools::Run::Meme, but here we create some manually: my $pred1 = Bio::Map::Prediction->new(-source => 'meme'); Bio::Map::Position->new(-element => $prediction1, -map => Bio::Map::GeneMap->get(-gene => 'gene1', -species => 'species1'), -start => 950, -end => 960); Bio::Map::Position->new(-element => $prediction1, -map => Bio::Map::GeneMap->get(-gene => 'gene1', -species => 'species2'), -start => 1950, -end => 1960); Bio::Map::Position->new(-element => $prediction1, -map => Bio::Map::GeneMap->get(-gene => 'gene2', -species => 'species1'), -start => 955, -end => 965); Bio::Map::Position->new(-element => $prediction1, -map => Bio::Map::GeneMap->get(-gene => 'gene2', -species => 'species2'), -start => 1955, -end => 1965); my $pred2 = Bio::Map::Prediction->new(-source => 'gerp'); Bio::Map::Position->new(-element => $prediction2, -map => Bio::Map::GeneMap->get(-gene => 'gene1', -species => 'species1'), -start => 950, -end => 960); # etc. # find the places where predictions agree use Bio::Map::GeneRelative; my $rel = Bio::Map::GeneRelative->new(-gene => 0); my $di = Bio::Map::Mappable->disconnected_intersections([$pred1, $pred2], -min_mappables_percent => 100, -min_map_percent => 100, -relative => $rel); my @positions = $di->get_positions; =head1 DESCRIPTION For example, used to model transcription factor binding site predictions, which can have multiple locations in several maps. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Prediction; use strict; use base qw(Bio::Map::Mappable); =head2 new Title : new Usage : my $prediction = Bio::Map::Prediction->new(); Function: Builds a new Bio::Map::Prediction object Returns : Bio::Map::Prediction Args : -name => string : name of the mappable element -id => string : id of the mappable element -source => string : name of the prediction program =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($source) = $self->_rearrange([qw(SOURCE)], @args); $self->source($source) if $source; return $self; } =head2 source Title : name Usage : $mappable->name($new_name); my $name = $mappable->name(); Function: Get/Set the name for this Mappable Returns : A scalar representing the current name of this Mappable Args : none to get string to set =cut sub source { my $self = shift; if (@_) { $self->{_source} = shift } return $self->{_source} || ''; } 1; BioPerl-1.6.923/Bio/Map/Relative.pm000555000765000024 2334112254227331 17022 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::Relative # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::Relative - Represents what a Position's coordiantes are relative to. =head1 SYNOPSIS # Get a Bio::Map::PositionI somehow my $pos = Bio::Map::Position->new(-value => 100); # its co-ordinates are implicitly relative to the start of its map my $implicit_relative = $pos->relative; my $type = $implicit_relative->type; # $type eq 'map' my $value = $implicit_relative->$type(); # $value == 0 # make its co-ordinates relative to another Position my $pos_we_are_relative_to = Bio::Map::Position->new(-value => 200); my $relative = Bio::Map::Relative->new(-position => $pos_we_are_relative_to); $pos->relative($relative); # Get the start co-ordinate of $pos relative to $pos_we_are_relative_to my $start = $pos->start; # $start == 100 # Get the start co-ordinate of $pos relative to the start of the map my $abs_start = $relative->absolute_conversion($pos); # $abs_start == 300 # - or - $pos->absolute(1); my $abs_start = $pos->start; # $abs_start == 300 $pos->absolute(0); # Get the start co-ordinate of $pos relative to a third Position my $pos_frame_of_reference = Bio::Map::Position->new(-value => 10); my $relative2 = Bio::Map::Relative->new(-position => $pos_frame_of_reference); my $start = $pos->start($relative2); # $start == 290 =head1 DESCRIPTION A Relative object is used to describe what the co-ordinates (numerical(), start(), end()) of a Position are relative to. By default they are implicitly assumed to be relative to the start of the map the Position is on. But setting the relative() of a Position to one of these objects lets us define otherwise. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::Relative; use strict; use Scalar::Util qw(looks_like_number); use base qw(Bio::Root::Root Bio::Map::RelativeI); =head2 new Title : new Usage : my $relative = Bio::Map::Relative->new(); Function: Build a new Bio::Map::Relative object. Returns : Bio::Map::Relative object Args : -map => int : coordinates are relative to this point on the Position's map [default is map => 0, ie. relative to the start of the map], -element => Mappable : or relative to this element's (a Bio::Map::MappableI) position in the map (only works if the given element has only one position in the map the Position belongs to), -position => Position : or relative to this other Position (a Bio::Map::PositionI, fails if the other Position is on a different map to this map) -description => string: Free text description of what this relative describes (To say a Position is relative to something and upstream of it, the Position's start() co-ordinate should be set negative) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($map, $element, $position, $desc) = $self->_rearrange([qw( MAP ELEMENT POSITION DESCRIPTION )], @args); if (defined($map) + defined($element) + defined($position) > 1) { $self->throw("-map, -element and -position are mutually exclusive"); } defined($map) && $self->map($map); $element && $self->element($element); $position && $self->position($position); $desc && $self->description($desc); return $self; } =head2 absolute_conversion Title : absolute_conversion Usage : my $absolute_coord = $relative->absolute_conversion($pos); Function: Convert the start co-ordinate of the supplied position into a number relative to the start of its map. Returns : scalar number Args : Bio::Map::PositionI object =cut sub absolute_conversion { my ($self, $pos) = @_; $self->throw("Must supply an object") unless ref($pos); $self->throw("This is [$pos], not a Bio::Map::PositionI") unless $pos->isa('Bio::Map::PositionI'); # get the raw start position of our position my $prior_abs = $pos->absolute; $pos->absolute(0) if $prior_abs; my $raw = $pos->start; $pos->absolute($prior_abs) if $prior_abs; $self->throw("Can't convert co-ordinates when start isn't set") unless defined($raw); #*** needed? return undef? # what are we relative to? my $type = $self->type; my $value = $self->$type; $self->throw("Details not yet set for this Relative, cannot convert") unless $type && defined($value); # get the absolute start of the thing we're relative to my $map = $pos->map; if ($type eq 'element') { $self->throw("Relative to a Mappable, but the Position has no map") unless $map; my @positions = $value->get_positions($map); $value = shift(@positions); $self->throw("Relative to a Mappable, but this Mappable has no positions on the supplied Position's map") unless $value; } if (ref($value)) { # psuedo-recurse my $rel = $value->relative; $value = $rel->absolute_conversion($value); } if (defined($value)) { return $value + $raw; } return; } =head2 type Title : type Usage : my $type = $relative->type(); Function: Get the type of thing we are relative to. The types correspond to a method name, so the value of what we are relative to can subsequently be found by $value = $relative->$type; Note that type is set by the last method that was set, or during new(). Returns : the string 'map', 'element' or 'position', or undef Args : none =cut sub type { my $self = shift; return $self->{_use} || return; } =head2 map Title : map Usage : my $int = $relative->map(); $relative->map($int); Function: Get/set the distance from the start of the map that the Position's co-ordiantes are relative to. Returns : int Args : none to get, OR int to set; a value of 0 means relative to the start of the map. =cut sub map { my ($self, $num) = @_; if (defined($num)) { $self->throw("This is [$num], not a number") unless looks_like_number($num); $self->{_use} = 'map'; $self->{_map} = $num; } return defined($self->{_map}) ? $self->{_map} : return; } =head2 element Title : element Usage : my $element = $relative->element(); $relative->element($element); Function: Get/set the map element (Mappable) the Position is relative to. If the Mappable has more than one Position on the Position's map, we will be relative to the Mappable's first Position on the map. Returns : Bio::Map::MappableI Args : none to get, OR Bio::Map::MappableI to set =cut sub element { my ($self, $element) = @_; if ($element) { $self->throw("Must supply an object") unless ref($element); $self->throw("This is [$element], not a Bio::Map::MappableI") unless $element->isa('Bio::Map::MappableI'); $self->{_use} = 'element'; $self->{_element} = $element; } return $self->{_element} || return; } =head2 position Title : position Usage : my $position = $relative->position(); $relative->position($position); Function: Get/set the Position your Position is relative to. Your Position will be made relative to the start of this supplied Position. It makes no difference what maps the Positions are on. Returns : Bio::Map::PositionI Args : none to get, OR Bio::Map::PositionI to set =cut sub position { my ($self, $pos) = @_; if ($pos) { $self->throw("Must supply an object") unless ref($pos); $self->throw("This is [$pos], not a Bio::Map::PositionI") unless $pos->isa('Bio::Map::PositionI'); $self->{_use} = 'position'; $self->{_position} = $pos; } return $self->{_position} || return; } =head2 description Title : description Usage : my $description = $relative->description(); $relative->description($description); Function: Get/set a textual description of what this relative describes. Returns : string Args : none to get, OR string to set =cut sub description { my $self = shift; if (@_) { $self->{desc} = shift } return $self->{desc} || ''; } 1; BioPerl-1.6.923/Bio/Map/RelativeI.pm000555000765000024 1150012254227313 17125 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::RelativeI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::RelativeI - Interface for describing what a Position's coordiantes are relative to. =head1 SYNOPSIS # do not use this module directly # See Bio::Map::Relative for an example of # implementation. =head1 DESCRIPTION A Relative object is used to describe what the co-ordinates (numerical(), start(), end()) of a Position are relative to. By default they are implicitly assumed to be relative to the start of the map the Position is on. But setting the relative() of a Position to one of these objects lets us define otherwise. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::RelativeI; use strict; use base qw(Bio::Root::RootI); =head2 absolute_conversion Title : absolute_conversion Usage : my $absolute_coord = $relative->absolute_conversion($pos); Function: Convert the start co-ordinate of the supplied position into a number relative to the start of its map. Returns : scalar number Args : Bio::Map::PositionI object =cut sub absolute_conversion { my $self = shift; $self->throw_not_implemented(); } =head2 type Title : type Usage : my $type = $relative->type(); Function: Get the type of thing we are relative to. The types correspond to a method name, so the value of what we are relative to can subsequently be found by $value = $relative->$type; Note that type is set by the last method that was set, or during new(). Returns : the string 'map', 'element' or 'position', or undef Args : none =cut sub type { my $self = shift; $self->throw_not_implemented(); } =head2 map Title : map Usage : my $int = $relative->map(); $relative->map($int); Function: Get/set the distance from the start of the map that the Position's co-ordiantes are relative to. Returns : int Args : none to get, OR int to set; a value of 0 means relative to the start of the map. =cut sub map { my $self = shift; $self->throw_not_implemented(); } =head2 element Title : element Usage : my $element = $relative->element(); $relative->element($element); Function: Get/set the map element (Mappable) the Position is relative to. If the Mappable has more than one Position on the Position's map, we will be relative to the Mappable's first Position on the map. Returns : Bio::Map::MappableI Args : none got get, OR Bio::Map::MappableI to set =cut sub element { my $self = shift; $self->throw_not_implemented(); } =head2 position Title : position Usage : my $position = $relative->position(); $relative->position($position); Function: Get/set the Position your Position is relative to. Your Position will be made relative to the start of this supplied Position. It makes no difference what maps the Positions are on. Returns : Bio::Map::PositionI Args : none got get, OR Bio::Map::PositionI to set =cut sub position { my $self = shift; $self->throw_not_implemented(); } =head2 description Title : description Usage : my $description = $relative->description(); $relative->description($description); Function: Get/set a textual description of what this relative describes. Returns : string Args : none to get, OR string to set =cut sub description { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Map/SimpleMap.pm000444000765000024 2112712254227337 17141 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Map::SimpleMap # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::SimpleMap - A MapI implementation handling the basics of a Map =head1 SYNOPSIS use Bio::Map::SimpleMap; my $map = Bio::Map::SimpleMap->new(-name => 'genethon', -type => 'Genetic', -units=> 'cM', -species => $human); foreach my $marker ( @markers ) { # get a list of markers somewhere $map->add_element($marker); } foreach my $marker ($map->get_elements) { # do something with this Bio::Map::MappableI } =head1 DESCRIPTION This is the basic implementation of a Bio::Map::MapI. It handles the essential storage of name, species, type, and units. It knows which map elements (mappables) belong to it, and their position. Subclasses might need to redefine or hardcode type(), length() and units(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Heikki Lehvaslaiho heikki-at-bioperl-dot-org Lincoln Stein lstein@cshl.org Sendu Bala bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::SimpleMap; use vars qw($MAPCOUNT); use strict; use base qw(Bio::Root::Root Bio::Map::MapI); BEGIN { $MAPCOUNT = 1; } =head2 new Title : new Usage : my $obj = Bio::Map::SimpleMap->new(); Function: Builds a new Bio::Map::SimpleMap object Returns : Bio::Map::SimpleMap Args : -name => name of map (string) -species => species for this map (Bio::Species) [optional] -units => map units (string) -uid => Unique Id [defaults to a unique integer] =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_name'} = ''; $self->{'_species'} = ''; $self->{'_units'} = ''; $self->{'_type'} = ''; $self->{'_uid'} = $MAPCOUNT++; my ($name, $type,$species, $units,$uid) = $self->_rearrange([qw(NAME TYPE SPECIES UNITS UID)], @args); defined $name && $self->name($name); defined $species && $self->species($species); defined $units && $self->units($units); defined $type && $self->type($type); defined $uid && $self->unique_id($uid); return $self; } =head2 species Title : species Usage : my $species = $map->species; Function: Get/Set Species for a map Returns : Bio::Taxon object or string Args : (optional) Bio::Taxon or string =cut sub species{ my ($self,$value) = @_; if( defined $value ) { $self->{'_species'} = $value; } return $self->{'_species'}; } =head2 units Title : units Usage : $map->units('cM'); Function: Get/Set units for a map Returns : units for a map Args : units for a map (string) =cut sub units{ my ($self,$value) = @_; if( defined $value ) { $self->{'_units'} = $value; } return $self->{'_units'}; } =head2 type Title : type Usage : my $type = $map->type Function: Get/Set Map type Returns : String coding map type Args : (optional) string =cut sub type { my ($self,$value) = @_; # this may be hardcoded/overriden by subclasses if( defined $value ) { $self->{'_type'} = $value; } return $self->{'_type'}; } =head2 name Title : name Usage : my $name = $map->name Function: Get/Set Map name Returns : Map name Args : (optional) string =cut sub name { my ($self,$value) = @_; if( defined $value ) { $self->{'_name'} = $value; } return $self->{'_name'}; } =head2 length Title : length Usage : my $length = $map->length(); Function: Retrieves the length of the map. It is possible for the length to be unknown for maps such as Restriction Enzyme, will return 0 in that case. Returns : integer representing length of map in current units will return 0 if length is not calculateable Args : none =cut sub length { my $self = shift; my $len = 0; foreach my $element ($self->get_elements) { foreach my $pos ($element->get_positions($self)) { if ($pos->value) { $len = $pos->end if $pos->end > $len; } } } return $len; } =head2 unique_id Title : unique_id Usage : my $id = $map->unique_id; Function: Get/Set the unique ID for this map Returns : a unique identifier Args : [optional] new identifier to set =cut sub unique_id { my ($self,$id) = @_; if( defined $id ) { $self->{'_uid'} = $id; } return $self->{'_uid'}; } =head2 add_element Title : add_element Usage : $map->add_element($element) Function: Tell a Bio::Map::MappableI object its default Map is this one; same as calling $element->default_map($map). *** does not actually add the element to this map! *** Returns : none Args : Bio::Map::MappableI object Status : Deprecated, will be removed in next version =cut sub add_element { my ($self, $element) = @_; return unless $element; $self->throw("This is not a Bio::Map::MappableI object but a [$element]") unless $element->isa('Bio::Map::MappableI'); $element->default_map($self); } =head2 get_elements Title : get_elements Usage : my @elements = $map->get_elements; Function: Retrieves all the elements on a map (unordered unless all elements have just 1 position on the map, in which case sorted) Returns : Array of Map elements (L) Args : none =cut sub get_elements { my $self = shift; my @elements = $self->SUPER::get_elements; # for backward compatability with MapIO tests, and for 'niceness', when # there is only 1 position per element we will return the elements in # order, as long as the positions have values set my $only_1 = 1; foreach my $element (@elements) { my @positions = $element->get_positions($self); if (@positions > 1 || (@positions == 1 && ! $positions[0]->value)) { $only_1 = 0; } } if ($only_1) { @elements = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [${[$_->get_positions($self)]}[0]->sortable, $_] } @elements; } return @elements; } =head2 each_element Title : each_element Function: Synonym of the get_elements() method. Status : deprecated, will be removed in the next version =cut *each_element = \&get_elements; =head2 purge_element Title : purge_element Usage : $map->purge_element($element) Function: Purge an element from the map. Returns : none Args : Bio::Map::MappableI object =cut sub purge_element { my ($self, $element) = @_; $self->throw("Must supply an argument") unless $element; $self->throw("This is [$element], not an object") unless ref($element); $self->throw("This is [$element], not a Bio::Map::MappableI object") unless $element->isa('Bio::Map::MappableI'); $self->purge_positions($element); } =head2 annotation Title : annotation Usage : $map->annotation($an_col); my $an_col = $map->annotation(); Function: Get the annotation collection (see Bio::AnnotationCollectionI) for this annotatable object. Returns : a Bio::AnnotationCollectionI implementing object, or undef Args : none to get, OR a Bio::AnnotationCollectionI implementing object to set =cut sub annotation { my $self = shift; if (@_) { $self->{_annotation} = shift } return $self->{_annotation} || return; } 1; BioPerl-1.6.923/Bio/Map/TranscriptionFactor.pm000444000765000024 1276212254227331 21247 0ustar00cjfieldsstaff000000000000# $Id: TranscriptionFactor.pm,v 1.6 2006/07/17 14:16:53 sendu Exp $ # # BioPerl module for Bio::Map::TranscriptionFactor # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Map::TranscriptionFactor - A transcription factor modelled as a mappable element =head1 SYNOPSIS use Bio::Map::TranscriptionFactor; use Bio::Map::GeneMap; use Bio::Map::Position; # model a TF that binds 500bp upstream of the BRCA2 gene in humans and # 250bp upstream of BRCA2 in mice my $tf = Bio::Map::TranscriptionFactor->get(-universal_name => 'tf1'); my $map1 = Bio::Map::GeneMap->get(-universal_name => "BRCA2", -species => "human"); my $map2 = Bio::Map::GeneMap->get(-universal_name => "BRCA2", -species => "mouse"); Bio::Map::Position->new(-map => $map1, -element => $tf, -start => -500, -length => 10); Bio::Map::Position->new(-map => $map2, -element => $tf, -start => -250, -length => 10); # Find out where the transcription factor binds foreach $pos ($tf->get_positions) { print $tf->universal_name, " binds at position " $pos->value, " relative to ", $pos->relative->description, " of gene ", $pos->map->universal_name, " in species ", $pos->map->species, "\n"; } =head1 DESCRIPTION A transcription factor modelled as a mappable element. It can have mulitple binding sites (positions) near multiple genes (maps). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Map::TranscriptionFactor; use strict; use base qw(Bio::Map::Mappable); our $TFS = {}; =head2 new Title : new Usage : my $tf = Bio::Map::TranscriptionFactor->new(); Function: Builds a new Bio::Map::TranscriptionFactor object Returns : Bio::Map::TranscriptionFactor Args : -universal_name => string name of the TF (in a form common to all species that have the TF, but unique amongst non-orthologous TFs), REQUIRED -description => string, free text description of the TF =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($u_name, $desc) = $self->_rearrange([qw(UNIVERSAL_NAME DESCRIPTION)], @args); $u_name || $self->throw("You must supply a -universal_name"); $self->universal_name($u_name); defined $desc && $self->description($desc); return $self; } =head2 get Title : get Usage : my $obj = Bio::Map::TranscriptionFactor->get(); Function: Builds a new Bio::Map::TranscriptionFactor object (like new()), or gets a pre-existing one that shares the same universal_name. Returns : Bio::Map::TranscriptionFactor Args : -universal_name => string name of the TF (in a form common to all species that have the TF, but unique amongst non-orthologous TFs), REQUIRED -description => string, free text description of the TF =cut sub get { my ($class, @args) = @_; my ($u_name) = Bio::Root::Root->_rearrange([qw(UNIVERSAL_NAME)], @args); if ($u_name && defined $TFS->{$u_name}) { return $TFS->{$u_name}; } return $class->new(@args); } =head2 universal_name Title : universal_name Usage : my $name = $obj->universal_name Function: Get/Set TF name, corresponding to the name of the TF in a form shared by orthologous versions of the TF in different species, but otherwise unique. Returns : string Args : none to get, OR string to set =cut sub universal_name { my ($self, $value) = @_; if (defined $value) { delete $TFS->{$self->{'_uname'}} if $self->{'_uname'}; $self->{'_uname'} = $value; $TFS->{$value} = $self; } return $self->{'_uname'}; } =head2 description Title : description Usage : my $desc = $obj->description Function: Get/Set a description of the TF. Returns : string Args : none to get, OR string to set =cut sub description { my $self = shift; if (@_) { $self->{desc} = shift } return $self->{desc} || ''; } 1; BioPerl-1.6.923/Bio/MapIO000755000765000024 012254227326 14762 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/MapIO/fpc.pm000444000765000024 3752512254227326 16261 0ustar00cjfieldsstaff000000000000# fpc.pm,v 1.2.2.1 2005/10/09 15:16:27 jason Exp # # BioPerl module for Bio::MapIO::fpc # # Please direct questions and support issues to # # Cared for by Gaurav Gupta # # Copyright AGCoL # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::MapIO::fpc - A FPC Map reader =head1 SYNOPSIS # do not use this object directly it is accessed through the Bio::MapIO system use Bio::MapIO; -format : specifies the format of the file format is "fpc", -file : specifies the name of the .fpc file -readcor : boolean argument, indicating if .cor is to be read or not. It looks for the .cor file in the same path as .fpc file. 0 : doesn't read .cor file 1 : reads the .cor file [default 0] -verbose : indicates the process of loading of fpc file my $mapio = Bio::MapIO->new(-format => "fpc", -file => "rice.fpc", -readcor => 0, -verbose => 0); my $map = $mapio->next_map(); foreach my $marker ( $map->each_markerid() ) { # loop through the markers associated with the map # likewise for contigs, clones, etc. } =head1 DESCRIPTION This object contains code for parsing and processing FPC files and creating L object from it. For faster access and better optimization, the data is stored internally in hashes. The corresponding objects are created on request. We handle reading of the FPC ourselves, since MapIO module of Bioperl adds too much overhead. =cut # Let the code begin... package Bio::MapIO::fpc; use strict; use POSIX; use Bio::Map::Physical; use Bio::Map::Clone; use Bio::Map::Contig; use Bio::Map::FPCMarker; use Bio::Range; use base qw(Bio::MapIO); my $_readcor; =head1 Initializer =head2 _initialize Title : _initialize Usage : called implicitly Function: calls the SUPER::_initialize Returns : nothing Args : species, readcor =cut sub _initialize{ my ($self,@args) = @_; my $species; $self->SUPER::_initialize(@args); ($species,$_readcor) = $self->_rearrange([qw(SPECIES READCOR)], @args); $_readcor = 0 unless (defined($_readcor)); } =head1 Access Methods These methods let you get and set the member variables =head2 next_map Title : next_map Usage : my $fpcmap = $mapio->next_map(); Function: gets the fpcmap from MapIO Returns : object of type L Args : none =cut sub next_map{ my ($self) = @_; my $line; my ($name,$fpcver,$moddate,$moduser,$contigcnt,$clonecnt,$markerscnt, $bandcnt,$marker,$seqclone); my ($corfile,$corindex,$BUFFER); my @cordata; my %fpcmarker; my ($contig, $contigNumber); my $curClone = 0; my $curMarker = 0; my $curContig = 0; my %_clones; my %_markers; my %_contigs; my $ctgzeropos = 1; my $map = Bio::Map::Physical->new('-units' => 'CB', '-type' => 'physical'); my $filename = $self->file(); my $fh = $self->{'_filehandle'}; if (defined($_readcor)) { $map->core_exists($_readcor); } else { $map->core_exists(0); } if ($map->core_exists()) { $corfile = substr($filename,0,length($filename)-3)."cor"; if (open(CORE,$corfile)) { while(read(CORE,$BUFFER,2)) { push(@cordata,unpack('n*', $BUFFER)); } } else { $map->core_exists(0); } } ## Read in the header while (defined($line = <$fh>)) { chomp($line); if ($line =~ m{^//\s+fpc\s+project\s+(.+)}) { $map->name($1); } if ($line =~ m{^//\s+([\d.]+)}) { my $version = $1; $version =~ /((\d+)\.(\d+))(.*)/; $map->version($1); if ($line =~ /User:\s+(.+)/) { $map->modification_user($1); } } if ($line =~ m{^//\s+Framework\s+(\w+)\s+(\w+)\s+([-\w]+)\s+(\w+)\s+(\w+)\s+(.+)$}) { $map->group_type($3) if ($2 eq "Label"); $map->group_abbr($5) if ($4 eq "Abbrev"); } last unless ($line =~ m{^//}); } if (!defined($map->group_type()) || !defined($map->group_abbr()) ) { $map->group_type("Chromosome"); $map->group_abbr("Chr"); } $_contigs{0}{'range'}{'end'} = 0; $_contigs{0}{'range'}{'start'} = 0; ## Read in the clone data while (defined($line = <$fh>)) { $marker = 0; $contig = 0; $seqclone = 0; $contigNumber = 0; my ($type,$name); my (@amatch,@pmatch,@ematch); my $bandsread = 0; last if ($line =~ /^Markerdata/); $line =~ /^(\w+)\s+:\s+"(.+)"/; ## these will be set if we did find the clone line ($type, $name) = ($1, $2); if ($name =~ /sd1/) { $seqclone = 1; } $_clones{$name}{'type'} = $type; $_clones{$name}{'contig'} = 0; $_contigs{'0'}{'clones'}{$name} = 0; my $temp; ## Loop through the following lines, getting attributes for clone while (defined($line = <$fh>) && $line !~ /^\s*\n$/) { if ($line =~ /^Map "ctg(\d+)" Ends (Left|Right) ([-\d]+)/) { $_clones{$name}{'contig'} = $1; $_contigs{$1}{'clones'}{$name} = 0; delete($_contigs{'0'}{'clones'}{$name}); $temp = $3; $contigNumber = $1; $line = <$fh>; $line =~ /^Map "ctg(\d+)" Ends (Left|Right) ([\d]+)/; $_clones{$name}{'range'}{'start'} = $temp; $_contigs{$contigNumber}{'range'}{'start'} = $temp if (!exists($_contigs{$contigNumber}{'range'}{'start'}) || $_contigs{$contigNumber}{'range'}{'start'} > $temp ); $_clones{$name}{'range'}{'end'} = $3; $_contigs{$contigNumber}{'range'}{'end'} = $3 if (!exists($_contigs{$contigNumber}{'range'}{'end'}) || $_contigs{$contigNumber}{'range'}{'end'} < $3 ); } elsif ($line =~ /^([a-zA-Z]+)_match_to_\w+\s+"(.+)"/) { my $matchtype = "match" . lc(substr($1, 0, 1)); $_clones{$name}{$matchtype}{$2} = 0; } elsif ($line =~ /^Positive_(\w+)\s+"(.+)"/) { $_clones{$name}{'markers'}{$2} = 0; $_markers{$2}{'clones'}{$name} = 0; $_markers{$2}{'type'} = $1; $_markers{$2}{'contigs'}{$contigNumber} = 0; $_contigs{$contigNumber}{'markers'}{$2} = 0; } elsif ($line =~ /^Bands\s+(\d+)\s+(\d+)/ && !$bandsread) { my $i = 0; my @numbands; $bandsread = 1; if ($map->core_exists()) { while($i<$2){ push(@numbands,$cordata[($1-1)+$i]); $i++; } $_clones{$name}{'bands'} = \@numbands; } else { push(@numbands,$1,$2); $_clones{$name}{'bands'} = \@numbands; } if (exists($_contigs{0}{'clones'}{$name})) { $_clones{$name}{'range'}{'start'} = $ctgzeropos; $_clones{$name}{'range'}{'end'} = $ctgzeropos + $2; $_contigs{0}{'range'}{'end'} = $ctgzeropos + $2; $ctgzeropos += $2; } } elsif ($line =~ /^Gel_number\s+(.+)/) { $_clones{$name}{'gel'} = $1; } elsif ($line =~ /^Remark\s+"(.+)"/) { $_clones{$name}{'remark'} .= $1; $_clones{$name}{'remark'} .= "\n"; if($seqclone == 1 ) { if( $1 =~ /\,\s+Chr(\d+)\s+/){ $_clones{$name}{'group'} = $1; } } } elsif ($line =~ /^Fp_number\s+"(.+)"/) { $_clones{$name}{'fp_number'} = $1; } elsif ($line =~ /^Shotgun\s+(\w+)\s+(\w+)/) { $_clones{$name}{'sequence_type'} = $1; $_clones{$name}{'sequence_status'} = $2; } elsif ($line =~ /^Fpc_remark\s+"(.+)"/) { $_clones{$name}{'fpc_remark'} .= $1; $_clones{$name}{'fpc_remark'} .= "\n"; } } $curClone++; print "Adding clone $curClone...\n\r" if ($self->verbose() && $curClone % 1000 == 0); } $map->_setCloneRef(\%_clones); $line = <$fh>; while (defined($line = <$fh>) && $line !~ /Contigdata/) { my ($type,$name); last if ($line !~ /^Marker_(\w+)\s+:\s+"(.+)"/); ($type, $name) = ($1, $2); $_markers{$name}{'type'} = $type; $_markers{$name}{'group'} = 0; $_markers{$name}{'global'} = 0; $_markers{$name}{'anchor'} = 0; while (defined($line = <$fh>) && $line !~ /^\s*\n$/) { if ($line =~ /^Global_position\s+([\d.]+)\s*(Frame)?/) { my $position = $1 - floor($1/1000)*1000; $position = sprintf("%.2f",$position); $_markers{$name}{'global'} = $position; $_markers{$name}{'group'} = floor($1/1000); $_markers{$name}{'anchor'} = 1; if(defined($2)) { $_markers{$name}{'framework'} = 1; } else { $_markers{$name}{'framework'} = 0; } } elsif ($line =~ /^Anchor_bin\s+"([\w\d.]+)"/) { my $grpmatch = $1; my $grptype = $map->group_type(); $grpmatch =~ /(\d+|\w)(.*)/; my ($group,$subgroup); $group = $1; $subgroup = $2; $subgroup = substr($subgroup,1) if ($subgroup =~ /^\./); $_markers{$name}{'group'} = $group; $_markers{$name}{'subgroup'} = $subgroup; } elsif ($line =~ /^Anchor_pos\s+([\d.]+)\s+(F|P)?/){ $_markers{$name}{'global'} = $1; $_markers{$name}{'anchor'} = 1; if ($2 eq 'F') { $_markers{$name}{'framework'} = 1; } else { $_markers{$name}{'framework'} = 0; } } elsif ($line =~ /^anchor$/) { $_markers{$name}{'anchor'} = 1; } elsif ($line =~ /^Remark\s+"(.+)"/) { $_markers{$name}{'remark'} .= $1; $_markers{$name}{'remark'} .= "\n"; } } $curMarker++; print "Adding Marker $curMarker...\n" if ($self->verbose() && $curMarker % 1000 == 0); } $map->_setMarkerRef(\%_markers); my $ctgname; my $grpabbr = $map->group_abbr(); my $chr_remark; $_contigs{0}{'group'} = 0; while (defined($line = <$fh>)) { if ($line =~ /^Ctg(\d+)/) { $ctgname = $1; $_contigs{$ctgname}{'group'} = 0; $_contigs{$ctgname}{'anchor'} = 0; $_contigs{$ctgname}{'position'} = 0; if ($line =~ /#\w*(.*)\w*$/) { $_contigs{$ctgname}{'remark'} = $1; if ($line =~ /#\s+Chr(\d+)\s+/) { $_contigs{$ctgname}{'group'} = $1; $_contigs{$ctgname}{'anchor'} = 1; } } } elsif ($line =~ /^Chr_remark\s+"(-|\+|Chr(\d+))\s+(.+)"$/) { $_contigs{$ctgname}{'anchor'} = 1; $_contigs{$ctgname}{'chr_remark'} = $3 if(defined($3)); if (defined($2)) { $_contigs{$ctgname}{'group'} = $2; } else { $_contigs{$ctgname}{'group'} = "?"; } } elsif ($line =~ /^User_remark\s+"(.+)"/) { $_contigs{$ctgname}{'usr_remark'} = $1; } elsif ($line =~ /^Trace_remark\s+"(.+)"/) { $_contigs{$ctgname}{'trace_remark'} = $1; } elsif ($grpabbr && $line =~ /^Chr_remark\s+"(\W|$grpabbr((\d+)|(\w+)|([.\w\d]+)))\s*(\{(.*)\}|\[(.*)\])?"\s+(Pos\s+((\d.)+|NaN))(NOEDIT)?/) { my $grpmatch = $2; my $pos = $10; if ($pos eq "NaN") { $pos = 0; print "Warning: Nan encountered for Contig position \n"; } $_contigs{$ctgname}{'chr_remark'} = $6; $_contigs{$ctgname}{'position'} = $pos; $_contigs{$ctgname}{'subgroup'} = 0; if (defined($grpmatch)) { $_contigs{$ctgname}{'anchor'} = 1; if ($grpmatch =~ /((\d+)((\D\d.\d+)|(.\d+)))|((\w+)(\.\d+))/) { my ($group,$subgroup); $group = $2 if($grpabbr eq "Chr"); $subgroup = $3 if($grpabbr eq "Chr"); $group = $7 if($grpabbr eq "Lg"); $subgroup = $8 if($grpabbr eq "Lg"); $subgroup = substr($subgroup,1) if ($subgroup =~ /^\./); $_contigs{$ctgname}{'group'} = $group; $_contigs{$ctgname}{'subgroup'} = $subgroup; } else { $_contigs{$ctgname}{'group'} = $grpmatch; } } else { $_contigs{$ctgname}{'anchor'} = 1; $_contigs{$ctgname}{'group'} = "?"; } } $curContig++; print "Adding Contig $curContig...\n" if ($self->verbose() && $curContig % 100 == 0); } $map->_setContigRef(\%_contigs); $map->_calc_markerposition(); $map->_calc_contigposition() if ($map->version() < 7.0); $map->_calc_contiggroup() if ($map->version() == 4.6); return $map; } =head2 write_map Title : write_map Usage : $mapio->write_map($map); Function: Write a map out Returns : none Args : Bio::Map::MapI =cut sub write_map{ my ($self,@args) = @_; $self->throw_not_implemented(); } 1; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Gaurav Gupta Email gaurav@genome.arizona.edu =head1 PROJECT LEADERS Jamie Hatfield jamie@genome.arizona.edu Dr. Cari Soderlund cari@genome.arizona.edu =head1 PROJECT DESCRIPTION The project was done in Arizona Genomics Computational Laboratory (AGCoL) at University of Arizona. This work was funded by USDA-IFAFS grant #11180 titled "Web Resources for the Computation and Display of Physical Mapping Data". For more information on this project, please refer: http://www.genome.arizona.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cutBioPerl-1.6.923/Bio/MapIO/mapmaker.pm000444000765000024 735112254227316 17257 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::MapIO::mapmaker # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::MapIO::mapmaker - A Mapmaker Map reader =head1 SYNOPSIS # do not use this object directly it is accessed through the Bio::MapIO system use Bio::MapIO; my $mapio = Bio::MapIO->new(-format => "mapmaker", -file => "mapfile.map"); while ( my $map = $mapio->next_map ) { # get each map foreach my $marker ( $map->each_element ) { # loop through the markers associated with the map } } =head1 DESCRIPTION This object contains code for parsing and processing Mapmaker output and creating L objects from it. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::MapIO::mapmaker; use strict; use Bio::Map::SimpleMap; use Bio::Map::LinkagePosition; use Bio::Map::Marker; use base qw(Bio::MapIO); =head2 next_map Title : next_map Usage : my $map = $factory->next_map; Function: Get one or more map objects from the Mapmaker input Returns : Bio::Map::MapI Args : none See L =cut sub next_map{ my ($self) = @_; my $map = Bio::Map::SimpleMap->new(-name => '', -units => 'cM', -type => 'Genetic'); # Mapmaker input can be free-form, like the result of a copy-paste # from a terminal, with no particular format before or after the # map data. The $in_map variable is a flag that's set to 1 when # we're reading map data lines and set back to 0 when we're finished. my ($in_map,$runningDistance); while ( defined ($_ = $self->_readline()) ) { if ( /^\s+Markers\s+Distance/ ) { $in_map = 1; next; } next unless $in_map; s/ +/\t/; my ($number,$name,$distance) = split; $runningDistance += $distance unless ($distance =~ /-+/); $runningDistance = '0.0' if ($runningDistance == 0 || $distance =~ /-+/); my $pos = Bio::Map::LinkagePosition->new(-order => $number, -map => $map, -value => $runningDistance ); my $marker = Bio::Map::Marker->new(-name => $name, -position => $pos ); if ($distance =~ /-+/) { # last marker $in_map = 0; return $map; } } } =head2 write_map Title : write_map Usage : $factory->write_map($map); Function: Write a map out through the factory Returns : none Args : Bio::Map::MapI =cut sub write_map{ my ($self,@args) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Matrix000755000765000024 012254227337 15263 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Matrix/Generic.pm000444000765000024 5041612254227337 17360 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::Generic # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::Generic - A generic matrix implementation =head1 SYNOPSIS # A matrix has columns and rows my $matrix = Bio::Matrix::Generic->new; $matrix->add_column(1,$column1); $matrix->add_column(2,$column2); my $element = $matrix->entry_by_num(1,2); $matrix->entry_by_num(1,2,$newval); my $entry = $matrix->entry('human', 'mouse'); $matrix->entry('human','mouse', $newval); =head1 DESCRIPTION This is a general purpose matrix object for dealing with row+column data which is typical when enumerating all the pairwise combinations and desiring to get slices of the data. Data can be accessed by column and row names or indexes. Matrix indexes start at 0. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Matrix::Generic; use strict; use base qw(Bio::Root::Root Bio::Matrix::MatrixI); =head2 new Title : new Usage : my $obj = Bio::Matrix::Generic->new(); Function: Builds a new Bio::Matrix::Generic object Returns : an instance of Bio::Matrix::Generic Args : -values => arrayref of arrayrefs of data initialization -rownames => arrayref of row names -colnames => arrayref of col names -matrix_id => id of the matrix -matrix_name=> name of the matrix -matrix_init_value => default value to initialize empty cells =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($values, $rownames, $colnames, $id,$name,$init_val) = $self->_rearrange([qw(VALUES ROWNAMES COLNAMES MATRIX_ID MATRIX_NAME MATRIX_INIT_VALUE)],@args); $self->matrix_id($id) if defined $id; $self->matrix_name($name) if defined $name; if( defined $rownames && defined $colnames ) { if( ref($rownames) !~ /ARRAY/i ) { $self->throw("need an arrayref for the -rownames option"); } # insure we copy the values $self->{'_rownames'} = [ @$rownames ]; my $count = 0; %{$self->{'_rownamesmap'}} = map { $_ => $count++ } @$rownames; if( ref($colnames) !~ /ARRAY/i ) { $self->throw("need an arrayref for the -colnames option"); } # insure we copy the values $self->{'_colnames'} = [ @$colnames ]; $count = 0; %{$self->{'_colnamesmap'}} = map { $_ => $count++ } @$colnames; $self->{'_values'} = []; if( defined $values ) { if( ref($values) !~ /ARRAY/i ) { $self->throw("Need an arrayref of arrayrefs (matrix) for -values option"); } for my $v ( @$values ) { if( ref($v) !~ /ARRAY/i ) { $self->throw("Need and array of arrayrefs (matrix) for -values option"); } push @{$self->{'_values'}}, [@$v]; } } else { my @fill = ($init_val) x scalar @$colnames; # undef init_val will be default for ( @$rownames ) { push @{$self->{'_values'}}, [@fill]; } } } elsif( ! defined $rownames && ! defined $colnames && ! defined $values ) { $self->{'_values'} = []; $self->{'_rownames'} = []; $self->{'_colnames'} = []; } else { $self->throw("Must have either provided no values/colnames/rownames or provided all three"); } return $self; } =head2 matrix_id Title : matrix_id Usage : my $id = $matrix->matrix_id Function: Get/Set the matrix ID Returns : scalar value Args : [optional] new id value to store =cut sub matrix_id{ my $self = shift; return $self->{'_matid'} = shift if @_; return $self->{'_matid'}; } =head2 matrix_name Title : matrix_name Usage : my $name = $matrix->matrix_name(); Function: Get/Set the matrix name Returns : scalar value Args : [optional] new matrix name value =cut sub matrix_name{ my $self = shift; return $self->{'_matname'} = shift if @_; return $self->{'_matname'}; } =head2 entry Title : entry Usage : my $entry = $matrix->entry($row,$col) Function: Get the value for a specific cell as specified by the row and column names Returns : scalar value or undef if row or col does not exist Args : $rowname - name of the row $colname - column name =cut sub entry{ my ($self,$row,$column,$newvalue) = @_; if( ! defined $row || ! defined $column ) { $self->throw("Need at least 2 ids"); } my ($rownum) = $self->row_num_for_name($row); my ($colnum) = $self->column_num_for_name($column); return $self->entry_by_num($rownum,$colnum,$newvalue); } =head2 get_entry Title : get_entry Usage : my $entry = $matrix->get_entry($rowname,$columname) Function: Get the entry for a given row,column pair Returns : scalar Args : $row name $column name =cut sub get_entry{ $_[0]->entry($_[1],$_[2]) } =head2 entry_by_num Title : entry_by_num Usage : my $entry = $matrix->entry_by_num($rownum,$colnum) Function: Get an entry by row and column numbers instead of by name (rows and columns start at 0) Returns : scalar value or undef if row or column name does not exist Args : $row - row number $col - column number [optional] $newvalue to store at this cell =cut sub entry_by_num { my ($self,$row,$col,$newvalue) = @_; if( ! defined $row || ! defined $col || $row !~ /^\d+$/ || $col !~ /^\d+$/ ) { $self->warn("expected to get 2 number for entry_by_num"); return; } if( defined $newvalue ) { return $self->_values->[$row][$col] = $newvalue; } else { return $self->_values->[$row][$col]; } } sub get_element { my $self = shift; $self->entry(@_); } =head2 column Title : column Usage : my @col = $matrix->column('ALPHA'); OR $matrix->column('ALPHA', \@col); Function: Get/Set a particular column Returns : Array (in array context) or arrayref (in scalar context) of values. For setting will warn if the new column is of a different length from the rest of the columns. Args : name of the column [optional] new column to store here =cut sub column{ my ($self,$column,$newcol) = @_; if( ! defined $column ) { $self->warn("Need at least a column id"); return; } my $colnum = $self->column_num_for_name($column); if( ! defined $colnum ) { $self->warn("could not find column number for $column"); return; } return $self->column_by_num($colnum,$newcol); } =head2 get_column Title : get_column Usage : my @row = $matrix->get_column('ALPHA'); Function: Get a particular column Returns : Array (in array context) or arrayref (in scalar context) of values Args : name of the column =cut sub get_column { $_[0]->column($_[1]) } =head2 column_by_num Title : column_by_num Usage : my @col = $matrix->column_by_num(1); OR $matrix->column_by_num(1,\@newcol); Function: Get/Set a column by its number instead of name (cols/rows start at 0) Returns : Array (in array context) or arrayref (in scalar context) of values Args : name of the column [optional] new value to store for a particular column =cut sub column_by_num{ my ($self,$colnum,$newcol) = @_; if( ! defined $colnum ) { $self->warn("need at least a column number"); return; } my $rowcount = $self->num_rows; my $colcount = $self->num_columns; my $ret; if( defined $newcol ) { if( ref($newcol) !~ /ARRAY/i) { $self->warn("expected a valid arrayref for resetting a column"); return; } if( scalar @$newcol != $rowcount ) { $self->warn("new column is not the correct length ($rowcount) - call add or remove row to shrink or grow the number of rows first"); return; } for(my $i=0; $i < $rowcount; $i++) { $self->entry_by_num($i,$colnum,$newcol->[$i]); } $ret = $newcol; } else { $ret = []; for(my $i=0; $i < $rowcount; $i++) { push @$ret,$self->entry_by_num($i,$colnum); } } if( wantarray ) { return @$ret } return $ret; } =head2 row Title : row Usage : my @row = $matrix->row($rowname); OR $matrix->row($rowname,\@rowvalues); Function: Get/Set the row of the matrix Returns : Array (in array context) or arrayref (in scalar context) Args : rowname [optional] new value of row to store =cut sub row { my ($self,$row,$newrow) = @_; if( ! defined $row) { $self->warn("Need at least a row id"); return; } my $rownum = $self->row_num_for_name($row); return $self->row_by_num($rownum,$newrow); } =head2 get_row Title : get_row Usage : my @row = $matrix->get_row('ALPHA'); Function: Get a particular row Returns : Array (in array context) or arrayref (in scalar context) of values Args : name of the row =cut sub get_row { $_[0]->row($_[1]) } =head2 row_by_num Title : row_by_num Usage : my @row = $matrix->row_by_num($rownum); OR $matrix->row($rownum,\@rowvalues); Function: Get/Set the row of the matrix Returns : Array (in array context) or arrayref (in scalar context) Args : rowname [optional] new value of row to store =cut sub row_by_num{ my ($self,$rownum,$newrow) = @_; if( ! defined $rownum ) { $self->warn("need at least a row number"); return; } my $colcount = $self->num_columns; my $ret; if( defined $newrow ) { if( ref($newrow) !~ /ARRAY/i) { $self->warn("expected a valid arrayref for resetting a row"); return; } if( scalar @$newrow != $colcount ) { $self->warn("new row is not the correct length ($colcount) - call add or remove column to shrink or grow the number of columns first"); return; } for(my $i=0; $i < $colcount; $i++) { $self->entry_by_num($rownum,$i, $newrow->[$i]); } $ret = $newrow; } else { $ret = []; for(my $i=0; $i < $colcount; $i++) { # we're doing this to explicitly # copy the entire row push @$ret, $self->entry_by_num($rownum,$i); } } if( wantarray ) { return @$ret } return $ret; } =head2 diagonal Title : diagonal Usage : my @diagonal = $matrix->get_diagonal() Function: Get the diagonal of a matrix Returns : Array (in array context) or arrayref (in scalar context) of values which lie along the diagonal Args : none =cut sub get_diagonal{ my ($self) = @_; my @diag; my $rowcount = $self->num_rows; my $colcount = $self->num_columns; for(my $i = 0; $i < $rowcount; $i++ ) { push @diag, $self->entry_by_num($i,$i); } return @diag; } =head2 add_row Title : add_row Usage : $matrix->add_row($index,\@newrow); Function: Adds a row at particular location in the matrix. If $index < the rowcount will shift all the rows down by the number of new rows. To add a single empty row, simply call $matrix->add_row($index,undef); Returns : the updated number of total rows in the matrix Args : index to store name of the row (header) newrow to add, if this is undef will add a single row with all values set to undef =cut sub add_row{ my ($self,$index,$name,$newrow) = @_; if( !defined $index || $index !~ /^\d+$/ ) { $self->warn("expected a valid row index in add_row"); return; } elsif( ! defined $name) { $self->warn("Need a row name or heading"); return; } elsif( defined $self->row_num_for_name($name) ) { $self->warn("Need a unqiue name for the column heading, $name is already used"); return; } my $colcount = $self->num_columns; my $rowcount = $self->num_rows; if( $index > $rowcount ) { $self->warn("cannot add a row beyond 1+last row at the end ($rowcount) not $index - adding at $rowcount instead"); $index = $rowcount; } if( ! defined $newrow ) { $newrow = []; $newrow->[$colcount] = undef; } elsif( ref($newrow) !~ /ARRAY/i ) { $self->throw("Expected either undef or a valid arrayref for add_row"); } # add this row to the matrix by carving out space for it with # splice splice(@{$self->{'_values'}}, $index,0,[]); for( my $i = 0; $i < $colcount; $i++ ) { $self->entry_by_num($index,$i,$newrow->[$i]); } splice(@{$self->{'_rownames'}}, $index,0,$name); # Sadly we have to remap these each time (except for the case # when we're adding a new column to the end, but I don't think # the speedup for that case warrants the extra code at this time. my $ct = 0; %{$self->{'_rownamesmap'}} = map { $_ => $ct++} @{$self->{'_rownames'}}; return $self->num_rows; } =head2 remove_row Title : remove_row Usage : $matrix->remove_row($colnum) Function: remove a row from the matrix shifting all the rows up by one Returns : Updated number of rows in the matrix Args : row index =cut sub remove_row{ my ($self,$rowindex) = @_; my $rowcount = $self->num_rows; if( $rowindex > $rowcount ) { $self->warn("rowindex $rowindex is greater than number of rows $rowcount, cannot process"); return 0; } else { splice(@{$self->_values},$rowindex,1); delete $self->{'_rownamesmap'}->{$self->{'_rownames'}->[$rowindex]}; splice(@{$self->{'_rownames'}},$rowindex,1); } my $ct = 0; %{$self->{'_rownamesmap'}} = map { $_ => $ct++} @{$self->{'_rownames'}}; return $self->num_rows; } =head2 add_column Title : add_column Usage : $matrix->add_column($index,$colname,\@newcol); Function: Adds a column at particular location in the matrix. If $index < the colcount will shift all the columns right by the number of new columns. To add a single empty column, simply call $matrix->add_column($index,undef); Returns : the updated number of total columns in the matrix Args : index to store name of the column (header) newcolumn to add, if this is undef will add a single column with all values set to undef =cut sub add_column{ my ($self,$index,$name,$newcol) = @_; if( !defined $index || $index !~ /^\d+$/ ) { $self->warn("expected a valid col index in add_column"); return; } elsif( ! defined $name) { $self->warn("Need a column name or heading"); return; } elsif( defined $self->column_num_for_name($name) ) { $self->warn("Need a unqiue name for the column heading, $name is already used"); return; } my $colcount = $self->num_columns; my $rowcount = $self->num_rows; if( $index > $colcount ) { $self->warn("cannot add a column beyond 1+last column at the end ($colcount) not $index - adding at $colcount instead"); $index = $colcount; } if( ! defined $newcol ) { $newcol = []; $newcol->[$rowcount] = undef; # make the array '$rowcount' long } elsif( ref($newcol) !~ /ARRAY/i ) { $self->throw("Expected either undef or a valid arrayref for add_row"); } for( my $i = 0; $i < $rowcount; $i++ ) { # add this column to each row splice(@{$self->_values->[$i]},$index,0,[]); $self->entry_by_num($i,$index,$newcol->[$i]); } splice(@{$self->{'_colnames'}}, $index,0,$name); # Sadly we have to remap these each time (except for the case # when we're adding a new column to the end, but I don't think # the speedup for that case warrants the extra code at this time. my $ct = 0; %{$self->{'_colnamesmap'}} = map {$_ => $ct++} @{$self->{'_colnames'}}; return $self->num_columns; } =head2 remove_column Title : remove_column Usage : $matrix->remove_column($colnum) Function: remove a column from the matrix shifting all the columns to the left by one Returns : Updated number of columns in the matrix Args : column index =cut sub remove_column{ my ($self,$colindex) = @_; my $colcount = $self->num_columns; my $rowcount = $self->num_rows; if( $colindex > $colcount ) { $self->warn("colindex $colindex is greater than number of columns ($colcount), cannot process"); return 0; } else { for(my $i = 0; $i < $rowcount; $i++ ) { splice(@{$self->_values->[$i]},$colindex,1); } delete $self->{'_colnamesmap'}->{$self->{'_colnames'}->[$colindex]}; splice(@{$self->{'_colnames'}},$colindex,1); } my $ct = 0; %{$self->{'_colnamesmap'}} = map {$_ => $ct++} @{$self->{'_colnames'}}; return $self->num_columns; } =head2 column_num_for_name Title : column_num_for_name Usage : my $num = $matrix->column_num_for_name($name) Function: Gets the column number for a particular column name Returns : integer Args : string =cut sub column_num_for_name{ my ($self,$name) = @_; return $self->{'_colnamesmap'}->{$name}; } =head2 row_num_for_name Title : row_num_for_name Usage : my $num = $matrix->row_num_for_name Function: Gets the row number for a particular row name Returns : integer Args : string =cut sub row_num_for_name{ my ($self,$name) = @_; return $self->{'_rownamesmap'}->{$name} } =head2 column_header Title : column_header Usage : my $name = $matrix->column_header(0) Function: Gets the column header for a particular column number Returns : string Args : integer =cut sub column_header{ my ($self,$num) = @_; return $self->{'_colnames'}->[$num]; } =head2 row_header Title : row_header Usage : my $name = $matrix->row_header(0) Function: Gets the row header for a particular row number Returns : string Args : integer =cut sub row_header{ my ($self,$num) = @_; return $self->{'_rownames'}->[$num]; } =head2 num_rows Title : num_rows Usage : my $rowcount = $matrix->num_rows; Function: Get the number of rows Returns : integer Args : none =cut sub num_rows{ my ($self) = @_; return scalar @{$self->_values}; } =head2 num_columns Title : num_columns Usage : my $colcount = $matrix->num_columns Function: Get the number of columns Returns : integer Args : none =cut sub num_columns{ my ($self) = @_; return scalar @{$self->_values->[0] || []}; } =head2 row_names Title : row_names Usage : my @rows = $matrix->row_names Function: The names of all the rows Returns : array in array context, arrayref in scalar context Args : none =cut sub row_names{ if( wantarray ) { return @{shift->{'_rownames'}}; } else { return shift->{'_rownames'}; } } =head2 column_names Title : column_names Usage : my @columns = $matrix->column_names Function: The names of all the columns Returns : array in array context, arrayref in scalar context Args : none =cut sub column_names{ if( wantarray ) { return @{shift->{'_colnames'}}; } else { return shift->{'_colnames'}; } } =head2 private methods Private methods for a Generic Matrix =head2 _values Title : _values Usage : $matrix->_values(); Function: get/set for array ref of the matrix containing distance values Returns : an array reference Args : an array reference =cut sub _values{ my ($self,$val) = @_; if( $val ){ $self->{'_values'} = $val; } return $self->{'_values'}; } 1; BioPerl-1.6.923/Bio/Matrix/IO.pm000444000765000024 1427512254227326 16314 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::IO # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::IO - A factory for Matrix parsing =head1 SYNOPSIS use Bio::Matrix::IO; my $parser = Bio::Matrix::IO->new(-format => 'scoring', -file => 'BLOSUMN50'); my $matrix = $parser->next_matrix; =head1 DESCRIPTION This is a general factory framework for writing parsers for Matricies. This includes parsing output from distance output like PHYLIP's ProtDist. Additionally it should be possible to fit parsers for PWM and PSSMs once their Matrix objects are written. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::IO; use strict; use base qw(Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Matrix::IO->new(); Function: Builds a new Bio::Matrix::IO object Returns : an instance of Bio::Matrix::IO Args : =cut sub new { my($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::Matrix::IO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{'-file'} || $ARGV[0] ) || 'scoring'; $format = "\L$format"; # normalize capitalization to lower case # normalize capitalization return unless( $class->_load_format_module($format) ); return "Bio::Matrix::IO::$format"->new(@args); } } =head2 newFh Title : newFh Usage : $fh = Bio::Matrix::IO->newFh(-file=>$filename,-format=>'Format') Function: does a new() followed by an fh() Example : $fh = Bio::Matrix::IO->newFh(-file=>$filename,-format=>'Format') $matrix = <$fh>; # read a matrix object print $fh $matrix; # write a matrix object Returns : filehandle tied to the Bio::SeqIO::Fh class Args : =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Get a filehandle type access to the matrix parser Example : $fh = $obj->fh; # make a tied filehandle $matrix = <$fh>; # read a matrix object print $fh $matrix; # write a matrix object Returns : filehandle tied to Bio::Matrix::IO class Args : none =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } =head2 format Title : format Usage : $format = $obj->format() Function: Get the matrix format Returns : matrix format Args : none =cut # format() method inherited from Bio::Root::IO =head2 next_matrix Title : next_matrix Usage : my $matrix = $matixio->next_matrix; Function: Parse the next matrix from the data stream Returns : L type object or undef when finished Args : none =cut sub next_matrix{ my ($self) = @_; $self->throw_not_implemented(); } =head2 write_matrix Title : write_matrix Usage : $io->write_matrix($matrix) Function: Writes a matrix out to the data stream Returns : none Args : Array of Bio::Matrix::MatrixI object - note that not all matricies can be converted to each format, beware with mixing matrix types and output formats =cut sub write_matrix{ my ($self) = @_; $self->throw_not_implemented(); } sub _initialize { my ($self,@args) = @_; $self->_initialize_io(@args); } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL Matrix::IO stuff* Function: Loads up (like use) a module at run time on demand =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::Matrix::IO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Returns : guessed format of filename (lower case) Args : filename =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'scoring' if /BLOSUM|PAM$/i; return 'phylip' if /\.dist$/i; } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my $class = shift; return bless {'matrixio' => shift},$class; } sub READLINE { my $self = shift; return $self->{'matrixio'}->next_tree() unless wantarray; my (@list,$obj); push @list,$obj while $obj = $self->{'treeio'}->next_tree(); return @list; } sub PRINT { my $self = shift; $self->{'matrixio'}->write_tree(@_); } 1; BioPerl-1.6.923/Bio/Matrix/MatrixI.pm000444000765000024 1266412254227327 17363 0ustar00cjfieldsstaff000000000000# $Id $ # # BioPerl module for Bio::Matrix::MatrixI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::MatrixI - An interface for describing a Matrix =head1 SYNOPSIS # Get a Matrix object =head1 DESCRIPTION This is an interface describing how one should be able to interact with a matrix. One can have a lot of information I suppose and this outline won't really work for PWM or PSSMs. We will have to derive a particular interface for those. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::MatrixI; use strict; use base qw(Bio::Root::RootI); =head2 matrix_id Title : matrix_id Usage : my $id = $matrix->matrix_id Function: Get the matrix ID Returns : string value Args : =cut sub matrix_id{ my ($self) = @_; $self->throw_not_implemented(); } =head2 matrix_name Title : matrix_name Usage : my $name = $matrix->matrix_name(); Function: Get the matrix name Returns : string value Args : =cut sub matrix_name{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_entry Title : get_entry Usage : my $entry = $matrix->get_entry($rowname,$columname) Function: Get the entry for a given row,column pair Returns : scalar Args : $row name $column name =cut sub get_entry{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_column Title : get_column Usage : my @row = $matrix->get_column('ALPHA'); Function: Get a particular column Returns : Array (in array context) or arrayref (in scalar context) of values Args : name of the column =cut sub get_column{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_row Title : get_row Usage : my @row = $matrix->get_row('ALPHA'); Function: Get a particular row Returns : Array (in array context) or arrayref (in scalar context) of values Args : name of the row =cut sub get_row{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_diagonal Title : get_diagonal Usage : my @diagonal = $matrix->get_diagonal; Function: Get the diagonal of the matrix Returns : Array (in array context) or arrayref (in scalar context) Args : none =cut sub get_diagonal{ my ($self) = @_; $self->throw_not_implemented(); } =head2 column_num_for_name Title : column_num_for_name Usage : my $num = $matrix->column_num_for_name($name) Function: Gets the column number for a particular column name Returns : integer Args : string =cut sub column_num_for_name{ my ($self) = @_; $self->throw_not_implemented(); } =head2 row_num_for_name Title : row_num_for_name Usage : my $num = $matrix->row_num_for_name($name) Function: Gets the row number for a particular row name Returns : integer Args : string =cut sub row_num_for_name{ my ($self) = @_; $self->throw_not_implemented(); } =head2 num_rows Title : num_rows Usage : my $rowcount = $matrix->num_rows; Function: Get the number of rows Returns : integer Args : none =cut sub num_rows{ my ($self) = @_; $self->throw_not_implemented(); } =head2 num_columns Title : num_columns Usage : my $colcount = $matrix->num_columns Function: Get the number of columns Returns : integer Args : none =cut sub num_columns{ my ($self) = @_; $self->throw_not_implemented(); } # inverse? =head2 reverse Title : reverse Usage : my $matrix = $matrix->reverse Function: Get the reverse of a matrix Returns : Args : =cut sub reverse{ my ($self) = @_; $self->throw_not_implemented(); } =head2 row_names Title : row_names Usage : my @rows = $matrix->row_names Function: The names of all the rows Returns : array in array context, arrayref in scalar context Args : none =cut sub row_names{ my ($self) = @_; $self->throw_not_implemented(); } =head2 column_names Title : column_names Usage : my @columns = $matrix->column_names Function: The names of all the columns Returns : array in array context, arrayref in scalar context Args : none =cut sub column_names{ my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Matrix/Mlagan.pm000444000765000024 1133612254227317 17177 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::Mlagan # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::Mlagan - A generic matrix with mlagan fields =head1 SYNOPSIS # See L for most methods. # These are relevant for mlagan IO: $matrix->gap_open(-400); $matrix->gap_continue(-25); =head1 DESCRIPTION This is based on Bio::Matrix::Generic, differing by storing gap_open and gap_continue data members to allow mlagan IO (see Bio::Matrix::IO::mlagan). (Those values are 'outside' the matrix.) It also limits the structure to a 6x6 matrix with row & column names 'A', 'C', 'G', 'T', '.' and 'N'. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Matrix::Mlagan; use strict; use base qw(Bio::Matrix::Generic); =head2 new Title : new Usage : my $obj = Bio::Matrix::Generic->new(); Function: Builds a new Bio::Matrix::Generic object Returns : an instance of Bio::Matrix::Generic Args : -values => arrayref of arrayrefs of data initialization -matrix_id => id of the matrix -matrix_name => name of the matrix -matrix_init_value => default value to initialize empty cells -gap_open => gap open penalty (int) -gap_continue => gap continue penalty (int) NB: -rownames and -colnames should not be given here, since they are always being set to 'A', 'C', 'G', 'T', '.' and 'N'. =cut sub new { my($class, @args) = @_; my %args = (@args, -rownames => [qw(A C G T . N)], -colnames => [qw(A C G T . N)]); my $self = $class->SUPER::new(%args); $self->_set_from_args(\@args, -methods => [qw(gap_open gap_continue)]); return $self; } =head2 gap_open Title : gap_open Usage : $obj->gap_open(-400); Function: Get/set the gap open amount. Returns : int Args : none to get, OR int to set =cut sub gap_open { my $self = shift; if (@_) { $self->{gap_open} = shift } return $self->{gap_open} || return; } =head2 gap_continue Title : gap_continue Usage : $obj->gap_continue(-25); Function: Get/set the gap continue amount. Returns : int Args : none to get, OR int to set =cut sub gap_continue { my $self = shift; if (@_) { $self->{gap_continue} = shift } return $self->{gap_continue} || return; } =head2 add_row Title : add_row Usage : Do not use Function: This generic method is not suitable for mlagan, where the number of rows is fixed. Returns : Warning Args : none =cut sub add_row { shift->warn("Mlagan matricies are fixed at 6x6"); } =head2 remove_row Title : remove_row Usage : Do not use Function: This generic method is not suitable for mlagan, where the number of rows is fixed. Returns : Warning Args : none =cut sub remove_row { shift->warn("Mlagan matricies are fixed at 6x6"); } =head2 add_column Title : add_column Usage : Do not use Function: This generic method is not suitable for mlagan, where the number of columns is fixed. Returns : Warning Args : none =cut sub add_column { shift->warn("Mlagan matricies are fixed at 6x6"); } =head2 remove_column Title : remove_column Usage : Do not use Function: This generic method is not suitable for mlagan, where the number of columns is fixed. Returns : Warning Args : none =cut sub remove_column { shift->warn("Mlagan matricies are fixed at 6x6"); } 1; BioPerl-1.6.923/Bio/Matrix/PhylipDist.pm000444000765000024 2547612254227321 20076 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Matrix::PhylipDist # # # Please direct questions and support issues to # # Cared for by Shawn Hoon # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::PhylipDist - A Phylip Distance Matrix object =head1 SYNOPSIS use Bio::Tools::Phylo::Phylip::ProtDist; my $dist = Bio::Tools::Phylo::Phylip::ProtDist->new( -file=>"protdist.out", -program=>"ProtDist"); #or my $dist = Bio::Tools::Phylo::Phylip::ProtDist->new( -fh=>"protdist.out", -program=>"ProtDist"); #get specific entries my $distance_value = $dist->get_entry('ALPHA','BETA'); my @columns = $dist->get_column('ALPHA'); my @rows = $dist->get_row('BETA'); my @diagonal = $dist->get_diagonal(); #print the matrix in phylip numerical format print $dist->print_matrix; =head1 DESCRIPTION Simple object for holding Distance Matrices generated by the following Phylip programs: 1) dnadist 2) protdist 3) restdist It currently handles parsing of the matrix without the data output option. 5 Alpha 0.00000 4.23419 3.63330 6.20865 3.45431 Beta 4.23419 0.00000 3.49289 3.36540 4.29179 Gamma 3.63330 3.49289 0.00000 3.68733 5.84929 Delta 6.20865 3.36540 3.68733 0.00000 4.43345 Epsilon 3.45431 4.29179 5.84929 4.43345 0.00000 =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a "_". =cut # Let the code begin... package Bio::Matrix::PhylipDist; use strict; use base qw(Bio::Root::Root Bio::Matrix::MatrixI); =head2 new Title : new Usage : my $family = Bio::Matrix::PhylipDist->new(-file=>"protdist.out", -program=>"protdist"); Function: Constructor for PhylipDist Object Returns : L =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($matrix,$values, $names, $program,$matname, $matid) = $self->_rearrange([qw(MATRIX VALUES NAMES PROGRAM MATRIX_NAME MATRIX_ID )],@args); ($matrix && $values && $names) || $self->throw("Need matrix, values, and names fields all provided!"); $program && $self->matrix_name($program) if defined $program; $self->_matrix($matrix) if ref($matrix) =~ /HASH/i; $self->_values($values) if ref($values) =~ /ARRAY/i; $self->names($names) if ref($names) =~ /ARRAY/i; $self->matrix_name($matname) if defined $matname; $self->matrix_id ($matid) if defined $matid; return $self; } =head2 get_entry Title : get_entry Usage : $matrix->get_entry(); Function: returns a particular entry Returns : a float Arguments: string id1, string id2 =cut sub get_entry { my ($self,$row,$column) = @_; $row && $column || $self->throw("Need at least 2 ids"); my %matrix = %{$self->_matrix}; my @values = @{$self->_values}; if(ref $matrix{$row}{$column}){ my ($i,$j) = @{$matrix{$row}{$column}}; return $values[$i][$j]; } return; } =head2 get_row Title : get_row Usage : $matrix->get_row('ALPHA'); Function: returns a particular row Returns : an array of float Arguments: string id1 =cut sub get_row { my ($self,$row) = @_; $row || $self->throw("Need at least a row id"); my %matrix = %{$self->_matrix}; my @values = @{$self->_values}; my @names = @{$self->names}; $matrix{$row} || return; my ($val) = values %{$matrix{$row}}; my $row_pointer = $val->[0]; my $index = scalar(@names)-1; return @{$values[$row_pointer]}[0..$index]; } =head2 get_column Title : get_column Usage : $matrix->get_column('ALPHA'); Function: returns a particular column Returns : an array of floats Arguments: string id1 =cut sub get_column { my ($self,$column) = @_; $column || $self->throw("Need at least a column id"); my %matrix = %{$self->_matrix}; my @values = @{$self->_values}; my @names = @{$self->names}; $matrix{$column} || return (); my ($val) = values %{$matrix{$column}}; my $row_pointer = $val->[0]; my @ret; for(my $i=0; $i < scalar(@names); $i++) { push @ret, $values[$i][$row_pointer]; } return @ret; } =head2 get_diagonal Title : get_diagonal Usage : $matrix->get_diagonal(); Function: returns the diagonal of the matrix Returns : an array of float Arguments: string id1 =cut sub get_diagonal { my ($self) = @_; my %matrix = %{$self->_matrix}; my @values = @{$self->_values}; my @return; foreach my $name (@{$self->names}){ my ($i,$j) = @{$matrix{$name}{$name}}; push @return,$values[$i][$j]; } return @return; } =head2 print_matrix Title : print_matrix Usage : $matrix->print_matrix(); Function: returns a string of the matrix in phylip format Returns : a string Arguments: =cut sub print_matrix { my ($self) = @_; my @names = @{$self->names}; my @values = @{$self->_values}; my %matrix = %{$self->_matrix}; my $str; $str.= (" "x 4). scalar(@names)."\n"; foreach my $name (@names){ my $newname = $name. (" " x (15-length($name))); if( length($name) >= 15 ) { $newname .= " " } $str.=$newname; my $count = 0; foreach my $n (@names) { my ($i,$j) = @{$matrix{$name}{$n}}; if($count < $#names){ $str .= $values[$i][$j]. " "; } else { if( ! defined $values[$i][$j] ) { $self->debug("no value for $i,$j cell\n"); } else { $str .= $values[$i][$j]; } } $count++; } $str.="\n"; } return $str; } =head2 _matrix Title : _matrix Usage : $matrix->_matrix(); Function: get/set for hash reference of the pointers to the value matrix Returns : hash reference Arguments: hash reference =cut sub _matrix { my ($self,$val) = @_; if($val){ $self->{'_matrix'} = $val; } return $self->{'_matrix'}; } =head2 names Title : names Usage : $matrix->names(); Function: get/set for array ref of names of sequences Returns : an array reference Arguments: an array reference =cut sub names { my ($self,$val) = @_; if($val){ $self->{'_names'} = $val; } return $self->{'_names'}; } =head2 program Title : program Usage : $matrix->program(); Function: get/set for the program name generating this matrix Returns : string Arguments: string =cut sub program { my ($self) = shift; return $self->matrix_name(@_); } =head2 _values Title : _values Usage : $matrix->_values(); Function: get/set for array ref of the matrix containing distance values Returns : an array reference Arguments: an array reference =cut sub _values { my ($self,$val) = @_; if($val){ $self->{'_values'} = $val; } return $self->{'_values'}; } =head1 L implementation =head2 matrix_id Title : matrix_id Usage : my $id = $matrix->matrix_id Function: Get/Set the matrix ID Returns : scalar value Args : [optional] new id value to store =cut sub matrix_id{ my $self = shift; return $self->{'_matid'} = shift if @_; return $self->{'_matid'}; } =head2 matrix_name Title : matrix_name Usage : my $name = $matrix->matrix_name(); Function: Get/Set the matrix name Returns : scalar value Args : [optional] new matrix name value =cut sub matrix_name{ my $self = shift; return $self->{'_matname'} = shift if @_; return $self->{'_matname'}; } =head2 column_header Title : column_header Usage : my $name = $matrix->column_header(0) Function: Gets the column header for a particular column number Returns : string Args : integer =cut sub column_header{ my ($self,$num) = @_; my @coln = $self->column_names; return $coln[$num]; } =head2 row_header Title : row_header Usage : my $name = $matrix->row_header(0) Function: Gets the row header for a particular row number Returns : string Args : integer =cut sub row_header{ my ($self,$num) = @_; my @rown = $self->row_names; return $rown[$num]; } =head2 column_num_for_name Title : column_num_for_name Usage : my $num = $matrix->column_num_for_name($name) Function: Gets the column number for a particular column name Returns : integer Args : string =cut sub column_num_for_name{ my ($self,$name) = @_; my $ct = 0; foreach my $n ( $self->column_names ) { return $ct if $n eq $name; $ct++; } return; } =head2 row_num_for_name Title : row_num_for_name Usage : my $num = $matrix->row_num_for_name($name) Function: Gets the row number for a particular row name Returns : integer Args : string =cut sub row_num_for_name{ my ($self,$name) = @_; my $ct = 0; foreach my $n ( $self->row_names ) { return $ct if $n eq $name; $ct++; } } =head2 num_rows Title : num_rows Usage : my $rowcount = $matrix->num_rows; Function: Get the number of rows Returns : integer Args : none =cut sub num_rows{ return scalar @{shift->names} } =head2 num_columns Title : num_columns Usage : my $colcount = $matrix->num_columns Function: Get the number of columns Returns : integer Args : none =cut sub num_columns{ return scalar @{shift->names}; } =head2 row_names Title : row_names Usage : my @rows = $matrix->row_names Function: The names of all the rows Returns : array in array context, arrayref in scalar context Args : none =cut sub row_names{ return @{shift->names} } =head2 column_names Title : column_names Usage : my @columns = $matrix->column_names Function: The names of all the columns Returns : array in array context, arrayref in scalar context Args : none =cut sub column_names{ return @{shift->names} } 1; BioPerl-1.6.923/Bio/Matrix/Scoring.pm000444000765000024 1346712254227312 17406 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::Scoring # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::Scoring - Object which can hold scoring matrix information =head1 SYNOPSIS use Bio::Matrix::Scoring; =head1 DESCRIPTION An object which can handle AA or NT scoring matrix information. Some transformation properties are available too. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::Scoring; use strict; use base qw(Bio::Matrix::Generic); =head2 new Title : new Usage : my $obj = Bio::Matrix::Scoring->new(); Function: Builds a new Bio::Matrix::Scoring object Returns : an instance of Bio::Matrix::Scoring Args : =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($entropy,$expected,$scale,$scaleval,$database, $lowestscore,$highestscore,$lambda,$H) = $self->_rearrange([qw( ENTROPY EXPECTED SCALE SCALE_VALUE DATABASE LOWEST_SCORE HIGHEST_SCORE LAMBDA H)], @args); $self->entropy ($entropy); $self->expected_score($expected); $self->scale ($scale); $self->scale_value($scaleval); $self->database ($database); $self->lowest_score($lowestscore); $self->highest_score($highestscore); $self->lambda($lambda); $self->H($H); return $self; } =head2 entropy Title : entropy Usage : $obj->entropy($newval) Function: Example : Returns : value of entropy (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub entropy{ my $self = shift; return $self->{'entropy'} = shift if @_; return $self->{'entropy'}; } =head2 expected_score Title : expected_score Usage : $obj->expected_score($newval) Function: Example : Returns : value of expected (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub expected_score{ my $self = shift; return $self->{'expected'} = shift if @_; return $self->{'expected'}; } =head2 scale Title : scale Usage : $obj->scale($newval) Function: Example : Returns : value of scale (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub scale{ my $self = shift; return $self->{'scale'} = shift if @_; return $self->{'scale'}; } =head2 scale_value Title : scale_value Usage : $obj->scale_value($newval) Function: Example : Returns : value of scale_value (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub scale_value{ my $self = shift; return $self->{'scale_value'} = shift if @_; return $self->{'scale_value'}; } =head2 description Title : description Usage : $obj->description($newval) Function: Example : Returns : value of description (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub description{ my $self = shift; return $self->{'description'} = shift if @_; return $self->{'description'}; } =head2 database Title : database Usage : $obj->database($newval) Function: Example : Returns : value of database (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub database{ my $self = shift; return $self->{'database'} = shift if @_; return $self->{'database'}; } =head2 lowest_score Title : lowest_score Usage : $obj->lowest_score($newval) Function: Example : Returns : value of lowest_score (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub lowest_score{ my $self = shift; return $self->{'lowest_score'} = shift if @_; return $self->{'lowest_score'}; } =head2 highest_score Title : highest_score Usage : $obj->highest_score($newval) Function: Example : Returns : value of highest_score (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub highest_score{ my $self = shift; return $self->{'highest_score'} = shift if @_; return $self->{'highest_score'}; } =head2 lambda Title : lambda Usage : $obj->lambda($newval) Function: Example : Returns : value of lambda (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub lambda{ my $self = shift; return $self->{'lambda'} = shift if @_; return $self->{'lambda'}; } =head2 H Title : H Usage : $obj->H($newval) Function: Example : Returns : value of H (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub H{ my $self = shift; return $self->{'H'} = shift if @_; return $self->{'H'}; } 1; BioPerl-1.6.923/Bio/Matrix/IO000755000765000024 012254227334 15567 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Matrix/IO/mlagan.pm000444000765000024 772712254227334 17536 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::IO::mlagan # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::IO::mlagan - A parser for the mlagan substitution matrix =head1 SYNOPSIS use Bio::Matrix::IO; my $parser = Bio::Matrix::IO->new(-format => 'mlagan', -file => 'nucmatrix.txt'); my $matrix = $parser->next_matrix; my $gap_open = $parser->gap_open; my $gap_continue = $parser->gap_continue; =head1 DESCRIPTION Use to read in and write out substitution matrix files suitable for use by mlagan. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::IO::mlagan; use strict; use Bio::Matrix::Mlagan; use base qw(Bio::Matrix::IO); =head2 new Title : new Usage : my $obj = Bio::Matrix::IO::mlagan->new(); Function: Builds a new Bio::Matrix::IO::mlagan object Returns : an instance of Bio::Matrix::IO::mlagan Args : =cut =head2 next_matrix Title : next_matrix Usage : my $matrix = $obj->next_matrix(); Function: parses a matrix file Returns : L Args : none =cut sub next_matrix { my $self = shift; my (@matrix, $gap_open, $gap_cont); while (defined ($_ = $self->_readline)) { if (/^[ACGTN\.]/) { my (undef, @values) = split; push(@matrix, \@values); } elsif (/^[-\d]/) { ($gap_open, $gap_cont) = split; last; } } @matrix == 6 || $self->throw("Something wrong with file, was it the correct format?"); my $matrix = Bio::Matrix::Mlagan->new(-values => \@matrix, -gap_open => $gap_open, -gap_continue => $gap_cont); return $matrix; } =head2 write_matrix Title : write_matrix Usage : $obj->write_matrix($matrix) Function: Write out a matrix in mlagan format Returns : n/a Args : L =cut sub write_matrix { my ($self, $matrix) = @_; $matrix || $self->throw("Matrix required as input"); my $gap_open = $matrix->gap_open; my $gap_continue = $matrix->gap_continue; unless (defined $gap_open && defined $gap_continue) { $self->throw("gap_open() and gap_continue() in the supplied matrix object must both be set"); } $self->_print(" A C G T . N\n"); foreach my $char (qw(A C G T . N)) { my @row = $matrix->get_row($char); my $row = $char; foreach my $val (@row) { $row .= " " x (5 - length($val)) . $val; } $self->_print($row."\n"); } $self->_print("\n$gap_open $gap_continue"); return; } 1; BioPerl-1.6.923/Bio/Matrix/IO/phylip.pm000444000765000024 1075712254227327 17623 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::IO::phylip # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::IO::phylip - A parser for PHYLIP distance matricies =head1 SYNOPSIS use Bio::Matrix::IO; my $parser = Bio::Matrix::IO->new(-format => 'phylip', -file => 't/data/phylipdist.out'); my $matrix = $parser->next_matrix; =head1 DESCRIPTION This is a parser for PHYLIP distance matrix output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::IO::phylip; use vars qw($DEFAULTPROGRAM); use strict; $DEFAULTPROGRAM = 'phylipdist'; use Bio::Matrix::PhylipDist; use base qw(Bio::Matrix::IO); =head2 new Title : new Usage : my $obj = Bio::Matrix::IO::phylip->new(); Function: Builds a new Bio::Matrix::IO::phylip object Returns : an instance of Bio::Matrix::IO::phylip Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($prog) = $self->_rearrange([qw(PROGRAM)], @args); $self->{'_program'} = $prog || $DEFAULTPROGRAM; return $self; } =head2 next_matrix Title : next_matrix Usage : my $matrix = $parser->next_matrix Function: Get the next result set from parser data Returns : L Args : none =cut sub next_matrix { my ($self) = @_; my @names; my @values; my $entry; my $size = 0; while ($entry=$self->_readline) { if($#names >=0 && $entry =~/^\s+\d+\n$/){ $self->_pushback($entry); last; } elsif($entry=~/^\s+(\d+)\n$/){ $size = $1; next; } elsif( $entry =~ s/^\s+(\-?\d+\.\d+)/$1/ ) { my (@line) = split( /\s+/,$entry); push @{$values[-1]}, @line; next; } my ($n,@line) = split( /\s+/,$entry); push @names, $n; push @values, [@line]; } if( scalar @names != $size ) { $self->warn("The number of entries ".(scalar @names). " is not the same $size"); } $#names>=0 || return; my %dist; my $i=0; foreach my $name(@names){ my $j=0; foreach my $n(@names) { $dist{$name}{$n} = [$i,$j]; $j++; } $i++; } my $matrix = Bio::Matrix::PhylipDist->new (-matrix_name => $self->{'_program'}, -matrix => \%dist, -names => \@names, -values => \@values); return $matrix; } =head2 write_matrix Title : write_matrix Usage : $matio->write_matrix($matrix) Function: Write out a matrix in the phylip distance format Returns : none Args : L =cut sub write_matrix { my ($self,@matricies) = @_; foreach my $matrix ( @matricies ) { my @names = @{$matrix->names}; my @values = @{$matrix->_values}; my %matrix = %{$matrix->_matrix}; my $str; $str.= (" "x 4). scalar(@names)."\n"; foreach my $name (@names){ my $newname = $name. (" " x (15-length($name))); if( length($name) >= 15 ) { $newname .= " " } $str.=$newname; my $count = 0; foreach my $n (@names){ my ($i,$j) = @{$matrix{$name}{$n}}; if($count < $#names){ $str.= $values[$i][$j]. " "; } else { $str.= $values[$i][$j]; } $count++; } $str.="\n"; } $self->_print($str); } } 1; BioPerl-1.6.923/Bio/Matrix/IO/scoring.pm000444000765000024 1062712254227313 17751 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Matrix::IO::scoring # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Matrix::IO::scoring - A parser for PAM/BLOSUM matricies =head1 SYNOPSIS use Bio::Matrix::IO; my $parser = Bio::Matrix::IO->new(-format => 'scoring', -file => 'BLOSUM50'); my $matrix = $parser->next_matrix; =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::IO::scoring; use strict; use Bio::Matrix::Scoring; use base qw(Bio::Matrix::IO); =head2 new Title : new Usage : my $obj = Bio::Matrix::IO::scoring->new(); Function: Builds a new Bio::Matrix::IO::scoring object Returns : an instance of Bio::Matrix::IO::scoring Args : =cut =head2 next_matrix Title : next_matrix Usage : my $matrux = $parser->next_matrix Function: parses a scoring matrix (BLOSUM,PAM styles) Returns : L Args : none =cut sub next_matrix{ my ($self) = @_; local ($_); my (@matrix,@cols,@rows,%extras,$inmatrix); while( defined ( $_ = $self->_readline ) ) { next if ( /^\s*$/); if( /^\#/ ) { if( $inmatrix ) { $self->_pushback($_); last; } if( m/Entropy\s+\=\s+(\S+)\,\s+ Expected\s+\=\s+(\S+)/ox ) { $extras{'-entropy'} = $1; $extras{'-expected'} = $2; } elsif ( m/Expected\s+score\s+\=\s+(\S+)\, \s+Entropy\s+\=\s+(\S+)/xo ){ $extras{'-entropy'} = $2; $extras{'-expected'} = $1; } elsif( m/(PAM\s+\d+)\s+substitution.+ scale\s+\=\s+(\S+)\s+\=\s+(\S+)/ox ) { $extras{'-matrix_name'} = $1; $extras{'-scale'} = $2; $extras{'-scale_value'} = $3; } elsif( /Blocks Database\s+\=\s+(\S+)/o ) { $extras{'-database'} = $1; } elsif( m/(\S+)\s+Bit\s+Units/ox ) { $extras{'-scale'} = $1; } elsif( m/Lowest score\s+\=\s+(\S+)\,\s+ Highest score\s+\=\s+(\S+)/ox ) { $extras{'-lowest_score'} = $1; $extras{'-highest_score'} = $2; } elsif( m/(Lambda)\s+\=\s+(\S+)\s+bits\, \s+(H)\s+\=\s+(\S+)/ox ) { # This is a DNA matrix $extras{$1} = $2; $extras{$3} = $4; } } elsif( s/^\s+(\S+)/$1/ ) { @cols = split; if( $cols[0] ne 'A' ) { $self->warn("Unrecognized first line of matrix, we might not have parsed it correctly"); } $inmatrix = 1; } elsif( $inmatrix ) { if( ! /^(\S+)/ ) { $inmatrix = 0; next } my ($rowname,@row) = split; push @rows, $rowname; push @matrix, [@row]; } else { print; } } my $matrix = Bio::Matrix::Scoring->new(-values => \@matrix, -rownames => \@rows, -colnames => \@cols, %extras); } =head2 write_matrix Title : write_matrix Usage : $matio->write_matrix($matrix) Function: Write out a matrix in the BLOSUM/PAM format Returns : none Args : L =cut sub write_matrix{ my ($self,@args) = @_; $self->warn("cannot actually use this function yet - it isn't finished"); return; } 1; BioPerl-1.6.923/Bio/Matrix/PSM000755000765000024 012254227337 15722 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Matrix/PSM/InstanceSite.pm000444000765000024 1752112254227317 21032 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::Matrix::PSM::InstanceSite - A PSM site occurance =head1 SYNOPSIS use Bio::Matrix::PSM::InstanceSite; #You can get an InstanceSite object either from a file: my ($instances,$matrix)=$SomePSMFile->parse_next; #or from memory my %params=(seq=>'TATAAT', id=>"TATAbox1", accession=>'ENSG00000122304', mid=>'TB1', desc=>'TATA box, experimentally verified in PRM1 gene', -relpos=>-35, -anchor=>'CHR7', -start=>35000921, -end=>35000926); #Last 2 arguments are passed to create a Bio::LocatableSeq object #Anchor shows the coordinates system for the Bio::LocatableSeq object =head1 DESCRIPTION Abstract interface to PSM site occurrence (PSM sequence match). InstanceSite objects may be used to describe a PSM (See L) sequence matches. The usual characteristic of such a match is sequence coordinates, score, sequence and sequence (gene) identifier- accession number or other id. This object inherits from Bio::LocatableSeq (which defines the real sequence) and might hold a SiteMatrix object, used to detect the CRE (cis-regulatory element), or created from this CRE. While the documentation states that the motif id and gene id (accession) combination should be unique, this is not entirely true- there might be more than one occurrence of the same cis-regulatory element in the upstream region of the same gene. Therefore relpos would be the third element to create a really unique combination. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head2 Description Bio::Matrix::PSM::InstanceSiteI implementation =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::InstanceSite; use strict; use base qw(Bio::LocatableSeq Bio::Matrix::PSM::InstanceSiteI); =head2 new Title : new Usage : my $isntance=Bio::Matrix::PSM::InstanceSite->new (-seq=>'TATAAT', -id=>"TATAbox1", -accession_number='ENSG00000122304', -mid=>'TB1', -desc=>'TATA box, experimentally verified in PRM1 gene', -relpos=>-35, -anchor=>'CHR7', -start=>35000921, -end=>35000926, strand=>1) Function: Creates an InstanceSite object from memory. Throws : Example : Returns : Bio::Matrix::PSM::InstanceSite object Args : hash =cut sub new { my ($class, @args) = @_; my %args = @args; #Too many things to rearrange, and I am creating >1K such objects routinely, so this is a performance issue $args{'-start'} ||= 1; my $end = $args{'-start'} + length($args{-seq}) -1; if (!defined($args{-strand})) { $args{-strand}=1; @args=%args; } my $self = $class->SUPER::new(@args,'-end',$end); while( @args ) { (my $key = shift @args) =~ s/-//gi; #deletes all dashes (only dashes)! $args{$key} = shift @args; } #should throw exception if seq is null, for now just warn if (($args{seq} eq '') || (!defined($args{seq}))) { $args{seq}="AGCT"; warn "No sequence?!\n"; } $self->{mid}=$args{mid}; $self->seq($args{seq}); $self->desc($args{desc}); $self->{score}=$args{score}; $self->{relpos}=$args{relpos}; $self->{frame}=$args{frame}; $self->{anchor}=$args{anchor}; return $self; } =head2 mid Title : mid Usage : my $mid=$instance->mid; Function: Get/Set the motif id Throws : Example : Returns : scalar Args : scalar =cut sub mid { my $self = shift; my $prev = $self->{mid}; if (@_) { $self->{mid} = shift; } return $prev; } =head2 score Title : score Usage : my $score=$instance->score; Function: Get/Set the score (mismatches) between the instance and the attached (or initial) PSM Throws : Example : Returns : real number Args : real number =cut sub score { my $self = shift; my $prev = $self->{score}; if (@_) { $self->{score} = shift; } return $prev; } =head2 anchor Title : anchor Usage : my $anchor=$instance->anchor; Function: Get/Set the anchor which shows what coordinate system start/end use Throws : Example : Returns : string Args : string =cut sub anchor { my $self = shift; my $prev = $self->{anchor}; if (@_) { $self->{anchor} = shift; } return $prev; } =head2 start Title : start Usage : my $start=$instance->start; Function: Get/Set the position of the instance on the sequence used Throws : Example : Returns : integer Args : integer =cut #Provided by LocatableSeq =head2 minstance Title : minstance Usage : my $minstance=$misntance->score; Function: Get/Set the unique identifier- sequence id/motif id, for example PRM1_TATAbox. Not necessarily human readable. Throws : Example : Returns : string Args : string =cut sub minstance { my $self = shift; my $prev = $self->{minstance}; if (@_) { $self->{minstance} = shift; } return $prev; } =head2 relpos Title : relpos Usage : my $seqpos=$instance->relpos; Function: Get/Set the relative position of the instance with respect to the transcription start site (if known). Can and usually is negative. Throws : Example : Returns : integer Args : integer =cut sub relpos { my $self = shift; my $prev = $self->{relpos}; if (@_) { $self->{relpos} = shift; } return $prev; } =head2 annotation Title : annotation Usage : $ann = $seq->annotation or $seq->annotation($annotation) Function: Gets or sets the annotation Returns : L object Args : None or L object See L and L for more information =cut sub annotation { my ($obj,$value) = @_; if( defined $value ) { $obj->throw("object of class ".ref($value)." does not implement ". "Bio::AnnotationCollectionI. Too bad.") unless $value->isa("Bio::AnnotationCollectionI"); $obj->{'_annotation'} = $value; } elsif( ! defined $obj->{'_annotation'}) { $obj->{'_annotation'} = Bio::Annotation::Collection->new(); } return $obj->{'_annotation'}; } =head2 species Title : species Usage : $species = $seq->species() or $seq->species($species) Function: Gets or sets the species Returns : L object Args : None or L object See L for more information =cut sub species { my ($self, $species) = @_; if ($species) { $self->{'species'} = $species; } else { return $self->{'species'}; } } =head2 frame Title : frame Usage : my $frane=$instance->frame; Function: Get/Set the frame of a DNA instance with respect to a protein motif used. Returns undef if the motif was not protein or the DB is protein. Throws : Example : Returns : integer Args : integer (0, 1, 2) =cut sub frame { my $self = shift; my $prev = $self->{frame}; if (@_) { $self->{frame} = shift; $self->throw("This is not a legitimate frame") unless (grep(/$self->{frame}/,qw[0 1 2])); } return $prev; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/InstanceSiteI.pm000444000765000024 1010612254227321 21126 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::Matrix::PSM::InstanceSiteI - InstanceSite interface, holds an instance of a PSM =head1 SYNOPSIS use Bio::Matrix::PSM::InstanceSite; #Y ou can get an InstanceSite object either from a file: my ($instances,$matrix)=$SomePSMFile->parse_next; #or from memory my %params=(seq => 'TATAAT', id => "TATAbox1", accession => 'ENSG00000122304', mid => 'TB1', desc => 'TATA box, experimentally verified in PRM1 gene', relpos => -35); =head1 DESCRIPTION Abstract interface to PSM site occurrence (PSM sequence match). InstanceSite objects may be used to describe a PSM (See Bio::Matrix::PSM::SiteMatrix) sequence matches. The usual characteristic of such a match is sequence coordinates, score, sequence and sequence (gene) identifier- accession number or other id. This object inherits from Bio::LocatableSeq (which defines the real sequence) and might hold a SiteMatrix object, used to detect the CRE (cis-regulatory element), or created from this CRE. While the documentation states that the motif id and gene id (accession) combination should be unique, this is not entirely true- there might be more than one occurrence of the same cis-regulatory element in the upstream region of the same gene. Therefore relpos would be the third element to create a really unique combination. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 SEE ALSO L, L, L =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::InstanceSiteI; use strict; use base qw(Bio::Root::RootI); =head2 mid Title : mid Usage : my $mid=$instance->mid; Function: Get/Set the motif id Throws : Returns : scalar Args : scalar =cut sub mid { my $self = shift; $self->throw_not_implemented(); } =head2 score Title : score Usage : my $score=$instance->score; Function: Get/Set the score (mismatches) between the instance and the attached (or initial) PSM Throws : Returns : real number Args : real number =cut sub score { my $self = shift; $self->throw_not_implemented(); } =head2 start Title : start Usage : my $start=$instance->start; Function: Get/Set the position of the instance on the sequence used Throws : Returns : integer Args : integer =cut sub start { my $self = shift; $self->throw_not_implemented(); } =head2 relpos Title : relpos Usage : my $seqpos=$instance->relpos; Function: Get/Set the relative position of the instance with respect to the transcription start site (if known). Can and usually is negative. Throws : Returns : integer Args : integer =cut sub relpos { my $self = shift; $self->throw_not_implemented(); } =head2 minstance Title : minstance Usage : my $minstance=$misntance->score; Function: Get/Set the unique identifier- sequence id/motif id, for example PRM1_TATAbox. Not necessarily human readable. Throws : Returns : string Args : string =cut sub minstance { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Matrix/PSM/IO.pm000444000765000024 1773112254227337 16755 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::IO - PSM parser =head1 SYNOPSIS use Bio::Matrix::PSM::IO; my $psmIO= Bio::Matrix::PSM::IO->new(-file=>$file, -format=>'transfac'); my $release=$psmIO->release; #Using Bio::Matrix::PSM::PsmHeader methods my $release=$psmIO->release; while (my $psm=$psmIO->next_psm) { my %psm_header=$psm->header; my $ic=$psm_header{IC}; my $sites=$psm_header{sites}; my $width=$psm_header{width}; my $score=$psm_header{e_val}; my $IUPAC=$psm->IUPAC; } my $instances=$psm->instances; foreach my $instance (@{$instances}) { my $id=$instance->primary_id; } =head1 DESCRIPTION This module allows you to read DNA position scoring matrices and/or their respective sequence matches from a file. There are two header methods, one belonging to Bio::Matrix::PSM::IO::driver and the other to Bio::Matrix::PSM::Psm. They provide general information about the file (driver) and for the current PSM result (Psm) respectively. Psm header method always returns the same thing, but some values in the hash might be empty, depending on the file you are parsing. You will get undef in this case (no exceptions are thrown). Please note that the file header data (commenatries, version, input data, configuration, etc.) might be obtained through Bio::Matrix::PSM::PsmHeader methods. Some methods are driver specific (meme, transfac, etc.): meme: weight mast: seq, instances If called when you parse a different file type you will get undef. For example: my $psmIO= Bio::Matrix::PSM::IO->new(file=>$file, format=>'transfac'); my %seq=$psmIO->seq; will return an empty hash. To see all methods and how to use them go to Bio::Matrix::PSM::PsmHeaderI. See also Bio::Matrix::PSM::PsmI for details on using and manipulating the parsed data. The only way to write PFM/PWM is through masta module (something like fasta for DNA matrices). You can see an example by reading Bio::Matrix::PSM::IO::masta documentation. =head1 See also Bio::Matrix::PSM::PsmI, Bio::Matrix::PSM::PsmHeaderI, Bio::Matrix::PSM::IO::masta =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::IO; use vars qw(@PSMFORMATS); use strict; use base qw(Bio::Root::IO); @PSMFORMATS = qw(meme transfac mast psiblast masta); =head2 new Title : new Usage : my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'meme', -file=>$file); Function: Associates a file with the appropriate parser Throws : Throws if the file passed is in HTML format or if some criteria for the file format are not met. See L and L for more details. Example : Returns : psm object, associated with a file with matrix file Args : hash =cut sub new { my($caller,@args) = @_; my $class = ref($caller) || $caller; my $self; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::Matrix::PSM::IO(\S+)/ ) { $self = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{'-file'} || $ARGV[0] ) || 'scoring'; $class->throw("$format format unrecognized or an argument error occured\n.") if (!grep(/$format/,@Bio::Matrix::PSM::IO::PSMFORMATS)); $format = "\L$format"; # normalize capitalization to lower case # normalize capitalization return unless( $class->_load_format_module($format) ); return "Bio::Matrix::PSM::IO::$format"->new(@args); } } =head2 fh Title : fh Usage : $obj->fh Function: Get a filehandle type access to the matrix parser Example : $fh = $obj->fh; # make a tied filehandle $matrix = <$fh>; # read a matrix object Returns : filehandle tied to Bio::Matrix::PSM::IO class Args : none =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL Matrix::PSM::IO stuff* Function: Loads up (like use) a module at run time on demand =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::Matrix::PSM::IO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Returns : guessed format of filename (lower case) Args : filename =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'meme' if /.meme$|meme.html$/i; return 'transfac' if /\.dat$/i; return 'mast' if /^mast\.|\.mast.html$|.mast$/i; } =head2 next_psm Title : next_psm Usage : my $psm=$psmIO->next_psm(); Function: Reads the next PSM from the input file, associated with this object Throws : Throws if there ara format violations in the input file (checking is not very strict with all drivers). Example : Returns : Bio::Matrix::PSM::Psm object Args : none =cut sub next_psm { my $self = shift; $self->throw_not_implemented(); } =head2 _parseMatrix Title : _parseMatrix Usage : Function: Parses the next site matrix information in the meme file Throws : Example : Internal stuff Returns : hash as for constructing a SiteMatrix object (see SiteMatrixI) Args : string =cut sub _parseMatrix { my $self = shift; $self->throw_not_implemented(); } =head2 _parseInstance Title : _parseInstance Usage : Function: Parses the next sites instances from the meme file Throws : Example : Internal stuff Returns : Bio::Matrix::PSM::SiteMatrix object Args : array references =cut sub _parseInstance { my $self = shift; $self->throw_not_implemented(); } =head2 _parse_coordinates Title : _parse_coordinates Usage : Function: Throws : Example : Internal stuff Returns : Args : =cut sub _parse_coordinates { my $self = shift; $self->throw_not_implemented(); } =head2 header Title : header Usage : my %header=$psmIO->header; Function: Returns the header for the PSM file, format specific Throws : Example : Returns : Hash or a single string with driver specific information Args : none =cut sub header { my $self = shift; $self->throw_not_implemented(); } =head2 _make_matrix Title : _make_matrix Usage : Function: makes a matrix from 4 array references (A C G T) Throws : Example : Returns : SiteMatrix object Args : array of references(A C G T) =cut sub _make_matrix { my $self = shift; $self->throw_not_implemented(); } sub DESTROY { my $self = shift; $self->close(); } 1; BioPerl-1.6.923/Bio/Matrix/PSM/ProtMatrix.pm000444000765000024 6373612254227326 20563 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::ProtMatrix - SiteMatrixI implementation, holds a position scoring matrix (or position weight matrix) with log-odds scoring information. =head1 SYNOPSIS use Bio::Matrix::PSM::ProtMatrix; # Create from memory by supplying probability matrix hash both as strings or # arrays where the frequencies Hash entries of the form lN refer to an array # of position-specific log-odds scores for amino acid N. Hash entries of the # form pN represent the position-specific probability of finding amino acid N. my %param = ( 'id' => 'A. thaliana protein atp1', '-e_val' => $score, 'lS' => [ '-2', '3', '-3', '2', '-3', '1', '1', '3' ], 'lF' => [ '-1', '-4', '0', '-5', '0', '-5', '-4', '-4' ], 'lT' => [ '-1', '1', '0', '1', '-2', '-1', '0', '1' ], 'lN' => [ '-3', '-1', '-2', '3', '-5', '5', '-2', '0' ], 'lK' => [ '-2', '0', '-3', '2', '-3', '2', '-3', '-1' ], 'lY' => [ '-2', '-3', '-3', '-4', '-3', '-4', '-4', '-4' ], 'lE' => [ '-3', '4', '-3', '2', '-4', '-2', '-3', '2' ], 'lV' => [ '0', '-2', '1', '-4', '1', '-4', '-1', '-3' ], 'lQ' => [ '-1', '0', '-2', '3', '-4', '1', '-3', '0' ], 'lM' => [ '8', '-3', '8', '-3', '1', '-3', '-3', '-3' ], 'lC' => [ '-2', '-3', '-3', '-4', '-3', '-4', '-3', '-3' ], 'lL' => [ '1', '-3', '1', '-4', '3', '-4', '-2', '-4' ], 'lA' => [ '-2', '1', '-2', '0', '-2', '-2', '2', '2' ], 'lW' => [ '-2', '-4', '-3', '-5', '-4', '-5', '-5', '-5' ], 'lP' => [ '-3', '-2', '-4', '-3', '-1', '-3', '6', '-3' ], 'lH' => [ '-2', '-2', '-3', '-2', '-5', '-2', '-2', '-3' ], 'lD' => [ '-4', '-1', '-3', '1', '-3', '-1', '-3', '4' ], 'lR' => [ '-2', '-1', '-3', '0', '-4', '4', '-4', '-3' ], 'lI' => [ '0', '-3', '0', '-4', '6', '-4', '-2', '-2' ], 'lG' => [ '-4', '-2', '-4', '-2', '-5', '-3', '-1', '-2' ], 'pS' => [ '0', '33', '0', '16', '1', '12', '11', '25' ], 'pF' => [ '0', '0', '2', '0', '3', '0', '0', '0' ], 'pT' => [ '0', '8', '7', '10', '1', '2', '7', '8' ], 'pN' => [ '0', '0', '2', '13', '0', '36', '1', '4' ], 'pK' => [ '0', '5', '0', '13', '1', '15', '0', '2' ], 'pY' => [ '0', '0', '0', '0', '0', '0', '0', '0' ], 'pE' => [ '0', '41', '1', '12', '0', '0', '0', '15' ], 'pV' => [ '0', '3', '9', '0', '2', '0', '3', '1' ], 'pQ' => [ '0', '0', '0', '15', '0', '4', '0', '3' ], 'pM' => [ '100', '0', '66', '0', '2', '0', '0', '0' ], 'pC' => [ '0', '0', '0', '0', '0', '0', '0', '0' ], 'pL' => [ '0', '0', '8', '0', '25', '0', '4', '0' ], 'pA' => [ '0', '10', '1', '9', '2', '0', '22', '16' ], 'pW' => [ '0', '0', '0', '0', '0', '0', '0', '0' ], 'pP' => [ '0', '0', '0', '0', '3', '1', '45', '0' ], 'pH' => [ '0', '0', '0', '0', '0', '0', '1', '0' ], 'pD' => [ '0', '0', '1', '7', '2', '2', '0', '22' ], 'pR' => [ '0', '0', '0', '3', '0', '27', '0', '0' ], 'pI' => [ '0', '0', '3', '0', '59', '1', '2', '3' ], 'pG' => [ '0', '0', '0', '1', '0', '0', '4', '1' ], ); my $matrix = Bio::Matrix::PSM::ProtMatrix( %param ); my $site = Bio::Matrix::PSM::ProtMatrix->new(%param); # Or get it from a file: use Bio::Matrix::PSM::IO; my $psmIO = Bio::Matrix::PSM::IO->new(-file => $file, -format => 'psi-blast'); while (my $psm = $psmIO->next_psm) { #Now we have a Bio::Matrix::PSM::Psm object, # see Bio::Matrix::PSM::PsmI for details #This is a Bio::Matrix::PSM::ProtMatrix object now my $matrix = $psm->matrix; } # Get a simple consensus, where alphabet is: # {A, R, N, D, C, Q, E, G, H, I, L, K, M, F, P, S, T, W, Y, V,} # choosing the highest probability or N if prob is too low my $consensus = $site->consensus; # Retrieving and using regular expressions: my $regexp = $site->regexp; my $count = grep($regexp,$seq); my $count = ($seq=~ s/$regexp/$1/eg); print "Motif $mid is present $count times in this sequence\n"; =head1 DESCRIPTION ProtMatrix is designed to provide some basic methods when working with position scoring (weight) matrices related to protein sequences. A protein PSM consists of 20 vectors with 20 frequencies (one per amino acid per position). This is the minimum information you should provide to construct a PSM object. The vectors can be provided as strings with frequencies where the frequency is {0..a} and a=1. This is the way MEME compressed representation of a matrix and it is quite useful when working with relational DB. If arrays are provided as an input (references to arrays actually) they can be any number, real or integer (frequency or count). When creating the object the constructor will check for positions that equal 0. If such is found it will increase the count for all positions by one and recalculate the frequency. Potential bug - if you are using frequencies and one of the positions is 0 it will change significantly. However, you should never have frequency that equals 0. Throws an exception if: You mix as an input array and string (for example A matrix is given as array, C - as string). The position vector is (0,0,0,0). One of the probability vectors is shorter than the rest. Summary of the methods I use most frequently (details bellow): iupac - return IUPAC compliant consensus as a string score - Returns the score as a real number IC - information content. Returns a real number id - identifier. Returns a string accession - accession number. Returns a string next_pos - return the sequence probably for each letter, IUPAC symbol, IUPAC probability and simple sequence consenus letter for this position. Rewind at the end. Returns a hash. pos - current position get/set. Returns an integer. regexp - construct a regular expression based on IUPAC consensus. For example AGWV will be [Aa][Gg][AaTt][AaCcGg] width - site width get_string - gets the probability vector for a single base as a string. get_array - gets the probability vector for a single base as an array. get_logs_array - gets the log-odds vector for a single base as an array. New methods, which might be of interest to anyone who wants to store PSM in a relational database without creating an entry for each position is the ability to compress the PSM vector into a string with losing usually less than 1% of the data. this can be done with: my $str=$matrix->get_compressed_freq('A'); or my $str=$matrix->get_compressed_logs('A'); Loading from a database should be done with new, but is not yet implemented. However you can still uncompress such string with: my @arr=Bio::Matrix::PSM::_uncompress_string ($str,1,1); for PSM or my @arr=Bio::Matrix::PSM::_uncompress_string ($str,1000,2); for log odds =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - James Thompson Email tex@biosysadmin.com =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::ProtMatrix; use strict; use base qw(Bio::Root::Root Bio::Matrix::PSM::SiteMatrixI); =head2 new Title : new Usage : my $site = Bio::Matrix::PSM::ProtMatrix->new( %probs, %logs, -IC => $ic, -e_val => $score, -id => $mid -model => \%model ); Function : Creates a new Bio::Matrix::PSM::ProtMatrix object from memory Throws : If inconsistent data for all vectors (all 20 amino acids) is provided, if you mix input types (string vs array) or if a position freq is 0. Example : Returns : Bio::Matrix::PSM::ProtMatrix object Args : Hash references to log-odds scores and probabilities for position-specific scoring info, e-value (optional), information content (optional), id (optional), model for background distribution of proteins (optional). =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my $consensus; #Too many things to rearrange, and I am creating simultanuously >500 # such objects routinely, so this becomes performance issue my %input; while( @args ) { (my $key = shift @args) =~ s/-//gi; #deletes all dashes (only dashes)! $input{$key} = shift @args; } # get a protein alphabet for processing log-odds scores and probabilities # maybe change this later on to allow for non-standard aa lists? my @alphabet = qw/A R N D C Q E G H I L K M F P S T W Y V/; foreach my $aa (@alphabet) { $self->{"log$aa"} = defined($input{"l$aa"}) ? $input{"l$aa"} : $self->throw("Error: No log-odds information for $aa!"); $self->{"prob$aa"} = defined($input{"p$aa"}) ? $input{"p$aa"} : $self->throw("Error: No probability information for $aa!"); } $self->{_position} = 0; $self->{IC} = $input{IC}; $self->{e_val} = $input{e_val}; $self->{sites} = $input{sites}; $self->{width} = $input{width}; $self->{accession_number} = $input{accession_number}; $self->{_correction} = defined($input{correction}) ? $input{correction} : 1 ; # Correction might be unwanted- supply your own # No id provided, null for the sake of rel db $self->{id} = defined($input{id}) ? $input{id} : 'null'; $self->{_alphabet} = \@alphabet; #Make consensus, throw if any one of the vectors is shorter $self = _calculate_consensus($self,$input{model}); return $self; } =head2 alphabet Title : Returns an array (or array reference if desired) to the alphabet Usage : Function : Returns an array (or array reference) containing all of the allowable characters for this matrix. Throws : Example : Returns : Array or arrary reference. Args : =cut sub alphabet { my $self = shift; if ( wantarray ) { return $self->{_alphabet}; } else { return @{$self->{_alphabet}}; } } =head2 _calculate_consensus Title : _calculate_consensus Usage : Function : Calculates the consensus sequence for this matrix. Throws : Example : Returns : Args : =cut sub _calculate_consensus { my $self = shift; my $thresh = shift; # verify that all of the array lengths in %probs are the same my @lengths = map { scalar(@$_) } map {$self->{"prob$_"}} @{ $self->{_alphabet} }; my $len = shift @lengths; for ( @lengths ) { if ( $_ ne $len ) { $self->throw( "Probability matrix is damaged!\n" ) }; } # iterate over probs, generate the most likely sequence and put it into # $self->{seq}. Put the probability of this sequence into $self->{seqp}. for ( my $i = 0; $i < $len; $i++ ) { # get a list of all the probabilities at position $i, ordered by $self->{_alphabet} my @probs = map { ${$self->{"prob$_"}}[$i] } @{ $self->{_alphabet} }; # calculate the consensus of @probs, put sequence into seqp and probabilities into seqp (${$self->{seq}}[$i],${$self->{seqp}}[$i]) = $self->_to_cons( @probs, $thresh ); } return $self; } =head2 next_pos Title : next_pos Usage : Function : Retrives the next position features: frequencies for all 20 amino acids, log-odds scores for all 20 amino acids at this position, the main (consensus) letter at this position, the probability for the consensus letter to occur at this position and the relative current position as an integer. Throws : Example : Returns : hash (or hash reference) (pA,pR,pN,pD,...,logA,logR,logN,logD,aa,prob,rel) - pN entries represent the probability for amino acid N to be at this position - logN entries represent the log-odds score for having amino acid N at this position - aa is the consensus amino acid - prob is the probability for the consensus amino acid to be at this position - rel is the relative index of the current position (integer) Args : none =cut sub next_pos { my $self = shift; $self->throw("instance method called on class") unless ref $self; my $len = @{$self->{seq}}; my $pos = $self->{_position}; # return a PSM if we're still within range if ($pos<$len) { my %probs = map { ("p$_", ${$self->{"prob$_"}}[$pos]) } @{$self->{_alphabet}}; my %logs = map { ("l$_", ${$self->{"log$_"}}[$pos]) } @{$self->{_alphabet}}; my $base = ${$self->{seq}}[$pos]; my $prob = ${$self->{seqp}}[$pos]; $self->{_position}++; my %hash = ( %probs, %logs, base => $base, rel => $pos, prob => $prob ); # decide whether to return the hash or a reference to it if ( wantarray ) { return %hash; } else { return \%hash; } } else { # otherwise, reset $self->{_position} and return nothing $self->{_position} = 0; return; } } =head2 curpos Title : curpos Usage : Function : Gets/sets the current position. Throws : Example : Returns : Current position (integer). Args : New position (integer). =cut sub curpos { my $self = shift; if (@_) { $self->{_position} = shift; } return $self->{_position}; } =head2 e_val Title : e_val Usage : Function : Gets/sets the e-value Throws : Example : Returns : Args : real number =cut sub e_val { my $self = shift; if (@_) { $self->{e_val} = shift; } return $self->{e_val}; } =head2 IC Title : IC Usage : Function : Position-specific information content. Throws : Example : Returns : Information content for current position. Args : Information content for current position. =cut sub IC { my $self = shift; if (@_) { $self->{IC} = shift; } return $self->{IC}; } =head2 accession_number Title : accession_number Usage : Function: accession number, this will be unique id for the ProtMatrix object as well for any other object, inheriting from ProtMatrix. Throws : Example : Returns : New accession number (string) Args : Accession number (string) =cut sub accession_number { my $self = shift; if (@_) { $self->{accession_number} = shift; } return $self->{accession_number}; } =head2 consensus Title : consensus Usage : Function : Returns the consensus sequence for this PSM. Throws : if supplied with thresold outisde 5..10 range Example : Returns : string Args : (optional) threshold value 5 to 10 (corresponds to 50-100% at each position =cut sub consensus { my $self = shift; my $thresh=shift; $self->_calculate_consensus($thresh) if ($thresh); #Change of threshold my $consensus=''; foreach my $letter (@{$self->{seq}}) { $consensus .= $letter; } return $consensus; } sub IUPAC { my $self = shift; return $self->consensus; } =head2 get_string Title : get_string Usage : Function: Returns given probability vector as a string. Useful if you want to store things in a rel database, where arrays are not first choice Throws : If the argument is outside {A,C,G,T} Example : Returns : string Args : character {A,C,G,T} =cut sub get_string { my $self = shift; my $base = shift; my $string = ''; my @prob = @{$self->{"prob$base"}}; if ( ! @prob ) { $self->throw( "No such base: $base\n"); } foreach my $prob (@prob) { my $corrected = $prob*10; my $next = sprintf("%.0f",$corrected); $next = 'a' if ($next eq '10'); $string .= $next; } return $string; } =head2 width Title : width Usage : Function : Returns the length of the site Throws : Example : Returns : number Args : =cut sub width { my $self = shift; my $width = @{$self->{probA}}; return $width; } =head2 get_array Title : get_array Usage : Function : Returns an array with frequencies for a specified amino acid. Throws : Example : Returns : Array representing frequencies for specified amino acid. Args : Single amino acid (character). =cut sub get_array { my $self = shift; my $letter = uc(shift); $self->throw ("No such base: $letter!\n") unless grep { /$letter/ } @{$self->{_alphabet}}; return @{$self->{"prob$letter"}}; } =head2 get_logs_array Title : get_logs_array Usage : Function : Returns an array with log_odds for a specified base Throws : Example : Returns : Array representing log-odds scores for specified amino acid. Args : Single amino acid (character). =cut sub get_logs_array { my $self = shift; my $letter = uc(shift); $self->throw ("No such base: $letter!\n") unless grep { /$letter/ } @{$self->{_alphabet}}; return @{$self->{"log$letter"}}; } =head2 id Title : id Usage : Function : Gets/sets the site id Throws : Example : Returns : string Args : string =cut sub id { my $self = shift; if (@_) { $self->{id} = shift; } return $self->{id}; } =head2 regexp Title : regexp Usage : Function : Returns a case-insensitive regular expression which matches the IUPAC convention. X's in consensus sequence will match anything. Throws : Example : Returns : string Args : Threshold for calculating consensus sequence (number in range 0-100 representing a percentage). Threshold defaults to 20. =cut sub regexp { my $self = shift; my $threshold = 20; if ( @_ ) { my $threshold = shift }; my @alphabet = @{$self->{_alphabet}}; my $width = $self->width; my (@regexp, $i); for ( $i = 0; $i < $width; $i++ ) { # get an array of the residues at this position with p > $threshold my @letters = map { uc($_).lc($_) } grep { $self->{"prob$_"}->[$i] >= $threshold } @alphabet; my $reg; if ( scalar(@letters) == 0 ) { $reg = '\.'; } else { $reg = '['.join('',@letters).']'; } push @regexp, $reg; } if ( wantarray ) { return @regexp; } else { return join '', @regexp; } } =head2 regexp_array Title : regexp_array Usage : Function : Returns an array of position-specific regular expressions. X's in consensus sequence will match anything. Throws : Example : Returns : Array of position-specific regular expressions. Args : Threshold for calculating consensus sequence (number in range 0-100 representing a percentage). Threshold defaults to 20. Notes : Simply calls regexp method in list context. =cut sub regexp_array { my $self = shift; return @{ $self->regexp }; } =head2 _compress_array Title : _compress_array Usage : Function : Will compress an array of real signed numbers to a string (ie vector of bytes) -127 to +127 for bi-directional(signed) and 0..255 for unsigned ; Throws : Example : Internal stuff Returns : String Args : array reference, followed by max value and direction (optional, defaults to 1), direction of 1 is unsigned, anything else is signed. =cut sub _compress_array { my ($array,$lm,$direct)=@_; my $str; return unless(($array) && ($lm)); $direct=1 unless ($direct); my $k1= ($direct==1) ? (255/$lm) : (127/$lm); foreach my $c (@{$array}) { $c=$lm if ($c>$lm); $c=-$lm if (($c<-$lm) && ($direct !=1)); $c=0 if (($c<0) && ($direct ==1)); my $byte=int($k1*$c); $byte=127+$byte if ($direct !=1);#Clumsy, should be really shift the bits my $char=chr($byte); $str.=$char; } return $str; } =head2 _uncompress_string Title : _uncompress_string Usage : Function : Will uncompress a string (vector of bytes) to create an array of real signed numbers (opposite to_compress_array) Throws : Example : Internal stuff Returns : string, followed by max value and direction (optional, defaults to 1), direction of 1 is unsigned, anything else is signed. Args : array =cut sub _uncompress_string { my ($str,$lm,$direct)=@_; my @array; return unless(($str) && ($lm)); $direct=1 unless ($direct); my $k1= ($direct==1) ? (255/$lm) : (127/$lm); while (my $c=chop($str)) { my $byte=ord($c); $byte=$byte-127 if ($direct !=1);#Clumsy, should be really shift the bits my $num=$byte/$k1; unshift @array,$num; } return @array; } =head2 get_compressed_freq Title : get_compressed_freq Usage : Function: A method to provide a compressed frequency vector. It uses one byte to code the frequence for one of the probability vectors for one position. Useful for relational database. Improvment of the previous 0..a coding. Throws : Example : my $strA=$self->get_compressed_freq('A'); Returns : String Args : char =cut sub get_compressed_freq { my $self=shift; my $base=shift; my $string=''; my @prob; BASE: { if ($base eq 'A') { @prob = @{$self->{probA}} unless (!defined($self->{probA})); last BASE; } if ($base eq 'G') { @prob = @{$self->{probG}} unless (!defined($self->{probG})); last BASE; } if ($base eq 'C') { @prob = @{$self->{probC}} unless (!defined($self->{probC})); last BASE; } if ($base eq 'T') { @prob = @{$self->{probT}} unless (!defined($self->{probT})); last BASE; } $self->throw ("No such base: $base!\n"); } my $str= _compress_array(\@prob,1,1); return $str; } =head2 sequence_match_weight Title : sequence_match_weight Usage : Function : This method will calculate the score of a match, based on the PSM if such is associated with the matrix object. Returns undef if no PSM data is available. Throws : if the length of the sequence is different from the matrix width Example : my $score=$matrix->sequence_match_weight('ACGGATAG'); Returns : Floating point Args : string =cut sub sequence_match_weight { my ($self,$seq)=@_; return unless ($self->{logA}); my $seqlen = length($seq); my $width = $self->width; $self->throw("Error: Input sequence size ($seqlen) not equal to PSM size ($width)!\n") unless (length($seq) == $self->width); my ($score,$i) = (0,0); foreach my $letter ( split //, $seq ) { # add up the score for this position $score += $self->{"log$letter"}->[$i]; $i++; } return $score; } =head2 _to_IUPAC Title : _to_IUPAC Usage : Function: Converts a single position to IUPAC compliant symbol and returns its probability. Currently returns the most likely amino acid/probability combination. Throws : Example : Returns : char, real number representing an amino acid and a probability. Args : real numbers for all 20 amino acids (ordered by alphabet contained in $self->{_alphabet}, minimum probability threshold. =cut sub _to_IUPAC { my ($self,@probs,$thresh) = @_; # provide a default threshold of 5, corresponds to 5% threshold for # inferring that the aa at any position is the true aa $thresh = 5 unless ( defined $thresh ); my ($IUPAC_aa,$max_prob) = ('X',$thresh); for my $aa ( @{$self->{_alphabet}} ) { my $prob = shift @probs; if ( $prob > $max_prob ) { $IUPAC_aa = $aa; $max_prob = $prob; } } return $IUPAC_aa, $max_prob; } =head2 _to_cons Title : _to_cons Usage : Function: Converts a single position to simple consensus character and returns its probability. Currently just calls the _to_IUPAC subroutine. Throws : Example : Returns : char, real number Args : real numbers for A,C,G,T (positional) =cut sub _to_cons { return _to_IUPAC( @_ ); } =head2 get_all_vectors Title : get_all_vectors Usage : Function : returns all possible sequence vectors to satisfy the PFM under a given threshold Throws : If threshold outside of 0..1 (no sense to do that) Example : my @vectors = $self->get_all_vectors(4); Returns : Array of strings Args : (optional) floating =cut #sub get_all_vectors { # my $self = shift; # my $thresh = shift; # # $self->throw("Out of range. Threshold should be >0 and 1<.\n") if (($thresh<0) || ($thresh>1)); # # my @seq = split(//,$self->consensus($thresh*10)); # my @perm; # for my $i (0..@{$self->{probA}}) { # push @{$perm[$i]},'A' if ($self->{probA}->[$i]>$thresh); # push @{$perm[$i]},'C' if ($self->{probC}->[$i]>$thresh); # push @{$perm[$i]},'G' if ($self->{probG}->[$i]>$thresh); # push @{$perm[$i]},'T' if ($self->{probT}->[$i]>$thresh); # push @{$perm[$i]},'N' if ($seq[$i] eq 'N'); # } # my $fpos=shift @perm; # my @strings=@$fpos; # foreach my $pos (@perm) { # my @newstr; # foreach my $let (@$pos) { # foreach my $string (@strings) { # my $newstring = $string . $let; # push @newstr,$newstring; # } # } # @strings=@newstr; # } # return @strings; #} 1; BioPerl-1.6.923/Bio/Matrix/PSM/ProtPsm.pm000444000765000024 1756112254227315 20047 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- #ISA ProtMatrix, HAS InstanceSite =head1 NAME Bio::Matrix::PSM::ProtPsm - handle combination of site matricies =head1 SYNOPSIS use Bio::Matrix::PSM::IO; #To get a ProtPsm object from a file use the Psm parser: my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'psiblast', -file=>$file); # Now go through all entities in the file with next_psm, which # returns a Psm object see Bio::Matrix::PSM::IO for detailed # documentation (matrix predictions or matrix sequence matches or # both): while (my $psm=$psmIO->next_psm) { my %psm_header = $psm->header; my $ic = $psm_header{IC}; my $sites = $psm_header{sites}; my $width = $psm_header{width}; my $score = $psm_header{e_val}; my $IUPAC = $psm->IUPAC; my $instances = $psm->instances; foreach my $instance (@{$instances}) { my $id = $instance->primary_id; #Do something with the id } } =head1 DESCRIPTION To handle a combination of site matrices and/or their corresponding sequence matches (instances). This object inherits from Bio::Matrix::PSM::ProtMatrix, so you can methods from that class. It may hold also an array of Bio::Matrix::PSM::InstanceSite object, but you will have to retrieve these through Bio::Matrix::PSM::ProtPsm-Einstances method (see below). To some extent this is an expanded ProtMatrix object, holding data from analysis that also deal with sequence matches of a particular matrix. =head2 DESIGN ISSUES This does not make too much sense to me I am mixing PSM with PSM sequence matches Though they are very closely related, I am not satisfied by the way this is implemented here. Heikki suggested different objects when one has something like meme But does this mean we have to write a different objects for mast, meme, transfac, theiresias, etc.? To me the best way is to return SiteMatrix object + arrray of InstanceSite objects and then mast will return undef for SiteMatrix and transfac will return undef for InstanceSite. Probably I cannot see some other design issues that might arise from such approach, but it seems more straightforward. Hilmar does not like this beacause it is an exception from the general BioPerl rules. Should I leave this as an option? Also the header rightfully belongs the driver object, and could be retrieved as hashes. I do not think it can be done any other way, unless we want to create even one more object with very unclear content. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - James Thompson Email tex@biosysadmin.com =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO ProtMatrix, meme, transfac, psiblast, InstanceSite =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::ProtPsm; use Bio::Matrix::PSM::InstanceSite; use strict; use base qw(Bio::Matrix::PSM::ProtMatrix Bio::Matrix::PSM::PsmI Bio::Annotation::Collection); @Bio::Matrix::PSM::Psm::HEADER = qw(e_val sites IC width); =head2 new Title : new Usage : my $psm = Bio::Matrix::PSM::ProtPsm->new( -pS => [ '0', '33', '0', '16', '1', '12', '11', '25' ], -pF => [ '0', '0', '2', '0', '3', '0', '0', '0' ], -pT => [ '0', '8', '7', '10', '1', '2', '7', '8' ], -pN => [ '0', '0', '2', '13', '0', '36', '1', '4' ], -pK => [ '0', '5', '0', '13', '1', '15', '0', '2' ], -pY => [ '0', '0', '0', '0', '0', '0', '0', '0' ], -pE => [ '0', '41', '1', '12', '0', '0', '0', '15' ], -pV => [ '0', '3', '9', '0', '2', '0', '3', '1' ], -pQ => [ '0', '0', '0', '15', '0', '4', '0', '3' ], -pM => [ '100', '0', '66', '0', '2', '0', '0', '0' ], -pC => [ '0', '0', '0', '0', '0', '0', '0', '0' ], -pL => [ '0', '0', '8', '0', '25', '0', '4', '0' ], -pA => [ '0', '10', '1', '9', '2', '0', '22', '16' ], -pW => [ '0', '0', '0', '0', '0', '0', '0', '0' ], -pP => [ '0', '0', '0', '0', '3', '1', '45', '0' ], -pH => [ '0', '0', '0', '0', '0', '0', '1', '0' ], -pD => [ '0', '0', '1', '7', '2', '2', '0', '22' ], -pR => [ '0', '0', '0', '3', '0', '27', '0', '0' ], -pI => [ '0', '0', '3', '0', '59', '1', '2', '3' ], -pG => [ '0', '0', '0', '1', '0', '0', '4', '1' ], -IC => $ic, -sites => $istes, -width => $width, -e_val => $e_val, -instances => $instances, } Function: Creates a new Bio::Matrix::PSM::ProtPsm object Throws : Example : Returns : Bio::Matrix::PSM::Psm object Args : hash =cut sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; my $self = $class->SUPER::new(@args); $self->{'_annotation'} = {}; #Init from Annotation::Collection $self->_typemap(Bio::Annotation::TypeManager->new()); #same ($self->{instances})=$self->_rearrange(['INSTANCES'], @args); return $self; } =head2 instances Title : instances Usage : my @instances=@{$psm->instances}; Function: Gets/sets the instances (Bio::Matrix::PSM::InstanceSite objects) associated with the Psm object Throws : Example : Returns : array reference (Bio::Matrix::PSM::InstanceSite objects) Args : array reference (Bio::Matrix::PSM::InstanceSite objects) =cut sub instances { my $self = shift; my $prev = $self->{instances}; if (@_) { $self->{instances} = shift; } return $prev; } =head2 header Title : header Usage : my %header=$psm->header; my $ic=$psm->header('IC'); Function: Gets the general information, common for most files, dealing with PSM such as information content (IC), score (e-value, etc.), number of sites (sites) and width. This list may expand. The current list should be in @Bio::Matrix::PSM::Psm::HEADER. Returns an epty list if an argument is supplied that is not in @Bio::Matrix::PSM::meme::HEADER. Throws : Example : Returns : hash or string Args : string (IC, e_val...) =cut sub header { my $self = shift; return if ($self->{end}); my %header; if (@_) {my $key=shift; return $self->{$key}; } foreach my $key (@Bio::Matrix::PSM::ProtPsm::HEADER) { $header{$key}=$self->{$key}; } return %header; } =head2 matrix Title : matrix Usage : my $matrix = $psm->matrix; Function: Gets/sets the SiteMatrix related information Throws : Example : Returns : Bio::Matrix::PSM::SiteMatrix objects Args : Bio::Matrix::PSM::SiteMatrix objects =cut sub matrix { my $self = shift; if (@_) { my $matrix = shift; my @alphabet = $self->alphabet; foreach my $char (@alphabet) { $self->{"log$char"} = $matrix->{"log$char"}; $self->{"prob$char"} = $matrix->{"prob$char"}; } $self->{IC} = $matrix->IC; $self->{e_val} = $matrix->e_val; $self->{id} = $matrix->id; } return $self; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/Psm.pm000444000765000024 1641412254227316 17177 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- #ISA SiteMatrix, HAS InstanceSite =head1 NAME Bio::Matrix::PSM::Psm - handle combination of site matricies =head1 SYNOPSIS use Bio::Matrix::PSM::IO; #To get a Psm object from a file use the Psm parser: my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'meme', -file=>$file); # Now go through all entities in the file with next_psm, which # returns a Psm object see Bio::Matrix::PSM::IO for detailed # documentation (matrix predictions or matrix sequence matches or # both): while (my $psm=$psmIO->next_psm) { my %psm_header=$psm->header; my $ic=$psm_header{IC}; my $sites=$psm_header{sites}; my $width=$psm_header{width}; my $score=$psm_header{e_val}; my $IUPAC=$psm->IUPAC; my $instances=$psm->instances; foreach my $instance (@{$instances}) { my $id=$instance->primary_id; #Do something with the id } } #or create from memmory: my $psm= Bio::Matrix::PSM::Psm->new( -pA=>\@pA,-pC=>\@pC,-pG=>\@pG,-pT=>\@pT, -id=>$id, -instances=>$instances, -e_val=>$e_val, -IC=>$ic, -width=>$width, -sites=>$sites) # where pA through pG are the respective frequencies of the matrix (see also # Bio::Matrix::PSM::SiteMatrix), and everything else is self-explenatory, # except for -instances (reference to an array of # Bio::Matrix::PSM::InstanceSite objects) which is documented bellow. =head1 DESCRIPTION To handle a combination of site matrices and/or their corresponding sequence matches (instances). This object inherits from Bio::Matrix::PSM::SiteMatrix, so you can use the respective methods. It may hold also an array of Bio::Matrix::PSM::InstanceSite object, but you will have to retrieve these through Bio::Matrix::PSM::Psm-Einstances method (see below). To some extent this is an expanded SiteMatrix object, holding data from analysis that also deal with sequence matches of a particular matrix. =head2 DESIGN ISSUES This does not make too much sense to me I am mixing PSM with PSM sequence matches Though they are very closely related, I am not satisfied by the way this is implemented here. Heikki suggested different objects when one has something like meme But does this mean we have to write a different objects for mast, meme, transfac, theiresias, etc.? To me the best way is to return SiteMatrix object + arrray of InstanceSite objects and then mast will return undef for SiteMatrix and transfac will return undef for InstanceSite. Probably I cannot see some other design issues that might arise from such approach, but it seems more straightforward. Hilmar does not like this beacause it is an exception from the general BioPerl rules Should I leave this as an option? Also the header rightfully belongs the driver object, and could be retrieved as hashes. I do not think it can be done any other way, unless we want to create even one more object with very unclear content. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO SiteMatrix, meme, transfac, InstanceSite =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::Psm; use Bio::Matrix::PSM::InstanceSite; use strict; use base qw(Bio::Matrix::PSM::SiteMatrix Bio::Matrix::PSM::PsmI Bio::Annotation::Collection); @Bio::Matrix::PSM::Psm::HEADER = qw(e_val sites IC width); =head2 new Title : new Usage : my $psm= Bio::Matrix::PSM::Psm->new( -pA=>\@pA,-pC=>\@pC, -pG=>\@pG,-pT=>\@pT,-id=>$id, -instances=>$instances, -e_val=>$e_val, -IC=>$ic, -width=>$width, -sites=>$sites) Function: Creates a new Bio::Matrix::PSM::Psm object Throws : Example : Returns : Bio::Matrix::PSM::Psm object Args : hash =cut sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; my $self = $class->SUPER::new(@args); $self->{'_annotation'} = {}; #Init from Annotation::Collection $self->_typemap(Bio::Annotation::TypeManager->new()); #same ($self->{instances})=$self->_rearrange(['INSTANCES'], @args); return $self; } =head2 instances Title : instances Usage : my @instances=@{$psm->instances}; Function: Gets/sets the instances (Bio::Matrix::PSM::InstanceSite objects) associated with the Psm object Throws : Example : Returns : array reference (Bio::Matrix::PSM::InstanceSite objects) Args : array reference (Bio::Matrix::PSM::InstanceSite objects) =cut sub instances { my $self = shift; my $prev = $self->{instances}; if (@_) { $self->{instances} = shift; } return $prev; } =head2 header Title : header Usage : my %header=$psm->header; my $ic=$psm->header('IC'); Function: Gets the general information, common for most files, dealing with PSM such as information content (IC), score (e-value, etc.), number of sites (sites) and width. This list may expand. The current list should be in @Bio::Matrix::PSM::Psm::HEADER. Returns undef if an argument is supplied that is not in @Bio::Matrix::PSM::meme::HEADER. Throws : Example : Returns : hash or string Args : string (IC, e_val...) =cut sub header { my $self = shift; return if ($self->{end}); my %header; if (@_) {my $key=shift; return $self->{$key}; } foreach my $key (@Bio::Matrix::PSM::Psm::HEADER) { $header{$key}=$self->{$key}; } return %header; } =head2 matrix Title : matrix Usage : my $matrix=$psm->matrix; Function: Gets/sets the SiteMatrix related information Throws : Example : Returns : Bio::Matrix::PSM::SiteMatrix objects Args : Bio::Matrix::PSM::SiteMatrix objects =cut sub matrix { my $self = shift; my $prev = Bio::Matrix::PSM::SiteMatrix->new(-pA=>$self->{probA}, -pC=>$self->{probC}, -pG=>$self->{probG}, -pT=>$self->{probT}, -lA=>$self->{logA}, -lC=>$self->{logC}, -lG=>$self->{logG}, -lT=>$self->{logT}, -IC=>$self->{IC}, -e_val=>$self->{e_val}, -id=>$self->{id}); if (@_) { my $matrix=shift; $self->{IC} = $matrix->IC; $self->{probA}=$matrix->{probA}; $self->{probC}=$matrix->{probC}; $self->{probG}=$matrix->{probG}; $self->{probT}=$matrix->{probT}; $self->{e_val}=$matrix->e_val; $self->{id}=$matrix->id; } return $prev; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/PsmHeader.pm000444000765000024 1544012254227312 20302 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::Matrix::PSM::PsmHeader - PSM mast parser implementation =head1 SYNOPSIS # See Bio::Matrix::PSM::IO for detailed documentation on how to use # PSM parsers =head1 DESCRIPTION Parser for mast. This driver unlike meme or transfac for example is dedicated more to PSM sequence matches =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::PsmHeader; use Bio::Matrix::PSM::InstanceSite; use strict; use base qw(Bio::Root::Root Bio::Matrix::PSM::PsmHeaderI); #These define what structures within the @Bio::Matrix::PSM::PsmHeader::MASTHEADER=qw(html version release seq hid length instances unstructured); @Bio::Matrix::PSM::PsmHeader::MEMEHEADER=qw(html version release hid weight length unstructured); @Bio::Matrix::PSM::PsmHeader::TRANSFACHEADER=qw(unstructured version release); @Bio::Matrix::PSM::PsmHeader::PSIBLASTHEADER=qw(seq width ic); @Bio::Matrix::PSM::PsmHeader::ALLHEADER=qw(header release type version html release weight length id seq instances unstructured); =head2 new Title : new Usage : my $header= Bio::Matrix::PSM::PsmHeader->new(-seq=>\%seq, -mid=>\%mid, -width=>\%width, -instances=>\%instances, -header=>\@header, -type=>'mast'); Function: Creates a new Bio::Matrix::PSM::PsmHeader object Throws : Example : Returns : Bio::Matrix::PSM::PsmHeader object Args : hash =cut sub new { my ($class,@args)=@_; my $self = $class->SUPER::new(@args); return $self; } #parse version/release info here from the unstructured array sub _initialize { my $self = shift; my $type=ref($self); $type=~s/\w+:://g; $self->{_type} = $type; my $dat=join(" ",grep(/version|release/i,@{$self->{unstructured}})); if ($dat && ($dat=~/version\b/i)) { $self->{version}=substr($dat,$+[0]+1); $self->{version}=~s/\s.+[^\d\.\:\/]//g; $self->{version}=~s/^\D//; } if ($dat && ($dat=~/release\b/i)) { my $rel=substr($dat,$+[0]+1); $rel=~s/[^\d\.\:\/\-]//g; $rel=~s/^\D//; if ($rel=~/\d\d:\d\d:\d\d/) { #Reformat if time is available too my $time=substr($rel,$-[0]+1); my $dat= substr($rel,0,$-[0]); $self->{release}="$dat $time"; } else { $self->{release}=$rel; } } return $self; } =head2 seq Title : seq Usage : my %seq= $header->seq(); Function: Returns the sequence data as a hash, indexed by a sequence ID (motif id or accession number) In case the input data is a motif it would return the consenus seq for each of them (mast). Throws : Example : Returns : hash Args : =cut sub seq { my $self = shift; return () unless ($self->_check('seq')); return %{$self->{seq}}; } =head2 hid Title : hid Usage : my @hid= $header->hid(); Function: Returns array with the motif ids Throws : Example : Returns : array Args : =cut sub hid { my $self = shift; return unless ($self->_check('hid')); my @header=@{$self->{hid}}; return @header; } =head2 length Title : length Usage : my %length= $header->length(); Function: Returns the length of the input sequence or motifs as a hash, indexed by a sequence ID (motif id or accession number) Throws : Example : Returns : hash Args : =cut sub length { my $self = shift; return unless ($self->_check('length')); return $self->{length}; } =head2 instances Title : instances Usage : my %instances= $header->instances(); Function: Returns the info about the input data, contained in the header Throws : Example : Returns : hash Args : =cut sub instances { my $self = shift; return unless ($self->_check('instances')); return %{$self->{instances}}; } =head2 weight Title : weight Usage : my %weights= $header->weight(); Function: Returns the weights of the input sequence as a hash, indexed by a sequence ID Throws : Example : Returns : hash Args : =cut sub weight { my $self = shift; return () unless ($self->_check('weight')); return %{$self->{weight}}; } =head2 unstuctured Title : unstuctured Usage : my @unstructured= $header->unstuctured(); Function: Returns the unstructured data in the header as an array, one line per array element, all control symbols are removed with \W Throws : Example : Returns : array Args : =cut sub unstructured { my $self = shift; return @{$self->{unstructured}}; } =head2 version Title : version Usage : my $version= $header->version; Function: Returns the version of the file being parsed if such exists Throws : Example : Returns : string Args : =cut sub version { my $self = shift; return $self->{version}; } =head2 release Title : release Usage : my $release= $header->release; Function: Returns the release of the file being parsed if such exists Throws : Example : Returns : string Args : =cut sub release { my $self = shift; return $self->{release}; } =head2 _check Title : _check Usage : if ($self->_check('weights') { #do something} else {return 0;} Function: Checks if the method called is aplicable to the file format Throws : Example : Returns : boolean Args : string =cut sub _check { my ($self,$method) = @_; my $type= $self->{'_type'}; if ($type eq 'meme') { return 0 unless (grep(/$method/, @Bio::Matrix::PSM::PsmHeader::MEMEHEADER)); } elsif ($type eq 'mast') { return 0 unless (grep(/$method/, @Bio::Matrix::PSM::PsmHeader::MASTHEADER)); } elsif ($type eq 'transfac') { return 0 unless (grep(/$method/, @Bio::Matrix::PSM::PsmHeader::TRANSFACHEADER)); } elsif ($type eq 'psiblast') { return 0 unless (grep(/$method/, @Bio::Matrix::PSM::PsmHeader::PSIBLASTHEADER)); } return 1; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/PsmHeaderI.pm000444000765000024 1451312254227332 20415 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::PsmHeaderI - handles the header data from a PSM file =head1 SYNOPSIS use Bio::Matrix::PSM::IO; #Obtain an Bio::Matrix::PSM::IO object: my $psmIO= Bio::Matrix::PSM::IO->new(-file=>$file, -format=>'mast'); #Get some general data about the file you are parsing: my $release=$psmIO->release; my $version=$psmIO->version; print "This analysis was performed using MAST version $version, release $release\n"; #Now let's see what are the consensus sequences of the motifs fed as an input: my %seq=$psmIO->seq; #let's cycle through all consensus sequences now: foreach my $id ($psmIO->hid) { print "Motif $id is \t",$seq{$id},"\n"; } #Finally look at the stuff we do not parse: my @inputfile=grep(/datafile/i,$psmIO->unstructured); =head1 DESCRIPTION Generally you should not use this object directly, you can access the information through a PSM driver (See Bio::Matrix::PSM::IO). It is handling the header data from a PSM file which may be very different. This means that some of the methods will return undef naturally, because this information is not present in the file which is parsed. Some important data might be left over in the unstructured part, and you might have to parse it yourself. I will try to 'structure' this header more in the near future. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::PsmHeaderI; use Bio::Matrix::PSM::InstanceSite; use Bio::Matrix::PSM::Psm; use Bio::Matrix::PSM::IO; use strict; use base qw(Bio::Matrix::PSM::PsmI); #Accessor methods, based on the driver @Bio::Matrix::PSM::PsmHeader::MASTHEADER=qw(html version release seq hid length instances unstructured); @Bio::Matrix::PSM::PsmHeader::MEMEHEADER=qw(html version release hid weight length unstructured); @Bio::Matrix::PSM::PsmHeader::TRANSFACHEADER=qw(unstructured version release); @Bio::Matrix::PSM::PsmHeader::ALLHEADER=qw(header release type version html release weight length hid seq instances unstructured); =head2 new Title : new Usage : my $header= Bio::Matrix::PSM::PsmHeader->new ( -seq=>\%seq, -mid=>\%mid, -width=>\%width, -instances=>\%instances, -header=>\@header, -type=>'mast'); Function: Creates a new Bio::Matrix::PSM::PsmHeader object Throws : Example : Returns : Bio::Matrix::PSM::PsmHeaderI object Args : hash =cut =head2 seq Title : seq Usage : my %seq= $header->seq(); Function: Returns the sequence data as a hash, indexed by a sequence ID (motif id or accession number) In case the input data is a motif it would return the consenus seq for each of them (mast). Throws : Example : Returns : hash Args : =cut sub seq { my $self = shift; $self->throw_not_implemented(); } =head2 hid Title : hid Usage : my @ids= $header->hid(); Function: Returns array with the motif/instance ids Throws : Example : Returns : array Args : =cut sub hid { my $self = shift; $self->throw_not_implemented(); } =head2 length Title : length Usage : my %length= $header->length(); Function: Returns the length of the input sequence or motifs as a hash, indexed by a sequence ID (motif id or accession number) Throws : Example : Returns : hash Args : =cut sub length { my $self = shift; $self->throw_not_implemented(); } =head2 instances Title : instances Usage : my %instances= $header->length(); Function: Returns the instance, used as a hash, indexed by a sequence ID (motif id or accession number) Throws : Example : Returns : hash of Bio::Matrix::PSM::InstanceSite objects Args : =cut sub instances { my $self = shift; $self->throw_not_implemented(); } =head2 weights Title : weights Usage : my %weights= $header->weights(); Function: Returns the weights of the input sequence as a hash, indexed by a sequence ID Throws : Example : Returns : hash Args : =cut sub weights { my $self = shift; $self->throw_not_implemented(); } =head2 unstuctured Title : unstuctured Usage : my @unstructured= $header->unstuctured(); Function: Returns the unstructured data in the header as an array, one line per array element, all control symbols are removed with \W Throws : Example : Returns : array Args : =cut sub unstructured { my $self = shift; $self->throw_not_implemented(); } =head2 version Title : version Usage : my $version= $header->version; Function: Returns the version of the file being parsed if such exists Throws : Example : Returns : string Args : =cut sub version { my $self = shift; $self->throw_not_implemented(); } =head2 revision Title : revision Usage : my $revision= $header->revision; Function: Returns the revision of the file being parsed if such exists Throws : Example : Returns : string Args : =cut sub revision { my $self = shift; $self->throw_not_implemented(); } =head2 _check Title : _check Usage : if ($self->_check('weights') { #do something} else {return 0;} Function: Checks if the method called is aplicable to the file format Throws : Example : Returns : boolean Args : string =cut sub _check { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Matrix/PSM/PsmI.pm000444000765000024 1454612254227312 17310 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- #ISA SiteMatrix, HAS InstanceSite =head1 NAME Bio::Matrix::PSM::PsmI - abstract interface to handler of site matricies =head1 SYNOPSIS use Bio::Matrix::PSM::IO; # To get a Psm object from a file use the Psm parser: my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'meme', -file=>$file); # Now go through all entities in the file with next_psm, which # returns a Psm object see Bio::Matrix::PSM::IO for detailed # documentation (matrix predictions or matrix sequence matches or # both): while (my $psm=$psmIO->next_psm) { my %psm_header=$psm->header; my $ic=$psm_header{IC}; my $sites=$psm_header{sites}; my $width=$psm_header{width}; my $score=$psm_header{e_val}; my $IUPAC=$psm->IUPAC; my $instances=$psm->instances; foreach my $instance (@{$instances}) { my $id=$instance->primary_id; #Do something with the id } } # or create from memmory: my $psm= Bio::Matrix::PSM::Psm->new( -pA=>\@pA,-pC=>\@pC,-pG=>\@pG,-pT=>\@pT, -id=>$id, -instances=>$instances, -e_val=>$e_val, -IC=>$ic, -width=>$width, -sites=>$sites) # where pA through pG are the respective frequencies of the matrix (see also # Bio::Matrix::PSM::SiteMatrix), and everything else is self-explenatory, # except for #-instances (reference to an array of Bio::Matrix::PSM::InstanceSite objects) # which is documented bellow. =head1 DESCRIPTION Supposed to handle a combination of site matrices and/or their corresponding sequence matches (instances). This object inherits from Bio::Matrix::PSM::SiteMatrix, so you can use the respective methods. It may hold also an array of Bio::Matrix::PSM::InstanceSite object, but you will have to retrieve these through Bio::Matrix::PSM::Psm-Einstances method (see below). To some extent this is an expanded SiteMatrix object, holding data from analysis that also deal with sequence matches of a particular matrix. =head2 DESIGN ISSUES This design is a bit of a compromise, so it might be a temporary solution I am mixing PSM with PSM sequence matches Though they are very closely related, I am not satisfied by the way this is implemented here. Heikki suggested different objects when one has something like meme But does this mean we have to write a different objects for mast, meme, transfac, theiresias, etc.? To me the best way is to return SiteMatrix object + arrray of InstanceSite objects and then mast will return undef for SiteMatrix and transfac will return undef for InstanceSite. Probably I cannot see some other design issues that might arise from such approach, but it seems more straightforward. Hilmar does not like this beacause it is an exception from the general BioPerl rules Should I leave this as an option? Also the header rightfully belongs the driver object, and could be retrieved as hashes. I do not think it can be done any other way, unless we want to create even one more object with very unclear content. =head1 SEE ALSO L, L, L, L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::PsmI; use Bio::Matrix::PSM::SiteMatrix; use Bio::Matrix::PSM::InstanceSite; use strict; use base qw(Bio::Matrix::PSM::SiteMatrixI); =head2 new Title : new Usage : my $psm= Bio::Matrix::PSM::Psm->new( -pA=>\@pA,-pC=>\@pC,-pG=>\@pG, -pT=>\@pT,-id=>$id, -instances=>$instances, -e_val=>$e_val, -IC=>$ic, -width=>$width, -sites=>$sites) Function: Creates a new Bio::Matrix::PSM::Psm object Throws : Example : Returns : Bio::Matrix::PSM::Psm object Args : hash =cut sub new { my $self = shift; $self->throw_not_implemented(); } =head2 instances Title : instances Usage : my @instances=@{$psm->instances}; Function: Gets/sets the instances (Bio::Matrix::PSM::InstanceSite objects) associated with the Psm object Throws : Example : Returns : array reference (Bio::Matrix::PSM::InstanceSite objects) Args : array reference (Bio::Matrix::PSM::InstanceSite objects) =cut sub instances { my $self = shift; $self->throw_not_implemented(); } =head2 matrix Title : matrix Usage : my $matrix=$psm->matrix; Function: Gets/sets the SiteMatrix related information Throws : Example : Returns : Bio::Matrix::PSM::SiteMatrix objects Args : Bio::Matrix::PSM::SiteMatrix objects =cut sub matrix { my $self = shift; $self->throw_not_implemented(); } =head2 header Title : header Usage : my %header=$psm->header; my $ic=$psm->header('IC'); Function: Gets the general information, common for most files, dealing with PSM such as information content (IC), score (e-value, etc.), number of sites (sites) and width. This list may expand. The current list should be in @Bio::Matrix::PSM::Psm::HEADER. Returns undef if an argument is supplied that is not in @Bio::Matrix::PSM::meme::HEADER. Throws : Example : Returns : hash or string Args : string (IC, e_val...) =cut sub header { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Matrix/PSM/SiteMatrix.pm000444000765000024 10001512254227315 20537 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::SiteMatrix - SiteMatrixI implementation, holds a position scoring matrix (or position weight matrix) and log-odds =head1 SYNOPSIS use Bio::Matrix::PSM::SiteMatrix; # Create from memory by supplying probability matrix hash # both as strings or arrays # where the frequencies $a,$c,$g and $t are supplied either as # arrayref or string. Accordingly, lA, lC, lG and lT are the log # odds (only as arrays, no checks done right now) my ($a,$c,$g,$t,$score,$ic, $mid)=@_; #or my ($a,$c,$g,$t,$score,$ic,$mid)=('05a011','110550','400001', '100104',0.001,19.2,'CRE1'); #Where a stands for all (this frequency=1), see explanation bellow my %param=(-pA=>$a,-pC=>$c,-pG=>$g,-pT=>$t, -lA=>$la, -lC=>$lc,-lG=>$lg,-lT=>$l, -IC=>$ic,-e_val=>$score, -id=>$mid); my $site=Bio::Matrix::PSM::SiteMatrix->new(%param); #Or get it from a file: use Bio::Matrix::PSM::IO; my $psmIO= Bio::Matrix::PSM::IO->new(-file=>$file, -format=>'transfac'); while (my $psm=$psmIO->next_psm) { #Now we have a Bio::Matrix::PSM::Psm object, # see Bio::Matrix::PSM::PsmI for details #This is a Bio::Matrix::PSM::SiteMatrix object now my $matrix=$psm->matrix; } # Get a simple consensus, where alphabet is {A,C,G,T,N}, # choosing the character that both satisfies a supplied or default threshold # frequency and is the most frequenct character at each position, or N. # So for the position with A, C, G, T frequencies of 0.5, 0.25, 0.10, 0.15, # the simple consensus character will be 'A', whilst for 0.5, 0.5, 0, 0 it # would be 'N'. my $consensus=$site->consensus; # Get the IUPAC ambiguity code representation of the data in the matrix. # Because the frequencies may have been pseudo-count corrected, insignificant # frequences (below 0.05 by default) are ignored. So a position with # A, C, G, T frequencies of 0.5, 0.5, 0.01, 0.01 will get the IUPAC code 'M', # while 0.97, 0.01, 0.01, 0.01 will get the code 'A' and # 0.25, 0.25, 0.25, 0.25 would get 'N'. my $iupac=$site->IUPAC; # Getting/using regular expression (a representation of the IUPAC string) my $regexp=$site->regexp; my $count=grep($regexp,$seq); my $count=($seq=~ s/$regexp/$1/eg); print "Motif $mid is present $count times in this sequence\n"; =head1 DESCRIPTION SiteMatrix is designed to provide some basic methods when working with position scoring (weight) matrices, such as transcription factor binding sites for example. A DNA PSM consists of four vectors with frequencies {A,C,G,T}. This is the minimum information you should provide to construct a PSM object. The vectors can be provided as strings with frequenciesx10 rounded to an int, going from {0..a} and 'a' represents the maximum (10). This is like MEME's compressed representation of a matrix and it is quite useful when working with relational DB. If arrays are provided as an input (references to arrays actually) they can be any number, real or integer (frequency or count). When creating the object you can ask the constructor to make a simple pseudo count correction by adding a number (typically 1) to all positions (with the -correction option). After adding the number the frequencies will be calculated. Only use correction when you supply counts, not frequencies. Throws an exception if: You mix as an input array and string (for example A matrix is given as array, C - as string). The position vector is (0,0,0,0). One of the probability vectors is shorter than the rest. Summary of the methods I use most frequently (details bellow): iupac - return IUPAC compliant consensus as a string score - Returns the score as a real number IC - information content. Returns a real number id - identifier. Returns a string accession - accession number. Returns a string next_pos - return the sequence probably for each letter, IUPAC symbol, IUPAC probability and simple sequence consenus letter for this position. Rewind at the end. Returns a hash. pos - current position get/set. Returns an integer. regexp - construct a regular expression based on IUPAC consensus. For example AGWV will be [Aa][Gg][AaTt][AaCcGg] width - site width get_string - gets the probability vector for a single base as a string. get_array - gets the probability vector for a single base as an array. get_logs_array - gets the log-odds vector for a single base as an array. New methods, which might be of interest to anyone who wants to store PSM in a relational database without creating an entry for each position is the ability to compress the PSM vector into a string with losing usually less than 1% of the data. this can be done with: my $str=$matrix->get_compressed_freq('A'); or my $str=$matrix->get_compressed_logs('A'); Loading from a database should be done with new, but is not yest implemented. However you can still uncompress such string with: my @arr=Bio::Matrix::PSM::_uncompress_string ($str,1,1); for PSM or my @arr=Bio::Matrix::PSM::_uncompress_string ($str,1000,2); for log odds =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::PSM::SiteMatrix; use strict; use base qw(Bio::Root::Root Bio::Matrix::PSM::SiteMatrixI); =head2 new Title : new Usage : my $site=Bio::Matrix::PSM::SiteMatrix->new(-pA=>$a,-pC=>$c, -pG=>$g,-pT=>$t, -IC=>$ic, -e_val=>$score, -id=>$mid); Function: Creates a new Bio::Matrix::PSM::SiteMatrix object from memory Throws : If inconsistent data for all vectors (A,C,G and T) is provided, if you mix input types (string vs array) or if a position freq is 0. Returns : Bio::Matrix::PSM::SiteMatrix object Args : -pA => vector with the frequencies or counts of A -pC => vector for C -pG => vector for G -pt => vector for T -lA => vector for the log of A -lC => vector for the log of C -lG => vector for the log of G -lT => vector for the log of T -IC => real number, the information content of this matrix -e_val => real number, the expect value -id => string, an identifier -width => int, width of the matrix in nucleotides -sites => int, the number of sites that went into this matrix -model => hash ref, background frequencies for A, C, G and T -correction => number, the number to add to all positions to achieve psuedo count correction (default 0: no correction) NB: do not use correction when your input is frequences! -accession_number => string, an accession number Vectors can be strings of the frequencies where the frequencies are multiplied by 10 and rounded to the nearest whole number, and where 'a' is used to denote the maximal frequency 10. There should be no punctuation (spaces etc.) in the string. For example, 'a0501'. Alternatively frequencies or counts can be represented by an array ref containing the counts, frequencies or logs as any kind of number. =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my $consensus; # Too many things to rearrange, and I am creating simultanuously >500 # such objects routinely, so this becomes performance issue my %input; while (@args) { (my $key = shift @args) =~ s/-//g; #deletes all dashes (only dashes)! $input{$key} = shift @args; } $self->{_position} = 0; $self->{IC} = $input{IC}; $self->{e_val} = $input{e_val}; $self->{width} = $input{width}; $self->{logA} = $input{lA}; $self->{logC} = $input{lC}; $self->{logG} = $input{lG}; $self->{logT} = $input{lT}; $self->{sites} = $input{sites}; $self->{id} = $input{id} || 'null'; $self->{correction} = $input{correction} || 0; $self->{accession_number} = $input{accession_number}; return $self unless (defined($input{pA}) && defined($input{pC}) && defined($input{pG}) && defined($input{pT})); # This should go to _initialize? # Check for input type- no mixing alllowed, throw ex if (ref($input{pA}) =~ /ARRAY/i ) { $self->throw("Mixing matrix data types not allowed: C is not reference") unless(ref($input{pC})); $self->throw("Mixing matrix data types not allowed: G is not reference") unless (ref($input{pG})); $self->throw("Mixing matrix data types not allowed: T is not reference") unless (ref($input{pT})); $self->{probA} = $input{pA}; $self->{probC} = $input{pC}; $self->{probG} = $input{pG}; $self->{probT} = $input{pT}; } else { $self->throw("Mixing matrix data types not allowed: C is reference") if (ref($input{pC})); $self->throw("Mixing matrix data types not allowed: G is reference") if (ref($input{pG})); $self->throw("Mixing matrix data types not allowed: T is reference") if (ref($input{pT})); $self->{probA} = [split(//,$input{pA})]; $self->{probC} = [split(//,$input{pC})]; $self->{probG} = [split(//,$input{pG})]; $self->{probT} = [split(//,$input{pT})]; for (my $i=0; $i<= @{$self->{probA}}+1; $i++) { # we implictely assume these are MEME-style frequencies x 10, so # 'a' represents the 'maximum', 10. Other positions can actually # add up to over 10 due to rounding, but I don't think that is a # problem? if (${$self->{probA}}[$i] and ${$self->{probA}}[$i] eq 'a') { ${$self->{probA}}[$i]='10'; } if (${$self->{probC}}[$i] and ${$self->{probC}}[$i] eq 'a') { ${$self->{probC}}[$i]='10'; } if (${$self->{probG}}[$i] and ${$self->{probG}}[$i] eq 'a') { ${$self->{probG}}[$i]='10'; } if (${$self->{probT}}[$i] and ${$self->{probT}}[$i] eq 'a') { ${$self->{probT}}[$i]='10'; } } } # Check for position with 0 for all bases, throw exception if so for (my $i=0;$i <= $#{$self->{probA}}; $i++) { if ((${$self->{probA}}[$i] + ${$self->{probC}}[$i] + ${$self->{probG}}[$i] + ${$self->{probT}}[$i]) == 0) { $self->throw("Position meaningless-all frequencies are 0"); } # apply psuedo-count correction to all values - this will result in # very bad frequencies if the input is already frequences and a # correction value as large as 1 is used! if ($self->{correction}) { ${$self->{probA}}[$i] += $self->{correction}; ${$self->{probC}}[$i] += $self->{correction}; ${$self->{probG}}[$i] += $self->{correction}; ${$self->{probT}}[$i] += $self->{correction}; } # (re)calculate frequencies my $div= ${$self->{probA}}[$i] + ${$self->{probC}}[$i] + ${$self->{probG}}[$i] + ${$self->{probT}}[$i]; ${$self->{probA}}[$i]=${$self->{probA}}[$i]/$div; ${$self->{probC}}[$i]=${$self->{probC}}[$i]/$div; ${$self->{probG}}[$i]=${$self->{probG}}[$i]/$div; ${$self->{probT}}[$i]=${$self->{probT}}[$i]/$div; } # Calculate the logs if ((!defined($self->{logA})) && ($input{model})) { $self->calc_weight($input{model}); } # Make consensus, throw if any one of the vectors is shorter $self->_calculate_consensus; return $self; } =head2 _calculate_consensus Title : _calculate_consensus Function: Internal stuff =cut sub _calculate_consensus { my $self=shift; my ($lc,$lt,$lg)=($#{$self->{probC}},$#{$self->{probT}},$#{$self->{probG}}); my $len=$#{$self->{probA}}; $self->throw("Probability matrix is damaged for C: $len vs $lc") if ($len != $lc); $self->throw("Probability matrix is damaged for T: $len vs $lt") if ($len != $lt); $self->throw("Probability matrix is damaged for G: $len vs $lg") if ($len != $lg); for (my $i=0; $i<$len+1; $i++) { #*** IUPACp values not actually used (eg. by next_pos) (${$self->{IUPAC}}[$i],${$self->{IUPACp}}[$i])=_to_IUPAC(${$self->{probA}}[$i], ${$self->{probC}}[$i], ${$self->{probG}}[$i], ${$self->{probT}}[$i]); (${$self->{seq}}[$i], ${$self->{seqp}}[$i]) = _to_cons(${$self->{probA}}[$i], ${$self->{probC}}[$i], ${$self->{probG}}[$i], ${$self->{probT}}[$i]); } return $self; } =head2 calc_weight Title : calc_weight Usage : $obj->calc_weight({A=>0.2562, C=>0.2438, G=>0.2432, T=>0.2568}); Function: Recalculates the PSM (or weights) based on the PFM (the frequency matrix) and user supplied background model. Throws : if no model is supplied Returns : n/a Args : reference to a hash with background frequencies for A,C,G and T =cut sub calc_weight { my ($self, $model) = @_; my %model; $model{probA}=$model->{A}; $model{probC}=$model->{C}; $model{probG}=$model->{G}; $model{probT}=$model->{T}; foreach my $let (qw(probA probC probG probT)) { my @str; $self->throw('You did not provide valid model\n') unless (($model{$let}>0) && ($model{$let}<1)); foreach my $f (@{$self->{$let}}) { my $w=log($f)-log($model{$let}); push @str,$w; } my $llet=$let; $llet=~s/prob/log/; $self->{$llet}=\@str; } return $self; } =head2 next_pos Title : next_pos Usage : Function: Retrives the next position features: frequencies for A,C,G,T, the main letter (as in consensus) and the probabilty for this letter to occur at this position and the current position Returns : hash (pA,pC,pG,pT,logA,logC,logG,logT,base,prob,rel) Args : none =cut sub next_pos { my $self = shift; $self->throw("instance method called on class") unless ref $self; my $len=@{$self->{seq}}; my $pos=$self->{_position}; # End reached? if ($pos<$len) { my $pA=${$self->{probA}}[$pos]; my $pC=${$self->{probC}}[$pos]; my $pG=${$self->{probG}}[$pos]; my $pT=${$self->{probT}}[$pos]; my $lA=${$self->{logA}}[$pos]; my $lC=${$self->{logC}}[$pos]; my $lG=${$self->{logG}}[$pos]; my $lT=${$self->{logT}}[$pos]; my $base=${$self->{seq}}[$pos]; my $prob=${$self->{seqp}}[$pos]; $self->{_position}++; my %seq=(pA=>$pA,pT=>$pT,pC=>$pC,pG=>$pG, lA=>$lA,lT=>$lT,lC=>$lC,lG=>$lG,base=>$base,rel=>$pos, prob=>$prob); return %seq; } else {$self->{_position}=0; return;} } =head2 curpos Title : curpos Usage : Function: Gets/sets the current position. Converts to 0 if argument is minus and to width if greater than width Returns : integer Args : integer =cut sub curpos { my $self = shift; my $prev = $self->{_position}; if (@_) { $self->{_position} = shift; } return $prev; } =head2 e_val Title : e_val Usage : Function: Gets/sets the e-value Returns : real number Args : none to get, real number to set =cut sub e_val { my $self = shift; my $prev = $self->{e_val}; if (@_) { $self->{e_val} = shift; } return $prev; } =head2 IC Title : IC Usage : Function: Get/set the Information Content Returns : real number Args : none to get, real number to set =cut sub IC { my $self = shift; my $prev = $self->{IC}; if (@_) { $self->{IC} = shift; } return $prev; } =head2 accession_number Title : accession_number Function: Get/set the accession number, this will be unique id for the SiteMatrix object as well for any other object, inheriting from SiteMatrix Returns : string Args : none to get, string to set =cut sub accession_number { my $self = shift; my $prev = $self->{accession_number}; if (@_) { $self->{accession_number} = shift; } return $prev; } =head2 consensus Title : consensus Usage : Function: Returns the consensus Returns : string Args : (optional) threshold value 1 to 10, default 5 '5' means the returned characters had a 50% or higher presence at their position =cut sub consensus { my ($self, $thresh) = @_; if ($thresh) { my $len=$#{$self->{probA}}; for (my $i=0; $i<$len+1; $i++) { (${$self->{seq}}[$i], ${$self->{seqp}}[$i]) = _to_cons(${$self->{probA}}[$i], ${$self->{probC}}[$i], ${$self->{probG}}[$i], ${$self->{probT}}[$i], $thresh); } } my $consensus=''; foreach my $letter (@{$self->{seq}}) { $consensus .= $letter; } return $consensus; } =head2 width Title : width Usage : Function: Returns the length of the sites in used to make this matrix Returns : int Args : none =cut sub width { my $self = shift; my $width=@{$self->{probA}}; return $width; } =head2 sites Title : sites Usage : Function: Get/set the number of sites that were used to make this matrix Returns : int Args : none to get, int to set =cut sub sites { my $self = shift; if (@_) { $self->{sites} = shift } return $self->{sites} || return; } =head2 IUPAC Title : IUPAC Usage : Function: Returns IUPAC compliant consensus Returns : string Args : optionally, also supply a whole number (int) of 1 or higher to set the significance level when considering the frequencies. 1 (the default) means a 0.05 significance level: frequencies lower than 0.05 will be ignored. 2 Means a 0.005 level, and so on. =cut sub IUPAC { my ($self, $thresh) = @_; if ($thresh) { my $len=$#{$self->{probA}}; for (my $i=0; $i<$len+1; $i++) { (${$self->{IUPAC}}[$i],${$self->{IUPACp}}[$i])=_to_IUPAC(${$self->{probA}}[$i], ${$self->{probC}}[$i], ${$self->{probG}}[$i], ${$self->{probT}}[$i], $thresh); } } my $iu=$self->{IUPAC}; my $iupac=''; foreach my $let (@{$iu}) { $iupac .= $let; } return $iupac; } =head2 _to_IUPAC Title : _to_IUPAC Usage : Function: Converts a single position to IUPAC compliant symbol. For rules see the implementation Returns : char, real number Args : real numbers for frequencies of A,C,G,T (positional) optionally, also supply a whole number (int) of 1 or higher to set the significance level when considering the frequencies. 1 (the default) means a 0.05 significance level: frequencies lower than 0.05 will be ignored. 2 Means a 0.005 level, and so on. =cut sub _to_IUPAC { my ($a, $c, $g, $t, $thresh) = @_; $thresh ||= 1; $thresh = int($thresh); $a = sprintf ("%.${thresh}f", $a); $c = sprintf ("%.${thresh}f", $c); $g = sprintf ("%.${thresh}f", $g); $t = sprintf ("%.${thresh}f", $t); my $total = $a + $c + $g + $t; return 'A' if ($a == $total); return 'G' if ($g == $total); return 'C' if ($c == $total); return 'T' if ($t == $total); my $r=$g+$a; return 'R' if ($r == $total); my $y=$t+$c; return 'Y' if ($y == $total); my $m=$a+$c; return 'M' if ($m == $total); my $k=$g+$t; return 'K' if ($k == $total); my $s=$g+$c; return 'S' if ($s == $total); my $w=$a+$t; return 'W' if ($w == $total); my $d=$r+$t; return 'D' if ($d == $total); my $v=$r+$c; return 'V' if ($v == $total); my $b=$y+$g; return 'B' if ($b == $total); my $h=$y+$a; return 'H' if ($h == $total); return 'N'; } =head2 _to_cons Title : _to_cons Usage : Function: Converts a single position to simple consensus character and returns its probability. For rules see the implementation Returns : char, real number Args : real numbers for A,C,G,T (positional), and optional 5th argument of threshold (as a number between 1 and 10, where 5 is default and means the returned character had a 50% or higher presence at this position) =cut sub _to_cons { my ($A, $C, $G, $T, $thresh) = @_; $thresh ||= 5; # this multiplication by 10 is just to satisfy the thresh range of 1-10 my $a = $A * 10; my $c = $C * 10; my $g = $G * 10; my $t = $T * 10; return 'N',10 if (($a<$thresh) && ($c<$thresh) && ($g<$thresh) && ($t<$thresh)); return 'N',10 if (($a==$t) && ($a==$c) && ($a==$g)); # threshold could be lower than 50%, so must check is not only over # threshold, but also the highest frequency return 'A',$a if (($a>=$thresh) && ($a>$t) && ($a>$c) && ($a>$g)); return 'C',$c if (($c>=$thresh) && ($c>$t) && ($c>$a) && ($c>$g)); return 'G',$g if (($g>=$thresh) && ($g>$t) && ($g>$c) && ($g>$a)); return 'T',$t if (($t>=$thresh) && ($t>$g) && ($t>$c) && ($t>$a)); return 'N',10; } =head2 get_string Title : get_string Usage : Function: Returns given probability vector as a string. Useful if you want to store things in a rel database, where arrays are not first choice Throws : If the argument is outside {A,C,G,T} Returns : string Args : character {A,C,G,T} =cut sub get_string { my $self=shift; my $base=shift; my $string=''; my @prob; BASE: { if ($base eq 'A') {@prob= @{$self->{probA}}; last BASE; } if ($base eq 'C') {@prob= @{$self->{probC}}; last BASE; } if ($base eq 'G') {@prob= @{$self->{probG}}; last BASE; } if ($base eq 'T') {@prob= @{$self->{probT}}; last BASE; } $self->throw ("No such base: $base!\n"); } foreach my $prob (@prob) { my $corrected = $prob*10; my $next=sprintf("%.0f",$corrected); $next='a' if ($next eq '10'); $string .= $next; } return $string; } =head2 get_array Title : get_array Usage : Function: Returns an array with frequencies for a specified base Returns : array Args : char =cut sub get_array { my $self=shift; my $base=uc(shift); return @{$self->{probA}} if ($base eq 'A'); return @{$self->{probC}} if ($base eq 'C'); return @{$self->{probG}} if ($base eq 'G'); return @{$self->{probT}} if ($base eq 'T'); $self->throw("No such base: $base!\n"); } =head2 get_logs_array Title : get_logs_array Usage : Function: Returns an array with log_odds for a specified base Returns : array Args : char =cut sub get_logs_array { my $self=shift; my $base=uc(shift); return @{$self->{logA}} if (($base eq 'A') && ($self->{logA})); return @{$self->{logC}} if (($base eq 'C') && ($self->{logC})); return @{$self->{logG}} if (($base eq 'G') && ($self->{logG})); return @{$self->{logT}} if (($base eq 'T') && ($self->{logT})); $self->throw ("No such base: $base!\n") if (!grep(/$base/,qw(A C G T))); return; } =head2 id Title : id Usage : Function: Gets/sets the site id Returns : string Args : string =cut sub id { my $self = shift; my $prev = $self->{id}; if (@_) { $self->{id} = shift; } return $prev; } =head2 regexp Title : regexp Usage : Function: Returns a regular expression which matches the IUPAC convention. N will match X, N, - and . Returns : string Args : none (works at the threshold last used for making the IUPAC string) =cut sub regexp { my $self=shift; my $regexp; foreach my $letter (@{$self->{IUPAC}}) { my $reg; LETTER: { if ($letter eq 'A') { $reg='[Aa]'; last LETTER; } if ($letter eq 'C') { $reg='[Cc]'; last LETTER; } if ($letter eq 'G') { $reg='[Gg]'; last LETTER; } if ($letter eq 'T') { $reg='[Tt]'; last LETTER; } if ($letter eq 'M') { $reg='[AaCcMm]'; last LETTER; } if ($letter eq 'R') { $reg='[AaGgRr]'; last LETTER; } if ($letter eq 'W') { $reg='[AaTtWw]'; last LETTER; } if ($letter eq 'S') { $reg='[CcGgSs]'; last LETTER; } if ($letter eq 'Y') { $reg='[CcTtYy]'; last LETTER; } if ($letter eq 'K') { $reg='[GgTtKk]'; last LETTER; } if ($letter eq 'V') { $reg='[AaCcGgVv]'; last LETTER; } if ($letter eq 'H') { $reg='[AaCcTtHh]'; last LETTER; } if ($letter eq 'D') { $reg='[AaGgTtDd]'; last LETTER; } if ($letter eq 'B') { $reg='[CcGgTtBb]'; last LETTER; } $reg='\S'; } $regexp .= $reg; } return $regexp; } =head2 regexp_array Title : regexp_array Usage : Function: Returns a regular expression which matches the IUPAC convention. N will match X, N, - and . Returns : array Args : none (works at the threshold last used for making the IUPAC string) To do : I have separated regexp and regexp_array, but maybe they can be rewritten as one - just check what should be returned =cut sub regexp_array { my $self=shift; my @regexp; foreach my $letter (@{$self->{IUPAC}}) { my $reg; LETTER: { if ($letter eq 'A') { $reg='[Aa]'; last LETTER; } if ($letter eq 'C') { $reg='[Cc]'; last LETTER; } if ($letter eq 'G') { $reg='[Gg]'; last LETTER; } if ($letter eq 'T') { $reg='[Tt]'; last LETTER; } if ($letter eq 'M') { $reg='[AaCcMm]'; last LETTER; } if ($letter eq 'R') { $reg='[AaGgRr]'; last LETTER; } if ($letter eq 'W') { $reg='[AaTtWw]'; last LETTER; } if ($letter eq 'S') { $reg='[CcGgSs]'; last LETTER; } if ($letter eq 'Y') { $reg='[CcTtYy]'; last LETTER; } if ($letter eq 'K') { $reg='[GgTtKk]'; last LETTER; } if ($letter eq 'V') { $reg='[AaCcGgVv]'; last LETTER; } if ($letter eq 'H') { $reg='[AaCcTtHh]'; last LETTER; } if ($letter eq 'D') { $reg='[AaGgTtDd]'; last LETTER; } if ($letter eq 'B') { $reg='[CcGgTtBb]'; last LETTER; } $reg='\S'; } push @regexp,$reg; } return @regexp; } =head2 _compress_array Title : _compress_array Usage : Function: Will compress an array of real signed numbers to a string (ie vector of bytes) -127 to +127 for bi-directional(signed) and 0..255 for unsigned Returns : String Args : array reference, followed by an max value and direction (optional, default 1-unsigned),1 unsigned, any other is signed. =cut sub _compress_array { my ($array,$lm,$direct)=@_; my $str; return unless(($array) && ($lm)); $direct=1 unless ($direct); my $k1= ($direct==1) ? (255/$lm) : (127/$lm); foreach my $c (@{$array}) { $c=$lm if ($c>$lm); $c=-$lm if (($c<-$lm) && ($direct !=1)); $c=0 if (($c<0) && ($direct ==1)); my $byte=int($k1*$c); $byte=127+$byte if ($direct !=1);#Clumsy, should be really shift the bits my $char=chr($byte); $str.=$char; } return $str; } =head2 _uncompress_string Title : _uncompress_string Usage : Function: Will uncompress a string (vector of bytes) to create an array of real signed numbers (opposite to_compress_array) Returns : string, followed by an max value and direction (optional, default 1-unsigned), 1 unsigned, any other is signed. Args : array =cut sub _uncompress_string { my ($str,$lm,$direct)=@_; my @array; return unless(($str) && ($lm)); $direct=1 unless ($direct); my $k1= ($direct==1) ? (255/$lm) : (127/$lm); foreach my $c (split(//,$str)) { my $byte=ord($c); $byte=$byte-127 if ($direct !=1);#Clumsy, should be really shift the bits my $num=$byte/$k1; push @array,$num; } return @array; } =head2 get_compressed_freq Title : get_compressed_freq Usage : Function: A method to provide a compressed frequency vector. It uses one byte to code the frequence for one of the probability vectors for one position. Useful for relational database. Improvment of the previous 0..a coding. Example : my $strA=$self->get_compressed_freq('A'); Returns : String Args : char =cut sub get_compressed_freq { my $self=shift; my $base=shift; my $string=''; my @prob; BASE: { if ($base eq 'A') { @prob= @{$self->{probA}} unless (!defined($self->{probA})); last BASE; } if ($base eq 'G') { @prob= @{$self->{probG}} unless (!defined($self->{probG})); last BASE; } if ($base eq 'C') { @prob= @{$self->{probC}} unless (!defined($self->{probC})); last BASE; } if ($base eq 'T') { @prob= @{$self->{probT}} unless (!defined($self->{probT})); last BASE; } $self->throw ("No such base: $base!\n"); } my $str= _compress_array(\@prob,1,1); return $str; } =head2 get_compressed_logs Title : get_compressed_logs Usage : Function: A method to provide a compressed log-odd vector. It uses one byte to code the log value for one of the log-odds vectors for one position. Example : my $strA=$self->get_compressed_logs('A'); Returns : String Args : char =cut sub get_compressed_logs { my $self=shift; my $base=shift; my $string=''; my @prob; BASE: { if ($base eq 'A') {@prob= @{$self->{logA}} unless (!defined($self->{logA})); last BASE; } if ($base eq 'C') {@prob= @{$self->{logC}} unless (!defined($self->{logC})); last BASE; } if ($base eq 'G') {@prob= @{$self->{logG}} unless (!defined($self->{logG})); last BASE; } if ($base eq 'T') {@prob= @{$self->{logT}} unless (!defined($self->{logT})); last BASE; } $self->throw ("No such base: $base!\n"); } return _compress_array(\@prob,1000,2); } =head2 sequence_match_weight Title : sequence_match_weight Usage : Function: This method will calculate the score of a match, based on the PWM if such is associated with the matrix object. Returns undef if no PWM data is available. Throws : if the length of the sequence is different from the matrix width Example : my $score=$matrix->sequence_match_weight('ACGGATAG'); Returns : Floating point Args : string =cut sub sequence_match_weight { my ($self,$seq)=@_; return unless ($self->{logA}); my $width=$self->width; $self->throw ("I can calculate the score only for sequence which are exactly my size for $seq, my width is $width\n") unless (length($seq)==@{$self->{logA}}); $seq = uc($seq); my @seq=split(//,$seq); my $score = 0; my $i=0; foreach my $pos (@seq) { my $tv = 'log'.$pos; $self->warn("Position ".($i+1)." of input sequence has unknown (ambiguity?) character '$pos': scores will be wrong") unless defined $self->{$tv}; $score += defined $self->{$tv} ? $self->{$tv}->[$i] : 0; $i++; } return $score; } =head2 get_all_vectors Title : get_all_vectors Usage : Function: returns all possible sequence vectors to satisfy the PFM under a given threshold Throws : If threshold outside of 0..1 (no sense to do that) Example : my @vectors=$self->get_all_vectors(4); Returns : Array of strings Args : (optional) floating =cut sub get_all_vectors { my $self=shift; my $thresh=shift; $self->throw("Out of range. Threshold should be >0 and 1<.\n") if (($thresh<0) || ($thresh>1)); my @seq=split(//,$self->consensus($thresh*10)); my @perm; for my $i (0..@{$self->{probA}}) { push @{$perm[$i]},'A' if ($self->{probA}->[$i]>$thresh); push @{$perm[$i]},'C' if ($self->{probC}->[$i]>$thresh); push @{$perm[$i]},'G' if ($self->{probG}->[$i]>$thresh); push @{$perm[$i]},'T' if ($self->{probT}->[$i]>$thresh); push @{$perm[$i]},'N' if ($seq[$i] eq 'N'); } my $fpos=shift @perm; my @strings=@$fpos; foreach my $pos (@perm) { my @newstr; foreach my $let (@$pos) { foreach my $string (@strings) { my $newstring = $string . $let; push @newstr,$newstring; } } @strings=@newstr; } return @strings; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/SiteMatrixI.pm000444000765000024 3063412254227323 20640 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::Matrix::PSM::SiteMatrixI - SiteMatrixI implementation, holds a position scoring matrix (or position weight matrix) and log-odds =head1 SYNOPSIS # You cannot use this module directly; see Bio::Matrix::PSM::SiteMatrix # for an example implementation =head1 DESCRIPTION SiteMatrix is designed to provide some basic methods when working with position scoring (weight) matrices, such as transcription factor binding sites for example. A DNA PSM consists of four vectors with frequencies {A,C,G,T}. This is the minimum information you should provide to construct a PSM object. The vectors can be provided as strings with frequenciesx10 rounded to an int, going from {0..a} and 'a' represents the maximum (10). This is like MEME's compressed representation of a matrix and it is quite useful when working with relational DB. If arrays are provided as an input (references to arrays actually) they can be any number, real or integer (frequency or count). When creating the object you can ask the constructor to make a simple pseudo count correction by adding a number (typically 1) to all positions (with the -correction option). After adding the number the frequencies will be calculated. Only use correction when you supply counts, not frequencies. Throws an exception if: You mix as an input array and string (for example A matrix is given as array, C - as string). The position vector is (0,0,0,0). One of the probability vectors is shorter than the rest. Summary of the methods I use most frequently (details bellow): iupac - return IUPAC compliant consensus as a string score - Returns the score as a real number IC - information content. Returns a real number id - identifier. Returns a string accession - accession number. Returns a string next_pos - return the sequence probably for each letter, IUPAC symbol, IUPAC probability and simple sequence consenus letter for this position. Rewind at the end. Returns a hash. pos - current position get/set. Returns an integer. regexp - construct a regular expression based on IUPAC consensus. For example AGWV will be [Aa][Gg][AaTt][AaCcGg] width - site width get_string - gets the probability vector for a single base as a string. get_array - gets the probability vector for a single base as an array. get_logs_array - gets the log-odds vector for a single base as an array. New methods, which might be of interest to anyone who wants to store PSM in a relational database without creating an entry for each position is the ability to compress the PSM vector into a string with losing usually less than 1% of the data. this can be done with: my $str=$matrix->get_compressed_freq('A'); or my $str=$matrix->get_compressed_logs('A'); Loading from a database should be done with new, but is not yest implemented. However you can still uncompress such string with: my @arr=Bio::Matrix::PSM::_uncompress_string ($str,1,1); for PSM or my @arr=Bio::Matrix::PSM::_uncompress_string ($str,1000,2); for log odds =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::SiteMatrixI; # use strict; use base qw(Bio::Root::RootI); =head2 calc_weight Title : calc_weight Usage : $self->calc_weight({A=>0.2562,C=>0.2438,G=>0.2432,T=>0.2568}); Function: Recalculates the PSM (or weights) based on the PFM (the frequency matrix) and user supplied background model. Throws : if no model is supplied Example : Returns : Args : reference to a hash with background frequencies for A,C,G and T =cut sub calc_weight { my $self = shift; $self->throw_not_implemented(); } =head2 next_pos Title : next_pos Usage : my %base=$site->next_pos; Function: Retrieves the next position features: frequencies and weights for A,C,G,T, the main letter (as in consensus) and the probabilty for this letter to occur at this position and the current position Throws : Example : Returns : hash (pA,pC,pG,pT,lA,lC,lG,lT,base,prob,rel) Args : none =cut sub next_pos { my $self = shift; $self->throw_not_implemented(); } =head2 curpos Title : curpos Usage : my $pos=$site->curpos; Function: Gets/sets the current position. Converts to 0 if argument is minus and to width if greater than width Throws : Example : Returns : integer Args : integer =cut sub curpos { my $self = shift; $self->throw_not_implemented(); } =head2 e_val Title : e_val Usage : my $score=$site->e_val; Function: Gets/sets the e-value Throws : Example : Returns : real number Args : real number =cut sub e_val { my $self = shift; $self->throw_not_implemented(); } =head2 consensus Title : consensus Usage : Function: Returns the consensus Returns : string Args : (optional) threshold value 1 to 10, default 5 '5' means the returned characters had a 50% or higher presence at their position =cut sub consensus { my $self = shift; $self->throw_not_implemented(); } =head2 accession_number Title : accession_number Usage : Function: accession number, this will be unique id for the SiteMatrix object as well for any other object, inheriting from SiteMatrix Throws : Example : Returns : string Args : string =cut sub accession_number { my $self = shift; $self->throw_not_implemented(); } =head2 width Title : width Usage : my $width=$site->width; Function: Returns the length of the site Throws : Example : Returns : number Args : =cut sub width { my $self = shift; $self->throw_not_implemented(); } =head2 IUPAC Title : IUPAC Usage : my $iupac_consensus=$site->IUPAC; Function: Returns IUPAC compliant consensus Throws : Example : Returns : string Args : =cut sub IUPAC { my $self = shift; $self->throw_not_implemented(); } =head2 IC Title : IC Usage : my $ic=$site->IC; Function: Information content Throws : Example : Returns : real number Args : none =cut sub IC { my $self=shift; $self->throw_not_implemented(); } =head2 get_string Title : get_string Usage : my $freq_A=$site->get_string('A'); Function: Returns given probability vector as a string. Useful if you want to store things in a rel database, where arrays are not first choice Throws : If the argument is outside {A,C,G,T} Example : Returns : string Args : character {A,C,G,T} =cut sub get_string { my $self=shift; $self->throw_not_implemented(); } =head2 id Title : id Usage : my $id=$site->id; Function: Gets/sets the site id Throws : Example : Returns : string Args : string =cut sub id { my $self = shift; $self->throw_not_implemented(); } =head2 regexp Title : regexp Usage : my $regexp=$site->regexp; Function: Returns a regular expression which matches the IUPAC convention. N will match X, N, - and . Throws : Example : Returns : string Args : =cut sub regexp { my $self=shift; $self->throw_not_implemented(); } =head2 regexp_array Title : regexp_array Usage : my @regexp=$site->regexp; Function: Returns a regular expression which matches the IUPAC convention. N will match X, N, - and . Throws : Example : Returns : array Args : To do : I have separated regexp and regexp_array, but maybe they can be rewritten as one - just check what should be returned =cut sub regexp_array { my $self=shift; $self->throw_not_implemented(); } =head2 get_array Title : get_array Usage : my @freq_A=$site->get_array('A'); Function: Returns an array with frequencies for a specified base Throws : Example : Returns : array Args : char =cut sub get_array { my $self=shift; $self->throw_not_implemented(); } =head2 _to_IUPAC Title : _to_IUPAC Usage : Function: Converts a single position to IUPAC compliant symbol and returns its probability. For rules see the implementation. Throws : Example : Returns : char, real number Args : real numbers for A,C,G,T (positional) =cut sub _to_IUPAC { my $self = shift; $self->throw_not_implemented(); } =head2 _to_cons Title : _to_cons Usage : Function: Converts a single position to simple consensus character and returns its probability. For rules see the implementation, Throws : Example : Returns : char, real number Args : real numbers for A,C,G,T (positional) =cut sub _to_cons { my $self = shift; $self->throw_not_implemented(); } =head2 _calculate_consensus Title : _calculate_consensus Usage : Function: Internal stuff Throws : Example : Returns : Args : =cut sub _calculate_consensus { my $self = shift; $self->throw_not_implemented(); } =head2 _compress_array Title : _compress_array Usage : Function: Will compress an array of real signed numbers to a string (ie vector of bytes) -127 to +127 for bi-directional(signed) and 0..255 for unsigned ; Throws : Example : Internal stuff Returns : String Args : array reference, followed by an max value and direction (optional, default 1-unsigned),1 unsigned, any other is signed. =cut sub _compress_array { my $self = shift; $self->throw_not_implemented(); } =head2 _uncompress_string Title : _uncompress_string Usage : Function: Will uncompress a string (vector of bytes) to create an array of real signed numbers (opposite to_compress_array) Throws : Example : Internal stuff Returns : string, followed by an max value and direction (optional, default 1-unsigned), 1 unsigned, any other is signed. Args : array =cut sub _uncompress_string { my $self = shift; $self->throw_not_implemented(); } =head2 get_compressed_freq Title : get_compressed_freq Usage : Function: A method to provide a compressed frequency vector. It uses one byte to code the frequence for one of the probability vectors for one position. Useful for relational database. Improvment of the previous 0..a coding. Throws : Example : my $strA=$self->get_compressed_freq('A'); Returns : String Args : char =cut sub get_compressed_freq { my $self = shift; $self->throw_not_implemented(); } =head2 get_compressed_logs Title : get_compressed_logs Usage : Function: A method to provide a compressed log-odd vector. It uses one byte to code the log value for one of the log-odds vectors for one position. Throws : Example : my $strA=$self->get_compressed_logs('A'); Returns : String Args : char =cut sub get_compressed_logs { my $self = shift; $self->throw_not_implemented(); } =head2 sequence_match_weight Title : sequence_match_weight Usage : Function: This method will calculate the score of a match, based on the PWM if such is associated with the matrix object. Returns undef if no PWM data is available. Throws : if the length of the sequence is different from the matrix width Example : my $score=$matrix->sequence_match_weight('ACGGATAG'); Returns : Floating point Args : string =cut sub sequence_match_weight { my $self = shift; $self->throw_not_implemented(); } =head2 get_all_vectors Title : get_all_vectors Usage : Function: returns all possible sequence vectors to satisfy the PFM under a given threshold Throws : If threshold outside of 0..1 (no sense to do that) Example : my @vectors=$self->get_all_vectors(4); Returns : Array of strings Args : (optional) floating =cut sub get_all_vectors { my $self = shift; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Matrix/PSM/IO000755000765000024 012254227335 16227 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Matrix/PSM/IO/mast.pm000444000765000024 2125212254227330 17703 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::Matrix::PSM::IO::mast - PSM mast parser implementation =head1 SYNOPSIS See Bio::Matrix::PSM::IO for detailed documentation on how to use PSM parsers =head1 DESCRIPTION Parser for mast. This driver unlike meme or transfac for example is dedicated more to PSM sequence matches, than to PSM themselves. =head1 TO DO Section III should be parsed too, otherwise no real sequence is available, so we supply 'NNNNN....' as a seq which is not right. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Matrix::PSM::IO::mast; use Bio::Matrix::PSM::InstanceSite; use Bio::Matrix::PSM::Psm; use Bio::Root::Root; use strict; use base qw(Bio::Matrix::PSM::PsmHeader Bio::Matrix::PSM::IO); =head2 new Title : new Usage : my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'mast', -file=>$file); Function: Associates a file with the appropriate parser Throws : Throws if the file passed is in HTML format or if some criteria for the file format are not met. Example : Returns : psm object, associated with a file with matrix file Args : hash return : "Bio::Matrix::PSM::$format"->new(@args); =cut sub new { my($class, @args)=@_; my $self = $class->SUPER::new(@args); my (%instances,@header,$n); my ($file)=$self->_rearrange(['FILE'], @args); $self->{file} = $file; $self->{_factor}=1; $self->_initialize_io(@args) || warn "Did you intend to use STDIN?"; #Read only for now $self->{_end}=0; undef $self->{hid}; return $self if ($file=~/^>/);#Just writing my $buf=$self->_readline; $self->throw('Cannot parse HTML format yet') if ($buf =~/^/); # this should probably be moved to its own function while ( defined($buf=$self->_readline)) { chomp($buf); if ($buf=~/DATABASE AND MOTIFS/) { while ($buf=$self->_readline) { if ($buf=~/DATABASE/) { $buf=~s/^[\s\t]+//; chomp $buf; ($n,$self->{_dbname},$self->{_dbtype})=split(/\s/,$buf); $self->{_dbtype}=~s/[\(\)]//g; } if ($buf=~/MOTIFS/) { $buf=~s/^[\s\t]+//; chomp $buf; ($n,$self->{_mrsc},$self->{_msrctype})=split(/\s/,$buf); $self->{_msrctype}=~s/[\(\)]//g; last; } } if ($self->{_msrctype} ne $self->{_dbtype}) {#Assume we have protein motifs, nuc DB (not handling opp.) $self->{_factor}=3; $self->{_mixquery}=1; } } if ($buf=~m/MOTIF WIDTH BEST POSSIBLE MATCH/) { $self->_readline; while (defined($buf=$self->_readline)) { last if ($buf!~/\w/); $buf=~s/\t+//g; $buf=~s/^\s+//g; my ($id,$width,$seq)=split(/\s+/,$buf); push @{$self->{hid}},$id; $self->{length}->{$id}=$width; $self->{seq}->{$id}=$seq; } next; } if ($buf=~m/section i:/i) { $self->_readline; $self->_readline; $self->_readline; %instances=_get_genes($self); $self->{instances}=\%instances; if (!(%instances)) { $self->warn ("Your MAST analysis did not find any matches satisfying the current threshold.\nSee MAST documentation for more information.\n"); return $self; #The header might be useful so we return the object, not undef } next; } if ($buf=~m/section ii:/i) { $self->_readline; $self->_readline; $self->_readline; last; } $buf=~s/[\t+\s+]/ /g; push @header,$buf unless (($buf=~/\*{10,}/)||($buf!~/\w/)); } $self->throw('Could not read Section I, probably wrong format, make sure it is not HTML, giving up...') if !(%instances); $self->warn( "This file might be an unreadable version, proceed with caution!\n") if (!grep(/\s+MAST\s+version\s+3/,@header)); $self->{unstructured} = \@header; $self->_initialize; return $self; } # Get the file header and put store it as a hash, which later we'll use to create # the header for each Psm. See Bio::Matrix::PSM::PsmI for header function. sub _get_genes { my $self=shift; my %llid; my $ok=0; my $i=0; my %instances; while (my $line=$self->_readline) { last if ($line=~/^[\s\t*]/); # Well, ids can be nearly anything...??? chomp($line); $i++; next if ($line eq ''); $line=~s/\s+/,/g; my ($id,$key,$eval,$len)=split(/,/,$line); unless ($len) { warn "Malformed data found: $line\n"; next; } $instances{$id}=Bio::Matrix::PSM::InstanceSite->new(-id=>$id, -desc=>$key, -score=>$eval, -width=>$len, -seq=>'ACGT'); } return %instances; } =head2 next_psm Title : next_psm Usage : my $psm=$psmIO->next_psm(); Function: Reads the next PSM from the input file, associated with this object Throws : Throws if there ara format violations in the input file (checking is not very strict with all drivers). Example : Returns : Bio::Matrix::PSM::Psm object Args : none =cut sub next_psm { my $self=shift; return if ($self->{_end}==1); my (@lmotifsm,%index,$eval,$scheme,$sid); %index= %{$self->{length}}; my (@instances,%instances); my $line=$self->_readline; $line=~s/[\t\n]//; if ($line =~ /\*{10,}/) { #Endo of Section II if we do only section II $self->{_end}=1; return ; } do { if ($line!~/^\s/) { ($sid,$eval,$scheme)=split(/\s+/,$line,3); } else { $scheme .=$line; } $line=$self->_readline; $line=~s/[\t\n]//; } until ($line!~/^\s/); my $pos=1; $scheme=~s/\s+//g; $scheme=~s/\n//g; my @motifs=split(/_/,$scheme); while (@motifs) { my $next=shift(@motifs); if (!($next=~/\D/)) { last if (!@motifs); $pos+=$next; next; } my $id=$next; my $score= $id=~m/\[/ ? 'strong' : 'weak' ; my $frame; my $strand = $id =~ m/\-\d/ ? -1 : 1 ; if ($self->{_mixquery}) { $frame = 0 if $id =~ m/\d+a/ ; $frame = 1 if $id =~ m/\d+b/ ; $frame = 2 if $id =~ m/\d+c/ ; } $id=~s/\D+//g; my @s; my $width=$index{$id}; #We don't know the sequence, but we know the length my $seq='N' x ($width*$self->{_factor}); #Future version will have to parse Section tree nad get the real seq my $instance=Bio::Matrix::PSM::InstanceSite->new ( -id=>"$id\@$sid", -mid=>$id, -accession_number=>$sid, -desc=>"Motif $id occurrance in $sid", -score=>$score, -seq=>$seq, -alphabet => 'dna', -start=>$pos, -strand=>$strand); $instance->frame($frame) if ($self->{_mixquery}); push @instances,$instance; $pos+=$index{$id}*$self->{_factor}; } my $psm= Bio::Matrix::PSM::Psm->new(-instances=> \@instances, -e_val => $eval, -id => $sid); $self->_pushback($line); return $psm; } =head2 write_psm Title : write_psm Usage : #Get SiteMatrix object somehow (see Bio::Matrix::PSM::SiteMatrix) my $matrix=$psmin->next_matrix; #Create the stream my $psmio=new(-file=>">psms.mast",-format=>'mast'); $psmio->write_psm($matrix); #Will warn if only PFM data is contained in $matrix, recalculate the PWM #based on normal distribution (A=>0.25, C=>0.25, etc) Function: writes pwm in mast format Throws : Example : Args : SiteMatrix object Returns : =cut sub write_psm { my ($self,$matrix)=@_; # my $idline=">". $matrix->id . "\n"; my $w=$matrix->width; my $header="ALPHABET= ACGT\nlog-odds matrix: alength= 4 w= $w\n"; $self->_print($header); unless ($matrix->get_logs_array('A')) { warn "No log-odds data, available, using normal distribution to recalculate the PWM"; $matrix->calc_weight({A=>0.25, C=>0.25, G=>0.25,T=>0.25}); } while (my %h=$matrix->next_pos) { $self->_print (join("\t",$h{lA},$h{lC},$h{lG},$h{lT},"\n")); } } 1; BioPerl-1.6.923/Bio/Matrix/PSM/IO/masta.pm000555000765000024 2035212254227335 20054 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::IO::masta - motif fasta format parser =head1 SYNOPSIS MASTA is a position frequency matrix format similar to fasta. It contains one ID row just like fasta and then the actual data, which is tab delimited: 0.1 0.62 .017 0.11 0.22 0.13 0.54 0.11 Or A,C,G and T could be horizontally positioned (positioning is automatically detected). Please note masta will parse only DNA at the moment. It will also convert a set of aligned sequences: ACATGCAT ACAGGGAT ACAGGCAT ACCGGCAT to a PFM (SiteMatrix object). When writing if you supply SEQ it will write 10 random instances, which represent correctly the frequency and can be used as an input for weblogo creation purposes. See Bio::Matrix::PSM::IO for detailed documentation on how to use masta parser =head1 DESCRIPTION Parser for meme. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::IO::masta; use Bio::Matrix::PSM::SiteMatrix; use vars qw(@HEADER); use strict; use base qw(Bio::Matrix::PSM::IO Bio::Root::Root); =head2 new Title : new Usage : my $psmIO = Bio::Matrix::PSM::IO->new(-format=> 'masta', -file => $file, -mtype => 'PWM'); Function: Associates a file with the appropriate parser Throws : Example : Args : hash Returns : "Bio::Matrix::PSM::$format"->new(@args); =cut sub new { my($class, @args)=@_; my $self = $class->SUPER::new(@args); my ($file)=$self->_rearrange(['FILE'], @args); my ($query,$tr1)=split(/\./,$file,2); $self->{file} = $file; $self->{_end} = 0; $self->{mtype} = uc($self->_rearrange(['MTYPE'], @args) || "PFM"); $self->_initialize_io(@args) || $self->warn("Did you intend to use STDIN?"); #Read only for now return $self; } =head2 write_psm Title : write_psm Usage : Function: writes a pfm/pwm/raw sequence in a simple masta format Throws : Example : Args : SiteMatrix object, type (optional string: PWM, SEQ or PFM) Returns : =cut sub write_psm { my ($self,$matrix,$type)=@_; $self->{mtype} = uc($type) if ($type); my $idline=">". $matrix->id . "\n"; $self->_print($idline); unless ($self->{mtype} eq 'SEQ') { while (my %h=$matrix->next_pos) { my $row=$self->{mtype} eq 'PWM' ? join("\t",$h{lA},$h{lC},$h{lG},$h{lT},"\n"):join("\t",$h{pA},$h{pC},$h{pG},$h{pT},"\n"); $self->_print ($row); } } else { my @seq; while (my %h=$matrix->next_pos) { my ($a,$c,$g,$t)=_freq_to_count(\%h); $self->throw("Could not convert from frequency to count\n") if (($a+$c+$g+$t) !=10); for my $i (0..$a-1) {$seq[$i].='A';} my $m=$a+$c; for my $i ($a..$m-1) {$seq[$i].='C';} my $n=$a+$c+$g; for my $i ($m..$n-1) {$seq[$i].='G';} for my $i ($n..9) {$seq[$i].='T';} } foreach my $s (@seq) { $s.="\n"; $self->_print ($s); } } } =head2 next_matrix Title : next_matrix Usage : my $matrix = $psmio->next_matrix; Function: Alias of next_psm function =cut sub next_matrix { shift->next_psm(@_); } =head2 next_psm Title : next_psm Usage : my $matrix=$psmio->next_psm; Function: returns the next matrix in the stream Throws : If there is you mix different types, for example weights and frequencies occur in the same entry You can mix weights, but these should be designated by different ID lines Example : Args : Returns : Bio::Matrix::PSM::SiteMatrix =cut sub next_psm { my $self=shift; return if ($self->{_end}); my $line=$self->_readline; $self->throw("No ID line- wrong format\n") unless ($line=~/^>/); my ($id,$desc)=split(/[\t\s]+/,$line,2); $id=~s/>//; my ($mtype,$format,@mdata,$len); $self->{_mtype} = 0; while ($line=$self->_readline) { next if $line =~ /^\s+$/;# There should not be empty lines, but just in case... chomp $line; if ($line =~ /^>/) { $self->_pushback($line); last; } if ($line !~ /[^ACGTacgt]/g) { # This is a set of aligned sequences $self->throw("Mixing between types is not allowed or a parsing error occured\n") if (($self->{_mtype} != 3) && ($mtype)) ; $self->throw("Bad sequence- different length: $line\n") if (($len) && ($len!=length($line))); $len=length($line) unless ($len); push @mdata,$line; $self->{_mtype}=3; } else { # do not strip 'e's since they are part of number notation for small/big numbers $line=~s/[a-df-zA-DF-Z]//g; #Well we may wanna do a hash and auto check for letter order if there is a really boring talk... $line=~s/^[\s\t]+//; $line=~s/[\s\t]+/\t/g; my @data=split(/[\s\t]+/,$line); if ($#data==3) { $self->throw("Mixing between types is not allowed or a parsing error occured\n") if (($mtype)&&($self->{_mtype} !=1)) ; $self->{_mtype}=1; $mtype=1; } else { $self->throw("Mixing between types is not allowedor a parsing error occured\n") if (($mtype)&&($self->{_mtype} !=2)) ; $self->{_mtype}=2; $mtype=1; } push @mdata,\@data; } } $self->{_end} = 1 if (!defined $line || $line !~ /^>/); return _make_matrix(\@mdata,$self->{_mtype},$id,$desc); } sub _make_matrix { my ($mdata,$type,$id,$desc)=@_; if ($type==1) { my @rearr=_rearrange_matrix($mdata); $mdata=\@rearr; } #Auto recognition for what type is this entry (PFM, PWM or simple count) #A bit dangerous, I hate too much auto stuff, but I want to be able to mix different #types in a single file my $mformat='count'; my ($a,$c,$g,$t); if ($type == 3 ) { ($a,$c,$g,$t)= &_count_positions($mdata); } else { ($a,$c,$g,$t)=@{$mdata}; my $k=$a->[0]+$c->[0]+$g->[0]+$t->[0]; my $l= ($a->[0]+$c->[0]+$g->[0]+$t->[0]) - (abs($a->[0])+abs($c->[0])+abs($g->[0])+abs($t->[0])); $mformat='freq' if (($k==1) && ($l==0)); $mformat='pwm' if ($l!=0); } my (@fa,@fc,@fg,@ft,%mparam); if ($mformat eq 'pwm') { foreach my $i (0..$#{$a}) { my $ca=exp $a->[$i]; my $cc=exp $c->[$i]; my $cg=exp $g->[$i]; my $ct=exp $t->[$i]; my $all=$ca+$cc+$cg+$ct; push @fa,($ca/$all)*100; push @fc,($cc/$all)*100; push @fg,($cg/$all)*100; push @ft,($ct/$all)*100; } } $desc.=", source is $mformat"; if ($mformat eq 'pwm') { $desc=~s/^pwm//; %mparam=(-pA=>\@fa,-pC=>\@fc,-pG=>\@fg,-pT=>\@ft,-id=>$id,-desc=>$desc, -lA=>$a,-lC=>$c,-lG=>$g,-lT=>$t); } else { %mparam=(-pA=>$a,-pC=>$c,-pG=>$g,-pT=>$t,-id=>$id,-desc=>$desc); } return new Bio::Matrix::PSM::SiteMatrix(%mparam); } sub _rearrange_matrix { my $mdata=shift; my (@a,@c,@g,@t); foreach my $entry (@{$mdata}) { my ($a,$c,$g,$t)=@$entry; push @a,$a; push @c,$c; push @g,$g; push @t,$t; } return \@a,\@c,\@g,\@t; } sub _count_positions { my $seq=shift; my %pos; my $l=length($seq->[0])-1; for( my $i = 0; $i <= $l; $i++ ) { for ( qw(A C G T) ) { $pos{$_}->[$i] = 0; } } foreach my $sequence (@{$seq}) { my @let= split(//,$sequence); for my $i (0..$#let) { $pos{uc($let[$i])}->[$i]++; } } return $pos{A},$pos{C},$pos{G},$pos{T}; } sub _freq_to_count { my $h=shift; my $a=int(10*$h->{pA}+0.5); my $c=int(10*$h->{pC}+0.5); my $g=int(10*$h->{pG}+0.5); my $t=int(10*$h->{pT}+0.5); return ($a,$c,$g,$t); } 1; BioPerl-1.6.923/Bio/Matrix/PSM/IO/meme.pm000444000765000024 2261612254227317 17674 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::IO::meme - PSM meme parser implementation =head1 SYNOPSIS See Bio::Matrix::PSM::IO for detailed documentation on how to use PSM parsers =head1 DESCRIPTION Parser for meme. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::IO::meme; use Bio::Matrix::PSM::InstanceSite; use Bio::Matrix::PSM::SiteMatrix; use Bio::Matrix::PSM::Psm; use vars qw(@HEADER); use strict; use base qw(Bio::Matrix::PSM::PsmHeader Bio::Matrix::PSM::IO); @Bio::Matrix::PSM::IO::meme::HEADER = qw(e_val sites IC width); =head2 new Title : new Usage : my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'meme', -file=>$file); Function: Associates a file with the appropriate parser Throws : Throws if the file passed is in HTML format or if the MEME header cannot be found. Example : Args : hash Returns : "Bio::Matrix::PSM::$format"->new(@args); =cut sub new { my($class, @args)=@_; my $self = $class->SUPER::new(@args); my ($file)=$self->_rearrange(['FILE'], @args); my ($query,$tr1)=split(/\./,$file,2); $self->{file} = $file; $self->{query}= $query; $self->{end} = 0; $self->{_strand}=0; #This we'll need to see if revcom option is used $self->_initialize_io(@args) || warn "Did you intend to use STDIN?"; #Read only for now #Skip header my $line; while (my $line=$self->_readline) { $self->throw('Cannot parse HTML, please use text output\n') if ($line=~//); #Should start parsing HTML output, not a bug deal chomp($line); if ($line=~"^ALPHABET") { $self=_parse_coordinates($self); last; } push @{$self->{unstructured}},$line unless (($line=~/\*{10,}/) || ($line eq '')); } $self->_initialize; return $self; } =head2 _parse_coordinates Title : _parse_coordinates Usage : Function: Throws : Example : Internal stuff Returns : Args : =cut sub _parse_coordinates { my $self=shift; $self->_readline; $self->_readline; my $line=$self->_readline; while ($line !~ /^\*{10,}/ ) { chomp $line; $line =~ s/\s+/,/g; my ($id1,$w1,$l1,$id2,$w2,$l2)=split(/,/,$line); push @{$self->{hid}},$id1; $self->{weight}->{$id1}=$w1; $self->{length}->{$id1}=$l1; if ($id2) { push @{$self->{hid}},$id2; $self->{weight}->{$id2}=$w2; $self->{length}->{$id2}=$l2; } $line=$self->_readline; } return $self; } =head2 header Title : header Usage : my %header=$psmIO->header; Function: Returns the header for the MEME file Throws : Example : Fetching all the sequences included in the MEME analysis, being parsed my %header=$psmIO->header; foreach my $seqid (@{$header{instances}}) { my $seq=$db->get_Seq_by_acc($id); #Do something with the sequence } where $db might be Bio::DB:GenBank object, see Returns : Hash with three keys: instances, weights and lengths, which should be self-explenatory. Each value is an array reference. Each array element corresponds to the same element in the other two arrays. So $header{instances}->[$i] will refer to the same sequence in the motif file as $header{weights}->[$i] and $header{lengths}->[$i] Args : none Notes : OBSOLETE! =cut sub header { my $self=shift; my @instances=@{$self->{_inst_name}}; my @weights=@{$self->{_inst_weight}}; my @lengths=@{$self->{_inst_coord}}; return (instances=>\@instances,weights=>\@weights,lengths=>\@lengths); } =head2 next_psm Title : next_psm Usage : my $psm=$psmIO->next_psm(); Function: Reads the next PSM from the input file, associated with this object Throws : Throws if the format is inconsistent with the rules for MEME 3.0.4: no SUMMARY Section present or some keywords are missing/altered. Example : Returns : Bio::Matrix::PSM::Psm object Args : none =cut sub next_psm { #Parses the next prediction and returns a psm objects my $self=shift; return if ($self->{end}); my ($endm,$line,$instances,$tr,$width,$motif_id,$sites,$e_val,$id,$ic,$lA,$lC,$lG,$lT); while (defined( $line = $self->_readline) ) { #Check if revcom is enabled, not very original check.... $self->{_strand}=1 if (($line=~/^Sequence name/) && ($line=~/Strand/)); if ($line=~ m/\sSite\s/) { $instances= $self->_parseInstance; } #Here starts the next motif if ( ($line=~/width/) && ($line=~/sites/)) { chomp($line); $line=~s/[\t\s=]+/,/g; $line=~s/\t/,/g; #Parsing the general information for this prediction ($tr,$motif_id,$tr,$width,$tr,$sites, $tr,$tr,$tr,$e_val)=split(/,/,$line); $self->{id}=$self->{query} . $motif_id; } if ($line =~ /content/i) { $line=$self->_readline; chomp($line); $line=~s/[\)\(]//g; ($ic)=split(/\s/,$line); } #Last info-prob matrix data if ($line=~/position-specific\s+scoring matrix/) { ($lA,$lC,$lG,$lT)=_parse_logs($self); } if ($line=~/^letter-probability\smatrix/) { my %matrix_dat=$self->_parseMatrix($motif_id); my $psm= Bio::Matrix::PSM::Psm->new(%matrix_dat, -instances=>$instances, -e_val=>$e_val, -IC=>$ic, -width=>$width, -sites=>$sites, -lA=>$lA, -lC=>$lC, -lG=>$lG, -lT=>$lT, ); return $psm; } if ($line=~"SUMMARY OF MOTIFS") { $self->{end}=1; return; } $endm=1 if ($line=~/^Time\s/); } if ($endm) { #End of file found, end of current motif too, but not all predictions were made as requested (No summary) $self->{end}=1; warn "This MEME analysis was terminated prematurely, you may have less motifs than you requested\n"; return; } $self->throw("Wrong format\n"); # Multiple keywords not found, probably wrong format } =head2 _parseMatrix Title : _parseMatrix Usage : Function: Parses the next site matrix information in the meme file Throws : Example : Internal stuff Returns : hash as for constructing a SiteMatrix object (see SiteMatrixI) Args : string =cut sub _parseMatrix { my ($self,$id)=@_; my (@pA,@pC,@pG,@pT); my $i=0; my $line = $self->_readline; #Most important part- the probability matrix do { chomp $line; last if ($line eq ''); $line=~s/^\s+//; $line=~s/\s+/,/g; ($pA[$i],$pC[$i],$pG[$i],$pT[$i])=split(/,/,$line); $i++; $line=$self->_readline; } until $line =~ /\-{10,}/; return (-pA=>\@pA,-pC=>\@pC,-pG=>\@pG,-pT=>\@pT,-id=>$id); } =head2 _parse_logs Title : _parse_logs Usage : Function: Parses the next site matrix log values in the meme file Throws : Example : Internal stuff Returns : array of array refs Args : string =cut sub _parse_logs { my $self=shift; my (@lA,@lC,@lG,@lT); my $i=0; $self->_readline; $self->_readline; my $line = $self->_readline; #Most important part- the probability matrix do { chomp $line; last if ($line eq ''); $line=~s/^\s+//; $line=~s/\s+/,/g; ($lA[$i],$lC[$i],$lG[$i],$lT[$i])=split(/,/,$line); $i++; $line=$self->_readline; } until $line =~ /\-{10,}/; return (\@lA,\@lC,\@lG,\@lT); } =head2 _parseInstance Title : _parseInstance Usage : Function: Parses the next sites instances from the meme file Throws : Example : Internal stuff Returns : Bio::Matrix::PSM::InstanceSite object Args : none =cut sub _parseInstance { my $self = shift; my $i=0; $self->_readline; my ($line,@instance); while (defined($line=$self->_readline) ) { last if ($line =~ /\-{5}/ ); chomp($line); my @comp=split(/\s+/,$line); my ($id,$start,$score,$strand,$s1,$s2,$s3); if ( $self->{_strand}) { ($id,$strand,$start,$score,$s1,$s2,$s3)=@comp; } else { ($id,$start,$score,$s1,$s2,$s3)=@comp; $strand=1; } my $seq= $s1.$s2.$s3; if ($seq =~ /[^ACGTacgtNnXx\-\.]/) { my $col=$#comp; $self->throw("I have not been able to parse the correct instance sequence: $seq, $col columns\n"); } my $sid = $self->{id} . '@' . $id; $instance[$i] = Bio::Matrix::PSM::InstanceSite->new (-mid => $self->{id}, -start => $start, -score => $score, -seq => $seq, -strand => $strand, -accession_number => $id, -primary_id => $sid, -desc => 'Bioperl MEME parser object' ); $i++; } $self->{instances} = \@instance; return \@instance; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/IO/psiblast.pm000444000765000024 722612254227331 20546 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::IO::psiblast - PSM psiblast parser =head1 SYNOPSIS See Bio::Matrix::PSM::IO for documentation =head1 DESCRIPTION Parser for ASCII matrices from PSI-BLAST (blastpgp program in BLAST distribution). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - James Thompson Email tex@biosysadmin.com =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::IO::psiblast; use Bio::Matrix::PSM::Psm; use Bio::Matrix::PSM::ProtMatrix; use strict; use base qw(Bio::Matrix::PSM::PsmHeader Bio::Matrix::PSM::IO); # define the order in which amino acids are listed in the psiblast matrix file our @ordered_alphabet = qw/A R N D C Q E G H I L K M F P S T W Y V/; =head2 new Title : new Usage : my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'psiblast', -file=>$file); Function: Associates a file with the appropriate parser Throws : Example : Args : Returns : Bio::Matrix::PSM::ProtMatrix->new(@args); =cut sub new { my ($class,@args)=@_; my $line; my $self = $class->SUPER::new(@args); my ($file) = $self->_rearrange(['FILE'], @args); $self->_initialize_io(@args) || warn "Did you intend to use STDIN?"; # Read only for now $self->_initialize; $self->{_ordered_alphabet} = \@ordered_alphabet; return $self; } =head2 next_psm Title : next_psm Usage : my $psm = $psmIO->next_psm(); Function: Reads the next PSM from the input file, associated with this object Throws : None Returns : Bio::Matrix::PSM::ProtPsm object Args : none =cut sub next_psm { my $self = shift; my $line; return if ($self->{_end}); my %args; my @ordered_alphabet = @{$self->{_ordered_alphabet}}; while ( defined( $line = $self->_readline) ) { # remove leading and trailing whitespace chomp $line; $line =~ s/^\s+//g; $line =~ s/\s+$//g; if ( $line =~ /^(\d+)\s+(\w{1})/ ) { # match reference aa and position number my @elements = split /\s+/, $line; my $position = shift @elements; my $letter = shift @elements; my $ratio = pop @elements; my $ic = pop @elements; # put the next 20 elements into the correct array in %args for ( 0 .. 19 ) { push @{$args{'l'.$ordered_alphabet[$_]}}, shift @elements; } for ( 0 .. 19 ) { push @{$args{'p'.$ordered_alphabet[$_]}}, shift @elements; } push @{$args{'ic'}}, $ic; } } $self->{_end} = 1; # psiblast matrix files currently only hold one PSM per file my $psm = Bio::Matrix::PSM::ProtMatrix->new( %args ); return $psm; } sub DESTROY { my $self=shift; $self->close; } 1; BioPerl-1.6.923/Bio/Matrix/PSM/IO/transfac.pm000444000765000024 1544312254227326 20552 0ustar00cjfieldsstaff000000000000#--------------------------------------------------------- =head1 NAME Bio::Matrix::PSM::IO::transfac - PSM transfac parser =head1 SYNOPSIS See Bio::Matrix::PSM::IO for documentation =head1 DESCRIPTION # =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov@utk.edu =head1 APPENDIX =cut # Let the code begin... package Bio::Matrix::PSM::IO::transfac; use Bio::Matrix::PSM::Psm; use Bio::Root::Root; use Bio::Annotation::Reference; use Bio::Annotation::Comment; use Bio::Annotation::DBLink; use strict; use base qw(Bio::Matrix::PSM::PsmHeader Bio::Matrix::PSM::IO); =head2 new Title : new Usage : my $psmIO = Bio::Matrix::PSM::IO->new(-format=>'transfac', -file=>$file); Function: Associates a file with the appropriate parser Throws : Example : Args : Returns : "Bio::Matrix::PSM::$format"->new(@args); =cut sub new { my ($class,@args)=@_; my $line; my $self = $class->SUPER::new(@args); my ($file)=$self->_rearrange(['FILE'], @args); $self->_initialize_io(@args) || warn "Did you intend to use STDIN?"; #Read only for now #Remove header do { $line=$self->_readline; chomp $line; push @{$self->{unstructured}},$line if (length($line)>2); } until ($line =~ m{^//}) || (!defined($line)); #Unstructured header $self->_initialize; return $self; } =head2 next_psm Title : next_psm Usage : my $psm=$psmIO->next_psm(); Function: Reads the next PSM from the input file, associated with this object Throws : Upon finding a line, defining the matrix, where one or more positions are not defined, see _make_matrix Returns : Bio::Matrix::PSM::Psm object Args : none =cut sub next_psm { my $self=shift; my $line; return if ($self->{end}); my (@a,@c,@g,@t, $id, $tr1, @refs,$accn, $bf, $sites); my $i=0; while (defined( $line=$self->_readline)) { chomp($line); if ($line=~/^\d{2}/) { #Begining of the frequency data ($a[$i],$c[$i],$g[$i],$t[$i])=_parse_matrix($line); $i++; } ($tr1,$accn)=split(/\s{2}/,$line) if ($line=~/^AC\s/); ($tr1,$bf)=split(/\s{2}/,$line) if ($line=~/^BF\s/); ($tr1,$id)=split(/\s{2}/,$line) if ($line=~/^ID\s/); last if (($line=~/^XX/) && ($i>0)); } if (!(defined($id) && defined($accn))) { $self->{end}=1; return; } while (defined( $line=$self->_readline)) { #How many sites? if ($line=~/^BA\s/) { my ($tr1,$ba)=split(/\s{2}/,$line); ($sites)=split(/\s/,$ba); } if ($line=~/^RN/) { #Adding a reference as Bio::Annotation object (self) # not interested in RN line itself, since has only transfac-specific # reference id? - no push back of line my $ref=_parse_ref($self); push @refs,$ref } last if ($line=~m{^//}); } # We have the frequencies, let's create a SiteMatrix object my %matrix = &_make_matrix($self,\@a,\@c,\@g,\@t,$id, $accn); $matrix{-sites}=$sites if ($sites); $matrix{-width}=@a; my $psm=Bio::Matrix::PSM::Psm->new(%matrix); foreach my $ref (@refs) { $psm->add_Annotation('reference',$ref); } return $psm; } =head2 _parseMatrix Title : _parseMatrix Usage : Function: Parses a line Throws : Example : Internal stuff Returns : array (frequencies for A,C,G,T in this order). Args : string =cut sub _parse_matrix { my $line=shift; $line=~s/\s+/,/g; my ($tr,$a,$c,$g,$t)=split(/,/,$line); return $a,$c,$g,$t; } =head2 _make_matrix Title : _make_matrix Usage : Function: Throws : If a position is undefined, for example if you have line like this in the file you are parsing: 08 4,7,,9 Example : Internal stuff Returns : Args : =cut sub _make_matrix { my ($a, $c, $g, $t, @fa, @fc,@fg, @ft, @a,@c,@g,@t); my $ave=0; my ($self,$cA,$cC,$cG,$cT, $id, $accn)= @_; for (my $i=0; $i < @{$cA};$i++) { #No value can be undefined -throw an exception, since setting to 0 probably would be wrong #If this happens it would indicate most probably that the file, being parsed is in a different format map { $self->throw('Parsing error, a position is not defined') unless defined(${$_}[$i]) } ($cA, $cG, $cC, $cT); if ( (${$cA}[$i] + ${$cC}[$i] + ${$cG}[$i] + ${$cT}[$i] ) ==0 ) { push @a,$ave; push @c,$ave; push @g,$ave; push @t,$ave; } else { push @a,${$cA}[$i]; push @c,${$cC}[$i]; push @g,${$cG}[$i]; push @t,${$cT}[$i]; $ave = ((${$cA}[$i]+${$cC}[$i]+ ${$cG}[$i]+${$cT}[$i]) / 4 +$ave)/2; } } for (my $i=0; $i<@a;$i++) { my $zero=($a[$i]+$c[$i]+$g[$i]+$t[$i]); next if ($zero==0); push @fa, $a[$i]; push @fc, $c[$i]; push @fg, $g[$i]; push @ft, $t[$i]; } return (-pA=>\@fa,-pC=>\@fc,-pG=>\@fg,-pT=>\@ft, -id=>$id, -accession_number=>$accn) } sub _parse_ref { my $self=shift; my ($authors,$title,$loc,@refs,$tr,$db,$dbid); while (my $refline=$self->_readline) { #Poorely designed, should go through an array with fields chomp $refline; my ($field,$arg)=split(/\s+/,$refline,2); last if ($field=~/XX/); $field.=' '; REF: { if ($field=~/RX/) { #DB Reference $refline=~s/[;\.]//g; ($tr, $db, $dbid)=split(/\s+/,$refline); last REF; } if ($field=~/RT/) { #Title $title .= $arg; last REF; } if ($field=~/RA/) { #Author $authors .= $arg; last REF; } if ($field=~/RL/) { #Journal $loc .= $arg; last REF; } } } my $reference=Bio::Annotation::Reference->new(-authors=>$authors, -title=>$title, -location=>$loc); if ($db eq 'MEDLINE') { # does it ever equal medline? $reference->medline($dbid); } elsif ($dbid) { $reference->pubmed($dbid); } return $reference; } sub DESTROY { my $self=shift; $self->close; } 1; BioPerl-1.6.923/Bio/MolEvol000755000765000024 012254227323 15367 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/MolEvol/CodonModel.pm000444000765000024 26345712254227323 20166 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::MolEvol::CodonModel # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::MolEvol::CodonModel - Codon Evolution Models =head1 SYNOPSIS use Bio::MolEvol::CodonModel; my $codon_path = Bio::MolEvol::CodonModel->codon_path; my ($ns, $syn) = $codon_path->{'AATAAC'}; print "AAT -> AAC: $ns ns mutations, $syn syn mutations\n"; =head1 DESCRIPTION This object is intended to group Codon Evolution Models. Currently it has one method codon_path that returns a hash reference representing the number of mutations it takes to mutate from one codon to another. Some more description of how this is generated will follow later. Additional codon evolution models and substitution matricies could be represented here as well. Some of this may not be optimally named so this can change before the next stable release of the BioPerl code. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org This is based on work from Alisha Holloway at UC Davis and Corbin Jones at UNC-Chapel Hill. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::MolEvol::CodonModel; =head2 codon_path Title : codon_path Usage : return a matrix of edit paths between codons Example : my $codon_path = Bio::MolEvol::CodonModel->codon_path; Returns : Hash reference Args : none =cut sub codon_path { return { 'AAAAAA' => [0,0], 'AAAAAC' => [1,0], 'AAAAAG' => [0,1], 'AAAAAT' => [1,0], 'AAAACA' => [1,0], 'AAAACC' => [1,1], 'AAAACG' => [1,1], 'AAAACT' => [1,1], 'AAAAGA' => [1,0], 'AAAAGC' => [2,0], 'AAAAGG' => [1,1], 'AAAAGT' => [2,0], 'AAAATA' => [1,0], 'AAAATC' => [1,1], 'AAAATG' => [1,1], 'AAAATT' => [1,1], 'AAACAA' => [1,0], 'AAACAC' => [2,0], 'AAACAG' => [1,1], 'AAACAT' => [2,0], 'AAACCA' => [2,0], 'AAACCC' => [2,1], 'AAACCG' => [2,1], 'AAACCT' => [2,1], 'AAACGA' => [1,1], 'AAACGC' => [1,2], 'AAACGG' => [1,2], 'AAACGT' => [1,2], 'AAACTA' => [2,0], 'AAACTC' => [2,1], 'AAACTG' => [2,1], 'AAACTT' => [2,1], 'AAAGAA' => [1,0], 'AAAGAC' => [2,0], 'AAAGAG' => [1,1], 'AAAGAT' => [2,0], 'AAAGCA' => [2,0], 'AAAGCC' => [2,1], 'AAAGCG' => [2,1], 'AAAGCT' => [2,1], 'AAAGGA' => [2,0], 'AAAGGC' => [2,1], 'AAAGGG' => [2,1], 'AAAGGT' => [2,1], 'AAAGTA' => [2,0], 'AAAGTC' => [2,1], 'AAAGTG' => [2,1], 'AAAGTT' => [2,1], 'AAATAC' => [2,0], 'AAATAT' => [2,0], 'AAATCA' => [2,0], 'AAATCC' => [2,1], 'AAATCG' => [2,1], 'AAATCT' => [2,1], 'AAATGC' => [3,0], 'AAATGG' => [2,1], 'AAATGT' => [3,0], 'AAATTA' => [2,0], 'AAATTC' => [2,1], 'AAATTG' => [2,1], 'AAATTT' => [2,1], 'AACAAA' => [1,0], 'AACAAC' => [0,0], 'AACAAG' => [1,0], 'AACAAT' => [0,1], 'AACACA' => [1,1], 'AACACC' => [1,0], 'AACACG' => [1,1], 'AACACT' => [1,1], 'AACAGA' => [2,0], 'AACAGC' => [1,0], 'AACAGG' => [2,0], 'AACAGT' => [1,1], 'AACATA' => [1,1], 'AACATC' => [1,0], 'AACATG' => [2,0], 'AACATT' => [1,1], 'AACCAA' => [2,0], 'AACCAC' => [1,0], 'AACCAG' => [2,0], 'AACCAT' => [1,1], 'AACCCA' => [2,1], 'AACCCC' => [2,0], 'AACCCG' => [2,1], 'AACCCT' => [2,1], 'AACCGA' => [2,1], 'AACCGC' => [2,0], 'AACCGG' => [2,1], 'AACCGT' => [2,1], 'AACCTA' => [2,1], 'AACCTC' => [2,0], 'AACCTG' => [2,1], 'AACCTT' => [2,1], 'AACGAA' => [2,0], 'AACGAC' => [1,0], 'AACGAG' => [2,0], 'AACGAT' => [1,1], 'AACGCA' => [2,1], 'AACGCC' => [2,0], 'AACGCG' => [2,1], 'AACGCT' => [2,1], 'AACGGA' => [2,1], 'AACGGC' => [2,0], 'AACGGG' => [2,1], 'AACGGT' => [2,1], 'AACGTA' => [2,1], 'AACGTC' => [2,0], 'AACGTG' => [2,1], 'AACGTT' => [2,1], 'AACTAC' => [1,0], 'AACTAT' => [1,1], 'AACTCA' => [2,1], 'AACTCC' => [2,0], 'AACTCG' => [2,1], 'AACTCT' => [2,1], 'AACTGC' => [2,0], 'AACTGG' => [3,0], 'AACTGT' => [2,1], 'AACTTA' => [2,1], 'AACTTC' => [2,0], 'AACTTG' => [3,0], 'AACTTT' => [2,1], 'AAGAAA' => [0,1], 'AAGAAC' => [1,0], 'AAGAAG' => [0,0], 'AAGAAT' => [1,0], 'AAGACA' => [1,1], 'AAGACC' => [1,1], 'AAGACG' => [1,0], 'AAGACT' => [1,1], 'AAGAGA' => [1,1], 'AAGAGC' => [2,0], 'AAGAGG' => [1,0], 'AAGAGT' => [2,0], 'AAGATA' => [1,1], 'AAGATC' => [2,0], 'AAGATG' => [1,0], 'AAGATT' => [2,0], 'AAGCAA' => [1,1], 'AAGCAC' => [2,0], 'AAGCAG' => [1,0], 'AAGCAT' => [2,0], 'AAGCCA' => [2,1], 'AAGCCC' => [2,1], 'AAGCCG' => [2,0], 'AAGCCT' => [2,1], 'AAGCGA' => [1,2], 'AAGCGC' => [1,2], 'AAGCGG' => [1,1], 'AAGCGT' => [1,2], 'AAGCTA' => [2,1], 'AAGCTC' => [2,1], 'AAGCTG' => [2,0], 'AAGCTT' => [2,1], 'AAGGAA' => [1,1], 'AAGGAC' => [2,0], 'AAGGAG' => [1,0], 'AAGGAT' => [2,0], 'AAGGCA' => [2,1], 'AAGGCC' => [2,1], 'AAGGCG' => [2,0], 'AAGGCT' => [2,1], 'AAGGGA' => [2,1], 'AAGGGC' => [2,1], 'AAGGGG' => [2,0], 'AAGGGT' => [2,1], 'AAGGTA' => [2,1], 'AAGGTC' => [2,1], 'AAGGTG' => [2,0], 'AAGGTT' => [2,1], 'AAGTAC' => [2,0], 'AAGTAT' => [2,0], 'AAGTCA' => [2,1], 'AAGTCC' => [2,1], 'AAGTCG' => [2,0], 'AAGTCT' => [2,1], 'AAGTGC' => [3,0], 'AAGTGG' => [2,0], 'AAGTGT' => [3,0], 'AAGTTA' => [2,1], 'AAGTTC' => [3,0], 'AAGTTG' => [2,0], 'AAGTTT' => [3,0], 'AATAAA' => [1,0], 'AATAAC' => [0,1], 'AATAAG' => [1,0], 'AATAAT' => [0,0], 'AATACA' => [1,1], 'AATACC' => [1,1], 'AATACG' => [1,1], 'AATACT' => [1,0], 'AATAGA' => [2,0], 'AATAGC' => [1,1], 'AATAGG' => [2,0], 'AATAGT' => [1,0], 'AATATA' => [1,1], 'AATATC' => [1,1], 'AATATG' => [2,0], 'AATATT' => [1,0], 'AATCAA' => [2,0], 'AATCAC' => [1,1], 'AATCAG' => [2,0], 'AATCAT' => [1,0], 'AATCCA' => [2,1], 'AATCCC' => [2,1], 'AATCCG' => [2,1], 'AATCCT' => [2,0], 'AATCGA' => [2,1], 'AATCGC' => [2,1], 'AATCGG' => [2,1], 'AATCGT' => [2,0], 'AATCTA' => [2,1], 'AATCTC' => [2,1], 'AATCTG' => [2,1], 'AATCTT' => [2,0], 'AATGAA' => [2,0], 'AATGAC' => [1,1], 'AATGAG' => [2,0], 'AATGAT' => [1,0], 'AATGCA' => [2,1], 'AATGCC' => [2,1], 'AATGCG' => [2,1], 'AATGCT' => [2,0], 'AATGGA' => [2,1], 'AATGGC' => [2,1], 'AATGGG' => [2,1], 'AATGGT' => [2,0], 'AATGTA' => [2,1], 'AATGTC' => [2,1], 'AATGTG' => [2,1], 'AATGTT' => [2,0], 'AATTAC' => [1,1], 'AATTAT' => [1,0], 'AATTCA' => [2,1], 'AATTCC' => [2,1], 'AATTCG' => [2,1], 'AATTCT' => [2,0], 'AATTGC' => [2,1], 'AATTGG' => [3,0], 'AATTGT' => [2,0], 'AATTTA' => [2,1], 'AATTTC' => [2,1], 'AATTTG' => [3,0], 'AATTTT' => [2,0], 'ACAAAA' => [1,0], 'ACAAAC' => [1,1], 'ACAAAG' => [1,1], 'ACAAAT' => [1,1], 'ACAACA' => [0,0], 'ACAACC' => [0,1], 'ACAACG' => [0,1], 'ACAACT' => [0,1], 'ACAAGA' => [1,0], 'ACAAGC' => [1,1], 'ACAAGG' => [1,1], 'ACAAGT' => [1,1], 'ACAATA' => [1,0], 'ACAATC' => [1,1], 'ACAATG' => [1,1], 'ACAATT' => [1,1], 'ACACAA' => [2,0], 'ACACAC' => [2,1], 'ACACAG' => [2,1], 'ACACAT' => [2,1], 'ACACCA' => [1,0], 'ACACCC' => [1,1], 'ACACCG' => [1,1], 'ACACCT' => [1,1], 'ACACGA' => [1,1], 'ACACGC' => [1,2], 'ACACGG' => [1,2], 'ACACGT' => [1,2], 'ACACTA' => [2,0], 'ACACTC' => [2,1], 'ACACTG' => [2,1], 'ACACTT' => [2,1], 'ACAGAA' => [2,0], 'ACAGAC' => [2,1], 'ACAGAG' => [2,1], 'ACAGAT' => [2,1], 'ACAGCA' => [1,0], 'ACAGCC' => [1,1], 'ACAGCG' => [1,1], 'ACAGCT' => [1,1], 'ACAGGA' => [2,0], 'ACAGGC' => [2,1], 'ACAGGG' => [2,1], 'ACAGGT' => [2,1], 'ACAGTA' => [2,0], 'ACAGTC' => [2,1], 'ACAGTG' => [2,1], 'ACAGTT' => [2,1], 'ACATAC' => [2,1], 'ACATAT' => [2,1], 'ACATCA' => [1,0], 'ACATCC' => [1,1], 'ACATCG' => [1,1], 'ACATCT' => [1,1], 'ACATGC' => [2,1], 'ACATGG' => [2,1], 'ACATGT' => [2,1], 'ACATTA' => [2,0], 'ACATTC' => [2,1], 'ACATTG' => [2,1], 'ACATTT' => [2,1], 'ACCAAA' => [1,1], 'ACCAAC' => [1,0], 'ACCAAG' => [1,1], 'ACCAAT' => [1,1], 'ACCACA' => [0,1], 'ACCACC' => [0,0], 'ACCACG' => [0,1], 'ACCACT' => [0,1], 'ACCAGA' => [1,1], 'ACCAGC' => [1,0], 'ACCAGG' => [1,1], 'ACCAGT' => [1,1], 'ACCATA' => [1,1], 'ACCATC' => [1,0], 'ACCATG' => [1,1], 'ACCATT' => [1,1], 'ACCCAA' => [2,1], 'ACCCAC' => [2,0], 'ACCCAG' => [2,1], 'ACCCAT' => [2,1], 'ACCCCA' => [1,1], 'ACCCCC' => [1,0], 'ACCCCG' => [1,1], 'ACCCCT' => [1,1], 'ACCCGA' => [1,2], 'ACCCGC' => [2,0], 'ACCCGG' => [1,2], 'ACCCGT' => [2,1], 'ACCCTA' => [2,1], 'ACCCTC' => [2,0], 'ACCCTG' => [2,1], 'ACCCTT' => [2,1], 'ACCGAA' => [2,1], 'ACCGAC' => [2,0], 'ACCGAG' => [2,1], 'ACCGAT' => [2,1], 'ACCGCA' => [1,1], 'ACCGCC' => [1,0], 'ACCGCG' => [1,1], 'ACCGCT' => [1,1], 'ACCGGA' => [2,1], 'ACCGGC' => [2,0], 'ACCGGG' => [2,1], 'ACCGGT' => [2,1], 'ACCGTA' => [2,1], 'ACCGTC' => [2,0], 'ACCGTG' => [2,1], 'ACCGTT' => [2,1], 'ACCTAC' => [2,0], 'ACCTAT' => [2,1], 'ACCTCA' => [1,1], 'ACCTCC' => [1,0], 'ACCTCG' => [1,1], 'ACCTCT' => [1,1], 'ACCTGC' => [2,0], 'ACCTGG' => [2,1], 'ACCTGT' => [2,1], 'ACCTTA' => [2,1], 'ACCTTC' => [2,0], 'ACCTTG' => [2,1], 'ACCTTT' => [2,1], 'ACGAAA' => [1,1], 'ACGAAC' => [1,1], 'ACGAAG' => [1,0], 'ACGAAT' => [1,1], 'ACGACA' => [0,1], 'ACGACC' => [0,1], 'ACGACG' => [0,0], 'ACGACT' => [0,1], 'ACGAGA' => [1,1], 'ACGAGC' => [1,1], 'ACGAGG' => [1,0], 'ACGAGT' => [1,1], 'ACGATA' => [1,1], 'ACGATC' => [1,1], 'ACGATG' => [1,0], 'ACGATT' => [1,1], 'ACGCAA' => [2,1], 'ACGCAC' => [2,1], 'ACGCAG' => [2,0], 'ACGCAT' => [2,1], 'ACGCCA' => [1,1], 'ACGCCC' => [1,1], 'ACGCCG' => [1,0], 'ACGCCT' => [1,1], 'ACGCGA' => [1,2], 'ACGCGC' => [1,2], 'ACGCGG' => [1,1], 'ACGCGT' => [1,2], 'ACGCTA' => [2,1], 'ACGCTC' => [2,1], 'ACGCTG' => [2,0], 'ACGCTT' => [2,1], 'ACGGAA' => [2,1], 'ACGGAC' => [2,1], 'ACGGAG' => [2,0], 'ACGGAT' => [2,1], 'ACGGCA' => [1,1], 'ACGGCC' => [1,1], 'ACGGCG' => [1,0], 'ACGGCT' => [1,1], 'ACGGGA' => [2,1], 'ACGGGC' => [2,1], 'ACGGGG' => [2,0], 'ACGGGT' => [2,1], 'ACGGTA' => [2,1], 'ACGGTC' => [2,1], 'ACGGTG' => [2,0], 'ACGGTT' => [2,1], 'ACGTAC' => [2,1], 'ACGTAT' => [2,1], 'ACGTCA' => [1,1], 'ACGTCC' => [1,1], 'ACGTCG' => [1,0], 'ACGTCT' => [1,1], 'ACGTGC' => [2,1], 'ACGTGG' => [2,0], 'ACGTGT' => [2,1], 'ACGTTA' => [2,1], 'ACGTTC' => [2,1], 'ACGTTG' => [2,0], 'ACGTTT' => [2,1], 'ACTAAA' => [1,1], 'ACTAAC' => [1,1], 'ACTAAG' => [1,1], 'ACTAAT' => [1,0], 'ACTACA' => [0,1], 'ACTACC' => [0,1], 'ACTACG' => [0,1], 'ACTACT' => [0,0], 'ACTAGA' => [1,1], 'ACTAGC' => [1,1], 'ACTAGG' => [1,1], 'ACTAGT' => [1,0], 'ACTATA' => [1,1], 'ACTATC' => [1,1], 'ACTATG' => [1,1], 'ACTATT' => [1,0], 'ACTCAA' => [2,1], 'ACTCAC' => [2,1], 'ACTCAG' => [2,1], 'ACTCAT' => [2,0], 'ACTCCA' => [1,1], 'ACTCCC' => [1,1], 'ACTCCG' => [1,1], 'ACTCCT' => [1,0], 'ACTCGA' => [1,2], 'ACTCGC' => [2,1], 'ACTCGG' => [1,2], 'ACTCGT' => [2,0], 'ACTCTA' => [2,1], 'ACTCTC' => [2,1], 'ACTCTG' => [2,1], 'ACTCTT' => [2,0], 'ACTGAA' => [2,1], 'ACTGAC' => [2,1], 'ACTGAG' => [2,1], 'ACTGAT' => [2,0], 'ACTGCA' => [1,1], 'ACTGCC' => [1,1], 'ACTGCG' => [1,1], 'ACTGCT' => [1,0], 'ACTGGA' => [2,1], 'ACTGGC' => [2,1], 'ACTGGG' => [2,1], 'ACTGGT' => [2,0], 'ACTGTA' => [2,1], 'ACTGTC' => [2,1], 'ACTGTG' => [2,1], 'ACTGTT' => [2,0], 'ACTTAC' => [2,1], 'ACTTAT' => [2,0], 'ACTTCA' => [1,1], 'ACTTCC' => [1,1], 'ACTTCG' => [1,1], 'ACTTCT' => [1,0], 'ACTTGC' => [2,1], 'ACTTGG' => [2,1], 'ACTTGT' => [2,0], 'ACTTTA' => [2,1], 'ACTTTC' => [2,1], 'ACTTTG' => [2,1], 'ACTTTT' => [2,0], 'AGAAAA' => [1,0], 'AGAAAC' => [2,0], 'AGAAAG' => [1,1], 'AGAAAT' => [2,0], 'AGAACA' => [1,0], 'AGAACC' => [1,1], 'AGAACG' => [1,1], 'AGAACT' => [1,1], 'AGAAGA' => [0,0], 'AGAAGC' => [1,0], 'AGAAGG' => [0,1], 'AGAAGT' => [1,0], 'AGAATA' => [1,0], 'AGAATC' => [1,1], 'AGAATG' => [1,1], 'AGAATT' => [1,1], 'AGACAA' => [1,1], 'AGACAC' => [1,2], 'AGACAG' => [1,2], 'AGACAT' => [1,2], 'AGACCA' => [1,1], 'AGACCC' => [1,2], 'AGACCG' => [1,2], 'AGACCT' => [1,2], 'AGACGA' => [0,1], 'AGACGC' => [0,2], 'AGACGG' => [0,2], 'AGACGT' => [0,2], 'AGACTA' => [1,1], 'AGACTC' => [1,2], 'AGACTG' => [1,2], 'AGACTT' => [1,2], 'AGAGAA' => [2,0], 'AGAGAC' => [2,1], 'AGAGAG' => [2,1], 'AGAGAT' => [2,1], 'AGAGCA' => [2,0], 'AGAGCC' => [2,1], 'AGAGCG' => [2,1], 'AGAGCT' => [2,1], 'AGAGGA' => [1,0], 'AGAGGC' => [1,1], 'AGAGGG' => [1,1], 'AGAGGT' => [1,1], 'AGAGTA' => [2,0], 'AGAGTC' => [2,1], 'AGAGTG' => [2,1], 'AGAGTT' => [2,1], 'AGATAC' => [3,0], 'AGATAT' => [3,0], 'AGATCA' => [2,0], 'AGATCC' => [2,1], 'AGATCG' => [2,1], 'AGATCT' => [2,1], 'AGATGC' => [2,0], 'AGATGG' => [1,1], 'AGATGT' => [2,0], 'AGATTA' => [2,0], 'AGATTC' => [2,1], 'AGATTG' => [2,1], 'AGATTT' => [2,1], 'AGCAAA' => [2,0], 'AGCAAC' => [1,0], 'AGCAAG' => [2,0], 'AGCAAT' => [1,1], 'AGCACA' => [1,1], 'AGCACC' => [1,0], 'AGCACG' => [1,1], 'AGCACT' => [1,1], 'AGCAGA' => [1,0], 'AGCAGC' => [0,0], 'AGCAGG' => [1,0], 'AGCAGT' => [0,1], 'AGCATA' => [1,1], 'AGCATC' => [1,0], 'AGCATG' => [2,0], 'AGCATT' => [1,1], 'AGCCAA' => [2,1], 'AGCCAC' => [2,0], 'AGCCAG' => [2,1], 'AGCCAT' => [2,1], 'AGCCCA' => [2,1], 'AGCCCC' => [2,0], 'AGCCCG' => [2,1], 'AGCCCT' => [2,1], 'AGCCGA' => [1,1], 'AGCCGC' => [1,0], 'AGCCGG' => [1,1], 'AGCCGT' => [1,1], 'AGCCTA' => [2,1], 'AGCCTC' => [2,0], 'AGCCTG' => [2,1], 'AGCCTT' => [2,1], 'AGCGAA' => [2,1], 'AGCGAC' => [2,0], 'AGCGAG' => [2,1], 'AGCGAT' => [2,1], 'AGCGCA' => [2,1], 'AGCGCC' => [2,0], 'AGCGCG' => [2,1], 'AGCGCT' => [2,1], 'AGCGGA' => [1,1], 'AGCGGC' => [1,0], 'AGCGGG' => [1,1], 'AGCGGT' => [1,1], 'AGCGTA' => [2,1], 'AGCGTC' => [2,0], 'AGCGTG' => [2,1], 'AGCGTT' => [2,1], 'AGCTAC' => [2,0], 'AGCTAT' => [2,1], 'AGCTCA' => [2,1], 'AGCTCC' => [2,0], 'AGCTCG' => [2,1], 'AGCTCT' => [2,1], 'AGCTGC' => [1,0], 'AGCTGG' => [2,0], 'AGCTGT' => [1,1], 'AGCTTA' => [2,1], 'AGCTTC' => [2,0], 'AGCTTG' => [3,0], 'AGCTTT' => [2,1], 'AGGAAA' => [1,1], 'AGGAAC' => [2,0], 'AGGAAG' => [1,0], 'AGGAAT' => [2,0], 'AGGACA' => [1,1], 'AGGACC' => [1,1], 'AGGACG' => [1,0], 'AGGACT' => [1,1], 'AGGAGA' => [0,1], 'AGGAGC' => [1,0], 'AGGAGG' => [0,0], 'AGGAGT' => [1,0], 'AGGATA' => [1,1], 'AGGATC' => [2,0], 'AGGATG' => [1,0], 'AGGATT' => [2,0], 'AGGCAA' => [1,2], 'AGGCAC' => [1,2], 'AGGCAG' => [1,1], 'AGGCAT' => [1,2], 'AGGCCA' => [1,2], 'AGGCCC' => [1,2], 'AGGCCG' => [1,1], 'AGGCCT' => [1,2], 'AGGCGA' => [0,2], 'AGGCGC' => [0,2], 'AGGCGG' => [0,1], 'AGGCGT' => [0,2], 'AGGCTA' => [1,2], 'AGGCTC' => [1,2], 'AGGCTG' => [1,1], 'AGGCTT' => [1,2], 'AGGGAA' => [2,1], 'AGGGAC' => [2,1], 'AGGGAG' => [2,0], 'AGGGAT' => [2,1], 'AGGGCA' => [2,1], 'AGGGCC' => [2,1], 'AGGGCG' => [2,0], 'AGGGCT' => [2,1], 'AGGGGA' => [1,1], 'AGGGGC' => [1,1], 'AGGGGG' => [1,0], 'AGGGGT' => [1,1], 'AGGGTA' => [2,1], 'AGGGTC' => [2,1], 'AGGGTG' => [2,0], 'AGGGTT' => [2,1], 'AGGTAC' => [3,0], 'AGGTAT' => [3,0], 'AGGTCA' => [2,1], 'AGGTCC' => [2,1], 'AGGTCG' => [2,0], 'AGGTCT' => [2,1], 'AGGTGC' => [2,0], 'AGGTGG' => [1,0], 'AGGTGT' => [2,0], 'AGGTTA' => [2,1], 'AGGTTC' => [3,0], 'AGGTTG' => [2,0], 'AGGTTT' => [3,0], 'AGTAAA' => [2,0], 'AGTAAC' => [1,1], 'AGTAAG' => [2,0], 'AGTAAT' => [1,0], 'AGTACA' => [1,1], 'AGTACC' => [1,1], 'AGTACG' => [1,1], 'AGTACT' => [1,0], 'AGTAGA' => [1,0], 'AGTAGC' => [0,1], 'AGTAGG' => [1,0], 'AGTAGT' => [0,0], 'AGTATA' => [1,1], 'AGTATC' => [1,1], 'AGTATG' => [2,0], 'AGTATT' => [1,0], 'AGTCAA' => [2,1], 'AGTCAC' => [2,1], 'AGTCAG' => [2,1], 'AGTCAT' => [2,0], 'AGTCCA' => [2,1], 'AGTCCC' => [2,1], 'AGTCCG' => [2,1], 'AGTCCT' => [2,0], 'AGTCGA' => [1,1], 'AGTCGC' => [1,1], 'AGTCGG' => [1,1], 'AGTCGT' => [1,0], 'AGTCTA' => [2,1], 'AGTCTC' => [2,1], 'AGTCTG' => [2,1], 'AGTCTT' => [2,0], 'AGTGAA' => [2,1], 'AGTGAC' => [2,1], 'AGTGAG' => [2,1], 'AGTGAT' => [2,0], 'AGTGCA' => [2,1], 'AGTGCC' => [2,1], 'AGTGCG' => [2,1], 'AGTGCT' => [2,0], 'AGTGGA' => [1,1], 'AGTGGC' => [1,1], 'AGTGGG' => [1,1], 'AGTGGT' => [1,0], 'AGTGTA' => [2,1], 'AGTGTC' => [2,1], 'AGTGTG' => [2,1], 'AGTGTT' => [2,0], 'AGTTAC' => [2,1], 'AGTTAT' => [2,0], 'AGTTCA' => [2,1], 'AGTTCC' => [2,1], 'AGTTCG' => [2,1], 'AGTTCT' => [2,0], 'AGTTGC' => [1,1], 'AGTTGG' => [2,0], 'AGTTGT' => [1,0], 'AGTTTA' => [2,1], 'AGTTTC' => [2,1], 'AGTTTG' => [3,0], 'AGTTTT' => [2,0], 'ATAAAA' => [1,0], 'ATAAAC' => [1,1], 'ATAAAG' => [1,1], 'ATAAAT' => [1,1], 'ATAACA' => [1,0], 'ATAACC' => [1,1], 'ATAACG' => [1,1], 'ATAACT' => [1,1], 'ATAAGA' => [1,0], 'ATAAGC' => [1,1], 'ATAAGG' => [1,1], 'ATAAGT' => [1,1], 'ATAATA' => [0,0], 'ATAATC' => [0,1], 'ATAATG' => [1,0], 'ATAATT' => [0,1], 'ATACAA' => [2,0], 'ATACAC' => [2,1], 'ATACAG' => [2,1], 'ATACAT' => [2,1], 'ATACCA' => [2,0], 'ATACCC' => [2,1], 'ATACCG' => [2,1], 'ATACCT' => [2,1], 'ATACGA' => [1,1], 'ATACGC' => [1,2], 'ATACGG' => [1,2], 'ATACGT' => [1,2], 'ATACTA' => [1,0], 'ATACTC' => [1,1], 'ATACTG' => [1,1], 'ATACTT' => [1,1], 'ATAGAA' => [2,0], 'ATAGAC' => [2,1], 'ATAGAG' => [2,1], 'ATAGAT' => [2,1], 'ATAGCA' => [2,0], 'ATAGCC' => [2,1], 'ATAGCG' => [2,1], 'ATAGCT' => [2,1], 'ATAGGA' => [2,0], 'ATAGGC' => [2,1], 'ATAGGG' => [2,1], 'ATAGGT' => [2,1], 'ATAGTA' => [1,0], 'ATAGTC' => [1,1], 'ATAGTG' => [1,1], 'ATAGTT' => [1,1], 'ATATAC' => [2,1], 'ATATAT' => [2,1], 'ATATCA' => [2,0], 'ATATCC' => [2,1], 'ATATCG' => [2,1], 'ATATCT' => [2,1], 'ATATGC' => [2,1], 'ATATGG' => [2,1], 'ATATGT' => [2,1], 'ATATTA' => [1,0], 'ATATTC' => [1,1], 'ATATTG' => [1,1], 'ATATTT' => [1,1], 'ATCAAA' => [1,1], 'ATCAAC' => [1,0], 'ATCAAG' => [2,0], 'ATCAAT' => [1,1], 'ATCACA' => [1,1], 'ATCACC' => [1,0], 'ATCACG' => [1,1], 'ATCACT' => [1,1], 'ATCAGA' => [1,1], 'ATCAGC' => [1,0], 'ATCAGG' => [2,0], 'ATCAGT' => [1,1], 'ATCATA' => [0,1], 'ATCATC' => [0,0], 'ATCATG' => [1,0], 'ATCATT' => [0,1], 'ATCCAA' => [2,1], 'ATCCAC' => [2,0], 'ATCCAG' => [2,1], 'ATCCAT' => [2,1], 'ATCCCA' => [2,1], 'ATCCCC' => [2,0], 'ATCCCG' => [2,1], 'ATCCCT' => [2,1], 'ATCCGA' => [1,2], 'ATCCGC' => [2,0], 'ATCCGG' => [2,1], 'ATCCGT' => [2,1], 'ATCCTA' => [1,1], 'ATCCTC' => [1,0], 'ATCCTG' => [1,1], 'ATCCTT' => [1,1], 'ATCGAA' => [2,1], 'ATCGAC' => [2,0], 'ATCGAG' => [2,1], 'ATCGAT' => [2,1], 'ATCGCA' => [2,1], 'ATCGCC' => [2,0], 'ATCGCG' => [2,1], 'ATCGCT' => [2,1], 'ATCGGA' => [2,1], 'ATCGGC' => [2,0], 'ATCGGG' => [2,1], 'ATCGGT' => [2,1], 'ATCGTA' => [1,1], 'ATCGTC' => [1,0], 'ATCGTG' => [1,1], 'ATCGTT' => [1,1], 'ATCTAC' => [2,0], 'ATCTAT' => [2,1], 'ATCTCA' => [2,1], 'ATCTCC' => [2,0], 'ATCTCG' => [2,1], 'ATCTCT' => [2,1], 'ATCTGC' => [2,0], 'ATCTGG' => [3,0], 'ATCTGT' => [2,1], 'ATCTTA' => [1,1], 'ATCTTC' => [1,0], 'ATCTTG' => [2,0], 'ATCTTT' => [1,1], 'ATGAAA' => [1,1], 'ATGAAC' => [2,0], 'ATGAAG' => [1,0], 'ATGAAT' => [2,0], 'ATGACA' => [1,1], 'ATGACC' => [1,1], 'ATGACG' => [1,0], 'ATGACT' => [1,1], 'ATGAGA' => [1,1], 'ATGAGC' => [2,0], 'ATGAGG' => [1,0], 'ATGAGT' => [2,0], 'ATGATA' => [1,0], 'ATGATC' => [1,0], 'ATGATG' => [0,0], 'ATGATT' => [1,0], 'ATGCAA' => [2,1], 'ATGCAC' => [2,1], 'ATGCAG' => [2,0], 'ATGCAT' => [2,1], 'ATGCCA' => [2,1], 'ATGCCC' => [2,1], 'ATGCCG' => [2,0], 'ATGCCT' => [2,1], 'ATGCGA' => [1,2], 'ATGCGC' => [1,2], 'ATGCGG' => [1,1], 'ATGCGT' => [1,2], 'ATGCTA' => [1,1], 'ATGCTC' => [1,1], 'ATGCTG' => [1,0], 'ATGCTT' => [1,1], 'ATGGAA' => [2,1], 'ATGGAC' => [2,1], 'ATGGAG' => [2,0], 'ATGGAT' => [2,1], 'ATGGCA' => [2,1], 'ATGGCC' => [2,1], 'ATGGCG' => [2,0], 'ATGGCT' => [2,1], 'ATGGGA' => [2,1], 'ATGGGC' => [2,1], 'ATGGGG' => [2,0], 'ATGGGT' => [2,1], 'ATGGTA' => [1,1], 'ATGGTC' => [1,1], 'ATGGTG' => [1,0], 'ATGGTT' => [1,1], 'ATGTAC' => [3,0], 'ATGTAT' => [3,0], 'ATGTCA' => [2,1], 'ATGTCC' => [2,1], 'ATGTCG' => [2,0], 'ATGTCT' => [2,1], 'ATGTGC' => [3,0], 'ATGTGG' => [2,0], 'ATGTGT' => [3,0], 'ATGTTA' => [1,1], 'ATGTTC' => [2,0], 'ATGTTG' => [1,0], 'ATGTTT' => [2,0], 'ATTAAA' => [1,1], 'ATTAAC' => [1,1], 'ATTAAG' => [2,0], 'ATTAAT' => [1,0], 'ATTACA' => [1,1], 'ATTACC' => [1,1], 'ATTACG' => [1,1], 'ATTACT' => [1,0], 'ATTAGA' => [1,1], 'ATTAGC' => [1,1], 'ATTAGG' => [2,0], 'ATTAGT' => [1,0], 'ATTATA' => [0,1], 'ATTATC' => [0,1], 'ATTATG' => [1,0], 'ATTATT' => [0,0], 'ATTCAA' => [2,1], 'ATTCAC' => [2,1], 'ATTCAG' => [2,1], 'ATTCAT' => [2,0], 'ATTCCA' => [2,1], 'ATTCCC' => [2,1], 'ATTCCG' => [2,1], 'ATTCCT' => [2,0], 'ATTCGA' => [1,2], 'ATTCGC' => [2,1], 'ATTCGG' => [2,1], 'ATTCGT' => [2,0], 'ATTCTA' => [1,1], 'ATTCTC' => [1,1], 'ATTCTG' => [1,1], 'ATTCTT' => [1,0], 'ATTGAA' => [2,1], 'ATTGAC' => [2,1], 'ATTGAG' => [2,1], 'ATTGAT' => [2,0], 'ATTGCA' => [2,1], 'ATTGCC' => [2,1], 'ATTGCG' => [2,1], 'ATTGCT' => [2,0], 'ATTGGA' => [2,1], 'ATTGGC' => [2,1], 'ATTGGG' => [2,1], 'ATTGGT' => [2,0], 'ATTGTA' => [1,1], 'ATTGTC' => [1,1], 'ATTGTG' => [1,1], 'ATTGTT' => [1,0], 'ATTTAC' => [2,1], 'ATTTAT' => [2,0], 'ATTTCA' => [2,1], 'ATTTCC' => [2,1], 'ATTTCG' => [2,1], 'ATTTCT' => [2,0], 'ATTTGC' => [2,1], 'ATTTGG' => [3,0], 'ATTTGT' => [2,0], 'ATTTTA' => [1,1], 'ATTTTC' => [1,1], 'ATTTTG' => [2,0], 'ATTTTT' => [1,0], 'CAAAAA' => [1,0], 'CAAAAC' => [2,0], 'CAAAAG' => [1,1], 'CAAAAT' => [2,0], 'CAAACA' => [2,0], 'CAAACC' => [2,1], 'CAAACG' => [2,1], 'CAAACT' => [2,1], 'CAAAGA' => [1,1], 'CAAAGC' => [2,1], 'CAAAGG' => [1,2], 'CAAAGT' => [2,1], 'CAAATA' => [2,0], 'CAAATC' => [2,1], 'CAAATG' => [2,1], 'CAAATT' => [2,1], 'CAACAA' => [0,0], 'CAACAC' => [1,0], 'CAACAG' => [0,1], 'CAACAT' => [1,0], 'CAACCA' => [1,0], 'CAACCC' => [1,1], 'CAACCG' => [1,1], 'CAACCT' => [1,1], 'CAACGA' => [1,0], 'CAACGC' => [1,1], 'CAACGG' => [1,1], 'CAACGT' => [1,1], 'CAACTA' => [1,0], 'CAACTC' => [1,1], 'CAACTG' => [1,1], 'CAACTT' => [1,1], 'CAAGAA' => [1,0], 'CAAGAC' => [2,0], 'CAAGAG' => [1,1], 'CAAGAT' => [2,0], 'CAAGCA' => [2,0], 'CAAGCC' => [2,1], 'CAAGCG' => [2,1], 'CAAGCT' => [2,1], 'CAAGGA' => [2,0], 'CAAGGC' => [2,1], 'CAAGGG' => [2,1], 'CAAGGT' => [2,1], 'CAAGTA' => [2,0], 'CAAGTC' => [2,1], 'CAAGTG' => [2,1], 'CAAGTT' => [2,1], 'CAATAC' => [2,0], 'CAATAT' => [2,0], 'CAATCA' => [2,0], 'CAATCC' => [2,1], 'CAATCG' => [2,1], 'CAATCT' => [2,1], 'CAATGC' => [2,1], 'CAATGG' => [2,1], 'CAATGT' => [2,1], 'CAATTA' => [1,1], 'CAATTC' => [2,1], 'CAATTG' => [1,2], 'CAATTT' => [2,1], 'CACAAA' => [2,0], 'CACAAC' => [1,0], 'CACAAG' => [2,0], 'CACAAT' => [1,1], 'CACACA' => [2,1], 'CACACC' => [2,0], 'CACACG' => [2,1], 'CACACT' => [2,1], 'CACAGA' => [1,2], 'CACAGC' => [2,0], 'CACAGG' => [1,2], 'CACAGT' => [2,1], 'CACATA' => [2,1], 'CACATC' => [2,0], 'CACATG' => [2,1], 'CACATT' => [2,1], 'CACCAA' => [1,0], 'CACCAC' => [0,0], 'CACCAG' => [1,0], 'CACCAT' => [0,1], 'CACCCA' => [1,1], 'CACCCC' => [1,0], 'CACCCG' => [1,1], 'CACCCT' => [1,1], 'CACCGA' => [1,1], 'CACCGC' => [1,0], 'CACCGG' => [1,1], 'CACCGT' => [1,1], 'CACCTA' => [1,1], 'CACCTC' => [1,0], 'CACCTG' => [1,1], 'CACCTT' => [1,1], 'CACGAA' => [2,0], 'CACGAC' => [1,0], 'CACGAG' => [2,0], 'CACGAT' => [1,1], 'CACGCA' => [2,1], 'CACGCC' => [2,0], 'CACGCG' => [2,1], 'CACGCT' => [2,1], 'CACGGA' => [2,1], 'CACGGC' => [2,0], 'CACGGG' => [2,1], 'CACGGT' => [2,1], 'CACGTA' => [2,1], 'CACGTC' => [2,0], 'CACGTG' => [2,1], 'CACGTT' => [2,1], 'CACTAC' => [1,0], 'CACTAT' => [1,1], 'CACTCA' => [2,1], 'CACTCC' => [2,0], 'CACTCG' => [2,1], 'CACTCT' => [2,1], 'CACTGC' => [2,0], 'CACTGG' => [2,1], 'CACTGT' => [2,1], 'CACTTA' => [1,2], 'CACTTC' => [2,0], 'CACTTG' => [1,2], 'CACTTT' => [2,1], 'CAGAAA' => [1,1], 'CAGAAC' => [2,0], 'CAGAAG' => [1,0], 'CAGAAT' => [2,0], 'CAGACA' => [2,1], 'CAGACC' => [2,1], 'CAGACG' => [2,0], 'CAGACT' => [2,1], 'CAGAGA' => [1,2], 'CAGAGC' => [2,1], 'CAGAGG' => [1,1], 'CAGAGT' => [2,1], 'CAGATA' => [2,1], 'CAGATC' => [2,1], 'CAGATG' => [2,0], 'CAGATT' => [2,1], 'CAGCAA' => [0,1], 'CAGCAC' => [1,0], 'CAGCAG' => [0,0], 'CAGCAT' => [1,0], 'CAGCCA' => [1,1], 'CAGCCC' => [1,1], 'CAGCCG' => [1,0], 'CAGCCT' => [1,1], 'CAGCGA' => [1,1], 'CAGCGC' => [1,1], 'CAGCGG' => [1,0], 'CAGCGT' => [1,1], 'CAGCTA' => [1,1], 'CAGCTC' => [1,1], 'CAGCTG' => [1,0], 'CAGCTT' => [1,1], 'CAGGAA' => [1,1], 'CAGGAC' => [2,0], 'CAGGAG' => [1,0], 'CAGGAT' => [2,0], 'CAGGCA' => [2,1], 'CAGGCC' => [2,1], 'CAGGCG' => [2,0], 'CAGGCT' => [2,1], 'CAGGGA' => [2,1], 'CAGGGC' => [2,1], 'CAGGGG' => [2,0], 'CAGGGT' => [2,1], 'CAGGTA' => [2,1], 'CAGGTC' => [2,1], 'CAGGTG' => [2,0], 'CAGGTT' => [2,1], 'CAGTAC' => [2,0], 'CAGTAT' => [2,0], 'CAGTCA' => [2,1], 'CAGTCC' => [2,1], 'CAGTCG' => [2,0], 'CAGTCT' => [2,1], 'CAGTGC' => [2,1], 'CAGTGG' => [2,0], 'CAGTGT' => [2,1], 'CAGTTA' => [1,2], 'CAGTTC' => [2,1], 'CAGTTG' => [1,1], 'CAGTTT' => [2,1], 'CATAAA' => [2,0], 'CATAAC' => [1,1], 'CATAAG' => [2,0], 'CATAAT' => [1,0], 'CATACA' => [2,1], 'CATACC' => [2,1], 'CATACG' => [2,1], 'CATACT' => [2,0], 'CATAGA' => [1,2], 'CATAGC' => [2,1], 'CATAGG' => [1,2], 'CATAGT' => [2,0], 'CATATA' => [2,1], 'CATATC' => [2,1], 'CATATG' => [2,1], 'CATATT' => [2,0], 'CATCAA' => [1,0], 'CATCAC' => [0,1], 'CATCAG' => [1,0], 'CATCAT' => [0,0], 'CATCCA' => [1,1], 'CATCCC' => [1,1], 'CATCCG' => [1,1], 'CATCCT' => [1,0], 'CATCGA' => [1,1], 'CATCGC' => [1,1], 'CATCGG' => [1,1], 'CATCGT' => [1,0], 'CATCTA' => [1,1], 'CATCTC' => [1,1], 'CATCTG' => [1,1], 'CATCTT' => [1,0], 'CATGAA' => [2,0], 'CATGAC' => [1,1], 'CATGAG' => [2,0], 'CATGAT' => [1,0], 'CATGCA' => [2,1], 'CATGCC' => [2,1], 'CATGCG' => [2,1], 'CATGCT' => [2,0], 'CATGGA' => [2,1], 'CATGGC' => [2,1], 'CATGGG' => [2,1], 'CATGGT' => [2,0], 'CATGTA' => [2,1], 'CATGTC' => [2,1], 'CATGTG' => [2,1], 'CATGTT' => [2,0], 'CATTAC' => [1,1], 'CATTAT' => [1,0], 'CATTCA' => [2,1], 'CATTCC' => [2,1], 'CATTCG' => [2,1], 'CATTCT' => [2,0], 'CATTGC' => [2,1], 'CATTGG' => [2,1], 'CATTGT' => [2,0], 'CATTTA' => [1,2], 'CATTTC' => [2,1], 'CATTTG' => [1,2], 'CATTTT' => [2,0], 'CCAAAA' => [2,0], 'CCAAAC' => [2,1], 'CCAAAG' => [2,1], 'CCAAAT' => [2,1], 'CCAACA' => [1,0], 'CCAACC' => [1,1], 'CCAACG' => [1,1], 'CCAACT' => [1,1], 'CCAAGA' => [1,1], 'CCAAGC' => [2,1], 'CCAAGG' => [1,2], 'CCAAGT' => [2,1], 'CCAATA' => [2,0], 'CCAATC' => [2,1], 'CCAATG' => [2,1], 'CCAATT' => [2,1], 'CCACAA' => [1,0], 'CCACAC' => [1,1], 'CCACAG' => [1,1], 'CCACAT' => [1,1], 'CCACCA' => [0,0], 'CCACCC' => [0,1], 'CCACCG' => [0,1], 'CCACCT' => [0,1], 'CCACGA' => [1,0], 'CCACGC' => [1,1], 'CCACGG' => [1,1], 'CCACGT' => [1,1], 'CCACTA' => [1,0], 'CCACTC' => [1,1], 'CCACTG' => [1,1], 'CCACTT' => [1,1], 'CCAGAA' => [2,0], 'CCAGAC' => [2,1], 'CCAGAG' => [2,1], 'CCAGAT' => [2,1], 'CCAGCA' => [1,0], 'CCAGCC' => [1,1], 'CCAGCG' => [1,1], 'CCAGCT' => [1,1], 'CCAGGA' => [2,0], 'CCAGGC' => [2,1], 'CCAGGG' => [2,1], 'CCAGGT' => [2,1], 'CCAGTA' => [2,0], 'CCAGTC' => [2,1], 'CCAGTG' => [2,1], 'CCAGTT' => [2,1], 'CCATAC' => [2,1], 'CCATAT' => [2,1], 'CCATCA' => [1,0], 'CCATCC' => [1,1], 'CCATCG' => [1,1], 'CCATCT' => [1,1], 'CCATGC' => [2,1], 'CCATGG' => [2,1], 'CCATGT' => [2,1], 'CCATTA' => [1,1], 'CCATTC' => [2,1], 'CCATTG' => [1,2], 'CCATTT' => [2,1], 'CCCAAA' => [2,1], 'CCCAAC' => [2,0], 'CCCAAG' => [2,1], 'CCCAAT' => [2,1], 'CCCACA' => [1,1], 'CCCACC' => [1,0], 'CCCACG' => [1,1], 'CCCACT' => [1,1], 'CCCAGA' => [1,2], 'CCCAGC' => [2,0], 'CCCAGG' => [1,2], 'CCCAGT' => [2,1], 'CCCATA' => [2,1], 'CCCATC' => [2,0], 'CCCATG' => [2,1], 'CCCATT' => [2,1], 'CCCCAA' => [1,1], 'CCCCAC' => [1,0], 'CCCCAG' => [1,1], 'CCCCAT' => [1,1], 'CCCCCA' => [0,1], 'CCCCCC' => [0,0], 'CCCCCG' => [0,1], 'CCCCCT' => [0,1], 'CCCCGA' => [1,1], 'CCCCGC' => [1,0], 'CCCCGG' => [1,1], 'CCCCGT' => [1,1], 'CCCCTA' => [1,1], 'CCCCTC' => [1,0], 'CCCCTG' => [1,1], 'CCCCTT' => [1,1], 'CCCGAA' => [2,1], 'CCCGAC' => [2,0], 'CCCGAG' => [2,1], 'CCCGAT' => [2,1], 'CCCGCA' => [1,1], 'CCCGCC' => [1,0], 'CCCGCG' => [1,1], 'CCCGCT' => [1,1], 'CCCGGA' => [2,1], 'CCCGGC' => [2,0], 'CCCGGG' => [2,1], 'CCCGGT' => [2,1], 'CCCGTA' => [2,1], 'CCCGTC' => [2,0], 'CCCGTG' => [2,1], 'CCCGTT' => [2,1], 'CCCTAC' => [2,0], 'CCCTAT' => [2,1], 'CCCTCA' => [1,1], 'CCCTCC' => [1,0], 'CCCTCG' => [1,1], 'CCCTCT' => [1,1], 'CCCTGC' => [2,0], 'CCCTGG' => [2,1], 'CCCTGT' => [2,1], 'CCCTTA' => [1,2], 'CCCTTC' => [2,0], 'CCCTTG' => [1,2], 'CCCTTT' => [2,1], 'CCGAAA' => [2,1], 'CCGAAC' => [2,1], 'CCGAAG' => [2,0], 'CCGAAT' => [2,1], 'CCGACA' => [1,1], 'CCGACC' => [1,1], 'CCGACG' => [1,0], 'CCGACT' => [1,1], 'CCGAGA' => [1,2], 'CCGAGC' => [2,1], 'CCGAGG' => [1,1], 'CCGAGT' => [2,1], 'CCGATA' => [2,1], 'CCGATC' => [2,1], 'CCGATG' => [2,0], 'CCGATT' => [2,1], 'CCGCAA' => [1,1], 'CCGCAC' => [1,1], 'CCGCAG' => [1,0], 'CCGCAT' => [1,1], 'CCGCCA' => [0,1], 'CCGCCC' => [0,1], 'CCGCCG' => [0,0], 'CCGCCT' => [0,1], 'CCGCGA' => [1,1], 'CCGCGC' => [1,1], 'CCGCGG' => [1,0], 'CCGCGT' => [1,1], 'CCGCTA' => [1,1], 'CCGCTC' => [1,1], 'CCGCTG' => [1,0], 'CCGCTT' => [1,1], 'CCGGAA' => [2,1], 'CCGGAC' => [2,1], 'CCGGAG' => [2,0], 'CCGGAT' => [2,1], 'CCGGCA' => [1,1], 'CCGGCC' => [1,1], 'CCGGCG' => [1,0], 'CCGGCT' => [1,1], 'CCGGGA' => [2,1], 'CCGGGC' => [2,1], 'CCGGGG' => [2,0], 'CCGGGT' => [2,1], 'CCGGTA' => [2,1], 'CCGGTC' => [2,1], 'CCGGTG' => [2,0], 'CCGGTT' => [2,1], 'CCGTAC' => [2,1], 'CCGTAT' => [2,1], 'CCGTCA' => [1,1], 'CCGTCC' => [1,1], 'CCGTCG' => [1,0], 'CCGTCT' => [1,1], 'CCGTGC' => [2,1], 'CCGTGG' => [2,0], 'CCGTGT' => [2,1], 'CCGTTA' => [1,2], 'CCGTTC' => [2,1], 'CCGTTG' => [1,1], 'CCGTTT' => [2,1], 'CCTAAA' => [2,1], 'CCTAAC' => [2,1], 'CCTAAG' => [2,1], 'CCTAAT' => [2,0], 'CCTACA' => [1,1], 'CCTACC' => [1,1], 'CCTACG' => [1,1], 'CCTACT' => [1,0], 'CCTAGA' => [1,2], 'CCTAGC' => [2,1], 'CCTAGG' => [1,2], 'CCTAGT' => [2,0], 'CCTATA' => [2,1], 'CCTATC' => [2,1], 'CCTATG' => [2,1], 'CCTATT' => [2,0], 'CCTCAA' => [1,1], 'CCTCAC' => [1,1], 'CCTCAG' => [1,1], 'CCTCAT' => [1,0], 'CCTCCA' => [0,1], 'CCTCCC' => [0,1], 'CCTCCG' => [0,1], 'CCTCCT' => [0,0], 'CCTCGA' => [1,1], 'CCTCGC' => [1,1], 'CCTCGG' => [1,1], 'CCTCGT' => [1,0], 'CCTCTA' => [1,1], 'CCTCTC' => [1,1], 'CCTCTG' => [1,1], 'CCTCTT' => [1,0], 'CCTGAA' => [2,1], 'CCTGAC' => [2,1], 'CCTGAG' => [2,1], 'CCTGAT' => [2,0], 'CCTGCA' => [1,1], 'CCTGCC' => [1,1], 'CCTGCG' => [1,1], 'CCTGCT' => [1,0], 'CCTGGA' => [2,1], 'CCTGGC' => [2,1], 'CCTGGG' => [2,1], 'CCTGGT' => [2,0], 'CCTGTA' => [2,1], 'CCTGTC' => [2,1], 'CCTGTG' => [2,1], 'CCTGTT' => [2,0], 'CCTTAC' => [2,1], 'CCTTAT' => [2,0], 'CCTTCA' => [1,1], 'CCTTCC' => [1,1], 'CCTTCG' => [1,1], 'CCTTCT' => [1,0], 'CCTTGC' => [2,1], 'CCTTGG' => [2,1], 'CCTTGT' => [2,0], 'CCTTTA' => [1,2], 'CCTTTC' => [2,1], 'CCTTTG' => [1,2], 'CCTTTT' => [2,0], 'CGAAAA' => [1,1], 'CGAAAC' => [2,1], 'CGAAAG' => [1,2], 'CGAAAT' => [2,1], 'CGAACA' => [1,1], 'CGAACC' => [1,2], 'CGAACG' => [1,2], 'CGAACT' => [1,2], 'CGAAGA' => [0,1], 'CGAAGC' => [1,1], 'CGAAGG' => [0,2], 'CGAAGT' => [1,1], 'CGAATA' => [1,1], 'CGAATC' => [1,2], 'CGAATG' => [1,2], 'CGAATT' => [1,2], 'CGACAA' => [1,0], 'CGACAC' => [1,1], 'CGACAG' => [1,1], 'CGACAT' => [1,1], 'CGACCA' => [1,0], 'CGACCC' => [1,1], 'CGACCG' => [1,1], 'CGACCT' => [1,1], 'CGACGA' => [0,0], 'CGACGC' => [0,1], 'CGACGG' => [0,1], 'CGACGT' => [0,1], 'CGACTA' => [1,0], 'CGACTC' => [1,1], 'CGACTG' => [1,1], 'CGACTT' => [1,1], 'CGAGAA' => [2,0], 'CGAGAC' => [2,1], 'CGAGAG' => [2,1], 'CGAGAT' => [2,1], 'CGAGCA' => [2,0], 'CGAGCC' => [2,1], 'CGAGCG' => [2,1], 'CGAGCT' => [2,1], 'CGAGGA' => [1,0], 'CGAGGC' => [1,1], 'CGAGGG' => [1,1], 'CGAGGT' => [1,1], 'CGAGTA' => [2,0], 'CGAGTC' => [2,1], 'CGAGTG' => [2,1], 'CGAGTT' => [2,1], 'CGATAC' => [2,1], 'CGATAT' => [2,1], 'CGATCA' => [2,0], 'CGATCC' => [2,1], 'CGATCG' => [2,1], 'CGATCT' => [2,1], 'CGATGC' => [1,1], 'CGATGG' => [1,1], 'CGATGT' => [1,1], 'CGATTA' => [1,1], 'CGATTC' => [2,1], 'CGATTG' => [1,2], 'CGATTT' => [2,1], 'CGCAAA' => [1,2], 'CGCAAC' => [2,0], 'CGCAAG' => [1,2], 'CGCAAT' => [2,1], 'CGCACA' => [1,2], 'CGCACC' => [2,0], 'CGCACG' => [1,2], 'CGCACT' => [2,1], 'CGCAGA' => [0,2], 'CGCAGC' => [1,0], 'CGCAGG' => [0,2], 'CGCAGT' => [1,1], 'CGCATA' => [1,2], 'CGCATC' => [2,0], 'CGCATG' => [1,2], 'CGCATT' => [2,1], 'CGCCAA' => [1,1], 'CGCCAC' => [1,0], 'CGCCAG' => [1,1], 'CGCCAT' => [1,1], 'CGCCCA' => [1,1], 'CGCCCC' => [1,0], 'CGCCCG' => [1,1], 'CGCCCT' => [1,1], 'CGCCGA' => [0,1], 'CGCCGC' => [0,0], 'CGCCGG' => [0,1], 'CGCCGT' => [0,1], 'CGCCTA' => [1,1], 'CGCCTC' => [1,0], 'CGCCTG' => [1,1], 'CGCCTT' => [1,1], 'CGCGAA' => [2,1], 'CGCGAC' => [2,0], 'CGCGAG' => [2,1], 'CGCGAT' => [2,1], 'CGCGCA' => [2,1], 'CGCGCC' => [2,0], 'CGCGCG' => [2,1], 'CGCGCT' => [2,1], 'CGCGGA' => [1,1], 'CGCGGC' => [1,0], 'CGCGGG' => [1,1], 'CGCGGT' => [1,1], 'CGCGTA' => [2,1], 'CGCGTC' => [2,0], 'CGCGTG' => [2,1], 'CGCGTT' => [2,1], 'CGCTAC' => [2,0], 'CGCTAT' => [2,1], 'CGCTCA' => [2,1], 'CGCTCC' => [2,0], 'CGCTCG' => [2,1], 'CGCTCT' => [2,1], 'CGCTGC' => [1,0], 'CGCTGG' => [1,1], 'CGCTGT' => [1,1], 'CGCTTA' => [1,2], 'CGCTTC' => [2,0], 'CGCTTG' => [1,2], 'CGCTTT' => [2,1], 'CGGAAA' => [1,2], 'CGGAAC' => [2,1], 'CGGAAG' => [1,1], 'CGGAAT' => [2,1], 'CGGACA' => [1,2], 'CGGACC' => [1,2], 'CGGACG' => [1,1], 'CGGACT' => [1,2], 'CGGAGA' => [0,2], 'CGGAGC' => [1,1], 'CGGAGG' => [0,1], 'CGGAGT' => [1,1], 'CGGATA' => [1,2], 'CGGATC' => [2,1], 'CGGATG' => [1,1], 'CGGATT' => [2,1], 'CGGCAA' => [1,1], 'CGGCAC' => [1,1], 'CGGCAG' => [1,0], 'CGGCAT' => [1,1], 'CGGCCA' => [1,1], 'CGGCCC' => [1,1], 'CGGCCG' => [1,0], 'CGGCCT' => [1,1], 'CGGCGA' => [0,1], 'CGGCGC' => [0,1], 'CGGCGG' => [0,0], 'CGGCGT' => [0,1], 'CGGCTA' => [1,1], 'CGGCTC' => [1,1], 'CGGCTG' => [1,0], 'CGGCTT' => [1,1], 'CGGGAA' => [2,1], 'CGGGAC' => [2,1], 'CGGGAG' => [2,0], 'CGGGAT' => [2,1], 'CGGGCA' => [2,1], 'CGGGCC' => [2,1], 'CGGGCG' => [2,0], 'CGGGCT' => [2,1], 'CGGGGA' => [1,1], 'CGGGGC' => [1,1], 'CGGGGG' => [1,0], 'CGGGGT' => [1,1], 'CGGGTA' => [2,1], 'CGGGTC' => [2,1], 'CGGGTG' => [2,0], 'CGGGTT' => [2,1], 'CGGTAC' => [2,1], 'CGGTAT' => [2,1], 'CGGTCA' => [2,1], 'CGGTCC' => [2,1], 'CGGTCG' => [2,0], 'CGGTCT' => [2,1], 'CGGTGC' => [1,1], 'CGGTGG' => [1,0], 'CGGTGT' => [1,1], 'CGGTTA' => [1,2], 'CGGTTC' => [2,1], 'CGGTTG' => [1,1], 'CGGTTT' => [2,1], 'CGTAAA' => [1,2], 'CGTAAC' => [2,1], 'CGTAAG' => [1,2], 'CGTAAT' => [2,0], 'CGTACA' => [1,2], 'CGTACC' => [2,1], 'CGTACG' => [1,2], 'CGTACT' => [2,0], 'CGTAGA' => [0,2], 'CGTAGC' => [1,1], 'CGTAGG' => [0,2], 'CGTAGT' => [1,0], 'CGTATA' => [1,2], 'CGTATC' => [2,1], 'CGTATG' => [1,2], 'CGTATT' => [2,0], 'CGTCAA' => [1,1], 'CGTCAC' => [1,1], 'CGTCAG' => [1,1], 'CGTCAT' => [1,0], 'CGTCCA' => [1,1], 'CGTCCC' => [1,1], 'CGTCCG' => [1,1], 'CGTCCT' => [1,0], 'CGTCGA' => [0,1], 'CGTCGC' => [0,1], 'CGTCGG' => [0,1], 'CGTCGT' => [0,0], 'CGTCTA' => [1,1], 'CGTCTC' => [1,1], 'CGTCTG' => [1,1], 'CGTCTT' => [1,0], 'CGTGAA' => [2,1], 'CGTGAC' => [2,1], 'CGTGAG' => [2,1], 'CGTGAT' => [2,0], 'CGTGCA' => [2,1], 'CGTGCC' => [2,1], 'CGTGCG' => [2,1], 'CGTGCT' => [2,0], 'CGTGGA' => [1,1], 'CGTGGC' => [1,1], 'CGTGGG' => [1,1], 'CGTGGT' => [1,0], 'CGTGTA' => [2,1], 'CGTGTC' => [2,1], 'CGTGTG' => [2,1], 'CGTGTT' => [2,0], 'CGTTAC' => [2,1], 'CGTTAT' => [2,0], 'CGTTCA' => [2,1], 'CGTTCC' => [2,1], 'CGTTCG' => [2,1], 'CGTTCT' => [2,0], 'CGTTGC' => [1,1], 'CGTTGG' => [1,1], 'CGTTGT' => [1,0], 'CGTTTA' => [1,2], 'CGTTTC' => [2,1], 'CGTTTG' => [1,2], 'CGTTTT' => [2,0], 'CTAAAA' => [2,0], 'CTAAAC' => [2,1], 'CTAAAG' => [2,1], 'CTAAAT' => [2,1], 'CTAACA' => [2,0], 'CTAACC' => [2,1], 'CTAACG' => [2,1], 'CTAACT' => [2,1], 'CTAAGA' => [1,1], 'CTAAGC' => [2,1], 'CTAAGG' => [1,2], 'CTAAGT' => [2,1], 'CTAATA' => [1,0], 'CTAATC' => [1,1], 'CTAATG' => [1,1], 'CTAATT' => [1,1], 'CTACAA' => [1,0], 'CTACAC' => [1,1], 'CTACAG' => [1,1], 'CTACAT' => [1,1], 'CTACCA' => [1,0], 'CTACCC' => [1,1], 'CTACCG' => [1,1], 'CTACCT' => [1,1], 'CTACGA' => [1,0], 'CTACGC' => [1,1], 'CTACGG' => [1,1], 'CTACGT' => [1,1], 'CTACTA' => [0,0], 'CTACTC' => [0,1], 'CTACTG' => [0,1], 'CTACTT' => [0,1], 'CTAGAA' => [2,0], 'CTAGAC' => [2,1], 'CTAGAG' => [2,1], 'CTAGAT' => [2,1], 'CTAGCA' => [2,0], 'CTAGCC' => [2,1], 'CTAGCG' => [2,1], 'CTAGCT' => [2,1], 'CTAGGA' => [2,0], 'CTAGGC' => [2,1], 'CTAGGG' => [2,1], 'CTAGGT' => [2,1], 'CTAGTA' => [1,0], 'CTAGTC' => [1,1], 'CTAGTG' => [1,1], 'CTAGTT' => [1,1], 'CTATAC' => [2,1], 'CTATAT' => [2,1], 'CTATCA' => [1,1], 'CTATCC' => [1,2], 'CTATCG' => [1,2], 'CTATCT' => [1,2], 'CTATGC' => [2,1], 'CTATGG' => [1,2], 'CTATGT' => [2,1], 'CTATTA' => [0,1], 'CTATTC' => [1,1], 'CTATTG' => [0,2], 'CTATTT' => [1,1], 'CTCAAA' => [2,1], 'CTCAAC' => [2,0], 'CTCAAG' => [2,1], 'CTCAAT' => [2,1], 'CTCACA' => [2,1], 'CTCACC' => [2,0], 'CTCACG' => [2,1], 'CTCACT' => [2,1], 'CTCAGA' => [1,2], 'CTCAGC' => [2,0], 'CTCAGG' => [1,2], 'CTCAGT' => [2,1], 'CTCATA' => [1,1], 'CTCATC' => [1,0], 'CTCATG' => [1,1], 'CTCATT' => [1,1], 'CTCCAA' => [1,1], 'CTCCAC' => [1,0], 'CTCCAG' => [1,1], 'CTCCAT' => [1,1], 'CTCCCA' => [1,1], 'CTCCCC' => [1,0], 'CTCCCG' => [1,1], 'CTCCCT' => [1,1], 'CTCCGA' => [1,1], 'CTCCGC' => [1,0], 'CTCCGG' => [1,1], 'CTCCGT' => [1,1], 'CTCCTA' => [0,1], 'CTCCTC' => [0,0], 'CTCCTG' => [0,1], 'CTCCTT' => [0,1], 'CTCGAA' => [2,1], 'CTCGAC' => [2,0], 'CTCGAG' => [2,1], 'CTCGAT' => [2,1], 'CTCGCA' => [2,1], 'CTCGCC' => [2,0], 'CTCGCG' => [2,1], 'CTCGCT' => [2,1], 'CTCGGA' => [2,1], 'CTCGGC' => [2,0], 'CTCGGG' => [2,1], 'CTCGGT' => [2,1], 'CTCGTA' => [1,1], 'CTCGTC' => [1,0], 'CTCGTG' => [1,1], 'CTCGTT' => [1,1], 'CTCTAC' => [2,0], 'CTCTAT' => [2,1], 'CTCTCA' => [1,2], 'CTCTCC' => [2,0], 'CTCTCG' => [1,2], 'CTCTCT' => [2,1], 'CTCTGC' => [2,0], 'CTCTGG' => [1,2], 'CTCTGT' => [2,1], 'CTCTTA' => [0,2], 'CTCTTC' => [1,0], 'CTCTTG' => [0,2], 'CTCTTT' => [1,1], 'CTGAAA' => [2,1], 'CTGAAC' => [2,1], 'CTGAAG' => [2,0], 'CTGAAT' => [2,1], 'CTGACA' => [2,1], 'CTGACC' => [2,1], 'CTGACG' => [2,0], 'CTGACT' => [2,1], 'CTGAGA' => [1,2], 'CTGAGC' => [2,1], 'CTGAGG' => [1,1], 'CTGAGT' => [2,1], 'CTGATA' => [1,1], 'CTGATC' => [1,1], 'CTGATG' => [1,0], 'CTGATT' => [1,1], 'CTGCAA' => [1,1], 'CTGCAC' => [1,1], 'CTGCAG' => [1,0], 'CTGCAT' => [1,1], 'CTGCCA' => [1,1], 'CTGCCC' => [1,1], 'CTGCCG' => [1,0], 'CTGCCT' => [1,1], 'CTGCGA' => [1,1], 'CTGCGC' => [1,1], 'CTGCGG' => [1,0], 'CTGCGT' => [1,1], 'CTGCTA' => [0,1], 'CTGCTC' => [0,1], 'CTGCTG' => [0,0], 'CTGCTT' => [0,1], 'CTGGAA' => [2,1], 'CTGGAC' => [2,1], 'CTGGAG' => [2,0], 'CTGGAT' => [2,1], 'CTGGCA' => [2,1], 'CTGGCC' => [2,1], 'CTGGCG' => [2,0], 'CTGGCT' => [2,1], 'CTGGGA' => [2,1], 'CTGGGC' => [2,1], 'CTGGGG' => [2,0], 'CTGGGT' => [2,1], 'CTGGTA' => [1,1], 'CTGGTC' => [1,1], 'CTGGTG' => [1,0], 'CTGGTT' => [1,1], 'CTGTAC' => [2,1], 'CTGTAT' => [2,1], 'CTGTCA' => [1,2], 'CTGTCC' => [1,2], 'CTGTCG' => [1,1], 'CTGTCT' => [1,2], 'CTGTGC' => [2,1], 'CTGTGG' => [1,1], 'CTGTGT' => [2,1], 'CTGTTA' => [0,2], 'CTGTTC' => [1,1], 'CTGTTG' => [0,1], 'CTGTTT' => [1,1], 'CTTAAA' => [2,1], 'CTTAAC' => [2,1], 'CTTAAG' => [2,1], 'CTTAAT' => [2,0], 'CTTACA' => [2,1], 'CTTACC' => [2,1], 'CTTACG' => [2,1], 'CTTACT' => [2,0], 'CTTAGA' => [1,2], 'CTTAGC' => [2,1], 'CTTAGG' => [1,2], 'CTTAGT' => [2,0], 'CTTATA' => [1,1], 'CTTATC' => [1,1], 'CTTATG' => [1,1], 'CTTATT' => [1,0], 'CTTCAA' => [1,1], 'CTTCAC' => [1,1], 'CTTCAG' => [1,1], 'CTTCAT' => [1,0], 'CTTCCA' => [1,1], 'CTTCCC' => [1,1], 'CTTCCG' => [1,1], 'CTTCCT' => [1,0], 'CTTCGA' => [1,1], 'CTTCGC' => [1,1], 'CTTCGG' => [1,1], 'CTTCGT' => [1,0], 'CTTCTA' => [0,1], 'CTTCTC' => [0,1], 'CTTCTG' => [0,1], 'CTTCTT' => [0,0], 'CTTGAA' => [2,1], 'CTTGAC' => [2,1], 'CTTGAG' => [2,1], 'CTTGAT' => [2,0], 'CTTGCA' => [2,1], 'CTTGCC' => [2,1], 'CTTGCG' => [2,1], 'CTTGCT' => [2,0], 'CTTGGA' => [2,1], 'CTTGGC' => [2,1], 'CTTGGG' => [2,1], 'CTTGGT' => [2,0], 'CTTGTA' => [1,1], 'CTTGTC' => [1,1], 'CTTGTG' => [1,1], 'CTTGTT' => [1,0], 'CTTTAC' => [2,1], 'CTTTAT' => [2,0], 'CTTTCA' => [1,2], 'CTTTCC' => [2,1], 'CTTTCG' => [1,2], 'CTTTCT' => [2,0], 'CTTTGC' => [2,1], 'CTTTGG' => [1,2], 'CTTTGT' => [2,0], 'CTTTTA' => [0,2], 'CTTTTC' => [1,1], 'CTTTTG' => [0,2], 'CTTTTT' => [1,0], 'GAAAAA' => [1,0], 'GAAAAC' => [2,0], 'GAAAAG' => [1,1], 'GAAAAT' => [2,0], 'GAAACA' => [2,0], 'GAAACC' => [2,1], 'GAAACG' => [2,1], 'GAAACT' => [2,1], 'GAAAGA' => [2,0], 'GAAAGC' => [2,1], 'GAAAGG' => [2,1], 'GAAAGT' => [2,1], 'GAAATA' => [2,0], 'GAAATC' => [2,1], 'GAAATG' => [2,1], 'GAAATT' => [2,1], 'GAACAA' => [1,0], 'GAACAC' => [2,0], 'GAACAG' => [1,1], 'GAACAT' => [2,0], 'GAACCA' => [2,0], 'GAACCC' => [2,1], 'GAACCG' => [2,1], 'GAACCT' => [2,1], 'GAACGA' => [2,0], 'GAACGC' => [2,1], 'GAACGG' => [2,1], 'GAACGT' => [2,1], 'GAACTA' => [2,0], 'GAACTC' => [2,1], 'GAACTG' => [2,1], 'GAACTT' => [2,1], 'GAAGAA' => [0,0], 'GAAGAC' => [1,0], 'GAAGAG' => [0,1], 'GAAGAT' => [1,0], 'GAAGCA' => [1,0], 'GAAGCC' => [1,1], 'GAAGCG' => [1,1], 'GAAGCT' => [1,1], 'GAAGGA' => [1,0], 'GAAGGC' => [1,1], 'GAAGGG' => [1,1], 'GAAGGT' => [1,1], 'GAAGTA' => [1,0], 'GAAGTC' => [1,1], 'GAAGTG' => [1,1], 'GAAGTT' => [1,1], 'GAATAC' => [2,0], 'GAATAT' => [2,0], 'GAATCA' => [2,0], 'GAATCC' => [2,1], 'GAATCG' => [2,1], 'GAATCT' => [2,1], 'GAATGC' => [2,1], 'GAATGG' => [2,1], 'GAATGT' => [2,1], 'GAATTA' => [2,0], 'GAATTC' => [2,1], 'GAATTG' => [2,1], 'GAATTT' => [2,1], 'GACAAA' => [2,0], 'GACAAC' => [1,0], 'GACAAG' => [2,0], 'GACAAT' => [1,1], 'GACACA' => [2,1], 'GACACC' => [2,0], 'GACACG' => [2,1], 'GACACT' => [2,1], 'GACAGA' => [2,1], 'GACAGC' => [2,0], 'GACAGG' => [2,1], 'GACAGT' => [2,1], 'GACATA' => [2,1], 'GACATC' => [2,0], 'GACATG' => [2,1], 'GACATT' => [2,1], 'GACCAA' => [2,0], 'GACCAC' => [1,0], 'GACCAG' => [2,0], 'GACCAT' => [1,1], 'GACCCA' => [2,1], 'GACCCC' => [2,0], 'GACCCG' => [2,1], 'GACCCT' => [2,1], 'GACCGA' => [2,1], 'GACCGC' => [2,0], 'GACCGG' => [2,1], 'GACCGT' => [2,1], 'GACCTA' => [2,1], 'GACCTC' => [2,0], 'GACCTG' => [2,1], 'GACCTT' => [2,1], 'GACGAA' => [1,0], 'GACGAC' => [0,0], 'GACGAG' => [1,0], 'GACGAT' => [0,1], 'GACGCA' => [1,1], 'GACGCC' => [1,0], 'GACGCG' => [1,1], 'GACGCT' => [1,1], 'GACGGA' => [1,1], 'GACGGC' => [1,0], 'GACGGG' => [1,1], 'GACGGT' => [1,1], 'GACGTA' => [1,1], 'GACGTC' => [1,0], 'GACGTG' => [1,1], 'GACGTT' => [1,1], 'GACTAC' => [1,0], 'GACTAT' => [1,1], 'GACTCA' => [2,1], 'GACTCC' => [2,0], 'GACTCG' => [2,1], 'GACTCT' => [2,1], 'GACTGC' => [2,0], 'GACTGG' => [2,1], 'GACTGT' => [2,1], 'GACTTA' => [2,1], 'GACTTC' => [2,0], 'GACTTG' => [2,1], 'GACTTT' => [2,1], 'GAGAAA' => [1,1], 'GAGAAC' => [2,0], 'GAGAAG' => [1,0], 'GAGAAT' => [2,0], 'GAGACA' => [2,1], 'GAGACC' => [2,1], 'GAGACG' => [2,0], 'GAGACT' => [2,1], 'GAGAGA' => [2,1], 'GAGAGC' => [2,1], 'GAGAGG' => [2,0], 'GAGAGT' => [2,1], 'GAGATA' => [2,1], 'GAGATC' => [2,1], 'GAGATG' => [2,0], 'GAGATT' => [2,1], 'GAGCAA' => [1,1], 'GAGCAC' => [2,0], 'GAGCAG' => [1,0], 'GAGCAT' => [2,0], 'GAGCCA' => [2,1], 'GAGCCC' => [2,1], 'GAGCCG' => [2,0], 'GAGCCT' => [2,1], 'GAGCGA' => [2,1], 'GAGCGC' => [2,1], 'GAGCGG' => [2,0], 'GAGCGT' => [2,1], 'GAGCTA' => [2,1], 'GAGCTC' => [2,1], 'GAGCTG' => [2,0], 'GAGCTT' => [2,1], 'GAGGAA' => [0,1], 'GAGGAC' => [1,0], 'GAGGAG' => [0,0], 'GAGGAT' => [1,0], 'GAGGCA' => [1,1], 'GAGGCC' => [1,1], 'GAGGCG' => [1,0], 'GAGGCT' => [1,1], 'GAGGGA' => [1,1], 'GAGGGC' => [1,1], 'GAGGGG' => [1,0], 'GAGGGT' => [1,1], 'GAGGTA' => [1,1], 'GAGGTC' => [1,1], 'GAGGTG' => [1,0], 'GAGGTT' => [1,1], 'GAGTAC' => [2,0], 'GAGTAT' => [2,0], 'GAGTCA' => [2,1], 'GAGTCC' => [2,1], 'GAGTCG' => [2,0], 'GAGTCT' => [2,1], 'GAGTGC' => [2,1], 'GAGTGG' => [2,0], 'GAGTGT' => [2,1], 'GAGTTA' => [2,1], 'GAGTTC' => [2,1], 'GAGTTG' => [2,0], 'GAGTTT' => [2,1], 'GATAAA' => [2,0], 'GATAAC' => [1,1], 'GATAAG' => [2,0], 'GATAAT' => [1,0], 'GATACA' => [2,1], 'GATACC' => [2,1], 'GATACG' => [2,1], 'GATACT' => [2,0], 'GATAGA' => [2,1], 'GATAGC' => [2,1], 'GATAGG' => [2,1], 'GATAGT' => [2,0], 'GATATA' => [2,1], 'GATATC' => [2,1], 'GATATG' => [2,1], 'GATATT' => [2,0], 'GATCAA' => [2,0], 'GATCAC' => [1,1], 'GATCAG' => [2,0], 'GATCAT' => [1,0], 'GATCCA' => [2,1], 'GATCCC' => [2,1], 'GATCCG' => [2,1], 'GATCCT' => [2,0], 'GATCGA' => [2,1], 'GATCGC' => [2,1], 'GATCGG' => [2,1], 'GATCGT' => [2,0], 'GATCTA' => [2,1], 'GATCTC' => [2,1], 'GATCTG' => [2,1], 'GATCTT' => [2,0], 'GATGAA' => [1,0], 'GATGAC' => [0,1], 'GATGAG' => [1,0], 'GATGAT' => [0,0], 'GATGCA' => [1,1], 'GATGCC' => [1,1], 'GATGCG' => [1,1], 'GATGCT' => [1,0], 'GATGGA' => [1,1], 'GATGGC' => [1,1], 'GATGGG' => [1,1], 'GATGGT' => [1,0], 'GATGTA' => [1,1], 'GATGTC' => [1,1], 'GATGTG' => [1,1], 'GATGTT' => [1,0], 'GATTAC' => [1,1], 'GATTAT' => [1,0], 'GATTCA' => [2,1], 'GATTCC' => [2,1], 'GATTCG' => [2,1], 'GATTCT' => [2,0], 'GATTGC' => [2,1], 'GATTGG' => [2,1], 'GATTGT' => [2,0], 'GATTTA' => [2,1], 'GATTTC' => [2,1], 'GATTTG' => [2,1], 'GATTTT' => [2,0], 'GCAAAA' => [2,0], 'GCAAAC' => [2,1], 'GCAAAG' => [2,1], 'GCAAAT' => [2,1], 'GCAACA' => [1,0], 'GCAACC' => [1,1], 'GCAACG' => [1,1], 'GCAACT' => [1,1], 'GCAAGA' => [2,0], 'GCAAGC' => [2,1], 'GCAAGG' => [2,1], 'GCAAGT' => [2,1], 'GCAATA' => [2,0], 'GCAATC' => [2,1], 'GCAATG' => [2,1], 'GCAATT' => [2,1], 'GCACAA' => [2,0], 'GCACAC' => [2,1], 'GCACAG' => [2,1], 'GCACAT' => [2,1], 'GCACCA' => [1,0], 'GCACCC' => [1,1], 'GCACCG' => [1,1], 'GCACCT' => [1,1], 'GCACGA' => [2,0], 'GCACGC' => [2,1], 'GCACGG' => [2,1], 'GCACGT' => [2,1], 'GCACTA' => [2,0], 'GCACTC' => [2,1], 'GCACTG' => [2,1], 'GCACTT' => [2,1], 'GCAGAA' => [1,0], 'GCAGAC' => [1,1], 'GCAGAG' => [1,1], 'GCAGAT' => [1,1], 'GCAGCA' => [0,0], 'GCAGCC' => [0,1], 'GCAGCG' => [0,1], 'GCAGCT' => [0,1], 'GCAGGA' => [1,0], 'GCAGGC' => [1,1], 'GCAGGG' => [1,1], 'GCAGGT' => [1,1], 'GCAGTA' => [1,0], 'GCAGTC' => [1,1], 'GCAGTG' => [1,1], 'GCAGTT' => [1,1], 'GCATAC' => [2,1], 'GCATAT' => [2,1], 'GCATCA' => [1,0], 'GCATCC' => [1,1], 'GCATCG' => [1,1], 'GCATCT' => [1,1], 'GCATGC' => [2,1], 'GCATGG' => [2,1], 'GCATGT' => [2,1], 'GCATTA' => [2,0], 'GCATTC' => [2,1], 'GCATTG' => [2,1], 'GCATTT' => [2,1], 'GCCAAA' => [2,1], 'GCCAAC' => [2,0], 'GCCAAG' => [2,1], 'GCCAAT' => [2,1], 'GCCACA' => [1,1], 'GCCACC' => [1,0], 'GCCACG' => [1,1], 'GCCACT' => [1,1], 'GCCAGA' => [2,1], 'GCCAGC' => [2,0], 'GCCAGG' => [2,1], 'GCCAGT' => [2,1], 'GCCATA' => [2,1], 'GCCATC' => [2,0], 'GCCATG' => [2,1], 'GCCATT' => [2,1], 'GCCCAA' => [2,1], 'GCCCAC' => [2,0], 'GCCCAG' => [2,1], 'GCCCAT' => [2,1], 'GCCCCA' => [1,1], 'GCCCCC' => [1,0], 'GCCCCG' => [1,1], 'GCCCCT' => [1,1], 'GCCCGA' => [2,1], 'GCCCGC' => [2,0], 'GCCCGG' => [2,1], 'GCCCGT' => [2,1], 'GCCCTA' => [2,1], 'GCCCTC' => [2,0], 'GCCCTG' => [2,1], 'GCCCTT' => [2,1], 'GCCGAA' => [1,1], 'GCCGAC' => [1,0], 'GCCGAG' => [1,1], 'GCCGAT' => [1,1], 'GCCGCA' => [0,1], 'GCCGCC' => [0,0], 'GCCGCG' => [0,1], 'GCCGCT' => [0,1], 'GCCGGA' => [1,1], 'GCCGGC' => [1,0], 'GCCGGG' => [1,1], 'GCCGGT' => [1,1], 'GCCGTA' => [1,1], 'GCCGTC' => [1,0], 'GCCGTG' => [1,1], 'GCCGTT' => [1,1], 'GCCTAC' => [2,0], 'GCCTAT' => [2,1], 'GCCTCA' => [1,1], 'GCCTCC' => [1,0], 'GCCTCG' => [1,1], 'GCCTCT' => [1,1], 'GCCTGC' => [2,0], 'GCCTGG' => [2,1], 'GCCTGT' => [2,1], 'GCCTTA' => [2,1], 'GCCTTC' => [2,0], 'GCCTTG' => [2,1], 'GCCTTT' => [2,1], 'GCGAAA' => [2,1], 'GCGAAC' => [2,1], 'GCGAAG' => [2,0], 'GCGAAT' => [2,1], 'GCGACA' => [1,1], 'GCGACC' => [1,1], 'GCGACG' => [1,0], 'GCGACT' => [1,1], 'GCGAGA' => [2,1], 'GCGAGC' => [2,1], 'GCGAGG' => [2,0], 'GCGAGT' => [2,1], 'GCGATA' => [2,1], 'GCGATC' => [2,1], 'GCGATG' => [2,0], 'GCGATT' => [2,1], 'GCGCAA' => [2,1], 'GCGCAC' => [2,1], 'GCGCAG' => [2,0], 'GCGCAT' => [2,1], 'GCGCCA' => [1,1], 'GCGCCC' => [1,1], 'GCGCCG' => [1,0], 'GCGCCT' => [1,1], 'GCGCGA' => [2,1], 'GCGCGC' => [2,1], 'GCGCGG' => [2,0], 'GCGCGT' => [2,1], 'GCGCTA' => [2,1], 'GCGCTC' => [2,1], 'GCGCTG' => [2,0], 'GCGCTT' => [2,1], 'GCGGAA' => [1,1], 'GCGGAC' => [1,1], 'GCGGAG' => [1,0], 'GCGGAT' => [1,1], 'GCGGCA' => [0,1], 'GCGGCC' => [0,1], 'GCGGCG' => [0,0], 'GCGGCT' => [0,1], 'GCGGGA' => [1,1], 'GCGGGC' => [1,1], 'GCGGGG' => [1,0], 'GCGGGT' => [1,1], 'GCGGTA' => [1,1], 'GCGGTC' => [1,1], 'GCGGTG' => [1,0], 'GCGGTT' => [1,1], 'GCGTAC' => [2,1], 'GCGTAT' => [2,1], 'GCGTCA' => [1,1], 'GCGTCC' => [1,1], 'GCGTCG' => [1,0], 'GCGTCT' => [1,1], 'GCGTGC' => [2,1], 'GCGTGG' => [2,0], 'GCGTGT' => [2,1], 'GCGTTA' => [2,1], 'GCGTTC' => [2,1], 'GCGTTG' => [2,0], 'GCGTTT' => [2,1], 'GCTAAA' => [2,1], 'GCTAAC' => [2,1], 'GCTAAG' => [2,1], 'GCTAAT' => [2,0], 'GCTACA' => [1,1], 'GCTACC' => [1,1], 'GCTACG' => [1,1], 'GCTACT' => [1,0], 'GCTAGA' => [2,1], 'GCTAGC' => [2,1], 'GCTAGG' => [2,1], 'GCTAGT' => [2,0], 'GCTATA' => [2,1], 'GCTATC' => [2,1], 'GCTATG' => [2,1], 'GCTATT' => [2,0], 'GCTCAA' => [2,1], 'GCTCAC' => [2,1], 'GCTCAG' => [2,1], 'GCTCAT' => [2,0], 'GCTCCA' => [1,1], 'GCTCCC' => [1,1], 'GCTCCG' => [1,1], 'GCTCCT' => [1,0], 'GCTCGA' => [2,1], 'GCTCGC' => [2,1], 'GCTCGG' => [2,1], 'GCTCGT' => [2,0], 'GCTCTA' => [2,1], 'GCTCTC' => [2,1], 'GCTCTG' => [2,1], 'GCTCTT' => [2,0], 'GCTGAA' => [1,1], 'GCTGAC' => [1,1], 'GCTGAG' => [1,1], 'GCTGAT' => [1,0], 'GCTGCA' => [0,1], 'GCTGCC' => [0,1], 'GCTGCG' => [0,1], 'GCTGCT' => [0,0], 'GCTGGA' => [1,1], 'GCTGGC' => [1,1], 'GCTGGG' => [1,1], 'GCTGGT' => [1,0], 'GCTGTA' => [1,1], 'GCTGTC' => [1,1], 'GCTGTG' => [1,1], 'GCTGTT' => [1,0], 'GCTTAC' => [2,1], 'GCTTAT' => [2,0], 'GCTTCA' => [1,1], 'GCTTCC' => [1,1], 'GCTTCG' => [1,1], 'GCTTCT' => [1,0], 'GCTTGC' => [2,1], 'GCTTGG' => [2,1], 'GCTTGT' => [2,0], 'GCTTTA' => [2,1], 'GCTTTC' => [2,1], 'GCTTTG' => [2,1], 'GCTTTT' => [2,0], 'GGAAAA' => [2,0], 'GGAAAC' => [2,1], 'GGAAAG' => [2,1], 'GGAAAT' => [2,1], 'GGAACA' => [2,0], 'GGAACC' => [2,1], 'GGAACG' => [2,1], 'GGAACT' => [2,1], 'GGAAGA' => [1,0], 'GGAAGC' => [1,1], 'GGAAGG' => [1,1], 'GGAAGT' => [1,1], 'GGAATA' => [2,0], 'GGAATC' => [2,1], 'GGAATG' => [2,1], 'GGAATT' => [2,1], 'GGACAA' => [2,0], 'GGACAC' => [2,1], 'GGACAG' => [2,1], 'GGACAT' => [2,1], 'GGACCA' => [2,0], 'GGACCC' => [2,1], 'GGACCG' => [2,1], 'GGACCT' => [2,1], 'GGACGA' => [1,0], 'GGACGC' => [1,1], 'GGACGG' => [1,1], 'GGACGT' => [1,1], 'GGACTA' => [2,0], 'GGACTC' => [2,1], 'GGACTG' => [2,1], 'GGACTT' => [2,1], 'GGAGAA' => [1,0], 'GGAGAC' => [1,1], 'GGAGAG' => [1,1], 'GGAGAT' => [1,1], 'GGAGCA' => [1,0], 'GGAGCC' => [1,1], 'GGAGCG' => [1,1], 'GGAGCT' => [1,1], 'GGAGGA' => [0,0], 'GGAGGC' => [0,1], 'GGAGGG' => [0,1], 'GGAGGT' => [0,1], 'GGAGTA' => [1,0], 'GGAGTC' => [1,1], 'GGAGTG' => [1,1], 'GGAGTT' => [1,1], 'GGATAC' => [2,1], 'GGATAT' => [2,1], 'GGATCA' => [2,0], 'GGATCC' => [2,1], 'GGATCG' => [2,1], 'GGATCT' => [2,1], 'GGATGC' => [1,1], 'GGATGG' => [1,1], 'GGATGT' => [1,1], 'GGATTA' => [2,0], 'GGATTC' => [2,1], 'GGATTG' => [2,1], 'GGATTT' => [2,1], 'GGCAAA' => [2,1], 'GGCAAC' => [2,0], 'GGCAAG' => [2,1], 'GGCAAT' => [2,1], 'GGCACA' => [2,1], 'GGCACC' => [2,0], 'GGCACG' => [2,1], 'GGCACT' => [2,1], 'GGCAGA' => [1,1], 'GGCAGC' => [1,0], 'GGCAGG' => [1,1], 'GGCAGT' => [1,1], 'GGCATA' => [2,1], 'GGCATC' => [2,0], 'GGCATG' => [2,1], 'GGCATT' => [2,1], 'GGCCAA' => [2,1], 'GGCCAC' => [2,0], 'GGCCAG' => [2,1], 'GGCCAT' => [2,1], 'GGCCCA' => [2,1], 'GGCCCC' => [2,0], 'GGCCCG' => [2,1], 'GGCCCT' => [2,1], 'GGCCGA' => [1,1], 'GGCCGC' => [1,0], 'GGCCGG' => [1,1], 'GGCCGT' => [1,1], 'GGCCTA' => [2,1], 'GGCCTC' => [2,0], 'GGCCTG' => [2,1], 'GGCCTT' => [2,1], 'GGCGAA' => [1,1], 'GGCGAC' => [1,0], 'GGCGAG' => [1,1], 'GGCGAT' => [1,1], 'GGCGCA' => [1,1], 'GGCGCC' => [1,0], 'GGCGCG' => [1,1], 'GGCGCT' => [1,1], 'GGCGGA' => [0,1], 'GGCGGC' => [0,0], 'GGCGGG' => [0,1], 'GGCGGT' => [0,1], 'GGCGTA' => [1,1], 'GGCGTC' => [1,0], 'GGCGTG' => [1,1], 'GGCGTT' => [1,1], 'GGCTAC' => [2,0], 'GGCTAT' => [2,1], 'GGCTCA' => [2,1], 'GGCTCC' => [2,0], 'GGCTCG' => [2,1], 'GGCTCT' => [2,1], 'GGCTGC' => [1,0], 'GGCTGG' => [1,1], 'GGCTGT' => [1,1], 'GGCTTA' => [2,1], 'GGCTTC' => [2,0], 'GGCTTG' => [2,1], 'GGCTTT' => [2,1], 'GGGAAA' => [2,1], 'GGGAAC' => [2,1], 'GGGAAG' => [2,0], 'GGGAAT' => [2,1], 'GGGACA' => [2,1], 'GGGACC' => [2,1], 'GGGACG' => [2,0], 'GGGACT' => [2,1], 'GGGAGA' => [1,1], 'GGGAGC' => [1,1], 'GGGAGG' => [1,0], 'GGGAGT' => [1,1], 'GGGATA' => [2,1], 'GGGATC' => [2,1], 'GGGATG' => [2,0], 'GGGATT' => [2,1], 'GGGCAA' => [2,1], 'GGGCAC' => [2,1], 'GGGCAG' => [2,0], 'GGGCAT' => [2,1], 'GGGCCA' => [2,1], 'GGGCCC' => [2,1], 'GGGCCG' => [2,0], 'GGGCCT' => [2,1], 'GGGCGA' => [1,1], 'GGGCGC' => [1,1], 'GGGCGG' => [1,0], 'GGGCGT' => [1,1], 'GGGCTA' => [2,1], 'GGGCTC' => [2,1], 'GGGCTG' => [2,0], 'GGGCTT' => [2,1], 'GGGGAA' => [1,1], 'GGGGAC' => [1,1], 'GGGGAG' => [1,0], 'GGGGAT' => [1,1], 'GGGGCA' => [1,1], 'GGGGCC' => [1,1], 'GGGGCG' => [1,0], 'GGGGCT' => [1,1], 'GGGGGA' => [0,1], 'GGGGGC' => [0,1], 'GGGGGG' => [0,0], 'GGGGGT' => [0,1], 'GGGGTA' => [1,1], 'GGGGTC' => [1,1], 'GGGGTG' => [1,0], 'GGGGTT' => [1,1], 'GGGTAC' => [2,1], 'GGGTAT' => [2,1], 'GGGTCA' => [2,1], 'GGGTCC' => [2,1], 'GGGTCG' => [2,0], 'GGGTCT' => [2,1], 'GGGTGC' => [1,1], 'GGGTGG' => [1,0], 'GGGTGT' => [1,1], 'GGGTTA' => [2,1], 'GGGTTC' => [2,1], 'GGGTTG' => [2,0], 'GGGTTT' => [2,1], 'GGTAAA' => [2,1], 'GGTAAC' => [2,1], 'GGTAAG' => [2,1], 'GGTAAT' => [2,0], 'GGTACA' => [2,1], 'GGTACC' => [2,1], 'GGTACG' => [2,1], 'GGTACT' => [2,0], 'GGTAGA' => [1,1], 'GGTAGC' => [1,1], 'GGTAGG' => [1,1], 'GGTAGT' => [1,0], 'GGTATA' => [2,1], 'GGTATC' => [2,1], 'GGTATG' => [2,1], 'GGTATT' => [2,0], 'GGTCAA' => [2,1], 'GGTCAC' => [2,1], 'GGTCAG' => [2,1], 'GGTCAT' => [2,0], 'GGTCCA' => [2,1], 'GGTCCC' => [2,1], 'GGTCCG' => [2,1], 'GGTCCT' => [2,0], 'GGTCGA' => [1,1], 'GGTCGC' => [1,1], 'GGTCGG' => [1,1], 'GGTCGT' => [1,0], 'GGTCTA' => [2,1], 'GGTCTC' => [2,1], 'GGTCTG' => [2,1], 'GGTCTT' => [2,0], 'GGTGAA' => [1,1], 'GGTGAC' => [1,1], 'GGTGAG' => [1,1], 'GGTGAT' => [1,0], 'GGTGCA' => [1,1], 'GGTGCC' => [1,1], 'GGTGCG' => [1,1], 'GGTGCT' => [1,0], 'GGTGGA' => [0,1], 'GGTGGC' => [0,1], 'GGTGGG' => [0,1], 'GGTGGT' => [0,0], 'GGTGTA' => [1,1], 'GGTGTC' => [1,1], 'GGTGTG' => [1,1], 'GGTGTT' => [1,0], 'GGTTAC' => [2,1], 'GGTTAT' => [2,0], 'GGTTCA' => [2,1], 'GGTTCC' => [2,1], 'GGTTCG' => [2,1], 'GGTTCT' => [2,0], 'GGTTGC' => [1,1], 'GGTTGG' => [1,1], 'GGTTGT' => [1,0], 'GGTTTA' => [2,1], 'GGTTTC' => [2,1], 'GGTTTG' => [2,1], 'GGTTTT' => [2,0], 'GTAAAA' => [2,0], 'GTAAAC' => [2,1], 'GTAAAG' => [2,1], 'GTAAAT' => [2,1], 'GTAACA' => [2,0], 'GTAACC' => [2,1], 'GTAACG' => [2,1], 'GTAACT' => [2,1], 'GTAAGA' => [2,0], 'GTAAGC' => [2,1], 'GTAAGG' => [2,1], 'GTAAGT' => [2,1], 'GTAATA' => [1,0], 'GTAATC' => [1,1], 'GTAATG' => [1,1], 'GTAATT' => [1,1], 'GTACAA' => [2,0], 'GTACAC' => [2,1], 'GTACAG' => [2,1], 'GTACAT' => [2,1], 'GTACCA' => [2,0], 'GTACCC' => [2,1], 'GTACCG' => [2,1], 'GTACCT' => [2,1], 'GTACGA' => [2,0], 'GTACGC' => [2,1], 'GTACGG' => [2,1], 'GTACGT' => [2,1], 'GTACTA' => [1,0], 'GTACTC' => [1,1], 'GTACTG' => [1,1], 'GTACTT' => [1,1], 'GTAGAA' => [1,0], 'GTAGAC' => [1,1], 'GTAGAG' => [1,1], 'GTAGAT' => [1,1], 'GTAGCA' => [1,0], 'GTAGCC' => [1,1], 'GTAGCG' => [1,1], 'GTAGCT' => [1,1], 'GTAGGA' => [1,0], 'GTAGGC' => [1,1], 'GTAGGG' => [1,1], 'GTAGGT' => [1,1], 'GTAGTA' => [0,0], 'GTAGTC' => [0,1], 'GTAGTG' => [0,1], 'GTAGTT' => [0,1], 'GTATAC' => [2,1], 'GTATAT' => [2,1], 'GTATCA' => [2,0], 'GTATCC' => [2,1], 'GTATCG' => [2,1], 'GTATCT' => [2,1], 'GTATGC' => [2,1], 'GTATGG' => [2,1], 'GTATGT' => [2,1], 'GTATTA' => [1,0], 'GTATTC' => [1,1], 'GTATTG' => [1,1], 'GTATTT' => [1,1], 'GTCAAA' => [2,1], 'GTCAAC' => [2,0], 'GTCAAG' => [2,1], 'GTCAAT' => [2,1], 'GTCACA' => [2,1], 'GTCACC' => [2,0], 'GTCACG' => [2,1], 'GTCACT' => [2,1], 'GTCAGA' => [2,1], 'GTCAGC' => [2,0], 'GTCAGG' => [2,1], 'GTCAGT' => [2,1], 'GTCATA' => [1,1], 'GTCATC' => [1,0], 'GTCATG' => [1,1], 'GTCATT' => [1,1], 'GTCCAA' => [2,1], 'GTCCAC' => [2,0], 'GTCCAG' => [2,1], 'GTCCAT' => [2,1], 'GTCCCA' => [2,1], 'GTCCCC' => [2,0], 'GTCCCG' => [2,1], 'GTCCCT' => [2,1], 'GTCCGA' => [2,1], 'GTCCGC' => [2,0], 'GTCCGG' => [2,1], 'GTCCGT' => [2,1], 'GTCCTA' => [1,1], 'GTCCTC' => [1,0], 'GTCCTG' => [1,1], 'GTCCTT' => [1,1], 'GTCGAA' => [1,1], 'GTCGAC' => [1,0], 'GTCGAG' => [1,1], 'GTCGAT' => [1,1], 'GTCGCA' => [1,1], 'GTCGCC' => [1,0], 'GTCGCG' => [1,1], 'GTCGCT' => [1,1], 'GTCGGA' => [1,1], 'GTCGGC' => [1,0], 'GTCGGG' => [1,1], 'GTCGGT' => [1,1], 'GTCGTA' => [0,1], 'GTCGTC' => [0,0], 'GTCGTG' => [0,1], 'GTCGTT' => [0,1], 'GTCTAC' => [2,0], 'GTCTAT' => [2,1], 'GTCTCA' => [2,1], 'GTCTCC' => [2,0], 'GTCTCG' => [2,1], 'GTCTCT' => [2,1], 'GTCTGC' => [2,0], 'GTCTGG' => [2,1], 'GTCTGT' => [2,1], 'GTCTTA' => [1,1], 'GTCTTC' => [1,0], 'GTCTTG' => [1,1], 'GTCTTT' => [1,1], 'GTGAAA' => [2,1], 'GTGAAC' => [2,1], 'GTGAAG' => [2,0], 'GTGAAT' => [2,1], 'GTGACA' => [2,1], 'GTGACC' => [2,1], 'GTGACG' => [2,0], 'GTGACT' => [2,1], 'GTGAGA' => [2,1], 'GTGAGC' => [2,1], 'GTGAGG' => [2,0], 'GTGAGT' => [2,1], 'GTGATA' => [1,1], 'GTGATC' => [1,1], 'GTGATG' => [1,0], 'GTGATT' => [1,1], 'GTGCAA' => [2,1], 'GTGCAC' => [2,1], 'GTGCAG' => [2,0], 'GTGCAT' => [2,1], 'GTGCCA' => [2,1], 'GTGCCC' => [2,1], 'GTGCCG' => [2,0], 'GTGCCT' => [2,1], 'GTGCGA' => [2,1], 'GTGCGC' => [2,1], 'GTGCGG' => [2,0], 'GTGCGT' => [2,1], 'GTGCTA' => [1,1], 'GTGCTC' => [1,1], 'GTGCTG' => [1,0], 'GTGCTT' => [1,1], 'GTGGAA' => [1,1], 'GTGGAC' => [1,1], 'GTGGAG' => [1,0], 'GTGGAT' => [1,1], 'GTGGCA' => [1,1], 'GTGGCC' => [1,1], 'GTGGCG' => [1,0], 'GTGGCT' => [1,1], 'GTGGGA' => [1,1], 'GTGGGC' => [1,1], 'GTGGGG' => [1,0], 'GTGGGT' => [1,1], 'GTGGTA' => [0,1], 'GTGGTC' => [0,1], 'GTGGTG' => [0,0], 'GTGGTT' => [0,1], 'GTGTAC' => [2,1], 'GTGTAT' => [2,1], 'GTGTCA' => [2,1], 'GTGTCC' => [2,1], 'GTGTCG' => [2,0], 'GTGTCT' => [2,1], 'GTGTGC' => [2,1], 'GTGTGG' => [2,0], 'GTGTGT' => [2,1], 'GTGTTA' => [1,1], 'GTGTTC' => [1,1], 'GTGTTG' => [1,0], 'GTGTTT' => [1,1], 'GTTAAA' => [2,1], 'GTTAAC' => [2,1], 'GTTAAG' => [2,1], 'GTTAAT' => [2,0], 'GTTACA' => [2,1], 'GTTACC' => [2,1], 'GTTACG' => [2,1], 'GTTACT' => [2,0], 'GTTAGA' => [2,1], 'GTTAGC' => [2,1], 'GTTAGG' => [2,1], 'GTTAGT' => [2,0], 'GTTATA' => [1,1], 'GTTATC' => [1,1], 'GTTATG' => [1,1], 'GTTATT' => [1,0], 'GTTCAA' => [2,1], 'GTTCAC' => [2,1], 'GTTCAG' => [2,1], 'GTTCAT' => [2,0], 'GTTCCA' => [2,1], 'GTTCCC' => [2,1], 'GTTCCG' => [2,1], 'GTTCCT' => [2,0], 'GTTCGA' => [2,1], 'GTTCGC' => [2,1], 'GTTCGG' => [2,1], 'GTTCGT' => [2,0], 'GTTCTA' => [1,1], 'GTTCTC' => [1,1], 'GTTCTG' => [1,1], 'GTTCTT' => [1,0], 'GTTGAA' => [1,1], 'GTTGAC' => [1,1], 'GTTGAG' => [1,1], 'GTTGAT' => [1,0], 'GTTGCA' => [1,1], 'GTTGCC' => [1,1], 'GTTGCG' => [1,1], 'GTTGCT' => [1,0], 'GTTGGA' => [1,1], 'GTTGGC' => [1,1], 'GTTGGG' => [1,1], 'GTTGGT' => [1,0], 'GTTGTA' => [0,1], 'GTTGTC' => [0,1], 'GTTGTG' => [0,1], 'GTTGTT' => [0,0], 'GTTTAC' => [2,1], 'GTTTAT' => [2,0], 'GTTTCA' => [2,1], 'GTTTCC' => [2,1], 'GTTTCG' => [2,1], 'GTTTCT' => [2,0], 'GTTTGC' => [2,1], 'GTTTGG' => [2,1], 'GTTTGT' => [2,0], 'GTTTTA' => [1,1], 'GTTTTC' => [1,1], 'GTTTTG' => [1,1], 'GTTTTT' => [1,0], 'TACAAA' => [2,0], 'TACAAC' => [1,0], 'TACAAG' => [2,0], 'TACAAT' => [1,1], 'TACACA' => [2,1], 'TACACC' => [2,0], 'TACACG' => [2,1], 'TACACT' => [2,1], 'TACAGA' => [3,0], 'TACAGC' => [2,0], 'TACAGG' => [3,0], 'TACAGT' => [2,1], 'TACATA' => [2,1], 'TACATC' => [2,0], 'TACATG' => [3,0], 'TACATT' => [2,1], 'TACCAA' => [2,0], 'TACCAC' => [1,0], 'TACCAG' => [2,0], 'TACCAT' => [1,1], 'TACCCA' => [2,1], 'TACCCC' => [2,0], 'TACCCG' => [2,1], 'TACCCT' => [2,1], 'TACCGA' => [2,1], 'TACCGC' => [2,0], 'TACCGG' => [2,1], 'TACCGT' => [2,1], 'TACCTA' => [2,1], 'TACCTC' => [2,0], 'TACCTG' => [2,1], 'TACCTT' => [2,1], 'TACGAA' => [2,0], 'TACGAC' => [1,0], 'TACGAG' => [2,0], 'TACGAT' => [1,1], 'TACGCA' => [2,1], 'TACGCC' => [2,0], 'TACGCG' => [2,1], 'TACGCT' => [2,1], 'TACGGA' => [2,1], 'TACGGC' => [2,0], 'TACGGG' => [2,1], 'TACGGT' => [2,1], 'TACGTA' => [2,1], 'TACGTC' => [2,0], 'TACGTG' => [2,1], 'TACGTT' => [2,1], 'TACTAC' => [0,0], 'TACTAT' => [0,1], 'TACTCA' => [1,1], 'TACTCC' => [1,0], 'TACTCG' => [1,1], 'TACTCT' => [1,1], 'TACTGC' => [1,0], 'TACTGG' => [2,0], 'TACTGT' => [1,1], 'TACTTA' => [2,0], 'TACTTC' => [1,0], 'TACTTG' => [2,0], 'TACTTT' => [1,1], 'TATAAA' => [2,0], 'TATAAC' => [1,1], 'TATAAG' => [2,0], 'TATAAT' => [1,0], 'TATACA' => [2,1], 'TATACC' => [2,1], 'TATACG' => [2,1], 'TATACT' => [2,0], 'TATAGA' => [3,0], 'TATAGC' => [2,1], 'TATAGG' => [3,0], 'TATAGT' => [2,0], 'TATATA' => [2,1], 'TATATC' => [2,1], 'TATATG' => [3,0], 'TATATT' => [2,0], 'TATCAA' => [2,0], 'TATCAC' => [1,1], 'TATCAG' => [2,0], 'TATCAT' => [1,0], 'TATCCA' => [2,1], 'TATCCC' => [2,1], 'TATCCG' => [2,1], 'TATCCT' => [2,0], 'TATCGA' => [2,1], 'TATCGC' => [2,1], 'TATCGG' => [2,1], 'TATCGT' => [2,0], 'TATCTA' => [2,1], 'TATCTC' => [2,1], 'TATCTG' => [2,1], 'TATCTT' => [2,0], 'TATGAA' => [2,0], 'TATGAC' => [1,1], 'TATGAG' => [2,0], 'TATGAT' => [1,0], 'TATGCA' => [2,1], 'TATGCC' => [2,1], 'TATGCG' => [2,1], 'TATGCT' => [2,0], 'TATGGA' => [2,1], 'TATGGC' => [2,1], 'TATGGG' => [2,1], 'TATGGT' => [2,0], 'TATGTA' => [2,1], 'TATGTC' => [2,1], 'TATGTG' => [2,1], 'TATGTT' => [2,0], 'TATTAC' => [0,1], 'TATTAT' => [0,0], 'TATTCA' => [1,1], 'TATTCC' => [1,1], 'TATTCG' => [1,1], 'TATTCT' => [1,0], 'TATTGC' => [1,1], 'TATTGG' => [2,0], 'TATTGT' => [1,0], 'TATTTA' => [2,0], 'TATTTC' => [1,1], 'TATTTG' => [2,0], 'TATTTT' => [1,0], 'TCAAAA' => [2,0], 'TCAAAC' => [2,1], 'TCAAAG' => [2,1], 'TCAAAT' => [2,1], 'TCAACA' => [1,0], 'TCAACC' => [1,1], 'TCAACG' => [1,1], 'TCAACT' => [1,1], 'TCAAGA' => [2,0], 'TCAAGC' => [2,1], 'TCAAGG' => [2,1], 'TCAAGT' => [2,1], 'TCAATA' => [2,0], 'TCAATC' => [2,1], 'TCAATG' => [2,1], 'TCAATT' => [2,1], 'TCACAA' => [2,0], 'TCACAC' => [2,1], 'TCACAG' => [2,1], 'TCACAT' => [2,1], 'TCACCA' => [1,0], 'TCACCC' => [1,1], 'TCACCG' => [1,1], 'TCACCT' => [1,1], 'TCACGA' => [2,0], 'TCACGC' => [2,1], 'TCACGG' => [2,1], 'TCACGT' => [2,1], 'TCACTA' => [1,1], 'TCACTC' => [1,2], 'TCACTG' => [1,2], 'TCACTT' => [1,2], 'TCAGAA' => [2,0], 'TCAGAC' => [2,1], 'TCAGAG' => [2,1], 'TCAGAT' => [2,1], 'TCAGCA' => [1,0], 'TCAGCC' => [1,1], 'TCAGCG' => [1,1], 'TCAGCT' => [1,1], 'TCAGGA' => [2,0], 'TCAGGC' => [2,1], 'TCAGGG' => [2,1], 'TCAGGT' => [2,1], 'TCAGTA' => [2,0], 'TCAGTC' => [2,1], 'TCAGTG' => [2,1], 'TCAGTT' => [2,1], 'TCATAC' => [1,1], 'TCATAT' => [1,1], 'TCATCA' => [0,0], 'TCATCC' => [0,1], 'TCATCG' => [0,1], 'TCATCT' => [0,1], 'TCATGC' => [1,1], 'TCATGG' => [1,1], 'TCATGT' => [1,1], 'TCATTA' => [1,0], 'TCATTC' => [1,1], 'TCATTG' => [1,1], 'TCATTT' => [1,1], 'TCCAAA' => [2,1], 'TCCAAC' => [2,0], 'TCCAAG' => [2,1], 'TCCAAT' => [2,1], 'TCCACA' => [1,1], 'TCCACC' => [1,0], 'TCCACG' => [1,1], 'TCCACT' => [1,1], 'TCCAGA' => [2,1], 'TCCAGC' => [2,0], 'TCCAGG' => [2,1], 'TCCAGT' => [2,1], 'TCCATA' => [2,1], 'TCCATC' => [2,0], 'TCCATG' => [2,1], 'TCCATT' => [2,1], 'TCCCAA' => [2,1], 'TCCCAC' => [2,0], 'TCCCAG' => [2,1], 'TCCCAT' => [2,1], 'TCCCCA' => [1,1], 'TCCCCC' => [1,0], 'TCCCCG' => [1,1], 'TCCCCT' => [1,1], 'TCCCGA' => [2,1], 'TCCCGC' => [2,0], 'TCCCGG' => [2,1], 'TCCCGT' => [2,1], 'TCCCTA' => [1,2], 'TCCCTC' => [2,0], 'TCCCTG' => [1,2], 'TCCCTT' => [2,1], 'TCCGAA' => [2,1], 'TCCGAC' => [2,0], 'TCCGAG' => [2,1], 'TCCGAT' => [2,1], 'TCCGCA' => [1,1], 'TCCGCC' => [1,0], 'TCCGCG' => [1,1], 'TCCGCT' => [1,1], 'TCCGGA' => [2,1], 'TCCGGC' => [2,0], 'TCCGGG' => [2,1], 'TCCGGT' => [2,1], 'TCCGTA' => [2,1], 'TCCGTC' => [2,0], 'TCCGTG' => [2,1], 'TCCGTT' => [2,1], 'TCCTAC' => [1,0], 'TCCTAT' => [1,1], 'TCCTCA' => [0,1], 'TCCTCC' => [0,0], 'TCCTCG' => [0,1], 'TCCTCT' => [0,1], 'TCCTGC' => [1,0], 'TCCTGG' => [1,1], 'TCCTGT' => [1,1], 'TCCTTA' => [1,1], 'TCCTTC' => [1,0], 'TCCTTG' => [1,1], 'TCCTTT' => [1,1], 'TCGAAA' => [2,1], 'TCGAAC' => [2,1], 'TCGAAG' => [2,0], 'TCGAAT' => [2,1], 'TCGACA' => [1,1], 'TCGACC' => [1,1], 'TCGACG' => [1,0], 'TCGACT' => [1,1], 'TCGAGA' => [2,1], 'TCGAGC' => [2,1], 'TCGAGG' => [2,0], 'TCGAGT' => [2,1], 'TCGATA' => [2,1], 'TCGATC' => [2,1], 'TCGATG' => [2,0], 'TCGATT' => [2,1], 'TCGCAA' => [2,1], 'TCGCAC' => [2,1], 'TCGCAG' => [2,0], 'TCGCAT' => [2,1], 'TCGCCA' => [1,1], 'TCGCCC' => [1,1], 'TCGCCG' => [1,0], 'TCGCCT' => [1,1], 'TCGCGA' => [2,1], 'TCGCGC' => [2,1], 'TCGCGG' => [2,0], 'TCGCGT' => [2,1], 'TCGCTA' => [1,2], 'TCGCTC' => [1,2], 'TCGCTG' => [1,1], 'TCGCTT' => [1,2], 'TCGGAA' => [2,1], 'TCGGAC' => [2,1], 'TCGGAG' => [2,0], 'TCGGAT' => [2,1], 'TCGGCA' => [1,1], 'TCGGCC' => [1,1], 'TCGGCG' => [1,0], 'TCGGCT' => [1,1], 'TCGGGA' => [2,1], 'TCGGGC' => [2,1], 'TCGGGG' => [2,0], 'TCGGGT' => [2,1], 'TCGGTA' => [2,1], 'TCGGTC' => [2,1], 'TCGGTG' => [2,0], 'TCGGTT' => [2,1], 'TCGTAC' => [1,1], 'TCGTAT' => [1,1], 'TCGTCA' => [0,1], 'TCGTCC' => [0,1], 'TCGTCG' => [0,0], 'TCGTCT' => [0,1], 'TCGTGC' => [1,1], 'TCGTGG' => [1,0], 'TCGTGT' => [1,1], 'TCGTTA' => [1,1], 'TCGTTC' => [1,1], 'TCGTTG' => [1,0], 'TCGTTT' => [1,1], 'TCTAAA' => [2,1], 'TCTAAC' => [2,1], 'TCTAAG' => [2,1], 'TCTAAT' => [2,0], 'TCTACA' => [1,1], 'TCTACC' => [1,1], 'TCTACG' => [1,1], 'TCTACT' => [1,0], 'TCTAGA' => [2,1], 'TCTAGC' => [2,1], 'TCTAGG' => [2,1], 'TCTAGT' => [2,0], 'TCTATA' => [2,1], 'TCTATC' => [2,1], 'TCTATG' => [2,1], 'TCTATT' => [2,0], 'TCTCAA' => [2,1], 'TCTCAC' => [2,1], 'TCTCAG' => [2,1], 'TCTCAT' => [2,0], 'TCTCCA' => [1,1], 'TCTCCC' => [1,1], 'TCTCCG' => [1,1], 'TCTCCT' => [1,0], 'TCTCGA' => [2,1], 'TCTCGC' => [2,1], 'TCTCGG' => [2,1], 'TCTCGT' => [2,0], 'TCTCTA' => [1,2], 'TCTCTC' => [2,1], 'TCTCTG' => [1,2], 'TCTCTT' => [2,0], 'TCTGAA' => [2,1], 'TCTGAC' => [2,1], 'TCTGAG' => [2,1], 'TCTGAT' => [2,0], 'TCTGCA' => [1,1], 'TCTGCC' => [1,1], 'TCTGCG' => [1,1], 'TCTGCT' => [1,0], 'TCTGGA' => [2,1], 'TCTGGC' => [2,1], 'TCTGGG' => [2,1], 'TCTGGT' => [2,0], 'TCTGTA' => [2,1], 'TCTGTC' => [2,1], 'TCTGTG' => [2,1], 'TCTGTT' => [2,0], 'TCTTAC' => [1,1], 'TCTTAT' => [1,0], 'TCTTCA' => [0,1], 'TCTTCC' => [0,1], 'TCTTCG' => [0,1], 'TCTTCT' => [0,0], 'TCTTGC' => [1,1], 'TCTTGG' => [1,1], 'TCTTGT' => [1,0], 'TCTTTA' => [1,1], 'TCTTTC' => [1,1], 'TCTTTG' => [1,1], 'TCTTTT' => [1,0], 'TGCAAA' => [3,0], 'TGCAAC' => [2,0], 'TGCAAG' => [3,0], 'TGCAAT' => [2,1], 'TGCACA' => [2,1], 'TGCACC' => [2,0], 'TGCACG' => [2,1], 'TGCACT' => [2,1], 'TGCAGA' => [2,0], 'TGCAGC' => [1,0], 'TGCAGG' => [2,0], 'TGCAGT' => [1,1], 'TGCATA' => [2,1], 'TGCATC' => [2,0], 'TGCATG' => [3,0], 'TGCATT' => [2,1], 'TGCCAA' => [2,1], 'TGCCAC' => [2,0], 'TGCCAG' => [2,1], 'TGCCAT' => [2,1], 'TGCCCA' => [2,1], 'TGCCCC' => [2,0], 'TGCCCG' => [2,1], 'TGCCCT' => [2,1], 'TGCCGA' => [1,1], 'TGCCGC' => [1,0], 'TGCCGG' => [1,1], 'TGCCGT' => [1,1], 'TGCCTA' => [2,1], 'TGCCTC' => [2,0], 'TGCCTG' => [2,1], 'TGCCTT' => [2,1], 'TGCGAA' => [2,1], 'TGCGAC' => [2,0], 'TGCGAG' => [2,1], 'TGCGAT' => [2,1], 'TGCGCA' => [2,1], 'TGCGCC' => [2,0], 'TGCGCG' => [2,1], 'TGCGCT' => [2,1], 'TGCGGA' => [1,1], 'TGCGGC' => [1,0], 'TGCGGG' => [1,1], 'TGCGGT' => [1,1], 'TGCGTA' => [2,1], 'TGCGTC' => [2,0], 'TGCGTG' => [2,1], 'TGCGTT' => [2,1], 'TGCTAC' => [1,0], 'TGCTAT' => [1,1], 'TGCTCA' => [1,1], 'TGCTCC' => [1,0], 'TGCTCG' => [1,1], 'TGCTCT' => [1,1], 'TGCTGC' => [0,0], 'TGCTGG' => [1,0], 'TGCTGT' => [0,1], 'TGCTTA' => [2,0], 'TGCTTC' => [1,0], 'TGCTTG' => [2,0], 'TGCTTT' => [1,1], 'TGGAAA' => [2,1], 'TGGAAC' => [3,0], 'TGGAAG' => [2,0], 'TGGAAT' => [3,0], 'TGGACA' => [2,1], 'TGGACC' => [2,1], 'TGGACG' => [2,0], 'TGGACT' => [2,1], 'TGGAGA' => [1,1], 'TGGAGC' => [2,0], 'TGGAGG' => [1,0], 'TGGAGT' => [2,0], 'TGGATA' => [2,1], 'TGGATC' => [3,0], 'TGGATG' => [2,0], 'TGGATT' => [3,0], 'TGGCAA' => [2,1], 'TGGCAC' => [2,1], 'TGGCAG' => [2,0], 'TGGCAT' => [2,1], 'TGGCCA' => [2,1], 'TGGCCC' => [2,1], 'TGGCCG' => [2,0], 'TGGCCT' => [2,1], 'TGGCGA' => [1,1], 'TGGCGC' => [1,1], 'TGGCGG' => [1,0], 'TGGCGT' => [1,1], 'TGGCTA' => [1,2], 'TGGCTC' => [1,2], 'TGGCTG' => [1,1], 'TGGCTT' => [1,2], 'TGGGAA' => [2,1], 'TGGGAC' => [2,1], 'TGGGAG' => [2,0], 'TGGGAT' => [2,1], 'TGGGCA' => [2,1], 'TGGGCC' => [2,1], 'TGGGCG' => [2,0], 'TGGGCT' => [2,1], 'TGGGGA' => [1,1], 'TGGGGC' => [1,1], 'TGGGGG' => [1,0], 'TGGGGT' => [1,1], 'TGGGTA' => [2,1], 'TGGGTC' => [2,1], 'TGGGTG' => [2,0], 'TGGGTT' => [2,1], 'TGGTAC' => [2,0], 'TGGTAT' => [2,0], 'TGGTCA' => [1,1], 'TGGTCC' => [1,1], 'TGGTCG' => [1,0], 'TGGTCT' => [1,1], 'TGGTGC' => [1,0], 'TGGTGG' => [0,0], 'TGGTGT' => [1,0], 'TGGTTA' => [1,1], 'TGGTTC' => [2,0], 'TGGTTG' => [1,0], 'TGGTTT' => [2,0], 'TGTAAA' => [3,0], 'TGTAAC' => [2,1], 'TGTAAG' => [3,0], 'TGTAAT' => [2,0], 'TGTACA' => [2,1], 'TGTACC' => [2,1], 'TGTACG' => [2,1], 'TGTACT' => [2,0], 'TGTAGA' => [2,0], 'TGTAGC' => [1,1], 'TGTAGG' => [2,0], 'TGTAGT' => [1,0], 'TGTATA' => [2,1], 'TGTATC' => [2,1], 'TGTATG' => [3,0], 'TGTATT' => [2,0], 'TGTCAA' => [2,1], 'TGTCAC' => [2,1], 'TGTCAG' => [2,1], 'TGTCAT' => [2,0], 'TGTCCA' => [2,1], 'TGTCCC' => [2,1], 'TGTCCG' => [2,1], 'TGTCCT' => [2,0], 'TGTCGA' => [1,1], 'TGTCGC' => [1,1], 'TGTCGG' => [1,1], 'TGTCGT' => [1,0], 'TGTCTA' => [2,1], 'TGTCTC' => [2,1], 'TGTCTG' => [2,1], 'TGTCTT' => [2,0], 'TGTGAA' => [2,1], 'TGTGAC' => [2,1], 'TGTGAG' => [2,1], 'TGTGAT' => [2,0], 'TGTGCA' => [2,1], 'TGTGCC' => [2,1], 'TGTGCG' => [2,1], 'TGTGCT' => [2,0], 'TGTGGA' => [1,1], 'TGTGGC' => [1,1], 'TGTGGG' => [1,1], 'TGTGGT' => [1,0], 'TGTGTA' => [2,1], 'TGTGTC' => [2,1], 'TGTGTG' => [2,1], 'TGTGTT' => [2,0], 'TGTTAC' => [1,1], 'TGTTAT' => [1,0], 'TGTTCA' => [1,1], 'TGTTCC' => [1,1], 'TGTTCG' => [1,1], 'TGTTCT' => [1,0], 'TGTTGC' => [0,1], 'TGTTGG' => [1,0], 'TGTTGT' => [0,0], 'TGTTTA' => [2,0], 'TGTTTC' => [1,1], 'TGTTTG' => [2,0], 'TGTTTT' => [1,0], 'TTAAAA' => [2,0], 'TTAAAC' => [2,1], 'TTAAAG' => [2,1], 'TTAAAT' => [2,1], 'TTAACA' => [2,0], 'TTAACC' => [2,1], 'TTAACG' => [2,1], 'TTAACT' => [2,1], 'TTAAGA' => [2,0], 'TTAAGC' => [2,1], 'TTAAGG' => [2,1], 'TTAAGT' => [2,1], 'TTAATA' => [1,0], 'TTAATC' => [1,1], 'TTAATG' => [1,1], 'TTAATT' => [1,1], 'TTACAA' => [1,1], 'TTACAC' => [1,2], 'TTACAG' => [1,2], 'TTACAT' => [1,2], 'TTACCA' => [1,1], 'TTACCC' => [1,2], 'TTACCG' => [1,2], 'TTACCT' => [1,2], 'TTACGA' => [1,1], 'TTACGC' => [1,2], 'TTACGG' => [1,2], 'TTACGT' => [1,2], 'TTACTA' => [0,1], 'TTACTC' => [0,2], 'TTACTG' => [0,2], 'TTACTT' => [0,2], 'TTAGAA' => [2,0], 'TTAGAC' => [2,1], 'TTAGAG' => [2,1], 'TTAGAT' => [2,1], 'TTAGCA' => [2,0], 'TTAGCC' => [2,1], 'TTAGCG' => [2,1], 'TTAGCT' => [2,1], 'TTAGGA' => [2,0], 'TTAGGC' => [2,1], 'TTAGGG' => [2,1], 'TTAGGT' => [2,1], 'TTAGTA' => [1,0], 'TTAGTC' => [1,1], 'TTAGTG' => [1,1], 'TTAGTT' => [1,1], 'TTATAC' => [2,0], 'TTATAT' => [2,0], 'TTATCA' => [1,0], 'TTATCC' => [1,1], 'TTATCG' => [1,1], 'TTATCT' => [1,1], 'TTATGC' => [2,0], 'TTATGG' => [1,1], 'TTATGT' => [2,0], 'TTATTA' => [0,0], 'TTATTC' => [1,0], 'TTATTG' => [0,1], 'TTATTT' => [1,0], 'TTCAAA' => [2,1], 'TTCAAC' => [2,0], 'TTCAAG' => [3,0], 'TTCAAT' => [2,1], 'TTCACA' => [2,1], 'TTCACC' => [2,0], 'TTCACG' => [2,1], 'TTCACT' => [2,1], 'TTCAGA' => [2,1], 'TTCAGC' => [2,0], 'TTCAGG' => [3,0], 'TTCAGT' => [2,1], 'TTCATA' => [1,1], 'TTCATC' => [1,0], 'TTCATG' => [2,0], 'TTCATT' => [1,1], 'TTCCAA' => [2,1], 'TTCCAC' => [2,0], 'TTCCAG' => [2,1], 'TTCCAT' => [2,1], 'TTCCCA' => [2,1], 'TTCCCC' => [2,0], 'TTCCCG' => [2,1], 'TTCCCT' => [2,1], 'TTCCGA' => [2,1], 'TTCCGC' => [2,0], 'TTCCGG' => [2,1], 'TTCCGT' => [2,1], 'TTCCTA' => [1,1], 'TTCCTC' => [1,0], 'TTCCTG' => [1,1], 'TTCCTT' => [1,1], 'TTCGAA' => [2,1], 'TTCGAC' => [2,0], 'TTCGAG' => [2,1], 'TTCGAT' => [2,1], 'TTCGCA' => [2,1], 'TTCGCC' => [2,0], 'TTCGCG' => [2,1], 'TTCGCT' => [2,1], 'TTCGGA' => [2,1], 'TTCGGC' => [2,0], 'TTCGGG' => [2,1], 'TTCGGT' => [2,1], 'TTCGTA' => [1,1], 'TTCGTC' => [1,0], 'TTCGTG' => [1,1], 'TTCGTT' => [1,1], 'TTCTAC' => [1,0], 'TTCTAT' => [1,1], 'TTCTCA' => [1,1], 'TTCTCC' => [1,0], 'TTCTCG' => [1,1], 'TTCTCT' => [1,1], 'TTCTGC' => [1,0], 'TTCTGG' => [2,0], 'TTCTGT' => [1,1], 'TTCTTA' => [1,0], 'TTCTTC' => [0,0], 'TTCTTG' => [1,0], 'TTCTTT' => [0,1], 'TTGAAA' => [2,1], 'TTGAAC' => [3,0], 'TTGAAG' => [2,0], 'TTGAAT' => [3,0], 'TTGACA' => [2,1], 'TTGACC' => [2,1], 'TTGACG' => [2,0], 'TTGACT' => [2,1], 'TTGAGA' => [2,1], 'TTGAGC' => [3,0], 'TTGAGG' => [2,0], 'TTGAGT' => [3,0], 'TTGATA' => [1,1], 'TTGATC' => [2,0], 'TTGATG' => [1,0], 'TTGATT' => [2,0], 'TTGCAA' => [1,2], 'TTGCAC' => [1,2], 'TTGCAG' => [1,1], 'TTGCAT' => [1,2], 'TTGCCA' => [1,2], 'TTGCCC' => [1,2], 'TTGCCG' => [1,1], 'TTGCCT' => [1,2], 'TTGCGA' => [1,2], 'TTGCGC' => [1,2], 'TTGCGG' => [1,1], 'TTGCGT' => [1,2], 'TTGCTA' => [0,2], 'TTGCTC' => [0,2], 'TTGCTG' => [0,1], 'TTGCTT' => [0,2], 'TTGGAA' => [2,1], 'TTGGAC' => [2,1], 'TTGGAG' => [2,0], 'TTGGAT' => [2,1], 'TTGGCA' => [2,1], 'TTGGCC' => [2,1], 'TTGGCG' => [2,0], 'TTGGCT' => [2,1], 'TTGGGA' => [2,1], 'TTGGGC' => [2,1], 'TTGGGG' => [2,0], 'TTGGGT' => [2,1], 'TTGGTA' => [1,1], 'TTGGTC' => [1,1], 'TTGGTG' => [1,0], 'TTGGTT' => [1,1], 'TTGTAC' => [2,0], 'TTGTAT' => [2,0], 'TTGTCA' => [1,1], 'TTGTCC' => [1,1], 'TTGTCG' => [1,0], 'TTGTCT' => [1,1], 'TTGTGC' => [2,0], 'TTGTGG' => [1,0], 'TTGTGT' => [2,0], 'TTGTTA' => [0,1], 'TTGTTC' => [1,0], 'TTGTTG' => [0,0], 'TTGTTT' => [1,0], 'TTTAAA' => [2,1], 'TTTAAC' => [2,1], 'TTTAAG' => [3,0], 'TTTAAT' => [2,0], 'TTTACA' => [2,1], 'TTTACC' => [2,1], 'TTTACG' => [2,1], 'TTTACT' => [2,0], 'TTTAGA' => [2,1], 'TTTAGC' => [2,1], 'TTTAGG' => [3,0], 'TTTAGT' => [2,0], 'TTTATA' => [1,1], 'TTTATC' => [1,1], 'TTTATG' => [2,0], 'TTTATT' => [1,0], 'TTTCAA' => [2,1], 'TTTCAC' => [2,1], 'TTTCAG' => [2,1], 'TTTCAT' => [2,0], 'TTTCCA' => [2,1], 'TTTCCC' => [2,1], 'TTTCCG' => [2,1], 'TTTCCT' => [2,0], 'TTTCGA' => [2,1], 'TTTCGC' => [2,1], 'TTTCGG' => [2,1], 'TTTCGT' => [2,0], 'TTTCTA' => [1,1], 'TTTCTC' => [1,1], 'TTTCTG' => [1,1], 'TTTCTT' => [1,0], 'TTTGAA' => [2,1], 'TTTGAC' => [2,1], 'TTTGAG' => [2,1], 'TTTGAT' => [2,0], 'TTTGCA' => [2,1], 'TTTGCC' => [2,1], 'TTTGCG' => [2,1], 'TTTGCT' => [2,0], 'TTTGGA' => [2,1], 'TTTGGC' => [2,1], 'TTTGGG' => [2,1], 'TTTGGT' => [2,0], 'TTTGTA' => [1,1], 'TTTGTC' => [1,1], 'TTTGTG' => [1,1], 'TTTGTT' => [1,0], 'TTTTAC' => [1,1], 'TTTTAT' => [1,0], 'TTTTCA' => [1,1], 'TTTTCC' => [1,1], 'TTTTCG' => [1,1], 'TTTTCT' => [1,0], 'TTTTGC' => [1,1], 'TTTTGG' => [2,0], 'TTTTGT' => [1,0], 'TTTTTA' => [1,0], 'TTTTTC' => [0,1], 'TTTTTG' => [1,0], 'TTTTTT' => [0,0], }; } 1; BioPerl-1.6.923/Bio/Nexml000755000765000024 012254227324 15076 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Nexml/Factory.pm000444000765000024 6333512254227324 17232 0ustar00cjfieldsstaff000000000000# $Id: Util.pm 15875 2009-07-21 19:20:00Z chmille4 $ # # BioPerl module for Bio::Nexml::Factory # # Please direct questions and support issues to # # Cared for by Chase Miller # # Copyright Chase Miller # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Nexml::Factory - A factory module for creating BioPerl and Bio::Phylo objects from/to nexml documents =head1 SYNOPSIS Do not use this module directly. It shoulde be used through Bio::NexmlIO, Bio::SeqIO::nexml, Bio::AlignIO::nexml, or Bio::TreeIO::nexml =head1 DESCRIPTION This is a factory/utility module in the Nexml namespace. It contains methods that are needed by multiple modules. This module handles the creation of BioPerl objects from Bio::Phylo objects and vice versa, which is used to read and write nexml documents to and from BioPerl objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chase Miller Email chmille4@gmail.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #Let the code begin package Bio::Nexml::Factory; use strict; BEGIN { use Bio::Root::Root; unless (eval "require Bio::Phylo; 1") { Bio::Root::Root->throw("Bio::Phylo package required; see http://www.nexml.org for download details"); } } use Bio::Phylo::Factory; use Bio::Phylo::Matrices; use Bio::Phylo::Matrices::Matrix; use Bio::Phylo::Matrices::Datum; use Bio::Phylo::Forest::Tree; use Bio::Phylo::Matrices; use Bio::Phylo::IO; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root); my $fac = Bio::Phylo::Factory->new(); =head2 new Title : new Usage : my $obj = Bio::Nexml::Factory->new(); Function: Builds a new L object Returns : L object Args : none =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); } #should all these creates be private methods? # naah./maj =head2 create_bperl_aln Title : create_bperl_aln Usage : my @alns = $factory->create_bperl_aln($objIO); Function: Converts Bio::Phylo::Matrices::Matrix objects into L objects Returns : an array of L objects Args : Bio::NexmlIO, Bio::SeqIO, Bio::AlignIO, or Bio::TreeIO see [http://search.cpan.org/~rvosa/Bio-Phylo/lib/Bio/Phylo/Project.pm Bio::Phylo::Project] =cut sub create_bperl_aln { my ($self, $caller) = @_; my ($start, $end, $seq, $desc); my $matrices = $caller->doc->get_matrices(); my @alns; foreach my $matrix (@$matrices) { #check if mol_type is something that makes sense to be an aln my $mol_type = lc($matrix->get_type()); unless ($mol_type eq 'dna' || $mol_type eq 'rna' || $mol_type eq 'protein') { next; # something for the back-burner: BioPerl has objects # to handle arbitrary genotypes; might be cool to # be able to create something besides alignments # here .../maj } #continue creating an aln my $aln = Bio::SimpleAlign->new(); my $taxa = $matrix->get_taxa(); # TODO: should $caller->{_ID} always be defined? # ATM, this is a Bio::AlignIO::nexml stream... $aln->{_Nexml_ID} = $caller->{_ID}? $caller->{_ID} . $taxa->get_xml_id : $taxa->get_xml_id; my $aln_feats = Bio::SeqFeature::Generic->new(); $aln_feats->add_tag_value('NexmlIO_ID', $caller->{_ID}); #check if there is a taxa associated with this alignment if ($taxa) { $aln_feats->add_tag_value('taxa_id', $taxa->get_xml_id()); $aln_feats->add_tag_value('taxa_label', $taxa->get_name()) if $taxa->get_name(); my $taxon = $taxa->first; while ($taxon) { $aln_feats->add_tag_value('taxon', $taxon->get_name); $taxon = $taxa->next; } } $aln->add_SeqFeature($aln_feats); my $basename = $matrix->get_name(); $aln->id($basename); my $seqNum = 0; my$row = $matrix->first; while ($row) { my $newSeq = $row->get_char(); my $rowlabel; $seqNum++; #constuct seqID based on matrix label and row id my $seqID = "$basename.row_$seqNum"; #Check if theres a row label and if not default to seqID if( !defined($rowlabel = $row->get_name())) {$rowlabel = $seqID;} $seq = Bio::LocatableSeq->new( -seq => $newSeq, -display_id => "$rowlabel", #-description => $desc, -alphabet => $mol_type, ); my $seq_feats; #check if there is a taxa associated w/ this alignment if($taxa) { if (my $taxon = $taxa->get_by_name($row->get_taxon->get_name())) { #attach taxon to each sequence by using the sequenceID because #LocatableSeq does not support features my $taxon_name = $taxon->get_name(); $seq_feats = Bio::SeqFeature::Generic->new(); $seq_feats->add_tag_value('taxon', "$taxon_name"); $seq_feats->add_tag_value('id', "$rowlabel"); } } $aln->add_seq($seq); $aln->add_SeqFeature($seq_feats); $self->debug("Reading r$rowlabel\n"); $row = $matrix->next(); } push (@alns, $aln); } return \@alns; } =head2 create_bperl_tree Title : create_bperl_tree Usage : my @trees = $factory->create_bperl_seq($objIO); Function: Converts Bio::Phylo::Forest::Tree objects into L objects Returns : an array of L objects Args : Bio::NexmlIO, Bio::SeqIO, Bio::AlignIO, or Bio::TreeIO see [http://search.cpan.org/~rvosa/Bio-Phylo/lib/Bio/Phylo/Project.pm Bio::Phylo::Project] =cut sub create_bperl_tree { my($self, $caller) = @_; my @trees; my $forests = $caller->doc->get_forests(); foreach my $forest (@$forests) { my $basename = $forest->get_name() || ''; my $taxa = $forest->get_taxa(); my $taxa_label = $taxa->get_name(); my $taxa_id = $taxa->get_xml_id(); my $t = $forest->first(); while ($t) { my %created_nodes; my $tree_id = $t->get_name(); my $tree = Bio::Tree::Tree->new(-id => "$basename.$tree_id"); #set the taxa info of the tree $tree->add_tag_value('taxa_label', $taxa_label) if defined($taxa_label); $tree->add_tag_value('taxa_id', $taxa_id) if defined($taxa_id); # TODO: should $caller->{_ID} always be defined? # ATM, this is a Bio::TreeIO::nexml stream... $tree->add_tag_value('_NexmlIO_ID', $caller->{_ID}) if $caller->{_ID}; my $taxon = $taxa->first; while($taxon) { $tree->add_tag_value('taxon', $taxon->get_name()) if defined($taxon->get_name); $taxon = $taxa->next; } #process terminals only, removing terminals as they get processed #which inturn creates new terminals to process until the entire tree has been processed my $terminals = $t->get_terminals(); # for(my $i=0; $i<@$terminals; $i++) while (my $terminal = shift @$terminals) { # my $terminal = $$terminals[$i]; my $new_node_id = $terminal->get_name(); my $newNode; if(exists $created_nodes{$new_node_id}) { $newNode = $created_nodes{$new_node_id}; } else { $newNode = Bio::Tree::Node->new(); $new_node_id ||= 'internal_'.$newNode->_creation_id; $newNode->id($new_node_id); $created_nodes{$new_node_id} = $newNode; } #check if taxa data exists for the current node ($terminal) if($taxa) { my $taxon = $terminal->get_taxon(); $newNode->add_tag_value("taxon", $taxon->get_name()) if $taxon && $taxon->get_name; } #check if you've reached the root of the tree and if so, stop. if($terminal->is_root()) { $tree->set_root_node($newNode); last; } #transfer attributes that apply to non-root only nodes $newNode->branch_length($terminal->get_branch_length()); my $parent = $terminal->get_parent(); my $parentID = $parent->get_name(); if(exists $created_nodes{$parentID}) { $created_nodes{$parentID}->add_Descendent($newNode); } else { my $parent_node = Bio::Tree::Node->new(); $parentID ||= 'internal_'.$parent_node->_creation_id; $parent_node->id($parentID); $parent_node->add_Descendent($newNode); $created_nodes{$parentID} = $parent_node; } #remove processed node from tree $parent->prune_child($terminal); #check if the parent of the removed node is now a terminal node and should be added for processing if($parent->is_terminal()) { push(@$terminals, $terminal->get_parent()) if $terminal->get_parent; } } push @trees, $tree; $t = $forest->next(); } } return \@trees; } =head2 create_bperl_seq Title : create_bperl_seq Usage : my @seqs = $factory->create_bperl_seq($objIO); Function: Converts Bio::Phylo::Matrices::Datum objects into L objects Returns : an array of L objects Args : Bio::NexmlIO, Bio::SeqIO, Bio::AlignIO, or Bio::TreeIO see [http://search.cpan.org/~rvosa/Bio-Phylo/lib/Bio/Phylo/Project.pm Bio::Phylo::Project] =cut sub create_bperl_seq { my($self, $caller) = @_; my $matrices = $caller->doc->get_matrices(); my @seqs; foreach my $matrix (@$matrices) { #check if mol_type is something that makes sense to be a seq my $mol_type = lc($matrix->get_type()); unless ($mol_type eq 'dna' || $mol_type eq 'rna' || $mol_type eq 'protein') { next; } my $taxa = $matrix->get_taxa(); my $seqnum = 0; my $taxa_id = $taxa->get_xml_id(); my $taxa_label = $taxa->get_name(); my $basename = $matrix->get_name(); my $row = $matrix->first; while ($row) { my $newSeq = $row->get_char(); my $feat = Bio::SeqFeature::Generic->new(); $feat->add_tag_value('matrix_label', $matrix->get_name()) if defined($matrix->get_name); $feat->add_tag_value('matrix_id', $matrix->get_xml_id()); $feat->add_tag_value('NexmlIO_ID', $caller->{_ID}); $feat->add_tag_value('taxa_id', $taxa_id) if defined($taxa_id); $feat->add_tag_value('taxa_label', $taxa_label) if defined($taxa_label); $seqnum++; #construct full sequence id by using bio::phylo "matrix label" and "row id" my $seqID = "$basename.seq_$seqnum"; my $rowlabel; #check if there is a label for the row, if not default to seqID if (!defined ($rowlabel = $row->get_name())) {$rowlabel = $seqID;} else {$seqID = $rowlabel;} #build the seq object using the factory create method my $seqbuilder = Bio::Seq::SeqFactory->new('-type' => 'Bio::Seq'); my $seq = $seqbuilder->create( -seq => $newSeq, -id => $rowlabel, -primary_id => $seqID, #-desc => $fulldesc, -alphabet => $mol_type, -direct => 1, ); # TODO: should $caller->{_ID} always be defined? # ATM, this is a Bio::SeqIO::nexml stream... $seq->{_Nexml_ID} = $caller->{_ID} ? $caller->{_ID} . $taxa_id : $taxa_id; $seq->{_Nexml_matrix_ID} = $caller->{_ID} ? $caller->{_ID} . $matrix->get_xml_id() : $matrix->get_xml_id(); #check if taxon linked to sequence if so create feature to attach to alignment if ($taxa) { my $taxon = $taxa->first; while ($taxon) { $feat->add_tag_value('taxon', $taxon->get_name) if defined($taxon->get_name); if($taxon eq $row->get_taxon) { my $taxon_name = $taxon->get_name(); $feat->add_tag_value('my_taxon', "$taxon_name") if defined($taxon_name); $feat->add_tag_value('id', $rowlabel); } $taxon = $taxa->next; } } $seq->add_SeqFeature($feat); push (@seqs, $seq); $row = $matrix->next; } } return \@seqs; } =head2 create_bphylo_tree Title : create_bphylo_tree Usage : my $bphylo_tree = $factory->create_bphylo_tree($bperl_tree); Function: Converts a L object into Bio::Phylo::Forest::Tree object Returns : a Bio::Phylo::Forest::Tree object Args : Bio::Tree::Tree object =cut sub create_bphylo_tree { my ($self, $bptree, $taxa) = @_; #most of the code below ripped form Bio::Phylo::Forest::Tree::new_from_bioperl()d my $tree = $fac->create_tree; my $class = 'Bio::Phylo::Forest::Tree'; if ( ref $bptree && $bptree->isa('Bio::Tree::TreeI') ) { bless $tree, $class; ($tree) = _copy_tree( $tree, $bptree->get_root_node, "", $taxa); # copy name my $name = $bptree->id; $tree->set_name( $name ) if defined $name; # copy score my $score = $bptree->score; $tree->set_score( $score ) if defined $score; } else { $self->throw('Not a bioperl tree!'); } return $tree; } sub _copy_tree { my ( $tree, $bpnode, $parent, $taxa ) = @_; my $node = create_bphylo_node($bpnode); my $taxon; if ($parent) { $parent->set_child($node); } if (my $bptaxon_name = $bpnode->get_tag_values('taxon')) { $node->set_taxon($taxa->get_by_name($bptaxon_name)); } $tree->insert($node); foreach my $bpchild ( $bpnode->each_Descendent ) { _copy_tree( $tree, $bpchild, $node, $taxa ); } return $tree; } =head2 create_bphylo_node Title : create_bphylo_node Usage : my $bphylo_node = $factory->create_bphylo_node($bperl_node); Function: Converts a L object into Bio::Phylo::Forest::Node object Returns : a Bio::Phylo::Forest::Node object Args : L object =cut sub create_bphylo_node { my ($bpnode) = @_; my $node = Bio::Phylo::Forest::Node->new(); #mostly ripped from Bio::Phylo::Forest::Node->new_from_bioperl() # copy name my $name = $bpnode->id; $node->set_name( $name ) if defined $name; # copy branch length my $branch_length = $bpnode->branch_length; $node->set_branch_length( $branch_length ) if defined $branch_length; # copy description my $desc = $bpnode->description; $node->set_desc( $desc ) if defined $desc; # copy bootstrap my $bootstrap = $bpnode->bootstrap; $node->set_score( $bootstrap ) if defined $bootstrap and looks_like_number $bootstrap; # copy other tags for my $tag ( $bpnode->get_all_tags ) { my @values = $bpnode->get_tag_values( $tag ); $node->set_generic( $tag => \@values ); } return $node; } =head2 create_bphylo_aln Title : create_bphylo_aln Usage : my $bphylo_aln = $factory->create_bphylo_aln($bperl_aln); Function: Converts a L object into Bio::Phylo::Matrices::Matrix object Returns : a Bio::Phylo::Matrices::Matrix object Args : Bio::SimpleAlign object =cut sub create_bphylo_aln { my ($self, $aln, $taxa, @args) = @_; #most of the code below ripped from Bio::Phylo::Matrices::Matrix::new_from_bioperl() if ( $aln->isa('Bio::Align::AlignI') ) { $aln->unmatch; $aln->map_chars('\.','-'); my @seqs = $aln->each_seq; my ( $type, $missing, $gap, $matchchar ); if ( $seqs[0] ) { $type = $seqs[0]->alphabet || $seqs[0]->_guess_alphabet || 'dna'; } else { $type = 'dna'; } my $matrix = $fac->create_matrix( '-type' => $type, '-special_symbols' => { '-missing' => $aln->missing_char || '?', '-matchchar' => $aln->match_char || '.', '-gap' => $aln->gap_char || '-', }, @args ); # XXX create raw getter/setter pairs for annotation, accession, consensus_meta source for my $field ( qw(description accession id annotation consensus_meta score source) ) { $matrix->$field( $aln->$field ); } my $to = $matrix->get_type_object; my @feats = $aln->get_all_SeqFeatures(); for my $seq ( @seqs ) { #create datum linked to taxa my $datum = create_bphylo_datum($seq, $taxa, \@feats, '-type_object' => $to); $matrix->insert($datum); } return $matrix; } else { $self->throw('Not a bioperl alignment!'); } } =head2 create_bphylo_seq Title : create_bphylo_seq Usage : my $bphylo_seq = $factory->create_bphylo_seq($bperl_seq); Function: Converts a L object into Bio::Phylo::Matrices::Matrix object Returns : a Bio::Phylo::Matrices::Matrix object Args : Bio::Seq object =cut sub create_bphylo_seq { my ($self, $seq, $taxa, @args) = @_; my $type = $seq->alphabet || $seq->_guess_alphabet || 'dna'; $type = uc($type); my $dat = create_bphylo_datum($seq, $taxa, '-type' => $type); # copy seq string my $seqstring = $seq->seq; if ( $seqstring and $seqstring =~ /\S/ ) { eval { $dat->set_char( $seqstring ) }; if ( $@ and UNIVERSAL::isa($@,'Bio::Phylo::Util::Exceptions::InvalidData') ) { $self->throw("\n\nThe BioPerl sequence object contains invalid data ($seqstring)\n"); } } # copy name my $name = $seq->display_id; #$dat->set_name( $name ) if defined $name; # copy desc my $desc = $seq->desc; $dat->set_desc( $desc ) if defined $desc; #get features from SeqFeatureI for my $field ( qw(start end strand) ) { $dat->$field( $seq->$field ) if $seq->can($field); } return $dat; } =head2 create_bphylo_taxa Title : create_bphylo_seq Usage : my $taxa = $factory->create_bphylo_taxa($bperl_obj); Function: creates a taxa object from the data attached to a bioperl object Returns : a Bio::Phylo::Taxa object Args : L object, or L object, or L object =cut sub create_bphylo_taxa { my $self = shift @_; my ($obj) = @_; #check if tree or aln object if ( UNIVERSAL::isa( $obj, 'Bio::Align::AlignI' ) || UNIVERSAL::isa( $obj, 'Bio::Seq')) { return $self->_create_bphylo_matrix_taxa(@_); } elsif ( UNIVERSAL::isa( $obj, 'Bio::Tree::TreeI' ) ) { return $self->_create_bphylo_tree_taxa(@_); } } sub _create_bphylo_tree_taxa { my ($self, $tree) = @_; my $taxa = $fac->create_taxa(); my $taxon; #check if taxa exists unless ($tree->has_tag('taxa_id')) { return 0; } #copy taxa details $taxa->set_xml_id(($tree->get_tag_values('taxa_id'))[0]); $taxa->set_name(($tree->get_tag_values('taxa_label'))[0]); foreach my $taxon_name ($tree->get_tag_values('taxon')) { $taxon = $fac->create_taxon(-name => $taxon_name); $taxa->insert($taxon); } return $taxa; } sub _create_bphylo_matrix_taxa { my ($self, $aln) = @_; my $taxa = $fac->create_taxa(); my $taxon; my @feats = $aln->get_all_SeqFeatures(); foreach my $feat (@feats) { if (my $taxa_id = ($feat->get_tag_values('taxa_id'))[0]) { my $taxa_label = ($feat->get_tag_values('taxa_label'))[0]; $taxa->set_name($taxa_label) if defined $taxa_label; $taxa->set_xml_id($taxa_id) if defined $taxa_label; my @taxa_bp = $feat->get_tag_values('taxon'); foreach my $taxon_name (@taxa_bp) { $taxon = $fac->create_taxon(-name => $taxon_name); $taxa->insert($taxon); } last; } } return $taxa } =head2 create_bphylo_datum Title : create_bphylo_datum Usage : my $bphylo_datum = $factory->create_bphylo_datum($bperl_datum); Function: Converts a L object into Bio::Phylo::Matrices::datum object Returns : a Bio::Phylo::Matrices::datum object Args : Bio::Seq object, Bio::Phylo::Taxa object, [optional] arrayref to SeqFeatures, [optional] key => value pairs to pass to Bio::Phylo constructor =cut sub create_bphylo_datum { #mostly ripped from Bio::Phylo::Matrices::Datum::new_from_bioperl() my ( $seq, $taxa, @args ) = @_; my $class = 'Bio::Phylo::Matrices::Datum'; my $feats; # want $seq type-check here? Allowable: is-a Bio::PrimarySeq, # Bio::LocatableSeq /maj if (@args % 2) { # odd $feats = shift @args; unless (ref($feats) eq 'ARRAY') { Bio::Root::Root->throw("Third argument must be array of SeqFeatures"); } } my $type = $seq->alphabet || $seq->_guess_alphabet || 'dna'; my $self = $class->new( '-type' => $type, @args ); # copy seq string my $seqstring = $seq->seq; if ( $seqstring and $seqstring =~ /\S/ ) { eval { $self->set_char( $seqstring ) }; if ( $@ and UNIVERSAL::isa($@,'Bio::Phylo::Util::Exceptions::InvalidData') ) { $self->throw("\n\nThe BioPerl sequence object contains invalid data ($seqstring)\n"); } } # copy name my $name = $seq->display_id; $self->set_name( $name ) if defined $name; my $taxon; my @feats = (defined $feats ? @$feats : $seq->get_all_SeqFeatures); # convert taxa foreach my $feat (@feats) { #get sequence id associated with taxa to compare my $taxa_id = ($feat->get_tag_values('id'))[0] if $feat->has_tag('id'); if ($taxa_id && $name eq $taxa_id) { my $taxon_name; if($feat->has_tag('my_taxon')) { $taxon_name = ($feat->get_tag_values('my_taxon'))[0] } else { $taxon_name = ($feat->get_tag_values('taxon'))[0]; } $self->set_taxon($taxa->get_by_name($taxon_name)); } } # copy desc my $desc = $seq->desc; $self->set_desc( $desc ) if defined $desc; # only Bio::LocatableSeq objs have these fields... for my $field ( qw(start end strand) ) { $self->$field( $seq->$field ) if $seq->can($field); } return $self; } =head2 CREATOR =cut =head1 bioperl_create Title : bioperl_create Usage : $bioperl_obj = $fac->bioperl_create($obj_type, $biophylo_proj); Function: Create a specified bioperl object using a Bio::Phylo project Args : scalar string ('aln', 'tree', 'seq') type designator Bio::Phylo::Project object Returns : Appropriate BioPerl object =cut sub bioperl_create { my $self = shift; my ($type, @args) = @_; unless (grep /^type/,qw( seq aln tree )) { $self->throw("Unrecognized type for argument 1"); } my $call = 'create_bioperl_'.$type; return $self->$call(@args); } 1; BioPerl-1.6.923/Bio/Ontology000755000765000024 012254227337 15631 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Ontology/DocumentRegistry.pm000444000765000024 1146112254227323 21651 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::DocumentRegistry # # Please direct questions and support issues to # # Cared for by Allen Day # # Copyright Allen Day # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::DocumentRegistry - Keep track of where to find ontologies. Allows lookups by name. =head1 SYNOPSIS my $registry = Bio::Ontology::DocumentRegistry->get_instance(); my($ont,$def,$fmt) = $registry->documents('Sequence Ontology'); my $io = Bio::OntologyIO->new(-url => $ont, -defs_url => $def, -format => $fmt); my $so = $io->next_ontology(); #... =head1 DESCRIPTION Do not use this directly, use Bio::Ontology::OntologyStore instead. Bio::Ontology::OntologyStore uses Bio::Ontology::DocumentRegistry to load and cache ontologies as object graphs, you can just ask it for what you want by name. See L for details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Allen Day Email allenday@ucla.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::DocumentRegistry; use strict; use base qw(Bio::Root::Root); use Data::Dumper; my $instance; BEGIN { $instance = { 'Sequence Ontology' => { ontology => "http://song.cvs.sourceforge.net/*checkout*/song/ontology/so.ontology?rev=HEAD", definitions => "http://song.cvs.sourceforge.net/*checkout*/song/ontology/so.definition?rev=HEAD", format => 'soflat', }, 'Sequence Ontology OBO' => { ontology => "http://song.cvs.sourceforge.net/*checkout*/song/ontology/so.obo?rev=HEAD", definitions => "http://song.cvs.sourceforge.net/*checkout*/song/ontology/so.definition?rev=HEAD", format => 'obo', }, #### TODO Server http://umn.dl.sourceforge.net/ does not respond, are there #### alternative sources? 'Sequence Ontology Feature Annotation' => { ontology => 'http://umn.dl.sourceforge.net/sourceforge/song/sofa.ontology', definitions =>'http://umn.dl.sourceforge.net/sourceforge/song/sofa.definition', format => 'soflat', }, 'Gene Ontology' => { ontology => [ 'http://www.geneontology.org/ontology/function.ontology', 'http://www.geneontology.org/ontology/process.ontology', 'http://www.geneontology.org/ontology/component.ontology' ], definitions => 'http://www.geneontology.org/ontology/GO.defs', format => 'soflat', }, }; #aliases $instance->{Gene_Ontology} = $instance->{'Gene Ontology'}; bless $instance, __PACKAGE__; } sub new { return shift->get_instance(@_); } =head2 get_instance Title : get_instance Usage : my $singleton = Bio::Ontology::DocumentRegistry->get_instance(); Function: constructor Returns : The Bio::Ontology::DocumentRegistry singleton. Args : None Usage =cut sub get_instance { return $instance; } =head2 documents Title : documents Usage : my($ontology_url, $definitions_url, $format) = $obj->documents('Sequence Ontology'); Function: Maps an ontology name to a list of (local or) remote URIs where the files can be located. Returns : A 3-item list: (1) URI for the ontology file (2) URI for the ontology definitions file (3) format of the files (dagedit, obo, etc) Args : Name of an ontology, e.g. 'Sequence Ontology', or 'Cellular Component (Gene Ontology)' =cut sub documents { my($self,$name) = @_; if(defined($self->{$name})){ return ($self->{$name}{ontology} , $self->{$name}{definitions}, $self->{$name}{format}); } else { return (); } } 1; BioPerl-1.6.923/Bio/Ontology/GOterm.pm000444000765000024 2230612254227336 17543 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::GOterm # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::GOterm - representation of GO terms =head1 SYNOPSIS $term = Bio::Ontology::GOterm->new ( -go_id => "GO:0016847", -name => "1-aminocyclopropane-1-carboxylate synthase", -definition => "Catalysis of ...", -is_obsolete => 0, -comment => "" ); $term->add_definition_references( @refs ); $term->add_secondary_GO_ids( @ids ); $term->add_aliases( @aliases ); foreach my $dr ( $term->each_definition_reference() ) { print $dr, "\n"; } # etc. =head1 DESCRIPTION This is "dumb" class for GO terms (it provides no functionality related to graphs). Implements Bio::Ontology::TermI. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Ontology::GOterm; use strict; use constant GOID_DEFAULT => "GO:0000000"; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::Ontology::Term); =head2 new Title : new Usage : $term = Bio::Ontology::GOterm->new( -go_id => "GO:0016847", -name => "1-aminocyclopropane-1-carboxylate synthase", -definition => "Catalysis of ...", -is_obsolete => 0, -comment => "" ); Function: Creates a new Bio::Ontology::GOterm. Returns : A new Bio::Ontology::GOterm object. Args : -go_id => the goid of this GO term [GO:nnnnnnn] or [nnnnnnn] (nnnnnnn is a zero-padded integer of seven digits) -name => the name of this GO term [scalar] -definition => the definition of this GO term [scalar] -ontology => the ontology for this term (a Bio::Ontology::OntologyI compliant object) -version => version information [scalar] -is_obsolete => the obsoleteness of this GO term [0 or 1] -comment => a comment [scalar] =cut sub new { my( $class,@args ) = @_; my $self = $class->SUPER::new( @args ); my ( $GO_id ) = $self->_rearrange( [ qw( GO_ID ) ], @args ); $GO_id && $self->GO_id( $GO_id ); return $self; } # new =head2 init Title : init() Usage : $term->init(); Function: Initializes this GOterm to all "" and empty lists. Returns : Args : =cut sub init { my $self = shift; # first call the inherited version to properly chain up the hierarchy $self->SUPER::init(@_); # then only initialize what we implement ourselves here #$self->GO_id( GOID_DEFAULT ); } # init =head2 GO_id Title : GO_id Usage : $term->GO_id( "GO:0003947" ); or print $term->GO_id(); Function: Set/get for the goid of this GO term. This is essentially an alias to identifier(), with added format checking. Returns : The goid [GO:nnnnnnn]. Args : The goid [GO:nnnnnnn] or [nnnnnnn] (nnnnnnn is a zero-padded integer of seven digits) (optional). =cut sub GO_id { my $self = shift; my $value; if ( @_ ) { $value = $self->_check_go_id( shift ); unshift(@_, $value); } return $self->identifier( @_ ); } # GO_id =head2 get_secondary_GO_ids Title : get_secondary_GO_ids Usage : @ids = $term->get_secondary_GO_ids(); Function: Returns a list of secondary goids of this Term. This is aliased to remove_secondary_ids(). Returns : A list of secondary goids [array of [GO:nnnnnnn]] (nnnnnnn is a zero-padded integer of seven digits). Args : =cut sub get_secondary_GO_ids { return shift->get_secondary_ids(@_); } # get_secondary_GO_ids =head2 add_secondary_GO_id Title : add_secondary_GO_id Usage : $term->add_secondary_GO_id( @ids ); or $term->add_secondary_GO_id( $id ); Function: Pushes one or more secondary goids into the list of secondary goids. This is aliased to remove_secondary_ids(). Returns : Args : One secondary goid [GO:nnnnnnn or nnnnnnn] or a list of secondary goids [array of [GO:nnnnnnn or nnnnnnn]] (nnnnnnn is a zero-padded integer of seven digits). =cut sub add_secondary_GO_id { return shift->add_secondary_id(@_); } # add_secondary_GO_id =head2 remove_secondary_GO_ids Title : remove_secondary_GO_ids() Usage : $term->remove_secondary_GO_ids(); Function: Deletes (and returns) the secondary goids of this Term. This is aliased to remove_secondary_ids(). Returns : A list of secondary goids [array of [GO:nnnnnnn]] (nnnnnnn is a zero-padded integer of seven digits). Args : =cut sub remove_secondary_GO_ids { return shift->remove_secondary_ids(@_); } # remove_secondary_GO_ids =head2 to_string Title : to_string() Usage : print $term->to_string(); Function: to_string method for GO terms. Returns : A string representation of this GOterm. Args : =cut sub to_string { my( $self ) = @_; my $s = ""; $s .= "-- GO id:\n"; $s .= ($self->GO_id() || '')."\n"; $s .= "-- Name:\n"; $s .= ($self->name() || '') ."\n"; $s .= "-- Definition:\n"; $s .= ($self->definition() || '') ."\n"; $s .= "-- Category:\n"; if ( defined( $self->ontology() ) ) { $s .= $self->ontology()->name()."\n"; } else { $s .= "\n"; } $s .= "-- Version:\n"; $s .= ($self->version() || '') ."\n"; $s .= "-- Is obsolete:\n"; $s .= $self->is_obsolete()."\n"; $s .= "-- Comment:\n"; $s .= ($self->comment() || '') ."\n"; $s .= "-- Definition references:\n"; $s .= $self->_array_to_string( $self->get_dbxrefs() )."\n"; $s .= "-- Secondary GO ids:\n"; $s .= $self->_array_to_string( $self->get_secondary_GO_ids() )."\n"; $s .= "-- Aliases:\n"; $s .= $self->_array_to_string( $self->get_synonyms() ); return $s; } # to_string # Title : _check_go_id # Function: Checks whether the argument is [GO:nnnnnnn]. # If "GO:" is not present, it adds it. # Returns : The canonical GO id. # Args : The value to be checked. sub _check_go_id { my ( $self, $value ) = @_; unless ( $value =~ /^(GO:)?\d{7}$/ || $value eq GOID_DEFAULT ) { $self->throw( "Found [" . $value . "] where [GO:nnnnnnn] or [nnnnnnn] expected" ); } unless ( $value =~ /^GO:/ ) { $value = "GO:".$value; } return $value; } # _check_go_id # Title : _array_to_string # Function: # Returns : # Args : sub _array_to_string { my( $self, @value ) = @_; my $s = ""; for ( my $i = 0; $i < scalar( @value ); ++$i ) { if ( ! ref( $value[ $i ] ) ) { $s .= "#" . $i . "\n-- " . $value[ $i ] . "\n"; } } return $s; } # _array_to_string ################################################################# # aliases or forwards to maintain backward compatibility ################################################################# *each_secondary_GO_id = \&get_secondary_GO_ids; *add_secondary_GO_ids = \&add_secondary_GO_id; 1; BioPerl-1.6.923/Bio/Ontology/InterProTerm.pm000444000765000024 3546012254227314 20741 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::InterProTerm # # Please direct questions and support issues to # # Cared for by Peter Dimitrov # # Copyright Peter Dimitrov # (c) Peter Dimitrov, dimitrov@gnf.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::InterProTerm - Implementation of InterProI term interface =head1 SYNOPSIS my $term = Bio::Ontology::InterProTerm->new( -interpro_id => "IPR000001", -name => "Kringle", -definition => "Kringles are autonomous structural domains ...", -ontology => "Domain" ); print $term->interpro_id(), "\n"; print $term->name(), "\n"; print $term->definition(), "\n"; print $term->is_obsolete(), "\n"; print $term->ontology->name(), "\n"; =head1 DESCRIPTION This is a simple extension of L for InterPro terms. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Dimitrov Email dimitrov@gnf.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::InterProTerm; use strict; use Bio::Annotation::Reference; use constant INTERPRO_ID_DEFAULT => "IPR000000"; use base qw(Bio::Ontology::Term); =head2 new Title : new Usage : $term = Bio::Ontology::InterProTerm->new( -interpro_id => "IPR000002", -name => "Cdc20/Fizzy", -definition => "The Cdc20/Fizzy region is almost always ...", -ontology => "Domain" ); Function: Creates a new Bio::Ontology::InterProTerm. Example : Returns : A new Bio::Ontology::InterProTerm object. Args : -interpro_id => the InterPro ID of the term. Has the form IPRdddddd, where dddddd is a zero-padded six digit number -name => the name of this InterPro term [scalar] -definition => the definition/abstract of this InterPro term [scalar] -ontology => ontology of InterPro terms [Bio::Ontology::OntologyI] -comment => a comment [scalar] =cut sub new{ my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ( $interpro_id, $short_name) = $self->_rearrange( [qw( INTERPRO_ID SHORT_NAME ) ], @args ); $interpro_id && $self->interpro_id( $interpro_id ); $short_name && $self->short_name( $short_name ); return $self; } =head2 init Title : init Usage : $term->init(); Function: Initializes this InterProTerm to all "" and empty lists. Example : Returns : Args : =cut sub init{ my $self = shift; # first call the inherited version to properly chain up the hierarchy $self->SUPER::init(@_); # then only initialize what we implement ourselves here $self->interpro_id( INTERPRO_ID_DEFAULT ); $self->short_name(""); } =head2 _check_interpro_id Title : _check_interpro_id Usage : Function: Performs simple check in order to validate that its argument has the form IPRdddddd, where dddddd is a zero-padded six digit number. Example : Returns : Returns its argument if valid, otherwise throws exception. Args : String =cut sub _check_interpro_id{ my ($self, $value) = @_; $self->throw( "InterPro ID ".$value." is incorrect\n" ) unless ( $value =~ /^IPR\d{6}$/ || $value eq INTERPRO_ID_DEFAULT ); return $value; } =head2 interpro_id Title : interpro_id Usage : $obj->interpro_id($newval) Function: Set/get for the interpro_id of this InterProTerm Example : Returns : value of interpro_id (a scalar) Args : new value (a scalar, optional) =cut sub interpro_id{ my ($self, $value) = @_; if( defined $value) { $value = $self->_check_interpro_id($value); return $self->identifier($value); } return $self->identifier(); } =head2 short_name Title : short_name Usage : $obj->short_name($newval) Function: Set/get for the short name of this InterProTerm. Example : Returns : value of short_name (a scalar) Args : new value (a scalar, optional) =cut sub short_name{ my ($self, $value) = @_; if( defined $value) { $self->{'short_name'} = $value ? $value : undef; } return $self->{'short_name'}; } =head2 protein_count Title : protein_count Usage : $obj->protein_count($newval) Function: Set/get for the protein count of this InterProTerm. Example : Returns : value of protein_count (a scalar) Args : new value (a scalar, optional) =cut sub protein_count{ my ($self,$value) = @_; if( defined $value) { $self->{'protein_count'} = $value ? $value : undef; } return $self->{'protein_count'}; } =head2 get_references Title : get_references Usage : Function: Get the references for this InterPro term. Example : Returns : An array of L objects Args : =cut # Defined in parent class #sub get_references{ # my $self = shift; # # return @{$self->{"_references"}} if exists($self->{"_references"}); # return (); #} =head2 add_reference Title : add_reference Usage : Function: Add one or more references to this InterPro term. Example : Returns : Args : One or more L objects. =cut # Defined in parent class #sub add_reference{ # my $self = shift; # # $self->{"_references"} = [] unless exists($self->{"_references"}); # push(@{$self->{"_references"}}, @_); #} =head2 remove_references Title : remove_references Usage : Function: Remove all references for this InterPro term. Example : Returns : The list of previous references as an array of L objects. Args : =cut # Defined in parent class #sub remove_references{ # my $self = shift; # # my @arr = $self->get_references(); # $self->{"_references"} = []; # return @arr; #} =head2 get_members Title : get_members Usage : @arr = get_members() Function: Get the list of member(s) for this object. Example : Returns : An array of Bio::Annotation::DBLink objects Args : =cut sub get_members{ my $self = shift; return $self->get_dbxrefs('member_list'); } =head2 add_member Title : add_member Usage : Function: Add one or more member(s) to this object. Example : Returns : Args : One or more Bio::Annotation::DBLink objects. =cut sub add_member{ my $self = shift; $self->add_dbxref(-dbxrefs => \@_, -context => 'member_list'); } =head2 remove_members Title : remove_members Usage : Function: Remove all members for this class. Example : Returns : The list of previous members as an array of Bio::Annotation::DBLink objects. Args : =cut sub remove_members{ my $self = shift; return $self->remove_dbxrefs('member_list'); } =head2 get_examples Title : get_examples Usage : @arr = get_examples() Function: Get the list of example(s) for this object. This is an element of the InterPro xml schema. Example : Returns : An array of Bio::Annotation::DBLink objects Args : =cut sub get_examples{ my $self = shift; return $self->get_dbxrefs('example_list'); } =head2 add_example Title : add_example Usage : Function: Add one or more example(s) to this object. This is an element of the InterPro xml schema. Example : Returns : Args : One or more Bio::Annotation::DBLink objects. =cut sub add_example{ my $self = shift; return $self->add_dbxref(-dbxrefs => \@_, -context => 'example_list'); } =head2 remove_examples Title : remove_examples Usage : Function: Remove all examples for this class. This is an element of the InterPro xml schema. Example : Returns : The list of previous examples as an array of Bio::Annotation::DBLink objects. Args : =cut sub remove_examples{ my $self = shift; return $self->remove_dbxrefs('example_list'); } =head2 get_external_documents Title : get_external_documents Usage : @arr = get_external_documents() Function: Get the list of external_document(s) for this object. This is an element of the InterPro xml schema. Example : Returns : An array of Bio::Annotation::DBLink objects Args : =cut sub get_external_documents{ my $self = shift; return $self->get_dbxrefs('external_doc_list'); } =head2 add_external_document Title : add_external_document Usage : Function: Add one or more external_document(s) to this object. This is an element of the InterPro xml schema. Example : Returns : Args : One or more Bio::Annotation::DBLink objects. =cut sub add_external_document{ my $self = shift; return $self->add_dbxref(-dbxrefs => \@_, -context => 'external_doc_list'); } =head2 remove_external_documents Title : remove_external_documents Usage : Function: Remove all external_documents for this class. This is an element of the InterPro xml schema. Example : Returns : The list of previous external_documents as an array of Bio::Annotation::DBLink objects. Args : =cut sub remove_external_documents{ my $self = shift; return $self->remove_dbxrefs('external_doc_list'); } =head2 class_list Title : class_list Usage : $obj->class_list($newval) Function: Set/get for class list element of the InterPro xml schema Example : Returns : reference to an array of Bio::Annotation::DBLink objects Args : reference to an array of Bio::Annotation::DBLink objects =cut # this is inconsistent with the above, but we work around it and hope nothing # breaks sub class_list{ my ($self, $value) = @_; if( defined $value && ref $value eq 'ARRAY') { if (!@$value) { # passing an empty array ref is essentially same as remove_dbxrefs, # so do that $self->remove_dbxrefs('class_list'); } else { $self->add_dbxref(-dbxrefs => $value, -context => 'class_list'); } } return [$self->get_dbxrefs('class_list')]; } =head2 to_string Title : to_string() Usage : print $term->to_string(); Function: to_string method for InterPro terms. Returns : A string representation of this InterPro term. Args : =cut sub to_string { my ($self) = @_; my $s = ""; $s .= "-- InterPro id:\n"; $s .= $self->interpro_id() . "\n"; if ( defined $self->name ) { $s .= "-- Name:\n"; $s .= $self->name() . "\n"; $s .= "-- Definition:\n"; $s .= $self->definition() . "\n"; $s .= "-- Category:\n"; if ( defined( $self->ontology() ) ) { $s .= $self->ontology()->name() . "\n"; } else { $s .= "\n"; } $s .= "-- Version:\n"; $s .= ( $self->version() || '' ) . "\n"; $s .= "-- Is obsolete:\n"; $s .= $self->is_obsolete() . "\n"; $s .= "-- Comment:\n"; $s .= ( $self->comment() || '' ) . "\n"; if ( defined $self->get_references ) { $s .= "-- References:\n"; foreach my $ref ( $self->get_references ) { $s .= $ref->authors . "\n" . $ref->title . "\n" . $ref->location . "\n\n"; } $s .= "\n"; } if ( defined $self->get_members ) { $s .= "-- Member List:\n"; foreach my $ref ( $self->get_members ) { $s .= $ref->database . "\t" . $ref->primary_id . "\n"; } $s .= "\n"; } if ( defined $self->get_external_documents ) { $s .= "-- External Document List:\n"; foreach my $ref ( $self->get_external_documents ) { $s .= $ref->database . "\t" . $ref->primary_id . "\n"; } $s .= "\n"; } if ( defined $self->get_examples ) { $s .= "-- Examples:\n"; foreach my $ref ( $self->get_examples ) { $s .= join( "\t", map { $ref->$_ || '' } qw(database primary_id comment) ) . "\n"; } $s .= "\n"; } if ( defined $self->class_list ) { $s .= "-- Class List:\n"; foreach my $ref ( @{ $self->class_list } ) { $s .= $ref->primary_id . "\n"; } $s .= "\n"; } if ( $self->get_secondary_ids ) { $s .= "-- Secondary IDs:\n"; foreach my $ref ( $self->get_secondary_ids() ) { # TODO: getting undef here in some cases, needs to be checked next unless defined ($ref); $s .= $ref . "\n"; } $s .= "\n"; } } else { $s .= "InterPro term not fully instantiated\n"; } return $s; } =head1 Deprecated methods These are here for backwards compatibility. =cut =head2 secondary_ids Title : secondary_ids Usage : $obj->secondary_ids($newval) Function: This is deprecated. Use get_secondary_ids() or add_secondary_id() instead. Example : Returns : reference to an array of strings Args : reference to an array of strings =cut sub secondary_ids{ my $self = shift; my @ids; $self->warn("secondary_ids is deprecated. Use ". "get_secondary_ids/add_secondary_id instead."); # set mode? if(@_) { my $sids = shift; if($sids) { $self->add_secondary_id(@$sids); @ids = @$sids; } else { # we interpret setting to undef as removing the array $self->remove_secondary_ids(); } } else { # no; get mode @ids = $self->get_secondary_ids(); } return \@ids; } 1; BioPerl-1.6.923/Bio/Ontology/OBOEngine.pm000444000765000024 7031212254227321 20105 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::OBOEngine # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::OBOEngine - An Ontology Engine for OBO style flat file format from the Gene Ontology Consortium =head1 SYNOPSIS use Bio::Ontology::OBOEngine; my $parser = Bio::Ontology::OBOEngine->new ( -file => "gene_ontology.obo" ); my $engine = $parser->parse(); =head1 DESCRIPTION Needs Graph.pm from CPAN. This module replaces SimpleGOEngine.pm, which is deprecated. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Sohel Merchant Email: s-merchant@northwestern.edu Address: Northwestern University Center for Genetic Medicine (CGM), dictyBase Suite 1206, 676 St. Clair st Chicago IL 60611 =head2 CONTRIBUTOR Hilmar Lapp, hlapp at gmx.net Chris Mungall, cjm at fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Ontology::OBOEngine; use Bio::Ontology::SimpleGOEngine::GraphAdaptor; use strict; use Bio::Ontology::RelationshipType; use Bio::Ontology::RelationshipFactory; use Data::Dumper; use constant TRUE => 1; use constant FALSE => 0; use constant IS_A => "IS_A"; use constant PART_OF => "PART_OF"; use constant RELATED_TO => "RELATED_TO"; use constant TERM => "TERM"; use constant TYPE => "TYPE"; use constant ONTOLOGY => "ONTOLOGY"; use constant REGULATES => "REGULATES"; use constant POSITIVELY_REGULATES => "POSITIVELY_REGULATES"; use constant NEGATIVELY_REGULATES => "NEGATIVELY_REGULATES"; use base qw(Bio::Root::Root Bio::Ontology::OntologyEngineI); =head2 new Title : new Usage : $engine = Bio::Ontology::OBOEngine->new() Function: Creates a new OBOEngine Returns : A new OBOEngine object Args : =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); $self->init(); return $self; } # new =head2 init Title : init() Usage : $engine->init(); Function: Initializes this Engine. Returns : Args : =cut sub init { my ( $self ) = @_; $self->{ "_is_a_relationship" } = Bio::Ontology::RelationshipType->get_instance( IS_A ); $self->{ "_part_of_relationship" } = Bio::Ontology::RelationshipType->get_instance( PART_OF ); $self->{ "_related_to_relationship" } = Bio::Ontology::RelationshipType->get_instance( RELATED_TO ); $self->{'_regulates_relationship'} = Bio::Ontology::RelationshipType->get_instance(REGULATES); $self->{'_positively_regulate'} = Bio::Ontology::RelationshipType->get_instance(POSITIVELY_REGULATES); $self->{'_negatively_regulate'} = Bio::Ontology::RelationshipType->get_instance(NEGATIVELY_REGULATES); $self->graph( Bio::Ontology::SimpleGOEngine::GraphAdaptor->new() ); # NG 05-02-16 # set defaults for the factories $self->relationship_factory(Bio::Ontology::RelationshipFactory->new( -type => "Bio::Ontology::Relationship")); } # init =head2 is_a_relationship Title : is_a_relationship() Usage : $IS_A = $engine->is_a_relationship(); Function: Returns a Bio::Ontology::RelationshipType object for "is-a" relationships Returns : Bio::Ontology::RelationshipType set to "IS_A" Args : =cut sub is_a_relationship { my ( $self, $value ) = @_; if ( defined $value ) { $self->throw( "Attempted to change immutable field" ); } return $self->{ "_is_a_relationship" }; } # is_a_relationship =head2 part_of_relationship Title : part_of_relationship() Usage : $PART_OF = $engine->part_of_relationship(); Function: Returns a Bio::Ontology::RelationshipType object for "part-of" relationships Returns : Bio::Ontology::RelationshipType set to "PART_OF" Args : =cut sub part_of_relationship { my ( $self, $value ) = @_; if ( defined $value ) { $self->throw( "Attempted to change immutable field" ); } return $self->{ "_part_of_relationship" }; } # part_of_relationship =head2 related_to_relationship Title : related_to_relationship() Usage : $RELATED_TO = $engine->related_to_relationship(); Function: Returns a Bio::Ontology::RelationshipType object for "related-to" relationships Returns : Bio::Ontology::RelationshipType set to "RELATED_TO" Args : =cut sub related_to_relationship { my ( $self, $value ) = @_; if ( defined $value ) { $self->throw( "Attempted to change immutable field" ); } return $self->{ "_related_to_relationship" }; } # related_to_relationship =head2 regulates_relationship Title : regulates_relationship() Usage : $REGULATES = $engine->regulates_relationship(); Function: Returns a Bio::Ontology::RelationshipType object for "regulates" relationships Returns : Bio::Ontology::RelationshipType set to "REGULATES" Args : =cut sub regulates_relationship { my ( $self, $value ) = @_; if ( defined $value ) { $self->throw( "Attempted to change immutable field" ); } return $self->{ "_regulates_relationship" }; } # is_a_relationship =head2 positively_regulates_relationship Title : positively_regulates_relationship() Usage : $REGULATES = $engine->positively_regulates_relationship(); Function: Returns a Bio::Ontology::RelationshipType object for "positively_regulates" relationships Returns : Bio::Ontology::RelationshipType set to "POSITIVELY_REGULATES" Args : =cut sub positively_regulates_relationship { my ( $self, $value ) = @_; if ( defined $value ) { $self->throw( "Attempted to change immutable field" ); } return $self->{ "_positively_regulate" }; } =head2 negatively_regulates_relationship Title : negatively_regulates_relationship() Usage : $REGULATES = $engine->negatively_regulates_relationship(); Function: Returns a Bio::Ontology::RelationshipType object for "negatively_regulates" relationships Returns : Bio::Ontology::RelationshipType set to "POSITIVELY_REGULATES" Args : =cut sub negatively_regulates_relationship { my ( $self, $value ) = @_; if ( defined $value ) { $self->throw( "Attempted to change immutable field" ); } return $self->{ "_negatively_regulate" }; } =head2 add_term Title : add_term Usage : $engine->add_term( $term_obj ); Function: Adds a Bio::Ontology::TermI to this engine Returns : true if the term was added and false otherwise (e.g., if the term already existed in the ontology engine) Args : Bio::Ontology::TermI =cut sub add_term { my ( $self, $term ) = @_; return FALSE if $self->has_term( $term ); my $goid = $self->_get_id($term); $self->graph()->add_vertex( $goid ); $self->graph()->set_vertex_attribute( $goid, TERM, $term ); # NG 05-02-16 return TRUE; } # add_term =head2 has_term Title : has_term Usage : $engine->has_term( $term ); Function: Checks whether this engine contains a particular term Returns : true or false Args : Bio::Ontology::TermI or Term identifier (e.g. "GO:0012345") =cut sub has_term { my ( $self, $term ) = @_; $term = $self->_get_id( $term ); if ( $self->graph()->has_vertex( $term ) ) { return TRUE; } else { return FALSE; } } # has_term =head2 add_relationship_type Title : add_relationship_type Usage : $engine->add_relationship_type( $type_name, $ont ); Function: Adds a new relationship type to the engine. Use get_relationship_type($type_name) to retrieve. Returns : true if successfully added, false otherwise Args : relationship type name to add (scalar) ontology to which to assign the relationship type =cut sub add_relationship_type{ my ($self,@args) = @_; if(scalar(@_) == 3){ my $type_name = $args[0]; my $ont = $args[1]; $self->{ "_extra_relationship_types" }{$type_name} = Bio::Ontology::RelationshipType->get_instance($type_name,$ont); #warn Dumper($self->{"_extra_relationship_types"}{$type_name}); return 1; } return 0; } =head2 get_relationship_type Title : get_relationship_type Usage : $engine->get_relationship_type( $type_name ); Function: Gets a Bio::Ontology::RelationshipI object corresponding to $type_name Returns : a Bio::Ontology::RelationshipI object Args : =cut sub get_relationship_type{ my ($self,$type_name) = @_; return $self->{ "_extra_relationship_types" }{$type_name}; } =head2 add_relationship Title : add_relationship Usage : $engine->add_relationship( $relationship ); $engine->add_relatioship( $subject_term, $predicate_term, $object_term, $ontology ); $engine->add_relatioship( $subject_id, $predicate_id, $object_id, $ontology); Function: Adds a relationship to this engine Returns : true if successfully added, false otherwise Args : The relationship in one of three ways: a) subject (or child) term id, Bio::Ontology::TermI (rel.type), object (or parent) term id, ontology or b) subject Bio::Ontology::TermI, predicate Bio::Ontology::TermI (rel.type), object Bio::Ontology::TermI, ontology or c) Bio::Ontology::RelationshipI-compliant object =cut # term objs or term ids sub add_relationship { my ( $self, $child, $type, $parent, $ont ) = @_; if ( scalar( @_ ) == 2 ) { $self->_check_class( $child, "Bio::Ontology::RelationshipI" ); $type = $child->predicate_term(); $parent = $child->object_term(); $ont = $child->ontology(); $child = $child->subject_term(); } $self->_check_class( $type, "Bio::Ontology::TermI" ); my $parentid = $self->_get_id( $parent ); my $childid = $self->_get_id( $child ); my $g = $self->graph(); $self->add_term($child) unless $g->has_vertex( $childid ); $self->add_term($parent) unless $g->has_vertex( $parentid ); # This prevents multi graphs. if ( $g->has_edge( $parentid, $childid ) ) { return FALSE; } $g->add_edge( $parentid, $childid ); $g->set_edge_attribute( $parentid, $childid, TYPE, $type ); # NG 05-02-16 $g->set_edge_attribute( $parentid, $childid, ONTOLOGY, $ont ); # NG 05-02-16 return TRUE; } # add_relationship =head2 get_relationships Title : get_relationships Usage : $engine->get_relationships( $term ); Function: Returns all relationships of a term, or all relationships in the graph if no term is specified. Returns : Relationship Args : term id or Bio::Ontology::TermI =cut sub get_relationships { my ( $self, $term ) = @_; my $g = $self->graph(); # obtain the ID if term provided my $termid; if($term) { $termid = $self->_get_id( $term ); # check for presence in the graph if ( ! $g->has_vertex( $termid ) ) { $self->throw( "no term with identifier \"$termid\" in ontology" ); } } # now build the relationships my $relfact = $self->relationship_factory(); # we'll build the relationships from edges my @rels = (); my @edges = $termid ? $g->edges_at( $termid ) : $g->edges(); # NG 05-02-13 while(@edges) { my ( $startid, $endid ) = @{ shift @edges }; # NG 05-02-16 my $rel = $relfact->create_object (-subject_term => $self->get_terms($endid), -object_term => $self->get_terms($startid), -predicate_term => $g->get_edge_attribute($startid, $endid, TYPE), -ontology => $g->get_edge_attribute($startid, $endid, ONTOLOGY)); push( @rels, $rel ); } return @rels; } # get_relationships =head2 get_all_relationships Title : get_all_relationships Usage : @rels = $engine->get_all_relationships(); Function: Returns all relationships in the graph. Returns : Relationship Args : =cut sub get_all_relationships { return shift->get_relationships(@_); } # get_all_relationships =head2 get_predicate_terms Title : get_predicate_terms Usage : $engine->get_predicate_terms(); Function: Returns the types of relationships this engine contains Returns : Bio::Ontology::RelationshipType Args : =cut sub get_predicate_terms { my ( $self ) = @_; my @a = ( $self->is_a_relationship(), $self->part_of_relationship(), $self->related_to_relationship(), $self->regulates_relationship(), $self->positively_regulates_relationship(), $self->negatively_regulates_relationship(), ); foreach my $termname (keys %{$self->{ "_extra_relationship_types" }}){ push @a, $self->{ "_extra_relationship_types" }{ $termname }; } return @a; } # get_predicate_terms =head2 get_child_terms Title : get_child_terms Usage : $engine->get_child_terms( $term_obj, @rel_types ); $engine->get_child_terms( $term_id, @rel_types ); Function: Returns the children of this term Returns : Bio::Ontology::TermI Args : Bio::Ontology::TermI, Bio::Ontology::RelationshipType or term id, Bio::Ontology::RelationshipType if NO Bio::Ontology::RelationshipType is indicated: children of ALL types are returned =cut sub get_child_terms { my ( $self, $term, @types ) = @_; return $self->_get_child_parent_terms_helper( $term, TRUE, @types ); } # get_child_terms =head2 get_descendant_terms Title : get_descendant_terms Usage : $engine->get_descendant_terms( $term_obj, @rel_types ); $engine->get_descendant_terms( $term_id, @rel_types ); Function: Returns the descendants of this term Returns : Bio::Ontology::TermI Args : Bio::Ontology::TermI, Bio::Ontology::RelationshipType or term id, Bio::Ontology::RelationshipType if NO Bio::Ontology::RelationshipType is indicated: descendants of ALL types are returned =cut sub get_descendant_terms { my ( $self, $term, @types ) = @_; my %ids = (); my @ids = (); $term = $self->_get_id( $term ); if ( ! $self->graph()->has_vertex( $term ) ) { $self->throw( "Ontology does not contain a term with an identifier of \"$term\"" ); } $self->_get_descendant_terms_helper( $term, \%ids, \@types ); while( ( my $id ) = each ( %ids ) ) { push( @ids, $id ); } return $self->get_terms( @ids ); } # get_descendant_terms =head2 get_parent_terms Title : get_parent_terms Usage : $engine->get_parent_terms( $term_obj, @rel_types ); $engine->get_parent_terms( $term_id, @rel_types ); Function: Returns the parents of this term Returns : Bio::Ontology::TermI Args : Bio::Ontology::TermI, Bio::Ontology::RelationshipType or term id, Bio::Ontology::RelationshipType if NO Bio::Ontology::RelationshipType is indicated: parents of ALL types are returned =cut sub get_parent_terms { my ( $self, $term, @types ) = @_; return $self->_get_child_parent_terms_helper( $term, FALSE, @types ); } # get_parent_terms =head2 get_ancestor_terms Title : get_ancestor_terms Usage : $engine->get_ancestor_terms( $term_obj, @rel_types ); $engine->get_ancestor_terms( $term_id, @rel_types ); Function: Returns the ancestors of this term Returns : Bio::Ontology::TermI Args : Bio::Ontology::TermI, Bio::Ontology::RelationshipType or term id, Bio::Ontology::RelationshipType if NO Bio::Ontology::RelationshipType is indicated: ancestors of ALL types are returned =cut sub get_ancestor_terms { my ( $self, $term, @types ) = @_; my %ids = (); my @ids = (); $term = $self->_get_id( $term ); if ( ! $self->graph()->has_vertex( $term ) ) { $self->throw( "Ontology does not contain a term with an identifier of \"$term\"" ); } $self->_get_ancestor_terms_helper( $term, \%ids, \@types ); while( ( my $id ) = each ( %ids ) ) { push( @ids, $id ); } return $self->get_terms( @ids ); } # get_ancestor_terms =head2 get_leaf_terms Title : get_leaf_terms Usage : $engine->get_leaf_terms(); Function: Returns the leaf terms Returns : Bio::Ontology::TermI Args : =cut sub get_leaf_terms { my ( $self ) = @_; my @a = $self->graph()->sink_vertices(); return $self->get_terms( @a ); } =head2 get_root_terms() Title : get_root_terms Usage : $engine->get_root_terms(); Function: Returns the root terms Returns : Bio::Ontology::TermI Args : =cut sub get_root_terms { my ( $self ) = @_; my @a = $self->graph()->source_vertices(); return $self->get_terms( @a ); } =head2 get_terms Title : get_terms Usage : @terms = $engine->get_terms( "GO:1234567", "GO:2234567" ); Function: Returns term objects with given identifiers Returns : Bio::Ontology::TermI, or the term corresponding to the first identifier if called in scalar context Args : term ids =cut sub get_terms { my ( $self, @ids ) = @_; my @terms = (); foreach my $id ( @ids ) { if ( $self->graph()->has_vertex( $id ) ) { push( @terms, $self->graph()->get_vertex_attribute( $id, TERM ) ); # NG 05-02-16 } } return wantarray ? @terms : shift(@terms); } # get_terms =head2 get_all_terms Title : get_all_terms Usage : $engine->get_all_terms(); Function: Returns all terms in this engine Returns : Bio::Ontology::TermI Args : =cut sub get_all_terms { my ( $self ) = @_; return( $self->get_terms( $self->graph()->vertices() ) ); } # get_all_terms =head2 find_terms Title : find_terms Usage : ($term) = $oe->find_terms(-identifier => "SO:0000263"); Function: Find term instances matching queries for their attributes. This implementation can efficiently resolve queries by identifier. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : Named parameters. The following parameters should be recognized by any implementations: -identifier query by the given identifier -name query by the given name =cut sub find_terms{ my ($self,@args) = @_; my @terms; my ($id,$name) = $self->_rearrange([qw(IDENTIFIER NAME)],@args); if(defined($id)) { @terms = $self->get_terms($id); } else { @terms = $self->get_all_terms(); } if(defined($name)) { @terms = grep { $_->name() eq $name; } @terms; } return @terms; } =head2 find_identically_named_terms Title : find_identically_named_terms Usage : ($term) = $oe->find_identically_named_terms($term0); Function: Find term instances where names match the query term name exactly Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : a Bio::Ontology::TermI object =cut sub find_identically_named_terms{ my ($self,$qterm) = @_; $self->throw("Argument doesn't implement Bio::Ontology::TermI. " . "Bummer." ) unless defined $qterm and $qterm->isa("Bio::Ontology::TermI"); my %matching_terms; foreach my $term ($self->get_all_terms) { $matching_terms{$term->identifier} = $term and next if $term->name eq $qterm->name; } return values %matching_terms; } =head2 find_identical_terms Title : find_identical_terms Usage : ($term) = $oe->find_identical_terms($term0); Function: Find term instances where name or synonym matches the query exactly Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : a Bio::Ontology::TermI object =cut sub find_identical_terms{ my ($self,$qterm) = @_; $self->throw("Argument doesn't implement Bio::Ontology::TermI. " . "Bummer." ) unless defined $qterm and $qterm->isa("Bio::Ontology::TermI"); my %matching_terms; foreach my $qstring ($qterm->name, $qterm->each_synonym) { foreach my $term ($self->get_all_terms) { foreach my $string ( $term->name, $term->each_synonym() ) { $matching_terms{$term->identifier} = $term and next if $string eq $qstring; } } } return values %matching_terms; } =head2 find_similar_terms Title : find_similar_terms Usage : ($term) = $oe->find_similar_terms($term0); Function: Find term instances where name or synonym, or part of one, matches the query. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : a Bio::Ontology::TermI object =cut sub find_similar_terms{ my ($self,$qterm) = @_; $self->throw("Argument doesn't implement Bio::Ontology::TermI. " . "Bummer." ) unless defined $qterm and $qterm->isa("Bio::Ontology::TermI"); my %matching_terms; foreach my $qstring ($qterm->name, $qterm->each_synonym) { foreach my $term ($self->get_all_terms) { foreach my $string ( $term->name, $term->each_synonym() ) { $matching_terms{$term->identifier} = $term and next if $string =~ /\Q$qstring\E/ or $qstring =~ /\Q$string\E/; } } } return values %matching_terms; } =head2 relationship_factory Title : relationship_factory Usage : $fact = $obj->relationship_factory() Function: Get/set the object factory to be used when relationship objects are created by the implementation on-the-fly. Example : Returns : value of relationship_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : on set, a Bio::Factory::ObjectFactoryI compliant object =cut sub relationship_factory{ my $self = shift; return $self->{'relationship_factory'} = shift if @_; return $self->{'relationship_factory'}; } =head2 term_factory Title : term_factory Usage : $fact = $obj->term_factory() Function: Get/set the object factory to be used when term objects are created by the implementation on-the-fly. Note that this ontology engine implementation does not create term objects on the fly, and therefore setting this attribute is meaningless. Example : Returns : value of term_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : on set, a Bio::Factory::ObjectFactoryI compliant object =cut sub term_factory{ my $self = shift; if(@_) { $self->warn("setting term factory, but ".ref($self). " does not create terms on-the-fly"); return $self->{'term_factory'} = shift; } return $self->{'term_factory'}; } =head2 graph Title : graph() Usage : $engine->graph(); Function: Returns the Graph this engine is based on Returns : Graph Args : =cut sub graph { my ( $self, $value ) = @_; if ( defined $value ) { $self->_check_class( $value, 'Bio::Ontology::SimpleGOEngine::GraphAdaptor' ); # NG 05-02-16 $self->{ "_graph" } = $value; } return $self->{ "_graph" }; } # graph # Internal methods # ---------------- # Checks the correct format of a GOBO-formatted id # Gets the id out of a term or id string sub _get_id { my ( $self, $term ) = @_; my $id = $term; if ( ref($term) ) { # use TermI standard API $self->throw( "Object doesn't implement Bio::Ontology::TermI. " . "Bummer." ) unless $term->isa("Bio::Ontology::TermI"); $id = $term->identifier(); # if there is no ID, we need to fake one from ontology name and name # in order to achieve uniqueness if ( !$id ) { $id = $term->ontology->name() if $term->ontology(); $id = $id ? $id . '|' : ''; $id .= $term->name(); } } return $id # if $term->isa("Bio::Ontology::GOterm")||($id =~ /^[A-Z_]{1,8}:\d{1,}$/); if $term->isa("Bio::Ontology::OBOterm") || ( $id =~ /^\w+:\w+$/ ); # prefix with something if only numbers # if($id =~ /^\d+$/) { # $self->warn(ref($self).": identifier [$id] is only numbers - ". # "prefixing with 'GO:'"); # return "GO:" . $id; # } # we shouldn't have gotten here if it's at least a remotely decent ID $self->throw( ref($self) . ": non-standard identifier '$id'\n" ) unless $id =~ /\|/; return $id; } # _get_id # Helper for getting children and parent terms sub _get_child_parent_terms_helper { my ( $self, $term, $do_get_child_terms, @types ) = @_; foreach my $type ( @types ) { $self->_check_class( $type, "Bio::Ontology::TermI" ); } my @relative_terms = (); $term = $self->_get_id( $term ); if ( ! $self->graph()->has_vertex( $term ) ) { $self->throw( "Ontology does not contain a term with an identifier of \"$term\"" ); } my @all_relative_terms = (); if ( $do_get_child_terms ) { @all_relative_terms = $self->graph()->successors( $term ); } else { @all_relative_terms = $self->graph()->predecessors( $term ); } foreach my $relative ( @all_relative_terms ) { if ( scalar( @types ) > 0 ) { foreach my $type ( @types ) { my $relative_type; if ( $do_get_child_terms ) { $relative_type = $self->graph()->get_edge_attribute ($term, $relative, TYPE ); # NG 05-02-16 } else { $relative_type = $self->graph()->get_edge_attribute ($relative, $term, TYPE ); # NG 05-02-16 } if ( $relative_type->equals( $type ) ) { push( @relative_terms, $relative ); } } } else { push( @relative_terms, $relative ); } } return $self->get_terms( @relative_terms ); } # get_child_terms # Recursive helper sub _get_descendant_terms_helper { my ( $self, $term, $ids_ref, $types_ref ) = @_; my @child_terms = $self->get_child_terms( $term, @$types_ref ); if ( scalar( @child_terms ) < 1 ) { return; } foreach my $child_term ( @child_terms ) { my $child_term_id = $self->_get_id($child_term->identifier()); $ids_ref->{ $child_term_id } = 0; $self->_get_descendant_terms_helper( $child_term_id, $ids_ref, $types_ref ); } } # _get_descendant_terms_helper # Recursive helper sub _get_ancestor_terms_helper { my ( $self, $term, $ids_ref, $types_ref ) = @_; my @parent_terms = $self->get_parent_terms( $term, @$types_ref ); if ( scalar( @parent_terms ) < 1 ) { return; } foreach my $parent_term ( @parent_terms ) { my $parent_term_id = $self->_get_id($parent_term->identifier()); $ids_ref->{ $parent_term_id } = 0; $self->_get_ancestor_terms_helper( $parent_term_id, $ids_ref, $types_ref ); } } # get_ancestor_terms_helper sub _check_class { my ( $self, $value, $expected_class ) = @_; if ( ! defined( $value ) ) { $self->throw( "Found [undef] where [$expected_class] expected" ); } elsif ( ! ref( $value ) ) { $self->throw( "Found [scalar] where [$expected_class] expected" ); } elsif ( ! $value->isa( $expected_class ) ) { $self->throw( "Found [" . ref( $value ) . "] where [$expected_class] expected" ); } } # _check_class ################################################################# # aliases ################################################################# *get_relationship_types = \&get_predicate_terms; 1; BioPerl-1.6.923/Bio/Ontology/OBOterm.pm000444000765000024 604112254227317 17632 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::Ontology::OBOterm - representation of OBO terms =head1 SYNOPSIS $term = Bio::Ontology::OBOterm->new ( -identifier => "GO:0005623", -name => "Cell", -definition => "The basic structural and functional unit ...", -is_obsolete => 0, -comment => "" ); $term->add_reference( @refs ); $term->add_secondary_id( @ids ); $term->add_synonym( @synonym ); # etc. =head1 DESCRIPTION This is data holder class for OBO terms. It is currently a dummy class since we anticipate that the OBO term will become more richer with more features being added to OBO flat-file format. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Sohel Merchant Email: s-merchant@northwestern.edu Address: Northwestern University Center for Genetic Medicine (CGM), dictyBase Suite 1206, 676 St. Clair st Chicago IL 60611 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Ontology::OBOterm; use strict; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::Ontology::Term); =head2 new Title : new Usage : $term = Bio::Ontology::OBOterm->new ( -identifier => "GO:0005623", -name => "Cell", -definition => "The basic structural and functional unit ...", -is_obsolete => 0, -comment => "" ); Function: Creates a new Bio::Ontology::OBOterm. Returns : A new Bio::Ontology::OBOterm object. Args : -identifier => the id of this OBO term [GO:nnnnnnn] integer of seven digits) -name => the name of this OBO term [scalar] -definition => the definition of this OBO term [scalar] -ontology => the ontology for this term (a Bio::Ontology::OntologyI compliant object) -version => version information [scalar] -is_obsolete => the obsoleteness of this OBO term [0 or 1] -comment => a comment [scalar] =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); return $self; } # new 1;BioPerl-1.6.923/Bio/Ontology/Ontology.pm000444000765000024 5564212254227312 20163 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::Ontology # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::Ontology - standard implementation of an Ontology =head1 SYNOPSIS use Bio::Ontology::Ontology; use Bio::Ontology::Term; # create ontology object my $ont = Bio::Ontology::Ontology->new(-name => "OBF"); # add terms, relationships ... my $bp = Bio::Ontology::Term->new(-identifier => '02', -name => "Bioperl"); my $obf = Bio::Ontology::Term->new(-identifier => '01', -name => "OBF"); my $partof = Bio::Ontology::RelationshipType->get_instance("PART_OF"); $ont->add_term($bp); $ont->add_term($obf); $ont->add_relationship($bp, $obf, $partof); # then query my @terms = $ont->get_root_terms(); # "OBF" my @desc = $ont->get_descendant_terms($terms[0], $partof); # "Bioperl" # ... see methods for other ways to query # for advanced users, you can re-use the query engine outside of an # ontology to let one instance manage multiple ontologies my $ont2 = Bio::Ontology::Ontology->new(-name => "Foundations", -engine => $ont->engine()); =head1 DESCRIPTION This is a no-frills implementation of L. The query functions are implemented by delegation to an OntologyEngineI implementation. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::Ontology; use strict; # Object preamble - inherits from Bio::Root::Root #use Bio::Ontology::SimpleOntologyEngine; # loaded dynamically now! use base qw(Bio::Root::Root Bio::Ontology::OntologyI Bio::AnnotatableI); =head2 new Title : new Usage : my $obj = Bio::Ontology::Ontology->new(); Function: Builds a new Bio::Ontology::Ontology object Returns : an instance of Bio::Ontology::Ontology Args : any number of named arguments. The following names will be recognized by this module: -name the name of the ontology -authority the name of the authority for the ontology -identifier an identifier for the ontology, if any -engine the Bio::Ontology::OntologyEngineI implementation that this instance should use; default is Bio::Ontology::SimpleOntologyEngine See the corresponding get/set methods for further documentation on individual properties. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($name,$auth,$def,$id,$engine) = $self->_rearrange([qw(NAME AUTHORITY DEFINITION IDENTIFIER ENGINE) ], @args); defined($name) && $self->name($name); defined($auth) && $self->authority($auth); defined($def) && $self->definition($def); defined($id) && $self->identifier($id); defined($engine) && $self->engine($engine); return $self; } =head1 Methods from L =cut =head2 name Title : name Usage : $obj->name($newval) Function: Get/set the name of the ontology. Example : Returns : value of name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub name{ my $self = shift; return $self->{'name'} = shift if @_; return $self->{'name'}; } =head2 authority Title : authority Usage : $obj->authority($newval) Function: Get/set the authority for this ontology, for instance the DNS base for the organization granting the name of the ontology and identifiers for the terms. This attribute is optional and should not generally expected by applications to have been set. It is here to follow the rules for namespaces, which ontologies serve as for terms. Example : Returns : value of authority (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub authority{ my $self = shift; return $self->{'authority'} = shift if @_; return $self->{'authority'}; } =head2 definition Title : definition Usage : $obj->definition($newval) Function: Get/set a descriptive definition of the ontology. Example : Returns : value of definition (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub definition{ my $self = shift; return $self->{'definition'} = shift if @_; return $self->{'definition'}; } =head2 identifier Title : identifier Usage : $id = $obj->identifier() Function: Get an identifier for this ontology. This is primarily intended for look-up purposes. The value is not modifiable and is determined automatically by the implementation. Also, the identifier's uniqueness will only hold within the scope of a particular application's run time since it is derived from a memory location. Example : Returns : value of identifier (a scalar) Args : =cut sub identifier{ my $self = shift; if(@_) { $self->throw("cannot modify identifier for ".ref($self)) if exists($self->{'identifier'}); my $id = shift; $self->{'identifier'} = $id if $id; } if(! exists($self->{'identifier'})) { ($self->{'identifier'}) = "$self" =~ /(0x[0-9a-fA-F]+)/; } return $self->{'identifier'}; } =head2 close Title : close Usage : Function: Release any resources this ontology may occupy. In order to efficiently release unused memory or file handles, you should call this method once you are finished with an ontology. Example : Returns : TRUE on success and FALSE otherwise Args : none =cut sub close{ my $self = shift; # if it is in the ontology store, remove it from there my $store = Bio::Ontology::OntologyStore->get_instance(); $store->remove_ontology($self); # essentially we need to dis-associate from the engine here $self->engine(undef); return 1; } =head1 Implementation-specific public methods =cut =head2 engine Title : engine Usage : $engine = $obj->engine() Function: Get/set the ontology engine to which all the query methods delegate. Example : Returns : an object implementing Bio::Ontology::OntologyEngineI Args : on set, new value (an object implementing Bio::Ontology::OntologyEngineI, or undef) See L. =cut sub engine{ my $self = shift; if (@_) { my $engine = shift; if($engine && (! (ref($engine) && $engine->isa("Bio::Ontology::OntologyEngineI")))) { $self->throw("object of class ".ref($engine)." does not implement". " Bio::Ontology::OntologyEngineI. Bummer!"); } $self->{'engine'} = $engine; } elsif (! exists($self->{'engine'})) { # instantiate on demand eval { # this introduces a dependency on Graph.pm, so load dynamically require Bio::Ontology::SimpleOntologyEngine; }; if ($@) { $self->throw("failed to load SimpleOntologyEngine, possibly " ."Graph.pm is not installed; either install or supply " ."another OntologyEngineI implementation:\n" .$@); } $self->{'engine'} = Bio::Ontology::SimpleOntologyEngine->new(); } return $self->{'engine'}; } =head1 Methods defined in L =cut =head2 add_term Title : add_term Usage : add_term(TermI term): TermI Function: Adds TermI object to the ontology engine term store If the ontology property of the term object was not set, this implementation will set it to itself upon adding the term. Example : $oe->add_term($term) Returns : its argument. Args : object of class TermI. =cut sub add_term{ my $self = shift; my $term = shift; # set ontology if not set already $term->ontology($self) if $term && (! $term->ontology()); return $self->engine->add_term($term,@_); } =head2 add_relationship Title : add_relationship Usage : add_relationship(RelationshipI relationship): RelationshipI add_relatioship(TermI subject, TermI predicate, TermI object) Function: Adds a relationship object to the ontology engine. Example : Returns : Its argument. Args : A RelationshipI object. =cut sub add_relationship { my $self = shift; my $rel = shift; if($rel && $rel->isa("Bio::Ontology::TermI")) { # we need to construct the relationship object on the fly my ($predicate,$object) = @_; $rel = Bio::Ontology::Relationship->new( -subject_term => $rel, -object_term => $object, -predicate_term => $predicate, -ontology => $self, ); } # set ontology if not set already $rel->ontology($self) unless $rel->ontology(); return $self->engine->add_relationship($rel); } =head2 get_relationship_type Title : get_relationship_type Usage : get_relationship_type(scalar): RelationshipTypeI Function: Get a relationshiptype object from the ontology engine. Example : Returns : A RelationshipTypeI object. Args : The name (scalar) of the RelationshipTypeI object desired. =cut sub get_relationship_type{ my $self = shift; return $self->engine->get_relationship_type(@_); } =head2 get_relationships Title : get_relationships Usage : get_relationships(TermI term): RelationshipI[] Function: Retrieves all relationship objects in the ontology, or all relationships of a given term. Example : Returns : Array of Bio::Ontology::RelationshipI objects Args : Optionally, a Bio::Ontology::TermI compliant object =cut sub get_relationships { my $self = shift; my $term = shift; if($term) { # we don't need to filter in this case return $self->engine->get_relationships($term); } # else we need to filter by ontology return grep { my $ont = $_->ontology; # the first condition is a superset of the second, but # we add it here for efficiency reasons, as many times # it will short-cut to true and is supposedly faster than # string comparison ($ont == $self) || ($ont->name eq $self->name); } $self->engine->get_relationships(@_); } =head2 get_predicate_terms Title : get_predicate_terms Usage : get_predicate_terms(): TermI Function: Retrieves all relationship types. Example : Returns : Array of TermI objects Args : =cut sub get_predicate_terms{ my $self = shift; # skipped Bio::Ontology::Relationship w/o defined Ontology (bug 2573) return grep { $_->ontology && ($_->ontology->name eq $self->name) } $self->engine->get_predicate_terms(@_); } =head2 get_child_terms Title : get_child_terms Usage : get_child_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all child terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_child_terms is a special case of get_descendant_terms, limiting the search to the direct descendants. Note that a returned term may possibly be in another ontology than this one, because the underlying engine may manage multiple ontologies and the relationships of terms between them. If you only want descendants within this ontology, you need to filter the returned array. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_child_terms{ return shift->engine->get_child_terms(@_); } =head2 get_descendant_terms Title : get_descendant_terms Usage : get_descendant_terms(TermI term, TermI rel_types): TermI Function: Retrieves all descendant terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Note that a returned term may possibly be in another ontology than this one, because the underlying engine may manage multiple ontologies and the relationships of terms between them. If you only want descendants within this ontology, you need to filter the returned array. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_descendant_terms{ return shift->engine->get_descendant_terms(@_); } =head2 get_parent_terms Title : get_parent_terms Usage : get_parent_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all parent terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_parent_terms is a special case of get_ancestor_terms, limiting the search to the direct ancestors. Note that a returned term may possibly be in another ontology than this one, because the underlying engine may manage multiple ontologies and the relationships of terms between them. If you only want descendants within this ontology, you need to filter the returned array. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_parent_terms{ return shift->engine->get_parent_terms(@_); } =head2 get_ancestor_terms Title : get_ancestor_terms Usage : get_ancestor_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all ancestor terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Note that a returned term may possibly be in another ontology than this one, because the underlying engine may manage multiple ontologies and the relationships of terms between them. If you only want descendants within this ontology, you need to filter the returned array. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_ancestor_terms{ return shift->engine->get_ancestor_terms(@_); } =head2 get_leaf_terms Title : get_leaf_terms Usage : get_leaf_terms(): TermI Function: Retrieves all leaf terms from the ontology. Leaf term is a term w/o descendants. Example : @leaf_terms = $obj->get_leaf_terms() Returns : Array of TermI objects. Args : =cut sub get_leaf_terms{ my $self = shift; return grep { my $ont = $_->ontology; # the first condition is a superset of the second, but # we add it here for efficiency reasons, as many times # it will short-cut to true and is supposedly faster than # string comparison ($ont == $self) || ($ont->name eq $self->name); } $self->engine->get_leaf_terms(@_); } =head2 get_root_terms() Title : get_root_terms Usage : get_root_terms(): TermI Function: Retrieves all root terms from the ontology. Root term is a term w/o parents. Example : @root_terms = $obj->get_root_terms() Returns : Array of TermI objects. Args : =cut sub get_root_terms{ my $self = shift; return grep { my $ont = $_->ontology; # the first condition is a superset of the second, but # we add it here for efficiency reasons, as many times # it will short-cut to true and is supposedly faster than # string comparison ($ont == $self) || ($ont->name eq $self->name); } $self->engine->get_root_terms(@_); } =head2 get_all_terms Title : get_all_terms Usage : get_all_terms: TermI Function: Retrieves all terms from the ontology. We do not mandate an order here in which the terms are returned. In fact, the default implementation will return them in unpredictable order. Example : @terms = $obj->get_all_terms() Returns : Array of TermI objects. Args : =cut sub get_all_terms{ my $self = shift; return grep { my $ont = $_->ontology; # the first condition is a superset of the second, but # we add it here for efficiency reasons, as many times # it will short-cut to true and is supposedly faster than # string comparison ($ont == $self) || ($ont->name eq $self->name); } $self->engine->get_all_terms(@_); } =head2 find_terms Title : find_terms Usage : ($term) = $oe->find_terms(-identifier => "SO:0000263"); Function: Find term instances matching queries for their attributes. An implementation may not support querying for arbitrary attributes, but can generally be expected to accept -identifier and -name as queries. If both are provided, they are implicitly intersected. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : Named parameters. The following parameters should be recognized by any implementations: -identifier query by the given identifier -name query by the given name =cut sub find_terms{ my $self = shift; return grep { $_->ontology->name eq $self->name; } $self->engine->find_terms(@_); } =head2 find_identical_terms Title : find_identical_terms Usage : ($term) = $oe->find_identical_terms($term0); Function: Find term instances where name or synonym matches the query exactly Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : a Bio::Ontology::TermI object =cut sub find_identical_terms{ my $self = shift; return grep { $_->ontology->name eq $self->name; } $self->engine->find_identical_terms(@_); } =head2 find_similar_terms Title : find_similar_terms Usage : ($term) = $oe->find_similar_terms($term0); Function: Find term instances where name or synonym, or part of one, matches the query. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : a Bio::Ontology::TermI object =cut sub find_similar_terms{ my $self = shift; return grep { $_->ontology->name eq $self->name; } $self->engine->find_similar_terms(@_); } =head2 find_identically_named_terms Title : find_identically_named_terms Usage : ($term) = $oe->find_identically_named_terms($term0); Function: Find term instances where names match the query term name exactly Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : a Bio::Ontology::TermI object =cut sub find_identically_named_terms{ my $self = shift; return grep { $_->ontology->name eq $self->name } $self->engine->find_identically_named_terms(@_); } =head1 Factory for relationships and terms =cut =head2 relationship_factory Title : relationship_factory Usage : $fact = $obj->relationship_factory() Function: Get (and set, if the engine supports it) the object factory to be used when relationship objects are created by the implementation on-the-fly. Example : Returns : value of relationship_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : =cut sub relationship_factory{ return shift->engine->relationship_factory(@_); } =head2 term_factory Title : term_factory Usage : $fact = $obj->term_factory() Function: Get (and set, if the engine supports it) the object factory to be used when term objects are created by the implementation on-the-fly. Example : Returns : value of term_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : =cut sub term_factory{ return shift->engine->term_factory(@_); } =head2 annotation Title : annotation Usage : $annos = $obj->annotation() Function: Get/Set the Bio::Annotation::Collection object The collection contains Bio::Annotation::SimpleValue objects to store header information like the version and date present in the header section of an Ontology file. Example : Returns : value of annotation (a Bio::Annotation::Collection compliant object) Args : A Bio::Annotation::Collection object (Optional) =cut sub annotation{ my $self = shift; $self->{'annotation'} = shift if @_; return $self->{'annotation'}; } ################################################################# # aliases ################################################################# *get_relationship_types = \&get_predicate_terms; 1; BioPerl-1.6.923/Bio/Ontology/OntologyEngineI.pm000444000765000024 3407112254227324 21416 0ustar00cjfieldsstaff000000000000# # BioPerl module for OntologyEngineI # # Please direct questions and support issues to # # Cared for by Peter Dimitrov # # (c) Peter Dimitrov # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::OntologyEngineI - Interface a minimal Ontology implementation should satisfy =head1 SYNOPSIS # see documentation of methods =head1 DESCRIPTION This describes the minimal interface an ontology query engine should provide. It intentionally does not make explicit references to the ontology being a DAG, nor does it mandate that the ontology be a vocabulary. Rather, it tries to generically express what should be accessible (queriable) about an ontology. The idea is to allow for different implementations for different purposes, which may then differ as to which operations are efficient and which are not, and how much richer the functionality is on top of this minimalistic set of methods. Check modules in the Bio::Ontology namespace to find out which implementations exist. At the time of writing, there is a SimpleOntologyEngine (which does not use Graph.pm), and a Graph.pm-based implementation in SimpleGOEngine. Ontology parsers in Bio::OntologyIO are required to return an implementation of this interface. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Dimitrov Email dimitrov@gnf.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::OntologyEngineI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 add_term Title : add_term Usage : add_term(TermI term): TermI Function: Adds TermI object to the ontology engine term store Example : $oe->add_term($term) Returns : its argument. Args : object of class TermI. =cut sub add_term{ shift->throw_not_implemented(); } =head2 add_relationship Title : add_relationship Usage : add_relationship(RelationshipI relationship): RelationshipI Function: Adds a relationship object to the ontology engine. Example : Returns : Its argument. Args : A RelationshipI object. =cut sub add_relationship{ shift->throw_not_implemented(); } =head2 add_relationship_type Title : add_relationship_type Usage : add_relationship_type(scalar,OntologyI ontology) Function: Adds a relationshiptype object to the ontology engine. Example : Returns : 1 on success, undef on failure Args : The name(scalar) of the relationshiptype, and the OntologyI it is to be added to. =cut sub add_relationship_type{ shift->throw_not_implemented(); } =head2 get_relationship_type Title : get_relationship_type Usage : get_relationship_type(scalar): RelationshipTypeI Function: Get a relationshiptype object from the ontology engine. Example : Returns : A RelationshipTypeI object. Args : The name (scalar) of the RelationshipTypeI object desired. =cut sub get_relationship_type{ shift->throw_not_implemented(); } =head2 get_relationships Title : get_relationships Usage : get_relationships(TermI term): RelationshipI Function: Retrieves all relationship objects from this ontology engine, or all relationships of a term if a term is supplied. Example : Returns : Array of Bio::Ontology::RelationshipI objects Args : None, or a Bio::Ontology::TermI compliant object for which to retrieve the relationships. =cut sub get_relationships{ shift->throw_not_implemented(); } =head2 get_predicate_terms Title : get_predicate_terms Usage : get_predicate_terms(): TermI Function: Example : Returns : Args : =cut sub get_predicate_terms{ shift->throw_not_implemented(); } =head2 get_child_terms Title : get_child_terms Usage : get_child_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all child terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_child_terms is a special case of get_descendant_terms, limiting the search to the direct descendants. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_child_terms{ shift->throw_not_implemented(); } =head2 get_descendant_terms Title : get_descendant_terms Usage : get_descendant_terms(TermI term, TermI rel_types): TermI Function: Retrieves all descendant terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_descendant_terms{ shift->throw_not_implemented(); } =head2 get_parent_terms Title : get_parent_terms Usage : get_parent_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all parent terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_parent_terms is a special case of get_ancestor_terms, limiting the search to the direct ancestors. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_parent_terms{ shift->throw_not_implemented(); } =head2 get_ancestor_terms Title : get_ancestor_terms Usage : get_ancestor_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all ancestor terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_ancestor_terms{ shift->throw_not_implemented(); } =head2 get_leaf_terms Title : get_leaf_terms Usage : get_leaf_terms(): TermI Function: Retrieves all leaf terms from the ontology. Leaf term is a term w/o descendants. Example : @leaf_terms = $obj->get_leaf_terms() Returns : Array of TermI objects. Args : =cut sub get_leaf_terms{ shift->throw_not_implemented(); } =head2 get_root_terms Title : get_root_terms Usage : get_root_terms(): TermI Function: Retrieves all root terms from the ontology. Root term is a term w/o ancestors. Example : @root_terms = $obj->get_root_terms() Returns : Array of TermI objects. Args : =cut sub get_root_terms{ shift->throw_not_implemented(); } =head1 Factory for relationships and terms =cut =head2 relationship_factory Title : relationship_factory Usage : $fact = $obj->relationship_factory() Function: Get (and set, if the implementation supports it) the object factory to be used when relationship objects are created by the implementation on-the-fly. Example : Returns : value of relationship_factory (a Bio::Factory::ObjectFactory compliant object) Args : =cut sub relationship_factory{ return shift->throw_not_implemented(); } =head2 term_factory Title : term_factory Usage : $fact = $obj->term_factory() Function: Get (and set, if the implementation supports it) the object factory to be used when term objects are created by the implementation on-the-fly. Example : Returns : value of term_factory (a Bio::Factory::ObjectFactory compliant object) Args : =cut sub term_factory{ return shift->throw_not_implemented(); } =head1 Decorator Methods These methods come with a default implementation that uses the abstract methods defined for this interface. This may not be very efficient, and hence implementors are encouraged to override these methods if they can provide more efficient implementations. =cut =head2 get_all_terms Title : get_all_terms Usage : get_all_terms: TermI Function: Retrieves all terms from the ontology. This is more a decorator method. We provide a default implementation here that loops over all root terms and gets all descendants for each root term. The overall union of terms is then made unique by name and ontology. We do not mandate an order here in which the terms are returned. In fact, the default implementation will return them in unpredictable order. Engine implementations that can provide a more efficient method for obtaining all terms should definitely override this. Example : @terms = $obj->get_all_terms() Returns : Array of TermI objects. Args : =cut sub get_all_terms{ my $self = shift; # get all root nodes my @roots = $self->get_root_terms(); # accumulate all descendants for each root term my @terms = map { $self->get_descendant_terms($_); } @roots; # add on the root terms themselves push(@terms, @roots); # make unique by name and ontology my %name_map = map { ($_->name."@".$_->ontology->name, $_); } @terms; # done return values %name_map; } =head2 find_terms Title : find_terms Usage : ($term) = $oe->find_terms(-identifier => "SO:0000263"); Function: Find term instances matching queries for their attributes. An implementation may not support querying for arbitrary attributes, but can generally be expected to accept -identifier and -name as queries. If both are provided, they are implicitly intersected. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : Named parameters. The following parameters should be recognized by any implementation: -identifier query by the given identifier -name query by the given name =cut sub find_terms{ my $self = shift; my %params = @_; @params{ map { lc $_; } keys %params } = values %params; # lowercase keys my @terms = grep { my $ok = exists($params{-identifier}) ? $_->identifier() eq $params{-identifier} : 1; $ok && ((! exists($params{-name})) || ($_->name() eq $params{-name})); } $self->get_all_terms(); return @terms; } =head1 Experimental API method proposals Ontologies are a very new domain in bioperl, and we are not sure yet what we will want to do on and with ontologies in which situation. The methods from here on downwards are solely API descriptions to solicit comment and feedback; the chance of any of those being actually implemented already is very slim. Disclaimer: As long as an API method stays in this section, it is subject to change, possibly even radical change or complete deletion. If it's not implemented yet (most likely it isn't), implement yourself at your own risk. So far for the disclaimer. The reason the API description is here, however, is to solicit feedback. Please feel encouraged to share your opinion, regardless of what it is (a notable difference of this API method to others is that there is actually no working code behind it - so the defense line is non-existent for practical purposes). =cut =head2 common_ancestor_path Title : common_ancestor_path Usage : Function: Get the paths from two terms A and B to term C, such that there is no other term D to which A and B would have a shorter path, provided there is a term C to which both A and B are connected by a path. Note that the path to the common ancestor between A and A exists, has distance zero, and predicate "identity". The search for the common ancestor C can be further constrained by supplying a predicate term. If supplied, the predicates of the two paths (A,C) and (B,C) must have a common ancestor identical to the predicate, or that has a path to the predicate. Example : Returns : The path of the first term to the common ancestor in scalar context, and both paths in list context. Paths are Bio::Ontology::PathI compliant objects. Args : The two terms (Bio::Ontology::TermI objects), and optionally a constraining common predicate (Bio::Ontology::TermI object). The latter may also be given as a scalar, in which case it is treated as a boolean that, if TRUE, means that the two paths must have identical predicates in order to be returned. =cut sub common_ancestor_path{ return shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Ontology/OntologyI.pm000444000765000024 2556512254227316 20301 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::OntologyI # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::OntologyI - Interface for an ontology implementation =head1 SYNOPSIS # see method documentation =head1 DESCRIPTION This describes the minimal interface an ontology implementation must provide. In essence, it represents a namespace with description on top of the query interface OntologyEngineI. This interface inherits from L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::OntologyI; use strict; use base qw(Bio::Ontology::OntologyEngineI); =head1 Methods defined in this interface. =cut =head2 name Title : name Usage : $obj->name($newval) Function: Get/set the name of this ontology. Example : Returns : value of name (a scalar) Args : =cut sub name{ shift->throw_not_implemented(); } =head2 authority Title : authority Usage : $auth = $obj->authority() Function: Get/set the authority for this ontology, for instance the DNS base for the organization granting the name of the ontology and identifiers for the terms. This attribute is optional and should not generally expected by applications to have been set. It is here to follow the rules for namespaces, which ontologies serve as for terms. Example : Returns : value of authority (a scalar) Args : =cut sub authority{ shift->throw_not_implemented(); } =head2 identifier Title : identifier Usage : $id = $obj->identifier() Function: Get an identifier for this ontology. This is primarily intended for look-up purposes. Clients should not expect the value to be modifiable, and it may not be allowed to set its value from outside. Also, the identifier's uniqueness may only hold within the scope of a particular application's run time, i.e., it may be a memory location. Example : Returns : value of identifier (a scalar) Args : =cut sub identifier{ shift->throw_not_implemented(); } =head2 definition Title : definition Usage : $def = $obj->definition() Function: Get a descriptive definition for this ontology. Example : Returns : value of definition (a scalar) Args : =cut sub definition{ shift->throw_not_implemented(); } =head2 close Title : close Usage : Function: Release any resources this ontology may occupy. In order to efficiently release used memory or file handles, you should call this method once you are finished with an ontology. Example : Returns : TRUE on success and FALSE otherwise Args : none =cut sub close{ shift->throw_not_implemented(); } =head1 Methods inherited from L Their documentations are copied here for completeness. In most use cases, you will want to access the query methods of an ontology, not just the name and description ... =cut =head2 add_term Title : add_term Usage : add_term(TermI term): TermI Function: Adds TermI object to the ontology engine term store. For ease of use, if the ontology property of the term object was not set, an implementation is encouraged to set it to itself upon adding the term. Example : $oe->add_term($term) Returns : its argument. Args : object of class TermI. =cut =head2 add_relationship Title : add_relationship Usage : add_relationship(RelationshipI relationship): RelationshipI Function: Adds a relationship object to the ontology engine. Example : Returns : Its argument. Args : A RelationshipI object. =cut =head2 get_relationships Title : get_relationships Usage : get_relationships(TermI term): RelationshipI Function: Retrieves all relationship objects from this ontology engine, or all relationships of a term if a term is supplied. Example : Returns : Array of Bio::Ontology::RelationshipI objects Args : None, or a Bio::Ontology::TermI compliant object for which to retrieve the relationships. =cut =head2 get_predicate_terms Title : get_predicate_terms Usage : get_predicate_terms(): TermI[] Function: Example : Returns : Args : =cut =head2 get_child_terms Title : get_child_terms Usage : get_child_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all child terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_child_terms is a special case of get_descendant_terms, limiting the search to the direct descendants. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut =head2 get_descendant_terms Title : get_descendant_terms Usage : get_descendant_terms(TermI term, TermI rel_types): TermI Function: Retrieves all descendant terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut =head2 get_parent_terms Title : get_parent_terms Usage : get_parent_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all parent terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_parent_terms is a special case of get_ancestor_terms, limiting the search to the direct ancestors. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut =head2 get_ancestor_terms Title : get_ancestor_terms Usage : get_ancestor_terms(TermI term, TermI predicate_terms): TermI Function: Retrieves all ancestor terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut =head2 get_leaf_terms Title : get_leaf_terms Usage : get_leaf_terms(): TermI Function: Retrieves all leaf terms from the ontology. Leaf term is a term w/o descendants. Example : @leaf_terms = $obj->get_leaf_terms() Returns : Array of TermI objects. Args : =cut =head2 get_root_terms() Title : get_root_terms Usage : get_root_terms(): TermI Function: Retrieves all root terms from the ontology. Root term is a term w/o descendants. Example : @root_terms = $obj->get_root_terms() Returns : Array of TermI objects. Args : =cut =head2 get_all_terms Title : get_all_terms Usage : get_all_terms: TermI Function: Retrieves all terms from the ontology. We do not mandate an order here in which the terms are returned. In fact, the default implementation will return them in unpredictable order. Example : @terms = $obj->get_all_terms() Returns : Array of TermI objects. Args : =cut =head2 find_terms Title : find_terms Usage : ($term) = $oe->find_terms(-identifier => "SO:0000263"); Function: Find term instances matching queries for their attributes. An implementation may not support querying for arbitrary attributes, but can generally be expected to accept -identifier and -name as queries. If both are provided, they are implicitly intersected. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : Named parameters. The following parameters should be recognized by any implementation: -identifier query by the given identifier -name query by the given name =cut =head1 Factory for relationships and terms =cut =head2 relationship_factory Title : relationship_factory Usage : $fact = $obj->relationship_factory() Function: Get (and set, if the implementation supports it) the object factory to be used when relationship objects are created by the implementation on-the-fly. Example : Returns : value of relationship_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : =cut sub relationship_factory{ return shift->throw_not_implemented(); } =head2 term_factory Title : term_factory Usage : $fact = $obj->term_factory() Function: Get (and set, if the implementation supports it) the object factory to be used when term objects are created by the implementation on-the-fly. Example : Returns : value of term_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : =cut sub term_factory{ return shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Ontology/OntologyStore.pm000444000765000024 2375212254227324 21200 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::OntologyStore # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::OntologyStore - A repository of ontologies =head1 SYNOPSIS #---------- #SCENARIO 1 #---------- #make an ontology object manually. via OntologyIO my $io = Bio::OntologyIO->new( #params to fetch Cell Ontology here ); my $cell_ontology = $io->next_ontology; #this is a singleton that caches the fact that you've created #a 'Cell Ontology' intance... my $store = Bio::Ontology::OntologyStore->get_instance(); #...and it can hand you back a copy of it at any time. my $cell_ontology_copy = $store->get_ontology('Cell Ontology'); #---------- #SCENARIO 2 #---------- my $store = Bio::Ontology::OntologyStore->get_instance(); #this use case allows the construction of an ontology on #demand just by supplying the name. my $ontology = $store->get_ontology('Sequence Ontology'); =head1 DESCRIPTION The primary purpose of this module is that of a singleton repository of L instances from which an Ontology instance can be retrieved by name or identifier. This enables TermI implementations to return their corresponding OntologyI through using this singleton store instead of storing a direct reference to the Ontology object. The latter would almost inevitably lead to memory cycles, and would therefore potentially blow up an application. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Hilmar Lapp Ehlapp@gmx.netE Allen Day Eallenday@ucla.eduE =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::OntologyStore; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Ontology::DocumentRegistry; use Bio::OntologyIO; use FileHandle; use File::Spec::Functions; use base qw(Bio::Root::Root); # these are the static ontology stores by name and by identifier - there is # only one of each in any application my %ont_store_by_name = (); my %ont_store_by_id = (); my %ont_aliases = ( 'Gene Ontology' => 'Gene_Ontology' ); # also, this is really meant as a singleton object, so we try to enforce it my $instance = undef; =head2 new Title : new Usage : my $obj = Bio::Ontology::OntologyStore->new(); Function: Returns the Bio::Ontology::OntologyStore object. Unlike usual implementations of new, this implementation will try to return a previously instantiated store, if there is any. It is just a synonym for get_instance. In order to avoid ambiguities in your code, you may rather want to call rather get_instance explicitly, which also usually is better associated with this kind of behaviour. Returns : an instance of Bio::Ontology::OntologyStore Args : =cut sub new { return shift->get_instance(@_); } =head2 get_instance Title : get_instance Usage : Function: Get an instance of this class for perusal. Since by design this class is meant to be used as a singleton, the implementation will return a previously instantianted store if there is one, and instantiate a new one otherwise. In order to use this class by means of an instance, call this method for added code clarity, not new(). Example : Returns : an instance of this class Args : named parameters, if any (currently, there are no class-specific parameters other than those accepted by Bio::Root::Root. See L. =cut sub get_instance{ my ($self,@args) = @_; if(! $instance) { $instance = $self->SUPER::new(@args); } return $instance; } =head2 get_ontology Title : get_ontology Usage : Function: Get a previously instantiated and registered instance of this class by name or by identifier. One of the main purposes of this class is to enable TermI implementations to return their respective ontology without keeping a strong reference to the respective ontology object. Only objects previously registered objects can be retrieved. This is a class method, hence you can call it on the class name, without dereferencing an object. Example : Returns : a Bio::Ontology::OntologyI implementing object, or undef if the query could not be satisfied Args : Named parameters specifying the query. The following parameters are recognized: -name query the store for an ontology with the given name -id query for an ontology with the given identifier If both are specified, an implicit AND logical operator is assumed. See L. =cut sub get_ontology{ my ($self,@args) = @_; my $ont; my ($name,$id) = $self->_rearrange([qw(NAME ID)], @args); if($id) { $ont = $ont_store_by_id{$id}; return unless $ont; # no AND can be satisfied in this case } if($name) { my $o = $ont_store_by_name{$name}; if(!$o){ my $doc_registry = Bio::Ontology::DocumentRegistry->get_instance(); my($url,$def,$fmt) = $doc_registry->documents($name); if(ref($url) eq 'ARRAY'){ my $io = Bio::OntologyIO->new(-url => $url, -defs_url => $def, -format => $fmt, ); $o = $io->next_ontology(); $ont_store_by_name{$name} = $o; } elsif($url){ my $io = Bio::OntologyIO->new(-url => $url, -defs_url => $def, -format => $fmt, ); $o = $io->next_ontology; $ont_store_by_name{$name} = $o; } } if((! $ont) || ($ont->identifier() eq $o->identifier())) { $ont = $o; } else { $ont = undef; } } return $ont; } =head2 register_ontology Title : register_ontology Usage : Function: Registers the given Ontology object for later retrieval by name and identifier. Example : Returns : TRUE on success and FALSE otherwise Args : the Bio::Ontology::OntologyI object(s) to register See L. =cut sub register_ontology { my ($self,@args) = @_; my $ret = 1; foreach my $ont (@args) { if(ref($ont) && $ont->isa('Bio::Ontology::OntologyI')){ $ont_store_by_name{$ont->name()} = $ont if $ont->name; next; } if(! (ref($ont) && $ont->isa("Bio::Ontology::OntologyI"))) { $self->throw((ref($ont) ? ref($ont) : $ont)." does not implement ". "Bio::Ontology::OntologyI or is not an object"); } if($self->get_ontology(-name => $ont->name())) { $self->warn("ontology with name \"".$ont->name(). "\" already exists in the store, ignoring new one"); $ret = 0; next; } if($self->get_ontology(-id => $ont->identifier())) { $self->warn("ontology with id \"".$ont->identifier(). "\" already exists in the store, ignoring new one"); $ret = 0; next; } $ont_store_by_name{$ont->name()} = $ont; $ont_store_by_id{$ont->identifier()} = $ont; } return $ret; } =head2 remove_ontology Title : remove_ontology Usage : Function: Remove the specified ontology from the store. Example : Returns : TRUE on success and FALSE otherwise Args : the Bio::Ontology::OntologyI implementing object(s) to be removed from the store See L. =cut sub remove_ontology{ my $self = shift; my $ret = 1; foreach my $ont (@_) { $self->throw(ref($ont)." does not implement Bio::Ontology::OntologyI") unless $ont && ref($ont) && $ont->isa("Bio::Ontology::OntologyI"); # remove it from both the id hash and the name hash delete $ont_store_by_id{$ont->identifier()}; delete $ont_store_by_name{$ont->name()} if $ont->name(); } return 1; } =head2 guess_ontology() Usage : my $ontology = Bio::Ontology::OntologyStore->guess_ontology('GO:0000001'); Function: tries to guess which ontology a term identifier comes from, loads it as necessary, and returns it as a Bio::Ontology::Ontology object. Example : Returns : a Bio::Ontology::Ontology object, or warns and returns undef Args : an ontology term identifier in XXXX:DDDDDDD format. Guessing is based on the XXXX string before the colon. =cut sub guess_ontology { my ($self,$id) = @_; my($prefix) = $id =~ /^(.+?):.+$/; my %prefix = ( SO => 'Sequence Ontology', SOFA => 'Sequence Ontology Feature Annotation', GO => 'Gene Ontology', ); return $prefix{$prefix} || undef; } 1; BioPerl-1.6.923/Bio/Ontology/Path.pm000444000765000024 1211312254227322 17230 0ustar00cjfieldsstaff000000000000# # BioPerl module for Path # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::Path - a path for an ontology term graph =head1 SYNOPSIS $path = Bio::Ontology::Path->new( -identifier => "16847", -subject_term => $subj, -object_term => $obj, -predicate_term => $pred, -distance => 3 ); =head1 DESCRIPTION This is a basic implementation of Bio::Ontology::PathI. Essiantially this is a very thin extension of L. It basically adds a method distance(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Hilmar Lapp =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::Path; use strict; use base qw(Bio::Ontology::Relationship Bio::Ontology::PathI); =head2 new Title : new Usage : $rel = Bio::Ontology::Path->new(-identifier => "16847", -subject_term => $subject, -object_term => $object, -predicate_term => $type ); -distance => 3 ); Function: Creates a new Bio::Ontology::Path. Returns : A new Bio::Ontology::Path object. Args : -identifier => the identifier of this relationship [scalar] -subject_term => the subject term [Bio::Ontology::TermI] -object_term => the object term [Bio::Ontology::TermI] -predicate_term => the predicate term [Bio::Ontology::TermI] -distance => the distance between subject and object =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $distance ) = $self->_rearrange( [qw( DISTANCE) ], @args ); $distance && $self->distance($distance); return $self; } # new =head2 init Title : init() Usage : $rel->init(); Function: Initializes this Path to all undef. Returns : Args : =cut sub init { my $self = shift; $self->SUPER::init(@_); $self->{ "_distance" } = undef; } # init =head2 distance Title : distance Usage : $obj->distance($newval) Function: Get/set the distance between the two terms connected by this path. Note that modifying the distance may not be meaningful. The implementation here is not connected to any graph engine, so changing an existing value may simply render the attribute's value wrong. Example : Returns : value of distance (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub distance{ my $self = shift; return $self->{'_distance'} = shift if @_; return $self->{'_distance'}; } =head2 to_string Title : to_string() Usage : print $rel->to_string(); Function: to_string method for Path. Returns : A string representation of this Path. Args : =cut sub to_string { my( $self ) = @_; my $s = $self->SUPER::to_string(); $s .= "-- Distance:\n"; $s .= $self->distance() if defined($self->distance()); $s .= "\n"; return $s; } # to_string 1; BioPerl-1.6.923/Bio/Ontology/PathI.pm000444000765000024 1113612254227312 17344 0ustar00cjfieldsstaff000000000000# # BioPerl module for PathI # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::PathI - Interface for a path between ontology terms =head1 SYNOPSIS # see documentation of methods and an implementation, e.g., # Bio::Ontology::Path =head1 DESCRIPTION This is the minimal interface for a path between two terms in an ontology. Ontology engines may use this. Essentially this is a very thin extension of the L interface. It basically adds an attribute distance(). For a RelationshipI, you can think of distance as equal to zero (subject == object) or 1 (subject != object). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::PathI; use strict; use base qw(Bio::Ontology::RelationshipI); =head2 distance Title : distance Usage : $obj->distance($newval) Function: Get (and set if the implementation allows it) the distance between the two terms connected by this path. Example : Returns : value of distance (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub distance{ return shift->throw_not_implemented(); } =head1 Bio::Ontology::RelationshipI Methods =cut =head2 subject_term Title : subject_term Usage : $subj = $rel->subject_term(); Function: Set/get for the subject term of this Relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The subject term [Bio::Ontology::TermI]. Args : =cut =head2 object_term Title : object_term Usage : $object = $rel->object_term(); Function: Set/get for the object term of this Relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The object term [Bio::Ontology::TermI]. Args : =cut =head2 predicate_term Title : predicate_term Usage : $type = $rel->predicate_term(); Function: Set/get for the predicate of this relationship. For a path the predicate (relationship type) is defined as the greatest common denominator of all predicates (relationship types) encountered along the path. I.e., if predicate A is-a predicate B, the greatest common denominator for a path containing both predicates A and B is B Returns : The predicate term [Bio::Ontology::TermI]. Args : =cut =head2 ontology Title : ontology Usage : $ont = $obj->ontology() Function: Get the ontology that defined this relationship. Example : Returns : an object implementing Bio::Ontology::OntologyI Args : See L. =cut 1; BioPerl-1.6.923/Bio/Ontology/Relationship.pm000444000765000024 2541112254227325 21005 0ustar00cjfieldsstaff000000000000# # BioPerl module for Relationship # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::Relationship - a relationship for an ontology =head1 SYNOPSIS $rel = Bio::Ontology::Relationship->new( -identifier => "16847", -subject_term => $subj, -object_term => $obj, -predicate_term => $pred ); =head1 DESCRIPTION This is a basic implementation of Bio::Ontology::RelationshipI. The terminology we use here is the one commonly used for ontologies, namely the triple of (subject, predicate, object), which in addition is scoped in a namespace (ontology). It is called triple because it is a tuple of three ontology terms. There are other terminologies in use for expressing relationships. For those who it helps to better understand the concept, the triple of (child, relationship type, parent) would be equivalent to the terminology chosen here, disregarding the question whether the notion of parent and child is sensible in the context of the relationship type or not. Especially in the case of ontologies with a wide variety of predicates the parent/child terminology and similar ones can quickly become ambiguous (e.g., A synthesises B), meaningless (e.g., A binds B), or even conflicting (e.g., A is-parent-of B), and are therefore strongly discouraged. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 CONTRIBUTORS Hilmar Lapp, email: hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::Relationship; use strict; use Bio::Ontology::TermI; use base qw(Bio::Root::Root Bio::Ontology::RelationshipI); =head2 new Title : new Usage : $rel = Bio::Ontology::Relationship->new(-identifier => "16847", -subject_term => $subject, -object_term => $object, -predicate_term => $type ); Function: Creates a new Bio::Ontology::Relationship. Returns : A new Bio::Ontology::Relationship object. Args : -identifier => the identifier of this relationship [scalar] -subject_term => the subject term [Bio::Ontology::TermI] -object_term => the object term [Bio::Ontology::TermI] -predicate_term => the predicate term [Bio::Ontology::TermI] =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $identifier, $subject_term, $child, # for backwards compatibility $object_term, $parent, # for backwards compatibility $predicate_term, $reltype, # for backwards compatibility $ont) = $self->_rearrange( [qw( IDENTIFIER SUBJECT_TERM CHILD_TERM OBJECT_TERM PARENT_TERM PREDICATE_TERM RELATIONSHIP_TYPE ONTOLOGY) ], @args ); $self->init(); $self->identifier( $identifier ); $subject_term = $child unless $subject_term; $object_term = $parent unless $object_term; $predicate_term = $reltype unless $predicate_term; $self->subject_term( $subject_term) if $subject_term; $self->object_term( $object_term) if $object_term; $self->predicate_term( $predicate_term ) if $predicate_term; $self->ontology($ont) if $ont; return $self; } # new =head2 init Title : init() Usage : $rel->init(); Function: Initializes this Relationship to all undef. Returns : Args : =cut sub init { my( $self ) = @_; $self->{ "_identifier" } = undef; $self->{ "_subject_term" } = undef; $self->{ "_object_term" } = undef; $self->{ "_predicate_term" } = undef; $self->ontology(undef); } # init =head2 identifier Title : identifier Usage : $rel->identifier( "100050" ); or print $rel->identifier(); Function: Set/get for the identifier of this Relationship. Returns : The identifier [scalar]. Args : The identifier [scalar] (optional). =cut sub identifier { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_identifier" } = $value; } return $self->{ "_identifier" }; } # identifier =head2 subject_term Title : subject_term Usage : $rel->subject_term( $subject ); or $subject = $rel->subject_term(); Function: Set/get for the subject term of this Relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The subject term [Bio::Ontology::TermI]. Args : The subject term [Bio::Ontology::TermI] (optional). =cut sub subject_term { my ( $self, $term ) = @_; if ( defined $term ) { $self->_check_class( $term, "Bio::Ontology::TermI" ); $self->{ "_subject_term" } = $term; } return $self->{ "_subject_term" }; } # subject_term =head2 object_term Title : object_term Usage : $rel->object_term( $object ); or $object = $rel->object_term(); Function: Set/get for the object term of this Relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The object term [Bio::Ontology::TermI]. Args : The object term [Bio::Ontology::TermI] (optional). =cut sub object_term { my ( $self, $term ) = @_; if ( defined $term ) { $self->_check_class( $term, "Bio::Ontology::TermI" ); $self->{ "_object_term" } = $term; } return $self->{ "_object_term" }; } =head2 predicate_term Title : predicate_term Usage : $rel->predicate_term( $type ); or $type = $rel->predicate_term(); Function: Set/get for the predicate (relationship type) of this relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The predicate term [Bio::Ontology::TermI]. Args : The predicate term [Bio::Ontology::TermI] (optional). =cut sub predicate_term { my ( $self, $term ) = @_; if ( defined $term ) { $self->_check_class( $term, "Bio::Ontology::TermI" ); $self->{ "_predicate_term" } = $term; } return $self->{ "_predicate_term" }; } =head2 ontology Title : ontology Usage : $ont = $obj->ontology() Function: Get/set the ontology that defined this relationship. Example : Returns : an object implementing L Args : on set, undef or an object implementing Bio::Ontology::OntologyI (optional) See L. =cut sub ontology{ my $self = shift; my $ont; if(@_) { $ont = shift; if($ont) { $ont = Bio::Ontology::Ontology->new(-name => $ont) if ! ref($ont); if(! $ont->isa("Bio::Ontology::OntologyI")) { $self->throw(ref($ont)." does not implement ". "Bio::Ontology::OntologyI. Bummer."); } } return $self->{"_ontology"} = $ont; } return $self->{"_ontology"}; } =head2 to_string Title : to_string() Usage : print $rel->to_string(); Function: to_string method for Relationship. Returns : A string representation of this Relationship. Args : =cut sub to_string { my( $self ) = @_; local $^W = 0; my $s = ""; $s .= "-- Identifier:\n"; $s .= $self->identifier()."\n"; $s .= "-- Subject Term Identifier:\n"; $s .= $self->subject_term()->identifier()."\n"; $s .= "-- Object Term Identifier:\n"; $s .= $self->object_term()->identifier()."\n"; $s .= "-- Relationship Type Identifier:\n"; $s .= $self->predicate_term()->identifier(); return $s; } # to_string sub _check_class { my ( $self, $value, $expected_class ) = @_; if ( ! defined( $value ) ) { $self->throw( "Found [undef] where [$expected_class] expected" ); } elsif ( ! ref( $value ) ) { $self->throw( "Found [scalar] where [$expected_class] expected" ); } elsif ( ! $value->isa( $expected_class ) ) { $self->throw( "Found [" . ref( $value ) . "] where [$expected_class] expected" ); } } # _check_type ################################################################# # aliases for backwards compatibility ################################################################# =head1 Deprecated Methods These methods are deprecated and defined here solely to preserve backwards compatibility. =cut *child_term = \&subject_term; *parent_term = \&object_term; *relationship_type = \&predicate_term; 1; BioPerl-1.6.923/Bio/Ontology/RelationshipFactory.pm000444000765000024 706312254227324 22317 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::RelationshipFactory # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::RelationshipFactory - Instantiates a new Bio::Ontology::RelationshipI (or derived class) through a factory =head1 SYNOPSIS use Bio::Ontology::RelationshipFactory; # the default type is Bio::Ontology::Relationship my $factory = Bio::Ontology::RelationshipFactory->new( -type => 'Bio::Ontology::GOterm'); my $clu = $factory->create_object(-name => 'peroxisome', -ontology => 'Gene Ontology', -identifier => 'GO:0005777'); =head1 DESCRIPTION This object will build L objects generically. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::RelationshipFactory; use strict; use Bio::Root::Root; use base qw(Bio::Factory::ObjectFactory); =head2 new Title : new Usage : my $obj = Bio::Ontology::RelationshipFactory->new(); Function: Builds a new Bio::Ontology::RelationshipFactory object Returns : Bio::Ontology::RelationshipFactory Args : -type => string, name of a Bio::Ontology::RelationshipI derived class. The default is Bio::Ontology::Relationship. See L, L. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); # make sure this matches our requirements $self->interface("Bio::Ontology::RelationshipI"); $self->type($self->type() || "Bio::Ontology::Relationship"); return $self; } 1; BioPerl-1.6.923/Bio/Ontology/RelationshipI.pm000444000765000024 1244612254227337 21125 0ustar00cjfieldsstaff000000000000# # BioPerl module for RelationshipI # # Please direct questions and support issues to # # Cared for by Peter Dimitrov # # (c) Peter Dimitrov # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::RelationshipI - Interface for a relationship between ontology terms =head1 SYNOPSIS # see documentation of methods and an implementation, e.g., # Bio::Ontology::Relationship =head1 DESCRIPTION This is the minimal interface for a relationship between two terms in an ontology. Ontology engines will use this. The terminology we use here is the one commonly used for ontologies, namely the triple of (subject, predicate, object), which in addition is scoped in a namespace (ontology). It is called triple because it is a tuple of three ontology terms. There are other terminologies in use for expressing relationships. For those who it helps to better understand the concept, the triple of (child, relationship type, parent) would be equivalent to the terminology chosen here, disregarding the question whether the notion of parent and child is sensible in the context of the relationship type or not. Especially in the case of ontologies with a wide variety of predicates the parent/child terminology and similar ones can quickly become ambiguous (e.g., A synthesises B), meaningless (e.g., A binds B), or even conflicting (e.g., A is-parent-of B), and are therefore strongly discouraged. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Dimitrov Email dimitrov@gnf.org =head1 CONTRIBUTORS Hilmar Lapp, email: hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::RelationshipI; use strict; use base qw(Bio::Root::RootI); =head2 identifier Title : identifier Usage : print $rel->identifier(); Function: Set/get for the identifier of this Relationship. Note that this may not necessarily be used by a particular ontology. Returns : The identifier [scalar]. Args : =cut sub identifier{ shift->throw_not_implemented(); } =head2 subject_term Title : subject_term Usage : $subj = $rel->subject_term(); Function: Set/get for the subject term of this Relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The subject term [Bio::Ontology::TermI]. Args : =cut sub subject_term{ shift->throw_not_implemented(); } =head2 object_term Title : object_term Usage : $object = $rel->object_term(); Function: Set/get for the object term of this Relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The object term [Bio::Ontology::TermI]. Args : =cut sub object_term{ shift->throw_not_implemented(); } =head2 predicate_term Title : predicate_term Usage : $type = $rel->predicate_term(); Function: Set/get for the relationship type of this relationship. The common convention for ontologies is to express relationships between terms as triples (subject, predicate, object). Returns : The relationship type [Bio::Ontology::TermI]. Args : =cut sub predicate_term{ shift->throw_not_implemented(); } =head2 ontology Title : ontology Usage : $ont = $obj->ontology() Function: Get the ontology that defined (is the scope for) this relationship. Example : Returns : an object implementing Bio::Ontology::OntologyI Args : See L. =cut sub ontology{ shift->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/Ontology/RelationshipType.pm000444000765000024 2653712254227333 21660 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::RelationshipType # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::RelationshipType - a relationship type for an ontology =head1 SYNOPSIS # =head1 DESCRIPTION This class can be used to model various types of relationships (such as "IS_A", "PART_OF", "CONTAINS", "FOUND_IN", "RELATED_TO"). This class extends L, so it essentially is-a L. In addition, all methods are overridden such as to make the object immutable. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::RelationshipType; use strict; use constant PART_OF => "PART_OF"; use constant RELATED_TO => "RELATED_TO"; use constant IS_A => "IS_A"; use constant CONTAINS => "CONTAINS"; use constant FOUND_IN => "FOUND_IN"; use constant REGULATES => "REGULATES"; use constant POSITIVELY_REGULATES => "POSITIVELY_REGULATES"; use constant NEGATIVELY_REGULATES => "NEGATIVELY_REGULATES"; use base qw(Bio::Ontology::Term); # # cache for terms # my %term_name_map = (); =head2 get_instance Title : get_instance Usage : $IS_A = Bio::Ontology::RelationshipType->get_instance( "IS_A" ); $PART_OF = Bio::Ontology::RelationshipType->get_instance( "PART_OF" ); $RELATED_TO = Bio::Ontology::RelationshipType->get_instance( "RELATED_TO" ); $CONTAINS = Bio::Ontology::RelationshipType->get_instance( "CONTAINS" ); $FOUND_IN = Bio::Ontology::RelationshipType->get_instance( "FOUND_IN" ); Function: Factory method to create instances of RelationshipType Returns : [Bio::Ontology::RelationshipType] Args : "IS_A" or "PART_OF" or "CONTAINS" or "FOUND_IN" or "RELATED_TO" [scalar] the ontology [Bio::Ontology::OntologyI] (optional) =cut sub get_instance { my ( $class, $name, $ont ) = @_; $class->throw("must provide predicate name") unless $name; # is one in the cache? my $reltype = $term_name_map{$name}; if($reltype && # check whether ontologies match (($ont && $reltype->ontology() && ($ont->name() eq $reltype->ontology->name())) || (! ($reltype->ontology() || $ont)))) { # we're done, return cached type return $reltype; } # valid relationship type? # #see the cell ontology. this code is too strict, even for dag-edit files. -allen # # if ( ! (($name eq IS_A) || ($name eq PART_OF) || # ($name eq CONTAINS) || ( $name eq FOUND_IN ))) { # my $msg = "Found unknown type of relationship: [" . $name . "]\n"; # $msg .= "Known types are: [" . IS_A . "], [" . PART_OF . "], [" . CONTAINS . "], [" . FOUND_IN . "]"; # $class->throw( $msg ); # } # if we get here we need to create the rel.type $reltype = $class->new(-name => $name, -ontology => $ont); # cache it (FIXME possibly overrides one from another ontology) $term_name_map{$name} = $reltype; return $reltype; } # get_instance =head2 init Title : init() Usage : $type->init(); Function: Initializes this to all undef and empty lists. Returns : Args : =cut sub init { my $self = shift; $self->SUPER::init(); # at this point we don't really need to do anything special for us } # init =head2 equals Title : equals Usage : if ( $type->equals( $other_type ) ) { ... Function: Compares this type to another one, based on string "eq" of the "identifier" field, if at least one of the two types has the identifier set, or string eq of the name otherwise. Returns : true or false Args : [Bio::Ontology::RelationshipType] =cut sub equals { my( $self, $type ) = @_; $self->_check_class( $type, "Bio::Ontology::RelationshipType" ); if ( $self->identifier() xor $type->identifier() ) { $self->warn("comparing relationship types when only ". "one has an identifier will always return false" ); } return ($self->identifier() || $type->identifier()) ? $self->identifier() eq $type->identifier() : $self->name() eq $type->name(); } # equals =head2 identifier Title : identifier Usage : $term->identifier( "IS_A" ); or print $term->identifier(); Function: Set/get for the immutable identifier of this Type. Returns : The identifier [scalar]. Args : The identifier [scalar] (optional). =cut sub identifier { my $self = shift; my $ret = $self->SUPER::identifier(); if(@_) { $self->throw($self->veto_change("identifier",$ret,$_[0])) if $ret && ($ret ne $_[0]); $ret = $self->SUPER::identifier(@_); } return $ret; } # identifier =head2 name Title : name Usage : $term->name( "is a type" ); or print $term->name(); Function: Set/get for the immutable name of this Type. Returns : The name [scalar]. Args : The name [scalar] (optional). =cut sub name { my $self = shift; my $ret = $self->SUPER::name(); if(@_) { $self->throw($self->veto_change("name",$ret,$_[0])) if $ret && ($ret ne $_[0]); $ret = $self->SUPER::name(@_); } return $ret; } # name =head2 definition Title : definition Usage : $term->definition( "" ); or print $term->definition(); Function: Set/get for the immutable definition of this Type. Returns : The definition [scalar]. Args : The definition [scalar] (optional). =cut sub definition { my $self = shift; my $ret = $self->SUPER::definition(); if(@_) { $self->veto_change("definition",$ret,$_[0]) if $ret && ($ret ne $_[0]); $ret = $self->SUPER::definition(@_); } # let's be nice and return something readable here return $ret if $ret; return $self->name()." relationship predicate (type)" if $self->name(); } # definition =head2 ontology Title : ontology Usage : $term->ontology( $top ); or $top = $term->ontology(); Function: Set/get for the ontology this relationship type lives in. Returns : The ontology [Bio::Ontology::OntologyI]. Args : On set, the ontology [Bio::Ontology::OntologyI] (optional). =cut sub ontology { my $self = shift; my $ret = $self->SUPER::ontology(); if(@_) { my $ont = shift; if($ret) { $self->throw($self->veto_change("ontology",$ret->name, $ont ? $ont->name : $ont)) unless $ont && ($ont->name() eq $ret->name()); } $ret = $self->SUPER::ontology($ont,@_); } return $ret; } # category =head2 version Title : version Usage : $term->version( "1.00" ); or print $term->version(); Function: Set/get for immutable version information. Returns : The version [scalar]. Args : The version [scalar] (optional). =cut sub version { my $self = shift; my $ret = $self->SUPER::version(); if(@_) { $self->throw($self->veto_change("version",$ret,$_[0])) if $ret && ($ret ne $_[0]); $ret = $self->SUPER::version(@_); } return $ret; } # version =head2 is_obsolete Title : is_obsolete Usage : $term->is_obsolete( 1 ); or if ( $term->is_obsolete() ) Function: Set/get for the immutable obsoleteness of this Type. Returns : the obsoleteness [0 or 1]. Args : the obsoleteness [0 or 1] (optional). =cut sub is_obsolete { my $self = shift; my $ret = $self->SUPER::is_obsolete(); if(@_) { $self->throw($self->veto_change("is_obsolete",$ret,$_[0])) if $ret && ($ret != $_[0]); $ret = $self->SUPER::is_obsolete(@_); } return $ret; } # is_obsolete =head2 comment Title : comment Usage : $term->comment( "..." ); or print $term->comment(); Function: Set/get for an arbitrary immutable comment about this Type. Returns : A comment. Args : A comment (optional). =cut sub comment { my $self = shift; my $ret = $self->SUPER::comment(); if(@_) { $self->throw($self->veto_change("comment",$ret,$_[0])) if $ret && ($ret ne $_[0]); $ret = $self->SUPER::comment(@_); } return $ret; } # comment =head1 Private methods May be overridden in a derived class, but should never be called from outside. =cut sub _check_class { my ( $self, $value, $expected_class ) = @_; if ( ! defined( $value ) ) { $self->throw( "Found [undef] where [$expected_class] expected" ); } elsif ( ! ref( $value ) ) { $self->throw( "Found [scalar] where [$expected_class] expected" ); } elsif ( ! $value->isa( $expected_class ) ) { $self->throw( "Found [" . ref( $value ) . "] where [$expected_class] expected" ); } } # _check_type =head2 veto_change Title : veto_change Usage : Function: Called if an attribute is changed. Setting an attribute is considered a change if it had a value before and the attempt to set it would change the value. This method returns the message to be printed in the exception. Example : Returns : A string Args : The name of the attribute that was attempted to change. Optionally, the old value and the new value for reporting purposes only. =cut sub veto_change{ my ($self,$attr,$old,$new) = @_; my $changetype = $old ? ($new ? "change" : "unset") : "change"; my $msg = "attempt to $changetype attribute $attr in ".ref($self). ", which is immutable"; $msg .= " (\"$old\" to \"$new\")" if $old && $new; return $msg; } 1; BioPerl-1.6.923/Bio/Ontology/SimpleOntologyEngine.pm000444000765000024 6646312254227326 22473 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::SimpleOntologyEngine # # Please direct questions and support issues to # # Cared for by Peter Dimitrov # # Copyright Peter Dimitrov # (c) Peter Dimitrov, dimitrov@gnf.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::SimpleOntologyEngine - Implementation of OntologyEngineI interface =head1 SYNOPSIS my $soe = Bio::Ontology::SimpleOntologyEngine->new; =head1 DESCRIPTION This is a "simple" implementation of Bio::Ontology::OntologyEngineI. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Dimitrov Email dimitrov@gnf.org =head1 CONTRIBUTORS Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::SimpleOntologyEngine; use strict; use Carp; use Bio::Ontology::RelationshipFactory; use Data::Dumper; use base qw(Bio::Root::Root Bio::Ontology::OntologyEngineI); =head2 new Title : new Usage : $soe = Bio::Ontology::SimpleOntologyEngine->new; Function: Initializes the ontology engine. Example : $soe = Bio::Ontology::SimpleOntologyEngine->new; Returns : Object of class SimpleOntologyEngine. Args : =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); # my %param = @args; $self->_term_store( {} ); $self->_relationship_store( {} ); $self->_inverted_relationship_store( {} ); $self->_relationship_type_store( {} ); $self->_instantiated_terms_store( {} ); # set defaults for the factories $self->relationship_factory( Bio::Ontology::RelationshipFactory->new( -type => "Bio::Ontology::Relationship" ) ); return $self; } =head2 _instantiated_terms_store Title : _instantiated_terms_store Usage : $obj->_instantiated_terms_store($newval) Function: Example : Returns : hash Args : empty hash =cut sub _instantiated_terms_store { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_instantiated_terms_store'} = $value; } return $self->{'_instantiated_terms_store'}; } =head2 mark_instantiated Title : mark_instantiated Usage : $self->mark_instantiated(TermI terms): TermI Function: Marks TermI objects as fully instantiated, allowing for proper counting of the number of terms in the term store. The TermI objects has to be already stored in the term store in order to be marked. Example : $self->mark_instantiated($term); Returns : its argument or throws an exception if a term is not in the term store. Args : array of objects of class TermI. =cut sub mark_instantiated { my ( $self, @terms ) = @_; foreach my $term (@terms) { $self->throw( "term " . $term->identifier . " not in the term store\n" ) if !defined $self->_term_store->{ $term->identifier }; $self->_instantiated_terms_store->{ $term->identifier } = 1; } return @terms; } =head2 mark_uninstantiated Title : mark_uninstantiated Usage : $self->mark_uninstantiated(TermI terms): TermI Function: Marks TermI objects as not fully instantiated, Example : $self->mark_uninstantiated($term); Returns : its argument or throws an exception if a term is not in the term store(if the term is not marked it does nothing). Args : array of objects of class TermI. =cut sub mark_uninstantiated { my ( $self, @terms ) = @_; foreach my $term (@terms) { $self->throw( "term " . $term->identifier . " not in the term store\n" ) if !defined $self->_term_store->{ $term->identifier }; delete $self->_instantiated_terms_store->{ $term->identifier } if defined $self->_instantiated_terms_store->{ $term->identifier }; } return @terms; } =head2 _term_store Title : term_store Usage : $obj->_term_store($newval) Function: Example : Returns : reference to an array of Bio::Ontology::TermI objects Args : reference to an array of Bio::Ontology::TermI objects =cut sub _term_store { my ( $self, $value ) = @_; if ( defined $value ) { if ( defined $self->{'_term_store'} ) { $self->throw("_term_store already defined\n"); } else { $self->{'_term_store'} = $value; } } return $self->{'_term_store'}; } =head2 add_term Title : add_term Usage : add_term(TermI term): TermI Function: Adds TermI object to the ontology engine term store. Marks the term fully instantiated by default. Example : $soe->add_term($term) Returns : its argument. Args : object of class TermI. =cut sub add_term { my ( $self, $term ) = @_; my $term_store = $self->_term_store; if ( defined $term_store->{ $term->identifier } && $self->_instantiated_terms_store->{ $term->identifier }) { $self->throw( "term " . $term->identifier . " already defined\n" ); } else { $term_store->{ $term->identifier } = $term; $self->_instantiated_terms_store->{ $term->identifier } = 1; } return $term; } =head2 get_term_by_identifier Title : get_term_by_identifier Usage : get_term_by_identifier(String id): TermI Function: Retrieves terms from the term store by their identifier field, or an empty list if not there. Example : $term = $soe->get_term_by_identifier("IPR000001"); Returns : An array of zero or more Bio::Ontology::TermI objects. Args : An array of identifier strings =cut sub get_term_by_identifier { my ( $self, @ids ) = @_; my @ans = (); foreach my $id (@ids) { my $term = $self->_term_store->{$id}; push @ans, $term if defined $term; } return @ans; } =head2 _get_number_rels Title : get_number_rels Usage : Function: Example : Returns : Args : =cut sub _get_number_rels { my ($self) = @_; my $num_rels = 0; foreach my $entry ( $self->_relationship_store ) { $num_rels += scalar keys %$entry; } return $num_rels; } =head2 _get_number_terms Title : _get_number_terms Usage : Function: Example : Returns : Args : =cut sub _get_number_terms { my ($self) = @_; return scalar $self->_filter_unmarked( values %{ $self->_term_store } ); } =head2 _relationship_store Title : _storerelationship_store Usage : $obj->relationship_store($newval) Function: Example : Returns : reference to an array of Bio::Ontology::TermI objects Args : reference to an array of Bio::Ontology::TermI objects =cut sub _relationship_store { my ( $self, $value ) = @_; if ( defined $value ) { if ( defined $self->{'_relationship_store'} ) { $self->throw("_relationship_store already defined\n"); } else { $self->{'_relationship_store'} = $value; } } return $self->{'_relationship_store'}; } =head2 _inverted_relationship_store Title : _inverted_relationship_store Usage : Function: Example : Returns : reference to an array of Bio::Ontology::TermI objects Args : reference to an array of Bio::Ontology::TermI objects =cut sub _inverted_relationship_store { my ( $self, $value ) = @_; if ( defined $value ) { if ( defined $self->{'_inverted_relationship_store'} ) { $self->throw("_inverted_relationship_store already defined\n"); } else { $self->{'_inverted_relationship_store'} = $value; } } return $self->{'_inverted_relationship_store'}; } =head2 _relationship_type_store Title : _relationship_type_store Usage : $obj->_relationship_type_store($newval) Function: Example : Returns : reference to an array of Bio::Ontology::RelationshipType objects Args : reference to an array of Bio::Ontology::RelationshipType objects =cut sub _relationship_type_store { my ( $self, $value ) = @_; if ( defined $value ) { if ( defined $self->{'_relationship_type_store'} ) { $self->throw("_relationship_type_store already defined\n"); } else { $self->{'_relationship_type_store'} = $value; } } return $self->{'_relationship_type_store'}; } =head2 _add_relationship_simple Title : _add_relationship_simple Usage : Function: Example : Returns : Args : =cut sub _add_relationship_simple { my ( $self, $store, $rel, $inverted ) = @_; my $subject = $rel->subject_term or $self->throw('cannot add relationship, relationship has no subject_term'); my $object = $rel->object_term or $self->throw('cannot add relationship, relationship has no object_term'); my ( $parent_id, $child_id ) = ( $object->identifier, $subject->identifier ); ( $parent_id, $child_id ) = ( $child_id, $parent_id ) if $inverted; if ( defined $store->{$parent_id} && defined $store->{$parent_id}->{$child_id} && $store->{$parent_id}->{$child_id}->name ne $rel->predicate_term->name ) { $self->throw( "relationship " . $rel->predicate_term->name . " between " . $parent_id . " and " . $child_id . " already defined as " . $store->{$parent_id}->{$child_id}->name . "\n" ); } # all is well if we get here $store->{$parent_id}->{$child_id} = $rel->predicate_term; } =head2 add_relationship Title : add_relationship Usage : add_relationship(RelationshipI relationship): RelationshipI Function: Adds a relationship object to the ontology engine. Example : Returns : Its argument. Args : A RelationshipI object. =cut sub add_relationship { my ( $self, $rel ) = @_; $self->_add_relationship_simple( $self->_relationship_store, $rel, 0 ); $self->_add_relationship_simple( $self->_inverted_relationship_store, $rel, 1 ); $self->_relationship_type_store->{ $self->_unique_termid( $rel->predicate_term ) } = $rel->predicate_term; return $rel; } =head2 get_relationships Title : get_relationships Usage : get_relationships(): RelationshipI Function: Retrieves all relationship objects. Example : Returns : Array of RelationshipI objects Args : =cut sub get_relationships { my $self = shift; my $term = shift; my @rels; my $store = $self->_relationship_store; my $relfact = $self->relationship_factory(); my @parent_ids = $term ? # if a term is supplied then only get the term's parents ( map { $_->identifier(); } $self->get_parent_terms($term) ) : # otherwise use all parent ids ( keys %{$store} ); # add the term as a parent too if one is supplied push( @parent_ids, $term->identifier ) if $term; foreach my $parent_id (@parent_ids) { my $parent_entry = $store->{$parent_id}; # if a term is supplied, add a relationship for the parent to the term # except if the parent is the term itself (we added that one before) if ( $term && ( $parent_id ne $term->identifier() ) ) { my @parent_terms = $self->get_term_by_identifier($parent_id); foreach my $parent_term (@parent_terms) { push( @rels, $relfact->create_object( -object_term => $parent_term, -subject_term => $term, -predicate_term => $parent_entry->{ $term->identifier }, -ontology => $term->ontology() ) ); } } else { # otherwise, i.e., no term supplied, or the parent equals the # supplied term my @parent_terms = $term ? ($term) : $self->get_term_by_identifier($parent_id); foreach my $child_id ( keys %$parent_entry ) { my $rel_info = $parent_entry->{$child_id}; my ($subj_term) = $self->get_term_by_identifier($child_id); foreach my $parent_term (@parent_terms) { push( @rels, $relfact->create_object( -object_term => $parent_term, -subject_term => $subj_term, -predicate_term => $rel_info, -ontology => $parent_term->ontology ) ); } } } } return @rels; } =head2 get_all_relationships Title : get_all_relationships Usage : get_all_relationships(): RelationshipI Function: Retrieves all relationship objects. Example : Returns : Array of RelationshipI objects Args : =cut sub get_all_relationships { return shift->get_relationships(); } =head2 get_predicate_terms Title : get_predicate_terms Usage : get_predicate_terms(): TermI Function: Retrives all relationship types stored in the engine Example : Returns : reference to an array of Bio::Ontology::RelationshipType objects Args : =cut sub get_predicate_terms { my ($self) = @_; return values %{ $self->_relationship_type_store }; } =head2 _is_rel_type Title : _is_rel_type Usage : Function: Example : Returns : Args : =cut sub _is_rel_type { my ( $self, $term, @rel_types ) = @_; foreach my $rel_type (@rel_types) { if ( $rel_type->identifier || $term->identifier ) { return 1 if $rel_type->identifier eq $term->identifier; } else { return 1 if $rel_type->name eq $term->name; } } return 0; } =head2 _typed_traversal Title : _typed_traversal Usage : Function: Example : Returns : Args : =cut sub _typed_traversal { my ( $self, $rel_store, $level, $term_id, @rel_types ) = @_; return if !defined( $rel_store->{$term_id} ); my %parent_entry = %{ $rel_store->{$term_id} }; my @children = keys %parent_entry; my @ans; if ( @rel_types > 0 ) { @ans = (); foreach my $child_id (@children) { push @ans, $child_id if $self->_is_rel_type( $rel_store->{$term_id}->{$child_id}, @rel_types ); } } else { @ans = @children; } if ( $level < 1 ) { my @ans1 = (); foreach my $child_id (@ans) { push @ans1, $self->_typed_traversal( $rel_store, $level - 1, $child_id, @rel_types ) if defined $rel_store->{$child_id}; } push @ans, @ans1; } return @ans; } =head2 get_child_terms Title : get_child_terms Usage : get_child_terms(TermI term, TermI predicate_terms): TermI get_child_terms(TermI term, RelationshipType predicate_terms): TermI Function: Retrieves all child terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_child_terms is a special case of get_descendant_terms, limiting the search to the direct descendants. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_child_terms { my ( $self, $term, @relationship_types ) = @_; $self->throw("must provide TermI compliant object") unless defined($term) && $term->isa("Bio::Ontology::TermI"); return $self->_filter_unmarked( $self->get_term_by_identifier( $self->_typed_traversal( $self->_relationship_store, 1, $term->identifier, @relationship_types ) ) ); } =head2 get_descendant_terms Title : get_descendant_terms Usage : get_descendant_terms(TermI term, TermI rel_types): TermI get_child_terms(TermI term, RelationshipType predicate_terms): TermI Function: Retrieves all descendant terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Uses _typed_traversal to find all descendants. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_descendant_terms { my ( $self, $term, @relationship_types ) = @_; $self->throw("must provide TermI compliant object") unless defined($term) && $term->isa("Bio::Ontology::TermI"); return $self->_filter_unmarked( $self->_filter_repeated( $self->get_term_by_identifier( $self->_typed_traversal( $self->_relationship_store, 0, $term->identifier, @relationship_types ) ) ) ); } =head2 get_parent_terms Title : get_parent_terms Usage : get_parent_terms(TermI term, TermI predicate_terms): TermI get_child_terms(TermI term, RelationshipType predicate_terms): TermI Function: Retrieves all parent terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. get_parent_terms is a special case of get_ancestor_terms, limiting the search to the direct ancestors. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_parent_terms { my ( $self, $term, @relationship_types ) = @_; $self->throw("term must be a valid object, not undef") unless defined $term; return $self->_filter_unmarked( $self->get_term_by_identifier( $self->_typed_traversal( $self->_inverted_relationship_store, 1, $term->identifier, @relationship_types ) ) ); } =head2 get_ancestor_terms Title : get_ancestor_terms Usage : get_ancestor_terms(TermI term, TermI predicate_terms): TermI get_child_terms(TermI term, RelationshipType predicate_terms): TermI Function: Retrieves all ancestor terms of a given term, that satisfy a relationship among those that are specified in the second argument or undef otherwise. Uses _typed_traversal to find all ancestors. Example : Returns : Array of TermI objects. Args : First argument is the term of interest, second is the list of relationship type terms. =cut sub get_ancestor_terms { my ( $self, $term, @relationship_types ) = @_; $self->throw("term must be a valid object, not undef") unless defined $term; return $self->_filter_unmarked( $self->_filter_repeated( $self->get_term_by_identifier( $self->_typed_traversal( $self->_inverted_relationship_store, 0, $term->identifier, @relationship_types ) ) ) ); } =head2 get_leaf_terms Title : get_leaf_terms Usage : get_leaf_terms(): TermI Function: Retrieves all leaf terms from the ontology. Leaf term is a term w/o descendants. Example : @leaf_terms = $obj->get_leaf_terms() Returns : Array of TermI objects. Args : =cut sub get_leaf_terms { my ($self) = @_; my @leaf_terms; foreach my $term ( values %{ $self->_term_store } ) { push @leaf_terms, $term if !defined $self->_relationship_store->{ $term->identifier } && defined $self->_instantiated_terms_store->{ $term->identifier }; } return @leaf_terms; } =head2 get_root_terms Title : get_root_terms Usage : get_root_terms(): TermI Function: Retrieves all root terms from the ontology. Root term is a term w/o descendants. Example : @root_terms = $obj->get_root_terms() Returns : Array of TermI objects. Args : =cut sub get_root_terms { my ($self) = @_; my @root_terms; foreach my $term ( values %{ $self->_term_store } ) { push @root_terms, $term if !defined $self->_inverted_relationship_store->{ $term->identifier } && defined $self->_instantiated_terms_store->{ $term->identifier }; } return @root_terms; } =head2 _filter_repeated Title : _filter_repeated Usage : @lst = $self->_filter_repeated(@old_lst); Function: Removes repeated terms Example : Returns : List of unique TermI objects Args : List of TermI objects =cut sub _filter_repeated { my ( $self, @args ) = @_; my %h; foreach my $element (@args) { $h{ $element->identifier } = $element if !defined $h{ $element->identifier }; } return values %h; } =head2 get_all_terms Title : get_all_terms Usage : get_all_terms(): TermI Function: Retrieves all terms currently stored in the ontology. Example : @all_terms = $obj->get_all_terms() Returns : Array of TermI objects. Args : =cut sub get_all_terms { my ($self) = @_; return $self->_filter_unmarked( values %{ $self->_term_store } ); } =head2 find_terms Title : find_terms Usage : ($term) = $oe->find_terms(-identifier => "SO:0000263"); Function: Find term instances matching queries for their attributes. This implementation can efficiently resolve queries by identifier. Example : Returns : an array of zero or more Bio::Ontology::TermI objects Args : Named parameters. The following parameters should be recognized by any implementations: -identifier query by the given identifier -name query by the given name =cut sub find_terms { my ( $self, @args ) = @_; my @terms; my ( $id, $name ) = $self->_rearrange( [qw(IDENTIFIER NAME)], @args ); if ( defined($id) ) { @terms = $self->get_term_by_identifier($id); } else { @terms = $self->get_all_terms(); } if ( defined($name) ) { @terms = grep { $_->name() eq $name; } @terms; } return @terms; } =head2 relationship_factory Title : relationship_factory Usage : $fact = $obj->relationship_factory() Function: Get/set the object factory to be used when relationship objects are created by the implementation on-the-fly. Example : Returns : value of relationship_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : on set, a Bio::Factory::ObjectFactoryI compliant object =cut sub relationship_factory { my $self = shift; return $self->{'relationship_factory'} = shift if @_; return $self->{'relationship_factory'}; } =head2 term_factory Title : term_factory Usage : $fact = $obj->term_factory() Function: Get/set the object factory to be used when term objects are created by the implementation on-the-fly. Note that this ontology engine implementation does not create term objects on the fly, and therefore setting this attribute is meaningless. Example : Returns : value of term_factory (a Bio::Factory::ObjectFactoryI compliant object) Args : on set, a Bio::Factory::ObjectFactoryI compliant object =cut sub term_factory { my $self = shift; if (@_) { $self->warn( "setting term factory, but " . ref($self) . " does not create terms on-the-fly" ); return $self->{'term_factory'} = shift; } return $self->{'term_factory'}; } =head2 _filter_unmarked Title : _filter_unmarked Usage : _filter_unmarked(TermI terms): TermI Function: Removes the uninstantiated terms from the list of terms Example : Returns : array of fully instantiated TermI objects Args : array of TermI objects =cut sub _filter_unmarked { my ( $self, @terms ) = @_; my @filtered_terms = (); if ( scalar(@terms) >= 1 ) { foreach my $term (@terms) { push @filtered_terms, $term if defined $self->_instantiated_terms_store->{ $term->identifier }; } } return @filtered_terms; } =head2 remove_term_by_id Title : remove_term_by_id Usage : remove_term_by_id(String id): TermI Function: Removes TermI object from the ontology engine using the string id as an identifier. Current implementation does not enforce consistency of the relationships using that term. Example : $term = $soe->remove_term_by_id($id); Returns : Object of class TermI or undef if not found. Args : The string identifier of a term. =cut sub remove_term_by_id { my ( $self, $id ) = @_; if ( $self->get_term_by_identifier($id) ) { my $term = $self->{_term_store}->{$id}; delete $self->{_term_store}->{$id}; return $term; } else { $self->warn("Term with id '$id' is not in the term store"); return; } } =head2 to_string Title : to_string Usage : print $sv->to_string(); Function: Currently returns formatted string containing the number of terms and number of relationships from the ontology engine. Example : print $sv->to_string(); Returns : Args : =cut sub to_string { my ($self) = @_; my $s = ""; $s .= "-- # Terms:\n"; $s .= scalar( $self->get_all_terms ) . "\n"; $s .= "-- # Relationships:\n"; $s .= $self->_get_number_rels . "\n"; return $s; } =head2 _unique_termid Title : _unique_termid Usage : Function: Returns a string that can be used as ID using fail-over approaches. If the identifier attribute is not set, it uses the combination of name and ontology name, provided both are set. If they are not, it returns the name alone. Note that this is a private method. Call from inheriting classes but not from outside. Example : Returns : a string Args : a Bio::Ontology::TermI compliant object =cut sub _unique_termid { my $self = shift; my $term = shift; return $term->identifier() if $term->identifier(); my $id = $term->ontology->name() if $term->ontology(); if ($id) { $id .= '|'; } else { $id = ''; } $id .= $term->name(); } ################################################################# # aliases ################################################################# *get_relationship_types = \&get_predicate_terms; 1; BioPerl-1.6.923/Bio/Ontology/Term.pm000444000765000024 6303512254227336 17261 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::Term # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::Term - implementation of the interface for ontology terms =head1 SYNOPSIS #get Bio::Ontology::TermI somehow. print $term->identifier(), "\n"; print $term->name(), "\n"; print $term->definition(), "\n"; print $term->is_obsolete(), "\n"; print $term->comment(), "\n"; foreach my $synonym ( $term->each_synonym() ) { print $synonym, "\n"; } =head1 DESCRIPTION This is a simple implementation for ontology terms providing basic methods (it provides no functionality related to graphs). It implements the L interface. This class also implements L and L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Ontology::Term; use strict; use Bio::Ontology::Ontology; use Bio::Ontology::OntologyStore; use Bio::Annotation::DBLink; use Data::Dumper; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::Root::Root Bio::Ontology::TermI Bio::IdentifiableI Bio::DescribableI); =head2 new Title : new Usage : $term = Bio::Ontology::Term->new( -identifier => "16847", -name => "1-aminocyclopropane-1-carboxylate synthase", -definition => "Catalysis of ...", -is_obsolete => 0, -comment => "" ); Function: Creates a new Bio::Ontology::Term. Returns : A new Bio::Ontology::Term object. Args : -identifier => the identifier of this term [scalar] -name => the name of this term [scalar] -definition => the definition of this term [scalar] -ontology => the ontology this term lives in (a Bio::Ontology::OntologyI object) -version => version information [scalar] -is_obsolete => the obsoleteness of this term [0 or 1] -comment => a comment [scalar] -dblinks => Bio::Annotation::DBLink objects [reference to array] -references => Bio::Annotation::Reference objects [reference to array] See L, L, L. =cut sub new { my( $class,@args ) = @_; my $self = $class->SUPER::new( @args ); my ( $identifier, $name, $definition, $category, $ont, $version, $is_obsolete, $comment, $dblinks, $dbxrefs, $references) = $self->_rearrange( [ qw(IDENTIFIER NAME DEFINITION CATEGORY ONTOLOGY VERSION IS_OBSOLETE COMMENT DBLINKS DBXREFS REFERENCES) ], @args ); $self->init(); defined($identifier) && $self->identifier( $identifier ); defined($name) && $self->name( $name ); defined($definition) && $self->definition( $definition ); defined($category) && $self->category( $category ); defined($ont) && $self->ontology( $ont ); defined($version) && $self->version( $version ); defined($is_obsolete) && $self->is_obsolete( $is_obsolete ); defined($comment) && $self->comment( $comment ); defined($dbxrefs) && $self->add_dbxref(-dbxrefs => $dbxrefs); # deprecated methods, allow to pass on to get the dep. notification ref($dblinks) && $self->add_dblink(@$dblinks); ref($references) && $self->add_reference(@$references); return $self; } # new sub init { my $self = shift; $self->identifier(undef); $self->name(undef); $self->comment(undef); $self->definition(undef); $self->ontology(undef); $self->is_obsolete(0); $self->remove_synonyms(); $self->remove_dbxrefs(); $self->remove_references; $self->remove_secondary_ids(); } # init =head2 identifier Title : identifier Usage : $term->identifier( "GO:0003947" ); or print $term->identifier(); Function: Set/get for the identifier of this Term. Returns : The identifier [scalar]. Args : The identifier [scalar] (optional). =cut sub identifier { my $self = shift; return $self->{'identifier'} = shift if @_; return $self->{'identifier'}; } # identifier =head2 name Title : name Usage : $term->name( "N-acetylgalactosaminyltransferase" ); or print $term->name(); Function: Set/get for the name of this Term. Returns : The name [scalar]. Args : The name [scalar] (optional). =cut sub name { my $self = shift; return $self->{'name'} = shift if @_; return $self->{'name'}; } # name =head2 definition Title : definition Usage : $term->definition( "Catalysis of ..." ); or print $term->definition(); Function: Set/get for the definition of this Term. Returns : The definition [scalar]. Args : The definition [scalar] (optional). =cut sub definition { my $self = shift; return $self->{'definition'} = shift if @_; return $self->{'definition'}; } # definition =head2 ontology Title : ontology Usage : $ont = $term->ontology(); or $term->ontology( $ont ); Function: Get the ontology this term is in. Note that with the ontology in hand you can query for all related terms etc. Returns : The ontology of this Term as a Bio::Ontology::OntologyI implementing object. Args : On set, the ontology of this Term as a Bio::Ontology::OntologyI implementing object or a string representing its name. See L. =cut sub ontology { my $self = shift; my $ont; if(@_) { $ont = shift; if($ont) { $ont = Bio::Ontology::Ontology->new(-name => $ont) if ! ref($ont); if(! $ont->isa("Bio::Ontology::OntologyI")) { $self->throw(ref($ont)." does not implement ". "Bio::Ontology::OntologyI. Bummer."); } } return $self->{"_ontology"} = $ont; } return $self->{"_ontology"}; } # ontology =head2 version Title : version Usage : $term->version( "1.00" ); or print $term->version(); Function: Set/get for version information. Returns : The version [scalar]. Args : The version [scalar] (optional). =cut sub version { my $self = shift; return $self->{'version'} = shift if @_; return $self->{'version'}; } # version =head2 is_obsolete Title : is_obsolete Usage : $term->is_obsolete( 1 ); or if ( $term->is_obsolete() ) Function: Set/get for the obsoleteness of this Term. Returns : the obsoleteness [0 or 1]. Args : the obsoleteness [0 or 1] (optional). =cut sub is_obsolete{ my $self = shift; return $self->{'is_obsolete'} = shift if @_; return $self->{'is_obsolete'}; } # is_obsolete =head2 comment Title : comment Usage : $term->comment( "Consider the term ..." ); or print $term->comment(); Function: Set/get for an arbitrary comment about this Term. Returns : A comment. Args : A comment (optional). =cut sub comment{ my $self = shift; return $self->{'comment'} = shift if @_; return $self->{'comment'}; } # comment =head2 get_synonyms Title : get_synonyms Usage : @aliases = $term->get_synonyms; Function: Returns a list of aliases of this Term. Returns : A list of aliases [array of [scalar]]. Args : =cut sub get_synonyms { my $self = shift; return @{ $self->{ "_synonyms" } } if exists($self->{ "_synonyms" }); return (); } # get_synonyms =head2 add_synonym Title : add_synonym Usage : $term->add_synonym( @asynonyms ); or $term->add_synonym( $synonym ); Function: Pushes one or more synonyms into the list of synonyms. Returns : Args : One synonym [scalar] or a list of synonyms [array of [scalar]]. =cut sub add_synonym { my ( $self, @values ) = @_; return unless( @values ); # avoid duplicates foreach my $syn (@values) { next if grep { $_ eq $syn; } @{$self->{ "_synonyms" }}; push( @{ $self->{ "_synonyms" } }, $syn ); } } # add_synonym =head2 remove_synonyms Title : remove_synonyms() Usage : $term->remove_synonyms(); Function: Deletes (and returns) the synonyms of this Term. Returns : A list of synonyms [array of [scalar]]. Args : =cut sub remove_synonyms { my ( $self ) = @_; my @a = $self->get_synonyms(); $self->{ "_synonyms" } = []; return @a; } # remove_synonyms =head2 get_dblinks Title : get_dblinks() Usage : @ds = $term->get_dblinks(); Function: Returns a list of each dblinks of this GO term. Returns : A list of dblinks [array of [scalars]]. Args : A scalar indicating the context (optional). If omitted, all dblinks will be returned. Note : deprecated method due to past use of mixed data types; use get_dbxrefs() instead, which handles both strings and DBLink instances =cut sub get_dblinks { my ($self, $context) = @_; $self->deprecated("Use of get_dblinks is deprecated. Note that prior use\n". "of this method could return either simple scalar values\n". "or Bio::Annotation::DBLink instances; only \n". "Bio::Annotation::DBLink is now supported.\n ". "Use get_dbxrefs() instead"); $self->get_dbxrefs($context); } # get_dblinks =head2 get_dbxrefs Title : get_dbxrefs() Usage : @ds = $term->get_dbxrefs(); Function: Returns a list of each link for this term. If an implementor of this interface permits modification of this array property, the class should define at least methods add_dbxref() and remove_dbxrefs(), with obvious functionality. Returns : A list of L instances Args : [optional] string which specifies context (default : returns all dbxrefs) =cut sub get_dbxrefs { my ($self, $context) = shift; my @dbxrefs; if (defined($context)) { if (exists($self->{_dblinks}->{$context})) { @dbxrefs = @{$self->{_dblinks}->{$context}}; } } else { @dbxrefs = map { @$_ } values %{$self->{_dblinks}} ; } return @dbxrefs; } # get_dbxrefs =head2 get_dblink_context Title : get_dblink_context Usage : @context = $term->get_dblink_context; Function: Return all context existing in Term Returns : a list of scalar Args : [none] Note : deprecated method due to past use of mixed data types; use get_dbxref_context() instead =cut sub get_dblink_context { my $self=shift; $self->deprecated("Use of get_dblink_context() is deprecated; use get_dbxref_context() instead"); return $self->get_dbxref_context(@_); } =head2 get_dbxref_context Title : get_dbxref_context Usage : @context = $term->get_dbxref_context; Function: Return all context strings existing in Term Returns : a list of scalars Args : [none] =cut sub get_dbxref_context { my $self=shift; return keys %{$self->{_dblinks}}; } =head2 add_dblink Title : add_dblink Usage : $term->add_dblink( @dbls ); or $term->add_dblink( $dbl ); Function: Pushes one or more dblinks onto the list of dblinks. Returns : Args : One or more L instances Note : deprecated method due to past use of mixed data types; use add_dbxref() instead, which handles both strings and DBLink instances =cut sub add_dblink { my $self = shift; $self->deprecated("Use of simple strings and add_dblink() is deprecated; use\n". "Bio::Annotation::DBLink instances and add_dbxref() instead"); # here we're assuming the data is in a simple DB:ID format my @dbxrefs; for my $string (@_) { my ($db, $id) = split(':',$string); push @dbxrefs, Bio::Annotation::DBLink->new(-database => $db, -primary_id => $id); } return $self->add_dbxref(-dbxrefs => \@dbxrefs, -context => '_default'); } # add_dblink =head2 add_dbxref Title : add_dbxref Usage : $term->add_dbxref( @dbls ); or $term->add_dbxref( $dbl ); Function: Pushes one or more dblinks onto the list of dblinks. Returns : Args : -dbxrefs : array ref of Bio::Annotation::DBLink instances -context : string designating the context for the DBLink (default : '_default' - contextless) =cut sub add_dbxref { my $self = shift; my ($links, $context) = $self->_rearrange([qw(DBXREFS CONTEXT)],@_); return unless defined $links; $context ||= '_default'; $self->throw("DBLinks must be passed as an array reference") if ref $links ne 'ARRAY'; foreach my $dbxref (@{$links}) { $self->throw("$dbxref is not a DBLink") unless ref $dbxref && $dbxref->isa('Bio::Annotation::DBLink'); $self->throw("'all' is a reserved word for context.") if $context eq 'all'; if (! exists($self->{_dblinks}->{$context})) { $self->{_dblinks}->{$context} = []; } my $linktext = ref $dbxref ? $dbxref->display_text : $dbxref; if (grep {$_->display_text eq $linktext} @{$self->{_dblinks}->{$context}}) { $self->warn("DBLink exists in the dblink of $context"); } push @{$self->{_dblinks}->{$context}}, $dbxref; } } # add_dbxref # alias, for consistency *add_dbxrefs = \&add_dbxref; =head2 has_dblink Title : has_dblink Usage : $term->has_dblink($dblink); Function: Checks if a DBXref is already existing in the OBOterm object Return : TRUE/FALSE Args : [arg1] A DBxref identifier Note : deprecated method due to past use of mixed data types; use has_dbxref() instead, which handles both strings and DBLink instances =cut sub has_dblink { my ( $self, $value ) = @_; $self->deprecated("use of has_dblink() is deprecated; use has_dbxref() instead"); return $self->has_dbxref($value); } =head2 has_dbxref Title : has_dbxref Usage : $term->has_dbxref($dbxref); Function: Checks if a dbxref string is already existing in the OBOterm object Return : TRUE/FALSE Args : [arg1] A DBxref identifier (string). Bio::Annotation::DBLink::display_text() is used for comparison against the string. =cut sub has_dbxref { my ( $self, $value ) = @_; return unless defined $value; my $context = "_default"; $self->throw("'all' is a reserved word for context.") if $context eq 'all'; $context ||= '_default'; if ( ( $self->{_dblinks}->{$context} ) && grep { $_->display_text eq $value } @{ $self->{_dblinks}->{$context} } ) { return TRUE; } else { return FALSE; } } =head2 add_dblink_context Title : add_dblink_context Usage : $term->add_dblink_context($db, $context); Function: add a dblink with its context Return : [none] Args : [arg1] a Bio::Annotation::DBLink instance [arg2] a string for context; if omitted, the default/context-less one will be used. Note : deprecated method due to past use of mixed data types; use add_dbxref() instead =cut sub add_dblink_context { my ($self, $value, $context) = @_; $self->deprecated("Use of simple strings and add_dblink_context() is deprecated; use\n Bio::Annotation::DBLink instances and add_dbxref() instead"); return $self->add_dbxref([$value],$context); } =head2 remove_dblinks Title : remove_dblinks() Usage : $term->remove_dblinks(); Function: Deletes (and returns) the definition references of this GO term. Returns : A list of definition references [array of [scalars]]. Args : Context. If omitted or equal to 'all', all dblinks will be removed. Note : deprecated method due to past use of mixed data types; use remove_dblinks() instead, which handles both strings and DBLink instances =cut sub remove_dblinks { my ($self, $context) = @_; $self->deprecated("use of remove_dblinks() is deprecated; use remove_dbxrefs() instead"); return $self->remove_dbxrefs(@_); } # remove_dblinks =head2 remove_dbxrefs Title : remove_dbxrefs() Usage : $term->remove_dbxrefs(); Function: Deletes (and returns) the definition references of this GO term. Returns : A list of definition references [array of [scalars]]. Args : Context. If omitted or equal to 'all', all dblinks will be removed. =cut sub remove_dbxrefs { my ($self, $context) = @_; $context = undef if $context && ($context eq "all"); my @old = $self->get_dbxrefs($context); if (defined($context)) { $self->{_dblinks}->{$context}=[]; } else { $self->{_dblinks} = {}; } return @old; } # remove_dbxrefs =head2 get_references Title : get_references Usage : @references = $self->get_references Fuctnion: Returns a list of references Return : A list of objects Args : [none] =cut sub get_references { my $self=shift; return @{$self->{_references}} if exists $self->{_references}; return (); } =head2 add_reference Title : add_reference Usage : $self->add_reference($reference); $self->add_reference($reference1, $reference2); Fuctnion: Add one or more references Returns : [none] =cut sub add_reference { my ($self, @values) =@_; return unless @values; # avoid duplicates and undefs foreach my $reference (@values){ $self->throw("Passed data not an Bio::Annotation::Reference") unless ref $reference && $reference->isa('Bio::AnnotationI'); next unless defined $reference; next if grep{$_ eq $reference} @{$self->{_references}}; push @{$self->{_references}}, $reference; } } =head2 remove_references Title : remove_references Usage : $self->remove_references; Function: Deletes (and returns) all references Returns : A list of references Args : [none] =cut sub remove_references { my $self=shift; my @references=$self->get_references; $self->{_references}=[]; return @references; } =head2 get_secondary_ids Title : get_secondary_ids Usage : @ids = $term->get_secondary_ids(); Function: Returns a list of secondary identifiers of this Term. Secondary identifiers mostly originate from merging terms, or possibly also from splitting terms. Returns : A list of secondary identifiers [array of [scalar]] Args : =cut sub get_secondary_ids { my $self = shift; return @{$self->{"_secondary_ids"}} if exists($self->{"_secondary_ids"}); return (); } # get_secondary_ids =head2 add_secondary_id Title : add_secondary_id Usage : $term->add_secondary_id( @ids ); or $term->add_secondary_id( $id ); Function: Adds one or more secondary identifiers to this term. Returns : Args : One or more secondary identifiers [scalars] =cut sub add_secondary_id { my $self = shift; return unless @_; # avoid duplicates foreach my $id (@_) { next if grep { !$_ or $_ eq $id; } @{$self->{ "_secondary_ids" }}; push( @{ $self->{ "_secondary_ids" } }, $id ); } } # add_secondary_id =head2 remove_secondary_ids Title : remove_secondary_ids Usage : $term->remove_secondary_ids(); Function: Deletes (and returns) the secondary identifiers of this Term. Returns : The previous list of secondary identifiers [array of [scalars]] Args : =cut sub remove_secondary_ids { my $self = shift; my @a = $self->get_secondary_ids(); $self->{ "_secondary_ids" } = []; return @a; } # remove_secondary_ids # Title :_is_true_or_false # Function: Checks whether the argument is TRUE or FALSE. # Returns : # Args : The value to be checked. sub _is_true_or_false { my ( $self, $value ) = @_; unless ( $value !~ /\D/ && ( $value == TRUE || $value == FALSE ) ) { $self->throw( "Found [" . $value . "] where " . TRUE . " or " . FALSE . " expected" ); } } # _is_true_or_false =head1 Methods implementing L and L =cut =head2 object_id Title : object_id Usage : $string = $obj->object_id() Function: a string which represents the stable primary identifier in this namespace of this object. This is a synonym for identifier(). Returns : A scalar =cut sub object_id { return shift->identifier(@_); } =head2 authority Title : authority Usage : $authority = $obj->authority() Function: a string which represents the organisation which granted the namespace, written as the DNS name for organisation (eg, wormbase.org) This forwards to ontology()->authority(). Note that you cannot set the authority before having set the ontology or the namespace (which will set the ontology). Returns : A scalar Args : on set, the new value (a scalar) =cut sub authority { my $self = shift; my $ont = $self->ontology(); return $ont->authority(@_) if $ont; $self->throw("cannot manipulate authority prior to ". "setting the namespace or ontology") if @_; return; } =head2 namespace Title : namespace Usage : $string = $obj->namespace() Function: A string representing the name space this identifier is valid in, often the database name or the name describing the collection. This forwards to ontology() (set mode) and ontology()->name() (get mode). I.e., setting the namespace will set the ontology to one matching that name in the ontology store, or to one newly created. Returns : A scalar Args : on set, the new value (a scalar) =cut sub namespace { my $self = shift; $self->ontology(@_) if(@_); my $ont = $self->ontology(); return defined($ont) ? $ont->name() : undef; } =head2 display_name Title : display_name Usage : $string = $obj->display_name() Function: A string which is what should be displayed to the user. The definition in Bio::DescribableI states that the string should not contain spaces. As this is not very sensible for ontology terms, we relax this here. The implementation just forwards to name(). Returns : A scalar Args : on set, the new value (a scalar) =cut sub display_name { return shift->name(@_); } =head2 description Title : description Usage : $string = $obj->description() Function: A text string suitable for displaying to the user a description. This string is likely to have spaces, but should not have any newlines or formatting - just plain text. This forwards to definition(). The caveat is that the text will often be longer for ontology term definitions than the 255 characters stated in the definition in Bio::DescribableI. Returns : A scalar Args : on set, the new value (a scalar) =cut sub description { return shift->definition(@_); } ################################################################# # aliases or forwards to maintain backward compatibility ################################################################# =head1 Deprecated methods Used for looking up the methods that supercedes them. =cut sub each_dblink {shift->throw("use of each_dblink() is deprecated; use get_dbxrefs() instead")} sub add_dblinks {shift->throw("use of add_dblinks() is deprecated; use add_dbxref() instead")} *each_synonym = \&get_synonyms; *add_synonyms = \&add_synonym; 1; BioPerl-1.6.923/Bio/Ontology/TermFactory.pm000444000765000024 1007412254227313 20577 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::TermFactory # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Ontology::TermFactory - Instantiates a new Bio::Ontology::TermI (or derived class) through a factory =head1 SYNOPSIS use Bio::Ontology::TermFactory; # the default type is Bio::Ontology::Term my $factory = Bio::Ontology::TermFactory->new( -type => 'Bio::Ontology::GOterm'); my $term = $factory->create_object(-name => 'peroxisome', -ontology => 'Gene Ontology', -identifier => 'GO:0005777'); =head1 DESCRIPTION This object will build L objects generically. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::TermFactory; use strict; use Bio::Root::Root; use base qw(Bio::Factory::ObjectFactory); =head2 new Title : new Usage : my $obj = Bio::Ontology::TermFactory->new(); Function: Builds a new Bio::Ontology::TermFactory object Returns : Bio::Ontology::TermFactory Args : -type => string, name of a Bio::Ontology::TermI derived class. The default is Bio::Ontology::Term. See L, L. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); # make sure this matches our requirements $self->interface("Bio::Ontology::TermI"); $self->type($self->type() || "Bio::Ontology::Term"); return $self; } =head2 create_object Title : create_object Usage : my $term = $factory->create_object(); Function: Instantiates new Bio::Ontology::TermI (or one of its child classes) This object allows us to genericize the instantiation of Term objects. Returns : Bio::Ontology::TermI compliant object The return type is configurable using new(-type =>"..."). Args : initialization parameters specific to the type of term object we want. Typically -name => $name -identifier => identifier for the term -ontology => ontology for the term See L. =cut 1; BioPerl-1.6.923/Bio/Ontology/TermI.pm000444000765000024 2244612254227316 17371 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Ontology::Term # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::TermI - interface for ontology terms =head1 SYNOPSIS #get Bio::Ontology::TermI somehow. print $term->identifier(), "\n"; print $term->name(), "\n"; print $term->definition(), "\n"; print $term->is_obsolete(), "\n"; print $term->comment(), "\n"; foreach my $synonym ( $term->get_synonyms() ) { print $synonym, "\n"; } =head1 DESCRIPTION This is "dumb" interface for ontology terms providing basic methods (it provides no functionality related to graphs). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Ontology::TermI; use strict; use base qw(Bio::Root::RootI); =head2 identifier Title : identifier Usage : $term->identifier( "0003947" ); or print $term->identifier(); Function: Set/get for the identifier of this Term. Returns : The identifier [scalar]. Args : The identifier [scalar] (optional). =cut sub identifier { shift->throw_not_implemented(); } # identifier =head2 name Title : name Usage : $term->name( "N-acetylgalactosaminyltransferase" ); or print $term->name(); Function: Set/get for the name of this Term. Returns : The name [scalar]. Args : The name [scalar] (optional). =cut sub name { shift->throw_not_implemented(); } # name =head2 definition Title : definition Usage : $term->definition( "Catalysis of ..." ); or print $term->definition(); Function: Set/get for the definition of this Term. Returns : The definition [scalar]. Args : The definition [scalar] (optional). =cut sub definition { shift->throw_not_implemented(); } # definition =head2 ontology Title : ontology Usage : $ont = $term->ontology(); or $term->ontology( $ont ); Function: Get the ontology this term is in. An implementation may not permit the value of this attribute to be changed once it is set, since that may have serious consequences (note that with the ontology in hand you can query for all related terms etc). Note for implementors: you will almost certainly have to take special precaution in order not to create cyclical references in memory. Returns : The ontology of this Term as a Bio::Ontology::OntologyI implementing object. Args : On set, the ontology of this Term as a Bio::Ontology::OntologyI implementing object or a string representing its name. See L. =cut sub ontology { shift->throw_not_implemented(); } # ontology =head2 version Title : version Usage : $term->version( "1.00" ); or print $term->version(); Function: Set/get for version information. Returns : The version [scalar]. Args : The version [scalar] (optional). =cut sub version { shift->throw_not_implemented(); } # version =head2 is_obsolete Title : is_obsolete Usage : $term->is_obsolete( 1 ); or if ( $term->is_obsolete() ) Function: Set/get for the obsoleteness of this Term. Returns : the obsoleteness [0 or 1]. Args : the obsoleteness [0 or 1] (optional). =cut sub is_obsolete { shift->throw_not_implemented(); } # is_obsolete =head2 comment Title : comment Usage : $term->comment( "Consider the term ..." ); or print $term->comment(); Function: Set/get for an arbitrary comment about this Term. Returns : A comment. Args : A comment (optional). =cut sub comment { shift->throw_not_implemented(); } # comment =head2 get_synonyms Title : get_synonyms Usage : @aliases = $term->get_synonyms(); Function: Returns a list of aliases of this Term. If an implementor of this interface permits modification of this array property, the class should define at least methods add_synonym() and remove_synonyms(), with obvious functionality. Returns : A list of aliases [array of [scalar]]. Args : =cut sub get_synonyms { shift->throw_not_implemented(); } # get_synonyms =head2 get_dblinks Title : get_dblinks() Usage : @ds = $term->get_dblinks(); Function: Returns a list of each dblink of this term. If an implementor of this interface permits modification of this array property, the class should define at least methods add_dblink() and remove_dblinks(), with obvious functionality. Returns : A list of dblinks [array of [scalars]]. Args : Note : This has been deprecated in favor of get_dbxrefs() =cut sub get_dblinks { shift->throw('get_dblinks() is deprecated, use get_dbxrefs() instead'); } # get_dblinks =head2 get_dbxrefs Title : get_dbxrefs() Usage : @ds = $term->get_dbxrefs(); Function: Returns a list of each link for this term. If an implementor of this interface permits modification of this array property, the class should define at least methods add_dbxref() and remove_dbxrefs(), with obvious functionality. Returns : A list of dblinks. This can return a mixed 'bag' of scalars and L instances, or specific subgroups can be returned based on passed arguments Args : implementation-specific =cut sub get_dbxrefs { shift->throw_not_implemented(); } # get_dblinks =head2 get_secondary_ids Title : get_secondary_ids Usage : @ids = $term->get_secondary_ids(); Function: Returns a list of secondary identifiers of this Term. Secondary identifiers mostly originate from merging terms, or possibly also from splitting terms. If an implementor of this interface permits modification of this array property, the class should define at least methods add_secondary_id() and remove_secondary_ids(), with obvious functionality. Returns : A list of secondary identifiers [array of [scalar]] Args : =cut sub get_secondary_ids { shift->throw_not_implemented(); } # get_secondary_ids =head1 Deprecated methods Used for looking up the methods that supercedes them. =cut =head2 category Title : category Usage : Function: This method is deprecated. Use ontology() instead. We provide an implementation here that preserves backwards compatibility, but if you do not have legacy code using it you should not be calling this method. Example : Returns : Args : =cut sub category { my $self = shift; $self->warn("TermI::category is deprecated and being phased out. ". "Use TermI::ontology instead."); # called in set mode? if(@_) { # yes; what is incompatible with ontology() is if we were given # a TermI object my $arg = shift; $arg = $arg->name() if ref($arg) && $arg->isa("Bio::Ontology::TermI"); return $self->ontology($arg,@_); } else { # No, called in get mode. This is always incompatible with ontology() # since category is supposed to return a TermI. my $ont = $self->ontology(); my $term; if(defined($ont)) { $term = Bio::Ontology::Term->new(-name => $ont->name(), -identifier =>$ont->identifier()); } return $term; } } # category 1; BioPerl-1.6.923/Bio/Ontology/SimpleGOEngine000755000765000024 012254227324 20432 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Ontology/SimpleGOEngine/GraphAdaptor.pm000444000765000024 1614612254227324 23531 0ustar00cjfieldsstaff000000000000# $Id: GraphAdaptor.pm 10525 2006-09-26 22:03:22Z sendu $ # # BioPerl Graph adaptor for Bio::Ontology::SimpleGOEngine # # Please direct questions and support issues to # # Cared for by Nat Goodman # # (c) Nathan Goodman natg@shore.net 2005 # (c) ISB, Institute for Systems Biology 2005 # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Ontology::SimpleGOEngine::GraphAdaptor - Graph adaptor for Bio::Ontology::SimpleGOEngine =head1 SYNOPSIS use Bio::Ontology::SimpleGOEngine::GraphAdaptor; my $graph = Bio::Ontology::SimpleGOEngine::GraphAdaptor; =head1 DESCRIPTION This is an adaptor to simplify use of versions of the standard CPAN Graph module (old is versions 0.2x; new is 0.5x and beyond) within Bio::Ontology::SimpleGOEngine. Prior versions of this module supported Graph version older than 0.5, however we are removing support for these older version post BioPerl 1.6.901. If you absolutely require an old version of Graph, please use an older version of BioPerl. This module implements only those Graph methods used by SimpleGOEngine. It is far from a complete compatibility layer! It also implements workarounds for certain performance problems in the current versions of Graph v0.5x. This class provides implementations for the required graph methods using the new version of Graph. In most cases, these are simple pass-throughs The methods implemented here or in the subclasses are listed below. In all cases, we implemented the Graph v0.5x interface. Consult the Graph v0.5x man page for details. add_vertex has_vertex add_edge has_edge vertices edges edges_at predecessors successors set_vertex_attribute get_vertex_attribute set_edge_attribute get_edge_attribute source_vertices sink_vertices =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Nat Goodman Email: natg at shore.net Address: Institute for Systems Biology 1441 N 34th St Seattle, WA 98103-8904 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Ontology::SimpleGOEngine::GraphAdaptor; use Graph::Directed; use strict; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $graph = Bio::Ontology::SimpleGOEngine::GraphAdaptor->new() Function: Creates a new graph Returns : Bio::Ontology::SimpleGOEngine::GraphAdaptor02 or Bio::Ontology::SimpleGOEngine::GraphAdaptor05 object, depending on which Graph version is available Args : none =cut sub new { my( $class ) = @_; $class = ref $class || $class; my $self= bless( {}, $class ); $self->{_graph}=Graph::Directed->new(); $self->{_vertex_attributes}={}; $self->{_edge_attributes}={}; return $self; } # Here are the main methods sub add_vertex { my $self=shift; $self->_graph->add_vertex(@_); } sub has_vertex { my $self=shift; $self->_graph->has_vertex(@_); } sub add_edge { my $self=shift; $self->_graph->add_edge(@_); } sub has_edge { my $self=shift; $self->_graph->has_edge(@_); } sub vertices { my $self=shift; $self->_graph->vertices(@_); } sub edges { my $self=shift; $self->_graph->edges(@_); } sub edges_at { my $self=shift; $self->_graph->edges_at(@_); } sub predecessors { my $self=shift; $self->_graph->predecessors(@_); } sub successors { my $self=shift; $self->_graph->successors(@_); } sub source_vertices { my $self=shift; $self->_graph->source_vertices(); } sub sink_vertices { my $self=shift; $self->_graph->sink_vertices(); } # The following methods workaround a performance problem in Graph v0.5x # when attributes are attached to the graph sub set_vertex_attribute { my($self,$v,$attribute,$value)=@_; $self->_vertex2attributes($v)->{$attribute}=$value; } sub get_vertex_attribute { my($self,$v,$attribute)=@_; $self->_vertex2attributes($v)->{$attribute}; } sub set_edge_attribute { my($self,$u,$v,$attribute,$value)=@_; $self->_edge2attributes($u,$v)->{$attribute}=$value; } sub get_edge_attribute { my($self,$u,$v,$attribute)=@_; $self->_edge2attributes($u,$v)->{$attribute}; } =head2 _graph Title : _graph Usage : $self->_graph(); Function: Internal method to access 'real' graph Returns : Graph::Directed object Args : none =cut sub _graph {$_[0]->{_graph}; } =head2 _vertex_attributes Title : _vertex_attributes Usage : $self->vertex_attributes(); Function: Internal method to access HASH used to store vertex attributes Returns : Graph::Directed object Args : none =cut sub _vertex_attributes {$_[0]->{_vertex_attributes}; } =head2 _edge_attributes Title : _edge_attributes Usage : $self->edge_attributes(); Function: Internal method to access HASH used to store edge attributes Returns : Graph::Directed object Args : none =cut sub _edge_attributes {$_[0]->{_edge_attributes}; } =head2 _vertex2attributes Title : _vertex2attributes Usage : $value=$graph->_vertex2attributes($v_->{ATTRIBUTE}; $graph->_vertex2attributes($v)->{ATTRIBUTE}=$value; Function: Internal method to access attributes for a specific vertex Returns : HASH Args : none =cut sub _vertex2attributes { my($self,$vertex)=@_; $self->_vertex_attributes->{$vertex} or $self->_vertex_attributes->{$vertex}={}; } =head2 _edge2attributes Title : _edge2attributes Usage : $value=$graph->_edge2attributes($u,$v)->{ATTRIBUTE}; $graph->_edge2attributes($u,$v)->{ATTRIBUTE}=$value; Function: Internal method to access HASH used to store edge attributes Returns : HASH Args : none =cut sub _edge2attributes { my($self,$u,$v)=@_; $self->_edge_attributes->{$u,$v} or $self->_edge_attributes->{$u,$v}={}; } 1; BioPerl-1.6.923/Bio/OntologyIO000755000765000024 012254227325 16056 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/OntologyIO/dagflat.pm000444000765000024 6271412254227323 20203 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::OntologyIO::dagflat # # Please direct questions and support issues to # # Cared for by Hilmar Lapp, hlapp at gmx.net # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) Hilmar Lapp, hlapp at gmx.net, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::dagflat - a base class parser for GO flat-file type formats =head1 SYNOPSIS use Bio::OntologyIO; # do not use directly -- use via Bio::OntologyIO # e.g., the GO parser is a simple extension of this class my $parser = Bio::OntologyIO->new ( -format => "go", -defs_file => "/home/czmasek/GO/GO.defs", -files => ["/home/czmasek/GO/component.ontology", "/home/czmasek/GO/function.ontology", "/home/czmasek/GO/process.ontology"] ); my $go_ontology = $parser->next_ontology(); my $IS_A = Bio::Ontology::RelationshipType->get_instance( "IS_A" ); my $PART_OF = Bio::Ontology::RelationshipType->get_instance( "PART_OF" ); my $RELATED_TO = Bio::Ontology::RelationshipType->get_instance( "RELATED_TO" ); =head1 DESCRIPTION Needs Graph.pm from CPAN. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head2 CONTRIBUTOR Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO::dagflat; use strict; use Bio::Root::IO; use Bio::Ontology::OBOEngine; use Bio::Ontology::Ontology; use Bio::Ontology::OntologyStore; use Bio::Ontology::TermFactory; use Bio::Annotation::DBLink; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::OntologyIO); =head2 new Title : new Usage : $parser = Bio::OntologyIO->new( -format => "go", -defs_file => "/path/to/GO.defs", -files => ["/path/to/component.ontology", "/path/to/function.ontology", "/path/to/process.ontology"] ); Function: Creates a new dagflat parser. Returns : A new dagflat parser object, implementing Bio::OntologyIO. Args : -defs_file => the name of the file holding the term definitions -files => a single ontology flat file holding the term relationships, or an array ref holding the file names (for GO, there will usually be 3 files: component.ontology, function.ontology, process.ontology) -file => if there is only a single flat file, it may also be specified via the -file parameter -ontology_name => the name of the ontology; if not specified the parser will auto-discover it by using the term that starts with a $, and converting underscores to spaces -engine => the Bio::Ontology::OntologyEngineI object to be reused (will be created otherwise); note that every Bio::Ontology::OntologyI will qualify as well since that one inherits from the former. See L. =cut # in reality, we let OntologyIO::new do the instantiation, and override # _initialize for all initialization work sub _initialize { my ($self, %arg) = @_; my ( $defs_file_name,$files,$defs_url,$url,$name,$eng ) = $self->_rearrange([qw( DEFS_FILE FILES DEFS_URL URL ONTOLOGY_NAME ENGINE) ], %arg ); delete($arg{-url}); #b/c GO has 3 files... $self->SUPER::_initialize( %arg ); $self->_done( FALSE ); $self->_not_first_record( FALSE ); $self->_term( "" ); delete $self->{'_ontologies'}; # ontology engine (and possibly name if it's an OntologyI) $eng = Bio::Ontology::OBOEngine->new() unless $eng; if($eng->isa("Bio::Ontology::OntologyI")) { $self->ontology_name($eng->name()); $eng = $eng->engine() if $eng->can('engine'); } $self->_ont_engine($eng); # flat files to parse if(defined($defs_file_name) && defined($defs_url)){ $self->throw('cannot provide both -defs_file and -defs_url'); } else { defined($defs_file_name) && $self->defs_file( $defs_file_name ); defined($defs_url) && $self->defs_url( $defs_url ); } if(defined($files) && defined($url)){ } elsif(defined($files)){ $self->{_flat_files} = $files ? ref($files) ? $files : [$files] : []; } elsif(defined($url)){ $self->url($url); } # ontology name (overrides implicit one through OntologyI engine) $self->ontology_name($name) if $name; } # _initialize =head2 ontology_name Title : ontology_name Usage : $obj->ontology_name($newval) Function: Get/set the name of the ontology parsed by this module. Example : Returns : value of ontology_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub ontology_name{ my $self = shift; return $self->{'ontology_name'} = shift if @_; return $self->{'ontology_name'}; } =head2 parse Title : parse() Usage : $parser->parse(); Function: Parses the files set with "new" or with methods defs_file and _flat_files. Normally you should not need to call this method as it will be called automatically upon the first call to next_ontology(). Returns : [Bio::Ontology::OntologyEngineI] Args : =cut sub parse { my $self = shift; #warn "PARSING"; # setup the default term factory if not done by anyone yet $self->term_factory(Bio::Ontology::TermFactory->new( -type => "Bio::Ontology::Term")) unless $self->term_factory(); # create the ontology object itself my $ont = Bio::Ontology::Ontology->new(-name => $self->ontology_name(), -engine => $self->_ont_engine()); # parse definitions while( my $term = $self->_next_term() ) { $self->_add_term( $term, $ont ); } # set up the ontology of the relationship types foreach ($self->_part_of_relationship(), $self->_is_a_relationship(), $self->_related_to_relationship()) { $_->ontology($ont); } # pre-seed the IO system with the first flat file if -file wasn't provided if(! $self->_fh) { if($self->url){ if(ref($self->url) eq 'ARRAY'){ #warn "BA"; foreach my $url (@{ $self->url }){ #warn $url; #warn $ont; #warn scalar($ont->get_all_terms()); $self->_initialize_io(-url => $url); $self->_parse_flat_file($ont); } $self->close(); } else { $self->_initialize_io(-url => $self->url); } } elsif($self->_flat_files){ $self->_initialize_io(-file => shift(@{$self->_flat_files()})); } } while($self->_fh) { $self->_parse_flat_file($ont); # advance to next flat file if more are available if(@{$self->_flat_files()}) { $self->close(); $self->_initialize_io(-file => shift(@{$self->_flat_files()})); } else { last; # nothing else to parse so terminate the loop } } $self->_add_ontology($ont); # not needed anywhere, only because of backward compatibility return $self->_ont_engine(); } # parse =head2 next_ontology Title : next_ontology Usage : Function: Get the next available ontology from the parser. This is the method prescribed by Bio::OntologyIO. Example : Returns : An object implementing Bio::Ontology::OntologyI, and undef if there is no more ontology in the input. Args : =cut sub next_ontology { my $self = shift; # parse if not done already $self->parse() unless exists($self->{'_ontologies'}); # return next available ontology if(exists($self->{'_ontologies'})){ my $ont = shift (@{$self->{'_ontologies'}}); if($ont){ my $store = Bio::Ontology::OntologyStore->new(); $store->register_ontology($ont); return $ont; } } return; } =head2 defs_file Title : defs_file Usage : $parser->defs_file( "GO.defs" ); Function: Set/get for the term definitions filename. Returns : The term definitions file name [string]. Args : On set, the term definitions file name [string] (optional). =cut sub defs_file { my $self = shift; if ( @_ ) { my $f = shift; $self->{ "_defs_file_name" } = $f; $self->_defs_io->close() if $self->_defs_io(); if(defined($f)) { $self->_defs_io( Bio::Root::IO->new( -input => $f ) ); } } return $self->{ "_defs_file_name" }; } # defs_file sub defs_url { my $self = shift; my $val = shift; if(defined($val)){ $self->{'_defs_url'} = $val; $self->_defs_io->close() if $self->_defs_io(); $self->_defs_io( Bio::Root::IO->new( -url => $val ) ); } return $self->{'_defs_url'}; } sub url { my $self = shift; my $val = shift; if(defined($val)){ $self->{'_url'} = $val; } return $self->{'_url'}; } =head2 close Title : close Usage : Function: Closes this ontology stream and associated file handles. Clients should call this method especially when they write ontologies. We need to override this here in order to close the file handle for the term definitions file. Example : Returns : none Args : none =cut sub close{ my $self = shift; # first call the inherited implementation $self->SUPER::close(); # then close the defs file io (if there is one) $self->_defs_io->close() if $self->_defs_io(); } =head2 _flat_files Title : _flat_files Usage : $files_to_parse = $parser->_flat_files(); Function: Get the array of ontology flat files that need to be parsed. Note that this array will decrease in elements over the parsing process. Therefore, it\'s value outside of this module will be limited. Also, be careful not to alter the array unless you know what you are doing. Returns : a reference to an array of zero or more strings Args : none =cut sub _flat_files { my $self = shift; $self->{_flat_files} = [] unless exists($self->{_flat_files}); return $self->{_flat_files}; } # INTERNAL METHODS # ---------------- =head2 _defs_io Title : _defs_io Usage : $obj->_defs_io($newval) Function: Get/set the Bio::Root::IO instance representing the definition file, if provided (see defs_file()). Example : Returns : value of _defs_io (a Bio::Root::IO object) Args : on set, new value (a Bio::Root::IO object or undef, optional) =cut sub _defs_io{ my $self = shift; return $self->{'_defs_io'} = shift if @_; return $self->{'_defs_io'}; } sub _add_ontology { my $self = shift; $self->{'_ontologies'} = [] unless exists($self->{'_ontologies'}); foreach my $ont (@_) { $self->throw(ref($ont)." does not implement Bio::Ontology::OntologyI") unless ref($ont) && $ont->isa("Bio::Ontology::OntologyI"); # the ontology name may have been auto-discovered while parsing # the file $ont->name($self->ontology_name) unless $ont->name(); push(@{$self->{'_ontologies'}}, $ont); } } # This simply delegates. See SimpleGOEngine. sub _add_term { my ( $self, $term, $ont ) = @_; $term->ontology($ont) if $ont && (! $term->ontology); $self->_ont_engine()->add_term( $term ); } # _add_term # This simply delegates. See SimpleGOEngine sub _part_of_relationship { my $self = shift; return $self->_ont_engine()->part_of_relationship(@_); } # _part_of_relationship # This simply delegates. See SimpleGOEngine sub _is_a_relationship { my $self = shift; return $self->_ont_engine()->is_a_relationship(@_); } # _is_a_relationship # This simply delegates. See SimpleGOEngine sub _related_to_relationship { my $self = shift; return $self->_ont_engine()->related_to_relationship(@_); } # _is_a_relationship # This simply delegates. See SimpleGOEngine sub _add_relationship { my ( $self, $parent, $child, $type, $ont ) = @_; # note the triple terminology (subject,predicate,object) corresponds to # (child,type,parent) $self->_ont_engine()->add_relationship( $child, $type, $parent, $ont ); } # _add_relationship # This simply delegates. See SimpleGOEngine sub _has_term { my $self = shift; return $self->_ont_engine()->has_term( @_ ); } # _add_term # This parses the relationships files sub _parse_flat_file { my $self = shift; my $ont = shift; my @stack = (); my $prev_spaces = -1; my $prev_term = ""; while ( my $line = $self->_readline() ) { if ( $line =~ /^!/ ) { next; } # split into term specifications my @termspecs = split(/ (?=[%<])/, $line); # the first element is whitespace only shift(@termspecs) if $termspecs[0] =~ /^\s*$/; # parse out the focus term my $current_term = $self->_get_first_termid( $termspecs[0] ); my @syns = $self->_get_synonyms( $termspecs[0] ); my @sec_go_ids = $self->_get_secondary_termids( $termspecs[0] ); my @cross = $self->_get_db_cross_refs( $termspecs[0] ); my @cross_refs; foreach my $cross_ref (@cross) { $cross_ref eq $current_term && next; push(@cross_refs, $cross_ref); } # parse out the parents of the focus term shift(@termspecs); my @isa_parents = (); my @partof_parents = (); foreach my $parent (@termspecs) { if (index($parent, "%") == 0) { push(@isa_parents, $self->_get_first_termid($parent)); } elsif (index($parent, "<") == 0) { push(@partof_parents, $self->_get_first_termid($parent)); } else { $self->warn("unhandled relationship type in '".$parent."'"); } } if ( ! $self->_has_term( $current_term ) ) { my $term =$self->_create_ont_entry($self->_get_name($line, $current_term), $current_term ); $self->_add_term( $term, $ont ); } my $current_term_object = $self->_ont_engine()->get_terms( $current_term ); my $anno = $self->_to_annotation(\@cross_refs); $current_term_object->add_dbxref(-dbxrefs => $anno); $current_term_object->add_secondary_id( @sec_go_ids ); $current_term_object->add_synonym( @syns ); unless ( $line =~ /^\$/ ) { $current_term_object->ontology( $ont ); } foreach my $parent ( @isa_parents ) { if ( ! $self->_has_term( $parent ) ) { my $term = $self->_create_ont_entry($self->_get_name($line, $parent), $parent ); $self->_add_term( $term, $ont ); } $self->_add_relationship( $parent, $current_term, $self->_is_a_relationship(), $ont); } foreach my $parent ( @partof_parents ) { if ( ! $self->_has_term( $parent ) ) { my $term = $self->_create_ont_entry($self->_get_name($line, $parent), $parent ); $self->_add_term( $term, $ont ); } $self->_add_relationship( $parent, $current_term, $self->_part_of_relationship(), $ont); } my $current_spaces = $self->_count_spaces( $line ); if ( $current_spaces != $prev_spaces ) { if ( $current_spaces == $prev_spaces + 1 ) { push( @stack, $prev_term ); } elsif ( $current_spaces < $prev_spaces ) { my $n = $prev_spaces - $current_spaces; for ( my $i = 0; $i < $n; ++$i ) { pop( @stack ); } } else { $self->throw( "format error (file ".$self->file.")" ); } } my $parent = $stack[ @stack - 1 ]; # add a relationship if the line isn\'t the one with the root term # of the ontology (which is also the name of the ontology) if ( index($line,'$') != 0 ) { #adding @reltype@ syntax if ( $line !~ /^\s*([<%~]|\@\w+?\@)/ ) { $self->throw( "format error (file ".$self->file.") offending line:\n$line" ); } my($relstring) = $line =~ /^\s*([<%~]|\@[^\@]+?\@)/; my $reltype; if ($relstring eq '<') { $reltype = $self->_part_of_relationship; } elsif ($relstring eq '%') { $reltype = $self->_is_a_relationship; } elsif ($relstring eq '~') { $reltype = $self->_related_to_relationship; } else { $relstring =~ s/\@//g; if ($self->_ont_engine->get_relationship_type($relstring)) { $reltype = $self->_ont_engine->get_relationship_type($relstring); } else { $self->_ont_engine->add_relationship_type($relstring, $ont); $reltype = $self->_ont_engine->get_relationship_type($relstring); } } #my $reltype = ($line =~ /^\s*_part_of_relationship() : #$self->_is_a_relationship(); $self->_add_relationship( $parent, $current_term, $reltype, $ont); } $prev_spaces = $current_spaces; $prev_term = $current_term; } return $ont; } # _parse_relationships_file # Parses the 1st term id number out of line. sub _get_first_termid { my ( $self, $line ) = @_; if ( $line =~ /;\s*([A-Z_]{1,8}:\d{1,})/ ) { # if ( $line =~ /;\s*(\w+:\w+)/ ) { return $1; } else { $self->throw( "format error: no term id in line \"$line\"" ); } } # _get_first_termid # Parses the name out of line. sub _get_name { my ( $self, $line, $termid ) = @_; if ( $line =~ /([^;<%~]+);\s*$termid/ ) { my $name = $1; # remove trailing and leading whitespace $name =~ s/\s+$//; $name =~ s/^\s+//; $name =~ s/\@.+?\@//; # remove leading dollar character; also we default the name of the # ontology to this name unless it is preset to something else if(index($name,'$') == 0) { $name = substr($name,1); # replace underscores by spaces for setting the ontology name $self->ontology_name(join(" ",split(/_/,$name))) unless $self->ontology_name(); } return $name; } else { return; } } # _get_name # Parses the synonyms out of line. sub _get_synonyms { my ( $self, $line ) = @_; my @synonyms = (); while ( $line =~ /synonym\s*:\s*([^;<%~]+)/g ) { my $syn = $1; $syn =~ s/\s+$//; $syn =~ s/^\s+//; push( @synonyms, $syn ); } return @synonyms; } # _get_synonyms # Parses the db cross refs out of line. sub _get_db_cross_refs { my ( $self, $line ) = @_; my @refs = (); while ( $line =~ /;([^;<%~:]+:[^;<%~:]+)/g ) { my $ref = $1; if ( $ref =~ /synonym/ || $ref =~ /[A-Z]{1,8}:\d{3,}/ ) { next; } $ref =~ s/\s+$//; $ref =~ s/^\s+//; $ref = $self->unescape( $ref ); push( @refs, $ref ) if defined $ref; } return @refs; } # Parses the secondary go ids out of a line sub _get_secondary_termids { my ( $self, $line ) = @_; my @secs = (); # while ( $line =~ /,\s*([A-Z]{1,8}:\d{3,})/g ) { while ( $line =~ /,\s*(\w+:\w+)/g ) { my $sec = $1; push( @secs, $sec ); } return @secs; } # _get_secondary_termids # Counts the spaces at the beginning of a line in the relationships files sub _count_spaces { my ( $self, $line ) = @_; if ( $line =~ /^(\s+)/ ) { return length( $1 ); } else { return 0; } } # _count_spaces # "next" method for parsing the defintions file sub _next_term { my ( $self ) = @_; if ( ($self->_done() == TRUE) || (! $self->_defs_io())) { return; } my $line = ""; my $termid = ""; my $next_term = $self->_term(); my $def = ""; my $comment = ""; my @def_refs = (); my $isobsolete; while( $line = ( $self->_defs_io->_readline() ) ) { if ( $line !~ /\S/ || $line =~ /^\s*!/ ) { next; } elsif ( $line =~ /^\s*term:\s*(.+)/ ) { $self->_term( $1 ); last if $self->_not_first_record(); $next_term = $1; $self->_not_first_record( TRUE ); } elsif ( $line =~ /^\s*[a-z]{0,8}id:\s*(.+)/ ) { $termid = $1; } elsif ( $line =~ /^\s*definition:\s*(.+)/ ) { $def = $self->unescape($1); $isobsolete = 1 if index($def,"OBSOLETE") == 0; } elsif ( $line =~ /^\s*definition_reference:\s*(.+)/ ) { push( @def_refs, $self->unescape($1) ); } elsif ( $line =~ /^\s*comment:\s*(.+)/ ) { $comment = $self->unescape($1); } } $self->_done( TRUE ) unless $line; # we'll come back until done return $self->_create_ont_entry( $next_term, $termid, $def, $comment, \@def_refs, $isobsolete); } # _next_term # Holds the GO engine to be parsed into sub _ont_engine { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_ont_engine" } = $value; } return $self->{ "_ont_engine" }; } # _ont_engine # Used to create ontology terms. # Arguments: name, id sub _create_ont_entry { my ( $self, $name, $termid, $def, $cmt, $dbxrefs, $obsolete ) = @_; if((!defined($obsolete)) && (index(lc($name),"obsolete") == 0)) { $obsolete = 1; } my $anno = $self->_to_annotation($dbxrefs); my $term = $self->term_factory->create_object(-name => $name, -identifier => $termid, -definition => $def, -comment => $cmt, -dbxrefs => $anno, -is_obsolete => $obsolete); return $term; } # _create_ont_entry # Holds whether first record or not sub _not_first_record { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_not_first_record" } = $value; } return $self->{ "_not_first_record" }; } # _not_first_record # Holds whether done or not sub _done { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_done" } = $value; } return $self->{ "_done" }; } # _done # Holds a term. sub _term { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_term" } = $value; } return $self->{ "_term" }; } # _term # convert simple strings to Bio::Annotation::DBLinks sub _to_annotation { my ($self , $links) = @_; return unless $links; my @dbxrefs; for my $string (@{$links}) { my ($db, $id) = split(':',$string); push @dbxrefs, Bio::Annotation::DBLink->new(-database => $db, -primary_id => $id); } return \@dbxrefs; } 1; BioPerl-1.6.923/Bio/OntologyIO/goflat.pm000444000765000024 1245312254227325 20052 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::OntologyIO::goflat # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::goflat - a parser for the Gene Ontology flat-file format =head1 SYNOPSIS use Bio::OntologyIO; # do not use directly -- use via Bio::OntologyIO my $parser = Bio::OntologyIO->new ( -format => "go", -defs_file => "/home/czmasek/GO/GO.defs", -files => ["/home/czmasek/GO/component.ontology", "/home/czmasek/GO/function.ontology", "/home/czmasek/GO/process.ontology"] ); my $go_ontology = $parser->next_ontology(); my $IS_A = Bio::Ontology::RelationshipType->get_instance( "IS_A" ); my $PART_OF = Bio::Ontology::RelationshipType->get_instance( "PART_OF" ); =head1 DESCRIPTION Needs Graph.pm from CPAN. This is essentially a very thin derivation of the dagflat parser. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head2 CONTRIBUTOR Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO::goflat; use strict; use Bio::Ontology::TermFactory; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::OntologyIO::dagflat); =head2 new Title : new Usage : $parser = Bio::OntologyIO->new( -format => "go", -defs_file => "/path/to/GO.defs", -files => ["/path/to/component.ontology", "/path/to/function.ontology", "/path/to/process.ontology"] ); Function: Creates a new goflat parser. Returns : A new goflat parser object, implementing Bio::OntologyIO. Args : -defs_file => the name of the file holding the term definitions -files => a single ontology flat file holding the term relationships, or an array ref holding the file names (for GO, there will usually be 3 files: component.ontology, function.ontology, process.ontology) -file => if there is only a single flat file, it may also be specified via the -file parameter -ontology_name => the name of the ontology; if not specified the parser will auto-discover it by using the term that starts with a $, and converting underscores to spaces -engine => the Bio::Ontology::OntologyEngineI object to be reused (will be created otherwise); note that every Bio::Ontology::OntologyI will qualify as well since that one inherits from the former. See L. =cut # in reality, we let OntologyIO::new do the instantiation, and override # _initialize for all initialization work sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize( @args ); # default term object factory $self->term_factory(Bio::Ontology::TermFactory->new( -type => "Bio::Ontology::GOterm")) unless $self->term_factory(); } # _initialize 1; BioPerl-1.6.923/Bio/OntologyIO/InterProParser.pm000444000765000024 1603512254227323 21513 0ustar00cjfieldsstaff000000000000# # BioPerl module for InterProParser # # Please direct questions and support issues to # # Cared for by Peter Dimitrov # # Copyright Peter Dimitrov # (c) Peter Dimitrov, dimitrov@gnf.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::InterProParser - Parser for InterPro xml files. =head1 SYNOPSIS # don't use this module directly - use Bio::OntologyIO with instead my $ipp = Bio::OntologyIO->new( -format => 'interpro', -file => 't/data/interpro.xml', -ontology_engine => 'simple' ); =head1 DESCRIPTION Use InterProParser to parse InterPro files in xml format. Typical use is the interpro.xml file published by EBI. The xml records should follow the format described in interpro.dtd, although the dtd file is not needed, and the XML file will not be validated against it. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Dimitrov Email dimitrov@gnf.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO::InterProParser; use strict; #use Carp; use XML::Parser::PerlSAX; use Bio::Ontology::SimpleOntologyEngine; use Bio::Ontology::TermFactory; use Bio::OntologyIO::Handlers::InterProHandler; use base qw(Bio::OntologyIO); =head2 new Title : new Usage : Function: Initializes objects needed for parsing. Example : $ipp = Bio::OntologyIO::InterProParser->new( -file => 't/data/interpro.xml', -ontology_engine => 'simple' ) Returns : Object of class Bio::OntologyIO::InterProParser. Args : -file - file name -ontology_engine - type of ontology engine. Should satisfy the OntologyEngine interface requirements. Currently the only option is 'simple'. In the future Graph.pm based engine will be added to the choices. =cut # in reality we let OntologyIO handle the first pass initialization # and instead override _initialize(). sub _initialize{ my $self = shift; $self->SUPER::_initialize(@_); my ($eng,$eng_type,$name) = $self->_rearrange([qw(ENGINE ONTOLOGY_ENGINE ONTOLOGY_NAME) ], @_); my $ip_h = Bio::OntologyIO::Handlers::InterProHandler->new( -ontology_name => $name); if(! $eng) { $eng_type = 'simple' unless $eng_type; if(lc($eng_type) eq 'simple') { $eng = Bio::Ontology::SimpleOntologyEngine->new(); } else { $self->throw("ontology engine type '$eng_type' ". "not implemented yet"); } } if($eng->isa("Bio::Ontology::OntologyI")) { $ip_h->ontology($eng); $eng = $eng->engine() if $eng->can('engine'); } $self->{_ontology_engine} = $eng; $ip_h->ontology_engine($eng); $self->{_parser} = XML::Parser::PerlSAX->new( Handler => $ip_h ); $self->{_interpro_handler} = $ip_h; # default term object factory $self->term_factory(Bio::Ontology::TermFactory->new( -type => "Bio::Ontology::InterProTerm")) unless $self->term_factory(); $ip_h->term_factory($self->term_factory()); } =head2 parse Title : parse Usage : Function: Performs the actual parsing. Example : $ipp->parse(); Returns : Args : =cut sub parse{ my $self = shift; my $ret; if ($self->file()) { $ret = $self->{_parser}->parse( Source => { SystemId => $self->file() } ); } elsif ($self->_fh()) { $ret = $self->{_parser}->parse( Source => { ByteStream => $self->_fh() } ); } else { $ret = undef; $self->throw("Only filenames and filehandles are understood here.\n"); } $self->_is_parsed(1); return $ret; } =head2 next_ontology Title : next_ontology Usage : $ipp->next_ontology() Function: Parses the input file and returns the next InterPro ontology available. Usually there will be only one ontology returned from an InterPro XML input. Example : $ipp->next_ontology(); Returns : Returns the ontology as a Bio::Ontology::OntologyEngineI compliant object. Args : See L. =cut sub next_ontology{ my $self = shift; $self->parse() unless $self->_is_parsed(); # there is only one ontology in an InterPro source file if(exists($self->{'_ontology_engine'})) { my $ont = $self->{_interpro_handler}->ontology(); delete $self->{_ontology_engine}; return $ont; } return; } =head2 _is_parsed Title : _is_parsed Usage : $obj->_is_parsed($newval) Function: Example : Returns : value of _is_parsed (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _is_parsed{ my $self = shift; return $self->{'_is_parsed'} = shift if @_; return $self->{'_is_parsed'}; } =head2 secondary_accessions_map Title : secondary_accessions_map Usage : $obj->secondary_accessions_map() Function: This method is merely for convenience, and one should normally use the InterProTerm secondary_ids method to access the secondary accessions. Example : $map = $interpro_parser->secondary_accessions_map; Returns : Reference to a hash that maps InterPro identifier to an array reference of secondary accessions following the InterPro xml schema. Args : Empty hash reference =cut sub secondary_accessions_map{ my ($self) = @_; return $self->{_interpro_handler}->{secondary_accessions_map}; } 1; BioPerl-1.6.923/Bio/OntologyIO/obo.pm000444000765000024 5750712254227312 17362 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::OntologyIO::obo # # Please direct questions and support issues to # # Cared for by Sohel Merchant, s-merchant at northwestern.edu # # Copyright Sohel Merchant # # You may distribute this module under the same terms as perl itself =head1 NAME Bio::OntologyIO::obo - a parser for OBO flat-file format from Gene Ontology Consortium =head1 SYNOPSIS use Bio::OntologyIO; # do not use directly -- use via Bio::OntologyIO my $parser = Bio::OntologyIO->new ( -format => "obo", -file => "gene_ontology.obo"); while(my $ont = $parser->next_ontology()) { print "read ontology ",$ont->name()," with ", scalar($ont->get_root_terms)," root terms, and ", scalar($ont->get_all_terms)," total terms, and ", scalar($ont->get_leaf_terms)," leaf terms\n"; } =head1 DESCRIPTION Needs Graph.pm from CPAN. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Sohel Merchant Email: s-merchant@northwestern.edu Address: Northwestern University Center for Genetic Medicine (CGM), dictyBase Suite 1206, 676 St. Clair st Chicago IL 60611 =head2 CONTRIBUTOR Hilmar Lapp, hlapp at gmx.net Chris Mungall, cjm at fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::OntologyIO::obo; use strict; use Bio::Root::IO; use Bio::Ontology::OBOEngine; use Bio::Ontology::Ontology; use Bio::Ontology::OntologyStore; use Bio::Ontology::TermFactory; use Bio::Annotation::Collection; use Text::Balanced qw(extract_quotelike extract_bracketed); use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::OntologyIO); =head2 new Title : new Usage : $parser = Bio::OntologyIO->new( -format => "obo", -file => "gene_ontology.obo"); Function: Creates a new dagflat parser. Returns : A new dagflat parser object, implementing Bio::OntologyIO. Args : -file => a single ontology flat file holding the terms, descriptions and relationships -ontology_name => the name of the ontology; if not specified the parser will assign the name of the ontology as the default-namespace header value from the OBO file. -engine => the Bio::Ontology::OntologyEngineI object to be reused (will be created otherwise); note that every Bio::Ontology::OntologyI will qualify as well since that one inherits from the former. See L. =cut # in reality, we let OntologyIO::new do the instantiation, and override # _initialize for all initialization work sub _initialize { my ( $self, %arg ) = @_; my ( $file, $name, $eng ) = $self->_rearrange( [ qw( FILE ONTOLOGY_NAME ENGINE) ], %arg ); $self->SUPER::_initialize(%arg); delete $self->{'_ontologies'}; # ontology engine (and possibly name if it's an OntologyI) $eng = Bio::Ontology::OBOEngine->new() unless $eng; if ( $eng->isa("Bio::Ontology::OntologyI") ) { $self->ontology_name( $eng->name() ); $eng = $eng->engine() if $eng->can('engine'); } $self->_ont_engine($eng); $self->ontology_name($name) if $name; } # _initialize =head2 ontology_name Title : ontology_name Usage : $obj->ontology_name($newval) Function: Get/set the name of the ontology parsed by this module. Example : Returns : value of ontology_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub ontology_name { my $self = shift; return $self->{'ontology_name'} = shift if @_; return $self->{'ontology_name'}; } =head2 parse Title : parse() Usage : $parser->parse(); Function: Parses the files set with "new" or with methods defs_file and _flat_files. Normally you should not need to call this method as it will be called automatically upon the first call to next_ontology(). Returns : Bio::Ontology::OntologyEngineI Args : =cut sub parse { my $self = shift; # setup the default term factory if not done by anyone yet $self->term_factory( Bio::Ontology::TermFactory->new( -type => "Bio::Ontology::OBOterm" ) ) unless $self->term_factory(); ## Parse the file header my $annotations_collection = $self->_header(); # create the default ontology object itself my $ont = Bio::Ontology::Ontology->new( -name => $self->ontology_name(), -engine => $self->_ont_engine() ); ## Assign the file headers $ont->annotation($annotations_collection); # set up the ontology of the relationship types foreach ( $self->_part_of_relationship(), $self->_is_a_relationship(), $self->_related_to_relationship(), $self->_regulates_relationship(), $self->_positively_regulates_relationship(), $self->_negatively_regulates_relationship(), ) { $_->ontology($ont); } ################################## $self->_add_ontology($ont); ################################## ### Adding new terms while ( my $term = $self->_next_term() ) { ### CHeck if the terms has a valid ID and NAME otherwise ignore the term if ( !$term->identifier() || !$term->name() ) { $self->throw( "OBO File Format Error on line " . $self->{'_current_line_no'} . " \nThe term does not have a id/name tag. This term will be ignored.\n" ); next; } #print $term->identifier(),"\t",$term->name(),"\n"; my $new_ontology_flag = 1; my $ontologies_array_ref = $self->{'_ontologies'}; foreach my $ontology (@$ontologies_array_ref) { my ($oname, $t_ns) = ($ontology->name(), $term->namespace() ); next unless (defined($oname) && defined($t_ns)); if ( $oname eq $t_ns ) { ### No need to create new ontology $new_ontology_flag = 0; $ont = $ontology; } } if ( $new_ontology_flag && $term->namespace() ) { my $new_ont = Bio::Ontology::Ontology->new( -name => $term->namespace(), -engine => $self->_ont_engine() ); $new_ont->annotation($annotations_collection); $self->_add_ontology($new_ont); $ont = $new_ont; } $self->_add_term( $term, $ont ); #### Addding the IS_A relationship my $isa_parents_array_ref = $self->{'_isa_parents'}; foreach my $parent_term (@$isa_parents_array_ref) { ### Check if parent exist, if not then add the term to the graph. if ( !( $self->_has_term($parent_term) ) ) { $self->_add_term( $parent_term, $ont ); } $self->_add_relationship( $parent_term, $term, $self->_is_a_relationship(), $ont ); } #### Addding the other relationships like part_of, realted_to, develpos_from my $relationship_hash_ref = $self->{'_relationships'}; foreach my $relationship ( keys %$relationship_hash_ref ) { my $reltype; #### Check if relationship exist, if not add it. if ( $self->_ont_engine->get_relationship_type($relationship) ) { $reltype = $self->_ont_engine->get_relationship_type($relationship); } else { $self->_ont_engine->add_relationship_type( $relationship, $ont ); $reltype = $self->_ont_engine->get_relationship_type($relationship); } #### Check if the id already exist in the graph my $id_array_ref = $$relationship_hash_ref{$relationship}; foreach my $id (@$id_array_ref) { my $parent_term = $self->_create_term_object(); $parent_term->identifier($id); $parent_term->ontology($ont); if ( !( $self->_has_term($parent_term) ) ) { $self->_add_term( $parent_term, $ont ); } $self->_add_relationship( $parent_term, $term, $reltype, $ont ); } } } return $self->_ont_engine(); } # parse =head2 next_ontology Title : next_ontology Usage : Function: Get the next available ontology from the parser. This is the method prescribed by Bio::OntologyIO. Example : Returns : An object implementing Bio::Ontology::OntologyI, and nothing if there is no more ontology in the input. Args : =cut sub next_ontology { my $self = shift; # parse if not done already $self->parse() unless exists( $self->{'_ontologies'} ); # return next available ontology if ( exists( $self->{'_ontologies'} ) ) { my $ont = shift( @{ $self->{'_ontologies'} } ); if ($ont) { my $store = Bio::Ontology::OntologyStore->new(); $store->register_ontology($ont); return $ont; } } return; } =head2 close Title : close Usage : Function: Closes this ontology stream and associated file handles. Clients should call this method especially when they write ontologies. We need to override this here in order to close the file handle for the term definitions file. Example : Returns : none Args : none =cut sub close { my $self = shift; # first call the inherited implementation $self->SUPER::close(); } # INTERNAL METHODS # ---------------- sub _add_ontology { my $self = shift; $self->{'_ontologies'} = [] unless exists( $self->{'_ontologies'} ); foreach my $ont (@_) { $self->throw( ref($ont) . " does not implement Bio::Ontology::OntologyI" ) unless ref($ont) && $ont->isa("Bio::Ontology::OntologyI"); # the ontology name may have been auto-discovered while parsing # the file $ont->name( $self->ontology_name ) unless $ont->name(); push( @{ $self->{'_ontologies'} }, $ont ); } } # This simply delegates. See OBOEngine. sub _add_term { my ( $self, $term, $ont ) = @_; $term->ontology($ont) if $ont && ( !$term->ontology ); $self->_ont_engine()->add_term($term); } # _add_term # This simply delegates. See OBOEngine sub _part_of_relationship { my $self = shift; return $self->_ont_engine()->part_of_relationship(@_); } # _part_of_relationship # This simply delegates. See OBOEngine sub _is_a_relationship { my $self = shift; return $self->_ont_engine()->is_a_relationship(@_); } # _is_a_relationship # This simply delegates. See OBOEngine sub _related_to_relationship { my $self = shift; return $self->_ont_engine()->related_to_relationship(@_); } # _is_a_relationship # This simply delegates. See OBOEngine sub _regulates_relationship { my $self = shift; return $self->_ont_engine()->regulates_relationship(@_); } # _part_of_relationship # This simply delegates. See OBOEngine sub _positively_regulates_relationship { my $self = shift; return $self->_ont_engine()->positively_regulates_relationship(@_); } # _part_of_relationship # This simply delegates. See OBOEngine sub _negatively_regulates_relationship { my $self = shift; return $self->_ont_engine()->negatively_regulates_relationship(@_); } # _part_of_relationship # This simply delegates. See OBOEngine sub _add_relationship { my ( $self, $parent, $child, $type, $ont ) = @_; # note the triple terminology (subject,predicate,object) corresponds to # (child,type,parent) $self->_ont_engine()->add_relationship( $child, $type, $parent, $ont ); } # _add_relationship # This simply delegates. See OBOEngine sub _has_term { my $self = shift; return $self->_ont_engine()->has_term(@_); } # _add_term # Holds the OBO engine to be parsed into sub _ont_engine { my ( $self, $value ) = @_; if ( defined $value ) { $self->{"_ont_engine"} = $value; } return $self->{"_ont_engine"}; } # _ont_engine # Removes the escape chracters from the file sub _filter_line { my ( $self, $line ) = @_; chomp($line); $line =~ tr [\200-\377] [\000-\177]; # see 'man perlop', section on tr/ # weird ascii characters should be excluded $line =~ tr/\0-\10//d; # remove weird characters; ascii 0-8 # preserve \11 (9 - tab) and \12 (10-linefeed) $line =~ tr/\13\14//d; # remove weird characters; 11,12 # preserve \15 (13 - carriage return) $line =~ tr/\16-\37//d; # remove 14-31 (all rest before space) $line =~ tr/\177//d; # remove DEL character $line =~ s/^\!.*//; $line =~ s/[^\\]\!.*//; $line =~ s/[^\\]\#.*//; $line =~ s/^\s+//; $line =~ s/\s+$//; return $line; } # Parses the header sub _header { my $self = shift; my $annotation_collection = Bio::Annotation::Collection->new(); my ( $tag, $value ); my $line_counter = 0; $self->{'_current_line_no'} = 0; my $format_version_header_flag = 0; my $default_namespace_header_flag = 0; while ( my $line = $self->_readline() ) { ++$line_counter; my $line = $self->_filter_line($line); if ( !$line ) { if ( !$format_version_header_flag || !$default_namespace_header_flag) { $self->throw( "OBO File Format Error - \nCannot find tag format-version and/ default-namespace . These are required header.\n" ); } $self->{'_current_line_no'} = $line_counter; return $annotation_collection; } ### CHeck if there is a header if($line =~ /\[\w*\]/) { $self->throw( "OBO File Format Error - \nCannot find tag format-version. Thi ia a required header.\n" ); } ### If the line is not null, check it contains atleasdt one colon $self->_check_colon( $line, $line_counter ); ### Thsse ar the allowed headers. Any other headers will be ignored if ( $line =~ /^(\[|format-version:|typeref:|version:|date:|saved-by:|auto-generated-by:|default-namespace:|remark:|subsetdef:)/ ) { if ( $line =~ /^([\w\-]+)\:\s*(.*)/ ) { ( $tag, $value ) = ( $1, $2 ); } if ( $tag =~ /format-version/) { $format_version_header_flag = 1; }elsif( $tag =~ /default-namespace/ ) { $default_namespace_header_flag = 1; } my $header = Bio::Annotation::SimpleValue->new( -value => $value ); $annotation_collection->add_Annotation( $tag, $header ); #### Assign the Ontology name as the value of the default-namespace header if ( $tag =~ /default-namespace/i ) { $self->ontology_name($value); } } } } ### Parses each stanza of the file sub _next_term { my $self = shift; my $term ; my $skip_stanza_flag = 1; my $line_counter = $self->{'_current_line_no'}; while ( my $line = $self->_readline() ) { #print $line."\n"; ++$line_counter; my $line = $self->_filter_line($line); if ( !$line && $term ) { $self->{'_current_line_no'} = $line_counter; return $term; } if ( ( $line =~ /^\[(\w+)\]\s*(.*)/ ) ) { #New stanza if ( uc($1) eq "TERM" ) { $term = $self->_create_term_object; $skip_stanza_flag = 0; ### Reset the relationships after each stanza $self->{'_relationships'} = {}; $self->{'_isa_parents'} = undef; } elsif ( uc($1) eq "TYPEDEF" ) { $skip_stanza_flag = 1; ### Check if this typedef is already defined by the relationship } else { $skip_stanza_flag = 1; $self->warn( "OBO File Format Warning on line $line_counter $line \nUnrecognized stanza type found. Skipping this stanza.\n" ); } next; } ### If the line is not null, check it contains atleasdt one colon $self->_check_colon( $line, $line_counter ); ### if there is any tag value other thn the list below move to the next tag next if ( ( $line !~ /^(\[|id:|name:|is_a:|relationship:|namespace:|is_obsolete:|alt_id:|def:|xref_analog:|exact_synonym:|broad_synonym:|related_synonym:|synonym:|comment:|xref:)/ ) || $skip_stanza_flag ); if ( $line =~ /^([\w\-]+)\:\s*(.*)/ ) { #TAg Value pair my ( $tag, $val ) = ( $1, $2 ); ### If no value for the tag thrown a warning if ( !$val ) { $self->warn( "OBO File Format Warning on line $line_counter $line \nTag has no value\n" ); } my $qh; ( $val, $qh ) = $self->_extract_quals($val); my $val2 = $val; $val2 =~ s/\\,/,/g; $tag = uc($tag); if ( $tag eq "ID" ) { $term->identifier($val); if ( $self->_has_term($term) ) { $term = $self->_ont_engine()->get_terms($val); } } elsif ( $tag eq "NAME" ) { $term->name($val); } elsif ( $tag eq "XREF_ANALOG" ) { if ( !$term->has_dbxref($val) ) { $term->add_dbxref(-dbxrefs => $self->_to_annotation([$val])); } } elsif ( $tag eq "XREF_UNKNOWN" ) { $term->add_dbxref(-dbxrefs => $self->_to_annotation([$val])); } elsif ( $tag eq "NAMESPACE" ) { $term->namespace($val); } elsif ( $tag eq "DEF" ) { my ( $defstr, $parts ) = $self->_extract_qstr($val); $term->definition($defstr); my $ann = $self->_to_annotation($parts); $term->add_dbxref(-dbxrefs => $ann); } elsif ( $tag =~ /(\w*)synonym/i ) { #$val =~ s/['"\[\]]//g; #NML commented out b/c need quotes $term->add_synonym($val); } elsif ( $tag eq "ALT_ID" ) { $term->add_secondary_id($val); } elsif ( $tag =~ /XREF/i ) { $term->add_secondary_id($val); } elsif ( $tag eq "IS_OBSOLETE" ) { if ( $val eq 'true' ) { $val = 1; } if ( $val eq 'false' ) { $val = 0; } $term->is_obsolete($val); } elsif ( $tag eq "COMMENT" ) { $term->comment($val); } elsif ( $tag eq "RELATIONSHIP" ) { $self->_handle_relationship_tag($val); } elsif ( $tag eq "IS_A" ) { $val =~ s/ //g; my $parent_term = $self->_create_term_object(); $parent_term->identifier($val); if ( $self->{'_isa_parents'} ) { my $isa_parents_array_ref = $self->{'_isa_parents'}; push( @$isa_parents_array_ref, $parent_term ); } else { my @terms_array; push( @terms_array, $parent_term ); $self->{'_isa_parents'} = \@terms_array; } } } } return $term; } # Creates a Bio::Ontology::OBOterm object sub _create_term_object { my ($self) = @_; my $term = $self->term_factory->create_object(); return $term; } # sub _extract_quals { my ( $self, $str ) = @_; my %q = (); if ( $str =~ /(.*)\s+(\{.*\})\s*$/ ) { my $return_str = $1; my $extr = $2; if ($extr) { my @qparts = $self->_split_on_comma($extr); foreach (@qparts) { if (/(\w+)=\"(.*)\"/) { $q{$1} = $2; } elsif (/(\w+)=\'(.*)\'/) { $q{$1} = $2; } else { warn("$_ in $str"); } } } return ( $return_str, \%q ); } else { return ( $str, {} ); } } # sub _extract_qstr { my ( $self, $str ) = @_; my ( $extr, $rem, $prefix ) = extract_quotelike($str); my $txt = $extr; $txt =~ s/^\"//; $txt =~ s/\"$//; if ($prefix) { warn("illegal prefix: $prefix in: $str"); } my @extra = (); # eg synonym: "foo" EXACT [...] if ( $rem =~ /(\w+)\s+(\[.*)/ ) { $rem = $2; push( @extra, split( ' ', $1 ) ); } my @parts = (); while ( ( $extr, $rem, $prefix ) = extract_bracketed( $rem, '[]' ) ) { last unless $extr; $extr =~ s/^\[//; $extr =~ s/\]$//; push( @parts, $extr ) if $extr; } @parts = map { $self->_split_on_comma($_) } @parts; $txt =~ s/\\//g; return ( $txt, \@parts, \@extra ); } # sub _split_on_comma { my ( $self, $str ) = @_; my @parts = (); while ( $str =~ /(.*[^\\],\s*)(.*)/ ) { $str = $1; my $part = $2; unshift( @parts, $part ); $str =~ s/,\s*$//; } unshift( @parts, $str ); return map { s/\\//g; $_ } @parts; } # This method checks for an existing colon in a line sub _check_colon { my ( $self, $line, $line_no ) = @_; if ( $line && !( $line =~ /:/ ) ) { $self->throw( "OBO File Format Error on line $line_no $line - \nCannot find key-terminating colon\n" ); } } # This method handles relationship tags sub _handle_relationship_tag { my ( $self, $val ) = @_; my @parts = split( / /, $val ); my $relationship = uc($parts[0]); my $id = $parts[1] =~ /\^(w+)\s+\!/ ? $1 : $parts[1]; my $parent_term = $self->_create_term_object(); $parent_term->identifier($id); if ( my $realtionships_hash = $self->{'_relationships'} ) { my $id_array_ref = $$realtionships_hash{$relationship}; if ( !$id_array_ref ) { my @ids; push( @ids, $id ); $$realtionships_hash{$relationship} = \@ids; } else { push( @$id_array_ref, $id ); } } } # convert simple strings to Bio::Annotation::DBLinks sub _to_annotation { my ($self , $links) = @_; return unless $links; my @dbxrefs; for my $string (@{$links}) { my ($db, $id) = split(':',$string); push @dbxrefs, Bio::Annotation::DBLink->new(-database => $db, -primary_id => $id); } return \@dbxrefs; } 1; BioPerl-1.6.923/Bio/OntologyIO/simplehierarchy.pm000555000765000024 4711012254227313 21764 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::OntologyIO::simplehierarchy # # Please direct questions and support issues to # # Cared for by Allen Day, allenday@ucla.edu # # (c) Allen Day, allenday@ucla.edu, 2003. # (c) Department of Human Genetics, UCLA Medical School, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::simplehierarchy - a base class parser for simple hierarchy-by-indentation type formats =head1 SYNOPSIS use Bio::OntologyIO; # do not use directly -- use via Bio::OntologyIO my $parser = Bio::OntologyIO->new ( -format => "simplehierarchy", -file => "pathology_terms.csv", -indent_string => ",", -ontology_name => "eVOC", -term_factory => $fact, ); my $ontology = $parser->next_ontology(); =head1 DESCRIPTION Needs Graph.pm from CPAN. This class is nearly identical to OntologyIO::dagflat, see L for details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Allen Day Email: allenday@ucla.edu =head2 CONTRIBUTOR Christian Zmasek =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO::simplehierarchy; use strict; use Data::Dumper; use File::Basename; use Bio::Root::IO; use Bio::Ontology::OBOEngine; use Bio::Ontology::Ontology; use Bio::Ontology::TermFactory; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::OntologyIO); =head2 new Title : new Usage : see SYNOPSIS Function: Creates a new simplehierarchy parser. Returns : A new simplehierarchy parser object, implementing Bio::OntologyIO. Args : -files => a single ontology flat file holding the term relationships, or an array ref holding the file names -file => if there is only a single flat file, it may also be specified via the -file parameter -ontology_name => the name of the ontology, defaults to "Gene Ontology" -file_is_root => Boolean indicating whether a virtual root term is to be added, the name of which will be derived from the file name. Default is false. Enabling this allows one to parse multiple input files into the same ontology and still have separately rooted. -engine => the L object to be reused (will be created otherwise); note that every L will qualify as well since that one inherits from the former. -indent_string => the string used to indent hierarchical levels in the file. For a file like this: term0 subterm1A subterm2A subterm1B subterm1C indent_string would be " ". Defaults to one space (" "). -comment_char => Allows specification of a regular expression string to indicate a comment line. Currently defaults to "[\|\-]". Note: this is not yet implemented. See L. =cut # in reality, we let OntologyIO::new do the instantiation, and override # _initialize for all initialization work sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize( @args ); my ( $indent,$files,$fileisroot,$name,$eng ) = $self->_rearrange([qw(INDENT_STRING FILES FILE_IS_ROOT ONTOLOGY_NAME ENGINE) ], @args); $self->_done( FALSE ); $self->_not_first_record( FALSE ); $self->_term( "" ); $self->file_is_root($fileisroot) if defined($fileisroot); $indent = ' ' unless defined($indent); #reasonable default? # the indentation string may have escaped chars if (($indent =~ /\\/) && ($indent !~ /[\$\`]/)) { $indent = "\$indent = \"$indent\""; eval $indent; } $self->indent_string($indent); delete $self->{'_ontologies'}; # ontology engine (and possibly name if it's an OntologyI) $eng = Bio::Ontology::OBOEngine->new() unless $eng; if($eng->isa("Bio::Ontology::OntologyI")) { $self->ontology_name($eng->name()); $eng = $eng->engine() if $eng->can('engine'); } $self->_ont_engine($eng); # flat files to parse $self->{_flat_files} = $files ? ref($files) ? $files : [$files] : []; # ontology name (overrides implicit one through OntologyI engine) $self->ontology_name($name) if $name; } # _initialize =head2 ontology_name Title : ontology_name Usage : $obj->ontology_name($newval) Function: Get/set the name of the ontology parsed by this module. Example : Returns : value of ontology_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub ontology_name{ my $self = shift; return $self->{'ontology_name'} = shift if @_; return $self->{'ontology_name'}; } =head2 parse Title : parse() Usage : $parser->parse(); Function: Parses the files set with "new" or with methods defs_file and _flat_files. Normally you should not need to call this method as it will be called automatically upon the first call to next_ontology(). Returns : [Bio::Ontology::OntologyEngineI] Args : =cut sub parse { my $self = shift; # setup the default term factory if not done by anyone yet $self->term_factory(Bio::Ontology::TermFactory->new( -type => "Bio::Ontology::Term")) unless $self->term_factory(); # create the ontology object itself my $ont = Bio::Ontology::Ontology->new(-name => $self->ontology_name(), -engine => $self->_ont_engine()); # set up the ontology of the relationship types foreach ($self->_part_of_relationship(), $self->_is_a_relationship(), $self->_related_to_relationship()) { $_->ontology($ont); } # pre-seed the IO system with the first flat file if -file wasn't provided if(! $self->_fh) { $self->_initialize_io(-file => shift(@{$self->_flat_files()})); } while($self->_fh) { $self->_parse_flat_file($ont); # advance to next flat file if more are available if(@{$self->_flat_files()}) { $self->close(); # reset the virtual root so that the next one is generated from # the next file $self->_virtual_root(undef); # now re-initialize the IO object $self->_initialize_io(-file => shift(@{$self->_flat_files()})); } else { last; # nothing else to parse so terminate the loop } } $self->_add_ontology($ont); # not needed anywhere, only because of backward compatibility return $self->_ont_engine(); } # parse =head2 next_ontology Title : next_ontology Usage : Function: Get the next available ontology from the parser. This is the method prescribed by Bio::OntologyIO. Example : Returns : An object implementing Bio::Ontology::OntologyI, and undef if there is no more ontology in the input. Args : =cut sub next_ontology{ my $self = shift; # parse if not done already $self->parse() unless exists($self->{'_ontologies'}); # return next available ontology return shift(@{$self->{'_ontologies'}}) if exists($self->{'_ontologies'}); return; } =head2 _flat_files Title : _flat_files Usage : $files_to_parse = $parser->_flat_files(); Function: Get the array of ontology flat files that need to be parsed. Note that this array will decrease in elements over the parsing process. Therefore, it\'s value outside of this module will be limited. Also, be careful not to alter the array unless you know what you are doing. Returns : a reference to an array of zero or more strings Args : none =cut sub _flat_files { my $self = shift; $self->{_flat_files} = [] unless exists($self->{_flat_files}); return $self->{_flat_files}; } # INTERNAL METHODS # ---------------- =head2 _defs_io Title : _defs_io Usage : $obj->_defs_io($newval) Function: Get/set the Bio::Root::IO instance representing the definition file, if provided (see defs_file()). Example : Returns : value of _defs_io (a Bio::Root::IO object) Args : on set, new value (a Bio::Root::IO object or undef, optional) =cut sub _defs_io{ my $self = shift; return $self->{'_defs_io'} = shift if @_; return $self->{'_defs_io'}; } sub _add_ontology { my $self = shift; $self->{'_ontologies'} = [] unless exists($self->{'_ontologies'}); foreach my $ont (@_) { $self->throw(ref($ont)." does not implement Bio::Ontology::OntologyI") unless ref($ont) && $ont->isa("Bio::Ontology::OntologyI"); push(@{$self->{'_ontologies'}}, $ont); } } # This simply delegates. See SimpleGOEngine. sub _add_term { my ( $self, $term, $ont ) = @_; $term->ontology($ont) if $ont && (! $term->ontology); $self->_ont_engine()->add_term( $term ); } # _add_term # This simply delegates. See SimpleGOEngine sub _part_of_relationship { my ( $self, $term ) = @_; return $self->_ont_engine()->part_of_relationship(); } # _part_of_relationship # This simply delegates. See SimpleGOEngine sub _is_a_relationship { my ( $self, $term ) = @_; return $self->_ont_engine()->is_a_relationship(); } # _is_a_relationship # This simply delegates. See SimpleGOEngine sub _related_to_relationship { my ( $self, $term ) = @_; return $self->_ont_engine()->related_to_relationship(); } # _is_a_relationship # This simply delegates. See SimpleGOEngine sub _add_relationship { my ( $self, $parent, $child, $type, $ont ) = @_; # note the triple terminology (subject,predicate,object) corresponds to # (child,type,parent) $self->_ont_engine()->add_relationship( $child, $type, $parent, $ont ); } # _add_relationship # This simply delegates. See SimpleGOEngine sub _has_term { my ( $self, $term ) = @_; $term = $self->ontology_name() .'|'. $term unless ref($term) || !$self->ontology_name(); return $self->_ont_engine()->has_term( $term ); } # _add_term # This simply delegates after prefixing the namespace name if it is just a # base identifier. See SimpleGOEngine sub _get_terms{ my $self = shift; my @args = (); while(@_) { unshift(@args, pop(@_)); # this actually does preserve the order $args[0] = $self->ontology_name() .'|'. $args[0] unless ref($args[0]) || !$self->ontology_name(); } return $self->_ont_engine->get_terms(@args); } # This parses the relationships files sub _parse_flat_file { my $self = shift; my $ont = shift; my @stack = (); my $prev_indent = -1; my $parent = ""; my $prev_term = ""; my $indent_string = $self->indent_string; while ( my $line = $self->_readline() ) { if ( $line =~ /^[$indent_string]*[\|\-]/ ) { #this is not yet generalized next; } my ($current_term) = $line =~ /^[$indent_string]*(.*)/; my $current_indent = $self->_count_indents( $line ); chomp $current_term; # remove extraneous delimiter characters at the end of the name if any $current_term =~ s/[$indent_string]+$//; # remove double quotes surrounding the entry, if any $current_term =~ s/^\"(.*)\"$/$1/; # also, the name might contain a synonym my $syn = $current_term =~ s/\s+{([^}]+)}// ? $1 : undef; if ( ! $self->_has_term( $current_term ) ) { my $term = $self->_create_ont_entry($current_term); # add synonym(s) if any $term->add_synonym(split(/[;,]\s*/,$syn)) if $syn; # add to the machine $self->_add_term( $term, $ont ); #go on to the next term if a root node. if($current_indent == 0) { # add the virtual root as parent if there is one if($self->_virtual_root()) { $self->_add_relationship($self->_virtual_root(), $term, $self->_is_a_relationship(), $ont); } $prev_indent = $current_indent; $prev_term = $current_term; push @stack, $current_term; next; } } # note: we are ensured to see the parent first in this type of file, # so we never need to possibly insert the parent here if ( $current_indent != $prev_indent ) { if ( $current_indent == $prev_indent + 1 ) { push( @stack, $prev_term ); } elsif ( $current_indent < $prev_indent ) { my $n = $prev_indent - $current_indent; for ( my $i = 0; $i < $n; ++$i ) { pop( @stack ); } } else { $self->throw("format error: indentation level $current_indent " ."is more than one higher than the previous " ."level $prev_indent ('$current_term', " ."file ".$self->file.")" ); } } $parent = $stack[-1]; if($parent ne $current_term) { #this prevents infinite recursion from a parent linking to itself $self->_add_relationship($self->_get_terms($parent), $self->_get_terms($current_term), $self->_is_a_relationship(), $ont); } $prev_indent = $current_indent; $prev_term = $current_term; } return $ont; } # _parse_relationships_file # Parses the 1st term id number out of line. sub _get_first_termid { my ( $self, $line ) = @_; if ( $line =~ /;\s*([A-Z]{1,8}:\d{7})/ ) { return $1; } else { $self->throw( "format error: no term id in line \"$line\"" ); } } # _get_first_termid # Counts the indents at the beginning of a line in the relationships files sub _count_indents { my ( $self, $line ) = @_; my $indent = $self->indent_string; if ( $line =~ /^($indent+)/ ) { return (length($1)/length($indent)); } else { return 0; } } # _count_indents # Holds the GO engine to be parsed into sub _ont_engine { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_ont_engine" } = $value; } return $self->{ "_ont_engine" }; } # _ont_engine # Used to create ontology terms. # Arguments: name, id sub _create_ont_entry { my ( $self, $name, $termid ) = @_; my $term = $self->term_factory->create_object(-name => $name, -identifier => $termid); return $term; } # _create_ont_entry # Holds whether first record or not sub _not_first_record { my ( $self, $value ) = @_; if ( defined $value ) { unless ( $value == FALSE || $value == TRUE ) { $self->throw( "Argument to method \"_not_first_record\" must be either ".TRUE." or ".FALSE ); } $self->{ "_not_first_record" } = $value; } return $self->{ "_not_first_record" }; } # _not_first_record # Holds whether done or not sub _done { my ( $self, $value ) = @_; if ( defined $value ) { unless ( $value == FALSE || $value == TRUE ) { $self->throw( "Found [$value] where [" . TRUE ." or " . FALSE . "] expected" ); } $self->{ "_done" } = $value; } return $self->{ "_done" }; } # _done # Holds a term. sub _term { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_term" } = $value; } return $self->{ "_term" }; } # _term =head2 indent_string Title : indent_string Usage : $obj->indent_string($newval) Function: Example : Returns : value of indent_string (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub indent_string{ my $self = shift; return $self->{'indent_string'} = shift if @_; return $self->{'indent_string'}; } =head2 file_is_root Title : file_is_root Usage : $obj->file_is_root($newval) Function: Boolean indicating whether a virtual root term is to be added, the name of which will be derived from the file name. Enabling this allows one to parse multiple input files into the same ontology and still have separately rooted. Example : Returns : value of file_is_root (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub file_is_root{ my $self = shift; return $self->{'file_is_root'} = shift if @_; return $self->{'file_is_root'}; } =head2 _virtual_root Title : _virtual_root Usage : $obj->_virtual_root($newval) Function: Example : Returns : value of _virtual_root (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _virtual_root{ my $self = shift; return $self->{'_virtual_root'} = shift if @_; # don't return anything if not in file_is_root mode, or if we don't # have a file to derive the root node from return unless $self->file_is_root() && $self->file(); # construct it if we haven't done this before if(! $self->{'_virtual_root'}) { my ($rt,undef,undef) = fileparse($self->file(), '\..*'); $rt =~ s/_/ /g; $rt = $self->_create_ont_entry($rt); $self->_add_term($rt, $self->ontology_name()); $self->{'_virtual_root'} = $rt; } return $self->{'_virtual_root'}; } 1; BioPerl-1.6.923/Bio/OntologyIO/soflat.pm000444000765000024 1163412254227312 20062 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::OntologyIO::soflat # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) Hilmar Lapp, hlapp at gnf.org, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002-3. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::soflat - a parser for the Sequence Ontology flat-file format =head1 SYNOPSIS use Bio::OntologyIO; # do not use directly -- use via Bio::OntologyIO my $parser = Bio::OntologyIO->new ( -format => "so", # or soflat -defs_file => "/home/czmasek/SO/SO.defs", -file => "/home/czmasek/SO/sofa.ontology" ); my $sofa_ontology = $parser->next_ontology(); my $IS_A = Bio::Ontology::RelationshipType->get_instance( "IS_A" ); my $PART_OF = Bio::Ontology::RelationshipType->get_instance( "PART_OF" ); =head1 DESCRIPTION Needs Graph.pm from CPAN. This is essentially a very thin derivation of the dagflat base-parser. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head2 CONTRIBUTOR Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO::soflat; use strict; use Bio::Ontology::TermFactory; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::OntologyIO::dagflat); =head2 new Title : new Usage : $parser = Bio::OntologyIO->new( -format => "soflat", -files => ["/path/to/sofa.ontology"] ); Function: Creates a new soflat parser. Returns : A new soflat parser object, implementing Bio::OntologyIO. Args : -defs_file => the name of the file holding the term definitions -files => a single ontology flat file holding the term relationships, or an array ref holding the file names -file => if there is only a single flat file, it may also be specified via the -file parameter -ontology_name => the name of the ontology; if not specified the parser will auto-discover it by using the term that starts with a $, and converting underscores to spaces -engine => the Bio::Ontology::OntologyEngineI object to be reused (will be created otherwise); note that every Bio::Ontology::OntologyI will qualify as well since that one inherits from the former. See L. =cut # in reality, we let OntologyIO::new do the instantiation, and override # _initialize for all initialization work sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize( @args ); # default term object factory $self->term_factory(Bio::Ontology::TermFactory->new( -type => "Bio::Ontology::GOterm")) unless $self->term_factory(); } # _initialize 1; BioPerl-1.6.923/Bio/OntologyIO/Handlers000755000765000024 012254227323 17614 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/OntologyIO/Handlers/BaseSAXHandler.pm000444000765000024 1321712254227323 23057 0ustar00cjfieldsstaff000000000000# # BioPerl module for BaseSAXHandler # # Please direct questions and support issues to # # Cared for by Juguang Xiao, juguang@tll.org.sg # # Copyright Juguang Xiao # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::Handlers::BaseSAXHandler base class for SAX Handlers =head1 SYNOPSIS See description. =head1 DESCRIPTION This module is an abstract module, serving as the base of any SAX Handler implementation. It tries to offer the framework that SAX handlers generally need, such as tag_stack, char_store, etc. In the implementation handler, you can take advantage of this based module by the following suggestions. 1) In start_element, sub start_element { my $self=shift; my $tag=$_[0]->{Name}; my %args=%{$_[0]->{Attributes}}; # Your code here. # Before you conclude the method, write these 2 line. $self->_visited_count_inc($tag); $self->_push_tag($tag); } 2) In end_element, sub end_element { my $self=shift; my $tag=shift->{Name}; # Your code here. # Before you conclude the method, write these 2 lines. $self->_visited_count_dec($tag); $self->_pop_tag; } 3) In characters, or any other methods where you may use the tag stack or count sub characters { my $self=shift; my $text=shift->{Data}; $self->_chars_hash->{$self->_top_tag} .= $text; } $count = $self->_visited_count('myTag'); $tag = $self->_top_tag; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Juguang Xiao, juguang@tll.org.sg =head2 APPENDIX The rest of the documentation details each of the object methods. Interal methods are usually preceded with a _ =cut package Bio::OntologyIO::Handlers::BaseSAXHandler; use strict; use base qw(Bio::Root::Root); sub new { my ($class, @args) = @_; my $self=$class->SUPER::new(@args); $self->_initialize(@args); return $self; } sub _initialize { my $self = shift; $self->{_tag_stack} = []; $self->{_visited_count} = {}; $self->{_chars_hash} = {}; $self->{_current_hash} = {}; } =head2 _tag_stack Title : _tag_stack Usage : @tags = $self->_tag_stack; Function: Get an array of tags that have been accessed but not enclosed. Return : Args : =cut sub _tag_stack { return @{shift->{_tag_stack}}; } =head2 _push_tag =cut sub _push_tag { my($self,$tag)=@_; push @{$self->{_tag_stack}}, $tag; } =head2 _pop_tag =cut sub _pop_tag { my $self=shift; return pop @{$self->{_tag_stack}}; } =head2 _top_tag Title : _top_tag Usage : $top = $self->_top_tag; Function: get the top tag in the tag stack. Return : a tag name Args : [none] =cut sub _top_tag { my $self = shift; my @stack=@{$self->{_tag_stack}}; return $stack[-1]; # get the last element in an array while remaining it in. There are few ways # 1) $stack[-1] # 2) $stack[$#stack] # 3) $stack[@stack-1] } =head2 _chars_hash Title : _chars_hash Usage : $hash= $self->_chars_hash; Function: return the character cache for the specific tag Return : a hash reference, which is intent for character storage for tags Args : [none] =cut sub _chars_hash { return shift->{_chars_hash}; } =head2 _current_hash =cut sub _current_hash { return shift->{_current_hash}; } =head2 _visited_count_inc Title : _vistied_count_inc Usage : $self->vistied_count_inc($tag); # the counter for the tag increase Function: the counter for the tag increase Return : the current count after this increment Args : the tag name [scalar] =cut sub _visited_count_inc { my ($self, $tag) = @_; my $visited_count=$self->{_visited_count}; if(exists $visited_count->{$tag}){ $visited_count->{$tag}++; }else{ $visited_count->{$tag}=1; } return $visited_count->{$tag}; } =head2 _visited_count_dec Title : _visited_count_dec Usage : $self->_visited_count_dec($tag); Function: the counter for the tag decreases by one Return : the current count for the specific tag after the decrement Args : the tag name [scalar] =cut sub _visited_count_dec { my ($self, $tag) = @_; my $visited_count=$self->{_visited_count}; if(exists $visited_count->{$tag}){ $visited_count->{$tag}--; }else{ $self->throw("'$tag' has not been visited yet. How to decrease it?!"); } return $visited_count->{$tag}; } =head2 _visited_count Title : _visited_count Usage : $count = $self->_visited_count Function: return the counter for the tag Return : the current counter for the specific tag Args : the tag name [scalar] =cut sub _visited_count { my ($self, $tag) = @_; return $self->{_visited_count}->{$tag}; } 1; BioPerl-1.6.923/Bio/OntologyIO/Handlers/InterPro_BioSQL_Handler.pm000444000765000024 4605012254227313 24703 0ustar00cjfieldsstaff000000000000# # BioPerl module for InterPro_BioSQL_Handler # # Please direct questions and support issues to # # Cared for by Juguang Xiao, juguang@tll.org.sg # # Copyright Juguang Xiao # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::Handlers::InterPro_BioSQL_Handler - parse an InterPro XML file and persist the resulting terms to a Biosql database =head1 SYNOPSIS # see load_interpro.pl in bioperl-db/scripts/biosql/ =head1 DESCRIPTION This module is for parsing an InterPro XML file and persist the resulting terms to a Biosql database as soon as the term is complete as signaled by the appropriate xml tag. This parser takes advantage of SAX, a stream-based XML parser technology, to keep the used memory as small as possible. The alternative parser for InterPro, module InterProHandler, builds up the entire ontology in memory, which given the size of the latest InterPro releases requires a huge amount of memory. This module takes the following non-standard arguments upon instantiation. -db the adaptor factory as returned by a call to Bio::DB::BioDB->new() -version the InterPro version (not available as property!) -term_factory the object factory to use for creating terms Note that there are two alternatives for how to persist the terms and relationships to the database. The default is using the adaptor factory passed as -db or set as a property to create persistent objects and store them in the database. The alternative is to specify a term persistence and a relationship persistence handler; if one or both have been set, the respective handler will be called with each term and relationship that is to be stored. See properties persist_term_handler and persist_relationship_handler. =head1 AUTHOR Juguang Xiao, juguang@tll.org.sg =head1 Contributors Hilmar Lapp, hlapp at gmx.net =head2 APPENDIX The rest of the documentation details each of the object methods. Interal methods are usually preceded with a _ =cut package Bio::OntologyIO::Handlers::InterPro_BioSQL_Handler; use strict; use Bio::Ontology::Ontology; use Bio::Ontology::Term; use Bio::Ontology::TermFactory; use Bio::Ontology::RelationshipType; use Bio::Ontology::Relationship; use Bio::Annotation::DBLink; use Bio::Annotation::Reference; use base qw(Bio::OntologyIO::Handlers::BaseSAXHandler); my $is_a_rel; my $count=0; sub _initialize { my($self,@args)=@_; $self->SUPER::_initialize(@args); my ($db, $version, $fact) = $self->_rearrange( [qw(DB VERSION TERM_FACTORY)], @args); $self->db($db) if $db; # this is now a property and may be set later if (!$fact) { $fact = Bio::Ontology::TermFactory->new(-type=>"Bio::Ontology::Term"); } $self->term_factory($fact); my $ontology = Bio::Ontology::Ontology->new(-name => 'InterPro'); if (defined($version)) { $version = "InterPro version $version"; $ontology->definition($version); } $self->_ontology($ontology); $is_a_rel = Bio::Ontology::RelationshipType->get_instance('IS_A'); $is_a_rel->ontology($ontology); } =head2 term_factory Title : term_factory Usage : $obj->term_factory($newval) Function: Get/set the ontology term factory to use. As a user of this module it is not necessary to call this method as there will be default. In order to change the default, the easiest way is to instantiate L with the proper -type argument. Most if not all parsers will actually use this very implementation, so even easier than the aforementioned way is to simply call $ontio->term_factory->type("Bio::Ontology::MyTerm"). Example : Returns : value of term_factory (a Bio::Factory::ObjectFactoryI object) Args : on set, new value (a Bio::Factory::ObjectFactoryI object, optional) =cut sub term_factory{ my $self = shift; return $self->{'term_factory'} = shift if @_; return $self->{'term_factory'}; } =head2 db Title : db Usage : $obj->db($newval) Function: Sets or retrieves the database adaptor factory. The adaptor factory is a Bio::DB::DBAdaptorI compliant object and will be used to obtain the persistence adaptors necessary to serialize terms and relationships to the database. Usually, you will obtain such an object from a call to Bio::DB::BioDB. You *must* set this property before starting the parse. Note that this property is immutable once set, except that you may set it to undef. Therefore, be careful not to set to undef before setting the desired real value. Example : Returns : value of db (a Bio::DB::DBAdaptorI compliant object) Args : on set, new value (a Bio::DB::DBAdaptorI compliant object or undef, optional) =cut sub db { my $self=shift; if(@_){ my $db = shift; if ($db && exists($self->{_db}) && ($self->{_db} != $db)) { $self->throw('db may not be modified once set'); } $self->{_db}=$db; } return $self->{_db}; } =head2 persist_term_handler Title : persist_term_handler Usage : $obj->persist_term_handler($handler,@args) Function: Sets or retrieves the persistence handler for terms along with the constant set of arguments to be passed to the handler. If set, the first argument will be treated as a closure and be called for each term to persist to the database. The term will be passed as a named parameter (-term), followed by the other arguments passed to this setter. Note that this allows one to pass an arbitrary configuration to the handler. If not set, terms will be persisted along with their relationships using the respective persistence adaptor returned by the adaptor factory (see property db). Example : Returns : an array reference with the values passed on set, or an empty array if never set Args : On set, an array of values. The first value is the handler as a closure; all other values will be passed to the handler as constant argument. =cut sub persist_term_handler{ my $self = shift; return $self->{'persist_term_handler'} = [@_] if @_; return $self->{'persist_term_handler'} || []; } =head2 persist_relationship_handler Title : persist_relationship_handler Usage : $obj->persist_relationship_handler($handler,@args) Function: Sets or retrieves the persistence handler for relationships along with the constant set of arguments to be passed to the handler. If set, the first argument will be treated as a closure and be called for each relationship to persist to the database. The relationship will be passed as a named parameter (-rel), followed by the other arguments passed to this setter. Note that this allows one to pass an arbitrary configuration to the handler. If not set, relationships will be persisted along with their relationships using the respective persistence adaptor returned by the adaptor factory (see property db). Example : Returns : an array reference with the values passed on set, or an empty array if never set Args : On set, an array of values. The first value is the handler as a closure; all other values will be passed to the handler as constant argument. =cut sub persist_relationship_handler{ my $self = shift; return $self->{'persist_relationship_handler'} = [@_] if @_; return $self->{'persist_relationship_handler'} || []; } =head2 _persist_term Title : _persist_term Usage : Function: Persists a term to the database, using either a previously set persistence handler, or the adaptor factory directly. Example : Returns : Args : the ontology term to persist =cut sub _persist_term { my $self = shift; my $term = shift; my ($handler,@args) = @{$self->persist_term_handler}; if ($handler) { &$handler('-term' => $term, @args); } else { # no handler; we'll do this ourselves straight and simple my $db = $self->db(); my $pterm = $db->create_persistent($term); eval { $pterm->create(); $pterm->commit(); }; if ($@) { $pterm->rollback(); $self->warn("failed to store term '".$term->name."': ".$@); } } } =head2 _persist_relationship Title : _persist_relationship Usage : Function: Persists a relationship to the database, using either a previously set persistence handler, or the adaptor factory directly. Example : Returns : Args : the term relationship to persist =cut sub _persist_relationship { my $self = shift; my $rel = shift; my ($handler,@args) = @{$self->persist_relationship_handler}; if ($handler) { &$handler('-rel' => $rel, @args); } else { # no handler; we'll do this ourselves straight and simple my $db = $self->db(); my $prel = $db->create_persistent($rel); eval { $prel->create(); $prel->commit(); }; if ($@) { $prel->rollback(); $self->warn("failed to store relationship of subject '" .$rel->subject_term->name."' to object '" .$rel->object_term->name.": ".$@); } } } =head2 _persist_ontology Title : _persist_ontology Usage : Function: Perists the ontology itself to the database, by either inserting or updating it. Note that this will only create or update the ontology as an entity, not any of its terms, relationships, or relationship types. Example : Returns : the ontology as a peristent object with primary key Args : the ontology to persist as a Bio::Ontology::OntologyI compliant object =cut sub _persist_ontology{ my $self = shift; my $ont = shift; my $db = $self->db(); # do a lookup first; chances are we have this already in the database my $adp = $db->get_object_adaptor($ont); # to avoid clobbering this ontology's properties with possibly older ones # from the database we'll need an object factory my $ontfact = Bio::Factory::ObjectFactory->new(-type=>"Bio::Ontology::Ontology"); # do the lookup: my $found = $adp->find_by_unique_key($ont, '-obj_factory' => $ontfact); # make a persistent object of the ontology $ont = $db->create_persistent($ont); # transfer primary key if found in the lookup $ont->primary_key($found->primary_key) if $found; # insert or update my $result; eval { $result = $ont->store(); }; if ($@ || !$result) { $adp->rollback(); $self->throw("failed to update ontology '" .$ont->name."' in database".($@ ? ": $@" : "")); } # done - we don't commit here return ref($result) ? $result : $ont; } sub start_document { my $self = shift; my $ont = $self->_ontology; my @iprtypes = ( $self->create_term(-identifier=>'IPR:Family', -name=>'Family', -ontology => $ont), $self->create_term(-identifier=>'IPR:Domain', -name=>'Domain', -ontology => $ont), $self->create_term(-identifier=>'IPR:Repeat', -name=>'Repeat', -ontology => $ont), $self->create_term(-identifier=>'IPR:PTM', -name=>'post-translational modification', -ontology => $ont), $self->create_term(-identifier=>'IPR:Active_site', -name=>'Active_site', -ontology => $ont), $self->create_term(-identifier=>'IPR:Binding_site', -name=>'Binding_site', -ontology => $ont), ); foreach my $iprtype (@iprtypes) { $self->_persist_term($iprtype); $ont->add_term($iprtype); } } sub start_element { my $self=shift; my $tag=$_[0]->{Name}; my %args=%{$_[0]->{Attributes}}; my $ont = $self->_ontology; if($tag eq 'interpro'){ my $id = $args{id}; my $term = $self->create_term(-identifier=>$id); $term->ontology($ont); $term->add_synonym($args{short_name}); #$term->definition(); my ($object_term) = ($ont->engine->get_term_by_identifier("IPR:".$args{type})); my $rel = Bio::Ontology::Relationship->new( -subject_term => $term, -predicate_term => $is_a_rel, -object_term => $object_term, -ontology => $ont ); $self->_relationship($rel); }elsif($tag eq 'example'){ my $example = Bio::Annotation::DBLink->new; $self->_current_hash->{example} = $example; }elsif($tag eq 'db_xref'){ my $top = $self->_top_tag; if($top eq 'example'){ my $example = $self->_current_hash->{example}; $example->database($args{db}); $example->primary_id($args{dbkey}); #print "EXAmPLE:\t", $example->database, '|', $example->primary_id, "\n"; }elsif($top eq 'child'){ ; }elsif($top eq 'member_list'){ my $dblink=Bio::Annotation::DBLink->new( -dbname => $args{id}, -primary_id => $args{dbkey}, -comment => $args{name} ); }elsif($top eq 'external_doc_list'){ ; }elsif($top eq 'publication'){ if($args{db} eq 'MEDLINE'){ $self->_current_hash->{medline} =$args{dbkey}; } elsif($args{db} eq 'PUBMED'){ $self->_current_hash->{pubmed} =$args{dbkey}; }else{ $self->warn("'".$args{dbkey}."' is not a MEDLINE publication, " ."don't know how to handle"); } }elsif($top eq 'structure_db_links'){ ; }elsif($top eq 'abstract'){ ; } #else{ # $self->warn("unrecognized element '$top' in element '$tag', ignoring"); #} }elsif($tag eq 'publication'){ my $publication = Bio::Annotation::Reference->new(); $self->_current_hash->{publication} = $publication; }elsif($tag eq 'author_list'){ ; }elsif($tag eq 'journal'){ ; }elsif($tag eq 'location'){ ; }elsif($tag eq 'year'){ ; } elsif (($tag eq 'dbinfo') && ($self->_top_tag eq 'release')) { my $entrydate = $args{file_date} || ''; $entrydate =~ s/ \d{2}:\d{2}:\d{2}//; my $def = $ont->definition() || ''; $def .= "\n" if length($def) > 0; $def .= $args{dbname}." version ".$args{version}.", " .$args{entry_count}." entries, ".$entrydate; $ont->definition($def); } #else{ # $self->warn("unrecognized element '$tag', ignoring"); #} $self->_visited_count_inc($tag); $self->_push_tag($tag); } sub end_element { my $self=shift; my $tag=shift->{Name}; my $chars_in=$self->_chars_hash->{$tag}; if($tag eq 'interpro'){ my $rel = $self->_relationship; # store subject term first in order to give the handler a chance to # apply whatever custom behaviour # (note that the object term is the InterPro type and has been stored # at the start of the whole document) $self->_persist_term($rel->subject_term); # the store the relationship to the InterPro type $self->_persist_relationship($rel); }elsif($tag eq 'name'){ my $rel = $self->_relationship; $rel->subject_term->name($self->_chars_hash->{name}); $self->_chars_hash->{name}=''; }elsif($tag eq 'abstract'){ my $rel = $self->_relationship; my $abstract = $self->_chars_hash->{abstract}; $abstract =~ s/\n/ /g; $rel->subject_term->definition($abstract); $self->_chars_hash->{abstract} = ''; }elsif($tag eq 'example'){ my $example = $self->_current_hash->{example}; my $comment = $self->_chars_hash->{example}; $comment =~ s/^(\s+)//; $comment =~ s/(\s+)$//; $example->comment($comment); $self->_relationship->subject_term->add_dbxref(-dbxrefs => [$example]); $self->_chars_hash->{example}=''; }elsif($tag eq 'publication'){ my $publication = $self->_create_publication; $self->_relationship->subject_term->add_reference($publication); }elsif($tag eq 'author_list'){ $self->_current_hash->{author} =$chars_in; }elsif($tag eq 'title'){ $self->_current_hash->{title}=$chars_in; } elsif ($tag eq 'release') { my $ont = $self->_persist_ontology($self->_ontology); $self->_ontology($ont) if $ont; } $self->_pop_tag; $self->_visited_count_dec($tag); } sub characters { my $self=shift; my $text = shift->{Data}; my $top_tag =$self->_top_tag; $self->_chars_hash->{$top_tag} .= $text; # $self->_chars_hash->{abstract} .= $text if $self->_visited_count('abstract'); } sub create_term { return shift->term_factory->create_object(@_); } sub _ontology { my $self = shift; return $self->{_ontology}=shift if @_; return $self->{_ontology}; } sub _relationship { my $self =shift; $self->{_relationship}=shift if @_; return $self->{_relationship}; } sub _create_publication { my $self=shift; my $publ = $self->_current_hash->{publication}; my $journal = $self->_current_hash->{journal} || ''; my $year = $self->_current_hash->{year} || ''; my $page_location = $self->_current_hash->{page_location} || ''; my $volumn = $self->_current_hash->{volumn} || ''; my $medline = $self->_current_hash->{medline} || $self->_current_hash->{pubmed}; $publ->authors($self->_current_hash->{author}); $publ->location("$journal, $year, V $volumn, $page_location"); $publ->title($self->_current_hash->{title}); $publ->medline($medline); if ($self->_current_hash->{pubmed} && ($self->_current_hash->{pubmed} != $medline)) { $publ->pubmed($self->_current_hash->{pubmed}); } # Clear the above in current hash $self->_current_hash->{publication} = undef; $self->_current_hash->{author} = undef; $self->_current_hash->{journal} = undef; $self->_current_hash->{year} = undef; $self->_current_hash->{page_location}=undef; $self->_current_hash->{volumn} = undef; $self->_current_hash->{title} = undef; $self->_current_hash->{medline} = undef; $self->_current_hash->{pubmed} = undef; } 1; BioPerl-1.6.923/Bio/OntologyIO/Handlers/InterProHandler.pm000444000765000024 5334212254227323 23376 0ustar00cjfieldsstaff000000000000# # BioPerl module for InterProHandler # # Please direct questions and support issues to # # Cared for by Peter Dimitrov # # Copyright Peter Dimitrov # (c) Peter Dimitrov, dimitrov@gnf.org, 2003. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2003. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::OntologyIO::Handlers::InterProHandler - XML handler class for InterProParser =head1 SYNOPSIS # do not use directly - used and instantiated by InterProParser =head1 DESCRIPTION Handles xml events generated by InterProParser when parsing InterPro XML files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Dimitrov Email dimitrov@gnf.org =head1 CONTRIBUTORS Juguang Xiao, juguang@tll.org.sg =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::OntologyIO::Handlers::InterProHandler; use strict; use Carp; use Bio::Ontology::Ontology; use Bio::Ontology::RelationshipType; use Bio::Ontology::SimpleOntologyEngine; use Bio::Annotation::Reference; use Data::Dumper; use base qw(Bio::Root::Root); my ( $record_count, $processed_count, $is_a_rel, $contains_rel, $found_in_rel ); =head2 new Title : new Usage : $h = Bio::OntologyIO::Handlers::InterProHandler->new; Function: Initializes global variables Example : Returns : an InterProHandler object Args : =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); my ( $eng, $ont, $name, $fact ) = $self->_rearrange( [qw[ ENGINE ONTOLOGY ONTOLOGY_NAME TERM_FACTORY ]], @args ); if ( defined($ont) ) { $self->ontology($ont); } else { $name = "InterPro" unless $name; $self->ontology( Bio::Ontology::Ontology->new( -name => $name ) ); } $self->ontology_engine($eng) if $eng; $self->term_factory($fact) if $fact; $is_a_rel = Bio::Ontology::RelationshipType->get_instance("IS_A"); $contains_rel = Bio::Ontology::RelationshipType->get_instance("CONTAINS"); $found_in_rel = Bio::Ontology::RelationshipType->get_instance("FOUND_IN"); $is_a_rel->ontology( $self->ontology() ); $contains_rel->ontology( $self->ontology() ); $found_in_rel->ontology( $self->ontology() ); $self->_cite_skip(0); $self->secondary_accessions_map( {} ); return $self; } =head2 ontology_engine Title : ontology_engine Usage : $obj->ontology_engine($newval) Function: Get/set ontology engine. Can be initialized only once. Example : Returns : value of ontology_engine (a scalar) Args : new value (a scalar, optional) =cut sub ontology_engine { my ( $self, $value ) = @_; if ( defined $value ) { if ( defined $self->{'ontology_engine'} ) { $self->throw("ontology_engine already defined"); } else { $self->throw( ref($value) . " does not implement " . "Bio::Ontology::OntologyEngineI. Bummer." ) unless $value->isa("Bio::Ontology::OntologyEngineI"); $self->{'ontology_engine'} = $value; # don't forget to set this as the engine of the ontology, otherwise # those two might not point to the same object my $ont = $self->ontology(); if ( $ont && $ont->can("engine") && ( !$ont->engine() ) ) { $ont->engine($value); } $self->debug( ref($self) . "::ontology_engine: registering ontology engine (" . ref($value) . "):\n" . $value->to_string . "\n" ); } } return $self->{'ontology_engine'}; } =head2 ontology Title : ontology Usage : Function: Get the ontology to add the InterPro terms to. The value is determined automatically once ontology_engine has been set and if it hasn't been set before. Example : Returns : A L implementing object. Args : On set, a L implementing object. =cut sub ontology { my ( $self, $ont ) = @_; if ( defined($ont) ) { $self->throw( ref($ont) . " does not implement Bio::Ontology::OntologyI" . ". Bummer." ) unless $ont->isa("Bio::Ontology::OntologyI"); $self->{'_ontology'} = $ont; } return $self->{'_ontology'}; } =head2 term_factory Title : term_factory Usage : $obj->term_factory($newval) Function: Get/set the ontology term object factory Example : Returns : value of term_factory (a Bio::Factory::ObjectFactory instance) Args : on set, new value (a Bio::Factory::ObjectFactory instance or undef, optional) =cut sub term_factory { my $self = shift; return $self->{'term_factory'} = shift if @_; return $self->{'term_factory'}; } =head2 _cite_skip Title : _cite_skip Usage : $obj->_cite_skip($newval) Function: Example : Returns : value of _cite_skip (a scalar) Args : new value (a scalar, optional) =cut sub _cite_skip { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_cite_skip'} = $value; } return $self->{'_cite_skip'}; } =head2 _hash Title : _hash Usage : $obj->_hash($newval) Function: Example : Returns : value of _hash (a scalar) Args : new value (a scalar, optional) =cut sub _hash { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_hash'} = $value; } return $self->{'_hash'}; } =head2 _stack Title : _stack Usage : $obj->_stack($newval) Function: Example : Returns : value of _stack (a scalar) Args : new value (a scalar, optional) =cut sub _stack { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_stack'} = $value; } return $self->{'_stack'}; } =head2 _top Title : _top Usage : Function: Example : Returns : Args : =cut sub _top { my ( $self, $_stack ) = @_; my @stack = @{$_stack}; return ( @stack >= 1 ) ? $stack[ @stack - 1 ] : undef; } =head2 _term Title : _term Usage : $obj->_term($newval) Function: Get/set method for the term currently processed. Example : Returns : value of term (a scalar) Args : new value (a scalar, optional) =cut sub _term { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_term'} = $value; } return $self->{'_term'}; } =head2 _clear_term Title : _clear_term Usage : Function: Removes the current term from the handler Example : Returns : Args : =cut sub _clear_term { my ($self) = @_; delete $self->{'_term'}; } =head2 _names Title : _names Usage : $obj->_names($newval) Function: Example : Returns : value of _names (a scalar) Args : new value (a scalar, optional) =cut sub _names { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_names'} = $value; } return $self->{'_names'}; } =head2 _create_relationship Title : _create_relationship Usage : Function: Helper function. Adds relationships to one of the relationship stores. Example : Returns : Args : =cut { my %relationship_cache; sub _clear_cache { %relationship_cache = () } sub _create_relationship { my ( $self, $ref_id, $rel_type_term ) = @_; my $ont = $self->ontology(); my $fact = $self->term_factory(); my $term_temp = ( $ont->engine->get_term_by_identifier($ref_id) )[0]; if ( !defined $term_temp ) { $term_temp = $ont->engine->add_term( $fact->create_object( -InterPro_id => $ref_id, -name => $ref_id, -ontology => $ont ) ); $ont->engine->mark_uninstantiated($term_temp); } my $marshalled = join(':', (sort $self->_term->identifier, $ref_id)); # check cache to see if the two have been seen before, using marshalled IDs if ($relationship_cache{$marshalled}++) { # TODO: should check that the relationship type for these terms is the # inverse of the stored relationship type return; } my $rel_type_name = $self->_top( $self->_names ); my $rel = Bio::Ontology::Relationship->new( -predicate_term => $rel_type_term ); if ( $rel_type_name eq 'parent_list' || $rel_type_name eq 'found_in' ) { $rel->object_term($term_temp); $rel->subject_term( $self->_term ); } else { $rel->object_term( $self->_term ); $rel->subject_term($term_temp); } $rel->ontology($ont); $ont->add_relationship($rel); } } =head2 start_element Title : start_element Usage : Function: This is a method that is derived from XML::SAX::Base and has to be overridden for processing start of xml element events. Used internally only. Example : Returns : Args : =cut sub start_element { my ( $self, $element ) = @_; my $ont = $self->ontology(); my $fact = $self->term_factory(); if ( $element->{Name} eq 'interprodb' ) { $ont->add_term( $fact->create_object( -identifier => "Active_site", -name => "Active Site" ) ); $ont->add_term( $fact->create_object( -identifier => "Conserved_site", -name => "Conserved Site" ) ); $ont->add_term( $fact->create_object( -identifier => "Binding_site", -name => "Binding Site" ) ); $ont->add_term( $fact->create_object( -identifier => "Family", -name => "Family" ) ); $ont->add_term( $fact->create_object( -identifier => "Domain", -name => "Domain" ) ); $ont->add_term( $fact->create_object( -identifier => "Repeat", -name => "Repeat" ) ); $ont->add_term( $fact->create_object( -identifier => "PTM", -name => "post-translational modification" ) ); $ont->add_term( $fact->create_object( -identifier => "Region", -name => "Region" ) ); } elsif ( $element->{Name} eq 'interpro' ) { my %record_args = %{ $element->{Attributes} }; my $id = $record_args{"id"}; # this sets the current term my $term = ( $ont->engine->get_term_by_identifier($id) )[0] || $fact->create_object( -InterPro_id => $id, -name => $id ); $self->_term($term); $term->ontology($ont); $term->short_name( $record_args{"short_name"} ); $term->protein_count( $record_args{"protein_count"} ); $self->_increment_record_count(); $self->_stack( [ { interpro => undef } ] ); $self->_names( ["interpro"] ); ## Adding a relationship between the newly created InterPro term ## and the term describing its type my $rel = Bio::Ontology::Relationship->new( -predicate_term => $is_a_rel ); my ($object_term) = $ont->find_terms( -identifier => $record_args{"type"} ) or $self->throw( "when processing interpro ID '$id', no term found for interpro type '$record_args{type}'" ); $rel->object_term($object_term); $rel->subject_term( $self->_term ); $rel->ontology($ont); $ont->add_relationship($rel); $ont->add_term($term); } elsif ( defined $self->_stack ) { my %hash = (); if ( keys %{ $element->{Attributes} } > 0 ) { foreach my $key ( keys %{ $element->{Attributes} } ) { $hash{$key} = $element->{Attributes}->{$key}; } } push @{ $self->_stack }, \%hash; if ( $element->{Name} eq 'rel_ref' ) { my $ref_id = $element->{Attributes}->{"ipr_ref"}; my $parent = $self->_top( $self->_names ); if ( $parent eq 'parent_list' || $parent eq 'child_list' ) { $self->_create_relationship( $ref_id, $is_a_rel ); } if ( $parent eq 'contains' ) { $self->_create_relationship( $ref_id, $contains_rel ); } if ( $parent eq 'found_in' ) { $self->_create_relationship( $ref_id, $found_in_rel ); } } elsif ( $element->{Name} eq 'abstract' ) { $self->_cite_skip(1); } push @{ $self->_names }, $element->{Name}; } } =head2 _char_storage Title : _char_storage Usage : $obj->_char_storage($newval) Function: Example : Returns : value of _char_storage (a scalar) Args : new value (a scalar, optional) =cut sub _char_storage { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_char_storage'} = $value; } return $self->{'_char_storage'}; } =head2 characters Title : characters Usage : Function: This is a method that is derived from XML::SAX::Base and has to be overridden for processing xml characters events. Used internally only. Example : Returns : Args : =cut sub characters { my ( $self, $characters ) = @_; my $text = $characters->{Data}; chomp $text; $text =~ s/^(\s+)//; $self->{_char_storage} .= $text; } =head2 end_element Title : end_element Usage : Function: This is a method that is derived from XML::SAX::Base and has to be overridden for processing end of xml element events. Used internally only. Example : Returns : Args : =cut sub end_element { my ( $self, $element ) = @_; if ( $element->{Name} eq 'interprodb' ) { $self->debug( "Interpro DB Parser Finished: $record_count read, $processed_count processed\n"); $self->_clear_cache(); } elsif ( $element->{Name} eq 'interpro' ) { $self->_clear_term; $self->_increment_processed_count(); } elsif ( $element->{Name} ne 'cite' ) { $self->{_char_storage} =~ s/<\/?p>//g; if ( ( defined $self->_stack ) ) { my $current_hash = pop @{ $self->_stack }; my $parent_hash = $self->_top( $self->_stack ); my $current_hash_key = pop @{ $self->_names }; if ( keys %{$current_hash} > 0 && $self->_char_storage ne "" ) { $current_hash->{comment} = $self->_char_storage; push @{ $parent_hash->{$current_hash_key} }, $current_hash; } elsif ( $self->_char_storage ne "" ) { push @{ $parent_hash->{$current_hash_key} }, { 'accumulated_text_12345' => $self->_char_storage }; } elsif ( keys %{$current_hash} > 0 ) { push @{ $parent_hash->{$current_hash_key} }, $current_hash; } if ( $element->{Name} eq 'pub_list' ) { my @refs = (); foreach my $pub_record ( @{ $current_hash->{publication} } ) { my $ref = Bio::Annotation::Reference->new; my $loc = $pub_record->{location}->[0]; # TODO: Getting unset stuff here; should this be an error? $ref->location( sprintf("%s, %s-%s, %s, %s", $pub_record->{journal}->[0]->{accumulated_text_12345} || '', $loc->{firstpage} || '', $loc->{lastpage} || '', $loc->{volume} || '', $pub_record->{year}->[0]->{accumulated_text_12345} || '') ); $ref->title( $pub_record->{title}->[0]->{accumulated_text_12345} ); my $ttt = $pub_record->{author_list}->[0]; $ref->authors( $ttt->{accumulated_text_12345} ); $ref->medline( scalar( $ttt->{dbkey} ) ) if exists( $ttt->{db} ) && $ttt->{db} eq "MEDLINE"; push @refs, $ref; } $self->_term->add_reference(@refs); } elsif ( $element->{Name} eq 'name' ) { $self->_term->name( $self->_char_storage ); } elsif ( $element->{Name} eq 'abstract' ) { $self->_term->definition( $self->_char_storage ); $self->_cite_skip(0); } elsif ( $element->{Name} eq 'member_list' ) { my @refs = (); foreach my $db_xref ( @{ $current_hash->{db_xref} } ) { push @refs, Bio::Annotation::DBLink->new( -database => $db_xref->{db}, -primary_id => $db_xref->{dbkey} ); } $self->_term->add_dbxref(-dbxrefs => \@refs, -context => 'member_list'); } elsif ( $element->{Name} eq 'sec_list' ) { my @refs = (); foreach my $sec_ac ( @{ $current_hash->{sec_ac} } ) { push @refs, $sec_ac->{sec_ac}; } $self->_term->add_secondary_id(@refs); $self->secondary_accessions_map->{ $self->_term->identifier } = \@refs; } elsif ( $element->{Name} eq 'example_list' ) { my @refs = (); foreach my $example ( @{ $current_hash->{examples} } ) { push @refs, Bio::Annotation::DBLink->new( -database => $example->{db_xref}->[0]->{db}, -primary_id => $example->{db_xref}->[0]->{dbkey}, -comment => $example->{comment} ); } $self->_term->add_dbxref(-dbxrefs => \@refs, -context => 'example_list'); } elsif ( $element->{Name} eq 'external_doc_list' ) { my @refs = (); foreach my $db_xref ( @{ $current_hash->{db_xref} } ) { push @refs, Bio::Annotation::DBLink->new( -database => $db_xref->{db}, -primary_id => $db_xref->{dbkey} ); } $self->_term->add_dbxref(-dbxrefs => \@refs, -context => 'external_doc_list'); } elsif ( $element->{Name} eq 'class_list' ) { my @refs = (); foreach my $classification ( @{ $current_hash->{classification} } ) { push @refs, Bio::Annotation::DBLink->new( -database => $classification->{class_type}, -primary_id => $classification->{id} ); } $self->_term->add_dbxref(-dbxrefs => \@refs, -context => 'class_list'); } elsif ( $element->{Name} eq 'deleted_entries' ) { my @refs = (); foreach my $del_ref ( @{ $current_hash->{del_ref} } ) { my $term = ( $self->ontology_engine->get_term_by_identifier( $del_ref->{id} ) )[0]; $term->is_obsolete(1) if defined $term; } } } $self->_char_storage('') if !$self->_cite_skip; } } =head2 secondary_accessions_map Title : secondary_accessions_map Usage : $obj->secondary_accessions_map($newval) Function: Example : $map = $interpro_handler->secondary_accessions_map(); Returns : Reference to a hash that maps InterPro identifier to an array reference of secondary accessions following the InterPro xml schema. Args : Empty hash reference =cut sub secondary_accessions_map { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'secondary_accessions_map'} = $value; } return $self->{'secondary_accessions_map'}; } =head2 _increment_record_count Title : _increment_record_count Usage : Function: Example : Returns : Args : =cut sub _increment_record_count { $record_count++; } =head2 _increment_processed_count Title : _increment_processed_count Usage : Function: Example : Returns : Args : =cut sub _increment_processed_count { my $self = shift; $processed_count++; $self->debug("$processed_count\n") if $processed_count % 100 == 0; } 1; BioPerl-1.6.923/Bio/Phenotype000755000765000024 012254227332 15765 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Phenotype/Correlate.pm000444000765000024 2140612254227325 20425 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::Correlate # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::Correlate - Representation of a correlating phenotype in a given species =head1 SYNOPSIS use Bio::Phenotype::Correlate; $co = Bio::Phenotype::Correlate->new( -name => "4(Tas1r3)", -description => "mouse correlate of human phenotype MIM 605865", -species => $mouse, -type => "homolog", -comment => "type=homolog is putative" ); print $co->name(); print $co->description(); print $co->species()->binomial(); print $co->type(); print $co->comment(); print $co->to_string(); =head1 DESCRIPTION This class models correlating phenotypes. Its creation was inspired by the OMIM database where many human phenotypes have a correlating mouse phenotype. Therefore, this class is intended to be used together with a phenotype class. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Phenotype::Correlate; use strict; use Bio::Species; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $co = Bio::Phenotype::Correlate->new( -name => "4(Tas1r3)", -description => "mouse correlate of human phenotype MIM 605865", -species => $mouse, -type => "homolog", -comment => "type=homolog is putative" ); Function: Creates a new Correlate object. Returns : A new Correlate object. Args : -name => a name or id -description => a description -species => the species of this correlating phenotype [Bio::Species] -type => the type of correlation -comment => a comment =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $name, $desc, $species, $type, $comment ) = $self->_rearrange( [ qw( NAME DESCRIPTION SPECIES TYPE COMMENT ) ], @args ); $self->init(); $name && $self->name( $name ); $desc && $self->description( $desc ); $species && $self->species( $species ); $type && $self->type( $type ); $comment && $self->comment( $comment ); return $self; } # new =head2 init Title : init() Usage : $co->init(); Function: Initializes this Correlate to all "". Returns : Args : =cut sub init { my( $self ) = @_; $self->name( "" ); $self->description( "" ); my $species = Bio::Species->new(); $species->classification( qw( species Undetermined ) ); $self->species( $species ); $self->type( "" ); $self->comment( "" ); } # init =head2 name Title : name Usage : $co->name( "4(Tas1r3)" ); or print $co->name(); Function: Set/get for the name or id of this Correlate. Returns : The name or id of this Correlate. Args : The name or id of this Correlate (optional). =cut sub name { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_name" } = $value; } return $self->{ "_name" }; } # name =head2 description Title : description Usage : $co->description( "mouse correlate of human phenotype MIM 03923" ); or print $co->description(); Function: Set/get for the description of this Correlate. Returns : A description of this Correlate. Args : A description of this Correlate (optional). =cut sub description { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_description" } = $value; } return $self->{ "_description" }; } # description =head2 species Title : species Usage : $co->species( $species ); or $species = $co->species(); Function: Set/get for the species of this Correlate. Returns : The Bio::Species of this Correlate [Bio::Species]. Args : The Bio::Species of this Correlate [Bio::Species] (optional). =cut sub species { my ( $self, $value ) = @_; if ( defined $value ) { $self->_check_ref_type( $value, "Bio::Species" ); $self->{ "_species" } = $value; } return $self->{ "_species" }; } # species =head2 type Title : type Usage : $co->type( "homolog" ); or print $co->type(); Function: Set/get for the type of this Correlate. Returns : The type of this Correlate. Args : The type of this Correlate (optional). =cut sub type { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_type" } = $value; } return $self->{ "_type" }; } # type =head2 comment Title : comment Usage : $co->comment( "doubtful" ); or print $co->comment(); Function: Set/get for an arbitrary comment about this Correlate. Returns : A comment. Args : A comment (optional). =cut sub comment { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_comment" } = $value; } return $self->{ "_comment" }; } # comment =head2 to_string Title : to_string() Usage : print $co->to_string(); Function: To string method for Correlate objects. Returns : A string representations of this Correlate. Args : =cut sub to_string { my ( $self ) = @_; my $s = ""; $s .= "-- Name:\n"; $s .= $self->name()."\n"; $s .= "-- Description:\n"; $s .= $self->description()."\n"; $s .= "-- Species:\n"; $s .= $self->species()->binomial()."\n"; $s .= "-- Type of correlation:\n"; $s .= $self->type()."\n"; $s .= "-- Comment:\n"; $s .= $self->comment(); return $s; } # to_string # Title : _check_ref_type # Function: Checks for the correct type. # Returns : # Args : The value to be checked, the expected class. sub _check_ref_type { my ( $self, $value, $expected_class ) = @_; if ( ! defined( $value ) ) { $self->throw( ( caller( 1 ) )[ 3 ] .": Found [undef" ."] where [$expected_class] expected" ); } elsif ( ! ref( $value ) ) { $self->throw( ( caller( 1 ) )[ 3 ] .": Found scalar" ." where [$expected_class] expected" ); } elsif ( ! $value->isa( $expected_class ) ) { $self->throw( ( caller( 1 ) )[ 3 ] .": Found [". ref( $value ) ."] where [$expected_class] expected" ); } } # _check_ref_type 1; BioPerl-1.6.923/Bio/Phenotype/Measure.pm000444000765000024 2030312254227322 20076 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::Measure # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::Measure - Representation of context/value(-range)/unit triplets =head1 SYNOPSIS use Bio::Phenotype::Measure; my $measure = Bio::Phenotype::Measure->new( -context => "length", -description => "reduced length in 4(Tas1r3)", -start => 0, -end => 15, -unit => "mm", -comment => "see also Miller et al" ); print $measure->context(); print $measure->description(); print $measure->start(); print $measure->end(); print $measure->unit(); print $measure->comment(); print $measure->to_string(); =head1 DESCRIPTION Measure is for biochemically defined phenotypes or any other types of measures. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Phenotype::Measure; use strict; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $me = Bio::Phenotype::Measure->new( -context => "length", -description => "reduced length in 4(Tas1r3)", -start => 0, -end => 15, -unit => "mm", -comment => "see Miller also et al" ); Function: Creates a new Measure object. Returns : A new Measure object. Args : -context => the context -description => a description -start => the start value -end => the end value -unit => the unit -comment => a comment =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $con, $desc, $start, $end, $unit, $comment ) = $self->_rearrange( [ qw( CONTEXT DESCRIPTION START END UNIT COMMENT ) ], @args ); $self->init(); $con && $self->context( $con ); $desc && $self->description( $desc ); $start && $self->start( $start ); $end && $self->end( $end ); $unit && $self->unit( $unit ); $comment && $self->comment( $comment ); return $self; } # new =head2 init Title : init() Usage : $measure->init(); Function: Initializes this Measure to all "". Returns : Args : =cut sub init { my( $self ) = @_; $self->context( "" ); $self->description( "" ); $self->start( "" ); $self->end( "" ); $self->unit( "" ); $self->comment( "" ); } # init =head2 context Title : context Usage : $measure->context( "Ca-conc" ); or print $measure->context(); Function: Set/get for the context of this Measure. Returns : The context. Args : The context (optional). =cut sub context { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_context" } = $value; } return $self->{ "_context" }; } # context =head2 description Title : description Usage : $measure->description( "reduced in 4(Tas1r3)" ); or print $measure->description(); Function: Set/get for the description of this Measure. Returns : A description. Args : A description (optional). =cut sub description { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_description" } = $value; } return $self->{ "_description" }; } # description =head2 start Title : start Usage : $measure->start( 330 ); or print $measure->start(); Function: Set/get for the start value of this Measure. Returns : The start value. Args : The start value (optional). =cut sub start { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_start" } = $value; } return $self->{ "_start" }; } # start =head2 end Title : end Usage : $measure->end( 459 ); or print $measure->end(); Function: Set/get for the end value of this Measure. Returns : The end value. Args : The end value (optional). =cut sub end { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_end" } = $value; } return $self->{ "_end" }; } # end =head2 unit Title : unit Usage : $measure->unit( "mM" ); or print $measure->unit(); Function: Set/get for the unit of this Measure. Returns : The unit. Args : The unit (optional). =cut sub unit { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_unit" } = $value; } return $self->{ "_unit" }; } # unit =head2 comment Title : comment Usage : $measure->comment( "see also Miller et al" ); or print $measure->comment(); Function: Set/get for an arbitrary comment about this Measure. Returns : A comment. Args : A comment (optional). =cut sub comment { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_comment" } = $value; } return $self->{ "_comment" }; } # comment =head2 to_string Title : to_string() Usage : print $measure->to_string(); Function: To string method for Measure objects. Returns : A string representations of this Measure. Args : =cut sub to_string { my ( $self ) = @_; my $s = ""; $s .= "-- Context:\n"; $s .= $self->context()."\n"; $s .= "-- Description:\n"; $s .= $self->description()."\n"; $s .= "-- Start:\n"; $s .= $self->start()."\n"; $s .= "-- End:\n"; $s .= $self->end()."\n"; $s .= "-- Unit:\n"; $s .= $self->unit()."\n"; $s .= "-- Comment:\n"; $s .= $self->comment(); return $s; } # to_string 1; BioPerl-1.6.923/Bio/Phenotype/Phenotype.pm000444000765000024 5322512254227326 20465 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::Phenotype # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::Phenotype - A class for modeling phenotypes =head1 SYNOPSIS #get Bio::Phenotype::PhenotypeI somehow print $phenotype->name(), "\n"; print $phenotype->description(), "\n"; my @keywords = ( "achondroplasia", "dwarfism" ); $phenotype->add_keywords( @keywords ); foreach my $keyword ( $phenotype->each_keyword() ) { print $keyword, "\n"; } $phenotype->remove_keywords(); foreach my $gene_symbol ( $phenotype->each_gene_symbol() ) { print $gene_symbol, "\n"; } foreach my $corr ( $phenotype->each_Correlate() ) { # Do something with $corr } foreach my $var ( $phenotype->each_Variant() ) { # Do something with $var (mutation) } foreach my $measure ( $phenotype->each_Measure() ) { # Do something with $measure } =head1 DESCRIPTION This superclass implements common methods for classes modelling phenotypes. Bio::Phenotype::OMIM::OMIMentry is an example of an instantiable phenotype class (the design of this interface was partially guided by the need to model OMIM entries). Please note. This class provides methods to associate mutations (methods "each_Variant", ...) and genotypes (methods "each_Genotype", ...) with phenotypes. Yet, these aspects might need some future enhancements, especially since there is no "genotype" class yet. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Phenotype::Phenotype; use strict; use Bio::Species; use Bio::Variation::VariantI; use Bio::Annotation::DBLink; use Bio::Annotation::Reference; use Bio::Phenotype::Measure; use Bio::Phenotype::Correlate; use Bio::Map::CytoPosition; use Bio::Range; use base qw(Bio::Root::Root Bio::Phenotype::PhenotypeI); =head2 new Title : new Usage : $obj = Bio::Phenotype::Phenotype->new( -name => "XY", -description => "This is ..." ); Function: Creates a new Phenotype object. Returns : A new Phenotype object. Args : -name => the name -description => the description of this phenotype -species => ref to the the species -comment => a comment =cut sub new { my( $class,@args ) = @_; my $self = $class->SUPER::new( @args ); my ( $name, $description, $species, $comment ) = $self->_rearrange( [ qw( NAME DESCRIPTION SPECIES COMMENT ) ], @args ); $self->init(); $name && $self->name( $name ); $description && $self->description( $description ); $species && $self->species( $species ); $comment && $self->comment( $comment ); return $self; } # new =head2 init Title : init() Usage : $obj->init(); Function: Initializes this OMIMentry to all "" and empty lists. Returns : Args : =cut sub init { my( $self ) = @_; $self->name( "" ); $self->description( "" ); my $species = Bio::Species->new(); $species->classification( qw( sapiens Homo ) ); $self->species( $species ); $self->comment( "" ); $self->remove_Correlates(); $self->remove_References(); $self->remove_CytoPositions(); $self->remove_gene_symbols(); $self->remove_Genotypes(); $self->remove_DBLinks(); $self->remove_keywords(); $self->remove_Variants(); $self->remove_Measures(); } # init =head2 name Title : name Usage : $obj->name( "r1" ); or print $obj->name(); Function: Set/get for the name or id of this phenotype. Returns : A name or id [scalar]. Args : A name or id [scalar] (optional). =cut sub name { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_name" } = $value; } return $self->{ "_name" }; } # name =head2 description Title : description Usage : $obj->description( "This is ..." ); or print $obj->description(); Function: Set/get for the description of this phenotype. Returns : A description [scalar]. Args : A description [scalar] (optional). =cut sub description { my $self = shift; return $self->{ "_description" } = shift if(@_); return $self->{ "_description" }; } =head2 species Title : species Usage : $obj->species( $species ); or $species = $obj->species(); Function: Set/get for the species of this phenotype. Returns : A species [Bio::Species]. Args : A species [Bio::Species] (optional). =cut sub species { my ( $self, $value ) = @_; if ( defined $value ) { $self->_check_ref_type( $value, "Bio::Species" ); $self->{ "_species" } = $value; } return $self->{ "_species" }; } # species =head2 comment Title : comment Usage : $obj->comment( "putative" ); or print $obj->comment(); Function: Set/get for a comment about this phenotype. Returns : A comment [scalar]. Args : A comment [scalar] (optional). =cut sub comment { my $self = shift; return $self->{ "_comment" } = shift if(@_); return $self->{ "_comment" }; } # comment =head2 each_gene_symbol Title : each_gene_symbol() Usage : @gs = $obj->each_gene_symbol(); Function: Returns a list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_gene_symbol { my ( $self ) = @_; return @{$self->{"_gene_symbols"}} if exists($self->{"_gene_symbols"}); return (); } # each_gene_symbol =head2 add_gene_symbols Title : add_gene_symbols Usage : $obj->add_gene_symbols( @gs ); or $obj->add_gene_symbols( $gs ); Function: Pushes one or more gene symbols [scalars, most likely Strings] into the list of gene symbols. Returns : Args : scalar(s). =cut sub add_gene_symbols { my ( $self, @values ) = @_; return unless( @values ); push( @{ $self->{ "_gene_symbols" } }, @values ); } # add_gene_symbols =head2 remove_gene_symbols Usage : $obj->remove_gene_symbols(); Function: Deletes (and returns) the list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub remove_gene_symbols { my ( $self ) = @_; my @a = $self->each_gene_symbol(); $self->{ "_gene_symbols" } = []; return @a; } # remove_gene_symbols =head2 each_Variant Title : each_Variant() Usage : @vs = $obj->each_Variant(); Function: Returns a list of Bio::Variation::VariantI implementing objects associated with this phenotype. This is for representing the actual mutation(s) causing this phenotype. {* The "variants" data member and its methods will/might need to be changed/improved in one way or another, CZ 09/06/02 *} Returns : A list of Bio::Variation::VariantI implementing objects. Args : =cut sub each_Variant { my ( $self ) = @_; return @{ $self->{ "_variants" } } if exists($self->{ "_variants" }); return (); } # each_Variant =head2 add_Variants Usage : $obj->add_Variants( @vs ); or $obj->add_Variants( $v ); Function: Pushes one or more Bio::Variation::VariantI implementing objects into the list of Variants. Returns : Args : Bio::Variation::VariantI implementing object(s). =cut sub add_Variants { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Variation::VariantI" ); } push( @{ $self->{ "_variants" } }, @values ); } # add_Variants =head2 remove_Variants Title : remove_Variants Usage : $obj->remove_Variants(); Function: Deletes (and returns) the list of Bio::Variation::VariantI implementing objects associated with this phenotype. Returns : A list of Bio::Variation::VariantI implementing objects. Args : =cut sub remove_Variants { my ( $self ) = @_; my @a = $self->each_Variant(); $self->{ "_variants" } = []; return @a; } # remove_Variants =head2 each_Reference Title : each_Reference() Usage : @refs = $obj->each_Reference(); Function: Returns a list of Bio::Annotation::Reference objects associated with this phenotype. Returns : A list of Bio::Annotation::Reference objects. Args : =cut sub each_Reference { my ( $self ) = @_; return @{ $self->{ "_references" } } if exists($self->{ "_references" }); return (); } # each_Reference =head2 add_References Title : add_References Usage : $obj->add_References( @refs ); or $obj->add_References( $ref ); Function: Pushes one or more Bio::Annotation::Reference objects into the list of References. Returns : Args : Bio::Annotation::Reference object(s). =cut sub add_References { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Annotation::Reference" ); } push( @{ $self->{ "_references" } }, @values ); } # add_References =head2 remove_References Title : remove_References() Usage : $obj->remove_References(); Function: Deletes (and returns) the list of Bio::Annotation::Reference objects associated with this phenotype. Returns : A list of Bio::Annotation::Reference objects. Args : =cut sub remove_References { my ( $self ) = @_; my @a = $self->each_Reference(); $self->{ "_references" } = []; return @a; } # remove_References =head2 each_CytoPosition Title : each_CytoPosition() Usage : @cps = $obj->each_CytoPosition(); Function: Returns a list of Bio::Map::CytoPosition objects associated with this phenotype. Returns : A list of Bio::Map::CytoPosition objects. Args : =cut sub each_CytoPosition { my ( $self ) = @_; return @{$self->{"_cyto_positions"}} if exists($self->{"_cyto_positions"}); return (); } # each_CytoPosition =head2 add_CytoPositions Title : add_CytoPositions Usage : $obj->add_CytoPositions( @cps ); or $obj->add_CytoPositions( $cp ); Function: Pushes one or more Bio::Map::CytoPosition objects into the list of CytoPositions. Returns : Args : Bio::Map::CytoPosition object(s). =cut sub add_CytoPositions { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Map::CytoPosition" ); } push( @{ $self->{ "_cyto_positions" } }, @values ); } # add_CytoPositions =head2 remove_CytoPositions Title : remove_CytoPositions Usage : $obj->remove_CytoPositions(); Function: Deletes (and returns) the list o fBio::Map::CytoPosition objects associated with this phenotype. Returns : A list of Bio::Map::CytoPosition objects. Args : =cut sub remove_CytoPositions { my ( $self ) = @_; my @a = $self->each_CytoPosition(); $self->{ "_cyto_positions" } = []; return @a; } # remove_CytoPositions =head2 each_Correlate Title : each_Correlate() Usage : @corrs = $obj->each_Correlate(); Function: Returns a list of Bio::Phenotype::Correlate objects associated with this phenotype. (Correlates are correlating phenotypes in different species; inspired by mouse correlates of human phenotypes in the OMIM database.) Returns : A list of Bio::Phenotype::Correlate objects. Args : =cut sub each_Correlate { my ( $self ) = @_; return @{ $self->{ "_correlates" } } if exists($self->{ "_correlates" }); return (); } # each_Correlate =head2 add_Correlates Title : add_Correlates Usage : $obj->add_Correlates( @corrs ); or $obj->add_Correlates( $corr ); Function: Pushes one or more Bio::Phenotype::Correlate objects into the list of Correlates. Returns : Args : Bio::Phenotype::Correlate object(s). =cut sub add_Correlates { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Phenotype::Correlate" ); } push( @{ $self->{ "_correlates" } }, @values ); } # add_Correlates =head2 remove_Correlates Title : remove_Correlates Usage : $obj->remove_Correlates(); Function: Deletes (and returns) the list of Bio::Phenotype::Correlate objects associated with this phenotype. Returns : A list of Bio::Phenotype::Correlate objects. Args : =cut sub remove_Correlates { my ( $self ) = @_; my @a = $self->each_Correlate(); $self->{ "_correlates" } = []; return @a; } # remove_Correlates =head2 each_Measure Title : each_Measure() Usage : @ms = $obj->each_Measure(); Function: Returns a list of Bio::Phenotype::Measure objects associated with this phenotype. (Measure is for biochemically defined phenotypes or any other types of measures.) Returns : A list of Bio::Phenotype::Measure objects. Args : =cut sub each_Measure { my ( $self ) = @_; return @{ $self->{ "_measures" } } if exists($self->{ "_measures" }); return (); } # each_Measure =head2 add_Measures Title : add_Measures Usage : $obj->add_Measures( @ms ); or $obj->add_Measures( $m ); Function: Pushes one or more Bio::Phenotype::Measure objects into the list of Measures. Returns : Args : Bio::Phenotype::Measure object(s). =cut sub add_Measures { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Phenotype::Measure" ); } push( @{ $self->{ "_measures" } }, @values ); } # add_Measures =head2 remove_Measures Title : remove_Measures Usage : $obj->remove_Measures(); Function: Deletes (and returns) the list of Bio::Phenotype::Measure objects associated with this phenotype. Returns : A list of Bio::Phenotype::Measure objects. Args : =cut sub remove_Measures { my ( $self ) = @_; my @a = $self->each_Measure(); $self->{ "_measures" } = []; return @a; } # remove_Measures =head2 each_keyword Title : each_keyword() Usage : @kws = $obj->each_keyword(); Function: Returns a list of key words [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_keyword { my ( $self ) = @_; return @{ $self->{ "_keywords" } } if exists($self->{ "_keywords" }); return (); } # each_keyword =head2 add_keywords Title : add_keywords Usage : $obj->add_keywords( @kws ); or $obj->add_keywords( $kw ); Function: Pushes one or more keywords [scalars, most likely Strings] into the list of key words. Returns : Args : scalar(s). =cut sub add_keywords { my ( $self, @values ) = @_; return unless( @values ); push( @{ $self->{ "_keywords" } }, @values ); } # add_keywords =head2 remove_keywords Title : remove_keywords Usage : $obj->remove_keywords(); Function: Deletes (and returns) the list of key words [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub remove_keywords { my ( $self ) = @_; my @a = $self->each_keyword(); $self->{ "_keywords" } = []; return @a; } # remove_keywords =head2 each_DBLink Title : each_DBLink() Usage : @dbls = $obj->each_DBLink(); Function: Returns a list of Bio::Annotation::DBLink objects associated with this phenotype. Returns : A list of Bio::Annotation::DBLink objects. Args : =cut sub each_DBLink { my ( $self ) = @_; return @{ $self->{ "_db_links" } } if exists($self->{ "_db_links" }); return (); } =head2 add_DBLinks Title : add_DBLinks Usage : $obj->add_DBLinks( @dbls ); or $obj->add_DBLinks( $dbl ); Function: Pushes one or more Bio::Annotation::DBLink objects into the list of DBLinks. Returns : Args : Bio::Annotation::DBLink object(s). =cut sub add_DBLinks { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Annotation::DBLink" ); } push( @{ $self->{ "_db_links" } }, @values ); } # add_DBLinks =head2 remove_DBLinks Title : remove_DBLinks Usage : $obj->remove_DBLinks(); Function: Deletes (and returns) the list of Bio::Annotation::DBLink objects associated with this phenotype. Returns : A list of Bio::Annotation::DBLink objects. Args : =cut sub remove_DBLinks { my ( $self ) = @_; my @a = $self->each_DBLink(); $self->{ "_db_links" } = []; return @a; } # remove_DBLinks =head2 each_Genotype Title : each_Reference() Usage : @gts = $obj->each_Reference(); Function: Returns a list of "Genotype" objects associated with this phenotype. {* the "genotypes" data member and its methods certainly will/needs to be changed/improved in one way or another since there is no "Genotype" class yet, CZ 09/06/02 *} Returns : A list of "Genotype" objects. Args : =cut sub each_Genotype { my ( $self ) = @_; return @{ $self->{ "_genotypes" } } if exists($self->{ "_genotypes" }); return (); } # each_Genotype =head2 add_Genotypes Title : add_Genotypes Usage : $obj->add_Genotypes( @gts ); or $obj->add_Genotypes( $gt ); Function: Pushes one or more "Genotypes" into the list of "Genotypes". Returns : Args : "Genotypes(s)". =cut sub add_Genotypes { my ( $self, @values ) = @_; return unless( @values ); #foreach my $value ( @values ) { # $self->_check_ref_type( $value, "Bio::GenotypeI" ); #} push( @{ $self->{ "_genotypes" } }, @values ); } # add_Genotypes =head2 remove_Genotypes Title : remove_Genotypes Usage : $obj->remove_Genotypes(); Function: Deletes (and returns) the list of "Genotype" objects associated with this phenotype. Returns : A list of "Genotype" objects. Args : =cut sub remove_Genotypes { my ( $self ) = @_; my @a = $self->each_Genotype(); $self->{ "_genotypes" } = []; return @a; } # remove_Genotypes =head2 _check_ref_type Title : _check_ref_type Usage : $self->_check_ref_type( $value, "Bio::Annotation::DBLink" ); Function: Checks for the correct type. Returns : Args : The value to be checked, the expected class. =cut sub _check_ref_type { my ( $self, $value, $expected_class ) = @_; if ( ! defined( $value ) ) { $self->throw( ( caller( 1 ) )[ 3 ] .": Found [undef" ."] where [$expected_class] expected" ); } elsif ( ! ref( $value ) ) { $self->throw( ( caller( 1 ) )[ 3 ] .": Found scalar" ." where [$expected_class] expected" ); } elsif ( ! $value->isa( $expected_class ) ) { $self->throw( ( caller( 1 ) )[ 3 ] .": Found [". ref( $value ) ."] where [$expected_class] expected" ); } } # _check_ref_type 1; BioPerl-1.6.923/Bio/Phenotype/PhenotypeI.pm000444000765000024 4055112254227332 20571 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::PhenotypeI # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::PhenotypeI - An interface for classes modeling phenotypes =head1 SYNOPSIS #get Bio::Phenotype::PhenotypeI somehow print $phenotype->name(), "\n"; print $phenotype->description(), "\n"; my @keywords = ( "achondroplasia", "dwarfism" ); $phenotype->add_keywords( @keywords ); foreach my $keyword ( $phenotype->each_keyword() ) { print $keyword, "\n"; } $phenotype->remove_keywords(); foreach my $gene_symbol ( $phenotype->each_gene_symbol() ) { print $gene_symbol, "\n"; } foreach my $corr ( $phenotype->each_Correlate() ) { # Do something with $corr } foreach my $var ( $phenotype->each_Variant() ) { # Do something with $var (mutation) } foreach my $measure ( $phenotype->each_Measure() ) { # Do something with $measure } =head1 DESCRIPTION This superclass defines common methods for classes modelling phenotypes. Bio::Phenotype::OMIM::OMIMentry is an example of an instantiable phenotype class (the design of this interface was partially guided by the need to model OMIM entries). Please note. This interface provides methods to associate mutations (methods "each_Variant", ...) and genotypes (methods "each_Genotype", ...) with phenotypes. Yet, these aspects might need some future enhancements, especially since there is no "genotype" class yet. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Phenotype::PhenotypeI; use base qw(Bio::Root::RootI); =head2 name Title : name Usage : $obj->name( "r1" ); or print $obj->name(); Function: Set/get for the name or id of this phenotype. Returns : A name or id [scalar]. Args : A name or id [scalar] (optional). =cut sub name { my ( $self ) = @_; $self->throw_not_implemented(); } # name =head2 description Title : description Usage : $obj->description( "This is ..." ); or print $obj->description(); Function: Set/get for the description of this phenotype. Returns : A description [scalar]. Args : A description [scalar] (optional). =cut sub description { my ( $self ) = @_; $self->throw_not_implemented(); } # description =head2 species Title : species Usage : $obj->species( $species ); or $species = $obj->species(); Function: Set/get for the species of this phenotype. Returns : A species [Bio::Species]. Args : A species [Bio::Species] (optional). =cut sub species { my ( $self ) = @_; $self->throw_not_implemented(); } # species =head2 comment Title : comment Usage : $obj->comment( "putative" ); or print $obj->comment(); Function: Set/get for a comment about this phenotype. Returns : A comment [scalar]. Args : A comment [scalar] (optional). =cut sub comment { my ( $self ) = @_; $self->throw_not_implemented(); } # comment =head2 each_gene_symbol Title : each_gene_symbol() Usage : @gs = $obj->each_gene_symbol(); Function: Returns a list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_gene_symbol { my ( $self ) = @_; $self->throw_not_implemented(); } # each_gene_symbol =head2 add_gene_symbols Title : add_gene_symbols Usage : $obj->add_gene_symbols( @gs ); or $obj->add_gene_symbols( $gs ); Function: Pushes one or more gene symbols [scalars, most likely Strings] into the list of gene symbols. Returns : Args : scalar(s). =cut sub add_gene_symbols { my ( $self ) = @_; $self->throw_not_implemented(); } # add_gene_symbols =head2 remove_gene_symbols Usage : $obj->remove_gene_symbols(); Function: Deletes (and returns) the list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub remove_gene_symbols { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_gene_symbols =head2 each_Variant Title : each_Variant() Usage : @vs = $obj->each_Variant(); Function: Returns a list of Bio::Variation::VariantI implementing objects associated with this phenotype. This is for representing the actual mutation(s) causing this phenotype. {* The "variants" data member and its methods will/might need to be changed/improved in one way or another, CZ 09/06/02 *} Returns : A list of Bio::Variation::VariantI implementing objects. Args : =cut sub each_Variant { my ( $self ) = @_; $self->throw_not_implemented(); } # each_Variant =head2 add_Variants Usage : $obj->add_Variants( @vs ); or $obj->add_Variants( $v ); Function: Pushes one or more Bio::Variation::VariantI implementing objects into the list of Variants. Returns : Args : Bio::Variation::VariantI implementing object(s). =cut sub add_Variants { my ( $self ) = @_; $self->throw_not_implemented(); } # add_Variants =head2 remove_Variants Title : remove_Variants Usage : $obj->remove_Variants(); Function: Deletes (and returns) the list of Bio::Variation::VariantI implementing objects associated with this phenotype. Returns : A list of Bio::Variation::VariantI implementing objects. Args : =cut sub remove_Variants { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_Variants =head2 each_Reference Title : each_Reference() Usage : @refs = $obj->each_Reference(); Function: Returns a list of Bio::Annotation::Reference objects associated with this phenotype. Returns : A list of Bio::Annotation::Reference objects. Args : =cut sub each_Reference { my ( $self ) = @_; $self->throw_not_implemented(); } # each_Reference =head2 add_References Title : add_References Usage : $obj->add_References( @refs ); or $obj->add_References( $ref ); Function: Pushes one or more Bio::Annotation::Reference objects into the list of References. Returns : Args : Bio::Annotation::Reference object(s). =cut sub add_References { my ( $self ) = @_; $self->throw_not_implemented(); } # add_References =head2 remove_References Title : remove_References() Usage : $obj->remove_References(); Function: Deletes (and returns) the list of Bio::Annotation::Reference objects associated with this phenotype. Returns : A list of Bio::Annotation::Reference objects. Args : =cut sub remove_References { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_References =head2 each_CytoPosition Title : each_CytoPosition() Usage : @cps = $obj->each_CytoPosition(); Function: Returns a list of Bio::Map::CytoPosition objects associated with this phenotype. Returns : A list of Bio::Map::CytoPosition objects. Args : =cut sub each_CytoPosition { my ( $self ) = @_; $self->throw_not_implemented(); } # each_CytoPosition =head2 add_CytoPositions Title : add_CytoPositions Usage : $obj->add_CytoPositions( @cps ); or $obj->add_CytoPositions( $cp ); Function: Pushes one or more Bio::Map::CytoPosition objects into the list of CytoPositions. Returns : Args : Bio::Map::CytoPosition object(s). =cut sub add_CytoPositions { my ( $self ) = @_; $self->throw_not_implemented(); } # add_CytoPositions =head2 remove_CytoPositions Title : remove_CytoPositions Usage : $obj->remove_CytoPositions(); Function: Deletes (and returns) the list o fBio::Map::CytoPosition objects associated with this phenotype. Returns : A list of Bio::Map::CytoPosition objects. Args : =cut sub remove_CytoPositions { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_CytoPositions =head2 each_Correlate Title : each_Correlate() Usage : @corrs = $obj->each_Correlate(); Function: Returns a list of Bio::Phenotype::Correlate objects associated with this phenotype. (Correlates are correlating phenotypes in different species; inspired by mouse correlates of human phenotypes in the OMIM database.) Returns : A list of Bio::Phenotype::Correlate objects. Args : =cut sub each_Correlate { my ( $self ) = @_; $self->throw_not_implemented(); } # each_Correlate =head2 add_Correlates Title : add_Correlates Usage : $obj->add_Correlates( @corrs ); or $obj->add_Correlates( $corr ); Function: Pushes one or more Bio::Phenotype::Correlate objects into the list of Correlates. Returns : Args : Bio::Phenotype::Correlate object(s). =cut sub add_Correlates { my ( $self ) = @_; $self->throw_not_implemented(); } # add_Correlates =head2 remove_Correlates Title : remove_Correlates Usage : $obj->remove_Correlates(); Function: Deletes (and returns) the list of Bio::Phenotype::Correlate objects associated with this phenotype. Returns : A list of Bio::Phenotype::Correlate objects. Args : =cut sub remove_Correlates { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_Correlates =head2 each_Measure Title : each_Measure() Usage : @ms = $obj->each_Measure(); Function: Returns a list of Bio::Phenotype::Measure objects associated with this phenotype. (Measure is for biochemically defined phenotypes or any other types of measures.) Returns : A list of Bio::Phenotype::Measure objects. Args : =cut sub each_Measure { my ( $self ) = @_; $self->throw_not_implemented(); } # each_Measure =head2 add_Measures Title : add_Measures Usage : $obj->add_Measures( @ms ); or $obj->add_Measures( $m ); Function: Pushes one or more Bio::Phenotype::Measure objects into the list of Measures. Returns : Args : Bio::Phenotype::Measure object(s). =cut sub add_Measures { my ( $self ) = @_; $self->throw_not_implemented(); } # add_Measures =head2 remove_Measures Title : remove_Measures Usage : $obj->remove_Measures(); Function: Deletes (and returns) the list of Bio::Phenotype::Measure objects associated with this phenotype. Returns : A list of Bio::Phenotype::Measure objects. Args : =cut sub remove_Measures { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_Measures =head2 each_keyword Title : each_keyword() Usage : @kws = $obj->each_keyword(); Function: Returns a list of key words [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_keyword { my ( $self ) = @_; $self->throw_not_implemented(); } # each_keyword =head2 add_keywords Title : add_keywords Usage : $obj->add_keywords( @kws ); or $obj->add_keywords( $kw ); Function: Pushes one or more keywords [scalars, most likely Strings] into the list of key words. Returns : Args : scalar(s). =cut sub add_keywords { my ( $self ) = @_; $self->throw_not_implemented(); } # add_keywords =head2 remove_keywords Title : remove_keywords Usage : $obj->remove_keywords(); Function: Deletes (and returns) the list of key words [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub remove_keywords { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_keywords =head2 each_DBLink Title : each_DBLink() Usage : @dbls = $obj->each_DBLink(); Function: Returns a list of Bio::Annotation::DBLink objects associated with this phenotype. Returns : A list of Bio::Annotation::DBLink objects. Args : =cut sub each_DBLink { my ( $self ) = @_; $self->throw_not_implemented(); } =head2 add_DBLinks Title : add_DBLinks Usage : $obj->add_DBLinks( @dbls ); or $obj->add_DBLinks( $dbl ); Function: Pushes one or more Bio::Annotation::DBLink objects into the list of DBLinks. Returns : Args : Bio::Annotation::DBLink object(s). =cut sub add_DBLinks { my ( $self ) = @_; $self->throw_not_implemented(); } # add_DBLinks =head2 remove_DBLinks Title : remove_DBLinks Usage : $obj->remove_DBLinks(); Function: Deletes (and returns) the list of Bio::Annotation::DBLink objects associated with this phenotype. Returns : A list of Bio::Annotation::DBLink objects. Args : =cut sub remove_DBLinks { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_DBLinks =head2 each_Genotype Title : each_Reference() Usage : @gts = $obj->each_Reference(); Function: Returns a list of "Genotype" objects associated with this phenotype. {* the "genotypes" data member and its methods certainly will/needs to be changed/improved in one way or another since there is no "Genotype" class yet, CZ 09/06/02 *} Returns : A list of "Genotype" objects. Args : =cut sub each_Genotype { my ( $self ) = @_; $self->throw_not_implemented(); } # each_Genotype =head2 add_Genotypes Title : add_Genotypes Usage : $obj->add_Genotypes( @gts ); or $obj->add_Genotypes( $gt ); Function: Pushes one or more "Genotypes" into the list of "Genotypes". Returns : Args : "Genotypes(s)". =cut sub add_Genotypes { my ( $self ) = @_; $self->throw_not_implemented(); } # add_Genotypes =head2 remove_Genotypes Title : remove_Genotypes Usage : $obj->remove_Genotypes(); Function: Deletes (and returns) the list of "Genotype" objects associated with this phenotype. Returns : A list of "Genotype" objects. Args : =cut sub remove_Genotypes { my ( $self ) = @_; $self->throw_not_implemented(); } # remove_Genotypes 1; BioPerl-1.6.923/Bio/Phenotype/MeSH000755000765000024 012254227317 16564 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Phenotype/MeSH/Term.pm000444000765000024 1505312254227313 20206 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::MeSH::Term # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::MeSH::Term - A MeSH term =head1 SYNOPSIS use Bio::Phenotype::MeSH::Term; # create a term object my $term = Bio::Phenotype::MeSH::Term->new (-id => 'D000001', -name => 'Dietary Fats', -description => 'dietary fats are...' ); # get a Bio::Phenotype::MeSH::Twig somehow... $term->add_twig($twig1); =head1 DESCRIPTION This class keeps information about MeSH terms. MeSH stands for Medical Subject Headings and is one of the ways for annotaing biomedical literature. The terminology is maintained by National Library of Medicine of USA . See http://www.nlm.nih.gov/mesh/meshhome.html. In addition to id, name and description a term can know about its surrounding terms (Bio::Phenotype::MeSH::Twig) in the term hierarchy. This class is mainly used from Bio::DB::MeSH which retrieves terms over the Web. =head1 SEE ALSO L, L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Phenotype::MeSH::Term; use strict; use base qw(Bio::Root::Root); sub new { my( $class,@args ) = @_; my $self = $class->SUPER::new( @args ); my ( $id, $name, $description, $comment ) = $self->_rearrange ( [ qw( ID NAME DESCRIPTION SPECIES COMMENT ) ], @args ); $self->{"_twigs"} = []; $id && $self->id( $id ); $name && $self->name( $name ); $description && $self->description( $description ); return $self; } =head2 id Title : id Usage : $obj->id( "r1" ); or print $obj->id(); Function: Set/get for the id. Returns : A id [scalar]. Args : A id [scalar] (optional). =cut sub id { my ( $self, $value ) = @_; $self->{ "_id" } = $value if defined $value; return $self->{ "_id" }; } =head2 name Title : name Usage : $obj->name( "r1" ); or print $obj->name(); Function: Set/get for the name. Returns : A name [scalar]. Args : A name [scalar] (optional). =cut sub name { my ( $self, $value ) = @_; $self->{ "_name" } = $value if defined $value; return $self->{ "_name" }; } =head2 description Title : description Usage : $obj->description( "r1" ); or print $obj->description(); Function: Set/get for the description. Returns : A description [scalar]. Args : A description [scalar] (optional). =cut sub description { my ( $self, $value ) = @_; $self->{ "_description" } = $value if defined $value; return $self->{ "_description" }; } =head2 add_synonym Title : add_synonym Usage : $obj->add_synonym( @synonyms ); or $obj->add_synonym( $synonym ); Function: Pushes one or more synonyms for the term term into the list of synonyms. Returns : Args : scalar(s). =cut sub add_synonym { my ( $self, @values ) = @_; push( @{ $self->{ "_synonyms" } }, @values ); } =head2 each_synonym Title : each_synonym() Usage : @gs = $obj->each_synonym(); Function: Returns a list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_synonym { my ( $self ) = shift; return @{ $self->{ "_synonyms" } }; } =head2 purge_synonyms Usage : $obj->purge_synonym(); Function: Deletes the list of synonyms to this term. Returns : A list of scalars. Args : =cut sub purge_synonyms { my ( $self ) = @_; $self->{ "_synonyms" } = []; } =head2 Twig management Each MeSH term belongs to a complex tree like hierarchy of terms where each term can appear multiple times. The immediately surrounding nodes of the tree are modelled in twigs. See: L. =cut =head2 add_twig Title : add_twig Usage : $obj->add_twig( @twigs ); or $obj->add_twig( $twig ); Function: Pushes one or more twig term names [scalars, most likely Strings] into the list of twigs. Returns : Args : scalar(s). =cut sub add_twig { my ( $self, @values ) = @_; foreach my $twig (@values) { $self->warn ("Not a MeSH twig [$twig]") unless $twig->isa('Bio::Phenotype::MeSH::Twig'); $twig->term($self); push( @{ $self->{ "_twigs" } }, $twig ); } 1; } =head2 each_twig Title : each_twig() Usage : @gs = $obj->each_twig(); Function: Returns a list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_twig { my ( $self ) = shift; return @{ $self->{ "_twigs" } }; } =head2 purge_twigs Usage : $obj->purge_twig(); Function: Deletes the list of twigs associated with this term. Returns : A list of scalars. Args : =cut sub purge_twigs { my ( $self ) = @_; $self->{ "_twigs" } = []; } =head2 each_parent Title : each_parent() Usage : @gs = $obj->each_parent(); Function: Returns a list of names of parents for this term Returns : A list of scalars. Args : =cut sub each_parent { my ( $self ) = shift; return map {$_->parent()} @{ $self->{ "_twigs" } }; } 1; BioPerl-1.6.923/Bio/Phenotype/MeSH/Twig.pm000444000765000024 1373612254227317 20223 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::MeSH::Twig # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::MeSH::Twig - Context for a MeSH term =head1 SYNOPSIS use Bio::Phenotype::MeSH::Twig # create a twig object my $twig = Bio::Phenotype::MeSH::Twig->new(); # the term has only one parent in any twig $twig->parent('Fats'); # a twig makeas sense only in the context of a term # which is a Bio::Phenotype::MeSH::Term object # a term can have many twigs i.e. it can appear in many places in # the hierarchy # $ term->add_twig($twig); # adding the twig into a term adds a link into into it $twig->term eq $term; # a twig can know about other terms under the parant node $twig->add_sister('Bread', 'Candy', 'Cereals'); print join ( ', ', $twig->each_sister()), "\n"; # a twig can know about other terms under this term $twig->add_child('Butter', 'Margarine'); print join ( ', ', $twig->each_child()), "\n"; =head1 DESCRIPTION This class represents the immediate surrounding of a MeSH term. It keeps track on nodes names above the current node ('parent') other nodes at the same level ('sisters') and nodes under it ('children'). Note that these are name strings, not objects. Each twig can be associated with only one term, but term can have multiple twigs. (Twigs can be though to be roles for a term.) =head1 SEE ALSO L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Phenotype::MeSH::Twig; use strict; use base qw(Bio::Root::Root); sub new { my( $class,@args ) = @_; my $self = $class->SUPER::new( @args ); my ($term, $parent ) = $self->_rearrange ( [ qw( TERM PARENT ) ], @args ); $self->{"_children"} = []; $self->{"_sisters"} = []; $term && $self->term($term ); $parent && $self->parent($parent ); return $self; } =head2 parent Title : parent Usage : $obj->parent( "r1" ); or print $obj->parent(); Function: Set/get for the parent. Returns : A parent [scalar]. Args : A parent [scalar] (optional). =cut sub parent { my ( $self, $value ) = @_; $self->{ "_parent" } = $value if defined $value; return $self->{ "_parent" }; } =head2 term Title : term Usage : $obj->term( "r1" ); or print $obj->term(); Function: Set/get for the term. Returns : A term [scalar]. Args : A term [scalar] (optional). =cut sub term { my ( $self, $value ) = @_; if (defined $value) { $self->throw ("Not a MeSH term [$value]") unless $value->isa('Bio::Phenotype::MeSH::Term'); $self->{ "_term" } = $value } return $self->{ "_term" }; } =head2 add_child Title : add_child Usage : $obj->add_child( @children ); or $obj->add_child( $child ); Function: Pushes one or more child term names [scalars, most likely Strings] into the list of children. Returns : Args : scalar(s). =cut sub add_child { my ( $self, @values ) = @_; push( @{ $self->{ "_children" } }, @values ); return scalar @values; } =head2 each_child Title : each_child() Usage : @gs = $obj->each_child(); Function: Returns a list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_child { my ( $self ) = shift; return @{ $self->{ "_children" } }; } =head2 purge_children Usage : $obj->purge_child(); Function: Deletes the list of children associated with this term. Returns : A list of scalars. Args : =cut sub purge_children { my ( $self ) = @_; $self->{ "_children" } = []; } =head2 add_sister Title : add_sister Usage : $obj->add_sister( @sisters ); or $obj->add_sister( $sister ); Function: Pushes one or more sister term names [scalars, most likely Strings] into the list of sisters. Returns : Args : scalar(s). =cut sub add_sister { my ( $self, @values ) = @_; push( @{ $self->{ "_sisters" } }, @values ); return scalar @values; } =head2 each_sister Title : each_sister() Usage : @gs = $obj->each_sister(); Function: Returns a list of gene symbols [scalars, most likely Strings] associated with this phenotype. Returns : A list of scalars. Args : =cut sub each_sister { my ( $self ) = shift; return @{ $self->{ "_sisters" } }; } =head2 purge_sisters Usage : $obj->purge_sister(); Function: Deletes the list of sisters associated with this term. Returns : A list of scalars. Args : =cut sub purge_sisters { my ( $self ) = @_; $self->{'_sisters'} = []; } 1; BioPerl-1.6.923/Bio/Phenotype/OMIM000755000765000024 012254227333 16527 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Phenotype/OMIM/MiniMIMentry.pm000444000765000024 1621512254227324 21570 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::OMIM::MiniMIMentry # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::OMIM::MiniMIMentry - Representation of a Mini MIM entry =head1 SYNOPSIS use Bio::Phenotype::OMIM::MiniMIMentry; $mm = Bio::Phenotype::OMIM::MiniMIMentry->new( -description => "The central form of ...", -created => "Victor A. McKusick: 6/4/1986", -contributors => "Kelly A. Przylepa - revised: 03/18/2002", -edited => "alopez: 06/03/1997" ); =head1 DESCRIPTION This class representats of Mini MIM entries. This class is intended to be used together with a OMIM entry class. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Phenotype::OMIM::MiniMIMentry; use strict; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $mm = Bio::Phenotype::OMIM::MiniMIMentry->new( -description => "The central form of ...", -created => "Victor A. McKusick: 6/4/1986", -contributors => "Kelly A. Przylepa - revised: 03/18/2002", -edited => "alopez: 06/03/1997" ); Function: Creates a new MiniMIMentry object. Returns : A new MiniMIMentry object. Args : -description => a description -created => name(s) and date(s) (free form) -contributors => name(s) and date(s) (free form) -edited => name(s) and date(s) (free form) =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $desc, $created, $contributors, $edited ) = $self->_rearrange( [ qw( DESCRIPTION CREATED CONTRIBUTORS EDITED ) ], @args ); $self->init(); $desc && $self->description( $desc ); $created && $self->created( $created ); $contributors && $self->contributors( $contributors ); $edited && $self->edited( $edited ); return $self; } # new =head2 init Title : init() Usage : $mm->init(); Function: Initializes this MiniMIMentry to all "". Returns : Args : =cut sub init { my( $self ) = @_; $self->description( "" ); $self->created( "" ); $self->contributors( "" ); $self->edited( "" ); } # init =head2 description Title : description Usage : $mm->description( "The central form of ..." ); or print $mm->description(); Function: Set/get for the description field of the Mini MIM database. Returns : The description. Args : The description (optional). =cut sub description { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_description" } = $value; } return $self->{ "_description" }; } # description =head2 created Title : created Usage : $mm->created( "Victor A. McKusick: 6/4/1986" ); or print $mm->created(); Function: Set/get for the created field of the Mini MIM database. Returns : Name(s) and date(s) [scalar - free form]. Args : Name(s) and date(s) [scalar - free form] (optional). =cut sub created { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_created" } = $value; } return $self->{ "_created" }; } # created =head2 contributors Title : contributors Usage : $mm->contributors( "Kelly A. Przylepa - revised: 03/18/2002" ); or print $mm->contributors(); Function: Set/get for the contributors field of the Mini MIM database. Returns : Name(s) and date(s) [scalar - free form]. Args : Name(s) and date(s) [scalar - free form] (optional). =cut sub contributors { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_contributors" } = $value; } return $self->{ "_contributors" }; } # contributors =head2 edited Title : edited Usage : $mm->edited( "alopez: 06/03/1997" ); or print $mm->edited(); Function: Set/get for the edited field of the Mini MIM database. Returns : Name(s) and date(s) [scalar - free form]. Args : Name(s) and date(s) [scalar - free form] (optional). =cut sub edited { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_edited" } = $value; } return $self->{ "_edited" }; } # edited =head2 to_string Title : to_string() Usage : print $mm->to_string(); Function: To string method for MiniMIMentry objects. Returns : A string representations of this MiniMIMentry. Args : =cut sub to_string { my ( $self ) = @_; my $s = ""; $s .= "-- Description:\n"; $s .= $self->description()."\n"; $s .= "-- Created:\n"; $s .= $self->created()."\n"; $s .= "-- Contributors:\n"; $s .= $self->contributors()."\n"; $s .= "-- Edited:\n"; $s .= $self->edited(); return $s; } # to_string 1; BioPerl-1.6.923/Bio/Phenotype/OMIM/OMIMentry.pm000444000765000024 5752612254227316 21105 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::OMIM::OMIMentry # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::OMIM::OMIMentry - represents OMIM (Online Mendelian Inheritance in Man) database entries =head1 SYNOPSIS $obj = Bio::Phenotype::OMIM::OMIMentry->new( -mim_number => 200000, -description => "This is ...", -more_than_two_genes => 1 ); =head1 DESCRIPTION Inherits from Bio::Phenotype::PhenotypeI. Bio::Phenotype::OMIM::OMIMparser parses the flat file representation of OMIM (i.e. files "omim.txt" and "genemap") returning OMIMentry objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Phenotype::OMIM::OMIMentry; use strict; use Bio::Phenotype::OMIM::MiniMIMentry; use Bio::Phenotype::OMIM::OMIMentryAllelicVariant; use constant TRUE => 1; use constant FALSE => 0; use constant DEFAULT_MIM_NUMER => 0; use base qw(Bio::Phenotype::Phenotype); =head2 new Title : new Usage : $obj = Bio::Phenotype::OMIM::OMIMentry->new( -mim_number => 200000, -description => "This is ...", -more_than_two_genes => 1 ); Function: Creates a new OMIMentry object. Returns : A new OMIMentry object. Args : -mim_number => the MIM number -title => the title or name -alternative_titles_and_symbols => the "alternative titles and symbols" -more_than_two_genes => can phenotype can be caused by mutation in any of two or more genes? -is_separate => is this phenotype separate from those represented by other entries -description => the description of this phenotype -mapping_method => the mapping method -gene_status => the gene status of this -comment => a comment -species => ref to the the species (human) -created => created by whom/when -edited => edited by whom/when -contributors => contributed by whom/when -additional_references => "see also" -clinical_symptoms => the clinical symptoms -minimim => the Mini MIM associated with this OMIM antry =cut sub new { my( $class,@args ) = @_; my $self = $class->SUPER::new( @args ); my ( $mim_number, $title, $alternative_titles_and_symbols, $more_than_two_genes, $is_separate, $description, $mapping_method, $gene_status, $comment, $species, $created, $edited, $contributors, $additional_references, $clinical_symptoms, $miniMIM ) = $self->_rearrange( [ qw( MIM_NUMBER TITLE ALTERNATIVE_TITLES_AND_SYMBOLS MORE_THAN_TWO_GENES IS_SEPARATE DESCRIPTION MAPPING_METHOD GENE_STATUS COMMENT SPECIES CREATED EDITED CONTRIBUTORS ADDITIONAL_REFERENCES CLINICAL_SYMPTOMS MINIMIM ) ], @args ); $self->init(); $mim_number && $self->MIM_number( $mim_number ); $title && $self->title( $title ); $alternative_titles_and_symbols && $self->alternative_titles_and_symbols( $alternative_titles_and_symbols ); $more_than_two_genes && $self->more_than_two_genes( $more_than_two_genes ); $is_separate && $self->is_separate( $is_separate ); $description && $self->description( $description ); $mapping_method && $self->mapping_method( $mapping_method ); $gene_status && $self->gene_status( $gene_status ); $comment && $self->comment( $comment ); $species && $self->species( $species ); $created && $self->created( $created ); $edited && $self->edited( $edited ); $contributors && $self->contributors( $contributors ); $additional_references && $self->additional_references( $additional_references ); $clinical_symptoms && $self->clinical_symptoms_raw( $clinical_symptoms ); $miniMIM && $self->miniMIM( $miniMIM ); return $self; } # new =head2 init Title : init() Usage : $obj->init(); Function: Initializes this OMIMentry to all "" and empty lists. Returns : Args : =cut sub init { my( $self ) = @_; $self->MIM_number( DEFAULT_MIM_NUMER ); $self->title( "" ); $self->alternative_titles_and_symbols( "" ); $self->more_than_two_genes( FALSE ); $self->is_separate( FALSE ); $self->description( "" ); $self->mapping_method( "" ); $self->gene_status( "" ); $self->comment( "" ); my $species = Bio::Species->new(); $species->classification( qw( sapiens Homo ) ); $self->species( $species ); $self->created( "" ); $self->edited( "" ); $self->contributors( "" ); $self->additional_references( "" ); $self->clinical_symptoms( {} ); $self->remove_Correlates(); $self->remove_References(); $self->remove_AllelicVariants(); $self->remove_CytoPositions(); $self->remove_gene_symbols(); $self->remove_Genotypes(); $self->remove_DBLinks(); $self->remove_keywords(); $self->remove_Variants(); $self->remove_Measures(); $self->miniMIM( Bio::Phenotype::OMIM::MiniMIMentry->new() ); } # init sub to_string { my( $self ) = @_; my $s = ""; $s .= "-- MIM number:\n"; $s .= $self->MIM_number()."\n\n"; $s .= "-- Title:\n"; $s .= $self->title()."\n\n"; $s .= "-- Alternative Titles and Symbols:\n"; $s .= $self->alternative_titles_and_symbols()."\n\n"; $s .= "-- Can be caused by Mutation in any of two or more Genes:\n"; $s .= $self->more_than_two_genes()."\n\n"; $s .= "-- Phenotype is separate:\n"; $s .= $self->is_separate()."\n\n"; $s .= "-- Description:\n"; $s .= $self->description()."\n\n"; $s .= "-- Species:\n"; $s .= $self->species()->binomial()."\n\n"; $s .= "-- Clinical Symptoms:\n"; $s .= $self->clinical_symptoms()."\n\n"; $s .= "-- Allelic Variants:\n"; $s .= $self->_array_to_string( $self->each_AllelicVariant() )."\n"; $s .= "-- Cyto Positions:\n"; $s .= $self->_array_to_string( $self->each_CytoPosition() )."\n"; $s .= "-- Gene Symbols:\n"; $s .= $self->_array_to_string( $self->each_gene_symbol() )."\n"; $s .= "-- Correlates:\n"; $s .= $self->_array_to_string( $self->each_Correlate() )."\n"; $s .= "-- References:\n"; $s .= $self->_array_to_string( $self->each_Reference() )."\n"; $s .= "-- Additional References:\n"; $s .= $self->additional_references()."\n\n"; $s .= "-- Mapping Method:\n"; $s .= $self->mapping_method()."\n\n"; $s .= "-- Gene status:\n"; $s .= $self->gene_status()."\n\n"; $s .= "-- Created:\n"; $s .= $self->created()."\n\n"; $s .= "-- Contributors:\n"; $s .= $self->contributors()."\n\n"; $s .= "-- Edited:\n"; $s .= $self->edited()."\n\n"; $s .= "-- Comment:\n"; $s .= $self->comment()."\n\n"; $s .= "-- MiniMIM:\n"; $s .= $self->miniMIM()->to_string()."\n\n"; return $s; } # to_string =head2 MIM_number Title : MIM_number Usage : $omim->MIM_number( "100050" ); or print $omim->MIM_number(); Function: Set/get for the MIM number of this OMIM entry. Returns : The MIM number [an integer larger than 100000]. Args : The MIM number [an integer larger than 100000] (optional). =cut sub MIM_number { my ( $self, $value ) = @_; if ( defined $value ) { if ( $value =~ /\D/ || ( $value < 100000 && $value != DEFAULT_MIM_NUMER ) ) { $self->throw( "Found [$value]" . " where [integer larger than 100000] expected" ); } $self->{ "_MIM_number" } = $value; } return $self->{ "_MIM_number" }; } # MIM_number =head2 title Title : title Usage : $omim->title( "AARSKOG SYNDROME" ); or print $omim->title(); Function: Set/get for the title or name of this OMIM entry. This method is an alias to the method "name" of Bio::Phenotype::PhenotypeI. Returns : The title [scalar]. Args : The title [scalar] (optional). =cut sub title { my $self = shift; $self->name(@_); } # title =head2 alternative_titles_and_symbols Title : alternative_titles_and_symbols Usage : $omim->alternative_titles_and_symbols( "AORTIC ANEURYSM, ABDOMINAL" ); or print $omim->alternative_titles_and_symbols(); Function: Set/get for the "alternative titles and symbols" of this OMIM entry. Currently, everything after the first line of title (TI) field is considered "alternative titles and symbols". Returns : "alternative titles and symbols" [scalar]. Args : "alternative titles and symbols" [scalar] (optional). =cut sub alternative_titles_and_symbols { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_alternative_titles_and_symbols" } = $value; } return $self->{ "_alternative_titles_and_symbols" }; } # alternative_titles_and_symbols =head2 more_than_two_genes Title : more_than_two_genes Usage : $omim->more_than_two_genes( 1 ); or print $omim->more_than_two_genes(); Function: This is true if this phenotype can be caused by mutation in any of two or more genes. In OMIM, this is indicated by a number symbol (#) before an entry number (e.g. #114480 -- BREAST CANCER). Returns : [1 or 0]. Args : [1 or 0] (optional). =cut sub more_than_two_genes { my ( $self, $value ) = @_; if ( defined $value ) { $self->_is_true_or_false( $value ); $self->{ "_more_than_two_genes" } = $value; } return $self->{ "_more_than_two_genes" }; } # more_than_two_genes =head2 is_separate Title : is_separate Usage : $omim->is_separate( 1 ); or print $omim->is_separate(); Function: This is true if the phenotype determined by the gene at the given locus is separate from those represented by other entries where "is_separate" is true and if the mode of inheritance of the phenotype has been proved (in the judgment of the authors and editors). In OMIM, this is indicated by a asterisk (*) before an entry number (e.g. *113705 BREAST CANCER, TYPE 1; BRCA1). Returns : [1 or 0]. Args : [1 or 0] (optional). =cut sub is_separate { my ( $self, $value ) = @_; if ( defined $value ) { $self->_is_true_or_false( $value ); $self->{ "_is_separate" } = $value; } return $self->{ "_is_separate" }; } # is_separate =head2 mapping_method Title : mapping_method Usage : $omim->mapping_method( "PCR of somatic cell hybrid DNA" ); or print $omim->mapping_method(); Function: Set/get for the mapping method of this OMIM entry. Returns : The mapping method [scalar]. Args : The mapping method [scalar] (optional). =cut sub mapping_method { my $self = shift; return $self->{ "_mapping_method" } = shift if(@_); return $self->{ "_mapping_method" }; } # mapping_method =head2 gene_status Title : gene_status Usage : $omim->gene_status( "C" ); or print $omim->gene_status(); Function: Set/get for the gene status of this OMIM entry. The certainty with which assignment of loci to chromosomes or the linkage between two loci has been established has been graded into the following classes: C = confirmed - observed in at least two laboratories or in several families. P = provisional - based on evidence from one laboratory or one family. I = inconsistent - results of different laboratories disagree. L = limbo - evidence not as strong as that provisional, but included for heuristic reasons. (Same as `tentative'.) Returns : [C, P, I, or L]. Args : [C, P, I, or L] (optional). =cut sub gene_status { my ( $self, $value ) = @_; if ( defined $value ) { #unless ( $value eq "C" # || $value eq "P" # || $value eq "I" # || $value eq "L" # || $value eq "A" # !? # || $value eq "H" # !? # || $value eq "U" # !? # || $value eq "" ) { # $self->throw( "Found [$value]" # . " where [C, P, I, or L] expected" ); #} unless ( $value eq "C" || $value eq "P" || $value eq "I" || $value eq "L" || $value eq "" ) { $value = ""; } $self->{ "_gene_status" } = $value; } return $self->{ "_gene_status" }; } # gene_status =head2 clinical_symptoms Title : clinical_symptoms Usage : $omim->clinical_symptoms({}); Function: Set/get for the clinical symptoms of this OMIM entry. Returns : [hash reference]. Args : [hash reference]. Suggested not to assign alone. Parser will do. =cut sub clinical_symptoms { my ( $self, $value ) = @_; if ( defined $value ) { unless(ref($value) eq 'HASH'){ $self->throw('a hash referenced needed'); } $self->{ "_clinical_symptoms" } = $value; } return $self->{ "_clinical_symptoms" }; } # clinical_symptoms =head2 clinical_symptoms_raw Title : clinical_symptoms_raw Usage : $omim->clinical_symptoms( "Patients with ..." ); print $omim->clinical_symptoms(); Functions : Get/set for text information of clinical symptoms Returns : The clinical symptoms [scalar]. Args : The clinical symptoms [scalar] (optional). =cut sub clinical_symptoms_raw { my $self = shift; return $self->{_clinical_symptoms_raw} = shift if @_; return $self->{_clinical_symptoms_raw}; } =head2 add_clinical_symptoms Title : add_clinical_symptoms Usage : $entry->add_clinical_symptoms('Ears', 'Floppy ears', 'Lop-ears'); Function : add one or more symptoms on one part of body. Returns : [none] Args : ($part, @symptoms) $part, the text name of part/organism of human @symptoms, an array of text description =cut sub add_clinical_symptoms { my ($self, $part, @symptoms) = @_; unless(defined $part){ $self->throw('a part/organism must be assigned'); } $self->{_clinical_symptoms} = {} unless $self->{_clinical_symptoms}; $self->{_clinical_symptoms}->{$part} = [] unless $self->{_clinical_symptoms}->{$part}; push @{$self->{_clinical_symptoms}->{$part}}, @symptoms; } =head2 query_clinical_symptoms Title : get_clinical_symptoms Usage : @symptoms = $self->query_clinical_symptoms('Ears'); Function : get all symptoms specific to one part/organism. Returns : an array of text Args : $organ =cut sub query_clinical_symptoms { my ($self, $organ)=@_; my $symptoms=$self->{_clinical_symptoms}->{$organ}; @$symptoms; } sub get_clinical_symptom_organs { my ($self)=@_; keys %{$self->{_clinical_symptoms}}; } =head2 created Title : created Usage : $omim->created( "Victor A. McKusick: 6/4/1986" ); or print $omim->created(); Function: Set/get for the created field of the OMIM database. Returns : Name(s) and date(s) [scalar - free form]. Args : Name(s) and date(s) [scalar - free form] (optional). =cut sub created { my $self = shift; return $self->{ "_created" } = shift if(@_); return $self->{ "_created" }; } # created =head2 contributors Title : contributors Usage : $omim->contributors( "Kelly A. Przylepa - revised: 03/18/2002" ); or print $omim->contributors(); Function: Set/get for the contributors field of the OMIM database. Returns : Name(s) and date(s) [scalar - free form]. Args : Name(s) and date(s) [scalar - free form] (optional). =cut sub contributors { my $self = shift; $self->{ "_contributors" } = shift if(@_); return $self->{ "_contributors" }; } # contributors =head2 edited Title : edited Usage : $omim->edited( "alopez: 06/03/1997" ); or print $omim->edited(); Function: Set/get for the edited field of the OMIM database. Returns : Name(s) and date(s) [scalar - free form]. Args : Name(s) and date(s) [scalar - free form] (optional). =cut sub edited { my $self = shift; return $self->{ "_edited" } = shift if(@_); return $self->{ "_edited" }; } # edited =head2 additional_references Title : additional_references Usage : $omim->additional_references( "Miller er al." ); or print $omim->additional_references(); Function: Set/get for the additional references of this OMIM antry (see also). Returns : additional reference [scalar]. Args : additional reference [scalar] (optional). =cut sub additional_references { my $self = shift; return $self->{ "_additional_references" } = shift if(@_); return $self->{ "_additional_references" }; } # additional_references =head2 miniMIM Title : miniMIM Usage : $omim->miniMIM( $MM ); or $MM = $omim->miniMIM(); Function: Set/get for the Mini MIM associated with this OMIM antry (see also). Returns : [Bio::Phenotype::OMIM::MiniMIMentry]. Args : [Bio::Phenotype::OMIM::MiniMIMentry] (optional). =cut sub miniMIM { my ( $self, $value ) = @_; if ( defined $value ) { $self->_check_ref_type( $value, "Bio::Phenotype::OMIM::MiniMIMentry" ); $self->{ "_mini_mim" } = $value; } return $self->{ "_mini_mim" }; } =head2 each_AllelicVariant Title : each_AllelicVariant() Usage : @avs = $obj->each_AllelicVariant(); Function: Returns a list of Bio::Phenotype::OMIM::OMIMentryAllelicVariant objects associated with this OMIM entry. Returns : A list of Bio::Phenotype::OMIM::OMIMentryAllelicVariant objects. Args : =cut sub each_AllelicVariant { my ( $self ) = @_; return @{$self->{"_allelic_variants"}} if exists($self->{"_allelic_variants"}); return (); } # each_AllelicVariant =head2 add_AllelicVariants Title : add_AllelicVariants Usage : $obj->add_AllelicVariants( @avs ); or $obj->add_AllelicVariants( $av ); Function: Pushes one or more OMIMentryAllelicVariant into the list of OMIMentryAllelicVariants. Returns : Args : Bio::Phenotype::OMIM::OMIMentryAllelicVariant object(s). =cut sub add_AllelicVariants { my ( $self, @values ) = @_; return unless( @values ); foreach my $value ( @values ) { $self->_check_ref_type( $value, "Bio::Phenotype::OMIM::OMIMentryAllelicVariant" ); } push( @{ $self->{ "_allelic_variants" } }, @values ); } # add_AllelicVariants =head2 remove_AllelicVariants Title : remove_AllelicVariants Usage : $obj->remove_AllelicVariants(); Function: Deletes (and returns) the list of OMIMentryAllelicVariant objects associated with this OMIM entry. Returns : A list of OMIMentryAllelicVariant objects. Args : =cut sub remove_AllelicVariants { my ( $self ) = @_; my @a = $self->each_AllelicVariant(); $self->{ "_allelic_variants" } = []; return @a; } # remove_AllelicVariants # Title : _array_to_string # Function: # Returns : # Args : sub _array_to_string { my( $self, @value ) = @_; my $s = ""; for ( my $i = 0; $i < scalar( @value ); ++$i ) { if ( ! ref( $value[ $i ] ) ) { $s .= "#" . $i . "\n-- Value:\n" . $value[ $i ] . "\n"; } elsif ( $value[ $i ]->isa( "Bio::Phenotype::OMIM::OMIMentryAllelicVariant" ) || $value[ $i ]->isa( "Bio::Phenotype::Correlate" ) ) { $s .= "#" . $i . "\n" . ( $value[ $i ] )->to_string() . "\n"; } elsif ( $value[ $i ]->isa( "Bio::Annotation::Reference" ) ) { $s .= "#".$i."\n-- Authors:\n".( $value[ $i ] )->authors()."\n"; $s .= "-- Title:\n".( $value[ $i ] )->title()."\n"; $s .= "-- Location:\n".( $value[ $i ] )->location()."\n"; } elsif ( $value[ $i ]->isa( "Bio::Map::CytoPosition" ) ) { $s .= "#" . $i . "\n-- Value:\n" . ( $value[ $i ] )->value() . "\n"; } } return $s; } # _array_to_string # Title :_is_true_or_false # Function: Checks whether the argument is 1 or 0. # Returns : # Args : The value to be checked. sub _is_true_or_false { my ( $self, $value ) = @_; unless ( $value !~ /\D/ && ( $value == TRUE || $value == FALSE ) ) { $self->throw( "Found [" . $value . "] where " . TRUE . " or " . FALSE . " expected" ); } } # _is_true_or_false 1; BioPerl-1.6.923/Bio/Phenotype/OMIM/OMIMentryAllelicVariant.pm000444000765000024 2522712254227323 23707 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::OMIM::OMIMentryAllelicVariant # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::OMIM::OMIMentryAllelicVariant - Representation of a allelic variant of the OMIM database =head1 SYNOPSIS use Bio::Phenotype::OMIM::OMIMentryAllelicVariant; $av = Bio::Phenotype::OMIM::OMIMentryAllelicVariant->new( -number => ".0001", -title => "ALCOHOL INTOLERANCE", -symbol => "ALDH2*2", -description => "The ALDH2*2-encoded ...", -aa_ori => "GLU", -aa_mut => "LYS", -position => 487, -additional_mutations => "IVS4DS, G-A, +1" ); =head1 DESCRIPTION This class models the allelic variant of the OMIM database. This class is intended to be used together with a OMIM entry class. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Phenotype::OMIM::OMIMentryAllelicVariant; use strict; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $av = Bio::Phenotype::OMIM::OMIMentryAllelicVariant->new( -number => ".0001", -title => "ALCOHOL INTOLERANCE", -symbol => "ALDH2*2", -description => "The ALDH2*2-encoded ...", -aa_ori => "GLU", -aa_mut => "LYS", -position => 487, -additional_mutations => "IVS4DS, G-A, +1" ); Function: Creates a new OMIMentryAllelicVariant object. Returns : A new OMIMentryAllelicVariant object. Args : -number => the OMIM allelic variant number -title => the title -symbol => a symbol -description => a description -aa_ori => the original amino acid -aa_mut => the mutated amino acid -position => the position of the mutation -additional_mutations => free form description of additional mutations =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $number, $title, $symbol, $desc, $ori, $mut, $pos, $am ) = $self->_rearrange( [ qw( NUMBER TITLE SYMBOL DESCRIPTION AA_ORI AA_MUT POSITION ADDITIONAL_MUTATIONS ) ], @args ); $self->init(); $number && $self->number( $number ); $title && $self->title( $title ); $symbol && $self->symbol( $symbol ); $desc && $self->description( $desc ); $ori && $self->aa_ori( $ori ); $mut && $self->aa_mut( $mut ); $pos && $self->position( $pos ); $am && $self->additional_mutations( $am ); return $self; } # new =head2 init Title : init() Usage : $av->init(); Function: Initializes this OMIMentryAllelicVariant to all "". Returns : Args : =cut sub init { my( $self ) = @_; $self->number( "" ); $self->title( "" ); $self->symbol( "" ); $self->description( "" ); $self->aa_ori( "" ); $self->aa_mut( "" ); $self->position( "" ); $self->additional_mutations( "" ); } # init =head2 number Title : number Usage : $av->number( ".0001" ); or print $av->number(); Function: Set/get for the OMIM allelic variant number of this OMIMentryAllelicVariant. Returns : The OMIM allelic variant number. Args : The OMIM allelic variant number (optional). =cut sub number { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_number" } = $value; } return $self->{ "_number" }; } # number =head2 title Title : title Usage : $av->title( "ALCOHOL INTOLERANCE" ); or print $av->title(); Function: Set/get for the title of this OMIMentryAllelicVariant. Returns : The title. Args : The title (optional). =cut sub title { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_title" } = $value; } return $self->{ "_title" }; } # title =head2 symbol Title : symbol Usage : $av->symbol( "ALDH2*2" ); or print $av->symbol(); Function: Set/get for the symbol of this OMIMentryAllelicVariant. Returns : A symbol. Args : A symbol (optional). =cut sub symbol { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_symbol" } = $value; } return $self->{ "_symbol" }; } # symbol =head2 description Title : description Usage : $av->description( "The ALDH2*2-encoded protein has a change ..." ); or print $av->description(); Function: Set/get for the description of this OMIMentryAllelicVariant. Returns : A description. Args : A description (optional). =cut sub description { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_description" } = $value; } return $self->{ "_description" }; } # description =head2 aa_ori Title : aa_ori Usage : $av->aa_ori( "GLU" ); or print $av->aa_ori(); Function: Set/get for the original amino acid(s). Returns : The original amino acid(s). Args : The original amino acid(s) (optional). =cut sub aa_ori { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_aa_ori" } = $value; } return $self->{ "_aa_ori" }; } # aa_ori =head2 aa_mut Title : aa_mut Usage : $av->aa_mut( "LYS" ); or print $av->aa_mut(); Function: Set/get for the mutated amino acid(s). Returns : The mutated amino acid(s). Args : The mutated amino acid(s) (optional). =cut sub aa_mut { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_aa_mut" } = $value; } return $self->{ "_aa_mut" }; } # aa_mut =head2 position Title : position Usage : $av->position( 487 ); or print $av->position(); Function: Set/get for the position of the mutation. Returns : The position of the mutation. Args : The position of the mutation (optional). =cut sub position { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_position" } = $value; } return $self->{ "_position" }; } # position =head2 additional_mutations Title : additional_mutations Usage : $av->additional_mutations( "1-BP DEL, 911T" ); or print $av->additional_mutations(); Function: Set/get for free form description of (additional) mutation(s). Returns : description of (additional) mutation(s). Args : description of (additional) mutation(s) (optional). =cut sub additional_mutations { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_additional_mutations" } = $value; } return $self->{ "_additional_mutations" }; } # additional_mutations =head2 to_string Title : to_string() Usage : print $av->to_string(); Function: To string method for OMIMentryAllelicVariant objects. Returns : A string representations of this OMIMentryAllelicVariant. Args : =cut sub to_string { my( $self ) = @_; my $s = ""; $s .= "-- Number:\n"; $s .= $self->number()."\n"; $s .= "-- Title:\n"; $s .= $self->title()."\n"; $s .= "-- Symbol:\n"; $s .= $self->symbol()."\n"; $s .= "-- Description:\n"; $s .= $self->description()."\n"; $s .= "-- Original AA(s):\n"; $s .= $self->aa_ori()."\n"; $s .= "-- Mutated AA(s):\n"; $s .= $self->aa_mut()."\n"; $s .= "-- Position:\n"; $s .= $self->position()."\n"; $s .= "-- Additional Mutation(s):\n"; $s .= $self->additional_mutations(); return $s; } # to_string 1; BioPerl-1.6.923/Bio/Phenotype/OMIM/OMIMparser.pm000444000765000024 6552012254227333 21230 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Phenotype::OMIM::OMIMparser # # Please direct questions and support issues to # # Cared for by Christian M. Zmasek or # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Phenotype::OMIM::OMIMparser - parser for the OMIM database =head1 SYNOPSIS use Bio::Phenotype::OMIM::OMIMparser; # The OMIM database is available as textfile at: # ftp://ncbi.nlm.nih.gov/repository/OMIM/omim.txt.Z # The genemap is available as textfile at: # ftp://ncbi.nlm.nih.gov/repository/OMIM/genemap $omim_parser = Bio::Phenotype::OMIM::OMIMparser->new( -genemap => "/path/to/genemap", -omimtext => "/path/to/omim.txt" ); while ( my $omim_entry = $omim_parser->next_phenotype() ) { # This prints everything. print( $omim_entry->to_string() ); print "\n\n"; # This gets individual data (some of them object-arrays) # (and illustrates the relevant methods of OMIMentry). my $numb = $omim_entry->MIM_number(); # *FIELD* NO my $title = $omim_entry->title(); # *FIELD* TI - first line my $alt = $omim_entry->alternative_titles_and_symbols(); # *FIELD* TI - additional lines my $mtt = $omim_entry->more_than_two_genes(); # "#" before title my $sep = $omim_entry->is_separate(); # "*" before title my $desc = $omim_entry->description(); # *FIELD* TX my $mm = $omim_entry->mapping_method(); # from genemap my $gs = $omim_entry->gene_status(); # from genemap my $cr = $omim_entry->created(); # *FIELD* CD my $cont = $omim_entry->contributors(); # *FIELD* CN my $ed = $omim_entry->edited(); # *FIELD* ED my $sa = $omim_entry->additional_references(); # *FIELD* SA my $cs = $omim_entry->clinical_symptoms_raw(); # *FIELD* CS my $comm = $omim_entry->comment(); # from genemap my $mini_mim = $omim_entry->miniMIM(); # *FIELD* MN # A Bio::Phenotype::OMIM::MiniMIMentry object. # class Bio::Phenotype::OMIM::MiniMIMentry # provides the following: # - description() # - created() # - contributors() # - edited() # # Prints the contents of the MINI MIM entry (most OMIM entries do # not have MINI MIM entries, though). print $mini_mim->description()."\n"; print $mini_mim->created()."\n"; print $mini_mim->contributors()."\n"; print $mini_mim->edited()."\n"; my @corrs = $omim_entry->each_Correlate(); # from genemap # Array of Bio::Phenotype::Correlate objects. # class Bio::Phenotype::Correlate # provides the following: # - name() # - description() (not used) # - species() (always mouse) # - type() ("OMIM mouse correlate") # - comment() my @refs = $omim_entry->each_Reference(); # *FIELD* RF # Array of Bio::Annotation::Reference objects. my @avs = $omim_entry->each_AllelicVariant(); # *FIELD* AV # Array of Bio::Phenotype::OMIM::OMIMentryAllelicVariant objects. # class Bio::Phenotype::OMIM::OMIMentryAllelicVariant # provides the following: # - number (e.g ".0001" ) # - title (e.g "ALCOHOL INTOLERANCE" ) # - symbol (e.g "ALDH2*2" ) # - description (e.g "The ALDH2*2-encoded protein has a change ..." ) # - aa_ori (used if information in the form "LYS123ARG" is found) # - aa_mut (used if information in the form "LYS123ARG" is found) # - position (used if information in the form "LYS123ARG" is found) # - additional_mutations (used for e.g. "1-BP DEL, 911T") my @cps = $omim_entry->each_CytoPosition(); # from genemap # Array of Bio::Map::CytoPosition objects. my @gss = $omim_entry->each_gene_symbol(); # from genemap # Array of strings. # do something ... } =head1 DESCRIPTION This parser returns Bio::Phenotype::OMIM::OMIMentry objects (which inherit from Bio::Phenotype::PhenotypeI). It parses the OMIM database available as ftp://ncbi.nlm.nih.gov/repository/OMIM/omim.txt.Z together with (optionally) the gene map file at ftp://ncbi.nlm.nih.gov/repository/OMIM/genemap. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Phenotype::OMIM::OMIMparser; use strict; use Bio::Root::IO; use Bio::Species; use Bio::Annotation::Reference; use Bio::Map::CytoPosition; use Bio::Phenotype::OMIM::OMIMentry; use Bio::Phenotype::OMIM::OMIMentryAllelicVariant; use Bio::Phenotype::Correlate; use base qw(Bio::Root::Root); use constant DEFAULT_STATE => 0; use constant MIM_NUMBER_STATE => 1; use constant TITLE_STATE => 2; use constant TEXT_STATE => 3; use constant MINI_MIM_TEXT_STATE => 4; use constant ALLELIC_VARIANT_STATE => 5; use constant SEE_ALSO_STATE => 6; use constant REF_STATE => 7; use constant SYMPT_STATE => 8; use constant CONTRIBUTORS_STATE => 9; use constant CREATED_BY_STATE => 10; use constant EDITED_BY_STATE => 11; use constant MINI_MIM_EDITED_BY_STATE => 12; use constant MINI_MIM_CREATED_BY_STATE => 13; use constant MINI_MIM_CONTRIBUTORS_STATE => 14; use constant TRUE => 1; use constant FALSE => 0; =head2 new Title : new Usage : $omim_parser = Bio::Phenotype::OMIM::OMIMparser->new( -genemap => "/path/to/genemap", -omimtext => "/path/to/omim.txt" ); Function: Creates a new OMIMparser. Returns : A new OMIMparser object. Args : -genemap => the genemap file name (optional) -omimtext => the omim text file name =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $genemap_file_name, $omimtxt_file_name ) = $self->_rearrange( [ qw( GENEMAP OMIMTEXT ) ], @args ); $self->init(); $genemap_file_name && $self->genemap_file_name( $genemap_file_name ); $omimtxt_file_name && $self->omimtxt_file_name( $omimtxt_file_name); return $self; } =head2 next_phenotype Title : next_phenotype() Usage : while ( my $omim_entry = $omim_parser->next_phenotype() ) { # do something with $omim_entry } Function: Returns an Bio::Phenotype::OMIM::OMIMentry or undef once the end of the omim text file is reached. Returns : A Bio::Phenotype::OMIM::OMIMentry. Args : =cut sub next_phenotype { my ( $self ) = @_; unless( defined( $self->_OMIM_text_file() ) ) { $self->_no_OMIM_text_file_provided_error(); } if ( $self->_done() == TRUE ) { return; } my $fieldtag = ""; my $contents = ""; my $line = ""; my $state = DEFAULT_STATE; my $saw_mini_min_flag = FALSE; my %record = (); while( $line = ( $self->_OMIM_text_file )->_readline() ) { if ( $line =~ /^\s*\*RECORD\*/ ) { if ( $self->_is_not_first_record() == TRUE ) { $self->_add_to_hash( $state, $contents,\%record ); my $omim_entry = $self->_createOMIMentry( \%record ); return $omim_entry; } else { $self->_is_not_first_record( TRUE ); } } elsif ( $line =~ /^\s*\*FIELD\*\s*(\S+)/ ) { $fieldtag = $1; if ( $state != DEFAULT_STATE ) { $self->_add_to_hash( $state, $contents,\%record ); } $contents = ""; if ( $fieldtag eq "NO" ) { $state = MIM_NUMBER_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "TI" ) { $state = TITLE_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "TX" ) { $state = TEXT_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "MN" ) { $state = MINI_MIM_TEXT_STATE; $saw_mini_min_flag = TRUE; } elsif ( $fieldtag eq "AV" ) { $state = ALLELIC_VARIANT_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "SA" ) { $state = SEE_ALSO_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "RF" ) { $state = REF_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "CS" ) { $state = SYMPT_STATE; $saw_mini_min_flag = FALSE; } elsif ( $fieldtag eq "CN" ) { if ( $saw_mini_min_flag == TRUE ) { $state = MINI_MIM_CONTRIBUTORS_STATE; } else { $state = CONTRIBUTORS_STATE; } } elsif ( $fieldtag eq "CD" ) { if ( $saw_mini_min_flag == TRUE ) { $state = MINI_MIM_CREATED_BY_STATE; } else { $state = CREATED_BY_STATE; } } elsif ( $fieldtag eq "ED" ) { if ( $saw_mini_min_flag == TRUE ) { $state = MINI_MIM_EDITED_BY_STATE; } else { $state = EDITED_BY_STATE; } } else { print "Warning: Unknown tag: $fieldtag\n"; } } else { $contents .= $line; } } $self->_OMIM_text_file()->close(); $self->_done( TRUE ); unless( %record ) { $self->_not_a_OMIM_text_file_error(); } $self->_add_to_hash( $state, $contents,\%record ); my $omim_entry = $self->_createOMIMentry( \%record ); return $omim_entry; } # next_phenotype =head2 init Title : init() Usage : $omim_parser->init(); Function: Initializes this OMIMparser to all "". Returns : Args : =cut sub init { my ( $self ) = @_; $self->genemap_file_name( "" ); $self->omimtxt_file_name( "" ); $self->_genemap_hash( {} ); $self->_OMIM_text_file( undef ); $self->_is_not_first_record( FALSE ); $self->_done( FALSE ); } # init =head2 genemap_file_name Title : genemap_file_name Usage : $omimparser->genemap_file_name( "genemap" ); Function: Set/get for the genemap file name. Returns : The genemap file name [string]. Args : The genemap file name [string] (optional). =cut sub genemap_file_name { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_genemap_file_name" } = $value; $self->_genemap_hash( $self->_read_genemap( $value ) ); } return $self->{ "_genemap_file_name" }; } # genemap_file_name =head2 omimtxt_file_name Title : omimtxt_file_name Usage : $omimparser->omimtxt_file_name( "omim.txt" ); Function: Set/get for the omim text file name. Returns : The the omim text file name [string]. Args : The the omim text file name [string] (optional). =cut sub omimtxt_file_name { my ( $self, $value ) = @_; if ( defined $value ) { $self->{ "_omimtxt_file_name" } = $value; if ( $value =~ /\W/ ) { $self->_OMIM_text_file( Bio::Root::IO->new->new( -file => $value ) ); } } return $self->{ "_omimtxt_file_name" }; } # omimtxt_file_name sub _createOMIMentry { my ( $self, $record_ref ) = @_; my $omim_entry = Bio::Phenotype::OMIM::OMIMentry->new(); my $mini_mim = Bio::Phenotype::OMIM::MiniMIMentry->new(); while ( ( my $key, my $val ) = each( %$record_ref ) ) { $val =~ s/^\s+//; $val =~ s/\s+$//; if ( $key == MIM_NUMBER_STATE ) { $val =~ s/\s+//g; $val =~ s/\D//g; $omim_entry->MIM_number( $val ); my $gm = $self->_genemap_hash(); if ( exists( $$gm{ $val } ) ) { $self->_parse_genemap( $omim_entry, $val ); } } elsif ( $key == TITLE_STATE ) { my ( $title, $alt_titles ) = $self->_parse_title( $val ); $omim_entry->title( $title ); $omim_entry->alternative_titles_and_symbols( $alt_titles ); if ( $title =~ /^\*/ ) { $omim_entry->is_separate( TRUE ); } elsif ( $title =~ /^#/ ) { $omim_entry->more_than_two_genes( TRUE ); } } elsif ( $key == TEXT_STATE ) { $val = undef if($val =~ /DESCRIPTION1\nDESCRIPTION2/); $omim_entry->description( $val ); } elsif ( $key == ALLELIC_VARIANT_STATE ) { my @allelic_variants = $self->_parse_allelic_variants( $val ); $omim_entry->add_AllelicVariants( @allelic_variants ); } elsif ( $key == SEE_ALSO_STATE ) { $omim_entry->additional_references( $val ); } elsif ( $key == REF_STATE ) { my @refs = $self->_parse_references( $val ); $omim_entry->add_References( @refs ); } elsif ( $key == SYMPT_STATE ) { $val = '' if($val eq 'clinical symptoms'); $omim_entry->clinical_symptoms_raw( $val ); } elsif ( $key == CONTRIBUTORS_STATE ) { $val = undef if($val =~ /cn1\ncn2\ncn3/); $omim_entry->contributors( $val ); } elsif ( $key == CREATED_BY_STATE ) { $val = undef if($val =~ /cd1\ncd2\ncd3/); $omim_entry->created( $val ); } elsif ( $key == EDITED_BY_STATE ) { $val = undef if($val =~ /ed1\ned2\ned3/); $omim_entry->edited( $val ); } elsif ( $key == MINI_MIM_TEXT_STATE ) { $mini_mim->description( $val ); } elsif ( $key == MINI_MIM_CONTRIBUTORS_STATE ) { $mini_mim->contributors( $val ); } elsif ( $key == MINI_MIM_CREATED_BY_STATE ) { $mini_mim->created( $val ); } elsif ( $key == MINI_MIM_EDITED_BY_STATE ) { $mini_mim->edited( $val ); } } my $man = Bio::Species->new(); $man->classification( qw( sapiens Homo ) ); $man->common_name( "man" ); $omim_entry->species( $man ); $omim_entry->miniMIM( $mini_mim ); # parse the symptoms text into a hash-based structure. $self->_finer_parse_symptoms($omim_entry); return $omim_entry; } # _createOMIMentry sub _finer_parse_symptoms { my ($self, $omim_entry) = @_; my $text = $omim_entry->clinical_symptoms_raw; if( $text ) { my $part; for my $line (split /\n/, $text){ if ($line =~ /^([\w\s,]+)\:\s*$/) { $part = $1; } elsif( $line =~ /^\s+$/ ) { } elsif($line =~ /^(\s+)([^;]+)\;?\s*$/){ my $symptom = $2; if( ! $part ) { # $self->warn("$text\nline='$line'\n"); next; } $omim_entry->add_clinical_symptoms($part, $symptom); } } } $omim_entry->clinical_symptoms_raw(''); } sub _parse_genemap { my ( $self, $omim_entry, $val ) = @_; my $genemap_line = ${ $self->_genemap_hash() }{ $val }; my @a = split( /\|/, $genemap_line ); my $locations = $a[ 4 ]; if ( defined ( $locations ) ) { $locations =~ s/\s+//g; my @ls = split( /[,;]/, $locations ); my @cps; foreach my $l ( @ls ) { my $cp = Bio::Map::CytoPosition->new( -value => $l ); push( @cps, $cp ); } $omim_entry->add_CytoPositions( @cps ); } my $gene_symbols = $a[ 5 ]; if ( defined ( $gene_symbols ) ) { $gene_symbols =~ s/\s+//g; my @gss = split( /[,;]/, $gene_symbols ); $omim_entry->add_gene_symbols( @gss ); } my $mouse_correlates = $a[ 16 ]; if ( defined ( $mouse_correlates ) ) { $mouse_correlates =~ s/\s+//g; my @mcs = split( /[,;]/, $mouse_correlates ); my @cs; foreach my $mc ( @mcs ) { my $mouse = Bio::Species->new(); $mouse->classification( qw( musculus Mus ) ); $mouse->common_name( "mouse" ); my $c = Bio::Phenotype::Correlate->new(); $c->name( $mc ); $c->species( $mouse ); $c->type( "OMIM mouse correlate" ); push( @cs, $c ); } $omim_entry->add_Correlates( @cs ); } $omim_entry->gene_status( $a[ 6 ] ) if defined $a[ 6 ]; $omim_entry->mapping_method( $a[ 10 ] ) if defined $a[ 10 ]; $omim_entry->comment( $a[ 11 ] ) if defined $a[ 11 ]; } # _parse_genemap sub _parse_allelic_variants { my ( $self, $text ) = @_; my @allelic_variants; my $number = ""; my $title = ""; my $symbol_mut_line = ""; my $prev_line = ""; my $description = ""; my $saw_empty_line = FALSE; my @lines = split( /\n/, $text ); foreach my $line ( @lines ) { if ( $line !~ /\w/ ) { $saw_empty_line = TRUE; } elsif ( $line =~ /^\s*(\.\d+)/ ) { my $current_number = $1; if ( $number ne "" ) { my $allelic_variant = $self->_create_allelic_variant( $number, $title, $symbol_mut_line, $description ); push( @allelic_variants, $allelic_variant ); } $number = $current_number; $title = ""; $prev_line = ""; $symbol_mut_line = ""; $description = ""; $saw_empty_line = FALSE; } elsif ( $title eq "" ) { $title = $line; } elsif ( $saw_empty_line == FALSE ) { $prev_line = $line; } elsif ( $saw_empty_line == TRUE ) { if ( $prev_line ne "" ) { $symbol_mut_line = $prev_line; $prev_line = ""; } if ( $description ne "" ) { $description .= "\n" . $line; } else { $description = $line; } } } my $allelic_variant = $self->_create_allelic_variant( $number, $title, $symbol_mut_line, $description ); push( @allelic_variants, $allelic_variant ); return @allelic_variants; } # _parse_allelic_variants sub _create_allelic_variant { my ( $self, $number, $title, $symbol_mut_line, $description ) = @_; my $symbol = ""; my $mutation = ""; my $aa_ori = ""; my $aa_mut = ""; my $position = ""; if ( $symbol_mut_line =~ /\s*(.+?)\s*,\s*([a-z]{3})(\d+)([a-z]{3})/i ) { $symbol = $1; $aa_ori = $2; $aa_mut = $4; $position = $3; } elsif ( $symbol_mut_line =~ /\s*(.+?)\s*,\s*(.+)/ ) { $symbol = $1; $mutation = $2; } else { $symbol = $symbol_mut_line; } if ( ! defined( $description ) ) { $self->throw("undef desc"); } if ( ! defined( $mutation ) ) { $self->throw("undef mutation"); } my $allelic_variant = Bio::Phenotype::OMIM::OMIMentryAllelicVariant->new(); $allelic_variant->number( $number ); $allelic_variant->aa_ori( $aa_ori ); $allelic_variant->aa_mut( $aa_mut ); $allelic_variant->position( $position ); $allelic_variant->title( $title ); $allelic_variant->symbol( $symbol ); $allelic_variant->description( $description ); $allelic_variant->additional_mutations( $mutation ); return $allelic_variant; } # _create_allelic_variant sub _parse_title { my ( $self, $text ) = @_; my $title = ""; if ( $text =~ /^(.+)\n/ ) { $title = $1; $text =~ s/^.+\n//; } else { $title = $text; $text = ""; } return ( $title, $text ); } # _parse_title sub _parse_references { my ( $self, $text ) = @_; $text =~ s/\A\s+//; $text =~ s/\s+\z//; $text =~ s/\A\d+\.\s*//; my @references; my @texts = split( /\s*\n\s*\n\s*\d+\.\s*/, $text ); foreach my $t ( @texts ) { my $authors = ""; my $title = ""; my $location = ""; $t =~ s/\s+/ /g; if ( $t =~ /(.+?)\s*:\s*(.+?[.?!])\s+(.+?)\s+(\S+?)\s*:\s*(\w?\d+.*)\s*,\s*(\d+)/ ) { $authors = $1; $title = $2; my $journal = $3; my $volume = $4; my $fromto = $5; my $year = $6; my $from = "", my $to = ""; if ( $fromto =~ /(\d+)-+(\d+)/ ) { $from = $1; $to = "-".$2; } elsif ( $fromto =~ /\A(\w+)/ ) { $from = $1; } $location = $journal." ".$volume." ".$from.$to." (".$year.")"; } elsif ( $t =~ /(.+?)\s*:\s*(.+?[.?!])\s*(.+?)\z/ ) { $authors = $1; $title = $2; $location = $3; } else { $title = $t; } my $ref = Bio::Annotation::Reference->new( -title => $title, -location => $location, -authors => $authors ); push( @references, $ref ); } return @references; } # _parse_references sub _genemap_hash { my ( $self, $value ) = @_; if ( defined $value ) { unless ( ref( $value ) eq "HASH" ) { $self->throw( "Argument to method \"_genemap_hash\" is not a reference to an Hash" ); } $self->{ "_genemap_hash" } = $value; } return $self->{ "_genemap_hash" }; } # _genemap_hash sub _is_not_first_record { my ( $self, $value ) = @_; if ( defined $value ) { unless ( $value == FALSE || $value == TRUE ) { $self->throw( "Found [$value] where [" . TRUE ." or " . FALSE . "] expected" ); } $self->{ "_not_first_record" } = $value; } return $self->{ "_not_first_record" }; } # _is_not_first_record sub _done { my ( $self, $value ) = @_; if ( defined $value ) { unless ( $value == FALSE || $value == TRUE ) { $self->throw( "Found [$value] where [" . TRUE ." or " . FALSE . "] expected" ); } $self->{ "_done" } = $value; } return $self->{ "_done" }; } # _done sub _OMIM_text_file { my ( $self, $value ) = @_; if ( defined $value ) { unless ( $value->isa( "Bio::Root::IO" ) ) { $self->throw( "[$value] is not a valid \"Bio::Root::IO\"" ); } $self->{ "_omimtxt_file" } = $value; } return $self->{ "_omimtxt_file" }; } # _OMIM_text_file sub _read_genemap { my ( $self, $genemap_file_name ) = @_; my $line = ""; my %genemap_hash = (); my $genemap_file = Bio::Root::IO->new( -file => $genemap_file_name ); my @a = (); my %gm = (); while( $line = $genemap_file->_readline() ) { @a = split( /\|/, $line ); unless( scalar( @a ) == 18 ) { $self->throw( "Gene map file \"".$self->genemap_file_name() . "\" is not in the expected format." . " Make sure there is a linebreak after the final line." ); } $gm{ $a[ 9 ] } = $line; } $genemap_file->close(); $self->_genemap_hash( \%gm ); } #_read_genemap sub _no_OMIM_text_file_provided_error { my ( $self ) = @_; my $msg = "Need to indicate a OMIM text file to read from with\n"; $msg .= "either \"OMIMparser->new( -omimtext => \"path/to/omim.txt\" );\"\n"; $msg .= "or \"\$omim_parser->omimtxt_file_name( \"path/to/omim.txt\" );\""; $self->throw( $msg ); } # _no_OMIM_text_file_provided_error sub _not_a_OMIM_text_file_error { my ( $self ) = @_; my $msg = "File \"".$self->omimtxt_file_name() . "\" appears not to be a OMIM text file"; $self->throw( $msg ); } # _not_a_OMIM_text_file_error sub _add_to_hash { my ( $self, $state, $contents, $record_ref ) = @_; if ( exists( $record_ref->{ $state } ) ) { chomp( $record_ref->{ $state } ); $record_ref->{ $state } = $record_ref->{ $state } . $contents; } else { $record_ref->{ $state } = $contents; } } # _add_to_hash 1; BioPerl-1.6.923/Bio/PhyloNetwork000755000765000024 012254227326 16462 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/PhyloNetwork/Factory.pm000444000765000024 1243112254227314 20602 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::Factory # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::Factory - Module to sequentially generate Phylogenetic Networks =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork; use Bio::PhyloNetwork::Factory; # Will generate sequentially all the 4059 binary tree-child phylogenetic # networks with 4 leaves my $factory=Bio::PhyloNetwork::Factory->new(-numleaves=>4); my @nets; while (my $net=$factory->next_network()) { push @nets,$net; print "".(scalar @nets).": ".$net->eNewick()."\n"; } =head1 DESCRIPTION Sequentially builds a (binary tree-child) phylogenetic network each time next_network is called. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::Factory; use strict; use warnings; use base qw(Bio::Root::Root); use Bio::PhyloNetwork; use Bio::PhyloNetwork::TreeFactory; =head2 new Title : new Usage : my $factory = new Bio::PhyloNetwork::Factory(); Function: Creates a new Bio::PhyloNetwork::Factory Returns : Bio::PhyloNetwork::RandomFactory Args : -numleaves => integer OR -leaves => reference to an array (of leaves names) -numhybrids => integer [default = numleaves -1] -recurse => boolean [optional] Returns a Bio::PhyloNetwork::Factory object. Such an object will sequentially create binary tree-child phylogenetic networks each time next_network is called. If the parameter -leaves=E\@leaves is given, then the set of leaves of these networks will be @leaves. If it is given the parameter -numleaves=E$numleaves, then the set of leaves will be "l1"..."l$numleaves". If the parameter -numhybrids=E$numhybrids is given, then the generated networks will have at most $numhybrids hybrid nodes. Note that, necessarily, $numhybrids E $numleaves. If the parameter -recurse=E1 is given, then all networks with number of hybrid nodes less or equal to $numhybrids will be given; otherwise only those with exactly $numhybrids hybrid nodes. =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($leavesR,$numleaves,$numhybrids,$recurse)= $self->_rearrange([qw(LEAVES NUMLEAVES NUMHYBRIDS RECURSE)],@args); my @leaves; if ((! defined $leavesR) && (defined $numleaves)) { @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } if (! defined $leavesR) { $self->throw("No leaves set neither numleaves given"); } @leaves=@$leavesR; $self->{leaves}=$leavesR; $numleaves=@leaves; $self->{numleaves}=$numleaves; $recurse ||= 0; if (! defined $numhybrids) { $numhybrids=$numleaves-1; $recurse=1; } $self->{recurse}=$recurse; $self->{numhybrids}=$numhybrids; if ($numhybrids ==0) { return Bio::PhyloNetwork::TreeFactory->new(-leaves=>\@leaves); } my $parent; if ($numhybrids > 1) { $parent=new($pkg,'-leaves'=>\@leaves, '-numhybrids'=>($numhybrids-1), '-recurse'=>($recurse)); } else { $parent=Bio::PhyloNetwork::TreeFactory->new(-leaves=>\@leaves); } $self->{parent}=$parent; my $oldnet=$parent->next_network(); $self->{oldnet}=$oldnet; $self->update(); $self->{found}=[]; bless($self,$pkg); } sub update { my ($self)=@_; my @candidates=$self->{oldnet}->edges(); $self->{candidates}=\@candidates; $self->{numcandidates}=(scalar @candidates); $self->{index1}=-$self->{recurse}; $self->{index2}=0; } =head2 next_network Title : next_network Usage : my $net=$factory->next_network() Function: returns a network Returns : Bio::PhyloNetwork Args : none =cut sub next_network { my ($self)=@_; my $numleaves=$self->{numleaves}; my $numhybrids=$self->{numhybrids}; START: if ($self->{index1}==-1) { $self->{index1}++; return $self->{oldnet}; } if ($self->{index1} >= $self->{numcandidates}) { $self->{index2}++; $self->{index1}=0; } if ($self->{index2} >= $self->{numcandidates}) { my $oldnet=$self->{parent}->next_network(); if (! $oldnet) { return 0; } $self->{oldnet}=$oldnet; $self->update(); goto START; } if ((scalar $self->{oldnet}->hybrid_nodes())< $self->{numhybrids}-1) { $self->{candidates}=[]; $self->{numcandidates}=0; goto START; } my $u1=$self->{candidates}->[$self->{index1}]->[0]; my $v1=$self->{candidates}->[$self->{index1}]->[1]; my $u2=$self->{candidates}->[$self->{index2}]->[0]; my $v2=$self->{candidates}->[$self->{index2}]->[1]; my $lbl=$self->{numhybrids}; if ($self->{oldnet}->is_attackable($u1,$v1,$u2,$v2)) { my $net=Bio::PhyloNetwork->new(-graph=>$self->{oldnet}->graph); $net->do_attack($u1,$v1,$u2,$v2,$lbl); $self->{index1}++; my @found=@{$self->{found}}; foreach my $netant (@found) { if ($net->is_mu_isomorphic($netant) ) { goto START; } } push @found,$net; $self->{found}=\@found; return $net; } else { $self->{index1}++; goto START; } } 1; BioPerl-1.6.923/Bio/PhyloNetwork/FactoryX.pm000444000765000024 1432312254227323 20734 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::FactoryX # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::FactoryX - Module to sequentially generate Phylogenetic Networks =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork; use Bio::PhyloNetwork::Factory; # Will generate sequentially all the 4059 binary tree-child phylogenetic # networks with 4 leaves my $factory=Bio::PhyloNetwork::Factory->new(-numleaves=>4); my @nets; while (my $net=$factory->next_network()) { push @nets,$net; print "".(scalar @nets).": ".$net->eNewick()."\n"; } =head1 DESCRIPTION Sequentially builds a (binary tree-child) phylogenetic network each time next_network is called. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::FactoryX; use strict; use warnings; use Data::Dumper; use base qw(Bio::Root::Root); use Bio::PhyloNetwork; use Bio::PhyloNetwork::TreeFactoryX; =head2 new Title : new Usage : my $factory = new Bio::PhyloNetwork::Factory(); Function: Creates a new Bio::PhyloNetwork::Factory Returns : Bio::PhyloNetwork::RandomFactory Args : -numleaves => integer OR -leaves => reference to an array (of leaves names) -numhybrids => integer [default = numleaves -1] -recurse => boolean [optional] Returns a Bio::PhyloNetwork::Factory object. Such an object will sequentially create binary tree-child phylogenetic networks each time next_network is called. If the parameter -leaves=E\@leaves is given, then the set of leaves of these networks will be @leaves. If it is given the parameter -numleaves=E$numleaves, then the set of leaves will be "l1"..."l$numleaves". If the parameter -numhybrids=E$numhybrids is given, then the generated networks will have at most $numhybrids hybrid nodes. Note that, necessarily, $numhybrids E $numleaves. If the parameter -recurse=E1 is given, then all networks with number of hybrid nodes less or equal to $numhybrids will be given; otherwise only those with exactly $numhybrids hybrid nodes. =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($leavesR,$numleaves,$numhybrids)= $self->_rearrange([qw(LEAVES NUMLEAVES NUMHYBRIDS)],@args); my @leaves; if ((! defined $leavesR) && (defined $numleaves)) { @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } if (! defined $leavesR) { $self->throw("No leaves set neither numleaves given"); } @leaves=@$leavesR; $self->{leaves}=$leavesR; $numleaves=@leaves; $self->{numleaves}=$numleaves; if (! defined $numhybrids) { $numhybrids=$numleaves-1; } $self->{numhybrids}=$numhybrids; if ($numhybrids ==0) { return Bio::PhyloNetwork::TreeFactoryX->new(-leaves=>\@leaves); } my $parent; if ($numhybrids > 1) { $parent=new($pkg,'-leaves'=>\@leaves, '-numhybrids'=>($numhybrids-1) ); my @subfactories=@{$parent->{subfactories}}; push @subfactories,$parent; # print "$numhybrids : ".(scalar @subfactories); # print "\n"; $self->{subfactories}=\@subfactories; # print "$numhybrids: ".(scalar @subfactories)."\n"; } else { $parent=Bio::PhyloNetwork::TreeFactoryX->new(-leaves=>\@leaves); $self->{subfactories}=[$parent]; } $self->{parent}=$parent; $self->update(); $self->{found}=[]; $self->{thrown}=0; $self->{hybnow}=0; bless($self,$pkg); } sub update { my ($self)=@_; if (defined $self->{oldnet}) { my @candidates=$self->{oldnet}->edges(); $self->{candidates}=\@candidates; $self->{numcandidates}=(scalar @candidates); $self->{index1}=0; $self->{index2}=0; } else { $self->{candidates}=[]; $self->{numcandidates}=0; $self->{index1}=0; $self->{index2}=0; } } sub next_network_repeated { my ($self)=@_; return 0 if ($self->{thrown} >= (scalar @{$self->{found}})); $self->{thrown}=$self->{thrown}+1; return $self->{found}->[$self->{thrown}-1]; } sub next_network_new { my ($self)=@_; START: # print $self->{index1}.",".$self->{index2}.":".$self->{numcandidates}."\n"; if ($self->{index1} >= $self->{numcandidates}) { $self->{index2}++; $self->{index1}=0; } # print $self->{index1}.",".$self->{index2}.":".$self->{numcandidates}."\n"; if ($self->{index2} >= $self->{numcandidates}) { my $oldnet=$self->{parent}->next_network_repeated(); if (! $oldnet) { # print "notoldnet\n"; return 0; } $self->{oldnet}=$oldnet; $self->update(); } my $u1=$self->{candidates}->[$self->{index1}]->[0]; my $v1=$self->{candidates}->[$self->{index1}]->[1]; my $u2=$self->{candidates}->[$self->{index2}]->[0]; my $v2=$self->{candidates}->[$self->{index2}]->[1]; my $lbl=$self->{numhybrids}; if ($self->{oldnet}->is_attackable($u1,$v1,$u2,$v2)) { my $net=Bio::PhyloNetwork->new(-graph=>$self->{oldnet}->graph); $net->do_attack($u1,$v1,$u2,$v2,$lbl); $self->{index1}++; my @found=@{$self->{found}}; foreach my $netant (@found) { if ($net->is_mu_isomorphic($netant) ) { goto START; } } push @found,$net; $self->{found}=\@found; return $net; } else { $self->{index1}++; goto START; } } =head2 next_network Title : next_network Usage : my $net=$factory->next_network() Function: returns a network Returns : Bio::PhyloNetwork Args : none =cut sub next_network { my ($self)=@_; my $hybnow; WTF: $hybnow=$self->{hybnow}; # print $hybnow; # print Dumper($self->{subfactories}->[$hybnow]); # print "$hybnow\n"; # print (scalar @{$self->{subfactories}}); # print "\n"; my $net; if ($hybnow < $self->{numhybrids}) { $net=$self->{subfactories}->[$hybnow]->next_network_new(); } else { $net=$self->next_network_new(); } if (! $net) { if ($hybnow < $self->{numhybrids}) { $self->{hybnow}=$self->{hybnow}+1; goto WTF; } return 0; } return $net; } 1; BioPerl-1.6.923/Bio/PhyloNetwork/GraphViz.pm000444000765000024 741312254227322 20710 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::GraphViz # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::GraphViz - Interface between PhyloNetwork and GraphViz =head1 SYNOPSIS use Bio::PhyloNetwork; use Bio::PhyloNetwork::GraphViz; my $net=Bio::PhyloNetwork->new( -eNewick=>'((H1,(H1,(H2,l))),H2)t0; (some long label)H1; ("quoted label")H2;' ); my $gv=Bio::PhyloNetwork::GraphViz->new(-net=>$net,-short_labels=>1); foreach my $u ($net->nodes()) { print "$u:".$gv->nodePN_to_nodeGV->{$u}."\n"; } print $gv->as_text; open PS, "> net.ps"; print PS $gv->as_ps; close PS; =head1 DESCRIPTION This is a module to create GraphViz objects representing phylogenetic networks. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L, L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::GraphViz; use strict; use warnings; use base qw(Bio::Root::Root GraphViz); use Bio::PhyloNetwork; =head2 new Title : new Usage : my $graphv = new Bio::PhyloNetwork::GraphViz(); Function: Creates a new Bio::PhyloNetwork::GraphViz object Returns : Bio::PhyloNetwork::GraphViz Args : -net => Bio::PhyloNetwork object -short_labels => boolean (optional) Returns a Bio::PhyloNetwork::GraphViz object, which is an extension of a GraphViz object. The GraphViz object is a representation of the phylogenetic network given. The extra information the created object holds is a hash table with keys the nodes of the PhyloNetwork object and values the nodes of the GraphViz object. If the optional argument -short_labels=E1 is given, the labels of the nodes in GraphViz are shortened to a maximum of 3 letters. =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($net,$short_labels)= $self->_rearrange([qw(NET SHORT_LABELS)],@args); if (! defined $short_labels) { $short_labels=0; } my $gv=GraphViz->new(); my $nodePN_to_nodeGV={}; my @nodes=$net->nodes(); foreach my $node (@nodes) { # my $namenode=generate_name($node); # $names->{$node}=$namenode; ### my $labelnodeint=$net->{labels}->{$node}; ### my $labelnode=($short_labels ? find_short_label($labelnodeint) : find_label($labelnodeint)); my $nodeGV= $gv->add_node(#$namenode, label=>$labelnode, shape=>($net->is_tree_node($node) ? 'circle' : 'box')); $nodePN_to_nodeGV->{$node}=$nodeGV; } my @edges=$net->edges(); foreach my $edge (@edges) { my $node1=$edge->[0]; # my $namenode1=generate_name($node1); my $node2=$edge->[1]; # my $namenode2=generate_name($node2); $gv->add_edge($nodePN_to_nodeGV->{$node1},$nodePN_to_nodeGV->{$node2}); } $self=$gv; $self->{nodePN_to_nodeGV}=$nodePN_to_nodeGV; bless($self,$pkg); } #sub generate_name { # my ($var)=@_; # if ($var =~ /\D/) { # print "$var contains a number.\b"; # return $var; # } # return "N$var"; #} sub find_short_label { my ($str)=@_; return substr(find_label($str),0,3); } sub find_label { my ($str)=@_; $str =~ tr/A-Za-z0-9//cd; return $str; } =head2 nodePN_to_nodeGV Title : nodePN_to_nodeGV Usage : my $hashR=$graphv->nodePN_to_nodeGV() Function: returns (a reference to) a hash holding the translation between nodes of the Bio::PhyloNetwork object and nodes of the GraphViz object Returns : reference to hash Args : none =cut sub nodePN_to_nodeGV { my ($self)=@_; return $self->{nodePN_to_nodeGV}; } 1; BioPerl-1.6.923/Bio/PhyloNetwork/muVector.pm000444000765000024 1516412254227322 21004 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::muVector # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::muVector - Module to compute with vectors of arbitrary dimension =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork::muVector; my $vec1=Bio::PhyloNetwork::muVector->new(4); my $vec2=Bio::PhyloNetwork::muVector->new([1,2,3,4]); my $vec3=Bio::PhyloNetwork::muVector->new([10,20,30,40]); my $vec4=$vec3-10*$vec2; if (($vec4 cmp $vec1) == 0) { print "$vec4 is zero\n"; } my $vec5=Bio::PhyloNetwork::muVector->new([8,2,2,4]); my $vec6=Bio::PhyloNetwork::muVector->new([1,2,3,4]); print "Test poset $vec5 > $vec6: ".$vec5->geq_poset($vec6)."\n"; print "Test lex $vec5 > $vec6: ".($vec5 cmp $vec6)."\n"; =head1 DESCRIPTION This is a module to work with vectors. It creates vectors of arbitrary length, defines its basic arithmetic operations, its lexicographic ordering and the natural structure of poset. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::muVector; use strict; use warnings; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $mu = new Bio::PhyloNetwork::muVector(); Function: Creates a new Bio::PhyloNetwork::muVector object Returns : Bio::PhyloNetwork::muVector Args : integer or (reference to) an array If given an integer as argument, returns a Bio::PhyloNetwork::muVector object with dimension the integer given and initialized to zero. If it is an anonimous array, then the vector is initialized with the values in the array and with the corresponding dimension. =cut sub new { my ($pkg,$cont)=@_; my $self=$pkg->SUPER::new(); my @arr=(); if (!ref($cont)) { #$cont is a number; initialize to a zero-vector for (my $i=0; $i < $cont; $i++) { $arr[$i]=0; } $self->{arr}=\@arr; } else { #$cont points to an array @arr=@{$cont}; } $self->{dim}=scalar @arr; $self->{arr}=\@arr; bless($self,$pkg); return $self; } sub dim { return shift->{dim} } use overload "+" => \&add, "-" => \&substract, "*" => \&scalarproduct, "<=>" => \&comparelex, "cmp" => \&comparelex, '""' => \&display, '@{}' => \&as_array; sub as_array { return shift->{arr}; } =head2 display Title : display Usage : my $str=$mu->display() Function: returns an string displaying its contents Returns : string Args : none This function is also overloaded to the "" operator. =cut sub display { my ($self)=@_; my @arr=@{$self->{arr}}; return "(@arr)"; } =head2 add Title : add Usage : $mu->add($mu2) Function: returns the sum of $mu and $mu2 Returns : Bio::PhyloNetwork::muVector Args : Bio::PhyloNetwork::muVector This function is also overloaded to the + operator. =cut sub add { my ($v1,$v2)=@_; $v1->throw("Vectors not the same size") unless ($v1->{dim} == $v2->{dim}); my $dim=$v1->{dim}; my @sum=(); for (my $i=0; $i<$dim; $i++) { $sum[$i]=$v1->[$i]+$v2->[$i]; } my $result=Bio::PhyloNetwork::muVector->new(\@sum); return $result; } =head2 substract Title : substract Usage : $mu->substract($mu2) Function: returns the difference of $mu and $mu2 Returns : Bio::PhyloNetwork::muVector Args : Bio::PhyloNetwork::muVector This function is also overloaded to the - operator. =cut sub substract { my ($v1,$v2)=@_; $v1->throw("Vectors not the same size") unless ($v1->{dim} == $v2->{dim}); my $dim=$v1->{dim}; my @sum=(); for (my $i=0; $i<$dim; $i++) { $sum[$i]=$v1->{arr}->[$i]-$v2->{arr}->[$i]; } my $result=Bio::PhyloNetwork::muVector->new(\@sum); return $result; } =head2 scalarproduct Title : scalarproduct Usage : $mu->scalarproduct($ct) Function: returns the scalar product of $ct and $mu Returns : Bio::PhyloNetwork::muVector Args : scalar This function is also overloaded to the * operator. =cut sub scalarproduct { my ($v1,$num,$swapped)=@_; my $dim=$v1->{dim}; my @sum=(); for (my $i=0; $i<$dim; $i++) { $sum[$i]=$num*$v1->{arr}->[$i]; } my $result=Bio::PhyloNetwork::muVector->new(\@sum); return $result; return $result; } =head2 comparelex Title : comparelex Usage : $mu1->comparelex($mu2) Function: compares $mu and $mu2 w.r.t. the lexicographic ordering Returns : scalar (-1 if $mu1<$mu2, 0 if $mu1=$mu2, 1 if $mu1>$mu2) Args : Bio::PhyloNetwork::muVector This function is also overloaded to the E=E and cmp operator. =cut sub comparelex { my ($v1,$v2)=@_; $v1->throw("Vectors not the same size") unless ($v1->{dim} == $v2->{dim}); my $dim=$v1->{dim}; for (my $i=0; $i<$dim; $i++) { return -1 if $v1->{arr}->[$i] < $v2->{arr}->[$i]; return 1 if $v1->{arr}->[$i] > $v2->{arr}->[$i]; } return 0; } =head2 geq_poset Title : geq_poset Usage : $mu1->geq_poset($mu2) Function: compares $mu and $mu2 w.r.t. the natural partial ordering Returns : boolean (1 if $mu >= $mu2, 0 otherwise) Args : Bio::PhyloNetwork::muVector =cut sub geq_poset { my ($v1,$v2)=@_; $v1->throw("Vectors not the same size") unless ($v1->{dim} == $v2->{dim}); my $dim=$v1->{dim}; for (my $i=0; $i<$dim; $i++) { return 0 unless $v1->[$i] >= $v2->[$i]; } return 1; } =head2 is_positive Title : is_positive Usage : $mu->is_positive() Function: tests if all components of $mu are positive (or zero) Returns : boolean Args : none =cut sub is_positive { my ($v1)=@_; my $dim=$v1->{dim}; for (my $i=0; $i<$dim; $i++) { return 0 unless $v1->[$i] >= 0; } return 1; } =head2 hamming Title : hamming Usage : $mu1->hamming($mu2) Function: returns the Hamming distance between $mu1 and $mu2 Returns : scalar Args : Bio::PhyloNetwork::muVector =cut sub hamming { my ($v1,$v2)=@_; $v1->throw("Vectors not the same size") unless ($v1->{dim} == $v2->{dim}); my $dim=$v1->{dim}; my $w=0; for (my $i=0; $i<$dim; $i++) { $w++ unless $v1->[$i] == $v2->[$i]; } return $w; } =head2 manhattan Title : manhattan Usage : $mu1->manhattan($mu2) Function: returns the Manhattan distance between $mu1 and $mu2 Returns : scalar Args : Bio::PhyloNetwork::muVector =cut sub manhattan { my ($v1,$v2)=@_; $v1->throw("Vectors not the same size") unless ($v1->{dim} == $v2->{dim}); my $dim=$v1->{dim}; my $w=0; for (my $i=0; $i<$dim; $i++) { $w+= abs($v1->[$i] - $v2->[$i]); } return $w; } 1; BioPerl-1.6.923/Bio/PhyloNetwork/RandomFactory.pm000444000765000024 1047012254227321 21742 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::RandomFactory # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::RandomFactory - Module to generate random Phylogenetic Networks =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork; use Bio::PhyloNetwork::RandomFactory; # Will generate at random all the 66 binary tree-child phylogenetic # networks with 3 leaves my $factory=Bio::PhyloNetwork::RandomFactory->new(-numleaves=>3,-norepeat=>1); my @nets; for (my $i=0; $i<66; $i++) { my $net=$factory->next_network(); push @nets,$net; print "".(scalar @nets).": ".$net->eNewick()."\n"; } =head1 DESCRIPTION Builds a random (binary tree-child) phylogenetic network each time next_network is called. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::RandomFactory; use strict; use warnings; use base qw(Bio::Root::Root); use Bio::PhyloNetwork; use Bio::Tree::RandomFactory; =head2 new Title : new Usage : my $factory = new Bio::PhyloNetwork::RandomFactory(); Function: Creates a new Bio::PhyloNetwork::RandomFactory Returns : Bio::PhyloNetwork::RandomFactory Args : -numleaves => integer OR -leaves => reference to an array (of leaves names) -numhybrids => integer [optional] -norepeat => boolean [optional] Returns a Bio::PhyloNetwork::RandomFactory object. Such an object will create random binary tree-child phylogenetic networks each time next_network is called. If the parameter -leaves=E\@leaves is given, then the set of leaves of these networks will be @leaves. If it is given the parameter -numleaves=E$numleaves, then the set of leaves will be "l1"..."l$numleaves". If the parameter -numhybrids=E$numhybrids is given, then the generated networks will have exactly $numhybrids hybrid nodes. Note that, necessarily, $numhybrids E $numleaves. Otherwise, the number of hybrid nodes will be chosen at random for each call of next_network. If the parameter -norepeat=E1 is given, then successive calls of next_network will give non-isomorphic networks. =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($leavesR,$numleaves,$numhybrids,$norepeat)= $self->_rearrange([qw(LEAVES NUMLEAVES NUMHYBRIDS NOREPEAT)],@args); my @leaves; if ((! defined $leavesR) && (defined $numleaves)) { @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } if (! defined $leavesR) { $self->throw("No leaves set neither numleaves given"); } $norepeat ||= 0; $self->{leaves}=\@leaves; $self->{numleaves}=$numleaves; $self->{numhybrids}=$numhybrids if defined $numhybrids; $self->{norepeat}=$norepeat; $self->{found}=[]; $self->{tree_factory}=Bio::Tree::RandomFactory->new(-taxa => \@leaves); bless($self,$pkg); } =head2 next_network Title : next_network Usage : my $net=$factory->next_network() Function: returns a random network Returns : Bio::PhyloNetwork Args : none =cut sub next_network { my ($self)=@_; my $numleaves=$self->{numleaves}; my @found=@{$self->{found}}; my $numhybrids; START: if (! defined $self->{numhybrids}) { $numhybrids=int(rand($numleaves)); } else { $numhybrids=$self->{numhybrids}; } my $tf=$self->{tree_factory}; my $tree=$tf->next_tree; my $net=Bio::PhyloNetwork->new(-tree=>$tree); for (my $i=1; $i<=$numhybrids; $i++) { $net=random_attack($net,$i); } if ($self->{norepeat}) { foreach my $ant (@found) { goto START if $net->is_mu_isomorphic($ant); } push @found,$net; $self->{found}=\@found; } return $net; } sub random_attack { my ($net,$lbl)=@_; my $graph=$net->{graph}; my ($u1,$v1,$u2,$v2); do { my $e1=$graph->random_edge; my $e2=$graph->random_edge; $u1=$e1->[0]; $v1=$e1->[1]; $u2=$e2->[0]; $v2=$e2->[1]; } while (! $net->is_attackable($u1,$v1,$u2,$v2,$lbl)); $net->do_attack($u1,$v1,$u2,$v2,$lbl); return $net; } 1; BioPerl-1.6.923/Bio/PhyloNetwork/TreeFactory.pm000444000765000024 776112254227322 21413 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::TreeFactory # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::TreeFactory - Module to sequentially generate Phylogenetic Trees =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork; use Bio::PhyloNetwork::TreeFactory; # Will generate sequentially all the 15 binary phylogetic # trees with 4 leaves my $factory=Bio::PhyloNetwork::TreeFactory->new(-numleaves=>4); my @nets; while (my $net=$factory->next_network()) { push @nets,$net; print "".(scalar @nets).": ".$net->eNewick()."\n"; } =head1 DESCRIPTION Sequentially builds a (binary) phylogenetic tree each time next_network is called. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::TreeFactory; use strict; use warnings; use base qw(Bio::Root::Root); use Bio::PhyloNetwork; =head2 new Title : new Usage : my $factory = new Bio::PhyloNetwork::TreeFactory(); Function: Creates a new Bio::PhyloNetwork::TreeFactory Returns : Bio::PhyloNetwork::RandomFactory Args : -numleaves => integer OR -leaves => reference to an array (of leaves names) Returns a Bio::PhyloNetwork::TreeFactory object. Such an object will sequentially create binary phylogenetic trees each time next_network is called. If the parameter -leaves=E\@leaves is given, then the set of leaves of these networks will be @leaves. If it is given the parameter -numleaves=E$numleaves, then the set of leaves will be "l1"..."l$numleaves". =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($leavesR,$numleaves,$numhybrids)= $self->_rearrange([qw(LEAVES NUMLEAVES NUMHYBRIDS)],@args); my @leaves; if ((! defined $leavesR) && (defined $numleaves)) { @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } if (! defined $leavesR) { $self->throw("No leaves set neither numleaves given"); } @leaves=@$leavesR; $self->{leaves}=$leavesR; $numleaves=@leaves; $self->{numleaves}=$numleaves; if ($numleaves > 2) { my @leavesparent=@leaves; my $newleaf=pop @leavesparent; $self->{newleaf}=$newleaf; $self->{parent}= new($pkg,-leaves=>\@leavesparent); my $oldnet=$self->{parent}->next_network(); $self->{oldnet}=$oldnet; my @candidates=$oldnet->nodes(); $self->{candidates}=\@candidates; } $self->{index}=0; bless($self,$pkg); } =head2 next_network Title : next_network Usage : my $net=$factory->next_network() Function: returns a tree Returns : Bio::PhyloNetwork Args : none =cut sub next_network { my ($self)=@_; my $n=$self->{numleaves}; if ($self->{numleaves} == 2) { if ($self->{index} == 0) { my $graph=Graph::Directed->new(); $graph->add_edges("t0",$self->{leaves}->[0],"t0",$self->{leaves}->[1]); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; return $net; } else { return 0; } } else { if ($self->{index} == (scalar @{$self->{candidates}})) { my $oldnet=$self->{parent}->next_network(); if (! $oldnet) { return 0; } $self->{oldnet}=$oldnet; my @candidates=$oldnet->nodes(); $self->{candidates}=\@candidates; $self->{index}=0; } my $graph=$self->{oldnet}->{graph}->copy(); my $u=$self->{candidates}->[$self->{index}]; foreach my $w ($graph->predecessors($u)) { $graph->delete_edge($w,$u); $graph->add_edge($w,"t$n"); } $graph->add_edge("t$n",$u); $graph->add_edge("t$n",$self->{newleaf}); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; return $net; } } 1; BioPerl-1.6.923/Bio/PhyloNetwork/TreeFactoryMulti.pm000444000765000024 1163312254227326 22443 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::TreeFactoryMulti # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::TreeFactoryMulti - Module to sequentially generate Phylogenetic Trees =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork; use Bio::PhyloNetwork::TreeFactory; # Will generate sequentially all the 15 binary phylogetic # trees with 4 leaves my $factory=Bio::PhyloNetwork::TreeFactory->new(-numleaves=>4); my @nets; while (my $net=$factory->next_network()) { push @nets,$net; print "".(scalar @nets).": ".$net->eNewick()."\n"; } =head1 DESCRIPTION Sequentially builds a (binary) phylogenetic tree each time next_network is called. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::TreeFactoryMulti; use strict; use warnings; use base qw(Bio::Root::Root); use Bio::PhyloNetwork; =head2 new Title : new Usage : my $factory = new Bio::PhyloNetwork::TreeFactory(); Function: Creates a new Bio::PhyloNetwork::TreeFactory Returns : Bio::PhyloNetwork::RandomFactory Args : -numleaves => integer OR -leaves => reference to an array (of leaves names) Returns a Bio::PhyloNetwork::TreeFactory object. Such an object will sequentially create binary phylogenetic trees each time next_network is called. If the parameter -leaves=E\@leaves is given, then the set of leaves of these networks will be @leaves. If it is given the parameter -numleaves=E$numleaves, then the set of leaves will be "l1"..."l$numleaves". =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($leavesR,$numleaves,$numhybrids)= $self->_rearrange([qw(LEAVES NUMLEAVES NUMHYBRIDS)],@args); my @leaves; if ((! defined $leavesR) && (defined $numleaves)) { @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } if (! defined $leavesR) { $self->throw("No leaves set neither numleaves given"); } @leaves=@$leavesR; $self->{leaves}=$leavesR; $numleaves=@leaves; $self->{numleaves}=$numleaves; if ($numleaves > 2) { my @leavesparent=@leaves; my $newleaf=pop @leavesparent; $self->{newleaf}=$newleaf; $self->{parent}= new($pkg,-leaves=>\@leavesparent); my $oldnet=$self->{parent}->next_network(); $self->{oldnet}=$oldnet; my @candidates=$oldnet->nodes(); $self->{candidates}=\@candidates; my @candidatesbis=$oldnet->internal_nodes(); $self->{candidatesbis}=\@candidatesbis; $self->{processbis}=0; } $self->{index}=0; bless($self,$pkg); } =head2 next_network Title : next_network Usage : my $net=$factory->next_network() Function: returns a tree Returns : Bio::PhyloNetwork Args : none =cut sub next_network { my ($self)=@_; my $n=$self->{numleaves}; if ($self->{numleaves} == 2) { if ($self->{index} == 0) { my $graph=Graph::Directed->new(); $graph->add_edges("t0",$self->{leaves}->[0],"t0",$self->{leaves}->[1]); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; return $net; } else { return 0; } } else { if (($self->{index} == (scalar @{$self->{candidatesbis}})) && $self->{processbis} ) { my $oldnet=$self->{parent}->next_network(); if (! $oldnet) { return 0; } $self->{oldnet}=$oldnet; my @candidates=$oldnet->nodes(); $self->{candidates}=\@candidates; my @candidatesbis=$oldnet->internal_nodes(); $self->{candidatesbis}=\@candidatesbis; $self->{processbis}=0; $self->{index}=0; my $n1=scalar @candidates; my $n2=scalar @candidatesbis; print $oldnet->eNewick()."(".$self->{numleaves}.")($n1,$n2):\n"; } if (($self->{index} == (scalar @{$self->{candidates}})) && $self->{processbis}==0 ) { $self->{processbis}=1; $self->{index}=0; print "--\n"; } if ($self->{processbis}==0) { my $graph=$self->{oldnet}->{graph}->copy(); my $u=$self->{candidates}->[$self->{index}]; foreach my $w ($graph->predecessors($u)) { $graph->delete_edge($w,$u); $graph->add_edge($w,"t$n"); } $graph->add_edge("t$n",$u); $graph->add_edge("t$n",$self->{newleaf}); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; return $net; } else { my $graph=$self->{oldnet}->{graph}->copy(); my $u=$self->{candidatesbis}->[$self->{index}]; # print "<<$u\n"; $graph->add_edge($u,$self->{newleaf}); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; return $net; } } } 1; BioPerl-1.6.923/Bio/PhyloNetwork/TreeFactoryX.pm000444000765000024 1064712254227313 21560 0ustar00cjfieldsstaff000000000000# # Module for Bio::PhyloNetwork::TreeFactoryX # # Please direct questions and support issues to # # Cared for by Gabriel Cardona # # Copyright Gabriel Cardona # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PhyloNetwork::TreeFactoryX - Module to sequentially generate Phylogenetic Trees =head1 SYNOPSIS use strict; use warnings; use Bio::PhyloNetwork; use Bio::PhyloNetwork::TreeFactory; # Will generate sequentially all the 15 binary phylogetic # trees with 4 leaves my $factory=Bio::PhyloNetwork::TreeFactory->new(-numleaves=>4); my @nets; while (my $net=$factory->next_network()) { push @nets,$net; print "".(scalar @nets).": ".$net->eNewick()."\n"; } =head1 DESCRIPTION Sequentially builds a (binary) phylogenetic tree each time next_network is called. =head1 AUTHOR Gabriel Cardona, gabriel(dot)cardona(at)uib(dot)es =head1 SEE ALSO L =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::PhyloNetwork::TreeFactoryX; use strict; use warnings; use base qw(Bio::Root::Root); use Bio::PhyloNetwork; =head2 new Title : new Usage : my $factory = new Bio::PhyloNetwork::TreeFactory(); Function: Creates a new Bio::PhyloNetwork::TreeFactory Returns : Bio::PhyloNetwork::RandomFactory Args : -numleaves => integer OR -leaves => reference to an array (of leaves names) Returns a Bio::PhyloNetwork::TreeFactory object. Such an object will sequentially create binary phylogenetic trees each time next_network is called. If the parameter -leaves=E\@leaves is given, then the set of leaves of these networks will be @leaves. If it is given the parameter -numleaves=E$numleaves, then the set of leaves will be "l1"..."l$numleaves". =cut sub new { my ($pkg,@args)=@_; my $self=$pkg->SUPER::new(@args); my ($leavesR,$numleaves,$numhybrids)= $self->_rearrange([qw(LEAVES NUMLEAVES NUMHYBRIDS)],@args); my @leaves; if ((! defined $leavesR) && (defined $numleaves)) { @leaves=map {"l$_"} (1..$numleaves); $leavesR=\@leaves; } if (! defined $leavesR) { $self->throw("No leaves set neither numleaves given"); } @leaves=@$leavesR; $self->{leaves}=$leavesR; $numleaves=@leaves; $self->{numleaves}=$numleaves; if ($numleaves > 2) { my @leavesparent=@leaves; my $newleaf=pop @leavesparent; $self->{newleaf}=$newleaf; $self->{parent}= new($pkg,-leaves=>\@leavesparent); my $oldnet=$self->{parent}->next_network_new(); $self->{oldnet}=$oldnet; my @candidates=$oldnet->nodes(); $self->{candidates}=\@candidates; } $self->{index}=0; $self->{found}=[]; $self->{thrown}=0; bless($self,$pkg); } =head2 next_network Title : next_network Usage : my $net=$factory->next_network() Function: returns a tree Returns : Bio::PhyloNetwork Args : none =cut sub next_network_new { my ($self)=@_; my $n=$self->{numleaves}; if ($self->{numleaves} == 2) { if ($self->{index} == 0) { my $graph=Graph::Directed->new(); $graph->add_edges("t0",$self->{leaves}->[0],"t0",$self->{leaves}->[1]); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; $self->{found}=[$net]; return $net; } else { return 0; } } else { if ($self->{index} == (scalar @{$self->{candidates}})) { my $oldnet=$self->{parent}->next_network_new(); if (! $oldnet) { return 0; } $self->{oldnet}=$oldnet; my @candidates=$oldnet->nodes(); $self->{candidates}=\@candidates; $self->{index}=0; } my $graph=$self->{oldnet}->{graph}->copy(); my $u=$self->{candidates}->[$self->{index}]; foreach my $w ($graph->predecessors($u)) { $graph->delete_edge($w,$u); $graph->add_edge($w,"t$n"); } $graph->add_edge("t$n",$u); $graph->add_edge("t$n",$self->{newleaf}); my $net=Bio::PhyloNetwork->new(-graph=>$graph); $self->{index}++; my @found=@{$self->{found}}; push @found,$net; $self->{found}=\@found; return $net; } } sub next_network_repeated { my ($self)=@_; return 0 if ($self->{thrown} >= (scalar @{$self->{found}})); $self->{thrown}=$self->{thrown}+1; return $self->{found}->[$self->{thrown}-1]; } sub next_network { my ($self)=@_; return $self->next_network_new(); } 1; BioPerl-1.6.923/Bio/PopGen000755000765000024 012254227336 15206 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/PopGen/Genotype.pm000444000765000024 1520512254227336 17516 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Genotype # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Genotype - An implementation of GenotypeI which is just an allele container =head1 SYNOPSIS use Bio::PopGen::Genotype; my $genotype = Bio::PopGen::Genotype->new(-marker_name => $name, -individual_id => $indid, -alleles => \@alleles); =head1 DESCRIPTION This object will contain alleles for a given marker for a given individual. The class variable BlankAlleles (accessible through $Bio::PopGen::Genotype::BlankAlleles = 'somepattern') can be set to a regexp pattern for identifying blank alleles which should no be counted (they are effectively missing data). By default it set to match white space, '-', 'N' or 'n', and '?' as blank alleles which are skipped. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Genotype; use vars qw($BlankAlleles); use strict; $BlankAlleles = '[\s\-Nn\?]'; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::PopGen::GenotypeI); =head2 new Title : new Usage : my $obj = Bio::PopGen::Genotype->new(); Function: Builds a new Bio::PopGen::Genotype object Returns : an instance of Bio::PopGen::Genotype Args : -marker_name => string representing name of the marker -individual_id => string representing individual id (optional) -alleles => arrayref with each item in the array being an allele =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($marker_name, $marker_type, $ind_id, $alleles) = $self->_rearrange([qw(MARKER_NAME MARKER_TYPE INDIVIDUAL_ID ALLELES)],@args); defined $marker_name && $self->marker_name($marker_name); defined $marker_type && $self->marker_type($marker_type); defined $ind_id && $self->individual_id($ind_id); if( defined $alleles ) { if( ref($alleles) =~ /array/i ) { $self->add_Allele(@$alleles); } else { $self->warn("Could not initialize with -alleles value, it is not an array ref"); } } return $self; } =head2 marker_name Title : marker_name Usage : my $name = $genotype->marker_name(); Function: Get the marker name for a genotype result Returns : string Args : [optional] marker name value to store =cut sub marker_name{ my ($self) = shift; return $self->{'_marker_name'} = shift if @_; return $self->{'_marker_name'}; } =head2 marker_type Title : marker_type Usage : my $name = $genotype->marker_type(); Function: Get the marker type for a genotype result Returns : M (microsatellite, or other multi-allelic locus) or S (biallelic/SNP locus) Args : [optional] marker type value to store =cut sub marker_type{ my ($self) = shift; return $self->{'_marker_type'} = shift if @_; return $self->{'_marker_type'}; } =head2 individual_id Title : individual_id Usage : my $indid = $genotype->individual_id(); Function: Gets the individual id associated with a genotype This is effectively a back reference since we will typically associate a genotype with an individual with an individual HAS-A genotype relationship. Returns : unique id string for an individual Args : none =cut sub individual_id { my ($self) = shift; return $self->{'_individual_id'} = shift if @_; return $self->{'_individual_id'}; } =head2 get_Alleles Title : get_Alleles Usage : my @alleles = $genotype->get_Alleles(); Function: Get the alleles for a given marker and individual Returns : array of alleles (strings in this implementation) Args : $showblank - boolean flag to indicate return ALL alleles not skipping the coded EMPTY alleles Note : Uses the class variable $BlankAlleles to test if alleles should be skipped or not. =cut sub get_Alleles{ my ($self) = shift; if( @_ && $_[0] ) { return @{$self->{'_alleles'} || []}; } else { if( defined $self->{'_cached_noblank'} ) { return @{$self->{'_cached_noblank'}} } # one liners - woo hoo. $self->{'_cached_noblank'} = [ grep { ! /^\s*$BlankAlleles\s*$/o } @{$self->{'_alleles'} || []}]; return @{$self->{'_cached_noblank'}}; } } =head2 add_Allele Title : add_Allele Usage : $genotype->add_Allele(@alleles); Function: Add alleles to the genotype, at this point there is no verification to insure that haploid individuals only have 1 allele or that diploids only have 2 - we assume that is done by the user creating these objects Returns : count of the number of alleles in genotype Args : Array of alleles to store =cut sub add_Allele { my ($self) = shift; $self->{'_cached_noblank'} = undef; push @{$self->{'_alleles'}}, @_; return scalar @{$self->{'_alleles'}}; } =head2 reset_Alleles Title : reset_Alleles Usage : $genotype->reset_Alleles; Function: Resets the stored alleles so the list is empty Returns : None Args : None =cut sub reset_Alleles{ my ($self,@args) = @_; $self->{'_cached_noblank'} = undef; $self->{'_alleles'} = []; return 0; } 1; BioPerl-1.6.923/Bio/PopGen/GenotypeI.pm000444000765000024 620012254227315 17577 0ustar00cjfieldsstaff000000000000# $Id $ # # BioPerl module for Bio::PopGen::GenotypeI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::GenotypeI - A marker and alleles for a specific individual =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the interface here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::GenotypeI; use strict; use base qw(Bio::Root::RootI); =head2 marker_name Title : marker_name Usage : my $name = $genotype->marker_name(); Function: Get the marker name for a genotype result Returns : string Args : none =cut sub marker_name{ my ($self) = @_; $self->throw_not_implemented(); } =head2 individual_id Title : individual_id Usage : my $indid = $genotype->individual_id(); Function: Gets the individual id associated with a genotype This is effectively a back reference since we will typically associate a genotype with an individual with an individual HAS-A genotype relationship. Returns : unique id string for an individual Args : none =cut sub individual_id{ my ($self) = @_; $self->throw_not_implemented(); } =head2 annotation Title : annotation Usage : my $annotation_collection = $genotype->annotation; Function: Get/set a Bio::AnnotationCollectionI for this genotype Returns : Bio::AnnotationCollectionI object Args : [optional set] Bio::AnnotationCollectionI object =cut sub annotation{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_Alleles Title : get_Alleles Usage : my @alleles = $genotype->get_Alleles(); Function: Get the alleles for a given marker and individual Returns : array of alleles (strings in many implementations) Args : none =cut sub get_Alleles{ my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/PopGen/HtSNP.pm000444000765000024 12506312254227316 16702 0ustar00cjfieldsstaff000000000000# module Bio::PopGen::HtSNP.pm # cared by Pedro M. Gomez-Fabre # # =head1 NAME Bio::PopGen::HtSNP.pm- Select htSNP from a haplotype set =head1 SYNOPSIS use Bio::PopGen::HtSNP; my $obj = Bio::PopGen::HtSNP->new($hap,$snp,$pop); =head1 DESCRIPTION Select the minimal set of SNP that contains the full information about the haplotype without redundancies. Take as input the followin values: =over 4 =item - the haplotype block (array of array). =item - the snp id (array). =item - family information and frequency (array of array). =back The final haplotype is generated in a numerical format and the SNP's sets can be retrieve from the module. B - If you force to include a family with indetermination, the SNP's with indetermination will be removed from the analysis, so consider before to place your data set what do you really want to do. - If two families have the same information (identical haplotype), one of them will be removed and the removed files will be stored classify as removed. - Only are accepted for calculation A, C, G, T and - (as deletion) and their combinations. Any other value as n or ? will be considered as degenerations due to lack of information. =head2 RATIONALE On a haplotype set is expected that some of the SNP and their variations contribute in the same way to the haplotype. Eliminating redundancies will produce a minimal set of SNP's that can be used as input for a taging selection process. On the process SNP's with the same variation are clustered on the same group. The idea is that because the tagging haplotype process is exponential. All redundant information we could eliminate on the tagging process will help to find a quick result. =head2 CONSTRUCTORS my $obj = Bio::PopGen::HtSNP->new (-haplotype_block => \@haplotype_patterns, -snp_ids => \@snp_ids, -pattern_freq => \@pattern_name_and_freq); where $hap, $snp and $pop are in the format: my $hap = [ 'acgt', 'agtc', 'cgtc' ]; # haplotype patterns' id my $snp = [qw/s1 s2 s3 s4/]; # snps' Id's my $pop = [ [qw/ uno 0.20/], [qw/ dos 0.20/], [qw/ tres 0.15/], ]; # haplotype_pattern_id Frequency =head2 OBJECT METHODS See Below for more detailed summaries. =head1 DETAILS =head2 How the process is working with one example Let's begin with one general example of the code. Input haplotype: acgtcca-t cggtagtgc cccccgtgc cgctcgtgc The first thing to to is to B into characters. a c g t c c a - t c g g t a g t g c c c c c c g t g c c g c t c g t g c Now we have to B the haplotype to B. This will produce the same SNP if we have input a or A. A C G T C C A - T C G G T A G T G C C C C C C G T G C C G C T C G T G C The program admit as values any combination of ACTG and - (deletions). The haplotype is B, considering the first variation as zero and the alternate value as 1 (see expanded description below). 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 0 0 1 1 1 1 Once we have the haplotype converted to numbers we have to generate the snp type information for the haplotype. B where: SUM is the sum of the values for the SNP value is the SNP number code (0 [generally for the mayor allele], 1 [for the minor allele]. position is the position on the block. For this example the code is: 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 0 0 1 1 1 1 ------------------------------------------------------------------ 14 10 12 4 2 14 14 14 14 14 = 0*2^0 + 1*2^1 + 1*2^2 + 1*2^3 12 = 0*2^0 + 1*2^1 + 0*2^2 + 1*2^3 .... Once we have the families classify. We will B just the SNP's B. 14 10 12 4 2 This information will be B is you want to tag the htSNP. Whatever it happens to one SNPs of a class will happen to a SNP of the same class. Therefore you don't need to scan redundancies =head2 Working with fuzzy data. This module is designed to work with fuzzy data. As the source of the haplotype is diverse. The program assume that some haplotypes can be generated using different values. If there is any indetermination (? or n) or any other degenerated value or invalid. The program will take away This SNP and will leave that for a further analysis. On a complex situation: a c g t ? c a c t a c g t ? c a - t c g ? t a g ? g c c a c t c g t g c c g c t c g t g c c g g t a g ? g c a c ? t ? c a c t On this haplotype everything is happening. We have a multialelic variance. We have indeterminations. We have deletions and we have even one SNP which is not a real SNP. The buiding process will be the same on this situation. Convert the haplotype to uppercase. A C G T ? C A C T A C G T ? C A - T C G ? T A G ? G C C A C T C G T G C C G C T C G T G C C G G T A G ? G C A C ? T ? C A C T All columns that present indeterminations will be removed from the analysis on this Step. hapotype after remove columns: A C T C C T A C T C - T C G T G G C C A T G G C C G T G G C C G T G G C A C T C C T All changes made on the haplotype matrix, will be also made on the SNP list. snp_id_1 snp_id_2 snp_id_4 snp_id_6 snp_id_8 snp_id_9 now the SNP that is not one SNP will be removed from the analysis. SNP with Id snp_id_4 (the one with all T's). because of the removing. Some of the families will become the same and will be clustered. A posteriori analysis will diference these families. but because of the indetermination can not be distinguish. A C C C T A C C - T C G G G C C A G G C C G G G C C G G G C A C C C T The result of the mergering will go like: A C C C T A C C - T C G G G C C A G G C Once again the changes made on the families and we merge the frequency (I) Before to convert the haplotype into numbers we consider how many variations we have on the set. On this case the variations are 3. The control code will use on this situation base three as mutiplicity 0 0 0 0 0 0 0 0 1 0 1 1 1 2 1 1 2 1 2 1 ----------------------------------- 36 63 36 75 36 And the minimal set for this combination is 0 0 0 0 0 1 1 1 2 1 2 2 B this second example is a remote example an on normal conditions. This conditions makes no sense, but as the haplotypes, can come from many sources we have to be ready for all kind of combinations. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Pedro M. Gomez-Fabre Email pgf18872-at-gsk-dot-com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::HtSNP; use Data::Dumper; use Storable qw(dclone); use vars qw (); use strict; use base qw(Bio::Root::Root); my $USAGE = 'Usage: Bio::PopGen::HtSNP->new(-haplotype_block -ids -pattern_freq) '; =head2 new Title : new Function: constructor of the class. Usage : $obj-> Bio::PopGen::HtSNP->new(-haplotype_block -snp_ids -pattern_freq) Returns : self hash Args : input haplotype (array of array) snp_ids (array) pop_freq (array of array) Status : public =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($haplotype_block, $snp_ids, $pattern_freq ) = $self->_rearrange([qw(HAPLOTYPE_BLOCK SNP_IDS PATTERN_FREQ)],@args); if ($haplotype_block){ $self->haplotype_block($haplotype_block); } else{ $self->throw("Haplotype block has not been defined. \n$USAGE"); } if ($snp_ids){ $self->snp_ids($snp_ids); } else{ $self->throw("Array with ids has not been defined. \n$USAGE"); } if ($pattern_freq){ $self->pattern_freq($pattern_freq); } else{ $self->throw("Array with pattern id and frequency has not been defined. \n$USAGE"); } # if the input values are not well formed complained and exit. _check_input($self); _do_it($self); return $self; } =head2 haplotype_block Title : haplotype_block Usage : my $haplotype_block = $HtSNP->haplotype_block(); Function: Get the haplotype block for a haplotype tagging selection Returns : reference of array Args : reference of array with haplotype pattern =cut sub haplotype_block{ my ($self) =shift; return $self->{'_haplotype_block'} = shift if @_; return $self->{'_haplotype_block'}; } =head2 snp_ids Title : snp_ids Usage : my $snp_ids = $HtSNP->$snp_ids(); Function: Get the ids for a haplotype tagging selection Returns : reference of array Args : reference of array with SNP ids =cut sub snp_ids{ my ($self) =shift; return $self->{'_snp_ids'} = shift if @_; return $self->{'_snp_ids'}; } =head2 pattern_freq Title : pattern_freq Usage : my $pattern_freq = $HtSNP->pattern_freq(); Function: Get the pattern id and frequency for a haplotype tagging selection Returns : reference of array Args : reference of array with SNP ids =cut sub pattern_freq{ my ($self) =shift; return $self->{'_pattern_freq'} = shift if @_; return $self->{'_pattern_freq'}; } =head2 _check_input Title : _check_input Usage : _check_input($self) Function: check for errors on the input Returns : self hash Args : self Status : internal =cut #------------------------ sub _check_input{ #------------------------ my $self = shift; _haplotype_length_error($self); _population_error($self); } =head2 _haplotype_length_error Title : _haplotype_length_error Usage : _haplotype_length_error($self) Function: check if the haplotype length is the same that the one on the SNP id list. If not break and exit Returns : self hash Args : self Status : internal =cut #------------------------ sub _haplotype_length_error{ #------------------------ my $self = shift; my $input_block = $self->haplotype_block(); my $snp_ids = $self->snp_ids(); ############################# # define error list ############################# my $different_haplotype_length = 0; ############################## # get parameters used to find # the errors ############################## my $snp_number = scalar @$snp_ids; my $number_of_families = scalar @$input_block; my $h = 0; # haplotype position ############################ # haplotype length # # if the length differs from the number of ids ############################ for ($h=0; $h<$#$input_block+1 ; $h++){ if (length $input_block->[$h] != $snp_number){ $different_haplotype_length = 1; last; } } # haploytypes does not have the same length if ($different_haplotype_length){ $self->throw("The number of snp ids is $snp_number and ". "the length of the family (". ($h+1) .") [". $input_block->[$h]."] is ". length $input_block->[$h], "\n"); } } =head2 _population_error Title : _population_error Usage : _population_error($self) Function: use input_block and pop_freq test if the number of elements match. If doesn't break and quit. Returns : self hash Args : self Status : internal =cut #------------------------ sub _population_error{ #------------------------ my $self = shift; my $input_block = $self->haplotype_block(); my $pop_freq = $self->pattern_freq(); ############################# # define error list ############################# my $pop_freq_elements_error = 0; # matrix bad formed ############################## # get parameters used to find # the errors ############################## my $number_of_families = scalar @$input_block; my $pf = 0; # number of elements on population frequency my $frequency = 0; # population frequency my $p_f_length = 0; # check if the pop_freq array is well formed and if the number # of elements fit with the number of families ############################# # check population frequency # # - population frequency matrix need to be well formed # - get the frequency # - calculate number of families on pop_freq ############################# for ($pf=0; $pf<$#$pop_freq+1; $pf++){ $frequency += $pop_freq->[$pf]->[1]; if ( scalar @{$pop_freq->[$pf]} !=2){ $p_f_length = scalar @{$pop_freq->[$pf]}; $pop_freq_elements_error = 1; last; } } ########################### ## error processing ########################### # The frequency shouldn't be greater than 1 if ($frequency >1) { $self->warn("The frequency for this set is $frequency (greater than 1)\n"); } # the haplotype matix is not well formed if ($pop_freq_elements_error){ $self->throw("the frequency matrix is not well formed\n". "\nThe number of elements for pattern ".($pf+1)." is ". "$p_f_length\n". "It should be 2 for pattern \"@{$pop_freq->[$pf]}\"\n". "\nFormat should be:\n". "haplotype_id\t frequency\n" ); } # the size does not fit on pop_freq array # with the one in haplotype (input_block) if ($pf != $number_of_families) { $self->throw("The number of patterns on frequency array ($pf)\n". "does not fit with the number of haplotype patterns on \n". "haplotype array ($number_of_families)\n"); } } =head2 _do_it Title : _do_it Usage : _do_it($self) Function: Process the input generating the results. Returns : self hash Args : self Status : internal =cut #------------------------ sub _do_it{ #------------------------ my $self = shift; # first we are goinf to define here all variables we are going to use $self -> {'w_hap'} = []; $self -> {'w_pop_freq'} = dclone ( $self ->pattern_freq() ); $self -> {'deg_pattern'} = {}; $self -> {'snp_type'} = {}; # type of snp on the set. see below $self -> {'alleles_number'} = 0; # number of variations (biallelic,...) $self -> {'snp_type_code'} = []; $self -> {'ht_type'} = []; # store the snp type used on the htSet $self -> {'split_hap'} = []; $self -> {'snp_and_code'} = []; # we classify the SNP under snp_type $self->{snp_type}->{useful_snp} = dclone ( $self ->snp_ids() ); $self->{snp_type}->{deg_snp} = []; # deg snp $self->{snp_type}->{silent_snp} = []; # not a real snp # split the haplotype _split_haplo ($self); # first we convert to upper case the haplotype # to make A the same as a for comparison _to_upper_case( $self -> {w_hap} ); ####################################################### # check if any SNP has indetermination. If any SNP has # indetermination this value will be removed. ####################################################### _remove_deg ( $self ); ####################################################### # depending of the families you use some SNPs can be # silent. This silent SNP's are not used on the # creation of tags and has to be skipped from the # analysis. ####################################################### _rem_silent_snp ( $self ); ####################################################### # for the remaining SNP's we have to check if two # families have the same value. If this is true, the families # will produce the same result and therefore we will not find # any pattern. So, the redundant families need to be take # away from the analysis. But also considered for a further # run. # # When we talk about a normal haplotype blocks this situation # makes no sense but if we remove one of the snp because the # degeneration two families can became the same. # these families may be analised on a second round ####################################################### _find_deg_pattern ( $self ); ################################################################# # if the pattern list length is different to the lenght of the w_hap # we can tell that tow columns have been considered as the same one # and therefore we have to start to remove the values. # remove all columns with degeneration # # For this calculation we don't use the pattern frequency. # All patterns are the same, This selection makes # sense when you have different frequency. # # Note: on this version we don't classify the haplotype by frequency # but if you need to do it. This is the place to do it!!!! # # In reality you don't need to sort the values because you will remove # the values according to their values. # # But as comes from a hash, the order could be different and as a # consequence the code generate on every run of the same set could # differ. That is not important. In fact, does not matter but could # confuse people. ################################################################# my @tmp =sort { $a <=> $b} keys %{$self -> {deg_pattern}}; # just count the families # if the size of the list is different to the size of the degenerated # family. There is degeneration. And the redundancies will be # removed. if($#tmp != $#{$self -> { w_hap } } ){ _keep_these_patterns($self->{w_hap}, \@tmp); _keep_these_patterns($self->{w_pop_freq}, \@tmp); } ################################################################# # the steps made before about removing snp and cluster families # are just needed pre-process the haplotype before. # # Now is when the fun starts. # # # once we have the this minimal matrix, we have to calculate the # max multipliticy for the values. The max number of alleles found # on the set. A normal haplotype is biallelic but we can not # reject multiple variations. ################################################################## _alleles_number ( $self ); ################################################################## # Now we have to convert the haplotype into number # # A C C - T # C A G G C # A C C C T # C G G G C # # one haplotype like this transformed into number produce this result # # 0 0 0 0 0 # 1 1 1 1 1 # 0 0 0 2 0 # 1 2 1 1 1 # ################################################################## _convert_to_numbers( $self ); ################################################################### # The next step is to calculate the type of the SNP. # This process is made based on the position of the SNP, the value # and its multiplicity. ################################################################### _snp_type_code( $self ); ################################################################### # now we have all information we need to calculate the haplotype # tagging SNP htSNP ################################################################### _htSNP( $self ); ################################################################### # patch: # # all SNP have a code. but if the SNP is not used this code must # be zero in case of silent SNP. This looks not to informative # because all the information is already there. But this method # compile the full set. ################################################################### _snp_and_code_summary( $self ); } =head2 input_block Title : input_block Usage : $obj->input_block() Function: returns input block Returns : reference to array of array Args : none Status : public =cut #------------------------ sub input_block{ #------------------------ my $self = shift; return $self -> {input_block}; } =head2 hap_length Title : hap_length Usage : $obj->hap_length() Function: get numbers of SNP on the haplotype Returns : scalar Args : none Status : public =cut #------------------------ sub hap_length{ #------------------------ my $self = shift; return scalar @{$self -> {'_snp_ids'}}; } =head2 pop_freq Title : pop_freq Usage : $obj->pop_freq() Function: returns population frequency Returns : reference to array Args : none Status : public =cut #------------------------ sub pop_freq{ #------------------------ my $self = shift; return $self -> {pop_freq} } =head2 deg_snp Title : deg_snp Usage : $obj->deg_snp() Function: returns snp_removes due to indetermination on their values Returns : reference to array Args : none Status : public =cut #------------------------ sub deg_snp{ #------------------------ my $self = shift; return $self -> {snp_type} ->{deg_snp}; } =head2 snp_type Title : snp_type Usage : $obj->snp_type() Function: returns hash with SNP type Returns : reference to hash Args : none Status : public =cut #------------------------ sub snp_type{ #------------------------ my $self = shift; return $self -> {snp_type}; } =head2 silent_snp Title : silent_snp Usage : $obj->silent_snp() Function: some SNP's are silent (not contibuting to the haplotype) and are not considering for this analysis Returns : reference to a array Args : none Status : public =cut #------------------------ sub silent_snp{ #------------------------ my $self = shift; return $self -> {snp_type} ->{silent_snp}; } =head2 useful_snp Title : useful_snp Usage : $obj->useful_snp() Function: returns list of SNP's that are can be used as htSNP. Some of them can produce the same information. But this is not considered here. Returns : reference to a array Args : none Status : public =cut #------------------------ sub useful_snp{ #------------------------ my $self = shift; return $self -> {snp_type} ->{useful_snp}; } =head2 ht_type Title : ht_type Usage : $obj->ht_type() Function: every useful SNP has a numeric code dependending of its value and position. For a better description see description of the module. Returns : reference to a array Args : none Status : public =cut #------------------------ sub ht_type{ #------------------------ my $self = shift; return $self -> {ht_type}; } =head2 ht_set Title : ht_set Usage : $obj->ht_set() Function: returns the minimal haplotype in numerical format. This haplotype contains the maximal information about the haplotype variations but with no redundancies. It's the minimal set that describes the haplotype. Returns : reference to an array of arrays Args : none Status : public =cut #------------------------ sub ht_set{ #------------------------ my $self = shift; return $self -> {w_hap}; } =head2 snp_type_code Title : snp_type_code Usage : $obj->snp_type_code() Function: returns the numeric code of the SNPs that need to be tagged that correspond to the SNP's considered in ht_set. Returns : reference to an array Args : none Status : public =cut #------------------------ sub snp_type_code{ #------------------------ my $self = shift; return $self -> {snp_type_code}; } =head2 snp_and_code Title : snp_and_code Usage : $obj->snp_and_code() Function: Returns the full list of SNP's and the code associate to them. If the SNP belongs to the group useful_snp it keep this code. If the SNP is silent the code is 0. And if the SNP is degenerated the code is -1. Returns : reference to an array of array Args : none Status : public =cut #------------------------ sub snp_and_code{ #------------------------ my $self = shift; return $self -> {'snp_and_code'}; } =head2 deg_pattern Title : deg_pattern Usage : $obj->deg_pattern() Function: Returns the a list with the degenerated haplotype. Sometimes due to degeneration some haplotypes looks the same and if we don't remove them it won't find any tag. Returns : reference to a hash of array Args : none Status : public =cut #------------------------ sub deg_pattern{ #------------------------ my $self = shift; return $self -> {'deg_pattern'}; } =head2 split_hap Title : split_hap Usage : $obj->split_hap() Function: simple representation of the haplotype base by base Same information that input haplotype but base based. Returns : reference to an array of array Args : none Status : public =cut #------------------------ sub split_hap{ #------------------------ my $self = shift; return $self -> {'split_hap'}; } =head2 _split_haplo Title : _split_haplo Usage : _split_haplo($self) Function: Take a haplotype and split it into bases Returns : self Args : none Status : internal =cut #------------------------ sub _split_haplo { #------------------------ my $self = shift; my $in = $self ->{'_haplotype_block'}; my $out = $self ->{'w_hap'}; # split every haplotype and store the result into $out foreach (@$in){ push @$out, [split (//,$_)]; } $self -> {'split_hap'} = dclone ($out); } # internal method to convert the haplotype to uppercase =head2 _to_upper_case Title : _to_upper_case Usage : _to_upper_case() Function: make SNP or in-dels Upper case Returns : self Args : an AoA ref Status : private =cut #------------------------ sub _to_upper_case { #------------------------ my ($arr) =@_; foreach my $aref (@$arr){ foreach my $value (@{$aref} ){ $value = uc $value; } } } =head2 _remove_deg Title : _remove_deg Usage : _remove_deg() Function: when have a indetermination or strange value this SNP is removed Returns : haplotype family set and degeneration list Args : ref to an AoA and a ref to an array Status : internal =cut #------------------------ sub _remove_deg { #------------------------ my $self = shift; my $hap = $self->{w_hap}; my $snp = $self->{snp_type}->{useful_snp}; my $deg_snp = $self->{snp_type}->{deg_snp}; my $rem = []; # take the position of the array to be removed # first we work on the columns we have void values $rem = _find_indet($hap,$rem); # find degenerated columns if (@$rem){ # remove column on haplotype _remove_col($hap,$rem); # remove list # now remove the values from SNP id _remove_snp_id($snp,$deg_snp,$rem); # remove list } } =head2 _rem_silent_snp Title : _rem_silent_snp Usage : _rem_silent_snp() Function: there is the remote possibilty that one SNP won't be a real SNP on this situation we have to remove this SNP, otherwise the program won't find any tag Returns : nonthing Args : ref to an AoA and a ref to an array Status : internal =cut #------------------------ sub _rem_silent_snp { #------------------------ my $self = shift; my $hap = $self->{w_hap}; my $snp = $self->{snp_type}->{useful_snp}; my $silent_snp = $self->{snp_type}->{silent_snp}; my $rem = []; # store the positions to be removed #find columns with no variation on the SNP, Real snp? $rem = _find_silent_snps($hap); if (@$rem){ # remove column on haplotype _remove_col($hap,$rem); # remove the values from SNP id _remove_snp_id($snp,$silent_snp,$rem); } } =head2 _find_silent_snps Title : _find_silent_snps Usage : Function: list of snps that are not SNPs. All values for that SNPs on the set is the same one. Look stupid but can happend and if this happend you will not find any tag Returns : nothing Args : Status : =cut #------------------------ sub _find_silent_snps{ #------------------------ my ($arr)=@_; my $list =[]; # no snp list; # determine the number of snp by the length of the first row. # we assume that the matrix is squared. my $colsn= @{$arr->[0]}; for (my $i=0;$i<$colsn;$i++){ my $different =0; # check degeneration for my $r (1..$#$arr){ if($arr->[0][$i] ne $arr->[$r][$i]){ $different =1; last; } } if(!$different){ push (@$list, $i); } } return $list; } =head2 _find_indet Title : _find_indet Usage : Function: find column (SNP) with invalid or degenerated values and store this values into the second parameter supplied. Returns : nothing Args : ref to AoA and ref to an array Status : internal =cut #------------------------ sub _find_indet{ #------------------------ my ($arr, $list)=@_; foreach my $i(0..$#$arr){ foreach my $j(0..$#{$arr->[$i]}){ unless ($arr->[$i][$j] =~ /[ACTG-]/){ if ($#$list<0){ push(@$list,$j); } else{ my $found =0; # check if already exist the value foreach my $k(0..$#$list){ $found =1 if ($list->[$k] eq $j); last if ($found); } if(!$found){ push(@$list,$j); } } } } } @$list = sort { $a <=> $b} @$list; return $list; } =head2 _remove_col Title : _remove_col Usage : Function: remove columns contained on the second array from the first arr Returns : nothing Args : array of array reference and array reference Status : internal =cut #------------------------ sub _remove_col{ #------------------------ my ($arr,$rem)=@_; foreach my $col (reverse @$rem){ splice @$_, $col, 1 for @$arr; } } =head2 _remove_snp_id Title : _remove_snp_id Usage : Function: remove columns contained on the second array from the first arr Returns : nothing Args : array of array reference and array reference Status : internal =cut #------------------------ sub _remove_snp_id{ #------------------------ my ($arr,$removed,$rem_list)=@_; push @$removed, splice @$arr, $_, 1 foreach reverse @$rem_list; } =head2 _find_deg_pattern Title : _find_deg_pattern Usage : Function: create a list with the degenerated patterns Returns : @array Args : a ref to AoA Status : public =cut #------------------------ sub _find_deg_pattern{ #------------------------ my $self = shift; my $arr = $self ->{w_hap}; # the working haplotype my $list = $self ->{'deg_pattern'}; # degenerated patterns # we have to check all elements foreach my $i(0..$#$arr){ # is the element has not been used create a key unless ( _is_on_hash ($list,\$i) ) { $list->{$i}=[$i]; }; foreach my $j($i+1..$#$arr){ my $comp = compare_arrays($arr->[$i],$arr->[$j]); if($comp){ # as we have no elements we push this into the list # check for the first element my $key = _key_for_value($list,\$i); push (@{$list->{$key}},$j); last; } } } } #------------------------ sub _key_for_value{ #------------------------ my($hash,$value)=@_; foreach my $key (keys %$hash){ if( _is_there(\@{$hash->{$key}},$value)){ return $key; } } } #------------------------ sub _is_on_hash{ #------------------------ my($hash,$value)=@_; foreach my $key (keys %$hash){ if( _is_there(\@{$hash->{$key}},$value)){ return 1; } } } #------------------------ sub _is_there{ #------------------------ my($arr,$value)=@_; foreach my $el (@$arr){ if ($el eq $$value){ return 1; } } } =head2 _keep_these_patterns Title : _keep_these_patterns Usage : Function: this is a basic approach, take a LoL and a list, keep just the columns included on the list Returns : nothing Args : an AoA and an array Status : public =cut #------------------------ sub _keep_these_patterns{ #------------------------ my ($arr,$list)=@_; # by now we just take one of the repetitions but you can weight # the values by frequency my @outValues=(); foreach my $k (@$list){ push @outValues, $arr->[$k]; } #make arr to hold the new values @$arr= @{dclone(\@outValues)}; } =head2 compare_arrays Title : compare_arrays Usage : Function: take two arrays and compare their values Returns : 1 if the two values are the same 0 if the values are different Args : an AoA and an array Status : public =cut #------------------------ sub compare_arrays { #------------------------ my ($first, $second) = @_; return 0 unless @$first == @$second; for (my $i = 0; $i < @$first; $i++) { return 0 if $first->[$i] ne $second->[$i]; } return 1; } =head2 _convert_to_numbers Title : _convert_to_numbers Usage : _convert_to_numbers() Function: tranform the haplotype into numbers. before to do that we have to consider the variation on the set. Returns : nonthing Args : ref to an AoA and a ref to an array Status : internal =cut #------------------------ sub _convert_to_numbers{ #------------------------ my $self = shift; my $hap_ref = $self->{w_hap}; my $mm = $self->{alleles_number}; # the first element is considered as zero. The first modification # is consider as one and so on. my $length = @{ @$hap_ref[0]}; #length of the haplotype for (my $c = 0; $c<$length;$c++){ my @al=(); for my $r (0..$#$hap_ref){ push @al,$hap_ref->[$r][$c] unless _is_there(\@al,\$hap_ref->[$r][$c]); $hap_ref->[$r][$c] = get_position(\@al,\$hap_ref->[$r][$c]); } } } =head2 _snp_type_code Title : _snp_type_code Usage : Function: we have to create the snp type code for each version. The way the snp type is created is the following: we take the number value for every SNP and do the following calculation let be a SNP set as follow: 0 0 1 1 1 2 and multiplicity 3 on this case the situation is: sum (value * multiplicity ^ position) for each SNP 0 * 3 ^ 0 + 1 * 3 ^ 1 + 1 * 3 ^ 2 = 12 0 * 3 ^ 0 + 1 * 3 ^ 1 + 2 * 3 ^ 2 = 21 Returns : nothing Args : $self Status : private =cut #------------------------ sub _snp_type_code{ #------------------------ my $self = shift; my $hap = $self->{w_hap}; my $arr = $self->{snp_type_code}; my $al = $self->{alleles_number}; my $length = @{ $hap->[0]}; #length of the haplotype for (my $c=0; $c<$length; $c++){ for my $r (0..$#$hap){ $arr->[$c] += $hap->[$r][$c] * $al ** $r; } } } ################################################# # return the position of an element in one array # The element is always present on the array ################################################# #------------------------ sub get_position{ #------------------------ my($array, $value)=@_; for my $i(0..$#$array) { if ($array->[$i] eq $$value){ return $i; } } } =head2 _alleles_number Title : _alleles_number Usage : Function: calculate the max number of alleles for a haplotype and if the number. For each SNP the number is stored and the max number of alleles for a SNP on the set is returned Returns : max number of alleles (a scalar storing a number) Args : ref to AoA Status : public =cut #------------------------ sub _alleles_number{ #------------------------ my $self = shift; my $hap_ref = $self ->{w_hap}; # working haplotype my $length = @{ @$hap_ref[0]}; # length of the haplotype for (my $c = 0; $c<$length;$c++){ my %alleles=(); for my $r (0..$#$hap_ref){ $alleles{ $hap_ref->[$r][$c] } =1; # new key for every new snp } # if the number of alleles for this column is # greater than before set $m value as allele number if ($self->{alleles_number} < keys %alleles) { $self->{alleles_number} = keys %alleles; } } } =head2 _htSNP Title : _htSNP Usage : _htSNP() Function: calculate the minimal set that contains all information of the haplotype. Returns : nonthing Args : ref to an AoA and a ref to an array Status : internal =cut #------------------------ sub _htSNP{ #------------------------ my $self = shift; my $hap = $self->{'w_hap'}; my $type = $self->{'snp_type_code'}; my $set = $self->{'ht_type'}; my $out = []; # store the minimal set my $nc=0; # new column for the output values # pass for every value of the snp_type_code for my $c (0..$#$type){ my $exist =0; # every new value (not present) is pushed into set if ( ! _is_there( $set,\$type->[$c] ) ){ push @$set, $type->[$c]; $exist =1; for my $r(0..$#$hap){ #save value of the snp for every SNP $out->[$r][$nc]= $hap->[$r][$c]; } } if ($exist){ $nc++ }; } @$hap = @{dclone $out}; } =head2 _snp_and_code_summary Title : _snp_and_code_summary Usage : _snp_and_code_summary() Function: compile on a list all SNP and the code for each. This information can be also obtained combining snp_type and snp_type_code but on these results the information about the rest of SNP's are not compiled as table. 0 will be silent SNPs -1 are degenerated SNPs and the rest of positive values are the code for useful SNP Returns : nonthing Args : ref to an AoA and a ref to an array Status : internal =cut #------------------------ sub _snp_and_code_summary{ #------------------------ my $self = shift; my $snp_type_code = $self->{'snp_type_code'}; my $useful_snp = $self->{'snp_type'}->{'useful_snp'}; my $silent_snp = $self->{'snp_type'}->{'silent_snp'}; my $deg_snp = $self->{'snp_type'}->{'deg_snp'}; my $snp_ids = $self->snp_ids(); my $snp_and_code = $self->{'snp_and_code'}; # walk all SNP's and generate code for each # do a practical thing. Consider all snp silent foreach my $i (0..$#$snp_ids){ # assign zero to silent my $value=0; # active SNPs foreach my $j (0..$#$useful_snp){ if ($snp_ids->[$i] eq $useful_snp->[$j]){ $value = $snp_type_code->[$j]; last; } } # assign -1 to degenerated foreach my $j (0..$#$deg_snp){ if ($snp_ids->[$i] eq $deg_snp->[$j]){ $value = -1; last; } } push @$snp_and_code, [$snp_ids->[$i], $value]; } } 1; BioPerl-1.6.923/Bio/PopGen/Individual.pm000444000765000024 1675212254227323 20020 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Individual # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Individual - An implementation of an Individual who has Genotype or Sequence Results =head1 SYNOPSIS use Bio::PopGen::Individual; my $ind = Bio::PopGen::Individual->new(-unique_id => $id, -genotypes => \@genotypes); =head1 DESCRIPTION This object is a container for genotypes. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Individual; use vars qw($UIDCOUNTER); use strict; BEGIN { $UIDCOUNTER = 1 } # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::PopGen::IndividualI); =head2 new Title : new Usage : my $obj = Bio::PopGen::Individual->new(); Function: Builds a new Bio::PopGen::Individual object Returns : an instance of Bio::PopGen::Individual Args : -unique_id => $id, -genotypes => \@genotypes =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_genotypes'} = {}; my ($uid,$genotypes) = $self->_rearrange([qw(UNIQUE_ID GENOTYPES)],@args); unless( defined $uid ) { $uid = $UIDCOUNTER++; } $self->unique_id($uid); if( defined $genotypes ) { if( ref($genotypes) =~ /array/i ) { $self->add_Genotype(@$genotypes); } else { $self->warn("Must provide a valid array reference to set the genotypes value in the contructor"); } } return $self; } =head2 unique_id Title : unique_id Usage : my $id = $individual->unique_id Function: Unique Identifier Returns : string representing unique identifier Args : string =cut sub unique_id{ my ($self) = shift; return $self->{'_unique_id'} = shift if @_; return $self->{'_unique_id'}; } =head2 num_of_results Title : num_of_results Usage : my $count = $person->num_results; Function: returns the count of the number of Results for a person Returns : integer Args : none =cut sub num_of_results { return scalar keys %{shift->{'_genotypes'}}; } =head2 annotation Title : annotation Usage : my $annotation_collection = $ind->annotation; Function: Get/set a Bio::AnnotationCollectionI for this individual Returns : Bio::AnnotationCollectionI object Args : [optional set] Bio::AnnotationCollectionI object =cut sub annotation{ my ($self, $arg) = @_; return $self->{_annotation} unless $arg; $self->throw("Bio::AnnotationCollectionI required for argument") unless ref($arg) && $arg->isa('Bio::AnnotationCollectionI'); return $self->{_annotation} = $arg; } =head2 add_Genotype Title : add_Genotype Usage : $individual->add_Genotype Function: add a genotype value Returns : count of the number of genotypes associated with this individual Args : @genotypes - L object(s) containing alleles plus a marker name =cut sub add_Genotype { my ($self,@genotypes) = @_; foreach my $g ( @genotypes ) { if( !ref($g) || ! $g->isa('Bio::PopGen::GenotypeI') ) { $self->warn("cannot add $g as a genotype skipping"); next; } my $mname = $g->marker_name; if( ! defined $mname || ! length($mname) ) { # can't just say ! name b/c '0' wouldn't be valid $self->warn("cannot add genotype because marker name is not defined or is an empty string"); next; } if( $self->verbose > 0 && defined $self->{'_genotypes'}->{$mname} ) { # a warning when we have verbosity cranked up $self->debug("Overwriting the previous value for $mname for this individual"); } # this will force Genotype individual_id to be set to # the Individual it has been added for $g->individual_id($self->unique_id); $self->{'_genotypes'}->{$mname} = $g; } return scalar keys %{$self->{'_genotypes'}}; } =head2 reset_Genotypes Title : reset_Genotypes Usage : $individual->reset_Genotypes; Function: Reset the genotypes stored for this individual Returns : none Args : none =cut sub reset_Genotypes{ shift->{'_genotypes'} = {}; } =head2 remove_Genotype Title : remove_Genotype Usage : $individual->remove_Genotype(@names) Function: Removes the genotypes for the requested markers Returns : none Args : Names of markers =cut sub remove_Genotype{ my ($self,@mkrs) = @_; foreach my $m ( @mkrs ) { delete($self->{'_genotypes'}->{$m}); } } =head2 get_Genotypes Title : get_Genotypes Usage : my @genotypes = $ind->get_Genotypes(-marker => $markername); Function: Get the genotypes for an individual, based on a criteria Returns : Array of genotypes Args : either none (return all genotypes) or -marker => name of marker to return (exact match, case matters) =cut sub get_Genotypes{ my ($self,@args) = @_; if( @args ) { unshift @args, '-marker' if( @args == 1 ); # deal with single args my ($name) = $self->_rearrange([qw(MARKER)], @args); if( ! defined($name) ) { $self->warn("Only know how to process the -marker field currently"); return(); } my $v = $self->{'_genotypes'}->{$name}; return $v; } return values %{$self->{'_genotypes'} || {}}; } =head2 has_Marker Title : has_Marker Usage : if( $ind->has_Marker($name) ) {} Function: Boolean test to see if an Individual has a genotype for a specific marker Returns : Boolean (true or false) Args : String representing a marker name =cut sub has_Marker{ my ($self,$name) = @_; return 0 if ! defined $name; $name = $name->name if ref($name) && $name->isa('Bio::PopGen::MarkerI'); if( ref($name) ) { $self->warn("Passed in a ".ref($name). " to has_Marker, expecting either a string or a Bio::PopGen::MarkerI"); return 0; } return defined $self->{'_genotypes'}->{$name}; } =head2 get_marker_names Title : get_marker_names Usage : my @names = $individual->get_marker_names; Function: Returns the list of known marker names Returns : List of strings Args : none =cut sub get_marker_names{ my ($self) = @_; return keys %{$self->{'_genotypes'}}; } 1; BioPerl-1.6.923/Bio/PopGen/IndividualI.pm000444000765000024 1003612254227331 20115 0ustar00cjfieldsstaff000000000000# $Id $ # # BioPerl module for Bio::PopGen::IndividualI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::IndividualI - An individual who has Genotype or Sequence Results =head1 SYNOPSIS # Get a Bio::PopGen::IndividualI somehow # test if it has alleles/genotypes for a given marker if( $ind->has_marker($markername) ) { } # get the unique id print $ind->unique_id, "\n"; # get the number of results (genotypes) print $ind->num_results; =head1 DESCRIPTION Describe the interface here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::IndividualI; use strict; use base qw(Bio::Root::RootI); =head2 unique_id Title : unique_id Usage : my $id = $individual->unique_id Function: Unique Identifier Returns : string representing unique identifier Args : string =cut sub unique_id{ my ($self) = @_; $self->throw_not_implemented(); } =head2 num_genotypes Title : num_genotypes Usage : my $count = $person->num_results; Function: returns the count of the number of Results for a person Returns : integer Args : none =cut sub num_genotypes { shift->throw_not_implemented; } sub num_of_results{ my $self = shift; $self->deprecated("num_of_results is deprecated, use num_genotypes instead"); $self->num_genotypes; } =head2 annotation Title : annotation Usage : my $annotation_collection = $ind->annotation; Function: Get/set a Bio::AnnotationCollectionI for this individual Returns : Bio::AnnotationCollectionI object Args : [optional set] Bio::AnnotationCollectionI object =cut sub annotation{ my ($self, $arg) = @_; $self->throw_not_implemented(); } =head2 get_Genotypes Title : get_Genotypes Usage : my @genotypes = $ind->get_Genotypes(-marker => $markername); Function: Get the genotypes for an individual, based on a criteria Returns : Array of genotypes Args : either none (return all genotypes) or -marker => name of marker to return (exact match, case matters) =cut sub get_Genotypes{ my ($self) = @_; $self->throw_not_implemented(); } =head2 has_Marker Title : has_Marker Usage : if( $ind->has_Marker($name) ) {} Function: Boolean test to see if an Individual has a genotype for a specific marker Returns : Boolean (true or false) Args : String representing a marker name =cut sub has_Marker{ my ($self,$name) = @_; $self->throw_not_implemented(); } =head2 get_marker_names Title : get_marker_names Usage : my @names = $individual->get_marker_names; Function: Returns the list of known marker names Returns : List of strings Args : none =cut sub get_marker_names{ my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/PopGen/IO.pm000444000765000024 1677512254227330 16242 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::IO # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::IO - Input individual,marker,allele information =head1 SYNOPSIS use Bio::PopGen::IO; my $io = Bio::PopGen::IO->new(-format => 'csv', -file => 'data.csv'); # Some IO might support reading in a population at a time my @population; while( my $ind = $io->next_individual ) { push @population, $ind; } =head1 DESCRIPTION This is a generic interface to reading in population genetic data (of which there really isn't too many standard formats). This implementation makes it easy to provide your own parser for the data. You need to only implement one function next_individual. You can also implement next_population if your data has explicit information about population memberhsip for the indidviduals. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... #TODO # Set the Individual creation as a factory rather than # hardcoded package Bio::PopGen::IO; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use base qw(Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::PopGen::IO->new(); Function: Builds a new Bio::PopGen::IO object Returns : an instance of Bio::PopGen::IO Args : =cut sub new { my($class,@args) = @_; if( $class =~ /Bio::PopGen::IO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{'-file'} || $ARGV[0] ) || 'csv'; # normalize capitalization to lower case $format = "\L$format"; return unless( $class->_load_format_module($format) ); return "Bio::PopGen::IO::${format}"->new(@args); } } =head2 format Title : format Usage : $format = $stream->format() Function: Get the PopGen format Returns : PopGen format Args : none =cut # format() method inherited from Bio::Root::IO # _initialize is chained for all PopGen::IO classes sub _initialize { my($self, @args) = @_; # my ($indfact, $popfact) = $self->_rearrange([qw(INDIVIDUAL_FACTORY # POPULATION_FACTORY)], # @args); # $indfact = Bio::PopGen::IndividualBuilder->new() unless $indfact; # $indfact = Bio::PopGen::PopulationBuilder->new() unless $indfact; # initialize the IO part $self->_initialize_io(@args); return 1; } =head2 next_individual Title : next_individual Usage : my $ind = $popgenio->next_individual; Function: Retrieve the next individual from a dataset Returns : L object Args : none =cut sub next_individual{ my ($self) = @_; $self->throw_not_implemented(); } =head2 next_population Title : next_population Usage : my $pop = $popgenio->next_population; Function: Retrieve the next population from a dataset Returns : L object Args : none Note : Many implementation will not implement this =cut sub next_population{ my ($self) = @_; $self->throw_not_implemented(); } =head2 write_individual Title : write_individual Usage : $popgenio->write_individual($ind); Function: Write an individual out in the implementation format Returns : none Args : L object(s) =cut sub write_individual{ my ($self) = @_; $self->throw_not_implemented(); } =head2 write_population Title : write_population Usage : $popgenio->write_population($pop); Function: Write a population out in the implementation format Returns : none Args : L object(s) Note : Many implementation will not implement this =cut sub write_population{ my ($self) = @_; $self->throw_not_implemented(); } =head2 newFh Title : newFh Usage : $fh = Bio::SeqIO->newFh(-file=>$filename,-format=>'Format') Function: does a new() followed by an fh() Example : $fh = Bio::SeqIO->newFh(-file=>$filename,-format=>'Format') $sequence = <$fh>; # read a sequence object print $fh $sequence; # write a sequence object Returns : filehandle tied to the Bio::SeqIO::Fh class Args : See L =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Example : $fh = $obj->fh; # make a tied filehandle $sequence = <$fh>; # read a sequence object print $fh $sequence; # write a sequence object Returns : filehandle tied to Bio::SeqIO class Args : none =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL Bio::PopGen::IO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self,$format) = @_; my $module = "Bio::PopGen::IO::" . $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'csv' if (/csv/i or /\.dat\w$/i); } sub close { my $self = shift; $self->SUPER::close(@_); } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my $class = shift; return bless {processor => shift}, $class; } sub READLINE { my $self = shift; return $self->{'processor'}->next_result() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'processor'}->next_result(); return @list; } sub PRINT { my $self = shift; $self->{'processor'}->write_result(@_); } 1; BioPerl-1.6.923/Bio/PopGen/Marker.pm000444000765000024 1672312254227326 17152 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Marker # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Marker - A genetic marker which one uses to generate genotypes =head1 SYNOPSIS my $name = $marker->name(); # marker name my $description = $marker->description(); # description my $type = $marker->type(); # coded type of the marker my $unique_id = $marker->unique_id; # optional unique ID my @alleles = $marker->get_Alleles(); # the known alleles my %allele_freqs = $marker->get_Allele_Frequencies(); # keys are marker names # vals are frequencies # may change to handle multiple populations =head1 DESCRIPTION This object will not contain genotype information pertaining to an individual, but rather population level statistics and descriptive information about a marker. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Marker; use strict; # Object preamble - inherits from Bio::Root::Root use vars qw($UniqueCounter); $UniqueCounter = 0; use base qw(Bio::Root::Root Bio::PopGen::MarkerI); =head2 new Title : new Usage : my $obj = Bio::PopGen::Marker->new(); Function: Builds a new Bio::PopGen::Marker object Returns : an instance of Bio::PopGen::Marker Args : -name => [string] marker name -description => [string] marker description -type => [string] marker type -unique_id => [string/int] unique id -allele_freq => [hash ref] allele frequencies =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($name,$desc,$type,$uid,$af) = $self->_rearrange([qw(NAME DESCRIPTION TYPE UNIQUE_ID ALLELE_FREQ)],@args); $self->{'_allele_freqs'} = {}; if( ! defined $uid ) { $uid = $UniqueCounter++; } if( defined $name) { $self->name($name); } else { $self->throw("Must provide a name when initializing a Marker"); } defined $desc && $self->description($desc); defined $type && $self->type($type); $self->unique_id($uid); if( defined $af) { if( ref($af) !~ /HASH/i ) { $self->warn("Must provide valid Hash reference for allele_freq method"); } else { foreach my $allele ( keys %$af ) { $self->add_Allele_Frequency($allele, $af->{$allele}); } } } return $self; } =head2 name Title : name Usage : my $name = $marker->name(); Function: Get the name of the marker Returns : string representing the name of the marker Args : [optional] name =cut sub name{ my $self = shift; return $self->{'_name'} = shift if @_; return $self->{'_name'}; } =head2 description Title : description Usage : my $desc = $marker->description Function: Get the marker description free text Returns : string Args : [optional] string =cut sub description{ my $self = shift; return $self->{'_description'} = shift if @_; return $self->{'_description'}; } =head2 type Title : type Usage : my $type = $marker->type; Function: Get coded string for marker type Returns : string Args : [optional] string =cut sub type{ my $self = shift; return $self->{'_type'} = shift if @_; return $self->{'_type'}; } =head2 unique_id Title : unique_id Usage : my $id = $marker->unique_id; Function: Get the unique marker ID Returns : unique ID string Args : [optional ] string =cut sub unique_id{ my $self = shift; return $self->{'_uniqueid'} = shift if @_; return $self->{'_uniqueid'}; } =head2 annotation Title : annotation Usage : my $annotation_collection = $marker->annotation; Function: Get/set a Bio::AnnotationCollectionI for this marker Returns : Bio::AnnotationCollectionI object Args : [optional set] Bio::AnnotationCollectionI object =cut sub annotation{ my ($self, $arg) = @_; return $self->{_annotation} unless $arg; $self->throw("Bio::AnnotationCollectionI required for argument") unless ref($arg) && $arg->isa('Bio::AnnotationCollectionI'); return $self->{_annotation} = $arg; } =head2 get_Alleles Title : get_Alleles Usage : my @alleles = $marker->get_Alleles(); Function: Get the available marker alleles Returns : Array of strings Args : none =cut sub get_Alleles{ my $self = shift; my (@numeric,@alpha); for ( keys %{$self->{'_allele_freqs'}} ) { if( /[^\d\.\-e]/ ) { push @alpha, $_ } else { push @numeric, $_ } } @numeric = sort { $b <=> $a } @numeric; @alpha = sort { $b cmp $a } @alpha; return @numeric,@alpha; } =head2 get_Allele_Frequencies Title : get_Allele_Frequencies Usage : my %allele_freqs = $marker->get_Allele_Frequencies; Function: Get the alleles and their frequency (set relative to a given population - you may want to create different markers with the same name for different populations with this current implementation Returns : Associative array where keys are the names of the alleles Args : none =cut sub get_Allele_Frequencies{ return %{$_[0]->{'_allele_freqs'}}; } =head2 add_Allele_Frequency Title : add_Allele_Frequency Usage : $marker->add_Allele_Frequency($allele,$freq) Function: Adds an allele frequency Returns : None Args : $allele - allele name $freq - frequency value =cut sub add_Allele_Frequency{ my ($self,$allele,$freq) = @_; $self->{'_allele_freqs'}->{$allele} = $freq; } =head2 reset_alleles Title : reset_alleles Usage : $marker->reset_alleles(); Function: Reset the alleles for a marker Returns : None Args : None =cut sub reset_alleles{ my ($self) = @_; $self->{'_allele_freqs'} = {}; } =head2 marker_coverage Title : marker_coverage Usage : $marker->marker_coverage(); Function: Get marker coverage, that is, the number of individuals where the marker is present excluding missing or ambiguous alleles Returns : integer, representing marker coverage Args : =cut sub marker_coverage{ my ($self) = @_; return $self->{_marker_coverage}; } 1; BioPerl-1.6.923/Bio/PopGen/MarkerI.pm000444000765000024 1117312254227330 17250 0ustar00cjfieldsstaff000000000000# $Id $ # # BioPerl module for Bio::PopGen::MarkerI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::MarkerI - A Population Genetic conceptual marker =head1 SYNOPSIS # Get a Bio::PopGen::MarkerI somehow - like using a Bio::PopGen::Marker my $name = $marker->name(); # marker name my $description = $marker->description(); # description my $type = $marker->type(); # coded type of the marker my $unique_id = $marker->unique_id; # optional unique ID my @alleles = $marker->get_Alleles(); # the known alleles my %allele_freqs = $marker->get_Allele_Frequencies(); # keys are marker names # vals are frequencies # may change to handle multiple populations =head1 DESCRIPTION This is the basic interface for Markers which one can associate alleles with for calculating Theta and Pi. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::MarkerI; use strict; use base qw(Bio::Root::RootI Bio::AnnotatableI); =head2 name Title : name Usage : my $name = $marker->name(); Function: Get the name of the marker Returns : string representing the name of the marker Args : =cut sub name{ $_[0]->throw_not_implemented(); } =head2 description Title : description Usage : my $desc = $marker->description Function: Get the marker description free text Returns : string Args : [optional] string =cut sub description{ $_[0]->throw_not_implemented(); } =head2 type Title : type Usage : my $type = $marker->type; Function: Get coded string for marker type Returns : string Args : [optional] string =cut sub type{ my ($self) = @_; $self->throw_not_implemented(); } =head2 unique_id Title : unique_id Usage : my $id = $marker->unique_id; Function: Get the unique marker ID Returns : unique ID string Args : [optional ] string =cut sub unique_id{ my ($self) = @_; $self->throw_not_implemented(); } =head2 annotation Title : annotation Usage : $obj->annotation($seq_obj) Function: retrieve the attached annotation object Returns : Bio::AnnotationCollectionI or none; See L and L for more information. This method comes through extension from L. =cut sub annotation{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_Alleles Title : get_Alleles Usage : my @alleles = $marker->get_Alleles(); Function: Get the available marker alleles if they are known and stored Returns : Array of strings Args : none =cut sub get_Alleles{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_Allele_Frequencies Title : get_Allele_Frequencies Usage : my %allele_freqs = $marker->get_Allele_Frequencies; Function: Get the alleles and their frequency (set relative to a given population - you may want to create different markers with the same name for different populations with this current implementation Returns : Associative array (hash) where keys are the names of the alleles Args : none =cut sub get_Allele_Frequencies{ my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/PopGen/PopStats.pm000444000765000024 2072512254227334 17502 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::PopStats # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::PopStats - A collection of methods for calculating statistics about a population or sets of populations =head1 SYNOPSIS use Bio::PopGen::PopStats; my $stats = Bio::PopGen::PopStats->new(); # add -haploid => 1 # to process haploid data =head1 DESCRIPTION Calculate various population structure statistics, most notably Wright's Fst. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::PopStats; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::PopGen::PopStats->new(); Function: Builds a new Bio::PopGen::PopStats object Returns : an instance of Bio::PopGen::PopStats Args : -haploid => 1 (if want to use haploid calculations) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($haploid) = $self->_rearrange([qw(HAPLOID)],@args); if( $haploid ) { $self->haploid_status(1) } return $self; } =head2 haploid_status Title : haploid_status Usage : $obj->haploid_status($newval) Function: Boolean value for whether or not to do haploid or diploid calculations, where appropriate Returns : Boolean Args : on set, new boolean value optional) =cut sub haploid_status{ my $self = shift; return $self->{'haploid_status'} = shift if @_; return $self->{'haploid_status'}; } # Implementation provided my Matthew Hahn, massaged by Jason Stajich =head2 Fst Title : Fst Usage : my $fst = $stats->Fst(\@populations,\@markernames) Function: Calculate Wright's Fst based on a set of sub-populations and specific markers Returns : Fst value (a value between 0 and 1) Args : Arrayref of populations to process Arrayref of marker names to process Note : Based on diploid method in Weir BS, Genetics Data Analysis II, 1996 page 178. =cut #' make emacs happy here sub Fst { my ($self,$populations,$markernames) = @_; if( ! defined $populations || ref($populations) !~ /ARRAY/i ) { $self->warn("Must provide a valid arrayref for populations"); return; } elsif( ! defined $markernames || ref($markernames) !~ /ARRAY/i ) { $self->warn("Must provide a valid arrayref for marker names"); return; } my $num_sub_pops = scalar @$populations; if( $num_sub_pops < 2 ) { $self->warn("Must provide at least 2 populations for this test, you provided $num_sub_pops"); return; } # This code assumes that pop 1 contains at least one of all the # alleles - need to do some more work to insure that the complete # set of alleles is seen. my $Fst; my ($TS_sub1,$TS_sub2); foreach my $marker ( @$markernames ) { # Get all the alleles from all the genotypes in all subpopulations my %allAlleles; foreach my $allele ( map { $_->get_Alleles() } map { $_->get_Genotypes($marker) } @$populations ){ $allAlleles{$allele}++; } my @alleles = keys %allAlleles; foreach my $allele_name ( @alleles ) { my $avg_samp_size = 0; # n-bar my $avg_allele_freq = 0; # p-tilda-A-dot my $total_samples_squared = 0; # my $sum_heterozygote = 0; my @marker_freqs; # Walk through each population, get the calculated allele frequencies # for the marker, do some bookkeeping foreach my $pop ( @$populations ) { my $s = $pop->get_number_individuals($marker); $avg_samp_size += $s; $total_samples_squared += $s**2; my $markerobj = $pop->get_Marker($marker); if( ! defined $markerobj ) { $self->warn("Could not derive Marker for $marker ". "from population ". $pop->name); return; } my $freq_homozygotes = $pop->get_Frequency_Homozygotes($marker,$allele_name); my %af = $markerobj->get_Allele_Frequencies(); my $all_freq = ( ($af{$allele_name} || 0)); $avg_allele_freq += $s * $all_freq; $sum_heterozygote += (2 * $s)*( $all_freq - $freq_homozygotes); push @marker_freqs, \%af; } my $total_samples = $avg_samp_size; # sum of n over i sub-populations $avg_samp_size /= $num_sub_pops; $avg_allele_freq /= $total_samples; # n-sub-c my $adj_samp_size = ( 1/ ($num_sub_pops - 1)) * ( $total_samples - ( $total_samples_squared/$total_samples)); my $variance = 0; # s-squared-sub-A my $sum_variance = 0; my $i = 0; # we have cached the marker info foreach my $pop ( @$populations ) { my $s = $pop->get_number_individuals($marker); my %af = %{$marker_freqs[$i++]}; $sum_variance += $s * (( ($af{$allele_name} || 0) - $avg_allele_freq)**2); } $variance = ( 1 / (( $num_sub_pops-1)*$avg_samp_size))*$sum_variance; # H-tilda-A-dot my $freq_heterozygote = ($sum_heterozygote / $total_samples); if( $self->haploid_status ) { # Haploid calculations my $T_sub1 = $variance - ( ( 1/($avg_samp_size-1))* ( ($avg_allele_freq*(1-$avg_allele_freq))- ( (($num_sub_pops-1)/$num_sub_pops)*$variance))); my $T_sub2 = ( (($adj_samp_size-1)/($avg_samp_size-1))* $avg_allele_freq*(1-$avg_allele_freq) ) + ( 1 + ( (($num_sub_pops-1)* ($avg_samp_size-$adj_samp_size))/ ($avg_samp_size - 1))) * ($variance/$num_sub_pops); #to get total Fst from all alleles (if more than two) or all #loci (if more than one), we need to calculate $T_sub1 and #$T_sub2 for all alleles for all loci, sum, and then divide #again to get Fst. $TS_sub1 += $T_sub1; $TS_sub2 += $T_sub2; } else { my $S_sub1 = $variance - ( (1/($avg_samp_size-1))* ( ($avg_allele_freq* (1-$avg_allele_freq)) - ((($num_sub_pops-1)/$num_sub_pops)* $variance)-0.25*$freq_heterozygote ) ); my $S_sub2 = ($avg_allele_freq*(1-$avg_allele_freq)) - ( ($avg_samp_size/($num_sub_pops*($avg_samp_size-1)))* ( ((($num_sub_pops*($avg_samp_size- $adj_samp_size))/ $avg_samp_size)*$avg_allele_freq* (1-$avg_allele_freq)) - ( (1/$avg_samp_size)* (($avg_samp_size-1)+ ($num_sub_pops-1)* ($avg_samp_size- $adj_samp_size) )*$variance ) - ( (($num_sub_pops*($avg_samp_size-$adj_samp_size))/ (4*$avg_samp_size*$adj_samp_size))* $freq_heterozygote ) ) ); my $S_sub3 = ($adj_samp_size/(2*$avg_samp_size))* $freq_heterozygote; #Again, to get the average over many alleles or many loci, #we will have to run the above for each and then sum the $S #variables and recalculate the F statistics $TS_sub1 += $S_sub1; $TS_sub2 += $S_sub2; } } } # $Fst_diploid = $S_sub1/$S_sub2; #my $Fit_diploid = 1 - ($S_sub3/$S_sub2); #my $Fis_diploid = ($Fit_diploid-$Fst_diploid)/(1-$Fst_diploid); $Fst = $TS_sub1 / $TS_sub2; return $Fst; } 1; BioPerl-1.6.923/Bio/PopGen/Population.pm000444000765000024 4200412254227334 20051 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Population # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Population - A population of individuals =head1 SYNOPSIS use Bio::PopGen::Population; use Bio::PopGen::Individual; my $population = Bio::PopGen::Population->new(); my $ind = Bio::PopGen::Individual->new(-unique_id => 'id'); $population->add_Individual($ind); for my $ind ( $population->get_Individuals ) { # iterate through the individuals } for my $name ( $population->get_marker_names ) { my $marker = $population->get_Marker($name); } my $num_inds = $population->get_number_individuals; my $homozygote_f = $population->get_Frequency_Homozygotes; my $heterozygote_f = $population->get_Frequency_Heterozygotes; # make a population haploid by making fake chromosomes through # haplotypes -- ala allele 1 is on chrom 1 and allele 2 is on chrom 2 # the number of individuals created will thus be 2 x number in # population my $happop = $population->haploid_population; =head1 DESCRIPTION This is a collection of individuals. We'll have ways of generating L objects out so we can calculate allele_frequencies for implementing the various statistical tests. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Population; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::PopGen::Marker; use Bio::PopGen::Genotype; our $CheckISA = 1; use base qw(Bio::Root::Root Bio::PopGen::PopulationI); =head2 new Title : new Usage : my $obj = Bio::PopGen::Population->new(); Function: Builds a new Bio::PopGen::Population object Returns : an instance of Bio::PopGen::Population Args : -individuals => array ref of individuals (optional) -name => population name (optional) -source => a source tag (optional) -description => a short description string of the population (optional) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_individuals'} = []; my ($name,$source,$description, $inds,$checkisa) = $self->_rearrange([qw(NAME SOURCE DESCRIPTION INDIVIDUALS CHECKISA)], @args); if( defined $inds ) { if( ref($inds) !~ /ARRAY/i ) { $self->warn("Need to provide a value array ref for the -individuals initialization flag"); } else { $self->add_Individual(@$inds); } } defined $name && $self->name($name); defined $source && $self->source($source); defined $description && $self->description($description); $self->{'_checkisa'} = defined $checkisa ? $checkisa : $CheckISA; return $self; } =head2 name Title : name Usage : my $name = $pop->name Function: Get the population name Returns : string representing population name Args : [optional] string representing population name =cut sub name{ my $self = shift; return $self->{'_name'} = shift if @_; return $self->{'_name'}; } =head2 description Title : description Usage : my $description = $pop->description Function: Get the population description Returns : string representing population description Args : [optional] string representing population description =cut sub description{ my $self = shift; return $self->{'_description'} = shift if @_; return $self->{'_description'}; } =head2 source Title : source Usage : my $source = $pop->source Function: Get the population source Returns : string representing population source Args : [optional] string representing population source =cut sub source{ my $self = shift; return $self->{'_source'} = shift if @_; return $self->{'_source'}; } =head2 annotation Title : annotation Usage : my $annotation_collection = $pop->annotation; Function: Get/set a Bio::AnnotationCollectionI for this population Returns : Bio::AnnotationCollectionI object Args : [optional set] Bio::AnnotationCollectionI object =cut sub annotation{ my ($self, $arg) = @_; return $self->{_annotation} unless $arg; $self->throw("Bio::AnnotationCollectionI required for argument") unless ref($arg) && $arg->isa('Bio::AnnotationCollectionI'); return $self->{_annotation} = $arg; } =head2 set_Allele_Frequency Title : set_Allele_Frequency Usage : $population->set_Allele_Frequency('marker' => { 'allele1' => 0.1}); Function: Sets an allele frequency for a Marker for this Population This allows the Population to not have individual individual genotypes but rather a set of overall allele frequencies Returns : Count of the number of markers Args : -name => (string) marker name -allele => (string) allele name -frequency => (double) allele frequency - must be between 0 and 1 OR -frequencies => { 'marker1' => { 'allele1' => 0.01, 'allele2' => 0.99}, 'marker2' => ... } =cut sub set_Allele_Frequency { my ($self,@args) = @_; my ($name,$allele, $frequency, $frequencies) = $self->_rearrange([qw(NAME ALLELE FREQUENCY FREQUENCIES )], @args); if( defined $frequencies ) { # this supercedes the res if( ref($frequencies) =~ /HASH/i ) { my ($markername,$alleles); while( ($markername,$alleles) = each %$frequencies ) { $self->{'_allele_freqs'}->{$markername} = Bio::PopGen::Marker->new(-name => $markername, -allele_freq => $alleles); } } else { $self->throw("Must provide a valid hashref for the -frequencies option"); } } else { unless( defined $self->{'_allele_freqs'}->{$name} ) { $self->{'_allele_freqs'}->{$name} = Bio::PopGen::Marker->new(-name => $name); } $self->{'_allele_freqs'}->{$name}->add_Allele_Frequency($allele,$frequency); } return scalar keys %{$self->{'_allele_freqs'}}; } =head2 add_Individual Title : add_Individual Usage : $population->add_Individual(@individuals); Function: Add individuals to a population Returns : count of the current number in the object Args : Array of Individuals =cut sub add_Individual{ my ($self,@inds) = @_; foreach my $i ( @inds ) { next if ! defined $i; unless( $self->{'_checkisa'} ? $i->isa('Bio::PopGen::IndividualI') : 1 ) { $self->warn("cannot add an individual ($i) which is not a Bio::PopGen::IndividualI"); next; } } push @{$self->{'_individuals'}}, @inds; $self->{'_cached_markernames'} = undef; $self->{'_allele_freqs'} = {}; return scalar @{$self->{'_individuals'} || []}; } =head2 remove_Individuals Title : remove_Individuals Usage : $population->remove_Individuals(@ids); Function: Remove individual(s) to a population Returns : count of the current number in the object Args : Array of ids =cut sub remove_Individuals { my ($self,@names) = @_; my $i = 0; my %namehash; # O(1) lookup will be faster I think foreach my $n ( @names ) { $namehash{$n}++ } my @tosplice; foreach my $ind ( @{$self->{'_individuals'} || []} ) { unshift @tosplice, $i if( $namehash{$ind->unique_id} ); $i++; } foreach my $index ( @tosplice ) { splice(@{$self->{'_individuals'}}, $index,1); } $self->{'_cached_markernames'} = undef; $self->{'_allele_freqs'} = {}; return scalar @{$self->{'_individuals'} || []}; } =head2 get_Individuals Title : get_Individuals Usage : my @inds = $pop->get_Individuals(); Function: Return the individuals, alternatively restrict by a criteria Returns : Array of Bio::PopGen::IndividualI objects Args : none if want all the individuals OR, -unique_id => To get an individual with a specific id -marker => To only get individuals which have a genotype specific for a specific marker name =cut sub get_Individuals{ my ($self,@args) = @_; my @inds = @{$self->{'_individuals'} || []}; return unless @inds; if( @args ) { # save a little time here if @args is empty my ($id,$marker) = $self->_rearrange([qw(UNIQUE_ID MARKER)], @args); if( defined $id ) { @inds = grep { $_->unique_id eq $id } @inds; } elsif (defined $marker) { @inds = grep { $_->has_Marker($marker) } @inds; } } return @inds; } =head2 get_Genotypes Title : get_Genotypes Usage : my @genotypes = $pop->get_Genotypes(-marker => $name) Function: Get the genotypes for all the individuals for a specific marker name Returns : Array of Bio::PopGen::GenotypeI objects Args : -marker => name of the marker =cut sub get_Genotypes{ my ($self,@args) = @_; my ($name) = $self->_rearrange([qw(MARKER)],@args); if( defined $name ) { return grep { defined $_ } map { $_->get_Genotypes(-marker => $name) } @{$self->{'_individuals'} || []} } $self->warn("You needed to have provided a valid -marker value"); return (); } =head2 get_marker_names Title : get_marker_names Usage : my @names = $pop->get_marker_names; Function: Get the names of the markers Returns : Array of strings Args : [optional] boolean flag to ignore internal cache status =cut sub get_marker_names { my ($self,$force) = @_; return @{$self->{'_cached_markernames'} || []} if( ! $force && defined $self->{'_cached_markernames'}); my %unique; foreach my $n ( map { $_->get_marker_names } $self->get_Individuals() ) { $unique{$n}++; } my @nms = keys %unique; if( $nms[0] =~ /^(Site|Codon)/ ) { # sort by site or codon number and do it in # a schwartzian transformation baby! @nms = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_ =~ /^(?:Codon|Site)-(\d+)/, $_] } @nms; } $self->{'_cached_markernames'} = [ @nms ]; return @{$self->{'_cached_markernames'} || []}; } =head2 get_Marker Title : get_Marker Usage : my $marker = $population->get_Marker($name) Function: Get a Bio::PopGen::Marker object based on this population Returns : Bio::PopGen::MarkerI object Args : name of the marker =cut sub get_Marker{ my ($self,$markername) = @_; my $marker; # setup some caching too if( defined $self->{'_allele_freqs'} && defined ($marker = $self->{'_allele_freqs'}->{$markername}) ) { # marker is now set to the stored value } else { my @genotypes = $self->get_Genotypes(-marker => $markername); $marker = Bio::PopGen::Marker->new(-name => $markername); if( ! @genotypes ) { $self->warn("No genotypes for Marker $markername in the population"); } else { my %alleles; my $count; for my $al ( map { $_->get_Alleles} @genotypes ) { next if($al eq '?'); $count++; $alleles{$al}++ } foreach my $allele ( keys %alleles ) { $marker->add_Allele_Frequency($allele, $alleles{$allele}/$count); $marker->{_marker_coverage} = $count/2; } } $self->{'_allele_freqs'}->{$markername} = $marker; } return $marker; } =head2 get_number_individuals Title : get_number_individuals Usage : my $count = $pop->get_number_individuals; Function: Get the count of the number of individuals Returns : integer >= 0 Args : none =cut sub get_number_individuals{ my ($self,$markername) = @_; if( $self->{'_forced_set_individuals'} ) { return $self->{'_forced_set_individuals'}; } unless( defined $markername ) { return scalar @{$self->{'_individuals'} || []}; } else { my $number =0; foreach my $individual ( @{$self->{'_individuals'} || []} ) { $number++ if( $individual->has_Marker($markername)); } return $number; } } =head2 set_number_individuals Title : set_number_individuals Usage : $pop->set_number_individuals($num); Function: Fixes the number of individuals, call this with 0 to unset. Only use this if you know what you are doing, this is only relavent when you are just adding allele frequency data for a population and want to calculate something like theta Returns : none Args : individual count, calling it with undef or 0 will reset the value to return a number calculated from the number of individuals stored for this population. =cut sub set_number_individuals{ my ($self,$indcount) = @_; return $self->{'_forced_set_individuals'} = $indcount; } =head2 get_Frequency_Homozygotes Title : get_Frequency_Homozygotes Usage : my $freq = $pop->get_Frequency_Homozygotes; Function: Calculate the frequency of homozygotes in the population Returns : fraction between 0 and 1 Args : $markername =cut sub get_Frequency_Homozygotes{ my ($self,$marker,$allelename) = @_; my ($homozygote_count) = 0; return 0 if ! defined $marker || ! defined $allelename; $marker = $marker->name if( defined $marker && ref($marker) && ( $self->{'_checkisa'} ? $marker->isa('Bio::PopGen::MarkerI') : 1)); my $total = $self->get_number_individuals($marker); foreach my $genotype ( $self->get_Genotypes($marker) ) { my %alleles = map { $_ => 1} $genotype->get_Alleles(); # what to do for non-diploid situations? if( $alleles{$allelename} ) { $homozygote_count++ if( keys %alleles == 1); } } return $total ? $homozygote_count / $total : 0; } =head2 get_Frequency_Heterozygotes Title : get_Frequency_Heterozygotes Usage : my $freq = $pop->get_Frequency_Homozygotes; Function: Calculate the frequency of homozygotes in the population Returns : fraction between 0 and 1 Args : $markername =cut sub get_Frequency_Heterozygotes{ my ($self,$marker,$allelename) = @_; my ($heterozygote_count) = 0; return 0 if ! defined $marker || ! defined $allelename; $marker = $marker->name if( defined $marker && ref($marker) && ($self->{'_checkisa'} ? $marker->isa('Bio::PopGen::MarkerI') : 1)); if( ref($marker) ) { $self->warn("Passed in a ".ref($marker). " to has_Marker, expecting either a string or a Bio::PopGen::MarkerI"); return 0; } my $total = $self->get_number_individuals($marker); foreach my $genotype ( $self->get_Genotypes($marker) ) { my %alleles = map { $_ => 1} $genotype->get_Alleles(); # what to do for non-diploid situations? if( $alleles{$allelename} ) { $heterozygote_count++ if( keys %alleles == 2); } } return $total ? $heterozygote_count / $total : 0; } =head2 haploid_population Title : haploid_population Usage : my $pop = $population->haploid_population; Function: Make a new population where all the individuals are haploid - effectively an individual out of each chromosome an individual has. Returns : L Args : None =cut sub haploid_population{ my ($self) = @_; my @inds; my @marker_names = $self->get_marker_names; for my $ind ( $self->get_Individuals ) { my @chromosomes; my $id = $ind->unique_id; # separate genotypes into 'chromosomes' for my $marker_name( @marker_names ) { my ($genotype) = $ind->get_Genotypes(-marker => $marker_name); my $i =0; for my $allele ( $genotype->get_Alleles ) { push @{$chromosomes[$i]}, Bio::PopGen::Genotype->new(-marker_name => $marker_name, -individual_id => $id.".$i", -alleles => [$allele]); $i++; } } for my $chrom ( @chromosomes ) { my $copyind = ref($ind)->new(-unique_id => $id.".1", -genotypes => $chrom); push @inds, $ind; } } my $population = ref($self)->new(-name => $self->name, -source => $self->source, -description => $self->description, -individuals => \@inds); } 1; BioPerl-1.6.923/Bio/PopGen/PopulationI.pm000444000765000024 1433712254227317 20173 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::PopulationI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::PopulationI - Interface for Populations =head1 SYNOPSIS # Get Bio::PopGen::PopulationI object somehow, like # from Bio::Population::Population print "name is ", $population->name(), "\n"; print "source is ", $population->source(), "\n"; print "description is ", $population->description(), "\n"; print "For marker $markername:\n"; foreach my $genotype ( $population->get_Genotypes(-marker => $markername) ) { print "Individual ", $genotype->individual_id, " genotype alleles are ", join(',', $genotype->get_Alleles()), "\n"; } # get a marker with allele frequencies calculated from the population my $marker = $population->get_Marker($markername); my %af = $marker->get_Allele_Frequencies; foreach my $allele ( keys %af ) { print "$allele $af{$allele}\n"; } =head1 DESCRIPTION This interface describes the basics of a population. One can use this object to get the genotypes of specific individuals, only those individuals which have a certain marker, or create a marker with allele frequency information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::PopulationI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 name Title : name Usage : my $name = $pop->name Function: Get the population name Returns : string representing population name Args : [optional] string representing population name =cut sub name{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 description Title : description Usage : my $description = $pop->description Function: Get the population description Returns : string representing population description Args : [optional] string representing population description =cut sub description{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 source Title : source Usage : my $source = $pop->source Function: Get the population source Returns : string representing population source Args : [optional] string representing population source =cut sub source{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 annotation Title : annotation Usage : my $annotation_collection = $pop->annotation; Function: Get/set a Bio::AnnotationCollectionI for this population Returns : Bio::AnnotationCollectionI object Args : [optional set] Bio::AnnotationCollectionI object =cut sub annotation{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_Individuals Title : get_Individuals Usage : my @inds = $pop->get_Individuals(); Function: Return the individuals, alternatively restrict by a criteria Returns : Array of L objects Args : none if want all the individuals OR, -unique_id => To get an individual with a specific id -marker => To only get individuals which have a genotype specific for a specific marker name =cut sub get_Individuals{ shift->throw_not_implemented(); } =head2 get_Genotypes Title : get_Genotypes Usage : my @genotypes = $pop->get_Genotypes(-marker => $name) Function: Get the genotypes for all the individuals for a specific marker name Returns : Array of L objects Args : -marker => name of the marker =cut sub get_Genotypes{ shift->throw_not_implemented; } =head2 get_Marker Title : get_Marker Usage : my $marker = $population->get_Marker($name) Function: Get a Bio::PopGen::Marker object based on this population Returns : L object Args : name of the marker =cut sub get_Marker{ shift->throw_not_implemented(); } =head2 get_marker_names Title : get_marker_names Usage : my @names = $pop->get_marker_names; Function: Get the names of the markers Returns : Array of strings Args : none =cut sub get_marker_names{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_Markers Title : get_Markers Usage : my @markers = $pop->get_Markers(); Function: Will retrieve a list of instantiated MarkerI objects for a population. This is a convience method combining get_marker_names with get_Marker Returns : List of array of Bio::PopGen::MarkerI objects Args : none =cut sub get_Markers{ my ($self) = shift; return map { $self->get_Marker($_) } $self->get_marker_names(); } =head2 get_number_individuals Title : get_number_individuals Usage : my $count = $pop->get_number_individuals; Function: Get the count of the number of individuals Returns : integer >= 0 Args : [optional] marker name, will return a count of the number of individuals which have this marker =cut sub get_number_individuals{ my ($self) = @_; $self->throw_not_implemented(); } 1; BioPerl-1.6.923/Bio/PopGen/Statistics.pm000444000765000024 14475012254227323 20102 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Statistics # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Statistics - Population Genetics statistical tests =head1 SYNOPSIS use Bio::PopGen::Statistics; use Bio::AlignIO; use Bio::PopGen::IO; use Bio::PopGen::Simulation::Coalescent; my $sim = Bio::PopGen::Simulation::Coalescent->new( -sample_size => 12); my $tree = $sim->next_tree; $sim->add_Mutations($tree,20); my $stats = Bio::PopGen::Statistics->new(); my $individuals = [ $tree->get_leaf_nodes]; my $pi = $stats->pi($individuals); my $D = $stats->tajima_D($individuals); # Alternatively to do this on input data from # See the tests in t/PopGen.t for more examples my $parser = Bio::PopGen::IO->new(-format => 'prettybase', -file => 't/data/popstats.prettybase'); my $pop = $parser->next_population; # Note that you can also call the stats as a class method if you like # the only reason to instantiate it (as above) is if you want # to set the verbosity for debugging $pi = Bio::PopGen::Statistics->pi($pop); $theta = Bio::PopGen::Statistics->theta($pop); # Pi and Theta also take additional arguments, # see the documentation for more information use Bio::PopGen::Utilities; use Bio::AlignIO; my $in = Bio::AlignIO->new(-file => 't/data/t7.aln', -format => 'clustalw'); my $aln = $in->next_aln; # get a population, each sequence is an individual and # for the default case, every site which is not monomorphic # is a 'marker'. Each individual will have a 'genotype' for the # site which will be the specific base in the alignment at that # site my $pop = Bio::PopGen::Utilities->aln_to_population(-alignment => $aln); =head1 DESCRIPTION This object is intended to provide implementations some standard population genetics statistics about alleles in populations. This module was previously named Bio::Tree::Statistics. This object is a place to accumulate routines for calculating various statistics from the coalescent simulation, marker/allele, or from aligned sequence data given that you can calculate alleles, number of segregating sites. Currently implemented: Fu and Li's D (fu_and_li_D) Fu and Li's D* (fu_and_li_D_star) Fu and Li's F (fu_and_li_F) Fu and Li's F* (fu_and_li_F_star) Tajima's D (tajima_D) Watterson's theta (theta) pi (pi) - number of pairwise differences composite_LD (composite_LD) McDonald-Kreitman (mcdonald_kreitman or MK) Count based methods also exist in case you have already calculated the key statistics (seg sites, num individuals, etc) and just want to compute the statistic. In all cases where a the method expects an arrayref of L objects and L object will also work. =head2 REFERENCES Fu Y.X and Li W.H. (1993) "Statistical Tests of Neutrality of Mutations." Genetics 133:693-709. Fu Y.X. (1996) "New Statistical Tests of Neutrality for DNA samples from a Population." Genetics 143:557-570. McDonald J, Kreitman M. Tajima F. (1989) "Statistical method for testing the neutral mutation hypothesis by DNA polymorphism." Genetics 123:585-595. =head2 CITING THIS WORK Please see this reference for use of this implementation. Stajich JE and Hahn MW "Disentangling the Effects of Demography and Selection in Human History." (2005) Mol Biol Evol 22(1):63-73. If you use these Bio::PopGen modules please cite the Bioperl publication (see FAQ) and the above reference. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Matthew Hahn Email jason-at-bioperl-dot-org Email matthew-dot-hahn-at-duke-dot-edu McDonald-Kreitman implementation based on work by Alisha Holloway at UC Davis. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Statistics; use strict; use constant { in_label => 'ingroup', out_label => 'outgroup', non_syn => 'non_synonymous', syn => 'synonymous', default_codon_table => 1, # Standard Codon table }; use Bio::MolEvol::CodonModel; use List::Util qw(sum); use base qw(Bio::Root::Root); our $codon_table => default_codon_table; our $has_twotailed => 0; BEGIN { eval { require Text::NSP::Measures::2D::Fisher2::twotailed }; if( $@ ) { $has_twotailed = 0; } else { $has_twotailed = 1; } } =head2 new Title : new Usage : my $obj = Bio::PopGen::Statistics->new(); Function: Builds a new Bio::PopGen::Statistics object Returns : an instance of Bio::PopGen::Statistics Args : none =cut =head2 fu_and_li_D Title : fu_and_li_D Usage : my $D = $statistics->fu_and_li_D(\@ingroup,\@outgroup); OR my $D = $statistics->fu_and_li_D(\@ingroup,$extmutations); Function: Fu and Li D statistic for a list of individuals given an outgroup and the number of external mutations (either provided or calculated from list of outgroup individuals) Returns : decimal Args : $individuals - array reference which contains ingroup individuals (L or derived classes) $extmutations - number of external mutations OR arrayref of outgroup individuals =cut sub fu_and_li_D { my ($self,$ingroup,$outgroup) = @_; my ($seg_sites,$n,$ancestral,$derived) = (0,0,0,0); if( ref($ingroup) =~ /ARRAY/i ) { $n = scalar @$ingroup; # pi - all pairwise differences $seg_sites = $self->segregating_sites_count($ingroup); } elsif( ref($ingroup) && $ingroup->isa('Bio::PopGen::PopulationI')) { $n = $ingroup->get_number_individuals; $seg_sites = $self->segregating_sites_count($ingroup); } else { $self->throw("expected an array reference of a list of Bio::PopGen::IndividualI OR a Bio::PopGen::PopulationI object to fu_and_li_D"); return 0; } if( $seg_sites <= 0 ) { $self->warn("mutation total was not > 0, cannot calculate a Fu and Li D"); return 0; } if( ! defined $outgroup ) { $self->warn("Need to provide either an array ref to the outgroup individuals or the number of external mutations"); return 0; } elsif( ref($outgroup) ) { ($ancestral,$derived) = $self->derived_mutations($ingroup,$outgroup); $ancestral = 0 unless defined $ancestral; } else { $ancestral = $outgroup; } return $self->fu_and_li_D_counts($n,$seg_sites, $ancestral,$derived); } =head2 fu_and_li_D_counts Title : fu_li_D_counts Usage : my $D = $statistics->fu_and_li_D_counts($samps,$sites, $external); Function: Fu and Li D statistic for the raw counts of the number of samples, sites, external and internal mutations Returns : decimal number Args : number of samples (N) number of segregating sites (n) number of external mutations (n_e) =cut sub fu_and_li_D_counts { my ($self,$n,$seg_sites, $external_mut) = @_; my $a_n = 0; if( $n <= 3 ) { $self->warn("n is $n, too small, must be > 3\n"); return; } for(my $k= 1; $k < $n; $k++ ) { $a_n += ( 1 / $k ); } my $b = 0; for(my $k= 1; $k < $n; $k++ ) { $b += ( 1 / $k**2 ); } my $c = 2 * ( ( ( $n * $a_n ) - (2 * ( $n -1 ))) / ( ( $n - 1) * ( $n - 2 ) ) ); my $v = 1 + ( ( $a_n**2 / ( $b + $a_n**2 ) ) * ( $c - ( ( $n + 1) / ( $n - 1) ) )); my $u = $a_n - 1 - $v; ($seg_sites - $a_n * $external_mut) / sqrt( ($u * $seg_sites) + ($v * $seg_sites*$seg_sites)); } =head2 fu_and_li_D_star Title : fu_and_li_D_star Usage : my $D = $statistics->fu_an_li_D_star(\@individuals); Function: Fu and Li's D* statistic for a set of samples Without an outgroup Returns : decimal number Args : array ref of L objects OR L object =cut #' # fu_and_li_D* sub fu_and_li_D_star { my ($self,$individuals) = @_; my ($seg_sites,$n,$singletons); if( ref($individuals) =~ /ARRAY/i ) { $n = scalar @$individuals; $seg_sites = $self->segregating_sites_count($individuals); $singletons = $self->singleton_count($individuals); } elsif( ref($individuals) && $individuals->isa('Bio::PopGen::PopulationI')) { my $pop = $individuals; $n = $pop->get_number_individuals; $seg_sites = $self->segregating_sites_count($pop); $singletons = $self->singleton_count($pop); } else { $self->throw("expected an array reference of a list of Bio::PopGen::IndividualI OR a Bio::PopGen::PopulationI object to fu_and_li_D_star"); return 0; } return $self->fu_and_li_D_star_counts($n,$seg_sites, $singletons); } =head2 fu_and_li_D_star_counts Title : fu_li_D_star_counts Usage : my $D = $statistics->fu_and_li_D_star_counts($samps,$sites, $singletons); Function: Fu and Li D statistic for the raw counts of the number of samples, sites, external and internal mutations Returns : decimal number Args : number of samples (N) number of segregating sites (n) singletons (n_s) =cut sub fu_and_li_D_star_counts { my ($self,$n,$seg_sites, $singletons) = @_; my $a_n; for(my $k = 1; $k < $n; $k++ ) { $a_n += ( 1 / $k ); } my $a1 = $a_n + 1 / $n; my $b = 0; for(my $k= 1; $k < $n; $k++ ) { $b += ( 1 / $k**2 ); } my $c = 2 * ( ( ( $n * $a_n ) - (2 * ( $n -1 ))) / ( ( $n - 1) * ( $n - 2 ) ) ); my $d = $c + ($n -2) / ($n - 1)**2 + 2 / ($n -1) * ( 1.5 - ( (2*$a1 - 3) / ($n -2) ) - 1 / $n ); my $v_star = ( ( ($n/($n-1) )**2)*$b + (($a_n**2)*$d) - (2*( ($n*$a_n*($a_n+1)) )/(($n-1)**2)) ) / (($a_n**2) + $b); my $u_star = ( ($n/($n-1))* ($a_n - ($n/ ($n-1)))) - $v_star; return (($n / ($n - 1)) * $seg_sites - $a_n * $singletons) / sqrt( ($u_star * $seg_sites) + ($v_star * $seg_sites*$seg_sites)); } =head2 fu_and_li_F Title : fu_and_li_F Usage : my $F = Bio::PopGen::Statistics->fu_and_li_F(\@ingroup,$ext_muts); Function: Calculate Fu and Li's F on an ingroup with either the set of outgroup individuals, or the number of external mutations Returns : decimal number Args : array ref of L objects for the ingroup OR a L object number of external mutations OR list of individuals for the outgroup =cut #' sub fu_and_li_F { my ($self,$ingroup,$outgroup) = @_; my ($seg_sites,$pi,$n,$external,$internal); if( ref($ingroup) =~ /ARRAY/i ) { $n = scalar @$ingroup; # pi - all pairwise differences $pi = $self->pi($ingroup); $seg_sites = $self->segregating_sites_count($ingroup); } elsif( ref($ingroup) && $ingroup->isa('Bio::PopGen::PopulationI')) { $n = $ingroup->get_number_individuals; $pi = $self->pi($ingroup); $seg_sites = $self->segregating_sites_count($ingroup); } else { $self->throw("expected an array reference of a list of Bio::PopGen::IndividualI OR a Bio::PopGen::PopulationI object to Fu and Li's F"); return 0; } if( ! defined $outgroup ) { $self->warn("Need to provide either an array ref to the outgroup individuals or the number of external mutations"); return 0; } elsif( ref($outgroup) ) { ($external,$internal) = $self->derived_mutations($ingroup,$outgroup); } else { $external = $outgroup; } $self->fu_and_li_F_counts($n,$pi,$seg_sites,$external); } =head2 fu_and_li_F_counts Title : fu_li_F_counts Usage : my $F = $statistics->fu_and_li_F_counts($samps,$pi, $sites, $external); Function: Fu and Li F statistic for the raw counts of the number of samples, sites, external and internal mutations Returns : decimal number Args : number of samples (N) average pairwise differences (pi) number of segregating sites (n) external mutations (n_e) =cut sub fu_and_li_F_counts { my ($self,$n,$pi,$seg_sites, $external) = @_; my $a_n = 0; for(my $k= 1; $k < $n; $k++ ) { $a_n += ( 1 / $k ); } my $a1 = $a_n + (1 / $n ); my $b = 0; for(my $k= 1; $k < $n; $k++ ) { $b += ( 1 / $k**2 ); } my $c = 2 * ( ( ( $n * $a_n ) - (2 * ( $n -1 ))) / ( ( $n - 1) * ( $n - 2 ) ) ); my $v_F = ( $c + ( (2*(($n**2)+$n+3)) / ( (9*$n)*($n-1) ) ) - (2/($n-1)) ) / ( ($a_n**2)+$b ); my $u_F = ( 1 + ( ($n+1)/(3*($n-1)) )- ( 4*( ($n+1)/(($n-1)**2) ))* ($a1 - ((2*$n)/($n+1))) ) / $a_n - $v_F; # warn("$v_F vf $u_F uf n = $n\n"); my $F = ($pi - $external) / ( sqrt( ($u_F*$seg_sites) + ($v_F*($seg_sites**2)) ) ); return $F; } =head2 fu_and_li_F_star Title : fu_and_li_F_star Usage : my $F = Bio::PopGen::Statistics->fu_and_li_F_star(\@ingroup); Function: Calculate Fu and Li's F* on an ingroup without an outgroup It uses count of singleton alleles instead Returns : decimal number Args : array ref of L objects for the ingroup OR L object =cut #' keep my emacs happy sub fu_and_li_F_star { my ($self,$individuals) = @_; my ($seg_sites,$pi,$n,$singletons); if( ref($individuals) =~ /ARRAY/i ) { $n = scalar @$individuals; # pi - all pairwise differences $pi = $self->pi($individuals); $seg_sites = $self->segregating_sites_count($individuals); $singletons = $self->singleton_count($individuals); } elsif( ref($individuals) && $individuals->isa('Bio::PopGen::PopulationI')) { my $pop = $individuals; $n = $pop->get_number_individuals; $pi = $self->pi($pop); $seg_sites = $self->segregating_sites_count($pop); $singletons = $self->singleton_count($pop); } else { $self->throw("expected an array reference of a list of Bio::PopGen::IndividualI OR a Bio::PopGen::PopulationI object to fu_and_li_F_star"); return 0; } return $self->fu_and_li_F_star_counts($n, $pi, $seg_sites, $singletons); } =head2 fu_and_li_F_star_counts Title : fu_li_F_star_counts Usage : my $F = $statistics->fu_and_li_F_star_counts($samps, $pi,$sites, $singletons); Function: Fu and Li F statistic for the raw counts of the number of samples, sites, external and internal mutations Returns : decimal number Args : number of samples (N) average pairwise differences (pi) number of segregating sites (n) singleton mutations (n_s) =cut sub fu_and_li_F_star_counts { my ($self,$n,$pi,$seg_sites, $singletons) = @_; if( $n <= 1 ) { $self->warn("N must be > 1\n"); return; } if( $n == 2) { return 0; } my $a_n = 0; my $b = 0; for(my $k= 1; $k < $n; $k++ ) { $b += (1 / ($k**2)); $a_n += ( 1 / $k ); # Eq (2) } my $a1 = $a_n + (1 / $n ); # warn("a_n is $a_n a1 is $a1 n is $n b is $b\n"); # From Simonsen et al (1995) instead of Fu and Li 1993 my $v_F_star = ( (( 2 * $n ** 3 + 110 * $n**2 - (255 * $n) + 153)/ (9 * ($n ** 2) * ( $n - 1))) + ((2 * ($n - 1) * $a_n ) / $n ** 2) - (8 * $b / $n) ) / ( ($a_n ** 2) + $b ); my $u_F_star = ((( (4* ($n**2)) + (19 * $n) + 3 - (12 * ($n + 1)* $a1)) / (3 * $n * ( $n - 1))) / $a_n) - $v_F_star; # warn("vf* = $v_F_star uf* = $u_F_star n = $n\n"); my $F_star = ( $pi - ($singletons*( ( $n-1) / $n)) ) / sqrt ( $u_F_star*$seg_sites + $v_F_star*$seg_sites**2); return $F_star; } =head2 tajima_D Title : tajima_D Usage : my $D = Bio::PopGen::Statistics->tajima_D(\@samples); Function: Calculate Tajima's D on a set of samples Returns : decimal number Args : array ref of L objects OR L object =cut #' sub tajima_D { my ($self,$individuals) = @_; my ($seg_sites,$pi,$n); if( ref($individuals) =~ /ARRAY/i ) { $n = scalar @$individuals; # pi - all pairwise differences $pi = $self->pi($individuals); $seg_sites = $self->segregating_sites_count($individuals); } elsif( ref($individuals) && $individuals->isa('Bio::PopGen::PopulationI')) { my $pop = $individuals; $n = $pop->get_number_individuals; $pi = $self->pi($pop); $seg_sites = $self->segregating_sites_count($pop); } else { $self->throw("expected an array reference of a list of Bio::PopGen::IndividualI OR a Bio::PopGen::PopulationI object to tajima_D"); return 0; } $self->tajima_D_counts($n,$seg_sites,$pi); } =head2 tajima_D_counts Title : tajima_D_counts Usage : my $D = $statistics->tajima_D_counts($samps,$sites,$pi); Function: Tajima's D statistic for the raw counts of the number of samples, sites, and avg pairwise distances (pi) Returns : decimal number Args : number of samples (N) number of segregating sites (n) average pairwise differences (pi) =cut #' sub tajima_D_counts { my ($self,$n,$seg_sites,$pi) = @_; my $a1 = 0; for(my $k= 1; $k < $n; $k++ ) { $a1 += ( 1 / $k ); } my $a2 = 0; for(my $k= 1; $k < $n; $k++ ) { $a2 += ( 1 / $k**2 ); } my $b1 = ( $n + 1 ) / ( 3* ( $n - 1) ); my $b2 = ( 2 * ( $n ** 2 + $n + 3) ) / ( ( 9 * $n) * ( $n - 1) ); my $c1 = $b1 - ( 1 / $a1 ); my $c2 = $b2 - ( ( $n + 2 ) / ( $a1 * $n))+( $a2 / $a1 ** 2); my $e1 = $c1 / $a1; my $e2 = $c2 / ( $a1**2 + $a2 ); my $denom = sqrt ( ($e1 * $seg_sites) + (( $e2 * $seg_sites) * ( $seg_sites - 1))); return if $denom == 0; my $D = ( $pi - ( $seg_sites / $a1 ) ) / $denom; return $D; } =head2 pi Title : pi Usage : my $pi = Bio::PopGen::Statistics->pi(\@inds) Function: Calculate pi (average number of pairwise differences) given a list of individuals which have the same number of markers (also called sites) as available from the get_Genotypes() call in L Returns : decimal number Args : Arg1= array ref of L objects which have markers/mutations. We expect all individuals to have a marker - we will deal with missing data as a special case. OR Arg1= L object. In the event that only allele frequency data is available, storing it in Population object will make this available. num sites [optional], an optional second argument (integer) which is the number of sites, then pi returned is pi/site. =cut sub pi { my ($self,$individuals,$numsites) = @_; my (%data,%marker_total,@marker_names,$n); if( ref($individuals) =~ /ARRAY/i ) { # one possible argument is an arrayref of Bio::PopGen::IndividualI objs @marker_names = $individuals->[0]->get_marker_names; $n = scalar @$individuals; # Here we are calculating the allele frequencies foreach my $ind ( @$individuals ) { if( ! $ind->isa('Bio::PopGen::IndividualI') ) { $self->warn("Expected an arrayref of Bio::PopGen::IndividualI objects, this is a ".ref($ind)."\n"); return 0; } foreach my $m ( @marker_names ) { foreach my $allele (map { $_->get_Alleles} $ind->get_Genotypes($m) ) { $data{$m}->{$allele}++; $marker_total{$m}++; } } } # while( my ($marker,$count) = each %marker_total ) { # foreach my $c ( values %{$data{$marker}} ) { # $c /= $count; # } # } # %data will contain allele frequencies for each marker, allele } elsif( ref($individuals) && $individuals->isa('Bio::PopGen::PopulationI') ) { my $pop = $individuals; $n = $pop->get_number_individuals; foreach my $marker( $pop->get_Markers ) { push @marker_names, $marker->name; #$data{$marker->name} = {$marker->get_Allele_Frequencies}; my @genotypes = $pop->get_Genotypes(-marker => $marker->name); for my $al ( map { $_->get_Alleles} @genotypes ) { $data{$marker->name}->{$al}++; $marker_total{$marker->name}++; } } } else { $self->throw("expected an array reference of a list of Bio::PopGen::IndividualI to pi"); } # based on Kevin Thornton's code: # http://molpopgen.org/software/libsequence/doc/html/PolySNP_8cc-source.html#l00152 # For now we assume that all individuals have the same markers my ($diffcount,$totalcompare) = (0,0); my $pi = 0; while ( my ($marker,$markerdat) = each %data ) { my $sampsize = $marker_total{$marker}; my $ssh = 0; my @alleles = keys %$markerdat; if ( $sampsize > 1 ) { my $denom = $sampsize * ($sampsize - 1.0); foreach my $al ( @alleles ) { $ssh += ($markerdat->{$al} * ($markerdat->{$al} - 1)) / $denom; } $pi += 1.0 - $ssh; } } $self->debug( "pi=$pi\n"); if( $numsites ) { return $pi / $numsites; } else { return $pi; } } =head2 theta Title : theta Usage : my $theta = Bio::PopGen::Statistics->theta($sampsize,$segsites); Function: Calculates Watterson's theta from the sample size and the number of segregating sites. Providing the third parameter, total number of sites will return theta per site. This is also known as K-hat = K / a_n Returns : decimal number Args : sample size (integer), num segregating sites (integer) total sites (integer) [optional] (to calculate theta per site) OR provide an arrayref of the L objects total sites (integer) [optional] (to calculate theta per site) OR provide an L object total sites (integer)[optional] =cut #' sub theta { my $self = shift; my ( $n, $seg_sites,$totalsites) = @_; if( ref($n) =~ /ARRAY/i ) { my $samps = $n; $totalsites = $seg_sites; # only 2 arguments if one is an array my %data; my @marker_names = $samps->[0]->get_marker_names; # we need to calculate number of polymorphic sites $seg_sites = $self->segregating_sites_count($samps); $n = scalar @$samps; } elsif(ref($n) && $n->isa('Bio::PopGen::PopulationI') ) { # This will handle the case when we pass in a PopulationI object my $pop = $n; $totalsites = $seg_sites; # shift the arguments over by one $n = $pop->haploid_population->get_number_individuals; $seg_sites = $self->segregating_sites_count($pop); } my $a1 = 0; for(my $k= 1; $k < $n; $k++ ) { $a1 += ( 1 / $k ); } if( $totalsites ) { # 0 and undef are the same can't divide by them $seg_sites /= $totalsites; } if( $a1 == 0 ) { return 0; } return $seg_sites / $a1; } =head2 singleton_count Title : singleton_count Usage : my ($singletons) = Bio::PopGen::Statistics->singleton_count(\@inds) Function: Calculate the number of mutations/alleles which only occur once in a list of individuals for all sites/markers Returns : (integer) number of alleles which only occur once (integer) Args : arrayref of L objects OR L object =cut sub singleton_count { my ($self,$individuals) = @_; my @inds; if( ref($individuals) =~ /ARRAY/ ) { @inds = @$individuals; } elsif( ref($individuals) && $individuals->isa('Bio::PopGen::PopulationI') ) { my $pop = $individuals; @inds = $pop->get_Individuals(); unless( @inds ) { $self->warn("Need to provide a population which has individuals loaded, not just a population with allele frequencies"); return 0; } } else { $self->warn("Expected either a PopulationI object or an arrayref of IndividualI objects"); return 0; } # find number of sites where a particular allele is only seen once my ($singleton_allele_ct,%sites) = (0); # first collect all the alleles into a hash structure foreach my $n ( @inds ) { if( ! $n->isa('Bio::PopGen::IndividualI') ) { $self->warn("Expected an arrayref of Bio::PopGen::IndividualI objects, this is a ".ref($n)."\n"); return 0; } foreach my $g ( $n->get_Genotypes ) { my ($nm,@alleles) = ($g->marker_name, $g->get_Alleles); foreach my $allele (@alleles ) { $sites{$nm}->{$allele}++; } } } foreach my $site ( values %sites ) { # don't really care what the name is foreach my $allelect ( values %$site ) { # # find the sites which have an allele with only 1 copy $singleton_allele_ct++ if( $allelect == 1 ); } } return $singleton_allele_ct; } # Yes I know that singleton_count and segregating_sites_count are # basically processing the same data so calling them both is # redundant, something I want to fix later but want to make things # correct and simple first =head2 segregating_sites_count Title : segregating_sites_count Usage : my $segsites = Bio::PopGen::Statistics->segregating_sites_count Function: Gets the number of segregating sites (number of polymorphic sites) Returns : (integer) number of segregating sites Args : arrayref of L objects OR L object =cut # perhaps we'll change this in the future # to return the actual segregating sites # so one can use this to pull in the names of those sites. # Would be trivial if it is useful. sub segregating_sites_count { my ($self,$individuals) = @_; my $type = ref($individuals); my $seg_sites = 0; if( $type =~ /ARRAY/i ) { my %sites; foreach my $n ( @$individuals ) { if( ! $n->isa('Bio::PopGen::IndividualI') ) { $self->warn("Expected an arrayref of Bio::PopGen::IndividualI objects, this is a ".ref($n)."\n"); return 0; } foreach my $g ( $n->get_Genotypes ) { my ($nm,@alleles) = ($g->marker_name, $g->get_Alleles); foreach my $allele (@alleles ) { $sites{$nm}->{$allele}++; } } } foreach my $site ( values %sites ) { # use values b/c we don't # really care what the name is # find the sites which >1 allele $seg_sites++ if( keys %$site > 1 ); } } elsif( $type && $individuals->isa('Bio::PopGen::PopulationI') ) { foreach my $marker ( $individuals->haploid_population->get_Markers ) { my @alleles = $marker->get_Alleles; $seg_sites++ if ( scalar @alleles > 1 ); } } else { $self->warn("segregating_sites_count expects either a PopulationI object or a list of IndividualI objects"); return 0; } return $seg_sites; } =head2 heterozygosity Title : heterozygosity Usage : my $het = Bio::PopGen::Statistics->heterozygosity($sampsize,$freq1); Function: Calculate the heterozgosity for a sample set for a set of alleles Returns : decimal number Args : sample size (integer) frequency of one allele (fraction - must be less than 1) [optional] frequency of another allele - this is only needed in a non-binary allele system Note : p^2 + 2pq + q^2 =cut sub heterozygosity { my ($self,$samp_size, $freq1,$freq2) = @_; if( ! $freq2 ) { $freq2 = 1 - $freq1 } if( $freq1 > 1 || $freq2 > 1 ) { $self->warn("heterozygosity expects frequencies to be less than 1"); } my $sum = ($freq1**2) + (($freq2)**2); my $h = ( $samp_size*(1- $sum) ) / ($samp_size - 1) ; return $h; } =head2 derived_mutations Title : derived_mutations Usage : my $ext = Bio::PopGen::Statistics->derived_mutations($ingroup,$outgroup); Function: Calculate the number of alleles or (mutations) which are ancestral and the number which are derived (occurred only on the tips) Returns : array of 2 items - number of external and internal derived mutation Args : ingroup - Ls arrayref OR L outgroup- Ls arrayref OR L OR a single L =cut sub derived_mutations { my ($self,$ingroup,$outgroup) = @_; my (%indata,%outdata,@marker_names); # basically we have to do some type checking # if that perl were typed... my ($itype,$otype) = (ref($ingroup),ref($outgroup)); return $outgroup unless( $otype ); # we expect arrayrefs or objects, nums # are already the value we # are searching for # pick apart the ingroup # get the data if( ref($ingroup) =~ /ARRAY/i ) { if( ! ref($ingroup->[0]) || ! $ingroup->[0]->isa('Bio::PopGen::IndividualI') ) { $self->warn("Expected an arrayref of Bio::PopGen::IndividualI objects or a Population for ingroup in external_mutations"); return 0; } # we assume that all individuals have the same markers # i.e. that they are aligned @marker_names = $ingroup->[0]->get_marker_names; for my $ind ( @$ingroup ) { for my $m ( @marker_names ) { for my $allele ( map { $_->get_Alleles } $ind->get_Genotypes($m) ) { $indata{$m}->{$allele}++; } } } } elsif( ref($ingroup) && $ingroup->isa('Bio::PopGen::PopulationI') ) { @marker_names = $ingroup->get_marker_names; for my $ind ( $ingroup->haploid_population->get_Individuals() ) { for my $m ( @marker_names ) { for my $allele ( map { $_->get_Alleles} $ind->get_Genotypes($m) ) { $indata{$m}->{$allele}++; } } } } else { $self->warn("Need an arrayref of Bio::PopGen::IndividualI objs or a Bio::PopGen::Population for ingroup in external_mutations"); return 0; } if( $otype =~ /ARRAY/i ) { if( ! ref($outgroup->[0]) || ! $outgroup->[0]->isa('Bio::PopGen::IndividualI') ) { $self->warn("Expected an arrayref of Bio::PopGen::IndividualI objects or a Population for outgroup in external_mutations"); return 0; } for my $ind ( @$outgroup ) { for my $m ( @marker_names ) { for my $allele ( map { $_->get_Alleles } $ind->get_Genotypes($m) ) { $outdata{$m}->{$allele}++; } } } } elsif( $otype->isa('Bio::PopGen::PopulationI') ) { for my $ind ( $outgroup->haploid_population->get_Individuals() ) { for my $m ( @marker_names ) { for my $allele ( map { $_->get_Alleles} $ind->get_Genotypes($m) ) { $outdata{$m}->{$allele}++; } } } } else { $self->warn("Need an arrayref of Bio::PopGen::IndividualI objs or a Bio::PopGen::Population for outgroup in external_mutations"); return 0; } # derived mutations are defined as # # ingroup (G A T) # outgroup (A) # derived mutations are G and T, A is the external mutation # ingroup (A T) # outgroup (C) # derived mutations A,T no external/ancestral mutations # ingroup (G A T) # outgroup (A T) # cannot determine my ($internal,$external); foreach my $marker ( @marker_names ) { my @outalleles = keys %{$outdata{$marker}}; my @in_alleles = keys %{$indata{$marker}}; next if( @outalleles > 1 || @in_alleles == 1); for my $allele ( @in_alleles ) { if( ! exists $outdata{$marker}->{$allele} ) { if( $indata{$marker}->{$allele} == 1 ) { $external++; } else { $internal++; } } } } return ($external, $internal); } =head2 composite_LD Title : composite_LD Usage : %matrix = Bio::PopGen::Statistics->composite_LD($population); Function: Calculate the Linkage Disequilibrium This is for calculating LD for unphased data. Other methods will be appropriate for phased haplotype data. Returns : Hash of Hashes - first key is site 1,second key is site 2 and value is LD for those two sites. my $LDarrayref = $matrix{$site1}->{$site2}; my ($ldval, $chisquared) = @$LDarrayref; Args : L or arrayref of Ls Reference: Weir B.S. (1996) "Genetic Data Analysis II", Sinauer, Sunderlanm MA. =cut sub composite_LD { my ($self,$pop) = @_; if( ref($pop) =~ /ARRAY/i ) { if( ref($pop->[0]) && $pop->[0]->isa('Bio::PopGen::IndividualI') ) { $pop = Bio::PopGen::Population->new(-individuals => @$pop); } else { $self->warn("composite_LD expects a Bio::PopGen::PopulationI or an arrayref of Bio::PopGen::IndividualI objects"); return (); } } elsif( ! ref($pop) || ! $pop->isa('Bio::PopGen::PopulationI') ) { $self->warn("composite_LD expects a Bio::PopGen::PopulationI or an arrayref of Bio::PopGen::IndividualI objects"); return (); } my @marker_names = $pop->get_marker_names; my @inds = $pop->get_Individuals; my $num_inds = scalar @inds; my (%lookup); # calculate allele frequencies for each marker from the population # use the built-in get_Marker to get the allele freqs # we still need to calculate the genotype frequencies foreach my $marker_name ( @marker_names ) { my(%allelef); foreach my $ind ( @inds ) { my ($genotype) = $ind->get_Genotypes(-marker => $marker_name); if( ! defined $genotype ) { $self->warn("no genotype for marker $marker_name for individual ". $ind->unique_id. "\n"); next; } my @alleles = sort $genotype->get_Alleles; next if( scalar @alleles != 2); my $genostr = join(',', @alleles); $allelef{$alleles[0]}++; $allelef{$alleles[1]}++; } # we should check for cases where there > 2 alleles or # only 1 allele and throw out those markers. my @alleles = sort keys %allelef; my $allele_count = scalar @alleles; # test if site is polymorphic if( $allele_count != 2) { # only really warn if we're seeing multi-allele $self->warn("Skipping $marker_name because it has $allele_count alleles (".join(',',@alleles)."), \ncomposite_LD will currently only work for biallelic markers") if $allele_count > 2; next; # skip this marker } # Need to do something here to detect alleles which aren't # a single character if( length($alleles[0]) != 1 || length($alleles[1]) != 1 ) { $self->warn("An individual has an allele which is not a single base, this is currently not supported in composite_LD - consider recoding the allele as a single character"); next; } # fix the call for allele 1 (A or B) and # allele 2 (a or b) in terms of how we'll do the # N square from Weir p.126 $self->debug( "$alleles[0] is 1, $alleles[1] is 2 for $marker_name\n"); $lookup{$marker_name}->{'1'} = $alleles[0]; $lookup{$marker_name}->{'2'} = $alleles[1]; } @marker_names = sort keys %lookup; my $site_count = scalar @marker_names; # where the final data will be stored my %stats_for_sites; # standard way of generating pairwise combos # LD is done by comparing all the pairwise site (marker) # combinations and keeping track of the genotype and # pairwise genotype (ie genotypes of the 2 sites) frequencies for( my $i = 0; $i < $site_count - 1; $i++ ) { my $site1 = $marker_names[$i]; for( my $j = $i+1; $j < $site_count ; $j++) { my (%genotypes, %total_genotype_count,$total_pairwisegeno_count, %pairwise_genotypes); my $site2 = $marker_names[$j]; my (%allele_count,%allele_freqs) = (0,0); foreach my $ind ( @inds ) { # build string of genotype at site 1 my ($genotype1) = $ind->get_Genotypes(-marker => $site1); my @alleles1 = sort $genotype1->get_Alleles; # if an individual has only one available allele # (has a blank or N for one of the chromosomes) # we don't want to use it in our calculation next unless( scalar @alleles1 == 2); my $genostr1 = join(',', @alleles1); # build string of genotype at site 2 my ($genotype2) = $ind->get_Genotypes(-marker => $site2); my @alleles2 = sort $genotype2->get_Alleles; my $genostr2 = join(',', @alleles2); next unless( scalar @alleles2 == 2); for (@alleles1) { $allele_count{$site1}++; $allele_freqs{$site1}->{$_}++; } $genotypes{$site1}->{$genostr1}++; $total_genotype_count{$site1}++; for (@alleles2) { $allele_count{$site2}++; $allele_freqs{$site2}->{$_}++; } $genotypes{$site2}->{$genostr2}++; $total_genotype_count{$site2}++; # We are using the $site1,$site2 to signify # a unique key $pairwise_genotypes{"$genostr1,$genostr2"}++; # some individuals $total_pairwisegeno_count++; } for my $site ( %allele_freqs ) { for my $al ( keys %{ $allele_freqs{$site} } ) { $allele_freqs{$site}->{$al} /= $allele_count{$site}; } } my $n = $total_pairwisegeno_count; # number of pairs of comparisons # 'A' and 'B' are two loci or in our case site1 and site2 my $allele1_site1 = $lookup{$site1}->{'1'}; # this is the BigA allele my $allele1_site2 = $lookup{$site2}->{'1'}; # this is the BigB allele my $allele2_site1 = $lookup{$site1}->{'2'}; # this is the LittleA allele my $allele2_site2 = $lookup{$site2}->{'2'}; # this is the LittleB allele # AABB my $N1genostr = join(",",( $allele1_site1, $allele1_site1, $allele1_site2, $allele1_site2)); $self->debug(" [$site1,$site2](AABB) N1genostr=$N1genostr\n"); # AABb my $N2genostr = join(",",( $allele1_site1, $allele1_site1, $allele1_site2, $allele2_site2)); $self->debug(" [$site1,$site2](AABb) N2genostr=$N2genostr\n"); # AaBB my $N4genostr = join(",",( $allele1_site1, $allele2_site1, $allele1_site2, $allele1_site2)); $self->debug(" [$site1,$site2](AaBB) N4genostr=$N4genostr\n"); # AaBb my $N5genostr = join(",",( $allele1_site1, $allele2_site1, $allele1_site2, $allele2_site2)); $self->debug(" [$site1,$site2](AaBb) N5genostr=$N5genostr\n"); # count of AABB in my $n1 = $pairwise_genotypes{$N1genostr} || 0; # count of AABb in my $n2 = $pairwise_genotypes{$N2genostr} || 0; # count of AaBB in my $n4 = $pairwise_genotypes{$N4genostr} || 0; # count of AaBb in my $n5 = $pairwise_genotypes{$N5genostr} || 0; my $homozA_site1 = join(",", ($allele1_site1,$allele1_site1)); my $homozB_site2 = join(",", ($allele1_site2,$allele1_site2)); my $p_AA = ($genotypes{$site1}->{$homozA_site1} || 0) / $n; my $p_BB = ($genotypes{$site2}->{$homozB_site2} || 0) / $n; my $p_A = $allele_freqs{$site1}->{$allele1_site1} || 0; # an individual allele freq my $p_a = 1 - $p_A; my $p_B = $allele_freqs{$site2}->{$allele1_site2} || 0; # an individual allele freq my $p_b = 1 - $p_B; # variance of allele frequencies my $pi_A = $p_A * $p_a; my $pi_B = $p_B * $p_b; # hardy weinberg my $D_A = $p_AA - $p_A**2; my $D_B = $p_BB - $p_B**2; my $n_AB = 2*$n1 + $n2 + $n4 + 0.5 * $n5; $self->debug("n_AB=$n_AB -- n1=$n1, n2=$n2 n4=$n4 n5=$n5\n"); my $delta_AB = (1 / $n ) * ( $n_AB ) - ( 2 * $p_A * $p_B ); $self->debug("delta_AB=$delta_AB -- n=$n, n_AB=$n_AB p_A=$p_A, p_B=$p_B\n"); $self->debug(sprintf(" (%d * %.4f) / ( %.2f + %.2f) * ( %.2f + %.2f) \n", $n,$delta_AB**2, $pi_A, $D_A, $pi_B, $D_B)); my $chisquared; eval { $chisquared = ( $n * ($delta_AB**2) ) / ( ( $pi_A + $D_A) * ( $pi_B + $D_B) ); }; if( $@ ) { $self->debug("Skipping the site because the denom is 0.\nsite1=$site1, site2=$site2 : pi_A=$pi_A, pi_B=$pi_B D_A=$D_A, D_B=$D_B\n"); next; } # this will be an upper triangular matrix $stats_for_sites{$site1}->{$site2} = [$delta_AB,$chisquared]; } } return %stats_for_sites; } =head2 mcdonald_kreitman Title : mcdonald_kreitman Usage : $Fstat = mcdonald_kreitman($ingroup, $outgroup); Function: Calculates McDonald-Kreitman statistic based on a set of ingroup individuals and an outgroup by computing the number of differences at synonymous and non-synonymous sites for intraspecific comparisons and with the outgroup Returns : 2x2 table, followed by a hash reference indicating any warning messages about the status of the alleles or codons Args : -ingroup => L object or arrayref of Ls -outgroup => L object or arrayef of Ls -polarized => Boolean, to indicate if this should be a polarized test. Must provide two individuals as outgroups. =cut sub mcdonald_kreitman { my ($self,@args) = @_; my ($ingroup, $outgroup,$polarized) = $self->_rearrange([qw(INGROUP OUTGROUP POLARIZED)],@args); my $verbose = $self->verbose; my $outgroup_count; my $gapchar = '\-'; if( ref($outgroup) =~ /ARRAY/i ) { $outgroup_count = scalar @$outgroup; } elsif( UNIVERSAL::isa($outgroup,'Bio::PopGen::PopulationI') ) { $outgroup_count = $outgroup->get_number_individuals; } else { $self->throw("Expected an ArrayRef of Individuals OR a Bio::PopGen::PopulationI"); } if( $polarized ) { if( $outgroup_count < 2 ) { $self->throw("Need 2 outgroups with polarized option\n"); } } elsif( $outgroup_count > 1 ) { $self->warn(sprintf("%s outgroup sequences provided, but only first will be used",$outgroup_count )); } elsif( $outgroup_count == 0 ) { $self->throw("No outgroup sequence provided"); } my $codon_path = Bio::MolEvol::CodonModel->codon_path; my (%marker_names,%unique,@inds); for my $p ( $ingroup, $outgroup) { if( ref($p) =~ /ARRAY/i ) { push @inds, @$p; } else { push @inds, $p->get_Individuals; } } for my $i ( @inds ) { if( $unique{$i->unique_id}++ ) { $self->warn("Individual ". $i->unique_id. " is seen more than once in the ingroup or outgroup set\n"); } for my $n ( $i->get_marker_names ) { $marker_names{$n}++; } } my @marker_names = keys %marker_names; if( $marker_names[0] =~ /^(Site|Codon)/ ) { # sort by site or codon number and do it in # a schwartzian transformation baby! @marker_names = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [$_ =~ /^(?:Codon|Site)-(\d+)/, $_] } @marker_names; } my $num_inds = scalar @inds; my %vals = ( 'ingroup' => $ingroup, 'outgroup' => $outgroup, ); # Make the Codon Table type a parameter! my $table = Bio::Tools::CodonTable->new(-id => $codon_table); my @vt = qw(outgroup ingroup); my %changes; my %status; my %two_by_two = ( 'fixed_N' => 0, 'fixed_S' => 0, 'poly_N' => 0, 'poly_S' => 0); for my $codon ( @marker_names ) { my (%codonvals); my %all_alleles; for my $t ( @vt ) { my $outcount = 1; for my $ind ( @{$vals{$t}} ) { my @alleles = $ind->get_Genotypes($codon)->get_Alleles; if( @alleles > 2 ) { warn("Codon $codon saw ", scalar @alleles, " alleles for ind ", $ind->unique_id, "\n"); die; } else { my ($allele) = shift @alleles; $all_alleles{$ind->unique_id} = $allele; my $AA = $table->translate($allele); next if( $AA eq 'X' || $AA eq '*' || $allele =~ /N/i); my $label = $t; if( $t eq 'outgroup' ) { $label = $t.$outcount++; } $codonvals{$label}->{$allele}++; $codonvals{all}->{$allele}++; } } } my $total = sum ( values %{$codonvals{'ingroup'}} ); next if( $total && $total < 2 ); # skip sites with < alleles # process all the seen alleles (codons) # this is a vertical slide through the alignment if( keys %{$codonvals{all}} <= 1 ) { # no changes or no VALID codons - monomorphic } else { # grab only the first outgroup codon (what to do with rest?) my ($outcodon) = keys %{$codonvals{'outgroup1'}}; if( ! $outcodon ) { $status{"no outgroup codon $codon"}++; next; } my $out_AA = $table->translate($outcodon); my ($outcodon2) = keys %{$codonvals{'outgroup2'}}; if( ($polarized && ($outcodon ne $outcodon2)) || $out_AA eq 'X' || $out_AA eq '*' ) { # skip if outgroup codons are different # (when polarized option is on) # or skip if the outcodon is STOP or 'NNN' if( $verbose > 0 ) { $self->debug("skipping $out_AA and $outcodon $outcodon2\n"); } $status{'outgroup codons different'}++; next; } # check if ingroup is actually different from outgroup - # if there are the same number of alleles when considering # ALL or just the ingroup, then there is nothing new seen # in the outgroup so it must be a shared allele (codon) # so we just count how many total alleles were seen # if this is the same as the number of alleles seen for just # the ingroup then the outgroup presents no new information my @ingroup_codons = keys %{$codonvals{'ingroup'}}; my $diff_from_out = ! exists $codonvals{'ingroup'}->{$outcodon}; if( $verbose > 0 ) { $self->debug("alleles are in: ", join(",", @ingroup_codons), " out: ", join(",", keys %{$codonvals{outgroup1}}), " diff_from_out=$diff_from_out\n"); for my $ind ( sort keys %all_alleles ) { $self->debug( "$ind\t$all_alleles{$ind}\n"); } } # are all the ingroup alleles the same and diferent from outgroup? # fixed differences between species if( $diff_from_out ) { if( scalar @ingroup_codons == 1 ) { # fixed differences if( $outcodon =~ /^$gapchar/ ) { $status{'outgroup codons with gaps'}++; next; } elsif( $ingroup_codons[0] =~ /$gapchar/) { $status{'ingroup codons with gaps'}++; next; } my $path = $codon_path->{uc $ingroup_codons[0].$outcodon}; $two_by_two{fixed_N} += $path->[0]; $two_by_two{fixed_S} += $path->[1]; if( $verbose > 0 ) { $self->debug("ingroup is @ingroup_codons outcodon is $outcodon\n"); $self->debug("path is ",join(",",@$path),"\n"); $self->debug (sprintf("%-15s fixeddiff - %s;%s(%s) %d,%d\tNfix=%d Sfix=%d Npoly=%d Spoly=%s\n",$codon,$ingroup_codons[0], $outcodon,$out_AA, @$path, map { $two_by_two{$_} } qw(fixed_N fixed_S poly_N poly_S))); } } else { # polymorphic and all are different from outgroup # Here we find the minimum number of NS subst my ($Ndiff,$Sdiff) = (3,0); # most different path for my $c ( @ingroup_codons ) { next if( $c =~ /$gapchar/ || $outcodon =~ /$gapchar/); my $path = $codon_path->{uc $c.$outcodon}; my ($tNdiff,$tSdiff) = @$path; if( $path->[0] < $Ndiff || ($tNdiff == $Ndiff && $tSdiff <= $Sdiff)) { ($Ndiff,$Sdiff) = ($tNdiff,$tSdiff); } } $two_by_two{fixed_N} += $Ndiff; $two_by_two{fixed_S} += $Sdiff; if( @ingroup_codons > 2 ) { $status{"more than 2 ingroup codons $codon"}++; warn("more than 2 ingroup codons (@ingroup_codons)\n"); } else { my $path = $codon_path->{uc join('',@ingroup_codons)}; $two_by_two{poly_N} += $path->[0]; $two_by_two{poly_S} += $path->[1]; if( $verbose > 0 ) { $self->debug(sprintf("%-15s polysite_all - %s;%s(%s) %d,%d\tNfix=%d Sfix=%d Npoly=%d Spoly=%s\n",$codon,join(',',@ingroup_codons), $outcodon,$out_AA,@$path, map { $two_by_two{$_} } qw(fixed_N fixed_S poly_N poly_S))); } } } } else { my %unq = map { $_ => 1 } @ingroup_codons; delete $unq{$outcodon}; my @unique_codons = keys %unq; # calc path for diff add to poly # Here we find the minimum number of subst bw # codons my ($Ndiff,$Sdiff) = (3,0); # most different path for my $c ( @unique_codons ) { my $path = $codon_path->{uc $c.$outcodon }; if( ! defined $path ) { die " cannot get path for ", $c.$outcodon, "\n"; } my ($tNdiff,$tSdiff) = @$path; if( $path->[0] < $Ndiff || ($tNdiff == $Ndiff && $tSdiff <= $Sdiff)) { ($Ndiff,$Sdiff) = ($tNdiff,$tSdiff); } } if( @unique_codons == 2 ) { my $path = $codon_path->{uc join('',@unique_codons)}; if( ! defined $path ) { $self->throw("no path for @unique_codons\n"); } $Ndiff += $path->[0]; $Sdiff += $path->[1]; } $two_by_two{poly_N} += $Ndiff; $two_by_two{poly_S} += $Sdiff; if( $verbose > 0 ) { $self->debug(sprintf("%-15s polysite - %s;%s(%s) %d,%d\tNfix=%d Sfix=%d Npoly=%d Spoly=%s\n",$codon,join(',',@ingroup_codons), $outcodon,$out_AA, $Ndiff, $Sdiff, map { $two_by_two{$_} } qw(fixed_N fixed_S poly_N poly_S))); } } } } return ( $two_by_two{'poly_N'}, $two_by_two{'fixed_N'}, $two_by_two{'poly_S'}, $two_by_two{'fixed_S'}, {%status}); } *MK = \&mcdonald_kreitman; =head2 mcdonald_kreitman_counts Title : mcdonald_kreitman_counts Usage : my $MK = $statistics->mcdonald_kreitman_counts( N_poly -> integer of count of non-syn polymorphism N_fix -> integer of count of non-syn fixed substitutions S_poly -> integer of count of syn polymorphism S_fix -> integer of count of syn fixed substitutions ); Function: Returns : decimal number Args : =cut sub mcdonald_kreitman_counts { my ($self,$Npoly,$Nfix,$Spoly,$Sfix) = @_; if( $has_twotailed ) { return &Text::NSP::Measures::2D::Fisher2::twotailed::calculateStatistic (n11=>$Npoly, n1p=>$Npoly+$Spoly, np1=>$Npoly+$Nfix, npp=>$Npoly+$Nfix+$Spoly+$Sfix); } else { $self->warn("cannot call mcdonald_kreitman_counts because no Fisher's exact is available - install Text::NSP::Measures::2D::Fisher2::twotailed"); return 0; } } 1; BioPerl-1.6.923/Bio/PopGen/TagHaplotype.pm000444000765000024 2451212254227330 20320 0ustar00cjfieldsstaff000000000000# module Bio::PopGen::TagHaplotype.pm # # Please direct questions and support issues to # # Cared for by Pedro M. Gomez-Fabre # # Copyright Pedro M. Gomez-Fabre # # You may distribute this module under the same term as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::PopGen::TagHaplotype.pm - Haplotype tag object. =head1 SYNOPSIS use Bio::PopGen::TagHaplotype; my $obj = Bio::PopGen::TagHaplotype -> new($hap); =head1 DESCRIPTION This module take as input a haplotype and try toe get the minimal set of SNP that define the haplotype. This module can be use alone. But due to the tagging haplotype process is exponential one. My suggestion is that before to use this module you pass your data under Select.mp module also on this folder. In any case if, you provide an haplotype the module will try to find the answer to your question. =head1 CONSTRUCTORS my $obj = Bio::PopGen::TagHaplotype -> new($hap); were $hap is the reference to an array of array with the haplotype. $hap= [[0, 0, 0], [1, 0, 0], [0, 1, 1] ]; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Pedro M. Gomez-Fabre Email pgf18872-at-gsk-dot-com =cut # Let the code begin... package Bio::PopGen::TagHaplotype; use strict; use Data::Dumper; use Storable qw(dclone); use base qw(Bio::Root::Root); my $USAGE = <new(-haplotype_block => \$hapblockref) EOF ; =head2 new Title : new Function: constructor of the class. Returns : self hash Args : input haplotype (array of array) Status : public =cut #------------------------ sub new{ #------------------------ my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($haplotype_block) = $self->_rearrange([qw(HAPLOTYPE_BLOCK)],@args); if ($haplotype_block) { $self->haplotype_block($haplotype_block); } else{ $self->throw("haplotype has not been supplied\n$USAGE"); } # check that the haplotype block is well formed. for (my $i=0; $i<$#$haplotype_block+1; $i++){ if ( $#{$haplotype_block->[0]} != $#{$haplotype_block->[$i]} ){ $self->throw("The haplotype matrix is not well formed (Not squared)"); } } # make the calculation my $tag_list = _scan_snp( $self ->haplotype_block ); if ($tag_list){ $self ->tag_list($tag_list); } else { $self ->tag_list(undef); } if ( defined $self->tag_list){ $self ->tag_length(scalar @{$self->tag_list}); } else { $self ->tag_length(0); #"NO TAGS FOUND!" } return $self; } =head2 haplotype_block Title : haplotype_block Usage : my $haplotype_block = $TagHaplotype->haplotype_block(); Function: Get the haplotype block for a haplotype tagging selection Returns : reference of array Args : reference of array with haplotype pattern =cut sub haplotype_block{ my ($self) =shift; return $self->{'_haplotype_block'} = shift if @_; return $self->{'_haplotype_block'}; } =head2 input_block Title : input_block Usage : $obj->input_block() Function: returns haplotype block. By now will produce the same output than $self->haplotype_block. but for compatiblity, this method is kept. This method is deprecated. Returns : reference to array of array with the haplotype input value Args : none Status : public =cut #------------------------ sub input_block{ #------------------------ my $self = shift; $self->warn(ref($self). "::input_block - deprecated method. Use haplotype_block() instead."); return $self->haplotype_block; } =head2 tag_list Title : tag_list Usage : $obj->tag_list() Function: returns the list of SNPs combination that identify the haplotype. All combinations are displayed as arrays Returns : reference to array of array. Args : none Status : public =cut #------------------------ sub tag_list{ #------------------------ my ($self) = shift; return $self->{'_tag_list'}= shift if @_; return $self->{'_tag_list'}; } =head2 tag_length Title : tag_length Usage : $obj->tag_length() Function: returns the length of the tag. Returns : scalar Args : none Status : public =cut #------------------------ sub tag_length{ #------------------------ my ($self) =shift; return $self ->{'_tag_length'} = shift if @_; return $self ->{'_tag_length'}; } =head2 _scan_snp Title : _scan_snp Usage : internal Function: scan sets increasing the length until find a non degenerated pattern. Returns : scalar Args : none Status : private =cut #------------------------ sub _scan_snp{ #------------------------ my ($hap)=@_; my $hap_length = scalar @{$hap->[0]}; ## store the haplotype length for my $i(1..$hap_length){ my $list = _gen_comb($hap_length, $i); my $snp_collection = _scan_combinations($hap, $list); # if there is any element on the collection. # We have reached our goal and # we can stop the calculation. if($#$snp_collection>-1){ return $snp_collection; } } } =head2 _gen_comb Title : _gen_comb Usage : internal Function: we supply the length of the haplotype and the length of the word we need to find and the functions returns the possible list of combinations. Returns : scalar Args : none Status : private =cut #------------------------ sub _gen_comb{ #------------------------ my ($hap_length,$n) = @_; my @array = (); # list with all elements we have to combine for(0..$hap_length-1){ push @array, $_ }; # # we need some parameters to create the combination list. # This parameters can be changed if we can modify the list values # my $m = -1; # this parameter start the calculation at value # m+1 on the recursive cicle. my $value = []; ## seems to have not too much sense here, but is ## needed on the recursion and need to be started ## from here my $list = []; _generateCombinations ( \@array, \$m, \$n, $value, $list); return $list; } =head2 _generateCombinations Title : _generateCombinations Usage : internal Function: Recursive function that produce all combinations for a set i.e.: 1, 2, 3, 4 and word of B<3> will produce: 1, 2, 3 1, 2, 4 1, 3, 4 2, 3, 4 Returns : Args : none Status : private =cut #------------------------ sub _generateCombinations{ #------------------------ my ($rarr, $rm, $rn, $rvalue,$rlist)=@_; for (my $i = ($$rm+1); $i[$i]); if (scalar @value2<$$rn){ _generateCombinations($rarr,\$i, $rn, \@value2, $rlist); } if (scalar @value2==$$rn){ push @$rlist, [@value2]; } if(scalar @value2>$$rn){ last; } } } # take the list of combinations # i.e.: 1 2 3 # 1 2 4 # 1 3 4 # 2 3 4 # # generate a sub array from the haplotype with the snp tag for the combination # and check all haplotypes for these columns. # if two haplotypes have the same value. we can not define the haplotype # without ambiguity. # Will return a list of valid combinations (SNP Tags) # =head2 _scan_combinations Title : _scan_combinations Usage : internal Function: take the haplotype and a list of possible combination for that length. Generate a subset and scan it to find if the information is enought to define the haplotype set. Returns : Args : none Status : private =cut #------------------------ sub _scan_combinations { #------------------------ my($hap,$list) = @_; my $valid_combination = undef; # we have to check every snp combinations from the list for my $i (0..$#$list){ # extract from the big array the one we will use for tag calculations my $subArray = _get_subArray ($hap, $list->[$i]); my $degeneration = _deg_test($subArray); if(!$degeneration){ push @$valid_combination, [@{$list->[$i]}]; } } return $valid_combination; } # return 1 if two arrays are degenerated (same haplotype) #------------------------ sub _deg_test{ #------------------------ my ($hap)= @_; # for every sub array we compare each element with the rest for my $c1(0..$#$hap){ for my $c2($c1+1..$#$hap){ my $degeneration = compare_arrays($hap->[$c1], $hap->[$c2]); if ($degeneration){ # if the two arrays are the same return 1; } } } } #------------------------ sub _get_subArray { #------------------------ my($hap, $combination) =@_; my $out = []; # output array to be tested for my $i (0..$#$hap){ foreach(@$combination){ push @{$out->[$i]}, $hap->[$i][$_]; } } return $out; } # # take two arrays and compare their values # Returns : 1 if the two values are the same # 0 if the values are different # #------------------------ sub compare_arrays { #------------------------ my ($first, $second) = @_; return 0 unless @$first == @$second; for (my $i = 0; $i < @$first; $i++) { return 0 if $first->[$i] ne $second->[$i]; } return 1; } 1; BioPerl-1.6.923/Bio/PopGen/Utilities.pm000444000765000024 2036312254227335 17677 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Utilities # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Utilities - Utilities for working with PopGen data and objects =head1 SYNOPSIS use Bio::PopGen::Utilities; use Bio::AlignIO; my $in = Bio::AlignIO->new(-file => 't/data/t7.aln', -format => 'clustalw'); my $aln = $in->next_aln; # get a population, each sequence is an individual and # for the default case, every site which is not monomorphic # is a 'marker'. Each individual will have a 'genotype' for the # site which will be the specific base in the alignment at that # site my $pop = Bio::PopGen::Utilities->aln_to_population(-alignment => $aln); # get the synonymous sites from the alignemt only as the 'genotypes' # for the population my $synpop = Bio::PopGen::Utilities->aln_to_population(-site_model => 'cod', -alignment => $aln); =head1 DESCRIPTION This object provides some convience function to turn sequence alignments into usable objects for the Population genetics modules (Bio::PopGen). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Utilities; use strict; use Bio::Align::DNAStatistics; use Bio::PopGen::Population; use Bio::PopGen::Individual; use base qw(Bio::Root::Root); use constant CodonLen => 3; =head2 aln_to_population Title : aln_to_population Usage : my $pop = Bio::PopGen::Utilities->aln_to_population($aln); Function: Turn and alignment into a set of L objects grouped in a L object Sites are treated as 'Markers' in the Bioperl PopGen object model in the sense that a site is a unique location for which an individual will have a genotype (a set of alleles). In this implementation we are assuming that each individual has a single entry in the alignment file. Specify a site model as one of those listed 'all' -- every base in the alignment is considered a site 'cod' -- codons The option -site_model for All sites : 'all' Codon sites : 'cod' or 'codon' To see all sites, including those which are fixed in the population add -include_monomorphic => 1 to the arguments Returns : Args : -include_monomorphic => 1 to specify all sites, even those which are monomorphic in the population (useful for HKA test mostly) [default is false] -phase => specify a phase for the data, this is only used if the site_mode is codon [default is 0] -site_model => one-of 'all', 'codon' to specify a site model for the data extraction from the alignment [default is all] -alignment => provide a L object [required] =cut sub aln_to_population{ my ($self,@args) = @_; my ($aln, $sitemodel,$phase, $includefixed,$checkisa) = $self->_rearrange([qw(ALIGNMENT SITE_MODEL PHASE INCLUDE_MONOMORPHIC CHECKISA)], @args); my %ambig_code = ('?' => ['?','?'], 'N' => ['?','?'], '-' => ['?','?'], 'G' => ['G','G'], 'A' => ['A','A'], 'T' => ['T','T'], 'C' => ['C','C'], 'R' => ['A','G'], 'Y' => ['C','T'], 'W' => ['T','A'], 'M' => ['C','A'], 'S' => ['C','G'], 'K' => ['G','T']); if( ! defined $aln ) { $self->warn("Must provide a valid Bio::SimpleAlign object to run aln_to_population"); return; } if( ! $aln->is_flush ) { $self->warn("Must provide a Bio::SimpleAlign object with aligned sequences to aln_to_population!"); return; } $phase = 0 unless defined $phase; if( $phase != 0 && $phase != 1 && $phase != 2 ) { warn("phase must be 0,1, or 2"); return; } my $alength = $aln->length; my @inds; if( ! defined $sitemodel || $sitemodel =~ /all/i ) { my $ct = 0; my @seqs; for my $seq ( $aln->each_seq ) { push @seqs, $seq->seq; push @inds, Bio::PopGen::Individual->new(-unique_id => $seq->display_id); } for( my $i = 0; $i < $alength; $i++ ) { my (@genotypes,%set); # do we skip indels? # slicing vertically for my $seq ( @seqs ) { my $site = uc(substr($seq,$i,1)); push @genotypes, $ambig_code{$site}; $set{$site}++; } if( keys %set > 1 || $includefixed ) { my $genoct = scalar @genotypes; for( my $j = 0; $j < $genoct; $j++ ) { $inds[$j]->add_Genotype(Bio::PopGen::Genotype->new (-marker_name => ($i+1), -individual_id=> $inds[$j]->unique_id, -alleles => $genotypes[$j])); } } } } elsif( $sitemodel =~ /cod(on)?/i ) { my $ct = 0; my @seqs; for my $seq ( $aln->each_seq ) { push @seqs, $seq->seq; push @inds, Bio::PopGen::Individual->new(-unique_id => $seq->display_id); } my $codonct = 0; for( my $i = $phase; $i < $alength; $i += CodonLen ) { my (@genotypes,%set,$genoct); for my $seq ( @seqs ) { my @unambig_site; my $site = uc(substr($seq,$i,CodonLen)); if( length($site) < CodonLen ) { # at end of alignment and this is not in phase $self->debug("phase was $phase, but got to end of alignment with overhang of $site"); next; } # do we check for gaps/indels here? for (my $pos=0; $pos 1 || $includefixed ) { for( my $j = 0; $j < $genoct; $j++ ) { $inds[$j]->add_Genotype(Bio::PopGen::Genotype->new (-marker_name => ($i/CodonLen), -individual_id=> $inds[$j]->unique_id, -alleles => $genotypes[$j])); } $codonct++; } } } else { $self->throw("Can only build sites based on all the data right now!"); } return Bio::PopGen::Population->new(-checkisa => 0, -source => 'alignment', -individuals=> \@inds); } 1; BioPerl-1.6.923/Bio/PopGen/IO000755000765000024 012254227334 15513 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/PopGen/IO/csv.pm000444000765000024 2356312254227334 17032 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::IO::csv # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::IO::csv -Extract individual allele data from a CSV parser =head1 SYNOPSIS #Do not use directly, use through the Bio::PopGen::IO driver use Bio::PopGen::IO; my $io = Bio::PopGen::IO->new(-format => 'csv', -file => 'data.csv'); # Some IO might support reading in a population at a time my @population; while( my $ind = $io->next_individual ) { push @population, $ind; } =head1 DESCRIPTION This object will parse comma delimited format (CSV) or whatever delimiter you specify. It currently doesn't handle the more complex quote escaped CSV format. There are 3 initialization parameters, the delimiter (-field_delimiter) [default ','], (-allele_delimiter) [default ' ']. The third initialization parameter is a boolean -no_header which specifies if there is no header line to read in. All lines starting with '#' will be skipped When no_header is not specific the data is assumed to be of the following form. Having a header line this SAMPLE,MARKERNAME1,MARKERNAME2,... and each data line having the form (diploid data) SAMP1,101 102,100 90,a b or for haploid data SAMP1,101,100,a =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::IO::csv; use vars qw($FieldDelim $AlleleDelim $NoHeader); use strict; ($FieldDelim,$AlleleDelim,$NoHeader) =( ',', '\s+',0); # Object preamble - inherits from Bio::Root::Root use Bio::PopGen::Individual; use Bio::PopGen::Population; use Bio::PopGen::Genotype; use base qw(Bio::PopGen::IO); =head2 new Title : new Usage : my $obj = Bio::PopGen::IO::csv->new(); Function: Builds a new Bio::PopGen::IO::csv object Returns : an instance of Bio::PopGen::IO::csv Args : [optional, these are the current defaults] -field_delimiter => ',' -allele_delimiter=> '\s+' -no_header => 0, =cut sub _initialize { my($self, @args) = @_; my ($fieldsep,$all_sep, $noheader) = $self->_rearrange([qw(FIELD_DELIMITER ALLELE_DELIMITER NO_HEADER)],@args); $self->flag('no_header', defined $noheader ? $noheader : $NoHeader); $self->flag('field_delimiter',defined $fieldsep ? $fieldsep : $FieldDelim); $self->flag('allele_delimiter',defined $all_sep ? $all_sep : $AlleleDelim); $self->{'_header'} = undef; return 1; } =head2 flag Title : flag Usage : $obj->flag($flagname,$newval) Function: Get/Set the flag value Returns : value of a flag (a boolean) Args : A flag name, currently we expect 'no_header', 'field_delimiter', or 'allele_delimiter' on set, new value (a boolean or undef, optional) =cut sub flag{ my $self = shift; my $fieldname = shift; return unless defined $fieldname; return $self->{'_flag'}->{$fieldname} = shift if @_; return $self->{'_flag'}->{$fieldname}; } =head2 next_individual Title : next_individual Usage : my $ind = $popgenio->next_individual; Function: Retrieve the next individual from a dataset Returns : L object Args : none =cut sub next_individual{ my ($self) = @_; while( defined( $_ = $self->_readline) ) { next if( /^\s*\#/ || /^\s+$/ || ! length($_) ); last; } return if ! defined $_; if( $self->flag('no_header') || defined $self->{'_header'} ) { #########new (allows field delim to be the same as the allele delim my ($samp,@marker_results); if($self->flag('field_delimiter') ne $self->flag('allele_delimiter')){ ($samp,@marker_results) = split($self->flag('field_delimiter'),$_); } else{ my $fielddelim = $self->flag('field_delimiter'); my $alleledelim = $self->flag('allele_delimiter'); ($samp) = /(^.+?)$fielddelim/; s/^.+?$fielddelim//; (@marker_results) = /([\d|\w]+$alleledelim[\d|\w]+)/g; } #########end new my $i = 1; foreach my $m ( @marker_results ) { $m =~ s/^\s+//; $m =~ s/\s+$//; my $markername; if( defined $self->{'_header'} ) { $markername = $self->{'_header'}->[$i]; } else { $markername = "Marker$i"; } $self->debug( "markername is $markername alleles are $m\n"); my @alleles = split($self->flag('allele_delimiter'), $m); $m = Bio::PopGen::Genotype->new(-alleles => \@alleles, -marker_name => $markername, -individual_id=> $samp); $i++; } return Bio::PopGen::Individual->new(-unique_id => $samp, -genotypes => \@marker_results); } else { chomp; $self->{'_header'} = [split($self->flag('field_delimiter'),$_)]; return $self->next_individual; # rerun loop again } return; } =head2 next_population Title : next_population Usage : my $ind = $popgenio->next_population; Function: Retrieve the next population from a dataset Returns : L object Args : none Note : Many implementation will not implement this =cut # Plan is to just return the whole dataset as a single population by # default I think - people would then have each population in a separate # file. sub next_population{ my ($self) = @_; my @inds; while( my $ind = $self->next_individual ) { push @inds, $ind; } Bio::PopGen::Population->new(-individuals => \@inds); } =head2 write_individual Title : write_individual Usage : $popgenio->write_individual($ind); Function: Write an individual out in the file format Returns : none Args : L object(s) =cut sub write_individual{ my ($self,@inds) = @_; my $fielddelim = $self->flag('field_delimiter'); my $alleledelim= $self->flag('allele_delimiter'); foreach my $ind ( @inds ) { if (! ref($ind) || ! $ind->isa('Bio::PopGen::IndividualI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::IndividualI object ($ind)"); next; } # we'll go ahead and sort these until # we have a better way to insure a consistent order my @marker_names = sort $ind->get_marker_names; if( ! $self->flag('no_header') && ! $self->flag('header_written') ) { $self->_print(join($fielddelim, ('SAMPLE', @marker_names)), "\n"); $self->flag('header_written',1); } $self->_print( join($fielddelim, $ind->unique_id, # we're chaining map here, pay attention and read # starting with the last map # we'll turn genotypes into allele pairs # which will be separated by the allele delimiter map { join($alleledelim,$_->get_Alleles) } # marker names will be sorted so we don't # have to worry about this between individuals # unless the individual set you pass in has # a mixed set of markers... # this will turn marker names into Genotypes map {$ind->get_Genotypes(-marker => $_)} @marker_names), "\n") } } =head2 write_population Title : write_population Usage : $popgenio->write_population($pop); Function: Write a population out in the file format Returns : none Args : L object(s) Note : Many implementation will not implement this =cut sub write_population{ my ($self,@pops) = @_; my $fielddelim = $self->flag('field_delimiter'); # my $alleledelim= $self->flag('allele_delimiter'); my $alleledelim = ' '; foreach my $pop ( @pops ) { if (! ref($pop) || ! $pop->isa('Bio::PopGen::PopulationI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::PopulationI object"); next; } # we'll go ahead and sort these until # we have a better way to insure a consistent order my @marker_names = sort $pop->get_marker_names; if( ! $self->flag('no_header') && ! $self->flag('header_written') ) { $self->_print( join($fielddelim, ('SAMPLE', @marker_names)), "\n"); $self->flag('header_written',1); } foreach my $ind ( $pop->get_Individuals ) { $self->_print( join($fielddelim, $ind->unique_id, # we're chaining map here, pay attention # and read starting with the last map # we'll turn genotypes into allele pairs # which will be separated by the allele # delimiter map { join($alleledelim,$_->get_Alleles) } # marker names will be sorted so we don't # have to worry about this between individuals # unless the individual set you pass in has # a mixed set of markers... # this will turn marker names into Genotypes map {$ind->get_Genotypes(-marker => $_)} @marker_names), "\n"); } } } 1; BioPerl-1.6.923/Bio/PopGen/IO/hapmap.pm000444000765000024 1747712254227327 17516 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::IO::hapmap # # Please direct questions and support issues to # # Cared for by Rich Dobson # # Copyright Rich Dobson # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::IO::hapmap - A parser for HapMap output data =head1 SYNOPSIS # Do not use directly, use through the Bio::PopGen::IO driver use Bio::PopGen::IO; my $io = Bio::PopGen::IO->new(-format => 'hapmap', -file => 'data.hapmap'); # Some IO might support reading in a population at a time my @population; while( my $ind = $io->next_individual ) { push @population, $ind; } =head1 DESCRIPTION A driver module for Bio::PopGen::IO for parsing hapmap data. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Rich Dobson Email r.j.dobson-at-qmul.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::IO::hapmap; use vars qw($FieldDelim $AlleleDelim $NoHeader $StartingCol); use strict; ($FieldDelim,$AlleleDelim,$NoHeader,$StartingCol) =( '\s+','',0,11); use Bio::PopGen::Individual; use Bio::PopGen::Population; use Bio::PopGen::Genotype; use base qw(Bio::PopGen::IO); =head2 new Title : new Usage : my $obj = Bio::PopGen::IO::hapmap->new(); Function: Builds a new Bio::PopGen::IO::hapmap object Returns : an instance of Bio::PopGen::IO::hapmap Args : [optional, these are the current defaults] -field_delimiter => ',' -allele_delimiter=> '\s+' -no_header => 0, -starting_column => 11 =cut sub _initialize { my($self, @args) = @_; $Bio::PopGen::Genotype::BlankAlleles=''; my ($fieldsep,$all_sep, $noheader, $start_col) = $self->_rearrange([qw(FIELD_DELIMITER ALLELE_DELIMITER NO_HEADER STARTING_COLUMN)], @args); $self->flag('no_header', defined $noheader ? $noheader : $NoHeader); $self->flag('field_delimiter',defined $fieldsep ? $fieldsep : $FieldDelim); $self->flag('allele_delimiter',defined $all_sep ? $all_sep : $AlleleDelim); $self->starting_column(defined $start_col ? $start_col : $StartingCol ); $self->{'_header'} = undef; return 1; } =head2 flag Title : flag Usage : $obj->flag($flagname,$newval) Function: Get/Set the flag value Returns : value of a flag (a boolean) Args : A flag name, currently we expect 'no_header', 'field_delimiter', or 'allele_delimiter' on set, new value (a boolean or undef, optional) =cut sub flag { my $self = shift; my $fieldname = shift; return unless defined $fieldname; return $self->{'_flag'}->{$fieldname} = shift if @_; return $self->{'_flag'}->{$fieldname}; } sub _pivot { my ($self) = @_; my (@cols,@rows,@idheader); while ($_ = $self->_readline){ chomp($_); next if( /^\s*\#/ || /^\s+$/ || ! length($_) ); if( /^rs\#\s+alleles\s+chrom\s+pos\s+strand/ ) { @idheader = split $self->flag('field_delimiter'); } else { push @cols, [split $self->flag('field_delimiter')]; } } my $startingcol = $self->starting_column; $self->{'_header'} = [ map { $_->[0] } @cols]; for my $n ($startingcol.. $#{ $cols[ 0 ]}) { my $column = [ $idheader[$n], map{ $_->[ $n ] } @cols ]; push (@rows, $column); } $self->{'_pivot'} = [@rows]; $self->{'_i'} = 0; } =head2 next_individual Title : next_individual Usage : my $ind = $popgenio->next_individual; Function: Retrieve the next individual from a dataset Returns : A Bio::PopGen::IndividualI object Args : none See L =cut sub next_individual { my ($self) = @_; unless($self->{'_pivot'}){ #if it's the first time then pivot the table and store. #Lines will now be read from the stored pivot version of the input file $self->_pivot; } $_ = $self->{'_pivot'}->[$self->{'_i'}++]; return unless defined $_; # Store all the marker related info. Now that the pivot has taken # place this is in the first few lines of the file Maybe this # should be put in a marker object. Doesn't seem to fit too well # though my ($samp,@marker_results) = @$_; # at some point use all this info my $i = 1; foreach my $m ( @marker_results ) { $m =~ s/^\s+//; $m =~ s/\s+$//; my $markername; if( defined $self->{'_header'} ) { $markername = $self->{'_header'}->[$i-1]; } else { $markername = "Marker$i"; } my @alleles = split($self->flag('allele_delimiter'), $m); if( @alleles != 2 ) { $self->warn("$m for $samp\n"); } else { $m = Bio::PopGen::Genotype->new(-alleles => \@alleles, -marker_name => $markername, -marker_type => 'S', # Guess hapmap only has SNP data -individual_id => $samp); } $i++; } return new Bio::PopGen::Individual(-unique_id => $samp, -genotypes => \@marker_results); } =head2 next_population Title : next_population Usage : my $ind = $popgenio->next_population; Function: Retrieve the next population from a dataset Returns : Bio::PopGen::PopulationI object Args : none Note : Many implementation will not implement this See L =cut sub next_population { my ($self) = @_; my @inds; while( my $ind = $self->next_individual ) { push @inds, $ind; } Bio::PopGen::Population->new(-individuals => \@inds); } =head2 write_individual Title : write_individual Usage : $popgenio->write_individual($ind); Function: Write an individual out in the file format NOT SUPPORTED BY hapmap format Returns : none Args : Bio::PopGen::PopulationI object(s) See L =cut sub write_individual { my ($self,@inds) = @_; # data from hapmap is output, not input, so # we don't need a method for writing and input file $self->throw_not_implemented(); } =head2 write_population Title : write_population Usage : $popgenio->write_population($pop); Function: Write a population out in the file format NOT SUPPORTED BY hapmap format Returns : none Args : Bio::PopGen::PopulationI object(s) Note : Many implementation will not implement this See L =cut sub write_population { my ($self,@inds) = @_; $self->throw_not_implemented(); } =head2 starting_column Title : starting_column Usage : $obj->starting_column($newval) Function: Column where data starts Example : Returns : value of starting_column (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub starting_column{ my $self = shift; return $self->{'starting_column'} = shift if @_; return $self->{'starting_column'}; } 1; BioPerl-1.6.923/Bio/PopGen/IO/phase.pm000444000765000024 2476712254227323 17344 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::IO::phase # # Please direct questions and support issues to # # Cared for by Rich Dobson # # Copyright Rich Dobson # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::IO::phase - A parser for Phase format data =head1 SYNOPSIS # Do not use directly, use through the Bio::PopGen::IO driver use Bio::PopGen::IO; my $io = Bio::PopGen::IO->new(-format => 'phase', -file => 'data.phase'); # Some IO might support reading in a population at a time my @population; while( my $ind = $io->next_individual ) { push @population, $ind; } =head1 DESCRIPTION A driver module for Bio::PopGen::IO for parsing phase data. PHASE is defined in http://www.stat.washington.edu/stephens/instruct2.1.pdf =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Rich Dobson Email r.j.dobson-at-qmul.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::IO::phase; use vars qw($FieldDelim $AlleleDelim $NoHeader); use strict; ($FieldDelim, $AlleleDelim, $NoHeader) = (' ', '\s+', 1); use Bio::PopGen::Individual; use Bio::PopGen::Population; use Bio::PopGen::Genotype; use base qw(Bio::PopGen::IO); =head2 new Title : new Usage : my $obj = Bio::PopGen::IO::hapmap->new(); Function: Builds a new Bio::PopGen::IO::hapmap object Returns : an instance of Bio::PopGen::IO::hapmap Args : [optional, these are the current defaults] -field_delimiter => ' ' -allele_delimiter=> '\s+' -no_header => 0, =cut sub _initialize { my($self, @args) = @_; $Bio::PopGen::Genotype::BlankAlleles=''; my ($fieldsep,$all_sep, $noheader) = $self->_rearrange([qw(FIELD_DELIMITER ALLELE_DELIMITER NO_HEADER)],@args); $self->flag('no_header', defined $noheader ? $noheader : $NoHeader); $self->flag('field_delimiter',defined $fieldsep ? $fieldsep : $FieldDelim); $self->flag('allele_delimiter',defined $all_sep ? $all_sep : $AlleleDelim); $self->{'_header'} = undef; return 1; } =head2 flag Title : flag Usage : $obj->flag($flagname,$newval) Function: Get/Set the flag value Returns : value of a flag (a boolean) Args : A flag name, currently we expect 'no_header', 'field_delimiter', or 'allele_delimiter' on set, new value (a boolean or undef, optional) =cut sub flag { my $self = shift; my $fieldname = shift; return unless defined $fieldname; return $self->{'_flag'}->{$fieldname} = shift if @_; return $self->{'_flag'}->{$fieldname}; } =head2 next_individual Title : next_individual Usage : my $ind = $popgenio->next_individual; Function: Retrieve the next individual from a dataset Returns : L object Args : none =cut sub next_individual { my ($self) = @_; my ($sam,@marker_results,$number_of_ids,$number_of_markers, $marker_positions,$micro_snp); while( defined( $_ = $self->_readline) ) { chomp; next if( /^\s+$/ || ! length($_) ); last; } return unless defined $_; if( $self->flag('no_header') || defined $self->{'_header'} ) { ####### sometimes there is some marker info at the start of a phase input file ####### we collect it in the next few lines if there is. Should this info be held in a marker object? if(!$self->{'_count'} && /^\s*\d+$/){ $self->flag('number_of_ids',$_); #print "number_of_ids : $number_of_ids\n"; $self->{'_count'}++; return $self->next_individual; } elsif($self->{'_count'} == 1 && /^\s*\d+$/){ $self->flag('number_of_markers',$_); #print "number_of_markers : $number_of_markers\n"; $self->{'_count'}++; return $self->next_individual; } elsif($self->{'_count'} == 2 && /^\s*P\s\d/){ $self->flag('marker_positions',$_); #print "marker_position : $marker_positions\n"; $self->{'_count'}++; return $self->next_individual; } elsif($self->{'_count'} == 3 && /^\s*(M|S)+\s*$/i){ $self->flag('micro_snp',$_); #print "microsat or snp : $micro_snp\n"; $self->{'_count'}++; return $self->next_individual; } elsif(/^\s*\#/){ ($self->{'_sam'}) = /^\s*\#(.+)/; #print "sample : $self->{'_sam'}\n"; $self->{'_count'}++; return $self->next_individual; } else { if( $self->{'_row1'} ) { # if we are looking at the 2nd row of alleles for this id @{$self->{'_second_row'}} = split($self->flag('field_delimiter'),$_); for my $i(0 .. $#{$self->{'_first_row'}}){ push(@{$self->{'_marker_results'}}, $self->{'_first_row'}->[$i]. $self->flag('field_delimiter'). $self->{'_second_row'}->[$i]); } $self->{'_row1'} = 0; } else { # if we are looking at the first row of alleles for this id @{$self->{'_marker_results'}} = (); @{$self->{'_first_row'}} = split($self->flag('field_delimiter'),$_); $self->{'_row1'} = 1; return $self->next_individual; } } my $i = 1; foreach my $m ( @{$self->{'_marker_results'}} ) { $m =~ s/^\s+//; $m =~ s/\s+$//; my $markername; if( defined($self->flag('marker_positions')) ) { $markername = (split($self->flag('field_delimiter'), $self->flag('marker_positions')))[$i]; } elsif( defined $self->{'_header'} ) { $markername = $self->{'_header'}->[$i] || "$i"; } else { $markername = "$i"; } my $markertype; if( defined($self->flag('marker_positions')) ) { $markertype = (split('', $self->flag('micro_snp')))[$i-1]; } else { $markertype = "S"; } $self->debug( "markername is $markername alleles are $m\n"); my @alleles = split($self->flag('allele_delimiter'), $m); $m = Bio::PopGen::Genotype->new(-alleles =>\@alleles, -marker_name => $markername, -marker_type => $markertype, -individual_id => $self->{'_sam'}); $i++; } return Bio::PopGen::Individual->new(-unique_id => $self->{'_sam'}, -genotypes =>\@{$self->{'_marker_results'}}, ); } else { $self->{'_header'} = [split($self->flag('field_delimiter'),$_)]; return $self->next_individual; # rerun loop again } return; } =head2 next_population Title : next_population Usage : my $ind = $popgenio->next_population; Function: Retrieve the next population from a dataset Returns : L object Args : none Note : Many implementation will not implement this =cut sub next_population{ my ($self) = @_; my @inds; while( my $ind = $self->next_individual ) { push @inds, $ind; } Bio::PopGen::Population->new(-individuals => \@inds); } =head2 write_individual Title : write_individual Usage : $popgenio->write_individual($ind); Function: Write an individual out in the file format Returns : none Args : L object(s) =cut sub write_individual { my ($self,@inds) = @_; my $fielddelim = $self->flag('field_delimiter'); my $alleledelim = $self->flag('allele_delimiter'); # For now capture print_header flag from @inds my $header = 1; $header = pop(@inds) if($inds[-1] =~ m/^[01]$/); foreach my $ind ( @inds ) { if (! ref($ind) || ! $ind->isa('Bio::PopGen::IndividualI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::IndividualI object ($ind)"); next; } # sort lexically until we have a better way to insure a consistent order my @marker_names = sort $ind->get_marker_names; if ($header) { my $n_markers = scalar(@marker_names); $self->_print( "1\n"); $self->_print( $n_markers, "\n"); if( $self->flag('no_header') && ! $self->flag('header_written') ) { $self->_print(join($fielddelim, ('P', @marker_names)), "\n"); $self->flag('header_written',1); } foreach my $geno ($ind->get_Genotypes()) { $self->_print($geno->marker_type); } $self->_print("\n"); } my(@row1,@row2); for (@marker_names){ my $geno = $ind->get_Genotypes(-marker => $_); my @alleles = $geno->get_Alleles(1); push(@row1,$alleles[0]); push(@row2,$alleles[1]); } $self->_print("#",$ind->unique_id,"\n", join($fielddelim,@row1),"\n", join($fielddelim,@row2),"\n"); } } =head2 write_population Title : write_population Usage : $popgenio->write_population($pop); Function: Write a population out in the file format Returns : none Args : L object(s) Note : Many implementation will not implement this =cut sub write_population { my ($self,@pops) = @_; my $fielddelim = $self->flag('field_delimiter'); my $alleledelim = $self->flag('allele_delimiter'); foreach my $pop ( @pops ) { if (! ref($pop) || ! $pop->isa('Bio::PopGen::PopulationI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::PopulationI object"); next; } # sort lexically until we have a better way to insure a consistent order my @marker_names = sort $pop->get_marker_names; my $n_markers = scalar(@marker_names); $self->_print( $pop->get_number_individuals, "\n"); $self->_print( $n_markers, "\n"); if( $self->flag('no_header') && ! $self->flag('header_written') ) { $self->_print( join($fielddelim, ('P', @marker_names)), "\n"); $self->flag('header_written',1); } foreach (@marker_names) { $self->_print(($pop->get_Genotypes($_))[0]->marker_type); } $self->_print("\n"); $self->write_individual( $pop->get_Individuals, 0 ); } } 1; BioPerl-1.6.923/Bio/PopGen/IO/prettybase.pm000444000765000024 1760612254227312 20416 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::IO::prettybase # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::IO::prettybase - Extract individual allele data from PrettyBase format =head1 SYNOPSIS Do not use directly, use through the Bio::PopGen::IO driver =head1 DESCRIPTION This object will parse comma delimited PrettyBase output. PrettyBase is defined by the SeattleSNPs http://pga.gs.washington.edu/ This is expected to be tab delimited (you can vary with the field_delimiter flag SITE SAMPLE ALLELE1 ALLELE2 There are 2 initialization parameters, the delimiter (-field_delimiter) [default 'tab'] and a boolean -no_header which specifies if there is no header line to read in. All lines starting with '#' will be skipped =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, matthew.hahn-at-duke.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::IO::prettybase; use vars qw($FieldDelim $Header); use strict; ($FieldDelim,$Header) =( '\t',0); use Bio::PopGen::Individual; use Bio::PopGen::Population; use Bio::PopGen::Genotype; use base qw(Bio::PopGen::IO); =head2 new Title : new Usage : my $obj = Bio::PopGen::IO::prettybase->new(); Function: Builds a new Bio::PopGen::IO::prettybase object Returns : an instance of Bio::PopGen::IO::prettybase Args : -field_delimiter => a field delimiter character or regexp (default is /\t/ ) -header => boolean if the file will have a header and parser should skip first line in the file (default is false) -convert_indel_states => convert alleles which are longer than one character to an 'I' meaning insert state, and alleles which are '-' to a delete state. (default is false) =cut sub _initialize { my($self, @args) = @_; my ($fieldsep, $conv_indels, $header) = $self->_rearrange([qw(FIELD_DELIMITER CONVERT_INDEL_STATES HEADER)],@args); $self->flag('header', defined $header ? $header : $Header); $self->flag('field_delimiter',defined $fieldsep ? $fieldsep : $FieldDelim); $self->{'_header'} = undef; $self->{'_parsed_individiuals'} = []; $self->{'_parsed'} = 0; $self->flag('convert_indel',$conv_indels || 0); return 1; } =head2 flag Title : flag Usage : $obj->flag($flagname,$newval) Function: Get/Set the flag value Returns : value of a flag (a boolean) Args : A flag name, currently we expect 'header', 'field_delimiter', or 'allele_delimiter' on set, new value (a boolean or undef, optional) =cut sub flag{ my $self = shift; my $fieldname = shift; return unless defined $fieldname; return $self->{'_flag'}->{$fieldname} = shift if @_; return $self->{'_flag'}->{$fieldname}; } =head2 next_individual Title : next_individual Usage : my $ind = $popgenio->next_individual; Function: Retrieve the next individual from a dataset Returns : Bio::PopGen::IndividualI object Args : none =cut sub next_individual { my ($self) = @_; unless( $self->{'_parsed'} ) { $self->_parse_prettybase; } return $self->{'_parsed_individiuals'}->[$self->{'_iterator'}++]; } =head2 next_population Title : next_population Usage : my $ind = $popgenio->next_population; Function: Retrieve the next population from a dataset Returns : Bio::PopGen::PopulationI object Args : none Note : Many implementation will not implement this =cut # Plan is to just return the whole dataset as a single population by # default I think - people would then have each population in a separate # file. sub next_population{ my ($self) = @_; my @inds; while( my $ind = $self->next_individual ) { push @inds, $ind; } return unless @inds; Bio::PopGen::Population->new(-individuals => \@inds); } sub _parse_prettybase { my $self = shift; my %inds; my $convert_indels = $self->flag('convert_indel'); while( defined( $_ = $self->_readline) ) { next if( /^\s*\#/ || /^\s+$/ || ! length($_) ); my ($site,$sample,@alleles) = split($self->flag('field_delimiter'),$_); if( ! defined $sample ) { warn("sample id is undefined for $_"); next; } for my $allele ( @alleles ) { $allele =~ s/^\s+//; $allele =~ s/\s+$//; if( $convert_indels ) { if( length($allele) > 1 ) { # we have an insert state $allele = 'I'; } elsif( $allele eq '-' ) { # have a delete state $allele = 'D'; } } } my $g = Bio::PopGen::Genotype->new(-alleles => \@alleles, -marker_name => $site, -individual_id=> $sample); if( ! defined $inds{$sample} ) { $inds{$sample} = Bio::PopGen::Individual->new(-unique_id => $sample); } $inds{$sample}->add_Genotype($g); } $self->{'_parsed_individiuals'} = [ values %inds ]; $self->{'_parsed'} = 1; return; } =head2 write_individual Title : write_individual Usage : $popgenio->write_individual($ind); Function: Write an individual out in the file format Returns : none Args : L object(s) =cut sub write_individual{ my ($self,@inds) = @_; foreach my $ind ( @inds ) { if (! ref($ind) || ! $ind->isa('Bio::PopGen::IndividualI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::IndividualI object"); next; } foreach my $marker ( $ind->get_marker_names ) { my $g = $ind->get_Genotypes(-marker=> $marker); next unless defined $g; $self->_print( join("\t", $marker, $ind->unique_id, $g->get_Alleles), "\n"); } } } =head2 write_population Title : write_population Usage : $popgenio->write_population($pop); Function: Write a population out in the file format Returns : none Args : L object(s) Note : Many implementation will not implement this =cut sub write_population{ my ($self,@pops) = @_; foreach my $pop ( @pops ) { if (! ref($pop) || ! $pop->isa('Bio::PopGen::PopulationI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::PopulationI object"); next; } my @mnames = $pop->get_marker_names; foreach my $ind ( $pop->get_Individuals ) { if (! ref($ind) || ! $ind->isa('Bio::PopGen::IndividualI') ) { $self->warn("Cannot write an object that is not a Bio::PopGen::IndividualI object"); next; } foreach my $marker ( @mnames ) { my $g = $ind->get_Genotypes(-marker=> $marker); next unless defined $g; $self->_print( join("\t", $marker, $ind->unique_id, $g->get_Alleles), "\n"); } } } } 1; BioPerl-1.6.923/Bio/PopGen/Simulation000755000765000024 012254227330 17324 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/PopGen/Simulation/Coalescent.pm000444000765000024 2642612254227321 22131 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Simulation::Coalescent # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Simulation::Coalescent - A Coalescent simulation factory =head1 SYNOPSIS use Bio::PopGen::Simulation::Coalescent; my @taxonnames = qw(SpeciesA SpeciesB SpeciesC SpeciesD); my $sim1 = Bio::PopGen::Simulation::Coalescent->new(-samples => \@taxonnames); my $tree = $sim1->next_tree; # add 20 mutations randomly to the tree $sim1->add_Mutations($tree,20); # or for anonymous samples my $sim2 = Bio::PopGen::Simulation::Coalescent->new( -sample_size => 6, -maxcount => 50); my $tree2 = $sim2->next_tree; # add 20 mutations randomly to the tree $sim2->add_Mutations($tree2,20); =head1 DESCRIPTION Builds a random tree every time next_tree is called or up to -maxcount times with branch lengths and provides the ability to randomly add mutations onto the tree with a probabilty proportional to the branch lengths. This algorithm is based on the make_tree algorithm from Richard Hudson 1990. Hudson, R. R. 1990. Gene genealogies and the coalescent process. Pp. 1-44 in D. Futuyma and J. Antonovics, eds. Oxford surveys in evolutionary biology. Vol. 7. Oxford University Press, New York. This module was previously named Bio::Tree::RandomTree =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Matthew Hahn Email jason-at-bioperl-dot-org Email matthew-dot-hahn-at-duke-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Simulation::Coalescent; use vars qw($PRECISION_DIGITS); use strict; $PRECISION_DIGITS = 3; # Precision for the branchlength use Bio::Tree::AlleleNode; use Bio::PopGen::Genotype; use Bio::Tree::Tree; use base qw(Bio::Root::Root Bio::Factory::TreeFactoryI); =head2 new Title : new Usage : my $obj = Bio::PopGen::Simulation::Coalescent->new(); Function: Builds a new Bio::PopGen::Simulation::Coalescent object Returns : an instance of Bio::PopGen::Simulation::Coalescent Args : -samples => arrayref of sample names OR -sample_size=> number of samples (samps will get a systematic name) -maxcount => [optional] maximum number of trees to provide =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_treecounter'} = 0; $self->{'_maxcount'} = 0; my ($maxcount, $samps,$samplesize ) = $self->_rearrange([qw(MAXCOUNT SAMPLES SAMPLE_SIZE)], @args); my @samples; if( ! defined $samps ) { if( ! defined $samplesize || $samplesize <= 0 ) { $self->throw("Must specify a valid samplesize if parameter -SAMPLE is not specified (sampsize is $samplesize)"); } foreach ( 1..$samplesize ) { push @samples, "Samp$_"; } } else { if( ref($samps) !~ /ARRAY/i ) { $self->throw("Must specify a valid ARRAY reference to the parameter -SAMPLES, did you forget a leading '\\'?"); } @samples = @$samps; } $self->samples(\@samples); $self->sample_size(scalar @samples); defined $maxcount && $self->maxcount($maxcount); return $self; } =head2 next_tree Title : next_tree Usage : my $tree = $factory->next_tree Function: Returns a random tree based on the initialized number of nodes NOTE: if maxcount is not specified on initialization or set to a valid integer, subsequent calls to next_tree will continue to return random trees and never return undef Returns : Bio::Tree::TreeI object Args : none =cut sub next_tree{ my ($self) = @_; # If maxcount is set to something non-zero then next tree will # continue to return valid trees until maxcount is reached # otherwise will always return trees return if( $self->maxcount && $self->{'_treecounter'}++ >= $self->maxcount ); my $size = $self->sample_size; my $in; my @tree = (); my @list = (); for($in=0;$in < 2*$size -1; $in++ ) { push @tree, { 'nodenum' => "Node$in" }; } # in C we would have 2 arrays # an array of nodes (tree) # and array of pointers to these nodes (list) # and we just shuffle the list items to do the # tree topology generation # instead in perl, we will have a list of hashes (nodes) called @tree # and a list of integers representing the indexes in tree called @list for($in=0;$in < $size;$in++) { $tree[$in]->{'time'} = 0; $tree[$in]->{'desc1'} = undef; $tree[$in]->{'desc2'} = undef; push @list, $in; } my $t=0; # generate times for the nodes for($in = $size; $in > 1; $in-- ) { $t+= -2.0 * log(1 - $self->random(1)) / ( $in * ($in-1) ); $tree[2 * $size - $in]->{'time'} =$t; } # topology generation for ($in = $size; $in > 1; $in-- ) { my $pick = int $self->random($in); my $nodeindex = $list[$pick]; my $swap = 2 * $size - $in; $tree[$swap]->{'desc1'} = $nodeindex; $list[$pick] = $list[$in-1]; $pick = int rand($in - 1); $nodeindex = $list[$pick]; $tree[$swap]->{'desc2'} = $nodeindex; $list[$pick] = $swap; } # Let's convert the hashes into nodes my @nodes = (); foreach my $n ( @tree ) { push @nodes, Bio::Tree::AlleleNode->new(-id => $n->{'nodenum'}, -branch_length => $n->{'time'}); } my $ct = 0; foreach my $node ( @nodes ) { my $n = $tree[$ct++]; if( defined $n->{'desc1'} ) { $node->add_Descendent($nodes[$n->{'desc1'}]); } if( defined $n->{'desc2'} ) { $node->add_Descendent($nodes[$n->{'desc2'}]); } } my $T = Bio::Tree::Tree->new(-root => pop @nodes ); return $T; } =head2 add_Mutations Title : add_Mutations Usage : $factory->add_Mutations($tree, $mutcount); Function: Adds mutations to a tree via a random process weighted by branch length (it is a poisson distribution as part of a coalescent process) Returns : none Args : $tree - Bio::Tree::TreeI $nummut - number of mutations $precision - optional # of digits for precision =cut sub add_Mutations{ my ($self,$tree, $nummut,$precision) = @_; $precision ||= $PRECISION_DIGITS; $precision = 10**$precision; my @branches; my @lens; my $branchlen = 0; my $last = 0; my @nodes = $tree->get_nodes(); my $i = 0; # Jason's somewhat simplistics way of doing a poission # distribution for a fixed number of mutations # build an array and put the node number in a slot # representing the branch to put a mutation on # but weight the number of slots per branch by the # length of the branch ( ancestor's time - node time) foreach my $node ( @nodes ) { if( $node->ancestor ) { my $len = int ( ($node->ancestor->branch_length - $node->branch_length) * $precision); if ( $len > 0 ) { for( my $j =0;$j < $len;$j++) { push @branches, $i; } $last += $len; } $branchlen += $len; } if( ! $node->isa('Bio::Tree::AlleleNode') ) { bless $node, 'Bio::Tree::AlleleNode'; # rebless it to the right node } # This let's us reset the stored genotypes so we can keep reusing the # same tree topology, but throw down mutations multiple times $node->reset_Genotypes; $i++; } # sanity check $self->throw("branch len is $branchlen arraylen is $last") unless ( $branchlen == $last ); my @mutations; for( my $j = 0; $j < $nummut; $j++) { my $index = int(rand($branchlen)); my $branch = $branches[$index]; # We're using an infinite sites model so every new # mutation is a new site my $g = Bio::PopGen::Genotype->new(-marker_name => "Mutation$j", -alleles => [1]); $nodes[$branch]->add_Genotype($g); push @mutations, "Mutation$j"; # Let's add this mutation to all the children (push it down # the branches to the tips) foreach my $child ( $nodes[$branch]->get_all_Descendents ) { $child->add_Genotype($g); } } # Insure that everyone who doesn't have the mutation # has the ancestral state, which is '0' foreach my $node ( @nodes ) { foreach my $m ( @mutations ) { if( ! $node->has_Marker($m) ) { my $emptyg = Bio::PopGen::Genotype->new(-marker_name => $m, -alleles => [0]); $node->add_Genotype($emptyg); } } } } =head2 maxcount Title : maxcount Usage : $obj->maxcount($newval) Function: Returns : Maxcount value Args : newvalue (optional) =cut sub maxcount{ my ($self,$value) = @_; if( defined $value) { if( $value =~ /^(\d+)/ ) { $self->{'maxcount'} = $1; } else { $self->warn("Must specify a valid Positive integer to maxcount"); $self->{'maxcount'} = 0; } } return $self->{'_maxcount'}; } =head2 samples Title : samples Usage : $obj->samples($newval) Function: Example : Returns : value of samples Args : newvalue (optional) =cut sub samples{ my ($self,$value) = @_; if( defined $value) { if( ref($value) !~ /ARRAY/i ) { $self->warn("Must specify a valid array ref to the method 'samples'"); $value = []; } $self->{'samples'} = $value; } return $self->{'samples'}; } =head2 sample_size Title : sample_size Usage : $obj->sample_size($newval) Function: Example : Returns : value of sample_size Args : newvalue (optional) =cut sub sample_size{ my ($self,$value) = @_; if( defined $value) { $self->{'sample_size'} = $value; } return $self->{'sample_size'}; } =head2 random Title : random Usage : my $rfloat = $node->random($size) Function: Generates a random number between 0 and $size This is abstracted so that someone can override and provide their own special RNG. This is expected to be a uniform RNG. Returns : Floating point random Args : $maximum size for random number (defaults to 1) =cut sub random{ my ($self,$max) = @_; return rand($max); } 1; BioPerl-1.6.923/Bio/PopGen/Simulation/GeneticDrift.pm000444000765000024 2035112254227330 22407 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::PopGen::Simulation::GeneticDrift # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::PopGen::Simulation::GeneticDrift - A simple genetic drift simulation =head1 SYNOPSIS use Bio::PopGen::Simulation::GeneticDrift; my $sim = Bio::PopGen::Simulation::GeneticDrift->new(-popsize => 40, -alleles => {A => 0.2, B => 0.8}); for(my $i =0 ;$i < 10; $i++ ) { my %f = $sim->next_generation; # get the freqs for each generation } for(my $i =0 ;$i < 10; $i++ ) { # get the allele freqs as part of a Bio::PopGen::Population object my $pop = $sim->next_generation('population'); } =head1 DESCRIPTION A very simple 1 locus multi-allele random drift module, start with an initial set of allele frequency and simulate what happens over time. This isn't really useful for anything in particular yet but will be built upon. See Gillespie JH. (1998) "Population Genetics: a Concise guide." The Johns Hopkins University Press, Baltimore, USA. pp.19-47. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::PopGen::Simulation::GeneticDrift; use strict; use Bio::PopGen::Population; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::PopGen::Simulation::GeneticDrift->new(); Function: Builds a new Bio::PopGen::Simulation::GeneticDrift object Returns : an instance of Bio::PopGen::Simulation::GeneticDrift Args : -popsize => starting N -haploid => boolean if we should simulate haploids -alleles => arrayref of the allele names OR -population => L object to initialize from some previously defined Population object (or result from a previous simulation) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($population, $popsize, $haploid, $alleles) = $self->_rearrange([qw(POPULATION POPSIZE HAPLOID ALLELES)],@args); if( defined $population && ref($population) && $population->isa('Bio::PopGen::PopulationI') ) { $self->population_size($population->get_number_individuals || $popsize); my %f = $population->get_Allele_Frequencies; while( my ($allele,$freq) = each %f ) { $self->add_Allele_Frequency($allele,$freq); } } else { $self->population_size($popsize); if( ! defined $alleles || ref($alleles) !~ /HASH/i ) { $self->throw("Must provide a valid set of initial allele frequencies to $class as an hashref"); } while( my ($allele,$freq) = each %$alleles ) { $self->add_Allele_Frequency($allele,$freq); } } unless( $self->validate_Frequencies ) { $self->throw("You specified allele frequencies which summed to more than 1"); } return $self; } =head2 next_generation Title : next_generation Usage : my %generation = $sim->next_generation Function: Get the next generation of allele frequencies based on the current generation Returns : Hash of allele frequencies Args : 'allelefreqs' or 'population' to get back a hash of allele frequencies (default) OR a L object =cut sub next_generation{ my ($self,$rettype) = @_; my %initial = $self->get_Allele_Frequencies; my $popsize = $self->population_size || $self->throw("Need to have set a valid population size when running the simulation"); # we're going to construct a mapping of the rational space from 0->1 # which will map to a particular allele and be proportional to it # frequency my ($last,@mapping) = (0); # we'll make ranges that cover from >= left and < right in terms of the # order doesn't matter - 'distance' does # range that we're going to try and match # since rand() goes from 0 up to 1 (not including 1) foreach my $a ( keys %initial ) { push @mapping, [$last,$initial{$a}+$last,$a]; $last += $initial{$a}; } my %f; for( my $i =0; $i < $popsize; $i++ ) { my $rand = rand(1); foreach my $val ( @mapping ) { if( $rand >= $val->[0] && $rand < $val->[1] ) { $f{$val->[2]}++; last; } } } foreach my $f ( values %f ) { $f /= $popsize; } %{$self->{'_allele_freqs'}} = %f; if( defined $rettype && $rettype =~ /population/i) { return Bio::PopGen::Poulation->new(-frequencies => \%f); } else { return %f; } } =head2 population_size Title : population_size Usage : $obj->population_size($newval) Function: Example : Returns : value of population_size (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub population_size{ my $self = shift; return $self->{'_population_size'} = shift if @_; return $self->{'_population_size'}; } =head2 set_Frequencies_Equivalent Title : set_Frequencies_Equivalent Usage : $sim->set_Frequencies_Equivalent Function: Reset the allele frequencies so they are all even Returns : none Args : none =cut sub set_Frequencies_Equivalent{ my ($self) = @_; my @alleles = keys %{$self->{'_allele_freqs'}}; my $eqfreq = 1 / scalar @alleles; for ( @alleles ) { $self->{'_allele_freqs'}->{$_} = $eqfreq } return; } =head2 get_Allele_Frequencies Title : get_Allele_Frequencies Usage : my %allele_freqs = $marker->get_Allele_Frequencies; Function: Get the alleles and their frequency (set relative to a given population - you may want to create different markers with the same name for different populations with this current implementation Returns : Associative array where keys are the names of the alleles Args : none =cut sub get_Allele_Frequencies{ return %{$_[0]->{'_allele_freqs'}}; } =head2 add_Allele_Frequency Title : add_Allele_Frequency Usage : $marker->add_Allele_Frequency($allele,$freq) Function: Adds an allele frequency Returns : None Args : $allele - allele name $freq - frequency value =cut sub add_Allele_Frequency{ my ($self,$allele,$freq) = @_; $self->{'_allele_freqs'}->{$allele} = $freq; } =head2 reset_alleles Title : reset_alleles Usage : $marker->reset_alleles(); Function: Reset the alleles for a marker Returns : None Args : None =cut sub reset_alleles{ my ($self) = @_; $self->{'_allele_freqs'} = {}; } =head2 validate_Frequencies Title : validate_Frequencies Usage : if( $sim->validate_Frequencies) {} Function: Sanity checker that allele frequencies sum to 1 or less Returns : boolean Args : -strict => 1 boolean if you want to insure that sum of freqs is 1 =cut sub validate_Frequencies{ my ($self,@args) = @_; my ($strict) = $self->_rearrange([qw(STRICT)], @args); my $sum = 0; my %freq = $self->get_Allele_Frequencies; foreach my $f ( values %freq ) { $sum += $f; } return ($strict) ? $sum == 1 : $sum <= 1; } 1; BioPerl-1.6.923/Bio/Restriction000755000765000024 012254227340 16316 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Restriction/Analysis.pm000444000765000024 12031012254227332 20632 0ustar00cjfieldsstaff000000000000# # BioPerl module Bio::Restriction::Analysis # # Please direct questions and support issues to # # Cared for by Rob Edwards # # You may distribute this module under the same terms as perl itself ## POD Documentation: =head1 NAME Bio::Restriction::Analysis - cutting sequences with restriction enzymes =head1 SYNOPSIS # analyze a DNA sequence for restriction enzymes use Bio::Restriction::Analysis; use Bio::PrimarySeq; use Data::Dumper; # get a DNA sequence from somewhere my $seq = Bio::PrimarySeq->new (-seq =>'AGCTTAATTCATTAGCTCTGACTGCAACGGGCAATATGTCTC', -primary_id => 'synopsis', -molecule => 'dna'); # now start an analysis. # this is using the default set of enzymes my $ra = Bio::Restriction::Analysis->new(-seq=>$seq); # find unique cutters. This returns a # Bio::Restriction::EnzymeCollection object my $enzymes = $ra->unique_cutters; print "Unique cutters: ", join (', ', map {$_->name} $enzymes->unique_cutters), "\n"; # AluI is one them. Where does it cut? # This is will return an array of the sequence strings my $enz = 'AluI'; my @frags = $ra->fragments($enz); # how big are the fragments? print "AluI fragment lengths: ", join(' & ', map {length $_} @frags), "\n"; # You can also bypass fragments and call sizes directly: # to see all the fragment sizes print "All sizes: ", join " ", $ra->sizes($enz), "\n"; # to see all the fragment sizes sorted by size like on a gel print "All sizes, sorted ", join (" ", $ra->sizes($enz, 0, 1)), "\n"; # how many times does each enzyme cut my $cuts = $ra->cuts_by_enzyme('BamHI'); print "BamHI cuts $cuts times\n"; # How many enzymes do not cut at all? print "There are ", scalar $ra->zero_cutters->each_enzyme, " enzymes that do not cut\n"; # what about enzymes that cut twice? my $two_cutters = $ra->cutters(2); print join (" ", map {$_->name} $two_cutters->each_enzyme), " cut the sequence twice\n"; # what are all the enzymes that cut, and how often do they cut printf "\n%-10s%s\n", 'Enzyme', 'Number of Cuts'; my $all_cutters = $ra->cutters; map { printf "%-10s%s\n", $_->name, $ra->cuts_by_enzyme($_->name) } $all_cutters->each_enzyme; # Finally, we can interact the restriction enzyme object by # retrieving it from the collection object see the docs for # Bio::Restriction::Enzyme.pm my $enzobj = $enzymes->get_enzyme($enz); =head1 DESCRIPTION Bio::Restriction::Analysis describes the results of cutting a DNA sequence with restriction enzymes. To use this module you can pass a sequence object and optionally a Bio::Restriction::EnzymeCollection that contains the enzyme(s) to cut the sequences with. There is a default set of enzymes that will be loaded if you do not pass in a Bio::Restriction::EnzymeCollection. To cut a sequence, set up a Restriction::Analysis object with a sequence like this: use Bio::Restriction::Analysis; my $ra = Bio::Restriction::Analysis->new(-seq=>$seqobj); or my $ra = Bio::Restriction::Analysis->new (-seq=>$seqobj, -enzymes=>$enzs); Then, to get the fragments for a particular enzyme use this: @fragments = $ra->fragments('EcoRI'); Note that the naming of restriction enzymes is that the last numbers are usually Roman numbers (I, II, III, etc). You may want to use something like this: # get a reference to an array of unique (single) cutters $singles = $re->unique_cutters; foreach my $enz ($singles->each_enzyme) { @fragments = $re->fragments($enz); ... do something here ... } Note that if your sequence is circular, the first and last fragment will be joined so that they are the appropriate length and sequence for further analysis. This fragment will also be checked for cuts by the enzyme(s). However, this will change the start of the sequence! There are two separate algorithms used depending on whether your enzyme has ambiguity. The non-ambiguous algorithm is a lot faster, and if you are using very large sequences you should try and use this algorithm. If you have a large sequence (e.g. genome) and want to use ambgiuous enzymes you may want to make separate Bio::Restriction::Enzyme objects for each of the possible alternatives and make sure that you do not set is_ambiguous! This version should correctly deal with overlapping cut sites in both ambiguous and non-ambiguous enzymes. I have tried to write this module with speed and memory in mind so that it can be effectively used for large (e.g. genome sized) sequence. This module only stores the cut positions internally, and calculates everything else on an as-needed basis. Therefore when you call fragment_maps (for example), there may be another delay while these are generated. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu, Steve Chervitz, sac@bioperl.org =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Mark A. Jensen, maj-at-fortinbras-dot-us =head1 COPYRIGHT Copyright (c) 2003 Rob Edwards. Some of this work is Copyright (c) 1997-2002 Steve A. Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are not considered part of the public interface and are described here for documentation purposes only. =cut package Bio::Restriction::Analysis; use Bio::Restriction::EnzymeCollection; use strict; use Data::Dumper; use base qw(Bio::Root::Root); use Scalar::Util qw(blessed); =head1 new Title : new Function : Initializes the restriction enzyme object Returns : The Restriction::Analysis object Arguments : $re_anal->new(-seq=$seqobj, -enzymes=>Restriction::EnzymeCollection object) -seq requires a Bio::PrimarySeq object -enzymes is optional. If omitted it will use the default set of enzymes This is the place to start. Pass in a sequence, and you will be able to get the fragments back out. Several other things are available like the number of zero cutters or single cutters. =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($seq,$enzymes) = $self->_rearrange([qw( SEQ ENZYMES )], @args); $seq && $self->seq($seq); $enzymes ? $self->enzymes($enzymes) : ($self->{'_enzymes'} = Bio::Restriction::EnzymeCollection->new ); # keep track of status $self->{'_cut'} = 0; # left these here because we want to reforce a _cut if someone # just calls new $self->{maximum_cuts} = 0; $self->{'_number_of_cuts_by_enzyme'} = {}; $self->{'_number_of_cuts_by_cuts'} = {}; $self->{'_fragments'} = {}; $self->{'_cut_positions'} = {}; # cut position is the real position $self->{'_frag_map_list'} = {}; return $self; } =head1 Methods to set parameters =cut =head2 seq Title : seq Usage : $ranalysis->seq($newval); Function : get/set method for the sequence to be cut Example : $re->seq($seq); Returns : value of seq Args : A Bio::PrimarySeqI dna object (optional) =cut sub seq { my $self = shift; if (@_) { my $seq = shift; $self->throw('Need a sequence object ['. ref $seq. ']') unless $seq->isa('Bio::PrimarySeqI'); $self->throw('Need a DNA sequence object ['. $seq->alphabet. ']') unless $seq->alphabet eq 'dna'; $self->{'_seq'} = $seq; $self->{'_cut'} = 0; } return $self->{'_seq'}; } =head2 enzymes Title : enzymes Usage : $re->enzymes($newval) Function : gets/Set the restriction enzyme enzymes Example : $re->enzymes('EcoRI') Returns : reference to the collection Args : an array of Bio::Restriction::EnzymeCollection and/or Bio::Restriction::Enzyme objects The default object for this method is Bio::Restriction::EnzymeCollection. However, you can also pass it a list of Bio::Restriction::Enzyme objects - even mixed with Collection objects. They will all be stored into one collection. =cut sub enzymes { my $self = shift; if (@_) { $self->{'_enzymes'} = Bio::Restriction::EnzymeCollection->new (-empty => 1) unless $self->{'_enzymes'}; $self->{'_enzymes'}->enzymes(@_); $self->{'_cut'} = 0; } return $self->{'_enzymes'}; } =head1 Perform the analysis =cut =head2 cut Title : cut Usage : $re->cut() Function : Cut the sequence with the enzymes Example : $re->cut(); $re->cut('single'); or $re->cut('multiple', $enzymecollection); Returns : $self Args : 'single' (optional), 'multiple' with enzyme collection. An explicit cut method is needed to pass arguments to it. There are two varieties of cut. Single is the default, and need not be explicitly called. This cuts the sequence with each enzyme separately. Multiple cuts a sequence with more than one enzyme. You must pass it a Bio::Restriction::EnzymeCollection object of the set of enzymes that you want to use in the double digest. The results will be stored as an enzyme named "multiple_digest", so you can use all the retrieval methods to get the data. If you want to use the default setting there is no need to call cut directly. Every method in the class that needs output checks the object's internal status and recalculates the cuts if needed. Note: cut doesn't now re-initialize everything before figuring out cuts. This is so that you can do multiple digests, or add more data or whatever. You'll have to use new to reset everything. See also the comments in above about ambiguous and non-ambiguous sequences. =cut sub cut { my ($self, $opt, $ec) = @_; # for the moment I have left this as a separate routine so # the user calls cut rather than _cuts. This also initializes # some stuff we need to use. $self->throw("A sequence must be supplied") unless $self->seq; if ($opt && uc($opt) eq "MULTIPLE") { $self->throw("You must supply a separate enzyme collection for multiple digests") unless $ec; $self->_multiple_cuts($ec); # multiple digests } else { # reset some of the things that we save $self->{maximum_cuts} = 0; $self->{'_number_of_cuts_by_enzyme'} = {}; $self->{'_number_of_cuts_by_cuts'} = {}; $self->{'_fragments'} = {}; $self->{'_cut_positions'} = {}; # cut position is the real position $self->{'_frag_map_list'} = {}; $self->_cuts; } $self->{'_cut'} = 1; return $self; } =head2 mulitple_digest Title : multiple_digest Function : perform a multiple digest on a sequence Returns : $self so you can go and get any of the other methods Arguments : An enzyme collection Multiple digests can use 1 or more enzymes, and the data is stored in as if it were an enzyme called multiple_digest. You can then retrieve information about multiple digests from any of the other methods. You can use this method in place of $re->cut('multiple', $enz_coll); =cut sub multiple_digest { my ($self, $ec)=@_; return $self->cut('multiple', $ec); } =head1 Query the results of the analysis =cut =head2 positions Title : positions Function : Retrieve the positions that an enzyme cuts at Returns : An array of the positions that an enzyme cuts at : or an empty array if the enzyme doesn't cut Arguments: An enzyme name to retrieve the positions for Comments : The cut occurs after the base specified. =cut sub positions { my ($self, $enz) = @_; $self->cut unless $self->{'_cut'}; $self->throw('no enzyme selected to get positions for') unless $enz; return defined $self->{'_cut_positions'}->{$enz} ? @{$self->{'_cut_positions'}->{$enz}} : (); } =head2 fragments Title : fragments Function : Retrieve the fragments that we cut Returns : An array of the fragments retrieved. Arguments: An enzyme name to retrieve the fragments for For example this code will retrieve the fragments for all enzymes that cut your sequence my $all_cutters = $analysis->cutters; foreach my $enz ($$all_cutters->each_enzyme}) { @fragments=$analysis->fragments($enz); } =cut sub fragments { my ($self, $enz) = @_; $self->cut unless $self->{'_cut'}; $self->throw('no enzyme selected to get fragments for') unless $enz; my @fragments; for ($self->fragment_maps($enz)) {push @fragments, $_->{seq}} return @fragments; } =head2 fragment_maps Title : fragment_maps Function : Retrieves fragment sequences with start and end points. Useful for feature construction. Returns : An array containing a hash reference for each fragment, containing the start point, end point and DNA sequence. The hash keys are 'start', 'end' and 'seq'. Returns an empty array if not defined. Arguments : An enzyme name, enzyme object, or enzyme collection to retrieve the fragments for. If passes an enzyme collection it will return the result of a multiple digest. This : will also cause the special enzyme 'multiple_digest' to be created so you can get : other information about this multiple digest. (TMTOWTDI). There is a minor problem with this and $self-Efragments that I haven't got a good answer for (at the moment). If the sequence is not cut, do we return undef, or the whole sequence? For linear fragments it would be good to return the whole sequence. For circular fragments I am not sure. At the moment it returns the whole sequence with start of 1 and end of length of the sequence. For example: use Bio::Restriction::Analysis; use Bio::Restriction::EnzymeCollection; use Bio::PrimarySeq; my $seq = Bio::PrimarySeq->new (-seq =>'AGCTTAATTCATTAGCTCTGACTGCAACGGGCAATATGTCTCTGTGTGGATCCAAAAAAGAGTGAGCTTCTGAT', -primary_id => 'synopsis', -molecule => 'dna'); my $ra = Bio::Restriction::Analysis->new(-seq=>$seq); my @gel; my @bam_maps = $ra->fragment_maps('BamHI'); foreach my $i (@bam_maps) { my $start = $i->{start}; my $end = $i->{end}; my $sequence = $i->{seq}; push @gel, "$start--$sequence--$end"; @gel = sort {length $b <=> length $a} @gel; } print join("\n", @gel) . "\n"; =cut sub fragment_maps { my ($self, $enz) = @_; $self->cut unless $self->{'_cut'}; $self->throw('no enzyme selected to get fragment maps for') unless $enz; # we are going to generate this on an as-needed basis rather than # for every enzyme this should cut down on the amount of # duplicated data we are trying to save in memory and make this # faster and easier for large sequences, e.g. genome analysis my @cut_positions; if (ref $enz eq '' && exists $self->{'_cut_positions'}->{$enz}) { @cut_positions=@{$self->{'_cut_positions'}->{$enz}}; } elsif ($enz->isa("Bio::Restriction::EnzymeI")) { @cut_positions=@{$self->{'_cut_positions'}->{$enz->name}}; } elsif ($enz->isa("Bio::Restriction::EnzymeCollection")) { $self->cut('multiple', $enz); @cut_positions=@{$self->{'_cut_positions'}->{'multiple_digest'}}; } unless (defined($cut_positions[0])) { # it doesn't cut # return the whole sequence # this should probably have the is_circular command my %map=( 'start' => 1, 'end' => $self->{'_seq'}->length, 'seq' => $self->{'_seq'}->seq ); push (@{$self->{'_frag_map_list'}->{$enz}}, \%map); return defined $self->{'_frag_map_list'}->{$enz} ? @{$self->{'_frag_map_list'}->{$enz}} : (); } @cut_positions=sort {$a <=> $b} @cut_positions; push my @cuts, $cut_positions[0]; foreach my $i (@cut_positions) { push @cuts, $i if $i != $cuts[$#cuts]; } my $start=1; my $stop; my %seq; my %stop; foreach $stop (@cuts) { next if !$stop; # cuts at beginning of sequence $seq{$start}=$self->{'_seq'}->subseq($start, $stop); $stop{$start}=$stop; $start=$stop+1; } $stop=$self->{'_seq'}->length; if ($start > $stop) { # borderline case. The enzyme cleaved at the end of the sequence # what do I do now? } else { $seq{$start}=$self->{'_seq'}->subseq($start, $stop); $stop{$start}=$stop; } if ($self->{'_seq'}->is_circular) { # join the first and last fragments $seq{$start}.=$seq{'1'}; delete $seq{'1'}; $stop{$start}=$stop{'1'}; delete $stop{'1'}; } foreach my $start (sort {$a <=> $b} keys %seq) { my %map=( 'start' => $start, 'end' => $stop{$start}, 'seq' => $seq{$start} ); push (@{$self->{'_frag_map_list'}->{$enz}}, \%map); } return defined $self->{'_frag_map_list'}->{$enz} ? @{$self->{'_frag_map_list'}->{$enz}} : (); } =head2 sizes Title : sizes Function : Retrieves an array with the sizes of the fragments Returns : Array that has the sizes of the fragments ordered from largest to smallest like they would appear in a gel. Arguments: An enzyme name to retrieve the sizes for is required and kilobases to the nearest 0.1 kb, else it will be in bp. If the optional third entry is set the results will be sorted. This is designed to make it easy to see what fragments you should get on a gel! You should be able to do these: # to see all the fragment sizes, print join "\n", $re->sizes($enz), "\n"; # to see all the fragment sizes sorted print join "\n", $re->sizes($enz, 0, 1), "\n"; # to see all the fragment sizes in kb sorted print join "\n", $re->sizes($enz, 1, 1), "\n"; =cut sub sizes { my ($self, $enz, $kb, $sort) = @_; $self->throw('no enzyme selected to get fragments for') unless $enz; if (blessed($enz)) { $self->throw("Enzyme must be enzyme name or a Bio::Restriction::EnzymeI, not ".ref($enz)) if !$enz->isa('Bio::Restriction::EnzymeI'); $enz = $enz->name; } $self->cut unless $self->{'_cut'}; my @frag; my $lastsite=0; foreach my $site (@{$self->{'_cut_positions'}->{$enz}}) { $kb ? push (@frag, (int($site-($lastsite))/100)/10) : push (@frag, $site-($lastsite)); $lastsite=$site; } $kb ? push (@frag, (int($self->{'_seq'}->length-($lastsite))/100)/10) : push (@frag, $self->{'_seq'}->length-($lastsite)); if ($self->{'_seq'}->is_circular) { my $first=shift @frag; my $last=pop @frag; push @frag, ($first+$last); } $sort ? @frag = sort {$b <=> $a} @frag : 1; return @frag; } =head1 How many times does enzymes X cut? =cut =head2 cuts_by_enzyme Title : cuts_by_enzyme Function : Return the number of cuts for an enzyme Returns : An integer with the number of times each enzyme cuts. Returns 0 if doesn't cut or undef if not defined Arguments : An enzyme name string =cut sub cuts_by_enzyme { my ($self, $enz)=@_; $self->throw("Need an enzyme name") unless defined $enz; $self->cut unless $self->{'_cut'}; return $self->{'_number_of_cuts_by_enzyme'}->{$enz}; } =head1 Which enzymes cut the sequence N times? =cut =head2 cutters Title : cutters Function : Find enzymes that cut a given number of times Returns : a Bio::Restriction::EnzymeCollection Arguments : 1. exact time or lower limit, non-negative integer, optional 2. upper limit, non-negative integer, larger or equalthan first, optional If no arguments are given, the method returns all enzymes that do cut the sequence. The argument zero, '0', is same as method zero_cutters(). The argument one, '1', corresponds to unique_cutters. If either of the limits is larger than number of cuts any enzyme cuts the sequence, the that limit is automagically lowered. The method max_cuts() gives the largest number of cuts. See Also : L, L, L =cut sub cutters { my ($self, $a, $z) = @_; $self->cut unless $self->{'_cut'}; my ($start, $end); if (defined $a) { $self->throw("Need a non-zero integer [$a]") unless $a =~ /^[+]?\d+$/; $start = $a; } else { $start = 1; } $start = $self->{'maximum_cuts'} if $start > $self->{'maximum_cuts'}; if (defined $z) { $self->throw("Need a non-zero integer no smaller than start [0]") unless $z =~ /^[+]?\d+$/ and $z >= $a; $end = $z; } elsif (defined $a) { $end = $start; } else { $end = $self->{'maximum_cuts'}; } $end = $self->{'maximum_cuts'} if $end > $self->{'maximum_cuts'}; my $set = Bio::Restriction::EnzymeCollection->new(-empty => 1); #return an empty set if nothing cuts return $set unless $self->{'maximum_cuts'}; for (my $i=$start; $i<=$end; $i++) { $set->enzymes( @{$self->{_number_of_cuts_by_cuts}->{$i}} ) if defined $self->{_number_of_cuts_by_cuts}->{$i}; } return $set; } =head2 unique_cutters Title : unique_cutters Function : A special case if cutters() where enzymes only cut once Returns : a Bio::Restriction::EnzymeCollection Arguments : - See also: L, L =cut sub unique_cutters { shift->cutters(1); } =head2 zero_cutters Title : zero_cutters Function : A special case if cutters() where enzymes don't cut the sequence Returns : a Bio::Restriction::EnzymeCollection Arguments : - See also: L, L =cut sub zero_cutters { shift->cutters(0); } =head2 max_cuts Title : max_cuts Function : Find the most number of cuts Returns : The number of times the enzyme that cuts most cuts. Arguments : None This is not a very practical method, but if you are curious... =cut sub max_cuts { return shift->{maximum_cuts} } =head1 Internal methods =cut =head2 _cuts Title : _cuts Function : Figures out which enzymes we know about and cuts the sequence. Returns : Nothing. Arguments : None. Comments : An internal method. This will figure out where the sequence should be cut, and provide the appropriate results. =cut sub _cuts { my $self = shift; my $target_seq=uc $self->{'_seq'}->seq; # I have been burned on this before :) # first, find out all the enzymes that we have foreach my $enz ($self->{'_enzymes'}->each_enzyme) { my @all_cuts; my @others = $enz->others if $enz->can("others"); foreach my $enzyme ($enz, @others) { # cut the sequence # _make_cuts handles all cases (amibiguous, non-ambiguous) X # (palindromic X non-palindromic) # my $cut_positions = $self->_make_cuts($target_seq, $enzyme); push @all_cuts, @$cut_positions; #### need to refactor circular handling.... #### # deal with is_circular sequences if ($self->{'_seq'}->is_circular) { $cut_positions=$self->_circular($target_seq, $enzyme); push @all_cuts, @$cut_positions; } # non-symmetric cutters (most external cutters, e.g.) need # special handling unless ($enzyme->is_symmetric) { # do all of above with explicit use of the # enzyme's 'complementary_cut'... $cut_positions = $self->_make_cuts($target_seq, $enzyme, 'COMP'); push @all_cuts, @$cut_positions; # deal with is_circular sequences if ($self->{'_seq'}->is_circular) { $cut_positions=$self->_circular($target_seq, $enzyme, 'COMP'); push @all_cuts, @$cut_positions; } } } if (defined $all_cuts[0]) { # now just remove any duplicate cut sites @all_cuts = sort {$a <=> $b} @all_cuts; push @{$self->{'_cut_positions'}->{$enz->name}}, $all_cuts[0]; foreach my $i (@all_cuts) { push @{$self->{'_cut_positions'}->{$enz->name}}, $i if $i != ${$self->{'_cut_positions'}->{$enz->name}}[$#{$self->{'_cut_positions'}->{$enz->name}}]; } } else { # this just fixes an eror when @all_cuts is not defined! @{$self->{'_cut_positions'}->{$enz->name}}=(); } # note I have removed saving any other information except the # cut_positions this should significantly decrease the amount # of memory that is required for large sequences. It should # also speed things up dramatically, because fragments and # fragment maps are only calculated for those enzymes they are # needed for. # finally, save minimal information about each enzyme my $number_of_cuts=scalar @{$self->{'_cut_positions'}->{$enz->name}}; # now just store the number of cuts $self->{_number_of_cuts_by_enzyme}->{$enz->name}=$number_of_cuts; push (@{$self->{_number_of_cuts_by_cuts}->{$number_of_cuts}}, $enz); if ($number_of_cuts > $self->{maximum_cuts}) { $self->{maximum_cuts}=$number_of_cuts; } } } =head2 _enzyme_sites Title : _enzyme_sites Function : An internal method to figure out the two sides of an enzyme Returns : The sequence before the cut and the sequence after the cut Arguments : A Bio::Restriction::Enzyme object, $comp : boolean, calculate based on $enz->complementary_cut() if true, $enz->cut() if false Status : NOW DEPRECATED - maj =cut sub _enzyme_sites { my ($self, $enz, $comp )=@_; # get the cut site # I have reworked this so that it uses $enz->cut to get the site my $site= ( $comp ? $enz->complementary_cut : $enz->cut ); # split it into the two fragments for the sequence before and after. $site=0 unless defined $site; # the default values just stop an error from an undefined # string. But they don't affect the split. my ($beforeseq, $afterseq)= ('.', '.'); # extra-site cutting # the before seq is going to be the entire site # the after seq is empty # BUT, need to communicate how to cut within the sample sequence # relative to the end of the site (do through $enz->cut), and # ALSO, need to check length of sample seq so that if cut falls # outside the input sequence, we have a warning/throw. /maj # pre-site cutting # need to handle negative site numbers if ($site <= 0) { # <= to handle pre-site cutting $afterseq=$enz->string; } elsif ($site >= $enz->seq->length) { # >= to handle extrasite cutters/maj $beforeseq=$enz->string; } else { # $site < $enz->seq->length $beforeseq=$enz->seq->subseq(1, $site); $afterseq=$enz->seq->subseq($site+1, $enz->seq->length); } # if the enzyme is ambiguous we need to convert this into a perl string if ($enz->is_ambiguous) { $beforeseq=$self->_expanded_string($beforeseq); $afterseq =$self->_expanded_string($afterseq); } return ($beforeseq, $afterseq); } =head2 _non_pal_enz Title : _non_pal_enz Function : Analyses non_palindromic enzymes for cuts in both ways (in fact, delivers only minus strand cut positions in the plus strand coordinates/maj) Returns : A reference to an array of cut positions Arguments: The sequence to check and the enzyme object NOW DEPRECATED/maj =cut sub _non_pal_enz { my ($self, $target_seq, $enz) =@_; # add support for non-palindromic sequences # the enzyme is not the same forwards and backwards my $site=$enz->complementary_cut; # complementary_cut is in plus strand coordinates # we are going to rc the sequence, so complementary_cut becomes length-complementary_cut # I think this is wrong; cut sites are a matter of position with respect # to the plus strand: the recognition site is double stranded and # directly identifiable on the plus strand sequence. /maj # what really needs doing is to keep track of plus strand and minus strand # nicks separately./maj my ($beforeseq, $afterseq)=('.', '.'); # now, for extra-site cuts, $site > length...so...?/maj my $new_left_cut=$enz->seq->length-$site; # there is a problem when this is actually zero if ($new_left_cut == 0) {$afterseq=$enz->seq->revcom->seq} elsif ($new_left_cut == $enz->seq->length) {$beforeseq=$enz->seq->revcom->seq} else { # this can't be right./maj $beforeseq=$enz->seq->revcom->subseq(1, ($enz->seq->length-$site)); $afterseq=$enz->seq->revcom->subseq(($enz->seq->length-$site), $enz->seq->length); } # do this correctly, in the context of the current code design, # by providing a "complement" argument to _ambig_cuts and _nonambig_cuts, # use these explicitly rather than this wrapper./maj my $results=[]; if ($enz->is_ambiguous) { $results= $self->_ambig_cuts($beforeseq, $afterseq, $target_seq, $enz); } else { $results= $self->_nonambig_cuts($beforeseq, $afterseq, $target_seq, $enz); } # deal with is_circular my $more_results=[]; $more_results=$self->_circular($beforeseq, $afterseq, $enz) if ($self->{'_seq'}->is_circular); return [@$more_results, @$results]; } =head2 _ambig_cuts Title : _ambig_cuts Function : An internal method to localize the cuts in the sequence Returns : A reference to an array of cut positions Arguments : The separated enzyme site, the target sequence, and the enzyme object Comments : This is a slow implementation but works for ambiguous sequences. Whenever possible, _nonambig_cuts should be used as it is a lot faster. =cut # we have problems here when the cut is extrasite: $beforeseq/$afterseq do # not define the cut site then! I am renaming this to _ambig_cuts_depr, # providing a more compact method that correctly handles extrasite cuts # below /maj sub _ambig_cuts_depr { my ($self, $beforeseq, $afterseq, $target_seq, $enz) = @_; # cut the sequence. This is done with split so we can use # regexp. $target_seq = uc $target_seq; my @cuts = split /($beforeseq)($afterseq)/i, $target_seq; # now the array has extra elements --- the before and after! # we have: # element 0 sequence # element 1 3' end # element 2 5' end of next sequence # element 3 sequence # .... # we need to loop through the array and add the ends to the # appropriate parts of the sequence my $i=0; my @re_frags; if ($#cuts) { # there is >1 element while ($i<$#cuts) { my $joinedseq; # the first sequence is a special case if ($i == 0) { $joinedseq=$cuts[$i].$cuts[$i+1]; } else { $joinedseq=$cuts[$i-1].$cuts[$i].$cuts[$i+1]; } # now deal with overlapping sequences # we can do this through a regular regexp as we only # have a short fragment to look through while ($joinedseq =~ /$beforeseq$afterseq/) { $joinedseq =~ s/^(.*?$beforeseq)($afterseq)/$2/; push @re_frags, $1; } push @re_frags, $joinedseq; $i+=3; } # I don't think we want the last fragment in. It is messing up the _circular # part of things. So I deleted this part of the code :) } else { # if we don't cut, leave the array empty return []; } # the sequence was not cut. # now @re_frags has the fragments of all the sequences # but some people want to have this return the lengths # of the fragments. # in theory the actual cut sites should be the length # of the fragments in @re_frags # note, that now this is the only data that we are saving. We # will have to go back add regenerate re_frags. The reason is # that we can use this in _circular easier my @cut_positions = map {length($_)} @re_frags; # the cut positions are right now the lengths of the sequence, but # we need to add them all onto each other for (my $i=1; $i<=$#cut_positions; $i++) { $cut_positions[$i]+=$cut_positions[$i-1]; } # in one of those oddities in life, 2 fragments mean an enzyme cut once # so $#re_frags is the number of cuts return \@cut_positions; } # new version/maj sub _ambig_cuts { my ($self, $before, $after, $target, $enz, $comp) = @_; my $cut_site = ($comp ? $enz->complementary_cut : $enz->cut); local $_ = uc $target; my @cuts; my $recog = $enz->recog; my $site_re = qr/($recog)/; push @cuts, pos while (/$site_re/g); $_ = $_ - length($enz->recog) + $cut_site for @cuts; return [@cuts]; } =head2 _nonambig_cuts Title : _nonambig_cuts Function : Figures out which enzymes we know about and cuts the sequence. Returns : Nothing. Arguments : The separated enzyme site, the target sequence, and the enzyme object An internal method. This will figure out where the sequence should be cut, and provide the appropriate results. This is a much faster implementation because it doesn't use a regexp, but it can not deal with ambiguous sequences =cut # now, DO want the enzyme object.../maj sub _nonambig_cuts { my ($self, $beforeseq, $afterseq, $target_seq, $enz, $comp) = @_; my $cut_site = ($comp ? $enz->complementary_cut : $enz->cut); if ($beforeseq eq ".") {$beforeseq = ''} if ($afterseq eq ".") {$afterseq = ''} $target_seq = uc $target_seq; # my $index_posn=index($target_seq, $beforeseq.$afterseq); my $index_posn=index($target_seq, $enz->recog); return [] if ($index_posn == -1); # there is no match to the sequence # there is at least one cut site my @cuts; while ($index_posn > -1) { # extrasite cutting issue here... # think we want $index_posn+$enz->cut # push (@cuts, $index_posn+length($beforeseq)); push (@cuts, $index_posn+$cut_site); # $index_posn=index($target_seq, $beforeseq.$afterseq, $index_posn+1); $index_posn=index($target_seq, $enz->recog, $index_posn+1); } return \@cuts; } =head2 _make_cuts Title : _make_cuts Usage : $an->_make_cuts( $target_sequence, $enzyme, $complement_q ) Function: Returns an array of cut sites on target seq, using enzyme on the plus strand ($complement_q = 0) or minus strand ($complement_q = 1); follows Enzyme objects in $enzyme->others() Returns : array of scalar integers Args : sequence string, B:R:Enzyme object, boolean =cut sub _make_cuts { no warnings qw( uninitialized ); my ($self, $target, $enz, $comp) = @_; local $_ = uc $target; my @cuts; my @enzs = map { $_ || () } ($enz, $enz->can('others') ? $enz->others : ()); ENZ: foreach $enz (@enzs) { my $recog = $enz->recog; my $cut_site = ($comp ? $enz->complementary_cut : $enz->cut); my @these_cuts; if ( $recog =~ /[^\w]/ ) { # "ambig" my $site_re = qr/($recog)/; push @these_cuts, pos while (/$site_re/g); $_ = $_ - length($enz->string) + $cut_site for @these_cuts; if (!$enz->is_palindromic) { pos = 0; my @these_rev_cuts; $recog = $enz->revcom_recog; $cut_site = length($enz->string) - ($comp ? $enz->cut : $enz->complementary_cut); $site_re = qr/($recog)/; push @these_rev_cuts, pos while (/$site_re/g); $_ = $_ - length($enz->string) + $cut_site for @these_rev_cuts; push @these_cuts, @these_rev_cuts; } } else { # "nonambig" my $index_posn=index($_, $recog); while ($index_posn > -1) { push (@these_cuts, $index_posn+$cut_site); $index_posn=index($_, $recog, $index_posn+1); } if (!$enz->is_palindromic) { $recog = $enz->revcom_recog; $cut_site = length($enz->string) - ($comp ? $enz->cut : $enz->complementary_cut); $index_posn=index($_, $recog); while ($index_posn > -1) { push @these_cuts, $index_posn+$cut_site; $index_posn=index($_, $recog, $index_posn+1); } } } push @cuts, @these_cuts; } return [@cuts]; } =head2 _multiple_cuts Title : _multiple_cuts Function : Figures out multiple digests Returns : An array of the cut sites for multiply digested DNA Arguments : A Bio::Restriction::EnzymeCollection object Comments : Double digests is one subset of this, but you can use as many enzymes as you want. =cut sub _multiple_cuts { my ($self, $ec)=@_; $self->cut unless $self->{'_cut'}; # now that we are using positions rather than fragments # this is really easy my @cuts; foreach my $enz ($ec->each_enzyme) { push @cuts, @{$self->{'_cut_positions'}->{$enz->name}} if defined $self->{'_cut_positions'}->{$enz->name}; } @{$self->{'_cut_positions'}->{'multiple_digest'}}=sort {$a <=> $b} @cuts; my $number_of_cuts; $number_of_cuts=scalar @{$self->{'_cut_positions'}->{'multiple_digest'}}; $self->{_number_of_cuts_by_enzyme}->{'multiple_digest'}=$number_of_cuts; push (@{$self->{_number_of_cuts_by_cuts}->{$number_of_cuts}}, 'multiple_digest'); if ($number_of_cuts > $self->{maximum_cuts}) { $self->{maximum_cuts}=$number_of_cuts; } } =head2 _circular Title : _circular Function : Identifies cuts at the join of the end of the target with the beginning of the target Returns : array of scalar integers ( cut sites near join, if any ) Arguments : scalar string (target sequence), Bio::Restriction::Enzyme obj =cut sub _circular { my ($self, $target, $enz, $comp) = @_; $target=uc $target; my $patch_len = ( length $target > 20 ? 10 : int( length($target)/2 ) ); my ($first, $last) = (substr($target, 0, $patch_len),substr($target, -$patch_len)); my $patch=$last.$first; # now find the cut sites my $cut_positions = $self->_make_cuts($patch, $enz, $comp); # the enzyme doesn't cut in the new fragment return [] if (!$cut_positions); # now we are going to add things to _cut_positions # in this shema it doesn't matter if the site is there twice - # we will take care of that later. Because we are using position # rather than frag or anything else, we can just # remove duplicates. my @circ_cuts; foreach my $cut (@$cut_positions) { if ($cut == length($last)) { # the cut is actually at position 0, but we're going to call this the # length of the sequence so we don't confuse no cuts with a 0 cut # push (@circ_cuts, $self->{'_seq'}->length); push (@circ_cuts, 0); } elsif ($cut < length($last)) { # the cut is before the end of the sequence #check push (@circ_cuts, $self->{'_seq'}->length - (length($last) - $cut)); } else { # the cut is at the start of the sequence (position >=1) # note, we put this at the beginning of the array rather than the end! unshift (@circ_cuts, $cut-length($last)); } } return \@circ_cuts; } =head2 _expanded_string Title : _expanded_string Function : Expand nucleotide ambiguity codes to their representative letters Returns : The full length string Arguments : The string to be expanded. Stolen from the original RestrictionEnzyme.pm =cut sub _expanded_string { my ($self, $str) = @_; $str =~ s/N|X/\./g; $str =~ s/R/\[AG\]/g; $str =~ s/Y/\[CT\]/g; $str =~ s/S/\[GC\]/g; $str =~ s/W/\[AT\]/g; $str =~ s/M/\[AC\]/g; $str =~ s/K/\[TG\]/g; $str =~ s/B/\[CGT\]/g; $str =~ s/D/\[AGT\]/g; $str =~ s/H/\[ACT\]/g; $str =~ s/V/\[ACG\]/g; return $str; } 1; BioPerl-1.6.923/Bio/Restriction/Enzyme.pm000444000765000024 13357512254227327 20343 0ustar00cjfieldsstaff000000000000#------------------------------------------------------------------ # # BioPerl module Bio::Restriction::Enzyme # # Please direct questions and support issues to # # Cared for by Rob Edwards # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------ ## POD Documentation: =head1 NAME Bio::Restriction::Enzyme - A single restriction endonuclease (cuts DNA at specific locations) =head1 SYNOPSIS # set up a single restriction enzyme. This contains lots of # information about the enzyme that is generally parsed from a # rebase file and can then be read back use Bio::Restriction::Enzyme; # define a new enzyme with the cut sequence my $re=Bio::Restriction::Enzyme->new (-enzyme=>'EcoRI', -seq=>'G^AATTC'); # once the sequence has been defined a bunch of stuff is calculated # for you: #### PRECALCULATED # find where the enzyme cuts after ... my $ca=$re->cut; # ... and where it cuts on the opposite strand my $oca = $re->complementary_cut; # get the cut sequence string back. # Note that site will return the sequence with a caret my $with_caret=$re->site; #returns 'G^AATTC'; # but it is also a Bio::PrimarySeq object .... my $without_caret=$re->seq; # returns 'GAATTC'; # ... and so does string $without_caret=$re->string; #returns 'GAATTC'; # what is the reverse complement of the cut site my $rc=$re->revcom; # returns 'GAATTC'; # now the recognition length. There are two types: # recognition_length() is the length of the sequence # cutter() estimate of cut frequency my $recog_length = $re->recognition_length; # returns 6 # also returns 6 in this case but would return # 4 for GANNTC and 5 for RGATCY (BstX2I)! $recog_length=$re->cutter; # is the sequence a palindrome - the same forwards and backwards my $pal= $re->palindromic; # this is a boolean # is the sequence blunt (i.e. no overhang - the forward and reverse # cuts are the same) print "blunt\n" if $re->overhang eq 'blunt'; # Overhang can have three values: "5'", "3'", "blunt", and undef # Direction is very important if you use Klenow! my $oh=$re->overhang; # what is the overhang sequence my $ohseq=$re->overhang_seq; # will return 'AATT'; # is the sequence ambiguous - does it contain non-GATC bases? my $ambig=$re->is_ambiguous; # this is boolean print "Stuff about the enzyme\nCuts after: $ca\n", "Complementary cut: $oca\nSite:\n\t$with_caret or\n", "\t$without_caret\n"; print "Reverse of the sequence: $rc\nRecognition length: $recog_length\n", "Is it palindromic? $pal\n"; print "The overhang is $oh with sequence $ohseq\n", "And is it ambiguous? $ambig\n\n"; ### THINGS YOU CAN SET, and get from rich REBASE file # get or set the isoschizomers (enzymes that recognize the same # site) $re->isoschizomers('PvuII', 'SmaI'); # not really true :) print "Isoschizomers are ", join " ", $re->isoschizomers, "\n"; # get or set the methylation sites $re->methylation_sites(2); # not really true :) print "Methylated at ", join " ", keys %{$re->methylation_sites},"\n"; #Get or set the source microbe $re->microbe('E. coli'); print "It came from ", $re->microbe, "\n"; # get or set the person who isolated it $re->source("Rob"); # not really true :) print $re->source, " sent it to us\n"; # get or set whether it is commercially available and the company # that it can be bought at $re->vendors('NEB'); # my favorite print "Is it commercially available :"; print $re->vendors ? "Yes" : "No"; print " and it can be got from ", join " ", $re->vendors, "\n"; # get or set a reference for this $re->reference('Edwards et al. J. Bacteriology'); print "It was not published in ", $re->reference, "\n"; # get or set the enzyme name $re->name('BamHI'); print "The name of EcoRI is not really ", $re->name, "\n"; =head1 DESCRIPTION This module defines a single restriction endonuclease. You can use it to make custom restriction enzymes, and it is used by Bio::Restriction::IO to define enzymes in the New England Biolabs REBASE collection. Use Bio::Restriction::Analysis to figure out which enzymes are available and where they cut your sequence. =head1 RESTRICTION MODIFICATION SYSTEMS At least three geneticaly and biochamically distinct restriction modification systems exist. The cutting components of them are known as restriction endonuleases. The three systems are known by roman numerals: Type I, II, and III restriction enzymes. REBASE format 'cutzymes'(#15) lists enzyme type in its last field. The categories there do not always match the the following short descriptions of the enzymes types. See http://it.stlawu.edu/~tbudd/rmsyst.html for a better overview. =head2 TypeI Type I systems recognize a bipartite asymetrical sequence of 5-7 bp: ---TGA*NnTGCT--- * = methylation sites ---ACTNnA*CGA--- n = 6 for EcoK, n = 8 for EcoB The cleavage site is roughly 1000 (400-7000) base pairs from the recognition site. =head2 TypeII The simplest and most common (at least commercially). Site recognition is via short palindromic base sequences that are 4-6 base pairs long. Cleavage is at the recognition site (but may occasionally be just adjacent to the palindromic sequence, usually within) and may produce blunt end termini or staggered, "sticky end" termini. =head2 TypeIII The recognition site is a 5-7 bp asymmetrical sequence. Cleavage is ATP dependent 24-26 base pairs downstream from the recognition site and usually yields staggered cuts 2-4 bases apart. =head1 COMMENTS I am trying to make this backwards compatible with Bio::Tools::RestrictionEnzyme. Undoubtedly some things will break, but we can fix things as we progress.....! I have added another comments section at the end of this POD that discusses a couple of areas I know are broken (at the moment) =head1 TO DO =over 2 =item * Convert vendors touse full names of companies instead of code =item * Add regular expression based matching to vendors =item * Move away from the archaic ^ notation for cut sites. Ideally I'd totally like to remove this altogether, or add a method that adds it in if someone really wants it. We should be fixed on a sequence, number notation. =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Peter Blaiklock, pblaiklo@restrictionmapper.org Mark A. Jensen, maj-at-fortinbras-dot-us =head1 COPYRIGHT Copyright (c) 2003 Rob Edwards. Some of this work is Copyright (c) 1997-2002 Steve A. Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are not considered part of the public interface and are described here for documentation purposes only. =cut package Bio::Restriction::Enzyme; use strict; use Bio::PrimarySeq; use Data::Dumper; use Tie::RefHash; use vars qw (%TYPE); use base qw(Bio::Root::Root Bio::Restriction::EnzymeI); BEGIN { my %TYPE = (I => 1, II => 1, III => 1); } =head2 new Title : new Function Function : Initializes the Enzyme object Returns : The Restriction::Enzyme object Argument : A standard definition can have several formats. For example: $re->new(-enzyme='EcoRI', -seq->'GAATTC' -cut->'1') Or, you can define the cut site in the sequence, for example $re->new(-enzyme='EcoRI', -seq->'G^AATTC'), but you must use a caret Or, a sequence can cut outside the recognition site, for example $re->new(-enzyme='AbeI', -seq->'CCTCAGC' -cut->'-5/-2') Other arguments: -isoschizomers=>\@list a reference to an array of known isoschizomers -references=>$ref a reference to the enzyme -source=>$source the source (person) of the enzyme -commercial_availability=>@companies a list of companies that supply the enzyme -methylation_site=>\%sites a reference to hash that has the position as the key and the type of methylation as the value -xln_sub => sub { ($self,$cut) = @_; ...; return $xln_cut }, a coderef to a routine that translates the input cut value into Bio::Restriction::Enzyme coordinates ( e.g., for withrefm format, this might be -xln_sub => sub { length( shift()->string ) + shift } ) A Restriction::Enzyme object manages its recognition sequence as a Bio::PrimarySeq object. The minimum requirement is for a name and a sequence. This will create the restriction enzyme object, and define several things about the sequence, such as palindromic, size, etc. =cut # do all cut/comp cut setting within the constructor # new args sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($name,$enzyme,$site,$seq,$precut, $postcut,$cut,$complementary_cut, $is_prototype, $prototype, $isoschizomers, $meth, $microbe, $source, $vendors, $references, $neo, $recog, $xln_sub) = $self->_rearrange([qw( NAME ENZYME SITE SEQ PRECUT POSTCUT CUT COMPLEMENTARY_CUT IS_PROTOTYPE PROTOTYPE ISOSCHIZOMERS METHYLATION_SITES MICROBE SOURCE VENDORS REFERENCES IS_NEOSCHIZOMER RECOG XLN_SUB )], @args); $self->throw('At the minimum, you must define a name and '. 'recognition site for the restriction enzyme') unless (($name || $enzyme) && ($site || $recog || $seq)); $self->{_isoschizomers} = []; $self->{_methylation_sites} = {}; $self->{_vendors} = []; $self->{_references} = []; # squelch warnings $postcut ||=''; # enzyme name $enzyme && $self->name($enzyme); $name && $self->name($name); # site # # note that the site() setter will automatically set # cut(), complementary_cut(), if the cut site is indicated # in $site with '^' /maj # create the cut site if appropriate/this is a kludge due to # the base.pm format in the new B:R order... if ( $cut and $cut <= length $site) { $site = substr($site, 0, $cut).'^'.substr($site, $cut); } if ($site) { $self->site($site); } else { $seq && $self->site($seq); } if ($recog) { $self->recog($recog); } else { $seq && $self->recog($seq); $site && $self->recog($site); } # call revcom_site to initialize it and revcom_recog: $self->revcom_site(); $recog = $self->string; # for length calculations below if ($xln_sub) { $self->warn("Translation subroutine is not a coderef; ignoring") unless ref($xln_sub) eq 'CODE'; } # cut coordinates my ($pc_cut, $pc_comp_cut) = ( $postcut =~ /(-?\d+)\/(-?\d+)/ ); # cut definitions in constructor override any autoset in # site() # definitions in site conform to withrefm coords, translation # happens here if (defined $cut) { $self->cut( $xln_sub ? $xln_sub->($self, $cut) : $cut ); } elsif ( defined $pc_cut ) { $self->cut( $xln_sub ? $xln_sub->($self, $pc_cut) : $pc_cut ); } if (defined $complementary_cut) { $self->complementary_cut($xln_sub ? $xln_sub->($self,$complementary_cut) : $complementary_cut); } elsif (defined $pc_comp_cut) { $self->complementary_cut($xln_sub ? $xln_sub->($self,$pc_comp_cut) : $pc_comp_cut); } $is_prototype && $self->is_prototype($is_prototype); $prototype && $self->prototype($prototype); $isoschizomers && $self->isoschizomers($isoschizomers); $meth && $self->methylation_sites($meth); $microbe && $self->microbe($microbe); $source && $self->source($source); $vendors && $self->vendors($vendors); $references && $self->references($references); $neo && $self->is_neoschizomer($neo); # create multicut enzymes here if $precut defined if (defined $precut) { bless $self, 'Bio::Restriction::Enzyme::MultiCut'; my ($pc_cut, $pc_comp_cut) = $precut =~ /(-?\d+)\/(-?\d+)/; my $re2 = $self->clone; $re2->cut($xln_sub ? $xln_sub->($self, -$pc_cut) : -$pc_cut); $re2->complementary_cut($xln_sub ? $xln_sub->($self, -$pc_comp_cut) : -$pc_comp_cut); $self->others($re2); } return $self; } =head1 Essential methods =cut =head2 name Title : name Usage : $re->name($newval) Function : Gets/Sets the restriction enzyme name Example : $re->name('EcoRI') Returns : value of name Args : newvalue (optional) This will also clean up the name. I have added this because some people get confused about restriction enzyme names. The name should be One upper case letter, and two lower case letters (because it is derived from the organism name, eg. EcoRI is from E. coli). After that it is all confused, but the numbers should be roman numbers not numbers, therefore we'll correct those. At least this will provide some standard, I hope. =cut sub name{ my ($self, $name)=@_; if ($name) { # correct and set the name my $old_name = $name; # remove spaces. Some people write HindIII as Hind III $name =~ s/\s+//g; # change TAILING ones to I's if ($name =~ m/(1+)$/) { my $i = 'I' x length($1); $name =~ s/1+$/$i/; } # make the first letter upper case $name =~ s/^(\w)/uc($1)/e; unless ($name eq $old_name) { # we have changed the name, so send a warning $self->warn("The enzyme name $old_name was changed to $name"); } $self->{'_name'} = $name; } return $self->{'_name'}; } =head2 site Title : site Usage : $re->site(); Function : Gets/sets the recognition sequence for the enzyme. Example : $seq_string = $re->site(); Returns : String containing recognition sequence indicating : cleavage site as in 'G^AATTC'. Argument : n/a Throws : n/a Side effect: the sequence is always converted to upper case. The cut site can also be set by using methods L and L. This will pad out missing sequence with N's. For example the enzyme Acc36I cuts at ACCTGC(4/8). This will be returned as ACCTGCNNNN^ Note that the common notation ACCTGC(4/8) means that the forward strand cut is four nucleotides after the END of the recognition site. The forward cut() in the coordinates used here in Acc36I ACCTGC(4/8) is at 6+4 i.e. 10. ** This is the main setable method for the recognition site. =cut sub site { my ($self, $site) = @_; if ( $site ) { $self->throw("Unrecognized characters in site: [$site]") if $site =~ /[^ATGCMRWSYKVHDBN\^]/i; # we may have to redefine this if there is a ^ in the sequence # first, check and see if we have a cut site in the sequence # if so, find the position, and set the target sequence and cut site $self->{'_site'} = $site; my ($first, $second) = $site =~ /(.*)\^(.*)/; $site = "$1$2" if defined $first; $self->{'_site'} = $site; # now set the recognition site as a new Bio::PrimarySeq object # we need it before calling cut() and complementary_cut() $self->{_seq} = Bio::PrimarySeq->new(-id=>$self->name, -seq=>$site, -verbose=>$self->verbose, -alphabet=>'dna'); if (defined $first) { $self->cut(length $first); $self->complementary_cut(length $second); $self->revcom_site(); } } return $self->{'_site'}; } =head2 revcom_site Title : revcom_site Usage : $re->revcom_site(); Function : Gets/sets the complementary recognition sequence for the enzyme. Example : $seq_string = $re->revcom_site(); Returns : String containing recognition sequence indicating : cleavage site as in 'G^AATTC'. Argument : none (sets on first call) Throws : n/a This is the same as site, except it returns the revcom site. For palindromic enzymes these two are identical. For non-palindromic enzymes they are not! On set, this also handles setting the revcom_recog attribute. See also L above. =cut sub revcom_site { my $self = shift; # getter return $self->{'_revcom_site'} unless !$self->{'_revcom_site'}; # setter my $site = $self->{'_site'}; if ($self->is_palindromic) { $self->{'_revcom_site'}=$self->{'_site'}; $self->revcom_recog( $self->string ); return $self->{'_revcom_site'}; } $self->throw("Unrecognized characters in revcom site: [$site]") if $site =~ /[^ATGCMRWSYKVHDBN\^]/i; if ($site =~ /\^/) { # first, check and see if we have a cut site indicated in the sequence # if so, find the position, and set the target sequence and cut site $site = $self->revcom; $self->revcom_recog( $site ); my $c = length($site)-$self->cut; $site = substr($site, 0, $c).'^'.substr($site,$c); $self->{'_revcom_site'} = $site; } else { my $revcom=$self->revcom; $self->revcom_recog( $revcom ); # my $cc=$self->complementary_cut; # my $hat=length($revcom)-$cc+1; # we need it on the other strand! # if ($cc > length($revcom)) { # my $pad= "N" x ($cc-length($revcom)); # $revcom = $pad. $revcom; # $hat=length($revcom)-$cc+1; # } # elsif ($cc < 0) { # my $pad = "N" x -$cc; # $revcom .= $pad; # $hat=length($revcom); # } # $revcom =~ s/(.{$hat})/$1\^/; $self->{'_revcom_site'}=$revcom; } return $self->{'_revcom_site'}; } =head2 cut Title : cut Usage : $num = $re->cut(1); Function : Sets/gets an integer indicating the position of cleavage relative to the 5' end of the recognition sequence in the forward strand. For type II enzymes, sets the symmetrically positioned reverse strand cut site by calling complementary_cut(). Returns : Integer, 0 if not set Argument : an integer for the forward strand cut site (optional) Note that the common notation ACCTGC(4/8) means that the forward strand cut is four nucleotides after the END of the recognition site. The forwad cut in the coordinates used here in Acc36I ACCTGC(4/8) is at 6+4 i.e. 10. Note that REBASE uses notation where cuts within symmetic sites are marked by '^' within the forward sequence but if the site is asymmetric the parenthesis syntax is used where numbering ALWAYS starts from last nucleotide in the forward strand. That's why AciI has a site usually written as CCGC(-3/-1) actualy cuts in C^C G C G G C^G In our notation, these locations are 1 and 3. The cuts locations in the notation used are relative to the first (non-N) nucleotide of the reported forward strand of the recognition sequence. The following diagram numbers the phosphodiester bonds (marked by + ) which can be cut by the restriction enzymes: 1 2 3 4 5 6 7 8 ... N + N + N + N + N + G + A + C + T + G + G + N + N + N ... -5 -4 -3 -2 -1 =cut sub cut { my ($self, $value) = @_; if (defined $value) { $self->throw("The cut position needs to be an integer [$value]") unless $value =~ /[-+]?\d+/; $self->{'_cut'} = $value; # add the caret to the site attribute only if internal /maj if ( ($self->{_site} !~ /\^/) && ($value <= length ($self->{_site}))) { $self->{_site} = substr($self->{_site}, 0, $value). '^'. substr($self->{_site}, $value); } # auto-set comp cut only if cut site is inside the recog site./maj $self->complementary_cut(length ($self->seq->seq) - $value ) if (($self->{_site} =~ /\^/) && ($self->type eq 'II')); } # return undef if not defined yet, not 0 /maj return $self->{'_cut'}; } =head2 cuts_after Title : cuts_after Usage : Alias for cut() =cut sub cuts_after { shift->cut(@_); } =head2 complementary_cut Title : complementary_cut Usage : $num = $re->complementary_cut('1'); Function : Sets/Gets an integer indicating the position of cleavage : on the reverse strand of the restriction site. Returns : Integer Argument : An integer (optional) Throws : Exception if argument is non-numeric. This method determines the cut on the reverse strand of the sequence. For most enzymes this will be within the sequence, and will be set automatically based on the forward strand cut, but it need not be. B that the returned location indicates the location AFTER the first non-N site nucleotide in the FORWARD strand. =cut sub complementary_cut { my ($self, $num)=@_; if (defined $num) { $self->throw("The cut position needs to be an integer [$num]") unless $num =~ /[-+]?\d+/; $self->{'_rc_cut'} = $num; } # return undef, not 0, if not yet defined /maj return $self->{'_rc_cut'}; } =head1 Read only (usually) recognition site descriptive methods =cut =head2 type Title : type Usage : $re->type(); Function : Get/set the restriction system type Returns : Argument : optional type: ('I'|II|III) Restriction enzymes have been catezorized into three types. Some REBASE formats give the type, but the following rules can be used to classify the known enzymes: =over 4 =item 1 Bipartite site (with 6-8 Ns in the middle and the cut site is E 50 nt away) =E type I =item 2 Site length E 3 =E type I =item 3 5-6 asymmetric site and cuts E20 nt away =E type III =item 4 All other =E type II =back There are some enzymes in REBASE which have bipartite recognition site and cat far from the site but are still classified as type I. I've no idea if this is really so. =cut sub type { my ($self, $value) = @_; if ($value) { $self->throw("Not a valid value [$value], needs to one of : ". join (', ', sort keys %TYPE) ) unless $TYPE{$value}; return $self->{'_type'} = $value; } # pre set #return $self->{'_type'} if $self->{'_type'}; # bipartite return $self->{'_type'} = 'I' if $self->{'_seq'}->seq =~ /N*[^N]+N{6,8}[^N]/ and abs($self->cut) > 50 ; # 3 nt site return $self->{'_type'} = 'I' if $self->{'_seq'}->length == 3; # asymmetric and cuts > 20 nt return $self->{'_type'} = 'III' if (length $self->string == 5 or length $self->string == 6 ) and not $self->palindromic and abs($self->cut) > 20; return $self->{'_type'} = 'II'; } =head2 seq Title : seq Usage : $re->seq(); Function : Get the Bio::PrimarySeq.pm object representing : the recognition sequence Returns : A Bio::PrimarySeq object representing the enzyme recognition site Argument : n/a Throws : n/a =cut sub seq { shift->{'_seq'}; } =head2 string Title : string Usage : $re->string(); Function : Get a string representing the recognition sequence. Returns : String. Does NOT contain a '^' representing the cut location as returned by the site() method. Argument : n/a Throws : n/a =cut sub string { shift->{'_seq'}->seq; } =head2 recog Title : recog Usage : $enz->recog($recognition_sequence) Function: Gets/sets the pure recognition site. Sets as regexp if appropriate. As for string(), the cut indicating carets (^) are expunged. Example : Returns : value of recog (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub recog{ my $self = shift; my $recog = shift; return $self->{'recog'} unless $recog; $recog =~ s/\^//g; $recog = _expand($recog) if $recog =~ /[^ATGC]/; return $self->{'recog'} = $recog; } =head2 revcom_recog Title : revcom_recog Usage : $enz->revcom_recog($recognition_sequence) Function: Gets/sets the pure reverse-complemented recognition site. Sets as regexp if appropriate. As for string(), the cut indicating carets (^) are expunged. Example : Returns : value of recog (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub revcom_recog{ my $self = shift; my $recog = shift; unless ($recog) { $self->throw( "revcom recognition site not set; call \$enz->revcom_site to initialize" ) unless $self->{'revcom_recog'}; return $self->{'revcom_recog'}; } $recog =~ s/\^//g; $recog = _expand($recog) if $recog =~ /[^ATGC]/; return $self->{'revcom_recog'} = $recog; } =head2 revcom Title : revcom Usage : $re->revcom(); Function : Get a string representing the reverse complement of : the recognition sequence. Returns : String Argument : n/a Throws : n/a =cut sub revcom { shift->{'_seq'}->revcom->seq(); } =head2 recognition_length Title : recognition_length Usage : $re->recognition_length(); Function : Get the length of the RECOGNITION sequence. This is the total recognition sequence, inluding the ambiguous codes. Returns : An integer Argument : Nothing See also: L =cut sub recognition_length { my $self = shift; return length($self->string); } =head2 cutter Title : cutter Usage : $re->cutter Function : Returns the "cutter" value of the recognition site. This is a value relative to site length and lack of ambiguity codes. Hence: 'RCATGY' is a five (5) cutter site and 'CCTNAGG' a six cutter This measure correlates to the frequency of the enzyme cuts much better than plain recognition site length. Example : $re->cutter Returns : integer or float number Args : none Why is this better than just stripping the ambiguos codes? Think about it like this: You have a random sequence; all nucleotides are equally probable. You have a four nucleotide re site. The probability of that site finding a match is one out of 4^4 or 256, meaning that on average a four cutter finds a match every 256 nucleotides. For a six cutter, the average fragment length is 4^6 or 4096. In the case of ambiguity codes the chances are finding the match are better: an R (A|T) has 1/2 chance of finding a match in a random sequence. Therefore, for RGCGCY the probability is one out of (2*4*4*4*4*2) which exactly the same as for a five cutter! Cutter, although it can have non-integer values turns out to be a useful and simple measure. From bug 2178: VHDB are ambiguity symbols that match three different nucleotides, so they contribute less to the effective recognition sequence length than e.g. Y which matches only two nucleotides. A symbol which matches n of the 4 nucleotides has an effective length of 1 - log(n) / log(4). =cut sub cutter { my ($self)=@_; $_ = uc $self->string; my $cutter = tr/[ATGC]//d; my $count = tr/[MRWSYK]//d; $cutter += $count/2; $count = tr/[VHDB]//d; $cutter += $count * (1 - log(3) / log(4)); return $cutter; } =head2 is_palindromic Title : is_palindromic Alias : palindromic Usage : $re->is_palindromic(); Function : Determines if the recognition sequence is palindromic : for the current restriction enzyme. Returns : Boolean Argument : n/a Throws : n/a A palindromic site (EcoRI): 5-GAATTC-3 3-CTTAAG-5 =cut sub is_palindromic { my $self = shift; return $self->{_palindromic} if defined $self->{_palindromic}; if ($self->string eq $self->revcom) { return $self->{_palindromic}=1; } return $self->{_palindromic} = 0; } sub palindromic { shift->is_palindromic(@_) } =head2 is_symmetric Title : is_symmetric Alias : symmetric Usage : $re->is_symmetric(); Function : Determines if the enzyme is a symmetric cutter Returns : Boolean Argument : none A symmetric but non-palindromic site (HindI): v 5-C A C-3 3-G T G-5 ^ =cut sub is_symmetric { no warnings qw( uninitialized ); my $self = shift; return $self->{_symmetric} if defined $self->{_symmetric}; if ($self->is_palindromic) { return $self->{_symmetric} = 1; } if ($self->cut == length($self->string) - $self->complementary_cut) { return $self->{_symmetric}=1; } return $self->{_symmetric} = 0; } sub symmetric { shift->is_symmetric(@_) } =head2 overhang Title : overhang Usage : $re->overhang(); Function : Determines the overhang of the restriction enzyme Returns : "5'", "3'", "blunt" of undef Argument : n/a Throws : n/a A blunt site in SmaI returns C 5' C C C^G G G 3' 3' G G G^C C C 5' A 5' overhang in EcoRI returns C<5'> 5' G^A A T T C 3' 3' C T T A A^G 5' A 3' overhang in KpnI returns C<3'> 5' G G T A C^C 3' 3' C^C A T G G 5' =cut sub overhang { my $self = shift; unless ($self->{'_cut'} && $self->{'_rc_cut'}) { return "unknown"; } if ($self->{_cut} < $self->{_rc_cut}) { $self->{_overhang}="5'"; } elsif ($self->{_cut} == $self->{_rc_cut}) { $self->{_overhang}="blunt"; } elsif ($self->{_cut} > $self->{_rc_cut}) { $self->{_overhang}="3'"; } else { $self->{_overhang}="unknown"; } return $self->{_overhang} } =head2 overhang_seq Title : overhang_seq Usage : $re->overhang_seq(); Function : Determines the overhang sequence of the restriction enzyme Returns : a Bio::LocatableSeq Argument : n/a Throws : n/a I do not think it is necessary to create a seq object of these. (Heikki) Note: returns empty string for blunt sequences and undef for ones that we don't know. Compare these: A blunt site in SmaI returns empty string 5' C C C^G G G 3' 3' G G G^C C C 5' A 5' overhang in EcoRI returns C 5' G^A A T T C 3' 3' C T T A A^G 5' A 3' overhang in KpnI returns C 5' G G T A C^C 3' 3' C^C A T G G 5' Note that you need to use method L to decide whether it is a 5' or 3' overhang!!! Note: The overhang stuff does not work if the site is asymmetric! Rethink! =cut sub overhang_seq { my $self = shift; # my $overhang->Bio::PrimarySeq(-id=>$self->name . '-overhang', # -verbose=>$self->verbose, # -alphabet=>'dna'); return '' if $self->overhang eq 'blunt' ; unless ($self->{_cut} && $self->{_rc_cut}) { # lets just check that we really can't figure it out $self->cut; $self->complementary_cut; unless ($self->{_cut} && $self->{_rc_cut}) { return; } } # this is throwing an error for sequences outside the restriction # site (eg ^NNNNGATCNNNN^) # So if this is the case we need to fake these guys if (($self->{_cut}<0) || ($self->{_rc_cut}<0) || ($self->{_cut}>$self->seq->length) || ($self->{_rc_cut}>$self->seq->length)) { my $tempseq=$self->site; my ($five, $three)=split /\^/, $tempseq; if ($self->{_cut} > $self->{_rc_cut}) { return substr($five, $self->{_rc_cut}) } elsif ($self->{_cut} < $self->{_rc_cut}) { return substr($three, 0, $self->{_rc_cut}) } else { return ''; } } if ($self->{_cut} > $self->{_rc_cut}) { return $self->seq->subseq($self->{_rc_cut}+1,$self->{_cut}); } elsif ($self->{_cut} < $self->{_rc_cut}) { return $self->seq->subseq($self->{_cut}+1, $self->{_rc_cut}); } else { return ''; } } =head2 compatible_ends Title : compatible_ends Usage : $re->compatible_ends($re2); Function : Determines if the two restriction enzyme cut sites have compatible ends. Returns : 0 if not, 1 if only one pair ends match, 2 if both ends. Argument : a Bio::Restriction::Enzyme Throws : unless the argument is a Bio::Resriction::Enzyme and if there are Ns in the ovarhangs In case of type II enzymes which which cut symmetrically, this function can be considered to return a boolean value. =cut sub compatible_ends { my ($self, $re) = @_; $self->throw("Need a Bio::Restriction::Enzyme as an argument, [$re]") unless $re->isa('Bio::Restriction::Enzyme'); # $self->throw("Only type II enzymes work now") # unless $self->type eq 'II'; $self->debug("N(s) in overhangs. Can not compare") if $self->overhang_seq =~ /N/ or $re->overhang_seq =~ /N/; return 2 if $self->overhang_seq eq $re->overhang_seq and $self->overhang eq $re->overhang; return 0; } =head2 is_ambiguous Title : is_ambiguous Usage : $re->is_ambiguous(); Function : Determines if the restriction enzyme contains ambiguous sequences Returns : Boolean Argument : n/a Throws : n/a =cut sub is_ambiguous { my $self = shift; return $self->string =~ m/[^AGCT]/ ? 1 : 0 ; } =head2 Additional methods from Rebase =cut =head2 is_prototype Title : is_prototype Usage : $re->is_prototype Function : Get/Set method for finding out if this enzyme is a prototype Example : $re->is_prototype(1) Returns : Boolean Args : none Prototype enzymes are the most commonly available and usually first enzymes discoverd that have the same recognition site. Using only prototype enzymes in restriction analysis avoids redundancy and speeds things up. =cut sub is_prototype { my ($self, $value) = @_; if (defined $value) { return $self->{'_is_prototype'} = $value ; } if (defined $self->{'_is_prototype'}) { return $self->{'_is_prototype'} } else { $self->warn("Can't unequivocally assign prototype based on input format alone"); return } } =head2 is_neoschizomer Title : is_neoschizomer Usage : $re->is_neoschizomer Function : Get/Set method for finding out if this enzyme is a neoschizomer Example : $re->is_neoschizomer(1) Returns : Boolean Args : none Neoschizomers are distinguishable from the prototype enzyme by having a different cleavage pattern. Note that not all formats report this =cut sub is_neoschizomer { my ($self, $value) = @_; if (defined $value) { return $self->{'_is_neoschizomer'} = $value ; } if (defined $self->{'_is_neoschizomer'}) { return $self->{'_is_neoschizomer'} } else { $self->warn("Can't unequivocally assign neoschizomer based on input format alone"); return } } =head2 prototype_name Title : prototype_name Alias : prototype Usage : $re->prototype_name Function : Get/Set method for the name of prototype for this enzyme's recognition site Example : $re->prototype_name(1) Returns : prototype enzyme name string or an empty string Args : optional prototype enzyme name string If the enzyme itself is the prototype, its own name is returned. Not to confuse the negative result with an unset value, use method L. This method is called I rather than I, because it returns a string rather than on object. =cut sub prototype_name { my $self = shift; $self->{'_prototype'} = shift if @_; return $self->name if $self->{'_is_prototype'}; return $self->{'_prototype'} || ''; } sub prototype { shift->prototype_name(@_) } =head2 isoschizomers Title : isoschizomers Alias : isos Usage : $re->isoschizomers(@list); Function : Gets/Sets a list of known isoschizomers (enzymes that recognize the same site, but don't necessarily cut at the same position). Arguments : A reference to an array that contains the isoschizomers Returns : A reference to an array of the known isoschizomers or 0 if not defined. This has to be the hardest name to spell, so now you can use the alias 'isos'. Added for compatibility to REBASE =cut sub isoschizomers { my ($self) = shift; push @{$self->{_isoschizomers}}, @_ if @_; # make sure that you don't dereference if null # chad believes quite strongly that you should return # a reference to an array anyway. don't bother dereferencing. # i'll post that to the list. if ($self->{'_isoschizomers'}) { return @{$self->{_isoschizomers}}; } } sub isos { shift->isoschizomers(@_) } =head2 purge_isoschizomers Title : purge_isoschizomers Alias : purge_isos Usage : $re->purge_isoschizomers(); Function : Purges the set of isoschizomers for this enzyme Arguments : Returns : 1 =cut sub purge_isoschizomers { my ($self) = shift; $self->{_isoschizomers} = []; } sub purge_isos { shift->purge_isoschizomers(@_) } =head2 methylation_sites Title : methylation_sites Usage : $re->methylation_sites(\%sites); Function : Gets/Sets known methylation sites (positions on the sequence that get modified to promote or prevent cleavage). Arguments : A reference to a hash that contains the methylation sites Returns : A reference to a hash of the methylation sites or an empty string if not defined. There are three types of methylation sites: =over 3 =item * (6) = N6-methyladenosine =item * (5) = 5-methylcytosine =item * (4) = N4-methylcytosine =back These are stored as 6, 5, and 4 respectively. The hash has the sequence position as the key and the type of methylation as the value. A negative number in the sequence position indicates that the DNA is methylated on the complementary strand. Note that in REBASE, the methylation positions are given Added for compatibility to REBASE. =cut sub methylation_sites { my $self = shift; while (@_) { my $key = shift; $self->{'_methylation_sites'}->{$key} = shift; } return %{$self->{_methylation_sites}}; } =head2 purge_methylation_sites Title : purge_methylation_sites Usage : $re->purge_methylation_sites(); Function : Purges the set of methylation_sites for this enzyme Arguments : Returns : =cut sub purge_methylation_sites { my ($self) = shift; $self->{_methylation_sites} = {}; } =head2 microbe Title : microbe Usage : $re->microbe($microbe); Function : Gets/Sets microorganism where the restriction enzyme was found Arguments : A scalar containing the microbes name Returns : A scalar containing the microbes name or 0 if not defined Added for compatibility to REBASE =cut sub microbe { my ($self, $microbe) = @_; if ($microbe) { $self->{_microbe}=$microbe; } return $self->{_microbe} || ''; } =head2 source Title : source Usage : $re->source('Rob Edwards'); Function : Gets/Sets the person who provided the enzyme Arguments : A scalar containing the persons name Returns : A scalar containing the persons name or 0 if not defined Added for compatibility to REBASE =cut sub source { my ($self, $source) = @_; if ($source) { $self->{_source}=$source; } return $self->{_source} || ''; } =head2 vendors Title : vendors Usage : $re->vendor(@list_of_companies); Function : Gets/Sets the a list of companies that you can get the enzyme from. Also sets the commercially_available boolean Arguments : A reference to an array containing the names of companies that you can get the enzyme from Returns : A reference to an array containing the names of companies that you can get the enzyme from Added for compatibility to REBASE =cut sub vendors { my $self = shift; push @{$self->{_vendors}}, @_ if @_; if ($self->{'_vendors'}) { return @{$self->{'_vendors'}}; } } =head2 purge_vendors Title : purge_vendors Usage : $re->purge_references(); Function : Purges the set of references for this enzyme Arguments : Returns : =cut sub purge_vendors { my ($self) = shift; $self->{_vendors} = []; } =head2 vendor Title : vendor Usage : $re->vendor(@list_of_companies); Function : Gets/Sets the a list of companies that you can get the enzyme from. Also sets the commercially_available boolean Arguments : A reference to an array containing the names of companies that you can get the enzyme from Returns : A reference to an array containing the names of companies that you can get the enzyme from Added for compatibility to REBASE =cut sub vendor { my $self = shift; return push @{$self->{_vendors}}, @_; return $self->{_vendors}; } =head2 references Title : references Usage : $re->references(string); Function : Gets/Sets the references for this enzyme Arguments : an array of string reference(s) (optional) Returns : an array of references Use L to reset the list of references This should be a L object, but its not (yet) =cut sub references { my ($self) = shift; push @{$self->{_references}}, @_ if @_; return @{$self->{_references}}; } =head2 purge_references Title : purge_references Usage : $re->purge_references(); Function : Purges the set of references for this enzyme Arguments : Returns : 1 =cut sub purge_references { my ($self) = shift; $self->{_references} = []; } =head2 clone Title : clone Usage : $re->clone Function : Deep copy of the object Arguments : - Returns : new Bio::Restriction::EnzymeI object This works as long as the object is a clean in-memory object using scalars, arrays and hashes. You have been warned. If you have module Storable, it is used, otherwise local code is used. Todo: local code cuts circular references. =cut # there's some issue here; deprecating and rolling another below/maj sub clone_depr { my ($self, $this) = @_; eval { require Storable; }; return Storable::dclone($self) unless $@; # modified from deep_copy() @ http://www.stonehenge.com/merlyn/UnixReview/col30.html unless ($this) { my $new; foreach my $k (keys %$self) { if (not ref $self->{$k}) { $new->{$k} = $self->{$k}; } else { $new->{$k} = $self->clone($self->{$k}); } #print Dumper $new; } bless $new, ref($self); return $new; } if (not ref $this) { $this; } elsif (ref $this eq "ARRAY") { [map $self->clone($_), @$this]; } elsif (ref $this eq "HASH") { +{map { $_ => $self->clone($this->{$_}) } keys %$this}; } else { # objects return if $this->isa('Bio::Restriction::EnzymeI'); return $this->clone if $this->can('clone'); my $obj; foreach my $k (keys %$this) { if (not ref $this->{$k}) { $obj->{$k} = $this->{$k}; } else { $obj->{$k} = $this->clone($this->{$k}); } } bless $obj, ref($this); return $obj; } } sub clone { my $self = shift; my ($this, $visited) = @_; unless (defined $this) { my %h; tie %h, 'Tie::RefHash'; my $visited = \%h; return $self->clone($self, $visited); } my $thing; for ($this) { if (ref) { return $visited->{$this} if $visited->{$this}; } # scalar (!ref) && do { $thing = $this; last; }; # object (ref =~ /^Bio::/) && do { $thing = {}; bless($thing, ref); $visited->{$this} = $thing; foreach my $attr (keys %{$_}) { $thing->{$attr} = (defined $_->{$attr} ? $self->clone($_->{$attr},$visited) : undef ); } last; }; (ref eq 'ARRAY') && do { $thing = []; $visited->{$this} = $thing; foreach my $elt (@{$_}) { push @$thing, (defined $elt ? $self->clone($elt,$visited) : undef); } last; }; (ref eq 'HASH') && do { $thing = {}; $visited->{$this} = $thing; no warnings qw( uninitialized ); # avoid 'uninitialized value' warning against $key foreach my $key (%{$_}) { $thing->{$key} = (defined $_->{key} ? $self->clone( $_->{$key},$visited) : undef ); } use warnings; last; }; (ref eq 'SCALAR') && do { $thing = ${$_}; $visited->{$this} = $thing; $thing = \$thing; last; }; } return $thing; } =head2 _expand Title : _expand Function : Expand nucleotide ambiguity codes to their representative letters Returns : The full length string Arguments : The string to be expanded. Stolen from the original RestrictionEnzyme.pm =cut sub _expand { my $str = shift; $str =~ s/N|X/\./g; $str =~ s/R/\[AG\]/g; $str =~ s/Y/\[CT\]/g; $str =~ s/S/\[GC\]/g; $str =~ s/W/\[AT\]/g; $str =~ s/M/\[AC\]/g; $str =~ s/K/\[TG\]/g; $str =~ s/B/\[CGT\]/g; $str =~ s/D/\[AGT\]/g; $str =~ s/H/\[ACT\]/g; $str =~ s/V/\[ACG\]/g; return $str; } 1; BioPerl-1.6.923/Bio/Restriction/EnzymeCollection.pm000444000765000024 2703512254227340 22323 0ustar00cjfieldsstaff000000000000#------------------------------------------------------------------------------- # # BioPerl module Bio::Restriction::EnzymeCollection # # Please direct questions and support issues to # # Cared for by Rob Edwards # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------------------- ## POD Documentation: =head1 NAME Bio::Restriction::EnzymeCollection - Set of restriction endonucleases =head1 SYNOPSIS use Bio::Restriction::EnzymeCollection; # Create a collection with the default enzymes. my $default_collection = Bio::Restriction::EnzymeCollection->new(); # Or create a collection from a REBASE 'withrefm' file obtained from # ftp://ftp.neb.com/pub/rebase/. (See Bio::Restriction::IO for more # information.) my $rebase = Bio::Restriction::IO->new( -file => 'withrefm.610', -format => 'withrefm' ); my $rebase_collection = $rebase->read(); # Or create an empty collection and set the enzymes later. See # 'CUSTOM COLLECTIONS' below for more information. my $empty_collection = Bio::Restriction::EnzymeCollection->new( -empty => 1 ); # Get an array of Bio::Restriction::Enzyme objects from the collection. my @enzymes = $default_collection->each_enzyme(); # Get a Bio::Restriction::Enzyme object for a particular enzyme by name. my $enz = $default_collection->get_enzyme( 'EcoRI' ); # Get a Bio::Restriction::EnzymeCollection object containing the enzymes # that have the equivalent of 6-bp recognition sequences. my $six_cutters = $default_collection->cutters( 6 ); # Get a Bio::Restriction::EnzymeCollection object containing the enzymes # that are rare cutters. my $rare_cutters = $default_collection->cutters( -start => 6, -end => 8 ); # Get a Bio::Restriction::EnzymeCollection object that contains enzymes # that generate blunt ends: my $blunt_cutters = $default_collection->blunt_enzymes(); # See 'CUSTOM COLLECTIONS' below for an example of creating a # Bio::Restriction::EnzymeCollection object with a specified subset of # enzymes using methods provided by the Bio::RestrictionEnzyme class. =head1 DESCRIPTION Bio::Restriction::EnzymeCollection represents a collection of restriction enzymes. If you create a new collection directly rather than from a REBASE file using L, it will be populated by a default set of enzymes with site and cut information only. Use L to figure out which enzymes are available and where they cut your sequence. =head1 CUSTOM COLLECTIONS Note that the underlying L objects have a rich variety of methods that allow more complicated selections than the methods that are defined by Bio::Restriction::EnzymeCollection. For example, the way to create a custom collection of Type II enzymes is as follows: my $complete_collection = Bio::Restriction::EnzymeCollection->new(); my $type_ii_collection = Bio::Restriction::EnzymeCollection->new( -empty => 1 ); $type_ii_collection->enzymes( grep { $_->type() eq 'II' } $complete_collection->each_enzyme() ); =head1 SEE ALSO L - read in enzymes from REBASE files L - figure out what enzymes cut a sequence L - define a single restriction enzyme =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 COPYRIGHT Copyright (c) 2003 Rob Edwards. Some of this work is Copyright (c) 1997-2002 Steve A. Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are not considered part of the public interface and are described here for documentation purposes only. =cut package Bio::Restriction::EnzymeCollection; use strict; use Bio::Restriction::Enzyme; use Bio::Restriction::IO; use Data::Dumper; use base qw(Bio::Root::Root); =head2 new Title : new Function : Initializes the Restriction::EnzymeCollection object Returns : The Restriction::EnzymeCollection object Arguments : optional named parameter -empty Set parameter -empty to true if you do NOT want the collection be populated by the default set of prototype type II enzymes. Alternatively, pass an array of enzymes to -enzymes parameter. =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($empty, $enzymes) = $self->_rearrange([qw( EMPTY ENZYMES )], @args); $self->{'_all_enzymes'} = []; $self->{'_enzymes'} = {}; return $self if $empty; if ($enzymes) { # as advertised in pod/maj $self->throw( "Arg to -enzymes must be an arrayref to Bio::Restriction::Enzyme objects") unless ref($enzymes) eq 'ARRAY'; $self->enzymes(@$enzymes); return $self; } else { # the default set of enzymes my $in = Bio::Restriction::IO->new(-verbose => $self->verbose); return $in->read; } } =head2 Manipulate the enzymes within the collection =cut =head2 enzymes Title : enzyme Function : add/get method for enzymes and enzyme collections Returns : object itself Arguments : array of Bio::Restriction::Enzyme and Bio::Restriction::EnzymeCollection objects =cut sub enzymes { my ($self, @enzs)=@_; foreach my $e (@enzs) { if ( ref $e eq '') { print "|$e|\n"; } elsif ($e->isa('Bio::Restriction::EnzymeI')) { push(@{$self->{'_all_enzymes'}},$e); $self->{'_enzymes'}->{$e->name} = $e; } elsif ($e->isa('Bio::Restriction::EnzymeCollection')) { $self->enzymes($e->each_enzyme); } else { my $r = 1; $self->warn("EnzymeCollection can not deal with ". ref($e)." objects"); } } return $self; } # # method to remove duplicates? # =head2 each_enzyme Title : each_enzyme Function : get an array of enzymes Returns : array of Bio::Restriction::Enzyme objects Arguments : - =cut sub each_enzyme { my $self = shift; return @{$self->{'_all_enzymes'}}; } =head2 get_enzyme Title : get_enzyme Function : Gets a Bio::Restriction::Enzyme object for the enzyme name Returns : A Bio::Restriction::Enzyme object or undef Arguments : An enzyme name that is in the collection =cut sub get_enzyme { my ($self, $name)=@_; return $self->{'_enzymes'}->{$name}; } =head2 available_list Title : available_list Function : Gets a list of all the enzymes that we know about Returns : A reference to an array with all the enzyme names that we have defined or 0 if none are defined Arguments : Nothing Comments : Note, I maintain this for backwards compatibility, but I don't like the name as it is very ambiguous =cut sub available_list { my ($self, $size)=@_; my @keys = sort keys %{$self->{'_enzymes'}}; return @keys; } =head2 longest_cutter Title : longest_cutter Function : Gets the enzyme with the longest recognition site Returns : A Bio::Restriction::Enzyme object Arguments : Nothing Comments : Note, this is used by Bio::Restriction::Analysis to figure out what to do with circular sequences =cut sub longest_cutter { my ($self)=@_; my $longest=0; my $longest_enz='.'; foreach my $enz ($self->each_enzyme) { my $len=$enz->recognition_length; if ($len > $longest) {$longest=$len; $longest_enz=$enz} } return $longest_enz; } =head2 Filter enzymes =cut =head2 blunt_enzymes Title : blunt_enzymes Function : Gets a list of all the enzymes that are blunt cutters Returns : A reference to an array with all the enzyme names that are blunt cutters or 0 if none are defined Arguments : Nothing Comments : This is an example of the kind of filtering better done by the scripts using the rich collection of methods in Bio::Restriction::Enzyme. =cut sub blunt_enzymes { my $self=shift; my $bs = Bio::Restriction::EnzymeCollection->new(-empty => 1); return $bs->enzymes( grep { $_->overhang eq 'blunt' } $self->each_enzyme ); } =head2 cutters Title : cutters Function : Gets a list of all the enzymes that recognize a certain size, e.g. 6-cutters Usage : $cutters = $collection->cutters(6); Returns : A reference to an array with all the enzyme names that are x cutters or 0 if none are defined Arguments : A positive number for the size of cutters to return OR A range: (-start => 6, -end => 8, -inclusive => 1, -exclusive = 0 ) The default for a range is 'inclusive' =cut sub cutters { my ($self) = shift; return unless @_; # no argument if (scalar @_ == 1 ) { my $size = shift; my @sizes; (ref $size eq 'ARRAY') ? push @sizes, @{$size} : push @sizes, $size; my $bs = Bio::Restriction::EnzymeCollection->new(-empty => 1); for my $size (@sizes) { $self->throw("Need a positive number [$size]") unless $size =~ /[+]?[\d\.]+/; foreach my $e ($self->each_enzyme) { ##print $e->name, ": ", $e->cutter, "\n" if $e->cutter == $size; $bs->enzymes($e) if $e->cutter == $size; } } return $bs; } else { # named arguments my ($start, $end, $inclusive, $exclusive ) = $self->_rearrange([qw( START END INCLUSIVE EXCLUSIVE )], @_); $self->throw("Start needs a positive number [$start]") unless $start =~ /[+]?[\d\.]+/; $self->throw("End needs a positive number [$end]") unless $end =~ /[+]?[\d\.]+/; my $limits; $inclusive = 1 if $inclusive or not $exclusive; $inclusive = 0 if $exclusive; my $bs = Bio::Restriction::EnzymeCollection->new(-empty => 1); if ($inclusive) { foreach my $e ($self->each_enzyme) { $bs->enzymes($e) if $e->cutter >= $start and $e->cutter <= $end; } } else { foreach my $e ($self->each_enzyme) { $bs->enzymes($e) if $e->cutter > $start and $e->cutter < $end; } } return $bs; } } 1; BioPerl-1.6.923/Bio/Restriction/EnzymeI.pm000444000765000024 4701312254227316 20421 0ustar00cjfieldsstaff000000000000#------------------------------------------------------------------ # # BioPerl module Bio::Restriction::EnzymeI # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------ ## POD Documentation: =head1 NAME Bio::Restriction::EnzymeI - Interface class for restriction endonuclease =head1 SYNOPSIS # do not run this class directly =head1 DESCRIPTION This module defines methods for a single restriction endonuclease. For an implementation, see L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Rob Edwards, redwards@utmem.edu =head1 SEE ALSO L =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are not considered part of the public interface and are described here for documentation purposes only. =cut package Bio::Restriction::EnzymeI; use strict; use base qw(Bio::Root::RootI); =head1 Essential methods =cut =head2 name Title : name Usage : $re->name($newval) Function : Gets/Sets the restriction enzyme name Example : $re->name('EcoRI') Returns : value of name Args : newvalue (optional) This will also clean up the name. I have added this because some people get confused about restriction enzyme names. The name should be One upper case letter, and two lower case letters (because it is derived from the organism name, eg. EcoRI is from E. coli). After that it is all confused, but the numbers should be roman numbers not numbers, therefore we'll correct those. At least this will provide some standard, I hope. =cut sub name { shift->throw_not_implemented; } =head2 site Title : site Usage : $re->site(); Function : Gets/sets the recognition sequence for the enzyme. Example : $seq_string = $re->site(); Returns : String containing recognition sequence indicating : cleavage site as in 'G^AATTC'. Argument : n/a Throws : n/a Side effect: the sequence is always converted to upper case. The cut site can also be set by using methods L and L. This will pad out missing sequence with N's. For example the enzyme Acc36I cuts at ACCTGC(4/8). This will be returned as ACCTGCNNNN^ Note that the common notation ACCTGC(4/8) means that the forward strand cut is four nucleotides after the END of the recognition site. The forward cut() in the coordinates used here in Acc36I ACCTGC(4/8) is at 6+4 i.e. 10. ** This is the main setable method for the recognition site. =cut sub site { shift->throw_not_implemented; } =head2 revcom_site Title : revcom_site Usage : $re->revcom_site(); Function : Gets/sets the complementary recognition sequence for the enzyme. Example : $seq_string = $re->revcom_site(); Returns : String containing recognition sequence indicating : cleavage site as in 'G^AATTC'. Argument : Sequence of the site Throws : n/a This is the same as site, except it returns the revcom site. For palindromic enzymes these two are identical. For non-palindromic enzymes they are not! See also L above. =cut sub cuts_after { shift->throw_not_implemented; } =head2 cut Title : cut Usage : $num = $re->cut(1); Function : Sets/gets an integer indicating the position of cleavage relative to the 5' end of the recognition sequence in the forward strand. For type II enzymes, sets the symmetrically positioned reverse strand cut site by calling complementary_cut(). Returns : Integer, 0 if not set Argument : an integer for the forward strand cut site (optional) Note that the common notation ACCTGC(4/8) means that the forward strand cut is four nucleotides after the END of the recognition site. The forwad cut in the coordinates used here in Acc36I ACCTGC(4/8) is at 6+4 i.e. 10. Note that REBASE uses notation where cuts within symmetic sites are marked by '^' within the forward sequence but if the site is asymmetric the parenthesis syntax is used where numbering ALWAYS starts from last nucleotide in the forward strand. That's why AciI has a site usually written as CCGC(-3/-1) actualy cuts in C^C G C G G C^G In our notation, these locations are 1 and 3. The cuts locations in the notation used are relative to the first (non-N) nucleotide of the reported forward strand of the recognition sequence. The following diagram numbers the phosphodiester bonds (marked by + ) which can be cut by the restriction enzymes: 1 2 3 4 5 6 7 8 ... N + N + N + N + N + G + A + C + T + G + G + N + N + N ... -5 -4 -3 -2 -1 =cut sub cut { shift->throw_not_implemented; } =head2 complementary_cut Title : complementary_cut Usage : $num = $re->complementary_cut('1'); Function : Sets/Gets an integer indicating the position of cleavage : on the reverse strand of the restriction site. Returns : Integer Argument : An integer (optional) Throws : Exception if argument is non-numeric. This method determines the cut on the reverse strand of the sequence. For most enzymes this will be within the sequence, and will be set automatically based on the forward strand cut, but it need not be. B that the returned location indicates the location AFTER the first non-N site nucleotide in the FORWARD strand. =cut sub complementary_cut { shift->throw_not_implemented; } =head1 Read only (usually) recognition site descriptive methods =cut =head2 type Title : type Usage : $re->type(); Function : Get/set the restriction system type Returns : Argument : optional type: ('I'|II|III) Restriction enzymes have been catezorized into three types. Some REBASE formats give the type, but the following rules can be used to classify the known enzymes: =over 4 =item 1 Bipartite site (with 6-8 Ns in the middle and the cut site is E 50 nt away) =E type I =item 2 Site length E 3 =E type I =item 3 5-6 asymmetric site and cuts E20 nt away =E type III =item 4 All other =E type II =back There are some enzymes in REBASE which have bipartite recognition site and cat far from the site but are still classified as type I. I've no idea if this is really so. =cut sub type { shift->throw_not_implemented; } =head2 seq Title : seq Usage : $re->seq(); Function : Get the Bio::PrimarySeq.pm object representing : the recognition sequence Returns : A Bio::PrimarySeq object representing the enzyme recognition site Argument : n/a Throws : n/a =cut sub seq { shift->throw_not_implemented; } =head2 string Title : string Usage : $re->string(); Function : Get a string representing the recognition sequence. Returns : String. Does NOT contain a '^' representing the cut location as returned by the site() method. Argument : n/a Throws : n/a =cut sub string { shift->throw_not_implemented; } =head2 revcom Title : revcom Usage : $re->revcom(); Function : Get a string representing the reverse complement of : the recognition sequence. Returns : String Argument : n/a Throws : n/a =cut sub revcom { shift->throw_not_implemented; } =head2 recognition_length Title : recognition_length Usage : $re->recognition_length(); Function : Get the length of the RECOGNITION sequence. This is the total recognition sequence, inluding the ambiguous codes. Returns : An integer Argument : Nothing See also: L =cut sub recognition_length { shift->throw_not_implemented; } =head2 non_ambiguous_length Title : non_ambiguous_length Usage : $re->non_ambiguous_length(); Function : Get the nonambiguous length of the RECOGNITION sequence. This is the total recognition sequence, excluding the ambiguous codes. Returns : An integer Argument : Nothing See also: L =cut sub non_ambiguous_length { shift->throw_not_implemented; } =head2 cutter Title : cutter Usage : $re->cutter Function : Returns the "cutter" value of the recognition site. This is a value relative to site length and lack of ambiguity codes. Hence: 'RCATGY' is a five (5) cutter site and 'CCTNAGG' a six cutter This measure correlates to the frequency of the enzyme cuts much better than plain recognition site length. Example : $re->cutter Returns : integer or float number Args : none Why is this better than just stripping the ambiguous codes? Think about it like this: You have a random sequence; all nucleotides are equally probable. You have a four nucleotide re site. The probability of that site finding a match is one out of 4^4 or 256, meaning that on average a four cutter finds a match every 256 nucleotides. For a six cutter, the average fragment length is 4^6 or 4096. In the case of ambiguity codes the chances are finding the match are better: an R (A|T) has 1/2 chance of finding a match in a random sequence. Therefore, for RGCGCY the probability is one out of (2*4*4*4*4*2) which exactly the same as for a five cutter! Cutter, although it can have non-integer values turns out to be a useful and simple measure. From bug 2178: VHDB are ambiguity symbols that match three different nucleotides, so they contribute less to the effective recognition sequence length than e.g. Y which matches only two nucleotides. A symbol which matches n of the 4 nucleotides has an effective length of 1 - log(n) / log(4). =cut sub cutter { shift->throw_not_implemented; } =head2 is_palindromic Title : is_palindromic Usage : $re->is_palindromic(); Function : Determines if the recognition sequence is palindromic : for the current restriction enzyme. Returns : Boolean Argument : n/a Throws : n/a A palindromic site (EcoRI): 5-GAATTC-3 3-CTTAAG-5 =cut sub is_palindromic { shift->throw_not_implemented; } =head2 overhang Title : overhang Usage : $re->overhang(); Function : Determines the overhang of the restriction enzyme Returns : "5'", "3'", "blunt" of undef Argument : n/a Throws : n/a A blunt site in SmaI returns C 5' C C C^G G G 3' 3' G G G^C C C 5' A 5' overhang in EcoRI returns C<5'> 5' G^A A T T C 3' 3' C T T A A^G 5' A 3' overhang in KpnI returns C<3'> 5' G G T A C^C 3' 3' C^C A T G G 5' =cut sub overhang { shift->throw_not_implemented; } =head2 overhang_seq Title : overhang_seq Usage : $re->overhang_seq(); Function : Determines the overhang sequence of the restriction enzyme Returns : a Bio::LocatableSeq Argument : n/a Throws : n/a I do not think it is necessary to create a seq object of these. (Heikki) Note: returns empty string for blunt sequences and undef for ones that we don't know. Compare these: A blunt site in SmaI returns empty string 5' C C C^G G G 3' 3' G G G^C C C 5' A 5' overhang in EcoRI returns C 5' G^A A T T C 3' 3' C T T A A^G 5' A 3' overhang in KpnI returns C 5' G G T A C^C 3' 3' C^C A T G G 5' Note that you need to use method L to decide whether it is a 5' or 3' overhang!!! Note: The overhang stuff does not work if the site is asymmetric! Rethink! =cut sub overhang_seq { shift->throw_not_implemented; } =head2 compatible_ends Title : compatible_ends Usage : $re->compatible_ends($re2); Function : Determines if the two restriction enzyme cut sites have compatible ends. Returns : 0 if not, 1 if only one pair ends match, 2 if both ends. Argument : a Bio::Restriction::Enzyme Throws : unless the argument is a Bio::Resriction::Enzyme and if there are Ns in the ovarhangs In case of type II enzymes which which cut symmetrically, this function can be considered to return a boolean value. =cut sub compatible_ends {shift->throw_not_implemented;} =head2 is_ambiguous Title : is_ambiguous Usage : $re->is_ambiguous(); Function : Determines if the restriction enzyme contains ambiguous sequences Returns : Boolean Argument : n/a Throws : n/a =cut sub is_ambiguous { shift->throw_not_implemented; } =head2 Additional methods from Rebase =cut =head2 is_prototype Title : is_prototype Usage : $re->is_prototype Function : Get/Set method for finding out if this enzyme is a prototype Example : $re->is_prototype(1) Returns : Boolean Args : none Prototype enzymes are the most commonly available and usually first enzymes discoverd that have the same recognition site. Using only prototype enzymes in restriciton analysis avoids redundacy and speeds things up. =cut sub is_prototype { shift->throw_not_implemented; } =head2 prototype_name Title : prototype_name Usage : $re->prototype_name Function : Get/Set method for the name of prototype for this enzyme's recognition site Example : $re->prototype_name(1) Returns : prototype enzyme name string or an empty string Args : optional prototype enzyme name string If the enzyme itself is the protype, its own name is returned. Not to confuse the negative result with an unset value, use method L. This method is called I rather than I, because it returns a string rather than on object. =cut sub prototype_name { shift->throw_not_implemented; } =head2 isoschizomers Title : isoschizomers Usage : $re->isoschizomers(@list); Function : Gets/Sets a list of known isoschizomers (enzymes that recognize the same site, but don't necessarily cut at the same position). Arguments : A reference to an array that contains the isoschizomers Returns : A reference to an array of the known isoschizomers or 0 if not defined. Added for compatibility to REBASE =cut sub isoschizomers { shift->throw_not_implemented; } =head2 purge_isoschizomers Title : purge_isoschizomers Usage : $re->purge_isoschizomers(); Function : Purges the set of isoschizomers for this enzyme Arguments : Returns : 1 =cut sub purge_isoschizomers { shift->throw_not_implemented; } =head2 methylation_sites Title : methylation_sites Usage : $re->methylation_sites(\%sites); Function : Gets/Sets known methylation sites (positions on the sequence that get modified to promote or prevent cleavage). Arguments : A reference to a hash that contains the methylation sites Returns : A reference to a hash of the methylation sites or an empty string if not defined. There are three types of methylation sites: =over 3 =item * (6) = N6-methyladenosine =item * (5) = 5-methylcytosine =item * (4) = N4-methylcytosine =back These are stored as 6, 5, and 4 respectively. The hash has the sequence position as the key and the type of methylation as the value. A negative number in the sequence position indicates that the DNA is methylated on the complementary strand. Note that in REBASE, the methylation positions are given Added for compatibility to REBASE. =cut sub methylation_sites { shift->throw_not_implemented; } =head2 purge_methylation_sites Title : purge_methylation_sites Usage : $re->purge_methylation_sites(); Function : Purges the set of methylation_sites for this enzyme Arguments : Returns : =cut sub purge_methylation_sites { shift->throw_not_implemented; } =head2 microbe Title : microbe Usage : $re->microbe($microbe); Function : Gets/Sets microorganism where the restriction enzyme was found Arguments : A scalar containing the microbes name Returns : A scalar containing the microbes name or 0 if not defined Added for compatibility to REBASE =cut sub microbe { shift->throw_not_implemented; } =head2 source Title : source Usage : $re->source('Rob Edwards'); Function : Gets/Sets the person who provided the enzyme Arguments : A scalar containing the persons name Returns : A scalar containing the persons name or 0 if not defined Added for compatibility to REBASE =cut sub source { shift->throw_not_implemented; } =head2 vendors Title : vendors Usage : $re->vendor(@list_of_companies); Function : Gets/Sets the a list of companies that you can get the enzyme from. Also sets the commercially_available boolean Arguments : A reference to an array containing the names of companies that you can get the enzyme from Returns : A reference to an array containing the names of companies that you can get the enzyme from Added for compatibility to REBASE =cut sub vendors { shift->throw_not_implemented; } =head2 purge_vendors Title : purge_vendors Usage : $re->purge_references(); Function : Purges the set of references for this enzyme Arguments : Returns : =cut sub purge_vendors { shift->throw_not_implemented; } =head2 vendor Title : vendor Usage : $re->vendor(@list_of_companies); Function : Gets/Sets the a list of companies that you can get the enzyme from. Also sets the commercially_available boolean Arguments : A reference to an array containing the names of companies that you can get the enzyme from Returns : A reference to an array containing the names of companies that you can get the enzyme from Added for compatibility to REBASE =cut sub vendor { shift->throw_not_implemented; } =head2 references Title : references Usage : $re->references(string); Function : Gets/Sets the references for this enzyme Arguments : an array of string reference(s) (optional) Returns : an array of references Use L to reset the list of references This should be a L or L object, but its not (yet) =cut sub references { shift->throw_not_implemented; } =head2 purge_references Title : purge_references Usage : $re->purge_references(); Function : Purges the set of references for this enzyme Arguments : Returns : 1 =cut sub purge_references { shift->throw_not_implemented; } =head2 clone Title : clone Usage : $re->clone Function : Deep copy of the object Arguments : - Returns : new Bio::Restriction::EnzymeI object This works as long as the object is a clean in-memory object using scalars, arrays and hashes. You have been warned. If you have module Storable, it is used, otherwise local code is used. Todo: local code cuts circular references. =cut sub clone { shift->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Restriction/IO.pm000444000765000024 1506412254227321 17345 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Restriction::IO # # Please direct questions and support issues to # # Cared for by Rob Edwards # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Restriction::IO - Handler for sequence variation IO Formats =head1 SYNOPSIS use Bio::Restriction::IO; $in = Bio::Restriction::IO->new(-file => "inputfilename" , -format => 'withrefm'); my $res = $in->read; # a Bio::Restriction::EnzymeCollection =head1 DESCRIPTION L is a handler module for the formats in the Restriction IO set, e.g. C. It is the officially sanctioned way of getting at the format objects, which most people should use. The structure, conventions and most of the code is inherited from L. The main difference is that instead of using methods C, you drop C<_seq> from the method name. Also, instead of dealing only with individual L objects, C will slurp in all enzymes into a L object. For more details, see documentation in L. =head1 TO DO At the moment, these can be use mainly to get a custom set if enzymes in C or C formats into L or L objects. Using C format is highly experimental and is not recommmended at this time. This class inherits from L for convenience sake, though this should inherit from L. Get rid of L inheritance by copying relevant methods in. C methods are currently not implemented for any format except C. Using C even with C format is not recommended as it does not support multicut/multisite enzyme output. Should additional formats be supported (such as XML)? =head1 SEE ALSO L, L, L =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Restriction::IO; use strict; use vars qw(%FORMAT); use base qw(Bio::SeqIO); %FORMAT = ( 'itype2' => 'itype2', '8' => 'itype2', 'withrefm' => 'withrefm', '31' => 'withrefm', 'base' => 'base', '0' => 'base', 'bairoch' => 'bairoch', '19' => 'bairoch', 'macvector' => 'bairoch', 'vectorNTI' => 'bairoch', 'neo' => 'prototype', 'prototype' => 'prototype' ); =head2 new Title : new Usage : $stream = Bio::Restriction::IO->new(-file => $filename, -format => 'Format') Function: Returns a new seqstream Returns : A Bio::Restriction::IO::Handler initialised with the appropriate format Args : -file => $filename -format => format -fh => filehandle to attach to =cut sub new { my ($class, %param) = @_; my ($format); @param{ map { lc $_ } keys %param } = values %param; # lowercase keys $format = $FORMAT{$param{'-format'}} if defined $param{'-format'}; $format ||= $class->_guess_format( $param{-file} || $ARGV[0] ) || 'base'; $format = "\L$format"; # normalize capitalization to lower case return unless $class->_load_format_module($format); return "Bio::Restriction::IO::$format"->new(%param); } =head2 format Title : format Usage : $format = $stream->format() Function: Get the restriction format Returns : restriction format Args : none =cut # format() method inherited from Bio::Root::IO sub _load_format_module { my ($class, $format) = @_; my $module = "Bio::Restriction::IO::" . $format; my $ok; eval { $ok = $class->_load_module($module); }; if ( $@ ) { print STDERR <read Function: reads all the restrction enzymes from the stream Returns : a Bio::Restriction::EnzymeCollection object Args : =cut sub read { my ($self, $seq) = @_; $self->throw_not_implemented(); } sub next { my ($self, $seq) = @_; $self->throw_not_implemented(); } sub next_seq { my ($self, $seq) = @_; $self->throw_not_implemented(); } =head2 write Title : write Usage : $stream->write($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Restriction::EnzymeCollection object =cut sub write { my ($self, $seq) = @_; $self->throw("Sorry, you cannot write to a generic ". "Bio::Restricion::IO object."); } sub write_seq { my ($self, $seq) = @_; $self->warn("These are not sequence objects. ". "Use method 'write' instead of 'write_seq'."); $self->write($seq); } =head2 _guess_format Title : _guess_format Usage : $obj->_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'flat' if /\.dat$/i; return 'xml' if /\.xml$/i; } 1; BioPerl-1.6.923/Bio/Restriction/Enzyme000755000765000024 012254227322 17565 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Restriction/Enzyme/MultiCut.pm000444000765000024 1020412254227312 22042 0ustar00cjfieldsstaff000000000000#------------------------------------------------------------------ # # BioPerl module Bio::Restriction::Enzyme::MultiCut # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------ ## POD Documentation: =head1 NAME Bio::Restriction::Enzyme::MultiCut - A single restriction endonuclease =head1 SYNOPSIS # set up a single restriction enzyme. This contains lots of # information about the enzyme that is generally parsed from a # rebase file and can then be read back use Bio::Restriction::Enzyme; =head1 DESCRIPTION This module defines a restriction endonuclease class where one object represents one of the distinct recognition sites for that enzyme. The method L stores references to other objects with alternative sites. In this schema each object within an EnzymeCollection can be checked for matching a sequence. REBASE report notation C means: Bsp24I 5' ^NNNNNNNNGACNNNNNNTGGNNNNNNNNNNNN^ 3' 3' ^NNNNNNNNNNNNNCTGNNNNNNACCNNNNNNN^ 5' =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Rob Edwards, redwards@utmem.edu =head1 COPYRIGHT Copyright (c) 2003 Rob Edwards. Some of this work is Copyright (c) 1997-2002 Steve A. Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are not considered part of the public interface and are described here for documentation purposes only. =cut package Bio::Restriction::Enzyme::MultiCut; use strict; use Data::Dumper; use vars qw (); use base qw(Bio::Restriction::Enzyme); =head2 new Title : new Function Function : Initializes the enzyme object Returns : The Restriction::Enzyme::MultiCut object Argument : =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($others) = $self->_rearrange([qw( OTHERS )], @args); $others && $self->others($others); return $self; } =head2 others Title : others Usage : $re->others(@enz_obj_array); Function : Stores auxiliary Enzyme::MultiCut objects for multicutting enzymes Arguments : optional array of Enzyme::MultiCut objects Returns : array of Enzyme objects Added for compatibility to REBASE =cut sub others { my $self = shift; push @{$self->{_others}}, @_ if @_; return unless $self->{_others}; return @{$self->{'_others'}}; } =head2 purge_others Title : purge_others Usage : $re->purge_references(); Function : Purges the set of references for this enzyme Arguments : Returns : =cut sub purge_others { my ($self) = shift; $self->{_others} = []; } 1; BioPerl-1.6.923/Bio/Restriction/Enzyme/MultiSite.pm000444000765000024 1040412254227322 22216 0ustar00cjfieldsstaff000000000000#------------------------------------------------------------------ # # BioPerl module Bio::Restriction::Enzyme::MultiSite # # Please direct questions and support issues to # # Cared for by Heikki Lehvaslaiho, heikki-at-bioperl-dot-org # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------ ## POD Documentation: =head1 NAME Bio::Restriction::Enzyme::MultiSite - A single restriction endonuclease =head1 SYNOPSIS # set up a single restriction enzyme. This contains lots of # information about the enzyme that is generally parsed from a # rebase file and can then be read back use Bio::Restriction::Enzyme; =head1 DESCRIPTION This module is used for restriction enzymes that recogonize more than one site. There are some enzymes that recognize sites that cannot be represented by the ambiguous genetic code. For example, M.PhiBssHII recognizes the sites: ACGCGT,CCGCGG,RGCGCY,RCCGGY, and GCGCGC Each site gets its own object that Bio::Restriction::Enzyme will refer to. Each also correlates with the other sites using the method L which stores references to other objects with alternative sites. In this schema each object within an EnzymeCollection can be checked for matching a sequence. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Rob Edwards, redwards@utmem.edu =head1 COPYRIGHT Copyright (c) 2003 Rob Edwards. Some of this work is Copyright (c) 1997-2002 Steve A. Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are not considered part of the public interface and are described here for documentation purposes only. =cut package Bio::Restriction::Enzyme::MultiSite; use strict; use Data::Dumper; use vars qw (); use base qw(Bio::Restriction::Enzyme); =head2 new Title : new Function Function : Initializes the enzyme object Returns : The Restriction::Enzyme::MultiSite object Argument : =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($others) = $self->_rearrange([qw( OTHERS )], @args); $others && $self->others($others); return $self; } =head2 others Title : others Usage : $re->others(@others); Function : Gets/Sets the a list of other sites that this enzyme recoginizes Arguments : An array containing the other Bio::Restriction::Enzyme::MultiSite objects. Returns : An array containing the other Bio::Restriction::Enzyme::MultiSite objects. =cut sub others { my $self = shift; push @{$self->{_others}}, @_ if @_; return unless $self->{_others}; return @{$self->{'_others'}}; } =head2 purge_others Title : purge_others Usage : $re->purge_references(); Function : Purges the set of references for this enzyme Arguments : Returns : =cut sub purge_others { my ($self) = shift; $self->{_others} = []; } 1; BioPerl-1.6.923/Bio/Restriction/IO000755000765000024 012254227336 16632 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Restriction/IO/bairoch.pm000444000765000024 1540112254227324 20752 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Restriction::IO::withrefm # # Please direct questions and support issues to # # Cared for by Rob Edwards # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Restriction::IO::bairoch - bairoch enzyme set =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Restriction::IO class. =head1 DESCRIPTION This is the most complete format of the REBASE files, and basically includes all the data on each of the restriction enzymes. This parser is for the Bairoch format (aka MacVector, Vector NTI, PC/Gene (Bairoch) format), REBASE format #19 =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Restriction::IO::bairoch; use vars qw(%WITH_REFM_FIELD); use strict; use Bio::Restriction::Enzyme; use Bio::Restriction::Enzyme::MultiCut; use Bio::Restriction::Enzyme::MultiSite; use Bio::Restriction::EnzymeCollection; use Data::Dumper; use base qw(Bio::Restriction::IO::base); =head2 read Title : read Usage : $renzs = $stream->read Function: reads all the restrction enzymes from the stream Returns : a Bio::Restriction::Restriction object Args : none =cut sub read { my $self = shift; my $renzs = Bio::Restriction::EnzymeCollection->new(-empty => 1); local $/ = '//'; while (defined(my $entry=$self->_readline()) ) { $self->debug("|$entry|\n"); # # Minimal information # my ($name) = $entry =~ /ID\s+(\S+)/; my ($site) = $entry =~ /RS\s+([^\n]+)/; next unless ($name && $site); # the standard sequence format for these guys is: # GATC, 2; # or, for enzymes that cut more than once # GATC, 2; GTAC, 2; # there are a couple of sequences that have multiple # recognition sites. my @sequences; if ($site =~ /\;/) { @sequences = split /\;/, $site; $self->debug(@sequences,"\n"); $site=shift @sequences; } my ($seq, $cut)=split /,\s+/, $site; $self->debug("SITE: |$site| GAVE: |$seq| and |$cut|\n"); if ($seq eq '?') { $self->warn("$name: no site. Skipping") if $self->verbose > 1; next; } # this is mainly an error check to make sure that I am adding what I think I am! if ($seq !~ /[NGATC]/i) { $self->throw("Sequence $name has weird sequence: |$seq|"); } my $re; if ($cut eq "?") { $re = Bio::Restriction::Enzyme->new(-name=>$name, -seq => $seq); } else { if ($cut !~ /^-?\d+$/) { $self->throw("Cut site from $name is weird: |$cut|\n"); } $re = Bio::Restriction::Enzyme->new(-name=>$name, -cut => $cut, -seq => $seq ); } $renzs->enzymes($re); # # prototype / isoschizomers # my ($prototype) = $entry =~ /PT\s+([^\n]+)/; if ($prototype) { #$re->isoschizomers(split /\,/, $isoschizomers); #NOTE: Need to add a method so that we can add isoschosomers to enzymes that may not exist! $re->is_prototype(0); } else { $re->is_prototype(1); } # # methylation # my ($meth) = $entry =~ /MS\s+([^\n]+)/; my @meths; if ($meth) { # this can be either X(Y) or X(Y),X2(Y2) # where X is the base and y is the type of methylation if ( $meth =~ /(\S+)\((\d+)\),(\S+)\((\d+)\)/ ) { # two msites per site #my ($p1, $m1, $p2, $m2) = ($1, $2, $3, $4); $re->methylation_sites($self->_meth($re,$1, $2), $self->_meth($re,$3,$4)); } elsif ($meth =~ /(\S+)\((\d+)\)/ ) { # one msite per site or more sites #print Dumper $meth; $re->methylation_sites( $self->_meth($re,$1,$2) ); @meths = split /, /, $meth; $meth=shift @meths; } else { $self->warn("Unknown methylation format [$meth]") if $self->verbose >0; } } # # microbe # my ($microbe) = $entry =~ /OS\s+([^\n]+)/; $re->microbe($microbe) if $microbe; # # source # #my ($source) = $entry =~ /<6>([^\n]+)/; #$re->source($source) if $source; # # vendors # my ($vendors) = $entry =~ /CR\s+([^\n]+)/; $re->vendors(split /,\s*/, $vendors) if $vendors; # # references # #my ($refs) = $entry =~ /<8>(.+)/s; #$re->references(map {split /\n+/} $refs) if $refs; # # create special types of Enzymes # $self->warn("Current issues with multisite enzymes using bairoch format\n". "Recommend using itype2 or withrefm formats for now") if @sequences; #$self->_make_multisites($renzs, $re, \@sequences, \@meths) if @sequences; } return $renzs; } =head2 write Title : write Usage : $stream->write($renzs) Function: writes restriction enzymes into the stream Returns : 1 for success and 0 for error Args : a Bio::Restriction::Enzyme or a Bio::Restriction::EnzymeCollection object =cut sub write { my ($self,@h) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Restriction/IO/base.pm000444000765000024 5245212254227315 20264 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Restriction::IO::base # # Please direct questions and support issues to # # Cared for by Rob Edwards # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Restriction::IO::base - base enzyme set =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Restriction::IO class. =head1 DESCRIPTION This class defines some base methods for restriction enzyme input and at the same time gives a base list of common enzymes. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Mark A. Jensen, maj-at-fortinbras-dot-us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Restriction::IO::base; use strict; use Bio::Restriction::Enzyme; use Bio::Restriction::EnzymeCollection; use Bio::Restriction::Enzyme::MultiCut; use Bio::Restriction::Enzyme::MultiSite; use base qw(Bio::Restriction::IO); my $offset; # class variable sub new { my($class, @args) = @_; $class = ref $class ? ref $class : $class; my $self = bless {}, $class; $self->_initialize(@args); return $self; } { my %FILE_FORMAT = ( #'itype2' => 'itype2', # itype2 format doesn't work with 'current' #'8' => 'itype2', 'withrefm' => 'withrefm', '31' => 'withrefm', #'bairoch' => 'bairoch', # bairoch format doesn't work with 'current' #'19' => 'bairoch', #'macvector' => 'bairoch', #'vectorNTI' => 'bairoch', 'neo' => 'neos', 'prototype' => 'proto' ); sub _initialize { my($self,@args) = @_; my ($current, $url, $file, $fh, $format, $verbose) = $self->_rearrange([qw(CURRENT URL FILE FH FORMAT VERBOSE)],@args); $verbose || 0; $self->verbose($verbose); if ($current && $format) { $self->throw("Can't use -current with file, fh, or url set") if ($url || $file || $fh); $self->throw("Format $format not retrievable using 'current'") if (!exists $FILE_FORMAT{$format}); my $io = $self->new(-url => 'ftp://ftp.neb.com/pub/rebase/VERSION'); chomp (my $version = $io->_readline); push @args, (-url => "ftp://ftp.neb.com/pub/rebase/$FILE_FORMAT{$format}.$version", -retries => 1); } $self->_companies; return unless $self->SUPER::_initialize(@args); } } =head2 read Title : read Usage : $renzs = $stream->read Function: reads all the restrction enzymes from the stream Returns : a Bio::Restriction::Restriction object Args : none =cut sub read { my $self = shift; my $renzs = Bio::Restriction::EnzymeCollection->new(-empty => 1); seek DATA,($offset||=tell DATA), 0; while () { chomp; next if /^\s*$/; my ($name, $site, $cut) = split /\s+/; my $re = Bio::Restriction::Enzyme->new(-name => $name, -site => $site, -cut => $cut); $renzs->enzymes($re); } return $renzs; } =head2 _xln_sub Title : _xln_sub Function: Translates withrefm coords to Bio::Restriction coords Args : Bio::Restriction::Enzyme object, scalar integer (cut posn) Note : Used internally; pass as a coderef to the B:R::Enzyme constructor Note : It is convenient for each format module to have its own version of this; not currently demanded by the interface. =cut sub _xln_sub { # for base.pm, a no-op my ($z,$c) = @_; return $c; } =head2 write Title : write Usage : $stream->write($renzs) Function: writes restriction enzymes into the stream Returns : 1 for success and 0 for error Args : a Bio::Restriction::Enzyme or a Bio::Restriction::EnzymeCollection object =cut sub write { my $self = shift; foreach (@_) { map { printf "%s\t%s\t%s\n", $_->name, $_->string, $_->cut } sort {$a->name cmp $b->name} $_->each_enzyme if $_->isa('Bio::Restriction::EnzymeCollection'); printf "%s\t%s\t%s\n", $_->name, $_->string, $_->cut if $_->isa('Bio::Restriction::Enzyme'); } } =head2 verify_prototype Title : verify_prototype Purpose : checks enzyme against current prototype list (retrieved remotely) Returns : returns TRUE if enzyme is prototype Argument : Bio::Restriction::EnzymeI Comments : This is an auxiliary method to retrieve and check an enzyme as a prototype. It retrieves the current list, stores it as a singleton instance, then uses it to check the prototype and modify is_prototype() to true or false. Use as follows: my $col = $io->read; for my $enz ($col->each_enzyme) { print $enz->name.":".$enz->site."\n"; print "\t".$io->verify_prototype($enz)."\n"; } =cut my $protodb; sub verify_prototype { my ($self, $enz) = @_; $self->throw("Must pass a Bio::Restriction::EnzymeI") unless $enz && ref $enz && $enz->isa("Bio::Restriction::EnzymeI"); if (!defined $protodb) { my $io = Bio::Restriction::IO->new(-format => 'prototype', -current => 1); $protodb = $io->read; } if ($protodb->get_enzyme($enz->name)) { $enz->is_prototype(1); } else { $enz->is_prototype(0); } $enz->is_prototype; } =head2 Common REBASE parsing methods The rest of the methods in this file are to be used by other REBASE parsers. They are not to be used outside subclasses of this base class. (They are 'protected' in the sense the word is used in Java.) =cut =head2 _cuts_from_site Title : _cuts_from_site Usage : ($site, $cut, $comp_cut) = _cuts_from_site('ACGCGT(4/5)'); Function: Separates cut positions from a single site string. Does nothing to site if it does not have the cut string Returns : array of site_string, forward_cut_position, reverse_cut_position Args : recognition site string Note : Not used in withrefm refactor/maj =cut sub _cuts_from_site { my ($self, $site) = @_; my ($cut, $comp_cut) = $site =~ /\((-?\d+)\/(-?\d+)\)/; $site =~ s/\(.*\)$//; return ($site, $cut, $comp_cut); } =head2 _meth Title : _meth Usage : ($pos, $meth) = $self->_meth('2(5)'); Function: Separates methylation postion and coce from a string. Adjusts the postion depending on enzyme site length and symmetry Returns : array of position and methylation code Args : 1. reference to Enzyme object 2. methylation description string =cut sub _meth { my ($self, $re, $meth) = @_; $meth =~ /(\S+)\((\d+)\)/; my ($pos, $m) = ($1, $2); $pos = 0 if $pos eq '?'; $pos = $re->seq->length + $pos if $pos and ! $re->palindromic; return ($pos, $m); $self->warn("Unknown methylation format [$meth]") if $self->verbose >0; } =head2 _coordinate_shift_to_cut Title : _coordinate_shift_to_cut Usage : $cut = $self->_coordinate_shift_to_cut($oricut, offset); Function: Adjust cut position coordinates to start from the first nucleotides of site Returns : Cut position in correct coordinates Args : 1. Original cut position 2. Length of the recognition site Note : Not used in withrefm.pm refactor/maj =cut sub _coordinate_shift_to_cut { my ($self, $cut, $site_length) = @_; return $cut + $site_length; } =head2 _make_multisites Title : _make_multisites Usage : $self->_make_multisites($first_enzyme, \@sites, \@mets) Function: Bless a Bio::Restriction::Enzyme into Bio::Restriction::Enzyme::MultiSite and clone it as many times as there are alternative sites. Returns : nothing, does in place editing Args : 1. a Bio::Restriction::Enzyme 2. reference to an array of recognition site strings 3. reference to an array of methylation code strings, optional =cut # removed the enzyme collection from arg list /maj sub _make_multisites { my ($self, $re, $sites, $meths, $xln_sub) = @_; bless $re, 'Bio::Restriction::Enzyme::MultiSite'; my $count = 0; while ($count < scalar @{$sites}) { # this should probably be refactored to use the constructor # too, rather than the clone/accessor method /maj # my $re2 = $re->clone; # my $re2; my $site = @{$sites}[$count]; my ($precut, $recog, $postcut) = ( $site =~ m/^(?:\((\w+\/\w+)\))?([\w^]+)(?:\((\w+\/\w+)\))?/ ); # set the site attribute # $re2->site($recog); # set the recog attribute (which will make the regexp transformation # if necessary: # $re2->recog($recog); # $recog = $re2->string; # no warnings; # avoid 'uninitialized value' warning against $postcut # my ($cut, $comp_cut) = ( $postcut =~ /(-?\d+)\/(-?\d+)/ ); # use warnings; # note the following hard codes the coordinate transformation # used for rebase/itype2 : this method will break on the # base.pm format. # if ($cut) { # $re2->cut($cut + length $recog); # $re2->complementary_cut($comp_cut + length $recog); # } my $re2 = Bio::Restriction::Enzyme::MultiSite->new( -name => $re->name, -site => $recog, -recog => $recog, -precut => $precut, -postcut => $postcut, -xln_sub => $xln_sub ); if ($meths and @$meths) { $re2->purge_methylation_sites; $re2->methylation_sites($self->_meth($re2, @{$meths}[$count])); } $re->others($re2); $count++; } foreach my $enz ($re->others) { $enz->others($re, grep {$_ ne $enz} $re->others); } 1; } =head2 _make_multicuts Title : _make_multicuts Usage : $self->_make_multicuts($first_enzyme, $precuts) Function: Bless a Bio::Restriction::Enzyme into Bio::Restriction::Enzyme::MultiCut and clone it. The precut string is processed to replase the cut sites in the cloned object. Both objects refer to each other through others() method. Returns : nothing, does in place editing Args : 1. a Bio::Restriction::Enzyme 2. precut string, e.g. '12/7' The examples we have of multiply cutting enzymes cut only four times. This protected method deals only with a string of two integers separated with a slash, e.g. '12/7'. The numbers represent the postions BEFORE the start of the recognition site, i.e. negative positions. =cut # removed the enzyme collection from arg list /maj sub _make_multicuts { my ($self, $re, $precut) = @_; bless $re, 'Bio::Restriction::Enzyme::MultiCut'; my ($cut, $comp_cut) = $precut =~ /(-?\d+)\/(-?\d+)/; my $re2 = $re->clone; $re2->cut("-$cut"); $re2->complementary_cut("-$comp_cut"); $re->others($re2); 1; } =head2 _companies Title : _companies Purpose : Defines the companies that we know about Returns : A hash Argument : Nothing Comments : An internal method to define the companies that we know about REBASE uses a code, and this converts the code to the real name (e.g. A = Amersham Pharmacia Biotech) =cut sub _companies { # this is just so it is easy to set up the codes that REBASE uses my $self=shift; my %companies=( 'A'=>'Amersham Pharmacia Biotech (1/03)', 'C'=>'Minotech Biotechnology (6/01)', 'E'=>'Stratagene (1/03)', 'F'=>'Fermentas AB (1/03)', 'G'=>'Qbiogene (1/03)', 'H'=>'American Allied Biochemical, Inc. (10/98)', 'I'=>'SibEnzyme Ltd. (1/03)', 'J'=>'Nippon Gene Co., Ltd. (6/00)', 'K'=>'Takara Shuzo Co. Ltd. (1/03)', 'M'=>'Roche Applied Science (1/03)', 'N'=>'New England Biolabs (1/03)', 'O'=>'Toyobo Biochemicals (11/98)', 'P'=>'Megabase Research Products (5/99)', 'Q'=>'CHIMERx (1/03)', 'R'=>'Promega Corporation (1/03)', 'S'=>'Sigma Chemical Corporation (1/03)', 'U'=>'Bangalore Genei (1/03)', 'V'=>'MRC-Holland (1/03)', 'X'=>'EURx Ltd. (1/03)'); $self->{company}=\%companies; } 1; __DATA__ AasI GACNNNNNNGTC 7 AatI AGGCCT 3 AccII CGCG 2 AatII GACGTC 5 AauI TGTACA 1 Acc113I AGTACT 3 Acc16I TGCGCA 3 Acc65I GGTACC 1 AccB1I GGYRCC 1 AccB7I CCANNNNNTGG 7 AccI GTMKAC 2 AccIII TCCGGA 1 AciI CCGC 1 AclI AACGTT 2 AcsI RAATTY 1 AcvI CACGTG 3 AcyI GRCGYC 2 AdeI CACNNNGTG 6 AfaI GTAC 2 AfeI AGCGCT 3 AflI GGWCC 1 AflII CTTAAG 1 AflIII ACRYGT 1 AgeI ACCGGT 1 AhaIII TTTAAA 3 AhdI GACNNNNNGTC 6 AhlI ACTAGT 1 AleI CACNNNNGTG 5 AluI AGCT 2 Alw21I GWGCWC 5 Alw44I GTGCAC 1 AlwNI CAGNNNCTG 6 Ama87I CYCGRG 1 AocI CCTNAGG 2 Aor51HI AGCGCT 3 ApaBI GCANNNNNTGC 8 ApaI GGGCCC 5 ApaLI GTGCAC 1 ApoI RAATTY 1 AscI GGCGCGCC 2 AseI ATTAAT 2 AsiAI ACCGGT 1 AsiSI GCGATCGC 5 AsnI ATTAAT 2 Asp700I GAANNNNTTC 5 Asp718I GGTACC 1 AspEI GACNNNNNGTC 6 AspHI GWGCWC 5 AspI GACNNNGTC 4 AspLEI GCGC 3 AspS9I GGNCC 1 AsuC2I CCSGG 2 AsuI GGNCC 1 AsuII TTCGAA 2 AsuNHI GCTAGC 1 AvaI CYCGRG 1 AvaII GGWCC 1 AviII TGCGCA 3 AvrII CCTAGG 1 AxyI CCTNAGG 2 BalI TGGCCA 3 BamHI GGATCC 1 BanI GGYRCC 1 BanII GRGCYC 5 BanIII ATCGAT 2 BbeI GGCGCC 5 BbrPI CACGTG 3 BbuI GCATGC 5 Bbv12I GWGCWC 5 BclI TGATCA 1 BcnI CCSGG 2 BcoI CYCGRG 1 BcuI ACTAGT 1 BetI WCCGGW 1 BfaI CTAG 1 BfmI CTRYAG 1 BfrBI ATGCAT 3 BfrI CTTAAG 1 BfuCI GATC 0 BglI GCCNNNNNGGC 7 BglII AGATCT 1 BlnI CCTAGG 1 BloHII CTGCAG 5 BlpI GCTNAGC 2 Bme1390I CCNGG 2 Bme1580I GKGCMC 5 Bme18I GGWCC 1 BmtI GCTAGC 5 BmyI GDGCHC 5 BoxI GACNNNNGTC 5 Bpu1102I GCTNAGC 2 Bpu14I TTCGAA 2 Bsa29I ATCGAT 2 BsaAI YACGTR 3 BsaBI GATNNNNATC 5 BsaHI GRCGYC 2 BsaJI CCNNGG 1 BsaOI CGRYCG 4 BsaWI WCCGGW 1 Bsc4I CCNNNNNNNGG 7 BscBI GGNNCC 3 BscFI GATC 0 BscI ATCGAT 2 Bse118I RCCGGY 1 Bse21I CCTNAGG 2 Bse8I GATNNNNATC 5 BseAI TCCGGA 1 BseBI CCWGG 2 BseCI ATCGAT 2 BseDI CCNNGG 1 BseJI GATNNNNATC 5 BseLI CCNNNNNNNGG 7 BsePI GCGCGC 1 BseSI GKGCMC 5 BseX3I CGGCCG 1 Bsh1236I CGCG 2 Bsh1285I CGRYCG 4 BshFI GGCC 2 BshI GGCC 2 BshNI GGYRCC 1 BshTI ACCGGT 1 BsiBI GATNNNNATC 5 BsiCI TTCGAA 2 BsiEI CGRYCG 4 BsiHKAI GWGCWC 5 BsiHKCI CYCGRG 1 BsiLI CCWGG 2 BsiMI TCCGGA 1 BsiQI TGATCA 1 BsiSI CCGG 1 BsiWI CGTACG 1 BsiXI ATCGAT 2 BsiYI CCNNNNNNNGG 7 BsiZI GGNCC 1 BslI CCNNNNNNNGG 7 BsoBI CYCGRG 1 Bsp106I ATCGAT 2 Bsp119I TTCGAA 2 Bsp120I GGGCCC 1 Bsp1286I GDGCHC 5 Bsp13I TCCGGA 1 Bsp1407I TGTACA 1 Bsp143I GATC 0 Bsp143II RGCGCY 5 Bsp1720I GCTNAGC 2 Bsp19I CCATGG 1 Bsp68I TCGCGA 3 BspA2I CCTAGG 1 BspCI CGATCG 4 BspDI ATCGAT 2 BspEI TCCGGA 1 BspHI TCATGA 1 BspLI GGNNCC 3 BspLU11I ACATGT 1 BspMII TCCGGA 1 BspT104I TTCGAA 2 BspT107I GGYRCC 1 BspTI CTTAAG 1 BspXI ATCGAT 2 BsrBRI GATNNNNATC 5 BsrFI RCCGGY 1 BsrGI TGTACA 1 BssAI RCCGGY 1 BssECI CCNNGG 1 BssHI CTCGAG 1 BssHII GCGCGC 1 BssKI CCNGG 0 BssNAI GTATAC 3 BssT1I CCWWGG 1 Bst1107I GTATAC 3 Bst2UI CCWGG 2 Bst4CI ACNGT 3 Bst98I CTTAAG 1 BstACI GRCGYC 2 BstAPI GCANNNNNTGC 7 BstBAI YACGTR 3 BstBI TTCGAA 2 BstC8I GCNNGC 3 BstDEI CTNAG 1 BstDSI CCRYGG 1 BstEII GGTNACC 1 BstENI CCTNNNNNAGG 5 BstENII GATC 0 BstFNI CGCG 2 BstH2I RGCGCY 5 BstHHI GCGC 3 BstHPI GTTAAC 3 BstKTI GATC 3 BstMAI CTGCAG 5 BstMCI CGRYCG 4 BstMWI GCNNNNNNNGC 7 BstNI CCWGG 2 BstNSI RCATGY 5 BstOI CCWGG 2 BstPAI GACNNNNGTC 5 BstPI GGTNACC 1 BstSCI CCNGG 0 BstSFI CTRYAG 1 BstSNI TACGTA 3 BstUI CGCG 2 BstX2I RGATCY 1 BstXI CCANNNNNNTGG 8 BstYI RGATCY 1 BstZ17I GTATAC 3 BstZI CGGCCG 1 Bsu15I ATCGAT 2 Bsu36I CCTNAGG 2 BsuRI GGCC 2 BsuTUI ATCGAT 2 BtgI CCRYGG 1 BthCI GCNGC 4 Cac8I GCNNGC 3 CaiI CAGNNNCTG 6 CauII CCSGG 2 CciNI GCGGCCGC 2 CelII GCTNAGC 2 CfoI GCGC 3 Cfr10I RCCGGY 1 Cfr13I GGNCC 1 Cfr42I CCGCGG 4 Cfr9I CCCGGG 1 CfrI YGGCCR 1 ChaI GATC 4 ClaI ATCGAT 2 CpoI CGGWCCG 2 Csp45I TTCGAA 2 Csp6I GTAC 1 CspAI ACCGGT 1 CspI CGGWCCG 2 CviAII CATG 1 CviJI RGCY 2 CviRI TGCA 2 CviTI RGCY 2 CvnI CCTNAGG 2 DdeI CTNAG 1 DpnI GATC 2 DpnII GATC 0 DraI TTTAAA 3 DraII RGGNCCY 2 DraIII CACNNNGTG 6 DrdI GACNNNNNNGTC 7 DsaI CCRYGG 1 DseDI GACNNNNNNGTC 7 EaeI YGGCCR 1 EagI CGGCCG 1 Eam1105I GACNNNNNGTC 6 Ecl136II GAGCTC 3 EclHKI GACNNNNNGTC 6 EclXI CGGCCG 1 Eco105I TACGTA 3 Eco130I CCWWGG 1 Eco147I AGGCCT 3 Eco24I GRGCYC 5 Eco32I GATATC 3 Eco47I GGWCC 1 Eco47III AGCGCT 3 Eco52I CGGCCG 1 Eco72I CACGTG 3 Eco81I CCTNAGG 2 Eco88I CYCGRG 1 Eco91I GGTNACC 1 EcoHI CCSGG 0 EcoICRI GAGCTC 3 EcoNI CCTNNNNNAGG 5 EcoO109I RGGNCCY 2 EcoO65I GGTNACC 1 EcoRI GAATTC 1 EcoRII CCWGG 0 EcoRV GATATC 3 EcoT14I CCWWGG 1 EcoT22I ATGCAT 5 EcoT38I GRGCYC 5 EgeI GGCGCC 3 EheI GGCGCC 3 ErhI CCWWGG 1 EsaBC3I TCGA 2 EspI GCTNAGC 2 FatI CATG 0 FauNDI CATATG 2 FbaI TGATCA 1 FblI GTMKAC 2 FmuI GGNCC 4 Fnu4HI GCNGC 2 FnuDII CGCG 2 FriOI GRGCYC 5 FseI GGCCGGCC 6 Fsp4HI GCNGC 2 FspAI RTGCGCAY 4 FspI TGCGCA 3 FunI AGCGCT 3 FunII GAATTC 1 HaeI WGGCCW 3 HaeII RGCGCY 5 HaeIII GGCC 2 HapII CCGG 1 HgiAI GWGCWC 5 HgiCI GGYRCC 1 HgiJII GRGCYC 5 HhaI GCGC 3 Hin1I GRCGYC 2 Hin6I GCGC 1 HinP1I GCGC 1 HincII GTYRAC 3 HindI CAC 2 HindII GTYRAC 3 HindIII AAGCTT 1 HinfI GANTC 1 HpaI GTTAAC 3 HpaII CCGG 1 Hpy178III TCNNGA 2 Hpy188I TCNGA 3 Hpy188III TCNNGA 2 Hpy8I GTNNAC 3 Hpy99I CGWCG 5 HpyCH4I CATG 3 HpyCH4III ACNGT 3 HpyCH4IV ACGT 1 HpyCH4V TGCA 2 HpyF10VI GCNNNNNNNGC 8 Hsp92I GRCGYC 2 Hsp92II CATG 4 HspAI GCGC 1 ItaI GCNGC 2 KasI GGCGCC 1 Kpn2I TCCGGA 1 KpnI GGTACC 5 Ksp22I TGATCA 1 KspAI GTTAAC 3 KspI CCGCGG 4 Kzo9I GATC 0 LpnI RGCGCY 3 LspI TTCGAA 2 MabI ACCWGGT 1 MaeI CTAG 1 MaeII ACGT 1 MaeIII GTNAC 0 MamI GATNNNNATC 5 MboI GATC 0 McrI CGRYCG 4 MfeI CAATTG 1 MflI RGATCY 1 MhlI GDGCHC 5 MlsI TGGCCA 3 MluI ACGCGT 1 MluNI TGGCCA 3 Mly113I GGCGCC 2 Mph1103I ATGCAT 5 MroI TCCGGA 1 MroNI GCCGGC 1 MroXI GAANNNNTTC 5 MscI TGGCCA 3 MseI TTAA 1 MslI CAYNNNNRTG 5 Msp20I TGGCCA 3 MspA1I CMGCKG 3 MspCI CTTAAG 1 MspI CCGG 1 MspR9I CCNGG 2 MssI GTTTAAAC 4 MstI TGCGCA 3 MunI CAATTG 1 MvaI CCWGG 2 MvnI CGCG 2 MwoI GCNNNNNNNGC 7 NaeI GCCGGC 3 NarI GGCGCC 2 NciI CCSGG 2 NcoI CCATGG 1 NdeI CATATG 2 NdeII GATC 0 NgoAIV GCCGGC 1 NgoMIV GCCGGC 1 NheI GCTAGC 1 NlaIII CATG 4 NlaIV GGNNCC 3 Nli3877I CYCGRG 5 NmuCI GTSAC 0 NotI GCGGCCGC 2 NruGI GACNNNNNGTC 6 NruI TCGCGA 3 NsbI TGCGCA 3 NsiI ATGCAT 5 NspBII CMGCKG 3 NspI RCATGY 5 NspIII CYCGRG 1 NspV TTCGAA 2 OliI CACNNNNGTG 5 PacI TTAATTAA 5 PaeI GCATGC 5 PaeR7I CTCGAG 1 PagI TCATGA 1 PalI GGCC 2 PauI GCGCGC 1 PceI AGGCCT 3 PciI ACATGT 1 PdiI GCCGGC 3 PdmI GAANNNNTTC 5 Pfl23II CGTACG 1 PflBI CCANNNNNTGG 7 PflFI GACNNNGTC 4 PflMI CCANNNNNTGG 7 PfoI TCCNGGA 1 PinAI ACCGGT 1 Ple19I CGATCG 4 PmaCI CACGTG 3 PmeI GTTTAAAC 4 PmlI CACGTG 3 Ppu10I ATGCAT 1 PpuMI RGGWCCY 2 PpuXI RGGWCCY 2 PshAI GACNNNNGTC 5 PshBI ATTAAT 2 PsiI TTATAA 3 Psp03I GGWCC 4 Psp124BI GAGCTC 5 Psp1406I AACGTT 2 Psp5II RGGWCCY 2 Psp6I CCWGG 0 PspAI CCCGGG 1 PspEI GGTNACC 1 PspGI CCWGG 0 PspLI CGTACG 1 PspN4I GGNNCC 3 PspOMI GGGCCC 1 PspPI GGNCC 1 PspPPI RGGWCCY 2 PssI RGGNCCY 5 PstI CTGCAG 5 PsuI RGATCY 1 PsyI GACNNNGTC 4 PvuI CGATCG 4 PvuII CAGCTG 3 RcaI TCATGA 1 RsaI GTAC 2 Rsr2I CGGWCCG 2 RsrII CGGWCCG 2 SacI GAGCTC 5 SacII CCGCGG 4 SalI GTCGAC 1 SanDI GGGWCCC 2 SatI GCNGC 2 Sau3AI GATC 0 Sau96I GGNCC 1 SauI CCTNAGG 2 SbfI CCTGCAGG 6 ScaI AGTACT 3 SciI CTCGAG 3 ScrFI CCNGG 2 SdaI CCTGCAGG 6 SduI GDGCHC 5 SecI CCNNGG 1 SelI CGCG 0 SexAI ACCWGGT 1 SfcI CTRYAG 1 SfeI CTRYAG 1 SfiI GGCCNNNNNGGCC 8 SfoI GGCGCC 3 Sfr274I CTCGAG 1 Sfr303I CCGCGG 4 SfuI TTCGAA 2 SgfI GCGATCGC 5 SgrAI CRCCGGYG 2 SgrBI CCGCGG 4 SinI GGWCC 1 SlaI CTCGAG 1 SmaI CCCGGG 3 SmiI ATTTAAAT 4 SmiMI CAYNNNNRTG 5 SmlI CTYRAG 1 SnaBI TACGTA 3 SpaHI GCATGC 5 SpeI ACTAGT 1 SphI GCATGC 5 SplI CGTACG 1 SrfI GCCCGGGC 4 Sse232I CGCCGGCG 2 Sse8387I CCTGCAGG 6 Sse8647I AGGWCCT 2 Sse9I AATT 0 SseBI AGGCCT 3 SspBI TGTACA 1 SspI AATATT 3 SstI GAGCTC 5 SstII CCGCGG 4 StuI AGGCCT 3 StyI CCWWGG 1 SunI CGTACG 1 SwaI ATTTAAAT 4 TaaI ACNGT 3 TaiI ACGT 4 TaqI TCGA 1 TasI AATT 0 TatI WGTACW 1 TauI GCSGC 4 TelI GACNNNGTC 4 TfiI GAWTC 1 ThaI CGCG 2 TliI CTCGAG 1 Tru1I TTAA 1 Tru9I TTAA 1 TscI ACGT 4 TseI GCWGC 1 Tsp45I GTSAC 0 Tsp4CI ACNGT 3 Tsp509I AATT 0 TspEI AATT 0 Tth111I GACNNNGTC 4 TthHB8I TCGA 1 UnbI GGNCC 0 Van91I CCANNNNNTGG 7 Vha464I CTTAAG 1 VneI GTGCAC 1 VpaK11AI GGWCC 0 VpaK11BI GGWCC 1 VspI ATTAAT 2 XagI CCTNNNNNAGG 5 XapI RAATTY 1 XbaI TCTAGA 1 XceI RCATGY 5 XcmI CCANNNNNNNNNTGG 8 XhoI CTCGAG 1 XhoII RGATCY 1 XmaCI CCCGGG 1 XmaI CCCGGG 1 XmaIII CGGCCG 1 XmaJI CCTAGG 1 XmiI GTMKAC 2 XmnI GAANNNNTTC 5 XspI CTAG 1 ZhoI ATCGAT 2 ZraI GACGTC 3 Zsp2I ATGCAT 5 BioPerl-1.6.923/Bio/Restriction/IO/itype2.pm000444000765000024 1465612254227321 20567 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Restriction::IO::itype2 # # Please direct questions and support issues to # # Cared for by Rob Edwards # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Restriction::IO::itype2 - itype2 enzyme set =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Restriction::IO class. =head1 DESCRIPTION This is tab delimited, entry per line format which is fast to process. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Mark A. Jensen, maj-at-fortinbras-dot-us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Restriction::IO::itype2; use strict; use Bio::Restriction::Enzyme; use Bio::Restriction::EnzymeCollection; use Data::Dumper; use base qw(Bio::Restriction::IO::base); =head2 read Title : read Usage : $renzs = $stream->read Function: reads all the restrction enzymes from the stream Returns : a Bio::Restriction::IO object Args : none Internally creates a hash of enzyme information which is passed on to L. =cut sub read { my $self = shift; my $renzs = Bio::Restriction::EnzymeCollection->new(-empty => 1); # read until start of data while (defined( my $line = $self->_readline()) ) { next if $line =~ /^[ R]/; $self->_pushback($line); last; } # enzyme name [tab] prototype [tab] recognition sequence with # cleavage site [tab] methylation site and type [tab] commercial # source [tab] references while (defined(my $line = $self->_readline()) ) { $self->debug($line); chomp $line; my ($name, $prototype, $site, $meth, $vendor, $refs) = split /\t/, $line; # we need mininum name and site unless ($site) { $self->warn("Can not parse line with name [$name]") if $self->verbose > 0; next; } next unless $name; # # four cut enzymes are not in this format # my $precut; # if ($site =~ m/^\((\d+\/\d+)\)[ATGCN]+/) { # $precut=$1; # $site =~ s/\($precut\)//; # } # -------------- cut --------------- # this regexp now parses all possible components # $1 : (s/t) or undef # $2 : [site] # $3 : (m/n) or undef /maj my ($precut, $recog, $postcut) = ( $site =~ m/^(?:\((\w+\/\w+)\))?([\w^]+)(?:\((\w+\/\w+)\))?/ ); my @sequences; if ($site =~ /\,/) { @sequences = split( /\,/, $site); $site=shift @sequences; } # # prototype # # presence of a name means the prototype isoschizomer, absence means # this enzyme is the prototype my $is_prototype = ($prototype ? 1 : 0); # # vendors # my @vendors; @vendors = ( split / */, $vendor) if $vendor; # # references # my @refs; @refs = map {split /\n+/} $refs if $refs; # when enz is constructed, site() will contain original characters, # but recog() will contain a regexp if required.../maj my $re = Bio::Restriction::Enzyme->new( -name => $name, -site => $recog, -recog => $recog, -precut => $precut, -postcut => $postcut, -is_prototype => $is_prototype, -prototype => $prototype, -vendors => [@vendors], -references => [@refs], -xln_sub => \&_xln_sub ); # # methylation # # [easier to set here during parsing than in constructor] /maj my @meths; if ($meth) { # this can be either X(Y) or X(Y),X2(Y2) # where X is the base and y is the type of methylation if ( $meth =~ /(\S+)\((\d+)\),(\S+)\((\d+)\)/ ) { # two msites per site #my ($p1, $m1, $p2, $m2) = ($1, $2, $3, $4); $re->methylation_sites($self->_meth($re,$1, $2), $self->_meth($re,$3,$4)); } elsif ($meth =~ /(\S+)\((\d+)\)/ ) { # one msite per site or more sites #print Dumper $meth; $re->methylation_sites( $self->_meth($re,$1,$2) ); @meths = split (/, /, $meth); $meth=shift @meths; } else { $self->warn("Unknown methylation format [$meth]") if $self->verbose >0; } } # # create special types of Enzymes # $self->_make_multisites( $re, \@sequences, \@meths) if @sequences; $renzs->enzymes($re); } return $renzs; } =head2 _xln_sub Title : _xln_sub Function: Translates withrefm coords to Bio::Restriction coords Args : Bio::Restriction::Enzyme object, scalar integer (cut posn) Note : Used internally; pass as a coderef to the B:R::Enzyme constructor =cut sub _xln_sub { my ($z,$c) = @_; return ($c < 0 ? $c : length($z->string)+$c); } =head2 write Title : write Usage : $stream->write($renzs) Function: writes restriction enzymes into the stream Returns : 1 for success and 0 for error Args : a Bio::Restriction::Enzyme or a Bio::Restriction::EnzymeCollection object =cut sub write { my ($self,@h) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Restriction/IO/prototype.pm000444000765000024 1012512254227335 21410 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Restriction::IO::prototype # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Restriction::IO::prototype - prototype enzyme set =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Restriction::IO class. =head1 DESCRIPTION This is a parser for the proto/neo file REBASE format, which contains prototype information as well as (in the neo file) neoschizomer data. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Restriction::IO::prototype; use vars qw(%WITH_REFM_FIELD); use strict; #use Bio::Restriction::IO; use Bio::Restriction::Enzyme; use Bio::Restriction::EnzymeCollection; use Data::Dumper; use base qw(Bio::Restriction::IO::base); =head2 read Title : read Usage : $renzs = $stream->read Function: reads all the restrction enzymes from the stream Returns : a Bio::Restriction::Restriction object Args : none =cut sub read { my $self = shift; my $coll = Bio::Restriction::EnzymeCollection->new(-empty => 1); my ($seentop, $last_type); while (defined (my $line = $self->_readline)) { chomp $line; next unless $line; if ($line =~ /TYPE\s+(I)+/) { $last_type = $1; $seentop ||= 1; next; } next unless $seentop; my @data = split /\s+/,$line,2; next if $data[0] =~ /^[-\s]*$/; # neo my ($enzyme, $is_neo, $is_proto, $site); if ($data[0] =~ /^\s+(\S+)\s+(\S+)/) { ($enzyme, $site, $is_proto, $is_neo) = ($1, $2, 0, 1); } else { ($enzyme, $site, $is_proto, $is_neo) = ($data[0], $data[1], 1, 0); } $site =~ s/\s+//g; my $precut; if ($site =~ m/^\((\d+\/\d+)\)[RYATGCN]+/) { $precut=$1; $site =~ s/\($precut\)//; } my ($cut, $comp_cut); ($site, $cut, $comp_cut) = $self->_cuts_from_site($site); my $re = Bio::Restriction::Enzyme->new( -type => $last_type, -site => $site, -name => $enzyme, -is_prototype => $is_proto, -is_neoschizomer => $is_neo); if ($cut) { $re->cut($self->_coordinate_shift_to_cut(length($site), $cut)); $re->complementary_cut($self->_coordinate_shift_to_cut(length($site), $comp_cut)); } $coll->enzymes($re); } return $coll->enzymes; } =head2 write Title : write Usage : $stream->write($renzs) Function: writes restriction enzymes into the stream Returns : 1 for success and 0 for error Args : a Bio::Restriction::Enzyme or a Bio::Restriction::EnzymeCollection object =cut sub write { my ($self,@h) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Restriction/IO/withrefm.pm000444000765000024 1600612254227336 21175 0ustar00cjfieldsstaff000000000000# BioPerl module for Bio::Restriction::IO::withrefm # # Please direct questions and support issues to # # Cared for by Rob Edwards # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Restriction::IO::withrefm - withrefm enzyme set =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Restriction::IO class. =head1 DESCRIPTION This is the most complete format of the REBASE files, and basically includes all the data on each of the restriction enzymes. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Mark A. Jensen, maj-at-fortinbras-dot-us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Restriction::IO::withrefm; use vars qw(%WITH_REFM_FIELD); use strict; #use Bio::Restriction::IO; use Bio::Restriction::Enzyme; use Bio::Restriction::EnzymeCollection; use Data::Dumper; use base qw(Bio::Restriction::IO::base); =head2 read Title : read Usage : $renzs = $stream->read Function: reads all the restrction enzymes from the stream Returns : a Bio::Restriction::Restriction object Args : none =cut sub read { my $self = shift; my $renzs = Bio::Restriction::EnzymeCollection->new(-empty => 1); local $/ = '<1>'; while (defined(my $entry=$self->_readline()) ) { # not an entry. next unless $entry =~ /<2>/; #$self->debug("|$entry|\n"); # # Minimal information # my ($name) = $entry =~ /^(\S+)/; my ($site) = $entry =~ /\<3\>([^\n]+)/; if ( ! defined $site || $site eq '' or $site eq '?') { $self->warn("$name: no site. Skipping") if $self->verbose > 1; next; } # there are a couple of sequences that have multiple # recognition sites eg M.PhiBssHII: ACGCGT,CCGCGG,RGCGCY,RCCGGY,GCGCGC # TaqII : GACCGA(11/9),CACCCA(11/9) my @sequences; if ($site =~ /\,/) { @sequences = split (/\,/, $site); $site=shift @sequences; } # this regexp now parses all possible components # $1 : (s/t) or undef # $2 : [site] # $3 : (m/n) or undef /maj no warnings; # avoid faulty 'uninitialized value' warnings # occurring against the variables set by # regexp matching (unless anyone has other ideas...) my ($precut, $recog, $postcut) = ( $site =~ m/^(?:\((-?\w+\/-?\w+)\))?([\w^]+)(?:\((-?\w+\/-?\w+)\))?/ ); # # prototype / isoschizomers # my ($isoschizomers) = $entry =~ /<2>([^\n]+)/; my @isos = split(/\,/,$isoschizomers); my $is_prototype = (@isos ? 1 : 0); # # microbe # my ($microbe) = $entry =~ /<5>([^\n]+)/; # # source # my ($source) = $entry =~ /<6>([^\n]+)/; # # vendors # my ($vendors) = $entry =~ /<7>([^\n]+)/; my @vendors = split(/ */, $vendors); # # references # my ($refs) = $entry =~ /<8>(.+)<1>/s; my @refs = map {split /\n+/} $refs; use warnings; # when enz is constructed, site() will contain original characters, # but recog() will contain a regexp if required.../maj my $re = Bio::Restriction::Enzyme->new( -name => $name, -site => $recog, -recog => $recog, -precut => $precut, -postcut => $postcut, -is_prototype => $is_prototype, -isoschizomers => [@isos], -source => $source, -vendors => [@vendors], -references => [@refs], -xln_sub => \&_xln_sub ); # # methylation: easier to set here during parsing/maj # my ($meth) = $entry =~ /<4>([^\n]+)/; my @meths; if ($meth) { # this can be either X(Y) or X(Y),X2(Y2) # where X is the base and y is the type of methylation if ( $meth =~ /(\S+)\((\d+)\),(\S+)\((\d+)\)/ ) { # two msites per site #my ($p1, $m1, $p2, $m2) = ($1, $2, $3, $4); $re->methylation_sites($self->_meth($re,$1, $2), $self->_meth($re,$3,$4)); } elsif ($meth =~ /(\S+)\((\d+)\)/ ) { # one msite per site or more sites $re->methylation_sites( $self->_meth($re,$1,$2) ); @meths = split (/\, /, $meth); $meth=shift @meths; } else { $self->warn("Unknown methylation format [$meth]") if $self->verbose >0; } } # the _make_multicuts function now takes place in the # Enzyme constructor / maj # # create special types of Enzymes # (because of object cloning in _make_multisites, this happens # after everything else is set /maj) # (with the removal of the collection from the arglist, this # call (or its code) could now be placed in the constructor, # which is safer (since this has to happen last), # but it requires the methylation info, which # is more natural to get out here in the parsing./maj $self->_make_multisites($re, \@sequences, \@meths, \&_xln_sub) if @sequences; $renzs->enzymes($re); } return $renzs; } =head2 _xln_sub Title : _xln_sub Function: Translates withrefm coords to Bio::Restriction coords Args : Bio::Restriction::Enzyme object, scalar integer (cut posn) Note : Used internally; pass as a coderef to the B:R::Enzyme constructor =cut sub _xln_sub { my ($z,$c) = @_; return ($c < 0 ? $c : length($z->string)+$c); } =head2 write Title : write Usage : $stream->write($renzs) Function: writes restriction enzymes into the stream Returns : 1 for success and 0 for error Args : a Bio::Restriction::Enzyme or a Bio::Restriction::EnzymeCollection object =cut sub write { my ($self,@h) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Root000755000765000024 012254227336 14741 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Root/Build.pm000444000765000024 12544212254227336 16543 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Root::Build # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Root::Build - A common Module::Build subclass base for BioPerl distributions =head1 SYNOPSIS ...TO BE ADDED =head1 DESCRIPTION This is a subclass of Module::Build so we can override certain methods and do fancy stuff It was first written against Module::Build::Base v0.2805. Many of the methods here are copy/pasted from there in their entirety just to change one or two minor things, since for the most part Module::Build::Base code is hard to cleanly override. B: per bug 3196, the majority of the code in this module has been revised or commented out to bring it in line with the Module::Build API. In particular, 'requires/recommends' tags in the Build.PL file were not of the same format as those for Module::Build, and so caused serious issues with newer versions (including giving incorrect meta data). Other problematic methods involving automatic installation of prereq modules via CPAN were also removed as they do not work with more modern perl tools such as perlbrew and cpanm. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Root::Build; BEGIN { # we really need Module::Build to be installed eval "use base Module::Build; 1" or die "This package requires Module::Build v0.2805 or greater to install itself.\n$@"; # ensure we'll be able to reload this module later by adding its path to inc use Cwd; use lib Cwd::cwd(); } use strict; use warnings; our $VERSION = '1.006923'; # pre-1.7 our @extra_types = qw(options excludes_os feature_requires test); # test must always be last in the list! our $checking_types = "requires|conflicts|".join("|", @extra_types); # our modules are in Bio, not lib sub find_pm_files { my $self = shift; foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) { $self->{properties}{pm_files}->{$pm} = File::Spec->catfile('lib', $pm); } $self->_find_file_by_type('pm', 'lib'); } # ask what scripts to install (this method is unique to bioperl) sub choose_scripts { my $self = shift; my $accept = shift; # we can offer interactive installation by groups only if we have subdirs # in scripts and no .PLS files there opendir(my $scripts_dir, 'scripts') or die "Can't open directory 'scripts': $!\n"; my $int_ok = 0; my @group_dirs; # only retain top-level script directories (the 'categories') while (my $thing = readdir($scripts_dir)) { next if $thing =~ /^\./; $thing = File::Spec->catfile('scripts', $thing); if (-d $thing) { $int_ok = 1; push(@group_dirs, $thing); } } closedir($scripts_dir); my $question = $int_ok ? "Install [a]ll BioPerl scripts, [n]one, ". "or choose groups [i]nteractively?" : "Install [a]ll BioPerl scripts ". "or [n]one?"; my $prompt = $accept ? 'a' : $self->prompt($question, 'a'); if ($prompt =~ /^[aA]/) { $self->log_info(" - will install all scripts\n"); $self->notes(chosen_scripts => 'all'); } elsif ($prompt =~ /^[iI]/) { $self->log_info(" - will install interactively:\n"); my @chosen_scripts; foreach my $group_dir (@group_dirs) { my $group = File::Basename::basename($group_dir); print " * group '$group' has:\n"; my @script_files = @{$self->rscan_dir($group_dir, qr/\.PLS$|\.pl$/)}; foreach my $script_file (@script_files) { my $script = File::Basename::basename($script_file); print " $script\n"; } my $result = $self->prompt(" Install scripts for group '$group'? [y]es [n]o [q]uit", 'n'); die if $result =~ /^[qQ]/; if ($result =~ /^[yY]/) { $self->log_info(" + will install group '$group'\n"); push(@chosen_scripts, @script_files); } else { $self->log_info(" - will not install group '$group'\n"); } } my $chosen_scripts = @chosen_scripts ? join("|", @chosen_scripts) : 'none'; $self->notes(chosen_scripts => $chosen_scripts); } else { $self->log_info(" - won't install any scripts\n"); $self->notes(chosen_scripts => 'none'); } print "\n"; } # our version of script_files doesn't take args but just installs those scripts # requested by the user after choose_scripts() is called. If it wasn't called, # installs all scripts in scripts directory sub script_files { my $self = shift; unless (-d 'scripts') { return {}; } my $chosen_scripts = $self->notes('chosen_scripts'); if ($chosen_scripts) { return if $chosen_scripts eq 'none'; return { map {$_, 1} split(/\|/, $chosen_scripts) } unless $chosen_scripts eq 'all'; } return $_ = { map {$_,1} @{$self->rscan_dir('scripts', qr/\.PLS$|\.pl$/)} }; } # extended to handle extra checking types #sub features { # my $self = shift; # my $ph = $self->{phash}; # # if (@_) { # my $key = shift; # if ($ph->{features}->exists($key)) { # return $ph->{features}->access($key, @_); # } # # if (my $info = $ph->{auto_features}->access($key)) { # my $failures = $self->prereq_failures($info); # my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0; # return !$disabled; # } # # return $ph->{features}->access($key, @_); # } # # # No args - get the auto_features & overlay the regular features # my %features; # my %auto_features = $ph->{auto_features}->access(); # while (my ($name, $info) = each %auto_features) { # my $failures = $self->prereq_failures($info); # my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0; # $features{$name} = $disabled ? 0 : 1; # } # %features = (%features, $ph->{features}->access()); # # return wantarray ? %features : \%features; #} #*feature = \&features; # overridden to fix a stupid bug in Module::Build and extended to handle extra # checking types #sub check_autofeatures { # my ($self) = @_; # my $features = $self->auto_features; # # return unless %$features; # # $self->log_info("Checking features:\n"); # # my $max_name_len = 0; # this wasn't set to 0 in Module::Build, causing warning in next line # $max_name_len = ( length($_) > $max_name_len ) ? length($_) : $max_name_len for keys %$features; # # while (my ($name, $info) = each %$features) { # $self->log_info(" $name" . '.' x ($max_name_len - length($name) + 4)); # if ($name eq 'PL_files') { # print "got $name => $info\n"; # print "info has:\n"; # while (my ($key, $val) = each %$info) { # print " $key => $val\n"; # } # } # # if ( my $failures = $self->prereq_failures($info) ) { # my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0; # $self->log_info( $disabled ? "disabled\n" : "enabled\n" ); # # my $log_text; # while (my ($type, $prereqs) = each %$failures) { # while (my ($module, $status) = each %$prereqs) { # my $required = ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0; # my $prefix = ($required) ? '-' : '*'; # $log_text .= " $prefix $status->{message}\n"; # } # } # $self->log_warn($log_text) if $log_text && ! $self->quiet; # } # else { # $self->log_info("enabled\n"); # } # } # # $self->log_info("\n"); #} # TODO: STDERR output redirect is causing some installations to fail, commenting # out until a fix is in place # overriden just to hide pointless ugly warnings #sub check_installed_status { # my $self = shift; # # open (my $olderr, ">&". fileno(STDERR)); # open(STDERR, "/dev/null"); # my $return = $self->SUPER::check_installed_status(@_); # open(STDERR, ">&". fileno($olderr)); # return $return; #} # extend to handle option checking (which takes an array ref) and code test # checking (which takes a code ref and must return a message only on failure) # and excludes_os (which takes an array ref of regexps). # also handles more informative output of recommends section #sub prereq_failures { # my ($self, $info) = @_; # # my @types = (@{ $self->prereq_action_types }, @extra_types); # $info ||= {map {$_, $self->$_()} @types}; # # my $out = {}; # foreach my $type (@types) { # my $prereqs = $info->{$type} || next; # # my $status = {}; # if ($type eq 'test') { # unless (keys %$out) { # if (ref($prereqs) eq 'CODE') { # $status->{message} = &{$prereqs}; # # # drop the code-ref to avoid Module::Build trying to store # # it with Data::Dumper, generating warnings. (And also, may # # be expensive to run the sub multiple times.) # $info->{$type} = $status->{message}; # } # else { # $status->{message} = $prereqs; # } # $out->{$type}{'test'} = $status if $status->{message}; # } # } # elsif ($type eq 'options') { # my @not_ok; # foreach my $wanted_option (@{$prereqs}) { # unless ($self->args($wanted_option)) { # push(@not_ok, $wanted_option); # } # } # # if (@not_ok > 0) { # $status->{message} = "Command line option(s) '@not_ok' not supplied"; # $out->{$type}{'options'} = $status; # } # } # elsif ($type eq 'excludes_os') { # foreach my $os (@{$prereqs}) { # if ($^O =~ /$os/i) { # $status->{message} = "This feature isn't supported under your OS ($os)"; # $out->{$type}{'excludes_os'} = $status; # last; # } # } # } # else { # while ( my ($modname, $spec) = each %$prereqs ) { # $status = $self->check_installed_status($modname, $spec); # next if $status->{ok}; # # if ($type =~ /^(?:\w+_)?conflicts$/) { # $status->{conflicts} = delete $status->{need}; # $status->{message} = "$modname ($status->{have}) conflicts with this distribution"; # } # elsif ($type =~ /^(?:\w+_)?recommends$/) { # my ($preferred_version, $why, $by_what) = split("/", $spec); # $by_what = join(", ", split(",", $by_what)); # $by_what =~ s/, (\S+)$/ and $1/; # # $status->{message} = (!ref($status->{have}) && $status->{have} eq '' # ? "Optional prerequisite $modname is not installed" # : "$modname ($status->{have}) is installed, but we prefer to have $preferred_version"); # # $status->{message} .= "\n (wanted for $why, used by $by_what)"; # # if ($by_what =~ /\[circular dependency!\]/) { # $preferred_version = -1; # } # # #my $installed = $self->install_optional($modname, $preferred_version, $status->{message}); # #next if $installed eq 'ok'; # #$status->{message} = $installed unless $installed eq 'skip'; # } # elsif ($type =~ /^feature_requires/) { # # if there is a test code-ref, drop it to avoid # # Module::Build trying to store it with Data::Dumper, # # generating warnings. # delete $info->{test}; # } # else { # my $installed = $self->install_required($modname, $spec, $status->{message}); # next if $installed eq 'ok'; # $status->{message} = $installed; # } # # $out->{$type}{$modname} = $status; # } # } # } # # return keys %{$out} ? $out : return; #} # install an external module using CPAN prior to testing and installation # should only be called by install_required or install_optional #sub install_prereq { # my ($self, $desired, $version, $required) = @_; # # if ($self->under_cpan) { # # Just add to the required hash, which CPAN >= 1.81 will check prior # # to install # $self->{properties}{requires}->{$desired} = $version; # $self->log_info(" I'll get CPAN to prepend the installation of this\n"); # return 'ok'; # } # else { # my $question = $required ? "$desired is absolutely required prior to installation: shall I install it now using a CPAN shell?" : # "To install $desired I'll need to open a CPAN shell right now; is that OK?"; # my $do_install = $self->y_n($question.' y/n', 'y'); # # if ($do_install) { # # Here we use CPAN to actually install the desired module, the benefit # # being we continue even if installation fails, and that this works # # even when not using CPAN to install. # require Cwd; # require CPAN; # # # Save this because CPAN will chdir all over the place. # my $cwd = Cwd::cwd(); # # CPAN::Shell->install($desired); # my $msg; # my $expanded = CPAN::Shell->expand("Module", $desired); # if ($expanded && $expanded->uptodate) { # $self->log_info("\n\n*** (back in BioPerl Build.PL) ***\n * You chose to install $desired and it installed fine\n"); # $msg = 'ok'; # } # else { # $self->log_info("\n\n*** (back in BioPerl Build.PL) ***\n"); # $msg = "You chose to install $desired but it failed to install"; # } # # chdir $cwd or die "Cannot chdir() back to $cwd: $!"; # return $msg; # } # else { # return $required ? "You chose not to install the REQUIRED module $desired: you'd better install it yourself manually!" : # "Even though you wanted the optional module $desired, you chose not to actually install it: do it yourself manually."; # } # } #} # install required modules listed in 'requires' or 'build_requires' arg to # new that weren't already installed. Should only be called by prereq_failures #sub install_required { # my ($self, $desired, $version, $msg) = @_; # # $self->log_info(" - ERROR: $msg\n"); # # return $self->install_prereq($desired, $version, 1); #} # install optional modules listed in 'recommends' arg to new that weren't # already installed. Should only be called by prereq_failures #sub install_optional { # my ($self, $desired, $version, $msg) = @_; # # unless (defined $self->{ask_optional}) { # $self->{ask_optional} = $self->args->{accept} # ? 'n' : $self->prompt("Install [a]ll optional external modules, [n]one, or choose [i]nteractively?", 'n'); # } # return 'skip' if $self->{ask_optional} =~ /^n/i; # # my $install; # if ($self->{ask_optional} =~ /^a/i) { # $self->log_info(" * $msg\n"); # $install = 1; # } # else { # $install = $self->y_n(" * $msg\n Do you want to install it? y/n", 'n'); # } # # my $orig_version = $version; # $version = 0 if $version == -1; # if ($install && ! ($self->{ask_optional} =~ /^a/i && $orig_version == -1)) { # return $self->install_prereq($desired, $version); # } # else { # my $circular = ($self->{ask_optional} =~ /^a/i && $orig_version == -1) ? " - this is a circular dependency so doesn't get installed when installing 'all' modules. If you really want it, choose modules interactively." : ''; # $self->log_info(" * You chose not to install $desired$circular\n"); # return 'ok'; # } #} # there's no official way to discover if being run by CPAN, we take an approach # similar to that of Module::AutoInstall #sub under_cpan { # my $self = shift; # # unless (defined $self->{under_cpan}) { # ## modified from Module::AutoInstall # # my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; # if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { # $self->{under_cpan} = $cpan_env ? 'CPAN' : 'CPANPLUS'; # } # # require CPAN; # # unless (defined $self->{under_cpan}) { # if ($CPAN::VERSION > '1.89') { # if ($cpan_env) { # $self->{under_cpan} = 'CPAN'; # } # else { # $self->{under_cpan} = 0; # } # } # } # # unless (defined $self->{under_cpan}) { # # load cpan config # if ($CPAN::HandleConfig::VERSION) { # # Newer versions of CPAN have a HandleConfig module # CPAN::HandleConfig->load; # } # else { # # Older versions had the load method in Config directly # CPAN::Config->load; # } # # # Find the CPAN lock-file # my $lock = File::Spec->catfile($CPAN::Config->{cpan_home}, '.lock'); # if (-f $lock) { # # Module::AutoInstall now goes on to open the lock file and compare # # its pid to ours, but we're not in a situation where we expect # # the pids to match, so we take the windows approach for all OSes: # # find out if we're in cpan_home # my $cwd = File::Spec->canonpath(Cwd::cwd()); # my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home}); # # $self->{under_cpan} = index($cwd, $cpan) > -1; # } # } # # if ($self->{under_cpan}) { # $self->log_info("(I think I'm being run by CPAN/CPANPLUS, so will rely on it to handle prerequisite installation)\n"); # } # else { # $self->log_info("(I think you ran Build.PL directly, so will use CPAN to install prerequisites on demand)\n"); # $self->{under_cpan} = 0; # } # } # # return $self->{under_cpan}; #} # overridden simply to not print the default answer if chosen by hitting return sub prompt { my $self = shift; my $mess = shift or die "prompt() called without a prompt message"; my $def; if ( $self->_is_unattended && !@_ ) { die <_readline(); if ( !defined($ans) # Ctrl-D or unattended or !length($ans) ) { # User hit return #print "$def\n"; didn't like this! $ans = $def; } return $ans; } # like the Module::Build version, except that we always get version from # dist_version sub find_dist_packages { my $self = shift; # Only packages in .pm files are candidates for inclusion here. # Only include things in the MANIFEST, not things in developer's # private stock. my $manifest = $self->_read_manifest('MANIFEST') or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first"; # Localize my %dist_files = map { $self->localize_file_path($_) => $_ } keys %$manifest; my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files }; my $actual_version = $self->dist_version; # First, we enumerate all packages & versions, # seperating into primary & alternative candidates my( %prime, %alt ); foreach my $file (@pm_files) { next if $dist_files{$file} =~ m{^t/}; # Skip things in t/ my @path = split( /\//, $dist_files{$file} ); (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//; my $pm_info = Module::Build::ModuleInfo->new_from_file( $file ); foreach my $package ( $pm_info->packages_inside ) { next if $package eq 'main'; # main can appear numerous times, ignore next if grep /^_/, split( /::/, $package ); # private package, ignore my $version = $pm_info->version( $package ); if ($version && $version != $actual_version) { $self->log_warn("Package $package had version $version!\n"); } $version = $actual_version; if ( $package eq $prime_package ) { if ( exists( $prime{$package} ) ) { # M::B::ModuleInfo will handle this conflict die "Unexpected conflict in '$package'; multiple versions found.\n"; } else { $prime{$package}{file} = $dist_files{$file}; $prime{$package}{version} = $version if defined( $version ); } } else { push( @{$alt{$package}}, { file => $dist_files{$file}, version => $version } ); } } } # Then we iterate over all the packages found above, identifying conflicts # and selecting the "best" candidate for recording the file & version # for each package. foreach my $package ( keys( %alt ) ) { my $result = $self->_resolve_module_versions( $alt{$package} ); if ( exists( $prime{$package} ) ) { # primary package selected if ( $result->{err} ) { # Use the selected primary package, but there are conflicting # errors amoung multiple alternative packages that need to be # reported $self->log_warn("Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err}); } elsif ( defined( $result->{version} ) ) { # There is a primary package selected, and exactly one # alternative package if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) { # Unless the version of the primary package agrees with the # version of the alternative package, report a conflict if ( $self->compare_versions( $prime{$package}{version}, '!=', $result->{version} ) ) { $self->log_warn("Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . " $result->{file} ($result->{version})\n"); } } else { # The prime package selected has no version so, we choose to # use any alternative package that does have a version $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version}; } } else { # no alt package found with a version, but we have a prime # package so we use it whether it has a version or not } } else { # No primary package was selected, use the best alternative if ( $result->{err} ) { $self->log_warn("Found conflicting versions for package '$package'\n" . $result->{err}); } # Despite possible conflicting versions, we choose to record # something rather than nothing $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version} if defined( $result->{version} ); } } # Stringify versions for (grep exists $_->{version}, values %prime) { $_->{version} = $_->{version}->stringify if ref($_->{version}); } return \%prime; } # our recommends syntax contains extra info that needs to be ignored at this # stage #sub _parse_conditions { # my ($self, $spec) = @_; # # ($spec) = split("/", $spec); # # if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores # return (">= $spec"); # } # else { # return split /\s*,\s*/, $spec; # } #} # when generating META.yml, we output optional_features syntax (instead of # recommends syntax). Note that as of CPAN v1.9402 nothing useful is done # with this information, which is why we implement our own request to install # the optional modules in install_optional(). # Also note that CPAN PLUS complains with an [ERROR] when it sees this META.yml, # but it isn't fatal and installation continues fine. # 'recommends' groups broken up now into separate modules and grouping the # 'requires' instead of lumping modules together (quotes were choking YAML # parsing). Now passes Parse::CPAN::Meta w/o errors. # -cjfields 9-17-09 # let us store extra things persistently in _build #sub _construct { # my $self = shift; # # # calling SUPER::_construct will dump some of the input to this sub out # # with Data::Dumper, which will complain about code refs. So we replace # # any code refs with dummies first, then put them back afterwards # my %in_hash = @_; # my $auto_features = $in_hash{auto_features} if defined $in_hash{auto_features}; # my %code_refs; # if ($auto_features) { # while (my ($key, $hash) = each %{$auto_features}) { # while (my ($sub_key, $val) = each %{$hash}) { # if (ref($val) && ref($val) eq 'CODE') { # $hash->{$sub_key} = 'CODE_ref'; # $code_refs{$key}->{$sub_key} = $val; # } # } # } # } # # $self = $self->SUPER::_construct(@_); # # my ($p, $ph) = ($self->{properties}, $self->{phash}); # # if (keys %code_refs) { # while (my ($key, $hash) = each %{$auto_features}) { # if (defined $code_refs{$key}) { # while (my ($sub_key, $code_ref) = each %{$code_refs{$key}}) { # $hash->{$sub_key} = $code_ref; # } # $ph->{auto_features}->{$key} = $hash; # } # } # } # # foreach (qw(manifest_skip post_install_scripts)) { # my $file = File::Spec->catfile($self->config_dir, $_); # $ph->{$_} = Module::Build::Notes->new(file => $file); # $ph->{$_}->restore if -e $file; # } # # return $self; #} #sub write_config { # my $self = shift; # $self->SUPER::write_config; # # # write extra things # $self->{phash}{$_}->write() foreach qw(manifest_skip post_install_scripts); # # # be even more certain we can reload ourselves during a resume by copying # # ourselves to _build\lib # # this is only possible for the core distribution where we are actually # # present in the distribution # my $self_filename = File::Spec->catfile('Bio', 'Root', 'Build.pm'); # -e $self_filename || return; # # my $filename = File::Spec->catfile($self->{properties}{config_dir}, 'lib', 'Bio', 'Root', 'Build.pm'); # my $filedir = File::Basename::dirname($filename); # # File::Path::mkpath($filedir); # warn "Can't create directory $filedir: $!" unless -d $filedir; # # File::Copy::copy($self_filename, $filename); # warn "Unable to copy 'Bio/Root/Build.pm' to '$filename'\n" unless -e $filename; #} # add a file to the default MANIFEST.SKIP #sub add_to_manifest_skip { # my $self = shift; # my %files = map {$self->localize_file_path($_), 1} @_; # $self->{phash}{manifest_skip}->write(\%files); #} # we always generate a new MANIFEST instead of allowing existing files to remain # MANIFEST.SKIP is left alone sub ACTION_manifest { my ($self) = @_; if ( -e 'MANIFEST' || -e 'MANIFEST.SKIP' ) { $self->log_warn("MANIFEST files already exist, will overwrite them\n"); unlink('MANIFEST'); } require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean. local ($^W, $ExtUtils::Manifest::Quiet) = (0,1); ExtUtils::Manifest::mkmanifest(); } # extended to add extra things to the default MANIFEST.SKIP #sub _write_default_maniskip { # my $self = shift; # $self->SUPER::_write_default_maniskip; # # my @extra = keys %{$self->{phash}{manifest_skip}->read}; # if (@extra) { # open(my $fh, '>>', 'MANIFEST.SKIP') or die "Could not open MANIFEST.SKIP file\n"; # print $fh "\n# Avoid additional run-time generated things\n"; # foreach my $line (@extra) { # print $fh $line, "\n"; # } # close($fh); # } #} # extended to run scripts post-installation sub ACTION_install { my ($self) = @_; require ExtUtils::Install; $self->depends_on('build'); ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0); #$self->run_post_install_scripts; } #sub add_post_install_script { # my $self = shift; # my %files = map {$self->localize_file_path($_), 1} @_; # $self->{phash}{post_install_scripts}->write(\%files); #} # #sub run_post_install_scripts { # my $self = shift; # my @scripts = keys %{$self->{phash}{post_install_scripts}->read}; # foreach my $script (@scripts) { # $self->run_perl_script($script); # } #} # for use with auto_features, which should require LWP::UserAgent as one of # its reqs # Note: as of 4-11-11, this is no longer called - if someone wants to run # network tests (off by default) w/o a network, then they are hanging themselves # by their own shoelaces. sub test_internet { eval {require LWP::UserAgent;}; if ($@) { # ideally this won't happen because auto_feature already specified # LWP::UserAgent, so this sub wouldn't get called if LWP not installed return "LWP::UserAgent not installed"; } my $ua = LWP::UserAgent->new; $ua->timeout(10); $ua->env_proxy; my $response = $ua->get('http://search.cpan.org/'); unless ($response->is_success) { return "Could not connect to the internet (http://search.cpan.org/)"; } return; } # nice directory names for dist-related actions sub dist_dir { my ($self) = @_; my $version = $self->dist_version; if ($version =~ /^\d\.\d{6}\d$/) { # 1.x.x.100 returned as 1.x.x.1 $version .= '00'; } $version =~ s/00(\d)/$1./g; $version =~ s/\.$//; if (my ($minor, $rev) = $version =~ /^\d\.(\d)\.\d\.(\d+)$/) { my $dev = ! ($minor % 2 == 0); if ($rev == 100) { my $replace = $dev ? "_$rev" : ''; $version =~ s/\.\d+$/$replace/; } elsif ($rev < 100) { $rev = sprintf("%03d", $rev); $version =~ s/\.\d+$/_$rev-RC/; } else { $rev -= 100 unless $dev; my $replace = $dev ? "_$rev" : ".$rev"; $version =~ s/\.\d+$/$replace/; } } return "$self->{properties}{dist_name}-$version"; } # try to be as consistent as possible with Module::Build API #sub ppm_name { # my $self = shift; # return $self->dist_dir.'-ppm'; #} # generate complete ppd4 version file #sub ACTION_ppd { # my $self = shift; # # my $file = $self->make_ppd(%{$self->{args}}); # $self->add_to_cleanup($file); # #$self->add_to_manifest_skip($file); #} # add pod2htm temp files to MANIFEST.SKIP, generated during ppmdist most likely #sub htmlify_pods { # my $self = shift; # $self->SUPER::htmlify_pods(@_); # #$self->add_to_manifest_skip('pod2htm*'); #} # don't copy across man3 docs since they're of little use under Windows and # have bad filenames sub ACTION_ppmdist { my $self = shift; my @types = $self->install_types(1); $self->SUPER::ACTION_ppmdist(@_); $self->install_types(0); } # when supplied a true value, pretends libdoc doesn't exist (preventing man3 # installation for ppmdist). when supplied false, they exist again sub install_types { my ($self, $no_libdoc) = @_; $self->{no_libdoc} = $no_libdoc if defined $no_libdoc; my @types = $self->SUPER::install_types; if ($self->{no_libdoc}) { my @altered_types; foreach my $type (@types) { push(@altered_types, $type) unless $type eq 'libdoc'; } return @altered_types; } return @types; } # overridden from Module::Build::PPMMaker for ppd4 compatability # note: no longer needed with more recent versions of Module::Build #sub make_ppd { # my ($self, %args) = @_; # # require Module::Build::PPMMaker; # my $mbp = Module::Build::PPMMaker->new(); # # my %dist; # foreach my $info (qw(name author abstract version)) { # my $method = "dist_$info"; # $dist{$info} = $self->$method() or die "Can't determine distribution's $info\n"; # } # $dist{codebase} = $self->ppm_name.'.tar.gz'; # $mbp->_simple_xml_escape($_) foreach $dist{abstract}, $dist{codebase}, @{$dist{author}}; # # my (undef, undef, undef, $mday, $mon, $year) = localtime(); # $year += 1900; # $mon++; # my $date = "$year-$mon-$mday"; # # my $softpkg_version = $self->dist_dir; # $softpkg_version =~ s/^$dist{name}-//; # # # to avoid a ppm bug, instead of including the requires in the softpackage # # for the distribution we're making, we'll make a seperate Bundle:: # # softpackage that contains all the requires, and require only the Bundle in # # the real softpackage # my ($bundle_name) = $dist{name} =~ /^.+-(.+)/; # $bundle_name ||= 'core'; # $bundle_name =~ s/^(\w)/\U$1/; # my $bundle_dir = "Bundle-BioPerl-$bundle_name-$softpkg_version-ppm"; # my $bundle_file = "$bundle_dir.tar.gz"; # my $bundle_softpkg_name = "Bundle-BioPerl-$bundle_name"; # $bundle_name = "Bundle::BioPerl::$bundle_name"; # # # header # my $ppd = <<"PPD"; # # $dist{name} # $dist{abstract} #@{[ join "\n", map " $_", @{$dist{author}} ]} # #PPD # # # provide section # foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) { # # convert these filepaths to Module names # $pm =~ s/\//::/g; # $pm =~ s/\.pm//; # # $ppd .= sprintf(<<'EOF', $pm, $dist{version}); # #EOF # } # # # rest of softpkg # $ppd .= <<"PPD"; # # # # # # #PPD # # # now a new softpkg for the bundle # $ppd .= <<"PPD"; # # # $bundle_name # Bundle of pre-requisites for $dist{name} #@{[ join "\n", map " $_", @{$dist{author}} ]} # # # # #PPD # # # required section # # we do both requires and recommends to make installation on Windows as # # easy (mindless) as possible # for my $type ('requires', 'recommends') { # my $prereq = $self->$type; # while (my ($modname, $version) = each %$prereq) { # next if $modname eq 'perl'; # ($version) = split("/", $version) if $version =~ /\//; # # # Module names must have at least one :: # unless ($modname =~ /::/) { # $modname .= '::'; # } # # # Bio::Root::Version number comes out as triplet number like 1.5.2; # # convert to our own version # if ($modname eq 'Bio::Root::Version') { # $version = $dist{version}; # } # # $ppd .= sprintf(<<'EOF', $modname, $version || ''); # #EOF # } # } # # # footer # $ppd .= <<'EOF'; # # #EOF # # my $ppd_file = "$dist{name}.ppd"; # my $fh = IO::File->new(">$ppd_file") or die "Cannot write to $ppd_file: $!"; # print $fh $ppd; # close $fh; # # $self->delete_filetree($bundle_dir); # mkdir($bundle_dir) or die "Cannot create '$bundle_dir': $!"; # $self->make_tarball($bundle_dir); # $self->delete_filetree($bundle_dir); # $self->add_to_cleanup($bundle_file); # #$self->add_to_manifest_skip($bundle_file); # # return $ppd_file; #} # we make all archive formats we want, not just .tar.gz # we also auto-run manifest action, since we always want to re-create # MANIFEST and MANIFEST.SKIP just-in-time sub ACTION_dist { my ($self) = @_; $self->depends_on('manifest'); $self->depends_on('distdir'); my $dist_dir = $self->dist_dir; $self->make_zip($dist_dir); $self->make_tarball($dist_dir); $self->delete_filetree($dist_dir); } # define custom clean/realclean actions to rearrange config file cleanup sub ACTION_clean { my ($self) = @_; $self->log_info("Cleaning up build files\n"); foreach my $item (map glob($_), $self->cleanup) { $self->delete_filetree($item); } $self->log_info("Cleaning up configuration files\n"); $self->delete_filetree($self->config_dir); } sub ACTION_realclean { my ($self) = @_; $self->depends_on('clean'); for my $method (qw(mymetafile mymetafile2 build_script)) { if ($self->can($method)) { $self->delete_filetree($self->$method); $self->log_info("Cleaning up $method data\n"); } } } # makes zip file for windows users and bzip2 files as well sub make_zip { my ($self, $dir, $file) = @_; $file ||= $dir; $self->log_info("Creating $file.zip\n"); my $zip_flags = $self->verbose ? '-r' : '-rq'; $self->do_system($self->split_like_shell("zip"), $zip_flags, "$file.zip", $dir); $self->log_info("Creating $file.bz2\n"); require Archive::Tar; # Archive::Tar versions >= 1.09 use the following to enable a compatibility # hack so that the resulting archive is compatible with older clients. $Archive::Tar::DO_NOT_USE_PREFIX = 0; my $files = $self->rscan_dir($dir); Archive::Tar->create_archive("$file.tar", 0, @$files); $self->do_system($self->split_like_shell("bzip2"), "-k", "$file.tar"); } # a method that can be called in a Build.PL script to ask the user if they want # internet tests. # Should only be called if you have tested for yourself that # $build->feature('Network Tests') is true sub prompt_for_network { my ($self, $accept) = @_; my $proceed = $accept ? 0 : $self->y_n("Do you want to run tests that require connection to servers across the internet\n(likely to cause some failures)? y/n", 'n'); if ($proceed) { $self->notes('network' => 1); $self->log_info(" - will run internet-requiring tests\n"); my $use_email = $self->y_n("Do you want to run tests requiring a valid email address? y/n",'n'); if ($use_email) { my $address = $self->prompt("Enter email address:"); $self->notes(email => $address); } } else { $self->notes(network => 0); $self->log_info(" - will not run internet-requiring tests\n"); } } # override the build script warnings flag sub print_build_script { my ($self, $fh) = @_; my $build_package = $self->build_class; my $closedata=""; my $config_requires; if ( -f $self->metafile ) { my $meta = eval { $self->read_metafile( $self->metafile ) }; $config_requires = $meta && $meta->{configure_requires}{'Module::Build'}; } $config_requires ||= 0; my %q = map {$_, $self->$_()} qw(config_dir base_dir); $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish; $q{magic_numfile} = $self->config_file('magicnum'); my @myINC = $self->_added_to_INC; for (@myINC, values %q) { $_ = File::Spec->canonpath( $_ ); s/([\\\'])/\\$1/g; } my $quoted_INC = join ",\n", map " '$_'", @myINC; my $shebang = $self->_startperl; my $magic_number = $self->magic_number; # unique to bioperl, shut off overly verbose warnings on windows, bug 3215 my $w = $^O =~ /win/i ? '# no warnings (win)' : '$^W = 1; # Use warnings'; print $fh <; close FH; return \$filenum == $magic_number; } my \$progname; my \$orig_dir; BEGIN { $w \$progname = basename(\$0); \$orig_dir = Cwd::cwd(); my \$base_dir = '$q{base_dir}'; if (!magic_number_matches()) { unless (chdir(\$base_dir)) { die ("Couldn't chdir(\$base_dir), aborting\\n"); } unless (magic_number_matches()) { die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n"); } } unshift \@INC, ( $quoted_INC ); } close(*DATA) unless eof(*DATA); # ensure no open handles to this script use $build_package; Module::Build->VERSION(q{$config_requires}); # Some platforms have problems setting \$^X in shebang contexts, fix it up here \$^X = Module::Build->find_perl_interpreter; if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) { warn "Warning: Build.PL has been altered. You may need to run 'perl Build.PL' again.\\n"; } # This should have just enough arguments to be able to bootstrap the rest. my \$build = $build_package->resume ( properties => { config_dir => '$q{config_dir}', orig_dir => \$orig_dir, }, ); \$build->dispatch; EOF } 1; BioPerl-1.6.923/Bio/Root/Exception.pm000444000765000024 3330712254227322 17413 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Root::Exception # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- =head1 NAME Bio::Root::Exception - Generic exception objects for Bioperl =head1 SYNOPSIS =head2 Throwing exceptions using L: use Bio::Root::Exception; use Error; # Set Error::Debug to include stack trace data in the error messages $Error::Debug = 1; $file = shift; open (IN, $file) || throw Bio::Root::FileOpenException ( "Can't open file $file for reading", $!); =head2 Throwing exceptions using L: # Here we have an object that ISA Bio::Root::Root, so it inherits throw(). open (IN, $file) || $object->throw(-class => 'Bio::Root::FileOpenException', -text => "Can't open file $file for reading", -value => $!); =head2 Catching and handling exceptions using L: use Bio::Root::Exception; use Error qw(:try); # Note that we need to import the 'try' tag from Error.pm # Set Error::Debug to include stack trace data in the error messages $Error::Debug = 1; $file = shift; try { open (IN, $file) || throw Bio::Root::FileOpenException ( "Can't open file $file for reading", $!); } catch Bio::Root::FileOpenException with { my $err = shift; print STDERR "Using default input file: $default_file\n"; open (IN, $default_file) || die "Can't open $default_file"; } otherwise { my $err = shift; print STDERR "An unexpected exception occurred: \n$err"; # By placing an the error object reference within double quotes, # you're invoking its stringify() method. } finally { # Any code that you want to execute regardless of whether or not # an exception occurred. }; # the ending semicolon is essential! =head2 Defining a new Exception type as a subclass of Bio::Root::Exception: @Bio::TestException::ISA = qw( Bio::Root::Exception ); =head1 DESCRIPTION =head2 Exceptions defined in L These are generic exceptions for typical problem situations that could arise in any module or script. =over 8 =item Bio::Root::Exception() =item Bio::Root::NotImplemented() =item Bio::Root::IOException() =item Bio::Root::FileOpenException() =item Bio::Root::SystemException() =item Bio::Root::BadParameter() =item Bio::Root::OutOfRange() =item Bio::Root::NoSuchThing() =back Using defined exception classes like these is a good idea because it indicates the basic nature of what went wrong in a convenient, computable way. If there is a type of exception that you want to throw that is not covered by the classes listed above, it is easy to define a new one that fits your needs. Just write a line like the following in your module or script where you want to use it (or put it somewhere that is accessible to your code): @NoCanDoException::ISA = qw( Bio::Root::Exception ); All of the exceptions defined in this module inherit from a common base class exception, Bio::Root::Exception. This allows a user to write a handler for all Bioperl-derived exceptions as follows: use Bio::Whatever; use Error qw(:try); try { # some code that depends on Bioperl } catch Bio::Root::Exception with { my $err = shift; print "A Bioperl exception occurred:\n$err\n"; }; So if you do create your own exceptions, just be sure they inherit from Bio::Root::Exception directly, or indirectly by inheriting from a Bio::Root::Exception subclass. The exceptions in Bio::Root::Exception are extensions of Graham Barr's L module available from CPAN. Despite this dependency, the L module does not explicitly C. This permits Bio::Root::Exception to be loaded even when Error.pm is not available. =head2 Throwing exceptions within Bioperl modules Error.pm is not part of the Bioperl distibution, and may not be present within any given perl installation. So, when you want to throw an exception in a Bioperl module, the safe way to throw it is to use L which can use Error.pm when it's available. See documentation in Bio::Root::Root for details. =head1 SEE ALSO See the C directory of the Bioperl distribution for working demo code. L for information about throwing L-based exceptions. L (available from CPAN, author: GBARR) Error.pm is helping to guide the design of exception handling in Perl 6. See these RFC's: http://dev.perl.org/rfc/63.pod http://dev.perl.org/rfc/88.pod =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 EXCEPTIONS =cut # Define some generic exceptions.' package Bio::Root::Exception; use Bio::Root::Version; use strict; my $debug = $Error::Debug; # Prevents the "used only once" warning. my $DEFAULT_VALUE = "__DUMMY__"; # Permits eval{} based handlers to work =head2 L Purpose : A generic base class for all BioPerl exceptions. By including a "catch Bio::Root::Exception" block, you should be able to trap all BioPerl exceptions. Example : throw Bio::Root::Exception("A generic exception", $!); =cut #--------------------------------------------------------- @Bio::Root::Exception::ISA = qw( Error ); #--------------------------------------------------------- =head1 Methods defined by Bio::Root::Exception =head2 new Purpose : Guarantees that -value is set properly before calling Error::new(). Arguments: key-value style arguments same as for Error::new() You can also specify plain arguments as ($message, $value) where $value is optional. -value, if defined, must be non-zero and not an empty string in order for eval{}-based exception handlers to work. These require that if($@) evaluates to true, which will not be the case if the Error has no value (Error overloads numeric operations to the Error::value() method). It is OK to create Bio::Root::Exception objects without specifying -value. In this case, an invisible dummy value is used. If you happen to specify a -value of zero (0), it will be replaced by the string "The number zero (0)". If you happen to specify a -value of empty string (""), it will be replaced by the string "An empty string ("")". =cut sub new { my ($class, @args) = @_; my ($value, %params); if( @args % 2 == 0 && $args[0] =~ /^-/) { %params = @args; $value = $params{'-value'}; } else { $params{-text} = $args[0]; $value = $args[1]; } if( defined $value ) { $value = "The number zero (0)" if $value =~ /^\d+$/ && $value == 0; $value = "An empty string (\"\")" if $value eq ""; } else { $value ||= $DEFAULT_VALUE; } $params{-value} = $value; my $self = $class->SUPER::new( %params ); return $self; } =head2 pretty_format() Purpose : Get a nicely formatted string containing information about the exception. Format is similar to that produced by Bio::Root::Root::throw(), with the addition of the name of the exception class in the EXCEPTION line and some other data available via the Error object. Example : print $error->pretty_format; =cut sub pretty_format { my $self = shift; my $msg = $self->text; my $stack = ''; if( $Error::Debug ) { $stack = $self->_reformat_stacktrace(); } my $value_string = $self->value ne $DEFAULT_VALUE ? "VALUE: ".$self->value."\n" : ""; my $class = ref($self); my $title = "------------- EXCEPTION: $class -------------"; my $footer = "\n" . '-' x CORE::length($title); my $out = "\n$title\n" . "MSG: $msg\n". $value_string. $stack. $footer . "\n"; return $out; } # Reformatting of the stack performed by _reformat_stacktrace: # 1. Shift the file:line data in line i to line i+1. # 2. change xxx::__ANON__() to "try{} block" # 3. skip the "require" and "Error::subs::try" stack entries (boring) # This means that the first line in the stack won't have any file:line data # But this isn't a big issue since it's for a Bio::Root::-based method # that doesn't vary from exception to exception. sub _reformat_stacktrace { my $self = shift; my $msg = $self->text; my $stack = $self->stacktrace(); $stack =~ s/\Q$msg//; my @stack = split( /\n/, $stack); my @new_stack = (); my ($method, $file, $linenum, $prev_file, $prev_linenum); my $stack_count = 0; foreach my $i( 0..$#stack ) { # print "STACK-ORIG: $stack[$i]\n"; if( ($stack[$i] =~ /^\s*([^(]+)\s*\(.*\) called at (\S+) line (\d+)/) || ($stack[$i] =~ /^\s*(require 0) called at (\S+) line (\d+)/)) { ($method, $file, $linenum) = ($1, $2, $3); $stack_count++; } else{ next; } if( $stack_count == 1 ) { push @new_stack, "STACK: $method"; ($prev_file, $prev_linenum) = ($file, $linenum); next; } if( $method =~ /__ANON__/ ) { $method = "try{} block"; } if( ($method =~ /^require/ and $file =~ /Error\.pm/ ) || ($method =~ /^Error::subs::try/ ) ) { last; } push @new_stack, "STACK: $method $prev_file:$prev_linenum"; ($prev_file, $prev_linenum) = ($file, $linenum); } push @new_stack, "STACK: $prev_file:$prev_linenum"; return join "\n", @new_stack; } =head2 stringify() Purpose : Overrides Error::stringify() to call pretty_format(). This is called automatically when an exception object is placed between double quotes. Example : catch Bio::Root::Exception with { my $error = shift; print "$error"; } See Also: L =cut sub stringify { my ($self, @args) = @_; return $self->pretty_format( @args ); } =head1 Subclasses of Bio::Root::Exception =head2 L Purpose : Indicates that a method has not been implemented. Example : throw Bio::Root::NotImplemented( -text => "Method \"foo\" not implemented in module FooBar.", -value => "foo" ); =cut #--------------------------------------------------------- @Bio::Root::NotImplemented::ISA = qw( Bio::Root::Exception ); #--------------------------------------------------------- =head2 L Purpose : Indicates that some input/output-related trouble has occurred. Example : throw Bio::Root::IOException( -text => "Can't save data to file $file.", -value => $! ); =cut #--------------------------------------------------------- @Bio::Root::IOException::ISA = qw( Bio::Root::Exception ); #--------------------------------------------------------- =head2 L Purpose : Indicates that a file could not be opened. Example : throw Bio::Root::FileOpenException( -text => "Can't open file $file for reading.", -value => $! ); =cut #--------------------------------------------------------- @Bio::Root::FileOpenException::ISA = qw( Bio::Root::IOException ); #--------------------------------------------------------- =head2 L Purpose : Indicates that a system call failed. Example : unlink($file) or throw Bio::Root::SystemException( -text => "Can't unlink file $file.", -value => $! ); =cut #--------------------------------------------------------- @Bio::Root::SystemException::ISA = qw( Bio::Root::Exception ); #--------------------------------------------------------- =head2 L Purpose : Indicates that one or more parameters supplied to a method are invalid, unspecified, or conflicting. Example : throw Bio::Root::BadParameter( -text => "Required parameter \"-foo\" was not specified", -value => "-foo" ); =cut #--------------------------------------------------------- @Bio::Root::BadParameter::ISA = qw( Bio::Root::Exception ); #--------------------------------------------------------- =head2 L Purpose : Indicates that a specified (start,end) range or an index to an array is outside the permitted range. Example : throw Bio::Root::OutOfRange( -text => "Start coordinate ($start) cannot be less than zero.", -value => $start ); =cut #--------------------------------------------------------- @Bio::Root::OutOfRange::ISA = qw( Bio::Root::Exception ); #--------------------------------------------------------- =head2 L Purpose : Indicates that a requested thing cannot be located and therefore could possibly be bogus. Example : throw Bio::Root::NoSuchThing( -text => "Accession M000001 could not be found.", -value => "M000001" ); =cut #--------------------------------------------------------- @Bio::Root::NoSuchThing::ISA = qw( Bio::Root::Exception ); #--------------------------------------------------------- 1; BioPerl-1.6.923/Bio/Root/HTTPget.pm000444000765000024 2722312254227313 16734 0ustar00cjfieldsstaff000000000000# # BioPerl module for fallback HTTP get operations. # # Module is proxy-aware # # Please direct questions and support issues to # # Cared for by Chris Dagdigian # but all of the good stuff was written by # Lincoln Stein. # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Root::HTTPget - module for fallback HTTP get operations when LWP:: is unavailable =head1 SYNOPSIS use Bio::Root::HTTPget; my $web = Bio::Root::HTTPget->new(); my $response = $web->get('http://localhost'); $response = $web->get('http://localhost/images'); $response = eval { $web->get('http://fred:secret@localhost/ladies_only/') } or warn $@; $response = eval { $web->get('http://jeff:secret@localhost/ladies_only/') } or warn $@; $response = $web->get('http://localhost/images/navauthors.gif'); $response = $web->get(-url=>'http://www.google.com', -proxy=>'http://www.modperl.com'); =head1 DESCRIPTION This is basically an last-chance module for doing network HTTP get requests in situations where more advanced external CPAN modules such as LWP:: are not installed. The particular reason this module was developed was so that the Open Bio Database Access code can fallback to fetching the default registry files from http://open-bio.org/registry/ without having to depend on external dependencies like Bundle::LWP for network HTTP access. The core of this module was written by Lincoln Stein. It can handle proxies and HTTP-based proxy authentication. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Lincoln Stein # Please direct questions and support issues to I Cared for by Chris Dagdigian =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Root::HTTPget; use strict; use warnings; use IO::Socket qw(:DEFAULT :crlf); use base qw(Bio::Root::Root); { # default attributes, in case used as a class/sub call my %attributes; =head2 get Title : get Usage : my $resp = get(-url => $url); Function: Returns : string Args : -url => URL to HTTPGet -proxy => proxy to use -user => username for proxy or authentication -pass => password for proxy or authentication -timeout => timeout =cut sub get { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my ($url,$proxy,$timeout,$auth_user,$auth_pass) = __PACKAGE__->_rearrange([qw(URL PROXY TIMEOUT USER PASS)],@_); my $dest = $proxy || $url; my ($host,$port,$path,$user,$pass) = _http_parse_url($dest) or __PACKAGE__->throw("invalid URL $url"); $auth_user ||= $user; $auth_pass ||= $pass; if ($self) { unless ($proxy) { $proxy = $self->proxy; } unless ($auth_user) { ($auth_user, $auth_pass) = $self->authentication; } } $path = $url if $proxy; # set up the connection my $socket = _http_connect($host,$port) or __PACKAGE__->throw("can't connect: $@"); # the request print $socket "GET $path HTTP/1.0$CRLF"; print $socket "User-Agent: Bioperl fallback fetcher/1.0$CRLF"; # Support virtual hosts print $socket "HOST: $host$CRLF"; if ($auth_user && $auth_pass) { # authentication information my $token = _encode_base64("$auth_user:$auth_pass"); print $socket "Authorization: Basic $token$CRLF"; } print $socket "$CRLF"; # read the response my $response; { local $/ = "$CRLF$CRLF"; $response = <$socket>; } my ($status_line,@other_lines) = split $CRLF,$response; my ($stat_code,$stat_msg) = $status_line =~ m!^HTTP/1\.[01] (\d+) (.+)! or __PACKAGE__->throw("invalid response from web server: got $response"); my %headers = map {/^(\S+): (.+)/} @other_lines; if ($stat_code == 302 || $stat_code == 301) { # redirect my $location = $headers{Location} or __PACKAGE__->throw("invalid redirect: no Location header"); return get(-url => $location, -proxy => $proxy, -timeout => $timeout, -user => $auth_user, -pass => $auth_pass); # recursive call } elsif ($stat_code == 401) { # auth required my $auth_required = $headers{'WWW-Authenticate'}; $auth_required =~ /^Basic realm="([^\"]+)"/ or __PACKAGE__->throw("server requires unknown type of". " authentication: $auth_required"); __PACKAGE__->throw("request failed: $status_line, realm = $1"); } elsif ($stat_code != 200) { __PACKAGE__->throw("request failed: $status_line"); } $response = ''; while (1) { my $bytes = read($socket,$response,2048,length $response); last unless $bytes > 0; } $response; } =head2 getFH Title : getFH Usage : Function: Example : Returns : string Args : =cut sub getFH { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my ($url,$proxy,$timeout,$auth_user,$auth_pass) = __PACKAGE__->_rearrange([qw(URL PROXY TIMEOUT USER PASS)],@_); my $dest = $proxy || $url; my ($host,$port,$path,$user,$pass) = _http_parse_url($dest) or __PACKAGE__->throw("invalid URL $url"); $auth_user ||= $user; $auth_pass ||= $pass; $path = $url if $proxy; # set up the connection my $socket = _http_connect($host,$port) or __PACKAGE__->throw("can't connect: $@"); # the request print $socket "GET $path HTTP/1.0$CRLF"; print $socket "User-Agent: Bioperl fallback fetcher/1.0$CRLF"; # Support virtual hosts print $socket "HOST: $host$CRLF"; if ($auth_user && $auth_pass) { # authentication information my $token = _encode_base64("$auth_user:$auth_pass"); print $socket "Authorization: Basic $token$CRLF"; } print $socket "$CRLF"; # read the response my $response; { local $/ = "$CRLF$CRLF"; $response = <$socket>; } my ($status_line,@other_lines) = split $CRLF,$response; my ($stat_code,$stat_msg) = $status_line =~ m!^HTTP/1\.[01] (\d+) (.+)! or __PACKAGE__->throw("invalid response from web server: got $response"); my %headers = map {/^(\S+): (.+)/} @other_lines; if ($stat_code == 302 || $stat_code == 301) { # redirect my $location = $headers{Location} or __PACKAGE__->throw("invalid redirect: no Location header"); return getFH(-url => $location, -proxy => $proxy, -timeout => $timeout, -user => $auth_user, -pass => $auth_pass); # recursive call } elsif ($stat_code == 401) { # auth required my $auth_required = $headers{'WWW-Authenticate'}; $auth_required =~ /^Basic realm="([^\"]+)"/ or __PACKAGE__->throw("server requires unknown type of ". "authentication: $auth_required"); __PACKAGE__->throw("request failed: $status_line, realm = $1"); } elsif ($stat_code != 200) { __PACKAGE__->throw("request failed: $status_line"); } # Now that we are reasonably sure the socket and request # are OK we pass the socket back as a filehandle so it can # be processed by the caller... $socket; } =head2 _http_parse_url Title : Usage : Function: Example : Returns : Args : =cut sub _http_parse_url { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my $url = shift; my ($user,$pass,$hostent,$path) = $url =~ m!^http://(?:([^:]+):([^:]+)@)?([^/]+)(/?[^\#]*)! or return; $path ||= '/'; my ($host,$port) = split(':',$hostent); return ($host,$port||80,$path,$user,$pass); } =head2 _http_connect Title : Usage : Function: Example : Returns : Args : =cut sub _http_connect { my ($host,$port,$timeout) = @_; my $sock = IO::Socket::INET->new(Proto => 'tcp', Type => SOCK_STREAM, PeerHost => $host, PeerPort => $port, Timeout => $timeout, ); $sock; } =head2 _encode_base64 Title : Usage : Function: Example : Returns : Args : =cut sub _encode_base64 { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my $res = ""; my $eol = $_[1]; $eol = "\n" unless defined $eol; pos($_[0]) = 0; # ensure start at the beginning $res = join '', map( pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs)); $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs # fix padding at the end my $padding = (3 - length($_[0]) % 3) % 3; $res =~ s/.{$padding}$/'=' x $padding/e if $padding; # break encoded string into lines of no more than 76 characters each if (length $eol) { $res =~ s/(.{1,76})/$1$eol/g; } return $res; } =head2 proxy Title : proxy Usage : $httpproxy = $db->proxy('http') or $db->proxy(['http','ftp'], 'http://myproxy' ) Function: Get/Set a proxy for use of proxy. Defaults to environment variable http_proxy if present. Returns : a string indicating the proxy Args : $protocol : string for the protocol to set/get $proxyurl : url of the proxy to use for the specified protocol $username : username (if proxy requires authentication) $password : password (if proxy requires authentication) =cut sub proxy { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my ($protocol,$proxy,$username,$password) = @_; my $atts = ref($self) ? $self : \%attributes; $protocol ||= 'http'; if (!$proxy) { if (defined $ENV{http_proxy}) { $proxy = $ENV{http_proxy}; if ($proxy =~ /\@/) { ($username, $password, $proxy) = $proxy =~ m{http://(\S+):(\S+)\@(\S+)}; $proxy = 'http://'.$proxy; } } } if (defined $proxy) { # default to class method call __PACKAGE__->authentication($username, $password) if ($username && $password); $atts->{'_proxy'}->{$protocol} = $proxy; } return $atts->{'_proxy'}->{$protocol}; } =head2 clear_proxy Title : clear_proxy Usage : my $old_prozy = $db->clear_proxy('http') Function: Unsets (clears) the proxy for the protocol indicated Returns : a string indicating the old proxy value Args : $protocol : string for the protocol to clear =cut sub clear_proxy { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my ($protocol) = @_; my $atts = ref($self) ? $self : \%attributes; $protocol ||= 'http'; delete $atts->{'_proxy'}->{$protocol}; } =head2 authentication Title : authentication Usage : $db->authentication($user,$pass) Function: Get/Set authentication credentials Returns : Array of user/pass Args : Array or user/pass =cut sub authentication { my $self; if($_[0] && (ref($_[0]) or $_[0] =~ /^Bio::/)) { $self = shift; } my $atts = ref($self) ? $self : \%attributes; if (@_) { my ($u,$p) = @_; my $atts = ref($self) ? $self : \%attributes; $atts->{'_authentication'} = [ $u,$p]; } return @{$atts->{'_authentication'} || []}; } } 1; BioPerl-1.6.923/Bio/Root/IO.pm000444000765000024 10335112254227332 16002 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Root::IO # # Please direct questions and support issues to # # Cared for by Hilmar Lapp # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Root::IO - module providing several methods often needed when dealing with file IO =head1 SYNOPSIS # utilize stream I/O in your module $self->{'io'} = Bio::Root::IO->new(-file => "myfile"); $self->{'io'}->_print("some stuff"); $line = $self->{'io'}->_readline(); $self->{'io'}->_pushback($line); $self->{'io'}->close(); # obtain platform-compatible filenames $path = Bio::Root::IO->catfile($dir, $subdir, $filename); # obtain a temporary file (created in $TEMPDIR) ($handle) = $io->tempfile(); =head1 DESCRIPTION This module provides methods that will usually be needed for any sort of file- or stream-related input/output, e.g., keeping track of a file handle, transient printing and reading from the file handle, a close method, automatically closing the handle on garbage collection, etc. To use this for your own code you will either want to inherit from this module, or instantiate an object for every file or stream you are dealing with. In the first case this module will most likely not be the first class off which your class inherits; therefore you need to call _initialize_io() with the named parameters in order to set file handle, open file, etc automatically. Most methods start with an underscore, indicating they are private. In OO speak, they are not private but protected, that is, use them in your module code, but a client code of your module will usually not want to call them (except those not starting with an underscore). In addition this module contains a couple of convenience methods for cross-platform safe tempfile creation and similar tasks. There are some CPAN modules related that may not be available on all platforms. At present, File::Spec and File::Temp are attempted. This module defines $PATHSEP, $TEMPDIR, and $ROOTDIR, which will always be set, and $OPENFLAGS, which will be set if either of File::Spec or File::Temp fails. The -noclose boolean (accessed via the noclose method) prevents a filehandle from being closed when the IO object is cleaned up. This is special behavior when a object like a parser might share a filehandle with an object like an indexer where it is not proper to close the filehandle as it will continue to be reused until the end of the stream is reached. In general you won't want to play with this flag. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 CONTRIBUTORS Mark A. Jensen ( maj -at- fortinbras -dot- us ) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Root::IO; our ($FILESPECLOADED, $FILETEMPLOADED, $FILEPATHLOADED, $TEMPDIR, $PATHSEP, $ROOTDIR, $OPENFLAGS, $VERBOSE, $ONMAC, $HAS_LWP, $HAS_EOL); use strict; use Symbol; use POSIX qw(dup); use IO::Handle; use Bio::Root::HTTPget; use base qw(Bio::Root::Root); my $TEMPCOUNTER; my $HAS_WIN32 = 0; BEGIN { $TEMPCOUNTER = 0; $FILESPECLOADED = 0; $FILETEMPLOADED = 0; $FILEPATHLOADED = 0; $VERBOSE = 0; # try to load those modules that may cause trouble on some systems eval { require File::Path; $FILEPATHLOADED = 1; }; if( $@ ) { print STDERR "Cannot load File::Path: $@" if( $VERBOSE > 0 ); # do nothing } eval { require LWP::UserAgent; }; if( $@ ) { print STDERR "Cannot load LWP::UserAgent: $@" if( $VERBOSE > 0 ); $HAS_LWP = 0; } else { $HAS_LWP = 1; } # If on Win32, attempt to find Win32 package if($^O =~ /mswin/i) { eval { require Win32; $HAS_WIN32 = 1; }; } # Try to provide a path separator. Why doesn't File::Spec export this, # or did I miss it? if($^O =~ /mswin/i) { $PATHSEP = "\\"; } elsif($^O =~ /macos/i) { $PATHSEP = ":"; } else { # unix $PATHSEP = "/"; } eval { require File::Spec; $FILESPECLOADED = 1; $TEMPDIR = File::Spec->tmpdir(); $ROOTDIR = File::Spec->rootdir(); require File::Temp; # tempfile creation $FILETEMPLOADED = 1; }; if( $@ ) { if(! defined($TEMPDIR)) { # File::Spec failed # determine tempdir if (defined $ENV{'TEMPDIR'} && -d $ENV{'TEMPDIR'} ) { $TEMPDIR = $ENV{'TEMPDIR'}; } elsif( defined $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'} ) { $TEMPDIR = $ENV{'TMPDIR'}; } if($^O =~ /mswin/i) { $TEMPDIR = 'C:\TEMP' unless $TEMPDIR; $ROOTDIR = 'C:'; } elsif($^O =~ /macos/i) { $TEMPDIR = "" unless $TEMPDIR; # what is a reasonable default on Macs? $ROOTDIR = ""; # what is reasonable?? } else { # unix $TEMPDIR = "/tmp" unless $TEMPDIR; $ROOTDIR = "/"; } if (!( -d $TEMPDIR && -w $TEMPDIR )) { $TEMPDIR = '.'; # last resort } } # File::Temp failed (alone, or File::Spec already failed) # # determine open flags for tempfile creation -- we'll have to do this # ourselves use Fcntl; use Symbol; $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/){ my ($bit, $func) = (0, "Fcntl::O_" . $oflag); no strict 'refs'; $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 }; } } $ONMAC = "\015" eq "\n"; } =head2 new Title : new Usage : Function: Overridden here to automatically call _initialize_io(). Example : Returns : new instance of this class Args : named parameters =cut sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 _initialize_io Title : initialize_io Usage : $self->_initialize_io(@params); Function: Initializes filehandle and other properties from the parameters. Currently recognizes the following named parameters: -file name of file to open -string a string that is to be converted to a filehandle -url name of URL to open -input name of file, or GLOB, or IO::Handle object -fh file handle (mutually exclusive with -file) -flush boolean flag to autoflush after each write -noclose boolean flag, when set to true will not close a filehandle (must explicitly call close($io->_fh) -retries number of times to try a web fetch before failure -ua_parms hashref of key => value parameters to pass to LWP::UserAgent->new() (only meaningful with -url is set) A useful value might be, for example, { timeout => 60 } (ua default is 180 sec) Returns : TRUE Args : named parameters =cut sub _initialize_io { my($self, @args) = @_; $self->_register_for_cleanup(\&_io_cleanup); my ($input, $noclose, $file, $fh, $string, $flush, $url, $retries, $ua_parms) = $self->_rearrange([qw(INPUT NOCLOSE FILE FH STRING FLUSH URL RETRIES UA_PARMS)], @args); if($url){ $retries ||= 5; if($HAS_LWP) { #use LWP::UserAgent require LWP::UserAgent; my $ua = LWP::UserAgent->new(%$ua_parms); my $http_result; my($handle,$tempfile) = $self->tempfile(); CORE::close($handle); for(my $try = 1 ; $try <= $retries ; $try++){ $http_result = $ua->get($url, ':content_file' => $tempfile); $self->warn("[$try/$retries] tried to fetch $url, but server ". "threw ". $http_result->code . ". retrying...") if !$http_result->is_success; last if $http_result->is_success; } $self->throw("failed to fetch $url, server threw ". $http_result->code) if !$http_result->is_success; $input = $tempfile; $file = $tempfile; } else { #use Bio::Root::HTTPget #$self->warn("no lwp"); $fh = Bio::Root::HTTPget::getFH($url); } } delete $self->{'_readbuffer'}; delete $self->{'_filehandle'}; $self->noclose( $noclose) if defined $noclose; # determine whether the input is a file(name) or a stream if($input) { if(ref(\$input) eq "SCALAR") { # we assume that a scalar is a filename if($file && ($file ne $input)) { $self->throw("input file given twice: $file and $input disagree"); } $file = $input; } elsif(ref($input) && ((ref($input) eq "GLOB") || $input->isa('IO::Handle'))) { # input is a stream $fh = $input; } else { # let's be strict for now $self->throw("unable to determine type of input $input: ". "not string and not GLOB"); } } if(defined($file) && defined($fh)) { $self->throw("Providing both a file and a filehandle for reading - ". "only one please!"); } if ($string) { if(defined($file) || defined($fh)) { $self->throw("File or filehandle provided with -string,". " please unset if you are using -string as a file"); } open($fh, "<", \$string) } if(defined($file) && ($file ne '')) { $fh = Symbol::gensym(); open ($fh,$file) || $self->throw("Could not open $file: $!"); $self->file($file); } if (defined $fh) { # check filehandle to ensure it's one of: # a GLOB reference, as in: open(my $fh, "myfile"); # an IO::Handle or IO::String object # the UNIVERSAL::can added to fix Bug2863 unless ( ( ref $fh && ( ref $fh eq 'GLOB' ) ) || ( ref $fh && ( UNIVERSAL::can( $fh, 'can' ) && ( $fh->isa('IO::Handle') || $fh->isa('IO::String') ) ) ) ) { $self->throw("file handle $fh doesn't appear to be a handle"); } } if ($HAS_EOL) { binmode $fh, ':raw:eol(LF-Native)'; } $self->_fh($fh) if $fh; # if not provided, defaults to STDIN and STDOUT $self->_flush_on_write(defined $flush ? $flush : 1); return 1; } =head2 _fh Title : _fh Usage : $obj->_fh($newval) Function: Get/set the file handle for the stream encapsulated. Example : Returns : value of _filehandle Args : newvalue (optional) =cut sub _fh { my ($obj, $value) = @_; if ( defined $value) { $obj->{'_filehandle'} = $value; } return $obj->{'_filehandle'}; } =head2 mode Title : mode Usage : $obj->mode() Function: Example : Returns : mode of filehandle: 'r' for readable 'w' for writable '?' if mode could not be determined Args : -force (optional), see notes. Notes : once mode() has been called, the filehandle's mode is cached for further calls to mode(). to override this behavior so that mode() re-checks the filehandle's mode, call with arg -force =cut sub mode { my ($obj, @arg) = @_; my %param = @arg; return $obj->{'_mode'} if defined $obj->{'_mode'} and !$param{-force}; # Previous system of: # my $iotest = new IO::Handle; # $iotest->fdopen( dup(fileno($fh)) , 'r' ); # if ($iotest->error == 0) { ... } # didn't actually seem to work under any platform, since there would no # no error if the filehandle had been opened writable only. Couldn't be # hacked around when dealing with unseekable (piped) filehandles. # # Just try and do a simple readline, turning io warnings off, instead: my $fh = $obj->_fh || return '?'; no warnings "io"; # we expect a warning if this is writable only my $line = <$fh>; if (defined $line) { $obj->_pushback($line); $obj->{'_mode'} = 'r'; } else { $obj->{'_mode'} = 'w'; } return $obj->{'_mode'}; } =head2 file Title : file Usage : $obj->file($newval) Function: Get/set the filename, if one has been designated. Example : Returns : value of file Args : newvalue (optional) =cut sub file { my ($obj, $value) = @_; if ( defined $value) { $obj->{'_file'} = $value; } return $obj->{'_file'}; } =head2 format Title : format Usage : $self->format($newval) Function: Get the format of a Bio::Root::IO sequence file or filehandle. Every object inheriting Bio::Root::IO is guaranteed to have a format. Returns : format of the file or filehandle, e.g. fasta, fastq, genbank, embl. Args : none =cut sub format { my ($self) = @_; my $format = (split '::', ref($self))[-1]; return $format; } =head2 variant Title : format Usage : $self->format($newval) Function: Get the variant of a Bio::Root::IO sequence file or filehandle. The format variant depends on the specific format used. Note that not all formats have variants Returns : variant of the file or filehandle, e.g. sanger, solexa or illumina for the fastq format, or undef for formats that do not have variants. Args : none Note : The Bio::Root::IO-implementing modules that require access to variants need to define a global hash that has the allowed variants as its keys. =cut sub variant { my ($self, $variant) = @_; if (defined $variant) { $variant = lc $variant; my $var_name = '%'.ref($self).'::variant'; my %ok_variants = eval $var_name; # e.g. %Bio::Assembly::IO::ace::variant if (scalar keys %ok_variants == 0) { $self->throw('Cannot check for validity of variant because global '. "variant $var_name is not set or is empty\n"); } if (not exists $ok_variants{$variant}) { $self->throw($variant.' is not a valid variant of the '.$self->format. ' format'); } $self->{variant} = $variant; } return $self->{variant}; } =head2 _print Title : _print Usage : $obj->_print(@lines) Function: Example : Returns : 1 on success, undef on failure =cut sub _print { my $self = shift; my $fh = $self->_fh() || \*STDOUT; my $ret = print $fh @_; return $ret; } =head2 _insert Title : _insert Usage : $obj->_insert($string,1) Function: Insert some text in a file at the given line number (1-based). Returns : 1 on success Args : string to write in file line number to insert the string at =cut sub _insert { my ($self, $string, $line_num) = @_; # Line number check if ($line_num < 1) { $self->throw("Cannot insert text at line $line_num because the minimum". " line number possible is 1"); } # File check my $file = $self->file; if (not defined $file) { $self->throw('Cannot insert a line in a IO object initialized with ". "anything else than a file.'); } $file =~ s/^\+?[><]?//; # transform '+>output.ace' into 'output.ace' # Everything that needs to be written is written before we read it $self->flush; # Edit the file in place, line by line (no slurping) { local @ARGV = ($file); # input file #local $^I = '~'; # backup file extension, e.g. ~, .bak, .ori local $^I = ''; # no backup file while (<>) { if ($. == $line_num) { # right line for new data print $string.$_; } else { print; } } } # Line number check (again) if ( $. > 0 && $line_num > $. ) { $self->throw("Cannot insert text at line $line_num because there are ". "only $. lines in file $file"); } # Re-open the file in append mode to be ready to add text at the end of it # when the next _print() statement comes open my $new_fh, ">>$file" or $self->throw("Cannot append to file $file: $!"); $self->_fh($new_fh); # If file is empty and we're inserting at line 1, simply append text to file if ( $. == 0 && $line_num == 1 ) { $self->_print($string); } return 1; } =head2 _readline Title : _readline Usage : $obj->_readline(%args) Function: Reads a line of input. Note that this method implicitely uses the value of $/ that is in effect when called. Note also that the current implementation does not handle pushed back input correctly unless the pushed back input ends with the value of $/. Example : Args : Accepts a hash of arguments, currently only -raw is recognized passing (-raw => 1) prevents \r\n sequences from being changed to \n. The default value of -raw is undef, allowing \r\n to be converted to \n. Returns : =cut sub _readline { my $self = shift; my %param =@_; my $fh = $self->_fh or return; my $line; # if the buffer been filled by _pushback then return the buffer # contents, rather than read from the filehandle if( @{$self->{'_readbuffer'} || [] } ) { $line = shift @{$self->{'_readbuffer'}}; } else { $line = <$fh>; } #don't strip line endings if -raw is specified # $line =~ s/\r\n/\n/g if( (!$param{-raw}) && (defined $line) ); # Dave Howorth's fix if( !$HAS_EOL && !$param{-raw} && (defined $line) ) { $line =~ s/\015\012/\012/g; # Change all CR/LF pairs to LF $line =~ tr/\015/\n/ unless $ONMAC; # Change all single CRs to NEWLINE } return $line; } =head2 _pushback Title : _pushback Usage : $obj->_pushback($newvalue) Function: puts a line previously read with _readline back into a buffer. buffer can hold as many lines as system memory permits. Example : $obj->_pushback($newvalue) Returns : none Args : newvalue Note : This is only supported for pushing back data ending with the current, localized value of $/. Using this method to push modified data back onto the buffer stack is not supported; see bug 843. =cut # fix for bug 843, this reveals some unsupported behavior #sub _pushback { # my ($obj, $value) = @_; # if (index($value, $/) >= 0) { # push @{$obj->{'_readbuffer'}}, $value; # } else { # $obj->throw("Pushing modifed data back not supported: $value"); # } #} sub _pushback { my ($obj, $value) = @_; return unless $value; unshift @{$obj->{'_readbuffer'}}, $value; } =head2 close Title : close Usage : $io->close() Function: Closes the file handle associated with this IO instance. Will not close the FH if -noclose is specified Returns : none Args : none =cut sub close { my ($self) = @_; # don't close if we explicitly asked not to return if $self->noclose; if( defined( my $fh = $self->{'_filehandle'} )) { $self->flush; return if ref $fh eq 'GLOB' && ( \*STDOUT == $fh || \*STDERR == $fh || \*STDIN == $fh ); # don't close IO::Strings close $fh unless ref $fh && $fh->isa('IO::String'); } $self->{'_filehandle'} = undef; delete $self->{'_readbuffer'}; } =head2 flush Title : flush Usage : $io->flush() Function: Flushes the filehandle Returns : none Args : none =cut sub flush { my ($self) = shift; if( !defined $self->{'_filehandle'} ) { $self->throw("Attempting to call flush but no filehandle active"); } if( ref($self->{'_filehandle'}) =~ /GLOB/ ) { my $oldh = select($self->{'_filehandle'}); $| = 1; select($oldh); } else { $self->{'_filehandle'}->flush(); } } =head2 noclose Title : noclose Usage : $obj->noclose($newval) Function: Get/Set the NOCLOSE flag - setting this to true will prevent a filehandle from being closed when an object is cleaned up or explicitly closed This is a bit of hack Returns : value of noclose (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub noclose{ my $self = shift; return $self->{'_noclose'} = shift if @_; return $self->{'_noclose'}; } sub _io_cleanup { my ($self) = @_; $self->close(); my $v = $self->verbose; # we are planning to cleanup temp files no matter what if( exists($self->{'_rootio_tempfiles'}) && ref($self->{'_rootio_tempfiles'}) =~ /array/i && !$self->save_tempfiles) { if( $v > 0 ) { warn( "going to remove files ", join(",", @{$self->{'_rootio_tempfiles'}}), "\n"); } unlink (@{$self->{'_rootio_tempfiles'}} ); } # cleanup if we are not using File::Temp if( $self->{'_cleanuptempdir'} && exists($self->{'_rootio_tempdirs'}) && ref($self->{'_rootio_tempdirs'}) =~ /array/i && !$self->save_tempfiles) { if( $v > 0 ) { warn( "going to remove dirs ", join(",", @{$self->{'_rootio_tempdirs'}}), "\n"); } $self->rmtree( $self->{'_rootio_tempdirs'}); } } =head2 exists_exe Title : exists_exe Usage : $exists = $obj->exists_exe('clustalw'); $exists = Bio::Root::IO->exists_exe('clustalw') $exists = Bio::Root::IO::exists_exe('clustalw') Function: Determines whether the given executable exists either as file or within the path environment. The latter requires File::Spec to be installed. On Win32-based system, .exe is automatically appended to the program name unless the program name already ends in .exe. Example : Returns : 1 if the given program is callable as an executable, and 0 otherwise Args : the name of the executable =cut sub exists_exe { my ($self, $exe) = @_; $self->throw("Must pass a defined value to exists_exe") unless defined $exe; $exe = $self if (!(ref($self) || $exe)); $exe .= '.exe' if(($^O =~ /mswin/i) && ($exe !~ /\.(exe|com|bat|cmd)$/i)); return $exe if ( -f $exe && -x $exe ); # full path and exists # Ewan's comment. I don't think we need this. People should not be # asking for a program with a pathseparator starting it # $exe =~ s/^$PATHSEP//; # Not a full path, or does not exist. Let's see whether it's in the path. if($FILESPECLOADED) { foreach my $dir (File::Spec->path()) { my $f = Bio::Root::IO->catfile($dir, $exe); return $f if( -f $f && -x $f ); } } return 0; } =head2 tempfile Title : tempfile Usage : my ($handle,$tempfile) = $io->tempfile(); Function: Returns a temporary filename and a handle opened for writing and and reading. Caveats : If you do not have File::Temp on your system you should avoid specifying TEMPLATE and SUFFIX. (We don't want to recode everything, okay?) Returns : a 2-element array, consisting of temporary handle and temporary file name Args : named parameters compatible with File::Temp: DIR (defaults to $Bio::Root::IO::TEMPDIR), TEMPLATE, SUFFIX. =cut #' sub tempfile { my ($self, @args) = @_; my ($tfh, $file); my %params = @args; # map between naming with and without dash foreach my $key (keys(%params)) { if( $key =~ /^-/ ) { my $v = $params{$key}; delete $params{$key}; $params{uc(substr($key,1))} = $v; } else { # this is to upper case my $v = $params{$key}; delete $params{$key}; $params{uc($key)} = $v; } } $params{'DIR'} = $TEMPDIR if(! exists($params{'DIR'})); unless (exists $params{'UNLINK'} && defined $params{'UNLINK'} && ! $params{'UNLINK'} ) { $params{'UNLINK'} = 1; } else { $params{'UNLINK'} = 0 } if($FILETEMPLOADED) { if(exists($params{'TEMPLATE'})) { my $template = $params{'TEMPLATE'}; delete $params{'TEMPLATE'}; ($tfh, $file) = File::Temp::tempfile($template, %params); } else { ($tfh, $file) = File::Temp::tempfile(%params); } } else { my $dir = $params{'DIR'}; $file = $self->catfile($dir, (exists($params{'TEMPLATE'}) ? $params{'TEMPLATE'} : sprintf( "%s.%s.%s", $ENV{USER} || 'unknown', $$, $TEMPCOUNTER++))); # sneakiness for getting around long filenames on Win32? if( $HAS_WIN32 ) { $file = Win32::GetShortPathName($file); } # Try to make sure this will be marked close-on-exec # XXX: Win32 doesn't respect this, nor the proper fcntl, # but may have O_NOINHERIT. This may or may not be in Fcntl. local $^F = 2; # Store callers umask my $umask = umask(); # Set a known umaskr umask(066); # Attempt to open the file if ( sysopen($tfh, $file, $OPENFLAGS, 0600) ) { # Reset umask umask($umask); } else { $self->throw("Could not open tempfile $file: $!\n"); } } if( $params{'UNLINK'} ) { push @{$self->{'_rootio_tempfiles'}}, $file; } return wantarray ? ($tfh,$file) : $tfh; } =head2 tempdir Title : tempdir Usage : my ($tempdir) = $io->tempdir(CLEANUP=>1); Function: Creates and returns the name of a new temporary directory. Note that you should not use this function for obtaining "the" temp directory. Use $Bio::Root::IO::TEMPDIR for that. Calling this method will in fact create a new directory. Returns : The name of a new temporary directory. Args : args - ( key CLEANUP ) indicates whether or not to cleanup dir on object destruction, other keys as specified by File::Temp =cut sub tempdir { my ( $self, @args ) = @_; if($FILETEMPLOADED && File::Temp->can('tempdir') ) { return File::Temp::tempdir(@args); } # we have to do this ourselves, not good # # we are planning to cleanup temp files no matter what my %params = @args; $self->{'_cleanuptempdir'} = ( defined $params{CLEANUP} && $params{CLEANUP} == 1); my $tdir = $self->catfile($TEMPDIR, sprintf("dir_%s-%s-%s", $ENV{USER} || 'unknown', $$, $TEMPCOUNTER++)); mkdir($tdir, 0755); push @{$self->{'_rootio_tempdirs'}}, $tdir; return $tdir; } =head2 catfile Title : catfile Usage : $path = Bio::Root::IO->catfile(@dirs,$filename); Function: Constructs a full pathname in a cross-platform safe way. If File::Spec exists on your system, this routine will merely delegate to it. Otherwise it tries to make a good guess. You should use this method whenever you construct a path name from directory and filename. Otherwise you risk cross-platform compatibility of your code. You can call this method both as a class and an instance method. Returns : a string Args : components of the pathname (directories and filename, NOT an extension) =cut sub catfile { my ($self, @args) = @_; return File::Spec->catfile(@args) if($FILESPECLOADED); # this is clumsy and not very appealing, but how do we specify the # root directory? if($args[0] eq '/') { $args[0] = $ROOTDIR; } return join($PATHSEP, @args); } =head2 rmtree Title : rmtree Usage : Bio::Root::IO->rmtree($dirname ); Function: Remove a full directory tree If File::Path exists on your system, this routine will merely delegate to it. Otherwise it runs a local version of that code. You should use this method to remove directories which contain files. You can call this method both as a class and an instance method. Returns : number of files successfully deleted Args : roots - rootdir to delete or reference to list of dirs verbose - a boolean value, which if TRUE will cause C to print a message each time it examines a file, giving the name of the file, and indicating whether it's using C or C to remove it, or that it's skipping it. (defaults to FALSE) safe - a boolean value, which if TRUE will cause C to skip any files to which you do not have delete access (if running under VMS) or write access (if running under another OS). This will change in the future when a criterion for 'delete permission' under OSs other than VMS is settled. (defaults to FALSE) =cut # taken straight from File::Path VERSION = "1.0403" sub rmtree { my($self,$roots, $verbose, $safe) = @_; if( $FILEPATHLOADED ) { return File::Path::rmtree ($roots, $verbose, $safe); } my $force_writable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || $^O eq 'amigaos' || $^O eq 'cygwin'); my $Is_VMS = $^O eq 'VMS'; my(@files); my($count) = 0; $verbose ||= 0; $safe ||= 0; if ( defined($roots) && length($roots) ) { $roots = [$roots] unless ref $roots; } else { $self->warn("No root path(s) specified\n"); return 0; } my($root); foreach $root (@{$roots}) { $root =~ s#/\z##; (undef, undef, my $rp) = lstat $root or next; $rp &= 07777; # don't forget setuid, setgid, sticky bits if ( -d _ ) { # notabene: 0777 is for making readable in the first place, # it's also intended to change it to writable in case we have # to recurse in which case we are better than rm -rf for # subtrees with strange permissions chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) or $self->warn("Can't make directory $root read+writable: $!") unless $safe; if (opendir(DIR, $root) ){ @files = readdir DIR; closedir(DIR); } else { $self->warn( "Can't read $root: $!"); @files = (); } # Deleting large numbers of files from VMS Files-11 filesystems # is faster if done in reverse ASCIIbetical order @files = reverse @files if $Is_VMS; ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); $count += $self->rmtree([@files],$verbose,$safe); if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { print "skipped $root\n" if $verbose; next; } chmod 0777, $root or $self->warn( "Can't make directory $root writable: $!") if $force_writable; print "rmdir $root\n" if $verbose; if (rmdir $root) { ++$count; } else { $self->warn( "Can't remove directory $root: $!"); chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) or $self->warn("and can't restore permissions to " . sprintf("0%o",$rp) . "\n"); } } else { if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !(-l $root || -w $root))) { print "skipped $root\n" if $verbose; next; } chmod 0666, $root or $self->warn( "Can't make file $root writable: $!") if $force_writable; warn "unlink $root\n" if $verbose; # delete all versions under VMS for (;;) { unless (unlink $root) { $self->warn( "Can't unlink file $root: $!"); if ($force_writable) { chmod $rp, $root or $self->warn("and can't restore permissions to " . sprintf("0%o",$rp) . "\n"); } last; } ++$count; last unless $Is_VMS && lstat $root; } } } $count; } =head2 _flush_on_write Title : _flush_on_write Usage : $obj->_flush_on_write($newval) Function: Boolean flag to indicate whether to flush the filehandle on writing when the end of a component is finished (Sequences,Alignments,etc) Returns : value of _flush_on_write Args : newvalue (optional) =cut sub _flush_on_write { my ($self,$value) = @_; if( defined $value) { $self->{'_flush_on_write'} = $value; } return $self->{'_flush_on_write'}; } =head2 save_tempfiles Title : save_tempfiles Usage : $obj->save_tempfiles(1) Function: Boolean flag to indicate whether to retain tempfiles/tempdir Returns : Boolean value : 1 = save tempfiles/tempdirs, 0 = remove (default) Args : Value evaluating to TRUE or FALSE =cut sub save_tempfiles { my $self = shift; if (@_) { my $value = shift; $self->{save_tempfiles} = $value ? 1 : 0; } return $self->{save_tempfiles} || 0; } 1; BioPerl-1.6.923/Bio/Root/Root.pm000444000765000024 4303712254227315 16403 0ustar00cjfieldsstaff000000000000package Bio::Root::Root; use strict; use Scalar::Util qw(blessed reftype); =head1 NAME Bio::Root::Root - Hash-based implementation of Bio::Root::RootI =head1 SYNOPSIS # Any Bioperl-compliant object is a RootI compliant object # Here's how to throw and catch an exception using the eval-based syntax. $obj->throw("This is an exception"); eval { $obj->throw("This is catching an exception"); }; if( $@ ) { print "Caught exception"; } else { print "no exception"; } # Alternatively, using the new typed exception syntax in the throw() call: $obj->throw( -class => 'Bio::Root::BadParameter', -text => "Can not open file $file", -value => $file ); # Want to see debug() outputs for this object my $obj = Bio::Object->new(-verbose=>1); my $obj = Bio::Object->new(%args); $obj->verbose(2); # Print debug messages which honour current verbosity setting $obj->debug("Boring output only to be seen if verbose > 0\n"); # Deep-object copy my $clone = $obj->clone; =head1 DESCRIPTION This is a hashref-based implementation of the Bio::Root::RootI interface. Most Bioperl objects should inherit from this. See the documentation for L for most of the methods implemented by this module. Only overridden methods are described here. =head2 Throwing Exceptions One of the functionalities that L provides is the ability to L() exceptions with pretty stack traces. Bio::Root::Root enhances this with the ability to use L (available from CPAN) if it has also been installed. If L has been installed, L() will use it. This causes an Error.pm-derived object to be thrown. This can be caught within a C block, from wich you can extract useful bits of information. If L is not installed, it will use the L-based exception throwing facilty. =head2 Typed Exception Syntax The typed exception syntax of L() has the advantage of plainly indicating the nature of the trouble, since the name of the class is included in the title of the exception output. To take advantage of this capability, you must specify arguments as named parameters in the L() call. Here are the parameters: =over 4 =item -class name of the class of the exception. This should be one of the classes defined in L, or a custom error of yours that extends one of the exceptions defined in L. =item -text a sensible message for the exception =item -value the value causing the exception or $!, if appropriate. =back Note that Bio::Root::Exception does not need to be imported into your module (or script) namespace in order to throw exceptions via Bio::Root::Root::throw(), since Bio::Root::Root imports it. =head2 Try-Catch-Finally Support In addition to using an eval{} block to handle exceptions, you can also use a try-catch-finally block structure if L has been installed in your system (available from CPAN). See the documentation for Error for more details. Here's an example. See the L module for other pre-defined exception types: try { open( IN, $file) || $obj->throw( -class => 'Bio::Root::FileOpenException', -text => "Cannot open file $file for reading", -value => $!); } catch Bio::Root::BadParameter with { my $err = shift; # get the Error object # Perform specific exception handling code for the FileOpenException } catch Bio::Root::Exception with { my $err = shift; # get the Error object # Perform general exception handling code for any Bioperl exception. } otherwise { # A catch-all for any other type of exception } finally { # Any code that you want to execute regardless of whether or not # an exception occurred. }; # the ending semicolon is essential! =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Functions originally from Steve Chervitz. Refactored by Ewan Birney. Re-refactored by Lincoln Stein. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' use strict; use Bio::Root::IO; use base qw(Bio::Root::RootI); our ($DEBUG, $ID, $VERBOSITY, $ERRORLOADED, $CLONE_CLASS); BEGIN { $ID = 'Bio::Root::Root'; $DEBUG = 0; $VERBOSITY = 0; $ERRORLOADED = 0; # Check whether or not Error.pm is available. # $main::DONT_USE_ERROR is intended for testing purposes and also # when you don't want to use the Error module, even if it is installed. # Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script. if( not $main::DONT_USE_ERROR ) { if ( eval "require Error" ) { import Error qw(:try); require Bio::Root::Exception; $ERRORLOADED = 1; $Error::Debug = 1; # enable verbose stack trace } } if( !$ERRORLOADED ) { require Carp; import Carp qw( confess ); } # set up _dclone() for my $class (qw(Clone::Fast Clone Storable)) { eval "require $class; 1;"; if (!$@) { $CLONE_CLASS = $class; if ($class eq 'Clone::Fast') { *Bio::Root::Root::_dclone = sub {shift; return Clone::Fast::clone(shift)}; } elsif ($class eq 'Clone') { *Bio::Root::Root::_dclone = sub {shift; return Clone::clone(shift)}; } else { *Bio::Root::Root::_dclone = sub {shift; return Storable::dclone(shift)}; } last; } } if (!defined $CLONE_CLASS) { *Bio::Root::Root::_dclone = sub { my ($self, $orig, $level) = @_; my $class = Scalar::Util::blessed($orig) || ''; my $reftype = Scalar::Util::reftype($orig) || ''; my $data; if (!$reftype) { $data = $orig } elsif ($reftype eq "ARRAY") { $data = [map $self->_dclone($_), @$orig]; } elsif ($reftype eq "HASH") { $data = { map { $_ => $self->_dclone($orig->{$_}) } keys %$orig }; } elsif ($reftype eq 'CODE') { # nothing, maybe shallow copy? $self->throw("Code reference cloning not supported"); } else { $self->throw("What type is $_?")} if ($class) { bless $data, $class; } $data; } } $main::DONT_USE_ERROR; # so that perl -w won't warn "used only once" } =head2 new Purpose : generic instantiation function can be overridden if special needs of a module cannot be done in _initialize =cut sub new { #my ($class, %param) = @_; my $class = shift; my $self = {}; bless $self, ref($class) || $class; if(@_ > 1) { # if the number of arguments is odd but at least 3, we'll give # it a try to find -verbose shift if @_ % 2; my %param = @_; ## See "Comments" above regarding use of _rearrange(). $self->verbose($param{'-VERBOSE'} || $param{'-verbose'}); } return $self; } =head2 clone Title : clone Usage : my $clone = $obj->clone(); or my $clone = $obj->clone( -start => 110 ); Function: Deep recursion copying of any object via Storable dclone() Returns : A cloned object. Args : Any named parameters provided will be set on the new object. Unnamed parameters are ignored. Comments: Where possible, faster clone methods are used, in order: Clone::Fast::clone(), Clone::clone(), Storable::dclone. If neither is present, a pure perl fallback (not very well tested) is used instead. Storable dclone() cannot clone CODE references. Therefore, any CODE reference in your original object will remain, but will not exist in the cloned object. This should not be used for anything other than cloning of simple objects. Developers of subclasses are encouraged to override this method with one of their own. =cut sub clone { my ($orig, %named_params) = @_; __PACKAGE__->throw("Can't call clone() as a class method") unless ref $orig && $orig->isa('Bio::Root::Root'); # Can't dclone CODE references... # Should we shallow copy these? Should be harmless for these specific # methods... my %put_these_back = ( _root_cleanup_methods => $orig->{'_root_cleanup_methods'}, ); delete $orig->{_root_cleanup_methods}; # call the proper clone method, set lazily above my $clone = __PACKAGE__->_dclone($orig); $orig->{_root_cleanup_methods} = $put_these_back{_root_cleanup_methods}; foreach my $key (grep { /^-/ } keys %named_params) { my $method = $key; $method =~ s/^-//; if ($clone->can($method)) { $clone->$method($named_params{$key}) } else { $orig->warn("Parameter $method is not a method for ".ref($clone)); } } return $clone; } =head2 _dclone Title : clone Usage : my $clone = $obj->_dclone($ref); or my $clone = $obj->_dclone($ref); Function: Returns a copy of the object passed to it (a deep clone) Returns : clone of passed argument Args : Anything NOTE : This differs from clone significantly in that it does not clone self, but the data passed to it. This code may need to be optimized or overridden as needed. Comments: This is set in the BEGIN block to take advantage of optimized cloning methods if Clone or Storable is present, falling back to a pure perl kludge. May be moved into a set of modules if the need arises. At the moment, code ref cloning is not supported. =cut =head2 verbose Title : verbose Usage : $self->verbose(1) Function: Sets verbose level for how ->warn behaves -1 = no warning 0 = standard, small warning 1 = warning with stack trace 2 = warning becomes throw Returns : The current verbosity setting (integer between -1 to 2) Args : -1,0,1 or 2 =cut sub verbose { my ($self,$value) = @_; # allow one to set global verbosity flag return $DEBUG if $DEBUG; return $VERBOSITY unless ref $self; if (defined $value || ! defined $self->{'_root_verbose'}) { $self->{'_root_verbose'} = $value || 0; } return $self->{'_root_verbose'}; } sub _register_for_cleanup { my ($self,$method) = @_; if ($method) { if(! exists($self->{'_root_cleanup_methods'})) { $self->{'_root_cleanup_methods'} = []; } push(@{$self->{'_root_cleanup_methods'}},$method); } } sub _unregister_for_cleanup { my ($self,$method) = @_; my @methods = grep {$_ ne $method} $self->_cleanup_methods; $self->{'_root_cleanup_methods'} = \@methods; } sub _cleanup_methods { my $self = shift; return unless ref $self && $self->isa('HASH'); my $methods = $self->{'_root_cleanup_methods'} or return; @$methods; } =head2 throw Title : throw Usage : $obj->throw("throwing exception message"); or $obj->throw( -class => 'Bio::Root::Exception', -text => "throwing exception message", -value => $bad_value ); Function: Throws an exception, which, if not caught with an eval or a try block will provide a nice stack trace to STDERR with the message. If Error.pm is installed, and if a -class parameter is provided, Error::throw will be used, throwing an error of the type specified by -class. If Error.pm is installed and no -class parameter is provided (i.e., a simple string is given), A Bio::Root::Exception is thrown. Returns : n/a Args : A string giving a descriptive error message, optional Named parameters: '-class' a string for the name of a class that derives from Error.pm, such as any of the exceptions defined in Bio::Root::Exception. Default class: Bio::Root::Exception '-text' a string giving a descriptive error message '-value' the value causing the exception, or $! (optional) Thus, if only a string argument is given, and Error.pm is available, this is equivalent to the arguments: -text => "message", -class => Bio::Root::Exception Comments : If Error.pm is installed, and you don't want to use it for some reason, you can block the use of Error.pm by Bio::Root::Root::throw() by defining a scalar named $main::DONT_USE_ERROR (define it in your main script and you don't need the main:: part) and setting it to a true value; you must do this within a BEGIN subroutine. =cut sub throw { my ($self, @args) = @_; my ($text, $class, $value) = $self->_rearrange( [qw(TEXT CLASS VALUE)], @args); $text ||= $args[0] if @args == 1; if ($ERRORLOADED) { # Enable re-throwing of Error objects. # If the error is not derived from Bio::Root::Exception, # we can't guarantee that the Error's value was set properly # and, ipso facto, that it will be catchable from an eval{}. # But chances are, if you're re-throwing non-Bio::Root::Exceptions, # you're probably using Error::try(), not eval{}. # TODO: Fix the MSG: line of the re-thrown error. Has an extra line # containing the '----- EXCEPTION -----' banner. if (ref($args[0])) { if( $args[0]->isa('Error')) { my $class = ref $args[0]; $class->throw( @args ); } else { my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0]; my $class = "Bio::Root::Exception"; $class->throw( '-text' => $text, '-value' => $args[0] ); } } else { $class ||= "Bio::Root::Exception"; my %args; if( @args % 2 == 0 && $args[0] =~ /^-/ ) { %args = @args; $args{-text} = $text; $args{-object} = $self; } $class->throw( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context! } } else { $class ||= ''; $class = ': '.$class if $class; my $std = $self->stack_trace_dump(); my $title = "------------- EXCEPTION$class -------------"; my $footer = ('-' x CORE::length($title))."\n"; $text ||= ''; die "\n$title\n", "MSG: $text\n", $std, $footer, "\n"; } } =head2 debug Title : debug Usage : $obj->debug("This is debugging output"); Function: Prints a debugging message when verbose is > 0 Returns : none Args : message string(s) to print to STDERR =cut sub debug { my ($self, @msgs) = @_; # using CORE::warn doesn't give correct backtrace information; we want the # line from the previous call in the call stack, not this call (similar to # cluck). For now, just add a stack trace dump and simple comment under the # correct conditions. if (defined $self->verbose && $self->verbose > 0) { if (!@msgs || $msgs[-1] !~ /\n$/) { push @msgs, "Debugging comment:" if !@msgs; push @msgs, sprintf("%s %s:%s", @{($self->stack_trace)[2]}[3,1,2])."\n"; } CORE::warn @msgs; } } =head2 _load_module Title : _load_module Usage : $self->_load_module("Bio::SeqIO::genbank"); Function: Loads up (like use) the specified module at run time on demand. Example : Returns : TRUE on success. Throws an exception upon failure. Args : The module to load (_without_ the trailing .pm). =cut sub _load_module { my ($self, $name) = @_; my ($module, $load, $m); $module = "_<$name.pm"; return 1 if $main::{$module}; # untaint operation for safe web-based running (modified after # a fix by Lincoln) HL if ($name !~ /^([\w:]+)$/) { $self->throw("$name is an illegal perl package name"); } else { $name = $1; } $load = "$name.pm"; my $io = Bio::Root::IO->new(); # catfile comes from IO $load = $io->catfile((split(/::/,$load))); eval { require $load; }; if ( $@ ) { $self->throw("Failed to load module $name. ".$@); } return 1; } sub DESTROY { my $self = shift; my @cleanup_methods = $self->_cleanup_methods or return; for my $method (@cleanup_methods) { $method->($self); } } 1; BioPerl-1.6.923/Bio/Root/RootI.pm000444000765000024 6652312254227333 16521 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Root::RootI # # Please direct questions and support issues to # # Cared for by Ewan Birney # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # # This was refactored to have chained calls to new instead # of chained calls to _initialize # # added debug and deprecated methods --Jason Stajich 2001-10-12 # =head1 NAME Bio::Root::RootI - Abstract interface to root object code =head1 SYNOPSIS # any bioperl or bioperl compliant object is a RootI # compliant object $obj->throw("This is an exception"); eval { $obj->throw("This is catching an exception"); }; if( $@ ) { print "Caught exception"; } else { print "no exception"; } # Using throw_not_implemented() within a RootI-based interface module: package Foo; use base qw(Bio::Root::RootI); sub foo { my $self = shift; $self->throw_not_implemented; } =head1 DESCRIPTION This is just a set of methods which do not assume B about the object they are on. The methods provide the ability to throw exceptions with nice stack traces. This is what should be inherited by all Bioperl compliant interfaces, even if they are exotic XS/CORBA/Other perl systems. =head2 Using throw_not_implemented() The method L should be called by all methods within interface modules that extend RootI so that if an implementation fails to override them, an exception will be thrown. For example, say there is an interface module called C that provides a method called C. Since this method is considered abstract within FooI and should be implemented by any module claiming to implement C, the C method should consist of the following: sub foo { my $self = shift; $self->throw_not_implemented; } So, if an implementer of C forgets to implement C and a user of the implementation calls C, a L exception will result. Unfortunately, failure to implement a method can only be determined at run time (i.e., you can't verify that an implementation is complete by running C on it). So it should be standard practice for a test of an implementation to check each method and verify that it doesn't throw a L. =head1 CONTACT Functions originally from Steve Chervitz. Refactored by Ewan Birney. Re-refactored by Lincoln Stein. Added to by Sendu Bala. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Root::RootI; use vars qw($DEBUG $ID $VERBOSITY); use strict; use Carp 'confess','carp'; use Bio::Root::Version; BEGIN { $ID = 'Bio::Root::RootI'; $DEBUG = 0; $VERBOSITY = 0; } sub new { my $class = shift; my @args = @_; unless ( $ENV{'BIOPERLDEBUG'} ) { carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead"); } eval "require Bio::Root::Root"; return Bio::Root::Root->new(@args); } # for backwards compatibility sub _initialize { my($self,@args) = @_; return 1; } =head2 throw Title : throw Usage : $obj->throw("throwing exception message") Function: Throws an exception, which, if not caught with an eval brace will provide a nice stack trace to STDERR with the message Returns : nothing Args : A string giving a descriptive error message =cut sub throw{ my ($self,$string) = @_; my $std = $self->stack_trace_dump(); my $out = "\n-------------------- EXCEPTION --------------------\n". "MSG: ".$string."\n".$std."-------------------------------------------\n"; die $out; } =head2 warn Title : warn Usage : $object->warn("Warning message"); Function: Places a warning. What happens now is down to the verbosity of the object (value of $obj->verbose) verbosity 0 or not set => small warning verbosity -1 => no warning verbosity 1 => warning with stack trace verbosity 2 => converts warnings into throw Returns : n/a Args : string (the warning message) =cut sub warn { my ($self,$string) = @_; my $verbose = $self->verbose; my $header = "\n--------------------- WARNING ---------------------\nMSG: "; my $footer = "---------------------------------------------------\n"; if ($verbose >= 2) { $self->throw($string); } elsif ($verbose <= -1) { return; } elsif ($verbose == 1) { CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer; return; } CORE::warn $header, $string, "\n", $footer; } =head2 deprecated Title : deprecated Usage : $obj->deprecated("Method X is deprecated"); $obj->deprecated("Method X is deprecated", 1.007); $obj->deprecated(-message => "Method X is deprecated"); $obj->deprecated(-message => "Method X is deprecated", -version => 1.007); Function: Prints a message about deprecation unless verbose is < 0 (which means be quiet) Returns : none Args : Message string to print to STDERR Version of BioPerl where use of the method results in an exception Notes : The method can be called two ways, either by positional arguments: $obj->deprecated('This module is deprecated', 1.006); or by named arguments: $obj->deprecated( -message => 'use of the method foo() is deprecated, use bar() instead', -version => 1.006 # throw if $VERSION is >= this version ); or timed to go off at a certain point: $obj->deprecated( -message => 'use of the method foo() is deprecated, use bar() instead', -warn_version => 1.006 # warn if $VERSION is >= this version -throw_version => 1.007 # throw if $VERSION is >= this version ); Using the last two named argument versions is suggested and will likely be the only supported way of calling this method in the future Yes, we see the irony of deprecating that particular usage of deprecated(). The main difference between usage of the two named argument versions is that by designating a 'warn_version' one indicates the functionality is officially deprecated beginning in a future version of BioPerl (so warnings are issued only after that point), whereas setting either 'version' or 'throw_version' (synonyms) converts the deprecation warning to an exception. For proper comparisons one must use a version in lines with the current versioning scheme for Perl and BioPerl, (i.e. where 1.006000 indicates v1.6.0, 5.010000 for v5.10.0, etc.). =cut sub deprecated{ my ($self) = shift; my ($msg, $version, $warn_version, $throw_version) = $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_); $version ||= $throw_version; for my $v ($warn_version, $version) { next unless defined $v; $self->throw('Version must be numerical, such as 1.006000 for v1.6.0, not '. $v) unless $v =~ /^\d+\.\d+$/; } return if ($warn_version && $Bio::Root::Version::VERSION < $warn_version); # below default insinuates we're deprecating a method and not a full module # but it's the most common use case $msg ||= "Use of ".(caller(1))[3]."() is deprecated"; # delegate to either warn or throw based on whether a version is given if ($version) { $msg .= "\nTo be removed in $version"; if ($Bio::Root::Version::VERSION >= $version) { $self->throw($msg) } } # passing this on to warn() should deal properly with verbosity issues $self->warn($msg); } =head2 stack_trace_dump Title : stack_trace_dump Usage : Function: Example : Returns : Args : =cut sub stack_trace_dump{ my ($self) = @_; my @stack = $self->stack_trace(); shift @stack; shift @stack; shift @stack; my $out; my ($module,$function,$file,$position); foreach my $stack ( @stack) { ($module,$file,$position,$function) = @{$stack}; $out .= "STACK $function $file:$position\n"; } return $out; } =head2 stack_trace Title : stack_trace Usage : @stack_array_ref= $self->stack_trace Function: gives an array to a reference of arrays with stack trace info each coming from the caller(stack_number) call Returns : array containing a reference of arrays Args : none =cut sub stack_trace{ my ($self) = @_; my $i = 0; my @out = (); my $prev = []; while( my @call = caller($i++)) { # major annoyance that caller puts caller context as # function name. Hence some monkeying around... $prev->[3] = $call[3]; push(@out,$prev); $prev = \@call; } $prev->[3] = 'toplevel'; push(@out,$prev); return @out; } =head2 _rearrange Usage : $object->_rearrange( array_ref, list_of_arguments) Purpose : Rearranges named parameters to requested order. Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param); : Where @param = (-sequence => $s, : -desc => $d, : -id => $i); Returns : @params - an array of parameters in the requested order. : The above example would return ($s, $i, $d). : Unspecified parameters will return undef. For example, if : @param = (-sequence => $s); : the above _rearrange call would return ($s, undef, undef) Argument : $order : a reference to an array which describes the desired : order of the named parameters. : @param : an array of parameters, either as a list (in : which case the function simply returns the list), : or as an associative array with hyphenated tags : (in which case the function sorts the values : according to @{$order} and returns that new array.) : The tags can be upper, lower, or mixed case : but they must start with a hyphen (at least the : first one should be hyphenated.) Source : This function was taken from CGI.pm, written by Dr. Lincoln : Stein, and adapted for use in Bio::Seq by Richard Resnick and : then adapted for use in Bio::Root::Object.pm by Steve Chervitz, : then migrated into Bio::Root::RootI.pm by Ewan Birney. Comments : : Uppercase tags are the norm, : (SAC) : This method may not be appropriate for method calls that are : within in an inner loop if efficiency is a concern. : : Parameters can be specified using any of these formats: : @param = (-name=>'me', -color=>'blue'); : @param = (-NAME=>'me', -COLOR=>'blue'); : @param = (-Name=>'me', -Color=>'blue'); : @param = ('me', 'blue'); : A leading hyphenated argument is used by this function to : indicate that named parameters are being used. : Therefore, the ('me', 'blue') list will be returned as-is. : : Note that Perl will confuse unquoted, hyphenated tags as : function calls if there is a function of the same name : in the current namespace: : -name => 'foo' is interpreted as -&name => 'foo' : : For ultimate safety, put single quotes around the tag: : ('-name'=>'me', '-color' =>'blue'); : This can be a bit cumbersome and I find not as readable : as using all uppercase, which is also fairly safe: : (-NAME=>'me', -COLOR =>'blue'); : : Personal note (SAC): I have found all uppercase tags to : be more manageable: it involves less single-quoting, : the key names stand out better, and there are no method naming : conflicts. : The drawbacks are that it's not as easy to type as lowercase, : and lots of uppercase can be hard to read. : : Regardless of the style, it greatly helps to line : the parameters up vertically for long/complex lists. : : Note that if @param is a single string that happens to start with : a dash, it will be treated as a hash key and probably fail to : match anything in the array_ref, so not be returned as normally : happens when @param is a simple list and not an associative array. =cut sub _rearrange { shift; #discard self my $order = shift; return @_ unless $_[0] && $_[0] =~ /^\-/; push @_, undef unless $#_ % 2; my %param; for( my $i = 0; $i < @_; $i += 2 ) { (my $key = $_[$i]) =~ tr/a-z\055/A-Z/d; #deletes all dashes! $param{$key} = $_[$i+1]; } return @param{map uc, @$order}; } =head2 _set_from_args Usage : $object->_set_from_args(\%args, -methods => \@methods) Purpose : Takes a hash of user-supplied args whose keys match method names, : and calls the method supplying it the corresponding value. Example : $self->_set_from_args(\%args, -methods => [qw(sequence id desc)]); : Where %args = (-sequence => $s, : -description => $d, : -ID => $i); : : the above _set_from_args calls the following methods: : $self->sequence($s); : $self->id($i); : ( $self->description($i) is not called because 'description' wasn't : one of the given methods ) Argument : \%args | \@args : a hash ref or associative array ref of arguments : where keys are any-case strings corresponding to : method names but optionally prefixed with : hyphens, and values are the values the method : should be supplied. If keys contain internal : hyphens (eg. to separate multi-word args) they : are converted to underscores, since method names : cannot contain dashes. : -methods => [] : (optional) only call methods with names in this : array ref. Can instead supply a hash ref where : keys are method names (of real existing methods : unless -create is in effect) and values are array : refs of synonyms to allow access to the method : using synonyms. If there is only one synonym it : can be supplied as a string instead of a single- : element array ref : -force => bool : (optional, default 0) call methods that don't : seem to exist, ie. let AUTOLOAD handle them : -create => bool : (optional, default 0) when a method doesn't : exist, create it as a simple getter/setter : (combined with -methods it would create all the : supplied methods that didn't exist, even if not : mentioned in the supplied %args) : -code => '' | {}: (optional) when creating methods use the supplied : code (a string which will be evaulated as a sub). : The default code is a simple get/setter. : Alternatively you can supply a hash ref where : the keys are method names and the values are : code strings. The variable '$method' will be : available at evaluation time, so can be used in : your code strings. Beware that the strict pragma : will be in effect. : -case_sensitive => bool : require case sensitivity on the part of : user (ie. a() and A() are two different : methods and the user must be careful : which they use). Comments : : The \%args argument will usually be the args received during new() : from the user. The user is allowed to get the case wrong, include : 0 or more than one hyphens as a prefix, and to include hyphens as : multi-word arg separators: '--an-arg' => 1, -an_arg => 1 and : An_Arg => 1 are all equivalent, calling an_arg(1). However, in : documentation users should only be told to use the standard form : -an_arg to avoid confusion. A possible exception to this is a : wrapper module where '--an-arg' is what the user is used to : supplying to the program being wrapped. : : Another issue with wrapper modules is that there may be an : argument that has meaning both to Bioperl and to the program, eg. : -verbose. The recommended way of dealing with this is to leave : -verbose to set the Bioperl verbosity whilst requesting users use : an invented -program_verbose (or similar) to set the program : verbosity. This can be resolved back with : Bio::Tools::Run::WrapperBase's _setparams() method and code along : the lines of: : my %methods = map { $_ => $_ } @LIST_OF_ALL_ALLOWED_PROGRAM_ARGS : delete $methods{'verbose'}; : $methods{'program_verbose'} = 'verbose'; : my $param_string = $self->_setparams(-methods => \%methods); : system("$exe $param_string"); =cut sub _set_from_args { my ($self, $args, @own_args) = @_; $self->throw("a hash/array ref of arguments must be supplied") unless ref($args); my ($methods, $force, $create, $code, $case); if (@own_args) { ($methods, $force, $create, $code, $case) = $self->_rearrange([qw(METHODS FORCE CREATE CODE CASE_SENSITIVE)], @own_args); } my $default_code = 'my $self = shift; if (@_) { $self->{\'_\'.$method} = shift } return $self->{\'_\'.$method};'; my %method_names = (); my %syns = (); if ($methods) { my @names; if (ref($methods) eq 'HASH') { @names = keys %{$methods}; %syns = %{$methods}; } else { @names = @{$methods}; %syns = map { $_ => $_ } @names; } %method_names = map { $case ? $_ : lc($_) => $_ } @names; } # deal with hyphens my %orig_args = ref($args) eq 'HASH' ? %{$args} : @{$args}; my %args; while (my ($method, $value) = each %orig_args) { $method =~ s/^-+//; $method =~ s/-/_/g; $args{$method} = $value; } # create non-existing methods on request if ($create) { unless ($methods) { %syns = map { $_ => $case ? $_ : lc($_) } keys %args; } foreach my $method (keys %syns) { $self->can($method) && next; my $string = $code || $default_code; if (ref($code) && ref($code) eq 'HASH') { $string = $code->{$method} || $default_code; } my $sub = eval "sub { $string }"; $self->throw("Compilation error for $method : $@") if $@; no strict 'refs'; *{ref($self).'::'.$method} = $sub; } } # create synonyms of existing methods while (my ($method, $syn_ref) = each %syns) { my $method_ref = $self->can($method) || next; foreach my $syn (@{ ref($syn_ref) ? $syn_ref : [$syn_ref] }) { next if $syn eq $method; $method_names{$case ? $syn : lc($syn)} = $syn; next if $self->can($syn); no strict 'refs'; *{ref($self).'::'.$syn} = $method_ref; } } # set values for methods while (my ($method, $value) = each %args) { $method = $method_names{$case ? $method : lc($method)} || ($methods ? next : $method); $self->can($method) || next unless $force; $self->$method($value); } } #----------------' sub _rearrange_old { #---------------- my($self,$order,@param) = @_; # JGRG -- This is wrong, because we don't want # to assign empty string to anything, and this # code is actually returning an array 1 less # than the length of @param: ## If there are no parameters, we simply wish to return ## an empty array which is the size of the @{$order} array. #return ('') x $#{$order} unless @param; # ...all we need to do is return an empty array: # return unless @param; # If we've got parameters, we need to check to see whether # they are named or simply listed. If they are listed, we # can just return them. # The mod test fixes bug where a single string parameter beginning with '-' gets lost. # This tends to happen in error messages such as: $obj->throw("-id not defined") return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2)); # Tester # print "\n_rearrange() named parameters:\n"; # my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; ; # Now we've got to do some work on the named parameters. # The next few lines strip out the '-' characters which # preceed the keys, and capitalizes them. for (my $i=0;$i<@param;$i+=2) { $param[$i]=~s/^\-//; $param[$i]=~tr/a-z/A-Z/; } # Now we'll convert the @params variable into an associative array. # local($^W) = 0; # prevent "odd number of elements" warning with -w. my(%param) = @param; # my(@return_array); # What we intend to do is loop through the @{$order} variable, # and for each value, we use that as a key into our associative # array, pushing the value at that key onto our return array. # my($key); #foreach (@{$order}) { # my($value) = $param{$key}; # delete $param{$key}; #push(@return_array,$param{$_}); #} return @param{@{$order}}; # print "\n_rearrange() after processing:\n"; # my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } ; # return @return_array; } =head2 _register_for_cleanup Title : _register_for_cleanup Usage : -- internal -- Function: Register a method to be called at DESTROY time. This is useful and sometimes essential in the case of multiple inheritance for classes coming second in the sequence of inheritance. Returns : Args : a code reference The code reference will be invoked with the object as the first argument, as per a method. You may register an unlimited number of cleanup methods. =cut sub _register_for_cleanup { my ($self,$method) = @_; $self->throw_not_implemented(); } =head2 _unregister_for_cleanup Title : _unregister_for_cleanup Usage : -- internal -- Function: Remove a method that has previously been registered to be called at DESTROY time. If called with a method to be called at DESTROY time. Has no effect if the code reference has not previously been registered. Returns : nothing Args : a code reference =cut sub _unregister_for_cleanup { my ($self,$method) = @_; $self->throw_not_implemented(); } =head2 _cleanup_methods Title : _cleanup_methods Usage : -- internal -- Function: Return current list of registered cleanup methods. Returns : list of coderefs Args : none =cut sub _cleanup_methods { my $self = shift; unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) { carp("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead"); } return; } =head2 throw_not_implemented Purpose : Throws a Bio::Root::NotImplemented exception. Intended for use in the method definitions of abstract interface modules where methods are defined but are intended to be overridden by subclasses. Usage : $object->throw_not_implemented(); Example : sub method_foo { $self = shift; $self->throw_not_implemented(); } Returns : n/a Args : n/a Throws : A Bio::Root::NotImplemented exception. The message of the exception contains - the name of the method - the name of the interface - the name of the implementing class If this object has a throw() method, $self->throw will be used. If the object doesn't have a throw() method, Carp::confess() will be used. =cut #' sub throw_not_implemented { my $self = shift; # Bio::Root::Root::throw() knows how to check for Error.pm and will # throw an Error-derived object of the specified class (Bio::Root::NotImplemented), # which is defined in Bio::Root::Exception. # If Error.pm is not available, the name of the class is just included in the # error message. my $message = $self->_not_implemented_msg; if ( $self->can('throw') ) { my @args; if ( $self->isa('Bio::Root::Root') ) { # Use Root::throw() hash-based arguments instead of RootI::throw() # single string argument whenever possible @args = ( -text => $message, -class => 'Bio::Root::NotImplemented' ); } else { @args = ( $message ); } $self->throw(@args); } else { confess $message; } } =head2 warn_not_implemented Purpose : Generates a warning that a method has not been implemented. Intended for use in the method definitions of abstract interface modules where methods are defined but are intended to be overridden by subclasses. Generally, throw_not_implemented() should be used, but warn_not_implemented() may be used if the method isn't considered essential and convenient no-op behavior can be provided within the interface. Usage : $object->warn_not_implemented( method-name-string ); Example : $self->warn_not_implemented( "get_foobar" ); Returns : Calls $self->warn on this object, if available. If the object doesn't have a warn() method, Carp::carp() will be used. Args : n/a =cut #' sub warn_not_implemented { my $self = shift; my $message = $self->_not_implemented_msg; if( $self->can('warn') ) { $self->warn( $message ); }else { carp $message ; } } # Unify 'not implemented' message. -Juguang sub _not_implemented_msg { my $self = shift; my $package = ref $self; my $meth = (caller(2))[3]; my $msg =< # # Cared for by Will Spooner # # Copyright Will Spooner # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Root::Storable - object serialisation methods =head1 SYNOPSIS my $storable = Bio::Root::Storable->new(); # Store/retrieve using class retriever my $token = $storable->store(); my $storable2 = Bio::Root::Storable->retrieve( $token ); # Store/retrieve using object retriever my $storable2 = $storable->new_retrievable(); $storable2->retrieve(); =head1 DESCRIPTION Generic module that allows objects to be safely stored/retrieved from disk. Can be inhereted by any BioPerl object. As it will not usually be the first class in the inheretence list, _initialise_storable() should be called during object instantiation. Object storage is recursive; If the object being stored contains other storable objects, these will be stored separately, and replaced by a skeleton object in the parent heirarchy. When the parent is later retrieved, its children remain in the skeleton state until explicitly retrieved by the parent. This lazy-retrieve approach has obvious memory efficiency benefits for certain applications. By default, objects are stored in binary format (using the Perl Storable module). Earlier versions of Perl5 do not include Storable as a core module. If this is the case, ASCII object storage (using the Perl Data::Dumper module) is used instead. ASCII storage can be enabled by default by setting the value of $Bio::Root::Storable::BINARY to false. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bio.perl.org =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Will Spooner Email whs@sanger.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Root::Storable; use strict; use Data::Dumper qw( Dumper ); use File::Spec; use Bio::Root::IO; use vars qw( $BINARY ); use base qw(Bio::Root::Root); BEGIN{ if( eval "require Storable" ){ Storable->import( 'freeze', 'thaw' ); $BINARY = 1; } } #---------------------------------------------------------------------- =head2 new Arg [1] : -workdir => filesystem path, -template => tmpfile template, -suffix => tmpfile suffix, Function : Builds a new Bio::Root::Storable inhereting object Returntype: Bio::Root::Storable inhereting object Exceptions: Caller : Example : $storable = Bio::Root::Storable->new() =cut sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); $self->_initialise_storable; return $self; } #---------------------------------------------------------------------- =head2 _initialise_storable Arg [1] : See 'new' method Function : Initialises storable-specific attributes Returntype: boolean Exceptions: Caller : Example : =cut sub _initialise_storable { my $self = shift; my( $workdir, $template, $suffix ) = $self->_rearrange([qw(WORKDIR TEMPLATE SUFFIX)], @_ ); $workdir && $self->workdir ( $workdir ); $template && $self->template( $template ); $suffix && $self->suffix ( $suffix ); return 1; } #---------------------------------------------------------------------- =head2 statefile Arg [1] : string (optional) Function : Accessor for the file to write state into. Should not normaly use as a setter - let Root::IO do this for you. Returntype: string Exceptions: Caller : Bio::Root::Storable->store Example : my $statefile = $obj->statefile(); =cut sub statefile{ my $key = '_statefile'; my $self = shift; if( @_ ){ $self->{$key} = shift } if( ! $self->{$key} ){ # Create a new statefile my $workdir = $self->workdir; my $template = $self->template; my $suffix = $self->suffix; # TODO: add cleanup and unlink methods. For now, we'll keep the # statefile hanging around. my @args = ( CLEANUP=>0, UNLINK=>0 ); if( $template ){ push( @args, 'TEMPLATE' => $template )}; if( $workdir ){ push( @args, 'DIR' => $workdir )}; if( $suffix ){ push( @args, 'SUFFIX' => $suffix )}; my( $fh, $file ) = Bio::Root::IO->new->tempfile( @args ); $self->{$key} = $file; } return $self->{$key}; } #---------------------------------------------------------------------- =head2 workdir Arg [1] : string (optional) (TODO - convert to array for x-platform) Function : Accessor for the statefile directory. Defaults to File::Spec->tmpdir Returntype: string Exceptions: Caller : Example : $obj->workdir('/tmp/foo'); =cut sub workdir { my $key = '_workdir'; my $self = shift; if( @_ ){ my $caller = join( ', ', (caller(0))[1..2] ); $self->{$key} && $self->debug("Overwriting workdir: probably bad!"); $self->{$key} = shift } # $self->{$key} ||= $Bio::Root::IO::TEMPDIR; $self->{$key} ||= File::Spec->tmpdir(); return $self->{$key}; } #---------------------------------------------------------------------- =head2 template Arg [1] : string (optional) Function : Accessor for the statefile template. Defaults to XXXXXXXX Returntype: string Exceptions: Caller : Example : $obj->workdir('RES_XXXXXXXX'); =cut sub template { my $key = '_template'; my $self = shift; if( @_ ){ $self->{$key} = shift } $self->{$key} ||= 'XXXXXXXX'; return $self->{$key}; } #---------------------------------------------------------------------- =head2 suffix Arg [1] : string (optional) Function : Accessor for the statefile template. Returntype: string Exceptions: Caller : Example : $obj->suffix('.state'); =cut sub suffix { my $key = '_suffix'; my $self = shift; if( @_ ){ $self->{$key} = shift } return $self->{$key}; } #---------------------------------------------------------------------- =head2 new_retrievable Arg [1] : Same as for 'new' Function : Similar to store, except returns a 'skeleton' of the calling object, rather than the statefile. The skeleton can be repopulated by calling 'retrieve'. This will be a clone of the original object. Returntype: Bio::Root::Storable inhereting object Exceptions: Caller : Example : my $skel = $obj->new_retrievable(); # skeleton $skel->retrieve(); # clone =cut sub new_retrievable{ my $self = shift; my @args = @_; $self->_initialise_storable( @args ); if( $self->retrievable ){ return $self->clone } # Clone retrievable return bless( { _statefile => $self->store(@args), _workdir => $self->workdir, _suffix => $self->suffix, _template => $self->template, _retrievable => 1 }, ref( $self ) ); } #---------------------------------------------------------------------- =head2 retrievable Arg [1] : none Function : Reports whether the object is in 'skeleton' state, and the 'retrieve' method can be called. Returntype: boolean Exceptions: Caller : Example : if( $obj->retrievable ){ $obj->retrieve } =cut sub retrievable { my $self = shift; if( @_ ){ $self->{_retrievable} = shift } return $self->{_retrievable}; } #---------------------------------------------------------------------- =head2 token Arg [1] : None Function : Accessor for token attribute Returntype: string. Whatever retrieve needs to retrieve. This base implementation returns the statefile Exceptions: Caller : Example : my $token = $obj->token(); =cut sub token{ my $self = shift; return $self->statefile; } #---------------------------------------------------------------------- =head2 store Arg [1] : none Function : Saves a serialised representation of the object structure to disk. Returns the name of the file that the object was saved to. Returntype: string Exceptions: Caller : Example : my $token = $obj->store(); =cut sub store{ my $self = shift; my $statefile = $self->statefile; my $store_obj = $self->serialise; my $io = Bio::Root::IO->new( ">$statefile" ); $io->_print( $store_obj ); $self->debug( "STORING $self to $statefile\n" ); return $statefile; } #---------------------------------------------------------------------- =head2 serialise Arg [1] : none Function : Prepares the the serialised representation of the object. Object attribute names starting with '__' are skipped. This is useful for those that do not serialise too well (e.g. filehandles). Attributes are examined for other storable objects. If these are found they are serialised separately using 'new_retrievable' Returntype: string Exceptions: Caller : Example : my $serialised = $obj->serialise(); =cut sub serialise{ my $self = shift; # Create a new object of same class that is going to be serialised my $store_obj = bless( {}, ref( $self ) ); my %retargs = ( -workdir =>$self->workdir, -suffix =>$self->suffix, -template=>$self->template ); # Assume that other storable bio objects held by this object are # only 1-deep. foreach my $key( keys( %$self ) ){ if( $key =~ /^__/ ){ next } # Ignore keys starting with '__' my $value = $self->{$key}; # Scalar value if( ! ref( $value ) ){ $store_obj->{$key} = $value; } # Bio::Root::Storable obj: save placeholder elsif( ref($value) =~ /^Bio::/ and $value->isa('Bio::Root::Storable') ){ # Bio::Root::Storable $store_obj->{$key} = $value->new_retrievable( %retargs ); next; } # Arrayref value. Look for Bio::Root::Storable objs elsif( ref( $value ) eq 'ARRAY' ){ my @ary; foreach my $val( @$value ){ if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){ push( @ary, $val->new_retrievable( %retargs ) ); } else{ push( @ary, $val ) } } $store_obj->{$key} = \@ary; } # Hashref value. Look for Bio::Root::Storable objs elsif( ref( $value ) eq 'HASH' ){ my %hash; foreach my $k2( keys %$value ){ my $val = $value->{$k2}; if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){ $hash{$k2} = $val->new_retrievable( %retargs ); } else{ $hash{$k2} = $val } } $store_obj->{$key} = \%hash; } # Unknown, just add to the store object regardless else{ $store_obj->{$key} = $value } } $store_obj->retrievable(0); # Once deserialised, obj not retrievable return $self->_freeze( $store_obj ); } #---------------------------------------------------------------------- =head2 retrieve Arg [1] : string; filesystem location of the state file to be retrieved Function : Retrieves a stored object from disk. Note that the retrieved object will be blessed into its original class, and not the Returntype: Bio::Root::Storable inhereting object Exceptions: Caller : Example : my $obj = Bio::Root::Storable->retrieve( $token ); =cut sub retrieve{ my( $caller, $statefile ) = @_; my $self = {}; my $class = ref( $caller ) || $caller; # Is this a call on a retrievable object? if( ref( $caller ) and $caller->retrievable ){ $self = $caller; $statefile = $self->statefile; } bless( $self, $class ); # Recover serialised object if( ! -f $statefile ){ $self->throw( "Token $statefile is not found" ); } my $io = Bio::Root::IO->new( $statefile ); local $/ = undef(); my $state_str = $io->_readline('-raw'=>1); # Dynamic-load modules required by stored object my $stored_obj; my $success; for( my $i=0; $i<10; $i++ ){ eval{ $stored_obj = $self->_thaw( $state_str ) }; if( ! $@ ){ $success=1; last } my $package; if( $@ =~ /Cannot restore overloading(.*)/i ){ my $postmatch = $1; #' if( $postmatch =~ /\(package +([\w\:]+)\)/ ) { $package = $1; } } if( $package ){ eval "require $package"; $self->throw($@) if $@; } else{ $self->throw($@) } } if( ! $success ){ $self->throw("maximum number of requires exceeded" ) } if( ! ref( $stored_obj ) ){ $self->throw( "Token $statefile returned no data" ); } map{ $self->{$_} = $stored_obj->{$_} } keys %$stored_obj; # Copy hasheys $self->retrievable(0); # Maintain class of stored obj return $self; } #---------------------------------------------------------------------- =head2 clone Arg [1] : none Function : Returns a clone of the calling object Returntype: Bio::Root::Storable inhereting object Exceptions: Caller : Example : my $clone = $obj->clone(); =cut sub clone { my $self = shift; my $frozen = $self->_freeze( $self ); return $self->_thaw( $frozen ); } #---------------------------------------------------------------------- =head2 remove Arg [1] : none Function : Clears the stored object from disk Returntype: boolean Exceptions: Caller : Example : $obj->remove(); =cut sub remove { my $self = shift; if( -e $self->statefile ){ unlink( $self->statefile ); } return 1; } #---------------------------------------------------------------------- =head2 _freeze Arg [1] : variable Function : Converts whatever is in the the arg into a string. Uses either Storable::freeze or Data::Dumper::Dump depending on the value of $Bio::Root::BINARY Returntype: Exceptions: Caller : Example : =cut sub _freeze { my $self = shift; my $data = shift; if( $BINARY ){ return freeze( $data ); } else{ $Data::Dumper::Purity = 1; return Data::Dumper->Dump( [\$data],["*code"] ); } } #---------------------------------------------------------------------- =head2 _thaw Arg [1] : string Function : Converts the string into a perl 'whatever'. Uses either Storable::thaw or eval depending on the value of $Bio::Root::BINARY. Note; the string arg should have been created with the _freeze method, or strange things may occur! Returntype: variable Exceptions: Caller : Example : =cut sub _thaw { my $self = shift; my $data = shift; if( $BINARY ){ return thaw( $data ) } else{ my $code; $code = eval( $data ) ; if($@) { $self->throw( "eval: $@" ); } ref( $code ) eq 'REF' || $self->throw( "Serialised string was not a scalar ref" ); return $$code; } } #---------------------------------------------------------------------- 1; BioPerl-1.6.923/Bio/Root/Test.pm000444000765000024 4464412254227325 16405 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Root::Test # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Root::Test - A common base for all Bioperl test scripts. =head1 SYNOPSIS use lib '.'; # (for core package tests only) use Bio::Root::Test; test_begin(-tests => 20, -requires_modules => [qw(IO::String XML::Parser)], -requires_networking => 1); my $do_network_tests = test_network(); my $output_debugging = test_debug(); # Bio::Root::Test rewraps Test::Most, so one can carry out tests with # Test::More, Test::Exception, Test::Warn, Test::Deep, Test::Diff syntax SKIP: { # these tests need version 2.6 of Optional::Module to work test_skip(-tests => 10, -requires_module => 'Optional::Module 2.6'); use_ok('Optional::Module'); # 9 other optional tests that need Optional::Module } SKIP: { test_skip(-tests => 10, -requires_networking => 1); # 10 optional tests that require internet access (only makes sense in the # context of a script that doesn't use -requires_networking in the call to # &test_begin) } # in unix terms, we want to test with a file t/data/input_file.txt my $input_file = test_input_file('input_file.txt'); # we want the name of a file we can write to, that will be automatically # deleted when the test script finishes my $output_file = test_output_file(); # we want the name of a directory we can store files in, that will be # automatically deleted when the test script finishes my $output_dir = test_output_dir(); =head1 DESCRIPTION This provides a common base for all BioPerl test scripts. It safely handles the loading of Test::Most, itself a simple wrapper around several highly used test modules: Test::More, Test::Exception, Test::Warn, Test::Deep, and Test::Diff. It also presents an interface to common needs such as skipping all tests if required modules aren't present or if network tests haven't been enabled. See test_begin(). In the same way, it allows you to skip just a subset of tests for those same reasons, in addition to requiring certain executables and environment variables. See test_skip(). It also has two further methods that let you decide if network tests should be run, and if debugging information should be printed. See test_network() and test_debug(). Finally, it presents a consistent way of getting the path to input and output files. See test_input_file(), test_output_file() and test_output_dir(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Chris Fields cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Root::Test; use strict; use warnings; # According to Ovid, 'use base' can override signal handling, so use # old-fashioned way. This should be a Test::Builder::Module subclass # for consistency (as are any Test modules) use Test::Most; use Test::Builder; use Test::Builder::Module; use File::Temp qw(tempdir); use File::Spec; our @ISA = qw(Test::Builder::Module); # TODO: Evil magic ahead; can we clean this up? { my $Tester = Test::Builder->new; no warnings 'redefine'; sub Test::Warn::_canonical_got_warning { my ($called_from, $msg) = @_; my $warn_kind = $called_from eq 'Carp' ? 'carped' : ($called_from =~ /Bio::/ ? 'Bioperl' : 'warn'); my $warning; if ($warn_kind eq 'Bioperl') { ($warning) = $msg =~ /\n--------------------- WARNING ---------------------\nMSG: (.+)\n---------------------------------------------------\n$/m; $warning ||= $msg; # shouldn't ever happen } else { my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included $warning = $warning_stack[0]; } return {$warn_kind => $warning}; # return only the real message } sub Test::Warn::_diag_found_warning { foreach (@_) { if (ref($_) eq 'HASH') { ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}") : (${$_}{Bioperl} ? $Tester->diag("found Bioperl warning: ${$_}{Bioperl}") : $Tester->diag("found warning: ${$_}{warn}")); } else { $Tester->diag( "found warning: $_" ); } } $Tester->diag( "didn't find a warning" ) unless @_; } sub Test::Warn::_cmp_got_to_exp_warning { my ($got_kind, $got_msg) = %{ shift() }; my ($exp_kind, $exp_msg) = %{ shift() }; return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); my $cmp; if ($got_kind eq 'Bioperl') { $cmp = $got_msg =~ /^\Q$exp_msg\E$/; } else { $cmp = $got_msg =~ /^\Q$exp_msg\E at \S+ line \d+\.?$/; } return $cmp; } } our @EXPORT = (@Test::Most::EXPORT, #@Bio::Root::Test::Warn::EXPORT, # Test::Warn method wrappers # BioPerl-specific qw( test_begin test_skip test_output_file test_output_dir test_input_file test_network test_email test_debug float_is )); our $GLOBAL_FRAMEWORK = 'Test::Most'; our @TEMP_FILES; =head2 test_begin Title : test_begin Usage : test_begin(-tests => 20); Function: Begin your test script, setting up the plan (skip all tests, or run them all) Returns : True if tests should be run. Args : -tests => int (REQUIRED, the number of tests that will be run) -requires_modules => [] (array ref of module names that are required; if any don't load, all tests will be skipped. To specify a required version of a module, include the version number after the module name, separated by a space) -requires_module => str (as above, but for just one module) -requires_networking => 1|0 (default 0, if true all tests will be skipped if network tests haven't been enabled in Build.PL) -requires_email => 1 (if true the desired number of tests will be skipped if either network tests haven't been enabled in Build.PL or an email hasn't been entered) -excludes_os => str (default none, if OS suppied, all tests will skip if running on that OS (eg. 'mswin')) -framework => str (default 'Test::Most', the Test module to load. NB: experimental, avoid using) Note, supplying -tests => 0 is possible, allowing you to skip all tests in the case that a test script is testing deprecated modules that have yet to be removed from the distribution =cut sub test_begin { my ($skip_all, $tests, $framework) = _skip(@_); $GLOBAL_FRAMEWORK = $framework; if ($framework eq 'Test::Most') { # ideally we'd delay loading Test::Most until this point, but see BEGIN # block if ($skip_all) { eval "plan skip_all => '$skip_all';"; } elsif (defined $tests && $tests == 0) { eval "plan skip_all => 'All tests are being skipped, probably because the module(s) being tested here are now deprecated';"; } elsif ($tests) { eval "plan tests => $tests;"; } return 1; } # go ahead and add support for other frameworks here else { die "Only Test::Most is supported at the current time\n"; } return 0; } =head2 test_skip Title : test_skip Usage : SKIP: { test_skip(-tests => 10, -requires_module => 'Optional::Module 2.01'); # 10 tests that need v2.01 of Optional::Module } Function: Skip a subset of tests for one of several common reasons: missing one or more optional modules, network tests haven't been enabled, a required binary isn't present, or an environmental variable isn't set Returns : n/a Args : -tests => int (REQUIRED, the number of tests that are to be skipped in the event one of the following options isn't satisfied) -requires_modules => [] (array ref of module names that are required; if any don't load, the desired number of tests will be skipped. To specify a required version of a module, include the version number after the module name, separated by a space) -requires_module => str (as above, but for just one module) -requires_executable => Bio::Tools::Run::WrapperBase instance (checks WrapperBase::executable for the presence of a binary, skips if absent) -requires_env => str (checks %ENV for a specific env. variable, skips if absent) -excludes_os => str (default none, if OS suppied, desired num of tests will skip if running on that OS (eg. 'mswin')) -requires_networking => 1 (if true the desired number of tests will be skipped if network tests haven't been enabled in Build.PL) -requires_email => 1 (if true the desired number of tests will be skipped if either network tests haven't been enabled in Build.PL or an email hasn't been entered) =cut sub test_skip { my ($skip, $tests, $framework) = _skip(@_); $tests || die "-tests must be a number greater than 0"; if ($framework eq 'Test::Most') { if ($skip) { eval "skip('$skip', $tests);"; } } # go ahead and add support for other frameworks here else { die "Only Test::Most is supported at the current time\n"; } } =head2 test_output_file Title : test_output_file Usage : my $output_file = test_output_file(); Function: Get the full path of a file suitable for writing to. When your test script ends, the file will be automatically deleted. Returns : string (file path) Args : none =cut sub test_output_file { die "test_output_file takes no args\n" if @_; # RT 48813 my $tmp = File::Temp->new(); push(@TEMP_FILES, $tmp); close($tmp); # Windows needs this return $tmp->filename; } =head2 test_output_dir Title : test_output_dir Usage : my $output_dir = test_output_dir(); Function: Get the full path of a directory suitable for storing temporary files in. When your test script ends, the directory and its contents will be automatically deleted. Returns : string (path) Args : none =cut sub test_output_dir { die "test_output_dir takes no args\n" if @_; return tempdir(CLEANUP => 1); } =head2 test_input_file Title : test_input_file Usage : my $input_file = test_input_file(); Function: Get the path of a desired input file stored in the standard location (currently t/data), but correct for all platforms. Returns : string (file path) Args : list of strings (ie. at least the input filename, preceded by the names of any subdirectories within t/data) eg. for the file t/data/in.file pass 'in.file', for the file t/data/subdir/in.file, pass ('subdir', 'in.file') =cut sub test_input_file { return File::Spec->catfile('t', 'data', @_); } =head2 test_network Title : test_network Usage : my $do_network_tests = test_network(); Function: Ask if network tests should be run. Returns : boolean Args : none =cut sub test_network { require Module::Build; my $build = Module::Build->current(); return $build->notes('network'); } =head2 test_email Title : test_email Usage : my $do_network_tests = test_email(); Function: Ask if email address provided Returns : boolean Args : none =cut sub test_email { require Module::Build; my $build = Module::Build->current(); # this should not be settable unless the network tests work return $build->notes('email'); } =head2 test_debug Title : test_debug Usage : my $output_debugging = test_debug(); Function: Ask if debugging information should be output. Returns : boolean Args : none =cut sub test_debug { return $ENV{'BIOPERLDEBUG'} || 0; } =head2 float_is Title : float_is Usage : float_is($val1, $val2); Function: test two floating point values for equality Returns : Boolean based on test (can use in combination with diag) Args : two scalar values (floating point numbers) (required via prototype) test message (optional) =cut sub float_is ($$;$) { my ($val1, $val2, $message) = @_; # catch any potential undefined values and directly compare if (!defined $val1 || !defined $val2) { is($val1, $val2 ,$message); } else { is(sprintf("%g",$val1), sprintf("%g",$val2),$message); } } # decide if should skip and generate skip message sub _skip { my %args = @_; # handle input strictly my $tests = $args{'-tests'}; #(defined $tests && $tests =~ /^\d+$/) || die "-tests must be supplied and be an int\n"; delete $args{'-tests'}; my $req_mods = $args{'-requires_modules'}; delete $args{'-requires_modules'}; my @req_mods; if ($req_mods) { ref($req_mods) eq 'ARRAY' || die "-requires_modules takes an array ref\n"; @req_mods = @{$req_mods}; } my $req_mod = $args{'-requires_module'}; delete $args{'-requires_module'}; if ($req_mod) { ref($req_mod) && die "-requires_module takes a string\n"; push(@req_mods, $req_mod); } my $req_net = $args{'-requires_networking'}; delete $args{'-requires_networking'}; my $req_email = $args{'-requires_email'}; delete $args{'-requires_email'}; my $req_env = $args{'-requires_env'}; delete $args{'-requires_env'}; # strip any leading $ in case someone passes $FOO instead of 'FOO' $req_env =~ s{^\$}{} if $req_env; my $req_exe = $args{'-requires_executable'}; delete $args{'-requires_executable'}; if ($req_exe && (!ref($req_exe) || !$req_exe->isa('Bio::Tools::Run::WrapperBase'))) { die "-requires_exe takes an argument of type Bio::Tools::Run::WrapperBase"; } my $os = $args{'-excludes_os'}; delete $args{'-excludes_os'}; my $framework = $args{'-framework'} || $GLOBAL_FRAMEWORK; delete $args{'-framework'}; # catch user mistakes while (my ($key, $val) = each %args) { die "unknown argument '$key' supplied, did you mistake 'required...' for 'requires...'?\n"; } # test user requirments and return if ($os) { if ($^O =~ /$os/i) { return ('Not compatible with your Operating System', $tests, $framework); } } foreach my $mod (@req_mods) { my $skip = _check_module($mod); if ($skip) { return ($skip, $tests, $framework); } } if ($req_net && ! test_network()) { return ('Network tests have not been requested', $tests, $framework); } if ($req_email && ! test_email()) { return ('Valid email not provided; required for tests', $tests, $framework); } if ($req_exe) { eval {$req_exe->executable}; if ($@) { my $msg = 'Required executable for '.ref($req_exe).' is not present'; diag($msg); return ($msg, $tests, $framework); } } if ($req_env && !exists $ENV{$req_env}) { my $msg = 'Required environment variable $'.$req_env. ' is not set'; diag($msg); return ($msg, $tests, $framework); } return ('', $tests, $framework); } sub _check_module { my $mod = shift; my $desired_version; if ($mod =~ /(\S+)\s+(\S+)/) { $mod = $1; $desired_version = $2; } eval "require $mod;"; if ($@) { if ($@ =~ /Can't locate/) { return "The optional module $mod (or dependencies thereof) was not installed"; } else { return "The optional module $mod generated the following error: \n$@"; } } elsif ($desired_version) { no strict 'refs'; unless (defined ${"${mod}::VERSION"}) { return "The optional module $mod didn't have a version, but we want v$desired_version"; } elsif (${"${mod}::VERSION"} < $desired_version) { return "The optional module $mod was out of date (wanted v$desired_version)"; } } return; } 1; BioPerl-1.6.923/Bio/Root/Utilities.pm000444000765000024 12735012254227323 17453 0ustar00cjfieldsstaff000000000000package Bio::Root::Utilities; use strict; =head1 NAME Bio::Root::Utilities - General-purpose utility module =head1 SYNOPSIS =head2 Object Creation # Using the supplied singleton object: use Bio::Root::Utilities qw(:obj); $Util->some_method(); # Create an object manually: use Bio::Root::Utilities; my $util = Bio::Root::Utilities->new(); $util->some_method(); $date_stamp = $Util->date_format('yyy-mm-dd'); $clean = $Util->untaint($dirty); $compressed = $Util->compress('/home/me/myfile.txt') my ($mean, $stdev) = $Util->mean_stdev( @data ); $Util->authority("me@example.com"); $Util->mail_authority("Something you should know about..."); ...and a host of other methods. See below. =head1 DESCRIPTION Provides general-purpose utilities of potential interest to any Perl script. The C<:obj> tag is a convenience that imports a $Util symbol into your namespace representing a Bio::Root::Utilities object. This saves you from creating your own Bio::Root::Utilities object via Cnew()> or from prefixing all method calls with C, though feel free to do these things if desired. Since there should normally not be a need for a script to have more than one Bio::Root::Utilities object, this module thus comes with it's own singleton. =head1 INSTALLATION This module is included with the central Bioperl distribution: http://www.bioperl.org/wiki/Getting_BioPerl ftp://bio.perl.org/pub/DIST Follow the installation instructions included in the README file. =head1 DEPENDENCIES Inherits from L, and uses L and L. Relies on external executables for file compression/uncompression and sending mail. No paths to these are hard coded but are located as needed. =head1 SEE ALSO http://bioperl.org - Bioperl Project Homepage =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 ACKNOWLEDGEMENTS This module was originally developed under the auspices of the Saccharomyces Genome Database: http://www.yeastgenome.org/ =head1 COPYRIGHT Copyright (c) 1996-2007 Steve Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut =head1 APPENDIX Methods beginning with a leading underscore are considered private and are intended for internal use by this module. They are B considered part of the public interface and are described here for documentation purposes only. =cut # Let the code begin... use Bio::Root::IO; use Bio::Root::Exception; use vars qw(@EXPORT_OK %EXPORT_TAGS); use base qw(Bio::Root::Root Exporter); @EXPORT_OK = qw($Util); %EXPORT_TAGS = ( obj => [qw($Util)], std => [qw($Util)],); use vars qw($ID $Util $GNU_PATH $TIMEOUT_SECS @COMPRESSION_UTILS @UNCOMPRESSION_UTILS $DEFAULT_NEWLINE $NEWLINE $AUTHORITY @MONTHS @DAYS $BASE_YEAR $DEFAULT_CENTURY ); $ID = 'Bio::Root::Utilities'; # Number of seconds to wait before timing out when reading input (taste_file()) $TIMEOUT_SECS = 30; $NEWLINE = $ENV{'NEWLINE'} || undef; $BASE_YEAR = 1900; # perl's localtime() assumes this for it's year data. # TODO: update this every hundred years. Y2K-sensitive code. $DEFAULT_CENTURY = $BASE_YEAR + 100; @MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); @DAYS = qw(Sun Mon Tue Wed Thu Fri Sat); # Sets the preference for compression utilities to be used by compress(). # The first executable in this list to be found in the current PATH will be used, # unless overridden in the call to that function. See docs for details. @COMPRESSION_UTILS = qw(gzip bzip2 zip compress); @UNCOMPRESSION_UTILS = qw(gunzip bunzip2 unzip uncompress); # Default person to receive feedback from users and possibly automatic error messages. $AUTHORITY = ''; # Note: $GNU_PATH is now deprecated, shouldn't be needed since now this module # will automatically locate the compression utility in the current PATH. # Retaining $GNU_PATH for backward compatibility. # # $GNU_PATH points to the directory containing the gzip and gunzip # executables. It may be required for executing gzip/gunzip # in some situations (e.g., when $ENV{PATH} doesn't contain this dir. # Customize $GNU_PATH for your site if the compress() or # uncompress() functions are generating exceptions. $GNU_PATH = ''; #$GNU_PATH = '/tools/gnu/bin/'; $DEFAULT_NEWLINE = "\012"; # \n (used if get_newline() fails for some reason) ## Static UTIL object. $Util = Bio::Root::Root->new(); =head2 date_format Title : date_format Usage : $Util->date_format( [FMT], [DATE]) Purpose : -- Get a string containing the formated date or time : taken when this routine is invoked. : -- Provides a way to avoid using `date`. : -- Provides an interface to localtime(). : -- Interconverts some date formats. : : (For additional functionality, use Date::Manip or : Date::DateCalc available from CPAN). Example : $Util->date_format(); : $date = $Util->date_format('yyyy-mmm-dd', '11/22/92'); Returns : String (unless 'list' is provided as argument, see below) : : 'yyyy-mm-dd' = 1996-05-03 # default format. : 'yyyy-dd-mm' = 1996-03-05 : 'yyyy-mmm-dd' = 1996-May-03 : 'd-m-y' = 3-May-1996 : 'd m y' = 3 May 1996 : 'dmy' = 3may96 : 'mdy' = May 3, 1996 : 'ymd' = 96may3 : 'md' = may3 : 'year' = 1996 : 'hms' = 23:01:59 # when not converting a format, 'hms' can be : # tacked on to any of the above options : # to add the time stamp: eg 'dmyhms' : 'full' | 'unix' = UNIX-style date: Tue May 5 22:00:00 1998 : 'list' = the contents of localtime(time) in an array. Argument : (all are optional) : FMT = yyyy-mm-dd | yyyy-dd-mm | yyyy-mmm-dd | : mdy | ymd | md | d-m-y | hms | hm : ('hms' may be appended to any of these to : add a time stamp) : : DATE = String containing date to be converted. : Acceptable input formats: : 12/1/97 (for 1 December 1997) : 1997-12-01 : 1997-Dec-01 Throws : Comments : If you don't care about formatting or using backticks, you can : always use: $date = `date`; : : For more features, use Date::Manip.pm, (which I should : probably switch to...) See Also : L, L =cut #---------------' sub date_format { #--------------- my $self = shift; my $option = shift; my $date = shift; # optional date to be converted. my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst); $option ||= 'yyyy-mm-dd'; my ($month_txt, $day_txt, $month_num, $fullYear); my ($converting, @date); # Load a supplied date for conversion: if(defined($date) && ($date =~ /[\D-]+/)) { $converting = 1; if( $date =~ m{/}) { ($mon,$mday,$year) = split(m{/}, $date); } elsif($date =~ /(\d{4})-(\d{1,2})-(\d{1,2})/) { ($year,$mon,$mday) = ($1, $2, $3); } elsif($date =~ /(\d{4})-(\w{3,})-(\d{1,2})/) { ($year,$mon,$mday) = ($1, $2, $3); $mon = $self->month2num($2); } else { print STDERR "\n*** Unsupported input date format: $date\n"; } if(length($year) == 4) { $fullYear = $year; $year = substr $year, 2; } else { # Heuristics to guess what century was intended when a 2-digit year is given # If number is over 50, assume it's for prev century; under 50 = default century. # TODO: keep an eye on this Y2K-sensitive code if ($year > 50) { $fullYear = $DEFAULT_CENTURY + $year - 100; } else { $fullYear = $DEFAULT_CENTURY + $year; } } $mon -= 1; } else { ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @date = localtime(($date ? $date : time())); return @date if $option =~ /list/i; $fullYear = $BASE_YEAR+$year; } $month_txt = $MONTHS[$mon]; $day_txt = $DAYS[$wday] if defined $wday; $month_num = $mon+1; # print "sec: $sec, min: $min, hour: $hour, month: $mon, m-day: $mday, year: $year\nwday: $wday, yday: $yday, dst: $isdst";; if( $option =~ /yyyy-mm-dd/i ) { $date = sprintf "%4d-%02d-%02d",$fullYear,$month_num,$mday; } elsif( $option =~ /yyyy-dd-mm/i ) { $date = sprintf "%4d-%02d-%02d",$fullYear,$mday,$month_num; } elsif( $option =~ /yyyy-mmm-dd/i ) { $date = sprintf "%4d-%3s-%02d",$fullYear,$month_txt,$mday; } elsif( $option =~ /full|unix/i ) { $date = sprintf "%3s %3s %2d %02d:%02d:%02d %d",$day_txt, $month_txt, $mday, $hour, $min, $sec, $fullYear; } elsif( $option =~ /mdy/i ) { $date = "$month_txt $mday, $fullYear"; } elsif( $option =~ /ymd/i ) { $date = $year."\l$month_txt$mday"; } elsif( $option =~ /dmy/i ) { $date = $mday."\l$month_txt$year"; } elsif( $option =~ /md/i ) { $date = "\l$month_txt$mday"; } elsif( $option =~ /d-m-y/i ) { $date = "$mday-$month_txt-$fullYear"; } elsif( $option =~ /d m y/i ) { $date = "$mday $month_txt $fullYear"; } elsif( $option =~ /year/i ) { $date = $fullYear; } elsif( $option =~ /dmy/i ) { $date = $mday.'-'.$month_txt.'-'.$fullYear; } elsif($option and $option !~ /hms/i) { print STDERR "\n*** Unrecognized date format request: $option\n"; } if( $option =~ /hms/i and not $converting) { $date .= " $hour:$min:$sec" if $date; $date ||= "$hour:$min:$sec"; } return $date || join(" ", @date); } =head2 month2num Title : month2num Purpose : Converts a string containing a name of a month to integer : representing the number of the month in the year. Example : $Util->month2num("march"); # returns 3 Argument : The string argument must contain at least the first : three characters of the month's name. Case insensitive. Throws : Exception if the conversion fails. =cut #--------------' sub month2num { #-------------- my ($self, $str) = @_; # Get string in proper format for conversion. $str = substr($str, 0, 3); for(0..$#MONTHS) { return $_+1 if $str =~ /$MONTHS[$_]/i; } $self->throw("Invalid month name: $str"); } =head2 num2month Title : num2month Purpose : Does the opposite of month2num. : Converts a number into a string containing a name of a month. Example : $Util->num2month(3); # returns 'Mar' Throws : Exception if supplied number is out of range. =cut #------------- sub num2month { #------------- my ($self, $num) = @_; $self->throw("Month out of range: $num") if $num < 1 or $num > 12; return $MONTHS[$num-1]; } =head2 compress Title : compress Usage : $Util->compress(full-path-filename); : $Util->compress(); Purpose : Compress a file. Example : $Util->compress("/usr/people/me/data.txt"); : $Util->compress(-file=>"/usr/people/me/data.txt", : -tmp=>1, : -outfile=>"/usr/people/share/data.txt.gz", : -exe=>"/usr/local/bin/fancyzip"); Returns : String containing full, absolute path to compressed file Argument : Named parameters (case-insensitive): : -FILE => String (name of file to be compressed, full path). : If the supplied filename ends with '.gz' or '.Z', : that extension will be removed before attempting to compress. : Optional: : -TMP => boolean. If true, (or if user is not the owner of the file) : the file is compressed to a temp file. If false, file may be : clobbered with the compressed version (if using a utility like : gzip, which is the default) : -OUTFILE => String (name of the output compressed file, full path). : -EXE => Name of executable for compression utility to use. : Will supercede those in @COMPRESSION_UTILS defined by : this module. If the absolute path to the executable is not provided, : it will be searched in the PATH env variable. Throws : Exception if file cannot be compressed. : If user is not owner of the file, generates a warning and compresses to : a tmp file. To avoid this warning, use the -o file test operator : and call this function with -TMP=>1. Comments : Attempts to compress using utilities defined in the @COMPRESSION_UTILS : defined by this module, in the order defined. The first utility that is : found to be executable will be used. Any utility defined in optional -EXE param : will be tested for executability first. : To minimize security risks, the -EXE parameter value is untained using : the untaint() method of this module (in 'relaxed' mode to permit path separators). See Also : L =cut #------------' sub compress { #------------ my ($self, @args) = @_; # This method formerly didn't use named params and expected fileName, tmp # in that order. This should be backward compatibile. my ($fileName, $tmp, $outfile, $exe) = $self->_rearrange([qw(FILE TMP OUTFILE EXE)], @args); my ($file, $get, $fmt); # in case the supplied name already has a compressed extension if($fileName =~ /(\.gz|\.Z|\.bz2|\.zip)$/) { $fileName =~ s/$1$//; }; $self->debug("compressing file $fileName"); my @util_to_use = @COMPRESSION_UTILS; if (defined $exe){ $exe = $self->untaint($exe, 1); unshift @util_to_use, $exe; } my @checked = @util_to_use; $exe ||= ''; while (not -x $exe and scalar(@util_to_use)) { $exe = $self->find_exe(shift @util_to_use); } unless (-x $exe) { $self->throw("Can't find compression utility. Looked for @checked"); } my ($compressed, @cmd, $handle); if(defined($outfile) or $tmp or not -o $fileName) { if (defined $outfile) { $compressed = $outfile; } else { # obtain a temporary file name (not using the handle) # and insert some special text to flag it as a bioperl-based temp file my $io = Bio::Root::IO->new(); ($handle, $compressed) = $io->tempfile(); $compressed .= '.tmp.bioperl.gz'; } if ($exe =~ /gzip|bzip2|compress/) { @cmd = ("$exe -f < \"$fileName\" > \"$compressed\""); } elsif ($exe eq 'zip') { @cmd = ("$exe -r \"$fileName.zip\" \"$fileName\""); } not $tmp and $self->warn("Not owner of file $fileName. Compressing to temp file $compressed."); $tmp = 1; } else { # Need to compute the compressed name based on exe since we're returning it. $compressed = $fileName; if ($exe =~ /gzip/) { $compressed .= '.gz'; } elsif ($exe =~ /bzip2/) { $compressed .= '.bz2'; } elsif ($exe =~ /zip/) { $compressed .= '.zip'; } elsif ($exe =~ /compress/) { $compressed .= '.Z'; } if ($exe =~ /gzip|bzip2|compress/) { @cmd = ($exe, '-f', $fileName); } elsif ($exe eq 'zip') { @cmd = ($exe, '-r', "$compressed", $fileName); } } if(system(@cmd) != 0) { $self->throw( -class => 'Bio::Root::SystemException', -text => "Failed to compress file $fileName using $exe: $!"); } return $compressed; } =head2 uncompress Title : uncompress Usage : $Util->uncompress(full-path-filename); : $Util->uncompress(); Purpose : Uncompress a file. Example : $Util->uncompress("/usr/people/me/data.txt"); : $Util->uncompress(-file=>"/usr/people/me/data.txt.gz", : -tmp=>1, : -outfile=>"/usr/people/share/data.txt", : -exe=>"/usr/local/bin/fancyzip"); Returns : String containing full, absolute path to uncompressed file Argument : Named parameters (case-insensitive): : -FILE => String (name of file to be uncompressed, full path). : If the supplied filename ends with '.gz' or '.Z', : that extension will be removed before attempting to uncompress. : Optional: : -TMP => boolean. If true, (or if user is not the owner of the file) : the file is uncompressed to a temp file. If false, file may be : clobbered with the uncompressed version (if using a utility like : gzip, which is the default) : -OUTFILE => String (name of the output uncompressed file, full path). : -EXE => Name of executable for uncompression utility to use. : Will supercede those in @UNCOMPRESSION_UTILS defined by : this module. If the absolute path to the executable is not provided, : it will be searched in the PATH env variable. Throws : Exception if file cannot be uncompressed. : If user is not owner of the file, generates a warning and uncompresses to : a tmp file. To avoid this warning, use the -o file test operator : and call this function with -TMP=>1. Comments : Attempts to uncompress using utilities defined in the @UNCOMPRESSION_UTILS : defined by this module, in the order defined. The first utility that is : found to be executable will be used. Any utility defined in optional -EXE param : will be tested for executability first. : To minimize security risks, the -EXE parameter value is untained using : the untaint() method of this module (in 'relaxed' mode to permit path separators). See Also : L =cut #------------' sub uncompress { #------------ my ($self, @args) = @_; # This method formerly didn't use named params and expected fileName, tmp # in that order. This should be backward compatibile. my ($fileName, $tmp, $outfile, $exe) = $self->_rearrange([qw(FILE TMP OUTFILE EXE)], @args); my ($file, $get, $fmt); # in case the supplied name lacks a compressed extension if(not $fileName =~ /(\.gz|\.Z|\.bz2|\.zip)$/) { $fileName .= $1; }; $self->debug("uncompressing file $fileName"); my @util_to_use = @UNCOMPRESSION_UTILS; if (defined $exe){ $exe = $self->untaint($exe, 1); unshift @util_to_use, $exe; } $exe ||= ''; while (not -x $exe and scalar(@util_to_use)) { $exe = $self->find_exe(shift @util_to_use); } unless (-x $exe) { $self->throw("Can't find compression utility. Looked for @util_to_use"); } my ($uncompressed, @cmd, $handle); $uncompressed = $fileName; $uncompressed =~ s/\.\w+$//; if(defined($outfile) or $tmp or not -o $fileName) { if (defined $outfile) { $uncompressed = $outfile; } else { # obtain a temporary file name (not using the handle) my $io = Bio::Root::IO->new(); ($handle, $uncompressed) = $io->tempfile(); # insert some special text to flag it as a bioperl-based temp file $uncompressed .= '.tmp.bioperl'; } if ($exe =~ /gunzip|bunzip2|uncompress/) { @cmd = ("$exe -f < \"$fileName\" > \"$uncompressed\""); } elsif ($exe eq 'unzip') { @cmd = ("$exe -p \"$fileName\" > \"$uncompressed\""); } not $tmp and $self->warn("Not owner of file $fileName. Uncompressing to temp file $uncompressed."); $tmp = 1; } else { if ($exe =~ /gunzip|bunzip2|uncompress/) { @cmd = ($exe, '-f', $fileName); } elsif ($exe eq 'zip') { @cmd = ($exe, $fileName); } } if(system(@cmd) != 0) { $self->throw( -class => 'Bio::Root::SystemException', -text => "Failed to uncompress file $fileName using $exe: $!"); } return $uncompressed; } =head2 file_date Title : file_date Usage : $Util->file_date( filename [,date_format]) Purpose : Obtains the date of a given file. : Provides flexible formatting via date_format(). Returns : String = date of the file as: yyyy-mm-dd (e.g., 1997-10-15) Argument : filename = string, full path name for file : date_format = string, desired format for date (see date_format()). : Default = yyyy-mm-dd Thows : Exception if no file is provided or does not exist. Comments : Uses the mtime field as obtained by stat(). =cut #-------------- sub file_date { #-------------- my ($self, $file, $fmt) = @_; $self->throw("No such file: $file") if not $file or not -e $file; $fmt ||= 'yyyy-mm-dd'; my @file_data = stat($file); return $self->date_format($fmt, $file_data[9]); # mtime field } =head2 untaint Title : untaint Purpose : To remove nasty shell characters from untrusted data : and allow a script to run with the -T switch. : Potentially dangerous shell meta characters: &;`'\"|*?!~<>^()[]{}$\n\r : Accept only the first block of contiguous characters: : Default allowed chars = "-\w.', ()" : If $relax is true = "-\w.', ()\/=%:^<>*" Usage : $Util->untaint($value, $relax) Returns : String containing the untained data. Argument: $value = string : $relax = boolean Comments: This general untaint() function may not be appropriate for every situation. To allow only a more restricted subset of special characters (for example, untainting a regular expression), then using a custom untainting mechanism would permit more control. Note that special trusted vars (like $0) require untainting. =cut #------------` sub untaint { #------------ my($self,$value,$relax) = @_; $relax ||= 0; my $untainted; $self->debug("\nUNTAINT: $value\n"); unless (defined $value and $value ne '') { return $value; } if( $relax ) { $value =~ /([-\w.\', ()\/=%:^<>*]+)/; $untainted = $1 # } elsif( $relax == 2 ) { # Could have several degrees of relax. # $value =~ /([-\w.\', ()\/=%:^<>*]+)/; # $untainted = $1 } else { $value =~ /([-\w.\', ()]+)/; $untainted = $1 } $self->debug("UNTAINTED: $untainted\n"); $untainted; } =head2 mean_stdev Title : mean_stdev Usage : ($mean, $stdev) = $Util->mean_stdev( @data ) Purpose : Calculates the mean and standard deviation given a list of numbers. Returns : 2-element list (mean, stdev) Argument : list of numbers (ints or floats) Thows : n/a =cut #--------------- sub mean_stdev { #--------------- my ($self, @data) = @_; return (undef,undef) if not @data; # case of empty @data list my $mean = 0; my $N = 0; foreach (@data) { $mean += $_; $N++ } $mean /= $N; my $sum_diff_sqd = 0; foreach (@data) { $sum_diff_sqd += ($mean - $_) * ($mean - $_); } # if only one element in @data list, unbiased stdev is undefined my $stdev = $N <= 1 ? undef : sqrt( $sum_diff_sqd / ($N-1) ); return ($mean, $stdev); } =head2 count_files Title : count_files Purpose : Counts the number of files/directories within a given directory. : Also reports the number of text and binary files in the dir : as well as names of these files and directories. Usage : count_files(\%data) : $data{-DIR} is the directory to be analyzed. Default is ./ : $data{-PRINT} = 0|1; if 1, prints results to STDOUT, (default=0). Argument : Hash reference (empty) Returns : n/a; : Modifies the hash ref passed in as the sole argument. : $$href{-TOTAL} scalar : $$href{-NUM_TEXT_FILES} scalar : $$href{-NUM_BINARY_FILES} scalar : $$href{-NUM_DIRS} scalar : $$href{-T_FILE_NAMES} array ref : $$href{-B_FILE_NAMES} array ref : $$href{-DIRNAMES} array ref =cut #---------------- sub count_files { #---------------- my $self = shift; my $href = shift; # Reference to an empty hash. my( $name, @fileLine); my $dir = $$href{-DIR} || './'; # THIS IS UNIX SPECIFIC? FIXME/TODO my $print = $$href{-PRINT} || 0; ### Make sure $dir ends with / $dir !~ m{/$} and do{ $dir .= '/'; $$href{-DIR} = $dir; }; open ( my $PIPE, "ls -1 $dir |" ) || $self->throw("Can't open input pipe: $!"); ### Initialize the hash data. $$href{-TOTAL} = 0; $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} = $$href{-NUM_DIRS} = 0; $$href{-T_FILE_NAMES} = []; $$href{-B_FILE_NAMES} = []; $$href{-DIR_NAMES} = []; while( <$PIPE> ) { chomp(); $$href{-TOTAL}++; if( -T $dir.$_ ) { $$href{-NUM_TEXT_FILES}++; push @{$$href{-T_FILE_NAMES}}, $_; } if( -B $dir.$_ and not -d $dir.$_) { $$href{-NUM_BINARY_FILES}++; push @{$$href{-B_FILE_NAMES}}, $_; } if( -d $dir.$_ ) { $$href{-NUM_DIRS}++; push @{$$href{-DIR_NAMES}}, $_; } } close $PIPE; if( $print) { printf( "\n%4d %s\n", $$href{-TOTAL}, "total files+dirs in $dir"); printf( "%4d %s\n", $$href{-NUM_TEXT_FILES}, "text files"); printf( "%4d %s\n", $$href{-NUM_BINARY_FILES}, "binary files"); printf( "%4d %s\n", $$href{-NUM_DIRS}, "directories"); } } #=head2 file_info # # Title : file_info # Purpose : Obtains a variety of date for a given file. # : Provides an interface to Perl's stat(). # Status : Under development. Not ready. Don't use! # #=cut #-------------- sub file_info { #-------------- my ($self, %param) = @_; my ($file, $get, $fmt) = $self->_rearrange([qw(FILE GET FMT)], %param); $get ||= 'all'; $fmt ||= 'yyyy-mm-dd'; my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks) = stat $file; if($get =~ /date/i) { ## I can get the elapsed time since the file was modified but ## it's not so straightforward to get the date in a nice format... ## Think about using a standard CPAN module for this, like ## Date::Manip or Date::DateCalc. my $date = $mtime; my $elsec = time - $mtime; printf "\nFile age: %.0f sec %.0f hrs %.0f days", $elsec, $elsec/3600, $elsec/(3600*24);; my $days = sprintf "%.0f", $elsec/(3600*24); } elsif($get eq 'all') { return stat $file; } } #------------ sub delete { #------------ my $self = shift; my $fileName = shift; if(not -e $fileName) { $self->throw("Can't delete file $fileName: Does not exist."); } elsif(not -o $fileName) { $self->throw("Can't delete file $fileName: Not owner."); } my $ulval = unlink($fileName) > 0 or $self->throw("Failed to delete file $fileName: $!"); } =head2 create_filehandle Usage : $object->create_filehandle(); Purpose : Create a FileHandle object from a file or STDIN. : Mainly used as a helper method by read() and get_newline(). Example : $data = $object->create_filehandle(-FILE =>'usr/people/me/data.txt') Argument : Named parameters (case-insensitive): : (all optional) : -CLIENT => object reference for the object submitting : the request. Default = $Util. : -FILE => string (full path to file) or a reference : to a FileHandle object or typeglob. This is an : optional parameter (if not defined, STDIN is used). Returns : Reference to a FileHandle object. Throws : Exception if cannot open a supplied file or if supplied with a : reference that is not a FileHandle ref. Comments : If given a FileHandle reference, this method simply returns it. : This method assumes the user wants to read ascii data. So, if : the file is binary, it will be treated as a compressed (gzipped) : file and access it using gzip -ce. The problem here is that not : all binary files are necessarily compressed. Therefore, : this method should probably have a -mode parameter to : specify ascii or binary. See Also : L =cut #--------------------- sub create_filehandle { #--------------------- my($self, @param) = @_; my($client, $file, $handle) = $self->_rearrange([qw( CLIENT FILE HANDLE )], @param); if(not ref $client) { $client = $self; } $file ||= $handle; if( $client->can('file')) { $file = $client->file($file); } my $FH; my ($handle_ref); if($handle_ref = ref($file)) { if($handle_ref eq 'FileHandle') { $FH = $file; $client->{'_input_type'} = "FileHandle"; } elsif($handle_ref eq 'GLOB') { $FH = $file; $client->{'_input_type'} = "Glob"; } else { $self->throw(-class=>'Bio::Root::IOException', -text =>"Can't read from $file: Not a FileHandle or GLOB ref."); } $self->verbose > 0 and printf STDERR "$ID: reading data from FileHandle\n"; } elsif($file) { $client->{'_input_type'} = "FileHandle for $file"; # Use gzip -cd to access compressed data. if( -B $file ) { $client->{'_input_type'} .= " (compressed)"; my $gzip = $self->find_exe('gzip'); $file = "$gzip -cd $file |" } require FileHandle; $FH = FileHandle->new(); open ($FH, $file) || $self->throw(-class=>'Bio::Root::FileOpenException', -text =>"Can't access data file: $file: $!"); $self->verbose > 0 and printf STDERR "$ID: reading data from file $file\n"; } else { # Read from STDIN. $FH = \*STDIN; $self->verbose > 0 and printf STDERR "$ID: reading data from STDIN\n"; $client->{'_input_type'} = "STDIN"; } return $FH; } =head2 get_newline Usage : $object->get_newline(); Purpose : Determine the character(s) used for newlines in a given file or : input stream. Delegates to Bio::Root::Utilities::get_newline() Example : $data = $object->get_newline(-CLIENT => $anObj, : -FILE =>'usr/people/me/data.txt') Argument : Same arguemnts as for create_filehandle(). Returns : Reference to a FileHandle object. Throws : Propogates any exceptions thrown by Bio::Root::Utilities::get_newline(). See Also : L, L =cut #----------------- sub get_newline { #----------------- my($self, @param) = @_; return $NEWLINE if defined $NEWLINE; my($client ) = $self->_rearrange([qw( CLIENT )], @param); my $FH = $self->create_filehandle(@param); if(not ref $client) { $client = $self; } if($client->{'_input_type'} =~ /STDIN|Glob|compressed/) { # Can't taste from STDIN since we can't seek 0 on it. # Are other non special Glob refs seek-able? # Attempt to guess newline based on platform. # Not robust since we could be reading Unix files on a Mac, e.g. if(defined $ENV{'MACPERL'}) { $NEWLINE = "\015"; # \r } else { $NEWLINE = "\012"; # \n } } else { $NEWLINE = $self->taste_file($FH); } close ($FH) unless ($client->{'_input_type'} eq 'STDIN' || $client->{'_input_type'} eq 'FileHandle' || $client->{'_input_type'} eq 'Glob' ); delete $client->{'_input_type'}; return $NEWLINE || $DEFAULT_NEWLINE; } =head2 taste_file Usage : $object->taste_file( ); : Mainly a utility method for get_newline(). Purpose : Sample a filehandle to determine the character(s) used for a newline. Example : $char = $Util->taste_file($FH) Argument : Reference to a FileHandle object. Returns : String containing an octal represenation of the newline character string. : Unix = "\012" ("\n") : Win32 = "\012\015" ("\r\n") : Mac = "\015" ("\r") Throws : Exception if no input is read within $TIMEOUT_SECS seconds. : Exception if argument is not FileHandle object reference. : Warning if cannot determine neewline char(s). Comments : Based on code submitted by Vicki Brown (vlb@deltagen.com). See Also : L =cut #--------------- sub taste_file { #--------------- my ($self, $FH) = @_; my $BUFSIZ = 256; # Number of bytes read from the file handle. my ($buffer, $octal, $str, $irs, $i); ref($FH) eq 'FileHandle' or $self->throw("Can't taste file: not a FileHandle ref"); $buffer = ''; # this is a quick hack to check for availability of alarm(); just copied # from Bio/Root/IOManager.pm HL 02/19/01 my $alarm_available = 1; eval { alarm(0); }; if($@) { # alarm() not available (ActiveState perl for win32 doesn't have it. # See jitterbug PR#98) $alarm_available = 0; } $SIG{ALRM} = sub { die "Timed out!"; }; my $result; eval { $alarm_available && alarm( $TIMEOUT_SECS ); $result = read($FH, $buffer, $BUFSIZ); # read the $BUFSIZ characters of file $alarm_available && alarm(0); }; if($@ =~ /Timed out!/) { $self->throw("Timed out while waiting for input.", "Timeout period = $TIMEOUT_SECS seconds.\nFor longer time before timing out, edit \$TIMEOUT_SECS in Bio::Root::Utilities.pm."); } elsif(not $result) { my $err = $@; $self->throw("read taste failed to read from FileHandle.", $err); } elsif($@ =~ /\S/) { my $err = $@; $self->throw("Unexpected error during read: $err"); } seek($FH, 0, 0) or $self->throw("seek failed to seek 0 on FileHandle."); my @chars = split(//, $buffer); my $flavor; for ($i = 0; $i <$BUFSIZ; $i++) { if (($chars[$i] eq "\012")) { unless ($chars[$i-1] eq "\015") { $flavor='Unix'; $octal = "\012"; $str = '\n'; $irs = "^J"; last; } } elsif (($chars[$i] eq "\015") && ($chars[$i+1] eq "\012")) { $flavor='DOS'; $octal = "\015\012"; $str = '\r\n'; $irs = "^M^J"; last; } elsif (($chars[$i] eq "\015")) { $flavor='Mac'; $octal = "\015"; $str = '\r'; $irs = "^M"; last; } } if (not $octal) { $self->warn("Could not determine newline char. Using '\012'"); $octal = "\012"; } else { # print STDERR "FLAVOR=$flavor, NEWLINE CHAR = $irs\n"; } return($octal); } =head2 file_flavor Usage : $object->file_flavor( ); Purpose : Returns the 'flavor' of a given file (unix, dos, mac) Example : print "$file has flavor: ", $Util->file_flavor($file); Argument : filename = string, full path name for file Returns : String describing flavor of file and handy info about line endings. : One of these is returned: : unix (\n or 012 or ^J) : dos (\r\n or 015,012 or ^M^J) : mac (\r or 015 or ^M) : unknown Throws : Exception if argument is not a file : Propogates any exceptions thrown by Bio::Root::Utilities::get_newline(). See Also : L, L =cut #--------------- sub file_flavor { #--------------- my ($self, $file) = @_; my %flavors=("\012" =>'unix (\n or 012 or ^J)', "\015\012" =>'dos (\r\n or 015,012 or ^M^J)', "\015" =>'mac (\r or 015 or ^M)' ); -f $file or $self->throw("Can't determine flavor: arg '$file' is either non existant or is not a file.\n"); my $octal = $self->get_newline($file); my $flavor = $flavors{$octal} || "unknown"; return $flavor; } ###################################### ##### Mail Functions ######## ###################################### =head2 mail_authority Title : mail_authority Usage : $Util->mail_authority( $message ) Purpose : Syntactic sugar to send email to $Bio::Root::Global::AUTHORITY See Also : L =cut sub mail_authority { my( $self, $message ) = @_; my $script = $self->untaint($0,1); my $email = $self->{'_auth_email'} || $AUTHORITY; if (defined $email) { $self->send_mail( -TO=>$AUTHORITY, -SUBJ=>$script, -MSG=>$message); } else { $self->throw("Can't email authority. No email defined."); } } =head2 authority Title : authority Usage : $Util->authority('admin@example.com'); Purpose : Set/get the email address that should be notified by mail_authority() See Also : L =cut sub authority { my( $self, $email ) = @_; $self->{'_auth_email'} = $email if defined $email; return $self->{'_auth_email'}; } =head2 send_mail Title : send_mail Usage : $Util->send_mail( named_parameters ) Purpose : Provides an interface to mail or sendmail, if available Returns : n/a Argument : Named parameters: (case-insensitive) : -TO => e-mail address to send to : -SUBJ => subject for message (optional) : -MSG => message to be sent (optional) : -CC => cc: e-mail address (optional) Thows : Exception if TO: address appears bad or is missing. : Exception if mail cannot be sent. Comments : Based on TomC's tip at: : http://www.perl.com/CPAN/doc/FMTEYEWTK/safe_shellings : : Using default 'From:' information. : sendmail options used: : -t: ignore the address given on the command line and : get To:address from the e-mail header. : -oi: prevents send_mail from ending the message if it : finds a period at the start of a line. See Also : L =cut #-------------' sub send_mail { #------------- my( $self, @param) = @_; my($recipient,$subj,$message,$cc) = $self->_rearrange([qw(TO SUBJ MSG CC)],@param); $self->throw("Invalid or missing e-mail address: $recipient") if not $recipient =~ /\S+\@\S+/; $subj ||= 'empty subject'; $message ||= ''; # Best to use mail rather than sendmail. Permissions on sendmail in # linux distros have been significantly locked down in recent years, # due to the perception that it is insecure. my ($exe, $ccinfo); if ($exe = $self->find_exe('mail')) { if (defined $cc) { $ccinfo = "-c $cc"; } $self->debug("send_mail: $exe -s '$subj' $ccinfo $recipient\n"); open (MAIL, "| $exe -s '$subj' $ccinfo $recipient") || $self->throw("Can't send email: mail cannot fork: $!"); print MAIL <warn("mail didn't exit nicely: $?"); close(MAIL); } elsif ($exe = $self->find_exe('sendmail')) { open (SENDMAIL, "| $exe -oi -t") || $self->throw("Can't send email: sendmail cannot fork: $!"); print SENDMAIL <warn("sendmail didn't exit nicely: $?"); close(SENDMAIL); } else { $self->throw("Can't find executable for mail or sendmail."); } } =head2 find_exe Title : find_exe Usage : $Util->find_exe(name); Purpose : Locate an executable (for use in a system() call, e.g.)) Example : $Util->find_exe("gzip"); Returns : String containing executable that passes the -x test. Returns undef if an executable of the supplied name cannot be found. Argument : Name of executable to be found. : Can be a full path. If supplied name is not executable, an executable : of that name will be searched in all directories in the currently : defined PATH environment variable. Throws : No exceptions, but issues a warning if multiple paths are found : for a given name. The first one is used. Comments : TODO: Confirm functionality on all bioperl-supported platforms. May get tripped up by variation in path separator character used for splitting ENV{PATH}. See Also : =cut sub find_exe { my ($self, $name) = @_; my @bindirs = split (':', $ENV{'PATH'}); my $exe = $name; unless (-x $exe) { undef $exe; my @exes; foreach my $d (@bindirs) { push(@exes, "$d/$name") if -x "$d/$name"; } if (scalar @exes) { $exe = $exes[0]; if (defined $exes[1]) { $self->warn("find_exe: Multiple paths to '$name' found. Using $exe."); } } } return $exe; } ###################################### ### Interactive Functions ##### ###################################### =head2 yes_reply Title : yes_reply() Usage : $Util->yes_reply( [query_string]); Purpose : To test an STDIN input value for affirmation. Example : print +( $Util->yes_reply('Are you ok') ? "great!\n" : "sorry.\n" ); : $Util->yes_reply('Continue') || die; Returns : Boolean, true (1) if input string begins with 'y' or 'Y' Argument: query_string = string to be used to prompt user (optional) : If not provided, 'Yes or no' will be used. : Question mark is automatically appended. =cut #------------- sub yes_reply { #------------- my $self = shift; my $query = shift; my $reply; $query ||= 'Yes or no'; print "\n$query? (y/n) [n] "; chomp( $reply = ); $reply =~ /^y/i; } =head2 request_data Title : request_data() Usage : $Util->request_data( [value_name]); Purpose : To request data from a user to be entered via keyboard (STDIN). Example : $name = $Util->request_data('Name'); : # User will see: % Enter Name: Returns : String, (data entered from keyboard, sans terminal newline.) Argument: value_name = string to be used to prompt user. : If not provided, 'data' will be used, (not very helpful). : Question mark is automatically appended. =cut #---------------- sub request_data { #---------------- my $self = shift; my $data = shift || 'data'; print "Enter $data: "; # Remove the terminal newline char. chomp($data = ); $data; } sub quit_reply { # Not much used since you can use request_data() # and test for an empty string. my $self = shift; my $reply; chop( $reply = ); $reply =~ /^q.*/i; } =head2 verify_version Purpose : Checks the version of Perl used to invoke the script. : Aborts program if version is less than the given argument. Usage : verify_version('5.000') =cut #------------------ sub verify_version { #------------------ my $self = shift; my $reqVersion = shift; $] < $reqVersion and do { printf STDERR ( "\a\n%s %0.3f.\n", "** Sorry. This Perl script requires at least version", $reqVersion); printf STDERR ( "%s %0.3f %s\n\n", "You are running Perl version", $], "Please update your Perl!\n\n" ); exit(1); } } 1; __END__ BioPerl-1.6.923/Bio/Root/Version.pm000444000765000024 537512254227335 17072 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Root::Version # # Please direct questions and support issues to # # Cared for by Aaron Mackey # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Root::Version - provide global, distribution-level versioning =head1 SYNOPSIS package Bio::Tools::NiftyFeature; require Bio::Root::RootI; # later, in client code: package main; use Bio::Tools::NiftyFeature 3.14; ## alternative usage: NiftyFeature defines own $VERSION: package Bio::Tools::NiftyFeature; my $VERSION = 9.8; # later in client code: package main; # ensure we're using an up-to-date BioPerl distribution use Bio::Perl 3.14; # NiftyFeature has its own versioning scheme: use Bio::Tools::NiftyFeature 9.8; =head1 DESCRIPTION This module provides a mechanism by which all other BioPerl modules can share the same $VERSION, without manually synchronizing each file. Bio::Root::RootI itself uses this module, so any module that directly (or indirectly) uses Bio::Root::RootI will get a global $VERSION variable set if it's not already. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Root::Version; use strict; our $VERSION = '1.006923'; # pre-1.7 $VERSION = eval $VERSION; sub import { # try to handle multiple levels of inheritance: my $i = 0; my $pkg = caller($i); no strict 'refs'; while ($pkg) { if ($pkg =~ m/^Bio::/o && not defined ${$pkg . "::VERSION"}) { ${$pkg . "::VERSION"} = $VERSION; } $pkg = caller(++$i); } } 1; __END__ BioPerl-1.6.923/Bio/Search000755000765000024 012254227334 15221 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Search/BlastStatistics.pm000555000765000024 604212254227315 21040 0ustar00cjfieldsstaff000000000000# # # BioPerl module for wrapping Blast statistics # # Please direct questions and support issues to # # Cared for by Chad Matsalla (bioinformatics1 at dieselwurks dot com) # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::BlastStatistics - An object for Blast statistics =head1 SYNOPSIS # this is a wrapper to hold the statistics from a Blast report my $bs = $result->get_statistics(); # you can get a statistic generically, like this: my $kappa = $bs->get_statistic("kappa"); # or specifically, like this: my $kappa2 = $bs->get_kappa(); =head1 DESCRIPTION This is a basic container to hold the statistics returned from a Blast. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1 at dieselwurks dot com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::BlastStatistics; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::RootI Bio::Search::StatisticsI); sub new { my ($class, @args) = @_; # really, don't bother with any initial initialization my $self = $class->SUPER::new(@args); return $self; } =head2 get_statistic Title : get_statistic Usage : $statistic_object->get_statistic($statistic_name); Function: Get the value of a statistic named $statistic_name Returns : A scalar that should be a string Args : A scalar that should be a string =cut sub get_statistic { my ($self,$arg) = @_; return $self->{$arg}; } =head2 set_statistic Title : set_statistic Usage : $statistic_object->set_statistic($statistic_name => $statistic_value); Function: Set the value of a statistic named $statistic_name to $statistic_value Returns : Void Args : A hash containing name=>value pairs =cut sub set_statistic { my ($self,%args) = @_; foreach (keys %args) { $self->{$_} = $args{$_}; } } 1; BioPerl-1.6.923/Bio/Search/BlastUtils.pm000444000765000024 4660012254227334 20030 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::Search::BlastUtils - Utility functions for Bio::Search:: BLAST objects =head1 SYNOPSIS # This module is just a collection of subroutines, not an object. See L. =head1 DESCRIPTION The BlastUtils.pm module is a collection of subroutines used primarily by Bio::Search::Hit::BlastHit objects for some of the additional functionality, such as HSP tiling. Right now, the BlastUtils is just a collection of methods, not an object, and it's tightly coupled to Bio::Search::Hit::BlastHit. A goal for the future is to generalize it to work based on the Bio::Search interfaces, then it can work with any objects that implements them. =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE =cut #' package Bio::Search::BlastUtils; use Bio::Root::Version; =head2 tile_hsps Usage : tile_hsps( $sbjct ); : This is called automatically by Bio::Search::Hit::BlastHit : during object construction or : as needed by methods that rely on having tiled data. Purpose : Collect statistics about the aligned sequences in a set of HSPs. : Calculates the following data across all HSPs: : -- total alignment length : -- total identical residues : -- total conserved residues Returns : n/a Argument : A Bio::Search::Hit::BlastHit object Throws : n/a Comments : : This method is *strongly* coupled to Bio::Search::Hit::BlastHit : (it accesses BlastHit data members directly). : TODO: Re-write this to the Bio::Search::Hit::HitI interface. : : This method performs more careful summing of data across : all HSPs in the Sbjct object. Only HSPs that are in the same strand : and frame are tiled. Simply summing the data from all HSPs : in the same strand and frame will overestimate the actual : length of the alignment if there is overlap between different HSPs : (often the case). : : The strategy is to tile the HSPs and sum over the : contigs, collecting data separately from overlapping and : non-overlapping regions of each HSP. To facilitate this, the : HSP.pm object now permits extraction of data from sub-sections : of an HSP. : : Additional useful information is collected from the results : of the tiling. It is possible that sub-sequences in : different HSPs will overlap significantly. In this case, it : is impossible to create a single unambiguous alignment by : concatenating the HSPs. The ambiguity may indicate the : presence of multiple, similar domains in one or both of the : aligned sequences. This ambiguity is recorded using the : ambiguous_aln() method. : : This method does not attempt to discern biologically : significant vs. insignificant overlaps. The allowable amount of : overlap can be set with the overlap() method or with the -OVERLAP : parameter used when constructing the Blast & Sbjct objects. : : For a given hit, both the query and the sbjct sequences are : tiled independently. : : -- If only query sequence HSPs overlap, : this may suggest multiple domains in the sbjct. : -- If only sbjct sequence HSPs overlap, : this may suggest multiple domains in the query. : -- If both query & sbjct sequence HSPs overlap, : this suggests multiple domains in both. : -- If neither query & sbjct sequence HSPs overlap, : this suggests either no multiple domains in either : sequence OR that both sequences have the same : distribution of multiple similar domains. : : This method can deal with the special case of when multiple : HSPs exactly overlap. : : Efficiency concerns: : Speed will be an issue for sequences with numerous HSPs. : Bugs : Currently, tile_hsps() does not properly account for : the number of non-tiled but overlapping HSPs, which becomes a problem : as overlap() grows. Large values overlap() may thus lead to : incorrect statistics for some hits. For best results, keep overlap() : below 5 (DEFAULT IS 2). For more about this, see the "HSP Tiling and : Ambiguous Alignments" section in L. See Also : L<_adjust_contigs>(), L =cut #-------------- sub tile_hsps { #-------------- my $sbjct = shift; $sbjct->{'_tile_hsps'} = 1; $sbjct->{'_gaps_query'} = 0; $sbjct->{'_gaps_sbjct'} = 0; ## Simple summation scheme. Valid if there is only one HSP. if((defined($sbjct->{'_n'}) and $sbjct->{'_n'} == 1) or $sbjct->num_hsps == 1) { my $hsp = $sbjct->hsp; $sbjct->{'_length_aln_query'} = $hsp->length('query'); $sbjct->{'_length_aln_sbjct'} = $hsp->length('sbjct'); $sbjct->{'_length_aln_total'} = $hsp->length('total'); ($sbjct->{'_totalIdentical'},$sbjct->{'_totalConserved'}) = $hsp->matches(); $sbjct->{'_gaps_query'} = $hsp->gaps('query'); $sbjct->{'_gaps_sbjct'} = $hsp->gaps('sbjct'); # print "_tile_hsps(): single HSP, easy stats.\n"; return; } else { # print STDERR "Sbjct: _tile_hsps: summing multiple HSPs\n"; $sbjct->{'_length_aln_query'} = 0; $sbjct->{'_length_aln_sbjct'} = 0; $sbjct->{'_length_aln_total'} = 0; $sbjct->{'_totalIdentical'} = 0; $sbjct->{'_totalConserved'} = 0; } ## More than one HSP. Must tile HSPs. # print "\nTiling HSPs for $sbjct\n"; my($hsp, $qstart, $qstop, $sstart, $sstop); my($frame, $strand, $qstrand, $sstrand); my(@qcontigs, @scontigs); my $qoverlap = 0; my $soverlap = 0; my $max_overlap = $sbjct->{'_overlap'}; foreach $hsp ($sbjct->hsps()) { # printf " HSP: %s\n%s\n",$hsp->name, $hsp->str('query'); # printf " Length = %d; Identical = %d; Conserved = %d; Conserved(1-10): %d",$hsp->length, $hsp->length(-TYPE=>'iden'), $hsp->length(-TYPE=>'cons'), $hsp->length(-TYPE=>'cons',-START=>0,-STOP=>10); ($qstart, $qstop) = $hsp->range('query'); ($sstart, $sstop) = $hsp->range('sbjct'); $frame = $hsp->frame('hit'); $frame = -1 unless defined $frame; ($qstrand, $sstrand) = $hsp->strand; my ($qgaps, $sgaps) = $hsp->gaps(); $sbjct->{'_gaps_query'} += $qgaps; $sbjct->{'_gaps_sbjct'} += $sgaps; $sbjct->{'_length_aln_total'} += $hsp->length; ## Collect contigs in the query sequence. $qoverlap = &_adjust_contigs('query', $hsp, $qstart, $qstop, \@qcontigs, $max_overlap, $frame, $qstrand); ## Collect contigs in the sbjct sequence (needed for domain data and gapped Blast). $soverlap = &_adjust_contigs('sbjct', $hsp, $sstart, $sstop, \@scontigs, $max_overlap, $frame, $sstrand); ## Collect overall start and stop data for query and sbjct over all HSPs. if(not defined $sbjct->{'_queryStart'}) { $sbjct->{'_queryStart'} = $qstart; $sbjct->{'_queryStop'} = $qstop; $sbjct->{'_sbjctStart'} = $sstart; $sbjct->{'_sbjctStop'} = $sstop; } else { $sbjct->{'_queryStart'} = ($qstart < $sbjct->{'_queryStart'} ? $qstart : $sbjct->{'_queryStart'}); $sbjct->{'_queryStop'} = ($qstop > $sbjct->{'_queryStop'} ? $qstop : $sbjct->{'_queryStop'}); $sbjct->{'_sbjctStart'} = ($sstart < $sbjct->{'_sbjctStart'} ? $sstart : $sbjct->{'_sbjctStart'}); $sbjct->{'_sbjctStop'} = ($sstop > $sbjct->{'_sbjctStop'} ? $sstop : $sbjct->{'_sbjctStop'}); } } ## Collect data across the collected contigs. # print "\nQUERY CONTIGS:\n"; # print " gaps = $sbjct->{'_gaps_query'}\n"; # TODO: Account for strand/frame issue! # Strategy: collect data on a per strand+frame basis and save the most significant one. my (%qctg_dat); foreach(@qcontigs) { # print " query contig: $_->{'start'} - $_->{'stop'}\n"; # print " iden = $_->{'iden'}; cons = $_->{'cons'}\n"; ($frame, $strand) = ($_->{'frame'}, $_->{'strand'}); $qctg_dat{ "$frame$strand" }->{'length_aln_query'} += $_->{'stop'} - $_->{'start'} + 1; $qctg_dat{ "$frame$strand" }->{'totalIdentical'} += $_->{'iden'}; $qctg_dat{ "$frame$strand" }->{'totalConserved'} += $_->{'cons'}; $qctg_dat{ "$frame$strand" }->{'qstrand'} = $strand; } # Find longest contig. my @sortedkeys = reverse sort { $qctg_dat{ $a }->{'length_aln_query'} <=> $qctg_dat{ $b }->{'length_aln_query'} } keys %qctg_dat; # Save the largest to the sbjct: my $longest = $sortedkeys[0]; $sbjct->{'_length_aln_query'} = $qctg_dat{ $longest }->{'length_aln_query'}; $sbjct->{'_totalIdentical'} = $qctg_dat{ $longest }->{'totalIdentical'}; $sbjct->{'_totalConserved'} = $qctg_dat{ $longest }->{'totalConserved'}; $sbjct->{'_qstrand'} = $qctg_dat{ $longest }->{'qstrand'}; ## Collect data for sbjct contigs. Important for gapped Blast. ## The totalIdentical and totalConserved numbers will be the same ## as determined for the query contigs. # print "\nSBJCT CONTIGS:\n"; # print " gaps = $sbjct->{'_gaps_sbjct'}\n"; my (%sctg_dat); foreach(@scontigs) { # print " sbjct contig: $_->{'start'} - $_->{'stop'}\n"; # print " iden = $_->{'iden'}; cons = $_->{'cons'}\n"; ($frame, $strand) = ($_->{'frame'}, $_->{'strand'}); $sctg_dat{ "$frame$strand" }->{'length_aln_sbjct'} += $_->{'stop'} - $_->{'start'} + 1; $sctg_dat{ "$frame$strand" }->{'frame'} = $frame; $sctg_dat{ "$frame$strand" }->{'sstrand'} = $strand; } @sortedkeys = reverse sort { $sctg_dat{ $a }->{'length_aln_sbjct'} <=> $sctg_dat{ $b }->{'length_aln_sbjct'} } keys %sctg_dat; # Save the largest to the sbjct: $longest = $sortedkeys[0]; $sbjct->{'_length_aln_sbjct'} = $sctg_dat{ $longest }->{'length_aln_sbjct'}; $sbjct->{'_frame'} = $sctg_dat{ $longest }->{'frame'}; $sbjct->{'_sstrand'} = $sctg_dat{ $longest }->{'sstrand'}; if($qoverlap) { if($soverlap) { $sbjct->ambiguous_aln('qs'); # print "\n*** AMBIGUOUS ALIGNMENT: Query and Sbjct\n\n"; } else { $sbjct->ambiguous_aln('q'); # print "\n*** AMBIGUOUS ALIGNMENT: Query\n\n"; } } elsif($soverlap) { $sbjct->ambiguous_aln('s'); # print "\n*** AMBIGUOUS ALIGNMENT: Sbjct\n\n"; } # Adjust length based on BLAST flavor. my $prog = $sbjct->algorithm; if($prog eq 'TBLASTN') { $sbjct->{'_length_aln_sbjct'} /= 3; } elsif($prog eq 'BLASTX' ) { $sbjct->{'_length_aln_query'} /= 3; } elsif($prog eq 'TBLASTX') { $sbjct->{'_length_aln_query'} /= 3; $sbjct->{'_length_aln_sbjct'} /= 3; } } =head2 _adjust_contigs Usage : n/a; called automatically during object construction. Purpose : Builds HSP contigs for a given BLAST hit. : Utility method called by _tile_hsps() Returns : Argument : Throws : Exceptions propagated from Bio::Search::Hit::BlastHSP::matches() : for invalid sub-sequence ranges. Status : Experimental Comments : This method does not currently support gapped alignments. : Also, it does not keep track of the number of HSPs that : overlap within the amount specified by overlap(). : This will lead to significant tracking errors for large : overlap values. See Also : L(), L =cut #------------------- sub _adjust_contigs { #------------------- my ($seqType, $hsp, $start, $stop, $contigs_ref, $max_overlap, $frame, $strand) = @_; my $overlap = 0; my ($numID, $numCons); # print STDERR "Testing $seqType data: HSP (${\$hsp->name}); $start, $stop, strand=$strand, frame=$frame\n"; foreach(@$contigs_ref) { # print STDERR " Contig: $_->{'start'} - $_->{'stop'}, strand=$_->{'strand'}, frame=$_->{'frame'}, iden= $_->{'iden'}, cons= $_->{'cons'}\n"; # Don't merge things unless they have matching strand/frame. next unless ($_->{'frame'} == $frame and $_->{'strand'} == $strand); ## Test special case of a nested HSP. Skip it. if($start >= $_->{'start'} and $stop <= $_->{'stop'}) { # print STDERR "----> Nested HSP. Skipping.\n"; $overlap = 1; next; } ## Test for overlap at beginning of contig. if($start < $_->{'start'} and $stop > ($_->{'start'} + $max_overlap)) { # print STDERR "----> Overlaps beg: existing beg,end: $_->{'start'},$_->{'stop'}, new beg,end: $start,$stop\n"; # Collect stats over the non-overlapping region. eval { ($numID, $numCons) = $hsp->matches(-SEQ =>$seqType, -START =>$start, -STOP =>$_->{'start'}-1); }; if($@) { warn "\a\n$@\n"; } else { $_->{'start'} = $start; # Assign a new start coordinate to the contig $_->{'iden'} += $numID; # and add new data to #identical, #conserved. $_->{'cons'} += $numCons; $overlap = 1; } } ## Test for overlap at end of contig. if($stop > $_->{'stop'} and $start < ($_->{'stop'} - $max_overlap)) { # print STDERR "----> Overlaps end: existing beg,end: $_->{'start'},$_->{'stop'}, new beg,end: $start,$stop\n"; # Collect stats over the non-overlapping region. eval { ($numID,$numCons) = $hsp->matches(-SEQ =>$seqType, -START =>$_->{'stop'}, -STOP =>$stop); }; if($@) { warn "\a\n$@\n"; } else { $_->{'stop'} = $stop; # Assign a new stop coordinate to the contig $_->{'iden'} += $numID; # and add new data to #identical, #conserved. $_->{'cons'} += $numCons; $overlap = 1; } } $overlap && do { # print STDERR " New Contig data:\n"; # print STDERR " Contig: $_->{'start'} - $_->{'stop'}, iden= $_->{'iden'}, cons= $_->{'cons'}\n"; last; }; } ## If there is no overlap, add the complete HSP data. !$overlap && do { # print STDERR "No overlap. Adding new contig.\n"; ($numID,$numCons) = $hsp->matches(-SEQ=>$seqType); push @$contigs_ref, {'start'=>$start, 'stop'=>$stop, 'iden'=>$numID, 'cons'=>$numCons, 'strand'=>$strand, 'frame'=>$frame}; }; $overlap; } =head2 get_exponent Usage : &get_exponent( number ); Purpose : Determines the power of 10 exponent of an integer, float, : or scientific notation number. Example : &get_exponent("4.0e-206"); : &get_exponent("0.00032"); : &get_exponent("10."); : &get_exponent("1000.0"); : &get_exponent("e+83"); Argument : Float, Integer, or scientific notation number Returns : Integer representing the exponent part of the number (+ or -). : If argument == 0 (zero), return value is "-999". Comments : Exponents are rounded up (less negative) if the mantissa is >= 5. : Exponents are rounded down (more negative) if the mantissa is <= -5. =cut #------------------ sub get_exponent { #------------------ my $data = shift; my($num, $exp) = split /[eE]/, $data; if( defined $exp) { $num = 1 if not $num; $num >= 5 and $exp++; $num <= -5 and $exp--; } elsif( $num == 0) { $exp = -999; } elsif( not $num =~ /\./) { $exp = CORE::length($num) -1; } else { $exp = 0; $num .= '0' if $num =~ /\.$/; my ($c); my $rev = 0; if($num !~ /^0/) { $num = reverse($num); $rev = 1; } do { $c = chop($num); $c == 0 && $exp++; } while( $c ne '.'); $exp = -$exp if $num == 0 and not $rev; $exp -= 1 if $rev; } return $exp; } =head2 collapse_nums Usage : @cnums = collapse_nums( @numbers ); Purpose : Collapses a list of numbers into a set of ranges of consecutive terms: : Useful for condensing long lists of consecutive numbers. : EXPANDED: : 1 2 3 4 5 6 10 12 13 14 15 17 18 20 21 22 24 26 30 31 32 : COLLAPSED: : 1-6 10 12-15 17 18 20-22 24 26 30-32 Argument : List of numbers sorted numerically. Returns : List of numbers mixed with ranges of numbers (see above). Throws : n/a See Also : L =cut #------------------ sub collapse_nums { #------------------ # This is probably not the slickest connectivity algorithm, but will do for now. my @a = @_; my ($from, $to, $i, @ca, $consec); $consec = 0; for($i=0; $i < @a; $i++) { not $from and do{ $from = $a[$i]; next; }; if($a[$i] == $a[$i-1]+1) { $to = $a[$i]; $consec++; } else { if($consec == 1) { $from .= ",$to"; } else { $from .= $consec>1 ? "\-$to" : ""; } push @ca, split(',', $from); $from = $a[$i]; $consec = 0; $to = undef; } } if(defined $to) { if($consec == 1) { $from .= ",$to"; } else { $from .= $consec>1 ? "\-$to" : ""; } } push @ca, split(',', $from) if $from; @ca; } =head2 strip_blast_html Usage : $boolean = &strip_blast_html( string_ref ); : This method is exported. Purpose : Removes HTML formatting from a supplied string. : Attempts to restore the Blast report to enable : parsing by Bio::SearchIO::blast.pm Returns : Boolean: true if string was stripped, false if not. Argument : string_ref = reference to a string containing the whole Blast : report containing HTML formatting. Throws : Croaks if the argument is not a scalar reference. Comments : Based on code originally written by Alex Dong Li : (ali@genet.sickkids.on.ca). : This method does some Blast-specific stripping : (adds back a '>' character in front of each HSP : alignment listing). : : THIS METHOD IS VERY SENSITIVE TO BLAST FORMATTING CHANGES! : : Removal of the HTML tags and accurate reconstitution of the : non-HTML-formatted report is highly dependent on structure of : the HTML-formatted version. For example, it assumes that first : line of each alignment section (HSP listing) starts with a : anchor tag. This permits the reconstruction of the : original report in which these lines begin with a ">". : This is required for parsing. : : If the structure of the Blast report itself is not intended to : be a standard, the structure of the HTML-formatted version : is even less so. Therefore, the use of this method to : reconstitute parsable Blast reports from HTML-format versions : should be considered a temorary solution. =cut #-------------------- sub strip_blast_html { #-------------------- # This may not best way to remove html tags. However, it is simple. # it won't work under following conditions: # 1) if quoted > appears in a tag (does this ever happen?) # 2) if a tag is split over multiple lines and this method is # used to process one line at a time. my ($string_ref) = shift; ref $string_ref eq 'SCALAR' or croak ("Can't strip HTML: ". "Argument is should be a SCALAR reference not a ${\ref $string_ref}\n"); my $str = $$string_ref; my $stripped = 0; # Removing "" and adding the '>' character for # HSP alignment listings. $str =~ s/(\A|\n)]+> ?/>/sgi and $stripped = 1; # Removing all "<>" tags. $str =~ s/<[^>]+>| //sgi and $stripped = 1; # Re-uniting any lone '>' characters. $str =~ s/(\A|\n)>\s+/\n\n>/sgi and $stripped = 1; $$string_ref = $str; $stripped; } 1; BioPerl-1.6.923/Bio/Search/DatabaseI.pm000444000765000024 651712254227314 17540 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::DatabaseI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::Search::DatabaseI - Interface for a database used in a sequence search =head1 SYNOPSIS Bio::Search::DatabaseI objects should not be instantiated since this module defines a pure interface. Given an object that implements the Bio::Search::DatabaseI interface, you can do the following things with it: $name = $db->name(); $date = $db->date(); $num_letters = $db->letters(); $num_entries = $db->entries(); =head1 DESCRIPTION This module defines methods for an object that provides metadata information about a database used for sequence searching. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =cut =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Search::DatabaseI; use strict; use base qw(Bio::Root::RootI); =head2 name Usage : $name = $db->name(); Purpose : Get the name of the database searched. Returns : String Argument : n/a =cut sub name { my $self = shift; $self->throw_not_implemented; } =head2 date Usage : $date = $db->date(); Purpose : Get the creation date of the queried database. Returns : String Argument : n/a =cut sub date { my $self = shift; $self->throw_not_implemented; } =head2 letters Usage : $num_letters = $db->letters(); Purpose : Get the number of letters in the queried database. Returns : Integer Argument : n/a =cut sub letters { my $self = shift; $self->throw_not_implemented; } =head2 entries Usage : $num_entries = $db->entries(); Purpose : Get the number of entries in the queried database. Returns : Integer Argument : n/a =cut sub entries { my $self = shift; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Search/GenericDatabase.pm000444000765000024 775712254227326 20736 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::GenericDatabase # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::Search::GenericDatabase - Generic implementation of Bio::Search::DatabaseI =head1 SYNOPSIS use Bio::Search::GenericDatabase; $db = Bio::Search::GenericDatabase->new( -name => 'my Blast db', -date => '2001-03-13', -length => 2352511, -entries => 250000 ); $name = $db->name(); $date = $db->date(); $num_letters = $db->letters(); $num_entries = $db->entries(); =head1 DESCRIPTION This module provides a basic implementation of L. See documentation in that module for more information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =cut =head1 APPENDIX The rest of the documentation details each of the object methods. =cut # Let the code begin... package Bio::Search::GenericDatabase; use strict; use base qw(Bio::Root::Root Bio::Search::DatabaseI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($name, $date, $length, $ents) = $self->_rearrange( [qw(NAME DATE LENGTH ENTRIES)], @args); $name && $self->name($name); $date && $self->date($date); $length && $self->letters($length); $ents && $self->entries($ents); return $self; } =head2 name See L() for documentation This implementation is a combined set/get accessor. =cut #--------------- sub name { #--------------- my $self = shift; if(@_) { my $name = shift; $name =~ s/(^\s+|\s+$)//g; $self->{'_db'} = $name; } $self->{'_db'}; } =head2 date See L() for documentation This implementation is a combined set/get accessor. =cut #----------------------- sub date { #----------------------- my $self = shift; if(@_) { $self->{'_dbDate'} = shift; } $self->{'_dbDate'}; } =head2 letters See L() for documentation This implementation is a combined set/get accessor. =cut #---------------------- sub letters { #---------------------- my $self = shift; if(@_) { $self->{'_dbLetters'} = shift; } $self->{'_dbLetters'}; } =head2 entries See L() for documentation This implementation is a combined set/get accessor. =cut #------------------ sub entries { #------------------ my $self = shift; if(@_) { $self->{'_dbEntries'} = shift; } $self->{'_dbEntries'}; } 1; BioPerl-1.6.923/Bio/Search/GenericStatistics.pm000555000765000024 615112254227312 21345 0ustar00cjfieldsstaff000000000000# # # BioPerl module for wrapping statistics # # Please direct questions and support issues to # # Cared for by Chad Matsalla (bioinformatics1 at dieselwurks dot com) # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::GenericStatistics - An object for statistics =head1 SYNOPSIS my $void = $obj->set_statistic("statistic_name","statistic_value"); my $value = $obj->get_statistic("statistic_name"); =head1 DESCRIPTION This is a basic container to hold the statistics returned from a program. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1 at dieselwurks dot com =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::GenericStatistics; use strict; use base qw(Bio::Root::Root Bio::Search::StatisticsI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 get_statistic Title : get_statistic Usage : $statistic_object->get_statistic($statistic_name); Function: Get the value of a statistic named $statistic_name Returns : A scalar that should be a string Args : A scalar that should be a string =cut sub get_statistic { my ($self,$arg) = @_; return $self->{stats}->{$arg}; } =head2 set_statistic Title : set_statistic Usage : $statistic_object->set_statistic($statistic_name => $statistic_value); Function: Set the value of a statistic named $statistic_name to $statistic_value Returns : Void Args : A hash containing name=>value pairs =cut sub set_statistic { my ($self,$name,$value) = @_; $self->{stats}->{$name} = $value; } =head2 available_statistics Title : available_statistics Usage : my @statnames = $statistic_object->available_statistics Function: Returns the names of the available statistics Returns : list of available statistic names Args : none =cut sub available_statistics { my $self = shift; return keys %{$self->{stats}}; } 1; BioPerl-1.6.923/Bio/Search/Processor.pm000444000765000024 573012254227330 17674 0ustar00cjfieldsstaff000000000000 # # BioPerl module for Bio::Search::Processor # # Please direct questions and support issues to # # Cared for by Aaron Mackey # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Processor - DESCRIPTION of Object =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey@virginia.edu Describe contact details here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Processor; use strict; use Bio::Root::Version; =head2 new Title : new Usage : $proc = Bio::Search::Processor->new -file => $filename, -algorithm => 'Algorithm' ; Function: Used to specify and initialize a data processor of search algorithm results. Returns : A processor specific to the algorithm type, if it exists. Args : -file => filename -algorithm => algorithm specifier -fh => filehandle to attach to (file or fh required) =cut sub new { my $type = shift; my $proc; my ($module, $load, $algorithm); my %args = @_; exists $args{'-algorithm'} or do { print STDERR "Must supply an algorithm!"; return; }; $algorithm = $args{'-algorithm'} || $args{'-ALGORITHM'}; $module = "_new(@_); return $proc; } 1; BioPerl-1.6.923/Bio/Search/SearchUtils.pm000444000765000024 7500512254227313 20166 0ustar00cjfieldsstaff000000000000=head1 NAME Bio::Search::SearchUtils - Utility functions for Bio::Search:: objects =head1 SYNOPSIS # This module is just a collection of subroutines, not an object. =head1 DESCRIPTION The SearchUtils.pm module is a collection of subroutines used primarily by Bio::Search::Hit::HitI objects for some of the additional functionality, such as HSP tiling. Right now, the SearchUtils is just a collection of methods, not an object. =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =cut package Bio::Search::SearchUtils; use Bio::Root::Version; use strict; =head2 tile_hsps Usage : tile_hsps( $sbjct ); : This is called automatically by methods in Bio::Search::Hit::GenericHit : that rely on having tiled data. : : If you are interested in getting data about the constructed HSP contigs: : my ($qcontigs, $scontigs) = Bio::Search::SearchUtils::tile_hsps($hit); : if (ref $qcontigs) { : print STDERR "Query contigs:\n"; : foreach (@{$qcontigs}) { : print "contig start is $_->{'start'}\n"; : print "contig stop is $_->{'stop'}\n"; : } : } : See below for more information about the contig data structure. : Purpose : Collect statistics about the aligned sequences in a set of HSPs. : Calculates the following data across all HSPs: : -- total alignment length : -- total identical residues : -- total conserved residues Returns : If there was only a single HSP (so no tiling was necessary) tile_hsps() returns a list of two non-zero integers. If there were multiple HSP, tile_hsps() returns a list of two array references containin HSP contig data. The first array ref contains a list of HSP contigs on the query sequence. The second array ref contains a list of HSP contigs on the subject sequence. Each contig is a hash reference with the following data fields: 'start' => start coordinate of the contig 'stop' => start coordinate of the contig 'iden' => number of identical residues in the contig 'cons' => number of conserved residues in the contig 'strand'=> strand of the contig 'frame' => frame of the contig Argument : A Bio::Search::Hit::HitI object Throws : n/a Comments : : This method performs more careful summing of data across : all HSPs in the Sbjct object. Only HSPs that are in the same strand : and frame are tiled. Simply summing the data from all HSPs : in the same strand and frame will overestimate the actual : length of the alignment if there is overlap between different HSPs : (often the case). : : The strategy is to tile the HSPs and sum over the : contigs, collecting data separately from overlapping and : non-overlapping regions of each HSP. To facilitate this, the : HSP.pm object now permits extraction of data from sub-sections : of an HSP. : : Additional useful information is collected from the results : of the tiling. It is possible that sub-sequences in : different HSPs will overlap significantly. In this case, it : is impossible to create a single unambiguous alignment by : concatenating the HSPs. The ambiguity may indicate the : presence of multiple, similar domains in one or both of the : aligned sequences. This ambiguity is recorded using the : ambiguous_aln() method. : : This method does not attempt to discern biologically : significant vs. insignificant overlaps. The allowable amount of : overlap can be set with the overlap() method or with the -OVERLAP : parameter used when constructing the Hit object. : : For a given hit, both the query and the sbjct sequences are : tiled independently. : : -- If only query sequence HSPs overlap, : this may suggest multiple domains in the sbjct. : -- If only sbjct sequence HSPs overlap, : this may suggest multiple domains in the query. : -- If both query & sbjct sequence HSPs overlap, : this suggests multiple domains in both. : -- If neither query & sbjct sequence HSPs overlap, : this suggests either no multiple domains in either : sequence OR that both sequences have the same : distribution of multiple similar domains. : : This method can deal with the special case of when multiple : HSPs exactly overlap. : : Efficiency concerns: : Speed will be an issue for sequences with numerous HSPs. : Bugs : Currently, tile_hsps() does not properly account for : the number of non-tiled but overlapping HSPs, which becomes a problem : as overlap() grows. Large values overlap() may thus lead to : incorrect statistics for some hits. For best results, keep overlap() : below 5 (DEFAULT IS 2). For more about this, see the "HSP Tiling and : Ambiguous Alignments" section in L. See Also : L<_adjust_contigs>(), L =cut #-------------- sub tile_hsps { #-------------- my $sbjct = shift; #print STDERR "Calling tile_hsps(): $sbjct\n"; #$sbjct->verbose(1); # to activate debugging $sbjct->tiled_hsps(1); # changed to not rely on n() (which is unreliable here) --cjfields 4/6/10 if( $sbjct->num_hsps == 0) { #print STDERR "_tile_hsps(): no hsps, nothing to tile! (", $sbjct->num_hsps, ")\n"; _warn_about_no_hsps($sbjct); return (undef, undef); } elsif($sbjct->num_hsps == 1) { ## Simple summation scheme. Valid if there is only one HSP. #print STDERR "_tile_hsps(): single HSP, easy stats.\n"; my $hsp = $sbjct->hsp; $sbjct->length_aln('query', $hsp->length('query')); $sbjct->length_aln('hit', $hsp->length('sbjct')); $sbjct->length_aln('total', $hsp->length('total')); $sbjct->matches( $hsp->matches() ); $sbjct->gaps('query', $hsp->gaps('query')); $sbjct->gaps('sbjct', $hsp->gaps('sbjct')); _adjust_length_aln($sbjct); return (1, 1); } else { #print STDERR "Sbjct: _tile_hsps: summing multiple HSPs\n"; $sbjct->length_aln('query', 0); $sbjct->length_aln('sbjct', 0); $sbjct->length_aln('total', 0); $sbjct->matches( 0, 0); $sbjct->gaps('query', 0); $sbjct->gaps('hit', 0); } ## More than one HSP. Must tile HSPs. # print "\nTiling HSPs for $sbjct\n"; my($hsp, $qstart, $qstop, $sstart, $sstop); my($frame, $strand, $qstrand, $sstrand); my(@qcontigs, @scontigs); my $qoverlap = 0; my $soverlap = 0; my $max_overlap = $sbjct->overlap; my $hit_qgaps = 0; my $hit_sgaps = 0; my $hit_len_aln = 0; my %start_stop; my $v = $sbjct->verbose; foreach $hsp ( $sbjct->hsps() ) { #$sbjct->debug( sprintf(" HSP: %s %d..%d\n",$hsp->query->seq_id, $hsp->query->start, $hsp->hit->end)) if $v > 0; #$hsp->str('query'); # printf " Length = %d; Identical = %d; Conserved = %d; Conserved(1-10): %d",$hsp->length, $hsp->length(-TYPE=>'iden'), # $hsp->length(-TYPE=>'cons'), # $hsp->length(-TYPE=>'cons', # -START=>0,-STOP=>10); ($qstart, $qstop) = $hsp->range('query'); ($sstart, $sstop) = $hsp->range('sbjct'); $frame = $hsp->frame('hit'); $frame = -1 unless defined $frame; ($qstrand, $sstrand) = ($hsp->query->strand, $hsp->hit->strand); # Note: No correction for overlap. my ($qgaps, $sgaps) = ($hsp->gaps('query'), $hsp->gaps('hit')); $hit_qgaps += $qgaps; $hit_sgaps += $sgaps; $hit_len_aln += $hsp->length; ## Collect contigs in the query sequence. $qoverlap += &_adjust_contigs('query', $hsp, $qstart, $qstop, \@qcontigs, $max_overlap, $frame, $qstrand); ## Collect contigs in the sbjct sequence # (needed for domain data and gapped Blast). $soverlap += &_adjust_contigs('sbjct', $hsp, $sstart, $sstop, \@scontigs, $max_overlap, $frame, $sstrand); ## Collect overall start and stop data for query and # sbjct over all HSPs. unless ( defined $start_stop{'qstart'} ) { $start_stop{'qstart'} = $qstart; $start_stop{'qstop'} = $qstop; $start_stop{'sstart'} = $sstart; $start_stop{'sstop'} = $sstop; } else { $start_stop{'qstart'} = ($qstart < $start_stop{'qstart'} ? $qstart : $start_stop{'qstart'} ); $start_stop{'qstop'} = ($qstop > $start_stop{'qstop'} ? $qstop : $start_stop{'qstop'} ); $start_stop{'sstart'} = ($sstart < $start_stop{'sstart'} ? $sstart : $start_stop{'sstart'} ); $start_stop{'sstop'} = ($sstop > $start_stop{'sstop'} ? $sstop : $start_stop{'sstop'} ); } } # Store the collected data in the Hit object $sbjct->gaps('query', $hit_qgaps); $sbjct->gaps('hit', $hit_sgaps); $sbjct->length_aln('total', $hit_len_aln); $sbjct->start('query',$start_stop{'qstart'}); $sbjct->end('query', $start_stop{'qstop'}); $sbjct->start('hit', $start_stop{'sstart'}); $sbjct->end('hit', $start_stop{'sstop'}); ## Collect data across the collected contigs. #$sbjct->debug( "\nQUERY CONTIGS:\n"." gaps = $sbjct->{'_gaps_query'}\n"); # Account for strand/frame. # Strategy: collect data on a per strand+frame basis and # save the most significant one. my (%qctg_dat); foreach (@qcontigs) { ($frame, $strand) = ($_->{'frame'}, $_->{'strand'}); if( $v > 0 ) { #$sbjct->debug(sprintf( "$frame/$strand len is getting %d for %d..%d\n", # ($_->{'stop'} - $_->{'start'} + 1), $_->{'start'}, $_->{'stop'})); } $qctg_dat{ "$frame$strand" }->{'length_aln_query'} += $_->{'stop'} - $_->{'start'} + 1; $qctg_dat{ "$frame$strand" }->{'totalIdentical'} += $_->{'iden'}; $qctg_dat{ "$frame$strand" }->{'totalConserved'} += $_->{'cons'}; $qctg_dat{ "$frame$strand" }->{'qstrand'} = $strand; } # Find longest contig. my @sortedkeys = sort { $qctg_dat{$b}->{'length_aln_query'} <=> $qctg_dat{$a}->{'length_aln_query'} } keys %qctg_dat; # Save the largest to the sbjct: my $longest = $sortedkeys[0]; #$sbjct->debug( "longest is ". $qctg_dat{ $longest }->{'length_aln_query'}. "\n"); $sbjct->length_aln('query', $qctg_dat{ $longest }->{'length_aln_query'}); $sbjct->matches($qctg_dat{ $longest }->{'totalIdentical'}, $qctg_dat{ $longest }->{'totalConserved'}); $sbjct->strand('query', $qctg_dat{ $longest }->{'qstrand'}); ## Collect data for sbjct contigs. Important for gapped Blast. ## The totalIdentical and totalConserved numbers will be the same ## as determined for the query contigs. #$sbjct->debug( "\nSBJCT CONTIGS:\n"." gaps = ". $sbjct->gaps('sbjct'). "\n"); my (%sctg_dat); foreach(@scontigs) { #$sbjct->debug(" sbjct contig: $_->{'start'} - $_->{'stop'}\n". # " iden = $_->{'iden'}; cons = $_->{'cons'}\n"); ($frame, $strand) = ($_->{'frame'}, $_->{'strand'}); $sctg_dat{ "$frame$strand" }->{'length_aln_sbjct'} += $_->{'stop'} - $_->{'start'} + 1; $sctg_dat{ "$frame$strand" }->{'frame'} = $frame; $sctg_dat{ "$frame$strand" }->{'sstrand'} = $strand; } @sortedkeys = sort { $sctg_dat{ $b }->{'length_aln_sbjct'} <=> $sctg_dat{ $a }->{'length_aln_sbjct'} } keys %sctg_dat; # Save the largest to the sbjct: $longest = $sortedkeys[0]; $sbjct->length_aln('sbjct', $sctg_dat{ $longest }->{'length_aln_sbjct'}); $sbjct->frame( $sctg_dat{ $longest }->{'frame'} ); $sbjct->strand('hit', $sctg_dat{ $longest }->{'sstrand'}); if($qoverlap) { if($soverlap) { $sbjct->ambiguous_aln('qs'); #$sbjct->debug("\n*** AMBIGUOUS ALIGNMENT: Query and Sbjct\n\n"); } else { $sbjct->ambiguous_aln('q'); #$sbjct->debug( "\n*** AMBIGUOUS ALIGNMENT: Query\n\n"); } } elsif($soverlap) { $sbjct->ambiguous_aln('s'); #$sbjct->debug( "\n*** AMBIGUOUS ALIGNMENT: Sbjct\n\n"); } _adjust_length_aln($sbjct); return ( [@qcontigs], [@scontigs] ); } # Title : _adjust_length_aln # Usage : n/a; internal use only; called by tile_hsps. # Purpose : Adjust length of aligment based on BLAST flavor. # Comments : See comments in logica_length() sub _adjust_length_aln { my $sbjct = shift; my $algo = $sbjct->algorithm; my $hlen = $sbjct->length_aln('sbjct'); my $qlen = $sbjct->length_aln('query'); $sbjct->length_aln('sbjct', logical_length($algo, 'sbjct', $hlen)); $sbjct->length_aln('query', logical_length($algo, 'query', $qlen)); } =head2 logical_length Usage : logical_length( $alg_name, $seq_type, $length ); Purpose : Determine the logical length of an aligned sequence based on : algorithm name and sequence type. Returns : integer representing the logical aligned length. Argument : $alg_name = name of algorigthm (e.g., blastx, tblastn) : $seq_type = type of sequence (e.g., query or hit) : $length = physical length of the sequence in the alignment. Throws : n/a Comments : This function is used to account for the fact that number of identities and conserved residues is reported in peptide space while the query length (in the case of BLASTX and TBLASTX) and/or the hit length (in the case of TBLASTN and TBLASTX) are in nucleotide space. The adjustment affects the values reported by the various frac_XXX methods in GenericHit and GenericHSP. =cut sub logical_length { my ($algo, $type, $len) = @_; my $logical = $len; if($algo =~ /^(?:PSI)?T(?:BLASTN|FAST(?:X|Y|XY))/oi ) { $logical = $len/3 if $type =~ /sbjct|hit|tot/i; } elsif($algo =~ /^(?:BLASTX|FAST(?:X|Y|XY))/oi ) { $logical = $len/3 if $type =~ /query|tot/i; } elsif($algo =~ /^TBLASTX/oi ) { $logical = $len/3; } return $logical; } #=head2 _adjust_contigs # # Usage : n/a; internal function called by tile_hsps # Purpose : Builds HSP contigs for a given BLAST hit. # : Utility method called by _tile_hsps() # Returns : # Argument : # Throws : Exceptions propagated from Bio::Search::Hit::BlastHSP::matches() # : for invalid sub-sequence ranges. # Status : Experimental # Comments : This method supports gapped alignments through a patch by maj # : to B:S:HSP:HSPI::matches(). # : It does not keep track of the number of HSPs that # : overlap within the amount specified by overlap(). # : This will lead to significant tracking errors for large # : overlap values. # #See Also : L(), L # #=cut sub _adjust_contigs { my ($seqType, $hsp, $start, $stop, $contigs_ref, $max_overlap, $frame, $strand) = @_; my $overlap = 0; my ($numID, $numCons); foreach (@$contigs_ref) { # Don't merge things unless they have matching strand/frame. next unless ($_->{'frame'} == $frame && $_->{'strand'} == $strand); # Test special case of a nested HSP. Skip it. if ($start >= $_->{'start'} && $stop <= $_->{'stop'}) { $overlap = 1; next; } # Test for overlap at beginning of contig, or precedes consecutively if ($start < $_->{'start'} && $stop >= ($_->{'start'} + $max_overlap - 1)) { eval { ($numID, $numCons) = $hsp->matches(-SEQ =>$seqType, -START => $start, -STOP => $_->{'start'} - 1); if ($numID eq '') { $hsp->warn("\$hsp->matches() returned '' for number identical; setting to 0"); $numID = 0; } if ($numCons eq '') { $hsp->warn("\$hsp->matches() returned '' for number conserved; setting to 0"); $numCons = 0; } }; if($@) { warn "\a\n$@\n"; } else { $_->{'start'} = $start; # Assign a new start coordinate to the contig $_->{'iden'} += $numID; # and add new data to #identical, #conserved. $_->{'cons'} += $numCons; push(@{$_->{hsps}}, $hsp); $overlap = 1; } } # Test for overlap at end of contig, or follows consecutively if ($stop > $_->{'stop'} and $start <= ($_->{'stop'} - $max_overlap + 1)) { eval { ($numID,$numCons) = $hsp->matches(-SEQ =>$seqType, -START => $_->{'stop'} + 1, -STOP => $stop); if ($numID eq '') { $hsp->warn("\$hsp->matches() returned '' for number identical; setting to 0"); $numID = 0; } if ($numCons eq '') { $hsp->warn("\$hsp->matches() returned '' for number conserved; setting to 0"); $numCons = 0; } }; if($@) { warn "\a\n$@\n"; } else { $_->{'stop'} = $stop; # Assign a new stop coordinate to the contig $_->{'iden'} += $numID; # and add new data to #identical, #conserved. $_->{'cons'} += $numCons; push(@{$_->{hsps}}, $hsp); $overlap = 1; } } last if $overlap; } if ($overlap && @$contigs_ref > 1) { ## Merge any contigs that now overlap my $max = $#{$contigs_ref}; for my $i (0..$max) { ${$contigs_ref}[$i] || next; my ($i_start, $i_stop) = (${$contigs_ref}[$i]->{start}, ${$contigs_ref}[$i]->{stop}); for my $u ($i+1..$max) { ${$contigs_ref}[$u] || next; my ($u_start, $u_stop) = (${$contigs_ref}[$u]->{start}, ${$contigs_ref}[$u]->{stop}); if ($u_start < $i_start && $u_stop >= ($i_start + $max_overlap - 1)) { # find the hsps within the contig that have sequence # extending before $i_start my ($ids, $cons) = (0, 0); my $use_start = $i_start; foreach my $hsp (sort { $b->end($seqType) <=> $a->end($seqType) } @{${$contigs_ref}[$u]->{hsps}}) { my $hsp_start = $hsp->start($seqType); $hsp_start < $use_start || next; my ($these_ids, $these_cons); eval { ($these_ids, $these_cons) = $hsp->matches(-SEQ => $seqType, -START => $hsp_start, -STOP => $use_start - 1); if ($these_ids eq '') { $hsp->warn("\$hsp->matches() returned '' for number identical; setting to 0"); $these_ids = 0; } if ($these_cons eq '') { $hsp->warn("\$hsp->matches() returned '' for number conserved; setting to 0"); $these_cons = 0; } }; if($@) { warn "\a\n$@\n"; } else { $ids += $these_ids; $cons += $these_cons; } last if $hsp_start == $u_start; $use_start = $hsp_start; } ${$contigs_ref}[$i]->{start} = $u_start; ${$contigs_ref}[$i]->{'iden'} += $ids; ${$contigs_ref}[$i]->{'cons'} += $cons; push(@{${$contigs_ref}[$i]->{hsps}}, @{${$contigs_ref}[$u]->{hsps}}); ${$contigs_ref}[$u] = undef; } elsif ($u_stop > $i_stop && $u_start <= ($i_stop - $max_overlap + 1)) { # find the hsps within the contig that have sequence # extending beyond $i_stop my ($ids, $cons) = (0, 0); my $use_stop = $i_stop; foreach my $hsp (sort { $a->start($seqType) <=> $b->start($seqType) } @{${$contigs_ref}[$u]->{hsps}}) { my $hsp_end = $hsp->end($seqType); $hsp_end > $use_stop || next; my ($these_ids, $these_cons); eval { ($these_ids, $these_cons) = $hsp->matches(-SEQ => $seqType, -START => $use_stop + 1, -STOP => $hsp_end); if ($these_ids eq '') { $hsp->warn("\$hsp->matches() returned '' for number identical; setting to 0"); $these_ids = 0; } if ($these_cons eq '') { $hsp->warn("\$hsp->matches() returned '' for number conserved; setting to 0"); $these_cons = 0; } }; if($@) { warn "\a\n$@\n"; } else { $ids += $these_ids; $cons += $these_cons; } last if $hsp_end == $u_stop; $use_stop = $hsp_end; } ${$contigs_ref}[$i]->{'stop'} = $u_stop; ${$contigs_ref}[$i]->{'iden'} += $ids; ${$contigs_ref}[$i]->{'cons'} += $cons; push(@{${$contigs_ref}[$i]->{hsps}}, @{${$contigs_ref}[$u]->{hsps}}); ${$contigs_ref}[$u] = undef; } elsif ($u_start >= $i_start && $u_stop <= $i_stop) { # nested, drop this contig #*** ideally we might do some magic to keep the stats of the # better hsp... ${$contigs_ref}[$u] = undef; } } } my @merged; foreach (@$contigs_ref) { push(@merged, $_ || next); } @{$contigs_ref} = @merged; } elsif (! $overlap) { ## If there is no overlap, add the complete HSP data. ($numID,$numCons) = $hsp->matches(-SEQ=>$seqType); if ($numID eq '') { $hsp->warn("\$hsp->matches() returned '' for number identical; setting to 0"); $numID = 0; } if ($numCons eq '') { $hsp->warn("\$hsp->matches() returned '' for number conserved; setting to 0"); $numCons = 0; } push @$contigs_ref, {'start' =>$start, 'stop' =>$stop, 'iden' =>$numID, 'cons' =>$numCons, 'strand'=>$strand,'frame'=>$frame,'hsps'=>[$hsp]}; } return $overlap; } =head2 get_exponent Usage : &get_exponent( number ); Purpose : Determines the power of 10 exponent of an integer, float, : or scientific notation number. Example : &get_exponent("4.0e-206"); : &get_exponent("0.00032"); : &get_exponent("10."); : &get_exponent("1000.0"); : &get_exponent("e+83"); Argument : Float, Integer, or scientific notation number Returns : Integer representing the exponent part of the number (+ or -). : If argument == 0 (zero), return value is "-999". Comments : Exponents are rounded up (less negative) if the mantissa is >= 5. : Exponents are rounded down (more negative) if the mantissa is <= -5. =cut sub get_exponent { my $data = shift; my($num, $exp) = split /[eE]/, $data; if( defined $exp) { $num = 1 if not $num; $num >= 5 and $exp++; $num <= -5 and $exp--; } elsif( $num == 0) { $exp = -999; } elsif( not $num =~ /\./) { $exp = CORE::length($num) -1; } else { $exp = 0; $num .= '0' if $num =~ /\.$/; my ($c); my $rev = 0; if($num !~ /^0/) { $num = reverse($num); $rev = 1; } do { $c = chop($num); $c == 0 && $exp++; } while( $c ne '.'); $exp = -$exp if $num == 0 and not $rev; $exp -= 1 if $rev; } return $exp; } =head2 collapse_nums Usage : @cnums = collapse_nums( @numbers ); Purpose : Collapses a list of numbers into a set of ranges of consecutive terms: : Useful for condensing long lists of consecutive numbers. : EXPANDED: : 1 2 3 4 5 6 10 12 13 14 15 17 18 20 21 22 24 26 30 31 32 : COLLAPSED: : 1-6 10 12-15 17 18 20-22 24 26 30-32 Argument : List of numbers sorted numerically. Returns : List of numbers mixed with ranges of numbers (see above). Throws : n/a See Also : L =cut sub collapse_nums { # This is probably not the slickest connectivity algorithm, but will do for now. my @a = @_; my ($from, $to, $i, @ca, $consec); $consec = 0; for($i=0; $i < @a; $i++) { not $from and do{ $from = $a[$i]; next; }; # pass repeated positions (gap inserts) next if $a[$i] == $a[$i-1]; if($a[$i] == $a[$i-1]+1) { $to = $a[$i]; $consec++; } else { if($consec == 1) { $from .= ",$to"; } else { $from .= $consec>1 ? "\-$to" : ""; } push @ca, split(',', $from); $from = $a[$i]; $consec = 0; $to = undef; } } if(defined $to) { if($consec == 1) { $from .= ",$to"; } else { $from .= $consec>1 ? "\-$to" : ""; } } push @ca, split(',', $from) if $from; @ca; } =head2 strip_blast_html Usage : $boolean = &strip_blast_html( string_ref ); : This method is exported. Purpose : Removes HTML formatting from a supplied string. : Attempts to restore the Blast report to enable : parsing by Bio::SearchIO::blast.pm Returns : Boolean: true if string was stripped, false if not. Argument : string_ref = reference to a string containing the whole Blast : report containing HTML formatting. Throws : Croaks if the argument is not a scalar reference. Comments : Based on code originally written by Alex Dong Li : (ali@genet.sickkids.on.ca). : This method does some Blast-specific stripping : (adds back a '>' character in front of each HSP : alignment listing). : : THIS METHOD IS VERY SENSITIVE TO BLAST FORMATTING CHANGES! : : Removal of the HTML tags and accurate reconstitution of the : non-HTML-formatted report is highly dependent on structure of : the HTML-formatted version. For example, it assumes that first : line of each alignment section (HSP listing) starts with a : anchor tag. This permits the reconstruction of the : original report in which these lines begin with a ">". : This is required for parsing. : : If the structure of the Blast report itself is not intended to : be a standard, the structure of the HTML-formatted version : is even less so. Therefore, the use of this method to : reconstitute parsable Blast reports from HTML-format versions : should be considered a temorary solution. =cut sub strip_blast_html { # This may not best way to remove html tags. However, it is simple. # it won't work under following conditions: # 1) if quoted > appears in a tag (does this ever happen?) # 2) if a tag is split over multiple lines and this method is # used to process one line at a time. my ($string_ref) = shift; ref $string_ref eq 'SCALAR' or croak ("Can't strip HTML: ". "Argument is should be a SCALAR reference not a ${\ref $string_ref}\n"); my $str = $$string_ref; my $stripped = 0; # Removing "" and adding the '>' character for # HSP alignment listings. $str =~ s/(\A|\n)]+> ?/>/sgi and $stripped = 1; # Removing all "<>" tags. $str =~ s/<[^>]+>| //sgi and $stripped = 1; # Re-uniting any lone '>' characters. $str =~ s/(\A|\n)>\s+/\n\n>/sgi and $stripped = 1; $$string_ref = $str; $stripped; } =head2 result2hash Title : result2hash Usage : my %data = &Bio::Search::SearchUtils($result) Function : converts ResultI data to simple hash Returns : hash Args : ResultI Note : used mainly as a utility for running SearchIO tests =cut sub result2hash { my ($result) = @_; my %hash; $hash{'query_name'} = $result->query_name; my $hitcount = 1; my $hspcount = 1; foreach my $hit ( $result->hits ) { $hash{"hit$hitcount\_name"} = $hit->name; # only going to test order of magnitude # too hard as these don't always match # $hash{"hit$hitcount\_signif"} = # ( sprintf("%.0e",$hit->significance) =~ /e\-?(\d+)/ ); $hash{"hit$hitcount\_bits"} = sprintf("%d",$hit->bits); foreach my $hsp ( $hit->hsps ) { $hash{"hsp$hspcount\_bits"} = sprintf("%d",$hsp->bits); # only going to test order of magnitude # too hard as these don't always match # $hash{"hsp$hspcount\_evalue"} = # ( sprintf("%.0e",$hsp->evalue) =~ /e\-?(\d+)/ ); $hash{"hsp$hspcount\_qs"} = $hsp->query->start; $hash{"hsp$hspcount\_qe"} = $hsp->query->end; $hash{"hsp$hspcount\_qstr"} = $hsp->query->strand; $hash{"hsp$hspcount\_hs"} = $hsp->hit->start; $hash{"hsp$hspcount\_he"} = $hsp->hit->end; $hash{"hsp$hspcount\_hstr"} = $hsp->hit->strand; #$hash{"hsp$hspcount\_pid"} = sprintf("%d",$hsp->percent_identity); #$hash{"hsp$hspcount\_fid"} = sprintf("%.2f",$hsp->frac_identical); $hash{"hsp$hspcount\_gaps"} = $hsp->gaps('total'); $hspcount++; } $hitcount++; } return %hash; } sub _warn_about_no_hsps { my $hit = shift; my $prev_func=(caller(1))[3]; $hit->warn("There is no HSP data for hit '".$hit->name."'.\n". "You have called a method ($prev_func)\n". "that requires HSP data and there was no HSP data for this hit,\n". "most likely because it was absent from the BLAST report.\n". "Note that by default, BLAST lists alignments for the first 250 hits,\n". "but it lists descriptions for 500 hits. If this is the case,\n". "and you care about these hits, you should re-run BLAST using the\n". "-b option (or equivalent if not using blastall) to increase the number\n". "of alignments.\n" ); } 1; BioPerl-1.6.923/Bio/Search/StatisticsI.pm000555000765000024 536712254227330 20171 0ustar00cjfieldsstaff000000000000# # # BioPerl module for wrapping runtime parameters # # Please direct questions and support issues to # # Cared for by Chad Matsalla (bioinformatics1 at dieselwurks dot com) # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::StatisticsI - A Base object for statistics =head1 SYNOPSIS # do not use this object directly, it provides the following methods # for its subclasses my $void = $obj->set_statistic("statistic_name","statistic_value"); my $value = $obj->get_statistic("statistic_name"); =head1 DESCRIPTION This is a basic container to hold the statistics returned from a program. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1 at dieselwurks dot com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::StatisticsI; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::RootI); =head2 get_statistic Title : get_statistic Usage : $statistic_object->get_statistic($statistic_name); Function: Get the value of a statistic named $statistic_name Returns : A scalar that should be a string Args : A scalar that should be a string =cut sub get_statistic { my ($self,$arg) = @_; $self->throw_not_implemented; } =head2 set_statistic Title : set_statistic Usage : $statistic_object->set_statistic($statistic_name => $statistic_value); Function: Set the value of a statistic named $statistic_name to $statistic_value Returns : Void Args : A hash containing name=>value pairs =cut sub set_statistic { my ($self,$name,$value) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/Search/Hit000755000765000024 012254227335 15746 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Search/Hit/BlastHit.pm000444000765000024 1177212254227320 20175 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::GenericHit # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::BlastHit - Blast-specific subclass of Bio::Search::Hit::GenericHit =head1 SYNOPSIS use Bio::Search::Hit::BlastHit; my $hit = Bio::Search::Hit::BlastHit->new(-algorithm => 'blastp'); # See Bio::Search::Hit::GenericHit for information about working with Hits. # TODO: Describe how to configure a SearchIO stream so that it generates # GenericHit objects. =head1 DESCRIPTION This object is a subclass of Bio::Search::Hit::GenericHit and provides some operations that facilitate working with BLAST and PSI-BLAST Hits. For general information about working with Hits, see Bio::Search::Hit::GenericHit. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich and Steve Chervitz Email jason@bioperl.org Email sac@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::BlastHit; use strict; use Bio::Search::SearchUtils; use base qw(Bio::Search::Hit::GenericHit); =head2 new Title : new Usage : my $obj = Bio::Search::Hit::GenericHit->new(); Function: Builds a new Bio::Search::Hit::GenericHit object Returns : Bio::Search::Hit::GenericHit Args : See Bio::Search::Hit::GenericHit() for other args. Here are the BLAST-specific args that can be used when creating BlastHit objects: -iteration => integer for the PSI-Blast iteration number -found_again => boolean, true if hit appears in a "previously found" section of a PSI-Blast report. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($iter,$found) = $self->_rearrange([qw(ITERATION FOUND_AGAIN )], @args); defined $iter && $self->iteration($iter); defined $found && $self->found_again($found); return $self; } =head2 iteration Usage : $hit->iteration( $iteration_num ); Purpose : Gets the iteration number in which the Hit was found. Example : $iteration_num = $sbjct->iteration(); Returns : Integer greater than or equal to 1 Non-PSI-BLAST reports will report iteration as 1, but this number is only meaningful for PSI-BLAST reports. Argument : iteration_num (optional, used when setting only) Throws : none See Also : L =cut sub iteration{ my ($self,$value) = @_; if( defined $value) { $self->{'_psiblast_iteration'} = $value; } return $self->{'_psiblast_iteration'}; } =head2 found_again Title : found_again Usage : $hit->found_again; $hit->found_again(1); Purpose : Gets a boolean indicator whether or not the hit has been found in a previous iteration. This is only applicable to PSI-BLAST reports. This method indicates if the hit was reported in the "Sequences used in model and found again" section of the PSI-BLAST report or if it was reported in the "Sequences not found previously or not previously below threshold" section of the PSI-BLAST report. Only for hits in iteration > 1. Example : if( $hit->found_again()) { ... }; Returns : Boolean, true (1) if the hit has been found in a previous PSI-BLAST iteration. Returns false (0 or undef) for hits that have not occurred in a previous PSI-BLAST iteration. Argument : Boolean (1 or 0). Only used for setting. Throws : none See Also : L =cut sub found_again { my $self = shift; return $self->{'_found_again'} = shift if @_; return $self->{'_found_again'}; } sub expect { shift->significance(@_) } 1; BioPerl-1.6.923/Bio/Search/Hit/BlastPullHit.pm000444000765000024 2167212254227330 21033 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::BlastPullHit # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::BlastPullHit - A parser and hit object for BLASTN hits =head1 SYNOPSIS # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'blast_pull', -file => 'result.blast'); while (my $result = $in->next_result) { while (my $hit = $result->next_hit) { print $hit->name, "\n"; print $hit->score, "\n"; print $hit->significance, "\n"; while (my $hsp = $hit->next_hsp) { # process HSPI objects } } } =head1 DESCRIPTION This object implements a parser for BLASTN hit output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::BlastPullHit; use strict; use Bio::Search::HSP::BlastPullHSP; use base qw(Bio::Root::Root Bio::Search::Hit::PullHitI); =head2 new Title : new Usage : my $obj = Bio::Search::Hit::BlastNHit->new(); Function: Builds a new Bio::Search::Hit::BlastNHit object. Returns : Bio::Search::Hit::BlastNHit Args : -chunk => [Bio::Root::IO, $start, $end] (required if no -parent) -parent => Bio::PullParserI object (required if no -chunk) -hit_data => array ref with [name description score significance] where the array ref provided to -chunk contains an IO object for a filehandle to something representing the raw data of the hit, and $start and $end define the tell() position within the filehandle that the hit data starts and ends (optional; defaults to start and end of the entire thing described by the filehandle) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_setup(@args); my $fields = $self->_fields; foreach my $field (qw( header start_end )) { $fields->{$field} = undef; } my $hit_data = $self->_raw_hit_data; if ($hit_data && ref($hit_data) eq 'ARRAY') { foreach my $field (qw(name description score significance)) { $fields->{$field} = shift(@{$hit_data}); } } $self->_dependencies( { ( name => 'header', length => 'header', description => 'header', accession => 'header', next_hsp => 'header', query_start => 'start_end', query_end => 'start_end', hit_start => 'start_end', hit_end => 'start_end' ) } ); return $self; } # # PullParserI discovery methods so we can answer all HitI questions # sub _discover_header { my $self = shift; $self->_chunk_seek(0); my $header = $self->_get_chunk_by_end("\n Score = "); unless ($header) { # no alignment or other data; all information was in the hit table of # the result $self->_calculate_accession_from_name; $self->_fields->{header} = 1; return; } $self->{_after_header} = $self->_chunk_tell; ($self->_fields->{name}, $self->_fields->{description}, $self->_fields->{length}) = $header =~ /^(\S+)\s+(\S.+?)?\s+Length\s*=\s*(\d+)/sm; if ($self->_fields->{description}) { $self->_fields->{description} =~ s/\n//g; } else { $self->_fields->{description} = ''; } $self->_calculate_accession_from_name; $self->_fields->{header} = 1; } sub _calculate_accession_from_name { my $self = shift; my $name = $self->get_field('name'); if ($name =~ /.+?\|.+?\|.+?\|(\w+)/) { $self->_fields->{accession} = $1; } elsif ($self->_fields->{name} =~ /.+?\|(\w+)?\./) { # old form? $self->_fields->{accession} = $1; } else { $self->_fields->{accession} = $name; } } sub _discover_start_end { my $self = shift; my ($q_start, $q_end, $h_start, $h_end); foreach my $hsp ($self->hsps) { my ($this_q_start, $this_h_start) = $hsp->start; my ($this_q_end, $this_h_end) = $hsp->end; if (! defined $q_start || $this_q_start < $q_start) { $q_start = $this_q_start; } if (! defined $h_start || $this_h_start < $h_start) { $h_start = $this_h_start; } if (! defined $q_end || $this_q_end > $q_end) { $q_end = $this_q_end; } if (! defined $h_end || $this_h_end > $h_end) { $h_end = $this_h_end; } } $self->_fields->{query_start} = $q_start; $self->_fields->{query_end} = $q_end; $self->_fields->{hit_start} = $h_start; $self->_fields->{hit_end} = $h_end; } sub _discover_next_hsp { my $self = shift; my $pos = $self->{_end_of_previous_hsp} || $self->{_after_header}; return unless $pos; $self->_chunk_seek($pos); my ($start, $end) = $self->_find_chunk_by_end("\n Score = "); if ((defined $end && ($end + $self->_chunk_true_start) > $self->_chunk_true_end) || ! $end) { $start = $self->{_end_of_previous_hsp} || $self->{_after_header}; $end = $self->_chunk_true_end; } else { $end += $self->_chunk_true_start; } $start += $self->_chunk_true_start; return if $start >= $self->_chunk_true_end; $self->{_end_of_previous_hsp} = $end - $self->_chunk_true_start; #*** needs to inherit piped_behaviour, and we need to deal with _sequential # ourselves $self->_fields->{next_hsp} = Bio::Search::HSP::BlastPullHSP->new(-parent => $self, -chunk => [$self->chunk, $start, $end]); } sub _discover_num_hsps { my $self = shift; $self->_fields->{num_hsps} = $self->hsps; } =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : L object or null if finished Args : none =cut sub next_hsp { my $self = shift; my $hsp = $self->get_field('next_hsp'); undef $self->_fields->{next_hsp}; return $hsp; } =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. Example : @hsps = $hit_object->hsps(); Returns : list of L objects. Argument : none =cut sub hsps { my $self = shift; my $old = $self->{_end_of_previous_hsp}; $self->rewind; my @hsps; while (defined(my $hsp = $self->next_hsp)) { push(@hsps, $hsp); } $self->{_end_of_previous_hsp} = $old; return @hsps; } =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single HSPI object for the present HitI object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a L object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' = highest scoring HSP. : 'worst' = lowest scoring HSP. Throws : Exception if an unrecognized argument is used. See Also : L, L() =cut sub hsp { my ($self, $type) = @_; $type ||= 'best'; $self->throw_not_implemented; } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the HSP iterator to the beginning, so that next_hsp() will subsequently return the first hsp and so on. Returns : n/a Args : none =cut sub rewind { my $self = shift; delete $self->{_end_of_previous_hsp}; } # have p() a synonym of significance() sub p { return shift->significance; } 1; BioPerl-1.6.923/Bio/Search/Hit/Fasta.pm000444000765000024 621412254227336 17503 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::Fasta # # Please direct questions and support issues to # # Cared for by Aaron Mackey # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::Fasta - Hit object specific for Fasta-generated hits =head1 SYNOPSIS # You wouldn't normally create these manually; # instead they would be produced by Bio::SearchIO::fasta use Bio::Search::Hit::Fasta; my $hit = Bio::Search::Hit::Fasta->new(id=>'LBL_6321', desc=>'lipoprotein', e_val=>0.01); =head1 DESCRIPTION L objects are data structures that contain information about specific hits obtained during a library search. Some information will be algorithm-specific, but others will be generally defined, such as the ability to obtain alignment objects corresponding to each hit. =head1 SEE ALSO L, L, L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey-at-virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::Search::Hit::Fasta; use vars qw($AUTOLOAD); use strict; use base qw(Bio::Search::Hit::HitI); my @AUTOLOAD_OK = qw(_ID _DESC _SIZE _INITN _INIT1 _OPT _ZSC _E_VAL); my %AUTOLOAD_OK = (); @AUTOLOAD_OK{@AUTOLOAD_OK} = (1) x @AUTOLOAD_OK; =head2 _initialize Function: where the heavy stuff will happen when new is called =cut sub _initialize { my($self, %args) = @_; my $make = $self->SUPER::_initialize(%args); while (my ($key, $val) = each %args) { $key = '_' . uc($key); $self->$key($val); } return $make; # success - we hope! } =head2 AUTOLOAD Function: Provide getter/setters for ID,DESC,SIZE,INITN,INIT1,OPT,ZSC,E_VAL =cut sub AUTOLOAD { my ($self, $val) = @_; $AUTOLOAD =~ s/.*:://; if ( $AUTOLOAD_OK{$AUTOLOAD} ) { $self->{$AUTOLOAD} = $val if defined $val; return $self->{$AUTOLOAD}; } else { $self->throw("Unallowed accessor: $AUTOLOAD !"); } } 1; BioPerl-1.6.923/Bio/Search/Hit/GenericHit.pm000444000765000024 16467712254227333 20545 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::GenericHit # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::GenericHit - A generic implementation of the Bio::Search::Hit::HitI interface =head1 SYNOPSIS use Bio::Search::Hit::GenericHit; my $hit = Bio::Search::Hit::GenericHit->new(-algorithm => 'blastp'); # typically one gets HitI objects from a SearchIO stream via a ResultI use Bio::SearchIO; my $parser = Bio::SearchIO->new(-format => 'blast', -file => 'result.bls'); my $result = $parser->next_result; my $hit = $result->next_hit; # TODO: Describe how to configure a SearchIO stream so that it generates # GenericHit objects. =head1 DESCRIPTION This object handles the hit data from a Database Sequence Search such as FASTA or BLAST. Unless you're writing a parser, you won't ever need to create a GenericHit or any other HitI-implementing object. If you use the SearchIO system, HitI objects are created automatically from a SearchIO stream which returns Bio::Search::Hit::HitI objects. For documentation on what you can do with GenericHit (and other HitI objects), please see the API documentation in L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich and Steve Chervitz Email jason-at-bioperl-dot-org Email sac-at-bioperl-dot-org =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::GenericHit; use strict; use Bio::Search::SearchUtils; use base qw(Bio::Root::Root Bio::Search::Hit::HitI); =head2 new Title : new Usage : my $obj = Bio::Search::Hit::GenericHit->new(); Function: Builds a new Bio::Search::Hit::GenericHit object Returns : Bio::Search::Hit::GenericHit Args : -name => Name of Hit (required) -description => Description (optional) -accession => Accession number (optional) -ncbi_gi => NCBI GI UID (optional) -length => Length of the Hit (optional) -score => Raw Score for the Hit (optional) -bits => Bit Score for the Hit (optional) -significance => Significance value for the Hit (optional) -algorithm => Algorithm used (BLASTP, FASTX, etc...) -hsps => Array ref of HSPs for this Hit. -found_again => boolean, true if hit appears in a "previously found" section of a PSI-Blast report. -hsp_factory => Bio::Factory::ObjectFactoryI able to create HSPI objects. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hsps, $name,$query_len,$desc, $acc, $locus, $length, $score,$algo,$signif,$bits, $p, $rank, $hsp_factory, $gi, $iter, $found) = $self->_rearrange([qw(HSPS NAME QUERY_LEN DESCRIPTION ACCESSION LOCUS LENGTH SCORE ALGORITHM SIGNIFICANCE BITS P RANK HSP_FACTORY NCBI_GI ITERATION FOUND_AGAIN)], @args); defined $query_len && $self->query_length($query_len); if( ! defined $name ) { $self->throw("Must have defined a valid name for Hit"); } else { $self->name($name); } defined $acc && $self->accession($acc); defined $locus && $self->locus($locus); defined $desc && $self->description($desc); defined $length && $self->length($length); defined $algo && $self->algorithm($algo); defined $signif && $self->significance($signif); defined $score && $self->raw_score($score); defined $bits && $self->bits($bits); defined $rank && $self->rank($rank); defined $hsp_factory && $self->hsp_factory($hsp_factory); defined $gi && $self->ncbi_gi($gi); defined $iter && $self->iteration($iter); defined $found && $self->found_again($found); # p() has a weird interface, so this is a hack workaround if (defined $p) { $self->{_p} = $p; } $self->{'_iterator'} = 0; if( defined $hsps ) { if( ref($hsps) !~ /array/i ) { $self->warn("Did not specify a valid array ref for the param HSPS ($hsps)"); } else { my $hspcount=0; while( @{$hsps} ) { $hspcount++; $self->add_hsp(shift @{$hsps} ); } $self->{'_hsps'} = undef if $hspcount == 0; } } else { $self->{'_hsps'} = undef; } return $self; } =head2 add_hsp Title : add_hsp Usage : $hit->add_hsp($hsp) Function: Add a HSP to the collection of HSPs for a Hit Returns : number of HSPs in the Hit Args : Bio::Search::HSP::HSPI object, OR hash ref containing data suitable for creating a HSPI object (&hsp_factory must be set to get it back) =cut sub add_hsp { my ($self,$hsp) = @_; if (!defined $hsp || (ref($hsp) ne 'HASH' && !$hsp->isa('Bio::Search::HSP::HSPI'))) { $self->throw("Must provide a valid Bio::Search::HSP::HSPI object or hash ref to object: $self method: add_hsp value: $hsp"); return; } push @{$self->{'_hsps'}}, $hsp; if (ref($hsp) eq 'HASH') { $self->{_hashes}->{$#{$self->{'_hsps'}}} = 1; } return scalar @{$self->{'_hsps'}}; } =head2 hsp_factory Title : hsp_factory Usage : $hit->hsp_factory($hsp_factory) Function: Get/set the factory used to build HSPI objects if necessary. Returns : Bio::Factory::ObjectFactoryI Args : Bio::Factory::ObjectFactoryI =cut sub hsp_factory { my $self = shift; if (@_) { $self->{_hsp_factory} = shift } return $self->{_hsp_factory} || return; } =head2 Bio::Search::Hit::HitI methods Implementation of Bio::Search::Hit::HitI methods =head2 name Title : name Usage : $hit_name = $hit->name(); Function: returns the name of the Hit sequence Returns : a scalar string Args : [optional] scalar string to set the name =cut sub name { my ($self,$value) = @_; my $previous = $self->{'_name'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_name'} = $value; } return $previous; } =head2 accession Title : accession Usage : $acc = $hit->accession(); Function: Retrieve the accession (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub accession { my ($self,$value) = @_; my $previous = $self->{'_accession'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_accession'} = $value; } return $previous; } =head2 description Title : description Usage : $desc = $hit->description(); Function: Retrieve the description for the hit Returns : a scalar string Args : [optional] scalar string to set the descrition =cut sub description { my ($self,$value) = @_; my $previous = $self->{'_description'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_description'} = $value; } return $previous; } =head2 length Title : length Usage : my $len = $hit->length Function: Returns the length of the hit Returns : integer Args : [optional] integer to set the length =cut sub length { my ($self,$value) = @_; my $previous = $self->{'_length'}; if( defined $value || ! defined $previous ) { $value = $previous = 0 unless defined $value; $self->{'_length'} = $value; } return $previous; } =head2 algorithm Title : algorithm Usage : $alg = $hit->algorithm(); Function: Gets the algorithm specification that was used to obtain the hit For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : [optional] scalar string to set the algorithm =cut sub algorithm { my ($self,$value) = @_; my $previous = $self->{'_algorithm'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_algorithm'} = $value; } return $previous; } =head2 raw_score Title : raw_score Usage : $score = $hit->raw_score(); Function: Gets the "raw score" generated by the algorithm. What this score is exactly will vary from algorithm to algorithm, returning undef if unavailable. Returns : a scalar value Args : [optional] scalar value to set the raw score =cut sub raw_score { my ($self,$value) = @_; my $previous = $self->{'_score'}; if( defined $value ) { $self->{'_score'} = $value; } elsif ( ! defined $previous ) { # Set the bits of the Hit to that of the top HSP. unless( defined $self->{'_hsps'}->[0] ) { $self->warn("No HSPs for this minimal Hit (".$self->name.")\n". "If using NCBI BLAST, check bits() instead"); return; } # use 'score' if available if ( defined( ($self->hsps)[0]->score ) ) { $previous = $self->{'_score'} = ($self->hsps)[0]->score; } # otherwise use 'bits' elsif ( defined( ($self->hsps)[0]->bits ) ) { $previous = $self->{'_score'} = ($self->hsps)[0]->bits; } } return $previous; } =head2 score Equivalent to L =cut sub score { shift->raw_score(@_); } =head2 significance Title : significance Usage : $significance = $hit->significance(); Function: Used to obtain the E or P value of a hit, i.e. the probability that this particular hit was obtained purely by random chance. If information is not available (nor calculatable from other information sources), return undef. Returns : a scalar value or undef if unavailable Args : [optional] scalar value to set the significance =cut sub significance { my ($self,$value) = @_; my $previous = $self->{'_significance'}; if( defined $value ) { $self->{'_significance'} = $value; } elsif ( ! defined $previous ) { unless( defined $self->{'_hsps'}->[0] ) { $self->warn("No HSPs for this Hit (".$self->name.")"); return; } # Set the significance of the Hit to that of the top HSP. $previous = $self->{'_significance'} = ($self->hsps)[0]->significance; } return $previous; } =head2 bits Usage : $hit_object->bits(); Purpose : Gets the bit score of the best HSP for the current hit. Example : $bits = $hit_object->bits(); Returns : Integer or undef if bit score is not set Argument : n/a Comments : For BLAST1, the non-bit score is listed in the summary line. See Also : L =cut sub bits { my ($self,$value) = @_; my $previous = $self->{'_bits'}; if( defined $value ) { $self->{'_bits'} = $value; } elsif ( ! defined $previous ) { # Set the bits of the Hit to that of the top HSP. unless( defined $self->{'_hsps'}->[0] ) { $self->warn("No HSPs for this minimal Hit (".$self->name.")\n". "If using WU-BLAST, check raw_score() instead"); return; } $previous = $self->{'_bits'} = ($self->hsps)[0]->bits; } return $previous; } =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : Bio::Search::HSP::HSPI object or null if finished Args : none =cut sub next_hsp { my $self = shift; $self->{'_iterator'} = 0 unless defined $self->{'_iterator'}; return unless defined($self->{'_hsps'}) && $self->{'_iterator'} <= scalar @{$self->{'_hsps'}}; my $iterator = $self->{'_iterator'}++; my $hsp = $self->{'_hsps'}->[$iterator] || return; if (ref($hsp) eq 'HASH') { my $factory = $self->hsp_factory || $self->throw("Tried to get a HSP, but it was a hash ref and we have no hsp factory"); $hsp = $factory->create_object(%{$hsp}); $self->{'_hsps'}->[$iterator] = $hsp; delete $self->{_hashes}->{$iterator}; } return $hsp; } =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. : Get the numbers of HSPs for the current hit. Example : @hsps = $hit_object->hsps(); : $num = $hit_object->hsps(); # alternatively, use num_hsps() Returns : Array context : list of Bio::Search::HSP::BlastHSP.pm objects. : Scalar context: integer (number of HSPs). : (Equivalent to num_hsps()). Argument : n/a. Relies on wantarray Throws : Exception if the HSPs have not been collected. See Also : L, L =cut sub hsps { my $self = shift; foreach my $i (keys %{$self->{_hashes} || {}}) { my $factory = $self->hsp_factory || $self->throw("Tried to get a HSP, but it was a hash ref and we have no hsp factory"); $self->{'_hsps'}->[$i] = $factory->create_object(%{$self->{'_hsps'}->[$i]}); delete $self->{_hashes}->{$i}; } return wantarray() ? @{$self->{'_hsps'} || []} : scalar(@{$self->{'_hsps'} || []}); } =head2 num_hsps Usage : $hit_object->num_hsps(); Purpose : Get the number of HSPs for the present hit. Example : $nhsps = $hit_object->num_hsps(); Returns : Integer or '-' if HSPs have not been callected Argument : n/a See Also : L =cut sub num_hsps { my $self = shift; unless ($self->{'_hsps'}) { return '-'; } return scalar(@{$self->{'_hsps'}}); } =head2 rewind Title : rewind Usage : $hit->rewind; Function: Allow one to reset the HSP iterator to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind{ my ($self) = @_; $self->{'_iterator'} = 0; } =head2 ambiguous_aln Usage : $ambig_code = $hit_object->ambiguous_aln(); Purpose : Sets/Gets ambiguity code data member. Example : (see usage) Returns : String = 'q', 's', 'qs', '-' : 'q' = query sequence contains overlapping sub-sequences : while sbjct does not. : 's' = sbjct sequence contains overlapping sub-sequences : while query does not. : 'qs' = query and sbjct sequence contains overlapping sub-sequences : relative to each other. : '-' = query and sbjct sequence do not contains multiple domains : relative to each other OR both contain the same distribution : of similar domains. Argument : n/a Throws : n/a Comment : Note: "sbjct" is synonymous with "hit" =cut sub ambiguous_aln { my $self = shift; if(@_) { $self->{'_ambiguous_aln'} = shift; } $self->{'_ambiguous_aln'} || '-'; } =head2 overlap See documentation in L =cut sub overlap { my $self = shift; if(@_) { $self->{'_overlap'} = shift; } defined $self->{'_overlap'} ? $self->{'_overlap'} : 0; } =head2 n Usage : $hit_object->n(); Purpose : Gets the N number for the current hit. : This is the number of HSPs in the set which was ascribed : the lowest P-value (listed on the description line). : This number is not the same as the total number of HSPs. : To get the total number of HSPs, use num_hsps(). Example : $n = $hit_object->n(); Returns : Integer Argument : n/a Throws : Exception if HSPs have not been set (BLAST2 reports). Comments : Note that the N parameter is not reported in gapped BLAST2. : Calling n() on such reports will result in a call to num_hsps(). : The num_hsps() method will count the actual number of : HSPs in the alignment listing, which may exceed N in : some cases. See Also : L =cut sub n { my $self = shift; # The check for $self->{'_n'} is a remnant from the 'query' mode days # in which the sbjct object would collect data from the description # line only. my ($n); if(not defined($self->{'_n'})) { if( $self->hsp ) { $n = $self->hsp->n; } } else { $n = $self->{'_n'}; } $n ||= $self->num_hsps; return $n; } =head2 p Usage : $hit_object->p( [format] ); Purpose : Get the P-value for the best HSP of the given BLAST hit. : (Note that P-values are not provided with NCBI Blast2 reports). Example : $p = $sbjct->p; : $p = $sbjct->p('exp'); # get exponent only. : ($num, $exp) = $sbjct->p('parts'); # split sci notation into parts Returns : Float or scientific notation number (the raw P-value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and P-value : is in scientific notation (See Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (See Comments). Throws : Warns if no P-value is defined. Uses expect instead. Comments : Using the 'parts' argument is not recommended since it will not : work as expected if the P-value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut sub p { # Some duplication of logic for p(), expect() and signif() for the sake of performance. my ($self, $fmt) = @_; my $val = $self->{'_p'}; # $val can be zero. if(!defined $val) { # P-value not defined, must be a NCBI Blast2 report. # Use expect instead. $self->warn( "P-value not defined. Using significance() instead."); $val = $self->significance(); } return $val if not $fmt or $fmt =~ /^raw/i; ## Special formats: exponent-only or as list. return &Bio::Search::SearchUtils::get_exponent($val) if $fmt =~ /^exp/i; return (split (/eE/, $val)) if $fmt =~ /^parts/i; ## Default: return the raw P-value. return $val; } =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single HSPI object for the present HitI object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a Bio::Search::HSP::BlastHSP.pm object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' or 'first' = highest scoring HSP. : 'worst' or 'last' = lowest scoring HSP. Throws : Exception if the HSPs have not been collected. : Exception if an unrecognized argument is used. See Also : L, L() =cut sub hsp { my( $self, $option ) = @_; $option ||= 'best'; if (not ref $self->{'_hsps'}) { $self->throw("Can't get HSPs: data not collected."); } my @hsps = $self->hsps; return $hsps[0] if $option =~ /best|first|1/i; return $hsps[$#hsps] if $option =~ /worst|last/i; $self->throw("Can't get HSP for: $option\n" . "Valid arguments: 'best', 'worst'"); } =head2 logical_length Usage : $hit_object->logical_length( [seq_type] ); : (mostly intended for internal use). Purpose : Get the logical length of the hit sequence. : This is necessary since the number of identical/conserved residues : can be in terms of peptide sequence space, yet the query and/or hit : sequence are in nucleotide space. Example : $len = $hit_object->logical_length(); Returns : Integer Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : : In the case of BLAST flavors: : For TBLASTN reports, the length of the aligned portion of the : nucleotide hit sequence is divided by 3; for BLASTX reports, : the length of the aligned portion of the nucleotide query : sequence is divided by 3. For TBLASTX reports, the length of : both hit and query sequence are converted. : : This is important for functions like frac_aligned_query() : which need to operate in amino acid coordinate space when dealing : with [T]BLAST[NX] type reports. See Also : L, L, L =cut sub logical_length { my $self = shift; my $seqType = shift || 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my ($length, $logical); my $algo = $self->algorithm; # For the sbjct, return logical sbjct length if( $seqType eq 'sbjct' ) { $length = $self->length; } else { # Otherwise, return logical query length $length = $self->query_length(); $self->throw("Must have defined query_len") unless ( $length ); } $logical = Bio::Search::SearchUtils::logical_length($algo, $seqType, $length); return int($logical); } =head2 length_aln Usage : $hit_object->length_aln( [seq_type] ); Purpose : Get the total length of the aligned region for query or sbjct seq. : This number will include all HSPs Example : $len = $hit_object->length_aln(); # default = query : $lenAln = $hit_object->length_aln('query'); Returns : Integer Argument : seq_Type = 'query' or 'hit' or 'sbjct' (Default = 'query') ('sbjct' is synonymous with 'hit') Throws : Exception if the argument is not recognized. Comments : This method will report the logical length of the alignment, : meaning that for TBLAST[NX] reports, the length is reported : using amino acid coordinate space (i.e., nucleotides / 3). : : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling length() on each (use hsps() to get all HSPs). See Also : L, L, L, L, L, L =cut sub length_aln { my( $self, $seqType, $num ) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; # Setter: if( defined $num) { return $self->{'_length_aln_'.$seqType} = $num; } unless ($self->{'_hsps'}) { #return wantarray ? ('-','-') : '-'; Bio::Search::SearchUtils::_warn_about_no_hsps($self); return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; my $data = $self->{'_length_aln_'.$seqType}; ## If we don't have data, figure out what went wrong. if(!$data) { $self->throw("Can't get length aln for sequence type \"$seqType\". " . "Valid types are 'query', 'hit', 'sbjct' ('sbjct' = 'hit')"); } return $data; } =head2 gaps Usage : $hit_object->gaps( [seq_type] ); Purpose : Get the number of gaps in the aligned query, hit, or both sequences. : Data is summed across all HSPs. Example : $qgaps = $hit_object->gaps('query'); : $hgaps = $hit_object->gaps('hit'); : $tgaps = $hit_object->gaps(); # default = total (query + hit) Returns : scalar context: integer : array context without args: two-element list of integers : (queryGaps, hitGaps) : Array context can be forced by providing an argument of 'list' or 'array'. : : CAUTION: Calling this method within printf or sprintf is arrray context. : So this function may not give you what you expect. For example: : printf "Total gaps: %d", $hit->gaps(); : Actually returns a two-element array, so what gets printed : is the number of gaps in the query, not the total : Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' | 'list' (default = 'total') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : If you need data for each HSP, use hsps() and then interate : through each HSP object. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : Not relying on wantarray since that will fail in situations : such as printf "%d", $hit->gaps() in which you might expect to : be printing the total gaps, but evaluates to array context. See Also : L =cut sub gaps { my( $self, $seqType, $num ) = @_; $seqType ||= (wantarray ? 'list' : 'total'); $seqType = 'sbjct' if $seqType eq 'hit'; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); return wantarray ? ('-','-') : '-'; #return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; $seqType = lc($seqType); if( defined $num ) { $self->throw("Can't set gaps for seqType '$seqType'. Must be 'query' or 'hit'\n") unless ($seqType eq 'sbjct' or $seqType eq 'query'); return $self->{'_gaps_'.$seqType} = $num; } elsif($seqType =~ /list|array/i) { return ($self->{'_gaps_query'}, $self->{'_gaps_sbjct'}); } elsif($seqType eq 'total') { return ($self->{'_gaps_query'} + $self->{'_gaps_sbjct'}) || 0; } else { return $self->{'_gaps_'.$seqType} || 0; } } =head2 matches See documentation in L =cut sub matches { my( $self, $arg1, $arg2) = @_; my(@data,$data); unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); return wantarray ? ('-','-') : '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; unless( $arg1 ) { @data = ($self->{'_totalIdentical'}, $self->{'_totalConserved'}); return @data; } else { if( defined $arg2 ) { $self->{'_totalIdentical'} = $arg1; $self->{'_totalConserved'} = $arg2; return ( $arg1, $arg2 ); } elsif($arg1 =~ /^id/i) { $data = $self->{'_totalIdentical'}; } else { $data = $self->{'_totalConserved'}; } #print STDERR "\nmatches(): id=$self->{'_totalIdentical'}, cons=$self->{'_totalConserved'}\n\n"; return $data; } ## If we make it to here, it is likely the case that ## the parser constructed a minimal hit object from the summary line only. ## It either delibrately skipped parsing the alignment section, ## or was not able to because it was absent (due to blast executable parameter ## setting such as -b 0 (B=0 for WU-BLAST) ) #$self->throw("Can't get identical or conserved data: no data."); } =head2 start Usage : $sbjct->start( [seq_type] ); Purpose : Gets the start coordinate for the query, sbjct, or both sequences : in the BlastHit object. If there is more than one HSP, the lowest start : value of all HSPs is returned. Example : $qbeg = $sbjct->start('query'); : $sbeg = $sbjct->start('hit'); : ($qbeg, $sbeg) = $sbjct->start(); Returns : scalar context: integer : array context without args: list of two integers (queryStart, sbjctStart) : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L, L, L =cut sub start { my ($self, $seqType, $num) = @_; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); return wantarray ? ('-','-') : '-'; } $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; if( defined $num ) { $seqType = "_\L$seqType\E"; return $self->{$seqType.'Start'} = $num; } # If there is only one HSP, defer this call to the solitary HSP. if($self->num_hsps == 1) { return $self->hsp->start($seqType); } else { # Tiling normally generates $self->{'_queryStart'} and # $self->{'_sbjctStart'}, but is very slow. If we haven't tiled, # find the answer quickly without tiling. unless (defined $self->{'_queryStart'}) { my $earliest_query_start; my $earliest_sbjct_start; foreach my $hsp ($self->hsps) { my $this_query_start = $hsp->start('query'); if (! defined $earliest_query_start || $this_query_start < $earliest_query_start) { $earliest_query_start = $this_query_start; } my $this_sbjct_start = $hsp->start('sbjct'); if (! defined $earliest_sbjct_start || $this_sbjct_start < $earliest_sbjct_start) { $earliest_sbjct_start = $this_sbjct_start; } } $self->{'_queryStart'} = $earliest_query_start; $self->{'_sbjctStart'} = $earliest_sbjct_start; } if ($seqType =~ /list|array/i) { return ($self->{'_queryStart'}, $self->{'_sbjctStart'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Start'}; } } } =head2 end Usage : $sbjct->end( [seq_type] ); Purpose : Gets the end coordinate for the query, sbjct, or both sequences : in the BlastHit object. If there is more than one HSP, the largest end : value of all HSPs is returned. Example : $qend = $sbjct->end('query'); : $send = $sbjct->end('hit'); : ($qend, $send) = $sbjct->end(); Returns : scalar context: integer : array context without args: list of two integers : (queryEnd, sbjctEnd) : Array context can be "induced" by providing an argument : of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'sbjct' : (case insensitive). If not supplied, 'query' is used. Throws : n/a See Also : L, L, L =cut sub end { my ($self, $seqType, $num) = @_; unless ($self->{'_hsps'}) { return wantarray ? ('-','-') : '-'; } $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; if( defined $num ) { $seqType = "_\L$seqType\E"; return $self->{$seqType.'Stop'} = $num; } # If there is only one HSP, defer this call to the solitary HSP. if($self->num_hsps == 1) { return $self->hsp->end($seqType); } else { # Tiling normally generates $self->{'_queryStop'} and # $self->{'_sbjctStop'}, but is very slow. If we haven't tiled, # find the answer quickly without tiling. unless (defined $self->{'_queryStop'}) { my $latest_query_end; my $latest_sbjct_end; foreach my $hsp ($self->hsps) { my $this_query_end = $hsp->end('query'); if (! defined $latest_query_end || $this_query_end > $latest_query_end) { $latest_query_end = $this_query_end; } my $this_sbjct_end = $hsp->end('sbjct'); if (! defined $latest_sbjct_end || $this_sbjct_end > $latest_sbjct_end) { $latest_sbjct_end = $this_sbjct_end; } } $self->{'_queryStop'} = $latest_query_end; $self->{'_sbjctStop'} = $latest_sbjct_end; } if($seqType =~ /list|array/i) { return ($self->{'_queryStop'}, $self->{'_sbjctStop'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Stop'}; } } } =head2 range Usage : $sbjct->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($qbeg, $qend) = $sbjct->range('query'); : ($sbeg, $send) = $sbjct->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut sub range { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; return ($self->start($seqType), $self->end($seqType)); } =head2 frac_identical Usage : $hit_object->frac_identical( [seq_type] ); Purpose : Get the overall fraction of identical positions across all HSPs. : The number refers to only the aligned regions and does not : account for unaligned regions in between the HSPs, if any. Example : $frac_iden = $hit_object->frac_identical('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' : default = 'query' (but see comments below). : ('sbjct' is synonymous with 'hit') Throws : n/a Comments : : To compute the fraction identical, the logical length of the : aligned portion of the sequence is used, meaning that : in the case of BLAST flavors, for TBLASTN reports, the length of : the aligned portion of the : nucleotide hit sequence is divided by 3; for BLASTX reports, : the length of the aligned portion of the nucleotide query : sequence is divided by 3. For TBLASTX reports, the length of : both hit and query sequence are converted. : This is necessary since the number of identical residues is : in terms of peptide sequence space. : : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Identical = 34/120 Positives = 67/120". : NCBI BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : : Therefore, when called with an argument of 'total', : this method will report different values depending on the : version of BLAST used. Total does NOT take into account HSP : tiling, so it should not be used. : : To get the fraction identical among only the aligned residues, : ignoring the gaps, call this method without an argument or : with an argument of 'query' or 'hit'. : : If you need data for each HSP, use hsps() and then iterate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, L, L =cut sub frac_identical { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name format. $seqType = lc($seqType); unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; my $ident = $self->matches('id'); my $total = $self->length_aln($seqType); my $ratio = $ident / $total; my $ratio_rounded = sprintf( "%.3f", $ratio); # Round down iff normal rounding yields 1 (just like blast) $ratio_rounded = 0.999 if (($ratio_rounded == 1) && ($ratio < 1)); return $ratio_rounded; } =head2 frac_conserved Usage : $hit_object->frac_conserved( [seq_type] ); Purpose : Get the overall fraction of conserved positions across all HSPs. : The number refers to only the aligned regions and does not : account for unaligned regions in between the HSPs, if any. Example : $frac_cons = $hit_object->frac_conserved('hit'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' : default = 'query' (but see comments below). : ('sbjct' is synonymous with 'hit') Throws : n/a Comments : : To compute the fraction conserved, the logical length of the : aligned portion of the sequence is used, meaning that : in the case of BLAST flavors, for TBLASTN reports, the length of : the aligned portion of the : nucleotide hit sequence is divided by 3; for BLASTX reports, : the length of the aligned portion of the nucleotide query : sequence is divided by 3. For TBLASTX reports, the length of : both hit and query sequence are converted. : This is necessary since the number of conserved residues is : in terms of peptide sequence space. : : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Positives = 34/120 Positives = 67/120". : NCBI BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : : Therefore, when called with an argument of 'total', : this method will report different values depending on the : version of BLAST used. Total does NOT take into account HSP : tiling, so it should not be used. : : To get the fraction conserved among only the aligned residues, : ignoring the gaps, call this method without an argument or : with an argument of 'query' or 'hit'. : : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, L =cut sub frac_conserved { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name format. $seqType = lc($seqType); unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; my $consv = $self->matches('cons'); my $total = $self->length_aln($seqType); my $ratio = $consv / $total; my $ratio_rounded = sprintf( "%.3f", $ratio); # Round down iff normal rounding yields 1 (just like blast) $ratio_rounded = 0.999 if (($ratio_rounded == 1) && ($ratio < 1)); return $ratio_rounded; } =head2 frac_aligned_query Usage : $hit_object->frac_aligned_query(); Purpose : Get the fraction of the query sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_query(); Returns : Float (2-decimal precision, e.g., 0.75). Argument : n/a Throws : n/a Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, L, L =cut sub frac_aligned_query { my $self = shift; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; sprintf( "%.2f", $self->length_aln('query') / $self->logical_length('query')); } =head2 frac_aligned_hit Usage : $hit_object->frac_aligned_hit(); Purpose : Get the fraction of the hit (sbjct) sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_hit(); Returns : Float (2-decimal precision, e.g., 0.75). Argument : n/a Throws : n/a Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, , L, L, L =cut sub frac_aligned_hit { my $self = shift; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; sprintf( "%.2f", $self->length_aln('sbjct') / $self->logical_length('sbjct')); } ## These methods are being maintained for backward compatibility. =head2 frac_aligned_sbjct Same as L =cut *frac_aligned_sbjct = \&frac_aligned_hit; =head2 num_unaligned_sbjct Same as L =cut *num_unaligned_sbjct = \&num_unaligned_hit; =head2 num_unaligned_hit Usage : $hit_object->num_unaligned_hit(); Purpose : Get the number of the unaligned residues in the hit sequence. : Sums across all all HSPs. Example : $num_unaln = $hit_object->num_unaligned_hit(); Returns : Integer Argument : n/a Throws : n/a Comments : See notes regarding logical lengths in the comments for frac_aligned_hit(). : They apply here as well. : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. See Also : L, L, L =cut sub num_unaligned_hit { my $self = shift; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; my $num = $self->logical_length('sbjct') - $self->length_aln('sbjct'); ($num < 0 ? 0 : $num ); } =head2 num_unaligned_query Usage : $hit_object->num_unaligned_query(); Purpose : Get the number of the unaligned residues in the query sequence. : Sums across all all HSPs. Example : $num_unaln = $hit_object->num_unaligned_query(); Returns : Integer Argument : n/a Throws : n/a Comments : See notes regarding logical lengths in the comments for frac_aligned_query(). : They apply here as well. : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. See Also : L, L, L =cut sub num_unaligned_query { my $self = shift; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; my $num = $self->logical_length('query') - $self->length_aln('query'); ($num < 0 ? 0 : $num ); } =head2 seq_inds Usage : $hit->seq_inds( seq_type, class, collapse ); Purpose : Get a list of residue positions (indices) across all HSPs : for identical or conserved residues in the query or sbjct sequence. Example : @s_ind = $hit->seq_inds('query', 'identical'); : @h_ind = $hit->seq_inds('hit', 'conserved'); : @h_ind = $hit->seq_inds('hit', 'conserved', 1); Returns : Array of integers : May include ranges if collapse is non-zero. Argument : [0] seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') : [1] class = 'identical' or 'conserved' (default = 'identical') : (can be shortened to 'id' or 'cons') : (actually, anything not 'id' will evaluate to 'conserved'). : [2] collapse = boolean, if non-zero, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. Throws : n/a. See Also : L =cut sub seq_inds { my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'sbjct' if $seqType eq 'hit'; my (@inds, $hsp); foreach $hsp ($self->hsps) { # This will merge data for all HSPs together. push @inds, $hsp->seq_inds($seqType, $class); } # Need to remove duplicates and sort the merged positions. if(@inds) { my %tmp = map { $_, 1 } @inds; @inds = sort {$a <=> $b} keys %tmp; } $collapse ? &Bio::Search::SearchUtils::collapse_nums(@inds) : @inds; } =head2 strand See documentation in L =cut sub strand { my ($self, $seqType, $strnd) = @_; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); return wantarray ? ('-','-') : '-'; #return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; $seqType = lc($seqType); if( defined $strnd ) { $self->throw("Can't set strand for seqType '$seqType'. Must be 'query' or 'hit'\n") unless ($seqType eq 'sbjct' or $seqType eq 'query'); return $self->{'_strand_'.$seqType} = $strnd; } my ($qstr, $hstr); # If there is only one HSP, defer this call to the solitary HSP. if($self->num_hsps == 1) { return $self->hsp->strand($seqType); } elsif( defined $self->{'_strand_query'}) { # Get the data computed during hsp tiling. $qstr = $self->{'_strand_query'}; $hstr = $self->{'_strand_sbjct'} } else { # otherwise, iterate through all HSPs collecting strand info. # This will return the string "-1/1" if there are HSPs on different strands. # NOTE: This was the pre-10/21/02 procedure which will no longer be used, # (unless the above elsif{} is commented out). my (%qstr, %hstr); foreach my $hsp( $self->hsps ) { my ( $q, $h ) = $hsp->strand(); $qstr{ $q }++; $hstr{ $h }++; } $qstr = join( '/', sort keys %qstr); $hstr = join( '/', sort keys %hstr); } if($seqType =~ /list|array/i) { return ($qstr, $hstr); } elsif( $seqType eq 'query' ) { return $qstr; } else { return $hstr; } } =head2 frame See documentation in L =cut sub frame { my( $self, $frm ) = @_; unless ($self->{'_hsps'}) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); #return wantarray ? ('-','-') : '-'; return '-'; } Bio::Search::SearchUtils::tile_hsps($self) unless $self->tiled_hsps; if( defined $frm ) { return $self->{'_frame'} = $frm; } # The check for $self->{'_frame'} is a remnant from the 'query' mode days # in which the sbjct object would collect data from the description line only. my ($frame); if(not defined($self->{'_frame'})) { $frame = $self->hsp->frame('hit'); } else { $frame = $self->{'_frame'}; } return $frame; } =head2 rank Title : rank Usage : $obj->rank($newval) Function: Get/Set the rank of this Hit in the Query search list i.e. this is the Nth hit for a specific query Returns : value of rank Args : newvalue (optional) =cut sub rank { my $self = shift; return $self->{'_rank'} = shift if @_; return $self->{'_rank'} || 1; } =head2 locus Title : locus Usage : $locus = $hit->locus(); Function: Retrieve the locus (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub locus { my ($self,$value) = @_; my $previous = $self->{'_locus'}; if( defined $value || ! defined $previous ) { unless (defined $value) { if ($self->{'_name'} =~/(gb|emb|dbj|ref)\|(.*)\|(.*)/) { $value = $previous = $3; } else { $value = $previous = ''; } } $self->{'_locus'} = $value; } return $previous; } =head2 each_accession_number Title : each_accession_number Usage : @each_accession_number = $hit->each_accession_number(); Function: Get each accession number listed in the description of the hit. If there are no alternatives, then only the primary accession will be given Returns : list of all accession numbers in the description Args : none =cut sub each_accession_number { my ($self,$value) = @_; my $desc = $self->{'_description'}; #put primary accnum on the list my @accnums; push (@accnums,$self->{'_accession'}); if( defined $desc ) { while ($desc =~ /(\b\S+\|\S*\|\S*\s?)/g) { my $id = $1; my ($acc, $version); if ($id =~ /(gb|emb|dbj|sp|pdb|bbs|ref|tp[gde])\|(.*)\|(.*)/) { ($acc, $version) = split /\./, $2; } elsif ($id =~ /(pir|prf|pat|gnl)\|(.*)\|(.*)/) { ($acc, $version) = split /\./, $3; } elsif( $id =~ /(gim|gi|bbm|bbs|lcl)\|(\d*)/) { $acc = $id; } elsif( $id =~ /(oth)\|(.*)\|(.*)\|(.*)/ ) { # discontinued... ($acc,$version) = ($2); } else { #punt, not matching the db's at ftp://ftp.ncbi.nih.gov/blast/db/README #Database Name Identifier Syntax #============================ ======================== #GenBank gb|accession|locus #EMBL Data Library emb|accession|locus #DDBJ, DNA Database of Japan dbj|accession|locus #NBRF PIR pir||entry #Protein Research Foundation prf||name #SWISS-PROT sp|accession|entry name #Brookhaven Protein Data Bank pdb|entry|chain #Patents pat|country|number #GenInfo Backbone Id bbs|number #General database identifier gnl|database|identifier #NCBI Reference Sequence ref|accession|locus #Local Sequence identifier lcl|identifier $acc=$id; } push(@accnums, $acc); } } return @accnums; } =head2 tiled_hsps See documentation in L =cut sub tiled_hsps { my $self = shift; return $self->{'_tiled_hsps'} = shift if @_; return $self->{'_tiled_hsps'}; } =head2 query_length Title : query_length Usage : $obj->query_length($newval) Function: Get/Set the query_length Returns : value of query_length (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub query_length { my $self = shift; return $self->{'_query_length'} = shift if @_; return $self->{'_query_length'}; } =head2 ncbi_gi Title : ncbi_gi Usage : $acc = $hit->ncbi_gi(); Function: Retrieve the NCBI Unique ID (aka the GI #), if available, for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub ncbi_gi { my ($self,$value) = @_; if( defined $value ) { $self->{'_ncbi_gi'} = $value; } else { $self->{'_ncbi_gi'} = $self->name =~ m{^gi\|(\d+)} ? $1 : ''; } return $self->{'_ncbi_gi'}; } # sort method for HSPs =head2 sort_hits Title : sort_hsps Usage : $result->sort_hsps(\&sort_function) Function : Sorts the available HSP objects by a user-supplied function. Defaults to sort by descending score. Returns : n/a Args : A coderef for the sort function. See the documentation on the Perl sort() function for guidelines on writing sort functions. Note : To access the special variables $a and $b used by the Perl sort() function the user function must access Bio::Search::Hit::HitI namespace. For example, use : $hit->sort_hsps( sub{$Bio::Search::Result::HitI::a->length <=> $Bio::Search::Result::HitI::b->length}); NOT $hit->sort_hsps($a->length <=> $b->length); =cut sub sort_hsps { my ($self, $coderef) = @_; my @sorted_hsps; if ($coderef) { $self->throw('sort_hsps requires a sort function passed as a subroutine reference') unless (ref($coderef) eq 'CODE'); } else { $coderef = \&_default_sort_hsps; # throw a warning? } my @hsps = $self->hsps(); eval {@sorted_hsps = sort $coderef @hsps }; if ($@) { $self->throw("Unable to sort hsps: $@"); } else { $self->{'_hsps'} = \@sorted_hsps; 1; } } =head2 iteration Usage : $hit->iteration( $iteration_num ); Purpose : Gets the iteration number in which the Hit was found. Example : $iteration_num = $sbjct->iteration(); Returns : Integer greater than or equal to 1 Non-PSI-BLAST reports may report iteration as 1, but this number is only meaningful for PSI-BLAST reports. Argument : iteration_num (optional, used when setting only) Throws : none See Also : L =cut sub iteration{ my ($self,$value) = @_; if( defined $value) { $self->{'_psiblast_iteration'} = $value; } return $self->{'_psiblast_iteration'}; } =head2 found_again Title : found_again Usage : $hit->found_again; $hit->found_again(1); Purpose : Gets a boolean indicator whether or not the hit has been found in a previous iteration. This is only applicable to PSI-BLAST reports. This method indicates if the hit was reported in the "Sequences used in model and found again" section of the PSI-BLAST report or if it was reported in the "Sequences not found previously or not previously below threshold" section of the PSI-BLAST report. Only for hits in iteration > 1. Example : if( $hit->found_again()) { ... }; Returns : Boolean, true (1) if the hit has been found in a previous PSI-BLAST iteration. Returns false (0 or undef) for hits that have not occurred in a previous PSI-BLAST iteration. Argument : Boolean (1 or 0). Only used for setting. Throws : none See Also : L =cut sub found_again { my $self = shift; return $self->{'_found_again'} = shift if @_; return $self->{'_found_again'}; } 1; BioPerl-1.6.923/Bio/Search/Hit/HitFactory.pm000444000765000024 712412254227321 20514 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::HitFactory # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::HitFactory - A factory to create Bio::Search::Hit::HitI objects =head1 SYNOPSIS use Bio::Search::Hit::HitFactory; my $factory = Bio::Search::Hit::HitFactory->new(); my $resultobj = $factory->create(@args); =head1 DESCRIPTION This is a general way of hiding the object creation process so that we can dynamically change the objects that are created by the SearchIO parser depending on what format report we are parsing. This object is for creating new Hits. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::HitFactory; use vars qw($DEFAULT_TYPE); use strict; use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI); BEGIN { $DEFAULT_TYPE = 'Bio::Search::Hit::GenericHit'; } =head2 new Title : new Usage : my $obj = Bio::Search::Hit::HitFactory->new(); Function: Builds a new Bio::Search::Hit::HitFactory object Returns : Bio::Search::Hit::HitFactory Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type) = $self->_rearrange([qw(TYPE)],@args); $self->type($type) if defined $type; return $self; } =head2 create Title : create Usage : $factory->create(%args) Function: Create a new L object Returns : L Args : hash of initialization parameters =cut sub create{ my ($self,@args) = @_; my $type = $self->type; eval { $self->_load_module($type) }; if( $@ ) { $self->throw("Unable to load module $type"); } return $type->new(@args); } =head2 type Title : type Usage : $factory->type('Bio::Search::Hit::GenericHit'); Function: Get/Set the Hit creation type Returns : string Args : [optional] string to set =cut sub type{ my ($self,$type) = @_; if( defined $type ) { # redundancy with the create method which also calls _load_module # I know - but this is not a highly called object so I am going # to leave it in eval {$self->_load_module($type) }; if( $@ ){ $self->warn("Cannot find module $type, unable to set type"); } else { $self->{'_type'} = $type; } } return $self->{'_type'} || $DEFAULT_TYPE; } 1; BioPerl-1.6.923/Bio/Search/Hit/HitI.pm000444000765000024 5320212254227323 17315 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::Hit::HitI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # Originally created by Aaron Mackey # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::HitI - Interface for a hit in a similarity search result =head1 SYNOPSIS # Bio::Search::Hit::HitI objects should not be instantiated since this # module defines a pure interface. # Given an object that implements the Bio::Search::Hit::HitI interface, # you can do the following things with it: # Get a HitI object from a SearchIO stream: use Bio::SeachIO; my $searchio = Bio::SearchIO->new(-format => 'blast', -file => 'result.bls'); my $result = $searchio->next_result; my $hit = $result->next_hit; $hit_name = $hit->name(); $desc = $hit->description(); $len = $hit->length $alg = $hit->algorithm(); $score = $hit->raw_score(); $significance = $hit->significance(); $rank = $hit->rank(); # the Nth hit for a specific query while( $hsp = $obj->next_hsp()) { ... } # process in iterator fashion for my $hsp ( $obj->hsps()()) { ... } # process in list fashion =head1 DESCRIPTION Bio::Search::Hit::* objects are data structures that contain information about specific hits obtained during a library search. Some information will be algorithm-specific, but others will be generally defined. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey, Steve Chervitz Email amackey@virginia.edu (original author) Email sac@bioperl.org =head1 COPYRIGHT Copyright (c) 1999-2001 Aaron Mackey, Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::HitI; use strict; use base qw(Bio::Root::RootI); =head2 name Title : name Usage : $hit_name = $hit->name(); Function: returns the name of the Hit sequence Returns : a scalar string Args : none The B of a hit is unique within a Result or within an Iteration. =cut sub name { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 description Title : description Usage : $desc = $hit->description(); Function: Retrieve the description for the hit Returns : a scalar string Args : none =cut sub description { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 accession Title : accession Usage : $acc = $hit->accession(); Function: Retrieve the accession (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub accession { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 locus Title : locus Usage : $acc = $hit->locus(); Function: Retrieve the locus(if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub locus { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 length Title : length Usage : my $len = $hit->length Function: Returns the length of the hit Returns : integer Args : none =cut sub length { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 algorithm Title : algorithm Usage : $alg = $hit->algorithm(); Function: Gets the algorithm specification that was used to obtain the hit For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : none =cut sub algorithm { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 raw_score Title : raw_score Usage : $score = $hit->raw_score(); Function: Gets the "raw score" generated by the algorithm. What this score is exactly will vary from algorithm to algorithm, returning undef if unavailable. Returns : a scalar value Args : none =cut sub raw_score { $_[0]->throw_not_implemented; } =head2 score Equivalent to L =cut sub score { shift->raw_score(@_); } =head2 significance Title : significance Usage : $significance = $hit->significance(); Function: Used to obtain the E or P value of a hit, i.e. the probability that this particular hit was obtained purely by random chance. If information is not available (nor calculatable from other information sources), return undef. Returns : a scalar value or undef if unavailable Args : none =cut sub significance { $_[0]->throw_not_implemented; } =head2 bits Usage : $hit_object->bits(); Purpose : Gets the bit score of the best HSP for the current hit. Example : $bits = $hit_object->bits(); Returns : Integer or double for FASTA reports Argument : n/a Comments : For BLAST1, the non-bit score is listed in the summary line. See Also : L =cut #--------- sub bits { #--------- $_[0]->throw_not_implemented(); } =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : L object or null if finished Args : none =cut sub next_hsp { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. : Get the numbers of HSPs for the current hit. Example : @hsps = $hit_object->hsps(); : $num = $hit_object->hsps(); # alternatively, use num_hsps() Returns : Array context : list of L objects. : Scalar context: integer (number of HSPs). : (Equivalent to num_hsps()). Argument : n/a. Relies on wantarray Throws : Exception if the HSPs have not been collected. See Also : L, L =cut #--------- sub hsps { #--------- my $self = shift; $self->throw_not_implemented(); } =head2 num_hsps Usage : $hit_object->num_hsps(); Purpose : Get the number of HSPs for the present Blast hit. Example : $nhsps = $hit_object->num_hsps(); Returns : Integer Argument : n/a Throws : Exception if the HSPs have not been collected. See Also : L =cut #------------- sub num_hsps { #------------- shift->throw_not_implemented(); } =head2 seq_inds Usage : $hit->seq_inds( seq_type, class, collapse ); Purpose : Get a list of residue positions (indices) across all HSPs : for identical or conserved residues in the query or sbjct sequence. Example : @s_ind = $hit->seq_inds('query', 'identical'); : @h_ind = $hit->seq_inds('hit', 'conserved'); : @h_ind = $hit->seq_inds('hit', 'conserved', 1); Returns : Array of integers : May include ranges if collapse is non-zero. Argument : [0] seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') : [1] class = 'identical' or 'conserved' (default = 'identical') : (can be shortened to 'id' or 'cons') : (actually, anything not 'id' will evaluate to 'conserved'). : [2] collapse = boolean, if non-zero, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. Throws : n/a. See Also : L =cut #------------- sub seq_inds { #------------- my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'sbjct' if $seqType eq 'hit'; my (@inds, $hsp); foreach $hsp ($self->hsps) { # This will merge data for all HSPs together. push @inds, $hsp->seq_inds($seqType, $class); } # Need to remove duplicates and sort the merged positions. if(@inds) { my %tmp = map { $_, 1 } @inds; @inds = sort {$a <=> $b} keys %tmp; } $collapse ? &Bio::Search::BlastUtils::collapse_nums(@inds) : @inds; } =head2 rewind Title : rewind Usage : $hit->rewind; Function: Allow one to reset the HSP iterator to the beginning if possible Returns : none Args : none =cut sub rewind{ my ($self) = @_; $self->throw_not_implemented(); } =head2 overlap Usage : $hit_object->overlap( [integer] ); Purpose : Gets/Sets the allowable amount overlap between different HSP sequences. Example : $hit_object->overlap(5); : $overlap = $hit_object->overlap; Returns : Integer. Argument : integer. Throws : n/a Status : Experimental Comments : Any two HSPs whose sequences overlap by less than or equal : to the overlap() number of resides will be considered separate HSPs : and will not get tiled by L. See Also : L, L =cut #------------- sub overlap { shift->throw_not_implemented } =head2 n Usage : $hit_object->n(); Purpose : Gets the N number for the current Blast hit. : This is the number of HSPs in the set which was ascribed : the lowest P-value (listed on the description line). : This number is not the same as the total number of HSPs. : To get the total number of HSPs, use num_hsps(). Example : $n = $hit_object->n(); Returns : Integer Argument : n/a Throws : Exception if HSPs have not been set (BLAST2 reports). Comments : Note that the N parameter is not reported in gapped BLAST2. : Calling n() on such reports will result in a call to num_hsps(). : The num_hsps() method will count the actual number of : HSPs in the alignment listing, which may exceed N in : some cases. See Also : L =cut #----- sub n { shift->throw_not_implemented } =head2 p Usage : $hit_object->p( [format] ); Purpose : Get the P-value for the best HSP of the given BLAST hit. : (Note that P-values are not provided with NCBI Blast2 reports). Example : $p = $sbjct->p; : $p = $sbjct->p('exp'); # get exponent only. : ($num, $exp) = $sbjct->p('parts'); # split sci notation into parts Returns : Float or scientific notation number (the raw P-value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and P-value : is in scientific notation (See Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (See Comments). Throws : Warns if no P-value is defined. Uses expect instead. Comments : Using the 'parts' argument is not recommended since it will not : work as expected if the P-value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut #-------- sub p { shift->throw_not_implemented() } =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single HSPI object for the present HitI object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a L object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' or 'first' = highest scoring HSP. : 'worst' or 'last' = lowest scoring HSP. Throws : Exception if the HSPs have not been collected. : Exception if an unrecognized argument is used. See Also : L, L() =cut #---------- sub hsp { shift->throw_not_implemented } =head2 logical_length Usage : $hit_object->logical_length( [seq_type] ); : (mostly intended for internal use). Purpose : Get the logical length of the hit sequence. : If the Blast is a TBLASTN or TBLASTX, the returned length : is the length of the would-be amino acid sequence (length/3). : For all other BLAST flavors, this function is the same as length(). Example : $len = $hit_object->logical_length(); Returns : Integer Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This is important for functions like frac_aligned_query() : which need to operate in amino acid coordinate space when dealing : with [T]BLAST[NX] type reports. See Also : L, L, L =cut #-------------------- sub logical_length { shift->throw_not_implemented() } =head2 rank Title : rank Usage : $obj->rank($newval) Function: Get/Set the rank of this Hit in the Query search list i.e. this is the Nth hit for a specific query Returns : value of rank Args : newvalue (optional) =cut sub rank{ my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 each_accession_number Title : each_accession_number Usage : $obj->each_accession_number Function: Get each accession number listed in the description of the hit. If there are no alternatives, then only the primary accession will be given Returns : list of all accession numbers in the description Args : none =cut sub each_accession_number{ my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 tiled_hsps Usage : $hit_object->tiled_hsps( [integer] ); Purpose : Gets/Sets an indicator for whether or not the HSPs in this Hit : have been tiled. : Methods that rely on HSPs being tiled should check this : and then call SearchUtils::tile_hsps() if not. Example : $hit_object->tiled_hsps(1); : if( $hit_object->tiled_hsps ) { # do something } Returns : Boolean (1 or 0) Argument : integer (optional) Throws : n/a =cut sub tiled_hsps { shift->throw_not_implemented } =head2 strand Usage : $sbjct->strand( [seq_type] ); Purpose : Gets the strand(s) for the query, sbjct, or both sequences : in the best HSP of the BlastHit object after HSP tiling. : Only valid for BLASTN, TBLASTX, BLASTX-query, TBLASTN-hit. Example : $qstrand = $sbjct->strand('query'); : $sstrand = $sbjct->strand('hit'); : ($qstrand, $sstrand) = $sbjct->strand(); Returns : scalar context: integer '1', '-1', or '0' : array context without args: list of two strings (queryStrand, sbjctStrand) : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling strand() on each (use hsps() to get all HSPs). : : Formerly (prior to 10/21/02), this method would return the : string "-1/1" for hits with HSPs on both strands. : However, now that strand and frame is properly being accounted : for during HSP tiling, it makes more sense for strand() : to return the strand data for the best HSP after tiling. : : If you really want to know about hits on opposite strands, : you should be iterating through the HSPs using methods on the : HSP objects. : : A possible use case where knowing whether a hit has HSPs : on both strands would be when filtering via SearchIO for hits with : this property. However, in this case it would be better to have a : dedicated method such as $hit->hsps_on_both_strands(). Similarly : for frame. This could be provided if there is interest. See Also : L() =cut #---------' sub strand { shift->throw_not_implemented } =head2 frame Usage : $hit_object->frame(); Purpose : Gets the reading frame for the best HSP after HSP tiling. : This is only valid for BLASTX and TBLASTN/X type reports. Example : $frame = $hit_object->frame(); Returns : Integer (-2 .. +2) Argument : n/a Throws : Exception if HSPs have not been set. Comments : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling frame() on each (use hsps() to get all HSPs). See Also : L =cut #---------' sub frame { shift->throw_not_implemented } =head2 matches Usage : $hit_object->matches( [class] ); Purpose : Get the total number of identical or conserved matches : (or both) across all HSPs. : (Note: 'conservative' matches are indicated as 'positives' : in BLAST reports.) Example : ($id,$cons) = $hit_object->matches(); # no argument : $id = $hit_object->matches('id'); : $cons = $hit_object->matches('cons'); Returns : Integer or a 2-element array of integers Argument : class = 'id' | 'cons' OR none. : If no argument is provided, both identical and conservative : numbers are returned in a two element list. : (Other terms can be used to refer to the conservative : matches, e.g., 'positive'. All that is checked is whether or : not the supplied string starts with 'id'. If not, the : conservative matches are returned.) Throws : Exception if the requested data cannot be obtained. Comments : This method requires that all HSPs be tiled. If there is more than one : HSP and they have not already been tiled, they will be tiled first automatically.. : : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : Does not rely on wantarray to return a list. Only checks for : the presence of an argument (no arg = return list). See Also : L, L =cut sub matches { shift->throw_not_implemented } # aliasing for Steve's method names sub hit_description { shift->description(@_) } # aliasing for Steve's method names sub hit_length { shift->length(@_) } # sort method for HSPs =head2 sort_hits Title : sort_hsps Usage : $result->sort_hsps(\&sort_function) Function : Sorts the available HSP objects by a user-supplied function. Defaults to sort by descending score. Returns : n/a Args : A coderef for the sort function. See the documentation on the Perl sort() function for guidelines on writing sort functions. Note : To access the special variables $a and $b used by the Perl sort() function the user function must access Bio::Search::Hit::HitI namespace. For example, use : $hit->sort_hsps( sub{$Bio::Search::Result::HitI::a->length <=> $Bio::Search::Result::HitI::b->length}); NOT $hit->sort_hsps($a->length <=> $b->length); =cut sub sort_hsps {shift->throw_not_implemented } =head2 _default sort_hsps Title : _default_sort_hsps Usage : Do not call directly. Function : Sort hsps in ascending order by evalue Args : None Returns: 1 on success Note : Used by $hit->sort_hsps() =cut sub _default_sort_hsps { $Bio::Search::Hit::HitI::a->evalue <=> $Bio::Search::Hit::HitI::a->evalue; } 1; BioPerl-1.6.923/Bio/Search/Hit/hmmer3Hit.pm000444000765000024 712212254227330 20276 0ustar00cjfieldsstaff000000000000# $Id: bioperl.lisp 15559 2009-02-23 12:11:20Z maj $ # # BioPerl module for Bio::Search::Hit::hmmer3Hit # # Please direct questions and support issues to # # Cared for by Thomas Sharpton # # Copyright Thomas Sharpton # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::hmmer3Hit - DESCRIPTION of Object =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: L rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Thomas Sharpton Email thomas.sharpton@gmail.com Describe contact details here =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::hmmer3Hit; use strict; use base qw(Bio::Search::Hit::GenericHit); =head2 new Title : new Usage : my $obj = Bio::Search::Hit::HMMERHit->new(); Function: Builds a new Bio::Search::Hit::HMMERHit object Returns : Bio::Search::Hit::HMMERHit Args : Plus the Bio::Search::Hit::GenericHit inherited params -name => Name of Hit (required) -description => Description (optional) -accession => Accession number (optional) -length => Length of the Hit (optional) -score => Raw Score for the Hit (optional) -significance => Significance value for the Hit (optional) -algorithm => Algorithm used (BLASTP, FASTX, etc...) -hsps => Array ref of HSPs for this Hit. =cut =head2 next_domain Title : next_domain Usage : my $domain = $hit->next_domain(); Function: An alias for L, this will return the next HSP Returns : L object Args : none =cut sub next_domain{ shift->next_hsp } =head2 domains Title : domains Usage : my @domains = $hit->domains(); Function: An alias for L, this will return the full list of hsps Returns : array of L objects Args : none =cut sub domains{ shift->hsps() } =head2 bits Usage : $hit_object->bits(); Purpose : Gets the bit score of the best HSP for the current hit. Example : $bits = $hit_object->bits(); Returns : Integer or undef if bit score is not set Argument : n/a See Also : L =cut sub bits { return 0 } =head2 iteration Title : iteration Usage : $obj->iteration($newval) Function: PSI-BLAST iteration Returns : value of iteration Args : newvalue (optional) =cut sub iteration { return 0 } 1; BioPerl-1.6.923/Bio/Search/Hit/HMMERHit.pm000444000765000024 1673312254227330 20003 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::HMMERHit # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::HMMERHit - A Hit module for HMMER hits =head1 SYNOPSIS use Bio::Search::Hit::HMMERHit; my $hit = Bio::Search::Hit::HMMERHit->new(); # use it in the same way as Bio::Search::Hit::GenericHit =head1 DESCRIPTION This is a specialization of L. There are a few news methods L and L. Note that L and L make no sense for this object and will return 0. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::HMMERHit; use strict; use base qw(Bio::Search::Hit::GenericHit); =head2 new Title : new Usage : my $obj = Bio::Search::Hit::HMMERHit->new(); Function: Builds a new Bio::Search::Hit::HMMERHit object Returns : Bio::Search::Hit::HMMERHit Args : Plus the Bio::Search::Hit::GenericHit inherited params -name => Name of Hit (required) -description => Description (optional) -accession => Accession number (optional) -length => Length of the Hit (optional) -score => Raw Score for the Hit (optional) -significance => Significance value for the Hit (optional) -algorithm => Algorithm used (BLASTP, FASTX, etc...) -hsps => Array ref of HSPs for this Hit. =cut =head2 next_domain Title : next_domain Usage : my $domain = $hit->next_domain(); Function: An alias for L, this will return the next HSP Returns : L object Args : none =cut sub next_domain{ shift->next_hsp } =head2 domains Title : domains Usage : my @domains = $hit->domains(); Function: An alias for L, this will return the full list of hsps Returns : array of L objects Args : none =cut sub domains{ shift->hsps() } =head2 inherited Bio::Search::Hit::GenericHit methods =cut =head2 add_hsp Title : add_hsp Usage : $hit->add_hsp($hsp) Function: Add a HSP to the collection of HSPs for a Hit Returns : number of HSPs in the Hit Args : Bio::Search::HSP::HSPI object =cut =head2 Bio::Search::Hit::HitI methods =cut =head2 name Title : name Usage : $hit_name = $hit->name(); Function: returns the name of the Hit sequence Returns : a scalar string Args : [optional] scalar string to set the name =cut =head2 accession Title : accession Usage : $acc = $hit->accession(); Function: Retrieve the accession (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut =head2 description Title : description Usage : $desc = $hit->description(); Function: Retrieve the description for the hit Returns : a scalar string Args : [optional] scalar string to set the descrition =cut =head2 length Title : length Usage : my $len = $hit->length Function: Returns the length of the hit Returns : integer Args : [optional] integer to set the length =cut =head2 algorithm Title : algorithm Usage : $alg = $hit->algorithm(); Function: Gets the algorithm specification that was used to obtain the hit For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : [optional] scalar string to set the algorithm =cut =head2 raw_score Title : raw_score Usage : $score = $hit->raw_score(); Function: Gets the "raw score" generated by the algorithm. What this score is exactly will vary from algorithm to algorithm, returning undef if unavailable. Returns : a scalar value Args : [optional] scalar value to set the raw score =cut =head2 significance Title : significance Usage : $significance = $hit->significance(); Function: Used to obtain the E or P value of a hit, i.e. the probability that this particular hit was obtained purely by random chance. If information is not available (nor calculatable from other information sources), return undef. Returns : a scalar value or undef if unavailable Args : [optional] scalar value to set the significance =cut =head2 bits Usage : $hit_object->bits(); Purpose : Gets the bit score of the best HSP for the current hit. Example : $bits = $hit_object->bits(); Returns : Integer or undef if bit score is not set Argument : n/a See Also : L =cut sub bits { return 0 } =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : Bio::Search::HSP::HSPI object or null if finished Args : none =cut =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. : Get the numbers of HSPs for the current hit. Example : @hsps = $hit_object->hsps(); : $num = $hit_object->hsps(); # alternatively, use num_hsps() Returns : Array context : list of Bio::Search::HSP::BlastHSP.pm objects. : Scalar context: integer (number of HSPs). : (Equivalent to num_hsps()). Argument : n/a. Relies on wantarray Throws : Exception if the HSPs have not been collected. See Also : L, L =cut =head2 num_hsps Usage : $hit_object->num_hsps(); Purpose : Get the number of HSPs for the present Blast hit. Example : $nhsps = $hit_object->num_hsps(); Returns : Integer Argument : n/a Throws : Exception if the HSPs have not been collected. See Also : L =cut =head2 rewind Title : rewind Usage : $hit->rewind; Function: Allow one to reset the HSP iteration to the beginning Since this is an in-memory implementation Returns : none Args : none =cut =head2 iteration Title : iteration Usage : $obj->iteration($newval) Function: PSI-BLAST iteration Returns : value of iteration Args : newvalue (optional) =cut sub iteration { return 0 } 1; BioPerl-1.6.923/Bio/Search/Hit/HmmpfamHit.pm000555000765000024 2343612254227324 20524 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::HmmpfamHit # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::HmmpfamHit - A parser and hit object for hmmpfam hits =head1 SYNOPSIS # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 'result.hmmer'); while (my $result = $in->next_result) { while (my $hit = $result->next_hit) { print $hit->name, "\n"; print $hit->score, "\n"; print $hit->significance, "\n"; while (my $hsp = $hit->next_hsp) { # process HSPI objects } } } =head1 DESCRIPTION This object implements a parser for hmmpfam hit output, a program in the HMMER package. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::HmmpfamHit; use strict; use Bio::Search::HSP::HmmpfamHSP; use base qw(Bio::Root::Root Bio::Search::Hit::PullHitI); =head2 new Title : new Usage : my $obj = Bio::Search::Hit::HmmpfamHit->new(); Function: Builds a new Bio::Search::Hit::HmmpfamHit object. Returns : Bio::Search::Hit::HmmpfamHit Args : -chunk => [Bio::Root::IO, $start, $end] (required if no -parent) -parent => Bio::PullParserI object (required if no -chunk) -hit_data => array ref with [name description score significance num_hsps rank] where the array ref provided to -chunk contains an IO object for a filehandle to something representing the raw data of the hit, and $start and $end define the tell() position within the filehandle that the hit data starts and ends (optional; defaults to start and end of the entire thing described by the filehandle) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_setup(@args); my $fields = $self->_fields; foreach my $field (qw( next_domain domains hsp_data )) { $fields->{$field} = undef; } my $hit_data = $self->_raw_hit_data; if ($hit_data && ref($hit_data) eq 'ARRAY') { foreach my $field (qw(name description score significance num_hsps rank)) { $fields->{$field} = shift(@{$hit_data}); } } $fields->{hit_start} = 1; delete $self->_fields->{accession}; $self->_dependencies( { ( length => 'hsp_data' ) } ); return $self; } # # PullParserI discovery methods so we can answer all HitI questions # sub _discover_description { # this should be set when this object is created, but if it was undef as is # possible, this _discover method will be called: just return and keep the # return value undef return; } sub _discover_hsp_data { my $self = shift; my $hsp_table = $self->get_field('hsp_table'); my $hsp_data = $hsp_table->{$self->get_field('name')} || undef; if ($hsp_data) { if (defined $hsp_data->{hit_length}) { $self->_fields->{length} = $hsp_data->{hit_length}; } # rank query_start query_end hit_start hit_end score evalue $self->_fields->{hsp_data} = $hsp_data->{hsp_data}; } } sub _discover_query_start { my $self = shift; my $hsp_data = $self->get_field('hsp_data') || return; my ($this_hsp) = sort { $a->[1] <=> $b->[1] } @{$hsp_data}; $self->_fields->{query_start} = $this_hsp->[1]; } sub _discover_query_end { my $self = shift; my $hsp_data = $self->get_field('hsp_data') || return; my ($this_hsp) = sort { $b->[2] <=> $a->[2] } @{$hsp_data}; $self->_fields->{query_end} = $this_hsp->[2]; } sub _discover_hit_start { my $self = shift; my $hsp_data = $self->get_field('hsp_data') || return; my ($this_hsp) = sort { $a->[3] <=> $b->[3] } @{$hsp_data}; $self->_fields->{hit_start} = $this_hsp->[3]; } sub _discover_hit_end { my $self = shift; my $hsp_data = $self->get_field('hsp_data') || return; my ($this_hsp) = sort { $b->[4] <=> $a->[4] } @{$hsp_data}; $self->_fields->{hit_end} = $this_hsp->[4]; } sub _discover_next_hsp { my $self = shift; my $hsp_data = $self->get_field('hsp_data') || return; unless (defined $self->{_next_hsp_index}) { $self->{_next_hsp_index} = 0; } return if $self->{_next_hsp_index} == -1; $self->_fields->{next_hsp} = Bio::Search::HSP::HmmpfamHSP->new(-parent => $self, -hsp_data => $hsp_data->[$self->{_next_hsp_index}++]); if ($self->{_next_hsp_index} > $#{$hsp_data}) { $self->{_next_hsp_index} = -1; } } =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : L object or null if finished Args : none =cut sub next_hsp { my $self = shift; my $hsp = $self->get_field('next_hsp'); undef $self->_fields->{next_hsp}; return $hsp; } =head2 next_domain Title : next_domain Usage : my $domain = $hit->next_domain(); Function: An alias for L, this will return the next HSP Returns : L object Args : none =cut *next_domain = \&next_hsp; =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. Example : @hsps = $hit_object->hsps(); Returns : list of L objects. Argument : none =cut sub hsps { my $self = shift; my $old = $self->{_next_hsp_index} || 0; $self->rewind; my @hsps; while (defined(my $hsp = $self->next_hsp)) { push(@hsps, $hsp); } $self->{_next_hsp_index} = @hsps > 0 ? $old : -1; return @hsps; } =head2 domains Title : domains Usage : my @domains = $hit->domains(); Function: An alias for L, this will return the full list of hsps Returns : array of L objects Args : none =cut *domains = \&hsps; =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single HSPI object for the present HitI object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a L object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' = highest scoring HSP. : 'worst' = lowest scoring HSP. Throws : Exception if an unrecognized argument is used. See Also : L, L() =cut sub hsp { my ($self, $type) = @_; $type ||= 'best'; my $hsp_data = $self->get_field('hsp_data') || return; my $sort; if ($type eq 'best') { $sort = sub { $a->[6] <=> $b->[6] }; } elsif ($type eq 'worst') { $sort = sub { $b->[6] <=> $a->[6] }; } else { $self->throw("Unknown arg '$type' given to hsp()"); } my ($this_hsp) = sort $sort @{$hsp_data}; return Bio::Search::HSP::HmmpfamHSP->new(-parent => $self, -hsp_data => $this_hsp); } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iterator to the beginning, so that next_hit() will subsequently return the first hit and so on. Returns : n/a Args : none =cut sub rewind { my $self = shift; my $hsp_data = $self->get_field('hsp_data') || return; $self->{_next_hsp_index} = @{$hsp_data} > 0 ? 0 : -1; } # have p() a synonym of significance() sub p { return shift->significance; } =head2 strand Usage : $sbjct->strand( [seq_type] ); Purpose : Gets the strand(s) for the query, sbjct, or both sequences. : For hmmpfam, the answers are always 1 (forward strand). Example : $qstrand = $sbjct->strand('query'); : $sstrand = $sbjct->strand('hit'); : ($qstrand, $sstrand) = $sbjct->strand(); Returns : scalar context: integer '1' : array context without args: list of two strings (1, 1) : Array context can be "induced" by providing an argument of 'list' : or 'array'. Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default : = 'query') ('sbjct' is synonymous with 'hit') =cut sub strand { my ($self, $type) = @_; $type ||= (wantarray ? 'list' : 'query'); $type = lc($type); if ($type eq 'list' || $type eq 'array') { return (1, 1); } return 1; } =head2 frac_aligned_query Usage : $hit_object->frac_aligned_query(); Purpose : Get the fraction of the query sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_query(); Returns : undef (the length of query sequences is unknown in Hmmpfam reports) Argument : none =cut # noop sub frac_aligned_query { } 1; BioPerl-1.6.923/Bio/Search/Hit/ModelHit.pm000444000765000024 4712612254227317 20200 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Hit::ModelHit # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::ModelHit - A model-based implementation of the Bio::Search::Hit::HitI interface =head1 SYNOPSIS use Bio::Search::Hit::ModelHit; my $hit = Bio::Search::Hit::ModelHit->new(-algorithm => 'rnamotif'); # typically one gets HitI objects from a SearchIO stream via a ResultI use Bio::SearchIO; my $parser = Bio::SearchIO->new(-format => 'infernal', -file => 'trap.inf'); my $result = $parser->next_result; my $hit = $result->next_hit; =head1 DESCRIPTION This object handles the hit data from a database search using models or descriptors instead of sequences, such as Infernal, HMMER, RNAMotif, etc. Unless you're writing a parser, you won't ever need to create a ModelHit or any other HitI-implementing object. If you use the SearchIO system, HitI objects are created automatically from a SearchIO stream which returns Bio::Search::Hit::HitI objects. Note that several HitI-based methods have been overridden from ModelHit due to their unreliability when dealing with queries that aren't sequence-based. It may be possible to reimplement these at a later point, but for the time being they will throw warnings and return w/o results. For documentation on what you can do with ModelHit (and other HitI objects), please see the API documentation in L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::ModelHit; use strict; use base qw(Bio::Search::Hit::GenericHit); =head1 HitI methods implemented in parent class Bio::Search::Hit::ModelHit =head2 new Title : new Usage : my $obj = Bio::Search::Hit::ModelHit->new(); Function: Builds a new Bio::Search::Hit::ModelHit object Returns : Bio::Search::Hit::ModelHit Args : -name => Name of Hit (required) -description => Description (optional) -accession => Accession number (optional) -ncbi_gi => NCBI GI UID (optional) -length => Length of the Hit (optional) -score => Raw Score for the Hit (optional) -bits => Bit Score for the Hit (optional) -significance => Significance value for the Hit (optional) -algorithm => Algorithm used (BLASTP, FASTX, etc...) -hsps => Array ref of HSPs for this Hit. -found_again => boolean, true if hit appears in a "previously found" section of a PSI-Blast report. -hsp_factory => Bio::Factory::ObjectFactoryI able to create HSPI objects. =cut =head2 add_hsp Title : add_hsp Usage : $hit->add_hsp($hsp) Function: Add a HSP to the collection of HSPs for a Hit Returns : number of HSPs in the Hit Args : Bio::Search::HSP::HSPI object, OR hash ref containing data suitable for creating a HSPI object (&hsp_factory must be set to get it back) =cut =head2 hsp_factory Title : hsp_factory Usage : $hit->hsp_factory($hsp_factory) Function: Get/set the factory used to build HSPI objects if necessary. Returns : Bio::Factory::ObjectFactoryI Args : Bio::Factory::ObjectFactoryI =cut =head2 Bio::Search::Hit::HitI methods Implementation of Bio::Search::Hit::HitI methods =head2 name Title : name Usage : $hit_name = $hit->name(); Function: returns the name of the Hit sequence Returns : a scalar string Args : [optional] scalar string to set the name =cut =head2 accession Title : accession Usage : $acc = $hit->accession(); Function: Retrieve the accession (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut =head2 description Title : description Usage : $desc = $hit->description(); Function: Retrieve the description for the hit Returns : a scalar string Args : [optional] scalar string to set the descrition =cut =head2 length Title : length Usage : my $len = $hit->length Function: Returns the length of the hit Returns : integer Args : [optional] integer to set the length =cut =head2 algorithm Title : algorithm Usage : $alg = $hit->algorithm(); Function: Gets the algorithm specification that was used to obtain the hit For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : [optional] scalar string to set the algorithm =cut =head2 raw_score Title : raw_score Usage : $score = $hit->raw_score(); Function: Gets the "raw score" generated by the algorithm. What this score is exactly will vary from algorithm to algorithm, returning undef if unavailable. Returns : a scalar value Args : [optional] scalar value to set the raw score =cut =head2 score Equivalent to L =cut =head2 significance Title : significance Usage : $significance = $hit->significance(); Function: Used to obtain the E or P value of a hit, i.e. the probability that this particular hit was obtained purely by random chance. If information is not available (nor calculatable from other information sources), return undef. Returns : a scalar value or undef if unavailable Args : [optional] scalar value to set the significance =cut =head2 bits Usage : $hit_object->bits(); Purpose : Gets the bit score of the best HSP for the current hit. Example : $bits = $hit_object->bits(); Returns : Integer or undef if bit score is not set Argument : n/a Comments : For BLAST1, the non-bit score is listed in the summary line. See Also : L =cut =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : Bio::Search::HSP::HSPI object or null if finished Args : none =cut =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. : Get the numbers of HSPs for the current hit. Example : @hsps = $hit_object->hsps(); : $num = $hit_object->hsps(); # alternatively, use num_hsps() Returns : Array context : list of Bio::Search::HSP::BlastHSP.pm objects. : Scalar context: integer (number of HSPs). : (Equivalent to num_hsps()). Argument : n/a. Relies on wantarray Throws : Exception if the HSPs have not been collected. See Also : L, L =cut =head2 num_hsps Usage : $hit_object->num_hsps(); Purpose : Get the number of HSPs for the present hit. Example : $nhsps = $hit_object->num_hsps(); Returns : Integer or '-' if HSPs have not been callected Argument : n/a See Also : L =cut =head2 rewind Title : rewind Usage : $hit->rewind; Function: Allow one to reset the HSP iterator to the beginning Since this is an in-memory implementation Returns : none Args : none =cut =head2 ambiguous_aln Usage : $ambig_code = $hit_object->ambiguous_aln(); Purpose : Sets/Gets ambiguity code data member. Example : (see usage) Returns : String = 'q', 's', 'qs', '-' : 'q' = query sequence contains overlapping sub-sequences : while sbjct does not. : 's' = sbjct sequence contains overlapping sub-sequences : while query does not. : 'qs' = query and sbjct sequence contains overlapping sub-sequences : relative to each other. : '-' = query and sbjct sequence do not contains multiple domains : relative to each other OR both contain the same distribution : of similar domains. Argument : n/a Throws : n/a Comment : Note: "sbjct" is synonymous with "hit" =cut =head2 overlap See documentation in L =cut sub overlap { my $self = shift; $self->{'_overlap'} = shift if @_; return exists $self->{'_overlap'} ? $self->{'_overlap'} : 0; } =head2 n Usage : $hit_object->n(); Purpose : Gets the N number for the current hit. : This is the number of HSPs in the set which was ascribed : the lowest P-value (listed on the description line). : This number is not the same as the total number of HSPs. : To get the total number of HSPs, use num_hsps(). Example : $n = $hit_object->n(); Returns : Integer Argument : n/a Throws : Exception if HSPs have not been set. Comments : Calling n() on such reports will result in a call to num_hsps(). : The num_hsps() method will count the actual number of : HSPs in the alignment listing, which may exceed N in : some cases. See Also : L =cut sub n { my $self = shift; $self->{'_n'} = shift if @_; return exists $self->{'_n'} ? $self->{'_n'} : $self->num_hsps; } =head2 p Usage : $hit_object->p( [format] ); Purpose : Get the P-value for the best HSP Example : $p = $sbjct->p; : $p = $sbjct->p('exp'); # get exponent only. : ($num, $exp) = $sbjct->p('parts'); # split sci notation into parts Returns : Float or scientific notation number (the raw P-value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and P-value : is in scientific notation (See Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (See Comments). Throws : Warns if no P-value is defined. Uses expect instead. Comments : Using the 'parts' argument is not recommended since it will not : work as expected if the P-value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single HSPI object for the present HitI object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a Bio::Search::HSP::BlastHSP.pm object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' or 'first' = highest scoring HSP. : 'worst' or 'last' = lowest scoring HSP. Throws : Exception if the HSPs have not been collected. : Exception if an unrecognized argument is used. See Also : L, L() =cut sub hsp { my( $self, $option ) = @_; $option ||= 'best'; if (not ref $self->{'_hsps'}) { $self->throw("Can't get HSPs: data not collected."); } my @hsps = $self->hsps; return $hsps[0] if $option =~ /best|first|1/i; return $hsps[$#hsps] if $option =~ /worst|last/i; $self->throw("Can't get HSP for: $option\n" . "Valid arguments: 'best', 'worst'"); } =head2 rank Title : rank Usage : $obj->rank($newval) Function: Get/Set the rank of this Hit in the Query search list i.e. this is the Nth hit for a specific query Returns : value of rank Args : newvalue (optional) =cut sub rank { my $self = shift; return $self->{'_rank'} = shift if @_; return $self->{'_rank'} || 1; } =head2 locus Title : locus Usage : $locus = $hit->locus(); Function: Retrieve the locus (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub locus { my ($self,$value) = @_; my $previous = $self->{'_locus'}; if( defined $value || ! defined $previous ) { unless (defined $value) { if ($self->{'_name'} =~/(gb|emb|dbj|ref)\|(.*)\|(.*)/) { $value = $previous = $3; } else { $value = $previous = ''; } } $self->{'_locus'} = $value; } return $previous; } =head2 each_accession_number Title : each_accession_number Usage : @each_accession_number = $hit->each_accession_number(); Function: Get each accession number listed in the description of the hit. If there are no alternatives, then only the primary accession will be given Returns : list of all accession numbers in the description Args : none =cut sub each_accession_number { my ($self,$value) = @_; my $desc = $self->{'_description'}; #put primary accnum on the list my @accnums; push (@accnums,$self->{'_accession'}); if( defined $desc ) { while ($desc =~ /(\b\S+\|\S*\|\S*\s?)/g) { my $id = $1; my ($acc, $version); if ($id =~ /(gb|emb|dbj|sp|pdb|bbs|ref|tp[gde])\|(.*)\|(.*)/) { ($acc, $version) = split /\./, $2; } elsif ($id =~ /(pir|prf|pat|gnl)\|(.*)\|(.*)/) { ($acc, $version) = split /\./, $3; } elsif( $id =~ /(gim|gi|bbm|bbs|lcl)\|(\d*)/) { $acc = $id; } elsif( $id =~ /(oth)\|(.*)\|(.*)\|(.*)/ ) { # discontinued... ($acc,$version) = ($2); } else { #punt, not matching the db's at ftp://ftp.ncbi.nih.gov/blast/db/README #Database Name Identifier Syntax #============================ ======================== #GenBank gb|accession|locus #EMBL Data Library emb|accession|locus #DDBJ, DNA Database of Japan dbj|accession|locus #NBRF PIR pir||entry #Protein Research Foundation prf||name #SWISS-PROT sp|accession|entry name #Brookhaven Protein Data Bank pdb|entry|chain #Patents pat|country|number #GenInfo Backbone Id bbs|number #General database identifier gnl|database|identifier #NCBI Reference Sequence ref|accession|locus #Local Sequence identifier lcl|identifier $acc=$id; } push(@accnums, $acc); } } return @accnums; } =head2 tiled_hsps See documentation in L =cut =head2 query_length Title : query_length Usage : $obj->query_length($newval) Function: Get/Set the query_length Returns : value of query_length (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub query_length { my $self = shift; return $self->{'_query_length'} = shift if @_; return $self->{'_query_length'}; } =head2 ncbi_gi Title : ncbi_gi Usage : $acc = $hit->ncbi_gi(); Function: Retrieve the NCBI Unique ID (aka the GI #), if available, for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub ncbi_gi { my ($self,$value) = @_; my $previous = $self->{'_ncbi_gi'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_ncbi_gi'} = $value; } return $previous; } =head1 ModelHit methods overridden in ModelHit The following methods have been overridden due to their current reliance on sequence-based queries. They may be implemented in future versions of this class. =head2 length_aln =cut sub length_aln { my $self = shift; $self->warn('$hit->length_aln not implemented for Model-based searches'); return; } =head2 gaps =cut sub gaps { my $self = shift; $self->warn('$hit->gaps not implemented for Model-based searches'); return; } =head2 matches =cut sub matches { my $self = shift; $self->warn('$hit->matches not implemented for Model-based searches'); return; } =head2 start =cut sub start { my $self = shift; $self->warn('$hit->start not implemented for Model-based searches'); return; } =head2 end =cut sub end { my $self = shift; $self->warn('$hit->end not implemented for Model-based searches'); return; } =head2 range =cut sub range { my $self = shift; $self->warn('$hit->range not implemented for Model-based searches'); return; } =head2 frac_identical =cut sub frac_identical { my $self = shift; $self->warn('$hit->frac_identical not implemented for Model-based searches'); return; } =head2 frac_conserved =cut sub frac_conserved { my $self = shift; $self->warn('$hit->frac_conserved not implemented for Model-based searches'); return; } =head2 frac_aligned_query =cut sub frac_aligned_query { my $self = shift; $self->warn('$hit->frac_aligned_query not implemented for Model-based searches'); return; } =head2 frac_aligned_hit =cut sub frac_aligned_hit { my $self = shift; $self->warn('$hit->frac_aligned_hit not implemented for Model-based searches'); return; } =head2 num_unaligned_hit =cut *num_unaligned_sbjct = \&num_unaligned_hit; sub num_unaligned_hit { my $self = shift; $self->warn('$hit->num_unaligned_hit/num_unaligned_sbjct not implemented for Model-based searches'); return; } =head2 num_unaligned_query =cut sub num_unaligned_query { my $self = shift; $self->warn('$hit->num_unaligned_query not implemented for Model-based searches'); return; } =head2 seq_inds =cut sub seq_inds { my $self = shift; $self->warn('$hit->seq_inds not implemented for Model-based searches'); return; } =head2 strand =cut sub strand { my $self = shift; $self->warn('$hit->strand not implemented for Model-based searches'); return; } =head2 frame =cut sub frame { my $self = shift; $self->warn('$hit->frame not implemented for Model-based searches'); return; } =head2 logical_length =cut sub logical_length { my $self = shift; $self->warn('$hit->logical_length not implemented for Model-based searches'); return; } 1; BioPerl-1.6.923/Bio/Search/Hit/PsiBlastHit.pm000444000765000024 20775312254227323 20702 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::Hit::PsiBlastHit # # (This module was originally called Bio::Tools::Blast::Sbjct) # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- ## POD Documentation: =head1 NAME Bio::Search::Hit::PsiBlastHit - Bioperl BLAST Hit object =head1 SYNOPSIS See L. =head1 DESCRIPTION The Bio::Search::Hit::PsiBlastHit.pm module encapsulates data and methods for manipulating "hits" from a BLAST report. A BLAST hit is a collection of HSPs along with other metadata such as sequence name and score information. Hit objects are accessed via L objects after parsing a BLAST report using the L system. In Blast lingo, the "sbjct" sequences are all the sequences in a target database which were compared against a "query" sequence. The terms "sbjct" and "hit" will be used interchangeably in this module. All methods that take 'sbjct' as an argument also support 'hit' as a synonym. This module supports BLAST versions 1.x and 2.x, gapped and ungapped, and PSI-BLAST. The construction of PsiBlastHit objects is performed by Bio::SearchIO::blast::PsiBlastHitFactory in a process that is orchestrated by the Blast parser (L). The resulting PsiBlastHits are then accessed via L). Therefore, you do not need to use L) directly. If you need to construct PsiBlastHits directly, see the C function for details. For L BLAST parsing usage examples, see the C directory of the Bioperl distribution. =head2 HSP Tiling and Ambiguous Alignments If a Blast hit has more than one HSP, the Bio::Search::Hit::PsiBlastHit.pm object has the ability to merge overlapping HSPs into contiguous blocks. This permits the PsiBlastHit object to sum data across all HSPs without counting data in the overlapping regions multiple times, which would happen if data from each overlapping HSP are simply summed. HSP tiling is performed automatically when methods of the PsiBlastHit object that rely on tiled data are invoked. These include L, L, L, L, L, L, L. It also permits the assessment of an "ambiguous alignment" if the query (or sbjct) sequences from different HSPs overlap (see L). The existence of an overlap could indicate a biologically interesting region in the sequence, such as a repeated domain. The PsiBlastHit object uses the C<-OVERLAP> parameter to determine when two sequences overlap; if this is set to 2 -- the default -- then any two sbjct or query HSP sequences must overlap by more than two residues to get merged into the same contig and counted as an overlap. See the L section below for "issues" with HSP tiling. The results of the HSP tiling is reported with the following ambiguity codes: 'q' = Query sequence contains multiple sub-sequences matching a single region in the sbjct sequence. 's' = Subject (PsiBlastHit) sequence contains multiple sub-sequences matching a single region in the query sequence. 'qs' = Both query and sbjct sequences contain more than one sub-sequence with similarity to the other sequence. For addition information about ambiguous BLAST alignments, see L =head1 DEPENDENCIES Bio::Search::Hit::PsiBlastHit.pm is a concrete class that inherits from L and L. and relies on L. =head1 BUGS One consequence of the HSP tiling is that methods that rely on HSP tiling such as L, L, L etc. may report misleading numbers when C<-OVERLAP> is set to a large number. For example, say we have two HSPs and the query sequence tile as follows: 1 8 22 30 40 60 Full seq: ------------------------------------------------------------ * ** * ** HSP1: --------------- (6 identical matches) ** ** ** HSP2: ------------- (6 identical matches) If C<-OVERLAP> is set to some number over 4, HSP1 and HSP2 will not be tiled into a single contig and their numbers of identical matches will be added, giving a total of 12, not 10 if they had be combined into one contig. This can lead to number greater than 1.0 for methods L and L. This is less of an issue with gapped Blast since it tends to combine HSPs that would be listed separately without gapping. (Fractions E1.0 can be viewed as a signal for an interesting alignment that warrants further inspection, thus turning this bug into a feature :-). Using large values for C<-OVERLAP> can lead to incorrect numbers reported by methods that rely on HSP tiling but can be useful if you care more about detecting ambiguous alignments. Setting C<-OVERLAP> to zero will lead to the most accurate numbers for the tiling-dependent methods but will be useless for detecting overlapping HSPs since all HSPs will appear to overlap. =head1 SEE ALSO Bio::Search::HSP::BlastHSP.pm - Blast HSP object. Bio::Search::Result::BlastResult.pm - Blast Result object. Bio::Search::Hit::HitI.pm - Interface implemented by PsiBlastHit.pm Bio::Root::Root.pm - Base class for PsiBlastHit.pm Links: http://bio.perl.org/ - Bioperl Project Homepage =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 ACKNOWLEDGEMENTS This software was originally developed in the Department of Genetics at Stanford University. I would also like to acknowledge my colleagues at Affymetrix for useful feedback. =head1 COPYRIGHT Copyright (c) 1996-2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::PsiBlastHit; use strict; use Bio::Search::BlastUtils; use vars qw(%SUMMARY_OFFSET); use overload '""' => \&to_string; use base qw(Bio::Root::Root Bio::Search::Hit::HitI); =head2 new Usage : $hit = Bio::Search::Hit::PsiBlastHit->new( %named_params ); : Bio::Search::Hit::PsiBlastHit.pm objects are constructed : automatically by Bio::SearchIO::PsiBlastHitFactory.pm, : so there is no need for direct instantiation. Purpose : Constructs a new PsiBlastHit object and Initializes key variables : for the hit. Returns : A Bio::Search::Hit::PsiBlastHit object Argument : Named Parameters: : Parameter keys are case-insensitive. : -RAW_DATA => array reference holding raw BLAST report data : for a single hit. This includes all lines : within the HSP alignment listing section of a : traditional BLAST or PSI-BLAST (non-XML) report, : starting at (or just after) the leading '>'. : -HOLD_RAW_DATA => boolean, should -RAW_DATA be saved within the object. : -QUERY_LEN => Length of the query sequence : -ITERATION => integer (PSI-BLAST iteration number in which hit was found) : -OVERLAP => integer (maximum overlap between adjacent : HSPs when tiling) : -PROGRAM => string (type of Blast: BLASTP, BLASTN, etc) : -SIGNIF => significance : -IS_PVAL => boolean, true if -SIGNIF contains a P-value : -SCORE => raw BLAST score : -FOUND_AGAIN => boolean, true if this was a hit from the : section of a PSI-BLAST with iteration > 1 : containing sequences that were also found : in iteration 1. Comments : This object accepts raw Blast report data not because it : is required for parsing, but in order to retrieve it : (only available if -HOLD_RAW_DATA is set to true). See Also : L, L =cut #------------------- sub new { #------------------- my ($class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ($raw_data, $signif, $is_pval, $hold_raw); ($self->{'_blast_program'}, $self->{'_query_length'}, $raw_data, $hold_raw, $self->{'_overlap'}, $self->{'_iteration'}, $signif, $is_pval, $self->{'_score'}, $self->{'_found_again'} ) = $self->_rearrange( [qw(PROGRAM QUERY_LEN RAW_DATA HOLD_RAW_DATA OVERLAP ITERATION SIGNIF IS_PVAL SCORE FOUND_AGAIN )], @args ); # TODO: Handle this in parser. Just pass in name parameter. $self->_set_id( $raw_data->[0] ); if($is_pval) { $self->{'_p'} = $signif; } else { $self->{'_expect'} = $signif; } if( $hold_raw ) { $self->{'_hit_data'} = $raw_data; } return $self; } sub DESTROY { my $self=shift; #print STDERR "-->DESTROYING $self\n"; } #================================================= # Begin Bio::Search::Hit::HitI implementation #================================================= =head2 algorithm Title : algorithm Usage : $alg = $hit->algorithm(); Function: Gets the algorithm specification that was used to obtain the hit For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : none =cut #---------------- sub algorithm { #---------------- my ($self,@args) = @_; return $self->{'_blast_program'}; } =head2 name Usage : $hit->name([string]); Purpose : Set/Get a string to identify the hit. Example : $name = $hit->name; : $hit->name('M81707'); Returns : String consisting of the hit's name or undef if not set. Comments : The name is parsed out of the "Query=" line as the first chunk of non-whitespace text. If you want the rest of the line, use $hit->description(). See Also: L =cut #' #---------------- sub name { #---------------- my $self = shift; if (@_) { my $name = shift; $name =~ s/^\s+|(\s+|,)$//g; $self->{'_name'} = $name; } return $self->{'_name'}; } =head2 description Usage : $hit_object->description( [integer] ); Purpose : Set/Get a description string for the hit. This is parsed out of the "Query=" line as everything after the first chunk of non-whitespace text. Use $hit->name() to get the first chunk (the ID of the sequence). Example : $description = $hit->description; : $desc_60char = $hit->description(60); Argument : Integer (optional) indicating the desired length of the : description string to be returned. Returns : String consisting of the hit's description or undef if not set. =cut #' #---------------- sub description { #---------------- my( $self, $len ) = @_; $len = (defined $len) ? $len : (CORE::length $self->{'_description'}); return substr( $self->{'_description'}, 0 ,$len ); } =head2 accession Title : accession Usage : $acc = $hit->accession(); Function: Retrieve the accession (if available) for the hit Returns : a scalar string (empty string if not set) Args : none Comments: Accession numbers are extracted based on the assumption that they are delimited by | characters (NCBI-style). If this is not the case, use the name() method and parse it as necessary. See Also: L =cut #-------------------- sub accession { #-------------------- my $self = shift; if(@_) { $self->{'_accession'} = shift; } $self->{'_accession'} || ''; } =head2 raw_score Usage : $hit_object->raw_score(); Purpose : Gets the BLAST score of the best HSP for the current Blast hit. Example : $score = $hit_object->raw_score(); Returns : Integer Argument : n/a Throws : n/a See Also : L =cut #---------- sub raw_score { #---------- my $self = shift; # The check for $self->{'_score'} is a remnant from the 'query' mode days # in which the sbjct object would collect data from the description line only. my ($score); if(not defined($self->{'_score'})) { $score = $self->hsp->score; } else { $score = $self->{'_score'}; } return $score; } =head2 length Usage : $hit_object->length(); Purpose : Get the total length of the hit sequence. Example : $len = $hit_object->length(); Returns : Integer Argument : n/a Throws : n/a Comments : Developer note: when using the built-in length function within : this module, call it as CORE::length(). See Also : L, L =cut #----------- sub length { #----------- my $self = shift; return $self->{'_length'}; } =head2 significance Equivalent to L =cut #---------------- sub significance { shift->signif( @_ ); } #---------------- =head2 next_hsp Title : next_hsp Usage : $hsp = $obj->next_hsp(); Function : returns the next available High Scoring Pair object Example : Returns : Bio::Search::HSP::BlastHSP or undef if finished Args : none =cut #---------------- sub next_hsp { #---------------- my $self = shift; unless($self->{'_hsp_queue_started'}) { $self->{'_hsp_queue'} = [$self->hsps()]; $self->{'_hsp_queue_started'} = 1; } pop @{$self->{'_hsp_queue'}}; } #================================================= # End Bio::Search::Hit::HitI implementation #================================================= # Providing a more explicit method for getting name of hit # (corresponds with column name in HitTableWriter) #---------------- sub hit_name { #---------------- my $self = shift; $self->name( @_ ); } # Older method Delegates to description() #---------------- sub desc { #---------------- my $self = shift; return $self->description( @_ ); } # Providing a more explicit method for getting description of hit # (corresponds with column name in HitTableWriter) #---------------- sub hit_description { #---------------- my $self = shift; return $self->description( @_ ); } =head2 score Equivalent to L =cut #---------------- sub score { shift->raw_score( @_ ); } #---------------- =head2 hit_length Equivalent to L =cut # Providing a more explicit method for getting length of hit #---------------- sub hit_length { shift->length( @_ ); } #---------------- =head2 signif Usage : $hit_object->signif( [format] ); Purpose : Get the P or Expect value for the best HSP of the given BLAST hit. : The value returned is the one which is reported in the description : section of the Blast report. For Blast1 and WU-Blast2, this : is a P-value, for Blast2, it is an Expect value. Example : $obj->signif() # returns 1.3e-34 : $obj->signif('exp') # returns -34 : $obj->signif('parts') # returns (1.3, -34) Returns : Float or scientific notation number (the raw P/Expect value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and P/Expect value : is in scientific notation (see Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (see Comments). Throws : n/a Comments : The signif() method provides a way to deal with the fact that : Blast1 and Blast2 formats (and WU- vs. NCBI-BLAST) differ in : what is reported in the description lines of each hit in the : Blast report. The signif() method frees any client code from : having to know if this is a P-value or an Expect value, : making it easier to write code that can process both : Blast1 and Blast2 reports. This is not necessarily a good thing, : since one should always know when one is working with P-values or : Expect values (hence the deprecated status). : Use of expect() is recommended since all hits will have an Expect value. : : Using the 'parts' argument is not recommended since it will not : work as expected if the expect value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut #------------- sub signif { #------------- # Some duplication of logic for p(), expect() and signif() for the sake of performance. my ($self, $fmt) = @_; my $val = defined($self->{'_p'}) ? $self->{'_p'} : $self->{'_expect'}; # $val can be zero. defined($val) or $self->throw("Can't get P- or Expect value: HSPs may not have been set."); return $val if not $fmt or $fmt =~ /^raw/i; ## Special formats: exponent-only or as list. return &Bio::Search::BlastUtils::get_exponent($val) if $fmt =~ /^exp/i; return (split (/eE/, $val)) if $fmt =~ /^parts/i; ## Default: return the raw P/Expect-value. return $val; } #---------------- sub raw_hit_data { #---------------- my $self = shift; my $data = '>'; # Need to add blank lines where we've removed them. foreach( @{$self->{'_hit_data'}} ) { if( $_ eq 'end') { $data .= "\n"; } else { $data .= /^\s*(Score|Query)/ ? "\n$_" : $_; } } return $data; } #=head2 _set_length # # Usage : $hit_object->_set_length( "233" ); # Purpose : Set the total length of the hit sequence. # Example : $hit_object->_set_length( $len ); # Returns : n/a # Argument : Integer (only when setting). Any commas will be stripped out. # Throws : n/a # #=cut #----------- sub _set_length { #----------- my ($self, $len) = @_; $len =~ s/,//g; # get rid of commas $self->{'_length'} = $len; } #=head2 _set_description # # Usage : Private method; called automatically during construction # Purpose : Sets the description of the hit sequence. # : For sequence without descriptions, does not set any description. # Argument : Array containing description (multiple lines). # Comments : Processes the supplied description: # 1. Join all lines into one string. # 2. Remove sequence id at the beginning of description. # 3. Removes junk charactes at begin and end of description. # #=cut #-------------- sub _set_description { #-------------- my( $self, @desc ) = @_; my( $desc); # print STDERR "PsiBlastHit: RAW DESC:\n@desc\n"; $desc = join(" ", @desc); my $name = $self->name; if($desc) { $desc =~ s/^\s*\S+\s+//; # remove the sequence ID(s) # This won't work if there's no description. $desc =~ s/^\s*$name//; # ...but this should. $desc =~ s/^[\s!]+//; $desc =~ s/ \d+$//; $desc =~ s/\.+$//; $self->{'_description'} = $desc; } # print STDERR "PsiBlastHit: _set_description = $desc\n"; } =head2 to_string Title : to_string Usage : print $hit->to_string; Function: Returns a string representation for the Blast Hit. Primarily intended for debugging purposes. Example : see usage Returns : A string of the form: [PsiBlastHit] e.g.: [PsiBlastHit] emb|Z46660|SC9725 S.cerevisiae chromosome XIII cosmid Args : None =cut #---------------- sub to_string { #---------------- my $self = shift; return "[PsiBlastHit] " . $self->name . " " . $self->description; } #=head2 _set_id # # Usage : Private method; automatically called by new() # Purpose : Sets the name of the PsiBlastHit sequence from the BLAST summary line. # : The identifier is assumed to be the first # : chunk of non-whitespace characters in the description line # : Does not assume any semantics in the structure of the identifier # : (Formerly, this method attempted to extract database name from # : the seq identifiers, but this was prone to break). # Returns : n/a # Argument : String containing description line of the hit from Blast report # : or first line of an alignment section (with or without the leading '>'). # Throws : Warning if cannot locate sequence ID. # #See Also : L, L # #=cut #--------------- sub _set_id { #--------------- my( $self, $desc ) = @_; # New strategy: Assume only that the ID is the first white space # delimited chunk. Not attempting to extract accession & database name. # Clients will have to interpret it as necessary. if($desc =~ /^>?(\S+)\s*(.*)/) { my ($name, $desc) = ($1, $2); $self->name($name); $self->{'_description'} = $desc; # Note that this description comes from the summary section of the # BLAST report and so may be truncated. The full description will be # set from the alignment section. We're setting description here in case # the alignment section isn't being parsed. # Assuming accession is delimited with | symbols (NCBI-style) my @pieces = split(/\|/,$name); my $acc = pop @pieces; $self->accession( $acc ); } else { $self->warn("Can't locate sequence identifier in summary line.", "Line = $desc"); $desc = 'Unknown sequence ID' if not $desc; $self->name($desc); } } =head2 ambiguous_aln Usage : $ambig_code = $hit_object->ambiguous_aln(); Purpose : Sets/Gets ambiguity code data member. Example : (see usage) Returns : String = 'q', 's', 'qs', '-' : 'q' = query sequence contains overlapping sub-sequences : while sbjct does not. : 's' = sbjct sequence contains overlapping sub-sequences : while query does not. : 'qs' = query and sbjct sequence contains overlapping sub-sequences : relative to each other. : '-' = query and sbjct sequence do not contains multiple domains : relative to each other OR both contain the same distribution : of similar domains. Argument : n/a Throws : n/a Status : Experimental See Also : L, L =cut #-------------------- sub ambiguous_aln { #-------------------- my $self = shift; if(@_) { $self->{'_ambiguous_aln'} = shift; } $self->{'_ambiguous_aln'} || '-'; } =head2 overlap Usage : $blast_object->overlap( [integer] ); Purpose : Gets/Sets the allowable amount overlap between different HSP sequences. Example : $blast_object->overlap(5); : $overlap = $blast_object->overlap; Returns : Integer. Argument : integer. Throws : n/a Status : Experimental Comments : Any two HSPs whose sequences overlap by less than or equal : to the overlap() number of resides will be considered separate HSPs : and will not get tiled by Bio::Search::BlastUtils::_adjust_contigs(). See Also : L, L =cut #------------- sub overlap { #------------- my $self = shift; if(@_) { $self->{'_overlap'} = shift; } defined $self->{'_overlap'} ? $self->{'_overlap'} : 0; } =head2 bits Usage : $hit_object->bits(); Purpose : Gets the BLAST bit score of the best HSP for the current Blast hit. Example : $bits = $hit_object->bits(); Returns : Integer Argument : n/a Throws : Exception if bit score is not set. Comments : For BLAST1, the non-bit score is listed in the summary line. See Also : L =cut #--------- sub bits { #--------- my $self = shift; # The check for $self->{'_bits'} is a remnant from the 'query' mode days # in which the sbjct object would collect data from the description line only. my ($bits); if(not defined($self->{'_bits'})) { $bits = $self->hsp->bits; } else { $bits = $self->{'_bits'}; } return $bits; } =head2 n Usage : $hit_object->n(); Purpose : Gets the N number for the current Blast hit. : This is the number of HSPs in the set which was ascribed : the lowest P-value (listed on the description line). : This number is not the same as the total number of HSPs. : To get the total number of HSPs, use num_hsps(). Example : $n = $hit_object->n(); Returns : Integer Argument : n/a Throws : Exception if HSPs have not been set (BLAST2 reports). Comments : Note that the N parameter is not reported in gapped BLAST2. : Calling n() on such reports will result in a call to num_hsps(). : The num_hsps() method will count the actual number of : HSPs in the alignment listing, which may exceed N in : some cases. See Also : L =cut #----- sub n { #----- my $self = shift; # The check for $self->{'_n'} is a remnant from the 'query' mode days # in which the sbjct object would collect data from the description line only. my ($n); if(not defined($self->{'_n'})) { $n = $self->hsp->n; } else { $n = $self->{'_n'}; } $n ||= $self->num_hsps; return $n; } =head2 frame Usage : $hit_object->frame(); Purpose : Gets the reading frame for the best HSP after HSP tiling. : This is only valid for BLASTX and TBLASTN/X reports. Example : $frame = $hit_object->frame(); Returns : Integer (-2 .. +2) Argument : n/a Throws : Exception if HSPs have not been set (BLAST2 reports). Comments : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling frame() on each (use hsps() to get all HSPs). See Also : L =cut #----------' sub frame { #---------- my $self = shift; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; # The check for $self->{'_frame'} is a remnant from the 'query' mode days # in which the sbjct object would collect data from the description line only. my ($frame); if(not defined($self->{'_frame'})) { $frame = $self->hsp->frame('hit'); } else { $frame = $self->{'_frame'}; } return $frame; } =head2 p Usage : $hit_object->p( [format] ); Purpose : Get the P-value for the best HSP of the given BLAST hit. : (Note that P-values are not provided with NCBI Blast2 reports). Example : $p = $sbjct->p; : $p = $sbjct->p('exp'); # get exponent only. : ($num, $exp) = $sbjct->p('parts'); # split sci notation into parts Returns : Float or scientific notation number (the raw P-value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and P-value : is in scientific notation (See Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (See Comments). Throws : Warns if no P-value is defined. Uses expect instead. Comments : Using the 'parts' argument is not recommended since it will not : work as expected if the P-value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut #-------- sub p { #-------- # Some duplication of logic for p(), expect() and signif() for the sake of performance. my ($self, $fmt) = @_; my $val = $self->{'_p'}; # $val can be zero. if(not defined $val) { # P-value not defined, must be a NCBI Blast2 report. # Use expect instead. $self->warn( "P-value not defined. Using expect() instead."); $val = $self->{'_expect'}; } return $val if not $fmt or $fmt =~ /^raw/i; ## Special formats: exponent-only or as list. return &Bio::Search::BlastUtils::get_exponent($val) if $fmt =~ /^exp/i; return (split (/eE/, $val)) if $fmt =~ /^parts/i; ## Default: return the raw P-value. return $val; } =head2 expect Usage : $hit_object->expect( [format] ); Purpose : Get the Expect value for the best HSP of the given BLAST hit. Example : $e = $sbjct->expect; : $e = $sbjct->expect('exp'); # get exponent only. : ($num, $exp) = $sbjct->expect('parts'); # split sci notation into parts Returns : Float or scientific notation number (the raw expect value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and Expect : is in scientific notation (see Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (see Comments). Throws : Exception if the Expect value is not defined. Comments : Using the 'parts' argument is not recommended since it will not : work as expected if the expect value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut #----------- sub expect { #----------- # Some duplication of logic for p(), expect() and signif() for the sake of performance. my ($self, $fmt) = @_; my $val; # For Blast reports that list the P value on the description line, # getting the expect value requires fully parsing the HSP data. # For NCBI blast, there's no problem. if(not defined($self->{'_expect'})) { if( defined $self->{'_hsps'}) { $self->{'_expect'} = $val = $self->hsp->expect; } else { # If _expect is not set and _hsps are not set, # then this must be a P-value-based report that was # run without setting the HSPs (shallow parsing). $self->throw("Can't get expect value. HSPs have not been set."); } } else { $val = $self->{'_expect'}; } # $val can be zero. defined($val) or $self->throw("Can't get Expect value."); return $val if not $fmt or $fmt =~ /^raw/i; ## Special formats: exponent-only or as list. return &Bio::Search::BlastUtils::get_exponent($val) if $fmt =~ /^exp/i; return (split (/eE/, $val)) if $fmt =~ /^parts/i; ## Default: return the raw Expect-value. return $val; } =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. : Get the numbers of HSPs for the current hit. Example : @hsps = $hit_object->hsps(); : $num = $hit_object->hsps(); # alternatively, use num_hsps() Returns : Array context : list of Bio::Search::HSP::BlastHSP.pm objects. : Scalar context: integer (number of HSPs). : (Equivalent to num_hsps()). Argument : n/a. Relies on wantarray Throws : Exception if the HSPs have not been collected. See Also : L, L =cut #--------- sub hsps { #--------- my $self = shift; if (not ref $self->{'_hsps'}) { $self->throw("Can't get HSPs: data not collected."); } return wantarray # returning list containing all HSPs. ? @{$self->{'_hsps'}} # returning number of HSPs. : scalar(@{$self->{'_hsps'}}); } =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single BlastHSP.pm object for the present PsiBlastHit.pm object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a Bio::Search::HSP::BlastHSP.pm object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' or 'first' = highest scoring HSP. : 'worst' or 'last' = lowest scoring HSP. Throws : Exception if the HSPs have not been collected. : Exception if an unrecognized argument is used. See Also : L, L() =cut #---------- sub hsp { #---------- my( $self, $option ) = @_; $option ||= 'best'; if (not ref $self->{'_hsps'}) { $self->throw("Can't get HSPs: data not collected."); } my @hsps = @{$self->{'_hsps'}}; return $hsps[0] if $option =~ /best|first|1/i; return $hsps[$#hsps] if $option =~ /worst|last/i; $self->throw("Can't get HSP for: $option\n" . "Valid arguments: 'best', 'worst'"); } =head2 num_hsps Usage : $hit_object->num_hsps(); Purpose : Get the number of HSPs for the present Blast hit. Example : $nhsps = $hit_object->num_hsps(); Returns : Integer Argument : n/a Throws : Exception if the HSPs have not been collected. See Also : L =cut #------------- sub num_hsps { #------------- my $self = shift; if (not defined $self->{'_hsps'}) { $self->throw("Can't get HSPs: data not collected."); } return scalar(@{$self->{'_hsps'}}); } =head2 logical_length Usage : $hit_object->logical_length( [seq_type] ); : (mostly intended for internal use). Purpose : Get the logical length of the hit sequence. : For query sequence of BLASTX and TBLASTX reports and the hit : sequence of TBLASTN and TBLASTX reports, the returned length : is the length of the would-be amino acid sequence (length/3). : For all other BLAST flavors, this function is the same as length(). Example : $len = $hit_object->logical_length(); Returns : Integer Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This is important for functions like frac_aligned_query() : which need to operate in amino acid coordinate space when dealing : with T?BLASTX type reports. See Also : L, L, L =cut #-------------------- sub logical_length { #-------------------- my $self = shift; my $seqType = shift || 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my $length; # For the sbjct, return logical sbjct length if( $seqType eq 'sbjct' ) { $length = $self->{'_logical_length'} || $self->{'_length'}; } else { # Otherwise, return logical query length $length = $self->{'_query_length'}; # Adjust length based on BLAST flavor. if($self->{'_blast_program'} =~ /T?BLASTX/ ) { $length /= 3; } } return $length; } =head2 length_aln Usage : $hit_object->length_aln( [seq_type] ); Purpose : Get the total length of the aligned region for query or sbjct seq. : This number will include all HSPs Example : $len = $hit_object->length_aln(); # default = query : $lenAln = $hit_object->length_aln('query'); Returns : Integer Argument : seq_Type = 'query' or 'hit' or 'sbjct' (Default = 'query') ('sbjct' is synonymous with 'hit') Throws : Exception if the argument is not recognized. Comments : This method will report the logical length of the alignment, : meaning that for TBLAST[NX] reports, the length is reported : using amino acid coordinate space (i.e., nucleotides / 3). : : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling length() on each (use hsps() to get all HSPs). See Also : L, L, L, L, L, L =cut #---------------' sub length_aln { #--------------- my( $self, $seqType ) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; my $data = $self->{'_length_aln_'.$seqType}; ## If we don't have data, figure out what went wrong. if(!$data) { $self->throw("Can't get length aln for sequence type \"$seqType\"" . "Valid types are 'query', 'hit', 'sbjct' ('sbjct' = 'hit')"); } $data; } =head2 gaps Usage : $hit_object->gaps( [seq_type] ); Purpose : Get the number of gaps in the aligned query, sbjct, or both sequences. : Data is summed across all HSPs. Example : $qgaps = $hit_object->gaps('query'); : $hgaps = $hit_object->gaps('hit'); : $tgaps = $hit_object->gaps(); # default = total (query + hit) Returns : scalar context: integer : array context without args: two-element list of integers : (queryGaps, sbjctGaps) : Array context can be forced by providing an argument of 'list' or 'array'. : : CAUTION: Calling this method within printf or sprintf is arrray context. : So this function may not give you what you expect. For example: : printf "Total gaps: %d", $hit->gaps(); : Actually returns a two-element array, so what gets printed : is the number of gaps in the query, not the total : Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' | 'list' (default = 'total') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : If you need data for each HSP, use hsps() and then interate : through each HSP object. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : Not relying on wantarray since that will fail in situations : such as printf "%d", $hit->gaps() in which you might expect to : be printing the total gaps, but evaluates to array context. See Also : L =cut #---------- sub gaps { #---------- my( $self, $seqType ) = @_; $seqType ||= (wantarray ? 'list' : 'total'); $seqType = 'sbjct' if $seqType eq 'hit'; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; $seqType = lc($seqType); if($seqType =~ /list|array/i) { return ($self->{'_gaps_query'}, $self->{'_gaps_sbjct'}); } if($seqType eq 'total') { return ($self->{'_gaps_query'} + $self->{'_gaps_sbjct'}) || 0; } else { return $self->{'_gaps_'.$seqType} || 0; } } =head2 matches Usage : $hit_object->matches( [class] ); Purpose : Get the total number of identical or conserved matches : (or both) across all HSPs. : (Note: 'conservative' matches are indicated as 'positives' : in the Blast report.) Example : ($id,$cons) = $hit_object->matches(); # no argument : $id = $hit_object->matches('id'); : $cons = $hit_object->matches('cons'); Returns : Integer or a 2-element array of integers Argument : class = 'id' | 'cons' OR none. : If no argument is provided, both identical and conservative : numbers are returned in a two element list. : (Other terms can be used to refer to the conservative : matches, e.g., 'positive'. All that is checked is whether or : not the supplied string starts with 'id'. If not, the : conservative matches are returned.) Throws : Exception if the requested data cannot be obtained. Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : Does not rely on wantarray to return a list. Only checks for : the presence of an argument (no arg = return list). See Also : L, L =cut #--------------- sub matches { #--------------- my( $self, $arg) = @_; my(@data,$data); if(!$arg) { @data = ($self->{'_totalIdentical'}, $self->{'_totalConserved'}); return @data if @data; } else { if($arg =~ /^id/i) { $data = $self->{'_totalIdentical'}; } else { $data = $self->{'_totalConserved'}; } return $data if $data; } ## Something went wrong if we make it to here. $self->throw("Can't get identical or conserved data: no data."); } =head2 start Usage : $sbjct->start( [seq_type] ); Purpose : Gets the start coordinate for the query, sbjct, or both sequences : in the PsiBlastHit object. If there is more than one HSP, the lowest start : value of all HSPs is returned. Example : $qbeg = $sbjct->start('query'); : $sbeg = $sbjct->start('hit'); : ($qbeg, $sbeg) = $sbjct->start(); Returns : scalar context: integer : array context without args: list of two integers (queryStart, sbjctStart) : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This method requires that all HSPs be tiled. If there is more than one : HSP and they have not already been tiled, they will be tiled first automatically.. : Remember that the start and end coordinates of all HSPs are : normalized so that start < end. Strand information can be : obtained by calling $hit->strand(). See Also : L, L, L, L, L =cut #---------- sub start { #---------- my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; # If there is only one HSP, defer this call to the solitary HSP. if($self->num_hsps == 1) { return $self->hsp->start($seqType); } else { Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; if($seqType =~ /list|array/i) { return ($self->{'_queryStart'}, $self->{'_sbjctStart'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Start'}; } } } =head2 end Usage : $sbjct->end( [seq_type] ); Purpose : Gets the end coordinate for the query, sbjct, or both sequences : in the PsiBlastHit object. If there is more than one HSP, the largest end : value of all HSPs is returned. Example : $qend = $sbjct->end('query'); : $send = $sbjct->end('hit'); : ($qend, $send) = $sbjct->end(); Returns : scalar context: integer : array context without args: list of two integers (queryEnd, sbjctEnd) : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'sbjct' : (case insensitive). If not supplied, 'query' is used. Throws : n/a Comments : This method requires that all HSPs be tiled. If there is more than one : HSP and they have not already been tiled, they will be tiled first automatically.. : Remember that the start and end coordinates of all HSPs are : normalized so that start < end. Strand information can be : obtained by calling $hit->strand(). See Also : L, L, L, L, L =cut #---------- sub end { #---------- my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; # If there is only one HSP, defer this call to the solitary HSP. if($self->num_hsps == 1) { return $self->hsp->end($seqType); } else { Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; if($seqType =~ /list|array/i) { return ($self->{'_queryStop'}, $self->{'_sbjctStop'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Stop'}; } } } =head2 range Usage : $sbjct->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($qbeg, $qend) = $sbjct->range('query'); : ($sbeg, $send) = $sbjct->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut #---------- sub range { #---------- my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; return ($self->start($seqType), $self->end($seqType)); } =head2 frac_identical Usage : $hit_object->frac_identical( [seq_type] ); Purpose : Get the overall fraction of identical positions across all HSPs. : The number refers to only the aligned regions and does not : account for unaligned regions in between the HSPs, if any. Example : $frac_iden = $hit_object->frac_identical('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' : default = 'query' (but see comments below). : ('sbjct' is synonymous with 'hit') Throws : n/a Comments : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Identical = 34/120 Positives = 67/120". : NCBI BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : : Therefore, when called with an argument of 'total', : this method will report different values depending on the : version of BLAST used. Total does NOT take into account HSP : tiling, so it should not be used. : : To get the fraction identical among only the aligned residues, : ignoring the gaps, call this method without an argument or : with an argument of 'query' or 'hit'. : : If you need data for each HSP, use hsps() and then iterate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, L, L =cut #------------------ sub frac_identical { #------------------ my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name format. $seqType = lc($seqType); Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; sprintf( "%.2f", $self->{'_totalIdentical'}/$self->{'_length_aln_'.$seqType}); } =head2 frac_conserved Usage : $hit_object->frac_conserved( [seq_type] ); Purpose : Get the overall fraction of conserved positions across all HSPs. : The number refers to only the aligned regions and does not : account for unaligned regions in between the HSPs, if any. Example : $frac_cons = $hit_object->frac_conserved('hit'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' : default = 'query' (but see comments below). : ('sbjct' is synonymous with 'hit') Throws : n/a Comments : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Positives = 34/120 Positives = 67/120". : NCBI BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : : Therefore, when called with an argument of 'total', : this method will report different values depending on the : version of BLAST used. Total does NOT take into account HSP : tiling, so it should not be used. : : To get the fraction conserved among only the aligned residues, : ignoring the gaps, call this method without an argument or : with an argument of 'query' or 'hit'. : : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, L =cut #-------------------- sub frac_conserved { #-------------------- my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name format. $seqType = lc($seqType); Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; sprintf( "%.2f", $self->{'_totalConserved'}/$self->{'_length_aln_'.$seqType}); } =head2 frac_aligned_query Usage : $hit_object->frac_aligned_query(); Purpose : Get the fraction of the query sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_query(); Returns : Float (2-decimal precision, e.g., 0.75). Argument : n/a Throws : n/a Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : To compute the fraction aligned, the logical length of the query : sequence is used, meaning that for [T]BLASTX reports, the : full length of the query sequence is converted into amino acids : by dividing by 3. This is necessary because of the way : the lengths of aligned sequences are computed. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, L, L =cut #---------------------- sub frac_aligned_query { #---------------------- my $self = shift; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; sprintf( "%.2f", $self->{'_length_aln_query'}/$self->logical_length('query')); } =head2 frac_aligned_hit Usage : $hit_object->frac_aligned_hit(); Purpose : Get the fraction of the hit (sbjct) sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_hit(); Returns : Float (2-decimal precision, e.g., 0.75). Argument : n/a Throws : n/a Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : To compute the fraction aligned, the logical length of the sbjct : sequence is used, meaning that for TBLAST[NX] reports, the : full length of the sbjct sequence is converted into amino acids : by dividing by 3. This is necessary because of the way : the lengths of aligned sequences are computed. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically. See Also : L, L, , L, L, L =cut #-------------------- sub frac_aligned_hit { #-------------------- my $self = shift; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; sprintf( "%.2f", $self->{'_length_aln_sbjct'}/$self->logical_length('sbjct')); } ## These methods are being maintained for backward compatibility. =head2 frac_aligned_sbjct Same as L =cut #---------------- sub frac_aligned_sbjct { my $self=shift; $self->frac_aligned_hit(@_); } #---------------- =head2 num_unaligned_sbjct Same as L =cut #---------------- sub num_unaligned_sbjct { my $self=shift; $self->num_unaligned_hit(@_); } #---------------- =head2 num_unaligned_hit Usage : $hit_object->num_unaligned_hit(); Purpose : Get the number of the unaligned residues in the hit sequence. : Sums across all all HSPs. Example : $num_unaln = $hit_object->num_unaligned_hit(); Returns : Integer Argument : n/a Throws : n/a Comments : See notes regarding logical lengths in the comments for frac_aligned_hit(). : They apply here as well. : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. See Also : L, L, L =cut #--------------------- sub num_unaligned_hit { #--------------------- my $self = shift; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; my $num = $self->logical_length('sbjct') - $self->{'_length_aln_sbjct'}; ($num < 0 ? 0 : $num ); } =head2 num_unaligned_query Usage : $hit_object->num_unaligned_query(); Purpose : Get the number of the unaligned residues in the query sequence. : Sums across all all HSPs. Example : $num_unaln = $hit_object->num_unaligned_query(); Returns : Integer Argument : n/a Throws : n/a Comments : See notes regarding logical lengths in the comments for frac_aligned_query(). : They apply here as well. : If you need data for each HSP, use hsps() and then interate : through the HSP objects. : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. See Also : L, L, L =cut #----------------------- sub num_unaligned_query { #----------------------- my $self = shift; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; my $num = $self->logical_length('query') - $self->{'_length_aln_query'}; ($num < 0 ? 0 : $num ); } =head2 seq_inds Usage : $hit->seq_inds( seq_type, class, collapse ); Purpose : Get a list of residue positions (indices) across all HSPs : for identical or conserved residues in the query or sbjct sequence. Example : @s_ind = $hit->seq_inds('query', 'identical'); : @h_ind = $hit->seq_inds('hit', 'conserved'); : @h_ind = $hit->seq_inds('hit', 'conserved', 1); Returns : Array of integers : May include ranges if collapse is non-zero. Argument : [0] seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') : [1] class = 'identical' or 'conserved' (default = 'identical') : (can be shortened to 'id' or 'cons') : (actually, anything not 'id' will evaluate to 'conserved'). : [2] collapse = boolean, if non-zero, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. Throws : n/a. Comments : Note that HSPs are not tiled for this. This could be a problem : for hits containing mutually exclusive HSPs. : TODO: Consider tiling and then reporting seq_inds for the : best HSP contig. See Also : L =cut #------------- sub seq_inds { #------------- my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'sbjct' if $seqType eq 'hit'; my (@inds, $hsp); foreach $hsp ($self->hsps) { # This will merge data for all HSPs together. push @inds, $hsp->seq_inds($seqType, $class); } # Need to remove duplicates and sort the merged positions. if(@inds) { my %tmp = map { $_, 1 } @inds; @inds = sort {$a <=> $b} keys %tmp; } $collapse ? &Bio::Search::BlastUtils::collapse_nums(@inds) : @inds; } =head2 iteration Usage : $sbjct->iteration( ); Purpose : Gets the iteration number in which the Hit was found. Example : $iteration_num = $sbjct->iteration(); Returns : Integer greater than or equal to 1 Non-PSI-BLAST reports will report iteration as 1, but this number is only meaningful for PSI-BLAST reports. Argument : none Throws : none See Also : L =cut #---------------- sub iteration { shift->{'_iteration'} } #---------------- =head2 found_again Usage : $sbjct->found_again; Purpose : Gets a boolean indicator whether or not the hit has been found in a previous iteration. This is only applicable to PSI-BLAST reports. This method indicates if the hit was reported in the "Sequences used in model and found again" section of the PSI-BLAST report or if it was reported in the "Sequences not found previously or not previously below threshold" section of the PSI-BLAST report. Only for hits in iteration > 1. Example : if( $sbjct->found_again()) { ... }; Returns : Boolean (1 or 0) for PSI-BLAST report iterations greater than 1. Returns undef for PSI-BLAST report iteration 1 and non PSI_BLAST reports. Argument : none Throws : none See Also : L =cut #---------------- sub found_again { shift->{'_found_again'} } #---------------- =head2 strand Usage : $sbjct->strand( [seq_type] ); Purpose : Gets the strand(s) for the query, sbjct, or both sequences : in the best HSP of the PsiBlastHit object after HSP tiling. : Only valid for BLASTN, TBLASTX, BLASTX-query, TBLASTN-hit. Example : $qstrand = $sbjct->strand('query'); : $sstrand = $sbjct->strand('hit'); : ($qstrand, $sstrand) = $sbjct->strand(); Returns : scalar context: integer '1', '-1', or '0' : array context without args: list of two strings (queryStrand, sbjctStrand) : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling strand() on each (use hsps() to get all HSPs). : : Formerly (prior to 10/21/02), this method would return the : string "-1/1" for hits with HSPs on both strands. : However, now that strand and frame is properly being accounted : for during HSP tiling, it makes more sense for strand() : to return the strand data for the best HSP after tiling. : : If you really want to know about hits on opposite strands, : you should be iterating through the HSPs using methods on the : HSP objects. : : A possible use case where knowing whether a hit has HSPs : on both strands would be when filtering via SearchIO for hits with : this property. However, in this case it would be better to have a : dedicated method such as $hit->hsps_on_both_strands(). Similarly : for frame. This could be provided if there is interest. See Also : L() =cut #----------' sub strand { #---------- my ($self, $seqType) = @_; Bio::Search::BlastUtils::tile_hsps($self) if not $self->{'_tile_hsps'}; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; my ($qstr, $hstr); # If there is only one HSP, defer this call to the solitary HSP. if($self->num_hsps == 1) { return $self->hsp->strand($seqType); } elsif( defined $self->{'_qstrand'}) { # Get the data computed during hsp tiling. $qstr = $self->{'_qstrand'}; $hstr = $self->{'_sstrand'}; } else { # otherwise, iterate through all HSPs collecting strand info. # This will return the string "-1/1" if there are HSPs on different strands. # NOTE: This was the pre-10/21/02 procedure which will no longer be used, # (unless the above elsif{} is commented out). my (%qstr, %hstr); foreach my $hsp( $self->hsps ) { my ( $q, $h ) = $hsp->strand(); $qstr{ $q }++; $hstr{ $h }++; } $qstr = join( '/', sort keys %qstr); $hstr = join( '/', sort keys %hstr); } if($seqType =~ /list|array/i) { return ($qstr, $hstr); } elsif( $seqType eq 'query' ) { return $qstr; } else { return $hstr; } } 1; __END__ ##################################################################################### # END OF CLASS # ##################################################################################### =head1 FOR DEVELOPERS ONLY =head2 Data Members Information about the various data members of this module is provided for those wishing to modify or understand the code. Two things to bear in mind: =over 4 =item 1 Do NOT rely on these in any code outside of this module. All data members are prefixed with an underscore to signify that they are private. Always use accessor methods. If the accessor doesn't exist or is inadequate, create or modify an accessor (and let me know, too!). (An exception to this might be for BlastHSP.pm which is more tightly coupled to PsiBlastHit.pm and may access PsiBlastHit data members directly for efficiency purposes, but probably should not). =item 2 This documentation may be incomplete and out of date. It is easy for these data member descriptions to become obsolete as this module is still evolving. Always double check this info and search for members not described here. =back An instance of Bio::Search::Hit::PsiBlastHit.pm is a blessed reference to a hash containing all or some of the following fields: FIELD VALUE -------------------------------------------------------------- _hsps : Array ref for a list of Bio::Search::HSP::BlastHSP.pm objects. : _db : Database identifier from the summary line. : _desc : Description data for the hit from the summary line. : _length : Total length of the hit sequence. : _score : BLAST score. : _bits : BLAST score (in bits). Matrix-independent. : _p : BLAST P value. Obtained from summary section. (Blast1/WU-Blast only) : _expect : BLAST Expect value. Obtained from summary section. : _n : BLAST N value (number of HSPs) (Blast1/WU-Blast2 only) : _frame : Reading frame for TBLASTN and TBLASTX analyses. : _totalIdentical: Total number of identical aligned monomers. : _totalConserved: Total number of conserved aligned monomers (a.k.a. "positives"). : _overlap : Maximum number of overlapping residues between adjacent HSPs : before considering the alignment to be ambiguous. : _ambiguous_aln : Boolean. True if the alignment of all HSPs is ambiguous. : _length_aln_query : Length of the aligned region of the query sequence. : _length_aln_sbjct : Length of the aligned region of the sbjct sequence. =cut 1; BioPerl-1.6.923/Bio/Search/Hit/PullHitI.pm000555000765000024 10572612254227327 20212 0ustar00cjfieldsstaff000000000000# # BioPerl module Bio::Search::Hit::PullHitI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Hit::PullHitI - Bio::Search::Hit::HitI interface for pull parsers. =head1 SYNOPSIS # This is an interface and cannot be instantiated # typically one gets HitI objects from a SearchIO stream via a ResultI use Bio::SearchIO; my $parser = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 't/data/hmmpfam.out'); my $result = $parser->next_result; my $hit = $result->next_hit; $hit_name = $hit->name(); $desc = $hit->description(); $len = $hit->length $alg = $hit->algorithm(); $score = $hit->raw_score(); $significance = $hit->significance(); $rank = $hit->rank(); # the Nth hit for a specific query while( $hsp = $obj->next_hsp()) { ... } # process in iterator fashion for my $hsp ( $obj->hsps()()) { ... } # process in list fashion =head1 DESCRIPTION This object handles the hit data from a database sequence search. PullHitI is for fast implementations that only do parsing work on the hit data when you actually request information by calling one of the HitI methods. Many methods of HitI are implemented in a way suitable for inheriting classes that use Bio::PullParserI. It only really makes sense for PullHit modules to be created by (and have as a -parent) PullResult modules. In addition to the usual -chunk and -parent, -hit_data is all you should supply when making a PullHit object. This will store that data and make it accessible via _raw_hit_data, which you can access in your subclass. It would be best to simply provide the data as the input -chunk instead, if the raw data is large enough. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 COPYRIGHT Copyright (c) 2006 Sendu Bala. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Hit::PullHitI; use Bio::Search::SearchUtils; use strict; use base qw(Bio::PullParserI Bio::Search::Hit::HitI); =head2 _setup Title : _setup Usage : $self->_setup(@args) Function: Implementers should call this to setup common fields and deal with common arguments to new(). Returns : n/a Args : @args received in new(). =cut sub _setup { my ($self, @args) = @_; # fields most subclasses probably will want $self->_fields( { ( next_hsp => undef, num_hsps => undef, hsps => undef, hit_start => undef, query_start => undef, hit_end => undef, query_end => undef, length => undef, name => undef , accession => undef ) } ); my ($parent, $chunk, $hit_data) = $self->_rearrange([qw(PARENT CHUNK HIT_DATA)], @args); $self->throw("Need -parent or -chunk to be defined") unless $parent || $chunk; $self->parent($parent) if $parent; if ($chunk) { my ($io, $start, $end) = (undef, 0, undef); if (ref($chunk) eq 'ARRAY') { ($io, $start, $end) = @{$chunk}; } else { $io = $chunk; } $self->chunk($io, -start => $start, -end => $end); } $self->_raw_hit_data($hit_data) if $hit_data; } sub _raw_hit_data { my $self = shift; if (@_) { $self->{_raw_hit_data} = shift; } return $self->{_raw_hit_data}; } # # Some of these methods are written explitely to avoid HitI throwing not # implemented; if it didn't do that then PullParserI AUTOLOAD would have # cought them. # =head2 name Title : name Usage : $hit_name = $hit->name(); Function: returns the name of the Hit sequence Returns : a scalar string Args : none The B of a hit is unique within a Result or within an Iteration. =cut sub name { return shift->get_field('name'); } =head2 description Title : description Usage : $desc = $hit->description(); Function: Retrieve the description for the hit Returns : a scalar string Args : none =cut sub description { return shift->get_field('description'); } =head2 accession Title : accession Usage : $acc = $hit->accession(); Function: Retrieve the accession (if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub accession { return shift->get_field('accession'); } =head2 locus Title : locus Usage : $acc = $hit->locus(); Function: Retrieve the locus(if available) for the hit Returns : a scalar string (empty string if not set) Args : none =cut sub locus { return shift->get_field('locus'); } =head2 length Title : length Usage : my $len = $hit->length Function: Returns the length of the hit Returns : integer Args : none =cut sub length { return shift->get_field('length'); } =head2 algorithm Title : algorithm Usage : $alg = $hit->algorithm(); Function: Gets the algorithm specification that was used to obtain the hit For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : none =cut sub algorithm { return shift->get_field('algorithm'); } =head2 raw_score Title : raw_score Usage : $score = $hit->raw_score(); Function: Gets the "raw score" generated by the algorithm. What this score is exactly will vary from algorithm to algorithm, returning undef if unavailable. Returns : a scalar value Args : none =cut sub raw_score { return shift->get_field('score'); } =head2 score Equivalent to L =cut sub score { return shift->get_field('score'); } =head2 significance Title : significance Usage : $significance = $hit->significance(); Function: Used to obtain the E or P value of a hit, i.e. the probability that this particular hit was obtained purely by random chance. If information is not available (nor calculatable from other information sources), return undef. Returns : a scalar value or undef if unavailable Args : none =cut sub significance { return shift->get_field('significance'); } =head2 bits Usage : $hit_object->bits(); Purpose : Gets the bit score of the best HSP for the current hit. Example : $bits = $hit_object->bits(); Returns : Integer or double for FASTA reports Argument : n/a Comments : For BLAST1, the non-bit score is listed in the summary line. See Also : L =cut sub bits { return shift->get_field('bits'); } =head2 next_hsp Title : next_hsp Usage : while( $hsp = $obj->next_hsp()) { ... } Function : Returns the next available High Scoring Pair Example : Returns : L object or null if finished Args : none =cut sub next_hsp { return shift->get_field('next_hsp'); } =head2 hsps Usage : $hit_object->hsps(); Purpose : Get a list containing all HSP objects. : Get the numbers of HSPs for the current hit. Example : @hsps = $hit_object->hsps(); : $num = $hit_object->hsps(); # alternatively, use num_hsps() Returns : Array context : list of L objects. : Scalar context: integer (number of HSPs). : (Equivalent to num_hsps()). Argument : n/a. Relies on wantarray Throws : Exception if the HSPs have not been collected. See Also : L, L =cut sub hsps { return shift->get_field('hsps'); } =head2 num_hsps Usage : $hit_object->num_hsps(); Purpose : Get the number of HSPs for the present Blast hit. Example : $nhsps = $hit_object->num_hsps(); Returns : Integer Argument : n/a Throws : Exception if the HSPs have not been collected. See Also : L =cut sub num_hsps { return shift->get_field('num_hsps'); } # # HitI/ GenericHit methods that are unrelated to simply parsing information # directly out of a file, but need more complex calculation; mostly not # implemented here. # =head2 seq_inds Usage : $hit->seq_inds( seq_type, class, collapse ); Purpose : Get a list of residue positions (indices) across all HSPs : for identical or conserved residues in the query or sbjct sequence. Example : @s_ind = $hit->seq_inds('query', 'identical'); : @h_ind = $hit->seq_inds('hit', 'conserved'); : @h_ind = $hit->seq_inds('hit', 'conserved', 1); Returns : Array of integers : May include ranges if collapse is non-zero. Argument : [0] seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') : [1] class = 'identical' or 'conserved' or 'nomatch' or 'gap' : (default = 'identical') : (can be shortened to 'id' or 'cons') : Note that 'conserved' includes identical unless you use : 'conserved-not-identical' : [2] collapse = boolean, if non-zero, consecutive positions are : merged using a range notation, e.g., : "1 2 3 4 5 7 9 10 11" collapses to "1-5 7 9-11". This : is useful for consolidating long lists. Default = no : collapse. Throws : n/a. See Also : L =cut sub seq_inds { my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'hit' if $seqType eq 'sbjct'; my $storage_name = '_seq_inds_'.$seqType.'_'.$class; unless (defined $self->{$storage_name}) { my @inds; foreach my $hsp ($self->hsps) { # This will merge data for all HSPs together. push @inds, $hsp->seq_inds($seqType, $class); } # Need to remove duplicates and sort the merged positions, unless gaps. if (@inds && $class ne 'gap') { my %tmp = map { $_, 1 } @inds; @inds = sort {$a <=> $b} keys %tmp; } $self->{$storage_name} = \@inds; } my @inds = @{$self->{$storage_name}}; $collapse ? &Bio::Search::SearchUtils::collapse_nums(@inds) : @inds; } =head2 rewind Title : rewind Usage : $hit->rewind; Function: Allow one to reset the HSP iterator to the beginning if possible Returns : none Args : none =cut sub rewind { shift->throw_not_implemented(); } =head2 overlap Usage : $hit_object->overlap( [integer] ); Purpose : Gets/Sets the allowable amount overlap between different HSP sequences. Example : $hit_object->overlap(5); : $overlap = $hit_object->overlap; Returns : Integer. Argument : integer. Throws : n/a Status : Deprecated Comments : This value isn't used for anything =cut sub overlap { my $self = shift; if (@_) { $self->{_overlap} = shift } return $self->{_overlap} || 0; } =head2 n Usage : $hit_object->n(); Purpose : Gets the N number for the current Blast hit. : This is the number of HSPs in the set which was ascribed : the lowest P-value (listed on the description line). : This number is not the same as the total number of HSPs. : To get the total number of HSPs, use num_hsps(). Example : $n = $hit_object->n(); Returns : Integer Argument : n/a Throws : Exception if HSPs have not been set (BLAST2 reports). Comments : Note that the N parameter is not reported in gapped BLAST2. : Calling n() on such reports will result in a call to num_hsps(). : The num_hsps() method will count the actual number of : HSPs in the alignment listing, which may exceed N in : some cases. See Also : L =cut sub n { return shift->get_field('num_hsps'); } =head2 p Usage : $hit_object->p( [format] ); Purpose : Get the P-value for the best HSP of the given BLAST hit. : (Note that P-values are not provided with NCBI Blast2 reports). Example : $p = $sbjct->p; : $p = $sbjct->p('exp'); # get exponent only. : ($num, $exp) = $sbjct->p('parts'); # split sci notation into parts Returns : Float or scientific notation number (the raw P-value, DEFAULT). : Integer if format == 'exp' (the magnitude of the base 10 exponent). : 2-element list (float, int) if format == 'parts' and P-value : is in scientific notation (See Comments). Argument : format: string of 'raw' | 'exp' | 'parts' : 'raw' returns value given in report. Default. (1.2e-34) : 'exp' returns exponent value only (34) : 'parts' returns the decimal and exponent as a : 2-element list (1.2, -34) (See Comments). Throws : Warns if no P-value is defined. Uses expect instead. Comments : Using the 'parts' argument is not recommended since it will not : work as expected if the P-value is not in scientific notation. : That is, floats are not converted into sci notation before : splitting into parts. See Also : L, L, L =cut sub p { shift->throw_not_implemented; } =head2 hsp Usage : $hit_object->hsp( [string] ); Purpose : Get a single HSPI object for the present HitI object. Example : $hspObj = $hit_object->hsp; # same as 'best' : $hspObj = $hit_object->hsp('best'); : $hspObj = $hit_object->hsp('worst'); Returns : Object reference for a L object. Argument : String (or no argument). : No argument (default) = highest scoring HSP (same as 'best'). : 'best' = highest scoring HSP. : 'worst' = lowest scoring HSP. Throws : Exception if an unrecognized argument is used. See Also : L, L() =cut sub hsp { shift->throw_not_implemented; } =head2 logical_length Usage : $hit_object->logical_length( [seq_type] ); : (mostly intended for internal use). Purpose : Get the logical length of the hit sequence. : If the Blast is a TBLASTN or TBLASTX, the returned length : is the length of the would-be amino acid sequence (length/3). : For all other BLAST flavors, this function is the same as length(). Example : $len = $hit_object->logical_length(); Returns : Integer Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This is important for functions like frac_aligned_query() : which need to operate in amino acid coordinate space when dealing : with [T]BLAST[NX] type reports. See Also : L, L, L =cut sub logical_length { my ($self, $type) = @_; $type ||= 'query'; $type = lc($type); $type = 'hit' if $type eq 'sbjct'; if ($type eq 'query') { return $self->get_field('query_length'); } elsif ($type eq 'hit') { return $self->get_field('length'); } } =head2 rank Title : rank Usage : $obj->rank($newval) Function: Get/Set the rank of this Hit in the Query search list i.e. this is the Nth hit for a specific query Returns : value of rank Args : newvalue (optional) =cut sub rank { return shift->get_field('rank'); } =head2 each_accession_number Title : each_accession_number Usage : $obj->each_accession_number Function: Get each accession number listed in the description of the hit. If there are no alternatives, then only the primary accession will be given (if there is one). Returns : list of all accession numbers in the description Args : none =cut sub each_accession_number { my $self = shift; my $accession = $self->get_field('accession') if $self->has_field('accession'); my $desc = $self->get_field('description') if $self->has_field('description'); return unless $accession || $desc; my @accnums; push (@accnums, $accession) if $accession; if (defined $desc) { while ($desc =~ /(\b\S+\|\S*\|\S*\s?)/g) { my $id = $1; my $acc; if ($id =~ /(?:gb|emb|dbj|sp|pdb|bbs|ref|tp[gde])\|(.*)\|(?:.*)/) { ($acc) = split /\./, $1; } elsif ($id =~ /(?:pir|prf|pat|gnl)\|(?:.*)\|(.*)/) { ($acc) = split /\./, $1; } elsif ($id =~ /(?:gim|gi|bbm|bbs|lcl)\|(?:\d*)/) { $acc = $id; } elsif ($id =~ /(?:oth)\|(.*)\|(?:.*)\|(?:.*)/ ) { # discontinued... $acc = $1; } else { $acc = $id; } push(@accnums, $acc); } } return @accnums; } =head2 tiled_hsps Usage : $hit_object->tiled_hsps( [integer] ); Purpose : Gets/Sets an indicator for whether or not the HSPs in this Hit : have been tiled. Example : $hit_object->tiled_hsps(1); : if( $hit_object->tiled_hsps ) { # do something } Returns : Boolean (1 or 0) Argument : integer (optional) Throws : n/a Status : Deprecated Notes : This value is not used for anything =cut sub tiled_hsps { my $self = shift; if (@_) { $self->{_hsps_are_tiled} = shift } return $self->{_hsps_are_tiled} || 0; } =head2 strand Usage : $sbjct->strand( [seq_type] ); Purpose : Gets the strand(s) for the query, sbjct, or both sequences : in the best HSP of the BlastHit object after HSP tiling. : Only valid for BLASTN, TBLASTX, BLASTX-query, TBLASTN-hit. Example : $qstrand = $sbjct->strand('query'); : $sstrand = $sbjct->strand('hit'); : ($qstrand, $sstrand) = $sbjct->strand(); Returns : scalar context: integer '1', '-1', or '0' : array context without args: list of two strings (queryStrand, sbjctStrand) : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling strand() on each (use hsps() to get all HSPs). : : Formerly (prior to 10/21/02), this method would return the : string "-1/1" for hits with HSPs on both strands. : However, now that strand and frame is properly being accounted : for during HSP tiling, it makes more sense for strand() : to return the strand data for the best HSP after tiling. : : If you really want to know about hits on opposite strands, : you should be iterating through the HSPs using methods on the : HSP objects. : : A possible use case where knowing whether a hit has HSPs : on both strands would be when filtering via SearchIO for hits with : this property. However, in this case it would be better to have a : dedicated method such as $hit->hsps_on_both_strands(). Similarly : for frame. This could be provided if there is interest. See Also : L() =cut sub strand { shift->throw_not_implemented; } =head2 frame Usage : $hit_object->frame(); Purpose : Gets the reading frame for the best HSP after HSP tiling. : This is only valid for BLASTX and TBLASTN/X type reports. Example : $frame = $hit_object->frame(); Returns : Integer (-2 .. +2) Argument : n/a Throws : Exception if HSPs have not been set. Comments : This method requires that all HSPs be tiled. If they have not : already been tiled, they will be tiled first automatically.. : If you don't want the tiled data, iterate through each HSP : calling frame() on each (use hsps() to get all HSPs). See Also : L =cut sub frame { shift->throw_not_implemented; } =head2 length_aln Usage : $hit_object->length_aln( [seq_type] ); Purpose : Get the total length of the aligned region for query or sbjct seq. : This number will include all HSPs, and excludes gaps. Example : $len = $hit_object->length_aln(); # default = query : $lenAln = $hit_object->length_aln('query'); Returns : Integer Argument : seq_Type = 'query' or 'hit' or 'sbjct' (Default = 'query') ('sbjct' is synonymous with 'hit') Throws : Exception if the argument is not recognized. Comments : This method will report the logical length of the alignment, : meaning that for TBLAST[NX] reports, the length is reported : using amino acid coordinate space (i.e., nucleotides / 3). See Also : L, L, L, L, L, L =cut sub length_aln { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'hit' if $seqType eq 'sbjct'; my %non_gaps = map { $_, 1 } $self->seq_inds($seqType, 'conserved'), $self->seq_inds($seqType, 'no_match'); return scalar(keys %non_gaps); } =head2 gaps Usage : $hit_object->gaps( [seq_type] ); Purpose : Get the number of gaps in the aligned query, hit, or both sequences. : Data is summed across all HSPs. Example : $qgaps = $hit_object->gaps('query'); : $hgaps = $hit_object->gaps('hit'); : $tgaps = $hit_object->gaps(); # default = total (query + hit) Returns : scalar context: integer : array context without args: two-element list of integers : (queryGaps, hitGaps) : Array context can be forced by providing an argument of 'list' or : 'array'. : : CAUTION: Calling this method within printf or sprintf is arrray : context. : So this function may not give you what you expect. For example: : printf "Total gaps: %d", $hit->gaps(); : Actually returns a two-element array, so what gets printed : is the number of gaps in the query, not the total : Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' | 'list' : (default = 'total') ('sbjct' is synonymous with 'hit') Comments : If you need data for each HSP, use hsps() and then interate : through each HSP object. =cut sub gaps { my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'total'); $seqType = 'hit' if $seqType eq 'sbjct'; if ($seqType =~ /list|array/i) { return (scalar($self->seq_inds('query', 'gap')), scalar($self->seq_inds('hit', 'gap'))); } elsif ($seqType eq 'total') { return (scalar($self->seq_inds('query', 'gap')) + scalar($self->seq_inds('hit', 'gap'))) || 0; } else { return scalar($self->seq_inds($seqType, 'gap')) || 0; } } =head2 matches Usage : $hit_object->matches( [class] ); Purpose : Get the total number of identical or conserved matches : (or both) across all HSPs. : (Note: 'conservative' matches are indicated as 'positives' : in BLAST reports.) Example : ($id,$cons) = $hit_object->matches(); # no argument : $id = $hit_object->matches('id'); : $cons = $hit_object->matches('cons'); Returns : Integer or a 2-element array of integers Argument : [0] class = 'id' | 'cons' OR none. : [1] seq_type = 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') : If no argument is provided, both identical and conservative : numbers are returned in a two element list. : (Other terms can be used to refer to the conservative : matches, e.g., 'positive'. All that is checked is whether or : not the supplied string starts with 'id'. If not, the : conservative matches are returned.) =cut sub matches { my ($self, $class, $seqType) = @_; # no query/hit choice? The answer differs depending on sequence, since # hsps could overlap on one sequence and not the other. Added an option, # but otherwise will assume 'hit' $seqType ||= 'hit'; $seqType = 'hit' if $seqType eq 'sbjct'; unless (exists $self->{_id_matches}) { $self->{_id_matches}->{hit} = scalar($self->seq_inds('hit', 'identical')); $self->{_id_matches}->{query} = scalar($self->seq_inds('query', 'identical')); } unless (exists $self->{_con_matches}) { foreach my $type ('hit', 'query') { # 'conserved-not-identical' can give us 'identical' matches if hsps # overlapped so have to get the difference my %identicals = map { $_ => 1 } $self->seq_inds($type, 'identical'); my @conserved = $self->seq_inds($type, 'conserved-not-identical'); my $real_conserved; foreach (@conserved) { unless (exists $identicals{$_}) { $real_conserved++; } } $self->{_con_matches}->{$type} = $real_conserved; } } unless ($class) { return ($self->{_id_matches}->{$seqType}, $self->{_con_matches}->{$seqType}); } else { if ($class =~ /^id/i) { return $self->{_id_matches}->{$seqType}; } else { return $self->{_con_matches}->{$seqType}; } } return; } =head2 start Usage : $sbjct->start( [seq_type] ); Purpose : Gets the start coordinate for the query, sbjct, or both sequences : in the object. If there is more than one HSP, the lowest start : value of all HSPs is returned. Example : $qbeg = $sbjct->start('query'); : $sbeg = $sbjct->start('hit'); : ($qbeg, $sbeg) = $sbjct->start(); Returns : scalar context: integer : array context without args: list of two integers (queryStart, : sbjctStart) : Array context can be "induced" by providing an argument of 'list' : or 'array'. Argument : 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') =cut sub start { my ($self, $seqType) = @_; unless ($self->get_field('num_hsps')) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); return; } $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'hit' if $seqType eq 'sbjct'; if ($seqType =~ /list|array/i) { return ($self->get_field('query_start'), $self->get_field('hit_start')); } elsif ($seqType eq 'hit') { return $self->get_field('hit_start'); } elsif ($seqType eq 'query') { return $self->get_field('query_start'); } else { $self->throw("Unknown sequence type '$seqType'"); } } =head2 end Usage : $sbjct->end( [seq_type] ); Purpose : Gets the end coordinate for the query, sbjct, or both sequences : in the object. If there is more than one HSP, the largest end : value of all HSPs is returned. Example : $qend = $sbjct->end('query'); : $send = $sbjct->end('hit'); : ($qend, $send) = $sbjct->end(); Returns : scalar context: integer : array context without args: list of two integers : (queryEnd, sbjctEnd) : Array context can be "induced" by providing an argument : of 'list' or 'array'. Argument : 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') =cut sub end { my ($self, $seqType) = @_; unless ($self->get_field('num_hsps')) { Bio::Search::SearchUtils::_warn_about_no_hsps($self); return; } $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'hit' if $seqType eq 'sbjct'; if ($seqType =~ /list|array/i) { return ($self->get_field('query_end'), $self->get_field('hit_end')); } elsif ($seqType eq 'hit') { return $self->get_field('hit_end'); } elsif ($seqType eq 'query') { return $self->get_field('query_end'); } else { $self->throw("Unknown sequence type '$seqType'"); } } =head2 range Usage : $sbjct->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($qbeg, $qend) = $sbjct->range('query'); : ($sbeg, $send) = $sbjct->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut sub range { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'hit' if $seqType eq 'sbjct'; return ($self->start($seqType), $self->end($seqType)); } =head2 frac_identical Usage : $hit_object->frac_identical( [seq_type] ); Purpose : Get the overall fraction of identical positions across all HSPs. : The number refers to only the aligned regions and does not : account for unaligned regions in between the HSPs, if any. Example : $frac_iden = $hit_object->frac_identical('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' : default = 'query' (but see comments below). : ('sbjct' is synonymous with 'hit') =cut sub frac_identical { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = lc($seqType); $seqType = 'hit' if $seqType eq 'sbjct'; my $ident = $self->matches('id', $seqType); my $total = $self->length_aln($seqType); my $ratio = $ident / $total; my $ratio_rounded = sprintf( "%.3f", $ratio); # Round down if normal rounding yields 1 (just like blast) $ratio_rounded = 0.999 if (($ratio_rounded == 1) && ($ratio < 1)); return $ratio_rounded; } =head2 frac_conserved Usage : $hit_object->frac_conserved( [seq_type] ); Purpose : Get the overall fraction of conserved positions across all HSPs. : The number refers to only the aligned regions and does not : account for unaligned regions in between the HSPs, if any. Example : $frac_cons = $hit_object->frac_conserved('hit'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' : default = 'query' (but see comments below). : ('sbjct' is synonymous with 'hit') =cut sub frac_conserved { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = lc($seqType); $seqType = 'hit' if $seqType eq 'sbjct'; my $consv = $self->matches('cons'); my $total = $self->length_aln($seqType); my $ratio = $consv / $total; my $ratio_rounded = sprintf( "%.3f", $ratio); # Round down iff normal rounding yields 1 (just like blast) $ratio_rounded = 0.999 if (($ratio_rounded == 1) && ($ratio < 1)); return $ratio_rounded; } =head2 frac_aligned_query Usage : $hit_object->frac_aligned_query(); Purpose : Get the fraction of the query sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_query(); Returns : Float (2-decimal precision, e.g., 0.75). Argument : none Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. =cut sub frac_aligned_query { my $self = shift; return sprintf("%.2f", $self->length_aln('query') / $self->logical_length('query')); } =head2 frac_aligned_hit Usage : $hit_object->frac_aligned_hit(); Purpose : Get the fraction of the hit (sbjct) sequence which has been aligned : across all HSPs (not including intervals between non-overlapping : HSPs). Example : $frac_alnq = $hit_object->frac_aligned_hit(); Returns : Float (2-decimal precision, e.g., 0.75). Argument : none Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. =cut sub frac_aligned_hit { my $self = shift; return sprintf( "%.2f", $self->length_aln('sbjct') / $self->logical_length('sbjct')); } =head2 num_unaligned_hit Usage : $hit_object->num_unaligned_hit(); Purpose : Get the number of the unaligned residues in the hit sequence. : Sums across all all HSPs. Example : $num_unaln = $hit_object->num_unaligned_hit(); Returns : Integer Argument : none Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. =cut sub num_unaligned_hit { my $self = shift; # why does this method even exist?! return $self->gaps('hit'); } =head2 num_unaligned_query Usage : $hit_object->num_unaligned_query(); Purpose : Get the number of the unaligned residues in the query sequence. : Sums across all all HSPs. Example : $num_unaln = $hit_object->num_unaligned_query(); Returns : Integer Argument : none Comments : If you need data for each HSP, use hsps() and then interate : through the HSP objects. =cut sub num_unaligned_query { my $self = shift; # why does this method even exist?! return $self->gaps('query'); } # aliasing for Steve's method names *hit_description = \&description; *hit_length = \&length; 1; BioPerl-1.6.923/Bio/Search/HSP000755000765000024 012254227340 15650 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Search/HSP/BlastHSP.pm000444000765000024 15446712254227321 20043 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::HSP::BlastHSP # # (This module was originally called Bio::Tools::Blast::HSP) # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- ## POD Documentation: =head1 NAME Bio::Search::HSP::BlastHSP - Bioperl BLAST High-Scoring Pair object =head1 SYNOPSIS See L. =head1 DESCRIPTION A Bio::Search::HSP::BlastHSP object provides an interface to data obtained in a single alignment section of a Blast report (known as a "High-scoring Segment Pair"). This is essentially a pairwise alignment with score information. BlastHSP objects are accessed via L objects after parsing a BLAST report using the L system. The construction of BlastHSP objects is performed by Bio::Factory::BlastHitFactory in a process that is orchestrated by the Blast parser (L). The resulting BlastHSPs are then accessed via L). Therefore, you do not need to use L) directly. If you need to construct BlastHSPs directly, see the new() function for details. For L BLAST parsing usage examples, see the C directory of the Bioperl distribution. =head2 Start and End coordinates Sequence endpoints are swapped so that start is always less than end. This affects For TBLASTN/X hits on the minus strand. Strand information can be recovered using the strand() method. This normalization step is standard Bioperl practice. It also facilitates use of range information by methods such as match(). =over 1 =item * Supports BLAST versions 1.x and 2.x, gapped and ungapped. =back Bio::Search::HSP::BlastHSP.pm has the ability to extract a list of all residue indices for identical and conservative matches along both query and sbjct sequences. Since this degree of detail is not always needed, this behavior does not occur during construction of the BlastHSP object. These data will automatically be collected as necessary as the BlastHSP.pm object is used. =head1 DEPENDENCIES Bio::Search::HSP::BlastHSP.pm is a concrete class that inherits from L and L. L and L are employed for creating sequence and alignment objects, respectively. =head2 Relationship to SimpleAlign.pm & Seq.pm BlastHSP.pm can provide the query or sbjct sequence as a L object via the L method. The BlastHSP.pm object can also create a two-sequence L alignment object using the the query and sbjct sequences via the L method. Creation of alignment objects is not automatic when constructing the BlastHSP.pm object since this level of functionality is not always required and would generate a lot of extra overhead when crunching many reports. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac-at-bioperl.orgE See L for where to send bug reports and comments. =head1 ACKNOWLEDGEMENTS This software was originally developed in the Department of Genetics at Stanford University. I would also like to acknowledge my colleagues at Affymetrix for useful feedback. =head1 SEE ALSO Bio::Search::Hit::BlastHit.pm - Blast hit object. Bio::Search::Result::BlastResult.pm - Blast Result object. Bio::Seq.pm - Biosequence object =head2 Links: http://bio.perl.org/ - Bioperl Project Homepage =head1 COPYRIGHT Copyright (c) 1996-2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =cut # END of main POD documentation. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::BlastHSP; use strict; use Bio::SeqFeature::Similarity; use vars qw($GAP_SYMBOL %STRAND_SYMBOL); use overload '""' => \&to_string; use base qw(Bio::SeqFeature::SimilarityPair Bio::Search::HSP::HSPI); $GAP_SYMBOL = '-'; # Need a more general way to handle gap symbols. %STRAND_SYMBOL = ('Plus' => 1, 'Minus' => -1 ); =head2 new Usage : $hsp = Bio::Search::HSP::BlastHSP->new( %named_params ); : Bio::Search::HSP::BlastHSP objects are constructed : automatically by Bio::SearchIO::BlastHitFactory, : so there is no need for direct instantiation. Purpose : Constructs a new BlastHSP object and Initializes key variables : for the HSP. Returns : A Bio::Search::HSP::BlastHSP object Argument : Named parameters: : Parameter keys are case-insensitive. : -RAW_DATA => array ref containing raw BLAST report data for : for a single HSP. This includes all lines : of the HSP alignment from a traditional BLAST or PSI-BLAST (non-XML) report, : -RANK => integer (1..n). : -PROGRAM => string ('TBLASTN', 'BLASTP', etc.). : -QUERY_NAME => string, id of query sequence : -HIT_NAME => string, id of hit sequence : Comments : Having the raw data allows this object to do lazy parsing of : the raw HSP data (i.e., not parsed until needed). : : Note that there is a fair amount of basic parsing that is : currently performed in this module that would be more appropriate : to do within a separate factory object. : This parsing code will likely be relocated and more initialization : parameters will be added to new(). : See Also : L, L =cut #---------------- sub new { #---------------- my ($class, @args ) = @_; my $self = $class->SUPER::new( @args ); # Initialize placeholders $self->{'_queryGaps'} = $self->{'_sbjctGaps'} = 0; my ($raw_data, $qname, $hname, $qlen, $hlen); ($self->{'_prog'}, $self->{'_rank'}, $raw_data, $qname, $hname) = $self->_rearrange([qw( PROGRAM RANK RAW_DATA QUERY_NAME HIT_NAME )], @args ); # _set_data() does a fair amount of parsing. # This will likely change (see comment above.) $self->_set_data( @{$raw_data} ); # Store the aligned query as sequence feature my ($qb, $hb) = ($self->start()); my ($qe, $he) = ($self->end()); my ($qs, $hs) = ($self->strand()); my ($qf,$hf) = ($self->query->frame(), $self->hit->frame); $self->query( Bio::SeqFeature::Similarity->new (-start =>$qb, -end =>$qe, -strand =>$qs, -bits =>$self->bits, -score =>$self->score, -frame =>$qf, -seq_id => $qname, -source =>$self->{'_prog'} )); $self->hit( Bio::SeqFeature::Similarity->new (-start =>$hb, -end =>$he, -strand =>$hs, -bits =>$self->bits, -score =>$self->score, -frame =>$hf, -seq_id => $hname, -source =>$self->{'_prog'} )); # set lengths $self->query->seqlength($qlen); # query $self->hit->seqlength($hlen); # subject $self->query->frac_identical($self->frac_identical('query')); $self->hit->frac_identical($self->frac_identical('hit')); return $self; } # Title : _id_str; # Purpose : Intended for internal use only to provide a string for use # within exception messages to help users figure out which # query/hit caused the problem. # Returns : Short string with name of query and hit seq sub _id_str { my $self = shift; if( not defined $self->{'_id_str'}) { my $qname = $self->query->seq_id; my $hname = $self->hit->seq_id; $self->{'_id_str'} = "QUERY=\"$qname\" HIT=\"$hname\""; } return $self->{'_id_str'}; } #================================================= # Begin Bio::Search::HSP::HSPI implementation #================================================= =head2 algorithm Title : algorithm Usage : $alg = $hsp->algorithm(); Function: Gets the algorithm specification that was used to obtain the hsp For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : none =cut #---------------- sub algorithm { #---------------- my ($self,@args) = @_; return $self->{'_prog'}; } =head2 signif() Usage : $hsp_obj->signif() Purpose : Get the P-value or Expect value for the HSP. Returns : Float (0.001 or 1.3e-43) : Returns P-value if it is defined, otherwise, Expect value. Argument : n/a Throws : n/a Comments : Provided for consistency with BlastHit::signif() : Support for returning the significance data in different : formats (e.g., exponent only), is not provided for HSP objects. : This is only available for the BlastHit or Blast object. See Also : L

, L, L =cut #----------- sub signif { #----------- my $self = shift; my $val ||= defined($self->{'_p'}) ? $self->{'_p'} : $self->{'_expect'}; $val; } =head2 evalue Usage : $hsp_obj->evalue() Purpose : Get the Expect value for the HSP. Returns : Float (0.001 or 1.3e-43) Argument : n/a Throws : n/a Comments : Support for returning the expectation data in different : formats (e.g., exponent only), is not provided for HSP objects. : This is only available for the BlastHit or Blast object. See Also : L

=cut #---------- sub evalue { shift->{'_expect'} } #---------- =head2 p Usage : $hsp_obj->p() Purpose : Get the P-value for the HSP. Returns : Float (0.001 or 1.3e-43) or undef if not defined. Argument : n/a Throws : n/a Comments : P-value is not defined with NCBI Blast2 reports. : Support for returning the expectation data in different : formats (e.g., exponent only) is not provided for HSP objects. : This is only available for the BlastHit or Blast object. See Also : L =cut #----- sub p { my $self = shift; $self->{'_p'}; } #----- # alias sub pvalue { shift->p(@_); } =head2 length Usage : $hsp->length( [seq_type] ) Purpose : Get the length of the aligned portion of the query or sbjct. Example : $hsp->length('query') Returns : integer Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' (default = 'total') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : 'total' length is the full length of the alignment : as reported in the denominators in the alignment section: : "Identical = 34/120 Positives = 67/120". See Also : L =cut #----------- sub length { #----------- ## Developer note: when using the built-in length function within ## this module, call it as CORE::length(). my( $self, $seqType,$data ) = @_; $seqType ||= 'total'; $seqType = 'sbjct' if $seqType eq 'hit'; $seqType ne 'total' and $self->_set_seq_data() unless $self->{'_set_seq_data'}; ## Sensitive to member name format. $seqType = "_\L$seqType\E"; if( defined $data ) { $self->{$seqType.'Length'} = $data; } $self->{$seqType.'Length'}; } =head2 gaps Usage : $hsp->gaps( [seq_type] ) Purpose : Get the number of gap characters in the query, sbjct, or total alignment. : Also can return query gap chars and sbjct gap chars as a two-element list : when in array context. Example : $total_gaps = $hsp->gaps(); : ($qgaps, $sgaps) = $hsp->gaps(); : $qgaps = $hsp->gaps('query'); Returns : scalar context: integer : array context without args: (int, int) = ('queryGaps', 'sbjctGaps') Argument : seq_type: 'query' or 'hit' or 'sbjct' or 'total' : ('sbjct' is synonymous with 'hit') : (default = 'total', scalar context) : Array context can be "induced" by providing an argument of 'list' or 'array'. Throws : n/a See Also : L, L =cut #--------- sub gaps { #--------- my( $self, $seqType ) = @_; $self->_set_seq_data() unless $self->{'_set_seq_data'}; $seqType ||= (wantarray ? 'list' : 'total'); $seqType = 'sbjct' if $seqType eq 'hit'; if($seqType =~ /list|array/i) { return (($self->{'_queryGaps'} || 0), ($self->{'_sbjctGaps'} || 0)); } if($seqType eq 'total') { return ($self->{'_queryGaps'} + $self->{'_sbjctGaps'}) || 0; } else { ## Sensitive to member name format. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Gaps'} || 0; } } =head2 frac_identical Usage : $hsp_object->frac_identical( [seq_type] ); Purpose : Get the fraction of identical positions within the given HSP. Example : $frac_iden = $hsp_object->frac_identical('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' or 'hit' or 'sbjct' or 'total' : ('sbjct' is synonymous with 'hit') : default = 'total' (but see comments below). Throws : n/a Comments : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Identical = 34/120 Positives = 67/120". : NCBI-BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : Therefore, when called without an argument or an argument of 'total', : this method will report different values depending on the : version of BLAST used. : : To get the fraction identical among only the aligned residues, : ignoring the gaps, call this method with an argument of 'query' : or 'sbjct' ('sbjct' is synonymous with 'hit'). See Also : L, L, L =cut #------------------- sub frac_identical { #------------------- # The value is calculated as opposed to storing it from the parsed results. # This saves storage and also permits flexibility in determining for which # sequence (query or sbjct) the figure is to be calculated. my( $self, $seqType ) = @_; $seqType ||= 'total'; $seqType = 'sbjct' if $seqType eq 'hit'; if($seqType ne 'total') { $self->_set_seq_data() unless $self->{'_set_seq_data'}; } ## Sensitive to member name format. $seqType = "_\L$seqType\E"; sprintf( "%.2f", $self->{'_numIdentical'}/$self->{$seqType.'Length'}); } =head2 frac_conserved Usage : $hsp_object->frac_conserved( [seq_type] ); Purpose : Get the fraction of conserved positions within the given HSP. : (Note: 'conservative' positions are called 'positives' in the : Blast report.) Example : $frac_cons = $hsp_object->frac_conserved('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' or 'hit' or 'sbjct' or 'total' : ('sbjct' is synonymous with 'hit') : default = 'total' (but see comments below). Throws : n/a Comments : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Identical = 34/120 Positives = 67/120". : NCBI-BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : Therefore, when called without an argument or an argument of 'total', : this method will report different values depending on the : version of BLAST used. : : To get the fraction conserved among only the aligned residues, : ignoring the gaps, call this method with an argument of 'query' : or 'sbjct'. See Also : L, L, L =cut #-------------------- sub frac_conserved { #-------------------- # The value is calculated as opposed to storing it from the parsed results. # This saves storage and also permits flexibility in determining for which # sequence (query or sbjct) the figure is to be calculated. my( $self, $seqType ) = @_; $seqType ||= 'total'; $seqType = 'sbjct' if $seqType eq 'hit'; if($seqType ne 'total') { $self->_set_seq_data() unless $self->{'_set_seq_data'}; } ## Sensitive to member name format. $seqType = "_\L$seqType\E"; sprintf( "%.2f", $self->{'_numConserved'}/$self->{$seqType.'Length'}); } =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : none =cut #---------------- sub query_string{ shift->seq_str('query'); } #---------------- =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : none =cut #---------------- sub hit_string{ shift->seq_str('hit'); } #---------------- =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : none =cut #---------------- sub homology_string{ shift->seq_str('match'); } #---------------- #================================================= # End Bio::Search::HSP::HSPI implementation #================================================= # Older method delegating to method defined in HSPI. =head2 expect See L =cut #---------- sub expect { shift->evalue( @_ ); } #---------- =head2 rank Usage : $hsp->rank( [string] ); Purpose : Get the rank of the HSP within a given Blast hit. Example : $rank = $hsp->rank; Returns : Integer (1..n) corresponding to the order in which the HSP appears in the BLAST report. =cut #' #---------- sub rank { shift->{'_rank'} } #---------- # For backward compatibility #---------- sub name { shift->rank } #---------- =head2 to_string Title : to_string Usage : print $hsp->to_string; Function: Returns a string representation for the Blast HSP. Primarily intended for debugging purposes. Example : see usage Returns : A string of the form: [BlastHSP] e.g.: [BlastHit] 1 Args : None =cut #---------- sub to_string { #---------- my $self = shift; return "[BlastHSP] " . $self->rank(); } =head2 _set_data Usage : called automatically during object construction. Purpose : Parses the raw HSP section from a flat BLAST report and sets the query sequence, sbjct sequence, and the "match" data : which consists of the symbols between the query and sbjct lines : in the alignment. Argument : Array (all lines for a single, complete HSP, from a raw, flat (i.e., non-XML) BLAST report) Throws : Propagates any exceptions from the methods called ("See Also") See Also : L, L, L =cut #-------------- sub _set_data { #-------------- my $self = shift; my @data = @_; my @queryList = (); # 'Query' = SEQUENCE USED TO QUERY THE DATABASE. my @sbjctList = (); # 'Sbjct' = HOMOLOGOUS SEQUENCE FOUND IN THE DATABASE. my @matchList = (); my $matchLine = 0; # Alternating boolean: when true, load 'match' data. my @linedat = (); #print STDERR "BlastHSP: set_data()\n"; my($line, $aln_row_len, $length_diff); $length_diff = 0; # Collecting data for all lines in the alignment # and then storing the collections for possible processing later. # # Note that "match" lines may not be properly padded with spaces. # This loop now properly handles such cases: # Query: 1141 PSLVELTIRDCPRLEVGPMIRSLPKFPMLKKLDLAVANIIEEDLDVIGSLEELVIXXXXX 1200 # PSLVELTIRDCPRLEVGPMIRSLPKFPMLKKLDLAVANIIEEDLDVIGSLEELVI # Sbjct: 1141 PSLVELTIRDCPRLEVGPMIRSLPKFPMLKKLDLAVANIIEEDLDVIGSLEELVILSLKL 1200 foreach $line( @data ) { next if $line =~ /^\s*$/; if( $line =~ /^ ?Score/ ) { $self->_set_score_stats( $line ); } elsif( $line =~ /^ ?(Identities|Positives|Strand)/ ) { $self->_set_match_stats( $line ); } elsif( $line =~ /^ ?Frame = ([\d+-]+)/ ) { # Version 2.0.8 has Frame information on a separate line. # Storing frame according to SeqFeature::Generic::frame() # which does not contain strand info (use strand()). my $frame = abs($1) - 1; $self->frame( $frame ); } elsif( $line =~ /^(Query:?[\s\d]+)([^\s\d]+)/ ) { push @queryList, $line; $self->{'_match_indent'} = CORE::length $1; $aln_row_len = (CORE::length $1) + (CORE::length $2); $matchLine = 1; } elsif( $matchLine ) { # Pad the match line with spaces if necessary. $length_diff = $aln_row_len - CORE::length $line; $length_diff and $line .= ' 'x $length_diff; push @matchList, $line; $matchLine = 0; } elsif( $line =~ /^Sbjct/ ) { push @sbjctList, $line; } } # Storing the query and sbjct lists in case they are needed later. # We could make this conditional to save memory. $self->{'_queryList'} = \@queryList; $self->{'_sbjctList'} = \@sbjctList; # Storing the match list in case it is needed later. $self->{'_matchList'} = \@matchList; if(not defined ($self->{'_numIdentical'})) { my $id_str = $self->_id_str; $self->throw( -text => "Can't parse match statistics. Possibly a new or unrecognized Blast format. ($id_str)"); } if(!scalar @queryList or !scalar @sbjctList) { my $id_str = $self->_id_str; $self->throw( "Can't find query or sbjct alignment lines. Possibly unrecognized Blast format. ($id_str)"); } } =head2 _set_score_stats Usage : called automatically by _set_data() Purpose : Sets various score statistics obtained from the HSP listing. Argument : String with any of the following formats: : blast2: Score = 30.1 bits (66), Expect = 9.2 : blast2: Score = 158.2 bits (544), Expect(2) = e-110 : blast1: Score = 410 (144.3 bits), Expect = 1.7e-40, P = 1.7e-40 : blast1: Score = 55 (19.4 bits), Expect = 5.3, Sum P(3) = 0.99 Throws : Exception if the stats cannot be parsed, probably due to a change : in the Blast report format. See Also : L =cut #-------------------- sub _set_score_stats { #-------------------- my ($self, $data) = @_; my ($expect, $p); if($data =~ /Score = +([\d.e+-]+) bits \(([\d.e+-]+)\), +Expect = +([\d.e+-]+)/) { # blast2 format n = 1 $self->bits($1); $self->score($2); $expect = $3; } elsif($data =~ /Score = +([\d.e+-]+) bits \(([\d.e+-]+)\), +Expect\((\d+)\) = +([\d.e+-]+)/) { # blast2 format n > 1 $self->bits($1); $self->score($2); $self->{'_n'} = $3; $expect = $4; } elsif($data =~ /Score = +([\d.e+-]+) \(([\d.e+-]+) bits\), +Expect = +([\d.e+-]+), P = +([\d.e-]+)/) { # blast1 format, n = 1 $self->score($1); $self->bits($2); $expect = $3; $p = $4; } elsif($data =~ /Score = +([\d.e+-]+) \(([\d.e+-]+) bits\), +Expect = +([\d.e+-]+), +Sum P\((\d+)\) = +([\d.e-]+)/) { # blast1 format, n > 1 $self->score($1); $self->bits($2); $expect = $3; $self->{'_n'} = $4; $p = $5; } else { my $id_str = $self->_id_str; $self->throw(-class => 'Bio::Root::Exception', -text => "Can't parse score statistics: unrecognized format. ($id_str)", -value => $data); } $expect = "1$expect" if $expect =~ /^e/i; $p = "1$p" if defined $p and $p=~ /^e/i; $self->{'_expect'} = $expect; $self->{'_p'} = $p || undef; $self->significance( $p || $expect ); } =head2 _set_match_stats Usage : Private method; called automatically by _set_data() Purpose : Sets various matching statistics obtained from the HSP listing. Argument : blast2: Identities = 23/74 (31%), Positives = 29/74 (39%), Gaps = 17/74 (22%) : blast2: Identities = 57/98 (58%), Positives = 74/98 (75%) : blast1: Identities = 87/204 (42%), Positives = 126/204 (61%) : blast1: Identities = 87/204 (42%), Positives = 126/204 (61%), Frame = -3 : WU-blast: Identities = 310/553 (56%), Positives = 310/553 (56%), Strand = Minus / Plus Throws : Exception if the stats cannot be parsed, probably due to a change : in the Blast report format. Comments : The "Gaps = " data in the HSP header has a different meaning depending : on the type of Blast: for BLASTP, this number is the total number of : gaps in query+sbjct; for TBLASTN, it is the number of gaps in the : query sequence only. Thus, it is safer to collect the data : separately by examining the actual sequence strings as is done : in _set_seq(). See Also : L, L =cut #-------------------- sub _set_match_stats { #-------------------- my ($self, $data) = @_; if($data =~ m!Identities = (\d+)/(\d+)!) { # blast1 or 2 format $self->{'_numIdentical'} = $1; $self->{'_totalLength'} = $2; } if($data =~ m!Positives = (\d+)/(\d+)!) { # blast1 or 2 format $self->{'_numConserved'} = $1; $self->{'_totalLength'} = $2; } if($data =~ m!Frame = ([\d+-]+)!) { $self->frame($1); } # Strand data is not always present in this line. # _set_seq() will also set strand information. if($data =~ m!Strand = (\w+) / (\w+)!) { $self->{'_queryStrand'} = $1; $self->{'_sbjctStrand'} = $2; } # if($data =~ m!Gaps = (\d+)/(\d+)!) { # $self->{'_totalGaps'} = $1; # } else { # $self->{'_totalGaps'} = 0; # } } =head2 _set_seq_data Usage : called automatically when sequence data is requested. Purpose : Sets the HSP sequence data for both query and sbjct sequences. : Includes: start, stop, length, gaps, and raw sequence. Argument : n/a Throws : Propagates any exception thrown by _set_match_seq() Comments : Uses raw data stored by _set_data() during object construction. : These data are not always needed, so it is conditionally : executed only upon demand by methods such as gaps(), _set_residues(), : etc. _set_seq() does the dirty work. See Also : L =cut #----------------- sub _set_seq_data { #----------------- my $self = shift; $self->_set_seq('query', @{$self->{'_queryList'}}); $self->_set_seq('sbjct', @{$self->{'_sbjctList'}}); # Liberate some memory. @{$self->{'_queryList'}} = @{$self->{'_sbjctList'}} = (); undef $self->{'_queryList'}; undef $self->{'_sbjctList'}; $self->{'_set_seq_data'} = 1; } =head2 _set_seq Usage : called automatically by _set_seq_data() : $hsp_obj->($seq_type, @data); Purpose : Sets sequence information for both the query and sbjct sequences. : Directly counts the number of gaps in each sequence (if gapped Blast). Argument : $seq_type = 'query' or 'sbjct' : @data = all seq lines with the form: : Query: 61 SPHNVKDRKEQNGSINNAISPTATANTSGSQQINIDSALRDRSSNVAAQPSLSDASSGSN 120 Throws : Exception if data strings cannot be parsed, probably due to a change : in the Blast report format. Comments : Uses first argument to determine which data members to set : making this method sensitive data member name changes. : Behavior is dependent on the type of BLAST analysis (TBLASTN, BLASTP, etc). Warning : Sequence endpoints are normalized so that start < end. This affects HSPs : for TBLASTN/X hits on the minus strand. Normalization facilitates use : of range information by methods such as match(). See Also : L, L, L, L, L =cut #------------- sub _set_seq { #------------- my $self = shift; my $seqType = shift; my @data = @_; my @ranges = (); my @sequence = (); my $numGaps = 0; foreach( @data ) { if( m/(\d+) *([^\d\s]+) *(\d+)/) { push @ranges, ( $1, $3 ) ; push @sequence, $2; #print STDERR "_set_seq found sequence \"$2\"\n"; } else { $self->warn("Bad sequence data: $_"); } } if( !(scalar(@sequence) and scalar(@ranges))) { my $id_str = $self->_id_str; $self->throw("Can't set sequence: missing data. Possibly unrecognized Blast format. ($id_str) $seqType"); } # Sensitive to member name changes. $seqType = "_\L$seqType\E"; $self->{$seqType.'Start'} = $ranges[0]; $self->{$seqType.'Stop'} = $ranges[ $#ranges ]; $self->{$seqType.'Seq'} = \@sequence; $self->{$seqType.'Length'} = abs($ranges[ $#ranges ] - $ranges[0]) + 1; # Adjust lengths for BLASTX, TBLASTN, TBLASTX sequences # Converting nucl coords to amino acid coords. my $prog = $self->algorithm; if($prog eq 'TBLASTN' and $seqType eq '_sbjct') { $self->{$seqType.'Length'} /= 3; } elsif($prog eq 'BLASTX' and $seqType eq '_query') { $self->{$seqType.'Length'} /= 3; } elsif($prog eq 'TBLASTX') { $self->{$seqType.'Length'} /= 3; } if( $prog ne 'BLASTP' ) { $self->{$seqType.'Strand'} = 'Plus' if $prog =~ /BLASTN/; $self->{$seqType.'Strand'} = 'Plus' if ($prog =~ /BLASTX/ and $seqType eq '_query'); # Normalize sequence endpoints so that start < end. # Reverse complement or 'minus strand' HSPs get flipped here. if($self->{$seqType.'Start'} > $self->{$seqType.'Stop'}) { ($self->{$seqType.'Start'}, $self->{$seqType.'Stop'}) = ($self->{$seqType.'Stop'}, $self->{$seqType.'Start'}); $self->{$seqType.'Strand'} = 'Minus'; } } ## Count number of gaps in each seq. Only need to do this for gapped Blasts. # if($self->{'_gapped'}) { my $seqstr = join('', @sequence); $seqstr =~ s/\s//g; my $num_gaps = CORE::length($seqstr) - $self->{$seqType.'Length'}; $self->{$seqType.'Gaps'} = $num_gaps if $num_gaps > 0; # } } =head2 _set_residues Usage : called automatically when residue data is requested. Purpose : Sets the residue numbers representing the identical and : conserved positions. These data are obtained by analyzing the : symbols between query and sbjct lines of the alignments. Argument : n/a Throws : Propagates any exception thrown by _set_seq_data() and _set_match_seq(). Comments : These data are not always needed, so it is conditionally : executed only upon demand by methods such as seq_inds(). : Behavior is dependent on the type of BLAST analysis (TBLASTN, BLASTP, etc). See Also : L, L, L =cut #------------------ sub _set_residues { #------------------ my $self = shift; my @sequence = (); $self->_set_seq_data() unless $self->{'_set_seq_data'}; # Using hashes to avoid saving duplicate residue numbers. my %identicalList_query = (); my %identicalList_sbjct = (); my %conservedList_query = (); my %conservedList_sbjct = (); my $aref = $self->_set_match_seq() if not ref $self->{'_matchSeq'}; $aref ||= $self->{'_matchSeq'}; my $seqString = join('', @$aref ); my $qseq = join('',@{$self->{'_querySeq'}}); my $sseq = join('',@{$self->{'_sbjctSeq'}}); my $resCount_query = $self->{'_queryStop'} || 0; my $resCount_sbjct = $self->{'_sbjctStop'} || 0; my $prog = $self->algorithm; if($prog !~ /^BLASTP|^BLASTN/) { if($prog eq 'TBLASTN') { $resCount_sbjct /= 3; } elsif($prog eq 'BLASTX') { $resCount_query /= 3; } elsif($prog eq 'TBLASTX') { $resCount_query /= 3; $resCount_sbjct /= 3; } } my ($mchar, $schar, $qchar); while( $mchar = chop($seqString) ) { ($qchar, $schar) = (chop($qseq), chop($sseq)); if( $mchar eq '+' ) { $conservedList_query{ $resCount_query } = 1; $conservedList_sbjct{ $resCount_sbjct } = 1; } elsif( $mchar ne ' ' ) { $identicalList_query{ $resCount_query } = 1; $identicalList_sbjct{ $resCount_sbjct } = 1; } $resCount_query-- if $qchar ne $GAP_SYMBOL; $resCount_sbjct-- if $schar ne $GAP_SYMBOL; } $self->{'_identicalRes_query'} = \%identicalList_query; $self->{'_conservedRes_query'} = \%conservedList_query; $self->{'_identicalRes_sbjct'} = \%identicalList_sbjct; $self->{'_conservedRes_sbjct'} = \%conservedList_sbjct; } =head2 _set_match_seq Usage : $hsp_obj->_set_match_seq() Purpose : Set the 'match' sequence for the current HSP (symbols in between : the query and sbjct lines.) Returns : Array reference holding the match sequences lines. Argument : n/a Throws : Exception if the _matchList field is not set. Comments : The match information is not always necessary. This method : allows it to be conditionally prepared. : Called by _set_residues>() and seq_str(). See Also : L, L =cut #------------------- sub _set_match_seq { #------------------- my $self = shift; if( ! ref($self->{'_matchList'}) ) { my $id_str = $self->_id_str; $self->throw("Can't set HSP match sequence: No data ($id_str)"); } my @data = @{$self->{'_matchList'}}; my(@sequence); foreach( @data ) { chomp($_); ## Remove leading spaces; (note: aln may begin with a space ## which is why we can't use s/^ +//). s/^ {$self->{'_match_indent'}}//; push @sequence, $_; } # Liberate some memory. @{$self->{'_matchList'}} = undef; $self->{'_matchList'} = undef; $self->{'_matchSeq'} = \@sequence; return $self->{'_matchSeq'}; } =head2 n Usage : $hsp_obj->n() Purpose : Get the N value (num HSPs on which P/Expect is based). : This value is not defined with NCBI Blast2 with gapping. Returns : Integer or null string if not defined. Argument : n/a Throws : n/a Comments : The 'N' value is listed in parenthesis with P/Expect value: : e.g., P(3) = 1.2e-30 ---> (N = 3). : Not defined in NCBI Blast2 with gaps. : This typically is equal to the number of HSPs but not always. : To obtain the number of HSPs, use Bio::Search::Hit::BlastHit::num_hsps(). See Also : L =cut #----- sub n { my $self = shift; $self->{'N'} || ''; } #----- =head2 matches Usage : $hsp->matches([seq_type], [start], [stop]); Purpose : Get the total number of identical and conservative matches : in the query or sbjct sequence for the given HSP. Optionally can : report data within a defined interval along the seq. : (Note: 'conservative' matches are called 'positives' in the : Blast report.) Example : ($id,$cons) = $hsp_object->matches('hit'); : ($id,$cons) = $hsp_object->matches('query',300,400); Returns : 2-element array of integers Argument : (1) seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : (2) start = Starting coordinate (optional) : (3) stop = Ending coordinate (optional) Throws : Exception if the supplied coordinates are out of range. Comments : Relies on seq_str('match') to get the string of alignment symbols : between the query and sbjct lines which are used for determining : the number of identical and conservative matches. See Also : L, L, L, L =cut #----------- sub matches { #----------- my( $self, %param ) = @_; my(@data); my($seqType, $beg, $end) = ($param{-SEQ}, $param{-START}, $param{-STOP}); $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my($start,$stop); if(!defined $beg && !defined $end) { ## Get data for the whole alignment. push @data, ($self->{'_numIdentical'}, $self->{'_numConserved'}); } else { ## Get the substring representing the desired sub-section of aln. $beg ||= 0; $end ||= 0; ($start,$stop) = $self->range($seqType); if($beg == 0) { $beg = $start; $end = $beg+$end; } elsif($end == 0) { $end = $stop; $beg = $end-$beg; } if($end >= $stop) { $end = $stop; } ##ML changed from if (end >stop) else { $end += 1;} ##ML moved from commented position below, makes ##more sense here # if($end > $stop) { $end = $stop; } if($beg < $start) { $beg = $start; } # else { $end += 1;} # my $seq = substr($self->seq_str('match'), $beg-$start, ($end-$beg)); ## ML: START fix for substr out of range error ------------------ my $seq = ""; my $prog = $self->algorithm; if (($prog eq 'TBLASTN') and ($seqType eq 'sbjct')) { $seq = substr($self->seq_str('match'), int(($beg-$start)/3), int(($end-$beg+1)/3)); } elsif (($prog eq 'BLASTX') and ($seqType eq 'query')) { $seq = substr($self->seq_str('match'), int(($beg-$start)/3), int(($end-$beg+1)/3)); } else { $seq = substr($self->seq_str('match'), $beg-$start, ($end-$beg)); } ## ML: End of fix for substr out of range error ----------------- ## ML: debugging code ## This is where we get our exception. Try printing out the values going ## into this: ## # print STDERR # qq(*------------MY EXCEPTION --------------------\nSeq: ") , # $self->seq_str("$seqType"), qq("\n),$self->rank,",( index:"; # print STDERR $beg-$start, ", len: ", $end-$beg," ), (HSPRealLen:", # CORE::length $self->seq_str("$seqType"); # print STDERR ", HSPCalcLen: ", $stop - $start +1 ," ), # ( beg: $beg, end: $end ), ( start: $start, stop: stop )\n"; ## ML: END DEBUGGING CODE---------- if(!CORE::length $seq) { my $id_str = $self->_id_str; $self->throw("Undefined $seqType sub-sequence ($beg,$end). Valid range = $start - $stop ($id_str)"); } ## Get data for a substring. # printf "Collecting HSP subsection data: beg,end = %d,%d; start,stop = %d,%d\n%s<---\n", $beg, $end, $start, $stop, $seq; # printf "Original match seq:\n%s\n",$self->seq_str('match'); $seq =~ s/ //g; # remove space (no info). my $len_cons = CORE::length $seq; $seq =~ s/\+//g; # remove '+' characters (conservative substitutions) my $len_id = CORE::length $seq; push @data, ($len_id, $len_cons); # printf " HSP = %s\n id = %d; cons = %d\n", $self->rank, $len_id, $len_cons; ; } @data; } =head2 num_identical Usage : $hsp_object->num_identical(); Purpose : Get the number of identical positions within the given HSP. Example : $num_iden = $hsp_object->num_identical(); Returns : integer Argument : n/a Throws : n/a See Also : L, L =cut #------------------- sub num_identical { #------------------- my( $self) = shift; $self->{'_numIdentical'}; } =head2 num_conserved Usage : $hsp_object->num_conserved(); Purpose : Get the number of conserved positions within the given HSP. Example : $num_iden = $hsp_object->num_conserved(); Returns : integer Argument : n/a Throws : n/a See Also : L, L =cut #------------------- sub num_conserved { #------------------- my( $self) = shift; $self->{'_numConserved'}; } =head2 range Usage : $hsp->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($query_beg, $query_end) = $hsp->range('query'); : ($hit_beg, $hit_end) = $hsp->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut #---------- sub range { #---------- my ($self, $seqType) = @_; $self->_set_seq_data() unless $self->{'_set_seq_data'}; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return ($self->{$seqType.'Start'},$self->{$seqType.'Stop'}); } =head2 start Usage : $hsp->start( [seq_type] ); Purpose : Gets the start coordinate for the query, sbjct, or both sequences : in the HSP alignment. : NOTE: Start will always be less than end. : To determine strand, use $hsp->strand() Example : $query_beg = $hsp->start('query'); : $hit_beg = $hsp->start('hit'); : ($query_beg, $hit_beg) = $hsp->start(); Returns : scalar context: integer : array context without args: list of two integers Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default= 'query') : ('sbjct' is synonymous with 'hit') : Array context can be "induced" by providing an argument of 'list' or 'array'. Throws : n/a See Also : L, L =cut #---------- sub start { #---------- my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; $self->_set_seq_data() unless $self->{'_set_seq_data'}; if($seqType =~ /list|array/i) { return ($self->{'_queryStart'}, $self->{'_sbjctStart'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Start'}; } } =head2 end Usage : $hsp->end( [seq_type] ); Purpose : Gets the end coordinate for the query, sbjct, or both sequences : in the HSP alignment. : NOTE: Start will always be less than end. : To determine strand, use $hsp->strand() Example : $query_end = $hsp->end('query'); : $hit_end = $hsp->end('hit'); : ($query_end, $hit_end) = $hsp->end(); Returns : scalar context: integer : array context without args: list of two integers Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default= 'query') : ('sbjct' is synonymous with 'hit') : Array context can be "induced" by providing an argument of 'list' or 'array'. Throws : n/a See Also : L, L, L =cut #---------- sub end { #---------- my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; $self->_set_seq_data() unless $self->{'_set_seq_data'}; if($seqType =~ /list|array/i) { return ($self->{'_queryStop'}, $self->{'_sbjctStop'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Stop'}; } } =head2 strand Usage : $hsp_object->strand( [seq_type] ) Purpose : Get the strand of the query or sbjct sequence. Example : print $hsp->strand('query'); : ($query_strand, $hit_strand) = $hsp->strand(); Returns : -1, 0, or 1 : -1 = Minus strand, +1 = Plus strand : Returns 0 if strand is not defined, which occurs : for BLASTP reports, and the query of TBLASTN : as well as the hit if BLASTX reports. : In scalar context without arguments, returns queryStrand value. : In array context without arguments, returns a two-element list : of strings (queryStrand, sbjctStrand). : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : seq_type: 'query' or 'hit' or 'sbjct' or undef : ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut #----------- sub strand { #----------- my( $self, $seqType ) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name format. $seqType = "_\L$seqType\E"; # $seqType could be '_list'. $self->{'_queryStrand'} or $self->_set_seq_data() unless $self->{'_set_seq_data'}; my $prog = $self->algorithm; if($seqType =~ /list|array/i) { my ($qstr, $hstr); if( $prog eq 'BLASTP') { $qstr = 0; $hstr = 0; } elsif( $prog eq 'TBLASTN') { $qstr = 0; $hstr = $STRAND_SYMBOL{$self->{'_sbjctStrand'}}; } elsif( $prog eq 'BLASTX') { $qstr = $STRAND_SYMBOL{$self->{'_queryStrand'}}; $hstr = 0; } else { $qstr = $STRAND_SYMBOL{$self->{'_queryStrand'}} if defined $self->{'_queryStrand'}; $hstr = $STRAND_SYMBOL{$self->{'_sbjctStrand'}} if defined $self->{'_sbjctStrand'}; } $qstr ||= 0; $hstr ||= 0; return ($qstr, $hstr); } local $^W = 0; $STRAND_SYMBOL{$self->{$seqType.'Strand'}} || 0; } =head2 seq Usage : $hsp->seq( [seq_type] ); Purpose : Get the query or sbjct sequence as a Bio::Seq.pm object. Example : $seqObj = $hsp->seq('query'); Returns : Object reference for a Bio::Seq.pm object. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query'). : ('sbjct' is synonymous with 'hit') Throws : Propagates any exception that occurs during construction : of the Bio::Seq.pm object. Comments : The sequence is returned in an array of strings corresponding : to the strings in the original format of the Blast alignment. : (i.e., same spacing). See Also : L, L, L =cut #------- sub seq { #------- my($self,$seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my $str = $self->seq_str($seqType); require Bio::Seq; Bio::Seq->new(-ID => $self->to_string, -SEQ => $str, -DESC => "$seqType sequence", ); } =head2 seq_str Usage : $hsp->seq_str( seq_type ); Purpose : Get the full query, sbjct, or 'match' sequence as a string. : The 'match' sequence is the string of symbols in between the : query and sbjct sequences. Example : $str = $hsp->seq_str('query'); Returns : String Argument : seq_Type = 'query' or 'hit' or 'sbjct' or 'match' : ('sbjct' is synonymous with 'hit') Throws : Exception if the argument does not match an accepted seq_type. Comments : Calls _set_seq_data() to set the 'match' sequence if it has : not been set already. See Also : L, L, L =cut #------------ sub seq_str { #------------ my($self,$seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; $self->_set_seq_data() unless $self->{'_set_seq_data'}; if($seqType =~ /sbjct|query/) { my $seq = join('',@{$self->{$seqType.'Seq'}}); $seq =~ s/\s+//g; return $seq; } elsif( $seqType =~ /match/i) { # Only need to call _set_match_seq() if the match seq is requested. my $aref = $self->_set_match_seq() unless ref $self->{'_matchSeq'}; $aref = $self->{'_matchSeq'}; return join('',@$aref); } else { my $id_str = $self->_id_str; $self->throw(-class => 'Bio::Root::BadParameter', -text => "Invalid or undefined sequence type: $seqType ($id_str)\n" . "Valid types: query, sbjct, match", -value => $seqType); } } =head2 seq_inds Usage : $hsp->seq_inds( seq_type, class, collapse ); Purpose : Get a list of residue positions (indices) for all identical : or conserved residues in the query or sbjct sequence. Example : @s_ind = $hsp->seq_inds('query', 'identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved'); : @h_ind = $hsp->seq_inds('hit', 'conserved', 1); Returns : List of integers : May include ranges if collapse is true. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : class = 'identical' or 'conserved' (default = identical) : (can be shortened to 'id' or 'cons') : (actually, anything not 'id' will evaluate to 'conserved'). : collapse = boolean, if true, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. Throws : n/a. Comments : Calls _set_residues() to set the 'match' sequence if it has : not been set already. See Also : L, L, L, L =cut #--------------- sub seq_inds { #--------------- my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'sbjct' if $seqType eq 'hit'; $self->_set_residues() unless defined $self->{'_identicalRes_query'}; $seqType = ($seqType !~ /^q/i ? 'sbjct' : 'query'); $class = ($class !~ /^id/i ? 'conserved' : 'identical'); ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; $class = "_\L$class\E"; my @ary = sort { $a <=> $b } keys %{ $self->{"${class}Res$seqType"}}; require Bio::Search::BlastUtils if $collapse; return $collapse ? &Bio::Search::BlastUtils::collapse_nums(@ary) : @ary; } =head2 get_aln Usage : $hsp->get_aln() Purpose : Get a Bio::SimpleAlign object constructed from the query + sbjct : sequences of the present HSP object. Example : $aln_obj = $hsp->get_aln(); Returns : Object reference for a Bio::SimpleAlign.pm object. Argument : n/a. Throws : Propagates any exception ocurring during the construction of : the Bio::SimpleAlign object. Comments : Requires Bio::SimpleAlign. : The Bio::SimpleAlign object is constructed from the query + sbjct : sequence objects obtained by calling seq(). : Gap residues are included (see $GAP_SYMBOL). See Also : L, L =cut #------------ sub get_aln { #------------ my $self = shift; require Bio::SimpleAlign; require Bio::LocatableSeq; my $qseq = $self->seq('query'); my $sseq = $self->seq('sbjct'); my $type = $self->algorithm =~ /P$|^T/ ? 'amino' : 'dna'; my $aln = Bio::SimpleAlign->new(); $aln->add_seq(Bio::LocatableSeq->new(-seq => $qseq->seq(), -id => 'query_'.$qseq->display_id(), -start => 1, -end => CORE::length($qseq))); $aln->add_seq(Bio::LocatableSeq->new(-seq => $sseq->seq(), -id => 'hit_'.$sseq->display_id(), -start => 1, -end => CORE::length($sseq))); return $aln; } 1; __END__ =head1 FOR DEVELOPERS ONLY =head2 Data Members Information about the various data members of this module is provided for those wishing to modify or understand the code. Two things to bear in mind: =over 4 =item 1 Do NOT rely on these in any code outside of this module. All data members are prefixed with an underscore to signify that they are private. Always use accessor methods. If the accessor doesn't exist or is inadequate, create or modify an accessor (and let me know, too!). =item 2 This documentation may be incomplete and out of date. It is easy for these data member descriptions to become obsolete as this module is still evolving. Always double check this info and search for members not described here. =back An instance of Bio::Search::HSP::BlastHSP.pm is a blessed reference to a hash containing all or some of the following fields: FIELD VALUE -------------------------------------------------------------- (member names are mostly self-explanatory) _score : _bits : _p : _n : Integer. The 'N' value listed in parenthesis with P/Expect value: : e.g., P(3) = 1.2e-30 ---> (N = 3). : Not defined in NCBI Blast2 with gaps. : To obtain the number of HSPs, use Bio::Search::Hit::BlastHit::num_hsps(). _expect : _queryLength : _queryGaps : _queryStart : _queryStop : _querySeq : _sbjctLength : _sbjctGaps : _sbjctStart : _sbjctStop : _sbjctSeq : _matchSeq : String. Contains the symbols between the query and sbjct lines which indicate identical (letter) and conserved ('+') matches or a mismatch (' '). _numIdentical : _numConserved : _identicalRes_query : _identicalRes_sbjct : _conservedRes_query : _conservedRes_sbjct : _match_indent : The number of leading space characters on each line containing the match symbols. _match_indent is 13 in this example: Query: 285 QNSAPWGLARISHRERLNLGSFNKYLYDDDAG Q +APWGLARIS G+ + Y YD+ AG ^^^^^^^^^^^^^ =cut 1; BioPerl-1.6.923/Bio/Search/HSP/BlastPullHSP.pm000444000765000024 3720012254227320 20640 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::BlastPullHSP # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::BlastPullHSP - A parser and HSP object for BlastN hsps =head1 SYNOPSIS # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 'result.blast'); while (my $result = $in->next_result) { while (my $hit = $result->next_hit) { print $hit->name, "\n"; print $hit->score, "\n"; print $hit->significance, "\n"; while (my $hsp = $hit->next_hsp) { # process HSPI objects } } } =head1 DESCRIPTION This object implements a parser for BlastN hsp output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::BlastPullHSP; use strict; use base qw(Bio::Search::HSP::PullHSPI); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::BlastNHSP->new(); Function: Builds a new Bio::Search::HSP::BlastNHSP object. Returns : Bio::Search::HSP::BlastNHSP Args : -chunk => [Bio::Root::IO, $start, $end] (required if no -parent) -parent => Bio::PullParserI object (required if no -chunk) where the array ref provided to -chunk contains an IO object for a filehandle to something representing the raw data of the hsp, and $start and $end define the tell() position within the filehandle that the hsp data starts and ends (optional; defaults to start and end of the entire thing described by the filehandle) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_setup(@args); my $fields = $self->_fields; foreach my $field (qw( header alignment query_strand hit_strand )) { $fields->{$field} = undef; } $self->_dependencies( { ( score => 'header', bits => 'header', evalue => 'header', total_gaps => 'header', query_strand => 'header', hit_strand => 'header', alignment => 'header', query_string => 'alignment', hit_string => 'alignment', homology_string => 'alignment', query_start => 'alignment', query_end => 'alignment', hit_start => 'alignment', hit_end => 'alignment', hit_identical_inds => 'seq_inds', hit_conserved_inds => 'seq_inds', hit_nomatch_inds => 'seq_inds', hit_gap_inds => 'seq_inds', query_identical_inds => 'seq_inds', query_conserved_inds => 'seq_inds', query_nomatch_inds => 'seq_inds', query_gap_inds => 'seq_inds' ) } ); return $self; } # # PullParserI discovery methods so we can answer all HitI questions # sub _discover_header { my $self = shift; $self->_chunk_seek(0); my $header = $self->_get_chunk_by_end("\nQuery"); $self->{_after_header} = $self->_chunk_tell; ($self->_fields->{bits}, $self->_fields->{score}, $self->_fields->{evalue}, $self->_fields->{total_gaps}, $self->_fields->{query_strand}, $self->_fields->{hit_strand}) = $header =~ /^\s*(\S+) bits \((\d+)\),\s+Expect = (\S+)(?:\s+.+Gaps = (\d+))?(?:.+Strand\s*=\s*(\w+)\s*\/\s*(\w+))?/sm; if ($self->_fields->{query_strand}) { # protein blasts don't have strand for my $strand_type ('query_strand', 'hit_strand') { $self->_fields->{$strand_type} = $self->_fields->{$strand_type} eq 'Plus' ? 1 : -1; } } else { $self->_fields->{query_strand} = 0; $self->_fields->{hit_strand} = 0; } if ($self->_fields->{evalue} =~ /^e/) { $self->_fields->{evalue} = '1'.$self->_fields->{evalue}; } # query_gaps isn't always given $self->_fields->{total_gaps} = '[unset]' unless $self->_fields->{total_gaps}; $self->_fields->{header} = 1; } sub _discover_alignment { my $self = shift; $self->_chunk_seek($self->{_after_header}); # work out various basic fields for the hsp # (quicker to do this all at once instead of each method working on # alignment itself) my ($query_string, $hit_string, $homology_string, $q_start, $h_start, $q_end, $h_end); while (my $strip = $self->_get_chunk_by_end("\nQuery") || $self->_get_chunk_by_nol(4)) { $strip =~ /\s+(\d+)\s+(\S+)\s+(\d+)\s+(\S.+)\nSbjct:?\s+(\d+)\s+(\S+)\s+(\d+)/gm || last; my $q1 = $1; $query_string .= $2; my $q2 = $3; my $hom = $4; my $h1 = $5; $hit_string .= $6; my $h2 = $7; $hom = ' 'x(length($6) - length($hom)).$hom; $homology_string .= $hom; for my $q ($q1, $q2) { if (! defined $q_start || $q < $q_start) { $q_start = $q; } if (! defined $q_end || $q > $q_end) { $q_end = $q; } } for my $h ($h1, $h2) { if (! defined $h_start || $h < $h_start) { $h_start = $h; } if (! defined $h_end || $h > $h_end) { $h_end = $h; } } } $self->_fields->{query_string} = $query_string; $self->_fields->{hit_string} = $hit_string; $self->_fields->{homology_string} = $homology_string; $self->_fields->{query_start} = $q_start; $self->_fields->{query_end} = $q_end; $self->_fields->{hit_start} = $h_start; $self->_fields->{hit_end} = $h_end; ($self->{_query_gaps}) = $query_string =~ tr/-//; ($self->{_hit_gaps}) = $hit_string =~ tr/-//; ($self->{_total_gaps}) = $self->{_query_gaps} + $self->{_hit_gaps}; $self->_fields->{alignment} = 1; # stop this method being called again } # seq_inds related methods, all just need seq_inds field to have been gotten sub _discover_seq_inds { my $self = shift; my ($seqString, $qseq, $sseq) = ( $self->get_field('homology_string'), $self->get_field('query_string'), $self->get_field('hit_string') ); # (code largely lifted from GenericHSP) # Using hashes to avoid saving duplicate residue numbers. my %identicalList_query = (); my %identicalList_sbjct = (); my %conservedList_query = (); my %conservedList_sbjct = (); my @gapList_query = (); my @gapList_sbjct = (); my %nomatchList_query = (); my %nomatchList_sbjct = (); my $resCount_query = $self->get_field('query_end'); my $resCount_sbjct = $self->get_field('hit_end'); my ($mchar, $schar, $qchar); while ($mchar = chop($seqString) ) { ($qchar, $schar) = (chop($qseq), chop($sseq)); if ($mchar eq '+' || $mchar eq '.' || $mchar eq ':') { $conservedList_query{ $resCount_query } = 1; $conservedList_sbjct{ $resCount_sbjct } = 1; } elsif ($mchar eq ' ') { $nomatchList_query{ $resCount_query } = 1; $nomatchList_sbjct{ $resCount_sbjct } = 1; } else { $identicalList_query{ $resCount_query } = 1; $identicalList_sbjct{ $resCount_sbjct } = 1; } if ($qchar eq '-') { push(@gapList_query, $resCount_query); } else { $resCount_query -= 1; } if ($schar eq '-') { push(@gapList_sbjct, $resCount_sbjct); } else { $resCount_sbjct -= 1; } } my $fields = $self->_fields; $fields->{hit_identical_inds} = [ sort { $a <=> $b } keys %identicalList_sbjct ]; $fields->{hit_conserved_inds} = [ sort { $a <=> $b } keys %conservedList_sbjct ]; $fields->{hit_nomatch_inds} = [ sort { $a <=> $b } keys %nomatchList_sbjct ]; $fields->{hit_gap_inds} = [ reverse @gapList_sbjct ]; $fields->{query_identical_inds} = [ sort { $a <=> $b } keys %identicalList_query ]; $fields->{query_conserved_inds} = [ sort { $a <=> $b } keys %conservedList_query ]; $fields->{query_nomatch_inds} = [ sort { $a <=> $b } keys %nomatchList_query ]; $fields->{query_gap_inds} = [ reverse @gapList_query ]; $fields->{seq_inds} = 1; } =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : L Args : none =cut sub query { my $self = shift; unless ($self->{_created_query}) { $self->SUPER::query( new Bio::SeqFeature::Similarity ('-primary' => $self->primary_tag, '-start' => $self->get_field('query_start'), '-end' => $self->get_field('query_end'), '-expect' => $self->get_field('evalue'), '-score' => $self->get_field('score'), '-strand' => $self->get_field('query_strand'), '-seq_id' => $self->get_field('query_name'), '-seqlength'=> $self->get_field('query_length'), '-source' => $self->get_field('algorithm'), '-seqdesc' => $self->get_field('query_description'), '-frame' => 0 # not known? ) ); $self->{_created_query} = 1; } return $self->SUPER::query(@_); } =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : L Args : [optional] new value to set =cut sub hit { my $self = shift; unless ($self->{_created_hit}) { $self->SUPER::hit( new Bio::SeqFeature::Similarity ('-primary' => $self->primary_tag, '-start' => $self->get_field('hit_start'), '-end' => $self->get_field('hit_end'), '-expect' => $self->get_field('evalue'), '-score' => $self->get_field('score'), '-strand' => $self->get_field('hit_strand'), '-seq_id' => $self->get_field('name'), '-seqlength'=> $self->get_field('length'), '-source' => $self->get_field('algorithm'), '-seqdesc' => $self->get_field('description'), '-frame' => 0 # not known? ) ); $self->{_created_hit} = 1; } return $self->SUPER::hit(@_); } =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gap characters in the query, hit, or total alignment. Returns : Integer, number of gap characters or 0 if none Args : 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) 'total' = num conserved / length of alignment (with gaps) default = 'total' =cut sub gaps { my ($self, $type) = @_; $type = lc $type if defined $type; $type = 'total' if (! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); $type = 'hit' if $type =~ /sbjct|subject/; if ($type eq 'total') { my $answer = $self->get_field('total_gaps'); return $answer unless $answer eq '[unset]'; } $self->get_field('alignment'); # make sure gaps have been calculated return $self->{'_'.$type.'_gaps'}; } =head2 strand Title : strand Usage : $hsp->strand('query') Function: Retrieves the strand for the HSP component requested Returns : +1 or -1 (0 if unknown) Args : 'hit' or 'subject' or 'sbjct' to retrieve the strand of the subject 'query' to retrieve the query strand (default) 'list' or 'array' to retreive both query and hit together =cut sub strand { my $self = shift; my $val = shift; $val = 'query' unless defined $val; $val =~ s/^\s+//; if ($val =~ /^q/i) { return $self->get_field('query_strand'); } elsif ($val =~ /^hi|^s/i) { return $self->get_field('hit_strand'); } elsif ($val =~ /^list|array/i) { return ($self->get_field('query_strand'), $self->get_field('hit_strand')); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 start Title : start Usage : $hsp->start('query') Function: Retrieves the start for the HSP component requested Returns : integer, or list of two integers (query start and subject start) in list context Args : 'hit' or 'subject' or 'sbjct' to retrieve the start of the subject 'query' to retrieve the query start (default) =cut sub start { my $self = shift; my $val = shift; $val = (wantarray ? 'list' : 'query') unless defined $val; $val =~ s/^\s+//; if ($val =~ /^q/i) { return $self->get_field('query_start'); } elsif ($val =~ /^(hi|s)/i) { return $self->get_field('hit_start'); } elsif ($val =~ /^list|array/i) { return ($self->get_field('query_start'), $self->get_field('hit_start') ); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 end Title : end Usage : $hsp->end('query') Function: Retrieves the end for the HSP component requested Returns : integer, or list of two integers (query end and subject end) in list context Args : 'hit' or 'subject' or 'sbjct' to retrieve the end of the subject 'query' to retrieve the query end (default) =cut sub end { my $self = shift; my $val = shift; $val = (wantarray ? 'list' : 'query') unless defined $val; $val =~ s/^\s+//; if ($val =~ /^q/i) { return $self->get_field('query_end'); } elsif ($val =~ /^(hi|s)/i) { return $self->get_field('hit_end'); } elsif ($val =~ /^list|array/i) { return ($self->get_field('query_end'), $self->get_field('hit_end')); } else { $self->warn("unrecognized end component '$val' requested\n"); } return 0; } =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP Returns : undef (Hmmpfam reports do not have p-values) Args : none =cut sub pvalue { } 1; BioPerl-1.6.923/Bio/Search/HSP/FastaHSP.pm000444000765000024 1340012254227334 17775 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::FastaHSP # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::FastaHSP - HSP object for FASTA specific data =head1 SYNOPSIS # get a FastaHSP from a SearchIO stream my $in = Bio::SearchIO->new(-format => 'fasta', -file => 'filename.fasta'); while( my $r = $in->next_result) { while( my $hit = $r->next_result ) { while( my $hsp = $hit->next_hsp ) { print "smith-waterman score (if available): ", $hsp->sw_score(),"\n"; } } } =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::FastaHSP; use strict; use base qw(Bio::Search::HSP::GenericHSP); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::FastaHSP->new(); Function: Builds a new Bio::Search::HSP::FastaHSP object Returns : Bio::Search::HSP::FastaHSP Args : -swscore => smith-waterman score =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($swscore, $evalue2) = $self->_rearrange([qw(SWSCORE EVALUE2)], @args); defined $swscore && $self->sw_score($swscore); defined $evalue2 && $self->evalue2($evalue2); return $self; } =head2 sw_score Title : sw_score Usage : $obj->sw_score($newval) Function: Get/Set Smith-Waterman score Returns : value of sw_score Args : newvalue (optional) =cut sub sw_score{ my ($self,$value) = @_; if( defined $value || ! defined $self->{'_sw_score'} ) { $value = 0 unless defined $value; # default value $self->{'_sw_score'} = $value; } return $self->{'_sw_score'}; } =head2 evalue2 Title : evalue2 Usage : $obj->evalue2($newval) Function: Get/Set E2() expectation value Returns : value of evalue2 Args : newvalue (optional) =cut sub evalue2{ my ($self,$value) = @_; if( defined $value || ! defined $self->{'_evalue2'} ) { $value = 0 unless defined $value; # default value $self->{'_evalue2'} = $value; } return $self->{'_evalue2'}; } sub get_aln { my ($self) = @_; require Bio::LocatableSeq; require Bio::SimpleAlign; my $aln = Bio::SimpleAlign->new(); my $hs = $self->hit_string(); my $qs = $self->query_string(); # fasta reports some extra 'regional' sequence information # we need to clear out first # this seemed a bit insane to me at first, but it appears to # work --jason # modified to deal with LocatableSeq's end point verification and to deal # with frameshifts (which shift the end points in translated sequences). # we infer the end of the regional sequence where the first # non space is in the homology string # then we use the HSP->length to tell us how far to read # to cut off the end of the sequence my ($start, $rest) = (0, 0); if( $self->homology_string() =~ /^(\s+)?(.*?)\s*$/ ) { ($start, $rest) = ($1 ? CORE::length($1) : 0, CORE::length($2)); } $self->debug("hs seq is '$hs'\n"); $self->debug("qs seq is '$qs'\n"); $hs = substr($hs, $start,$rest); $qs = substr($qs, $start,$rest); my $seqonly = $qs; $seqonly =~ s/\s+//g; my ($q_nm,$s_nm) = ($self->query->seq_id(), $self->hit->seq_id()); unless( defined $q_nm && CORE::length ($q_nm) ) { $q_nm = 'query'; } unless( defined $s_nm && CORE::length ($s_nm) ) { $s_nm = 'hit'; } $self->_calculate_seq_positions; my $query = Bio::LocatableSeq->new('-seq' => $seqonly, '-id' => $q_nm, '-start' => $self->query->start, '-end' => $self->query->end, '-frameshifts' => (exists $self->{seqinds}{_frameshiftRes_query}) ? $self->{seqinds}{_frameshiftRes_query} : undef, '-mapping' => [1, $self->{_query_mapping}], -verbose => $self->verbose ); $seqonly = $hs; $seqonly =~ s/\s+//g; my $hit = Bio::LocatableSeq->new('-seq' => $seqonly, '-id' => $s_nm, '-start' => $self->hit->start, '-end' => $self->hit->end, '-frameshifts' => exists $self->{seqinds}{_frameshiftRes_sbjct} ? $self->{seqinds}{_frameshiftRes_sbjct} : undef, '-mapping' => [1, $self->{_hit_mapping}], -verbose => $self->verbose ); $aln->add_seq($query); $aln->add_seq($hit); return $aln; } 1; BioPerl-1.6.923/Bio/Search/HSP/GenericHSP.pm000444000765000024 15405412254227332 20344 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::GenericHSP # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::GenericHSP - A "Generic" implementation of a High Scoring Pair =head1 SYNOPSIS my $hsp = Bio::Search::HSP::GenericHSP->new( -algorithm => 'blastp', -evalue => '1e-30', ); $r_type = $hsp->algorithm; $pvalue = $hsp->p(); $evalue = $hsp->evalue(); $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); $qseq = $hsp->query_string; $hseq = $hsp->hit_string; $homo_string = $hsp->homology_string; $len = $hsp->length( ['query'|'hit'|'total'] ); $len = $hsp->length( ['query'|'hit'|'total'] ); $rank = $hsp->rank; # TODO: Describe how to configure a SearchIO stream so that it generates # GenericHSP objects. =head1 DESCRIPTION This implementation is "Generic", meaning it is is suitable for holding information about High Scoring pairs from most Search reports such as BLAST and FastA. Specialized objects can be derived from this. Unless you're writing a parser, you won't ever need to create a GenericHSP or any other HSPI-implementing object. If you use the SearchIO system, HSPI objects are created automatically from a SearchIO stream which returns Bio::Search::Result::ResultI objects and you get the HSPI objects via the ResultI API. For documentation on what you can do with GenericHSP (and other HSPI objects), please see the API documentation in L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich and Steve Chervitz Email jason-at-bioperl.org Email sac-at-bioperl.org =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::GenericHSP; use strict; use Bio::Root::Root; use Bio::SeqFeature::Similarity; use base qw(Bio::Search::HSP::HSPI); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::GenericHSP->new(); Function: Builds a new Bio::Search::HSP::GenericHSP object Returns : Bio::Search::HSP::GenericHSP Args : -algorithm => algorithm used (BLASTP, TBLASTX, FASTX, etc) -evalue => evalue -pvalue => pvalue -bits => bit value for HSP -score => score value for HSP (typically z-score but depends on analysis) -hsp_length=> Length of the HSP (including gaps) -identical => # of residues that that matched identically -percent_identity => (optional) percent identity -conserved => # of residues that matched conservatively (only protein comparisions; conserved == identical in nucleotide comparisons) -hsp_gaps => # of gaps in the HSP -query_gaps => # of gaps in the query in the alignment -hit_gaps => # of gaps in the subject in the alignment -query_name => HSP Query sequence name (if available) -query_start => HSP Query start (in original query sequence coords) -query_end => HSP Query end (in original query sequence coords) -query_length=> total length of the query sequence -query_seq => query sequence portion of the HSP -query_desc => textual description of the query -hit_name => HSP Hit sequence name (if available) -hit_start => HSP Hit start (in original hit sequence coords) -hit_end => HSP Hit end (in original hit sequence coords) -hit_length => total length of the hit sequence -hit_seq => hit sequence portion of the HSP -hit_desc => textual description of the hit -homology_seq=> homology sequence for the HSP -hit_frame => hit frame (only if hit is translated protein) -query_frame => query frame (only if query is translated protein) -rank => HSP rank -links => HSP links information (WU-BLAST only) -hsp_group => HSP Group informat (WU-BLAST only) -gap_symbol => symbol representing a gap (default = '-') -hit_features=> string of features found in or near HSP hit region (reported in some BLAST text output, v. 2.2.13 and up) -stranded => If the algorithm isn't known (i.e. defaults to 'generic'), setting this will indicate start/end coordinates are to be used to determine the strand for 'query', 'subject', 'hit', 'both', or 'none' (default = 'none') =cut sub new { my($class,%args) = @_; # don't pass anything to SUPER; complex hierarchy results in lots of work # for nothing my $self = $class->SUPER::new(); # for speed, don't use _rearrange and just store all input data directly # with no method calls and no work done. work can be carried # out just-in-time later if desired while (my ($arg, $value) = each %args) { $arg =~ tr/a-z\055/A-Z/d; $self->{$arg} = $value; } my $bits = $self->{BITS}; defined $self->{VERBOSE} && $self->verbose($self->{VERBOSE}); if (exists $self->{GAP_SYMBOL}) { # not checking anything else but the length (must be 1 as only one gap # symbol allowed currently); can add in support for symbol checks or # multiple symbols later if needed $self->throw("Gap symbol must be of length 1") if CORE::length($self->{GAP_SYMBOL}) != 1; } else { # dafault $self->{GAP_SYMBOL} = '-'; } $self->{ALGORITHM} ||= 'GENERIC'; $self->{STRANDED} ||= 'NONE'; if (! defined $self->{QUERY_LENGTH} || ! defined $self->{HIT_LENGTH}) { $self->throw("Must define hit and query length"); } $self->{'_sequenceschanged'} = 1; $self->{_finished_new} = 1; return $self; } sub _logical_length { my ($self, $type) = @_; if (!defined($self->{_sbjct_offset}) || !defined($self->{_query_offset})) { $self->_calculate_seq_offsets(); } my $key = $type =~ /sbjct|hit|tot/i ? 'sbjct' : 'query'; my $offset = $self->{"_${key}_offset"}; return $self->length($type) / $offset ; } =head2 L methods Implementation of L methods follow =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the HSP Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut sub algorithm{ my ($self,$value) = @_; my $previous = $self->{'ALGORITHM'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'ALGORITHM'} = $value; } return $previous; } =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP or undef Returns : float or exponential (2e-10) P-value is not defined with NCBI Blast2 reports. Args : [optional] numeric to set value =cut sub pvalue { my ($self,$value) = @_; my $previous = $self->{'PVALUE'}; if( defined $value ) { $self->{'PVALUE'} = $value; } return $previous; } =head2 evalue Title : evalue Usage : my $evalue = $hsp->evalue(); Function: Returns the e-value for this HSP Returns : float or exponential (2e-10) Args : [optional] numeric to set value =cut sub evalue { my ($self,$value) = @_; my $previous = $self->{'EVALUE'}; if( defined $value ) { $self->{'EVALUE'} = $value; } return $previous; } =head2 frac_identical Title : frac_identical Usage : my $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); Function: Returns the fraction of identitical positions for this HSP Returns : Float in range 0.0 -> 1.0 Args : arg 1: 'query' = num identical / length of query seq (without gaps) 'hit' = num identical / length of hit seq (without gaps) synonyms: 'sbjct', 'subject' 'total' = num identical / length of alignment (with gaps) synonyms: 'hsp' default = 'total' arg 2: [optional] frac identical value to set for the type requested Note : for translated sequences, this adjusts the length accordingly =cut sub frac_identical { my ($self, $type,$value) = @_; unless ($self->{_did_prefrac}) { $self->_pre_frac; } $type = lc $type if defined $type; $type = 'hit' if( defined $type && $type =~ /subject|sbjct/); $type = 'total' if( ! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); my $previous = $self->{'_frac_identical'}->{$type}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; if( $type eq 'hit' || $type eq 'query' ) { $self->$type()->frac_identical( $value); } $self->{'_frac_identical'}->{$type} = $value; } return $previous; } =head2 frac_conserved Title : frac_conserved Usage : my $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); Function : Returns the fraction of conserved positions for this HSP. This is the fraction of symbols in the alignment with a positive score. Returns : Float in range 0.0 -> 1.0 Args : arg 1: 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) synonyms: 'sbjct', 'subject' 'total' = num conserved / length of alignment (with gaps) synonyms: 'hsp' default = 'total' arg 2: [optional] frac conserved value to set for the type requested =cut sub frac_conserved { my ($self, $type,$value) = @_; unless ($self->{_did_prefrac}) { $self->_pre_frac; } $type = lc $type if defined $type; $type = 'hit' if( defined $type && $type =~ /subject|sbjct/); $type = 'total' if( ! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); my $previous = $self->{'_frac_conserved'}->{$type}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_frac_conserved'}->{$type} = $value; } return $previous; } =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gap characters in the query, hit, or total alignment. Returns : Integer, number of gaps or 0 if none Args : arg 1: 'query' = num gap characters in query seq 'hit' = num gap characters in hit seq; synonyms: 'sbjct', 'subject' 'total' = num gap characters in whole alignment; synonyms: 'hsp' default = 'total' arg 2: [optional] integer gap value to set for the type requested =cut sub gaps { my ($self, $type, $value) = @_; unless ($self->{_did_pregaps}) { $self->_pre_gaps; } $type = lc $type if defined $type; $type = 'total' if( ! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); $type = 'hit' if $type =~ /sbjct|subject/; my $previous = $self->{'_gaps'}->{$type}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_gaps'}->{$type} = $value; } return $previous || 0; } =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : [optional] string to set for query sequence =cut sub query_string{ my ($self,$value) = @_; my $previous = $self->{QUERY_SEQ}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{QUERY_SEQ} = $value; # do some housekeeping so we know when to # re-run _calculate_seq_positions $self->{'_sequenceschanged'} = 1; } return $previous; } =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : [optional] string to set for hit sequence =cut sub hit_string{ my ($self,$value) = @_; my $previous = $self->{HIT_SEQ}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{HIT_SEQ} = $value; # do some housekeeping so we know when to # re-run _calculate_seq_positions $self->{'_sequenceschanged'} = 1; } return $previous; } =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : [optional] string to set for homology sequence =cut sub homology_string{ my ($self,$value) = @_; my $previous = $self->{HOMOLOGY_SEQ}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{HOMOLOGY_SEQ} = $value; # do some housekeeping so we know when to # re-run _calculate_seq_positions $self->{'_sequenceschanged'} = 1; } return $previous; } =head2 length Title : length Usage : my $len = $hsp->length( ['query'|'hit'|'total'] ); Function : Returns the length of the query or hit in the alignment (without gaps) or the aggregate length of the HSP (including gaps; this may be greater than either hit or query ) Returns : integer Args : arg 1: 'query' = length of query seq (without gaps) 'hit' = length of hit seq (without gaps) (synonyms: sbjct, subject) 'total' = length of alignment (with gaps) default = 'total' arg 2: [optional] integer length value to set for specific type =cut sub length { my $self = shift; my $type = shift; $type = 'total' unless defined $type; $type = lc $type; if( $type =~ /^q/i ) { return $self->query()->length(shift); } elsif( $type =~ /^(hit|subject|sbjct)/ ) { return $self->hit()->length(shift); } else { my $v = shift; if( defined $v ) { $self->{HSP_LENGTH} = $v; } return $self->{HSP_LENGTH}; } return 0; # should never get here } =head2 hsp_length Title : hsp_length Usage : my $len = $hsp->hsp_length() Function: shortcut length('hsp') Returns : floating point between 0 and 100 Args : none =cut sub hsp_length { return shift->length('hsp', shift); } =head2 percent_identity Title : percent_identity Usage : my $percentid = $hsp->percent_identity() Function: Returns the calculated percent identity for an HSP Returns : floating point between 0 and 100 Args : none =cut sub percent_identity { my $self = shift; unless ($self->{_did_prepi}) { $self->_pre_pi; } return $self->SUPER::percent_identity(@_); } =head2 frame Title : frame Usage : my ($qframe, $hframe) = $hsp->frame('list',$queryframe,$subjectframe) Function: Set the Frame for both query and subject and insure that they agree. This overrides the frame() method implementation in FeaturePair. Returns : array of query and subject frame if return type wants an array or query frame if defined or subject frame if not defined Args : 'hit' or 'subject' or 'sbjct' to retrieve the frame of the subject (default) 'query' to retrieve the query frame 'list' or 'array' to retrieve both query and hit frames together Note : Frames are stored in the GFF way (0-2) not 1-3 as they are in BLAST (negative frames are deduced by checking the strand of the query or hit) =cut # Note: changed 4/19/08 - bug 2485 # # frame() is supposed to be a getter/setter (as is implied by the Function desc # above; this is also consistent with Bio::SeqFeature::SimilarityPair). Also, # the API is not consistent with the other HSP/SimilarityPair methods such as # strand(), start(), end(), etc. # # In order to make this consistent with other methods all work is now done # when the features are instantiated and not delayed. We compromise by # defaulting back 'to hit' w/o passed args. Setting is now allowed. sub frame { my $self = shift; my $val = shift; if (!defined $val) { # unfortunately, w/o args we need to warn about API changes $self->warn("API for frame() has changed.\n". "Please refer to documentation for Bio::Search::HSP::GenericHSP;\n". "returning query frame"); $val = 'query'; } $val =~ s/^\s+//; if( $val =~ /^q/i ) { return $self->query->frame(@_); } elsif( $val =~ /^hi|^s/i ) { return $self->hit->frame(@_); } elsif ( $val =~ /^list|array/i ) { return ($self->query->frame($_[0]), $self->hit->frame($_[1]) ); } elsif ( $val =~ /^\d+$/) { # old API i.e. frame($query_frame, $hit_frame). This catches all but one # case, where no arg is passed (so the hit is wanted). $self->warn("API for frame() has changed.\n". "Please refer to documentation for Bio::Search::HSP::GenericHSP"); wantarray ? return ($self->query->frame($val), $self->hit->frame(@_) ) : return $self->hit->frame($val,@_); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 get_aln Title : get_aln Usage : my $aln = $hsp->gel_aln Function: Returns a L object representing the HSP alignment Returns : L Args : none =cut sub get_aln { my ($self) = @_; require Bio::LocatableSeq; require Bio::SimpleAlign; my $aln = Bio::SimpleAlign->new(); my $hs = $self->hit_string(); my $qs = $self->query_string(); # FASTA specific stuff moved to the FastaHSP object my $seqonly = $qs; $seqonly =~ s/[\-\s]//g; my ($q_nm,$s_nm) = ($self->query->seq_id(), $self->hit->seq_id()); # Should we silently change the name of the query or hit if it isn't # defined? May need revisiting... cjfields 2008-12-3 (commented out below) #unless( defined $q_nm && CORE::length ($q_nm) ) { # $q_nm = 'query'; #} #unless( defined $s_nm && CORE::length ($s_nm) ) { # $s_nm = 'hit'; #} # mapping: 1 residues for every x coordinate positions my $query = Bio::LocatableSeq->new( -seq => $qs, -id => $q_nm, -start => $self->query->start, -end => $self->query->end, -strand => $self->query->strand, -force_nse => $q_nm ? 0 : 1, -mapping => [ 1, $self->{_query_mapping} ] ); $seqonly = $hs; $seqonly =~ s/[\-\s]//g; my $hit = Bio::LocatableSeq->new( -seq => $hs, -id => $s_nm, -start => $self->hit->start, -end => $self->hit->end, -strand => $self->hit->strand, -force_nse => $s_nm ? 0 : 1, -mapping => [ 1, $self->{_hit_mapping} ] ); $aln->add_seq($query); $aln->add_seq($hit); return $aln; } =head2 num_conserved Title : num_conserved Usage : $obj->num_conserved($newval) Function: returns the number of conserved residues in the alignment Returns : integer Args : integer (optional) =cut sub num_conserved{ my ($self,$value) = @_; unless ($self->{_did_presimilar}) { $self->_pre_similar_stats; } if (defined $value) { $self->{CONSERVED} = $value; } return $self->{CONSERVED}; } =head2 num_identical Title : num_identical Usage : $obj->num_identical($newval) Function: returns the number of identical residues in the alignment Returns : integer Args : integer (optional) =cut sub num_identical{ my ($self,$value) = @_; unless ($self->{_did_presimilar}) { $self->_pre_similar_stats; } if( defined $value) { $self->{IDENTICAL} = $value; } return $self->{IDENTICAL}; } =head2 rank Usage : $hsp->rank( [string] ); Purpose : Get the rank of the HSP within a given Blast hit. Example : $rank = $hsp->rank; Returns : Integer (1..n) corresponding to the order in which the HSP appears in the BLAST report. =cut sub rank { my ($self,$value) = @_; if( defined $value) { $self->{RANK} = $value; } return $self->{RANK}; } =head2 seq_inds Title : seq_inds Purpose : Get a list of residue positions (indices) for all identical : or conserved residues in the query or sbjct sequence. Example : @s_ind = $hsp->seq_inds('query', 'identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved'); : @h_ind = $hsp->seq_inds('hit', 'conserved-not-identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved', 1); Returns : List of integers : May include ranges if collapse is true. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : class = 'identical' - identical positions : 'conserved' - conserved positions : 'nomatch' - mismatched residue or gap positions : 'mismatch' - mismatched residue positions (no gaps) : 'gap' - gap positions only : 'frameshift'- frameshift positions only : 'conserved-not-identical' - conserved positions w/o : identical residues : The name can be shortened to 'id' or 'cons' unless : the name is . The default value is : 'identical' : : collapse = boolean, if true, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. : Throws : n/a. Comments : For HSPs partially or completely derived from translated sequences : (TBLASTN, BLASTX, TBLASTX, or similar), some positional data : cannot easily be attributed to a single position (i.e. the : positional data is ambiguous). In these cases all three codon : positions are reported. Under these conditions you can check : ambiguous_seq_inds() to determine whether the query, subject, : or both are ambiguous. : See Also : L, L =cut sub seq_inds{ my ($self, $seqType, $class, $collapse) = @_; # prepare the internal structures - this is cached so # if the strings have not changed we're okay $self->_calculate_seq_positions(); $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'sbjct' if $seqType eq 'hit'; my $t = lc(substr($seqType,0,1)); if( $t eq 'q' ) { $seqType = 'query'; } elsif ( $t eq 's' || $t eq 'h' ) { $seqType = 'sbjct'; } else { $self->warn("unknown seqtype $seqType using 'query'"); $seqType = 'query'; } $t = lc(substr($class,0,1)); if( $t eq 'c' ) { if( $class =~ /conserved\-not\-identical/ ) { $class = 'conserved'; } else { $class = 'conservedall'; } } elsif( $t eq 'i' ) { $class = 'identical'; } elsif( $t eq 'n' ) { $class = 'nomatch'; } elsif( $t eq 'm' ) { $class = 'mismatch'; } elsif( $t eq 'g' ) { $class = 'gap'; } elsif( $t eq 'f' ) { $class = 'frameshift'; } else { $self->warn("unknown sequence class $class using 'identical'"); $class = 'identical'; } ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; $class = "_\L$class\E"; my @ary; if( $class eq '_gap' ) { # this means that we are remapping the gap length that is stored # in the hash (for example $self->{'_gapRes_query'} ) # so we'll return an array which has the values of the position of the # of the gap (the key in the hash) + the gap length (value in the # hash for this key - 1. # changing this; since the index is the position prior to the insertion, # repeat the position based on the number of gaps inserted @ary = map { my @tmp; # position holds number of gaps inserted for my $g (1..$self->{seqinds}{"${class}Res$seqType"}->{$_}) { push @tmp, $_ ; } @tmp} sort { $a <=> $b } keys %{ $self->{seqinds}{"${class}Res$seqType"}}; } elsif( $class eq '_conservedall' ) { @ary = sort { $a <=> $b } keys %{ $self->{seqinds}{"_conservedRes$seqType"}}, keys %{ $self->{seqinds}{"_identicalRes$seqType"}}, } else { @ary = sort { $a <=> $b } keys %{ $self->{seqinds}{"${class}Res$seqType"}}; } require Bio::Search::BlastUtils if $collapse; return $collapse ? &Bio::Search::SearchUtils::collapse_nums(@ary) : @ary; } =head2 ambiguous_seq_inds Title : ambiguous_seq_inds Purpose : returns a string denoting whether sequence indices for query, : subject, or both are ambiguous Returns : String; 'query', 'subject', 'query/subject', or empty string '' Argument : none Comments : For HSPs partially or completely derived from translated sequences : (TBLASTN, BLASTX, TBLASTX, or similar), some positional data : cannot easily be attributed to a single position (i.e. the : positional data is ambiguous). In these cases all three codon : positions are reported when using seq_inds(). Under these : conditions you can check ambiguous_seq_inds() to determine whether : the query, subject, or both are ambiguous. See Also : L =cut sub ambiguous_seq_inds { my $self = shift; $self->_calculate_seq_positions(); my $type = ($self->{_query_offset} == 3 && $self->{_sbjct_offset} == 3) ? 'query/subject' : ($self->{_query_offset} == 3) ? 'query' : ($self->{_sbjct_offset} == 3) ? 'subject' : ''; return $type; } =head2 Inherited from L These methods come from L =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : L Args : [optional] new value to set =cut sub query { my $self = shift; unless ($self->{_created_qff}) { $self->_query_seq_feature; } return $self->SUPER::query(@_); } sub feature1 { my $self = shift; if (! $self->{_finished_new} || $self->{_making_qff}) { return $self->{_sim1} if $self->{_sim1}; $self->{_sim1} = Bio::SeqFeature::Similarity->new(); return $self->{_sim1}; } unless ($self->{_created_qff}) { $self->_query_seq_feature; } return $self->SUPER::feature1(@_); } =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : L Args : [optional] new value to set =cut sub hit { my $self = shift; unless ($self->{_created_sff}) { $self->_subject_seq_feature; } return $self->SUPER::hit(@_); } sub feature2 { my $self = shift; if (! $self->{_finished_new} || $self->{_making_sff}) { return $self->{_sim2} if $self->{_sim2}; $self->{_sim2} = Bio::SeqFeature::Similarity->new(); return $self->{_sim2}; } unless ($self->{_created_sff}) { $self->_subject_seq_feature; } return $self->SUPER::feature2(@_); } =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Get/Set the significance value Returns : numeric Args : [optional] new value to set =cut # Override significance to return the e-value or, if this is # not defined (WU-BLAST), return the p-value. sub significance { my ($self, $val) = @_; if (!defined $self->{SIGNIFICANCE} || defined $val) { $self->{SIGNIFICANCE} = defined $val ? $val : defined $self->evalue ? $self->evalue : defined $self->pvalue ? $$self->pvalue : undef; $self->query->significance($self->{SIGNIFICANCE}); } return $self->{SIGNIFICANCE}; } =head2 strand Title : strand Usage : $hsp->strand('query') Function: Retrieves the strand for the HSP component requested Returns : +1 or -1 Args : 'hit' or 'subject' or 'sbjct' to retrieve the strand of the subject, 'query' to retrieve the query strand (default) =cut sub strand { my ($self,$type) = @_; if( $type =~ /^q/i && defined $self->{'QUERY_STRAND'} ) { return $self->{'QUERY_STRAND'}; } elsif( $type =~ /^(hit|subject|sbjct)/i && defined $self->{'HIT_STRAND'} ) { return $self->{'HIT_STRAND'}; } return $self->SUPER::strand($type) } =head2 score Title : score Usage : $score = $obj->score(); $obj->score($value); Function: Get/Set the score value Returns : numeric Args : [optional] new value to set =head2 bits Title : bits Usage : $bits = $obj->bits(); $obj->bits($value); Function: Get/Set the bits value Returns : numeric Args : [optional] new value to set =head1 Private methods =cut =head2 _calculate_seq_positions Title : _calculate_seq_positions Usage : $self->_calculate_seq_positions Function: Internal function Returns : Args : =cut sub _calculate_seq_positions { my ($self,@args) = @_; return unless ( $self->{'_sequenceschanged'} ); $self->{'_sequenceschanged'} = 0; my ($seqString, $qseq,$sseq) = ( $self->homology_string(), $self->query_string(), $self->hit_string() ); my ($mlen, $qlen, $slen) = (CORE::length($seqString), CORE::length($qseq), CORE::length($sseq)); my $qdir = $self->query->strand || 1; my $sdir = $self->hit->strand || 1; my ($resCount_query, $endpoint_query) = ($qdir <=0) ? ($self->query->end, $self->query->start) : ($self->query->start, $self->query->end); my ($resCount_sbjct, $endpoint_sbjct) = ($sdir <=0) ? ($self->hit->end, $self->hit->start) : ($self->hit->start, $self->hit->end); my $prog = $self->algorithm; if( $prog =~ /FAST|SSEARCH|SMITH-WATERMAN/i ) { # we infer the end of the regional sequence where the first and last # non spaces are in the homology string # then we use the HSP->length to tell us how far to read # to cut off the end of the sequence my ($start, $rest) = (0,0); if( $seqString =~ /^(\s+)?(.*?)\s*$/ ) { ($start, $rest) = ($1 ? CORE::length($1) : 0, CORE::length($2)); } $seqString = substr($seqString, $start, $rest); $qseq = substr($qseq, $start, $rest); $sseq = substr($sseq, $start, $rest); # commented out 10/29/08 # removing frameshift symbols doesn't take into account the following: # 1) does not remove the same point in the homology string (get # positional errors) # 2) adjustments to the overall position in the string due to the # frameshift must be taken into consideration (get balancing errors) # # Frameshifts will be handled directly in the main loop. # --chris # fasta reports some extra 'regional' sequence information # we need to clear out first # this seemed a bit insane to me at first, but it appears to # work --jason #$qseq =~ s![\\\/]!!g; #$sseq =~ s![\\\/]!!g; } if (!defined($self->{_sbjct_offset}) || !defined($self->{_query_offset})) { $self->_calculate_seq_offsets(); } my ($qfs, $sfs) = (0,0); CHAR_LOOP: for my $pos (0..CORE::length($seqString)-1) { my @qrange = (0 - $qfs)..($self->{_query_offset} - 1); my @srange = (0 - $sfs)..($self->{_sbjct_offset} - 1); # $self->debug("QRange:@qrange SRange:@srange\n") if ($qfs || $sfs); ($qfs, $sfs) = (0,0); my ($mchar, $qchar, $schar) = ( unpack("x$pos A1",$seqString) || ' ', $pos < CORE::length($qseq) ? unpack("x$pos A1",$qseq) : '-', $pos < CORE::length($sseq) ? unpack("x$pos A1",$sseq) : '-' ); my $matchtype = ''; my ($qgap, $sgap) = (0,0); if( $mchar eq '+' || $mchar eq '.') { # conserved $self->{seqinds}{_conservedRes_query}{ $resCount_query + ($_ * $qdir) } = 1 for @qrange; $self->{seqinds}{_conservedRes_sbjct}{ $resCount_sbjct + ($_ * $sdir) } = 1 for @srange; $matchtype = 'conserved'; } elsif( $mchar eq ':' || $mchar ne ' ' ) { # identical $self->{seqinds}{_identicalRes_query}{ $resCount_query + ($_ * $qdir) } = 1 for @qrange; $self->{seqinds}{_identicalRes_sbjct}{ $resCount_sbjct + ($_ * $sdir) } = 1 for @srange; $matchtype = 'identical'; } elsif( $mchar eq ' ' ) { # possible mismatch/nomatch/frameshift $qfs = $qchar eq '/' ? -1 : # base inserted to match frame $qchar eq '\\' ? 1 : # base deleted to match frame 0; $sfs = $schar eq '/' ? -1 : $schar eq '\\' ? 1 : 0; if ($qfs) { # Frameshifts are tricky. # '/' indicates that the next residue is shifted back one # (-1) frame position and is a deletion of one base (so to # correctly align, a base is inserted). That residue should only # occupy two sequence positions instead of three. # '\' indicates that the next residue is shifted forward # one (+1) frame position and is an insertion of one base (so to # correctly align, a base is removed). That residue should # occupy four sequence positions instead of three. # Note that gaps are not counted across from frameshifts. # Frameshift indices are a range of positions starting in the # previous sequence position in which the frameshift occurs; # they are ambiguous by nature. $self->{seqinds}{_frameshiftRes_query}{ $resCount_query - ($_ * $qdir * $qfs) } = $qfs for @qrange; $matchtype = "$qfs frameshift-query"; $sgap = $qgap = 1; } elsif ($sfs) { $self->{seqinds}{_frameshiftRes_sbjct}{ $resCount_sbjct - ($_ * $sdir * $sfs) } = $sfs for @srange; $matchtype = "$sfs frameshift-sbcjt"; $sgap = $qgap = 1; } elsif ($qchar eq $self->{GAP_SYMBOL}) { # gap are counted as being in the immediately preceeding residue # position; for translated sequences this is not the start of # the previous codon, but the third codon position $self->{seqinds}{_gapRes_query}{ $resCount_query - $qdir }++ for @qrange; $matchtype = 'gap-query'; $qgap++; } elsif ($schar eq $self->{GAP_SYMBOL}) { $self->{seqinds}{_gapRes_sbjct}{ $resCount_sbjct - $sdir }++ for @srange; $matchtype = 'gap-sbjct'; $sgap++; } else { # if not a gap or frameshift in either seq, must be mismatch $self->{seqinds}{_mismatchRes_query}{ $resCount_query + ($_ * $qdir) } = 1 for @qrange; $self->{seqinds}{_mismatchRes_sbjct}{ $resCount_sbjct + ($_ * $sdir) } = 1 for @srange; $matchtype = 'mismatch'; } # always add a nomatch unless the current position in the seq is a gap if (!$sgap) { $self->{seqinds}{_nomatchRes_sbjct}{ $resCount_sbjct + ($_ * $sdir) } = 1 for @srange; } if (!$qgap) { $self->{seqinds}{_nomatchRes_query}{ $resCount_query + ($_ * $qdir) } = 1 for @qrange; } } else { $self->warn("Unknown midline character: [$mchar]"); } # leave in and uncomment for future debugging #$self->debug(sprintf("%7d %1s[%1s]%1s %-7d Type: %-20s QOff:%-2d SOff:%-2d\n", # $resCount_query, # $qchar, # $mchar, # $schar, # $resCount_sbjct, # $matchtype, # ($self->{_query_offset} * $qdir), # ($self->{_sbjct_offset} * $sdir))); $resCount_query += ($qdir * (scalar(@qrange) + $qfs)) if !$qgap; $resCount_sbjct += ($sdir * (scalar(@srange) + $sfs)) if !$sgap; } return 1; } sub _calculate_seq_offsets { my $self = shift; my $prog = $self->algorithm; ($self->{_sbjct_offset}, $self->{_query_offset}) = (1,1); if($prog =~ /^(?:PSI)?T(BLAST|FAST)(N|X|Y)/oi ) { $self->{_sbjct_offset} = 3; if ($1 eq 'BLAST' && $2 eq 'X') { #TBLASTX $self->{_query_offset} = 3; } } elsif($prog =~ /^(BLAST|FAST)(X|Y|XY)/oi ) { $self->{_query_offset} = 3; } 1; } =head2 n See documentation in L =cut sub n { my $self = shift; if(@_) { $self->{'N'} = shift; } # note that returning 1 is completely an assumption defined $self->{'N'} ? $self->{'N'} : 1; } =head2 range See documentation in L =cut sub range { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my ($start, $end); if( $seqType eq 'query' ) { $start = $self->query->start; $end = $self->query->end; } else { $start = $self->hit->start; $end = $self->hit->end; } return ($start, $end); } =head2 links Title : links Usage : $obj->links($newval) Function: Get/Set the Links value (from WU-BLAST) Indicates the placement of the alignment in the group of HSPs Returns : Value of links Args : On set, new value (a scalar or undef, optional) =cut sub links{ my $self = shift; return $self->{LINKS} = shift if @_; return $self->{LINKS}; } =head2 hsp_group Title : hsp_group Usage : $obj->hsp_group($newval) Function: Get/Set the Group value (from WU-BLAST) Indicates a grouping of HSPs Returns : Value of group Args : On set, new value (a scalar or undef, optional) =cut sub hsp_group { my $self = shift; return $self->{HSP_GROUP} = shift if @_; return $self->{HSP_GROUP}; } =head2 hit_features Title : hit_features Usage : $obj->hit_features($newval) Function: Get/Set the HSP hit feature string (from some BLAST 2.2.13 text output), which is a string of overlapping or nearby features in HSP hit Returns : Value of hit features, if present Args : On set, new value (a scalar or undef, optional) =cut sub hit_features { my $self = shift; return $self->{HIT_FEATURES} = shift if @_; return $self->{HIT_FEATURES}; } # The cigar string code is written by Juguang Xiao =head1 Brief introduction on cigar string NOTE: the concept is originally from EnsEMBL docs at http://may2005.archive.ensembl.org/Docs/wiki/html/EnsemblDocs/CigarFormat.html Please append to these docs if you have a better definition. Sequence alignment hits can be stored in a database as ungapped alignments. This imposes 2 major constraints on alignments: a) alignments for a single hit record require multiple rows in the database, and b) it is not possible to accurately retrieve the exact original alignment. Alternatively, sequence alignments can be stored as gapped alignments using the CIGAR line format (where CIGAR stands for Concise Idiosyncratic Gapped Alignment Report). In the cigar line format alignments are stored as follows: M: Match D: Deletion I: Insertion An example of an alignment for a hypthetical protein match is shown below: Query: 42 PGPAGLP----GSVGLQGPRGLRGPLP-GPLGPPL... PG P G GP R PLGP Sbjct: 1672 PGTP*TPLVPLGPWVPLGPSSPR--LPSGPLGPTD... protein_align_feature table as the following cigar line: 7M4D12M2I2MD7M =head2 cigar_string Name: cigar_string Usage: $cigar_string = $hsp->cigar_string Function: Generate and return cigar string for this HSP alignment Args: No input needed Return: a cigar string =cut sub cigar_string { my ($self, $arg) = @_; $self->warn("this is not a setter") if(defined $arg); unless(defined $self->{_cigar_string}){ # generate cigar string my $cigar_string = $self->generate_cigar_string($self->query_string, $self->hit_string); $self->{_cigar_string} = $cigar_string; } # end of unless return $self->{_cigar_string}; } =head2 generate_cigar_string Name: generate_cigar_string Usage: my $cigar_string = Bio::Search::HSP::GenericHSP::generate_cigar_string ($qstr, $hstr); Function: generate cigar string from a simple sequence of alignment. Args: the string of query and subject Return: cigar string =cut sub generate_cigar_string { my ($self, $qstr, $hstr) = @_; my @qchars = split //, $qstr; my @hchars = split //, $hstr; unless(scalar(@qchars) == scalar(@hchars)){ $self->throw("two sequences are not equal in lengths"); } $self->{_count_for_cigar_string} = 0; $self->{_state_for_cigar_string} = 'M'; my $cigar_string = ''; for(my $i=0; $i <= $#qchars; $i++){ my $qchar = $qchars[$i]; my $hchar = $hchars[$i]; if($qchar ne $self->{GAP_SYMBOL} && $hchar ne $self->{GAP_SYMBOL}){ # Match $cigar_string .= $self->_sub_cigar_string('M'); }elsif($qchar eq $self->{GAP_SYMBOL}){ # Deletion $cigar_string .= $self->_sub_cigar_string('D'); }elsif($hchar eq $self->{GAP_SYMBOL}){ # Insertion $cigar_string .= $self->_sub_cigar_string('I'); }else{ $self->throw("Impossible state that 2 gaps on each seq aligned"); } } $cigar_string .= $self->_sub_cigar_string('X'); # not forget the tail. return $cigar_string; } # an internal method to help generate cigar string sub _sub_cigar_string { my ($self, $new_state) = @_; my $sub_cigar_string = ''; if($self->{_state_for_cigar_string} eq $new_state){ $self->{_count_for_cigar_string} += 1; # Remain the state and increase the counter }else{ $sub_cigar_string .= $self->{_count_for_cigar_string} unless $self->{_count_for_cigar_string} == 1; $sub_cigar_string .= $self->{_state_for_cigar_string}; $self->{_count_for_cigar_string} = 1; $self->{_state_for_cigar_string} = $new_state; } return $sub_cigar_string; } # needed before seqfeatures can be made sub _pre_seq_feature { my $self = shift; my $algo = $self->{ALGORITHM}; my ($queryfactor, $hitfactor) = (0,0); my ($hitmap, $querymap) = (1,1); if( $algo =~ /^(?:PSI)?T(?:BLAST|FAST|SW)[NY]/oi ) { $hitfactor = 1; $hitmap = 3; } elsif ($algo =~ /^(?:FAST|BLAST)(?:X|Y|XY)/oi || $algo =~ /^P?GENEWISE/oi ) { $queryfactor = 1; $querymap = 3; } elsif ($algo =~ /^T(BLAST|FAST|SW)(X|Y|XY)/oi || $algo =~ /^(BLAST|FAST|SW)N/oi || $algo =~ /^WABA|AXT|BLAT|BLASTZ|PSL|MEGABLAST|EXONERATE|SW|SSEARCH|SMITH\-WATERMAN|SIM4$/){ if ($2) { $hitmap = $querymap = 3; } $hitfactor = 1; $queryfactor = 1; } elsif ($algo =~ /^RPS-BLAST/) { if ($algo =~ /^RPS-BLAST\(BLASTX\)/) { $queryfactor = 1; $querymap = 3; } $hitfactor = 0; } else { my $stranded = lc substr($self->{STRANDED}, 0,1); $queryfactor = ($stranded eq 'q' || $stranded eq 'b') ? 1 : 0; $hitfactor = ($stranded eq 'h' || $stranded eq 's' || $stranded eq 'b') ? 1 : 0; } $self->{_query_factor} = $queryfactor; $self->{_hit_factor} = $hitfactor; $self->{_hit_mapping} = $hitmap; $self->{_query_mapping} = $querymap; } # make query seq feature sub _query_seq_feature { my $self = shift; $self->{_making_qff} = 1; my $qs = $self->{QUERY_START}; my $qe = $self->{QUERY_END}; unless (defined $self->{_query_factor}) { $self->_pre_seq_feature; } my $queryfactor = $self->{_query_factor}; unless( defined $qe && defined $qs ) { $self->throw("Did not specify a Query End or Query Begin"); } my $strand; if ($qe > $qs) { # normal query: start < end if ($queryfactor) { $strand = 1; } else { $strand = undef; } } else { if ($queryfactor) { $strand = -1; } else { $strand = undef; } ($qs,$qe) = ($qe,$qs); } # Note: many of these data are not query- and hit-specific. # Only start, end, name, length are. # We could be more efficient by only storing this info once. # steve chervitz --- Sat Apr 5 00:55:07 2003 my $sim1 = $self->{_sim1} || Bio::SeqFeature::Similarity->new(); $sim1->start($qs); $sim1->end($qe); $sim1->significance($self->{EVALUE}); $sim1->bits($self->{BITS}); $sim1->score($self->{SCORE}); $sim1->strand($strand); $sim1->seq_id($self->{QUERY_NAME}); $sim1->seqlength($self->{QUERY_LENGTH}); $sim1->source_tag($self->{ALGORITHM}); $sim1->seqdesc($self->{QUERY_DESC}); $sim1->add_tag_value('meta', $self->{META}) if $self->can('meta'); # to determine frame from something like FASTXY which doesn't # report the frame my $qframe = $self->{QUERY_FRAME}; if (defined $strand && !defined $qframe && $queryfactor) { $qframe = ( $qs % 3 ) * $strand; } elsif (!defined $strand) { $qframe = 0; } if( $qframe =~ /^([+-])?([0-3])/ ) { my $dir = $1 || '+'; if($qframe && (($dir eq '-' && $strand >= 0) || ($dir eq '+' && $strand <= 0)) ) { $self->warn("Query frame ($qframe) did not match strand of query ($strand)"); } $qframe = $2 != 0 ? $2 - 1 : $2; } else { $self->warn("Unknown query frame ($qframe)"); $qframe = 0; } $sim1->frame($qframe); $self->SUPER::feature1($sim1); $self->{_created_qff} = 1; $self->{_making_qff} = 0; } # make subject seq feature sub _subject_seq_feature { my $self = shift; $self->{_making_sff} = 1; my $hs = $self->{HIT_START}; my $he = $self->{HIT_END}; unless (defined $self->{_hit_factor}) { $self->_pre_seq_feature; } my $hitfactor = $self->{_hit_factor}; unless( defined $he && defined $hs ) { $self->throw("Did not specify a Hit End or Hit Begin"); } my $strand; if ($he > $hs) { # normal subject if ($hitfactor) { $strand = 1; } else { $strand = undef; } } else { if ($hitfactor) { $strand = -1; } else { $strand = undef; } ($hs,$he) = ( $he,$hs); # reverse subject: start bigger than end } my $sim2 = $self->{_sim2} || Bio::SeqFeature::Similarity->new(); $sim2->start($hs); $sim2->end($he); $sim2->significance($self->{EVALUE}); $sim2->bits($self->{BITS}); $sim2->score($self->{SCORE}); $sim2->strand($strand); $sim2->seq_id($self->{HIT_NAME}); $sim2->seqlength($self->{HIT_LENGTH}); $sim2->source_tag($self->{ALGORITHM}); $sim2->seqdesc($self->{HIT_DESC}); $sim2->add_tag_value('meta', $self->{META}) if $self->can('meta'); my $hframe = $self->{HIT_FRAME}; if (defined $strand && !defined $hframe && $hitfactor) { $hframe = ( $hs % 3 ) * $strand; } elsif (!defined $strand) { $hframe = 0; } if( $hframe =~ /^([+-])?([0-3])/ ) { my $dir = $1 || '+'; if($hframe && (($dir eq '-' && $strand >= 0) || ($dir eq '+' && $strand <= 0)) ) { $self->warn("Subject frame ($hframe) did not match strand of subject ($strand)"); } $hframe = $2 != 0 ? $2 - 1 : $2; } else { $self->warn("Unknown subject frame ($hframe)"); $hframe = 0; } $sim2->frame($hframe); $self->SUPER::feature2($sim2); $self->{_created_sff} = 1; $self->{_making_sff} = 0; } # before calling the num_* methods sub _pre_similar_stats { my $self = shift; my $identical = $self->{IDENTICAL}; my $conserved = $self->{CONSERVED}; my $percent_id = $self->{PERCENT_IDENTITY}; if (! defined $identical) { if (! defined $percent_id) { $self->warn("Did not defined the number of identical matches or overall percent identity in the HSP; assuming 0"); $identical = 0; } else { $identical = sprintf("%.0f",$percent_id * $self->{HSP_LENGTH}); } } if (! defined $conserved) { $self->warn("Did not define the number of conserved matches in the HSP; assuming conserved == identical ($identical)") if( $self->{ALGORITHM} !~ /^((FAST|BLAST)N)|EXONERATE|SIM4|AXT|PSL|BLAT|BLASTZ|WABA/oi); $conserved = $identical; } $self->{IDENTICAL} = $identical; $self->{CONSERVED} = $conserved; $self->{_did_presimilar} = 1; } # before calling the frac_* methods sub _pre_frac { my $self = shift; my $hsp_len = $self->{HSP_LENGTH}; my $hit_len = $self->{HIT_LENGTH}; my $query_len = $self->{QUERY_LENGTH}; my $identical = $self->num_identical; my $conserved = $self->num_conserved; $self->{_did_prefrac} = 1; my $logical; if( $hsp_len ) { $self->length('total', $hsp_len); $logical = $self->_logical_length('total'); $self->frac_identical( 'total', $identical / $hsp_len); $self->frac_conserved( 'total', $conserved / $hsp_len); } if( $hit_len ) { $logical = $self->_logical_length('hit'); $self->frac_identical( 'hit', $identical / $logical); $self->frac_conserved( 'hit', $conserved / $logical); } if( $query_len ) { $logical = $self->_logical_length('query'); $self->frac_identical( 'query', $identical / $logical) ; $self->frac_conserved( 'query', $conserved / $logical); } } # before calling gaps() # This relies first on passed parameters (parser-dependent), then on gaps # calculated by seq_inds() (if set), then falls back to directly checking # for '-' as a last resort sub _pre_gaps { my $self = shift; my $query_gaps = $self->{QUERY_GAPS}; my $query_seq = $self->{QUERY_SEQ}; my $hit_gaps = $self->{HIT_GAPS}; my $hit_seq = $self->{HIT_SEQ}; my $gaps = $self->{HSP_GAPS}; $self->{_did_pregaps} = 1; # well, we're in the process; avoid recursion if( defined $query_gaps ) { $self->gaps('query', $query_gaps); } elsif( defined $query_seq ) { my $qg = (defined $self->{'_query_offset'}) ? $self->seq_inds('query','gaps') : scalar( $query_seq =~ tr/\-//); my $offset = $self->{'_query_offset'} || 1; $self->gaps('query', $qg/$offset); } if( defined $hit_gaps ) { $self->gaps('hit', $hit_gaps); } elsif( defined $hit_seq ) { my $hg = (defined $self->{'_sbjct_offset'}) ? $self->seq_inds('hit','gaps') : scalar( $hit_seq =~ tr/\-//); my $offset = $self->{'_sbjct_offset'} || 1; $self->gaps('hit', $hg/$offset); } if( ! defined $gaps ) { $gaps = $self->gaps("query") + $self->gaps("hit"); } $self->gaps('total', $gaps); } # before percent_identity sub _pre_pi { my $self = shift; $self->{_did_prepi} = 1; $self->percent_identity($self->{PERCENT_IDENTITY} || $self->frac_identical('total')*100) if( $self->{HSP_LENGTH} > 0 ); } 1; BioPerl-1.6.923/Bio/Search/HSP/HMMERHSP.pm000444000765000024 2740712254227337 17626 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::HMMERHSP # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::HMMERHSP - A HSP object for HMMER results =head1 SYNOPSIS use Bio::Search::HSP::HMMERHSP; # use it just like a Bio::Search::HSP::GenericHSP object =head1 DESCRIPTION This object is a specialization of L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::HMMERHSP; use strict; use base qw(Bio::Search::HSP::GenericHSP); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::HMMERHSP->new(); Function: Builds a new Bio::Search::HSP::HMMERHSP object Returns : Bio::Search::HSP::HMMERHSP Args : Plus Bio::Search::HSP::GenericHSP methods -algorithm => algorithm used (BLASTP, TBLASTX, FASTX, etc) -evalue => evalue -pvalue => pvalue -bits => bit value for HSP -score => score value for HSP (typically z-score but depends on analysis) -hsp_length => Length of the HSP (including gaps) -identical => # of residues that that matched identically -conserved => # of residues that matched conservatively (only protein comparisions - conserved == identical in nucleotide comparisons) -hsp_gaps => # of gaps in the HSP -query_gaps => # of gaps in the query in the alignment -hit_gaps => # of gaps in the subject in the alignment -query_name => HSP Query sequence name (if available) -query_start => HSP Query start (in original query sequence coords) -query_end => HSP Query end (in original query sequence coords) -hit_name => HSP Hit sequence name (if available) -hit_start => HSP Hit start (in original hit sequence coords) -hit_end => HSP Hit end (in original hit sequence coords) -hit_length => total length of the hit sequence -query_length => total length of the query sequence -query_seq => query sequence portion of the HSP -hit_seq => hit sequence portion of the HSP -homology_seq => homology sequence for the HSP -hit_frame => hit frame (only if hit is translated protein) -query_frame => query frame (only if query is translated protein) =cut =head2 Bio::Search::HSP::HSPI methods Implementation of Bio::Search::HSP::HSPI methods follow =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the HSP Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP or undef Returns : float or exponential (2e-10) P-value is not defined with NCBI Blast2 reports. Args : [optional] numeric to set value =cut =head2 evalue Title : evalue Usage : my $evalue = $hsp->evalue(); Function: Returns the e-value for this HSP Returns : float or exponential (2e-10) Args : [optional] numeric to set value =cut =head2 frac_identical Title : frac_identical Usage : my $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); Function: Returns the fraction of identitical positions for this HSP Returns : Float in range 0.0 -> 1.0 Args : arg 1: 'query' = num identical / length of query seq (without gaps) 'hit' = num identical / length of hit seq (without gaps) 'total' = num identical / length of alignment (with gaps) default = 'total' arg 2: [optional] frac identical value to set for the type requested =cut =head2 frac_conserved Title : frac_conserved Usage : my $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); Function : Returns the fraction of conserved positions for this HSP. This is the fraction of symbols in the alignment with a positive score. Returns : Float in range 0.0 -> 1.0 Args : arg 1: 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) 'total' = num conserved / length of alignment (with gaps) default = 'total' arg 2: [optional] frac conserved value to set for the type requested =cut =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gaps in the query, hit, or total alignment. Returns : Integer, number of gaps or 0 if none Args : arg 1: 'query' = num gaps in query seq 'hit' = num gaps in hit seq 'total' = num gaps in whole alignment default = 'total' arg 2: [optional] integer gap value to set for the type requested =cut =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : [optional] string to set for query sequence =cut =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : [optional] string to set for hit sequence =cut =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : [optional] string to set for homology sequence =cut =head2 length Title : length Usage : my $len = $hsp->length( ['query'|'hit'|'total'] ); Function : Returns the length of the query or hit in the alignment (without gaps) or the aggregate length of the HSP (including gaps; this may be greater than either hit or query ) Returns : integer Args : arg 1: 'query' = length of query seq (without gaps) 'hit' = length of hit seq (without gaps) 'total' = length of alignment (with gaps) default = 'total' arg 2: [optional] integer length value to set for specific type =cut =head2 percent_identity Title : percent_identity Usage : my $percentid = $hsp->percent_identity() Function: Returns the calculated percent identity for an HSP Returns : floating point between 0 and 100 Args : none =cut =head2 frame Title : frame Usage : my ($qframe, $hframe) = $hsp->frame('list',$queryframe,$subjectframe) Function: Set the Frame for both query and subject and insure that they agree. This overrides the frame() method implementation in FeaturePair. Returns : array of query and subject frame if return type wants an array or query frame if defined or subject frame if not defined Args : 'hit' or 'subject' or 'sbjct' to retrieve the frame of the subject (default) 'query' to retrieve the query frame 'list' or 'array' to retrieve both query and hit frames together Note : Frames are stored in the GFF way (0-2) not 1-3 as they are in BLAST (negative frames are deduced by checking the strand of the query or hit) =cut =head2 get_aln Title : get_aln Usage : my $aln = $hsp->gel_aln Function: Returns a Bio::SimpleAlign representing the HSP alignment Returns : Bio::SimpleAlign Args : none =cut sub get_aln { my ($self) = shift; $self->warn("Inappropriate to build a Bio::SimpleAlign from a HMMER HSP object"); return; } =head2 num_conserved Title : num_conserved Usage : $obj->num_conserved($newval) Function: returns the number of conserved residues in the alignment Returns : inetger Args : integer (optional) =cut =head2 num_identical Title : num_identical Usage : $obj->num_identical($newval) Function: returns the number of identical residues in the alignment Returns : integer Args : integer (optional) =cut =head2 seq_inds Title : seq_inds Purpose : Get a list of residue positions (indices) for all identical : or conserved residues in the query or sbjct sequence. Example : @s_ind = $hsp->seq_inds('query', 'identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved'); : @h_ind = $hsp->seq_inds('hit', 'conserved', 1); Returns : List of integers : May include ranges if collapse is true. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : class = 'identical' or 'conserved' or 'nomatch' or 'gap' : (default = identical) : (can be shortened to 'id' or 'cons') : : collapse = boolean, if true, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. Throws : n/a. Comments : See Also : L, L =cut =head2 Inherited from Bio::SeqFeature::SimilarityPair These methods come from Bio::SeqFeature::SimilarityPair =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Get/Set the significance value Returns : numeric Args : [optional] new value to set =head2 score Title : score Usage : my $score = $hsp->score(); Function: Returns the score for this HSP or undef Returns : numeric Args : [optional] numeric to set value =cut =head2 bits Title : bits Usage : my $bits = $hsp->bits(); Function: Returns the bit value for this HSP or undef Returns : numeric Args : none =cut 1; BioPerl-1.6.923/Bio/Search/HSP/HmmpfamHSP.pm000555000765000024 2663312254227336 20345 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::HmmpfamHSP # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::HmmpfamHSP - A parser and HSP object for hmmpfam hsps =head1 SYNOPSIS # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 'result.hmmer'); while (my $result = $in->next_result) { while (my $hit = $result->next_hit) { print $hit->name, "\n"; print $hit->score, "\n"; print $hit->significance, "\n"; while (my $hsp = $hit->next_hsp) { # process HSPI objects } } } =head1 DESCRIPTION This object implements a parser for hmmpfam hsp output, a program in the HMMER package. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::HmmpfamHSP; use strict; use base qw(Bio::Search::HSP::PullHSPI); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::HmmpfamHSP->new(); Function: Builds a new Bio::Search::HSP::HmmpfamHSP object. Returns : Bio::Search::HSP::HmmpfamHSP Args : -chunk => [Bio::Root::IO, $start, $end] (required if no -parent) -parent => Bio::PullParserI object (required if no -chunk) -hsp_data => array ref with [rank query_start query_end hit_start hit_end score evalue] where the array ref provided to -chunk contains an IO object for a filehandle to something representing the raw data of the hsp, and $start and $end define the tell() position within the filehandle that the hsp data starts and ends (optional; defaults to start and end of the entire thing described by the filehandle) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_setup(@args); my $fields = $self->_fields; foreach my $field (qw( alignment )) { $fields->{$field} = undef; } my $hsp_data = $self->_raw_hsp_data; if ($hsp_data && ref($hsp_data) eq 'ARRAY') { my @hsp_data = @{$hsp_data}; # don't alter the reference foreach my $field (qw(rank query_start query_end hit_start hit_end score evalue)) { $fields->{$field} = shift(@hsp_data); } } $self->_dependencies( { ( query_string => 'alignment', hit_string => 'alignment', homology_string => 'alignment', hit_identical_inds => 'seq_inds', hit_conserved_inds => 'seq_inds', hit_nomatch_inds => 'seq_inds', hit_gap_inds => 'seq_inds', query_identical_inds => 'seq_inds', query_conserved_inds => 'seq_inds', query_nomatch_inds => 'seq_inds', query_gap_inds => 'seq_inds' ) } ); return $self; } # # PullParserI discovery methods so we can answer all HitI questions # sub _discover_alignment { my $self = shift; my $alignments_hash = $self->get_field('alignments'); my $identifier = $self->get_field('name').'~~~~'.$self->get_field('rank'); while (! defined $alignments_hash->{$identifier}) { last unless $self->parent->parent->_next_alignment; } my $alignment = $alignments_hash->{$identifier}; if ($alignment) { # work out query, hit and homology strings, and some stats # (quicker to do this all at once instead of each method working on # $alignment string itself) my ($query_string, $hit_string, $homology_string); while ($alignment =~ /\s+(\S+)\n\s+(\S.+)\n\s+\S+\s+\d+\s+(\S+)\s+\d/gm) { my $hi = $1; my $ho = $2; $query_string .= $3; $hi =~ s/\*\-\>//; $ho = ' 'x(length($hi) - length($ho)).$ho; $hi =~ s/\<\-\*//; $hit_string .= $hi; $homology_string .= $ho; } $self->_fields->{query_string} = $query_string; $self->_fields->{hit_string} = $hit_string; $homology_string =~ s/ $//; $self->_fields->{homology_string} = $homology_string; ($self->{_query_gaps}) = $query_string =~ tr/-//; ($self->{_hit_gaps}) = $hit_string =~ tr/.//; ($self->{_total_gaps}) = $self->{_query_gaps} + $self->{_hit_gaps}; } $self->_fields->{alignment} = 1; # stop this method being called again } # seq_inds related methods, all just need seq_inds field to have been gotten sub _discover_seq_inds { my $self = shift; my ($seqString, $qseq, $sseq) = ( $self->get_field('homology_string'), $self->get_field('query_string'), $self->get_field('hit_string') ); # (code largely lifted from GenericHSP) # Using hashes to avoid saving duplicate residue numbers. my %identicalList_query = (); my %identicalList_sbjct = (); my %conservedList_query = (); my %conservedList_sbjct = (); my @gapList_query = (); my @gapList_sbjct = (); my %nomatchList_query = (); my %nomatchList_sbjct = (); my $resCount_query = $self->get_field('query_end'); my $resCount_sbjct = $self->get_field('hit_end'); my ($mchar, $schar, $qchar); while ($mchar = chop($seqString) ) { ($qchar, $schar) = (chop($qseq), chop($sseq)); if ($mchar eq '+' || $mchar eq '.' || $mchar eq ':') { $conservedList_query{ $resCount_query } = 1; $conservedList_sbjct{ $resCount_sbjct } = 1; } elsif ($mchar eq ' ') { $nomatchList_query{ $resCount_query } = 1; $nomatchList_sbjct{ $resCount_sbjct } = 1; } else { $identicalList_query{ $resCount_query } = 1; $identicalList_sbjct{ $resCount_sbjct } = 1; } if ($qchar eq '-') { push(@gapList_query, $resCount_query); } else { $resCount_query -= 1; } if ($schar eq '.') { push(@gapList_sbjct, $resCount_sbjct); } else { $resCount_sbjct -= 1; } } my $fields = $self->_fields; $fields->{hit_identical_inds} = [ sort { $a <=> $b } keys %identicalList_sbjct ]; $fields->{hit_conserved_inds} = [ sort { $a <=> $b } keys %conservedList_sbjct ]; $fields->{hit_nomatch_inds} = [ sort { $a <=> $b } keys %nomatchList_sbjct ]; $fields->{hit_gap_inds} = [ reverse @gapList_sbjct ]; $fields->{query_identical_inds} = [ sort { $a <=> $b } keys %identicalList_query ]; $fields->{query_conserved_inds} = [ sort { $a <=> $b } keys %conservedList_query ]; $fields->{query_nomatch_inds} = [ sort { $a <=> $b } keys %nomatchList_query ]; $fields->{query_gap_inds} = [ reverse @gapList_query ]; $fields->{seq_inds} = 1; } =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : L Args : none =cut sub query { my $self = shift; unless ($self->{_created_query}) { $self->SUPER::query( new Bio::SeqFeature::Similarity ('-primary' => $self->primary_tag, '-start' => $self->get_field('query_start'), '-end' => $self->get_field('query_end'), '-expect' => $self->get_field('evalue'), '-score' => $self->get_field('score'), '-strand' => 1, '-seq_id' => $self->get_field('query_name'), #'-seqlength'=> $self->get_field('query_length'), (not known) '-source' => $self->get_field('algorithm'), '-seqdesc' => $self->get_field('query_description') ) ); $self->{_created_query} = 1; } return $self->SUPER::query(@_); } =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : L Args : [optional] new value to set =cut sub hit { my $self = shift; unless ($self->{_created_hit}) { # the full length isn't always known (given in the report), but don't # warn about the missing info all the time my $verbose = $self->parent->parent->parent->verbose; $self->parent->parent->parent->verbose(-1); my $seq_length = $self->get_field('length'); $self->parent->parent->parent->verbose($verbose); $self->SUPER::hit( new Bio::SeqFeature::Similarity ('-primary' => $self->primary_tag, '-start' => $self->get_field('hit_start'), '-end' => $self->get_field('hit_end'), '-expect' => $self->get_field('evalue'), '-score' => $self->get_field('score'), '-strand' => 1, '-seq_id' => $self->get_field('name'), $seq_length ? ('-seqlength' => $seq_length) : (), '-source' => $self->get_field('algorithm'), '-seqdesc' => $self->get_field('description') ) ); $self->{_created_hit} = 1; } return $self->SUPER::hit(@_); } =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gaps in the query, hit, or total alignment. Returns : Integer, number of gaps or 0 if none Args : 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) 'total' = num conserved / length of alignment (with gaps) default = 'total' =cut sub gaps { my ($self, $type) = @_; $type = lc $type if defined $type; $type = 'total' if (! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); $type = 'hit' if $type =~ /sbjct|subject/; $self->get_field('alignment'); # make sure gaps have been calculated return $self->{'_'.$type.'_gaps'}; } =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP Returns : undef (Hmmpfam reports do not have p-values) Args : none =cut # noop sub pvalue { } 1; BioPerl-1.6.923/Bio/Search/HSP/HSPFactory.pm000444000765000024 706512254227316 20340 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::HSPFactory # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::HSPFactory - A factory to create Bio::Search::HSP::HSPI objects =head1 SYNOPSIS use Bio::Search::HSP::HSPFactory; my $factory = Bio::Search::HSP::HSPFactory->new(); my $resultobj = $factory->create(@args); =head1 DESCRIPTION This is a general way of hiding the object creation process so that we can dynamically change the objects that are created by the SearchIO parser depending on what format report we are parsing. This object is for creating new HSPs. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::HSPFactory; use vars qw($DEFAULT_TYPE); use strict; use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI); BEGIN { $DEFAULT_TYPE = 'Bio::Search::HSP::GenericHSP'; } =head2 new Title : new Usage : my $obj = Bio::Search::HSP::HSPFactory->new(); Function: Builds a new Bio::Search::HSP::HSPFactory object Returns : Bio::Search::HSP::HSPFactory Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type) = $self->_rearrange([qw(TYPE)],@args); $self->type($type) if defined $type; return $self; } =head2 create Title : create Usage : $factory->create(%args) Function: Create a new L object Returns : L Args : hash of initialization parameters =cut sub create{ my ($self,@args) = @_; my $type = $self->type; eval { $self->_load_module($type) }; if( $@ ) { $self->throw("Unable to load module $type"); } return $type->new(@args); } =head2 type Title : type Usage : $factory->type('Bio::Search::HSP::GenericHSP'); Function: Get/Set the HSP creation type Returns : string Args : [optional] string to set =cut sub type{ my ($self,$type) = @_; if( defined $type ) { # redundancy with the create method which also calls _load_module # I know - but this is not a highly called object so I am going # to leave it in eval {$self->_load_module($type) }; if( $@ ){ $self->warn("Cannot find module $type, unable to set type. $@") } else { $self->{'_type'} = $type; } } return $self->{'_type'} || $DEFAULT_TYPE; } 1; BioPerl-1.6.923/Bio/Search/HSP/HSPI.pm000444000765000024 5353612254227340 17142 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module for Bio::Search::HSP::HSPI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # and Jason Stajich # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::HSPI - Interface for a High Scoring Pair in a similarity search result =head1 SYNOPSIS # Bio::Search::HSP::HSPI objects cannot be instantiated since this # module defines a pure interface. # Given an object that implements the Bio::Search::HSP::HSPI interface, # you can do the following things with it: $r_type = $hsp->algorithm; $pvalue = $hsp->pvalue(); $evalue = $hsp->evalue(); $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); $qseq = $hsp->query_string; $hseq = $hsp->hit_string; $homology_string = $hsp->homology_string; $len = $hsp->length( ['query'|'hit'|'total'] ); $rank = $hsp->rank; =head1 DESCRIPTION Bio::Search::HSP::HSPI objects cannot be instantiated since this module defines a pure interface. Given an object that implements the L interface, you can do the following things with it: =head1 SEE ALSO This interface inherits methods from these other modules: L, L L Please refer to these modules for documentation of the many additional inherited methods. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Steve Chervitz, Jason Stajich Email sac-at-bioperl.org Email jason-at-bioperl.org =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz, Jason Stajich. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::HSPI; use strict; use Carp; use base qw(Bio::SeqFeature::SimilarityPair Bio::Root::RootI); =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the HSP Returns : string (e.g., BLASTP) Args : none =cut sub algorithm{ my ($self,@args) = @_; $self->throw_not_implemented; } =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP or undef Returns : float or exponential (2e-10) P-value is not defined with NCBI Blast2 reports. Args : none =cut sub pvalue { my ($self) = @_; $self->throw_not_implemented; } =head2 evalue Title : evalue Usage : my $evalue = $hsp->evalue(); Function: Returns the e-value for this HSP Returns : float or exponential (2e-10) Args : none =cut sub evalue { my ($self) = @_; $self->throw_not_implemented; } =head2 frac_identical Title : frac_identical Usage : my $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); Function: Returns the fraction of identitical positions for this HSP Returns : Float in range 0.0 -> 1.0 Args : 'query' = num identical / length of query seq (without gaps) 'hit' = num identical / length of hit seq (without gaps) 'total' = num identical / length of alignment (with gaps) default = 'total' =cut sub frac_identical { my ($self, $type) = @_; $self->throw_not_implemented; } =head2 frac_conserved Title : frac_conserved Usage : my $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); Function : Returns the fraction of conserved positions for this HSP. This is the fraction of symbols in the alignment with a positive score. Returns : Float in range 0.0 -> 1.0 Args : 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) 'total' = num conserved / length of alignment (with gaps) default = 'total' =cut sub frac_conserved { my ($self, $type) = @_; $self->throw_not_implemented; } =head2 num_identical Title : num_identical Usage : $obj->num_identical($newval) Function: returns the number of identical residues in the alignment Returns : integer Args : integer (optional) =cut sub num_identical{ shift->throw_not_implemented; } =head2 num_conserved Title : num_conserved Usage : $obj->num_conserved($newval) Function: returns the number of conserved residues in the alignment Returns : inetger Args : integer (optional) =cut sub num_conserved{ shift->throw_not_implemented(); } =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gap characters in the query, hit, or total alignment. Returns : Integer, number of gap characters or 0 if none Args : 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) 'total' = num conserved / length of alignment (with gaps) default = 'total' =cut sub gaps { my ($self, $type) = @_; $self->throw_not_implemented; } =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : none =cut sub query_string{ my ($self) = @_; $self->throw_not_implemented; } =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : none =cut sub hit_string{ my ($self) = @_; $self->throw_not_implemented; } =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : none =cut sub homology_string{ my ($self) = @_; $self->throw_not_implemented; } =head2 length Title : length Usage : my $len = $hsp->length( ['query'|'hit'|'total'] ); Function : Returns the length of the query or hit in the alignment (without gaps) or the aggregate length of the HSP (including gaps; this may be greater than either hit or query ) Returns : integer Args : 'query' = length of query seq (without gaps) 'hit' = length of hit seq (without gaps) 'total' = length of alignment (with gaps) default = 'total' Args : none =cut sub length{ shift->throw_not_implemented(); } =head2 percent_identity Title : percent_identity Usage : my $percentid = $hsp->percent_identity() Function: Returns the calculated percent identity for an HSP Returns : floating point between 0 and 100 Args : none =cut sub percent_identity{ my ($self) = @_; return $self->frac_identical('hsp') * 100; } =head2 get_aln Title : get_aln Usage : my $aln = $hsp->get_aln Function: Returns a Bio::SimpleAlign representing the HSP alignment Returns : Bio::SimpleAlign Args : none =cut sub get_aln { my ($self) = @_; $self->throw_not_implemented; } =head2 seq_inds Title : seq_inds Purpose : Get a list of residue positions (indices) for all identical : or conserved residues in the query or sbjct sequence. Example : @s_ind = $hsp->seq_inds('query', 'identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved'); : @h_ind = $hsp->seq_inds('hit', 'conserved', 1); Returns : List of integers : May include ranges if collapse is true. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = query) ('sbjct' is synonymous with 'hit') class = 'identical' or 'conserved' or 'nomatch' or 'gap' (default = identical) (can be shortened to 'id' or 'cons') collapse = boolean, if true, consecutive positions are merged using a range notation, e.g., "1 2 3 4 5 7 9 10 11" collapses to "1-5 7 9-11". This is useful for consolidating long lists. Default = no collapse. Throws : n/a. Comments : See Also : L, L =cut sub seq_inds { shift->throw_not_implemented(); } =head2 Inherited from L These methods come from L =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Get/Set the significance value (see Bio::SeqFeature::SimilarityPair) Returns : significance value (scientific notation string) Args : significance value (sci notation string) =head2 score Title : score Usage : my $score = $hsp->score(); Function: Returns the score for this HSP or undef Returns : numeric Args : [optional] numeric to set value =head2 bits Title : bits Usage : my $bits = $hsp->bits(); Function: Returns the bit value for this HSP or undef Returns : numeric Args : none =cut # override =head2 strand Title : strand Usage : $hsp->strand('query') Function: Retrieves the strand for the HSP component requested Returns : +1 or -1 (0 if unknown) Args : 'hit' or 'subject' or 'sbjct' to retrieve the strand of the subject 'query' to retrieve the query strand (default) 'list' or 'array' to retreive both query and hit together =cut sub strand { my $self = shift; my $val = shift; $val = 'query' unless defined $val; $val =~ s/^\s+//; if ( $val =~ /^q/i ) { return $self->query->strand(@_); } elsif ( $val =~ /^hi|^s/i ) { return $self->hit->strand(@_); } elsif ( $val =~ /^list|array/i ) { # Do we really need to pass on additional arguments here? HL # (formerly this was strand(shift) which is really bad coding because # it breaks if the callee allows setting to undef) return ( $self->query->strand(@_), $self->hit->strand(@_) ); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 start Title : start Usage : $hsp->start('query') Function: Retrieves the start for the HSP component requested Returns : integer Args : 'hit' or 'subject' or 'sbjct' to retrieve the start of the subject 'query' to retrieve the query start (default) =cut sub start { my $self = shift; my $val = shift; $val = 'query' unless defined $val; $val =~ s/^\s+//; if( $val =~ /^q/i ) { return $self->query->start(@_); } elsif( $val =~ /^(hi|s)/i ) { return $self->hit->start(@_); } elsif ( $val =~ /^list|array/i ) { # do we really need to pass on additional arguments here? HL # (formerly this was strand(shift) which is really bad coding because # it breaks if the callee allows setting to undef) return ($self->query->start(@_), $self->hit->start(@_) ); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 end Title : end Usage : $hsp->end('query') Function: Retrieves the end for the HSP component requested Returns : integer Args : 'hit' or 'subject' or 'sbjct' to retrieve the end of the subject 'query' to retrieve the query end (default) =cut sub end { my $self = shift; my $val = shift; $val = 'query' unless defined $val; $val =~ s/^\s+//; if( $val =~ /^q/i ) { return $self->query->end(@_); } elsif( $val =~ /^(hi|s)/i ) { return $self->hit->end(@_); } elsif ( $val =~ /^list|array/i ) { # do we really need to pass on additional arguments here? HL # (formerly this was strand(shift) which is really bad coding because # it breaks if the callee allows setting to undef) return ($self->query->end(@_), $self->hit->end(@_) ); } else { $self->warn("unrecognized end component '$val' requested\n"); } return 0; } =head2 seq Usage : $hsp->seq( [seq_type] ); Purpose : Get the query or sbjct sequence as a Bio::Seq.pm object. Example : $seqObj = $hsp->seq('query'); Returns : Object reference for a Bio::Seq.pm object. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query'). : ('sbjct' is synonymous with 'hit') : default is 'query' Throws : Propagates any exception that occurs during construction : of the Bio::Seq.pm object. Comments : The sequence is returned in an array of strings corresponding : to the strings in the original format of the Blast alignment. : (i.e., same spacing). See Also : L, L, L =cut sub seq { my($self,$seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my $str = $self->seq_str($seqType); if( $seqType =~ /^(m|ho)/i ) { $self->throw("cannot call seq on the homology match string, it isn't really a sequence, use get_aln to convert the HSP to a Bio::AlignIO and generate a consensus from that."); } require Bio::LocatableSeq; my $id = $seqType =~ /^q/i ? $self->query->seq_id : $self->hit->seq_id; return Bio::LocatableSeq->new( -ID => $id, -SEQ => $str, -START => $self->start($seqType), -END => $self->end($seqType), -STRAND => $self->strand($seqType), -FORCE_NSE => $id ? 0 : 1, -DESC => "$seqType sequence " ); } =head2 seq_str Usage : $hsp->seq_str( seq_type ); Purpose : Get the full query, sbjct, or 'match' sequence as a string. : The 'match' sequence is the string of symbols in between the : query and sbjct sequences. Example : $str = $hsp->seq_str('query'); Returns : String Argument : seq_Type = 'query' or 'hit' or 'sbjct' or 'match' : ('sbjct' is synonymous with 'hit') : default is 'query' Throws : Exception if the argument does not match an accepted seq_type. Comments : See Also : L, L, C<_set_match_seq> =cut sub seq_str { my $self = shift; my $type = shift || 'query'; if( $type =~ /^q/i ) { return $self->query_string(@_) } elsif( $type =~ /^(s)|(hi)/i ) { return $self->hit_string(@_)} elsif ( $type =~ /^(ho)|(ma)/i ) { return $self->homology_string(@_) } else { $self->warn("unknown sequence type $type"); } return ''; } =head2 rank Usage : $hsp->rank( [string] ); Purpose : Get the rank of the HSP within a given Blast hit. Example : $rank = $hsp->rank; Returns : Integer (1..n) corresponding to the order in which the HSP appears in the BLAST report. =cut sub rank { shift->throw_not_implemented } =head2 matches Usage : $hsp->matches(-seq => 'hit'|'query', -start => $start, -stop => $stop); Purpose : Get the total number of identical and conservative matches : in the query or sbjct sequence for the given HSP. Optionally can : report data within a defined interval along the seq. : (Note: 'conservative' matches are called 'positives' in the : Blast report.) Example : ($id,$cons) = $hsp_object->matches(-seq => 'hit'); : ($id,$cons) = $hsp_object->matches(-seq => 'query', -start => 300, -stop => 400); Returns : 2-element array of integers Argument : (1) seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : (2) start = Starting coordinate (optional) : (3) stop = Ending coordinate (optional) Throws : Exception if the supplied coordinates are out of range. Comments : Relies on seq_str('match') to get the string of alignment symbols : between the query and sbjct lines which are used for determining : the number of identical and conservative matches. See Also : L, L, L, L =cut #----------- sub matches { #----------- my( $self, %param ) = @_; my(@data); my($seqType, $beg, $end) = ($param{-SEQ}, $param{-START}, $param{-STOP}); $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; if( (!defined $beg && !defined $end) || ! $self->seq_str('match') ) { ## Get data for the whole alignment. push @data, ($self->num_identical, $self->num_conserved); } else { ## Get the substring representing the desired sub-section of aln. $beg ||= 0; $end ||= 0; my($start,$stop) = $self->range($seqType); if($beg == 0) { $beg = $start; $end = $beg+$end; } # sane? elsif($end == 0) { $end = $stop; $beg = $end-$beg; } # sane? if($end > $stop) { $end = $stop; } if($beg < $start) { $beg = $start; } # now with gap handling! /maj my $match_str = $self->seq_str('match'); if ($self->gaps) { # strip the homology string of gap positions relative # to the target type $match_str = $self->seq_str('match'); my $tgt = $self->seq_str($seqType); my $encode = $match_str ^ $tgt; my $zap = '-'^' '; $encode =~ s/$zap//g; $tgt =~ s/-//g; $match_str = $tgt ^ $encode; } ## ML: START fix for substr out of range error ------------------ my $seq = ""; if (($self->algorithm =~ /TBLAST[NX]/) && ($seqType eq 'sbjct')) { $seq = substr($match_str, int(($beg-$start)/3), int(($end-$beg+1)/3)); } elsif (($self->algorithm =~ /T?BLASTX/) && ($seqType eq 'query')) { $seq = substr($match_str, int(($beg-$start)/3), int(($end-$beg+1)/3)); } else { $seq = substr($match_str, $beg-$start, ($end-$beg+1)); } ## ML: End of fix for substr out of range error ----------------- if(!CORE::length $seq) { $self->throw("Undefined sub-sequence ($beg,$end). Valid range = $start - $stop"); } $seq =~ s/ //g; # remove space (no info). my $len_cons = CORE::length $seq; $seq =~ s/\+//g; # remove '+' characters (conservative substitutions) my $len_id = CORE::length $seq; push @data, ($len_id, $len_cons); } @data; } =head2 n Usage : $hsp_obj->n() Purpose : Get the N value (num HSPs on which P/Expect is based). : This value is not defined with NCBI Blast2 with gapping. Returns : Integer or null string if not defined. Argument : n/a Throws : n/a Comments : The 'N' value is listed in parenthesis with P/Expect value: : e.g., P(3) = 1.2e-30 ---> (N = 3). : Not defined in NCBI Blast2 with gaps. : This typically is equal to the number of HSPs but not always. : To obtain the number of HSPs, use Bio::Search::Hit::HitI::num_hsps(). See Also : L =cut sub n { shift->throw_not_implemented } =head2 range Usage : $hsp->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($query_beg, $query_end) = $hsp->range('query'); : ($hit_beg, $hit_end) = $hsp->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This is a convenience method for constructions such as ($hsp->query->start, $hsp->query->end) =cut sub range { shift->throw_not_implemented } sub expect { shift->evalue(@_) } 1; BioPerl-1.6.923/Bio/Search/HSP/ModelHSP.pm000444000765000024 4215712254227313 20007 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::ModelHSP # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::ModelHSP - A HSP object for model-based searches =head1 SYNOPSIS use Bio::Search::HSP::ModelHSP; # us it just like a Bio::Search::HSP::ModelHSP object =head1 DESCRIPTION This object is a specialization of L and is used for searches which involve a query model, such as a Hidden Markov Model (HMM), covariance model (CM), descriptor, or anything else besides a sequence. Note that results from any HSPI class methods which rely on the query being a sequence are unreliable and have thus been overridden with warnings indicating they have not been implemented at this time. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::ModelHSP; use strict; use Bio::Seq::Meta; use base qw(Bio::Search::HSP::GenericHSP); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::ModelHSP->new(); Function: Builds a new Bio::Search::HSP::ModelHSP object Returns : Bio::Search::HSP::ModelHSP Args : Plus Bio::Seach::HSP::ModelHSP methods -algorithm => algorithm used (Infernal, RNAMotif, ERPIN, etc) -evalue => evalue -pvalue => pvalue -bits => bit value for HSP -score => score value for HSP (typically z-score but depends on analysis) -hsp_length=> Length of the HSP (including gaps) -identical => # of residues that that matched identically -conserved => # of residues that matched conservatively (only protein comparisions; conserved == identical in nucleotide comparisons) -hsp_gaps => # of gaps in the HSP -query_gaps => # of gaps in the query in the alignment -hit_gaps => # of gaps in the subject in the alignment -query_name => HSP Query sequence name (if available) -query_start => HSP Query start (in original query sequence coords) -query_end => HSP Query end (in original query sequence coords) -hit_name => HSP Hit sequence name (if available) -hit_start => HSP Hit start (in original hit sequence coords) -hit_end => HSP Hit end (in original hit sequence coords) -hit_length => total length of the hit sequence -query_length=> total length of the query sequence -query_seq => query sequence portion of the HSP -hit_seq => hit sequence portion of the HSP -homology_seq=> homology sequence for the HSP -hit_frame => hit frame (only if hit is translated protein) -query_frame => query frame (only if query is translated protein) -meta => optional meta data (sec structure, markup, etc) -custom_score=> custom score data =cut =head2 meta Title : meta Usage : my $meta = $hsp->meta(); Function: Returns meta data for this HSP or undef Returns : string of meta data or undef Args : [optional] string to set value Note : At some point very soon this will likely be a Bio::AnnotationI. Don't get used to a simple string! =cut sub meta { my ($self,$value) = @_; my $previous = $self->{'META'}; if( defined $value ) { $self->{'META'} = $value; } return $previous; } =head2 custom_score Title : custom_score Usage : my $data = $hsp->custom_score(); Function: Returns custom_score data for this HSP, or undef Returns : custom_score data or undef Args : [optional] custom_score Note : This is a Get/Set used to deal with odd score-like data generated from RNAMotif (and other programs) where the score section can be customized to include non-standard data, including sequence data, user-based scores, and other values. =cut sub custom_score { my ($self,$value) = @_; my $previous = $self->{'CUSTOMSCORE'}; if( defined $value ) { $self->{'CUSTOMSCORE'} = $value; } return $previous; } =head2 Bio::Search::HSP::HSPI methods Implementation of Bio::Search::HSP::HSPI methods follow =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the HSP Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut =head2 strand Title : strand Usage : $hsp->strand('hit') Function: Retrieves the strand for the HSP component requested Returns : +1 or -1 (0 if unknown) Args : 'hit' or 'subject' or 'sbjct' to retrieve the strand of the subject. There is no strand available for 'query', as the query is a model and not a true sequence. =cut # overrides HSPI::seq() =head2 seq Usage : $hsp->seq( [seq_type] ); Purpose : Get the query or sbjct sequence as a Bio::Seq.pm object. Example : $seqObj = $hsp->seq('sbjct'); Returns : Object reference for a Bio::Seq.pm object. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'sbjct'). : ('sbjct' is synonymous with 'hit') : default is 'sbjct' : Note: if there is no sequence available (eg for a model-based : search), this returns a LocatableSeq object w/o a sequence Throws : Propagates any exception that occurs during construction : of the Bio::Seq.pm object. Comments : The sequence is returned in an array of strings corresponding : to the strings in the original format of the Blast alignment. : (i.e., same spacing). See Also : L, L =cut #------- sub seq { #------- my($self,$seqType) = @_; $seqType ||= 'sbjct'; $seqType = 'sbjct' if $seqType eq 'hit'; my $str = $self->seq_str($seqType); if( $seqType =~ /^(m|ho)/i ) { $self->throw("cannot call seq on the homology match string, it isn't really a sequence, use get_aln to convert the HSP to a Bio::AlignIO and generate a consensus from that."); } require Bio::LocatableSeq; my $id = $seqType =~ /^q/i ? $self->query->seq_id : $self->hit->seq_id; $str =~ s{\*\[\s*(\d+)\s*\]\*}{'N' x $1}ge; $str =~ s{\s+}{}g; my $seq = Bio::LocatableSeq->new (-ID => $id, -START => $self->start($seqType), -END => $self->end($seqType), -STRAND=> $self->strand($seqType), -DESC => "$seqType sequence ", ); $seq->seq($str) if $str; $seq; } =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP or undef Returns : float or exponential (2e-10) P-value is not defined with NCBI Blast2 reports. Args : [optional] numeric to set value =cut =head2 evalue Title : evalue Usage : my $evalue = $hsp->evalue(); Function: Returns the e-value for this HSP Returns : float or exponential (2e-10) Args : [optional] numeric to set value =cut =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gaps in the query, hit, or total alignment. Returns : Integer, number of gaps or 0 if none Args : arg 1: 'query' = num gaps in query seq 'hit' = num gaps in hit seq 'total' = num gaps in whole alignment default = 'total' arg 2: [optional] integer gap value to set for the type requested =cut =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : [optional] string to set for query sequence =cut =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : [optional] string to set for hit sequence =cut =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : [optional] string to set for homology sequence =cut =head2 length Title : length Usage : my $len = $hsp->length( ['query'|'hit'|'total'] ); Function : Returns the length of the query or hit in the alignment (without gaps) or the aggregate length of the HSP (including gaps; this may be greater than either hit or query ) Returns : integer Args : arg 1: 'query' = length of query seq (without gaps) 'hit' = length of hit seq (without gaps) 'total' = length of alignment (with gaps) default = 'total' arg 2: [optional] integer length value to set for specific type =cut =head2 frame Title : frame Usage : my ($qframe, $hframe) = $hsp->frame('list',$queryframe,$subjectframe) Function: Set the Frame for both query and subject and insure that they agree. This overrides the frame() method implementation in FeaturePair. Returns : array of query and subject frame if return type wants an array or query frame if defined or subject frame if not defined Args : 'hit' or 'subject' or 'sbjct' to retrieve the frame of the subject (default) 'query' to retrieve the query frame 'list' or 'array' to retrieve both query and hit frames together Note : Frames are stored in the GFF way (0-2) not 1-3 as they are in BLAST (negative frames are deduced by checking the strand of the query or hit) =cut =head2 get_aln Title : get_aln Usage : my $aln = $hsp->gel_aln Function: Returns a Bio::SimpleAlign representing the HSP alignment Returns : Bio::SimpleAlign Args : none =cut sub get_aln { my ($self) = @_; require Bio::LocatableSeq; require Bio::SimpleAlign; my $aln = Bio::SimpleAlign->new; my %hsp = (hit => $self->hit_string, midline => $self->homology_string, query => $self->query_string, meta => $self->meta); # this takes care of infernal issues if ($hsp{meta} && $hsp{meta} =~ m{~+}) { $self->_postprocess_hsp(\%hsp); } if (!$hsp{query}) { $self->warn("Missing query string, can't build alignment"); return; } my $seqonly = $hsp{query}; $seqonly =~ s/[\-\s]//g; my ($q_nm,$s_nm) = ($self->query->seq_id(), $self->hit->seq_id()); unless( defined $q_nm && CORE::length ($q_nm) ) { $q_nm = 'query'; } unless( defined $s_nm && CORE::length ($s_nm) ) { $s_nm = 'hit'; } my $query = Bio::LocatableSeq->new('-seq' => $hsp{query}, '-id' => $q_nm, '-start' => $self->query->start, '-end' => $self->query->end, ); $seqonly = $hsp{hit}; $seqonly =~ s/[\-\s]//g; my $hit = Bio::LocatableSeq->new('-seq' => $hsp{hit}, '-id' => $s_nm, '-start' => $self->hit->start, '-end' => $self->hit->end, ); $aln->add_seq($query); $aln->add_seq($hit); if ($hsp{meta}) { my $meta_obj = Bio::Seq::Meta->new(); $meta_obj->named_meta('ss_cons', $hsp{meta}); $aln->consensus_meta($meta_obj); } return $aln; } =head2 Inherited from Bio::SeqFeature::SimilarityPair These methods come from Bio::SeqFeature::SimilarityPair =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Get/Set the significance value Returns : numeric Args : [optional] new value to set =head2 score Title : score Usage : my $score = $hsp->score(); Function: Returns the score for this HSP or undef Returns : numeric Args : [optional] numeric to set value =cut =head2 bits Title : bits Usage : my $bits = $hsp->bits(); Function: Returns the bit value for this HSP or undef Returns : numeric Args : none =cut =head1 ModelHSP methods overridden in ModelHSP The following methods have been overridden due to their current reliance on sequence-based queries. They may be implemented in future versions of this class. =head2 seq_inds =cut sub seq_inds { my $self = shift; $self->warn('$hsp->seq_inds not implemented for Model-based searches'); return; } =head2 frac_identical =cut sub frac_identical { my $self = shift; $self->warn('$hsp->frac_identical not implemented for Model-based searches'); return; } =head2 frac_conserved =cut sub frac_conserved { my $self = shift; $self->warn('$hsp->frac_conserved not implemented for Model-based searches'); return; } =head2 matches =cut sub matches { my $self = shift; $self->warn('$hsp->matches not implemented for Model-based searches'); return; } =head2 num_conserved =cut sub num_conserved { my $self = shift; $self->warn('$hsp->num_conserved not implemented for Model-based searches'); return; } =head2 num_identical =cut sub num_identical { my $self = shift; $self->warn('$hsp->num_identical not implemented for Model-based searches'); return; } =head2 cigar_string =cut sub cigar_string { my $self = shift; $self->warn('$hsp->cigar_string not implemented for Model-based searches'); return; } =head2 generate_cigar_string =cut sub generate_cigar_string { my $self = shift; $self->warn('$hsp->generate_cigar_string not implemented for Model-based searches'); return; } =head2 percent_identity =cut sub percent_identity { my $self = shift; $self->warn('$hsp->percent_identity not implemented for Model-based searches'); return; } ############## PRIVATE ############## # the following method postprocesses HSP data in cases where the sequences # aren't complete (which can trigger a validation error) { my $SEQ_REGEX = qr/\*\[\s*(\d+)\s*\]\*/; my $META_REGEX = qr/(~+)/; sub _postprocess_hsp { my ($self, $hsp) = @_; $self->throw('Must pass a hash ref for HSP processing') unless ref($hsp) eq 'HASH'; my @ins; for my $type (qw(query hit meta)) { $hsp->{$type} =~ s{\s+$}{}; my $str = $hsp->{$type}; my $regex = $type eq 'meta' ? $META_REGEX : $SEQ_REGEX; my $ind = 0; while ($str =~ m{$regex}g) { $ins[$ind]->{$type} = {pos => pos($str) - length($1), str => $1}; $ind++; } } for my $chunk (reverse @ins) { my ($max, $min) = ($chunk->{hit}->{str} >= $chunk->{query}->{str}) ? ('hit', 'query') : ('query', 'hit'); my %rep; $rep{$max} = 'N' x $chunk->{$max}->{str}; $rep{$min} = 'N' x $chunk->{$min}->{str}. ('-'x($chunk->{$max}->{str}-$chunk->{$min}->{str})); $rep{'meta'} = '~' x $chunk->{$max}->{str}; $rep{'midline'} = ' ' x $chunk->{$max}->{str}; for my $t (qw(hit query meta midline)) { substr($hsp->{$t}, $chunk->{meta}->{pos}, length($chunk->{meta}->{str}) , $rep{$t}); } } } } 1; BioPerl-1.6.923/Bio/Search/HSP/PsiBlastHSP.pm000444000765000024 16102012254227314 20500 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::HSP::PsiBlastHSP # # (This module was originally called Bio::Tools::Blast::HSP) # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- ## POD Documentation: =head1 NAME Bio::Search::HSP::PsiBlastHSP - Bioperl BLAST High-Scoring Pair object =head1 SYNOPSIS See L. =head1 DESCRIPTION A Bio::Search::HSP::PsiBlastHSP object provides an interface to data obtained in a single alignment section of a Blast report (known as a "High-scoring Segment Pair"). This is essentially a pairwise alignment with score information. PsiBlastHSP objects are accessed via L objects after parsing a BLAST report using the L system. The construction of PsiBlastHSP objects is performed by Bio::Factory::BlastHitFactory in a process that is orchestrated by the Blast parser (L). The resulting PsiBlastHSPs are then accessed via L). Therefore, you do not need to use L) directly. If you need to construct PsiBlastHSPs directly, see the new() function for details. For L BLAST parsing usage examples, see the C directory of the Bioperl distribution. =head2 Start and End coordinates Sequence endpoints are swapped so that start is always less than end. This affects For TBLASTN/X hits on the minus strand. Strand information can be recovered using the strand() method. This normalization step is standard Bioperl practice. It also facilitates use of range information by methods such as match(). =over 1 =item * Supports BLAST versions 1.x and 2.x, gapped and ungapped. =back Bio::Search::HSP::PsiBlastHSP.pm has the ability to extract a list of all residue indices for identical and conservative matches along both query and sbjct sequences. Since this degree of detail is not always needed, this behavior does not occur during construction of the PsiBlastHSP object. These data will automatically be collected as necessary as the PsiBlastHSP.pm object is used. =head1 DEPENDENCIES Bio::Search::HSP::PsiBlastHSP.pm is a concrete class that inherits from L and L. L and L are employed for creating sequence and alignment objects, respectively. =head2 Relationship to L and L PsiBlastHSP.pm can provide the query or sbjct sequence as a L object via the L method. The PsiBlastHSP.pm object can also create a two-sequence L alignment object using the the query and sbjct sequences via the L method. Creation of alignment objects is not automatic when constructing the PsiBlastHSP.pm object since this level of functionality is not always required and would generate a lot of extra overhead when crunching many reports. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac-at-bioperl.orgE See L for where to send bug reports and comments. =head1 ACKNOWLEDGEMENTS This software was originally developed in the Department of Genetics at Stanford University. I would also like to acknowledge my colleagues at Affymetrix for useful feedback. =head1 SEE ALSO Bio::Search::Hit::BlastHit.pm - Blast hit object. Bio::Search::Result::BlastResult.pm - Blast Result object. Bio::Seq.pm - Biosequence object =head2 Links: http://bio.perl.org/ - Bioperl Project Homepage =head1 COPYRIGHT Copyright (c) 1996-2001 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =cut # END of main POD documentation. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::PsiBlastHSP; use strict; use Bio::SeqFeature::Similarity; use vars qw($GAP_SYMBOL %STRAND_SYMBOL); use overload '""' => \&to_string; use base qw(Bio::SeqFeature::SimilarityPair Bio::Search::HSP::HSPI); $GAP_SYMBOL = '-'; # Need a more general way to handle gap symbols. %STRAND_SYMBOL = ('Plus' => 1, 'Minus' => -1 ); =head2 new Usage : $hsp = Bio::Search::HSP::PsiBlastHSP->new( %named_params ); : Bio::Search::HSP::PsiBlastHSP.pm objects are constructed : automatically by Bio::SearchIO::BlastHitFactory.pm, : so there is no need for direct instantiation. Purpose : Constructs a new PsiBlastHSP object and Initializes key variables : for the HSP. Returns : A Bio::Search::HSP::PsiBlastHSP object Argument : Named parameters: : Parameter keys are case-insensitive. : -RAW_DATA => array ref containing raw BLAST report data for : for a single HSP. This includes all lines : of the HSP alignment from a traditional BLAST or PSI-BLAST (non-XML) report, : -RANK => integer (1..n). : -PROGRAM => string ('TBLASTN', 'BLASTP', etc.). : -QUERY_NAME => string, id of query sequence : -HIT_NAME => string, id of hit sequence : Comments : Having the raw data allows this object to do lazy parsing of : the raw HSP data (i.e., not parsed until needed). : : Note that there is a fair amount of basic parsing that is : currently performed in this module that would be more appropriate : to do within a separate factory object. : This parsing code will likely be relocated and more initialization : parameters will be added to new(). : See Also : L, L =cut #---------------- sub new { #---------------- my ($class, @args ) = @_; my $self = $class->SUPER::new( @args ); # Initialize placeholders $self->{'_queryGaps'} = $self->{'_sbjctGaps'} = 0; my ($raw_data, $qname, $hname, $qlen, $hlen); ($self->{'_prog'}, $self->{'_rank'}, $raw_data, $qname, $hname) = $self->_rearrange([qw( PROGRAM RANK RAW_DATA QUERY_NAME HIT_NAME )], @args ); # _set_data() does a fair amount of parsing. # This will likely change (see comment above.) $self->_set_data( @{$raw_data} ); # Store the aligned query as sequence feature my ($qb, $hb) = ($self->start()); my ($qe, $he) = ($self->end()); my ($qs, $hs) = ($self->strand()); my ($qf,$hf) = ($self->query->frame(), $self->hit->frame); $self->query( Bio::SeqFeature::Similarity->new (-start =>$qb, -end =>$qe, -strand =>$qs, -bits =>$self->bits, -score =>$self->score, -frame =>$qf, -seq_id => $qname, -source =>$self->{'_prog'} )); $self->hit( Bio::SeqFeature::Similarity->new (-start =>$hb, -end =>$he, -strand =>$hs, -bits =>$self->bits, -score =>$self->score, -frame =>$hf, -seq_id => $hname, -source =>$self->{'_prog'} )); # set lengths $self->query->seqlength($qlen); # query $self->hit->seqlength($hlen); # subject $self->query->frac_identical($self->frac_identical('query')); $self->hit->frac_identical($self->frac_identical('hit')); return $self; } #sub DESTROY { # my $self = shift; # #print STDERR "--->DESTROYING $self\n"; #} # Title : _id_str; # Purpose : Intended for internal use only to provide a string for use # within exception messages to help users figure out which # query/hit caused the problem. # Returns : Short string with name of query and hit seq sub _id_str { my $self = shift; if( not defined $self->{'_id_str'}) { my $qname = $self->query->seqname; my $hname = $self->hit->seqname; $self->{'_id_str'} = "QUERY=\"$qname\" HIT=\"$hname\""; } return $self->{'_id_str'}; } #================================================= # Begin Bio::Search::HSP::HSPI implementation #================================================= =head2 algorithm Title : algorithm Usage : $alg = $hsp->algorithm(); Function: Gets the algorithm specification that was used to obtain the hsp For BLAST, the algorithm denotes what type of sequence was aligned against what (BLASTN: dna-dna, BLASTP prt-prt, BLASTX translated dna-prt, TBLASTN prt-translated dna, TBLASTX translated dna-translated dna). Returns : a scalar string Args : none =cut #---------------- sub algorithm { #---------------- my ($self,@args) = @_; return $self->{'_prog'}; } =head2 signif() Usage : $hsp_obj->signif() Purpose : Get the P-value or Expect value for the HSP. Returns : Float (0.001 or 1.3e-43) : Returns P-value if it is defined, otherwise, Expect value. Argument : n/a Throws : n/a Comments : Provided for consistency with BlastHit::signif() : Support for returning the significance data in different : formats (e.g., exponent only), is not provided for HSP objects. : This is only available for the BlastHit or Blast object. See Also : L

, L, L =cut #----------- sub signif { #----------- my $self = shift; my $val ||= defined($self->{'_p'}) ? $self->{'_p'} : $self->{'_expect'}; $val; } =head2 evalue Usage : $hsp_obj->evalue() Purpose : Get the Expect value for the HSP. Returns : Float (0.001 or 1.3e-43) Argument : n/a Throws : n/a Comments : Support for returning the expectation data in different : formats (e.g., exponent only), is not provided for HSP objects. : This is only available for the BlastHit or Blast object. See Also : L

=cut #---------- sub evalue { shift->{'_expect'} } #---------- =head2 p Usage : $hsp_obj->p() Purpose : Get the P-value for the HSP. Returns : Float (0.001 or 1.3e-43) or undef if not defined. Argument : n/a Throws : n/a Comments : P-value is not defined with NCBI Blast2 reports. : Support for returning the expectation data in different : formats (e.g., exponent only) is not provided for HSP objects. : This is only available for the BlastHit or Blast object. See Also : L =cut #----- sub p { my $self = shift; $self->{'_p'}; } #----- # alias sub pvalue { shift->p(@_); } =head2 length Usage : $hsp->length( [seq_type] ) Purpose : Get the length of the aligned portion of the query or sbjct. Example : $hsp->length('query') Returns : integer Argument : seq_type: 'query' | 'hit' or 'sbjct' | 'total' (default = 'total') ('sbjct' is synonymous with 'hit') Throws : n/a Comments : 'total' length is the full length of the alignment : as reported in the denominators in the alignment section: : "Identical = 34/120 Positives = 67/120". See Also : L =cut #----------- sub length { #----------- ## Developer note: when using the built-in length function within ## this module, call it as CORE::length(). my( $self, $seqType ) = @_; $seqType ||= 'total'; $seqType = 'sbjct' if $seqType eq 'hit'; $seqType ne 'total' and $self->_set_seq_data() unless $self->{'_set_seq_data'}; ## Sensitive to member name format. $seqType = "_\L$seqType\E"; $self->{$seqType.'Length'}; } =head2 gaps Usage : $hsp->gaps( [seq_type] ) Purpose : Get the number of gap characters in the query, sbjct, or total alignment. : Also can return query gap chars and sbjct gap chars as a two-element list : when in array context. Example : $total_gaps = $hsp->gaps(); : ($qgaps, $sgaps) = $hsp->gaps(); : $qgaps = $hsp->gaps('query'); Returns : scalar context: integer : array context without args: (int, int) = ('queryGaps', 'sbjctGaps') Argument : seq_type: 'query' or 'hit' or 'sbjct' or 'total' : ('sbjct' is synonymous with 'hit') : (default = 'total', scalar context) : Array context can be "induced" by providing an argument of 'list' or 'array'. Throws : n/a See Also : L, L =cut #--------- sub gaps { #--------- my( $self, $seqType ) = @_; $self->_set_seq_data() unless $self->{'_set_seq_data'}; $seqType ||= (wantarray ? 'list' : 'total'); $seqType = 'sbjct' if $seqType eq 'hit'; if($seqType =~ /list|array/i) { return (($self->{'_queryGaps'} || 0), ($self->{'_sbjctGaps'} || 0)); } if($seqType eq 'total') { return ($self->{'_queryGaps'} + $self->{'_sbjctGaps'}) || 0; } else { ## Sensitive to member name format. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Gaps'} || 0; } } =head2 frac_identical Usage : $hsp_object->frac_identical( [seq_type] ); Purpose : Get the fraction of identical positions within the given HSP. Example : $frac_iden = $hsp_object->frac_identical('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' or 'hit' or 'sbjct' or 'total' : ('sbjct' is synonymous with 'hit') : default = 'total' (but see comments below). Throws : n/a Comments : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Identical = 34/120 Positives = 67/120". : NCBI-BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : Therefore, when called without an argument or an argument of 'total', : this method will report different values depending on the : version of BLAST used. : : To get the fraction identical among only the aligned residues, : ignoring the gaps, call this method with an argument of 'query' : or 'sbjct' ('sbjct' is synonymous with 'hit'). See Also : L, L, L =cut #------------------- sub frac_identical { #------------------- # The value is calculated as opposed to storing it from the parsed results. # This saves storage and also permits flexibility in determining for which # sequence (query or sbjct) the figure is to be calculated. my( $self, $seqType ) = @_; $seqType ||= 'total'; $seqType = 'sbjct' if $seqType eq 'hit'; if($seqType ne 'total') { $self->_set_seq_data() unless $self->{'_set_seq_data'}; } ## Sensitive to member name format. $seqType = "_\L$seqType\E"; sprintf( "%.2f", $self->{'_numIdentical'}/$self->{$seqType.'Length'}); } =head2 frac_conserved Usage : $hsp_object->frac_conserved( [seq_type] ); Purpose : Get the fraction of conserved positions within the given HSP. : (Note: 'conservative' positions are called 'positives' in the : Blast report.) Example : $frac_cons = $hsp_object->frac_conserved('query'); Returns : Float (2-decimal precision, e.g., 0.75). Argument : seq_type: 'query' or 'hit' or 'sbjct' or 'total' : ('sbjct' is synonymous with 'hit') : default = 'total' (but see comments below). Throws : n/a Comments : Different versions of Blast report different values for the total : length of the alignment. This is the number reported in the : denominators in the stats section: : "Identical = 34/120 Positives = 67/120". : NCBI-BLAST uses the total length of the alignment (with gaps) : WU-BLAST uses the length of the query sequence (without gaps). : Therefore, when called without an argument or an argument of 'total', : this method will report different values depending on the : version of BLAST used. : : To get the fraction conserved among only the aligned residues, : ignoring the gaps, call this method with an argument of 'query' : or 'sbjct'. See Also : L, L, L =cut #-------------------- sub frac_conserved { #-------------------- # The value is calculated as opposed to storing it from the parsed results. # This saves storage and also permits flexibility in determining for which # sequence (query or sbjct) the figure is to be calculated. my( $self, $seqType ) = @_; $seqType ||= 'total'; $seqType = 'sbjct' if $seqType eq 'hit'; if($seqType ne 'total') { $self->_set_seq_data() unless $self->{'_set_seq_data'}; } ## Sensitive to member name format. $seqType = "_\L$seqType\E"; sprintf( "%.2f", $self->{'_numConserved'}/$self->{$seqType.'Length'}); } =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : none =cut #---------------- sub query_string{ shift->seq_str('query'); } #---------------- =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : none =cut #---------------- sub hit_string{ shift->seq_str('hit'); } #---------------- =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : none =cut #---------------- sub homology_string{ shift->seq_str('match'); } #---------------- #================================================= # End Bio::Search::HSP::HSPI implementation #================================================= # Older method delegating to method defined in HSPI. =head2 expect See L =cut #---------- sub expect { shift->evalue( @_ ); } #---------- =head2 rank Usage : $hsp->rank( [string] ); Purpose : Get the rank of the HSP within a given Blast hit. Example : $rank = $hsp->rank; Returns : Integer (1..n) corresponding to the order in which the HSP appears in the BLAST report. =cut #' #---------- sub rank { shift->{'_rank'} } #---------- # For backward compatibility #---------- sub name { shift->rank } #---------- =head2 to_string Title : to_string Usage : print $hsp->to_string; Function: Returns a string representation for the Blast HSP. Primarily intended for debugging purposes. Example : see usage Returns : A string of the form: [PsiBlastHSP] e.g.: [BlastHit] 1 Args : None =cut #---------- sub to_string { #---------- my $self = shift; return "[PsiBlastHSP] " . $self->rank(); } =head2 _set_data Usage : called automatically during object construction. Purpose : Parses the raw HSP section from a flat BLAST report and sets the query sequence, sbjct sequence, and the "match" data : which consists of the symbols between the query and sbjct lines : in the alignment. Argument : Array (all lines for a single, complete HSP, from a raw, flat (i.e., non-XML) BLAST report) Throws : Propagates any exceptions from the methods called ("See Also") See Also : L, L, L =cut #-------------- sub _set_data { #-------------- my $self = shift; my @data = @_; my @queryList = (); # 'Query' = SEQUENCE USED TO QUERY THE DATABASE. my @sbjctList = (); # 'Sbjct' = HOMOLOGOUS SEQUENCE FOUND IN THE DATABASE. my @matchList = (); my $matchLine = 0; # Alternating boolean: when true, load 'match' data. my @linedat = (); #print STDERR "PsiBlastHSP: set_data()\n"; my($line, $aln_row_len, $length_diff); $length_diff = 0; # Collecting data for all lines in the alignment # and then storing the collections for possible processing later. # # Note that "match" lines may not be properly padded with spaces. # This loop now properly handles such cases: # Query: 1141 PSLVELTIRDCPRLEVGPMIRSLPKFPMLKKLDLAVANIIEEDLDVIGSLEELVIXXXXX 1200 # PSLVELTIRDCPRLEVGPMIRSLPKFPMLKKLDLAVANIIEEDLDVIGSLEELVI # Sbjct: 1141 PSLVELTIRDCPRLEVGPMIRSLPKFPMLKKLDLAVANIIEEDLDVIGSLEELVILSLKL 1200 foreach $line( @data ) { next if $line =~ /^\s*$/; if( $line =~ /^ ?Score/ ) { $self->_set_score_stats( $line ); } elsif( $line =~ /^ ?(Identities|Positives|Strand)/ ) { $self->_set_match_stats( $line ); } elsif( $line =~ /^ ?Frame = ([\d+-]+)/ ) { # Version 2.0.8 has Frame information on a separate line. # Storing frame according to SeqFeature::Generic::frame() # which does not contain strand info (use strand()). my $frame = abs($1) - 1; $self->frame( $frame ); } elsif( $line =~ /^(Query:?[\s\d]+)([^\s\d]+)/ ) { push @queryList, $line; $self->{'_match_indent'} = CORE::length $1; $aln_row_len = (CORE::length $1) + (CORE::length $2); $matchLine = 1; } elsif( $matchLine ) { # Pad the match line with spaces if necessary. $length_diff = $aln_row_len - CORE::length $line; $length_diff and $line .= ' 'x $length_diff; push @matchList, $line; $matchLine = 0; } elsif( $line =~ /^Sbjct/ ) { push @sbjctList, $line; } } # Storing the query and sbjct lists in case they are needed later. # We could make this conditional to save memory. $self->{'_queryList'} = \@queryList; $self->{'_sbjctList'} = \@sbjctList; # Storing the match list in case it is needed later. $self->{'_matchList'} = \@matchList; if(not defined ($self->{'_numIdentical'})) { my $id_str = $self->_id_str; $self->throw( -text => "Can't parse match statistics. Possibly a new or unrecognized Blast format. ($id_str)"); } if(!scalar @queryList or !scalar @sbjctList) { my $id_str = $self->_id_str; $self->throw( "Can't find query or sbjct alignment lines. Possibly unrecognized Blast format. ($id_str)"); } } =head2 _set_score_stats Usage : called automatically by _set_data() Purpose : Sets various score statistics obtained from the HSP listing. Argument : String with any of the following formats: : blast2: Score = 30.1 bits (66), Expect = 9.2 : blast2: Score = 158.2 bits (544), Expect(2) = e-110 : blast1: Score = 410 (144.3 bits), Expect = 1.7e-40, P = 1.7e-40 : blast1: Score = 55 (19.4 bits), Expect = 5.3, Sum P(3) = 0.99 Throws : Exception if the stats cannot be parsed, probably due to a change : in the Blast report format. See Also : L =cut #-------------------- sub _set_score_stats { #-------------------- my ($self, $data) = @_; my ($expect, $p); if($data =~ /Score = +([\d.e+-]+) bits \(([\d.e+-]+)\), +Expect = +([\d.e+-]+)/) { # blast2 format n = 1 $self->bits($1); $self->score($2); $expect = $3; } elsif($data =~ /Score = +([\d.e+-]+) bits \(([\d.e+-]+)\), +Expect\((\d+)\) = +([\d.e+-]+)/) { # blast2 format n > 1 $self->bits($1); $self->score($2); $self->{'_n'} = $3; $expect = $4; } elsif($data =~ /Score = +([\d.e+-]+) \(([\d.e+-]+) bits\), +Expect = +([\d.e+-]+), P = +([\d.e-]+)/) { # blast1 format, n = 1 $self->score($1); $self->bits($2); $expect = $3; $p = $4; } elsif($data =~ /Score = +([\d.e+-]+) \(([\d.e+-]+) bits\), +Expect = +([\d.e+-]+), +Sum P\((\d+)\) = +([\d.e-]+)/) { # blast1 format, n > 1 $self->score($1); $self->bits($2); $expect = $3; $self->{'_n'} = $4; $p = $5; } else { my $id_str = $self->_id_str; $self->throw(-class => 'Bio::Root::Exception', -text => "Can't parse score statistics: unrecognized format. ($id_str)", -value => $data); } $expect = "1$expect" if $expect =~ /^e/i; $p = "1$p" if defined $p and $p=~ /^e/i; $self->{'_expect'} = $expect; $self->{'_p'} = $p || undef; $self->significance( $p || $expect ); } =head2 _set_match_stats Usage : Private method; called automatically by _set_data() Purpose : Sets various matching statistics obtained from the HSP listing. Argument : blast2: Identities = 23/74 (31%), Positives = 29/74 (39%), Gaps = 17/74 (22%) : blast2: Identities = 57/98 (58%), Positives = 74/98 (75%) : blast1: Identities = 87/204 (42%), Positives = 126/204 (61%) : blast1: Identities = 87/204 (42%), Positives = 126/204 (61%), Frame = -3 : WU-blast: Identities = 310/553 (56%), Positives = 310/553 (56%), Strand = Minus / Plus Throws : Exception if the stats cannot be parsed, probably due to a change : in the Blast report format. Comments : The "Gaps = " data in the HSP header has a different meaning depending : on the type of Blast: for BLASTP, this number is the total number of : gaps in query+sbjct; for TBLASTN, it is the number of gaps in the : query sequence only. Thus, it is safer to collect the data : separately by examining the actual sequence strings as is done : in _set_seq(). See Also : L, L =cut #-------------------- sub _set_match_stats { #-------------------- my ($self, $data) = @_; if($data =~ m!Identities = (\d+)/(\d+)!) { # blast1 or 2 format $self->{'_numIdentical'} = $1; $self->{'_totalLength'} = $2; } if($data =~ m!Positives = (\d+)/(\d+)!) { # blast1 or 2 format $self->{'_numConserved'} = $1; $self->{'_totalLength'} = $2; } if($data =~ m!Frame = ([\d+-]+)!) { $self->frame($1); } # Strand data is not always present in this line. # _set_seq() will also set strand information. if($data =~ m!Strand = (\w+) / (\w+)!) { $self->{'_queryStrand'} = $1; $self->{'_sbjctStrand'} = $2; } # if($data =~ m!Gaps = (\d+)/(\d+)!) { # $self->{'_totalGaps'} = $1; # } else { # $self->{'_totalGaps'} = 0; # } } =head2 _set_seq_data Usage : called automatically when sequence data is requested. Purpose : Sets the HSP sequence data for both query and sbjct sequences. : Includes: start, stop, length, gaps, and raw sequence. Argument : n/a Throws : Propagates any exception thrown by _set_match_seq() Comments : Uses raw data stored by _set_data() during object construction. : These data are not always needed, so it is conditionally : executed only upon demand by methods such as gaps(), _set_residues(), : etc. _set_seq() does the dirty work. See Also : L =cut #----------------- sub _set_seq_data { #----------------- my $self = shift; $self->_set_seq('query', @{$self->{'_queryList'}}); $self->_set_seq('sbjct', @{$self->{'_sbjctList'}}); # Liberate some memory. @{$self->{'_queryList'}} = @{$self->{'_sbjctList'}} = (); undef $self->{'_queryList'}; undef $self->{'_sbjctList'}; $self->{'_set_seq_data'} = 1; } =head2 _set_seq Usage : called automatically by _set_seq_data() : $hsp_obj->($seq_type, @data); Purpose : Sets sequence information for both the query and sbjct sequences. : Directly counts the number of gaps in each sequence (if gapped Blast). Argument : $seq_type = 'query' or 'sbjct' : @data = all seq lines with the form: : Query: 61 SPHNVKDRKEQNGSINNAISPTATANTSGSQQINIDSALRDRSSNVAAQPSLSDASSGSN 120 Throws : Exception if data strings cannot be parsed, probably due to a change : in the Blast report format. Comments : Uses first argument to determine which data members to set : making this method sensitive data member name changes. : Behavior is dependent on the type of BLAST analysis (TBLASTN, BLASTP, etc). Warning : Sequence endpoints are normalized so that start < end. This affects HSPs : for TBLASTN/X hits on the minus strand. Normalization facilitates use : of range information by methods such as match(). See Also : L, L, L, L, L =cut #------------- sub _set_seq { #------------- my $self = shift; my $seqType = shift; my @data = @_; my @ranges = (); my @sequence = (); my $numGaps = 0; foreach( @data ) { if( m/(\d+) *([^\d\s]+) *(\d+)/) { push @ranges, ( $1, $3 ) ; push @sequence, $2; #print STDERR "_set_seq found sequence \"$2\"\n"; } else { $self->warn("Bad sequence data: $_"); } } if( !(scalar(@sequence) and scalar(@ranges))) { my $id_str = $self->_id_str; $self->throw("Can't set sequence: missing data. Possibly unrecognized Blast format. ($id_str)"); } # Sensitive to member name changes. $seqType = "_\L$seqType\E"; $self->{$seqType.'Start'} = $ranges[0]; $self->{$seqType.'Stop'} = $ranges[ $#ranges ]; $self->{$seqType.'Seq'} = \@sequence; $self->{$seqType.'Length'} = abs($ranges[ $#ranges ] - $ranges[0]) + 1; # Adjust lengths for BLASTX, TBLASTN, TBLASTX sequences # Converting nucl coords to amino acid coords. my $prog = $self->algorithm; if($prog eq 'TBLASTN' and $seqType eq '_sbjct') { $self->{$seqType.'Length'} /= 3; } elsif($prog eq 'BLASTX' and $seqType eq '_query') { $self->{$seqType.'Length'} /= 3; } elsif($prog eq 'TBLASTX') { $self->{$seqType.'Length'} /= 3; } if( $prog ne 'BLASTP' ) { $self->{$seqType.'Strand'} = 'Plus' if $prog =~ /BLASTN/; $self->{$seqType.'Strand'} = 'Plus' if ($prog =~ /BLASTX/ and $seqType eq '_query'); # Normalize sequence endpoints so that start < end. # Reverse complement or 'minus strand' HSPs get flipped here. if($self->{$seqType.'Start'} > $self->{$seqType.'Stop'}) { ($self->{$seqType.'Start'}, $self->{$seqType.'Stop'}) = ($self->{$seqType.'Stop'}, $self->{$seqType.'Start'}); $self->{$seqType.'Strand'} = 'Minus'; } } ## Count number of gaps in each seq. Only need to do this for gapped Blasts. # if($self->{'_gapped'}) { my $seqstr = join('', @sequence); $seqstr =~ s/\s//g; my $num_gaps = CORE::length($seqstr) - $self->{$seqType.'Length'}; $self->{$seqType.'Gaps'} = $num_gaps if $num_gaps > 0; # } } =head2 _set_residues Usage : called automatically when residue data is requested. Purpose : Sets the residue numbers representing the identical and : conserved positions. These data are obtained by analyzing the : symbols between query and sbjct lines of the alignments. Argument : n/a Throws : Propagates any exception thrown by _set_seq_data() and _set_match_seq(). Comments : These data are not always needed, so it is conditionally : executed only upon demand by methods such as seq_inds(). : Behavior is dependent on the type of BLAST analysis (TBLASTN, BLASTP, etc). See Also : L, L, L =cut #------------------ sub _set_residues { #------------------ my $self = shift; my @sequence = (); $self->_set_seq_data() unless $self->{'_set_seq_data'}; # Using hashes to avoid saving duplicate residue numbers. my %identicalList_query = (); my %identicalList_sbjct = (); my %conservedList_query = (); my %conservedList_sbjct = (); my $aref = $self->_set_match_seq() if not ref $self->{'_matchSeq'}; $aref ||= $self->{'_matchSeq'}; my $seqString = join('', @$aref ); my $qseq = join('',@{$self->{'_querySeq'}}); my $sseq = join('',@{$self->{'_sbjctSeq'}}); my $resCount_query = $self->{'_queryStop'} || 0; my $resCount_sbjct = $self->{'_sbjctStop'} || 0; my $prog = $self->algorithm; if($prog !~ /^BLASTP|^BLASTN/) { if($prog eq 'TBLASTN') { $resCount_sbjct /= 3; } elsif($prog eq 'BLASTX') { $resCount_query /= 3; } elsif($prog eq 'TBLASTX') { $resCount_query /= 3; $resCount_sbjct /= 3; } } my ($mchar, $schar, $qchar); while( $mchar = chop($seqString) ) { ($qchar, $schar) = (chop($qseq), chop($sseq)); if( $mchar eq '+' ) { $conservedList_query{ $resCount_query } = 1; $conservedList_sbjct{ $resCount_sbjct } = 1; } elsif( $mchar ne ' ' ) { $identicalList_query{ $resCount_query } = 1; $identicalList_sbjct{ $resCount_sbjct } = 1; } $resCount_query-- if $qchar ne $GAP_SYMBOL; $resCount_sbjct-- if $schar ne $GAP_SYMBOL; } $self->{'_identicalRes_query'} = \%identicalList_query; $self->{'_conservedRes_query'} = \%conservedList_query; $self->{'_identicalRes_sbjct'} = \%identicalList_sbjct; $self->{'_conservedRes_sbjct'} = \%conservedList_sbjct; } =head2 _set_match_seq Usage : $hsp_obj->_set_match_seq() Purpose : Set the 'match' sequence for the current HSP (symbols in between : the query and sbjct lines.) Returns : Array reference holding the match sequences lines. Argument : n/a Throws : Exception if the _matchList field is not set. Comments : The match information is not always necessary. This method : allows it to be conditionally prepared. : Called by _set_residues>() and seq_str(). See Also : L, L =cut #------------------- sub _set_match_seq { #------------------- my $self = shift; if( ! ref($self->{'_matchList'}) ) { my $id_str = $self->_id_str; $self->throw("Can't set HSP match sequence: No data ($id_str)"); } my @data = @{$self->{'_matchList'}}; my(@sequence); foreach( @data ) { chomp($_); ## Remove leading spaces; (note: aln may begin with a space ## which is why we can't use s/^ +//). s/^ {$self->{'_match_indent'}}//; push @sequence, $_; } # Liberate some memory. @{$self->{'_matchList'}} = undef; $self->{'_matchList'} = undef; $self->{'_matchSeq'} = \@sequence; return $self->{'_matchSeq'}; } =head2 n Usage : $hsp_obj->n() Purpose : Get the N value (num HSPs on which P/Expect is based). : This value is not defined with NCBI Blast2 with gapping. Returns : Integer or null string if not defined. Argument : n/a Throws : n/a Comments : The 'N' value is listed in parenthesis with P/Expect value: : e.g., P(3) = 1.2e-30 ---> (N = 3). : Not defined in NCBI Blast2 with gaps. : This typically is equal to the number of HSPs but not always. : To obtain the number of HSPs, use Bio::Search::Hit::BlastHit::num_hsps(). See Also : L =cut #----- sub n { my $self = shift; $self->{'_n'} || ''; } #----- =head2 matches Usage : $hsp->matches([seq_type], [start], [stop]); Purpose : Get the total number of identical and conservative matches : in the query or sbjct sequence for the given HSP. Optionally can : report data within a defined interval along the seq. : (Note: 'conservative' matches are called 'positives' in the : Blast report.) Example : ($id,$cons) = $hsp_object->matches('hit'); : ($id,$cons) = $hsp_object->matches('query',300,400); Returns : 2-element array of integers Argument : (1) seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : (2) start = Starting coordinate (optional) : (3) stop = Ending coordinate (optional) Throws : Exception if the supplied coordinates are out of range. Comments : Relies on seq_str('match') to get the string of alignment symbols : between the query and sbjct lines which are used for determining : the number of identical and conservative matches. See Also : L, L, L, L =cut #----------- sub matches { #----------- my( $self, %param ) = @_; my(@data); my($seqType, $beg, $end) = ($param{-SEQ}, $param{-START}, $param{-STOP}); $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my($start,$stop); if(!defined $beg && !defined $end) { ## Get data for the whole alignment. push @data, ($self->{'_numIdentical'}, $self->{'_numConserved'}); } else { ## Get the substring representing the desired sub-section of aln. $beg ||= 0; $end ||= 0; ($start,$stop) = $self->range($seqType); if($beg == 0) { $beg = $start; $end = $beg+$end; } elsif($end == 0) { $end = $stop; $beg = $end-$beg; } if($end >= $stop) { $end = $stop; } ##ML changed from if (end >stop) else { $end += 1;} ##ML moved from commented position below, makes ##more sense here # if($end > $stop) { $end = $stop; } if($beg < $start) { $beg = $start; } # else { $end += 1;} # my $seq = substr($self->seq_str('match'), $beg-$start, ($end-$beg)); ## ML: START fix for substr out of range error ------------------ my $seq = ""; my $prog = $self->algorithm; if (($prog eq 'TBLASTN') and ($seqType eq 'sbjct')) { $seq = substr($self->seq_str('match'), int(($beg-$start)/3), int(($end-$beg+1)/3)); } elsif (($prog eq 'BLASTX') and ($seqType eq 'query')) { $seq = substr($self->seq_str('match'), int(($beg-$start)/3), int(($end-$beg+1)/3)); } else { $seq = substr($self->seq_str('match'), $beg-$start, ($end-$beg)); } ## ML: End of fix for substr out of range error ----------------- ## ML: debugging code ## This is where we get our exception. Try printing out the values going ## into this: ## # print STDERR # qq(*------------MY EXCEPTION --------------------\nSeq: ") , # $self->seq_str("$seqType"), qq("\n),$self->rank,",( index:"; # print STDERR $beg-$start, ", len: ", $end-$beg," ), (HSPRealLen:", # CORE::length $self->seq_str("$seqType"); # print STDERR ", HSPCalcLen: ", $stop - $start +1 ," ), # ( beg: $beg, end: $end ), ( start: $start, stop: stop )\n"; ## ML: END DEBUGGING CODE---------- if(!CORE::length $seq) { my $id_str = $self->_id_str; $self->throw("Undefined $seqType sub-sequence ($beg,$end). Valid range = $start - $stop ($id_str)"); } ## Get data for a substring. # printf "Collecting HSP subsection data: beg,end = %d,%d; start,stop = %d,%d\n%s<---\n", $beg, $end, $start, $stop, $seq; # printf "Original match seq:\n%s\n",$self->seq_str('match'); $seq =~ s/ //g; # remove space (no info). my $len_cons = CORE::length $seq; $seq =~ s/\+//g; # remove '+' characters (conservative substitutions) my $len_id = CORE::length $seq; push @data, ($len_id, $len_cons); # printf " HSP = %s\n id = %d; cons = %d\n", $self->rank, $len_id, $len_cons; ; } @data; } =head2 num_identical Usage : $hsp_object->num_identical(); Purpose : Get the number of identical positions within the given HSP. Example : $num_iden = $hsp_object->num_identical(); Returns : integer Argument : n/a Throws : n/a See Also : L, L =cut #------------------- sub num_identical { #------------------- my( $self) = shift; $self->{'_numIdentical'}; } =head2 num_conserved Usage : $hsp_object->num_conserved(); Purpose : Get the number of conserved positions within the given HSP. Example : $num_iden = $hsp_object->num_conserved(); Returns : integer Argument : n/a Throws : n/a See Also : L, L =cut #------------------- sub num_conserved { #------------------- my( $self) = shift; $self->{'_numConserved'}; } =head2 range Usage : $hsp->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($query_beg, $query_end) = $hsp->range('query'); : ($hit_beg, $hit_end) = $hsp->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut #---------- sub range { #---------- my ($self, $seqType) = @_; $self->_set_seq_data() unless $self->{'_set_seq_data'}; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return ($self->{$seqType.'Start'},$self->{$seqType.'Stop'}); } =head2 start Usage : $hsp->start( [seq_type] ); Purpose : Gets the start coordinate for the query, sbjct, or both sequences : in the HSP alignment. : NOTE: Start will always be less than end. : To determine strand, use $hsp->strand() Example : $query_beg = $hsp->start('query'); : $hit_beg = $hsp->start('hit'); : ($query_beg, $hit_beg) = $hsp->start(); Returns : scalar context: integer : array context without args: list of two integers Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default= 'query') : ('sbjct' is synonymous with 'hit') : Array context can be "induced" by providing an argument of 'list' or 'array'. Throws : n/a See Also : L, L =cut #---------- sub start { #---------- my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; $self->_set_seq_data() unless $self->{'_set_seq_data'}; if($seqType =~ /list|array/i) { return ($self->{'_queryStart'}, $self->{'_sbjctStart'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Start'}; } } =head2 end Usage : $hsp->end( [seq_type] ); Purpose : Gets the end coordinate for the query, sbjct, or both sequences : in the HSP alignment. : NOTE: Start will always be less than end. : To determine strand, use $hsp->strand() Example : $query_end = $hsp->end('query'); : $hit_end = $hsp->end('hit'); : ($query_end, $hit_end) = $hsp->end(); Returns : scalar context: integer : array context without args: list of two integers Argument : In scalar context: seq_type = 'query' or 'hit' or 'sbjct' (default= 'query') : ('sbjct' is synonymous with 'hit') : Array context can be "induced" by providing an argument of 'list' or 'array'. Throws : n/a See Also : L, L, L =cut #---------- sub end { #---------- my ($self, $seqType) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; $self->_set_seq_data() unless $self->{'_set_seq_data'}; if($seqType =~ /list|array/i) { return ($self->{'_queryStop'}, $self->{'_sbjctStop'}); } else { ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; return $self->{$seqType.'Stop'}; } } =head2 strand Usage : $hsp_object->strand( [seq_type] ) Purpose : Get the strand of the query or sbjct sequence. Example : print $hsp->strand('query'); : ($query_strand, $hit_strand) = $hsp->strand(); Returns : -1, 0, or 1 : -1 = Minus strand, +1 = Plus strand : Returns 0 if strand is not defined, which occurs : for BLASTP reports, and the query of TBLASTN : as well as the hit if BLASTX reports. : In scalar context without arguments, returns queryStrand value. : In array context without arguments, returns a two-element list : of strings (queryStrand, sbjctStrand). : Array context can be "induced" by providing an argument of 'list' or 'array'. Argument : seq_type: 'query' or 'hit' or 'sbjct' or undef : ('sbjct' is synonymous with 'hit') Throws : n/a See Also : L, L =cut #----------- sub strand { #----------- my( $self, $seqType ) = @_; $seqType ||= (wantarray ? 'list' : 'query'); $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name format. $seqType = "_\L$seqType\E"; # $seqType could be '_list'. $self->{'_queryStrand'} or $self->_set_seq_data() unless $self->{'_set_seq_data'}; my $prog = $self->algorithm; if($seqType =~ /list|array/i) { my ($qstr, $hstr); if( $prog eq 'BLASTP') { $qstr = 0; $hstr = 0; } elsif( $prog eq 'TBLASTN') { $qstr = 0; $hstr = $STRAND_SYMBOL{$self->{'_sbjctStrand'}}; } elsif( $prog eq 'BLASTX') { $qstr = $STRAND_SYMBOL{$self->{'_queryStrand'}}; $hstr = 0; } else { $qstr = $STRAND_SYMBOL{$self->{'_queryStrand'}} if defined $self->{'_queryStrand'}; $hstr = $STRAND_SYMBOL{$self->{'_sbjctStrand'}} if defined $self->{'_sbjctStrand'}; } $qstr ||= 0; $hstr ||= 0; return ($qstr, $hstr); } local $^W = 0; $STRAND_SYMBOL{$self->{$seqType.'Strand'}} || 0; } =head2 seq Usage : $hsp->seq( [seq_type] ); Purpose : Get the query or sbjct sequence as a Bio::Seq.pm object. Example : $seqObj = $hsp->seq('query'); Returns : Object reference for a Bio::Seq.pm object. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query'). : ('sbjct' is synonymous with 'hit') Throws : Propagates any exception that occurs during construction : of the Bio::Seq.pm object. Comments : The sequence is returned in an array of strings corresponding : to the strings in the original format of the Blast alignment. : (i.e., same spacing). See Also : L, L, L =cut #------- sub seq { #------- my($self,$seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; my $str = $self->seq_str($seqType); require Bio::Seq; Bio::Seq->new(-ID => $self->to_string, -SEQ => $str, -DESC => "$seqType sequence", ); } =head2 seq_str Usage : $hsp->seq_str( seq_type ); Purpose : Get the full query, sbjct, or 'match' sequence as a string. : The 'match' sequence is the string of symbols in between the : query and sbjct sequences. Example : $str = $hsp->seq_str('query'); Returns : String Argument : seq_Type = 'query' or 'hit' or 'sbjct' or 'match' : ('sbjct' is synonymous with 'hit') Throws : Exception if the argument does not match an accepted seq_type. Comments : Calls _set_seq_data() to set the 'match' sequence if it has : not been set already. See Also : L, L, L =cut #------------ sub seq_str { #------------ my($self,$seqType) = @_; $seqType ||= 'query'; $seqType = 'sbjct' if $seqType eq 'hit'; ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; $self->_set_seq_data() unless $self->{'_set_seq_data'}; if($seqType =~ /sbjct|query/) { my $seq = join('',@{$self->{$seqType.'Seq'}}); $seq =~ s/\s+//g; return $seq; } elsif( $seqType =~ /match/i) { # Only need to call _set_match_seq() if the match seq is requested. my $aref = $self->_set_match_seq() unless ref $self->{'_matchSeq'}; $aref = $self->{'_matchSeq'}; return join('',@$aref); } else { my $id_str = $self->_id_str; $self->throw(-class => 'Bio::Root::BadParameter', -text => "Invalid or undefined sequence type: $seqType ($id_str)\n" . "Valid types: query, sbjct, match", -value => $seqType); } } =head2 seq_inds Usage : $hsp->seq_inds( seq_type, class, collapse ); Purpose : Get a list of residue positions (indices) for all identical : or conserved residues in the query or sbjct sequence. Example : @s_ind = $hsp->seq_inds('query', 'identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved'); : @h_ind = $hsp->seq_inds('hit', 'conserved', 1); Returns : List of integers : May include ranges if collapse is true. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : class = 'identical' or 'conserved' (default = identical) : (can be shortened to 'id' or 'cons') : (actually, anything not 'id' will evaluate to 'conserved'). : collapse = boolean, if true, consecutive positions are merged : using a range notation, e.g., "1 2 3 4 5 7 9 10 11" : collapses to "1-5 7 9-11". This is useful for : consolidating long lists. Default = no collapse. Throws : n/a. Comments : Calls _set_residues() to set the 'match' sequence if it has : not been set already. See Also : L, L, L, L =cut #--------------- sub seq_inds { #--------------- my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = 'sbjct' if $seqType eq 'hit'; $self->_set_residues() unless defined $self->{'_identicalRes_query'}; $seqType = ($seqType !~ /^q/i ? 'sbjct' : 'query'); $class = ($class !~ /^id/i ? 'conserved' : 'identical'); ## Sensitive to member name changes. $seqType = "_\L$seqType\E"; $class = "_\L$class\E"; my @ary = sort { $a <=> $b } keys %{ $self->{"${class}Res$seqType"}}; require Bio::Search::BlastUtils if $collapse; return $collapse ? &Bio::Search::BlastUtils::collapse_nums(@ary) : @ary; } =head2 get_aln Usage : $hsp->get_aln() Purpose : Get a Bio::SimpleAlign object constructed from the query + sbjct : sequences of the present HSP object. Example : $aln_obj = $hsp->get_aln(); Returns : Object reference for a Bio::SimpleAlign.pm object. Argument : n/a. Throws : Propagates any exception ocurring during the construction of : the Bio::SimpleAlign object. Comments : Requires Bio::SimpleAlign. : The Bio::SimpleAlign object is constructed from the query + sbjct : sequence objects obtained by calling seq(). : Gap residues are included (see $GAP_SYMBOL). See Also : L, L =cut #------------ sub get_aln { #------------ my $self = shift; require Bio::SimpleAlign; require Bio::LocatableSeq; my $qseq = $self->seq('query'); my $sseq = $self->seq('sbjct'); my $type = $self->algorithm =~ /P$|^T/ ? 'amino' : 'dna'; my $aln = Bio::SimpleAlign->new(); $aln->add_seq(Bio::LocatableSeq->new(-seq => $qseq->seq(), -id => 'query_'.$qseq->display_id(), -start => 1, -end => CORE::length($qseq))); $aln->add_seq(Bio::LocatableSeq->new(-seq => $sseq->seq(), -id => 'hit_'.$sseq->display_id(), -start => 1, -end => CORE::length($sseq))); return $aln; } 1; __END__ =head1 FOR DEVELOPERS ONLY =head2 Data Members Information about the various data members of this module is provided for those wishing to modify or understand the code. Two things to bear in mind: =over 4 =item 1 Do NOT rely on these in any code outside of this module. All data members are prefixed with an underscore to signify that they are private. Always use accessor methods. If the accessor doesn't exist or is inadequate, create or modify an accessor (and let me know, too!). =item 2 This documentation may be incomplete and out of date. It is easy for these data member descriptions to become obsolete as this module is still evolving. Always double check this info and search for members not described here. =back An instance of Bio::Search::HSP::PsiBlastHSP.pm is a blessed reference to a hash containing all or some of the following fields: FIELD VALUE -------------------------------------------------------------- (member names are mostly self-explanatory) _score : _bits : _p : _n : Integer. The 'N' value listed in parenthesis with P/Expect value: : e.g., P(3) = 1.2e-30 ---> (N = 3). : Not defined in NCBI Blast2 with gaps. : To obtain the number of HSPs, use Bio::Search::Hit::BlastHit::num_hsps(). _expect : _queryLength : _queryGaps : _queryStart : _queryStop : _querySeq : _sbjctLength : _sbjctGaps : _sbjctStart : _sbjctStop : _sbjctSeq : _matchSeq : String. Contains the symbols between the query and sbjct lines which indicate identical (letter) and conserved ('+') matches or a mismatch (' '). _numIdentical : _numConserved : _identicalRes_query : _identicalRes_sbjct : _conservedRes_query : _conservedRes_sbjct : _match_indent : The number of leading space characters on each line containing the match symbols. _match_indent is 13 in this example: Query: 285 QNSAPWGLARISHRERLNLGSFNKYLYDDDAG Q +APWGLARIS G+ + Y YD+ AG ^^^^^^^^^^^^^ =cut 1; BioPerl-1.6.923/Bio/Search/HSP/PSLHSP.pm000444000765000024 714612254227315 17366 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::PSLHSP # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::PSLHSP - A HSP for PSL output =head1 SYNOPSIS # get a PSLHSP somehow (SearchIO::psl) =head1 DESCRIPTION This is a HSP for PSL output so we can handle seq_inds differently. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::PSLHSP; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Search::HSP::GenericHSP); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::PSLHSP->new(); Function: Builds a new Bio::Search::HSP::PSLHSP object Returns : an instance of Bio::Search::HSP::PSLHSP Args : -gapblocks => arrayref of gap locations which are [start,length] of gaps =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($qgaplocs, $hgaplocs, $mismatches) = $self->_rearrange([qw(QUERY_GAPBLOCKS HIT_GAPBLOCKS MISMATCHES)], @args); $self->gap_blocks('query',$qgaplocs) if defined $qgaplocs; $self->gap_blocks('hit', $hgaplocs) if defined $hgaplocs; $self->mismatches($mismatches) if defined $mismatches; return $self; } =head2 gap_blocks Title : gap_blocks Usage : $obj->gap_blocks($seqtype,$blocks) Function: Get/Set the gap blocks Returns : value of gap_blocks (a scalar) Args : sequence type - 'query' or 'hit' blocks - arrayref of block start,length =cut sub gap_blocks { my ($self,$seqtype,$blocks) = @_; if( ! defined $seqtype ) { $seqtype = 'query' } $seqtype = lc($seqtype); $seqtype = 'hit' if $seqtype eq 'sbjct'; if( $seqtype !~ /query|hit/i ) { $self->warn("Expect either 'query' or 'hit' as argument 1 for gap_blocks"); } unless( defined $blocks ) { return $self->{'_gap_blocks'}->{$seqtype}; } else { return $self->{'_gap_blocks'}->{$seqtype} = $blocks; } } =head2 mismatches Title : mismatches Usage : $obj->mismatches($newval) Function: Get/Set the number of mismatches Returns : value of mismatches (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub mismatches{ my $self = shift; return $self->{'mismatches'} = shift if @_; return $self->{'mismatches'}; } 1; BioPerl-1.6.923/Bio/Search/HSP/PullHSPI.pm000555000765000024 6300612254227316 17776 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::PullHSPI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::PullHSPI - Bio::Search::HSP::HSPI interface for pull parsers. =head1 SYNOPSIS # This is an interface and cannot be instantiated # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 'result.hmmer'); while (my $result = $in->next_result) { while (my $hit = $result->next_hit) { while (my $hsp = $hit->next_hsp) { $r_type = $hsp->algorithm; $pvalue = $hsp->p(); $evalue = $hsp->evalue(); $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); $qseq = $hsp->query_string; $hseq = $hsp->hit_string; $homo_string = $hsp->homology_string; $len = $hsp->length( ['query'|'hit'|'total'] ); $len = $hsp->length( ['query'|'hit'|'total'] ); $rank = $hsp->rank; } } } =head1 DESCRIPTION PullHSP is for fast implementations that only do parsing work on the hsp data when you actually request information by calling one of the HSPI methods. Many methods of HSPI are implemented in a way suitable for inheriting classes that use Bio::PullParserI. It only really makes sense for PullHSP modules to be created by (and have as a -parent) PullHit modules. In addition to the usual -chunk and -parent, -hsp_data is all you should supply when making a PullHSP object. This will store that data and make it accessible via _raw_hsp_data, which you can access in your subclass. It would be best to simply provide the data as the input -chunk instead, if the raw data is large enough. =head1 SEE ALSO This module inherits methods from these other modules: L, L L Please refer to these modules for documentation of the many additional inherited methods. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 COPYRIGHT Copyright (c) 2006 Sendu Bala. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::PullHSPI; use strict; use base qw(Bio::Search::HSP::HSPI Bio::PullParserI); =head2 _setup Title : _setup Usage : $self->_setup(@args) Function: Implementers should call this to setup common fields and deal with common arguments to new(). Returns : n/a Args : @args received in new(). =cut sub _setup { my ($self, @args) = @_; # fields most subclasses probably will want $self->_fields( { ( hsp_length => undef, identical => undef, percent_identity => undef, conserved => undef, hsp_gaps => undef, query_gaps => undef, hit_gaps => undef, evalue => undef, pvalue => undef, score => undef, query_start => undef, query_end => undef, query_string => undef, hit_start => undef, hit_end => undef, hit_string => undef, homology_string => undef, rank => undef, seq_inds => undef, hit_identical_inds => undef, hit_conserved_inds => undef, hit_nomatch_inds => undef, hit_gap_inds => undef, query_identical_inds => undef, query_conserved_inds => undef, query_nomatch_inds => undef, query_gap_inds => undef ) } ); my ($parent, $chunk, $hsp_data) = $self->_rearrange([qw(PARENT CHUNK HSP_DATA)], @args); $self->throw("Need -parent or -chunk to be defined") unless defined $parent || $chunk; $self->parent($parent) if $parent; if ($chunk) { my ($io, $start, $end) = (undef, 0, undef); if (ref($chunk) eq 'ARRAY') { ($io, $start, $end) = @{$chunk}; } else { $io = $chunk; } $self->chunk($io, -start => $start, -end => $end); } $self->_raw_hsp_data($hsp_data) if $hsp_data; return $self; } sub _raw_hsp_data { my $self = shift; if (@_) { $self->{_raw_hsp_data} = shift; } return $self->{_raw_hsp_data}; } # # Some of these methods are written explitely to avoid HSPI throwing not # implemented or the wrong ancestor class being used to answer the method; # if it didn't do that then PullParserI AUTOLOAD would have cought them. # =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the HSP Returns : string (e.g., BLASTP) Args : none =cut sub algorithm { return shift->get_field('algorithm'); } =head2 pvalue Title : pvalue Usage : my $pvalue = $hsp->pvalue(); Function: Returns the P-value for this HSP or undef Returns : float or exponential (2e-10) Args : none =cut sub pvalue { return shift->get_field('pvalue'); } =head2 evalue Title : evalue Usage : my $evalue = $hsp->evalue(); Function: Returns the e-value for this HSP Returns : float or exponential (2e-10) Args : none =cut sub evalue { return shift->get_field('evalue'); } *expect = \&evalue; =head2 frac_identical Title : frac_identical Usage : my $frac_id = $hsp->frac_identical( ['query'|'hit'|'total'] ); Function: Returns the fraction of identitical positions for this HSP Returns : Float in range 0.0 -> 1.0 Args : 'query' = num identical / length of query seq (without gaps) 'hit' = num identical / length of hit seq (without gaps) 'total' = num identical / length of alignment (with gaps) default = 'total' =cut sub frac_identical { my ($self, $type) = @_; $type = lc $type if defined $type; $type = 'hit' if (defined $type && $type =~ /subject|sbjct/); $type = 'total' if (! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); my $ratio = $self->num_identical($type) / $self->length($type); return sprintf( "%.4f", $ratio); } =head2 frac_conserved Title : frac_conserved Usage : my $frac_cons = $hsp->frac_conserved( ['query'|'hit'|'total'] ); Function : Returns the fraction of conserved positions for this HSP. This is the fraction of symbols in the alignment with a positive score. Returns : Float in range 0.0 -> 1.0 Args : 'query' = num conserved / length of query seq (without gaps) 'hit' = num conserved / length of hit seq (without gaps) 'total' = num conserved / length of alignment (with gaps) default = 'total' =cut sub frac_conserved { my ($self, $type) = @_; $type = lc $type if defined $type; $type = 'hit' if (defined $type && $type =~ /subject|sbjct/); $type = 'total' if (! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); my $ratio = $self->num_conserved($type) / $self->length($type); return sprintf( "%.4f", $ratio); } =head2 num_identical Title : num_identical Usage : $obj->num_identical($newval) Function: returns the number of identical residues in the alignment Returns : integer Args : integer (optional) =cut sub num_identical { my $self = shift; return scalar($self->seq_inds('hit', 'identical')); } =head2 num_conserved Title : num_conserved Usage : $obj->num_conserved($newval) Function: returns the number of conserved residues in the alignment Returns : inetger Args : integer (optional) =cut sub num_conserved { my $self = shift; return scalar($self->seq_inds('hit', 'conserved-not-identical')); } =head2 gaps Title : gaps Usage : my $gaps = $hsp->gaps( ['query'|'hit'|'total'] ); Function : Get the number of gap characters in the query, hit, or total alignment. Returns : Integer, number of gap characters or 0 if none Args : 'query', 'hit' or 'total'; default = 'total' =cut sub gaps { my ($self, $type) = @_; $type = lc $type if defined $type; $type = 'total' if (! defined $type || $type eq 'hsp' || $type !~ /query|hit|subject|sbjct|total/); $type = 'hit' if $type =~ /sbjct|subject/; if ($type eq 'total') { return scalar($self->seq_inds('hit', 'gap')) + scalar($self->seq_inds('query', 'gap')); } return scalar($self->seq_inds($type, 'gap')); } =head2 query_string Title : query_string Usage : my $qseq = $hsp->query_string; Function: Retrieves the query sequence of this HSP as a string Returns : string Args : none =cut sub query_string { return shift->get_field('query_string'); } =head2 hit_string Title : hit_string Usage : my $hseq = $hsp->hit_string; Function: Retrieves the hit sequence of this HSP as a string Returns : string Args : none =cut sub hit_string { return shift->get_field('hit_string'); } =head2 homology_string Title : homology_string Usage : my $homo_string = $hsp->homology_string; Function: Retrieves the homology sequence for this HSP as a string. : The homology sequence is the string of symbols in between the : query and hit sequences in the alignment indicating the degree : of conservation (e.g., identical, similar, not similar). Returns : string Args : none =cut sub homology_string { return shift->get_field('homology_string'); } =head2 length Title : length Usage : my $len = $hsp->length( ['query'|'hit'|'total'] ); Function : Returns the length of the query or hit in the alignment (without gaps) or the aggregate length of the HSP (including gaps; this may be greater than either hit or query ) Returns : integer Args : 'query' = length of query seq (without gaps) 'hit' = length of hit seq (without gaps) 'total' = length of alignment (with gaps) default = 'total' Args : none =cut sub length { my ($self, $type) = @_; $type = 'total' unless defined $type; $type = lc $type; if ($type =~ /^q/i) { return $self->query->length; } elsif ($type =~ /^(hit|subject|sbjct)/) { return $self->hit->length; } else { return $self->hit->length + $self->gaps('hit'); } } =head2 hsp_length Title : hsp_length Usage : my $len = $hsp->hsp_length() Function: shortcut length('hsp') Returns : floating point between 0 and 100 Args : none =cut sub hsp_length { return shift->length('total'); } =head2 percent_identity Title : percent_identity Usage : my $percentid = $hsp->percent_identity() Function: Returns the calculated percent identity for an HSP Returns : floating point between 0 and 100 Args : none =cut sub percent_identity{ my ($self) = @_; return $self->frac_identical('hsp') * 100; } =head2 get_aln Title : get_aln Usage : my $aln = $hsp->get_aln Function: Returns a Bio::SimpleAlign representing the HSP alignment Returns : Bio::SimpleAlign Args : none =cut sub get_aln { my $self = shift; require Bio::LocatableSeq; require Bio::SimpleAlign; my $aln = Bio::SimpleAlign->new(); my $hs = $self->seq('hit'); my $qs = $self->seq('query'); if ($hs && $qs) { $aln->add_seq($hs); $aln->add_seq($qs); return $aln; } return; } =head2 seq_inds Title : seq_inds Purpose : Get a list of residue positions (indices) for all identical : or conserved residues in the query or sbjct sequence. Example : @s_ind = $hsp->seq_inds('query', 'identical'); : @h_ind = $hsp->seq_inds('hit', 'conserved'); : @h_ind = $hsp->seq_inds('hit', 'conserved', 1); Returns : List of integers : May include ranges if collapse is true. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = query) ('sbjct' is synonymous with 'hit') class = 'identical' or 'conserved' or 'nomatch' or 'gap' (default = identical) (can be shortened to 'id' or 'cons') Note that 'conserved' includes identical unless you use 'conserved-not-identical' collapse = boolean, if true, consecutive positions are merged using a range notation, e.g., "1 2 3 4 5 7 9 10 11" collapses to "1-5 7 9-11". This is useful for consolidating long lists. Default = no collapse. Throws : n/a. Comments : See Also : L, L =cut sub seq_inds { my ($self, $seqType, $class, $collapse) = @_; $seqType ||= 'query'; $class ||= 'identical'; $collapse ||= 0; $seqType = lc($seqType); $class = lc($class); $seqType = 'hit' if $seqType eq 'sbjct'; my $t = substr($seqType,0,1); if ($t eq 'q') { $seqType = 'query'; } elsif ($t eq 's' || $t eq 'h') { $seqType = 'hit'; } else { $self->warn("unknown seqtype $seqType using 'query'"); $seqType = 'query'; } $t = substr($class,0,1); if ($t eq 'c') { if ($class eq 'conserved-not-identical') { $class = 'conserved'; } else { $class = 'conservedall'; } } elsif ($t eq 'i') { $class = 'identical'; } elsif ($t eq 'n') { $class = 'nomatch'; } elsif ($t eq 'g') { $class = 'gap'; } else { $self->warn("unknown sequence class $class using 'identical'"); $class = 'identical'; } $seqType .= '_'; $class .= '_inds'; my @ary; if ($class eq 'conservedall_inds') { my %tmp = map { $_, 1 } @{$self->get_field($seqType.'conserved_inds')}, @{$self->get_field($seqType.'identical_inds')}; @ary = sort {$a <=> $b} keys %tmp; } else { @ary = @{$self->get_field($seqType.$class)}; } return $collapse ? &Bio::Search::SearchUtils::collapse_nums(@ary) : @ary; } =head2 Inherited from L These methods come from L =head2 query Title : query Usage : my $query = $hsp->query Function: Returns a SeqFeature representing the query in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 hit Title : hit Usage : my $hit = $hsp->hit Function: Returns a SeqFeature representing the hit in the HSP Returns : Bio::SeqFeature::Similarity Args : [optional] new value to set =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Get/Set the significance value (see Bio::SeqFeature::SimilarityPair) Returns : significance value (scientific notation string) Args : significance value (sci notation string) =cut sub significance { return shift->get_field('evalue'); } =head2 score Title : score Usage : my $score = $hsp->score(); Function: Returns the score for this HSP or undef Returns : numeric Args : [optional] numeric to set value =cut sub score { return shift->get_field('score'); } =head2 bits Title : bits Usage : my $bits = $hsp->bits(); Function: Returns the bit value for this HSP or undef Returns : numeric Args : none =cut sub bits { return shift->get_field('bits'); } # override =head2 strand Title : strand Usage : $hsp->strand('query') Function: Retrieves the strand for the HSP component requested Returns : +1 or -1 (0 if unknown) Args : 'hit' or 'subject' or 'sbjct' to retrieve the strand of the subject 'query' to retrieve the query strand (default) 'list' or 'array' to retreive both query and hit together =cut sub strand { my $self = shift; my $val = shift; $val = 'query' unless defined $val; $val =~ s/^\s+//; if ($val =~ /^q/i) { return $self->query->strand(@_); } elsif ($val =~ /^hi|^s/i) { return $self->hit->strand(@_); } elsif ($val =~ /^list|array/i) { return ($self->query->strand(@_), $self->hit->strand(@_) ); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 start Title : start Usage : $hsp->start('query') Function: Retrieves the start for the HSP component requested Returns : integer, or list of two integers (query start and subject start) in list context Args : 'hit' or 'subject' or 'sbjct' to retrieve the start of the subject 'query' to retrieve the query start (default) =cut sub start { my $self = shift; my $val = shift; $val = (wantarray ? 'list' : 'query') unless defined $val; $val =~ s/^\s+//; if ($val =~ /^q/i) { return $self->query->start(@_); } elsif ($val =~ /^(hi|s)/i) { return $self->hit->start(@_); } elsif ($val =~ /^list|array/i) { return ($self->query->start(@_), $self->hit->start(@_) ); } else { $self->warn("unrecognized component '$val' requested\n"); } return 0; } =head2 end Title : end Usage : $hsp->end('query') Function: Retrieves the end for the HSP component requested Returns : integer, or list of two integers (query end and subject end) in list context Args : 'hit' or 'subject' or 'sbjct' to retrieve the end of the subject 'query' to retrieve the query end (default) =cut sub end { my $self = shift; my $val = shift; $val = (wantarray ? 'list' : 'query') unless defined $val; $val =~ s/^\s+//; if ($val =~ /^q/i) { return $self->query->end(@_); } elsif ($val =~ /^(hi|s)/i) { return $self->hit->end(@_); } elsif ($val =~ /^list|array/i) { return ($self->query->end(@_), $self->hit->end(@_) ); } else { $self->warn("unrecognized end component '$val' requested\n"); } return 0; } =head2 seq Usage : $hsp->seq( [seq_type] ); Purpose : Get the query or sbjct sequence as a Bio::Seq.pm object. Example : $seqObj = $hsp->seq('query'); Returns : Object reference for a Bio::LocatableSeq object. Argument : seq_type = 'query' or 'hit' or 'sbjct' (default = 'query'). : ('sbjct' is synonymous with 'hit') : default is 'query' =cut sub seq { my ($self, $seqType) = @_; $seqType ||= 'query'; $seqType = 'hit' if $seqType eq 'sbjct'; if ($seqType =~ /^(m|ho)/i ) { $self->throw("cannot call seq on the homology match string, it isn't really a sequence, use get_aln to convert the HSP to a Bio::AlignIO and generate a consensus from that."); } my $str = $self->seq_str($seqType) || return; require Bio::LocatableSeq; my $id = ($seqType =~ /^q/i) ? $self->query->seq_id : $self->hit->seq_id; return Bio::LocatableSeq->new( -ID => $id, -SEQ => $str, -START => $self->start($seqType), -END => $self->end($seqType), -STRAND => $self->strand($seqType), -FORCE_NSE => $id ? 0 : 1, -DESC => "$seqType sequence " ); } =head2 seq_str Usage : $hsp->seq_str( seq_type ); Purpose : Get the full query, sbjct, or 'match' sequence as a string. : The 'match' sequence is the string of symbols in between the : query and sbjct sequences. Example : $str = $hsp->seq_str('query'); Returns : String Argument : seq_Type = 'query' or 'hit' or 'sbjct' or 'match' : ('sbjct' is synonymous with 'hit') : default is 'query' Throws : Exception if the argument does not match an accepted seq_type. Comments : See Also : L, L, B<_set_match_seq()> =cut sub seq_str { my $self = shift; my $type = shift || 'query'; if ($type =~ /^q/i) { return $self->query_string(@_); } elsif ($type =~ /^(s)|(hi)/i) { return $self->hit_string(@_); } elsif ($type =~ /^(ho)|(ma)/i) { return $self->homology_string(@_); } else { $self->warn("unknown sequence type $type"); } return ''; } =head2 rank Usage : $hsp->rank( [string] ); Purpose : Get the rank of the HSP within a given Blast hit. Example : $rank = $hsp->rank; Returns : Integer (1..n) corresponding to the order in which the HSP appears in the BLAST report. =cut sub rank { return shift->get_field('rank'); } =head2 matches Usage : $hsp->matches(-seq => 'hit'|'query', -start => $start, -stop => $stop); Purpose : Get the total number of identical and conservative matches : in the query or sbjct sequence for the given HSP. Optionally can : report data within a defined interval along the seq. Example : ($id,$cons) = $hsp_object->matches(-seq => 'hit'); : ($id,$cons) = $hsp_object->matches(-seq => 'query', -start => 300, -stop => 400); Returns : 2-element array of integers Argument : (1) seq_type = 'query' or 'hit' or 'sbjct' (default = query) : ('sbjct' is synonymous with 'hit') : (2) start = Starting coordinate (optional) : (3) stop = Ending coordinate (optional) =cut sub matches { my ($self, @args) = @_; my($seqType, $beg, $end) = $self->_rearrange([qw(SEQ START STOP)], @args); $seqType ||= 'query'; $seqType = 'hit' if $seqType eq 'sbjct'; my @data; if ((!defined $beg && !defined $end) || ! $self->seq_str('match')) { push @data, ($self->num_identical, $self->num_conserved); } else { $beg ||= 0; $end ||= 0; my ($start, $stop) = $self->range($seqType); if ($beg == 0) { $beg = $start; $end = $beg+$end; } elsif ($end == 0) { $end = $stop; $beg = $end-$beg; } if ($end >= $stop) { $end = $stop; } else { $end += 1; } if ($beg < $start) { $beg = $start; } my $seq = substr($self->seq_str('homology'), $beg-$start, ($end-$beg)); if (!CORE::length $seq) { $self->throw("Undefined sub-sequence ($beg,$end). Valid range = $start - $stop"); } ## Get data for a substring. $seq =~ s/ //g; # remove space (no info). my $len_cons = CORE::length $seq; $seq =~ s/\+//g; # remove '+' characters (conservative substitutions) my $len_id = CORE::length $seq; push @data, ($len_id, $len_cons); } return @data; } =head2 n Usage : $hsp_obj->n() Purpose : Get the N value (num HSPs on which P/Expect is based). Returns : Integer or null string if not defined. Argument : n/a Throws : n/a Comments : The 'N' value is listed in parenthesis with P/Expect value: : e.g., P(3) = 1.2e-30 ---> (N = 3). : Not defined in NCBI Blast2 with gaps. : This typically is equal to the number of HSPs but not always. =cut sub n { return shift->get_field('num_hsps'); } =head2 range Usage : $hsp->range( [seq_type] ); Purpose : Gets the (start, end) coordinates for the query or sbjct sequence : in the HSP alignment. Example : ($query_beg, $query_end) = $hsp->range('query'); : ($hit_beg, $hit_end) = $hsp->range('hit'); Returns : Two-element array of integers Argument : seq_type = string, 'query' or 'hit' or 'sbjct' (default = 'query') : ('sbjct' is synonymous with 'hit') Throws : n/a Comments : This is a convenience method for constructions such as ($hsp->query->start, $hsp->query->end) =cut sub range { my ($self, $seqType) = @_; $seqType ||= 'query'; my ($start, $end); if ($seqType eq 'query') { $start = $self->query->start; $end = $self->query->end; } else { $start = $self->hit->start; $end = $self->hit->end; } return ($start, $end); } #*** would want cigar stuff from GenericHSP - move to HSPI? 1; BioPerl-1.6.923/Bio/Search/HSP/WABAHSP.pm000444000765000024 1025012254227335 17452 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::HSP::WABAHSP # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::HSP::WABAHSP - HSP object suitable for describing WABA alignments =head1 SYNOPSIS # use this object as you would a GenericHSP # a few other methods have been added including state =head1 DESCRIPTION This object implements a few of the extra methods such as hmmstate_string which returns the HMM state representation for the WABA alignment. We also must implement a method to calculate homology_string since it is not returned by the algorithm in the machine readable format. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::HSP::WABAHSP; use strict; use Bio::Root::RootI; use base qw(Bio::Search::HSP::GenericHSP); =head2 new Title : new Usage : my $obj = Bio::Search::HSP::WABAHSP->new(); Function: Builds a new Bio::Search::HSP::WABAHSP object Returns : Bio::Search::HSP::WABAHSP Args : -hmmstate_seq => the string representing the state output from WABA =cut sub new { my($class,@args) = @_; # gotta do some preprocessing before we send the arguments to the superclass my ($len,$qs,$hs) = Bio::Root::RootI->_rearrange([qw(HSP_LENGTH QUERY_SEQ HIT_SEQ)],@args); if( $len != length($qs) ) { Bio::Root::RootI->warn("HSP_LENGTH must equal length of query_seq string, using value from QUERY_SEQ\n"); $len = length($qs); } my( $homol_seq,$gapct,$identical) = ('',0,0); for(my $i=0;$i<$len;$i++) { my $q = substr($qs,$i,1); my $h = substr($hs,$i,1); if( $q eq '-' || $h eq '-' ) { $homol_seq .= ' '; $gapct ++; } elsif( $q eq $h ) { $homol_seq .= '|'; $identical++; } else { $homol_seq .= ' '; } } my $self = $class->SUPER::new('-conserved' => $identical, '-identical' => $identical, '-gaps' => $gapct, '-homology_seq' => $homol_seq, @args); my ($hmmst) = $self->_rearrange([qw(HMMSTATE_SEQ)],@args); defined $hmmst && $self->hmmstate_string($hmmst); $self->add_tag_value('Target' , join(" ","Sequence:".$self->hit->seq_id, $self->hit->start, $self->hit->end)); return $self; } =head2 hmmstate_string Title : hmmstate_string Usage : my $hmmseq = $wabahsp->hmmstate_string(); Function: Get/Set the WABA HMM stateseq Returns : string Args : [optional] string =cut sub hmmstate_string{ my ($self,$val) = @_; if( defined $val ) { $self->{'_hmmstate_string'} = $val; } return $self->{'_hmmstate_string'}; } =head2 homology_string Title : homolgy_string Usage : my $homology_str = $hsp->homology_string(); Function: Homology string must be calculated for a WABA HSP so we can do so here and cache the result so it is only done once Returns : string Args : none =cut sub homology_string{ my ($self) = @_; return ''; } 1; BioPerl-1.6.923/Bio/Search/Iteration000755000765000024 012254227337 17162 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Search/Iteration/GenericIteration.pm000444000765000024 5201212254227313 23122 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Iteration::GenericIteration # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # Copyright Steve Chervitz # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # TODO: Consider calling this BlastIteration (strongly) and maybe simplifying IterationI. =head1 NAME Bio::Search::Iteration::GenericIteration - A generic implementation of the Bio::Search::Iteration::IterationI interface. =head1 SYNOPSIS use Bio::Search::Iteration::GenericIteration; my $it = Bio::Search::GenericIteration->new( -number => 1, -converged => 0, -newhits_unclassified => [@newhits_unclass], -newhits_below => [@newhits_below_threshold], -newhits_not_below => [@newhits_not_below_threshold], -oldhits_below => [@oldhits_below_threshold], -oldhits_newly_below => [@oldhits_newly_below_threshold], -oldhits_not_below => [@oldhits_not_below_threshold], ); # TODO: Describe how to configure a SearchIO stream so that it generates # GenericIteration objects. =head1 DESCRIPTION This module acts as a container for Bio::Search::Hit::HitI objects, allowing a Search::Result::ResultI object to partition its hits based on which iteration the hit occurred in (e.g., a PSI-BLAST round). Unless you're writing a parser, you won't ever need to create a GenericIteration or any other IterationI-implementing object. If you use the SearchIO system, IterationI objects are created automatically from a SearchIO stream which returns Bio::Search::Result::ResultI objects and you get the IterationI objects via the ResultI API. For documentation on what you can do with GenericIteration (and other IterationI objects), please see the API documentation in L. Bio::Search::Iteration::GenericIteration is similar in spirit to the deprecated Bio::Tools::BPlite::Iteration modules in bioperl releases prior to 1.6, except that Bio::Search::Iteration::GenericIteration is a pure container, without any parsing functionality as is in Bio::Tools::BPlite::Iteration. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Steve Chervitz Email sac@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Iteration::GenericIteration; use strict; use base qw(Bio::Root::Root Bio::Search::Iteration::IterationI); =head2 new Title : new Usage : my $obj = Bio::Search::Iteration->new(%args); Function: Builds a new Bio::Search::Iteration object Returns : Bio::Search::Iteration::GenericIteration object Args : -number => integer for the number of this iteration (required) -converged => boolean value whether or not the iteration converged -newhits_unclassified => array reference to hits that were not found in a previous iteration for the iteration and have not been classified with regard to the inclusion threshold # The following are only used for PSI-BLAST reports: -newhits_below => array reference to hits were not found in a previous iteration and are below the inclusion threshold. -newhits_not_below => array reference to hits that were not found in a previous iteration below threshold that and are not below the inclusion threshold threshold. -oldhits_below => array reference to hits that were found in a previous iteration below inclusion threshold and are still below threshold in the current iteration. -oldhits_newly_below => array reference to hits that were found in a previous iteration above threshold but are below threshold in the current iteration. -oldhits_not_below => array reference to hits that were found in a previous iteration above threshold that and are still above the inclusion threshold threshold. -hit_factory => Bio::Factory::ObjectFactoryI capable of making Bio::Search::Hit::HitI objects =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($number, $newhits_unclassified, $newhits_below, $newhits_not_below, $oldhits_below, $oldhits_newly_below, $oldhits_not_below, $converged, $h_f) = $self->_rearrange([qw(NUMBER NEWHITS_UNCLASSIFIED NEWHITS_BELOW NEWHITS_NOT_BELOW OLDHITS_BELOW OLDHITS_NEWLY_BELOW OLDHITS_NOT_BELOW CONVERGED HIT_FACTORY )], @args); if( ! defined $number ) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Iteration number not specified."); } else { $self->number($number); } defined $converged && $self->converged($converged); # TODO: Performance optimization test calling add_hit() vs. simple assignment: # push @{$self->{'_hits_new'}}, @{$newhits}; # vs. # foreach(@{$newhits_below}) {$self->add_hit(-hit=>$_, -old=>0, -below=>1);} if(defined $newhits_unclassified ) { if( ref($newhits_unclassified) =~ /ARRAY/i) { push @{$self->{'_newhits_unclassified'}}, @{$newhits_unclassified}; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Parameter NEWHITS is not an array ref: $newhits_unclassified"); } } else { $self->{'_newhits_unclassified'} = []; } if(defined $newhits_below ) { if( ref($newhits_below) =~ /ARRAY/i) { push @{$self->{'_newhits_below_threshold'}}, @{$newhits_below}; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Parameter NEWHITS_BELOW is not an array ref: $newhits_below"); } } else { $self->{'_newhits_below_threshold'} = []; } if(defined $newhits_not_below ) { if( ref($newhits_not_below) =~ /ARRAY/i) { push @{$self->{'_newhits_not_below_threshold'}}, @{$newhits_not_below}; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Parameter NEWHITS_NOT_BELOW is not an array ref: $newhits_not_below"); } } else { $self->{'_newhits_not_below_threshold'} = []; } if(defined $oldhits_below ) { if( ref($oldhits_below) =~ /ARRAY/i) { push @{$self->{'_oldhits_below_threshold'}}, @{$oldhits_below}; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Parameter OLDHITS_BELOW is not an array ref: $oldhits_below"); } } else { $self->{'_oldhits_below_threshold'} = []; } if(defined $oldhits_newly_below ) { if( ref($oldhits_newly_below) =~ /ARRAY/i) { push @{$self->{'_oldhits_newly_below_threshold'}}, @{$oldhits_newly_below}; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Parameter OLDHITS_NEWLY_BELOW is not an array ref: $oldhits_newly_below"); } } else { $self->{'_oldhits_newly_below_threshold'} = []; } if(defined $oldhits_not_below ) { if( ref($oldhits_not_below) =~ /ARRAY/i) { push @{$self->{'_oldhits_not_below_threshold'}}, @{$oldhits_not_below}; } else { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Parameter OLDHITS_NOT_BELOW is not an array ref: $oldhits_not_below"); } } else { $self->{'_oldhits_not_below_threshold'} = []; } $self->hit_factory($h_f) if $h_f; return $self; } =head2 number See documentation in Bio::Search::Iteration::IterationI. =cut sub number { my ($self,$value) = @_; my $previous = $self->{'_number'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_number'} = $value; } return $previous; } =head2 converged See documentation in Bio::Search::Iteration::IterationI. =cut sub converged { my ($self,$value) = @_; my $previous = $self->{'_converged'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_converged'} = $value; } return $previous; } =head2 hit_factory Title : hit_factory Usage : $hit->hit_factory($hit_factory) Function: Get/set the factory used to build HitI objects if necessary. Returns : Bio::Factory::ObjectFactoryI Args : Bio::Factory::ObjectFactoryI =cut sub hit_factory { my $self = shift; if (@_) { $self->{_hit_factory} = shift } return $self->{_hit_factory} || return; } =head2 next_hit This iterates through all old hits as returned by L followed by all new hits as returned by L. For more documentation see L. =cut sub next_hit { my ($self) = @_; unless($self->{'_hit_queue_started'}) { $self->{'_hit_queue'} = ( [$self->oldhits(), $self->newhits()] ); $self->{'_hit_queue_started'} = 1; } return shift @{$self->{'_hit_queue'}}; } =head2 next_hit_new See documentation in L. =cut sub next_hit_new { my ($self) = @_; unless($self->{'_hit_queue_new_started'}) { $self->{'_hit_queue_new'} = [$self->newhits()]; $self->{'_hit_queue_new_started'} = 1; } return shift @{$self->{'_hit_queue_new'}}; } =head2 next_hit_old See documentation in L. =cut sub next_hit_old { my ($self,$found_again) = @_; unless($self->{'_hit_queue_old_started'}) { $self->{'_hit_queue_old'} = [$self->oldhits()]; $self->{'_hit_queue_old_started'} = 1; } return shift @{$self->{'_hit_queue_old'}}; } =head2 rewind Title : rewind Usage : $iteration->rewind; Function: Allow one to reset the Hit iterators to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind { my $self = shift; $self->{'_hit_queue_started'} = 0; $self->{'_hit_queue_new_started'} = 0; $self->{'_hit_queue_old_started'} = 0; foreach ($self->hits) { $_->rewind; } } =head2 num_hits See documentation in L. =cut sub num_hits { my $self = shift; return $self->num_hits_old + $self->num_hits_new; } =head2 num_hits_new See documentation in L. =cut sub num_hits_new { my $self = shift; return scalar $self->newhits(); } =head2 num_hits_old See documentation in L. =cut sub num_hits_old { my ($self,$found_again) = @_; return scalar $self->oldhits(); } =head2 add_hit See documentation in L. =cut sub add_hit { my ($self,@args) = @_; my( $hit, $old, $below, $newly_below ) = $self->_rearrange([qw(HIT OLD BELOW_THRESHOLD NEWLY_BELOW )], @args); my $count = 0; unless( ref($hit) eq 'HASH' || $hit->isa('Bio::Search::Hit::HitI') ) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Passed in " .ref($hit). " as a Hit which is not a Bio::Search::Hit::HitI."); } if($old) { if ($newly_below) { push @{$self->{'_oldhits_newly_below_threshold'}}, $hit; $count = scalar @{$self->{'_oldhits_newly_below_threshold'}}; } elsif ($below) { push @{$self->{'_oldhits_below_threshold'}}, $hit; $count = scalar @{$self->{'_oldhits_below_threshold'}}; } else { push @{$self->{'_oldhits_not_below_threshold'}}, $hit; $count = scalar @{$self->{'_oldhits_not_below_threshold'}}; } } elsif (defined $old) { # -old is defined but false, so this is a new PSI-BLAST hit if ($below) { push @{$self->{'_newhits_below_threshold'}}, $hit; $count = scalar @{$self->{'_newhits_below_threshold'}}; } elsif (defined $below) { push @{$self->{'_newhits_not_below_threshold'}}, $hit; $count = scalar @{$self->{'_newhits_not_below_threshold'}}; } else { # -below not defined, PSI-BLAST threshold may not be known push @{$self->{'_newhits_unclassified'}}, $hit; $count = scalar @{$self->{'_newhits_unclassified'}}; } } else { # -old not defined, so it's non-PSI-BLAST push @{$self->{'_newhits_unclassified'}}, $hit; $count = scalar @{$self->{'_newhits_unclassified'}}; } return $count; } =head2 hits See Documentation in InterfaceI. =cut sub hits { my $self = shift; # print STDERR "Called GenericIteration::hits()\n"; my @new = $self->newhits; my @old = $self->oldhits; return ( @new, @old ); } =head2 newhits Returns a list containing all newhits in this order: newhits_below_threshold newhits_not_below_threshold newhits_unclassified See more documentation in InterfaceI. =cut sub newhits { my $self = shift; my @hits = $self->newhits_below_threshold; push @hits, $self->newhits_not_below_threshold; push @hits, $self->newhits_unclassified; return @hits; } =head2 newhits_below_threshold See documentation in L. =cut sub newhits_below_threshold { my $self = shift; if (ref $self->{'_newhits_below_threshold'} ) { my $factory = $self->hit_factory || return @{$self->{'_newhits_below_threshold'}}; for (0..$#{$self->{'_newhits_below_threshold'}}) { ref(${$self->{'_newhits_below_threshold'}}[$_]) eq 'HASH' || next; ${$self->{'_newhits_below_threshold'}}[$_] = $factory->create_object(%{${$self->{'_newhits_below_threshold'}}[$_]}); } return @{$self->{'_newhits_below_threshold'}}; } return; } =head2 newhits_not_below_threshold See documentation in L. =cut sub newhits_not_below_threshold { my $self = shift; if (ref $self->{'_newhits_not_below_threshold'} ) { my $factory = $self->hit_factory || return @{$self->{'_newhits_not_below_threshold'}}; for (0..$#{$self->{'_newhits_not_below_threshold'}}) { ref(${$self->{'_newhits_not_below_threshold'}}[$_]) eq 'HASH' || next; ${$self->{'_newhits_not_below_threshold'}}[$_] = $factory->create_object(%{${$self->{'_newhits_not_below_threshold'}}[$_]}); } return @{$self->{'_newhits_not_below_threshold'}}; } return; } =head2 newhits_unclassified Title : newhits_unclassified Usage : foreach( $iteration->hits_unclassified ) {...} Function: Gets all newhits that have not been partitioned into sets relative to the inclusion threshold. Returns : Array of Bio::Search::Hit::HitI objects. Args : none =cut sub newhits_unclassified { my $self = shift; if (ref $self->{'_newhits_unclassified'} ) { my $factory = $self->hit_factory || return @{$self->{'_newhits_unclassified'}}; for (0..$#{$self->{'_newhits_unclassified'}}) { ref(${$self->{'_newhits_unclassified'}}[$_]) eq 'HASH' || next; ${$self->{'_newhits_unclassified'}}[$_] = $factory->create_object(%{${$self->{'_newhits_unclassified'}}[$_]}); } return @{$self->{'_newhits_unclassified'}}; } return; } =head2 oldhits Returns a list containing all oldhits in this order: oldhits_below_threshold oldhits_newly_below_threshold oldhits_not_below_threshold See more documentation in InterfaceI. =cut sub oldhits { my $self = shift; my @hits = $self->oldhits_below_threshold; push @hits, $self->oldhits_newly_below_threshold; push @hits, $self->oldhits_not_below_threshold; return @hits; } =head2 oldhits_below_threshold See documentation in L. =cut sub oldhits_below_threshold { my $self = shift; if (ref $self->{'_oldhits_below_threshold'} ) { my $factory = $self->hit_factory || return @{$self->{'_oldhits_below_threshold'}}; for (0..$#{$self->{'_oldhits_below_threshold'}}) { ref(${$self->{'_oldhits_below_threshold'}}[$_]) eq 'HASH' || next; ${$self->{'_oldhits_below_threshold'}}[$_] = $factory->create_object(%{${$self->{'_oldhits_below_threshold'}}[$_]}); } return @{$self->{'_oldhits_below_threshold'}}; } return; } =head2 oldhits_newly_below_threshold See documentation in L. =cut sub oldhits_newly_below_threshold { my $self = shift; if (ref $self->{'_oldhits_newly_below_threshold'} ) { my $factory = $self->hit_factory || return @{$self->{'_oldhits_newly_below_threshold'}}; for (0..$#{$self->{'_oldhits_newly_below_threshold'}}) { ref(${$self->{'_oldhits_newly_below_threshold'}}[$_]) eq 'HASH' || next; ${$self->{'_oldhits_newly_below_threshold'}}[$_] = $factory->create_object(%{${$self->{'_oldhits_newly_below_threshold'}}[$_]}); } return @{$self->{'_oldhits_newly_below_threshold'}}; } return; } =head2 oldhits_not_below_threshold See documentation in L. =cut sub oldhits_not_below_threshold { my $self = shift; if (ref $self->{'_oldhits_not_below_threshold'} ) { my $factory = $self->hit_factory || return @{$self->{'_oldhits_not_below_threshold'}}; for (0..$#{$self->{'_oldhits_not_below_threshold'}}) { ref(${$self->{'_oldhits_not_below_threshold'}}[$_]) eq 'HASH' || next; ${$self->{'_oldhits_not_below_threshold'}}[$_] = $factory->create_object(%{${$self->{'_oldhits_not_below_threshold'}}[$_]}); } return @{$self->{'_oldhits_not_below_threshold'}}; } return; } =head2 hits_below_threshold See documentation in L. =cut sub hits_below_threshold { my $self = shift; my @hits = $self->newhits_below_threshold; push @hits, $self->oldhits_newly_below_threshold; return @hits; } =head2 get_hit See documentation in L. To free up the memory used by the get_hit() functionality, call free_hit_lookup(). This functionality might be useful at the Result level, too. BlastResult::get_hit() would return a list of HitI objects for hits that occur in multiple iterations. =cut sub get_hit { my ($self,$name) = @_; $self->_create_hit_lookup() unless defined $self->{'_hit_lookup'}; return $self->{'_hit_lookup'}->{"\U$name"}; } # Internal method. sub _create_hit_lookup { my $self = shift; foreach ($self->hits) { my $hname = $_->name; $self->{'_hit_lookup'}->{"\U$hname"} = $_; } } =head2 free_hit_lookup Purpose : Frees up the memory used by the get_hit() functionality. For the memory-conscious. =cut sub free_hit_lookup { my $self = shift; undef $self->{'_hit_lookup'}; } 1; BioPerl-1.6.923/Bio/Search/Iteration/IterationI.pm000444000765000024 5303112254227337 21746 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::Iteration::IterationI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::Search::Iteration::IterationI - Abstract interface to an iteration from an iterated search result, such as PSI-BLAST. =head1 SYNOPSIS # Bio::Search::Iteration::IterationI objects cannot be # instantiated since this module defines a pure interface. # Given an object that implements the # Bio::Search::Iteration::IterationI interface, # you can do the following things with it: # First, open up a SearchIO stream use Bio::SearchIO; my $file = shift or die "Usage: $0 \n"; my $in = Bio::SearchIO->new(-format => 'blast', -file => $file # comment out this line to read STDIN ); # Iterate over all results in the input stream while (my $result = $in->next_result) { printf "Result #%d: %s\n", $in->result_count, $result->to_string; printf "Total Iterations: %d\n", $result->num_iterations(); # Iterate over all iterations and process old and new hits # separately. while( my $it = $result->next_iteration) { printf "\nIteration %d\n", $it->number; printf "Converged: %d\n", $it->converged; # Print out the hits not found in previous iteration printf "New hits: %d\n", $it->num_hits_new; while( my $hit = $it->next_hit_new ) { printf " %s, Expect=%g\n", $hit->name, $hit->expect; } # Print out the hits found in previous iteration printf "Old hits: %d\n", $it->num_hits_old; while( my $hit = $it->next_hit_old ) { printf " %s, Expect=%g\n", $hit->name, $hit->expect; } } printf "%s\n\n", '-' x 50; } printf "Total Reports processed: %d: %s\n", $in->result_count; __END__ # NOTE: The following functionality is just proposed # (does not yet exist but might, given sufficient hew and cry): # Zero-in on the new hits found in last iteration. # By default, iteration() returns the last one. my $last_iteration = $result->iteration(); while( my $hit = $last_iteration->next_hit) { # Do something with new hit... } # Get the first iteration my $first_iteration = $result->iteration(1); =head1 DESCRIPTION Bio::Search::Result::ResultI objects are data structures containing the results from the execution of a search algorithm. As such, it may contain various algorithm specific information as well as details of the execution, but will contain a few fundamental elements, including the ability to return Bio::Search::Hit::HitI objects. =head2 Classification of Hits Within a given iteration, the hits can be classified into a number of useful subsets based on whether or not the hit appeard in a previous iteration and whether or not the hit is below the threshold E-value for inclusion in the score matrix model. All hits (A) _______________|_________________ | | New hits Old hits (B) (C) _________|________ _______|_________ | | | | Below Above Below Above threshold threshold threshold threshold (D) (E) (F) (G) _________|___________ | | Occurred in a Occurred in a previous iteration previous iteration below threshold above threshold (H) (I) Notes: The term I in the diagram and descriptions below refer to this inclusion threshold. I actually means I. The IterationI interface defines a number of methods for extracting these subsets of hits. =over 4 =item * newhits_below_threshold() [subset D] Hits that did not appear in a previous iteration and are below threshold in the current iteration. =item * newhits_not_below_threshold() [subset E] Hits that did not appear in a previous iteration and are not below threshold in the current iteration. =item * newhits() [subset B] All newly found hits, below and above the inclusion threshold. This is the union of newhits_below_threshold() + newhits_not_below_threshold() [subset D + subset E]. =item * oldhits_below_threshold() [subset H] Hits that appeared in a previous iteration below threshold and are still below threshold in the current iteration. =item * oldhits_newly_below_threshold() [subset I] Hits that appeared in a previous iteration above threshold but are below threshold in the current iteration. (Not applicable to the first iteration.) =item * oldhits_not_below_threshold() [subset G] Hits that appeared in a previous iteration not below threshold and are still not below threshold in the current iteration. =item * oldhits() [subset C] All hits that occured in a previous iteration, whether below or above threshold in the current iteration. Union of oldhits_below_threshold() + oldhits_newly_below_threshold() + oldhits_not_below_threshold() [subset H + subset I + subset G]. (Not applicable to the first iteration.) =item * hits_below_threshold() [subset D + subset F] All hits, old and new, that are below the inclusion threshold in this iteration. This is the union of newhits_below_threshold() + oldhits_below_threshold() + oldhits_newly_below_threshold() [subset D + subset H + subset I]. =item * hits() [subset A] The union of newhits() and oldhits() [subset B + subset C]. =back For the first iteration, the methods L, L, L, and oldhits_not_below_threshold() will return empty lists. Iterator and numbers-of-hit methods are provided for subsets A, B, and C: =over 4 =item * next_hit_new(), num_hits_new() [subset B] =item * next_hit_old(), num_hits_old() [subset C] =item * next_hit(), num_hits() [subset A] =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 2003 Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::Search::Iteration::IterationI; use strict; use base qw(Bio::Root::RootI); =head2 number Title : number Usage : $it_number = $iteration->number(); Purpose : returns the number of the iteration (a.k.a "round") within the Result. Returns : integer Args : [optional] integer to set the number of the iteration =cut sub number { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 converged Title : converged Usage : $it_converged = $iteration->converged(); Purpose : Indicates whether or not the iteration has converged Returns : boolean Args : [optional] boolean value to set the converged of the iteration =cut sub converged { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 next_hit Title : next_hit Usage : while( $hit = $iteration->next_hit( [$found_again]) ) { ... } Purpose : Iterates through all of the HitI objects including new hits and old hits found in a previous iteration and both below and above the inclusion threshold. Corresponds to subset A in the "Classification of Hits" documentation section of this module. Returns : A Bio::Search::Hit::HitI object or undef if there are no more. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L next_hit() iterates through all hits, including the new ones for this iteration and those found in previous iterations. You can interrogate each hit using L to determine whether it is new or old. To get just the new hits, use L. To get just the old hits, use L. =cut sub next_hit { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 next_hit_new Title : next_hit_new Usage : while( $hit = $iteration->next_hit_new() ) { ... } Purpose : Iterates through all newly found hits (did not occur in a previous iteration) and are either below or above the inclusion threshold. Corresponds to subset B in the "Classification of Hits" documentation section of this module. Returns : A Bio::Search::Hit::HitI object or undef if there are no more. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L, L =cut sub next_hit_new { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 next_hit_old Title : next_hit_old Usage : while( $hit = $iteration->next_hit_old() ) { ... } Purpose : Iterates through the Hit objects representing just the hits that have been found in a previous iteration, whether below or above the inclusion threshold. Corresponds to subset C in the "Classification of Hits" documentation section of this module. Returns : A Bio::Search::Hit::HitI object or undef if there are no more. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L, L =cut sub next_hit_old { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 num_hits Title : num_hits Usage : my $hitcount_total = $iteration->num_hits Purpose : Returns the total number of hits for this query result, including new and old below and above inclusion threshold. Returns : integer Args : none See Also: L, L, L =cut sub num_hits { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 num_hits_new Title : num_hits_new Usage : my $hitcount_new = $result->num_hits_new; : my $hitcount_new_below_thresh = $result->num_hits_new( 1 ); Purpose : Returns the number of new hits in this iteration that were not found in a previous iteration and are either below or above the the inclusion threshold. Corresponds to subset B in the "Classification of Hits" documentation section of this module. Returns : integer Args : (optional) boolean, true if you want to get a count of just the new hits that are below the inclusion threshold. See Also: L, L, L =cut sub num_hits_new { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 num_hits_old Title : num_hits_old Usage : my $hitcount_old = $result->num_hits_old; : my $hitcount_old_below_thresh = $result->num_hits_old( 1 ); Purpose : Returns the number of new hits in this iteration that were found in a previous iteration and are either below or above the the inclusion threshold. Corresponds to subset C in the "Classification of Hits" documentation section of this module. Returns : integer Args : (optional) boolean, true if you want to get a count of just the old hits that are below the inclusion threshold. See Also: L, L, L =cut sub num_hits_old { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 hits Title : hits Usage : foreach( $obj->hits() ) { ... }; Purpose : Provides access to all hits, both new and old, and either below or above the inclusion threshold. Corresponds to subset A in the "Classification of Hits" documentation section of this module. Returns : An array containing all HitI objects. Hits will be ordered according to their occurrence in the report unless otherwise specified. Args : none See Also: L, L, L =cut sub hits { shift->throw_not_implemented(); } =head2 newhits Title : newhits Usage : foreach( $obj->newhits() ) { ... }; Purpose : Provides access to hits that were not found in a previous iteration and may be either below or above the inclusion threshold. Corresponds to subset B in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be ordered according to their occurrence in the report unless otherwise specified. Args : none See Also: L, L, L + L, L =cut sub newhits { shift->throw_not_implemented(); } =head2 oldhits Title : oldhits Usage : foreach( $obj->oldhits() ) { ... }; Purpose : Provides access to hits that were found in a previous iteration and are either below or above the inclusion threshold in the current iteration. Corresponds to subset C in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be ordered according to their occurrence in the report unless otherwise specified. Args : none See Also: L, L, L, L, L, L =cut sub oldhits { shift->throw_not_implemented(); } =head2 newhits_below_threshold Title : newhits_below_threshold Usage : foreach( $obj->newhits_below_threshold() ) { ... }; Purpose : Provides access to hits that did not appear in a previous iteration and are below threshold. Corresponds to subset D in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L, L =cut sub newhits_below_threshold { shift->throw_not_implemented(); } =head2 oldhits_below_threshold Title : oldhits_below_threshold Usage : foreach( $obj->oldhits_below_threshold() ) { ... }; Purpose : Provides access to hits that appeared in a previous iteration below inclusion threshold and are still below threshold. Corresponds to subset H in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L, L =cut sub oldhits_below_threshold { shift->throw_not_implemented(); } =head2 oldhits_newly_below_threshold Title : oldhits_newly_below_threshold Usage : foreach( $obj->oldhits_newly_below_threshold() ) { ... }; Purpose : Provides access to hits that appeared in a previous iteration above threshold but are below threshold in the current iteration. Not applicable to the first iteration. Corresponds to subset I in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L =cut sub oldhits_newly_below_threshold { shift->throw_not_implemented(); } =head2 oldhits_not_below_threshold Title : oldhits_not_below_threshold Usage : foreach( $obj->oldhits_not_below_threshold() ) { ... }; Purpose : Provides access to hits that appeared in a previous iteration not below threshold and are still not below threshold. Corresponds to subset G in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L =cut sub oldhits_not_below_threshold { shift->throw_not_implemented(); } =head2 newhits_not_below_threshold Title : newhits_not_below_threshold Usage : foreach( $obj->newhits_not_below_threshold() ) { ... }; Purpose : Provides access to hits that did not appear in a previous iteration and are not below threshold in the current iteration. Corresponds to subset E in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L =cut sub newhits_not_below_threshold { shift->throw_not_implemented(); } =head2 hits_below_threshold Title : hits_below_threshold Usage : foreach( $obj->hits_below_threshold() ) { ... }; Purpose : Provides access to all hits, old and new, that are below the inclusion threshold. Corresponds to the union of subset D and subset F in the "Classification of Hits" documentation section of this module. Returns : An array containing Bio::Search::Hit::HitI objects. Hits will be returned in the order in which they occur in the report unless otherwise specified. Args : none See Also: L, L, L, L =cut sub hits_below_threshold { shift->throw_not_implemented(); } =head2 add_hit Title : add_hit Usage : $report->add_hit(-hit =>$hit_obj, -old =>$boolean, -below_threshold =>$boolean, -newly_below =>$boolean ) Purpose : Adds a HitI to the stored list of hits Returns : Number of HitI currently stored for the class of the added hit. Args : Tagged values, the only required one is -hit. All others are used only for PSI-BLAST reports. -hit => Bio::Search::Hit::HitI object -old => boolean, true indicates that the hit was found in a previous iteration. Default=false. -below_threshold => boolean, true indicates that the hit is below the inclusion threshold. -newly_below => boolean, true indicates that the hit is below the inclusion threshold in this iteration but was above the inclusion threshold in a previous iteration. Only appropriate for old hits. Default=false. Throws : Bio::Root::BadParameter if the hit is not a Bio::Search::Hit::HitI. Bio::Root::BadParameter if -old=>false and -newly_below=>true. =cut sub add_hit { shift->throw_not_implemented } =head2 get_hit Title : get_hit Usage : $hit = $report->get_hit( $hit_name ) Purpose : Gets a HitI object given its name if a hit with this name exists within this Iteration. Returns : Bio::Search::Hit::HitI object or undef if there is no such hit. Args : $hit_name = string containing name of the hit Throws : n/a The name string must be the same as that returned by Bio::Search::Hit::HitI::name(). The lookup should be case-insensitive. =cut sub get_hit { shift->throw_not_implemented } 1; BioPerl-1.6.923/Bio/Search/Result000755000765000024 012254227340 16474 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Search/Result/BlastPullResult.pm000444000765000024 2700412254227331 22313 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::BlastPullResult # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::BlastPullResult - A parser and result object for BLASTN results =head1 SYNOPSIS # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'blast_pull', -file => 'result.blast'); while (my $result = $in->next_result) { print $result->query_name, " ", $result->algorithm, " ", $result->num_hits(), " hits\n"; } =head1 DESCRIPTION This object implements a parser for NCBI BLASTN result output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::BlastPullResult; use strict; use Bio::Search::Hit::BlastPullHit; use base qw(Bio::Root::Root Bio::Search::Result::PullResultI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::Result::hmmpfam->new(); Function: Builds a new Bio::SearchIO::Result::hmmpfam object Returns : Bio::SearchIO::Result::hmmpfam Args : -chunk => [Bio::Root::IO, $start, $end] (required if no -parent) -parent => Bio::PullParserI object (required if no -chunk) -parameters => hash ref of search parameters (key => value), optional -statistics => hash ref of search statistics (key => value), optional where the array ref provided to -chunk contains an IO object for a filehandle to something representing the raw data of the result, and $start and $end define the tell() position within the filehandle that the result data starts and ends (optional; defaults to start and end of the entire thing described by the filehandle) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_setup(@args); foreach my $field (qw( header hit_table hsp_table alignments next_model models query_length stats_and_params)) { $self->_fields->{$field} = undef; } $self->_dependencies( { ( query_name => 'header', query_accession => 'header', query_description => 'header', query_length => 'header', hit_table => 'header', num_hits => 'hit_table', no_hits_found => 'hit_table' ) } ); return $self; } # # PullParserI discovery methods so we can answer all ResultI questions # sub _discover_header { my $self = shift; $self->_chunk_seek(0); my $header = $self->_get_chunk_by_end("Value\n"); if (!$header) { $header = $self->_get_chunk_by_end("***** No hits found ******\n"); $self->{_no_hits_found} = 1; } $self->throw("Invalid header returned") unless $header; $self->{_after_header} = $self->_chunk_tell; ($self->_fields->{query_name}) = $header =~ /^\s*(\S+)/; $self->_fields->{query_accession} = ''; $self->_fields->{query_description} = ''; if ($header =~ /^Length=(\d+)/m) { $self->_fields->{query_length} = $1; } elsif ($header =~ /\((\d+) letters\)/) { # older form? $self->_fields->{query_length} = $1; if ($header =~ /^\s*\(\d+ letters/) { # there wasn't a query sequence name $self->_fields->{query_name} = ''; } } $self->_fields->{header} = 1; } sub _discover_hit_table { my $self = shift; $self->_chunk_seek($self->{_after_header}); my $table = $self->_get_chunk_by_end("\n>"); if (!$table && !$self->{_no_hits_found}) { # no alignments, presumably; hit table comprises the remainder of this # result while (my $line = $self->_get_chunk_by_nol(1)) { $table .= $line; } } $table ||= ''; $self->{_after_hit_table} = $self->_chunk_tell; my $evalue_cutoff = $self->get_field('evalue_cutoff'); undef $evalue_cutoff if $evalue_cutoff eq '[unset]'; my $score_cutoff = $self->get_field('score_cutoff'); undef $score_cutoff if $score_cutoff eq '[unset]'; my @table; my $no_hit = 1; while ($table =~ /^(\S+)\s+(\S.*?)?\s+(\S+)\s+([\de]\S*)\s*\n/gm) { $no_hit = 0; my ($name, $desc, $score, $evalue) = ($1, $2, $3, $4); $desc ||= ''; if ($evalue =~ /^e/) { $evalue = '1'.$evalue; } next if ($evalue_cutoff && $evalue > $evalue_cutoff); next if ($score_cutoff && $score < $score_cutoff); push(@table, [$name, $desc, $score, $evalue]); } $self->_fields->{hit_table} = \@table; $self->{_next_hit_index} = @table > 0 ? 0 : -1; $self->_fields->{no_hits_found} = $no_hit; $self->_fields->{num_hits} = @table; } sub _discover_next_hit { my $self = shift; my $hit_table = $self->get_field('hit_table'); return if $self->{_next_hit_index} == -1; my $hit_row = ${$hit_table}[$self->{_next_hit_index}]; $self->_chunk_seek($self->{_end_of_previous_hit} || $self->{_after_hit_table}); my ($start, $end) = $self->_find_chunk_by_end("\n>"); unless ($end) { $start = $self->{_end_of_previous_hit} || $self->{_after_hit_table}; $end = $self->_chunk_true_end; } else { $end += $self->_chunk_true_start; } $start += $self->_chunk_true_start; $self->{_end_of_previous_hit} = $end - $self->_chunk_true_start; #*** needs to inherit piped_behaviour, and we need to deal with _sequential # ourselves $self->_fields->{next_hit} = Bio::Search::Hit::BlastPullHit->new(-parent => $self, -chunk => [$self->chunk, $start, $end], -hit_data => $hit_row); $self->{_next_hit_index}++; if ($self->{_next_hit_index} > $#{$hit_table}) { $self->{_next_hit_index} = -1; } } sub _discover_stats_and_params { my $self = shift; $self->_chunk_seek(0); my ($start, $end) = $self->_find_chunk_by_end("\n Database: "); $self->_chunk_seek($end); my $gapped = 0; while ($self->_get_chunk_by_nol(1)) { if (/Number of letters in database:\s+(\S+)/) { my $stat = $1; $stat =~ s/,//g; $self->add_statistic('dbletters', $stat); } elsif (/Number of sequences in database:\s+(\S+)/) { my $stat = $1; $stat =~ s/,//g; $self->add_statistic('dbentries', $stat); } elsif (/^Lambda/) { my $line = $self->_get_chunk_by_nol(1); $line =~ /\s+(\S+)\s+(\S+)\s+(\S+)/; $self->add_statistic($gapped ? 'lambda_gapped' : 'lambda', $1); $self->add_statistic($gapped ? 'kappa_gapped' : 'kappa', $2); $self->add_statistic($gapped ? 'entropy_gapped' : 'entropy', $3); $gapped = 1; } elsif (/^Matrix: (.+)\n/) { $self->add_parameter('matrix', $1); } elsif (/^Gap Penalties: Existence: (\d+), Extension: (\d+)/) { $self->add_parameter('gapopen', $1); $self->add_parameter('gapext', $2); } elsif (/^Number of Hits to DB: (\d+)/) { $self->add_statistic('Hits_to_DB', $1); } elsif (/^Number of extensions: (\d+)/) { $self->add_statistic('num_extensions', $1); } elsif (/^Number of successful extensions: (\d+)/) { $self->add_statistic('num_successful_extensions', $1); } elsif (/^Number of sequences better than (\S+):/) { $self->add_parameter('expect', $1); } elsif (/^[Ll]ength of query: (\d+)/) { $self->add_statistic('querylength', $1); } elsif (/^[Ee]ffective HSP length: (\d+)/) { $self->add_statistic('effective_hsplength', $1); } elsif (/^[Ee]ffective length of database: (\d+)/) { $self->add_statistic('effectivedblength', $1); } elsif (/^[Ee]ffective search space: (\d+)/) { $self->add_statistic('effectivespace', $1); } elsif (/^[Ee]ffective search space used: (\d+)/) { $self->add_statistic('effectivespaceused', $1); } elsif (/^([TAXS]\d?): (\d+)(?: \((\S+))?/) { $self->add_statistic($1, $2); $self->add_statistic($1.'_bits', $3) if $3; } } $self->_fields->{stats_and_params} = 1; } =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none =cut sub next_hit { my $self = shift; my $hit = $self->get_field('next_hit'); undef $self->_fields->{next_hit}; return $hit; } =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the HitI objects contained within this Result Returns : Array of Bio::Search::Hit::HitI objects Args : none See Also: L =cut sub hits { my $self = shift; my $old = $self->{_next_hit_index} || 0; $self->rewind; my @hits; while (defined(my $hit = $self->next_hit)) { push(@hits, $hit); } $self->{_next_hit_index} = @hits > 0 ? $old : -1; return @hits; } =head2 sort_hits Title : sort_hits Usage : $result->sort_hits('throw("Not implemented yet"); } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iterator to the beginning, so that next_hit() will subsequently return the first hit and so on. Returns : n/a Args : none =cut sub rewind { my $self = shift; unless ($self->_fields->{hit_table}) { $self->get_field('hit_table'); } $self->{_next_hit_index} = @{$self->_fields->{hit_table}} > 0 ? 0 : -1; } =head2 get_statistic Title : get_statistic Usage : my $gap_ext = $result->get_statistic('kappa') Function: Returns the value for a specific statistic available from this result Returns : string Args : name of statistic (string) =cut sub get_statistic { my $self = shift; $self->get_field('stats_and_params'); return $self->SUPER::get_statistic(@_); } =head2 get_parameter Title : get_parameter Usage : my $gap_ext = $result->get_parameter('gapext') Function: Returns the value for a specific parameter used when running this result Returns : string Args : name of parameter (string) =cut sub get_parameter { my $self = shift; $self->get_field('stats_and_params'); return $self->SUPER::get_parameter(@_); } 1; BioPerl-1.6.923/Bio/Search/Result/BlastResult.pm000444000765000024 3554712254227340 21471 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::BlastResult # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # Copyright Steve Chervitz # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::BlastResult - Blast-specific subclass of Bio::Search::Result::GenericResult =head1 SYNOPSIS # Working with iterations (PSI-BLAST results) $result->next_iteration(); $result->num_iterations(); $result->iteration(); $result->iterations(); # See Bio::Search::Result::GenericResult for information about working with Results. # See L # for details about working with iterations. # TODO: # * Show how to configure a SearchIO stream so that it generates # BlastResult objects. =head1 DESCRIPTION This object is a subclass of Bio::Search::Result::GenericResult and provides some operations that facilitate working with BLAST and PSI-BLAST results. For general information about working with Results, see Bio::Search::Result::GenericResult. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Steve Chervitz Email sac@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::BlastResult; use strict; use Bio::Search::BlastStatistics; use base qw(Bio::Search::Result::GenericResult); =head2 new Title : new Usage : my $obj = Bio::Search::Result::BlastResult->new(); Function: Builds a new Bio::Search::Result::BlastResult object Returns : Bio::Search::Result::BlastResult Args : See Bio::Search::Result::GenericResult(); The following parameters are specific to BlastResult: -iterations => array ref of Bio::Search::Iteration::IterationI objects -inclusion_threshold => e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_iterations'} = []; $self->{'_iteration_index'} = 0; $self->{'_iteration_count'} = 0; my( $iters, $ithresh ) = $self->_rearrange([qw(ITERATIONS INCLUSION_THRESHOLD)],@args); $self->{'_inclusion_threshold'} = $ithresh; # This is a read-only variable if( defined $iters ) { $self->throw("Must define arrayref of Iterations when initializing a $class\n") unless ref($iters) =~ /array/i; foreach my $i ( @{$iters} ) { $self->add_iteration($i); } } else { # This shouldn't get called with the new SearchIO::blast. print STDERR "BlastResult::new(): Not adding iterations.\n"; $self->{'_no_iterations'} = 1; } return $self; } =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the available hits for this Result Returns : Array of L objects Args : none Note : This method overrides L to take into account the possibility of multiple iterations, as occurs in PSI-BLAST reports. If there are multiple iterations, all 'new' hits for all iterations are returned. These are the hits that did not occur in a previous iteration. See Also: L =cut sub hits { my ($self) = shift; if ($self->{'_no_iterations'}) { return $self->SUPER::hits; } my @hits = (); foreach my $it ($self->iterations) { push @hits, $it->hits; } return @hits; } =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none Note : This method overrides L to take into account the possibility of multiple iterations, as occurs in PSI-BLAST reports. If there are multiple iterations, calling next_hit() traverses the all of the hits, old and new, for each iteration, calling next_hit() on each iteration. See Also: L =cut sub next_hit { my ($self,@args) = @_; if ($self->{'_no_iterations'}) { return $self->SUPER::next_hit(@args); } my $iter_index; if (not defined $self->{'_last_hit'}) { $iter_index = $self->{'_iter_index'} = $self->_next_iteration_index; } else { $iter_index = $self->{'_iter_index'}; } return if $iter_index >= scalar @{$self->{'_iterations'}}; my $it = $self->{'_iterations'}->[$iter_index]; my $hit = $self->{'_last_hit'} = $it->next_hit; return defined($hit) ? $hit : $self->next_hit; } =head2 num_hits Title : num_hits Usage : my $hitcount= $result->num_hits Function: returns the number of hits for this query result Returns : integer Args : none Note : This method overrides L to take into account the possibility of multiple iterations, as occurs in PSI-BLAST reports. If there are multiple iterations, calling num_hits() returns the number of 'new' hits for each iteration. These are the hits that did not occur in a previous iteration. See Also: L =cut sub num_hits{ my ($self) = shift; if ($self->{'_no_iterations'}) { return $self->SUPER::num_hits; } if (not defined $self->{'_iterations'}) { $self->throw("Can't get Hits: data not collected."); } return scalar( $self->hits ); } =head2 add_hit Title : add_hit Usage : $report->add_hit($hit) Function: Adds a HitI to the stored list of hits Returns : Number of HitI currently stored Args : Bio::Search::Hit::HitI =cut sub add_hit { my ($self,$hit) = @_; my $iter = $self->iteration; if( $hit->isa('Bio::Search::Hit::HitI') ) { return $iter->add_hit(-hit => $hit); } else { $self->throw("Passed in a " .ref($hit). " as a Iteration which is not a Bio::Search::Hit::HitI."); } return $iter->num_hits; } =head2 add_iteration Title : add_iteration Usage : $report->add_iteration($iteration) Function: Adds a IterationI to the stored list of iterations Returns : Number of IterationI currently stored Args : Bio::Search::Iteration::IterationI =cut sub add_iteration { my ($self,$i) = @_; if( $i->isa('Bio::Search::Iteration::IterationI') ) { push @{$self->{'_iterations'}}, $i; $self->{'_iteration_count'}++; } else { $self->throw("Passed in a " .ref($i). " as a Iteration which is not a Bio::Search::Iteration::IterationI."); } return scalar @{$self->{'_iterations'}}; } =head2 next_iteration Title : next_iteration Usage : while( $it = $result->next_iteration()) { ... } Function: Returns the next Iteration object, representing all hits found within a given PSI-Blast iteration. Returns : a Bio::Search::Iteration::IterationI object or undef if there are no more. Args : none =cut sub next_iteration { my ($self) = @_; unless($self->{'_iter_queue_started'}) { $self->{'_iter_queue'} = [$self->iterations()]; $self->{'_iter_queue_started'} = 1; } return shift @{$self->{'_iter_queue'}}; } =head2 iteration Usage : $iteration = $blast->iteration( $number ); Purpose : Get an IterationI object for the specified iteration in the search result (PSI-BLAST). Returns : Bio::Search::Iteration::IterationI object Throws : Bio::Root::NoSuchThing exception if $number is not within range of the number of iterations in this report. Argument : integer (optional, if not specified get the last iteration) First iteration = 1 =cut sub iteration { my ($self,$num) = @_; $num = scalar @{$self->{'_iterations'}} unless defined $num; unless ($num >= 1 and $num <= scalar $self->{'_iteration_count'}) { $self->throw(-class=>'Bio::Root::NoSuchThing', -text=>"No such iteration number: $num. Valid range=1-$self->{'_iteration_count'}", -value=>$num); } return $self->{'_iterations'}->[$num-1]; } =head2 num_iterations Usage : $num_iterations = $blast->num_iterations; Purpose : Get the number of iterations in the search result (PSI-BLAST). Returns : Total number of iterations in the report Argument : none (read-only) =cut sub num_iterations { shift->{'_iteration_count'} } # Methods provided for consistency with BPpsilite.pm (now deprecated); # these are now merely synonyms =head2 number_of_iterations Usage : $num_iterations = $blast->number_of_iterations; Purpose : Get the number of iterations in the search result (PSI-BLAST). Returns : Total number of iterations in the report Argument : none (read-only) Note : Alias of L. =cut sub number_of_iterations { shift->num_iterations } =head2 round Usage : $round = $blast->round( $number ); Purpose : Get an IterationI object for the specified iteration in the search result (PSI-BLAST). Returns : Bio::Search::Iteration::IterationI object Throws : Bio::Root::NoSuchThing exception if $number is not within range of the number of iterations in this report. Argument : integer (optional, if not specified get the last iteration) First iteration = 1 Note : Alias of L. =cut sub round { shift->iteration(@_) } =head2 iterations Title : iterations Usage : my @iterations = $result->iterations Function: Returns the IterationI objects contained within this Result Returns : Array of L objects Args : none =cut sub iterations { my $self = shift; my @its = (); if( ref($self->{'_iterations'}) =~ /ARRAY/i ) { @its = @{$self->{'_iterations'}}; } return @its; } =head2 psiblast Usage : if( $blast->psiblast ) { ... } Purpose : Set/get a boolean indicator whether or not the report is a PSI-BLAST report. Returns : 1 if PSI-BLAST, undef if not. Argument : 1 (when setting) =cut #---------------- sub psiblast { #---------------- my ($self, $val ) = @_; if( $val ) { $self->{'_psiblast'} = 1; } return $self->{'_psiblast'}; } =head2 no_hits_found Usage : $nohits = $blast->no_hits_found( $iteration_number ); Purpose : Get boolean indicator indicating whether or not any hits were present in the report. This is NOT the same as determining the number of hits via the hits() method, which will return zero hits if there were no hits in the report or if all hits were filtered out during the parse. Thus, this method can be used to distinguish these possibilities for hitless reports generated when filtering. Returns : Boolean Argument : (optional) integer indicating the iteration number (PSI-BLAST) If iteration number is not specified and this is a PSI-BLAST result, then this method will return true only if all iterations had no hits found. =cut sub no_hits_found { my ($self, $round) = @_; my $result = 0; # final return value of this method. # Watch the double negative! # result = 0 means "yes hits were found" # result = 1 means "no hits were found" (for the indicated iteration or all iterations) # If a iteration was not specified and there were multiple iterations, # this method should return true only if all iterations had no hits found. if( not defined $round ) { if( $self->{'_iterations'} > 1) { $result = 1; foreach my $i( 1..$self->{'_iterations'} ) { if( not defined $self->{"_iteration_$i"}->{'_no_hits_found'} ) { $result = 0; last; } } } else { $result = $self->{"_iteration_1"}->{'_no_hits_found'}; } } else { $result = $self->{"_iteration_$round"}->{'_no_hits_found'}; } return $result; } =head2 set_no_hits_found Usage : $blast->set_no_hits_found( $iteration_number ); Purpose : Set boolean indicator indicating whether or not any hits were present in the report. Returns : n/a Argument : (optional) integer indicating the iteration number (PSI-BLAST) =cut sub set_no_hits_found { my ($self, $round) = @_; $round ||= 1; $self->{"_iteration_$round"}->{'_no_hits_found'} = 1; } =head2 _next_iteration_index Title : _next_iteration_index Usage : private =cut sub _next_iteration_index{ my ($self,@args) = @_; return $self->{'_iteration_index'}++; } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Iteration iterator to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind { my $self = shift; $self->SUPER::rewind(@_); $self->{'_iteration_index'} = 0; foreach ($self->iterations) { $_->rewind; } } =head2 inclusion_threshold Title : inclusion_threshold Usage : my $incl_thresh = $result->inclusion_threshold; (read-only) Function: Gets the e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) that was used for generating the report being parsed. Returns : number (real) or undef if not a PSI-BLAST report. Args : none =cut sub inclusion_threshold { my $self = shift; return $self->{'_inclusion_threshold'}; } 1; BioPerl-1.6.923/Bio/Search/Result/CrossMatchResult.pm000444000765000024 3151412254227333 22462 0ustar00cjfieldsstaff000000000000package Bio::Search::Result::CrossMatchResult; # # BioPerl module for Bio::Search::Result::CrossMatchResult # # Please direct questions and support issues to # # Cared for by Shin Leong # # Copyright Shin Leong # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::CrossMatchResult - CrossMatch-specific subclass of Bio::Search::Result::GenericResult =head1 SYNOPSIS # Working with iterations (CrossMatch results) $result->next_iteration(); $result->num_iterations(); $result->iteration(); $result->iterations(); # See Bio::Search::Result::GenericResult for information about working with Results. # See L # for details about working with iterations. # TODO: # * Show how to configure a SearchIO stream so that it generates # CrossMatchResult objects. =head1 DESCRIPTION This object is a subclass of Bio::Search::Result::GenericResult and provides some operations that facilitate working with CrossMatch and CrossMatch results. For general information about working with Results, see Bio::Search::Result::GenericResult. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shin Leong Email sleong@watson.wustl.edu =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::CrossMatchResult; use strict; use Bio::Search::Result::GenericResult; use base qw(Bio::Search::Result::GenericResult); =head2 new Title : new Usage : my $obj = Bio::Search::Result::CrossMatchResult->new(); Function: Builds a new Bio::Search::Result::CrossMatchResult object Returns : Bio::Search::Result::CrossMatchResult Args : See Bio::Search::Result::GenericResult(); The following parameters are specific to CrossMatchResult: -iterations => array ref of Bio::Search::Iteration::IterationI objects -inclusion_threshold => e-value threshold for inclusion in the CrossMatch score matrix model (blastpgp) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_iterations'} = []; $self->{'_iteration_index'} = 0; $self->{'_iteration_count'} = 0; my( $iters, $ithresh ) = $self->_rearrange([qw(ITERATIONS INCLUSION_THRESHOLD)],@args); $self->{'_inclusion_threshold'} = $ithresh; # This is a read-only variable if( defined $iters ) { $self->throw("Must define arrayref of Iterations when initializing a $class\n") unless ref($iters) =~ /array/i; foreach my $i ( @{$iters} ) { $self->add_iteration($i); } } else { # This shouldn't get called with the new SearchIO::blast. #print STDERR "CrossMatchResult::new(): Not adding iterations.\n"; $self->{'_no_iterations'} = 1; } #$self->SUPER::algorithm('cross_match'); return $self; } =head2 hits This method overrides L to take into account the possibility of multiple iterations, as occurs in CrossMatch reports. If there are multiple iterations, all 'new' hits for all iterations are returned. These are the hits that did not occur in a previous iteration. See Also: L =cut sub hits { my ($self) = shift; if ($self->{'_no_iterations'}) { return $self->SUPER::hits; } my @hits = (); foreach my $it ($self->iterations) { push @hits, $it->hits; } return @hits; } =head2 next_hit This method overrides L to take into account the possibility of multiple iterations, as occurs in CrossMatch reports. If there are multiple iterations, calling next_hit() traverses the all of the hits, old and new, for each iteration, calling next_hit() on each iteration. See Also: L =cut sub next_hit { my ($self,@args) = @_; if ($self->{'_no_iterations'}) { return $self->SUPER::next_hit(@args); } my $iter_index; if (not defined $self->{'_last_hit'}) { $iter_index = $self->{'_iter_index'} = $self->_next_iteration_index; } else { $iter_index = $self->{'_iter_index'}; } return if $iter_index >= scalar @{$self->{'_iterations'}}; my $it = $self->{'_iterations'}->[$iter_index]; my $hit = $self->{'_last_hit'} = $it->next_hit; return defined($hit) ? $hit : $self->next_hit; } =head2 num_hits This method overrides L to take into account the possibility of multiple iterations, as occurs in CrossMatch reports. If there are multiple iterations, calling num_hits() returns the number of 'new' hits for each iteration. These are the hits that did not occur in a previous iteration. See Also: L =cut sub num_hits{ my ($self) = shift; if ($self->{'_no_iterations'}) { return $self->SUPER::num_hits; } if (not defined $self->{'_iterations'}) { $self->throw("Can't get Hits: data not collected."); } return scalar( $self->hits ); } =head2 add_iteration Title : add_iteration Usage : $report->add_iteration($iteration) Function: Adds a IterationI to the stored list of iterations Returns : Number of IterationI currently stored Args : Bio::Search::Iteration::IterationI =cut sub add_iteration { my ($self,$i) = @_; if( $i->isa('Bio::Search::Iteration::IterationI') ) { push @{$self->{'_iterations'}}, $i; $self->{'_iteration_count'}++; } else { $self->throw("Passed in a " .ref($i). " as a Iteration which is not a Bio::Search::IterationI."); } return scalar @{$self->{'_iterations'}}; } =head2 next_iteration Title : next_iteration Usage : while( $it = $result->next_iteration()) { ... } Function: Returns the next Iteration object, representing all hits found within a given CrossMatch iteration. Returns : a Bio::Search::Iteration::IterationI object or undef if there are no more. Args : none =cut sub next_iteration { my ($self) = @_; unless($self->{'_iter_queue_started'}) { $self->{'_iter_queue'} = [$self->iterations()]; $self->{'_iter_queue_started'} = 1; } return shift @{$self->{'_iter_queue'}}; } =head2 iteration Usage : $iteration = $blast->iteration( $number ); Purpose : Get an IterationI object for the specified iteration in the search result (CrossMatch). Returns : Bio::Search::Iteration::IterationI object Throws : Bio::Root::NoSuchThing exception if $number is not within range of the number of iterations in this report. Argument : integer (optional, if not specified get the last iteration) First iteration = 1 =cut sub iteration { my ($self,$num) = @_; $num = scalar @{$self->{'_iterations'}} unless defined $num; unless ($num >= 1 and $num <= scalar $self->{'_iteration_count'}) { $self->throw(-class=>'Bio::Root::NoSuchThing', -text=>"No such iteration number: $num. Valid range=1-$self->{'_iteration_count'}", -value=>$num); } return $self->{'_iterations'}->[$num-1]; } =head2 num_iterations Usage : $num_iterations = $blast->num_iterations; Purpose : Get the number of iterations in the search result (CrossMatch). Returns : Total number of iterations in the report Argument : none (read-only) =cut sub num_iterations { shift->{'_iteration_count'} } # Methods provided for consistency with BPpsilite.pm (now deprecated); # these are now merely synonyms =head2 number_of_iterations Same as L. =cut sub number_of_iterations { shift->num_iterations } =head2 round Same as L. =cut sub round { shift->iteration(@_) } =head2 iterations Title : iterations Usage : my @iterations = $result->iterations Function: Returns the IterationI objects contained within this Result Returns : Array of L objects Args : none =cut sub iterations { my $self = shift; my @its = (); if( ref($self->{'_iterations'}) =~ /ARRAY/i ) { @its = @{$self->{'_iterations'}}; } return @its; } =head2 no_hits_found Usage : $nohits = $blast->no_hits_found( $iteration_number ); Purpose : Get boolean indicator indicating whether or not any hits were present in the report. This is NOT the same as determining the number of hits via the hits() method, which will return zero hits if there were no hits in the report or if all hits were filtered out during the parse. Thus, this method can be used to distinguish these possibilities for hitless reports generated when filtering. Returns : Boolean Argument : (optional) integer indicating the iteration number (CrossMatch) If iteration number is not specified and this is a CrossMatch result, then this method will return true only if all iterations had no hits found. =cut sub no_hits_found { my ($self, $round) = @_; my $result = 0; # final return value of this method. # Watch the double negative! # result = 0 means "yes hits were found" # result = 1 means "no hits were found" (for the indicated iteration or all iterations) # If a iteration was not specified and there were multiple iterations, # this method should return true only if all iterations had no hits found. if( not defined $round ) { if( $self->{'_iterations'} > 1) { $result = 1; foreach my $i( 1..$self->{'_iterations'} ) { if( not defined $self->{"_iteration_$i"}->{'_no_hits_found'} ) { $result = 0; last; } } } else { $result = $self->{"_iteration_1"}->{'_no_hits_found'}; } } else { $result = $self->{"_iteration_$round"}->{'_no_hits_found'}; } return $result; } =head2 set_no_hits_found Usage : $blast->set_no_hits_found( $iteration_number ); Purpose : Set boolean indicator indicating whether or not any hits were present in the report. Returns : n/a Argument : (optional) integer indicating the iteration number (CrossMatch) =cut sub set_no_hits_found { my ($self, $round) = @_; $round ||= 1; $self->{"_iteration_$round"}->{'_no_hits_found'} = 1; } =head2 _next_iteration_index Title : _next_iteration_index Usage : private =cut sub _next_iteration_index{ my ($self,@args) = @_; return $self->{'_iteration_index'}++; } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Iteration iterator to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind { my $self = shift; $self->SUPER::rewind(@_); $self->{'_iteration_index'} = 0; foreach ($self->iterations) { $_->rewind; } } =head2 inclusion_threshold Title : inclusion_threshold Usage : my $incl_thresh = $result->inclusion_threshold; (read-only) Function: Gets the e-value threshold for inclusion in the CrossMatch score matrix model (blastpgp) that was used for generating the report being parsed. Returns : number (real) or undef if not a CrossMatch report. Args : none =cut sub inclusion_threshold { my $self = shift; return $self->{'_inclusion_threshold'}; } sub algorithm_old { my $self = shift; my $value = shift; if($value) { print STDERR "Cannot set the algorightm on this class!\n"; return $self->SUPER::algorithm; } else { return $self->SUPER::algorithm; } } 1; #$Header$ BioPerl-1.6.923/Bio/Search/Result/GenericResult.pm000444000765000024 5451612254227320 21773 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::GenericResult # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::GenericResult - Generic Implementation of Bio::Search::Result::ResultI interface applicable to most search results. =head1 SYNOPSIS # typically one gets Results from a SearchIO stream use Bio::SearchIO; my $io = Bio::SearchIO->new(-format => 'blast', -file => 't/data/HUMBETGLOA.tblastx'); while( my $result = $io->next_result ) { # process all search results within the input stream while( my $hit = $result->next_hit ) { # insert code here for hit processing } } use Bio::Search::Result::GenericResult; my @hits = (); # would be a list of Bio::Search::Hit::HitI objects # typically these are created from a Bio::SearchIO stream my $result = Bio::Search::Result::GenericResult->new ( -query_name => 'HUMBETGLOA', -query_accession => '' -query_description => 'Human haplotype C4 beta-globin gene, complete cds.' -query_length => 3002 -database_name => 'ecoli.aa' -database_letters => 4662239, -database_entries => 400, -parameters => { 'e' => '0.001' }, -statistics => { 'kappa' => 0.731 }, -algorithm => 'blastp', -algorithm_version => '2.1.2', ); my $id = $result->query_name(); my $desc = $result->query_description(); my $name = $result->database_name(); my $size = $result->database_letters(); my $num_entries = $result->database_entries(); my $gap_ext = $result->get_parameter('e'); my @params = $result->available_parameters; my $kappa = $result->get_statistic('kappa'); my @statnames = $result->available_statistics; # TODO: Show how to configure a SearchIO stream so that it generates # GenericResult objects. =head1 DESCRIPTION This object is an implementation of the Bio::Search::Result::ResultI interface and provides a generic place to store results from a sequence database search. Unless you're writing a parser, you won't ever need to create a GenericResult or any other ResultI-implementing object. If you use the SearchIO system, ResultI objects are created automatically from a SearchIO stream which returns Bio::Search::Result::ResultI objects. For documentation on what you can do with GenericResult (and other ResultI objects), please see the API documentation in L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich and Steve Chervitz Email jason@bioperl.org Email sac@bioperl.org =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::GenericResult; use strict; use Bio::Search::GenericStatistics; use Bio::Tools::Run::GenericParameters; # bug #1420 #use overload # '""' => \&to_string; use base qw(Bio::Root::Root Bio::Search::Result::ResultI); =head2 new Title : new Usage : my $obj = Bio::Search::Result::GenericResult->new(); Function: Builds a new Bio::Search::Result::GenericResult object Returns : Bio::Search::Result::GenericResult Args : -query_name => Name of query Sequence -query_accession => Query accession number (if available) -query_description => Description of query sequence -query_length => Length of query sequence -database_name => Name of database -database_letters => Number of residues in database -database_entries => Number of entries in database -hits => array ref of Bio::Search::Hit::HitI objects -parameters => hash ref of search parameters (key => value) -statistics => hash ref of search statistics (key => value) -algorithm => program name (blastx) -algorithm_version => version of the algorithm (2.1.2) -algorithm_reference => literature reference string for this algorithm -rid => value of the BLAST Request ID (eg. RID: ZABJ4EA7014) -hit_factory => Bio::Factory::ObjectFactoryI capable of making Bio::Search::Hit::HitI objects =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_hits'} = []; $self->{'_hitindex'} = 0; $self->{'_statistics'} = Bio::Search::GenericStatistics->new(); $self->{'_parameters'} = Bio::Tools::Run::GenericParameters->new(); my ($qname,$qacc,$qdesc,$qlen, $qgi, $dbname,$dblet,$dbent,$params, $stats, $hits, $algo, $algo_v, $prog_ref, $algo_r, $rid, $hit_factory) = $self->_rearrange([qw(QUERY_NAME QUERY_ACCESSION QUERY_DESCRIPTION QUERY_LENGTH QUERY_GI DATABASE_NAME DATABASE_LETTERS DATABASE_ENTRIES PARAMETERS STATISTICS HITS ALGORITHM ALGORITHM_VERSION PROGRAM_REFERENCE ALGORITHM_REFERENCE RID HIT_FACTORY )],@args); $algo_r ||= $prog_ref; defined $algo && $self->algorithm($algo); defined $algo_v && $self->algorithm_version($algo_v); defined $algo_r && $self->algorithm_reference($algo_r); defined $rid && $self->rid($rid); defined $qname && $self->query_name($qname); defined $qacc && $self->query_accession($qacc); defined $qdesc && $self->query_description($qdesc); defined $qlen && $self->query_length($qlen); defined $qgi && $self->query_gi($qgi); defined $dbname && $self->database_name($dbname); defined $dblet && $self->database_letters($dblet); defined $dbent && $self->database_entries($dbent); defined $hit_factory && $self->hit_factory($hit_factory); if( defined $params ) { if( ref($params) !~ /hash/i ) { $self->throw("Must specify a hash reference with the parameter '-parameters"); } while( my ($key,$value) = each %{$params} ) { $self->{'_parameters'}->set_parameter($key => $value); # $self->add_parameter($key,$value); } } if( defined $stats ) { if( ref($stats) !~ /hash/i ) { $self->throw("Must specify a hash reference with the parameter '-statistics"); } while( my ($key,$value) = each %{$stats} ) { $self->{'_statistics'}->set_statistic($key => $value); # $self->add_statistic($key,$value); } } if( defined $hits ) { $self->throw("Must define arrayref of Hits when initializing a $class\n") unless ref($hits) =~ /array/i; foreach my $s ( @$hits ) { $self->add_hit($s); } } return $self; } =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the Result Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut sub algorithm{ my ($self,$value) = @_; my $previous = $self->{'_algorithm'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_algorithm'} = $value; } return $previous; } =head2 algorithm_version Title : algorithm_version Usage : my $r_version = $hsp->algorithm_version Function: Obtain the version of the algorithm used to obtain the Result Returns : string (e.g., 2.1.2) Args : [optional] scalar string to set algorithm version value =cut sub algorithm_version{ my ($self,$value) = @_; my $previous = $self->{'_algorithm_version'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_algorithm_version'} = $value; } return $previous; } =head2 Bio::Search::Result::ResultI interface methods Bio::Search::Result::ResultI implementation =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none =cut sub next_hit { my ($self,@args) = @_; my $index = $self->_nexthitindex; return if $index > scalar @{$self->{'_hits'}}; my $hit = $self->{'_hits'}->[$index]; if (ref($hit) eq 'HASH') { my $factory = $self->hit_factory || $self->throw("Tried to get a Hit, but it was a hash ref and we have no hit factory"); $hit = $factory->create_object(%{$hit}); $self->{'_hits'}->[$index] = $hit; delete $self->{_hashes}->{$index}; } return $hit; } =head2 query_name Title : query_name Usage : $id = $result->query_name(); Function: Get the string identifier of the query used by the algorithm that performed the search. Returns : a string. Args : [optional] new string value for query name =cut sub query_name { my ($self,$value) = @_; my $previous = $self->{'_queryname'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_queryname'} = $value; } return $previous; } =head2 query_accession Title : query_accession Usage : $id = $result->query_accession(); Function: Get the accession (if available) for the query sequence Returns : a string Args : [optional] new string value for accession =cut sub query_accession { my ($self,$value) = @_; my $previous = $self->{'_queryacc'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_queryacc'} = $value; } return $previous; } =head2 query_gi Title : query_gi Usage : $acc = $hit->query_gi(); Function: Retrieve the NCBI Unique ID (aka the GI #), if available, for the query Returns : a scalar string (empty string if not set) Args : none =cut sub query_gi { my ($self,$value) = @_; if( defined $value ) { $self->{'_query_gi'} = $value; } else { $self->{'_query_gi'} = $self->query_name =~ m{^gi\|(\d+)} ? $1 : ''; } return $self->{'_query_gi'}; } =head2 query_length Title : query_length Usage : $id = $result->query_length(); Function: Get the length of the query sequence used in the search. Returns : a number Args : [optional] new integer value for query length =cut sub query_length { my ($self,$value) = @_; my $previous = $self->{'_querylength'}; if( defined $value || ! defined $previous ) { $value = $previous = 0 unless defined $value; $self->{'_querylength'} = $value; } return $previous; } =head2 query_description Title : query_description Usage : $id = $result->query_description(); Function: Get the description of the query sequence used in the search. Returns : a string Args : [optional] new string for the query description =cut sub query_description { my ($self,$value) = @_; my $previous = $self->{'_querydesc'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_querydesc'} = $value; } return $previous; } =head2 database_name Title : database_name Usage : $name = $result->database_name() Function: Used to obtain the name of the database that the query was searched against by the algorithm. Returns : a scalar string Args : [optional] new string for the db name =cut sub database_name { my ($self,$value) = @_; my $previous = $self->{'_dbname'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_dbname'} = $value; } return $previous; } =head2 database_letters Title : database_letters Usage : $size = $result->database_letters() Function: Used to obtain the size of database that was searched against. Returns : a scalar integer (units specific to algorithm, but probably the total number of residues in the database, if available) or undef if the information was not available to the Processor object. Args : [optional] new scalar integer for number of letters in db =cut sub database_letters { my ($self,$value) = @_; my $previous = $self->{'_dbletters'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_dbletters'} = $value; } return $previous; } =head2 database_entries Title : database_entries Usage : $num_entries = $result->database_entries() Function: Used to obtain the number of entries contained in the database. Returns : a scalar integer representing the number of entities in the database or undef if the information was not available. Args : [optional] new integer for the number of sequence entries in the db =cut sub database_entries { my ($self,$value) = @_; my $previous = $self->{'_dbentries'}; if( defined $value || ! defined $previous ) { $value = $previous = '' unless defined $value; $self->{'_dbentries'} = $value; } return $previous; } =head2 get_parameter Title : get_parameter Usage : my $gap_ext = $report->get_parameter('gapext') Function: Returns the value for a specific parameter used when running this report Returns : string Args : name of parameter (string) =cut sub get_parameter { my ($self,$name) = @_; return $self->{'_parameters'}->get_parameter($name); } =head2 available_parameters Title : available_parameters Usage : my @params = $report->available_paramters Function: Returns the names of the available parameters Returns : Return list of available parameters used for this report Args : none =cut sub available_parameters{ my ($self) = @_; return $self->{'_parameters'}->available_parameters; } =head2 get_statistic Title : get_statistic Usage : my $gap_ext = $report->get_statistic('kappa') Function: Returns the value for a specific statistic available from this report Returns : string Args : name of statistic (string) =cut sub get_statistic{ my ($self,$key) = @_; return $self->{'_statistics'}->get_statistic($key); } =head2 available_statistics Title : available_statistics Usage : my @statnames = $report->available_statistics Function: Returns the names of the available statistics Returns : Return list of available statistics used for this report Args : none =cut sub available_statistics{ my ($self) = @_; return $self->{'_statistics'}->available_statistics; } =head2 Bio::Search::Report Bio::Search::Result::GenericResult specific methods =head2 add_hit Title : add_hit Usage : $report->add_hit($hit) Function: Adds a HitI to the stored list of hits Returns : Number of HitI currently stored Args : Bio::Search::Hit::HitI =cut sub add_hit { my ($self,$s) = @_; if (ref($s) eq 'HASH' || $s->isa('Bio::Search::Hit::HitI') ) { push @{$self->{'_hits'}}, $s; } else { $self->throw("Passed in " .ref($s)." as a Hit which is not a Bio::Search::HitI."); } if (ref($s) eq 'HASH') { $self->{_hashes}->{$#{$self->{'_hits'}}} = 1; } return scalar @{$self->{'_hits'}}; } =head2 hit_factory Title : hit_factory Usage : $hit->hit_factory($hit_factory) Function: Get/set the factory used to build HitI objects if necessary. Returns : Bio::Factory::ObjectFactoryI Args : Bio::Factory::ObjectFactoryI =cut sub hit_factory { my $self = shift; if (@_) { $self->{_hit_factory} = shift } return $self->{_hit_factory} || return; } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iterator to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind{ my ($self) = @_; $self->{'_hitindex'} = 0; } =head2 _nexthitindex Title : _nexthitindex Usage : private =cut sub _nexthitindex{ my ($self,@args) = @_; return $self->{'_hitindex'}++; } =head2 add_parameter Title : add_parameter Usage : $report->add_parameter('gapext', 11); Function: Adds a parameter Returns : none Args : key - key value name for this parama value - value for this parameter =cut sub add_parameter { my ($self,$key,$value) = @_; $self->{'_parameters'}->set_parameter($key => $value); } =head2 add_statistic Title : add_statistic Usage : $report->add_statistic('lambda', 2.3); Function: Adds a parameter Returns : none Args : key - key value name for this parama value - value for this parameter =cut sub add_statistic { my ($self,$key,$value) = @_; $self->{'_statistics'}->set_statistic($key => $value); return; } =head2 num_hits Title : num_hits Usage : my $hitcount= $result->num_hits Function: returns the number of hits for this query result Returns : integer Args : none =cut sub num_hits{ my ($self) = shift; if (not defined $self->{'_hits'}) { $self->throw("Can't get Hits: data not collected."); } return scalar(@{$self->{'_hits'}}); } =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the available hits for this Result Returns : Array of L objects Args : none =cut sub hits { my ($self) = shift; foreach my $i (keys %{$self->{_hashes} || {}}) { my $factory = $self->hit_factory || $self->throw("Tried to get a Hit, but it was a hash ref and we have no hit factory"); $self->{'_hits'}->[$i] = $factory->create_object(%{$self->{'_hits'}->[$i]}); delete $self->{_hashes}->{$i}; } my @hits = (); if (ref $self->{'_hits'}) { @hits = @{$self->{'_hits'}}; } return @hits; } =head2 algorithm_reference Title : algorithm_reference Usage : $obj->algorithm_reference($newval) Function: Returns : string containing literature reference for the algorithm Args : newvalue string (optional) Comments: Formerly named program_reference(), which is still supported for backwards compatibility. =cut sub algorithm_reference{ my ($self,$value) = @_; if( defined $value) { $self->{'algorithm_reference'} = $value; } return $self->{'algorithm_reference'}; } =head2 program_reference Title : program_reference Usage : $obj->program_reference() Function: Returns : string containing literature reference for the algorithm Args : Comments: Deprecated - use algorithm_reference() instead. =cut sub program_reference { shift->algorithm_reference(@_); } =head2 rid Title : rid Usage : $obj->rid($newval) Function: Returns : value of the BLAST Request ID (eg. RID: ZABJ4EA7014) Args : newvalue (optional) Comments: The default implementation in ResultI returns an empty string rather than throwing a NotImplemented exception, since the RID may not always be available and is not critical. See: (1) http://www.ncbi.nlm.nih.gov/Class/MLACourse/Modules/BLAST/rid.html (2) http://www.ncbi.nlm.nih.gov/staff/tao/URLAPI/new/node63.html =cut sub rid{ my ($self,$value) = @_; if( defined $value) { $self->{'rid'} = $value; } return $self->{'rid'}; } =head2 no_hits_found See documentation in L =cut sub no_hits_found { my $self = shift; # Watch the double negative! # result = 0 means "yes hits were found" # result = 1 means "no hits were found" return $self->{'_no_hits_found'}; } =head2 set_no_hits_found See documentation in L =cut sub set_no_hits_found { my $self = shift; $self->{'_no_hits_found'} = 1; } =head2 to_string Title : to_string Usage : print $blast->to_string; Function: Returns a string representation for the Blast result. Primarily intended for debugging purposes. Example : see usage Returns : A string of the form: [GenericResult] query= db=query_description .", db=" . $self->database_name; return $str; } 1; BioPerl-1.6.923/Bio/Search/Result/hmmer3Result.pm000444000765000024 775412254227323 21577 0ustar00cjfieldsstaff000000000000# $Id: bioperl.lisp 15559 2009-02-23 12:11:20Z maj $ # # BioPerl module for Bio::Search::Result::hmmer3Result # # Please direct questions and support issues to # # Cared for by Thomas Sharpton # # Copyright Thomas Sharpton # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::hmmer3Result - DESCRIPTION of Object =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: L rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Thomas Sharpton Email thomas.sharpton@gmail.com Describe contact details here =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::hmmer3Result; use strict; use base qw(Bio::Search::Result::GenericResult); =head2 new Title : new Usage : my $obj = new Bio::Search::Result::hmmer3Result.pm(); Function: Builds a new Bio::Search::Result::hmmer3Result.pm object Returns : an instance of Bio::Search::Result::hmmer3Result.pm Args : -hmm_name => string, name of hmm file -sequence_file => name of the sequence file =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hmm,$seqfile) = $self->_rearrange([qw(HMM_NAME SEQUENCE_FILE)], @args); defined( $seqfile ) && $self->sequence_file( $seqfile ); defined( $hmm ) && $self->hmm_name( $hmm ); return $self; } =head2 hmm_name Title : hmm_name Usage : $obj->hmm_name($newval) Function: Get/Set the value of hmm_name Returns : value of hmm_name Args : newvalue (optional) =cut sub hmm_name{ my ($self,$value) = @_; if( defined $value) { $self->{'_hmm_name'} = $value; } return $self->{'_hmm_name'}; } =head2 sequence_file Title : sequence_file Usage : $obj->sequence_file($newval) Function: Get/Set the value of sequence_file Returns : value of sequence_file Args : newvalue (optional) =cut sub sequence_file{ my ($self,$value) = @_; if( defined $value) { $self->{'_sequence_file'} = $value; } return $self->{'_sequence_file'}; } =head2 next_model Title : next_model Usage : my $domain = $result->next_model Function: Returns the next domain - this is an alias for next_hit Returns : L object Args : none =cut sub next_model{ shift->next_hit } =head2 models Title : models Usage : my @domains = $result->models; Function: Returns the list of HMM models seen - this is an alias for hits() Returns : Array of L objects Args : none =cut sub models{ shift->hits } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iteration to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind{ my ($self) = @_; $self->{'_hitindex'} = 0; } 1; BioPerl-1.6.923/Bio/Search/Result/HMMERResult.pm000444000765000024 2535012254227326 21267 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::HMMERResult # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::HMMERResult - A Result object for HMMER results =head1 SYNOPSIS use Bio::Search::Result::HMMERResult; my $result = Bio::Search::Result::HMMERResult->new ( -hmm_name => 'pfam', -sequence_file => 'roa1.pep', -hits => \@hits); # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer', -file => 'result.hmmer'); while( my $result = $in->next_result ) { print $result->query_name, " ", $result->algorithm, " ", $result->num_hits(), " hits\n"; } =head1 DESCRIPTION This is a specialization of L. There are a few extra methods, specifically L, L, L, and L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::HMMERResult; use strict; use base qw(Bio::Search::Result::GenericResult); =head2 new Title : new Usage : my $obj = Bio::Search::Result::HMMERResult->new(); Function: Builds a new Bio::Search::Result::HMMERResult object Returns : Bio::Search::Result::HMMERResult Args : -hmm_name => string, name of hmm file -sequence_file => name of the sequence file plus Bio::Search::Result::GenericResult parameters -query_name => Name of query Sequence -query_accession => Query accession number (if available) -query_description => Description of query sequence -query_length => Length of query sequence -database_name => Name of database -database_letters => Number of residues in database -database_entries => Number of entries in database -parameters => hash ref of search parameters (key => value) -statistics => hash ref of search statistics (key => value) -algorithm => program name (blastx) -algorithm_version => version of the algorithm (2.1.2) -program_reference => literature reference string for this algorithm =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hmm,$seqfile) = $self->_rearrange([qw(HMM_NAME SEQUENCE_FILE)], @args); defined( $seqfile) && $self->sequence_file($seqfile); defined( $hmm) && $self->hmm_name($hmm); return $self; } =head2 hmm_name Title : hmm_name Usage : $obj->hmm_name($newval) Function: Get/Set the value of hmm_name Returns : value of hmm_name Args : newvalue (optional) =cut sub hmm_name{ my ($self,$value) = @_; if( defined $value) { $self->{'_hmm_name'} = $value; } return $self->{'_hmm_name'}; } =head2 sequence_file Title : sequence_file Usage : $obj->sequence_file($newval) Function: Get/Set the value of sequence_file Returns : value of sequence_file Args : newvalue (optional) =cut sub sequence_file{ my ($self,$value) = @_; if( defined $value) { $self->{'_sequence_file'} = $value; } return $self->{'_sequence_file'}; } =head2 next_model Title : next_model Usage : my $domain = $result->next_model Function: Returns the next domain - this is an alias for next_hit Returns : L object Args : none =cut sub next_model{ shift->next_hit } =head2 models Title : models Usage : my @domains = $result->models; Function: Returns the list of HMM models seen - this is an alias for hits() Returns : Array of L objects Args : none =cut sub models{ shift->hits } =head2 Bio::Search::Result::GenericResult inherited methods =cut =head2 algorithm Title : algorithm Usage : my $r_type = $hsp->algorithm Function: Obtain the name of the algorithm used to obtain the Result Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut =head2 algorithm_version Title : algorithm_version Usage : my $r_version = $hsp->algorithm_version Function: Obtain the version of the algorithm used to obtain the Result Returns : string (e.g., 2.1.2) Args : [optional] scalar string to set algorithm version value =cut =head2 Bio::Search::Result::ResultI interface methods Bio::Search::Result::ResultI implementation =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none =cut =head2 query_name Title : query_name Usage : $id = $result->query_name(); Function: Get the string identifier of the query used by the algorithm that performed the search. Returns : a string. Args : [optional] new string value for query name =cut =head2 query_accession Title : query_accession Usage : $id = $result->query_accession(); Function: Get the accession (if available) for the query sequence Returns : a string Args : [optional] new string value for accession =cut =head2 query_length Title : query_length Usage : $id = $result->query_length(); Function: Get the length of the query sequence used in the search. Returns : a number Args : [optional] new integer value for query length =cut =head2 query_description Title : query_description Usage : $id = $result->query_description(); Function: Get the description of the query sequence used in the search. Returns : a string Args : [optional] new string for the query description =cut =head2 database_name Title : database_name Usage : $name = $result->database_name() Function: Used to obtain the name of the database that the query was searched against by the algorithm. Returns : a scalar string Args : [optional] new string for the db name =cut =head2 database_letters Title : database_letters Usage : $size = $result->database_letters() Function: Used to obtain the size of database that was searched against. Returns : a scalar integer (units specific to algorithm, but probably the total number of residues in the database, if available) or undef if the information was not available to the Processor object. Args : [optional] new scalar integer for number of letters in db =cut =head2 database_entries Title : database_entries Usage : $num_entries = $result->database_entries() Function: Used to obtain the number of entries contained in the database. Returns : a scalar integer representing the number of entities in the database or undef if the information was not available. Args : [optional] new integer for the number of sequence entries in the db =cut =head2 get_parameter Title : get_parameter Usage : my $gap_ext = $report->get_parameter('gapext') Function: Returns the value for a specific parameter used when running this report Returns : string Args : name of parameter (string) =cut =head2 available_parameters Title : available_parameters Usage : my @params = $report->available_paramters Function: Returns the names of the available parameters Returns : Return list of available parameters used for this report Args : none =cut =head2 get_statistic Title : get_statistic Usage : my $gap_ext = $report->get_statistic('kappa') Function: Returns the value for a specific statistic available from this report Returns : string Args : name of statistic (string) =cut =head2 available_statistics Title : available_statistics Usage : my @statnames = $report->available_statistics Function: Returns the names of the available statistics Returns : Return list of available statistics used for this report Args : none =cut =head2 Bio::Search::Result::GenericResult specific methods =cut =head2 add_hit Title : add_hit Usage : $report->add_hit($hit) Function: Adds a HitI to the stored list of hits Returns : Number of HitI currently stored Args : Bio::Search::Hit::HitI =cut =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iteration to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind{ my ($self) = @_; $self->{'_hitindex'} = 0; } =head2 add_parameter Title : add_parameter Usage : $report->add_parameter('gapext', 11); Function: Adds a parameter Returns : none Args : key - key value name for this parama value - value for this parameter =cut =head2 add_statistic Title : add_statistic Usage : $report->add_statistic('lambda', 2.3); Function: Adds a parameter Returns : none Args : key - key value name for this parama value - value for this parameter =cut =head2 num_hits Title : num_hits Usage : my $hitcount= $result->num_hits Function: returns the number of hits for this query result Returns : integer Args : none =cut =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the available hits for this Result Returns : Array of L objects Args : none =cut =head2 program_reference Title : program_reference Usage : $obj->program_reference($newval) Function: Returns : value of the literature reference for the algorithm Args : newvalue (optional) =cut 1; BioPerl-1.6.923/Bio/Search/Result/HmmpfamResult.pm000555000765000024 2662612254227317 22016 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::HmmpfamResult # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::HmmpfamResult - A parser and result object for hmmpfam results =head1 SYNOPSIS # generally we use Bio::SearchIO to build these objects use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 'result.hmmer'); while (my $result = $in->next_result) { print $result->query_name, " ", $result->algorithm, " ", $result->num_hits(), " hits\n"; } =head1 DESCRIPTION This object implements a parser for hmmpfam result output, a program in the HMMER package. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::HmmpfamResult; use strict; use Bio::Search::Hit::HmmpfamHit; use base qw(Bio::Root::Root Bio::Search::Result::PullResultI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::Result::hmmpfam->new(); Function: Builds a new Bio::SearchIO::Result::hmmpfam object Returns : Bio::SearchIO::Result::hmmpfam Args : -chunk => [Bio::Root::IO, $start, $end] (required if no -parent) -parent => Bio::PullParserI object (required if no -chunk) -parameters => hash ref of search parameters (key => value), optional -statistics => hash ref of search statistics (key => value), optional where the array ref provided to -chunk contains an IO object for a filehandle to something representing the raw data of the result, and $start and $end define the tell() position within the filehandle that the result data starts and ends (optional; defaults to start and end of the entire thing described by the filehandle) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_setup(@args); foreach my $field (qw( header hit_table hsp_table alignments next_model models query_length )) { $self->_fields->{$field} = undef; } $self->_dependencies( { ( query_name => 'header', query_accession => 'header', query_description => 'header', hit_table => 'header', num_hits => 'hit_table', no_hits_found => 'hit_table', hsp_table => 'hit_table', next_alignment => 'hsp_table' ) } ); return $self; } # # PullParserI discovery methods so we can answer all ResultI questions # sub _discover_header { my $self = shift; $self->_chunk_seek(0); my $header = $self->_get_chunk_by_end("all domains):\n"); $self->{_after_header} = $self->_chunk_tell; $header || $self->throw("Could not find hmmer header, is file really hmmer format?"); ($self->_fields->{query_name}) = $header =~ /^Query(?:\s+sequence)?:\s+(\S+)/m; ($self->_fields->{query_accession}) = $header =~ /^Accession:\s+(\S+)/m; ($self->_fields->{query_description}) = $header =~ /^Description:\s+(\S.+)/m; $self->_fields->{query_accession} ||= ''; $self->_fields->{query_description} ||= ''; $self->_fields->{header} = 1; # stop this method being called again } sub _discover_hit_table { my $self = shift; $self->_chunk_seek($self->{_after_header}); my $table = $self->_get_chunk_by_end("for domains:\n"); $self->{_after_hit_table} = $self->_chunk_tell; my $evalue_cutoff = $self->get_field('evalue_cutoff'); undef $evalue_cutoff if $evalue_cutoff eq '[unset]'; my $score_cutoff = $self->get_field('score_cutoff'); undef $score_cutoff if $score_cutoff eq '[unset]'; my $hsps_cutoff = $self->get_field('hsps_cutoff'); undef $hsps_cutoff if $hsps_cutoff eq '[unset]'; my @table; my $no_hit = 1; while ($table =~ /^(\S+)\s+(\S.+?)?\s+(\S+)\s+(\S+)\s+(\d+)\n/gm) { $no_hit = 0; my $evalue = abs($4); # consistency for tests under Windows next if ($evalue_cutoff && $evalue > $evalue_cutoff); next if ($score_cutoff && $3 < $score_cutoff); next if ($hsps_cutoff && $5 < $hsps_cutoff); push(@table, [$1, $2, $3, $evalue, $5]); } $self->_fields->{hit_table} = \@table; $self->{_next_hit_index} = @table > 0 ? 0 : -1; $self->_fields->{no_hits_found} = $no_hit; $self->_fields->{num_hits} = @table; } sub _discover_hsp_table { my $self = shift; $self->_chunk_seek($self->{_after_hit_table}); my $table = $self->_get_chunk_by_end("top-scoring domains:\n"); $table ||= $self->_get_chunk_by_end("//\n"); # A0 reports $self->{_after_hsp_table} = $self->_chunk_tell; my %table; # can't save this regex work for the hsp object because the hit object needs # its length, so may as well just do all the work here while ($table =~ /^(\S+)\s+(\d+)\/\d+\s+(\d+)\s+(\d+)\s+\S\S\s+(\d+)\s+(\d+)\s+\S(\S)\s+(\S+)\s+(\S+)/gm) { # rank query_start query_end hit_start hit_end score evalue my $evalue = abs($9); # consistency for tests under Windows push(@{$table{$1}->{hsp_data}}, [$2, $3, $4, $5, $6, $8, $evalue]); if ($7 eq ']') { $table{$1}->{hit_length} = $6; } } $self->_fields->{hsp_table} = \%table; } sub _discover_alignments { my $self = shift; $self->_fields->{alignments} = { }; } sub _next_alignment { my $self = shift;; return if $self->{_no_more_alignments}; my $aligns = $self->_fields->{alignments}; unless (defined $self->{_after_previous_alignment}) { $self->_chunk_seek($self->{_after_hsp_table}); my $chunk = $self->_get_chunk_by_end(": domain"); unless ($chunk) { $self->{_no_more_alignments} = 1; return; } $self->{_after_previous_alignment} = $self->_chunk_tell; $self->{_next_alignment_start_text} = $chunk; return $self->_next_alignment; } $self->_chunk_seek($self->{_after_previous_alignment}); my $chunk = $self->_get_chunk_by_end(": domain"); unless ($chunk) { $self->_chunk_seek($self->{_after_previous_alignment}); $chunk = $self->_get_chunk_by_end("//"); unless ($chunk) { $self->{_no_more_alignments} = 1; return; } } $self->{_after_previous_alignment} = $self->_chunk_tell; if (defined $self->{_next_alignment_start_text}) { $chunk = $self->{_next_alignment_start_text}.$chunk; } $chunk =~ s/(\S+: domain)$//; $self->{_next_alignment_start_text} = $1; my ($name, $domain) = $chunk =~ /^(\S+): domain (\d+)/; $aligns->{$name.'~~~~'.$domain} = $chunk; return 1; } sub _discover_next_hit { my $self = shift; my @hit_table = @{$self->get_field('hit_table')}; return if $self->{_next_hit_index} == -1; #[name description score significance num_hsps rank] my @hit_data = (@{$hit_table[$self->{_next_hit_index}++]}, $self->{_next_hit_index}); $self->_fields->{next_hit} = Bio::Search::Hit::HmmpfamHit->new(-parent => $self, -hit_data => \@hit_data); if ($self->{_next_hit_index} > $#hit_table) { $self->{_next_hit_index} = -1; } } =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none =cut sub next_hit { my $self = shift; my $hit = $self->get_field('next_hit'); undef $self->_fields->{next_hit}; return $hit; } =head2 next_model Title : next_model Usage : my $domain = $result->next_model Function: Returns the next domain - this is an alias for next_hit() Returns : L object Args : none =cut *next_model = \&next_hit; =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the HitI objects contained within this Result Returns : Array of Bio::Search::Hit::HitI objects Args : none See Also: L =cut sub hits { my $self = shift; my $old = $self->{_next_hit_index} || 0; $self->rewind; my @hits; while (defined(my $hit = $self->next_hit)) { push(@hits, $hit); } $self->{_next_hit_index} = @hits > 0 ? $old : -1; return @hits; } =head2 models Title : models Usage : my @domains = $result->models; Function: Returns the list of HMM models seen - this is an alias for hits() Returns : Array of L objects Args : none =cut *models = \&hits; =head2 sort_hits Title : sort_hits Usage : $result->sort_hits('sort_hits( sub{$Bio::Search::Result::HmmpfamResult::a->[2] <=> $Bio::Search::Result::HmmpfamResult::b->[2]}); NOT $result->sort_hits($a->[2] <=> $b->[2]); =cut sub sort_hits { my ($self, $code_ref) = @_; $code_ref ||= sub { $a->[3] <=> $b->[3] }; # avoid creating hit objects just to sort, hence force user to sort on # the array references in hit table my $table_ref = $self->get_field('hit_table'); @{$table_ref} > 1 || return; my @sorted = sort $code_ref @{$table_ref}; @sorted == @{$table_ref} || $self->throw("Your sort routine failed to give back all hits!"); $self->_fields->{hit_table} = \@sorted; } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iterator to the beginning, so that next_hit() will subsequently return the first hit and so on. Returns : n/a Args : none =cut sub rewind { my $self = shift; unless ($self->_fields->{hit_table}) { $self->get_field('hit_table'); } $self->{_next_hit_index} = @{$self->_fields->{hit_table}} > 0 ? 0 : -1; } 1; BioPerl-1.6.923/Bio/Search/Result/PullResultI.pm000555000765000024 3464312254227322 21450 0ustar00cjfieldsstaff000000000000# # BioPerl module Bio::Search::Result::PullResultI # # Please direct questions and support issues to # # Cared for by Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::PullResultI - Bio::Search::Result::ResultI interface for 'pull' parsers =head1 SYNOPSIS # This is an interface and cannot be instantiated # typically one gets Results from a SearchIO stream use Bio::SearchIO; my $io = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 't/data/hmmpfam.out'); my $result = $io->next_result; while( $hit = $result->next_hit()) { # enter code here for hit processing } my $id = $result->query_name(); my $desc = $result->query_description(); my $dbname = $result->database_name(); my $size = $result->database_letters(); my $num_entries = $result->database_entries(); my $gap_ext = $result->get_parameter('gapext'); my @params = $result->available_parameters; my $kappa = $result->get_statistic('kappa'); my @statnames = $result->available_statistics; =head1 DESCRIPTION Bio::Search::Result::ResultI objects are data structures containing the results from the execution of a search algorithm. As such, it may contain various algorithm specific information as well as details of the execution, but will contain a few fundamental elements, including the ability to return Bio::Search::Hit::HitI objects. PullResultI is for fast implementations that only do parsing work on the result data when you actually request information by calling one of the ResultI methods. Many methods of ResultI are implemented in a way suitable for inheriting classes that use Bio::PullParserI. It only really makes sense for PullResult modules to be created by (and have as a -parent) SearchIO modules written using PullParserI. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Sendu Bala Email bix@sendu.me.uk =head1 COPYRIGHT Copyright (c) 2006 Sendu Bala. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::PullResultI; use strict; use Bio::Search::GenericStatistics; use Bio::Tools::Run::GenericParameters; use base qw(Bio::PullParserI Bio::Search::Result::ResultI); =head2 _setup Title : _setup Usage : $self->_setup(@args) Function: Implementers should call this to setup common fields and deal with common arguments to new(). Returns : n/a Args : @args received in new(). =cut sub _setup { my ($self, @args) = @_; # fields most subclasses probably will want $self->_fields( { ( next_hit => undef, num_hits => undef, hits => undef, no_hits_found => undef, query_name => undef, query_accession => undef, query_length => undef, query_description => undef ) } ); my ($parent, $chunk, $params, $stats) = $self->_rearrange([qw(PARENT CHUNK PARAMETERS STATISTICS)], @args); $self->throw("Need -parent or -chunk to be defined") unless $parent || $chunk; $self->parent($parent) if $parent; if ($chunk) { my ($io, $start, $end) = (undef, 0, undef); if (ref($chunk) eq 'ARRAY') { ($io, $start, $end) = @{$chunk}; } else { $io = $chunk; } $self->chunk($io, -start => $start, -end => $end); } if (defined $params) { if (ref($params) !~ /hash/i) { $self->throw("Must specify a hash reference with the the parameter '-parameters"); } while (my ($key,$value) = each %{$params}) { $self->add_parameter($key, $value); } } if (defined $stats) { if (ref($stats) !~ /hash/i) { $self->throw("Must specify a hash reference with the the parameter '-statistics"); } while (my ($key,$value) = each %{$stats}) { $self->add_statistic($key, $value); } } } # # Some of these methods are written explitely to avoid ResultI throwing not # implemented; if it didn't do that then PullParserI AUTOLOAD would have # cought all them. # =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none =cut sub next_hit { return shift->get_field('next_hit'); } =head2 sort_hits Title : sort_hits Usage : $result->sort_hits(\&sort_function) Function : Sorts the available hit objects by a user-supplied function. Defaults to sort by descending score. Returns : n/a Args : A coderef for the sort function. See the documentation on the Perl sort() function for guidelines on writing sort functions. Note : To access the special variables $a and $b used by the Perl sort() function the user function must access Bio::Search::Result::ResultI namespace. For example, use : $result->sort_hits(sub{$Bio::Search::Result::ResultI::a->length <=> $Bio::Search::Result::ResultI::b->length}); NOT $result->sort_hits($a->length <=>$b->length); =cut # In ResultI. subclasses will probably want to override since sort_hits normally # calls hits(). =head2 query_name Title : query_name Usage : $id = $result->query_name(); Function: Get the string identifier of the query used by the algorithm that performed the search. Returns : a string. Args : none =cut sub query_name { return shift->get_field('query_name'); } =head2 query_accession Title : query_accession Usage : $id = $result->query_accession(); Function: Get the accession (if available) for the query sequence Returns : a string Args : none =cut sub query_accession { return shift->get_field('query_accession'); } =head2 query_length Title : query_length Usage : $id = $result->query_length(); Function: Get the length of the query sequence used in the search. Returns : a number Args : none =cut sub query_length { return shift->get_field('query_length'); } =head2 query_description Title : query_description Usage : $id = $result->query_description(); Function: Get the description of the query sequence used in the search. Returns : a string Args : none =cut sub query_description { return shift->get_field('query_description'); } =head2 database_name Title : database_name Usage : $name = $result->database_name() Function: Used to obtain the name of the database that the query was searched against by the algorithm. Returns : a scalar string Args : none =cut sub database_name { return shift->get_field('database_name'); } =head2 database_letters Title : database_letters Usage : $size = $result->database_letters() Function: Used to obtain the size of database that was searched against. Returns : a scalar integer (units specific to algorithm, but probably the total number of residues in the database, if available) or undef if the information was not available to the Processor object. Args : none =cut sub database_letters { return shift->get_field('database_letters'); } =head2 database_entries Title : database_entries Usage : $num_entries = $result->database_entries() Function: Used to obtain the number of entries contained in the database. Returns : a scalar integer representing the number of entities in the database or undef if the information was not available. Args : none =cut sub database_entries { return shift->get_field('database_entries'); } =head2 algorithm Title : algorithm Usage : my $r_type = $result->algorithm Function: Obtain the name of the algorithm used to obtain the Result Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut sub algorithm { return shift->get_field('algorithm'); } =head2 algorithm_version Title : algorithm_version Usage : my $r_version = $result->algorithm_version Function: Obtain the version of the algorithm used to obtain the Result Returns : string (e.g., 2.1.2) Args : [optional] scalar string to set algorithm version value =cut sub algorithm_version { return shift->get_field('algorithm_version'); } =head2 algorithm_reference Title : algorithm_reference Usage : $obj->algorithm_reference($newval) Function: Returns : value of the literature reference for the algorithm Args : newvalue (optional) Comments: The default implementation in ResultI returns an empty string rather than throwing a NotImplemented exception, since the ref may not always be available and is not critical. =cut sub algorithm_reference { my ($self) = @_; return ''; } =head2 num_hits Title : num_hits Usage : my $hitcount= $result->num_hits Function: returns the number of hits for this query result Returns : integer Args : none =cut sub num_hits { return shift->get_field('num_hits'); } =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the HitI objects contained within this Result Returns : Array of Bio::Search::Hit::HitI objects Args : none See Also: L =cut sub hits { return shift->get_field('hits'); } =head2 no_hits_found Usage : $nohits = $blast->no_hits_found(); Function : Get boolean indicator indicating whether or not any hits were present in the report. This is NOT the same as determining the number of hits via the hits() method, which will return zero hits if there were no hits in the report or if all hits were filtered out during the parse. Thus, this method can be used to distinguish these possibilities for hitless reports generated when filtering. Returns : Boolean Args : none =cut sub no_hits_found { return shift->get_field('no_hits_found'); } =head2 rewind Title : rewind Usage : $result->rewind; Function: Allow one to reset the Hit iterator to the beginning Since this is an in-memory implementation Returns : none Args : none =cut sub rewind { shift->throw_not_implemented(); } =head2 get_parameter Title : get_parameter Usage : my $gap_ext = $result->get_parameter('gapext') Function: Returns the value for a specific parameter used when running this result Returns : string Args : name of parameter (string) =cut sub get_parameter { my ($self, $param) = @_; $param || return; return unless defined $self->{_parameters}; return $self->{_parameters}->get_parameter($param); } =head2 available_parameters Title : available_parameters Usage : my @params = $result->available_parameters Function: Returns the names of the available parameters Returns : Return list of available parameters used for this result Args : none =cut sub available_parameters { my $self = shift; return () unless defined $self->{_parameters}; return $self->{_parameters}->available_parameters; } =head2 add_parameter Title : add_parameter Usage : $result->add_parameter('gapext', 11); Function: Adds a parameter Returns : none Args : key - key value name for this parama value - value for this parameter =cut sub add_parameter { my ($self, $key, $value) = @_; unless (exists $self->{_parameters}) { $self->{_parameters} = Bio::Tools::Run::GenericParameters->new(); } $self->{_parameters}->set_parameter($key => $value); } =head2 get_statistic Title : get_statistic Usage : my $gap_ext = $result->get_statistic('kappa') Function: Returns the value for a specific statistic available from this result Returns : string Args : name of statistic (string) =cut sub get_statistic { my ($self, $stat) = @_; $stat || return; return unless defined $self->{_statistics}; return $self->{_statistics}->get_statistic($stat); } =head2 available_statistics Title : available_statistics Usage : my @statnames = $result->available_statistics Function: Returns the names of the available statistics Returns : Return list of available statistics used for this result Args : none =cut sub available_statistics { my $self = shift; return () unless defined $self->{_statistics}; return $self->{_statistics}->available_statistics; } =head2 add_statistic Title : add_statistic Usage : $result->add_statistic('lambda', 2.3); Function: Adds a statistic Returns : none Args : key - key value name for this statistic value - value for this statistic =cut sub add_statistic { my ($self, $key, $value) = @_; unless (exists $self->{_statistics}) { $self->{_statistics} = Bio::Search::GenericStatistics->new(); } $self->{_statistics}->set_statistic($key => $value); } 1; BioPerl-1.6.923/Bio/Search/Result/ResultFactory.pm000444000765000024 725112254227316 22005 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::ResultFactory # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::ResultFactory - A factory to create Bio::Search::Result::ResultI objects =head1 SYNOPSIS use Bio::Search::Result::ResultFactory; my $factory = Bio::Search::Result::ResultFactory->new(); my $resultobj = $factory->create(@args); =head1 DESCRIPTION This is a general way of hiding the object creation process so that we can dynamically change the objects that are created by the SearchIO parser depending on what format report we are parsing. This object is for creating new Results. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::ResultFactory; use vars qw($DEFAULT_TYPE); use strict; use base qw(Bio::Root::Root Bio::Factory::ObjectFactoryI); BEGIN { $DEFAULT_TYPE = 'Bio::Search::Result::GenericResult'; } =head2 new Title : new Usage : my $obj = Bio::Search::Result::ResultFactory->new(); Function: Builds a new Bio::Search::Result::ResultFactory object Returns : Bio::Search::Result::ResultFactory Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type) = $self->_rearrange([qw(TYPE)],@args); $self->type($type) if defined $type; return $self; } =head2 create Title : create Usage : $factory->create(%args) Function: Create a new L object Returns : L Args : hash of initialization parameters =cut sub create{ my ($self,@args) = @_; my $type = $self->type; eval { $self->_load_module($type) }; if( $@ ) { $self->throw("Unable to load module $type: $@"); } return $type->new(@args); } =head2 type Title : type Usage : $factory->type('Bio::Search::Result::GenericResult'); Function: Get/Set the Result creation type Returns : string Args : [optional] string to set =cut sub type{ my ($self,$type) = @_; if( defined $type ) { # redundancy with the create method which also calls _load_module # I know - but this is not a highly called object so I am going # to leave it in eval {$self->_load_module($type) }; if( $@ ){ $self->warn("Cannot find module $type, unable to set type"); } else { $self->{'_type'} = $type; } } return $self->{'_type'} || $DEFAULT_TYPE; } 1; BioPerl-1.6.923/Bio/Search/Result/ResultI.pm000444000765000024 3103712254227327 20607 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::Search::Result::ResultI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # Originally created by Aaron Mackey # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::ResultI - Abstract interface to Search Result objects =head1 SYNOPSIS # Bio::Search::Result::ResultI objects cannot be instantiated since this # module defines a pure interface. # Given an object that implements the Bio::Search::Result::ResultI interface, # you can do the following things with it: use Bio::SearchIO; my $io = Bio::SearchIO->new(-format => 'blast', -file => 't/data/HUMBETGLOA.tblastx'); my $result = $io->next_result; while( $hit = $result->next_hit()) { # enter code here for hit processing } my $id = $result->query_name(); my $desc = $result->query_description(); my $dbname = $result->database_name(); my $size = $result->database_letters(); my $num_entries = $result->database_entries(); my $gap_ext = $result->get_parameter('gapext'); my @params = $result->available_parameters; my $kappa = $result->get_statistic('kappa'); my @statnames = $result->available_statistics; =head1 DESCRIPTION Bio::Search::Result::ResultI objects are data structures containing the results from the execution of a search algorithm. As such, it may contain various algorithm specific information as well as details of the execution, but will contain a few fundamental elements, including the ability to return Bio::Search::Hit::HitI objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Aaron Mackey Eamackey@virginia.eduE (original author) Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 1999-2001 Aaron Mackey, Steve Chervitz. All Rights Reserved. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::Search::Result::ResultI; use strict; use base qw(Bio::AnalysisResultI); =head2 next_hit Title : next_hit Usage : while( $hit = $result->next_hit()) { ... } Function: Returns the next available Hit object, representing potential matches between the query and various entities from the database. Returns : a Bio::Search::Hit::HitI object or undef if there are no more. Args : none =cut sub next_hit { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 sort_hits Title : sort_hits Usage : $result->sort_hits(\&sort_function) Function : Sorts the available hit objects by a user-supplied function. Defaults to sort by descending score. Returns : n/a Args : A coderef for the sort function. See the documentation on the Perl sort() function for guidelines on writing sort functions. Note : To access the special variables $a and $b used by the Perl sort() function the user function must access Bio::Search::Result::ResultI namespace. For example, use : $result->sort_hits( sub{$Bio::Search::Result::ResultI::a->length <=> $Bio::Search::Result::ResultI::b->length}); NOT $result->sort_hits($a->length <=>$b->length); =cut sub sort_hits { my ($self, $coderef) = @_; my @sorted_hits; if ($coderef) { $self->throw('sort_hits requires a sort function passed as a subroutine reference') unless (ref($coderef) eq 'CODE'); } else { $coderef = \&_default_sort_hits; # throw a warning? } my @hits = $self->hits(); eval {@sorted_hits = sort $coderef @hits }; if ($@) { $self->throw("Unable to sort hits: $@"); } else { $self->{'_hits'} = \@sorted_hits; $self->{'_no_iterations'} = 1; # to bypass iteration checking in hits() method 1; } } =head2 _default sort_hits Title : _default_sort_hits Usage : Do not call directly. Function: Sort hits in descending order by score Args : None Returns: 1 on success Note : Used by $result->sort_hits() =cut sub _default_sort_hits { $Bio::Search::Result::ResultI::b->score <=> $Bio::Search::Result::ResultI::a->score; } =head2 query_name Title : query_name Usage : $id = $result->query_name(); Function: Get the string identifier of the query used by the algorithm that performed the search. Returns : a string. Args : none =cut sub query_name { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 query_accession Title : query_accession Usage : $id = $result->query_accession(); Function: Get the accession (if available) for the query sequence Returns : a string Args : none =cut sub query_accession { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 query_length Title : query_length Usage : $id = $result->query_length(); Function: Get the length of the query sequence used in the search. Returns : a number Args : none =cut sub query_length { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 query_description Title : query_description Usage : $id = $result->query_description(); Function: Get the description of the query sequence used in the search. Returns : a string Args : none =cut sub query_description { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 database_name Title : database_name Usage : $name = $result->database_name() Function: Used to obtain the name of the database that the query was searched against by the algorithm. Returns : a scalar string Args : none =cut sub database_name { my ($self,@args) = @_; $self->throw_not_implemented; } =head2 database_letters Title : database_letters Usage : $size = $result->database_letters() Function: Used to obtain the size of database that was searched against. Returns : a scalar integer (units specific to algorithm, but probably the total number of residues in the database, if available) or undef if the information was not available to the Processor object. Args : none =cut sub database_letters { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 database_entries Title : database_entries Usage : $num_entries = $result->database_entries() Function: Used to obtain the number of entries contained in the database. Returns : a scalar integer representing the number of entities in the database or undef if the information was not available. Args : none =cut sub database_entries { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 get_parameter Title : get_parameter Usage : my $gap_ext = $result->get_parameter('gapext') Function: Returns the value for a specific parameter used when running this result Returns : string Args : name of parameter (string) =cut sub get_parameter{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 available_parameters Title : available_parameters Usage : my @params = $result->available_parameters Function: Returns the names of the available parameters Returns : Return list of available parameters used for this result Args : none =cut sub available_parameters{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_statistic Title : get_statistic Usage : my $gap_ext = $result->get_statistic('kappa') Function: Returns the value for a specific statistic available from this result Returns : string Args : name of statistic (string) =cut sub get_statistic{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 available_statistics Title : available_statistics Usage : my @statnames = $result->available_statistics Function: Returns the names of the available statistics Returns : Return list of available statistics used for this result Args : none =cut sub available_statistics{ my ($self) = @_; $self->throw_not_implemented(); } =head2 algorithm Title : algorithm Usage : my $r_type = $result->algorithm Function: Obtain the name of the algorithm used to obtain the Result Returns : string (e.g., BLASTP) Args : [optional] scalar string to set value =cut sub algorithm{ my ($self) = @_; $self->throw_not_implemented(); } =head2 algorithm_version Title : algorithm_version Usage : my $r_version = $result->algorithm_version Function: Obtain the version of the algorithm used to obtain the Result Returns : string (e.g., 2.1.2) Args : [optional] scalar string to set algorithm version value =cut sub algorithm_version{ my ($self) = @_; $self->throw_not_implemented(); } =head2 algorithm_reference Title : algorithm_reference Usage : $obj->algorithm_reference($newval) Function: Returns : value of the literature reference for the algorithm Args : newvalue (optional) Comments: The default implementation in ResultI returns an empty string rather than throwing a NotImplemented exception, since the ref may not always be available and is not critical. =cut sub algorithm_reference{ my ($self) = @_; return ''; } =head2 rid Title : rid Usage : $obj->rid($newval) Function: Returns : value of the BLAST Request ID (eg. RID: ZABJ4EA7014) Args : newvalue (optional) Comments: The default implementation in ResultI returns an empty string rather than throwing a NotImplemented exception, since the RID may not always be available and is not critical. See: (1) http://www.ncbi.nlm.nih.gov/Class/MLACourse/Modules/BLAST/rid.html (2) http://www.ncbi.nlm.nih.gov/staff/tao/URLAPI/new/node63.html =cut sub rid{ my ($self) = @_; return ''; } =head2 num_hits Title : num_hits Usage : my $hitcount= $result->num_hits Function: returns the number of hits for this query result Returns : integer Args : none =cut sub num_hits{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 hits Title : hits Usage : my @hits = $result->hits Function: Returns the HitI objects contained within this Result Returns : Array of Bio::Search::Hit::HitI objects Args : none See Also: L =cut sub hits{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 no_hits_found Usage : $nohits = $blast->no_hits_found(); Purpose : Get boolean indicator indicating whether or not any hits were present in the report. This is NOT the same as determining the number of hits via the hits() method, which will return zero hits if there were no hits in the report or if all hits were filtered out during the parse. Thus, this method can be used to distinguish these possibilities for hitless reports generated when filtering. Returns : Boolean Argument : none =cut #----------- sub no_hits_found { shift->throw_not_implemented } =head2 set_no_hits_found Usage : $blast->set_no_hits_found(); Purpose : Set boolean indicator indicating whether or not any hits were present in the report. Returns : n/a Argument : none =cut sub set_no_hits_found { shift->throw_not_implemented } 1; BioPerl-1.6.923/Bio/Search/Result/WABAResult.pm000444000765000024 640612254227322 21106 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Result::WABAResult # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Result::WABAResult - Result object for WABA alignment output =head1 SYNOPSIS # use this object exactly as you would a GenericResult # the only extra method is query_database which is the # name of the file where the query sequence came from =head1 DESCRIPTION This object is for WABA result output, there is little difference between this object and a GenericResult save the addition of one method query_database. Expect many of the fields for GenericResult to be empty however as WABA was not intended to provide a lot of extra information other than the alignment. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Result::WABAResult; use strict; use base qw(Bio::Search::Result::GenericResult); =head2 new Title : new Usage : my $obj = Bio::Search::Result::WABAResult->new(); Function: Builds a new Bio::Search::Result::WABAResult object Returns : Bio::Search::Result::WABAResult Args : -query_database => "name of the database where the query came from" =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($db) = $self->_rearrange([qw(QUERY_DATABASE)], @args); defined $db && $self->query_database($db); return $self; } =head2 query_database Title : query_database Usage : $obj->query_database($newval) Function: Data field for the database filename where the query sequence came from Returns : value of query_database Args : newvalue (optional) =cut sub query_database{ my ($self,$value) = @_; if( defined $value) { $self->{'query_database'} = $value; } return $self->{'query_database'}; } =head2 All other methods are inherited from Bio::Search::Result::GenericResult See the L for complete documentation of the rest of the methods that are available for this module. =cut 1; BioPerl-1.6.923/Bio/Search/Tiling000755000765000024 012254227340 16444 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/Search/Tiling/MapTileUtils.pm000555000765000024 5056512254227340 21551 0ustar00cjfieldsstaff000000000000#$Id$ package Bio::Search::Tiling::MapTileUtils; use strict; use warnings; use Exporter; BEGIN { our @ISA = qw( Exporter ); our @EXPORT = qw( get_intervals_from_hsps interval_tiling decompose_interval containing_hsps covering_groups _allowable_filters _set_attributes _mapping_coeff); } # tiling trials # assumed: intervals are [$a0, $a1], with $a0 <= $a1 =head1 NAME Bio::Search::Tiling::MapTileUtils - utilities for manipulating closed intervals for an HSP tiling algorithm =head1 SYNOPSIS Not used directly. =head1 DESCRIPTION Not used directly. =head1 NOTE An "interval" in this module is defined as an arrayref C<[$a0, $a1]>, where C<$a0, $a1> are scalar numbers satisfying C<$a0 E= $a1>. =head1 AUTHOR Mark A. Jensen - maj -at- fortinbras -dot- us =head1 APPENDIX =head2 interval_tiling Title : interval_tiling() Usage : @tiling = interval_tiling( \@array_of_intervals ) Function: Find minimal set of intervals covering the input set Returns : array of arrayrefs of the form ( [$interval => [ @indices_of_collapsed_input_intervals ]], ...) Args : arrayref of intervals =cut sub interval_tiling { return unless $_[0]; # no input my $n = scalar @{$_[0]}; my %input; @input{(0..$n-1)} = @{$_[0]}; my @active = (0..$n-1); my @hold; my @tiled_ints; my @ret; while (@active) { my $tgt = $input{my $tgt_i = shift @active}; push @tiled_ints, $tgt_i; my $tgt_not_disjoint = 1; while ($tgt_not_disjoint) { $tgt_not_disjoint = 0; while (my $try_i = shift @active) { my $try = $input{$try_i}; if ( !are_disjoint($tgt, $try) ) { $tgt = min_covering_interval($tgt,$try); push @tiled_ints, $try_i; $tgt_not_disjoint = 1; } else { push @hold, $try_i; } } if (!$tgt_not_disjoint) { push @ret, [ $tgt => [@tiled_ints] ]; @tiled_ints = (); } @active = @hold; @hold = (); } } return @ret; } =head2 decompose_interval Title : decompose_interval Usage : @decomposition = decompose_interval( \@overlappers ) Function: Calculate the disjoint decomposition of a set of overlapping intervals, each annotated with a list of covering intervals Returns : array of arrayrefs of the form ( [[@interval] => [@indices_of_coverers]], ... ) Args : arrayref of intervals (arrayrefs like [$a0, $a1], with Note : Each returned interval is associated with a list of indices of the original intervals that cover that decomposition component (scalar size of this list could be called the 'coverage coefficient') Note : Coverage: each component of the decomp is completely contained in the input intervals that overlap it, by construction. Caveat : This routine expects the members of @overlappers to overlap, but doesn't check this. =cut ### what if the input intervals don't overlap?? They MUST overlap; that's ### what interval_tiling() is for. sub decompose_interval { return unless $_[0]; # no input my @ints = @{$_[0]}; my (%flat,@flat); ### this is ok, but need to handle the case where a lh and rh endpoint ### coincide... # decomposition -- # flatten: # every lh endpoint generates (lh-1, lh) # every rh endpoint generates (rh, rh+) foreach (@ints) { $flat{$$_[0]-1}++; $flat{$$_[0]}++; $flat{$$_[1]}++; $flat{$$_[1]+1}++; } # sort, create singletons if nec. my @a; @a = sort {$a<=>$b} keys %flat; # throw out first and last (meeting a boundary condition) shift @a; pop @a; # look for singletons @flat = (shift @a, shift @a); if ( $flat[1]-$flat[0] == 1 ) { @flat = ($flat[0],$flat[0], $flat[1]); } while (my $a = shift @a) { if ($a-$flat[-2]==2) { push @flat, $flat[-1]; # create singleton interval } push @flat, $a; } if ($flat[-1]-$flat[-2]==1 and @flat % 2) { push @flat, $flat[-1]; } # component intervals are consecutive pairs my @decomp; while (my $a = shift @flat) { push @decomp, [$a, shift @flat]; } # for each component, return a list of the indices of the input intervals # that cover the component. my @coverage; foreach my $i (0..$#decomp) { foreach my $j (0..$#ints) { unless (are_disjoint($decomp[$i], $ints[$j])) { if (defined $coverage[$i]) { push @{$coverage[$i]}, $j; } else { $coverage[$i] = [$j]; } } } } return map { [$decomp[$_] => $coverage[$_]] } (0..$#decomp); } =head2 are_disjoint Title : are_disjoint Usage : are_disjoint( [$a0, $a1], [$b0, $b1] ) Function: Determine if two intervals are disjoint Returns : True if the intervals are disjoint, false if they overlap Args : array of two intervals =cut sub are_disjoint { my ($int1, $int2) = @_; return 1 if ( $$int1[1] < $$int2[0] ) || ( $$int2[1] < $$int1[0]); return 0; } =head2 min_covering_interval Title : min_covering_interval Usage : $interval = min_covering_interval( [$a0,$a1],[$b0,$b1] ) Function: Determine the minimal covering interval for two intervals Returns : an interval Args : two intervals =cut sub min_covering_interval { my ($int1, $int2) = @_; my @a = sort {$a <=> $b} (@$int1, @$int2); return [$a[0],$a[-1]]; } =head2 get_intervals_from_hsps Title : get_intervals_from_hsps Usage : @intervals = get_intervals_from_hsps($type, @hsp_objects) Function: Return array of intervals of the form [ $start, $end ], from an array of hsp objects Returns : an array of intervals Args : scalar $type, array of HSPI objects; where $type is one of 'hit', 'subject', 'query' =cut sub get_intervals_from_hsps { my $type = shift; my @hsps; if (ref($type) =~ /HSP/) { push @hsps, $type; $type = 'query'; } elsif ( !grep /^$type$/,qw( hit subject query ) ) { die "Unknown HSP type '$type'"; } $type = 'hit' if $type eq 'subject'; push @hsps, @_; my @ret; foreach (@hsps) { # push @ret, [ $_->start($type), $_->end($type)]; push @ret, [ $_->range($type) ]; } return @ret; } # fast, clear, nasty, brutish and short. # for _allowable_filters(), _set_mapping() # covers BLAST, FAST families # FASTA is ambiguous (nt or aa) based on alg name only my $alg_lookup = { 'N' => { 'mapping' => [1,1], 'def_context' => ['p_','p_'], 'has_strand' => [1, 1], 'has_frame' => [0, 0]}, 'P' => { 'mapping' => [1,1], 'def_context' => ['all','all'], 'has_strand' => [0, 0], 'has_frame' => [0, 0]}, 'X' => { 'mapping' => [3, 1], 'def_context' => [undef,'all'], 'has_strand' => [1, 0], 'has_frame' => [1, 0]}, 'Y' => { 'mapping' => [3, 1], 'def_context' => [undef,'all'], 'has_strand' => [1, 0], 'has_frame' => [1, 0]}, 'TA' => { 'mapping' => [1, 3], 'def_context' => ['all',undef], 'has_strand' => [0, 1], 'has_frame' => [0, 1]}, 'TN' => { 'mapping' => [1, 3], 'def_context' => ['p_',undef], 'has_strand' => [1,1], 'has_frame' => [0, 1]}, 'TX' => { 'mapping' => [3, 3], 'def_context' => [undef,undef], 'has_strand' => [1, 1], 'has_frame' => [1, 1]}, 'TY' => { 'mapping' => [3, 3], 'def_context' => [undef,undef], 'has_strand' => [1, 1], 'has_frame' => [1, 1]} }; =head2 _allowable_filters Title : _allowable_filters Usage : _allowable_filters($Bio_Search_Hit_HitI, $type) Function: Return the HSP filters (strand, frame) allowed, based on the reported algorithm Returns : String encoding allowable filters: s = strand, f = frame Empty string if no filters allowed undef if algorithm unrecognized Args : A Bio::Search::Hit::HitI object, scalar $type, one of 'hit', 'subject', 'query'; default is 'query' =cut sub _allowable_filters { my $hit = shift; my $type = shift; $type ||= 'q'; unless (grep /^$type$/, qw( h q s ) ) { warn("Unknown type '$type'; returning ''"); return ''; } $type = 'h' if $type eq 's'; my $alg = $hit->algorithm; # pretreat (i.e., kludge it) $alg =~ /^RPS/ and ($alg) = ($alg =~ /\(([^)]+)\)/); for ($hit->algorithm) { /MEGABLAST/i && do { return qr/[s]/; }; /(.?)BLAST(.?)/i && do { return $$alg_lookup{$1.$2}{$type}; }; /(.?)FAST(.?)/ && do { return $$alg_lookup{$1.$2}{$type}; }; do { # unrecognized last; }; } return; } =head2 _set_attributes Title : _set_attributes Usage : $tiling->_set_attributes() Function: Sets attributes for invocant that depend on algorithm name Returns : True on success Args : none Note : setting based on the configuration table %alg_lookup =cut sub _set_attributes { my $self = shift; my $alg = $self->hit->algorithm; # pretreat (i.e., kludge it) $alg =~ /^RPS/ and ($alg) = ($alg =~ /\(([^)]+)\)/); for ($alg) { /MEGABLAST/i && do { ($self->{_mapping_query},$self->{_mapping_hit}) = (1,1); ($self->{_def_context_query},$self->{_def_context_hit}) = ('p_','p_'); ($self->{_has_frame_query},$self->{_has_frame_hit}) = (0, 0); ($self->{_has_strand_query},$self->{_has_strand_hit}) = (1, 1); last; }; /(.?)BLAST(.?)/i && do { ($self->{_mapping_query},$self->{_mapping_hit}) = @{$$alg_lookup{$1.$2}{mapping}}; ($self->{_def_context_query},$self->{_def_context_hit}) = @{$$alg_lookup{$1.$2}{def_context}}; ($self->{_has_frame_query},$self->{_has_frame_hit}) = @{$$alg_lookup{$1.$2}{has_frame}}; ($self->{_has_strand_query},$self->{_has_strand_hit}) = @{$$alg_lookup{$1.$2}{has_strand}}; last; }; /(.?)FAST(.?)/ && do { ($self->{_mapping_query},$self->{_mapping_hit}) = @{$$alg_lookup{$1.$2}{mapping}}; ($self->{_def_context_query},$self->{_def_context_hit}) = @{$$alg_lookup{$1.$2}{def_context}}; ($self->{_has_frame_query},$self->{_has_frame_hit}) = @{$$alg_lookup{$1.$2}{has_frame}}; ($self->{_has_strand_query},$self->{_has_strand_hit}) = @{$$alg_lookup{$1.$2}{has_strand}}; last; }; do { # unrecognized $self->warn("Unrecognized algorithm '$alg'; defaults may not work"); ($self->{_mapping_query},$self->{_mapping_hit}) = (1,1); ($self->{_def_context_query},$self->{_def_context_hit}) = ('all','all'); ($self->{_has_frame_query},$self->{_has_frame_hit}) = (0,0); ($self->{_has_strand_query},$self->{_has_strand_hit}) = (0,0); return 0; last; }; } return 1; } sub _mapping_coeff { my $obj = shift; my $type = shift; my %type_i = ( 'query' => 0, 'hit' => 1 ); unless ( ref($obj) && $obj->can('algorithm') ) { $obj->warn("Object type unrecognized"); return undef; } $type ||= 'query'; unless ( grep(/^$type$/, qw( query hit subject ) ) ) { $obj->warn("Sequence type unrecognized"); return undef; } $type = 'hit' if $type eq 'subject'; my $alg = $obj->algorithm; # pretreat (i.e., kludge it) $alg =~ /^RPS/ and ($alg) = ($alg =~ /\(([^)]+)\)/); for ($alg) { /MEGABLAST/i && do { return 1; }; /(.?)BLAST(.?)/i && do { return $$alg_lookup{$1.$2}{'mapping'}[$type_i{$type}]; }; /(.?)FAST(.?)/ && do { return $$alg_lookup{$1.$2}{'mapping'}[$type_i{$type}]; }; do { # unrecognized last; }; } return; } # a graphical depiction of a set of intervals sub _ints_as_text { my $ints = shift; my @ints = @$ints; my %pos; for (@ints) { $pos{$$_[0]}++; $pos{$$_[1]}++; } my @pos = sort {$a<=>$b} keys %pos; @pos = map {sprintf("%03d",$_)} @pos; #header my $max=0; $max = (length > $max) ? length : $max for (@pos); for my $j (0..$max-1) { my $i = $max-1-$j; my @line = map { substr($_, $j, 1) || '0' } @pos; print join('', @line), "\n"; } print '-' x @pos, "\n"; undef %pos; @pos{map {sprintf("%d",$_)} @pos} = (0..@pos); foreach (@ints) { print ' ' x $pos{$$_[0]}, '[', ' ' x ($pos{$$_[1]}-$pos{$$_[0]}-1), ']', ' ' x (@pos-$pos{$$_[1]}), "\n"; } } =head2 containing_hsps() Title : containing_hsps Usage : @hsps = containing_hsps($interval, @hsps_to_search) Function: Return a list of hsps whose coordinates completely contain the given $interval Returns : Array of HSP objects Args : $interval : [$int1, $int2], array of HSP objects =cut # could be more efficient if hsps are assumed ordered... sub containing_hsps { my $intvl = shift; my @hsps = @_; my @ret; my ($beg, $end) = @$intvl; foreach my $hsp (@hsps) { my ($start, $stop) = ($hsp->start, $hsp->end); push @ret, $hsp if ( $start <= $beg and $end <= $stop ); } return @ret; } =head2 covering_groups() Title : covering_groups Usage : Function: divide a list of **ordered,disjoint** intervals (as from a coverage map) into a set of disjoint covering groups Returns : array of arrayrefs, each arrayref a covering set of intervals Args : array of intervals =cut sub covering_groups { my @intervals = @_; return unless @intervals; my (@groups, $grp); push @{$groups[0]}, shift @intervals; $grp = $groups[0]; for (my $intvl = shift @intervals; @intervals; $intvl = shift @intervals) { if ( $intvl->[0] - $grp->[-1][1] == 1 ) { # intervals are direcly adjacent push @$grp, $intvl; } else { $grp = [$intvl]; push @groups, $grp; } } return @groups; } 1; # need our own subsequencer for hsps. package Bio::Search::HSP::HSPI; use strict; use warnings; =head2 matches_MT Title : matches_MT Usage : $hsp->matches($type, $action, $start, $end) Purpose : Get the total number of identical or conserved matches in the query or sbjct sequence for the given HSP. Optionally can report data within a defined interval along the seq. Returns : scalar int Args : Comments : Relies on seq_str('match') to get the string of alignment symbols between the query and sbjct lines which are used for determining the number of identical and conservative matches. Note : Modeled on Bio::Search::HSP::HSPI::matches =cut sub matches_MT { my( $self, @args ) = @_; my($type, $action, $beg, $end) = $self->_rearrange( [qw(TYPE ACTION START END)], @args); my @actions = qw( identities conserved searchutils ); # prep $type $self->throw("Type not specified") if !defined $type; $self->throw("Type '$type' unrecognized") unless grep(/^$type$/,qw(query hit subject)); $type = 'hit' if $type eq 'subject'; # prep $action $self->throw("Action not specified") if !defined $action; $self->throw("Action '$action' unrecognized") unless grep(/^$action$/, @actions); my ($len_id, $len_cons); my $c = Bio::Search::Tiling::MapTileUtils::_mapping_coeff($self, $type); if ((defined $beg && !defined $end) || (!defined $beg && defined $end)) { $self->throw("Both start and end are required"); } elsif ( (!defined($beg) && !defined($end)) || !$self->seq_str('match') ) { ## Get data for the whole alignment. # the reported values x mapping $self->debug("Sequence data not present in report; returning data for entire HSP") unless $self->seq_str('match'); ($len_id, $len_cons) = map { $c*$_ } ($self->num_identical, $self->num_conserved); for ($action) { $_ eq 'identities' && do { return $len_id; }; $_ eq 'conserved' && do { return $len_cons; }; $_ eq 'searchutils' && do { return ($len_id, $len_cons); }; do { $self->throw("What are YOU doing here?"); }; } } else { ## Get the substring representing the desired sub-section of aln. my($start,$stop) = $self->range($type); if ( $beg < $start or $stop < $end ) { $self->throw("Start/stop out of range [$start, $stop]"); } # handle gaps my $match_str = $self->seq_str('match'); if ($self->gaps) { # strip the homology string of gap positions relative # to the target type $match_str = $self->seq_str('match'); my $tgt = $self->seq_str($type); my $encode = $match_str ^ $tgt; my $zap = '-'^' '; $encode =~ s/$zap//g; $tgt =~ s/-//g; $match_str = $tgt ^ $encode; # match string is now the correct length for substr'ing below, # given that start and end are gapless coordinates in the # blast report } my $seq = ""; $seq = substr( $match_str, int( ($beg-$start)/Bio::Search::Tiling::MapTileUtils::_mapping_coeff($self, $type) ), int( 1+($end-$beg)/Bio::Search::Tiling::MapTileUtils::_mapping_coeff($self, $type) ) ); if(!CORE::length $seq) { $self->throw("Undefined sub-sequence ($beg,$end). Valid range = $start - $stop"); } $seq =~ s/ //g; # remove space (no info). $len_cons = (CORE::length $seq)*(Bio::Search::Tiling::MapTileUtils::_mapping_coeff($self,$type)); $seq =~ s/\+//g; # remove '+' characters (conservative substitutions) $len_id = (CORE::length $seq)*(Bio::Search::Tiling::MapTileUtils::_mapping_coeff($self,$type)); for ($action) { $_ eq 'identities' && do { return $len_id; }; $_ eq 'conserved' && do { return $len_cons; }; $_ eq 'searchutils' && do { return ($len_id, $len_cons); }; do { $self->throw("What are YOU doing here?"); }; } } } 1; package Bio::LocatableSeq; use strict; use warnings; # mixin the Bio::FeatureHolderI implementation of # Bio::Seq -- for get_tiled_aln =head2 get_SeqFeatures Title : get_SeqFeatures Usage : Function: Get the feature objects held by this feature holder. Features which are not top-level are subfeatures of one or more of the returned feature objects, which means that you must traverse the subfeature arrays of each top-level feature object in order to traverse all features associated with this sequence. Top-level features can be obtained by tag, specified in the argument. Use get_all_SeqFeatures() if you want the feature tree flattened into one single array. Example : Returns : an array of Bio::SeqFeatureI implementing objects Args : [optional] scalar string (feature tag) =cut sub get_SeqFeatures{ my $self = shift; my $tag = shift; if( !defined $self->{'_as_feat'} ) { $self->{'_as_feat'} = []; } if ($tag) { return map { $_->primary_tag eq $tag ? $_ : () } @{$self->{'_as_feat'}}; } else { return @{$self->{'_as_feat'}}; } } =head2 feature_count Title : feature_count Usage : $seq->feature_count() Function: Return the number of SeqFeatures attached to a sequence Returns : integer representing the number of SeqFeatures Args : None =cut sub feature_count { my ($self) = @_; if (defined($self->{'_as_feat'})) { return ($#{$self->{'_as_feat'}} + 1); } else { return 0; } } =head2 add_SeqFeature Title : add_SeqFeature Usage : $seq->add_SeqFeature($feat); $seq->add_SeqFeature(@feat); Function: Adds the given feature object (or each of an array of feature objects to the feature array of this sequence. The object passed is required to implement the Bio::SeqFeatureI interface. Returns : 1 on success Args : A Bio::SeqFeatureI implementing object, or an array of such objects. =cut sub add_SeqFeature { my ($self,@feat) = @_; $self->{'_as_feat'} = [] unless $self->{'_as_feat'}; foreach my $feat ( @feat ) { if( !$feat->isa("Bio::SeqFeatureI") ) { $self->throw("$feat is not a SeqFeatureI and that's what we expect..."); } $feat->attach_seq($self); push(@{$self->{'_as_feat'}},$feat); } return 1; } =head2 remove_SeqFeatures Title : remove_SeqFeatures Usage : $seq->remove_SeqFeatures(); Function: Flushes all attached SeqFeatureI objects. To remove individual feature objects, delete those from the returned array and re-add the rest. Example : Returns : The array of Bio::SeqFeatureI objects removed from this seq. Args : None =cut sub remove_SeqFeatures { my $self = shift; return () unless $self->{'_as_feat'}; my @feats = @{$self->{'_as_feat'}}; $self->{'_as_feat'} = []; return @feats; } 1; BioPerl-1.6.923/Bio/Search/Tiling/MapTiling.pm000555000765000024 13450712254227335 21104 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Tiling::MapTiling # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Tiling::MapTiling - An implementation of an HSP tiling algorithm, with methods to obtain frequently-requested statistics =head1 SYNOPSIS # get a BLAST $hit from somewhere, then $tiling = Bio::Search::Tiling::MapTiling->new($hit); # stats $numID = $tiling->identities(); $numCons = $tiling->conserved(); $query_length = $tiling->length('query'); $subject_length = $tiling->length('subject'); # or... $subject_length = $tiling->length('hit'); # get a visual on the coverage map print $tiling->coverage_map_as_text('query',$context,'LEGEND'); # tilings $context = $tiling->_context( -type => 'subject', -strand=> 1, -frame=>1); @covering_hsps_for_subject = $tiling->next_tiling('subject',$context); $context = $tiling->_context( -type => 'query', -strand=> -1, -frame=>0); @covering_hsps_for_query = $tiling->next_tiling('query', $context); =head1 DESCRIPTION Frequently, users want to use a set of high-scoring pairs (HSPs) obtained from a BLAST or other search to assess the overall level of identity, conservation, or coverage represented by matches between a subject and a query sequence. Because a set of HSPs frequently describes multiple overlapping sequence fragments, a simple summation of statistics over the HSPs will generally overestimate those statistics. To obtain an accurate estimate of global hit statistics, a 'tiling' of HSPs onto either the subject or the query sequence must be performed, in order to properly correct for this. This module will execute a tiling algorithm on a given hit based on an interval decomposition I'm calling the "coverage map". Internal object methods compute the various statistics, which are then stored in appropriately-named public object attributes. See L for more info on the algorithm. =head2 STRAND/FRAME CONTEXTS In BLASTX, TBLASTN, and TBLASTX reports, strand and frame information are reported for the query, subject, or query and subject, respectively, for each HSP. Tilings for these sequence types are only meaningful when they include HSPs in the same strand and frame, or "context". So, in these situations, the context must be specified in the method calls or the methods will throw. Contexts are specified as strings: C<[ 'all' | [m|p][_|0|1|2] ]>, where C = all HSPs (will throw if context must be specified), C = minus strand, C

= plus strand, and C<_> = no frame info, C<0,1,2> = respective (absolute) frame. The L method will convert a (strand, frame) specification to a context string, e.g.: $context = $self->_context(-type=>'query', -strand=>-1, -frame=>-2); returns C. The contexts present among the HSPs in a hit are identified and stored for convenience upon object construction. These are accessed off the object with the L method. If contexts don't apply for the given report, this returns C<('all')>. =head1 TILED ALIGNMENTS The experimental method L will use a tiling to concatenate tiled hsps into a series of L objects: @alns = $tiling->get_tiled_alns($type, $context); Each alignment contains two sequences with ids 'query' and 'subject', and consists of a concatenation of tiling HSPs which overlap or are directly adjacent. The alignment are returned in C<$type> sequence order. When HSPs overlap, the alignment sequence is taken from the HSP which comes first in the coverage map array. The sequences in each alignment contain features (even though they are L objects) which map the original query/subject coordinates to the new alignment sequence coordinates. You can determine the original BLAST fragments this way: $aln = ($tiling->get_tiled_alns)[0]; $qseq = $aln->get_seq_by_id('query'); $hseq = $aln->get_seq_by_id('subject'); foreach my $feat ($qseq->get_SeqFeatures) { $org_start = ($feat->get_tag_values('query_start'))[0]; $org_end = ($feat->get_tag_values('query_end'))[0]; # original fragment as represented in the tiled alignment: $org_fragment = $feat->seq; } foreach my $feat ($hseq->get_SeqFeatures) { $org_start = ($feat->get_tag_values('subject_start'))[0]; $org_end = ($feat->get_tag_values('subject_end'))[0]; # original fragment as represented in the tiled alignment: $org_fragment = $feat->seq; } =head1 DESIGN NOTE The major calculations are made just-in-time, and then memoized. So, for example, for a given MapTiling object, a coverage map would usually be calculated only once (for the query), and at most twice (if the subject perspective is also desired), and then only when a statistic is first accessed. Afterward, the map and/or any statistic is read from storage. So feel free to call the statistic methods frequently if it suits you. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj -at- fortinbras -dot- us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Tiling::MapTiling; use strict; use warnings; # Object preamble - inherits from Bio::Root::Root #use lib '../../..'; use Bio::Root::Root; use Bio::Search::Tiling::TilingI; use Bio::Search::Tiling::MapTileUtils; use Bio::LocatableSeq; # use base qw(Bio::Root::Root Bio::Search::Tiling::TilingI); use base qw(Bio::Root::Root Bio::Search::Tiling::TilingI); =head1 CONSTRUCTOR =head2 new Title : new Usage : my $obj = new Bio::Search::Tiling::GenericTiling(); Function: Builds a new Bio::Search::Tiling::GenericTiling object Returns : an instance of Bio::Search::Tiling::GenericTiling Args : -hit => $a_Bio_Search_Hit_HitI_object general filter function: -hsp_filter => sub { my $this_hsp = shift; ...; return 1 if $wanted; return 0; } =cut sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args); my($hit, $filter) = $self->_rearrange( [qw( HIT HSP_FILTER)],@args ); $self->throw("HitI object required") unless $hit; $self->throw("Argument must be HitI object") unless ( ref $hit && $hit->isa('Bio::Search::Hit::HitI') ); $self->{hit} = $hit; $self->_set_attributes(); $self->{"_algorithm"} = $hit->algorithm; my @hsps = $hit->hsps; # apply filter function if requested if ( defined $filter ) { if ( ref($filter) eq 'CODE' ) { @hsps = map { $filter->($_) ? $_ : () } @hsps; } else { $self->warn("-filter is not a coderef; ignoring"); } } # identify available contexts for my $t (qw( query hit )) { my %contexts; for my $i (0..$#hsps) { my $ctxt = $self->_context( -type => $t, -strand => $hsps[$i]->strand($t), -frame => $hsps[$i]->frame($t)); $contexts{$ctxt} ||= []; push @{$contexts{$ctxt}}, $i; } $self->{"_contexts_${t}"} = \%contexts; } $self->warn("No HSPs present in hit after filtering") unless (@hsps); $self->hsps(\@hsps); return $self; } # a tiling is based on the set of hsps contained in a single hit. # check all the boundaries - zero hsps, one hsp, all disjoint hsps =head1 TILING ITERATORS =head2 next_tiling Title : next_tiling Usage : @hsps = $self->next_tiling($type); Function: Obtain a tiling: a minimal set of HSPs covering the $type ('hit', 'subject', 'query') sequence Example : Returns : an array of HSPI objects Args : scalar $type: one of 'hit', 'subject', 'query', with 'subject' an alias for 'hit' =cut sub next_tiling{ my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); return $self->_tiling_iterator($type, $context)->(); } =head2 rewind_tilings Title : rewind_tilings Usage : $self->rewind_tilings($type) Function: Reset the next_tilings($type) iterator Example : Returns : True on success Args : scalar $type: one of 'hit', 'subject', 'query'; default is 'query' =cut sub rewind_tilings{ my $self = shift; my ($type,$context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); return $self->_tiling_iterator($type, $context)->('REWIND'); } =head1 ALIGNMENTS =head2 get_tiled_alns() Title : get_tiled_alns Usage : @alns = $tiling->get_tiled_alns($type, $context) Function: Use a tiling to construct a minimal set of alignment objects covering the region specified by $type/$context by splicing adjacent HSP tiles Returns : an array of Bio::SimpleAlign objects; see Note below Args : scalar $type: one of 'hit', 'subject', 'query' default is 'query' scalar $context: strand/frame context string Following $type and $context, an array of ordered, tiled HSP objects can be specified; this is the tiling that will directly the alignment construction default -- the first tiling provided by a tiling iterator Notes : Each returned alignment is a concatenation of adjacent tiles. The set of alignments will cover all regions described by the $type/$context pair in the hit. The pair of sequences in each alignment have ids 'query' and 'subject', and each sequence possesses SeqFeatures that map the original query or subject coordinates to the sequence coordinates in the tiled alignment. =cut sub get_tiled_alns { my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); my $t = shift; # first arg after type/context, arrayref to a tiling my @tiling; if ($t && (ref($t) eq 'ARRAY')) { @tiling = @$t; } else { # otherwise, take the first tiling available @tiling = $self->_make_tiling_iterator($type,$context)->(); } my @ret; my @map = $self->coverage_map($type, $context); my @intervals = map {$_->[0]} @map; # disjoint decomp # divide into disjoint covering groups my @groups = covering_groups(@intervals); require Bio::SimpleAlign; require Bio::SeqFeature::Generic; # cut hsp aligns along the disjoint decomp # look for gaps...or add gaps? my ($q_start, $h_start, $q_strand, $h_strand); # build seqs for my $grp (@groups) { my $taln = Bio::SimpleAlign->new(); my (@qfeats, @hfeats); my $query_string = ''; my $hit_string = ''; my ($qlen,$hlen) = (0,0); my ($qinc, $hinc, $qstart, $hstart); for my $intvl (@$grp) { # following just chooses the first available hsp containing the # interval -- this is arbitrary, could be smarter. my $aln = ( containing_hsps($intvl, @tiling) )[0]->get_aln; my $qseq = $aln->get_seq_by_pos(1); my $hseq = $aln->get_seq_by_pos(2); $qstart ||= $qseq->start; $hstart ||= $hseq->start; # calculate the slice boundaries my ($beg, $end); for ($type) { /query/ && do { $beg = $aln->column_from_residue_number($qseq->id, $intvl->[0]); $end = $aln->column_from_residue_number($qseq->id, $intvl->[1]); last; }; /subject|hit/ && do { $beg = $aln->column_from_residue_number($hseq->id, $intvl->[0]); $end = $aln->column_from_residue_number($hseq->id, $intvl->[1]); last; }; } $aln = $aln->slice($beg, $end); $qseq = $aln->get_seq_by_pos(1); $hseq = $aln->get_seq_by_pos(2); $qinc = $qseq->length - $qseq->num_gaps($Bio::LocatableSeq::GAP_SYMBOLS); $hinc = $hseq->length - $hseq->num_gaps($Bio::LocatableSeq::GAP_SYMBOLS); push @qfeats, Bio::SeqFeature::Generic->new( -start => $qlen+1, -end => $qlen+$qinc, -strand => $qseq->strand, -primary => 'query', -source_tag => 'BLAST', -display_name => 'query coordinates', -tag => { query_id => $qseq->id, query_desc => $qseq->desc, query_start => $qstart + (($qseq->strand && $qseq->strand < 0) ? -1 : 1)*$qlen, query_end => $qstart + (($qseq->strand && $qseq->strand < 0) ? -1 : 1)*($qlen+$qinc-1), } ); push @hfeats, Bio::SeqFeature::Generic->new( -start => $hlen+1, -end => $hlen+$hinc, -strand => $hseq->strand, -primary => 'subject/hit', -source_tag => 'BLAST', -display_name => 'subject/hit coordinates', -tag => { subject_id => $hseq->id, subject_desc => $hseq->desc, subject_start => $hstart + (($hseq->strand && $hseq->strand < 0) ? -1 : 1)*$hlen, subject_end => $hstart + (($hseq->strand && $hseq->strand < 0) ? -1 : 1)*($hlen+$hinc-1) } ); $query_string .= $qseq->seq; $hit_string .= $hseq->seq; $qlen += $qinc; $hlen += $hinc; } # create the LocatableSeqs and add the features to each # then add the seqs to the new aln # note in MapTileUtils, Bio::FeatureHolderI methods have been # mixed into Bio::LocatableSeq my $qseq = Bio::LocatableSeq->new( -id => 'query', -seq => $query_string); $qseq->add_SeqFeature(@qfeats); my $hseq = Bio::LocatableSeq->new( -id => 'subject', -seq => $hit_string ); $hseq->add_SeqFeature(@hfeats); $taln->add_seq($qseq); $taln->add_seq($hseq); push @ret, $taln; } return @ret; } =head1 STATISTICS =head2 identities Title : identities Usage : $tiling->identities($type, $action, $context) Function: Retrieve the calculated number of identities for the invocant Example : Returns : value of identities (a scalar) Args : scalar $type: one of 'hit', 'subject', 'query' default is 'query' option scalar $action: one of 'exact', 'est', 'fast', 'max' default is 'exact' option scalar $context: strand/frame context string Note : getter only =cut sub identities{ my $self = shift; my ($type, $action, $context) = @_; $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); if (!defined $self->{"identities_${type}_${action}_${context}"}) { $self->_calc_stats($type, $action, $context); } return $self->{"identities_${type}_${action}_${context}"}; } =head2 conserved Title : conserved Usage : $tiling->conserved($type, $action) Function: Retrieve the calculated number of conserved sites for the invocant Example : Returns : value of conserved (a scalar) Args : scalar $type: one of 'hit', 'subject', 'query' default is 'query' option scalar $action: one of 'exact', 'est', 'fast', 'max' default is 'exact' option scalar $context: strand/frame context string Note : getter only =cut sub conserved{ my $self = shift; my ($type, $action, $context) = @_; $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); if (!defined $self->{"conserved_${type}_${action}_${context}"}) { $self->_calc_stats($type, $action, $context); } return $self->{"conserved_${type}_${action}_${context}"}; } =head2 length Title : length Usage : $tiling->length($type, $action, $context) Function: Retrieve the total length of aligned residues for the seq $type Example : Returns : value of length (a scalar) Args : scalar $type: one of 'hit', 'subject', 'query' default is 'query' option scalar $action: one of 'exact', 'est', 'fast', 'max' default is 'exact' option scalar $context: strand/frame context string Note : getter only =cut sub length{ my $self = shift; my ($type,$action,$context) = @_; $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); if (!defined $self->{"length_${type}_${action}_${context}"}) { $self->_calc_stats($type, $action, $context); } return $self->{"length_${type}_${action}_${context}"}; } =head2 frac Title : frac Usage : $tiling->frac($type, $denom, $action, $context, $method) Function: Return the fraction of sequence length consisting of desired kinds of pairs (given by $method), with respect to $denom Returns : scalar float Args : -type => one of 'hit', 'subject', 'query' -denom => one of 'total', 'aligned' -action => one of 'exact', 'est', 'fast', 'max' -context => strand/frame context string -method => one of 'identical', 'conserved' Note : $denom == 'aligned', return desired_stat/num_aligned $denom == 'total', return desired_stat/_reported_length (i.e., length of the original input sequences) Note : In keeping with the spirit of Bio::Search::HSP::HSPI, reported lengths of translated dna are reduced by a factor of 3, to provide fractions relative to amino acid coordinates. =cut sub frac { my $self = shift; my @args = @_; my ($type, $denom, $action, $context, $method) = $self->_rearrange([qw(TYPE DENOM ACTION CONTEXT METHOD)],@args); $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); unless ($method and grep(/^$method$/, qw( identical conserved ))) { $self->throw("-method must specified; one of ('identical', 'conserved')"); } $denom ||= 'total'; unless (grep /^$denom/, qw( total aligned )) { $self->throw("Denominator selection must be one of ('total', 'aligned'), not '$denom'"); } my $key = "frac_${method}_${type}_${denom}_${action}_${context}"; my $stat; for ($method) { $_ eq 'identical' && do { $stat = $self->identities($type, $action, $context); last; }; $_ eq 'conserved' && do { $stat = $self->conserved($type, $action, $context); last; }; do { $self->throw("What are YOU doing here?"); }; } if (!defined $self->{$key}) { for ($denom) { /total/ && do { $self->{$key} = $stat/$self->_reported_length($type); # need fudge fac?? last; }; /aligned/ && do { $self->{$key} = $stat/$self->length($type,$action,$context); last; }; do { $self->throw("What are YOU doing here?"); }; } } return $self->{$key}; } =head2 frac_identical Title : frac_identical Usage : $tiling->frac_identical($type, $denom, $action, $context) Function: Return the fraction of sequence length consisting of identical pairs, with respect to $denom Returns : scalar float Args : -type => one of 'hit', 'subject', 'query' -denom => one of 'total', 'aligned' -action => one of 'exact', 'est', 'fast', 'max' -context => strand/frame context string Note : $denom == 'aligned', return conserved/num_aligned $denom == 'total', return conserved/_reported_length (i.e., length of the original input sequences) Note : In keeping with the spirit of Bio::Search::HSP::HSPI, reported lengths of translated dna are reduced by a factor of 3, to provide fractions relative to amino acid coordinates. Note : This an alias that calls frac() =cut sub frac_identical{ my $self = shift; my @args = @_; my ($type, $denom, $action,$context) = $self->_rearrange( [qw[ TYPE DENOM ACTION CONTEXT]],@args ); $self->frac( -type=>$type, -denom=>$denom, -action=>$action, -method=>'identical', -context=>$context); } =head2 frac_conserved Title : frac_conserved Usage : $tiling->frac_conserved($type, $denom, $action, $context) Function: Return the fraction of sequence length consisting of conserved pairs, with respect to $denom Returns : scalar float Args : -type => one of 'hit', 'subject', 'query' -denom => one of 'total', 'aligned' -action => one of 'exact', 'est', 'fast', 'max' -context => strand/frame context string Note : $denom == 'aligned', return conserved/num_aligned $denom == 'total', return conserved/_reported_length (i.e., length of the original input sequences) Note : In keeping with the spirit of Bio::Search::HSP::HSPI, reported lengths of translated dna are reduced by a factor of 3, to provide fractions relative to amino acid coordinates. Note : This an alias that calls frac() =cut sub frac_conserved{ my $self = shift; my @args = @_; my ($type, $denom, $action, $context) = $self->_rearrange( [qw[ TYPE DENOM ACTION CONTEXT]],@args ); $self->frac( -type=>$type, -denom=>$denom, -action=>$action, -context=>$context, -method=>'conserved'); } =head2 frac_aligned Title : frac_aligned Aliases : frac_aligned_query - frac_aligned(-type=>'query',...) frac_aligned_hit - frac_aligned(-type=>'hit',...) Usage : $tiling->frac_aligned(-type=>$type, -action=>$action, -context=>$context) Function: Return the fraction of input sequence length that was aligned by the algorithm Returns : scalar float Args : -type => one of 'hit', 'subject', 'query' -action => one of 'exact', 'est', 'fast', 'max' -context => strand/frame context string =cut sub frac_aligned{ my ($self, @args) = @_; my ($type, $action, $context) = $self->_rearrange([qw(TYPE ACTION CONTEXT)],@args); $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); if (!$self->{"frac_aligned_${type}_${action}_${context}"}) { $self->{"frac_aligned_${type}_${action}_${context}"} = $self->num_aligned($type,$action,$context)/$self->_reported_length($type); } return $self->{"frac_aligned_${type}_${action}_${context}"}; } sub frac_aligned_query { shift->frac_aligned(-type=>'query', @_) } sub frac_aligned_hit { shift->frac_aligned(-type=>'hit', @_) } =head2 num_aligned Title : num_aligned Usage : $tiling->num_aligned(-type=>$type) Function: Return the number of residues of sequence $type that were aligned by the algorithm Returns : scalar int Args : -type => one of 'hit', 'subject', 'query' -action => one of 'exact', 'est', 'fast', 'max' -context => strand/frame context string Note : Since this is calculated from reported coordinates, not symbol string counts, it is already in terms of "logical length" Note : Aliases length() =cut sub num_aligned { shift->length( @_ ) }; =head2 num_unaligned Title : num_unaligned Usage : $tiling->num_unaligned(-type=>$type) Function: Return the number of residues of sequence $type that were left unaligned by the algorithm Returns : scalar int Args : -type => one of 'hit', 'subject', 'query' -action => one of 'exact', 'est', 'fast', 'max' -context => strand/frame context string Note : Since this is calculated from reported coordinates, not symbol string counts, it is already in terms of "logical length" =cut sub num_unaligned { my $self = shift; my ($type,$action,$context) = @_; my $ret; $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); if (!defined $self->{"num_unaligned_${type}_${action}_${context}"}) { $self->{"num_unaligned_${type}_${action}_${context}"} = $self->_reported_length($type)-$self->num_aligned($type,$action,$context); } return $self->{"num_unaligned_${type}_${action}_${context}"}; } =head2 range Title : range Usage : $tiling->range(-type=>$type) Function: Returns the extent of the longest tiling as ($min_coord, $max_coord) Returns : array of two scalar integers Args : -type => one of 'hit', 'subject', 'query' -context => strand/frame context string =cut sub range { my ($self, $type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); my @a = $self->_contig_intersection($type,$context); return ($a[0][0], $a[-1][1]); } =head1 ACCESSORS =head2 coverage_map Title : coverage_map Usage : $map = $tiling->coverage_map($type) Function: Property to contain the coverage map calculated by _calc_coverage_map() - see that for details Example : Returns : value of coverage_map_$type as an array Args : scalar $type: one of 'hit', 'subject', 'query' default is 'query' Note : getter =cut sub coverage_map{ my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); if (!defined $self->{"coverage_map_${type}_${context}"}) { # following calculates coverage maps in all strands/frames # if necessary $self->_calc_coverage_map($type, $context); } # if undef is returned, then there were no hsps for given strand/frame if (!defined $self->{"coverage_map_${type}_${context}"}) { $self->warn("No HSPS present for type '$type' in context '$context' for this hit"); return undef; } return @{$self->{"coverage_map_${type}_${context}"}}; } =head2 coverage_map_as_text Title : coverage_map_as_text Usage : $tiling->coverage_map_as_text($type, $legend_flag) Function: Format a text-graphic representation of the coverage map Returns : an array of scalar strings, suitable for printing Args : $type: one of 'query', 'hit', 'subject' $context: strand/frame context string $legend_flag: boolean; add a legend indicating the actual interval coordinates for each component interval and hsp (in the $type sequence context) Example : print $tiling->coverage_map_as_text('query',1); =cut sub coverage_map_as_text{ my $self = shift; my ($type, $context, $legend_q) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); my @map = $self->coverage_map($type, $context); my @ret; my @hsps = $self->hit->hsps; my %hsps_i; require Tie::RefHash; tie %hsps_i, 'Tie::RefHash'; @hsps_i{@hsps} = (0..$#hsps); my @mx; foreach (0..$#map) { my @hspx = ('') x @hsps; my @these_hsps = @{$map[$_]->[1]}; @hspx[@hsps_i{@these_hsps}] = ('*') x @these_hsps; $mx[$_] = \@hspx; } untie %hsps_i; push @ret, "\tIntvl\n"; push @ret, "HSPS\t", join ("\t", (0..$#map)), "\n"; foreach my $h (0..$#hsps) { push @ret, join("\t", $h, map { $mx[$_][$h] } (0..$#map) ),"\n"; } if ($legend_q) { push @ret, "Interval legend\n"; foreach (0..$#map) { push @ret, sprintf("%d\t[%d, %d]\n", $_, @{$map[$_][0]}); } push @ret, "HSP legend\n"; my @ints = get_intervals_from_hsps($type,@hsps); foreach (0..$#hsps) { push @ret, sprintf("%d\t[%d, %d]\n", $_, @{$ints[$_]}); } } return @ret; } =head2 hit Title : hit Usage : $tiling->hit Function: Example : Returns : The HitI object associated with the invocant Args : none Note : getter only =cut sub hit{ my $self = shift; $self->warn("Getter only") if @_; return $self->{'hit'}; } =head2 hsps Title : hsps Usage : $tiling->hsps() Function: Container for the HSP objects associated with invocant Example : Returns : an array of hsps associated with the hit Args : on set, new value (an arrayref or undef, optional) =cut sub hsps{ my $self = shift; return $self->{'hsps'} = shift if @_; return @{$self->{'hsps'}}; } =head2 contexts Title : contexts Usage : @contexts = $tiling->context($type) or @indices = $tiling->context($type, $context) Function: Retrieve the set of available contexts in the hit, or the indices of hsps having the given context (integer indices for the array returned by $self->hsps) Returns : array of scalar context strings or array of scalar positive integers undef if no hsps in given context Args : $type: one of 'query', 'hit', 'subject' optional $context: context string =cut sub contexts{ my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); return keys %{$self->{"_contexts_$type"}} unless defined $context; return undef unless $self->{"_contexts_$type"}{$context}; return @{$self->{"_contexts_$type"}{$context}}; } =head2 mapping Title : mapping Usage : $tiling->mapping($type) Function: Retrieve the mapping coefficient for the sequence type based on the underlying algorithm Returns : scalar integer (mapping coefficient) Args : $type: one of 'query', 'hit', 'subject' Note : getter only (set in constructor) =cut sub mapping{ my $self = shift; my $type = shift; $self->_check_type_arg(\$type); return $self->{"_mapping_${type}"}; } =head2 default_context Title : default_context Usage : $tiling->default_context($type) Function: Retrieve the default strand/frame context string for the sequence type based on the underlying algorithm Returns : scalar string (context string) Args : $type: one of 'query', 'hit', 'subject' Note : getter only (set in constructor) =cut sub default_context{ my $self = shift; my $type = shift; $self->_check_type_arg(\$type); return $self->{"_def_context_${type}"}; } =head2 algorithm Title : algorithm Usage : $tiling->algorithm Function: Retrieve the algorithm name associated with the invocant's hit object Returns : scalar string Args : none Note : getter only (set in constructor) =cut sub algorithm{ my $self = shift; $self->warn("Getter only") if @_; return $self->{"_algorithm"}; } =head1 "PRIVATE" METHODS =head2 Calculators See L for lower level calculation methods. =head2 _calc_coverage_map Title : _calc_coverage_map Usage : $tiling->_calc_coverage_map($type) Function: Calculates the coverage map for the object's associated hit from the perspective of the desired $type (see Args:) and sets the coverage_map() property Returns : True on success Args : optional scalar $type: one of 'hit'|'subject'|'query' default is 'query' Note : The "coverage map" is an array with the following format: ( [ $component_interval => [ @containing_hsps ] ], ... ), where $component_interval is a closed interval (see DESCRIPTION) of the form [$a0, $a1] with $a0 <= $a1, and @containing_hsps is an array of all HspI objects in the hit which completely contain the $component_interval. The set of $component_interval's is a disjoint decomposition of the minimum set of minimal intervals that completely cover the hit's HSPs (from the perspective of the $type) Note : This calculates the map for all strand/frame contexts available in the hit =cut sub _calc_coverage_map { my $self = shift; my ($type) = @_; $self->_check_type_arg(\$type); # obtain the [start, end] intervals for all hsps in the hit (relative # to the type) unless ($self->{'hsps'}) { $self->warn("No HSPs for this hit"); return; } my (@map, @hsps, %filters, @intervals); # conversion here? my $c = $self->mapping($type); # create the possible maps for my $context ($self->contexts($type)) { @map = (); @hsps = ($self->hsps)[$self->contexts($type, $context)]; @intervals = get_intervals_from_hsps( $type, @hsps ); # the "frame" my $f = ($intervals[0]->[0] - 1) % $c; # convert interval endpoints... for (@intervals) { $$_[0] = ($$_[0] - $f + $c - 1)/$c; $$_[1] = ($$_[1] - $f)/$c; } # determine the minimal set of disjoint intervals that cover the # set of hsp intervals my @dj_set = interval_tiling(\@intervals); # decompose each disjoint interval into another set of disjoint # intervals, each of which is completely contained within the # original hsp intervals with which it overlaps my $i=0; my @decomp; for my $dj_elt (@dj_set) { my ($covering, $indices) = @$dj_elt; my @covering_hsps = @hsps[@$indices]; my @coverers = @intervals[@$indices]; @decomp = decompose_interval( \@coverers ); for (@decomp) { my ($component, $container_indices) = @{$_}; push @map, [ $component, [@covering_hsps[@$container_indices]] ]; } 1; } # unconvert the components: ##### foreach (@map) { $$_[0][0] = $c*$$_[0][0] - $c + 1 + $f; $$_[0][1] = $c*$$_[0][1] + $f; } foreach (@dj_set) { $$_[0][0] = $c*$$_[0][0] - $c + 1 + $f; $$_[0][1] = $c*$$_[0][1] + $f; } # sort the map on the interval left-ends @map = sort { $a->[0][0]<=>$b->[0][0] } @map; $self->{"coverage_map_${type}_${context}"} = [@map]; # set the _contig_intersection attribute here (side effect) $self->{"_contig_intersection_${type}_${context}"} = [map { $$_[0] } @map]; } return 1; # success } =head2 _calc_stats Title : _calc_stats Usage : $tiling->_calc_stats($type, $action, $context) Function: Calculates [estimated] tiling statistics (identities, conserved sites length) and sets the public accessors Returns : True on success Args : scalar $type: one of 'hit', 'subject', 'query' default is 'query' optional scalar $action: requests calculation method currently one of 'exact', 'est', 'fast', 'max' option scalar $context: strand/frame context string Note : Action: The statistics are calculated by summing quantities over the disjoint component intervals, taking into account coverage of those intervals by multiple HSPs. The action tells the algorithm how to obtain those quantities-- 'exact' will use Bio::Search::HSP::HSPI::matches to count the appropriate segment of the homology string; 'est' will estimate the statistics by multiplying the fraction of the HSP overlapped by the component interval (see MapTileUtils) by the BLAST-reported identities/postives (this may be convenient for BLAST summary report formats) * Both exact and est take the average over the number of HSPs that overlap the component interval. 'max' uses the exact method to calculate the statistics, and returns only the maximum identites/positives over overlapping HSP for the component interval. No averaging is involved here. 'fast' doesn't involve tiling at all (hence the name), but it seems like a very good estimate, and uses only reported values, and so does not require sequence data. It calculates an average of reported identities, conserved sites, and lengths, over unmodified hsps in the hit, weighted by the length of the hsps. =cut sub _calc_stats { my $self = shift; my ($type, $action, $context) = @_; # need to check args here, in case method is called internally. $self->_check_type_arg(\$type); $self->_check_action_arg(\$action); $self->_check_context_arg($type, \$context); my ($ident, $cons, $length) = (0,0,0); # fast : avoid coverage map altogether, get a pretty damn # good estimate with a weighted average of reported hsp # statistics ($action eq 'fast') && do { my @hsps = $self->hit->hsps; @hsps = @hsps[$self->contexts($type, $context)]; # weights for averages my @wt = map {$_->length($type)} @hsps; my $sum = eval( join('+',@wt) ); $_ /= $sum for (@wt); for (@hsps) { my $wt = shift @wt; $ident += $wt*$_->matches_MT($type,'identities'); $cons += $wt*$_->matches_MT($type,'conserved'); $length += $wt*$_->length($type); } }; # or, do tiling # calculate identities/conserved sites in tiling # estimate based on the fraction of the component interval covered # and ident/cons reported by the HSPs ($action ne 'fast') && do { foreach ($self->coverage_map($type, $context)) { my ($intvl, $hsps) = @{$_}; my $len = ($$intvl[1]-$$intvl[0]+1); my $ncover = ($action eq 'max') ? 1 : scalar @$hsps; my ($acc_i, $acc_c) = (0,0); foreach my $hsp (@$hsps) { for ($action) { ($_ eq 'est') && do { my ($inc_i, $inc_c) = $hsp->matches_MT( -type => $type, -action => 'searchutils', ); my $frac = $len/$hsp->length($type); $acc_i += $inc_i * $frac; $acc_c += $inc_c * $frac; last; }; ($_ eq 'max') && do { my ($inc_i, $inc_c) = $hsp->matches_MT( -type => $type, -action => 'searchutils', -start => $$intvl[0], -end => $$intvl[1] ); $acc_i = ($acc_i > $inc_i) ? $acc_i : $inc_i; $acc_c = ($acc_c > $inc_c) ? $acc_c : $inc_c; last; }; (!$_ || ($_ eq 'exact')) && do { my ($inc_i, $inc_c) = $hsp->matches_MT( -type => $type, -action => 'searchutils', -start => $$intvl[0], -end => $$intvl[1] ); $acc_i += $inc_i; $acc_c += $inc_c; last; }; } } $ident += ($acc_i/$ncover); $cons += ($acc_c/$ncover); $length += $len; } }; $self->{"identities_${type}_${action}_${context}"} = $ident; $self->{"conserved_${type}_${action}_${context}"} = $cons; $self->{"length_${type}_${action}_${context}"} = $length; return 1; } =head2 Tiling Helper Methods =cut # coverage_map is of the form # ( [ $interval, \@containing_hsps ], ... ) # so, for each interval, pick one of the containing hsps, # and return the union of all the picks. # use the combinatorial generating iterator, with # the urns containing the @containing_hsps for each # interval =head2 _make_tiling_iterator Title : _make_tiling_iterator Usage : $self->_make_tiling_iterator($type) Function: Create an iterator code ref that will step through all minimal combinations of HSPs that produce complete coverage of the $type ('hit', 'subject', 'query') sequence, and set the correct iterator property of the invocant Example : Returns : The iterator Args : scalar $type, one of 'hit', 'subject', 'query'; default is 'query' =cut sub _make_tiling_iterator { ### create the urns my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); # initialize the urns my @urns = map { [0, $$_[1]] } $self->coverage_map($type, $context); my $FINISHED = 0; my $iter = sub { # rewind? if (my $rewind = shift) { # reinitialize urn indices $$_[0] = 0 for (@urns); $FINISHED = 0; return 1; } # check if done... return if $FINISHED; my $finished_incrementing = 0; # @ret is the collector of urn choices my @ret; for my $urn (@urns) { my ($n, $hsps) = @$urn; push @ret, $$hsps[$n]; unless ($finished_incrementing) { if ($n == $#$hsps) { $$urn[0] = 0; } else { ($$urn[0])++; $finished_incrementing = 1 } } } # backstop... $FINISHED = 1 unless $finished_incrementing; # uniquify @ret # $hsp->rank is a unique identifier for an hsp in a hit. # preserve order in @ret my (%order, %uniq); @order{(0..$#ret)} = @ret; $uniq{$order{$_}->rank} = $_ for (0..$#ret); @ret = @order{ sort {$a<=>$b} values %uniq }; return @ret; }; return $iter; } =head2 _tiling_iterator Title : _tiling_iterator Usage : $tiling->_tiling_iterator($type,$context) Function: Retrieve the tiling iterator coderef for the requested $type ('hit', 'subject', 'query') Example : Returns : coderef to the desired iterator Args : scalar $type, one of 'hit', 'subject', 'query' default is 'query' option scalar $context: strand/frame context string Note : getter only =cut sub _tiling_iterator { my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); if (!defined $self->{"_tiling_iterator_${type}_${context}"}) { $self->{"_tiling_iterator_${type}_${context}"} = $self->_make_tiling_iterator($type,$context); } return $self->{"_tiling_iterator_${type}_${context}"}; } =head2 Construction Helper Methods See also L. =cut sub _check_type_arg { my $self = shift; my $typeref = shift; $$typeref ||= 'query'; $self->throw("Unknown type '$$typeref'") unless grep(/^$$typeref$/, qw( hit query subject )); $$typeref = 'hit' if $$typeref eq 'subject'; return 1; } sub _check_action_arg { my $self = shift; my $actionref = shift; if (!$$actionref) { $$actionref = ($self->_has_sequence_data ? 'exact' : 'est'); } else { $self->throw("Calc action '$$actionref' unrecognized") unless grep /^$$actionref$/, qw( est exact fast max ); if ($$actionref ne 'est' and !$self->_has_sequence_data) { $self->warn("Blast file did not possess sequence data; defaulting to 'est' action"); $$actionref = 'est'; } } return 1; } sub _check_context_arg { my $self = shift; my ($type, $contextref) = @_; if (!$$contextref) { $self->throw("Type '$type' requires strand/frame context for algorithm ".$self->algorithm) unless ($self->mapping($type) == 1); # set default according to default_context attrib $$contextref = $self->default_context($type); } else { ($$contextref =~ /^[mp]$/) && do { $$contextref .= '_' }; $self->throw("Context '$$contextref' unrecognized") unless $$contextref =~ /all|[mp][0-2_]/; } } =head2 _make_context_key Title : _make_context_key Alias : _context Usage : $tiling->_make_context_key(-strand => $strand, -frame => $frame) Function: create a string indicating strand/frame context; serves as component of memoizing hash keys Returns : scalar string Args : -type => one of ('query', 'hit', 'subject') -strand => one of (1,0,-1) -frame => one of (-2, 1, 0, 1, -2) called w/o args: returns 'all' =cut sub _make_context_key { my $self = shift; my @args = @_; my ($type, $strand, $frame) = $self->_rearrange([qw(TYPE STRAND FRAME)], @args); _check_type_arg(\$type); return 'all' unless (defined $strand or defined $frame); if ( defined $strand && $self->_has_strand($type) ) { if (defined $frame && $self->_has_frame($type)) { return ($strand >= 0 ? 'p' : 'm').abs($frame); } else { return ($strand >= 0 ? 'p_' : 'm_'); } } else { if (defined $frame && $self->_has_frame($type)) { $self->warn("Frame defined without strand; punting with plus strand"); return 'p'.abs($frame); } else { return 'all'; } } } =head2 _context Title : _context Alias : _make_context_key Usage : $tiling->_make_context_key(-strand => $strand, -frame => $frame) Function: create a string indicating strand/frame context; serves as component of memoizing hash keys Returns : scalar string Args : -type => one of ('query', 'hit', 'subject') -strand => one of (1,0,-1) -frame => one of (-2, 1, 0, 1, -2) called w/o args: returns 'all' =cut sub _context { shift->_make_context_key(@_) } =head2 Predicates Most based on a reading of the algorithm name with a configuration lookup. =over =item _has_sequence_data() =cut sub _has_sequence_data { my $self = shift; $self->throw("Hit attribute not yet set") unless defined $self->hit; return (($self->hit->hsps)[0]->seq_str('match') ? 1 : 0); } =item _has_logical_length() =cut sub _has_logical_length { my $self = shift; my $type = shift; $self->_check_type_arg(\$type); # based on mapping coeff $self->throw("Mapping coefficients not yet set") unless defined $self->mapping($type); return ($self->mapping($type) > 1); } =item _has_strand() =cut sub _has_strand { my $self = shift; my $type = shift; $self->_check_type_arg(\$type); return $self->{"_has_strand_${type}"}; } =item _has_frame() =cut sub _has_frame { my $self = shift; my $type = shift; $self->_check_type_arg(\$type); return $self->{"_has_frame_${type}"}; } =back =head1 Private Accessors =head2 _contig_intersection Title : _contig_intersection Usage : $tiling->_contig_intersection($type) Function: Return the minimal set of $type coordinate intervals covered by the invocant's HSPs Returns : array of intervals (2-member arrayrefs; see MapTileUtils) Args : scalar $type: one of 'query', 'hit', 'subject' =cut sub _contig_intersection { my $self = shift; my ($type, $context) = @_; $self->_check_type_arg(\$type); $self->_check_context_arg($type, \$context); if (!defined $self->{"_contig_intersection_${type}_${context}"}) { $self->_calc_coverage_map($type); } return @{$self->{"_contig_intersection_${type}_${context}"}}; } =head2 _reported_length Title : _reported_length Usage : $tiling->_reported_length($type) Function: Get the total length of the seq $type for the invocant's hit object, as reported by (not calculated from) the input data file Returns : scalar int Args : scalar $type: one of 'query', 'hit', 'subject' Note : This is kludgy; the hit object does not currently maintain accessors for these values, but the hsps possess these attributes. This is a wrapper that allows a consistent access method in the MapTiling code. Note : Since this number is based on a reported length, it is already a "logical length". =cut sub _reported_length { my $self = shift; my $type = shift; $self->_check_type_arg(\$type); my $key = uc( $type."_LENGTH" ); return ($self->hsps)[0]->{$key}; } 1; BioPerl-1.6.923/Bio/Search/Tiling/TilingI.pm000555000765000024 2441312254227313 20525 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::Search::Tiling::TilingI # # Please direct questions and support issues to # # Cared for by Mark A. Jensen # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Search::Tiling::TilingI - Abstract interface for an HSP tiling module =head1 SYNOPSIS Not used directly. Useful POD here for developers, however. The interface is desgined to make the following code conversion as simple as possible: From: # Bio::Search::SearchUtils-based while ( local $_ = $result->next_hit ) { printf( "E-value: %g; Fraction aligned: %f; Number identical: %d\n", $hit->significance, $hit->frac_aligned_query, $hit->num_identical); } To: # TilingI-based while ( local $_ = $result->next_hit ) { my $tiling = Bio::Search::Tiling::MyTiling($_); printf( "E-value: %g; Fraction aligned: %f; Number identical: %d\n", $hit->significance, $tiling->frac_aligned_query, $tiling->num_identical); } =head1 DESCRIPTION This module provides strong suggestions for any intended HSP tiling object implementation. An object subclassing TilingI should override the methods defined here according to their descriptions below. See the section STATISTICS METHODS for hints on implementing methods that are valid across different algorithms and report types. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj@fortinbras.us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Search::Tiling::TilingI; use strict; use warnings; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use base qw(Bio::Root::Root); =head2 STATISTICS METHODS The tiling statistics can be thought of as global counterparts to similar statistics defined for the individual HSPs. We therefore prescribe definitions for many of the synonymous methods defined in L. The tiling statistics must be able to keep track of the coordinate systems in which both the query and subject sequences exist; i.e., either nucleotide or amino acid. This information is typically inferred from the name of the algorithm used to perform the original search (contained in C<$hit_object-Ealgorithm>). Here is a table of algorithm information that may be useful (if you trust us). algorithm query on hit coordinates(q/h) --------- ------------ --------------- blastn dna on dna dna/dna blastp aa on aa aa/aa blastx xna on aa dna/aa tblastn aa on xna aa/dna tblastx xna on xna dna/dna fasta dna on dna dna/dna fasta aa on aa aa/aa fastx xna on aa dna/aa fasty xna on aa dna/aa tfasta aa on xna aa/dna tfasty aa on xna aa/dna megablast dna on dna dna/dna xna: translated nucleotide data Statistics methods must also be aware of differences in reporting among the algorithms. Hit attributes are not necessarily normalized over all algorithms. Devs, please feel free to add examples to the list below. =over =item NCBI BLAST vs WU-BLAST (AB-BLAST) lengths The total length of the alignment is reported differently between these two flavors. C<$hit_object-Elength()> will contain the number in the denominator of the stats line; i.e., 120 in Identical = 34/120 Positives = 67/120 NCBI BLAST uses the total length of the query sequence as input by the user (a.k.a. "with gaps"). WU-BLAST uses the length of the query sequence actually aligned by the algorithm (a.k.a. "without gaps"). =back Finally, developers should remember that sequence data may or may not be associated with the HSPs contained in the hit object. This will typically depend on whether a full report (e.g, C) or a summary (e.g., C) was parsed. Statistics methods that depend directly on the sequence data will need to check that that data is present. =head2 identities Title : identities Alias : num_identical Usage : $num_identities = $tiling->identities() Function: Return the estimated or exact number of identities in the tiling, accounting for overlapping HSPs Example : Returns : number of identical residue pairs Args : =cut sub identities{ my ($self,@args) = @_; $self->throw_not_implemented; } #HSPI synonym sub num_identical { shift->identities( @_ ) } =head2 conserved Title : conserved Alias : num_conserved Usage : $num_conserved = $tiling->conserved() Function: Return the estimated or exact number of conserved sites in the tiling, accounting for overlapping HSPs Example : Returns : number of conserved residue pairs Args : =cut sub conserved{ my ($self,@args) = @_; $self->throw_not_implemented; } #HSPI synonym sub num_conserved { shift->conserved( @_ ) } =head2 length Title : length Usage : $max_length = $tiling->length($type) Function: Return the total number of residues of the subject or query sequence covered by the tiling Returns : number of "logical" residues covered Args : scalar $type, one of 'hit', 'subject', 'query' =cut sub length{ my ($self, $type, @args) = @_; $self->throw_not_implemented; } =head2 frac_identical Title : frac_identical Usage : $tiling->frac_identical($type) Function: Return the fraction of sequence length consisting of identical pairs Returns : scalar float Args : scalar $type, one of 'hit', 'subject', 'query' Note : This method must take account of the $type coordinate system and the length reporting method (see STATISTICS METHODS above) =cut sub frac_identical { my ($self, $type, @args) = @_; $self->throw_not_implemented; } =head2 percent_identity Title : percent_identity Usage : $tiling->percent_identity($type) Function: Return the fraction of sequence length consisting of identical pairs as a percentage Returns : scalar float Args : scalar $type, one of 'hit', 'subject', 'query' =cut sub percent_identity { my ($self, $type, @args) = @_; return $self->frac_identical($type, @args) * 100; } =head2 frac_conserved Title : frac_conserved Usage : $tiling->frac_conserved($type) Function: Return the fraction of sequence length consisting of conserved pairs Returns : scalar float Args : scalar $type, one of 'hit', 'subject', 'query' Note : This method must take account of the $type coordinate system and the length reporting method (see STATISTICS METHODS above) =cut sub frac_conserved{ my ($self, $type, @args) = @_; $self->throw_not_implemented; } =head2 percent_conserved Title : percent_conserved Usage : $tiling->percent_conserved($type) Function: Return the fraction of sequence length consisting of conserved pairs as a percentage Returns : scalar float Args : scalar $type, one of 'hit', 'subject', 'query' =cut sub percent_conserved { my ($self, $type, @args) = @_; return $self->frac_conserved($type, @args) * 100; } =head2 frac_aligned Title : frac_aligned Usage : $tiling->frac_aligned($type) Function: Return the fraction of B sequence length consisting that was aligned by the algorithm Returns : scalar float Args : scalar $type, one of 'hit', 'subject', 'query' Note : This method must take account of the $type coordinate system and the length reporting method (see STATISTICS METHODS above) =cut sub frac_aligned{ my ($self, $type, @args) = @_; $self->throw_not_implemented; } # aliases for back compat sub frac_aligned_query { shift->frac_aligned('query', @_) } sub frac_aligned_hit { shift->frac_aligned('hit', @_) } =head2 range Title : range Usage : $tiling->range($type) Function: Returns the extent of the longest tiling as ($min_coord, $max_coord) Returns : array of two scalar integers Args : scalar $type, one of 'hit', 'subject', 'query' =cut sub range { my ($self, $type, @args) = @_; $self->throw_not_implemented; } =head1 TILING ITERATORS =head2 next_tiling Title : next_tiling Usage : @hsps = $self->next_tiling($type); Function: Obtain a tiling of HSPs over the $type ('hit', 'subject', 'query') sequence Example : Returns : an array of HSPI objects Args : scalar $type: one of 'hit', 'subject', 'query', with 'subject' an alias for 'hit' =cut sub next_tiling{ my ($self,$type,@args) = @_; $self->throw_not_implemented; } =head2 rewind_tilings Title : rewind_tilings Usage : $self->rewind_tilings($type) Function: Reset the next_tilings($type) iterator Example : Returns : True on success Args : scalar $type: one of 'hit', 'subject', 'query', with 'subject' an alias for 'hit' =cut sub rewind_tilings{ my ($self, $type, @args) = @_; $self->throw_not_implemented; } #alias sub rewind { shift->rewind_tilings(@_) } =head1 INFORMATIONAL ACCESSORS =head2 algorithm Title : algorithm Usage : $tiling->algorithm Function: Retrieve the algorithm name associated with the invocant's hit object Returns : scalar string Args : =cut sub algorithm{ my ($self, @args) = @_; $self->throw_not_implemented; } 1; BioPerl-1.6.923/Bio/SearchIO000755000765000024 012254227340 15446 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/SearchIO/axt.pm000444000765000024 3124712254227327 16771 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::axt # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::axt - a parser for axt format reports =head1 SYNOPSIS use Bio::SearchIO; my $parser = Bio::SearchIO->new(-format => 'axt', -file => 't/data/report.blastz'); while( my $result = $parser->next_result ) { while( my $hit = $result->next_hit ) { while( my $hsp = $hit->next_hsp ) { } } } =head1 DESCRIPTION This is a parser and event-generator for AXT format reports. BLASTZ reports (Schwartz et al,(2003) Genome Research, 13:103-107) are normally in LAV format but are commonly post-processed to AXT format; many precomputed BLASTZ reports, such as those found in the UCSC Genome Browser, are in AXT format. This parser will also parse any AXT format produced from any lav report and directly out of BLAT. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::axt; use vars qw(%MODEMAP %MAPPING @STATES $GAPCHAR); use strict; use Bio::Search::Result::ResultFactory; use Bio::Search::HSP::HSPFactory; use base qw(Bio::SearchIO); use POSIX; BEGIN { # mapping of NCBI Blast terms to Bioperl hash keys %MODEMAP = ('AXTOutput' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); $GAPCHAR = '-'; %MAPPING = ( 'Hsp_score' => 'HSP-score', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', # ignoring this for now 'Hsp_align-len' => 'HSP-hsp_length', 'Hit_id' => 'HIT-name', 'AXTOutput_query-def'=> 'RESULT-query_name', ); } =head2 new Title : new Usage : my $obj = Bio::SearchIO::axt->new(); Function: Builds a new Bio::SearchIO::axt object Returns : an instance of Bio::SearchIO::axt Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result{ my ($self) = @_; local $/ = "\n"; local $_; my ($curquery,$curhit); $self->start_document(); my @hit_signifs; while( defined ($_ = $self->_readline )) { next if (/^\s+$/); if( m/^(\d+)\s+ # alignment number - we'll throw this away anyways (\S+)\s+ # Query name (\d+)\s+(\d+)\s+ # Query start Query end (always + strand, 0 based) (\S+)\s+ # Hit name (\d+)\s+(\d+)\s+ # Hit start Hit end (0 based) ([\-\+])\s+ # Hit strand ([\d\.\-]+)\s+ # Score /ox ) { my ($alnnum, $qname,$qstart,$qend, $hname, $hstart,$hend,$hstrand, $score) = ($1,$2,$3,$4,$5, $6,$7,$8,$9); $self->{'_reporttype'} = 'AXT'; # Jim's code is 0 based # yes, but axt format is one-based, see bug 3145 - cjfields 10-11-10 #$qstart++; $qend++; $hstart++; $hend++; if( defined $curquery && $curquery ne $qname ) { $self->end_element({'Name' => 'Hit'}); $self->_pushback($_); $self->end_element({'Name' => 'AXTOutput'}); return $self->end_document(); } if( defined $curhit && $curhit ne $hname) { # slight duplication here -- keep these in SYNC $self->end_element({'Name' => 'Hit'}); $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hname}); } elsif ( ! defined $curquery ) { $self->start_element({'Name' => 'AXTOutput'}); $self->{'_result_count'}++; $self->element({'Name' => 'AXTOutput_query-def', 'Data' => $qname }); $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hname}); } $self->start_element({'Name' => 'Hsp'}); my $queryalign = $self->_readline; my $hitalign = $self->_readline; chomp($queryalign); chomp($hitalign); my $alnlen = length($queryalign); my $qgapnum = ( $queryalign =~ s/\Q$GAPCHAR/$GAPCHAR/g); my $hgapnum = ( $hitalign =~ s/\Q$GAPCHAR/$GAPCHAR/g); my $totalgaps = ($qgapnum + $hgapnum); if( $hstrand eq '-' ) { # strand gets inferred by start/end ($hstart,$hend) = ($hend,$hstart); } $self->element({'Name' => 'Hsp_score', 'Data' => $score}); $self->element({'Name' => 'Hsp_query-from', 'Data' => $qstart}); $self->element({'Name' => 'Hsp_query-to', 'Data' => $qend}); $self->element({'Name' => 'Hsp_hit-from', 'Data' => $hstart}); $self->element({'Name' => 'Hsp_hit-to', 'Data' => $hend}); $self->element({'Name' => 'Hsp_gaps', 'Data' => $qgapnum + $hgapnum}); $self->element({'Name' => 'Hsp_querygaps', 'Data' => $qgapnum}); $self->element({'Name' => 'Hsp_hitgaps', 'Data' => $hgapnum}); $self->element({'Name' => 'Hsp_identity', 'Data' => $alnlen - $totalgaps}); $self->element({'Name' => 'Hsp_positive', 'Data' => $alnlen - $totalgaps}); $self->element({'Name' => 'Hsp_qseq', 'Data' => $queryalign}); $self->element({'Name' => 'Hsp_hseq', 'Data' => $hitalign}); $self->end_element({'Name' => 'Hsp'}); $curquery = $qname; $curhit = $hname; } } # fence post if( defined $curquery ) { $self->end_element({'Name' => 'Hit'}); $self->end_element({'Name' => 'AXTOutput'}); return $self->end_document(); } return; } sub _initialize { my ($self,@args) = @_; $self->SUPER::_initialize(@args); $self->_eventHandler->register_factory('result', Bio::Search::Result::ResultFactory->new(-type => 'Bio::Search::Result::GenericResult')); $self->_eventHandler->register_factory('hsp', Bio::Search::HSP::HSPFactory->new(-type => 'Bio::Search::HSP::GenericHSP')); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if( my $type = $MODEMAP{$nm} ) { $self->_mode($type); if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; } if($nm eq 'AXTOutput') { $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $rc; # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if( my $type = $MODEMAP{$nm} ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->warn( "unknown nm $nm ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( $nm eq 'AXTOutput' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} ); if( $data->{'Data'} =~ /^\s+$/ ) { return unless $data->{'Name'} =~ /Hsp\_(midline|qseq|hseq)/; } if( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/ ) { $self->{'_last_hspdata'}->{$data->{'Name'}} .= $data->{'Data'}; } $self->{'_last_data'} = $data->{'Data'}; } =head2 _mode Title : _mode Usage : $obj->_mode($newval) Function: Example : Returns : value of _mode Args : newvalue (optional) =cut sub _mode{ my ($self,$value) = @_; if( defined $value) { $self->{'_mode'} = $value; } return $self->{'_mode'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handles a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } 1; BioPerl-1.6.923/Bio/SearchIO/blast.pm000444000765000024 27035712254227317 17330 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::blast # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # 20030409 - sac # PSI-BLAST full parsing support. Rollout of new # model which will remove Steve's old psiblast driver # 20030424 - jason # Megablast parsing fix as reported by Neil Saunders # 20030427 - jason # Support bl2seq parsing # 20031124 - jason # Parse more blast statistics, lambda, entropy, etc # from WU-BLAST in frame-specific manner # 20060216 - cjf - fixed blast parsing for BLAST v2.2.13 output # 20071104 - dmessina - added support for WUBLAST -echofilter # 20071121 - cjf - fixed several bugs (bugs 2391, 2399, 2409) =head1 NAME Bio::SearchIO::blast - Event generator for event based parsing of blast reports =head1 SYNOPSIS # Do not use this object directly - it is used as part of the # Bio::SearchIO system. use Bio::SearchIO; my $searchio = Bio::SearchIO->new(-format => 'blast', -file => 't/data/ecolitst.bls'); while( my $result = $searchio->next_result ) { while( my $hit = $result->next_hit ) { while( my $hsp = $hit->next_hsp ) { # ... } } } =head1 DESCRIPTION This object encapsulated the necessary methods for generating events suitable for building Bio::Search objects from a BLAST report file. Read the L for more information about how to use this. This driver can parse: =over 4 =item * NCBI produced plain text BLAST reports from blastall, this also includes PSIBLAST, PSITBLASTN, RPSBLAST, and bl2seq reports. NCBI XML BLAST output is parsed with the blastxml SearchIO driver =item * WU-BLAST all reports =item * Jim Kent's BLAST-like output from his programs (BLASTZ, BLAT) =item * BLAST-like output from Paracel BTK output =back =head2 bl2seq parsing Since I cannot differentiate between BLASTX and TBLASTN since bl2seq doesn't report the algorithm used - I assume it is BLASTX by default - you can supply the program type with -report_type in the SearchIO constructor i.e. my $parser = Bio::SearchIO->new(-format => 'blast', -file => 'bl2seq.tblastn.report', -report_type => 'tblastn'); This only really affects where the frame and strand information are put - they will always be on the $hsp-Equery instead of on the $hsp-Ehit part of the feature pair for blastx and tblastn bl2seq produced reports. Hope that's clear... =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email Jason Stajich jason-at-bioperl.org =head1 CONTRIBUTORS Steve Chervitz sac-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin...' package Bio::SearchIO::blast; use Bio::SearchIO::IteratedSearchResultEventBuilder; use strict; use vars qw(%MAPPING %MODEMAP $DEFAULT_BLAST_WRITER_CLASS $MAX_HSP_OVERLAP $DEFAULT_SIGNIF $DEFAULT_SCORE $DEFAULTREPORTTYPE ); use base qw(Bio::SearchIO); use Data::Dumper; BEGIN { # mapping of NCBI Blast terms to Bioperl hash keys %MODEMAP = ( 'BlastOutput' => 'result', 'Iteration' => 'iteration', 'Hit' => 'hit', 'Hsp' => 'hsp' ); # This should really be done more intelligently, like with # XSLT %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_n', => 'HSP-n', 'Hsp_pvalue' => 'HSP-pvalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame' => 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', 'Hsp_links' => 'HSP-links', 'Hsp_group' => 'HSP-hsp_group', 'Hsp_features' => 'HSP-hit_features', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_signif' => 'HIT-significance', # For NCBI blast, the description line contains bits. # For WU-blast, the description line contains score. 'Hit_score' => 'HIT-score', 'Hit_bits' => 'HIT-bits', 'Iteration_iter-num' => 'ITERATION-number', 'Iteration_converged' => 'ITERATION-converged', 'BlastOutput_program' => 'RESULT-algorithm_name', 'BlastOutput_version' => 'RESULT-algorithm_version', 'BlastOutput_algorithm-reference' => 'RESULT-algorithm_reference', 'BlastOutput_rid' => 'RESULT-rid', 'BlastOutput_query-def' => 'RESULT-query_name', 'BlastOutput_query-len' => 'RESULT-query_length', 'BlastOutput_query-acc' => 'RESULT-query_accession', 'BlastOutput_query-gi' => 'RESULT-query_gi', 'BlastOutput_querydesc' => 'RESULT-query_description', 'BlastOutput_db' => 'RESULT-database_name', 'BlastOutput_db-len' => 'RESULT-database_entries', 'BlastOutput_db-let' => 'RESULT-database_letters', 'BlastOutput_inclusion-threshold' => 'RESULT-inclusion_threshold', 'Parameters_matrix' => { 'RESULT-parameters' => 'matrix' }, 'Parameters_expect' => { 'RESULT-parameters' => 'expect' }, 'Parameters_include' => { 'RESULT-parameters' => 'include' }, 'Parameters_sc-match' => { 'RESULT-parameters' => 'match' }, 'Parameters_sc-mismatch' => { 'RESULT-parameters' => 'mismatch' }, 'Parameters_gap-open' => { 'RESULT-parameters' => 'gapopen' }, 'Parameters_gap-extend' => { 'RESULT-parameters' => 'gapext' }, 'Parameters_filter' => { 'RESULT-parameters' => 'filter' }, 'Parameters_allowgaps' => { 'RESULT-parameters' => 'allowgaps' }, 'Parameters_full_dbpath' => { 'RESULT-parameters' => 'full_dbpath' }, 'Statistics_db-len' => { 'RESULT-statistics' => 'dbentries' }, 'Statistics_db-let' => { 'RESULT-statistics' => 'dbletters' }, 'Statistics_hsp-len' => { 'RESULT-statistics' => 'effective_hsplength' }, 'Statistics_query-len' => { 'RESULT-statistics' => 'querylength' }, 'Statistics_eff-space' => { 'RESULT-statistics' => 'effectivespace' }, 'Statistics_eff-spaceused' => { 'RESULT-statistics' => 'effectivespaceused' }, 'Statistics_eff-dblen' => { 'RESULT-statistics' => 'effectivedblength' }, 'Statistics_kappa' => { 'RESULT-statistics' => 'kappa' }, 'Statistics_lambda' => { 'RESULT-statistics' => 'lambda' }, 'Statistics_entropy' => { 'RESULT-statistics' => 'entropy' }, 'Statistics_gapped_kappa' => { 'RESULT-statistics' => 'kappa_gapped' }, 'Statistics_gapped_lambda' => { 'RESULT-statistics' => 'lambda_gapped' }, 'Statistics_gapped_entropy' => { 'RESULT-statistics' => 'entropy_gapped' }, 'Statistics_framewindow' => { 'RESULT-statistics' => 'frameshiftwindow' }, 'Statistics_decay' => { 'RESULT-statistics' => 'decayconst' }, 'Statistics_hit_to_db' => { 'RESULT-statistics' => 'Hits_to_DB' }, 'Statistics_num_suc_extensions' => { 'RESULT-statistics' => 'num_successful_extensions' }, 'Statistics_length_adjustment' => { 'RESULT-statistics' => 'length_adjustment' }, 'Statistics_number_of_hsps_better_than_expect_value_cutoff_without_gapping' => { 'RESULT-statistics' => 'number_of_hsps_better_than_expect_value_cutoff_without_gapping' }, 'Statistics_number_of_hsps_gapped' => { 'RESULT-statistics' => 'number_of_hsps_gapped' }, 'Statistics_number_of_hsps_successfully_gapped' => { 'RESULT-statistics' => 'number_of_hsps_successfully_gapped' }, # WU-BLAST stats 'Statistics_DFA_states' => { 'RESULT-statistics' => 'num_dfa_states' }, 'Statistics_DFA_size' => { 'RESULT-statistics' => 'dfa_size' }, 'Statistics_noprocessors' => { 'RESULT-statistics' => 'no_of_processors' }, 'Statistics_neighbortime' => { 'RESULT-statistics' => 'neighborhood_generate_time' }, 'Statistics_starttime' => { 'RESULT-statistics' => 'start_time' }, 'Statistics_endtime' => { 'RESULT-statistics' => 'end_time' }, ); # add WU-BLAST Frame-Based Statistics for my $frame ( 0 .. 3 ) { for my $strand ( '+', '-' ) { for my $ind ( qw(length efflength E S W T X X_gapped E2 E2_gapped S2) ) { $MAPPING{"Statistics_frame$strand$frame\_$ind"} = { 'RESULT-statistics' => "Frame$strand$frame\_$ind" }; } for my $val (qw(lambda kappa entropy )) { for my $type (qw(used computed gapped)) { my $key = "Statistics_frame$strand$frame\_$val\_$type"; my $val = { 'RESULT-statistics' => "Frame$strand$frame\_$val\_$type" }; $MAPPING{$key} = $val; } } } } # add Statistics for my $stats ( qw(T A X1 X2 X3 S1 S2 X1_bits X2_bits X3_bits S1_bits S2_bits num_extensions num_successful_extensions seqs_better_than_cutoff posted_date search_cputime total_cputime search_actualtime total_actualtime no_of_processors ctxfactor) ) { my $key = "Statistics_$stats"; my $val = { 'RESULT-statistics' => $stats }; $MAPPING{$key} = $val; } # add WU-BLAST Parameters for my $param ( qw(span span1 span2 links warnings notes hspsepsmax hspsepqmax topcomboN topcomboE postsw cpus wordmask filter sort_by_pvalue sort_by_count sort_by_highscore sort_by_totalscore sort_by_subjectlength noseqs gi qtype qres V B Z Y M N) ) { my $key = "Parameters_$param"; my $val = { 'RESULT-parameters' => $param }; $MAPPING{$key} = $val; } $DEFAULT_BLAST_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; $MAX_HSP_OVERLAP = 2; # Used when tiling multiple HSPs. $DEFAULTREPORTTYPE = 'BLASTP'; # for bl2seq } =head2 new Title : new Usage : my $obj = Bio::SearchIO::blast->new(%args); Function: Builds a new Bio::SearchIO::blast object Returns : Bio::SearchIO::blast Args : Key-value pairs: -fh/-file => filehandle/filename to BLAST file -format => 'blast' -report_type => 'blastx', 'tblastn', etc -- only for bl2seq reports when you want to distinguish between tblastn and blastx reports (this only controls where the frame information is put - on the query or subject object. -inclusion_threshold => e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) -signif => float or scientific notation number to be used as a P- or Expect value cutoff -score => integer or scientific notation number to be used as a blast score value cutoff -bits => integer or scientific notation number to be used as a bit score value cutoff -hit_filter => reference to a function to be used for filtering hits based on arbitrary criteria. All hits of each BLAST report must satisfy this criteria to be retained. If a hit fails this test, it is ignored. This function should take a Bio::Search::Hit::BlastHit.pm object as its first argument and return true if the hit should be retained. Sample filter function: -hit_filter => sub { $hit = shift; $hit->gaps == 0; }, (Note: -filt_func is synonymous with -hit_filter) -overlap => integer. The amount of overlap to permit between adjacent HSPs when tiling HSPs. A reasonable value is 2. Default = $Bio::SearchIO::blast::MAX_HSP_OVERLAP. The following criteria are not yet supported: (these are probably best applied within this module rather than in the event handler since they would permit the parser to take some shortcuts.) -check_all_hits => boolean. Check all hits for significance against significance criteria. Default = false. If false, stops processing hits after the first non-significant hit or the first hit that fails the hit_filter call. This speeds parsing, taking advantage of the fact that the hits are processed in the order they appear in the report. -min_query_len => integer to be used as a minimum for query sequence length. Reports with query sequences below this length will not be processed. Default = no minimum length. -best => boolean. Only process the best hit of each report; default = false. =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); # Blast reports require a specialized version of the SREB due to the # possibility of iterations (PSI-BLAST). Forwarding all arguments to it. An # issue here is that we want to set new default object factories if none are # supplied. my $handler = Bio::SearchIO::IteratedSearchResultEventBuilder->new(@args); $self->attach_EventHandler($handler); # 2006-04-26 move this to the attach_handler function in this module so we # can really reset the handler # Optimization: caching # the EventHandler since it is used a lot during the parse. # $self->{'_handler_cache'} = $handler; my ($rpttype ) = $self->_rearrange( [ qw( REPORT_TYPE) ], @args ); defined $rpttype && ( $self->{'_reporttype'} = $rpttype ); } sub attach_EventHandler { my ($self,$handler) = @_; $self->SUPER::attach_EventHandler($handler); # Optimization: caching the EventHandler since it is used a lot # during the parse. $self->{'_handler_cache'} = $handler; return; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; my $v = $self->verbose; my $data = ''; my $flavor = ''; $self->{'_seentop'} = 0; # start next report at top my ( $reporttype, $seenquery, $reportline, $reportversion ); my ( $seeniteration, $found_again ); my $incl_threshold = $self->inclusion_threshold; my $bl2seq_fix; $self->start_document(); # let the fun begin... my (@hit_signifs); my $gapped_stats = 0; # for switching between gapped/ungapped # lambda, K, H local $_ = "\n"; #consistency PARSER: while ( defined( $_ = $self->_readline ) ) { next if (/^\s+$/); # skip empty lines next if (/CPU time:/); next if (/^>\s*$/); next if (/[*]+\s+No hits found\s+[*]+/); if ( /^((?:\S+?)?BLAST[NPX]?)\s+(.+)$/i # NCBI BLAST, PSIBLAST # RPSBLAST, MEGABLAST || /^(P?GENEWISE|HFRAME|SWN|TSWN)\s+(.+)/i #Paracel BTK ) { ($reporttype, $reportversion) = ($1, $2); # need to keep track of whether this is WU-BLAST if ($reportversion && $reportversion =~ m{WashU$}) { $self->{'_wublast'}++; } $self->debug("blast.pm: Start of new report: $reporttype, $reportversion\n"); if ( $self->{'_seentop'} ) { # This handles multi-result input streams $self->_pushback($_); last PARSER; } $self->_start_blastoutput; if ($reporttype =~ /RPS-BLAST/) { $reporttype .= '(BLASTP)'; # default RPS-BLAST type } $reportline = $_; # to fix the fact that RPS-BLAST output is wrong $self->element( { 'Name' => 'BlastOutput_program', 'Data' => $reporttype } ); $self->element( { 'Name' => 'BlastOutput_version', 'Data' => $reportversion } ); $self->element( { 'Name' => 'BlastOutput_inclusion-threshold', 'Data' => $incl_threshold } ); } # parse the BLAST algorithm reference elsif(/^Reference:\s+(.*)$/) { # want to preserve newlines for the BLAST algorithm reference my $algorithm_reference = "$1\n"; $_ = $self->_readline; # while the current line, does not match an empty line, a RID:, a # Database:, or a query definition line (Query=) we are still # looking at the algorithm_reference, append it to what we parsed so # far while($_ !~ /^$/ && $_ !~ /^RID:/ && $_ !~ /^Database:/ && $_ !~ /^Query=/) { $algorithm_reference .= "$_"; $_ = $self->_readline; } # if we exited the while loop, we saw an empty line, a RID:, or a # Database:, so push it back $self->_pushback($_); $self->element( { 'Name' => 'BlastOutput_algorithm-reference', 'Data' => $algorithm_reference } ); } # parse BLAST RID (Request ID) elsif(/^RID:\s+(.*)$/) { my $rid = $1; $self->element( { 'Name' => 'BlastOutput_rid', 'Data' => $rid } ); } # added Windows workaround for bug 1985 elsif (/^(Searching|Results from round)/) { next unless $1 =~ /Results from round/; $self->debug("blast.pm: Possible psi blast iterations found...\n"); $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->in_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); if ( defined $seeniteration ) { $self->within_element('iteration') && $self->end_element( { 'Name' => 'Iteration' } ); $self->start_element( { 'Name' => 'Iteration' } ); } else { $self->start_element( { 'Name' => 'Iteration' } ); } $seeniteration = 1; } elsif (/^Query=\s*(.*)$/) { my $q = $1; $self->debug("blast.pm: Query= found...$_\n"); my $size = 0; if ( defined $seenquery ) { $self->_pushback($_); $self->_pushback($reportline) if $reportline; last PARSER; } if ( !defined $reporttype ) { $self->_start_blastoutput; if ( defined $seeniteration ) { $self->in_element('iteration') && $self->end_element( { 'Name' => 'Iteration' } ); $self->start_element( { 'Name' => 'Iteration' } ); } else { $self->start_element( { 'Name' => 'Iteration' } ); } $seeniteration = 1; } $seenquery = $q; $_ = $self->_readline; while ( defined($_) ) { if (/^Database:/) { $self->_pushback($_); last; } # below line fixes length issue with BLAST v2.2.13; still works # with BLAST v2.2.12 if ( /\((\-?[\d,]+)\s+letters.*\)/ || /^Length=(\-?[\d,]+)/ ) { $size = $1; $size =~ s/,//g; last; } else { # bug 2391 $q .= ($q =~ /\w$/ && $_ =~ /^\w/) ? " $_" : $_; $q =~ s/\s+/ /g; # this catches the newline as well $q =~ s/^ | $//g; } $_ = $self->_readline; } chomp($q); my ( $nm, $desc ) = split( /\s+/, $q, 2 ); $self->element( { 'Name' => 'BlastOutput_query-def', 'Data' => $nm } ) if $nm; $self->element( { 'Name' => 'BlastOutput_query-len', 'Data' => $size } ); defined $desc && $desc =~ s/\s+$//; $self->element( { 'Name' => 'BlastOutput_querydesc', 'Data' => $desc } ); my ( $gi, $acc, $version ) = $self->_get_seq_identifiers($nm); $version = defined($version) && length($version) ? ".$version" : ""; $self->element( { 'Name' => 'BlastOutput_query-acc', 'Data' => "$acc$version" } ) if $acc; # these elements are dropped with some multiquery reports; add # back here $self->element( { 'Name' => 'BlastOutput_db-len', 'Data' => $self->{'_blsdb_length'} } ) if $self->{'_blsdb_length'}; $self->element( { 'Name' => 'BlastOutput_db-let', 'Data' => $self->{'_blsdb_letters'} } ) if $self->{'_blsdb_letters'}; $self->element( { 'Name' => 'BlastOutput_db', 'Data' => $self->{'_blsdb'} } ) if $self->{'_blsdb_letters'}; } # added check for WU-BLAST -echofilter option (bug 2388) elsif (/^>Unfiltered[+-]1$/) { # skip all of the lines of unfiltered sequence while($_ !~ /^Database:/) { $self->debug("Bypassing features line: $_"); $_ = $self->_readline; } $self->_pushback($_); } elsif (/Sequences producing significant alignments:/) { $self->debug("blast.pm: Processing NCBI-BLAST descriptions\n"); $flavor = 'ncbi'; # PSI-BLAST parsing needs to be fixed to specifically look # for old vs new per iteration, as sorting based on duplication # leads to bugs, see bug 1986 # The next line is not necessarily whitespace in psiblast reports. # Also note that we must look for the end of this section by testing # for a line with a leading >. Blank lines occur with this section # for psiblast. if ( !$self->in_element('iteration') ) { $self->start_element( { 'Name' => 'Iteration' } ); } # changed 8/28/2008 to exit hit table if blank line is found after an # appropriate line my $h_regex; my $seen_block; DESCLINE: while ( defined( my $descline = $self->_readline() ) ) { if ($descline =~ m{^\s*$}) { last DESCLINE if $seen_block; next DESCLINE; } # any text match is part of block... $seen_block++; # GCG multiline oddness... if ($descline =~ /^(\S+)\s+Begin:\s\d+\s+End:\s+\d+/xms) { my ($id, $nextline) = ($1, $self->_readline); $nextline =~ s{^!}{}; $descline = "$id $nextline"; } # NCBI style hit table (no N) if ($descline =~ /(?element( { 'Name' => 'Iteration_converged', 'Data' => 1 } ); } else { $self->_pushback($descline); # Catch leading > (end of section) last DESCLINE; } } } elsif (/Sequences producing High-scoring Segment Pairs:/) { # This block is for WU-BLAST, so we don't have to check for psi-blast stuff # skip the next line $self->debug("blast.pm: Processing WU-BLAST descriptions\n"); $_ = $self->_readline(); $flavor = 'wu'; if ( !$self->in_element('iteration') ) { $self->start_element( { 'Name' => 'Iteration' } ); } while ( defined( $_ = $self->_readline() ) && !/^\s+$/ ) { my @line = split; pop @line; # throw away first number which is for 'N'col # add the last 2 entries to array s.t. we can reconstruct # a minimal Hit object at the end of the day push @hit_signifs, [ pop @line, pop @line, shift @line, join( ' ', @line ) ]; } } elsif (/^Database:\s*(.+?)\s*$/) { $self->debug("blast.pm: Database: $1\n"); my $db = $1; while ( defined( $_ = $self->_readline ) ) { if ( /^\s+(\-?[\d\,]+|\S+)\s+sequences\; \s+(\-?[\d,]+|\S+)\s+ # Deal with NCBI 2.2.8 OSX problems total\s+letters/ox ) { my ( $s, $l ) = ( $1, $2 ); $s =~ s/,//g; $l =~ s/,//g; $self->element( { 'Name' => 'BlastOutput_db-len', 'Data' => $s } ); $self->element( { 'Name' => 'BlastOutput_db-let', 'Data' => $l } ); # cache for next round in cases with multiple queries $self->{'_blsdb'} = $db; $self->{'_blsdb_length'} = $s; $self->{'_blsdb_letters'} = $l; last; } else { chomp; $db .= $_; } } $self->element( { 'Name' => 'BlastOutput_db', 'Data' => $db } ); } # move inside of a hit elsif (/^>\s*(\S+)\s*(.*)?/) { chomp; $self->debug("blast.pm: Hit: $1\n"); $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->in_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); # special case when bl2seq reports don't have a leading # Query= if ( !$self->within_element('result') ) { $self->_start_blastoutput; $self->start_element( { 'Name' => 'Iteration' } ); } elsif ( !$self->within_element('iteration') ) { $self->start_element( { 'Name' => 'Iteration' } ); } $self->start_element( { 'Name' => 'Hit' } ); my $id = $1; my $restofline = $2; $self->debug("Starting a hit: $1 $2\n"); $self->element( { 'Name' => 'Hit_id', 'Data' => $id } ); my ($gi, $acc, $version ) = $self->_get_seq_identifiers($id); $self->element( { 'Name' => 'Hit_accession', 'Data' => $acc } ); # add hit significance (from the hit table) # this is where Bug 1986 went awry # Changed for Bug2409; hit->significance and hit->score/bits derived # from HSPs, not hit table unless necessary HITTABLE: while (my $v = shift @hit_signifs) { my $tableid = $v->[2]; if ($tableid !~ m{\Q$id\E}) { $self->debug("Hit table ID $tableid doesn't match current hit id $id, checking next hit table entry...\n"); next HITTABLE; } else { last HITTABLE; } } while ( defined( $_ = $self->_readline() ) ) { next if (/^\s+$/); chomp; if (/Length\s*=\s*([\d,]+)/) { my $l = $1; $l =~ s/\,//g; $self->element( { 'Name' => 'Hit_len', 'Data' => $l } ); last; } else { if ($restofline !~ /\s$/) { # bug #3235 s/^\s(?!\s)/\x01/; #new line to concatenate desc lines with } $restofline .= $_; } } $restofline =~ s/\s+/ /g; $self->element( { 'Name' => 'Hit_def', 'Data' => $restofline } ); } elsif (/\s+(Plus|Minus) Strand HSPs:/i) { next; } elsif ( ( $self->in_element('hit') || $self->in_element('hsp') ) && # paracel genewise BTK m/Score\s*=\s*(\S+)\s*bits\s* # Bit score (?:\((\d+)\))?, # Raw score \s+Log\-Length\sScore\s*=\s*(\d+) # Log-Length score /ox ) { $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->start_element( { 'Name' => 'Hsp' } ); $self->debug( "Got paracel genewise HSP score=$1\n"); # Some data clean-up so e-value will appear numeric to perl my ( $bits, $score, $evalue ) = ( $1, $2, $3 ); $evalue =~ s/^e/1e/i; $self->element( { 'Name' => 'Hsp_score', 'Data' => $score } ); $self->element( { 'Name' => 'Hsp_bit-score', 'Data' => $bits } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => $evalue } ); } elsif ( ( $self->in_element('hit') || $self->in_element('hsp') ) && # paracel hframe BTK m/Score\s*=\s*([^,\s]+), # Raw score \s*Expect\s*=\s*([^,\s]+), # E-value \s*P(?:\(\S+\))?\s*=\s*([^,\s]+) # P-value /ox ) { $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->start_element( { 'Name' => 'Hsp' } ); $self->debug( "Got paracel hframe HSP score=$1\n"); # Some data clean-up so e-value will appear numeric to perl my ( $score, $evalue, $pvalue ) = ( $1, $2, $3 ); $evalue = "1$evalue" if $evalue =~ /^e/; $pvalue = "1$pvalue" if $pvalue =~ /^e/; $self->element( { 'Name' => 'Hsp_score', 'Data' => $score } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => $evalue } ); $self->element( { 'Name' => 'Hsp_pvalue', 'Data' => $pvalue } ); } elsif ( ( $self->in_element('hit') || $self->in_element('hsp') ) && # wublast m/Score\s*=\s*(\S+)\s* # Bit score \(([\d\.]+)\s*bits\), # Raw score \s*Expect\s*=\s*([^,\s]+), # E-value \s*(?:Sum)?\s* # SUM P(?:\(\d+\))?\s*=\s*([^,\s]+) # P-value (?:\s*,\s+Group\s*\=\s*(\d+))? # HSP Group /ox ) { # wu-blast HSP parse $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->start_element( { 'Name' => 'Hsp' } ); # Some data clean-up so e-value will appear numeric to perl my ( $score, $bits, $evalue, $pvalue, $group ) = ( $1, $2, $3, $4, $5 ); $evalue =~ s/^e/1e/i; $pvalue =~ s/^e/1e/i; $self->element( { 'Name' => 'Hsp_score', 'Data' => $score } ); $self->element( { 'Name' => 'Hsp_bit-score', 'Data' => $bits } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => $evalue } ); $self->element( { 'Name' => 'Hsp_pvalue', 'Data' => $pvalue } ); if ( defined $group ) { $self->element( { 'Name' => 'Hsp_group', 'Data' => $group } ); } } elsif ( ( $self->in_element('hit') || $self->in_element('hsp') ) && # ncbi blast, works with 2.2.17 m/^\sFeatures\s\w+\sthis\spart/xmso # If the line begins with "Features in/flanking this part of subject sequence:" ) { $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); my $featline; $_ = $self->_readline; while($_ !~ /^\s*$/) { chomp; $featline .= $_; $_ = $self->_readline; } $self->_pushback($_); $featline =~ s{(?:^\s+|\s+^)}{}g; $featline =~ s{\n}{;}g; $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_features', 'Data' => $featline } ); $self->{'_seen_hsp_features'} = 1; } elsif ( ( $self->in_element('hit') || $self->in_element('hsp') ) && # ncbi blast, works with 2.2.17 m/Score\s*=\s*(\S+)\s*bits\s* # Bit score (?:\((\d+)\))?, # Missing for BLAT pseudo-BLAST fmt \s*Expect(?:\((\d+\+?)\))?\s*=\s*([^,\s]+) # E-value /ox ) { # parse NCBI blast HSP if( !$self->{'_seen_hsp_features'} ) { $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->start_element( { 'Name' => 'Hsp' } ); } # Some data clean-up so e-value will appear numeric to perl my ( $bits, $score, $n, $evalue ) = ( $1, $2, $3, $4 ); $evalue =~ s/^e/1e/i; $self->element( { 'Name' => 'Hsp_score', 'Data' => $score } ); $self->element( { 'Name' => 'Hsp_bit-score', 'Data' => $bits } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => $evalue } ); $self->element( { 'Name' => 'Hsp_n', 'Data' => $n } ) if defined $n; $score = '' unless defined $score; # deal with BLAT which # has no score only bits $self->debug("Got NCBI HSP score=$score, evalue $evalue\n"); } elsif ( $self->in_element('hsp') && m/Identities\s*=\s*(\d+)\s*\/\s*(\d+)\s*[\d\%\(\)]+\s* (?:,\s*Positives\s*=\s*(\d+)\/(\d+)\s*[\d\%\(\)]+\s*)? # pos only valid for Protein alignments (?:\,\s*Gaps\s*=\s*(\d+)\/(\d+))? # Gaps /oxi ) { $self->element( { 'Name' => 'Hsp_identity', 'Data' => $1 } ); $self->element( { 'Name' => 'Hsp_align-len', 'Data' => $2 } ); if ( defined $3 ) { $self->element( { 'Name' => 'Hsp_positive', 'Data' => $3 } ); } else { $self->element( { 'Name' => 'Hsp_positive', 'Data' => $1 } ); } if ( defined $6 ) { $self->element( { 'Name' => 'Hsp_gaps', 'Data' => $5 } ); } $self->{'_Query'} = { 'begin' => 0, 'end' => 0 }; $self->{'_Sbjct'} = { 'begin' => 0, 'end' => 0 }; if (/(Frame\s*=\s*.+)$/) { # handle wu-blast Frame listing on same line $self->_pushback($1); } } elsif ( $self->in_element('hsp') && /Strand\s*=\s*(Plus|Minus)\s*\/\s*(Plus|Minus)/i ) { # consume this event ( we infer strand from start/end) if (!defined($reporttype)) { $self->{'_reporttype'} = $reporttype = 'BLASTN'; $bl2seq_fix = 1; # special case to resubmit the algorithm # reporttype } next; } elsif ( $self->in_element('hsp') && /Links\s*=\s*(\S+)/ox ) { $self->element( { 'Name' => 'Hsp_links', 'Data' => $1 } ); } elsif ( $self->in_element('hsp') && /Frame\s*=\s*([\+\-][1-3])\s*(\/\s*([\+\-][1-3]))?/ ) { my $frame1 = $1 || 0; my $frame2 = $2 || 0; # this is for bl2seq only if ( not defined $reporttype ) { $bl2seq_fix = 1; if ( $frame1 && $frame2 ) { $reporttype = 'TBLASTX' } else { # We can distinguish between BLASTX and TBLASTN from the report # (and assign $frame1 properly) by using the start/end from query. # If the report is BLASTX, the coordinates distance from query # will be 3 times the length of the alignment shown (coordinates in nt, # alignment in aa); if not then subject is the nucleotide sequence (TBLASTN). # Will have to fast-forward to query alignment line and then go back. my $fh = $self->_fh; my $file_pos = tell $fh; my $a_position = ''; my $ali_length = ''; my $b_position = ''; while (my $line = <$fh>) { if ($line =~ m/^(?:Query|Sbjct):?\s+(\-?\d+)?\s*(\S+)\s+(\-?\d+)?/) { $a_position = $1; my $alignment = $2; $b_position = $3; use Bio::LocatableSeq; my $gap_symbols = $Bio::LocatableSeq::GAP_SYMBOLS; $alignment =~ s/[$gap_symbols]//g; $ali_length = length($alignment); last; } } my $coord_length = ($a_position < $b_position) ? ($b_position - $a_position + 1) : ($a_position - $b_position + 1); ($coord_length == ($ali_length * 3)) ? ($reporttype = 'BLASTX') : ($reporttype = 'TBLASTN'); # Rewind filehandle to its original position to continue parsing seek $fh, $file_pos, 0; } $self->{'_reporttype'} = $reporttype; } my ( $queryframe, $hitframe ); if ( $reporttype eq 'TBLASTX' ) { ( $queryframe, $hitframe ) = ( $frame1, $frame2 ); $hitframe =~ s/\/\s*//g; } elsif ( $reporttype eq 'TBLASTN' || $reporttype eq 'PSITBLASTN') { ( $hitframe, $queryframe ) = ( $frame1, 0 ); } elsif ( $reporttype eq 'BLASTX' || $reporttype eq 'RPS-BLAST(BLASTP)') { ( $queryframe, $hitframe ) = ( $frame1, 0 ); # though NCBI doesn't report it, this is a special BLASTX-like # RPS-BLAST; should be handled differently if ($reporttype eq 'RPS-BLAST(BLASTP)') { $self->element( { 'Name' => 'BlastOutput_program', 'Data' => 'RPS-BLAST(BLASTX)' } ); } } $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => $queryframe } ); $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => $hitframe } ); } elsif (/^Parameters:/ || /^\s+Database:\s+?/ || /^\s+Subset/ || /^\s*Lambda/ || /^\s*Histogram/ || ( $self->in_element('hsp') && /WARNING|NOTE/ ) ) { # Note: Lambda check was necessary to parse # t/data/ecoli_domains.rpsblast AND to parse bl2seq $self->debug("blast.pm: found parameters section \n"); $self->in_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->in_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); # This is for the case when we specify -b 0 (or B=0 for WU-BLAST) # and still want to construct minimal Hit objects $self->_cleanup_hits(\@hit_signifs) if scalar(@hit_signifs); $self->within_element('iteration') && $self->end_element( { 'Name' => 'Iteration' } ); next if /^\s+Subset/; my $blast = (/^(\s+Database\:)|(\s*Lambda)/) ? 'ncbi' : 'wublast'; if (/^\s*Histogram/) { $blast = 'btk'; } my $last = ''; # default is that gaps are allowed $self->element( { 'Name' => 'Parameters_allowgaps', 'Data' => 'yes' } ); while ( defined( $_ = $self->_readline ) ) { if ( /^((?:\S+)?BLAST[NPX]?)\s+(.+)$/i # NCBI BLAST, PSIBLAST # RPSBLAST, MEGABLAST || /^(P?GENEWISE|HFRAME|SWN|TSWN)\s+(.+)/i #Paracel BTK ) { $self->_pushback($_); # let's handle this in the loop last; } elsif (/^Query=/) { $self->_pushback($_); $self->_pushback($reportline) if $reportline; last PARSER; } # here is where difference between wublast and ncbiblast # is better handled by different logic if ( /Number of Sequences:\s+([\d\,]+)/i || /of sequences in database:\s+(\-?[\d,]+)/i ) { my $c = $1; $c =~ s/\,//g; $self->element( { 'Name' => 'Statistics_db-len', 'Data' => $c } ); } elsif (/letters in database:\s+(\-?[\d,]+)/i) { my $s = $1; $s =~ s/,//g; $self->element( { 'Name' => 'Statistics_db-let', 'Data' => $s } ); } elsif ( $blast eq 'btk' ) { next; } elsif ( $blast eq 'wublast' ) { # warn($_); if (/E=(\S+)/) { $self->element( { 'Name' => 'Parameters_expect', 'Data' => $1 } ); } elsif (/nogaps/) { $self->element( { 'Name' => 'Parameters_allowgaps', 'Data' => 'no' } ); } elsif (/ctxfactor=(\S+)/) { $self->element( { 'Name' => 'Statistics_ctxfactor', 'Data' => $1 } ); } elsif ( /(postsw|links|span[12]?|warnings|notes|gi|noseqs|qres|qype)/ ) { $self->element( { 'Name' => "Parameters_$1", 'Data' => 'yes' } ); } elsif (/(\S+)=(\S+)/) { $self->element( { 'Name' => "Parameters_$1", 'Data' => $2 } ); } elsif ( $last =~ /(Frame|Strand)\s+MatID\s+Matrix name/i ) { my $firstgapinfo = 1; my $frame = undef; while ( defined($_) && !/^\s+$/ ) { s/^\s+//; s/\s+$//; if ( $firstgapinfo && s/Q=(\d+),R=(\d+)\s+//x ) { $firstgapinfo = 0; $self->element( { 'Name' => 'Parameters_gap-open', 'Data' => $1 } ); $self->element( { 'Name' => 'Parameters_gap-extend', 'Data' => $2 } ); my @fields = split; for my $type ( qw(lambda_gapped kappa_gapped entropy_gapped) ) { next if $type eq 'n/a'; if ( !@fields ) { warn "fields is empty for $type\n"; next; } $self->element( { 'Name' => "Statistics_frame$frame\_$type", 'Data' => shift @fields } ); } } else { my ( $frameo, $matid, $matrix, @fields ) = split; if ( !defined $frame ) { # keep some sort of default feature I guess # even though this is sort of wrong $self->element( { 'Name' => 'Parameters_matrix', 'Data' => $matrix } ); $self->element( { 'Name' => 'Statistics_lambda', 'Data' => $fields[0] } ); $self->element( { 'Name' => 'Statistics_kappa', 'Data' => $fields[1] } ); $self->element( { 'Name' => 'Statistics_entropy', 'Data' => $fields[2] } ); } $frame = $frameo; my $ii = 0; for my $type ( qw(lambda_used kappa_used entropy_used lambda_computed kappa_computed entropy_computed) ) { my $f = $fields[$ii]; next unless defined $f; # deal with n/a if ( $f eq 'same' ) { $f = $fields[ $ii - 3 ]; } $ii++; $self->element( { 'Name' => "Statistics_frame$frame\_$type", 'Data' => $f } ); } } # get the next line $_ = $self->_readline; } $last = $_; } elsif ( $last =~ /(Frame|Strand)\s+MatID\s+Length/i ) { my $frame = undef; while ( defined($_) && !/^\s+/ ) { s/^\s+//; s/\s+$//; my @fields = split; if ( @fields <= 3 ) { for my $type (qw(X_gapped E2_gapped S2)) { last unless @fields; $self->element( { 'Name' => "Statistics_frame$frame\_$type", 'Data' => shift @fields } ); } } else { for my $type ( qw(length efflength E S W T X E2 S2) ) { $self->element( { 'Name' => "Statistics_frame$frame\_$type", 'Data' => shift @fields } ); } } $_ = $self->_readline; } $last = $_; } elsif (/(\S+\s+\S+)\s+DFA:\s+(\S+)\s+\((.+)\)/) { if ( $1 eq 'states in' ) { $self->element( { 'Name' => 'Statistics_DFA_states', 'Data' => "$2 $3" } ); } elsif ( $1 eq 'size of' ) { $self->element( { 'Name' => 'Statistics_DFA_size', 'Data' => "$2 $3" } ); } } elsif ( m/^\s+Time to generate neighborhood:\s+ (\S+\s+\S+\s+\S+)/x ) { $self->element( { 'Name' => 'Statistics_neighbortime', 'Data' => $1 } ); } elsif (/processors\s+used:\s+(\d+)/) { $self->element( { 'Name' => 'Statistics_noprocessors', 'Data' => $1 } ); } elsif ( m/^\s+(\S+)\s+cpu\s+time:\s+ # cputype (\S+\s+\S+\s+\S+) # cputime \s+Elapsed:\s+(\S+)/x ) { my $cputype = lc($1); $self->element( { 'Name' => "Statistics_$cputype\_cputime", 'Data' => $2 } ); $self->element( { 'Name' => "Statistics_$cputype\_actualtime", 'Data' => $3 } ); } elsif (/^\s+Start:/) { my ( $junk, $start, $stime, $end, $etime ) = split( /\s+(Start|End)\:\s+/, $_ ); chomp($stime); $self->element( { 'Name' => 'Statistics_starttime', 'Data' => $stime } ); chomp($etime); $self->element( { 'Name' => 'Statistics_endtime', 'Data' => $etime } ); } elsif (/^\s+Database:\s+(.+)$/) { $self->element( { 'Name' => 'Parameters_full_dbpath', 'Data' => $1 } ); } elsif (/^\s+Posted:\s+(.+)/) { my $d = $1; chomp($d); $self->element( { 'Name' => 'Statistics_posted_date', 'Data' => $d } ); } } elsif ( $blast eq 'ncbi' ) { if (m/^Matrix:\s+(.+)\s*$/oxi) { $self->element( { 'Name' => 'Parameters_matrix', 'Data' => $1 } ); } elsif (/^Gapped/) { $gapped_stats = 1; } elsif (/^Lambda/) { $_ = $self->_readline; s/^\s+//; my ( $lambda, $kappa, $entropy ) = split; if ($gapped_stats) { $self->element( { 'Name' => "Statistics_gapped_lambda", 'Data' => $lambda } ); $self->element( { 'Name' => "Statistics_gapped_kappa", 'Data' => $kappa } ); $self->element( { 'Name' => "Statistics_gapped_entropy", 'Data' => $entropy } ); } else { $self->element( { 'Name' => "Statistics_lambda", 'Data' => $lambda } ); $self->element( { 'Name' => "Statistics_kappa", 'Data' => $kappa } ); $self->element( { 'Name' => "Statistics_entropy", 'Data' => $entropy } ); } } elsif (m/effective\s+search\s+space\s+used:\s+(\d+)/oxi) { $self->element( { 'Name' => 'Statistics_eff-spaceused', 'Data' => $1 } ); } elsif (m/effective\s+search\s+space:\s+(\d+)/oxi) { $self->element( { 'Name' => 'Statistics_eff-space', 'Data' => $1 } ); } elsif ( m/Gap\s+Penalties:\s+Existence:\s+(\d+)\, \s+Extension:\s+(\d+)/ox ) { $self->element( { 'Name' => 'Parameters_gap-open', 'Data' => $1 } ); $self->element( { 'Name' => 'Parameters_gap-extend', 'Data' => $2 } ); } elsif (/effective\s+HSP\s+length:\s+(\d+)/) { $self->element( { 'Name' => 'Statistics_hsp-len', 'Data' => $1 } ); } elsif (/Number\s+of\s+HSP's\s+better\s+than\s+(\S+)\s+without\s+gapping:\s+(\d+)/) { $self->element( { 'Name' => 'Statistics_number_of_hsps_better_than_expect_value_cutoff_without_gapping', 'Data' => $2 } ); } elsif (/Number\s+of\s+HSP's\s+gapped:\s+(\d+)/) { $self->element( { 'Name' => 'Statistics_number_of_hsps_gapped', 'Data' => $1 } ); } elsif (/Number\s+of\s+HSP's\s+successfully\s+gapped:\s+(\d+)/) { $self->element( { 'Name' => 'Statistics_number_of_hsps_successfully_gapped', 'Data' => $1 } ); } elsif (/Length\s+adjustment:\s+(\d+)/) { $self->element( { 'Name' => 'Statistics_length_adjustment', 'Data' => $1 } ); } elsif (/effective\s+length\s+of\s+query:\s+([\d\,]+)/i) { my $c = $1; $c =~ s/\,//g; $self->element( { 'Name' => 'Statistics_query-len', 'Data' => $c } ); } elsif (/effective\s+length\s+of\s+database:\s+([\d\,]+)/i) { my $c = $1; $c =~ s/\,//g; $self->element( { 'Name' => 'Statistics_eff-dblen', 'Data' => $c } ); } elsif ( /^(T|A|X1|X2|X3|S1|S2):\s+(\d+(\.\d+)?)\s+(?:\(\s*(\d+\.\d+) bits\))?/ ) { my $v = $2; chomp($v); $self->element( { 'Name' => "Statistics_$1", 'Data' => $v } ); if ( defined $4 ) { $self->element( { 'Name' => "Statistics_$1_bits", 'Data' => $4 } ); } } elsif ( m/frameshift\s+window\, \s+decay\s+const:\s+(\d+)\,\s+([\.\d]+)/x ) { $self->element( { 'Name' => 'Statistics_framewindow', 'Data' => $1 } ); $self->element( { 'Name' => 'Statistics_decay', 'Data' => $2 } ); } elsif (m/^Number\s+of\s+Hits\s+to\s+DB:\s+(\S+)/ox) { $self->element( { 'Name' => 'Statistics_hit_to_db', 'Data' => $1 } ); } elsif (m/^Number\s+of\s+extensions:\s+(\S+)/ox) { $self->element( { 'Name' => 'Statistics_num_extensions', 'Data' => $1 } ); } elsif ( m/^Number\s+of\s+successful\s+extensions:\s+ (\S+)/ox ) { $self->element( { 'Name' => 'Statistics_num_suc_extensions', 'Data' => $1 } ); } elsif ( m/^Number\s+of\s+sequences\s+better\s+than\s+ (\S+):\s+(\d+)/ox ) { $self->element( { 'Name' => 'Parameters_expect', 'Data' => $1 } ); $self->element( { 'Name' => 'Statistics_seqs_better_than_cutoff', 'Data' => $2 } ); } elsif (/^\s+Posted\s+date:\s+(.+)/) { my $d = $1; chomp($d); $self->element( { 'Name' => 'Statistics_posted_date', 'Data' => $d } ); } elsif ( !/^\s+$/ ) { #$self->debug( "unmatched stat $_"); } } $last = $_; } } elsif ( $self->in_element('hsp') ) { $self->debug("blast.pm: Processing HSP\n"); # let's read 3 lines at a time; # bl2seq hackiness... Not sure I like $self->{'_reporttype'} ||= $DEFAULTREPORTTYPE; my %data = ( 'Query' => '', 'Mid' => '', 'Hit' => '' ); my $len; for ( my $i = 0 ; defined($_) && $i < 3 ; $i++ ) { # $self->debug("$i: $_") if $v; if ( ( $i == 0 && /^\s+$/) || /^\s*(?:Lambda|Minus|Plus|Score)/i ) { $self->_pushback($_) if defined $_; $self->end_element( { 'Name' => 'Hsp' } ); last; } chomp; if (/^((Query|Sbjct):?\s+(\-?\d+)?\s*)(\S+)\s+(\-?\d+)?/) { my ( $full, $type, $start, $str, $end ) = ( $1, $2, $3, $4, $5 ); if ( $str eq '-' ) { $i = 3 if $type eq 'Sbjct'; } else { $data{$type} = $str; } $len = length($full); $self->{"\_$type"}->{'begin'} = $start unless $self->{"_$type"}->{'begin'}; $self->{"\_$type"}->{'end'} = $end; } elsif (/^((Query|Sbjct):?\s+(\-?0+)\s*)/) { # Bug from NCBI's BLAST: unaligned output $_ = $self->_readline() for 0..1; last; } else { $self->throw("no data for midline $_") unless ( defined $_ && defined $len ); $data{'Mid'} = substr( $_, $len ); } $_ = $self->_readline(); } $self->characters( { 'Name' => 'Hsp_qseq', 'Data' => $data{'Query'} } ); $self->characters( { 'Name' => 'Hsp_hseq', 'Data' => $data{'Sbjct'} } ); $self->characters( { 'Name' => 'Hsp_midline', 'Data' => $data{'Mid'} } ); } else { #$self->debug("blast.pm: unrecognized line $_"); } } $self->debug("blast.pm: End of BlastOutput\n"); if ( $self->{'_seentop'} ) { $self->within_element('hsp') && $self->end_element( { 'Name' => 'Hsp' } ); $self->within_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); # cleanup extra hits $self->_cleanup_hits(\@hit_signifs) if scalar(@hit_signifs); $self->within_element('iteration') && $self->end_element( { 'Name' => 'Iteration' } ); if ($bl2seq_fix) { $self->element( { 'Name' => 'BlastOutput_program', 'Data' => $reporttype } ); } $self->end_element( { 'Name' => 'BlastOutput' } ); } return $self->end_document(); } # Private method for internal use only. sub _start_blastoutput { my $self = shift; $self->start_element( { 'Name' => 'BlastOutput' } ); $self->{'_seentop'} = 1; $self->{'_result_count'}++; $self->{'_handler_rc'} = undef; } =head2 _will_handle Title : _will_handle Usage : Private method. For internal use only. if( $self->_will_handle($type) ) { ... } Function: Provides an optimized way to check whether or not an element of a given type is to be handled. Returns : Reference to EventHandler object if the element type is to be handled. undef if the element type is not to be handled. Args : string containing type of element. Optimizations: =over 2 =item 1 Using the cached pointer to the EventHandler to minimize repeated lookups. =item 2 Caching the will_handle status for each type that is encountered so that it only need be checked by calling handler-Ewill_handle($type) once. =back This does not lead to a major savings by itself (only 5-10%). In combination with other optimizations, or for large parse jobs, the savings good be significant. To test against the unoptimized version, remove the parentheses from around the third term in the ternary " ? : " operator and add two calls to $self-E_eventHandler(). =cut sub _will_handle { my ( $self, $type ) = @_; my $handler = $self->{'_handler_cache'}; my $will_handle = defined( $self->{'_will_handle_cache'}->{$type} ) ? $self->{'_will_handle_cache'}->{$type} : ( $self->{'_will_handle_cache'}->{$type} = $handler->will_handle($type) ); return $will_handle ? $handler : undef; } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if ($type) { my $handler = $self->_will_handle($type); if ($handler) { my $func = sprintf( "start_%s", lc $type ); $self->{'_handler_rc'} = $handler->$func( $data->{'Attributes'} ); } #else { #$self->debug( # changed 4/29/2006 to play nice with other event handlers # "Bio::SearchIO::InternalParserError ". # "\nCan't handle elements of type \'$type.\'" #); #} unshift @{ $self->{'_elements'} }, $type; if ( $type eq 'result' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; } else { # cleanup some things if ( defined $self->{'_values'} ) { foreach my $k ( grep { /^\U$type\-/ } keys %{ $self->{'_values'} } ) { delete $self->{'_values'}->{$k}; } } } } } =head2 end_element Title : end_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : hashref with an element's worth of data Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $type; my $rc; # cache these (TODO: we should probably cache all cross-report data) if ( $nm eq 'BlastOutput_program' ) { if ( $self->{'_last_data'} =~ /(t?blast[npx])/i ) { $self->{'_reporttype'} = uc $1; } $self->{'_reporttype'} ||= $DEFAULTREPORTTYPE; } if ( $nm eq 'BlastOutput_version' ) { $self->{'_reportversion'} = $self->{'_last_data'}; } # Hsps are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if ( $nm eq 'Hsp' ) { foreach (qw(Hsp_qseq Hsp_midline Hsp_hseq Hsp_features)) { $self->element( { 'Name' => $_, 'Data' => $self->{'_last_hspdata'}->{$_} } ) if defined $self->{'_last_hspdata'}->{$_}; } $self->{'_last_hspdata'} = {}; $self->element( { 'Name' => 'Hsp_query-from', 'Data' => $self->{'_Query'}->{'begin'} } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => $self->{'_Query'}->{'end'} } ); $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => $self->{'_Sbjct'}->{'begin'} } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => $self->{'_Sbjct'}->{'end'} } ); # } elsif( $nm eq 'Iteration' ) { # Nothing special needs to be done here. } if ( $type = $MODEMAP{$nm} ) { my $handler = $self->_will_handle($type); if ($handler) { my $func = sprintf( "end_%s", lc $type ); $rc = $handler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { # this is where we shove in the data from the # hashref info about params or statistics my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { #$self->debug("blast.pm: unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $type && $type eq 'result' ); $self->{'_seen_hsp_features'} = 0; return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convenience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; # Note that start element isn't needed for character data # Not too SAX-y, though #$self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; if ( $self->in_element('hsp') && $data->{'Name'} =~ /^Hsp\_(qseq|hseq|midline)$/ ) { $self->{'_last_hspdata'}->{ $data->{'Name'} } .= $data->{'Data'} if defined $data->{'Data'}; } return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/ ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name See Also: L =cut sub within_element { my ( $self, $name ) = @_; return 0 if ( !defined $name && !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { if ( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'within_element' because within can be tested for a whole block. Returns : boolean Args : string element name See Also: L =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ( $self, @args ) = @_; #$self->debug("blast.pm: end_document\n"); return $self->{'_result'}; } sub write_result { my ( $self, $blast, @args ) = @_; if ( not defined( $self->writer ) ) { $self->warn("Writer not defined. Using a $DEFAULT_BLAST_WRITER_CLASS"); $self->writer( $DEFAULT_BLAST_WRITER_CLASS->new() ); } $self->SUPER::write_result( $blast, @args ); } sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } =head2 inclusion_threshold Title : inclusion_threshold Usage : my $incl_thresh = $isreb->inclusion_threshold; : $isreb->inclusion_threshold(1e-5); Function: Get/Set the e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) that was used for generating the reports being parsed. Returns : number (real) Default value: $Bio::SearchIO::IteratedSearchResultEventBuilder::DEFAULT_INCLUSION_THRESHOLD Args : number (real) (e.g., 0.0001 or 1e-4 ) =cut =head2 max_significance Usage : $obj->max_significance(); Purpose : Set/Get the P or Expect value used as significance screening cutoff. This is the value of the -signif parameter supplied to new(). Hits with P or E-value above this are skipped. Returns : Scientific notation number with this format: 1.0e-05. Argument : Scientific notation number or float (when setting) Comments : Screening of significant hits uses the data provided on the : description line. For NCBI BLAST1 and WU-BLAST, this data : is P-value. for NCBI BLAST2 it is an Expect value. =cut =head2 signif Synonym for L =cut =head2 min_score Usage : $obj->min_score(); Purpose : Set/Get the Blast score used as screening cutoff. This is the value of the -score parameter supplied to new(). Hits with scores below this are skipped. Returns : Integer or scientific notation number. Argument : Integer or scientific notation number (when setting) Comments : Screening of significant hits uses the data provided on the : description line. =cut =head2 min_query_length Usage : $obj->min_query_length(); Purpose : Gets the query sequence length used as screening criteria. This is the value of the -min_query_len parameter supplied to new(). Hits with sequence length below this are skipped. Returns : Integer Argument : n/a =cut =head2 best_hit_only Title : best_hit_only Usage : print "only getting best hit.\n" if $obj->best_hit_only; Purpose : Set/Get the indicator for whether or not to process only : the best BlastHit. Returns : Boolean (1 | 0) Argument : Boolean (1 | 0) (when setting) =cut =head2 check_all_hits Title : check_all_hits Usage : print "checking all hits.\n" if $obj->check_all_hits; Purpose : Set/Get the indicator for whether or not to process all hits. : If false, the parser will stop processing hits after the : the first non-significance hit or the first hit that fails : any hit filter. Returns : Boolean (1 | 0) Argument : Boolean (1 | 0) (when setting) =cut # general private method used to make minimal hits from leftover # data in the hit table sub _cleanup_hits { my ($self, $hits) = @_; while ( my $v = shift @{ $hits }) { next unless defined $v; $self->start_element( { 'Name' => 'Hit' } ); my $id = $v->[2]; my $desc = $v->[3]; $self->element( { 'Name' => 'Hit_id', 'Data' => $id } ); my ($gi, $acc, $version ) = $self->_get_seq_identifiers($id); $self->element( { 'Name' => 'Hit_accession', 'Data' => $acc } ); if ( defined $v ) { $self->element( { 'Name' => 'Hit_signif', 'Data' => $v->[0] } ); if (exists $self->{'_wublast'}) { $self->element( { 'Name' => 'Hit_score', 'Data' => $v->[1] } ); } else { $self->element( { 'Name' => 'Hit_bits', 'Data' => $v->[1] } ); } } $self->element( { 'Name' => 'Hit_def', 'Data' => $desc } ); $self->end_element( { 'Name' => 'Hit' } ); } } 1; __END__ Developer Notes --------------- The following information is added in hopes of increasing the maintainability of this code. It runs the risk of becoming obsolete as the code gets updated. As always, double check against the actual source. If you find any discrepencies, please correct them. [ This documentation added on 3 Jun 2003. ] The logic is the brainchild of Jason Stajich, documented by Steve Chervitz. Jason: please check it over and modify as you see fit. Question: Elmo wants to know: How does this module unmarshall data from the input stream? (i.e., how does information from a raw input file get added to the correct Bioperl object?) Answer: This answer is specific to SearchIO::blast, but may apply to other SearchIO.pm subclasses as well. The following description gives the basic idea. The actual processing is a little more complex for certain types of data (HSP, Report Parameters). You can think of blast::next_result() as faking a SAX XML parser, making a non-XML document behave like its XML. The overhead to do this is quite substantial (~650 lines of code instead of ~80 in blastxml.pm). 0. First, add a key => value pair for the datum of interest to %MAPPING Example: 'Foo_bar' => 'Foo-bar', 1. next_result() collects the datum of interest from the input stream, and calls element(). Example: $self->element({ 'Name' => 'Foo_bar', 'Data' => $foobar}); 2. The element() method is a convenience method that calls start_element(), characters(), and end_element(). 3. start_element() checks to see if the event handler can handle a start_xxx(), where xxx = the 'Name' parameter passed into element(), and calls start_xxx() if so. Otherwise, start_element() does not do anything. Data that will have such an event handler are defined in %MODEMAP. Typically, there are only handler methods for the main parts of the search result (e.g., Result, Iteration, Hit, HSP), which have corresponding Bioperl modules. So in this example, there was an earlier call such as $self->element({'Name'=>'Foo'}) and the Foo_bar datum is meant to ultimately go into a Foo object. The start_foo() method in the handler will typically do any data initialization necessary to prepare for creating a new Foo object. Example: SearchResultEventBuilder::start_result() 4. characters() takes the value of the 'Data' key from the hashref argument in the elements() call and saves it in a local data member: Example: $self->{'_last_data'} = $data->{'Data'}; 5. end_element() is like start_element() in that it does the check for whether the event handler can handle end_xxx() and if so, calls it, passing in the data collected from all of the characters() calls that occurred since the start_xxx() call. If there isn't any special handler for the data type specified by 'Name', end_element() will place the data saved by characters() into another local data member that saves it in a hash with a key defined by %MAPPING. Example: $nm = $data->{'Name'}; $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; In this case, $MAPPING{$nm} is 'Foo-bar'. end_element() finishes by resetting the local data member used by characters(). (i.e., $self->{'_last_data'} = '';) 6. When the next_result() method encounters the end of the Foo element in the input stream. It will invoke $self->end_element({'Name'=>'Foo'}). end_element() then sends all of the data in the $self->{'_values'} hash. Note that $self->{'_values'} is cleaned out during start_element(), keeping it at a resonable size. In the event handler, the end_foo() method takes the hash from end_element() and creates a new hash containing the same data, but having keys lacking the 'Foo' prefix (e.g., 'Foo-bar' becomes '-bar'). The handler's end_foo() method then creates the Foo object, passing in this new hash as an argument. Example: SearchResultEventBuilder::end_result() 7. Objects created from the data in the search result are managed by the event handler which adds them to a ResultI object (using API methods for that object). The ResultI object gets passed back to SearchIO::end_element() when it calls end_result(). The ResultI object is then saved in an internal data member of the SearchIO object, which returns it at the end of next_result() by calling end_document(). (Technical Note: All objects created by end_xxx() methods in the event handler are returned to SearchIO::end_element(), but the SearchIO object only cares about the ResultI objects.) (Sesame Street aficionados note: This answer was NOT given by Mr. Noodle ;-P) BioPerl-1.6.923/Bio/SearchIO/blast_pull.pm000444000765000024 2116712254227330 20330 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::blast_pull # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::blast_pull - A parser for BLAST output =head1 SYNOPSIS # do not use this class directly it is available through Bio::SearchIO use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'blast_pull', -file => 't/data/new_blastn.txt'); while (my $result = $in->next_result) { # this is a Bio::Search::Result::BlastPullResult object print "Results for ", $result->query_name(), "\n"; while (my $hit = $result->next_hit) { print $hit->name(), "\n"; while (my $hsp = $hit->next_hsp) { print "length is ", $hsp->length(), "\n"; } } } =head1 DESCRIPTION This object implements a pull-parser for BLAST output. It is fast since it only does work on request (hence 'pull'). Currently only NCBI BLASTN and BLASTP are supported. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::blast_pull; use strict; use Bio::Search::Result::BlastPullResult; use base qw(Bio::SearchIO Bio::PullParserI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::blast_pull->new(); Function: Builds a new Bio::SearchIO::blast_pull object Returns : Bio::SearchIO::blast_pull Args : -fh/-file => BLAST output filename -format => 'blast_pull' -evalue => float or scientific notation number to be used as an evalue cutoff for hits -score => integer or scientific notation number to be used as a score value cutoff for hits -piped_behaviour => 'temp_file'|'memory'|'sequential_read' -piped_behaviour defines what the parser should do if the input is an unseekable filehandle (eg. piped input), see Bio::PullParserI::chunk for details. Default is 'memory'. =cut sub _initialize { my ($self, @args) = @_; # don't do normal SearchIO initialization my ($writer, $file, $fh, $piped_behaviour, $evalue, $score) = $self->_rearrange([qw(WRITER FILE FH PIPED_BEHAVIOUR EVALUE SCORE)], @args); $self->writer($writer) if $writer; $self->_fields( { ( header => undef, algorithm => undef, algorithm_version => undef, algorithm_reference => '', database_name => undef, database_letters => undef, database_entries => undef, next_result => undef, evalue_cutoff => '[unset]', score_cutoff => '[unset]' ) } ); $self->_fields->{evalue_cutoff} = $evalue if $evalue; $self->_fields->{score_cutoff} = $score if $score; $self->_dependencies( { ( algorithm => 'header', algorithm_version => 'header', database_name => 'header', database_letters => 'header', database_entries => 'header' ) } ); $self->chunk($file || $fh || $self->throw("-file or -fh must be supplied"), -piped_behaviour => $piped_behaviour || 'memory'); } sub _discover_header { my $self = shift; $self->_chunk_seek(0); my $header = $self->_get_chunk_by_end("\nQuery="); $self->{_after_header} = $self->_chunk_tell; #*** won't catch all types? only support blastn/p now anyway $header =~ /^(\S+) (\S+\s+\S+)/; $self->_fields->{algorithm} = $1; $self->_fields->{algorithm_version} = $2; my ($database) = $header =~ /^Database: (.+)/sm; unless ($database) { # earlier versions put query before database? my $header2 = $self->_get_chunk_by_end(".done\n"); ($database) = $header2 =~ /^Database: (.+)/sm; } $database =~ s/\s+(\d\S+) sequences; (\d\S+) total letters.*//s; my $entries = $1; my $letters = $2; $database =~ s/\n//g; $entries =~ s/,//g; $letters =~ s/,//g; $self->_fields->{database_name} = $database; $self->_fields->{database_entries} = $entries; $self->_fields->{database_letters} = $letters; $self->_fields->{header} = 1; } sub _discover_next_result { my $self = shift; return if $self->{_after_results}; my $type = $self->get_field('algorithm'); # also sets _after_header if not set if ($type eq 'BLASTN' || $type eq 'BLASTP') { unless ($self->_sequential) { $self->_chunk_seek($self->{_end_of_previous_result} || $self->{_after_header}); my ($start, $end) = $self->_find_chunk_by_end("\nQuery="); return if ($start == $end); unless ($end) { $start = $self->{_end_of_previous_result} || $self->{_after_header}; $end = undef; } $self->_fields->{next_result} = Bio::Search::Result::BlastPullResult->new(-chunk => [($self->chunk, $start, $end)], -parent => $self); $self->{_end_of_previous_result} = $end; } else { #*** doesn't work for the last result, needs fixing - try getting the database end chunk on failure?... $self->throw("sequential mode not yet implemented"); my $chunk = $self->_get_chunk_by_end("\nQuery="); $chunk || return; $self->_fields->{next_result} = Bio::Search::Result::BlastPullResult->new(-chunk => [$chunk], -parent => $self); } } else { $self->throw("Can only handle NCBI BLASTN and BLASTP right now"); } } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my $self = shift; my $result = $self->get_field('next_result') || return; undef $self->_fields->{next_result}; $self->{'_result_count'}++; return $result; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed. Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } =head2 rewind Title : rewind Usage : $searchio->rewind; Function: Allow one to reset the Result iterator to the beginning, so that next_result() will subsequently return the first result and so on. NB: result objects are not cached, so you will get new result objects each time you rewind. Also, note that result_count() counts the number of times you have called next_result(), so will not be able tell you how many results there were in the file if you use rewind(). Returns : n/a Args : none =cut sub rewind { my $self = shift; delete $self->{_end_of_previous_result}; } 1; BioPerl-1.6.923/Bio/SearchIO/blasttable.pm000444000765000024 4320212254227314 20300 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::blasttable # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::blasttable - Driver module for SearchIO for parsing NCBI -m 8/9 format =head1 SYNOPSIS # do not use this module directly use Bio::SearchIO; my $parser = Bio::SearchIO->new(-file => $file, -format => 'blasttable'); while( my $result = $parser->next_result ) { } =head1 DESCRIPTION This module will support parsing NCBI -m 8 or -m 9 tabular output and WU-BLAST -mformat 2 or -mformat 3 tabular output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::blasttable; use vars qw(%MAPPING %MODEMAP $DEFAULT_WRITER_CLASS $DefaultProgramName); use strict; use Bio::Search::Result::ResultFactory; use Bio::Search::Hit::HitFactory; use Bio::Search::HSP::HSPFactory; $DefaultProgramName = 'BLASTN'; $DEFAULT_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; # mapping of terms to Bioperl hash keys %MODEMAP = ( 'Result' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_mismatches' => 'HSP-mismatches', 'Hsp_qgapblocks' => 'HSP-query_gapblocks', 'Hsp_hgapblocks' => 'HSP-hit_gapblocks', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame'=> 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_signif' => 'HIT-significance', 'Hit_score' => 'HIT-score', 'Hit_bits' => 'HIT-bits', 'Result_program' => 'RESULT-algorithm_name', 'Result_version' => 'RESULT-algorithm_version', 'Result_query-def'=> 'RESULT-query_name', 'Result_query-len'=> 'RESULT-query_length', 'Result_query-acc'=> 'RESULT-query_accession', 'Result_querydesc'=> 'RESULT-query_description', 'Result_db' => 'RESULT-database_name', 'Result_db-len' => 'RESULT-database_entries', 'Result_db-let' => 'RESULT-database_letters', ); use base qw(Bio::SearchIO); =head2 new Title : new Usage : my $obj = Bio::SearchIO::blasttable->new(); Function: Builds a new Bio::SearchIO::blasttable object Returns : an instance of Bio::SearchIO::blasttable Args : =cut sub _initialize { my ($self,@args) = @_; $self->SUPER::_initialize(@args); my ($pname) = $self->_rearrange([qw(PROGRAM_NAME)], @args); $self->program_name($pname || $DefaultProgramName); $self->_eventHandler->register_factory('result', Bio::Search::Result::ResultFactory->new(-type => 'Bio::Search::Result::GenericResult')); $self->_eventHandler->register_factory('hit', Bio::Search::Hit::HitFactory->new(-type => 'Bio::Search::Hit::GenericHit')); $self->_eventHandler->register_factory('hsp', Bio::Search::HSP::HSPFactory->new(-type => 'Bio::Search::HSP::GenericHSP')); } =head2 next_result Title : next_result Usage : my $result = $parser->next_result Function: Parse the next result from the data stream Returns : L Args : none =cut sub next_result{ my ($self) = @_; my ($lastquery,$lasthit); local $/ = "\n"; local $_; my ($alg, $ver); while( defined ($_ = $self->_readline) ) { # WU-BLAST -mformat 3 only if(m{^#\s((?:\S+?)?BLAST[NPX])\s(\d+\.\d+.+\d{4}\])}) { ($alg, $ver) = ($1, $2); # only one header for whole file with WU-BLAST # so $alg and $ver won't get set properly for # each result $self->program_name($alg) if $alg; $self->element({'Name' => 'Result_version', 'Data' => $ver}) if $ver; next; } # -m 9 only elsif(m{^#\s+((?:\S+?)?BLAST[NPX])\s+(.+)}) { ($alg, $ver) = ($1, $2); next; } next if /^#/ || /^\s*$/; my @fields = split; next if @fields == 1; my ($qname,$hname, $percent_id, $hsp_len, $mismatches,$gapsm, $qstart,$qend,$hstart,$hend,$evalue,$bits); # WU-BLAST-specific my ($num_scores, $raw_score, $identities, $positives, $percent_pos, $qgap_blocks,$qgaps, $sgap_blocks, $sgaps, $qframe, $sframe); # NCBI -m8 and -m9 if (@fields == 12) { ($qname,$hname, $percent_id, $hsp_len, $mismatches,$gapsm, $qstart,$qend,$hstart,$hend,$evalue,$bits) = @fields; # NCBI -m8 and -m9, v 2.2.18+ } elsif (@fields == 13) { ($qname, $hname, $percent_id, $percent_pos, $hsp_len, $mismatches, $gapsm, $qstart,$qend,$hstart,$hend,$evalue,$bits) = @fields; } # WU-BLAST -mformat 2 and 3 elsif ((@fields == 22) or (@fields == 24)) { ($qname,$hname,$evalue,$num_scores, $bits, $raw_score, $hsp_len, $identities, $positives,$mismatches, $percent_id, $percent_pos, $qgap_blocks, $qgaps, $sgap_blocks, $sgaps, $qframe, $qstart, $qend, $sframe, $hstart,$hend,) = @fields; # we need total gaps in the alignment $gapsm=$qgaps+$sgaps; } if (@fields == 12 || @fields == 13) { # need to determine total gaps in the alignment for NCBI output # since NCBI reports number of gapopens and NOT total gaps my $qlen = abs($qstart - $qend) + 1; my $querygaps = $hsp_len - $qlen; my $hlen = abs($hstart - $hend) + 1; my $hitgaps = $hsp_len - $hlen; $gapsm = $querygaps + $hitgaps; } # Remember Jim's code is 0 based if( defined $lastquery && $lastquery ne $qname ) { $self->end_element({'Name' => 'Hit'}); $self->end_element({'Name' => 'Result'}); $self->_pushback($_); return $self->end_document; } elsif( ! defined $lastquery ) { $self->{'_result_count'}++; $self->start_element({'Name' => 'Result'}); $self->element({'Name' => 'Result_program', 'Data' => $alg || $self->program_name}); $self->element({'Name' => 'Result_version', 'Data' => $ver}) if $ver; $self->element({'Name' => 'Result_query-def', 'Data' => $qname}); $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hname}); # we'll store the 1st hsp bits as the hit bits $self->element({'Name' => 'Hit_bits', 'Data' => $bits}); # we'll store the 1st hsp value as the hit evalue $self->element({'Name' => 'Hit_signif', 'Data' => $evalue}); } elsif( $lasthit ne $hname ) { if( $self->in_element('hit') ) { $self->end_element({'Name' => 'Hit'}); } $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hname}); # we'll store the 1st hsp bits as the hit bits $self->element({'Name' => 'Hit_bits', 'Data' => $bits}); # we'll store the 1st hsp value as the hit evalue $self->element({'Name' => 'Hit_signif', 'Data' => $evalue}); } my $identical = $hsp_len - $mismatches - $gapsm; # If $positives value is absent, try to recover it from $percent_pos, # this is better than letting the program to assume "conserved == identical" if (not defined $positives and defined $percent_pos) { $positives = sprintf "%d", ($percent_pos * $hsp_len / 100); } $self->start_element({'Name' => 'Hsp'}); $self->element({'Name' => 'Hsp_evalue', 'Data' => $evalue}); $self->element({'Name' => 'Hsp_bit-score', 'Data' => $bits}); $self->element({'Name' => 'Hsp_identity', 'Data' => $identical}); $self->element({'Name' => 'Hsp_positive', 'Data' => $positives}); $self->element({'Name' => 'Hsp_gaps', 'Data' => $gapsm}); $self->element({'Name' => 'Hsp_query-from', 'Data' => $qstart}); $self->element({'Name' => 'Hsp_query-to', 'Data' => $qend}); $self->element({'Name' => 'Hsp_hit-from', 'Data' => $hstart }); $self->element({'Name' => 'Hsp_hit-to', 'Data' => $hend }); $self->element({'Name' => 'Hsp_align-len', 'Data' => $hsp_len}); $self->end_element({'Name' => 'Hsp'}); $lastquery = $qname; $lasthit = $hname; } # fencepost if( defined $lasthit && defined $lastquery ) { if( $self->in_element('hit') ) { $self->end_element({'Name' => 'Hit'}); } $self->end_element({'Name' => 'Result'}); return $self->end_document; } } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if( my $type = $MODEMAP{$nm} ) { $self->_mode($type); if( $self->_will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; } if($nm eq 'Result') { $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $rc; # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if( my $type = $MODEMAP{$nm} ) { if( $self->_will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->warn( "unknown nm $nm ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( $nm eq 'Result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; # deep bug fix: set $self->{'_last_data'} to undef if $$data{Data} is # a valid slot, whose value is undef -- # allows an undef to be propagated to object constructors and # handled there as desired; in particular, when Hsp_postive => -conserved # is not defined (in BLASTN, e.g.), the value of hsp's {CONSERVED} property is # set to the value of {IDENTICAL}. #/maj # return unless ( defined $data->{'Data'} ); return unless ( grep /Data/, keys %$data ); if ( !defined $data->{'Data'} ) { $self->{'_last_data'} = undef; return; } if( $data->{'Data'} =~ /^\s+$/ ) { return unless $data->{'Name'} =~ /Hsp\_(midline|qseq|hseq)/; } if( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/ ) { $self->{'_last_hspdata'}->{$data->{'Name'}} .= $data->{'Data'}; } $self->{'_last_data'} = $data->{'Data'}; } =head2 _mode Title : _mode Usage : $obj->_mode($newval) Function: Example : Returns : value of _mode Args : newvalue (optional) =cut sub _mode{ my ($self,$value) = @_; if( defined $value) { $self->{'_mode'} = $value; } return $self->{'_mode'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handles a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } =head2 program_name Title : program_name Usage : $obj->program_name($newval) Function: Get/Set the program name Returns : value of program_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub program_name{ my $self = shift; $self->{'program_name'} = shift if @_; return $self->{'program_name'} || $DefaultProgramName; } =head2 _will_handle Title : _will_handle Usage : Private method. For internal use only. if( $self->_will_handle($type) ) { ... } Function: Provides an optimized way to check whether or not an element of a given type is to be handled. Returns : Reference to EventHandler object if the element type is to be handled. undef if the element type is not to be handled. Args : string containing type of element. Optimizations: =over 2 =item 1 Using the cached pointer to the EventHandler to minimize repeated lookups. =item 2 Caching the will_handle status for each type that is encountered so that it only need be checked by calling handler-Ewill_handle($type) once. =back This does not lead to a major savings by itself (only 5-10%). In combination with other optimizations, or for large parse jobs, the savings good be significant. To test against the unoptimized version, remove the parentheses from around the third term in the ternary " ? : " operator and add two calls to $self-E_eventHandler(). =cut sub _will_handle { my ($self,$type) = @_; my $handler = $self->{'_handler'}; my $will_handle = defined($self->{'_will_handle_cache'}->{$type}) ? $self->{'_will_handle_cache'}->{$type} : ($self->{'_will_handle_cache'}->{$type} = $handler->will_handle($type)); return $will_handle ? $handler : undef; } 1; BioPerl-1.6.923/Bio/SearchIO/blastxml.pm000444000765000024 3351312254227324 20016 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::blastxml # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::blastxml - A SearchIO implementation of NCBI Blast XML parsing. =head1 SYNOPSIS use Bio::SearchIO; my $searchin = Bio::SearchIO->new(-format => 'blastxml', -file => 't/data/plague_yeast.bls.xml'); while( my $result = $searchin->next_result ) { .... } # one can also request that the parser NOT keep the XML data in memory # by using the tempfile initialization flag. $searchin = Bio::SearchIO->new(-tempfile => 1, -format => 'blastxml', -file => 't/data/plague_yeast.bls.xml'); while( my $result = $searchin->next_result ) { .... } # PSI-BLAST parsing (default is normal BLAST) $searchin = Bio::SearchIO->new( -format => 'blastxml', -blasttype => 'psiblast', -file => 't/data/plague_yeast.bls.xml'); while( my $result = $searchin->next_result ) { .... } =head1 DESCRIPTION This object implements a NCBI Blast XML parser. It requires XML::SAX; it is also recommended (for faster parsing) that XML::SAX::ExpatXS or XML::LibXML be installed. Either 'XML::SAX::ExpatXS' or 'XML::LibXML::SAX::Parser' should be set as the default parser in ParserDetails.ini. This file is located in the SAX subdirectory of XML in your local perl library (normally in the 'site' directory). Two different XML handlers currently exist to deal with logical differences between how normal BLAST reports and PSI-BLAST reports are logically parsed into BioPerl objects; this is explicitly settable using the B<-blasttype> parameter. The default is for parsing a normal BLAST report ('blast'), but if one is expecting PSI-BLAST report parsing, -blasttype B be set explicitly to 'psiblast'. This is due to a lack of any information in the XML output which tells the parser the report is derived from a PSI-BLAST run vs. a normal BLAST run. There is one additional initialization flag from the SearchIO defaults. That is the B<-tempfile> flag. If specified as true, then the parser will write out each report to a temporary filehandle rather than holding the entire report as a string in memory. The reason this is done in the first place is NCBI reports have an uncessary E?xml version="1.0"?E at the beginning of each report and RPS-BLAST reports have an additional unnecessary RPS-BLAST tag at the top of each report. So we currently have implemented the work around by preparsing the file (yes it makes the process slower, but it works). We are open to suggestions on how to optimize this in the future. =head1 DEPENDENCIES In addition to parts of the Bio:: hierarchy, this module uses: XML::SAX It is also recommended that XML::SAX::ExpatXS be installed and made the default XML::SAX parser using , along with the Expat library () for faster parsing. XML::SAX::Expat is not recommended; XML::SAX::ExpatXS is considered the current replacement for XML::SAX:Expat and is actively being considered to replace XML::SAX::Expat. XML::SAX::Expat will work, but only if you have local copies of the NCBI BLAST DTDs. This is due to issues with NCBI's BLAST XML format. The DTDs and the web address to obtain them are: NCBI_BlastOutput.dtd NCBI_BlastOutput.mod.dtd http://www.ncbi.nlm.nih.gov/data_specs/dtd/ =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::blastxml; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SearchIO); use Bio::Root::Root; use XML::SAX; use IO::File; use Bio::SearchIO::XML::BlastHandler; use Bio::SearchIO::IteratedSearchResultEventBuilder; our $DEBUG; my %VALID_TYPE = ( 'BLAST' => 'Bio::SearchIO::XML::BlastHandler', 'PSIBLAST' => 'Bio::SearchIO::XML::PsiBlastHandler', 'PSI-BLAST' => 'Bio::SearchIO::XML::PsiBlastHandler' ); # mapping of NCBI Blast terms to Bioperl hash keys =head2 new Title : new Usage : my $searchio = Bio::SearchIO->new(-format => 'blastxml', -file => 'filename', -tempfile => 1); Function: Initializes the object - this is chained through new in SearchIO Returns : Bio::SearchIO::blastxml object Args : One additional argument from the format and file/fh parameters. -tempfile => boolean. Defaults to false. Write out XML data to a temporary filehandle to send to PerlSAX parser. =cut =head2 _initialize Title : _initialize Usage : private Function: Initializes the object - this is chained through new in SearchIO =cut sub _initialize{ my ($self,@args) = @_; $self->SUPER::_initialize(@args); my ($usetempfile, $blasttype,$xmlcompact) = $self->_rearrange([qw( TEMPFILE BLASTTYPE XMLCOMPACT)],@args); $blasttype ||= 'BLAST'; $self->{_xml_compact} = $xmlcompact || 0; $self->blasttype(uc $blasttype); defined $usetempfile && $self->use_tempfile($usetempfile); $self->{_result_count} = 0; eval { require Time::HiRes }; if( $@ ) { $DEBUG = 0; } $DEBUG = 1 if( ! defined $DEBUG && ($self->verbose > 0)); } sub attach_EventHandler { my ($self,$handler) = @_; $self->SUPER::attach_EventHandler($handler); # Make sure if there is an XML parser present already, the internal Handler # is set if (exists $self->{'_xmlparser'}) { $self->{'_xmlparser'}->get_handler->eventHandler($handler); } # Optimization: caching the EventHandler since it is used a lot # during the parse. $self->{'_handler_cache'} = $handler; return; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; my $result; my ($tfh); # XMLCOMPACT # WU-BLAST has an XML_COMPACT option which needs to be preprocessed before # passing on to the parser. if ($self->{_xml_compact}) { $self->debug("XMLCOMPACT mode\n"); my ($tfh2, $filename) = IO::File->new_tmpfile or $self->throw("Unable to open temp file: $!"); $tfh2->autoflush(1); my $fh = $self->_fh; while (my $line = <$fh>) { $line =~ s/>\n_fh($tfh2); } if( $self->use_tempfile ) { $tfh = IO::File->new_tmpfile or $self->throw("Unable to open temp file: $!"); $tfh->autoflush(1); } my $okaytoprocess = ($self->blasttype =~ /PSI/) ? $self->_chunk_psiblast($tfh) : $self->_chunk_normalblast($tfh); return unless( $okaytoprocess); my %parser_args; if( defined $tfh ) { seek($tfh,0,0); %parser_args = ('Source' => { 'ByteStream' => $tfh }); } else { %parser_args = ('Source' => { 'String' => $self->{'_blastdata'} }); } my $starttime; if( $DEBUG ) { $starttime = [ Time::HiRes::gettimeofday() ]; } eval { $result = $self->{'_xmlparser'}->parse(%parser_args); }; if( $@ ) { $self->warn("error in parsing a report:\n $@"); $result = undef; } if( $DEBUG ) { $self->debug( sprintf("parsing took %f seconds\n", Time::HiRes::tv_interval($starttime))); } # parsing magic here - but we call event handlers rather than # instantiating things if (defined $result) { # result count is handled here, as the BLASTXML reports are # broken up into smaller easier to digest bits $self->{_result_count}++; return $result; } else { return; } } =head2 result_count Title : result_count Usage : $num = $stream->result_count; Function: Gets the number of Blast results that have been successfully parsed at the point of the method call. This is not the total # of results in the file. Returns : integer Args : none Throws : none =cut sub result_count { my $self = shift; return $self->{_result_count}; } =head2 use_tempfile Title : use_tempfile Usage : $obj->use_tempfile($newval) Function: Get/Set boolean flag on whether or not use a tempfile Example : Returns : value of use_tempfile Args : newvalue (optional) =cut sub use_tempfile{ my ($self,$value) = @_; if( defined $value) { $self->{'_use_tempfile'} = $value; } return $self->{'_use_tempfile'}; } =head2 blasttype Title : blasttype Usage : $obj->blasttype($newtype) Function: Get/Set BLAST report type. Returns : BLAST report type Args : case-insensitive string of types BLAST or PSIBLAST (default: BLAST) Note : this is used to determine how reports are 'chunked' (in cases where multiple queries are submitted) and which XML handler to use when parsing the report(s) =cut sub blasttype{ my ($self,$value) = @_; if ($value) { $self->throw("$value is not a supported BLAST type") unless exists $VALID_TYPE{$value}; my $ok; eval { $ok = $self->_load_module($VALID_TYPE{$value}); }; if ($@) { print STDERR <new(-verbose => $self->verbose); # The XML handler does the heavy work, passes data to object handler if ($value =~ /^PSI/) { my $handler = Bio::SearchIO::IteratedSearchResultEventBuilder->new(); $self->{'_handler'} = $handler; # cache } $xmlhandler->eventHandler($self->_eventHandler()); # start up the parser factory my $parserfactory = XML::SAX::ParserFactory->parser( Handler => $xmlhandler); $self->{'_xmlparser'} = $parserfactory; $self->saxparser(ref($parserfactory)); $self->{'_blasttype'} = $value; } return $self->{'_blasttype'}; } sub saxparser { my $self = shift; return ref($self->{'_xmlparser'}); } sub _chunk_normalblast { my ($self, $tfh) = @_; local $/ = "\n"; local $_; $self->{'_blastdata'} = ''; my ($sawxmlheader, $okaytoprocess); my $mode = 'header'; my $tail = << 'XML_END'; XML_END # no buffering needed (famous last words...) my $fh = $self->_fh; #chop up XML into edible bits for the parser while( defined( my $line = <$fh>) ) { next if $line =~ m{^\s*}xmso || $line =~ m{^}xmso; if( $line =~ m{^RPS-BLAST}i ) { $self->{'_type'} = 'RPS-BLAST'; next; } elsif ($line =~ m{^<\?xml\sversion="1.0"}xms) {# & delete $self->{'_header'} if exists $self->{'_header'}; $sawxmlheader++; $mode = 'header'; } elsif ($line =~ m{^\s*}xmso) { if (!$sawxmlheader) { if (defined $tfh) { print $tfh $self->{'_header'} } else { $self->{'_blastdata'} .= $self->{'_header'}; } } $mode = 'iteration'; } elsif ($line =~ m{^\s*}xmso) { if (defined $tfh) { print $tfh $line.$tail; } else { $self->{'_blastdata'} .= $line.$tail; } $okaytoprocess++; last; } if (defined $tfh) { print $tfh $line; } else { $self->{'_blastdata'} .= $line; } $self->{"_$mode"} .= $line if $mode eq 'header'; } return $okaytoprocess; } sub _chunk_psiblast { my ($self, $tfh) = @_; local $/ = "\n"; local $_; $self->{'_blastdata'} = ''; my ($sawxmlheader, $okaytoprocess); # no buffering needed (famous last words...) my $fh = $self->_fh; #chop up XML into edible bits for the parser while( defined( my $line = <$fh>) ) { if (defined $tfh) { print $tfh $line; } else { $self->{'_blastdata'} .= $line; } #$self->{"_$mode"} .= $line; if ($line =~ m{^}xmso) { $okaytoprocess++; last; } } #$self->debug($self->{'_blastdata'}."\n"); return $okaytoprocess; } 1; BioPerl-1.6.923/Bio/SearchIO/cross_match.pm000444000765000024 2343212254227330 20471 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::cross_match # # Please direct questions and support issues to # # Cared for by Shin Leong # # Copyright Shin Leong # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::cross_match - CrossMatch-specific subclass of Bio::SearchIO =head1 SYNOPSIS # Working with iterations (CrossMatch results) my $searchIO = Bio::SearchIO->new( -format => 'cross_match', -file => "$file.screen.out" ) while(my $r = $searchIO->next_result) { while(my $hit = $r->next_hit) { while(my $hsp = $hit->next_hsp) { #Do the processing here. } } } See L for details about working with Bio::SearchIO. =head1 DESCRIPTION This object is a subclass of Bio::SearchIO and provides some operations that facilitate working with CrossMatch and CrossMatch results. For general information about working with Results, see L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shin Leong Email sleong@watson.wustl.edu =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::cross_match; use Bio::Search::Result::CrossMatchResult; use Bio::SearchIO; use Bio::Search::Hit::GenericHit; use Bio::Search::HSP::GenericHSP; use base qw(Bio::SearchIO); =head2 next_result Title : next_result Usage : $result = stream->next_result Function: Reads the next ResultI object from the stream and returns it. Certain driver modules may encounter entries in the stream that are either misformatted or that use syntax not yet understood by the driver. If such an incident is recoverable, e.g., by dismissing a feature of a feature table or some other non-mandatory part of an entry, the driver will issue a warning. In the case of a non-recoverable situation an exception will be thrown. Do not assume that you can resume parsing the same stream after catching the exception. Note that you can always turn recoverable errors into exceptions by calling $stream->verbose(2) (see Bio::Root::RootI POD page). Returns : A Bio::Search::Result::ResultI object Args : n/a See L =cut sub next_result { my ($self) = @_; my $start = 0; while ( defined( $_ = $self->_readline ) ) { return if ( $self->{'_end_document'} ); if (/^cross_match version\s+(.*?)$/) { $self->{_algorithm_version} = $1; } elsif (/^Maximal single base matches/) { $start = 1; } elsif (/^(\d+) matching entries/) { $self->{'_end_document'} = 1; return; } elsif ( ( $start || $self->{'_result_count'} ) && /^\s*(\d+)/xms ) { $self->{'_result_count'}++; return $self->_parse($_); } elsif ( !$self->{_parameters} ) { if (/.*?\s+(\-.*?)$/) { my $p = $1; my @pp = split /\s+/, $p; for ( my $i = 0 ; $i < @pp ; $i++ ) { if ( $pp[$i] =~ /^\-/ ) { if ( $pp[ $i + 1 ] && $pp[ $i + 1 ] !~ /^\-/ ) { $self->{_parameters}->{ $pp[$i] } = $pp[ $i + 1 ]; $i++; } else { $self->{_parameters}->{ $pp[$i] } = ""; } } } } } elsif (/^Query file(s):\s+(.*?)$/) { $self->{_query_name} = $1; } elsif (/^Subject file(s):\s+(.*?)$/) { $self->{_subject_name} = $2; } } } =head2 _alignment Title : _alignment Usage : private =cut sub _alignment { my $self = shift; # C H_EO-aaa01PCR02 243 CCTCTGAATGGCTGAAGACCCCTCTGCCGAGGGAGGTTGGGGATTGTGGG 194 # # 0284119_008.c1- 1 CCTCTGAATGGCTGAAGACCCCTCTGCCGAGGGAGGTTGGGGATTGTGGG 50 # # C H_EO-aaa01PCR02 193 ACAAGGTCCCTTGGTGCTGATGGCCTGAAGGGGCCTGAGCTGTGGGCAGA 144 # # 0284119_008.c1- 51 ACAAGGTCCCTTGGTGCTGATGGCCTGAAGGGGCCTGAGCTGTGGGCAGA 100 # # C H_EO-aaa01PCR02 143 TGCAGTTTTCTGTGGGCTTGGGGAACCTCTCACGTTGCTGTGTCCTGGTG 94 # # 0284119_008.c1- 101 TGCAGTTTTCTGTGGGCTTGGGGAACCTCTCACGTTGCTGTGTCCTGGTG 150 # # C H_EO-aaa01PCR02 93 AGCAGCCCGACCAATAAACCTGCTTTTCTAAAAGGATCTGTGTTTGATTG 44 # # 0284119_008.c1- 151 AGCAGCCCGACCAATAAACCTGCTTTTCTAAAAGGATCTGTGTTTGATTG 200 # # C H_EO-aaa01PCR02 43 TATTCTCTGAAGGCAGTTACATAGGGTTACAGAGG 9 # # 0284119_008.c1- 201 TATTCTCTGAAGGCAGTTACATAGGGTTACAGAGG 235 # LSF: Should be the blank line. Otherwise error. my $blank = $self->_readline; unless ( $blank =~ /^\s*$/ ) { return; } my @data; my @pad; $count = 0; while ( defined( $_ = $self->_readline ) ) { $count = 0 if ( $count >= 3 ); next if (/^$/); if (/^(C \S+.*?\d+ )(\S+) \d+$|^( \S+.*?\d+ )(\S+) \d+$$|^\s+$/) { $count++; if ( $1 || $3 ) { $pad[$count] = $1 ? $1 : $3; push @{ $data[$count] }, ( $2 ? $2 : $4 ); } else { if (/\s{$pad[0],$pad[0]}(.*?)$/) { push @{ $data[$count] }, $1; } else { $self->throw("Format error for the homology line [$_]."); } } } else { last; } } return @data; } =head2 _parse Title : _parse Usage : private =cut sub _parse { my $self = shift; my $line = shift; my $is_alignment = 0; my ( $hit_seq, $homology_seq, $query_seq ); # 32 5.13 0.00 0.00 H_DO-0065PCR0005792_034a.b1-1 327 365 (165) C 1111547847_forward (0) 39 1 #OR #ALIGNMENT 32 5.13 0.00 0.00 H_DO-0065PCR0005792_034a.b1-1 327 365 (165) C 1111547847_forward (0) 39 1 $line =~ s/^\s+|\s+$//g; my @r = split /\s+/, $line; if ( $r[0] eq "ALIGNMENT" ) { $is_alignment = 1; shift @r; ( $hit_seq, $homology_seq, $query_seq ) = $self->_alignment(); } my $subject_seq_id; my $query_seq_id = $r[4]; my $query_start = $r[5]; my $query_end = $r[6]; my $is_complement = 0; my $subject_start; my $subject_end; if ( $r[8] eq "C" && $r[9] !~ /^\(\d+\)$/ ) { $subject_seq_id = $r[9]; $is_complement = 1; $subject_start = $r[11]; $subject_end = $r[12]; } else { $subject_seq_id = $r[8]; $subject_start = $r[9]; $subject_end = $r[10]; } my $hit = Bio::Search::Hit::GenericHit->new( -name => $subject_seq_id, -hsps => [ Bio::Search::HSP::GenericHSP->new( -query_name => $query_seq_id, -query_start => $query_start, -query_end => $query_end, -hit_name => $subject_seq_id, -hit_start => $subject_start, -hit_end => $subject_end, -query_length => 0, -hit_length => 0, -identical => $r[0], -conserved => $r[0], -query_seq => $query_seq ? ( join "", @$query_seq ) : "", #query sequence portion of the HSP -hit_seq => $hit_seq ? ( join "", @$hit_seq ) : "", #hit sequence portion of the HSP -homology_seq => $homology_seq ? ( join "", @$homology_seq ) : "", #homology sequence for the HSP #LSF: Need the direction, just to fool the GenericHSP module. -algorithm => 'SW', ) ], ); my $result = Bio::Search::Result::CrossMatchResult->new( -query_name => $self->{_query_name}, -query_accession => '', -query_description => '', -query_length => 0, -database_name => $self->{_subject_name}, -database_letters => 0, -database_entries => 0, -parameters => $self->{_parameters}, -statistics => {}, -algorithm => 'cross_match', -algorithm_version => $self->{_algorithm_version}, ); $result->add_hit($hit); return $result; } =head2 result_count Title : result_count Usage : $num = $stream->result_count; Function: Gets the number of CrossMatch results that have been parsed. Returns : integer Args : none Throws : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } 1; #$Header$ BioPerl-1.6.923/Bio/SearchIO/erpin.pm000444000765000024 4627412254227336 17320 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::erpin # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::erpin - SearchIO-based ERPIN parser =head1 SYNOPSIS # do not call this module directly. Use Bio::SearchIO. =head1 DESCRIPTION This is an experimental SearchIO-based parser for output from the erpin program. It currently parses erpin output for ERPIN versions 4.2.5 and above; older versions may work but will not be supported. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields-at-uiuc-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::erpin; use strict; use Data::Dumper; use base qw(Bio::SearchIO); my %MODEMAP = ( 'Result' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); my %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', # no evalues yet 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', # 'Hsp_hit-to' => 'HSP-hit_end', # 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_structure' => 'HSP-meta', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_stranded' => 'HSP-stranded', # not supported yet 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_gi' => 'HIT-ncbi_gi', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_signif' => 'HIT-significance', # none yet 'Hit_score' => 'HIT-score', # best HSP bit score 'Hit_bits' => 'HIT-bits', # best HSP bit score 'ERPIN_program' => 'RESULT-algorithm_name', # get/set 'ERPIN_version' => 'RESULT-algorithm_version', # get/set 'ERPIN_query-def'=> 'RESULT-query_name', # get/set 'ERPIN_query-len'=> 'RESULT-query_length', 'ERPIN_query-acc'=> 'RESULT-query_accession', # get/set 'ERPIN_querydesc'=> 'RESULT-query_description', # get/set 'ERPIN_db' => 'RESULT-database_name', # get/set 'ERPIN_db-len' => 'RESULT-database_entries', # none yet 'ERPIN_db-let' => 'RESULT-database_letters', # none yet 'Parameters_cutoff' => { 'RESULT-parameters' => 'cutoff' }, 'Parameters_expect' => { 'RESULT-parameters' => 'expect' }, 'Parameters_include' => { 'RESULT-parameters' => 'include' }, 'Parameters_sc-match' => { 'RESULT-parameters' => 'match' }, 'Parameters_sc-mismatch' => { 'RESULT-parameters' => 'mismatch' }, 'Parameters_gap-open' => { 'RESULT-parameters' => 'gapopen' }, 'Parameters_gap-extend' => { 'RESULT-parameters' => 'gapext' }, 'Parameters_filter' => { 'RESULT-parameters' => 'filter' }, 'Parameters_allowgaps' => { 'RESULT-parameters' => 'allowgaps' }, 'Parameters_full_dbpath' => { 'RESULT-parameters' => 'full_dbpath' }, 'Statistics_db-let' => { 'RESULT-statistics' => 'dbletters' }, ); my $MINSCORE = 0; my $DEFAULT_VERSION = '4.2.5'; my $DEFAULT_ALGORITHM = 'erpin'; =head2 new Title : new Usage : my $obj = Bio::SearchIO::infernal->new(); Function: Builds a new Bio::SearchIO::infernal object Returns : Bio::SearchIO::infernal Args : -fh/-file => cmsearch (infernal) filename -format => 'erpin' -algorithm => algorithm (default 'Infernal') -query_acc => query accession, eg. Rfam accession (default undef) -hsp_minscore => minimum HSP score cutoff -version => ERPIN version (not reported in output) =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ($cutoff, $accession, $version) = $self->_rearrange([qw(HSP_MINSCORE QUERY_ACC VERSION)],@args); my $handler = $self->_eventHandler; $handler->register_factory( 'result', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::GenericResult', -interface => 'Bio::Search::Result::ResultI', -verbose => $self->verbose() ) ); $handler->register_factory( 'hit', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::ModelHit', -interface => 'Bio::Search::Hit::HitI', -verbose => $self->verbose() ) ); $handler->register_factory( 'hsp', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::ModelHSP', -interface => 'Bio::Search::HSP::HSPI', -verbose => $self->verbose() ) ); $accession && $self->query_accession($accession); $cutoff ||= $MINSCORE; $self->hsp_minscore($cutoff); $version ||= $DEFAULT_VERSION; $self->algorithm_version($version); } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; my $seentop = 0; local $/ = "\n"; local $_; my $accession = $self->query_accession; my $minscore = $self->hsp_minscore; my $version = $self->algorithm_version; my $verbose = $self->verbose; # cache for speed? $self->start_document(); my ($lasthit, $lastscore, $lastlen, $lasteval); #my $hitline; PARSER: while ( defined( my $line = $self->_readline ) ) { next if $line =~ m{^\s*$}; if ($line =~ m{^Training\sset:\s+"(.*)"}xmso) { if ($seentop) { $self->_pushback($line); last PARSER; } $self->start_element({'Name' => 'Result'}); $self->element_hash( { 'ERPIN_query-def' => $1, 'ERPIN_program' =>'erpin', 'ERPIN_version' => $version, 'ERPIN_query-acc' => $accession, }); $seentop = 1; # parse rest of header here HEADER: while (defined ($line = $self->_readline) ) { next if $line =~ m{^\s*$}; if (index($line, '>') == 0 || index($line, '-------- at level 1 --------') == 0) { $self->_pushback($line); last HEADER; } if ($line =~ m{^\s+(\d+\ssequences\sof\slength\s\d+)}xmso) { $self->element( {'Name' => 'ERPIN_querydesc', 'Data' => $1} ); } elsif ($line =~ m{^Cutoff:\s+(\S+)}xmso) { $self->element( {'Name' => 'Parameters_cutoff', 'Data' => $1} ); } elsif ($line =~ m{^Database:\s+"(.*)"}xmso) { $self->element( {'Name' => 'ERPIN_db', 'Data' => $1} ); } elsif ($line =~ m{^\s+(\d+)\snucleotides\sto\sbe\sprocessed\sin\s(\d+)\ssequences}xmso) { $self->element_hash( {'ERPIN_db-len' => $2, 'ERPIN_db-let' => $1} ); } elsif ($line =~ m{^E-value\sat\scutoff\s\S+\sfor\s\S+\sdouble\sstrand\sdata:\s+(\S+)}xmso) { $self->element( {'Name' => 'Parameters_expect', 'Data' => $1} ); } elsif ($line =~ m{^\s+(ATGC\sratios:\s+(?:\S+\s+\S+\s+\S+\s+\S+))}) { $self->element( {'Name' => 'Statistics_db-let', 'Data' => $1} ); } } } elsif ($line =~ m{^>(\S+)\s+(.*)}xmso ) { my ($id, $desc) = ($1, $2); chomp $desc; # desc line is repeated for each strand, so must check # prior to starting a new hit if (!$lasthit || $id ne $lasthit) { if ($self->within_element('hit') ) { $self->element_hash({ 'Hit_signif' => $lasteval, 'Hit_score' => $lastscore, 'Hit_bits' => $lastscore }); $self->end_element({'Name' => 'Hit'}); } $self->start_element({'Name' => 'Hit'}); my ($gi, $acc, $ver) = $self->_get_seq_identifiers($id); $self->element_hash({ 'Hit_id' => $id, 'Hit_gi' => $gi, 'Hit_accession' => $ver ? "$acc.$ver" : $acc ? $acc : $id, 'Hit_def' => $desc }); } $lasthit = $id; } elsif ( (index($line, 'FW') == 0) || (index($line, 'RC') == 0)) { my ($str, $hn, $pos, $score, $eval) = split ' ', $line; if ($minscore < $score) { $self->start_element({'Name' => 'Hsp'}); my ($start, $end) = split m{\.\.}, $pos, 2; ($start, $end) = ($end, $start) if ($str eq 'RC'); $line = $self->_readline; chomp $line; $self->element_hash({ 'Hsp_stranded' => 'HIT', 'Hsp_hit-from' => $start, 'Hsp_hit-to' => $end, 'Hsp_score' => $score, 'Hsp_bit-score' => $score, 'Hsp_evalue' => $eval, 'Hsp_query-from' => 1, 'Hsp_query-to' => length($line), 'Hsp_align-len' => length($line), 'Hsp_hseq' =>$line }); $self->end_element({'Name' => 'Hsp'}); $lastscore = $score if (!$lastscore || $lastscore < $score); $lasteval = $eval if (!$lasteval || $lasteval > $eval); } } else { #$self->debug("Dropped data: $line"); } } if ($seentop) { if ($self->within_element('hit')) { $self->element_hash({ 'Hit_signif' => $lasteval, 'Hit_score' => $lastscore, 'Hit_bits' => $lastscore }); $self->end_element({'Name' => 'Hit'}); } $self->end_element({'Name' => 'Result'}); } return $self->end_document(); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "start_%s", lc $type ); $self->_eventHandler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( defined $type && $type eq 'result' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys, 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "end_%s", lc $type ); $rc = $self->_eventHandler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } my $lastelem = shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { $self->debug("unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convenience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; # simple data calls (%MAPPING) do not need start_element $self->characters($data); $self->end_element($data); } =head2 element_hash Title : element Usage : $eventhandler->element_hash({'Hsp_hit-from' => $start, 'Hsp_hit-to' => $end, 'Hsp_score' => $lastscore}); Function: Convenience method that takes multiple simple data elements and maps to appropriate parameters Returns : none Args : Hash ref with the mapped key (in %MAPPING) and value =cut sub element_hash { my ($self, $data) = @_; $self->throw("Must provide data hash ref") if !$data || !ref($data); for my $nm (sort keys %{$data}) { next if $data->{$nm} && $data->{$nm} =~ m{^\s*$}o; if ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $data->{$nm}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $data->{$nm}; } } } } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/o ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if ( !defined $name || !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { return 1 if ( $_ eq $name ); } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'within' because 'in' only tests its immediate parent. Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ($self) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } =head2 query_accession Title : query_accession Usage : my $acc = $parser->query_accession(); Function: Get/Set query (model) accession; Infernal currently does not output the accession number (Rfam accession #) Returns : String (accession) Args : [optional] String (accession) =cut sub query_accession { my $self = shift; return $self->{'_query_accession'} = shift if @_; return $self->{'_query_accession'}; } =head2 hsp_minscore Title : hsp_minscore Usage : my $cutoff = $parser->hsp_minscore(); Function: Get/Set min bit score cutoff (for generating Hits/HSPs) Returns : score (number) Args : [optional] score (number) =cut sub hsp_minscore { my $self = shift; return $self->{'_hsp_minscore'} = shift if @_; return $self->{'_hsp_minscore'}; } =head2 algorithm_version Title : algorithm_version Usage : my $ver = $parser->algorithm_version(); Function: Get/Set algorithm version (not defined in RNAMotif output) Returns : String (accession) Args : [optional] String (accession) =cut sub algorithm_version { my $self = shift; return $self->{'_algorithm'} = shift if @_; return $self->{'_algorithm'}; } 1; BioPerl-1.6.923/Bio/SearchIO/EventHandlerI.pm000444000765000024 1270312254227334 20657 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::EventHandlerI # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::EventHandlerI - An abstract Event Handler for Search Result parsing =head1 SYNOPSIS # do not use this object directly it is an interface # See Bio::SearchIO::SearchResultEventBuilder for an implementation use Bio::SearchIO::SearchResultEventBuilder; my $handler = Bio::SearchIO::SearchResultEventBuilder->new(); =head1 DESCRIPTION This interface describes the basic methods needed to handle Events thrown from parsing a Search Result such as FASTA, BLAST, or HMMer. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::EventHandlerI; use strict; use Carp; use base qw(Bio::Event::EventHandlerI); =head2 start_result Title : start_result Usage : $handler->start_result($data) Function: Begins a result event cycle Returns : none Args : Type of Result =cut sub start_result { my ($self) = @_; $self->throw_not_implemented(); } =head2 end_result Title : end_result Usage : $handler->end_result($data) Function: Ends a result event cycle Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_result{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 start_hsp Title : start_hsp Usage : $handler->start_hsp($data) Function: Start a HSP event cycle Returns : none Args : type of element associated hashref =cut sub start_hsp{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 end_hsp Title : end_hsp Usage : $handler->end_hsp() Function: Ends a HSP event cycle Returns : Bio::Search::HSP::HSPI object Args : type of event and associated hashref =cut sub end_hsp{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 start_hit Title : start_hit Usage : $handler->start_hit() Function: Starts a Hit event cycle Returns : none Args : type of event and associated hashref =cut sub start_hit { my ($self,@args) = @_; $self->throw_not_implemented } =head2 end_hit Title : end_hit Usage : $handler->end_hit() Function: Ends a Hit event cycle Returns : Bio::Search::Hit::HitI object Args : type of event and associated hashref =cut sub end_hit { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 start_iteration Title : start_iteration Usage : $handler->start_iteration() Function: Starts an Iteration event cycle Returns : none Args : type of event and associated hashref =cut sub start_iteration { my ($self,@args) = @_; $self->throw_not_implemented } =head2 end_iteration Title : end_iteration Usage : $handler->end_iteration() Function: Ends an Iterationevent cycle Returns : Bio::Search::Iteration::IterationI object Args : type of event and associated hashref =cut sub end_iteration { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 register_factory Title : register_factory Usage : $handler->register_factory('TYPE',$factory); Function: Register a specific factory for a object type class Returns : none Args : string representing the class and Bio::Factory::ObjectFactoryI See L for more information =cut sub register_factory{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 factory Title : factory Usage : my $f = $handler->factory('TYPE'); Function: Retrieves the associated factory for requested 'TYPE' Returns : a Bio::Factory::ObjectFactoryI Throws : Bio::Root::BadParameter if none registered for the supplied type Args : name of factory class to retrieve See L for more information =cut sub factory{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 Bio::Event::EventHandlerI methods =cut =head2 will_handle Title : will_handle Usage : if( $handler->will_handle($event_type) ) { ... } Function: Tests if this event builder knows how to process a specific event Returns : boolean Args : event type name =cut =head2 SAX methods See L for the additional SAX methods. =cut 1; BioPerl-1.6.923/Bio/SearchIO/exonerate.pm000444000765000024 5414712254227340 20166 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::exonerate # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::exonerate - parser for Exonerate =head1 SYNOPSIS # do not use this module directly, it is a driver for SearchIO use Bio::SearchIO; my $searchio = Bio::SearchIO->new(-file => 'file.exonerate', -format => 'exonerate'); while( my $r = $searchio->next_result ) { print $r->query_name, "\n"; } =head1 DESCRIPTION This is a driver for the SearchIO system for parsing Exonerate (Guy Slater) output. You can get Exonerate at http://www.ebi.ac.uk/~guy/exonerate/ [until Guy puts up a Web reference,publication for it.]). An optional parameter -min_intron is supported by the L initialization method. This is if you run Exonerate with a different minimum intron length (default is 30) the parser will be able to detect the difference between standard deletions and an intron. Still some room to play with there that might cause this to get misinterpreted that has not been fully tested or explored. The VULGAR and CIGAR formats should be parsed okay now creating HSPs where appropriate (so merging match states where appropriate rather than breaking an HSP at each indel as it may have done in the past). The GFF that comes from exonerate is still probably a better way to go if you are doing protein2genome or est2genome mapping. For example you can see this script: ### TODO: Jason, this link is dead, do we have an updated one? http://fungal.genome.duke.edu/~jes12/software/scripts/process_exonerate_gff3.perl.txt If your report contains both CIGAR and VULGAR lines only the first one will processed for a given Query/Target pair. If you preferentially want to use VULGAR or CIGAR add one of these options when initializing the SearchIO object. -cigar => 1 OR -vulgar => 1 Or set them via these methods. $parser->cigar(1) OR $parser->vulgar(1) =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::exonerate; use strict; use vars qw(@STATES %MAPPING %MODEMAP $DEFAULT_WRITER_CLASS $MIN_INTRON); use base qw(Bio::SearchIO); %MODEMAP = ( 'ExonerateOutput' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_query-from'=> 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_score' => 'HSP-score', 'Hsp_qlength' => 'HSP-query_length', 'Hsp_hlength' => 'HSP-hit_length', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hit_id' => 'HIT-name', 'Hit_desc' => 'HIT-description', 'Hit_len' => 'HIT-length', 'Hit_score' => 'HIT-score', 'ExonerateOutput_program' => 'RESULT-algorithm_name', 'ExonerateOutput_query-def' => 'RESULT-query_name', 'ExonerateOutput_query-desc'=> 'RESULT-query_description', 'ExonerateOutput_query-len' => 'RESULT-query_length', ); $DEFAULT_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; $MIN_INTRON=30; # This is the minimum intron size =head2 new Title : new Usage : my $obj = Bio::SearchIO::exonerate->new(); Function: Builds a new Bio::SearchIO::exonerate object Returns : an instance of Bio::SearchIO::exonerate Args : -min_intron => somewhat obselete option, how to determine if a an indel is an intron or a local gap. Use VULGAR rather than CIGAR to avoid this heuristic,default 30. -cigar => 1 set this to 1 if you want to parse CIGAR exclusively. -vulgar => 1 set this to 1 if you want to parse VULGAR exclusively, setting both to 1 will revert to the default behavior of just parsing the first line that it sees. =cut sub new { my ($class) = shift; my $self = $class->SUPER::new(@_); my ($min_intron,$cigar, $vulgar) = $self->_rearrange([qw(MIN_INTRON CIGAR VULGAR)], @_); if( $min_intron ) { $MIN_INTRON = $min_intron; } if( $cigar && $vulgar ) { $self->warn("cannot get HSPs from both CIGAR and VULGAR lines, will just choose whichever comes first (same as if you had chosen neither"); $cigar = 0; $vulgar=0; } $self->cigar($cigar); $self->vulgar($vulgar); $self; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result{ my ($self) = @_; local $/ = "\n"; local $_; $self->{'_last_data'} = ''; my ($reporttype,$seenquery,$reportline); $self->start_document(); my @hit_signifs; my $seentop; my (@q_ex, @m_ex, @h_ex); ## gc addition while( defined($_ = $self->_readline) ) { # warn( "Reading $_"); if( /^\s*Query:\s+(\S+)\s*(.+)?/ ) { if( $seentop ) { $self->end_element({'Name' => 'ExonerateOutput'}); $self->_pushback($_); return $self->end_document(); } $seentop = 1; my ($nm,$desc) = ($1,$2); chomp($desc) if defined $desc; $self->{'_result_count'}++; $self->start_element({'Name' => 'ExonerateOutput'}); $self->element({'Name' => 'ExonerateOutput_query-def', 'Data' => $nm }); $self->element({'Name' => 'ExonerateOutput_query-desc', 'Data' => $desc }); $self->element({'Name' => 'ExonerateOutput_program', 'Data' => 'Exonerate' }); $self->{'_seencigar'} = 0; $self->{'_vulgar'} = 0; } elsif ( /^Target:\s+(\S+)\s*(.+)?/ ) { my ($nm,$desc) = ($1,$2); chomp($desc) if defined $desc; $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $nm}); $self->element({'Name' => 'Hit_desc', 'Data' => $desc}); $self->{'_seencigar'} = 0; $self->{'_vulgar'} = 0; } elsif( s/^vulgar:\s+(\S+)\s+ # query sequence id (\d+)\s+(\d+)\s+([\-\+\.])\s+ # query start-end-strand (\S+)\s+ # target sequence id (\d+)\s+(\d+)\s+([\-\+])\s+ # target start-end-strand (-?\d+)\s+ # score //ox ) { next if( $self->cigar || $self->{'_seencigar'}); $self->{'_vulgar'}++; # # Note from Ewan. This is ugly - copy and paste from # cigar line parsing. Should unify somehow... # if( ! $self->within_element('result') ) { $self->start_element({'Name' => 'ExonerateOutput'}); $self->element({'Name' => 'ExonerateOutput_query-def', 'Data' => $1 }); } if( ! $self->within_element('hit') ) { $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $5}); } ## gc note: ## $qe and $he are no longer used for calculating the ends, ## just the $qs and $hs values and the alignment and insert lenghts my ($qs,$qe,$qstrand) = ($2,$3,$4); my ($hs,$he,$hstrand) = ($6,$7,$8); my $score = $9; # $self->element({'Name' => 'ExonerateOutput_query-len', # 'Data' => $qe}); # $self->element({'Name' => 'Hit_len', # 'Data' => $he}); ## gc note: ## add one because these values are zero-based ## this calculation was originally done lower in the code, ## but it's clearer to do it just once at the start my @rest = split; my ($qbegin,$qend) = ('query-from', 'query-to'); if( $qstrand eq '-' ) { $qstrand = -1; $qe++; } else { $qstrand = 1; $qs++; } my ($hbegin,$hend) = ('hit-from', 'hit-to'); if( $hstrand eq '-' ) { $hstrand = -1; $he++; } else { $hstrand = 1; $hs++; } # okay let's do this right and generate a set of HSPs # from the cigar line/home/bio1/jes12/bin/exonerate --model est2genome --bestn 1 t/data/exonerate_cdna.fa t/data/exonerate_genomic_rev.fa my ($aln_len,$inserts,$deletes) = (0,0,0); my ($laststate,@events,$gaps) =( '' ); while( @rest >= 3 ) { my ($state,$len1,$len2) = (shift @rest, shift @rest, shift @rest); # # HSPs are only the Match cases; otherwise we just # move the coordinates on by the correct amount # if( $state eq 'M' ) { if( $laststate eq 'G' ) { # merge gaps across Match states so the HSP # goes across $events[-1]->{$qend} = $qs + $len1*$qstrand - $qstrand; $events[-1]->{$hend} = $hs + $len2*$hstrand - $hstrand; $events[-1]->{'gaps'} = $gaps; } else { push @events, { 'score' => $score, 'align-len' => $len1, $qbegin => $qs, $qend => ($qs + $len1*$qstrand - $qstrand), $hbegin => $hs, $hend => ($hs + $len2*$hstrand - $hstrand), }; } $gaps = 0; } else { $gaps = $len1 + $len2 if $state eq 'G'; } $qs += $len1*$qstrand; $hs += $len2*$hstrand; $laststate= $state; } for my $event ( @events ) { $self->start_element({'Name' => 'Hsp'}); while( my ($key,$val) = each %$event ) { $self->element({'Name' => "Hsp_$key", 'Data' => $val}); } $self->element({'Name' => 'Hsp_identity', 'Data' => 0}); $self->end_element({'Name' => 'Hsp'}); } # end of hit $self->element({'Name' => 'Hit_score', 'Data' => $score}); # issued end... $self->end_element({'Name' => 'Hit'}); $self->end_element({'Name' => 'ExonerateOutput'}); return $self->end_document(); } elsif( s/^cigar:\s+(\S+)\s+ # query sequence id (\d+)\s+(\d+)\s+([\-\+])\s+ # query start-end-strand (\S+)\s+ # target sequence id (\d+)\s+(\d+)\s+([\-\+])\s+ # target start-end-strand (-?\d+)\s+ # score //ox ) { next if( $self->vulgar || $self->{'_seenvulgar'}); $self->{'_cigar'}++; if( ! $self->within_element('result') ) { $self->start_element({'Name' => 'ExonerateOutput'}); $self->element({'Name' => 'ExonerateOutput_query-def', 'Data' => $1 }); } if( ! $self->within_element('hit') ) { $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $5}); } ## gc note: ## $qe and $he are no longer used for calculating the ends, ## just the $qs and $hs values and the alignment and insert lenghts my ($qs,$qe,$qstrand) = ($2,$3,$4); my ($hs,$he,$hstrand) = ($6,$7,$8); my $score = $9; # $self->element({'Name' => 'ExonerateOutput_query-len', # 'Data' => $qe}); # $self->element({'Name' => 'Hit_len', # 'Data' => $he}); my @rest = split; if( $qstrand eq '-' ) { $qstrand = -1; ($qs,$qe) = ($qe,$qs); # flip-flop if we're on opp strand $qs--; $qe++; } else { $qstrand = 1; } if( $hstrand eq '-' ) { $hstrand = -1; ($hs,$he) = ($he,$hs); # flip-flop if we're on opp strand $hs--; $he++; } else { $hstrand = 1; } # okay let's do this right and generate a set of HSPs # from the cigar line ## gc note: ## add one because these values are zero-based ## this calculation was originally done lower in the code, ## but it's clearer to do it just once at the start $qs++; $hs++; my ($aln_len,$inserts,$deletes) = (0,0,0); while( @rest >= 2 ) { my ($state,$len) = (shift @rest, shift @rest); if( $state eq 'I' ) { $inserts+=$len; } elsif( $state eq 'D' ) { if( $len >= $MIN_INTRON ) { $self->start_element({'Name' => 'Hsp'}); $self->element({'Name' => 'Hsp_score', 'Data' => $score}); $self->element({'Name' => 'Hsp_align-len', 'Data' => $aln_len}); $self->element({'Name' => 'Hsp_identity', 'Data' => $aln_len - ($inserts + $deletes)}); # HSP ends where the other begins $self->element({'Name' => 'Hsp_query-from', 'Data' => $qs}); ## gc note: ## $qs is now the start of the next hsp ## the end of this hsp is 1 before this position ## (or 1 after in case of reverse strand) $qs += $aln_len*$qstrand; $self->element({'Name' => 'Hsp_query-to', 'Data' => $qs - ($qstrand*1)}); $hs += $deletes*$hstrand; $self->element({'Name' => 'Hsp_hit-from', 'Data' => $hs}); $hs += $aln_len*$hstrand; $self->element({'Name' => 'Hsp_hit-to', 'Data' => $hs-($hstrand*1)}); $self->element({'Name' => 'Hsp_align-len', 'Data' => $aln_len + $inserts + $deletes}); $self->element({'Name' => 'Hsp_identity', 'Data' => $aln_len }); $self->element({'Name' => 'Hsp_gaps', 'Data' => $inserts + $deletes}); $self->element({'Name' => 'Hsp_querygaps', 'Data' => $inserts}); $self->element({'Name' => 'Hsp_hitgaps', 'Data' => $deletes}); ## gc addition start $self->element({'Name' => 'Hsp_qseq', 'Data' => shift @q_ex, }); $self->element({'Name' => 'Hsp_hseq', 'Data' => shift @h_ex, }); $self->element({'Name' => 'Hsp_midline', 'Data' => shift @m_ex, }); ## gc addition end $self->end_element({'Name' => 'Hsp'}); $aln_len = $inserts = $deletes = 0; } $deletes+=$len; } else { $aln_len += $len; } } $self->start_element({'Name' => 'Hsp'}); ## gc addition start $self->element({'Name' => 'Hsp_qseq', 'Data' => shift @q_ex, }); $self->element({'Name' => 'Hsp_hseq', 'Data' => shift @h_ex, }); $self->element({'Name' => 'Hsp_midline', 'Data' => shift @m_ex, }); ## gc addition end $self->element({'Name' => 'Hsp_score', 'Data' => $score}); $self->element({'Name' => 'Hsp_query-from', 'Data' => $qs}); $qs += $aln_len*$qstrand; $self->element({'Name' => 'Hsp_query-to', 'Data' => $qs - ($qstrand*1)}); $hs += $deletes*$hstrand; $self->element({'Name' => 'Hsp_hit-from', 'Data' => $hs}); $hs += $aln_len*$hstrand; $self->element({'Name' => 'Hsp_hit-to', 'Data' => $hs -($hstrand*1)}); $self->element({'Name' => 'Hsp_align-len', 'Data' => $aln_len}); $self->element({'Name' => 'Hsp_identity', 'Data' => $aln_len - ($inserts + $deletes)}); $self->element({'Name' => 'Hsp_gaps', 'Data' => $inserts + $deletes}); $self->element({'Name' => 'Hsp_querygaps', 'Data' => $inserts}); $self->element({'Name' => 'Hsp_hitgaps', 'Data' => $deletes}); $self->end_element({'Name' => 'Hsp'}); $self->element({'Name' => 'Hit_score', 'Data' => $score}); $self->end_element({'Name' => 'Hit'}); $self->end_element({'Name' => 'ExonerateOutput'}); return $self->end_document(); } else { # skipping this line } } return $self->end_document() if( $seentop ); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if( $type ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; if($type eq 'result') { $self->{'_values'} = {}; $self->{'_result'}= undef; } } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if( $type = $MODEMAP{$nm} ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->debug( "unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/ ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_elements'} = []; $self->{'_reporttype'} = 'exonerate'; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } sub write_result { my ($self, $blast, @args) = @_; if( not defined($self->writer) ) { $self->warn("Writer not defined. Using a $DEFAULT_WRITER_CLASS"); $self->writer( $DEFAULT_WRITER_CLASS->new() ); } $self->SUPER::write_result( $blast, @args ); } sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } =head2 vulgar Title : vulgar Usage : $obj->vulgar($newval) Function: Get/Set flag, do you want to build HSPs from VULGAR string? Returns : value of vulgar (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub vulgar{ my $self = shift; my $x = shift if @_; if( @_ ) { if( $_[0] && $self->{'_cigar'} ) { $self->warn("Trying to set vulgar and cigar both to 1, must be either or"); $self->{'_cigar'} = 0; return $self->{'_vulgar'} = 0; } } return $self->{'_vulgar'}; } =head2 cigar Title : cigar Usage : $obj->cigar($newval) Function: Get/Set boolean flag do you want to build HSPs from CIGAR strings? Returns : value of cigar (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub cigar{ my $self = shift; my $x = shift if @_; if( @_ ) { if( $_[0] && $self->{'_vulgar'} ) { $self->warn("Trying to set vulgar and cigar both to 1, must be either or"); $self->{'_vulgar'} = 0; return $self->{'_cigar'} = 0; } } return $self->{'_cigar'}; } 1; BioPerl-1.6.923/Bio/SearchIO/fasta.pm000444000765000024 15007412254227321 17305 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::fasta # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::fasta - A SearchIO parser for FASTA results =head1 SYNOPSIS # Do not use this object directly, use it through the SearchIO system use Bio::SearchIO; my $searchio = Bio::SearchIO->new(-format => 'fasta', -file => 'report.FASTA'); while( my $result = $searchio->next_result ) { # ... do what you would normally doi with Bio::SearchIO. } =head1 DESCRIPTION This object contains the event based parsing code for FASTA format reports. It creates L objects instead of L for the HSP objects. This module will parse -m 9 -d 0 output as well as default m 1 output from FASTA as well as SSEARCH. Also see the SearchIO HOWTO: L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Aaron Mackey, William Pearson Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::fasta; use vars qw(%MODEMAP %MAPPING $IDLENGTH); use strict; # Object preamble - inherits from Bio::Root::RootI use Bio::Factory::ObjectFactory; BEGIN { # Set IDLENGTH to a new value if you have # compile FASTA with a different ID length # (actually newest FASTA allows the setting of this # via -C parameter, default is 6) $IDLENGTH = 6; # mapping of NCBI Blast terms to Bioperl hash keys %MODEMAP = ( 'FastaOutput' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); # This should really be done more intelligently, like with # XSLT %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_sw-score' => 'HSP-swscore', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_evalue2' => 'HSP-evalue2', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame' => 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_signif' => 'HIT-significance', 'Hit_score' => 'HIT-score', 'FastaOutput_program' => 'RESULT-algorithm_name', 'FastaOutput_version' => 'RESULT-algorithm_version', 'FastaOutput_query-def' => 'RESULT-query_name', 'FastaOutput_querydesc' => 'RESULT-query_description', 'FastaOutput_query-len' => 'RESULT-query_length', 'FastaOutput_db' => 'RESULT-database_name', 'FastaOutput_db-len' => 'RESULT-database_entries', 'FastaOutput_db-let' => 'RESULT-database_letters', 'Parameters_matrix' => { 'RESULT-parameters' => 'matrix' }, 'Parameters_expect' => { 'RESULT-parameters' => 'expect' }, 'Parameters_include' => { 'RESULT-parameters' => 'include' }, 'Parameters_sc-match' => { 'RESULT-parameters' => 'match' }, 'Parameters_sc-mismatch' => { 'RESULT-parameters' => 'mismatch' }, 'Parameters_gap-open' => { 'RESULT-parameters' => 'gapopen' }, 'Parameters_gap-ext' => { 'RESULT-parameters' => 'gapext' }, 'Parameters_word-size' => { 'RESULT-parameters' => 'wordsize' }, 'Parameters_ktup' => { 'RESULT-parameters' => 'ktup' }, 'Parameters_filter' => { 'RESULT-parameters' => 'filter' }, 'Statistics_db-num' => { 'RESULT-statistics' => 'dbentries' }, 'Statistics_db-len' => { 'RESULT-statistics' => 'dbletters' }, 'Statistics_hsp-len' => { 'RESULT-statistics' => 'hsplength' }, 'Statistics_eff-space' => { 'RESULT-statistics' => 'effectivespace' }, 'Statistics_kappa' => { 'RESULT-statistics' => 'kappa' }, 'Statistics_lambda' => { 'RESULT-statistics' => 'lambda' }, 'Statistics_entropy' => { 'RESULT-statistics' => 'entropy' }, ); } use base qw(Bio::SearchIO); =head2 new Title : new Usage : my $obj = Bio::SearchIO::fasta->new(); Function: Builds a new Bio::SearchIO::fasta object Returns : Bio::SearchIO::fasta Args : -idlength - set ID length to something other than the default (6), this is only necessary if you have compiled FASTA with a new default id length to display in the HSP alignment blocks =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); return unless @args; my ($idlength) = $self->_rearrange( [qw(IDLENGTH)], @args ); $self->idlength( $idlength || $IDLENGTH ); $self->_eventHandler->register_factory( 'hsp', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::FastaHSP', -interface => 'Bio::Search::HSP::HSPI' ) ); return 1; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; local $/ = "\n"; local $_; my $data = ''; my $seentop = 0; my $current_hsp; my $m9HSP = 0; $self->start_document(); my @hit_signifs; while ( defined( $_ = $self->_readline ) ) { next if ( !$self->in_element('hsp') && /^\s+$/ ); # skip empty lines if ( m/(\S+)\s+searches\s+a\s+(protein\s+or\s+DNA\s+)?sequence/oxi || /(\S+)\s+compares\s+a/ || /(\S+)\s+performs\s+a/ || /(\S+)\s+produces\s/ || /(\S+)\s+finds\s+/ # for lalign, but does not work because no "The best scores are:" || ( m/^\#\s+/ # has a command log line && ( $_ = $self->_readline ) && /(\S+)\s+searches\s+a\s+(protein\s+or\s+DNA\s+)?sequence/oxi || /(\S+)\s+compares\s+a/ || /(\S+)\s+performs\s+a/ || /(\S+)\s+produces\s/ || /(\S+)\s+finds\s+/ # for lalign, but does not work because no "The best scores are:" ) ) { if ($seentop) { $self->_pushback($_); $self->end_element( { 'Name' => 'FastaOutput' } ); return $self->end_document(); } $self->{'_reporttype'} = $1; $self->start_element( { 'Name' => 'FastaOutput' } ); $self->{'_result_count'}++; $seentop = 1; #$self->debug( "reporttype is " . $self->{'_reporttype'} . "\n" ); $self->element( { 'Name' => 'FastaOutput_program', 'Data' => $self->{'_reporttype'} } ); my $version; # version 35 version string on same line if (/version/) { ($version) = (/version\s+(\S+)/); } # earlier versions, it's on the next line else { $_ = $self->_readline(); ($version) = (/version\s+(\S+)/); } $version = '' unless defined $version; $self->{'_version'} = $version; $self->element( { 'Name' => 'FastaOutput_version', 'Data' => $version } ); my ( $last, $leadin, $type, $querylen, $querytype, $querydef ); while ( defined( $_ = $self->_readline() ) ) { if ( /^ ( (?:\s+>) | # fa33 lead-in (?:\s*\d+\s*>>>) # fa34 mlib lead-in ) (.*) /x ) { ( $leadin, $querydef ) = ( $1, $2 ); if ( $leadin =~ m/>>>/ ) { if ( $querydef =~ /^(.*?)\s+(?:\-\s+)?(\d+)\s+(aa|nt).*$/o ) { ( $querydef, $querylen, $querytype ) = ( $1, $2, $3 ); last; } } else { if ( $last =~ /(\S+)[:,]\s*(\d+)\s+(aa|nt)/ ) { ( $querylen, $querytype ) = ( $2, $3 ); $querydef ||= $1; last; } } } elsif (m/^\s*vs\s+\S+/o) { if ( $last =~ /(\S+)[,:]\s+(\d+)\s+(aa|nt)/o ) { ( $querydef, $querylen, $querytype ) = ( $1, $2, $3 ); last; } } $last = $_; } if ( $self->{'_reporttype'} && $self->{'_reporttype'} eq 'FASTA' ) { if ( $querytype eq 'nt' ) { $self->{'_reporttype'} = 'FASTN'; } elsif ( $querytype eq 'aa' ) { $self->{'_reporttype'} = 'FASTP'; } } my ( $name, $descr ) = $querydef =~ m/^(\S+)\s*(.*?)\s*$/o; $self->element( { 'Name' => 'FastaOutput_query-def', 'Data' => $name } ); $self->element( { 'Name' => 'FastaOutput_querydesc', 'Data' => $descr } ); if ($querylen) { $self->element( { 'Name' => 'FastaOutput_query-len', 'Data' => $querylen } ); } else { $self->warn("unable to find and set query length"); } if ( $last =~ /^\s*vs\s+(\S+)/ || ( $last =~ /^searching\s+(\S+)\s+library/ ) || ( $last =~ /^Library:\s+(\S+)\s+/ ) || ( defined $_ && ( /^\s*vs\s+(\S+)/ || /^Library:\s+(\S+)\s+/ ) ) || ( defined( $_ = $self->_readline() ) && ( /^\s*vs\s+(\S+)/ || /^Library:\s+(\S+)/ ) ) ) { $self->element( { 'Name' => 'FastaOutput_db', 'Data' => $1 } ); } elsif (m/^\s+opt(?:\s+E\(\))?$/o) { # histogram ... read over it more rapidly than the larger outer loop: while ( defined( $_ = $self->_readline ) ) { last if m/^>\d+/; } } } elsif (/(\d+)\s+residues\s+in\s+(\d+)\s+(?:library\s+)?sequences/) { $self->element( { 'Name' => 'FastaOutput_db-let', 'Data' => $1 } ); $self->element( { 'Name' => 'FastaOutput_db-len', 'Data' => $2 } ); $self->element( { 'Name' => 'Statistics_db-len', 'Data' => $1 } ); $self->element( { 'Name' => 'Statistics_db-num', 'Data' => $2 } ); } elsif (/Lambda=\s*(\S+)/) { $self->element( { 'Name' => 'Statistics_lambda', 'Data' => $1 } ); } elsif (/K=\s*(\S+)/) { $self->element( { 'Name' => 'Statistics_kappa', 'Data' => $1 } ); } elsif (/^\s*(Smith-Waterman)/) { $self->{'_reporttype'} = $1; m/\[\s*(\S+)\s+matrix \([^\)]+\)(xS)?\],/; $self->element( { 'Name' => 'Parameters_matrix', 'Data' => $1 } ); $self->element( { 'Name' => 'Parameters_filter', 'Data' => defined $2 ? 1 : 0, } ); if (/\s*gap\-penalty:\s*(\-?\d+)\/(\-?\d+)/) { $self->element( { 'Name' => 'Parameters_gap-open', 'Data' => $1, } ); $self->element( { 'Name' => 'Parameters_gap-ext', 'Data' => $2, } ); } elsif (/\s*open\/ext:\s*(\-?\d+)\/(\-?\d+)/) { $self->element( { 'Name' => 'Parameters_gap-open', 'Data' => $1, } ); $self->element( { 'Name' => 'Parameters_gap-ext', 'Data' => $2, } ); } $self->element( { 'Name' => 'FastaOutput_program', 'Data' => $self->{'_reporttype'} } ); } elsif (/The best( related| unrelated)? scores are:/) { my $rel = $1; my @labels = split; @labels = map { if ( $_ =~ m/^E\((\d+)\)$/o ) { $self->element( { 'Name' => 'Statistics_eff-space', 'Data' => $1 } ); "evalue"; } else { # canonicalize changed column headers if ($_ eq "gapl") { $_ = "lgaps"; } elsif ($_ eq "gapq") { $_ = "qgaps"; } elsif ($_ eq "E2()") { $_ = "evalue2"; } $_; } } @labels[ $rel ? 5 : 4 .. $#labels ]; while ( defined( $_ = $self->_readline() ) && !/^\s+$/ ) { my @line = split; if ( $line[-1] =~ m/\=/o && $labels[-1] ne 'aln_code' ) { # unlabelled alignment hit; push @labels, "aln_code"; } if ($line[0] eq "+-") { $m9HSP = 1; # parse HSP, add to last parsed Hit my %hspData; my @line = split; @hspData{@labels} = splice( @line, @line - @labels ); $hspData{lframe} = $hit_signifs[-1]->{lframe}; push @{$hit_signifs[-1]->{HSPs}}, \%hspData; next; } elsif ($line[0] eq '>>><<<') { last; } my (%data, %hspData); @data{@labels} = @hspData{@labels} = splice( @line, @line - @labels ); if ( $line[-1] =~ m/\[([1-6rf])\]/o ) { my $fr = $1; $hspData{lframe} = $data{lframe} = ( $fr =~ /\d/o ? ( $fr <= 3 ? "+$fr" : "-@{[$fr-3]}" ) : ( $fr eq 'f' ? '+1' : '-1' ) ); pop @line; } else { $hspData{lframe} = $data{lframe} = '0'; } if ( $line[-1] =~ m/^\(?(\d+)\)$/ ) { $data{hit_len} = $1; pop @line; if ( $line[-1] =~ m/^\($/ ) { pop @line; } } else { $data{hit_len} = 0; } # rebuild the first part of the line, preserving spaces: ($_) = m/^(\S+(?:\s+\S+){$#line})/; my ( $id, $desc ) = split( /\s+/, $_, 2 ); my @pieces = split( /\|/, $id ); my $acc = pop @pieces; $acc =~ s/\.\d+$//; @data{qw(id desc acc)} = ( $id, $desc, $acc ); $data{HSPs} = [ \%hspData ]; push @hit_signifs, \%data; } } elsif ( /^\s*([T]?FAST[XYAF]).+,\s*(\S+)\s*matrix[^\]]+?(xS)?\]\s*ktup:\s*(\d+)/ ) { $self->element( { 'Name' => 'Parameters_matrix', 'Data' => $2 } ); $self->element( { 'Name' => 'Parameters_filter', 'Data' => defined $3 ? 1 : 0, } ); $self->element( { 'Name' => 'Parameters_ktup', 'Data' => $4 } ); $self->{'_reporttype'} = $1 if ( $self->{'_reporttype'} !~ /FAST[PN]/i ); # # get gap-pen line for FASTA33, which is not on the matrix line # # FASTA (3.36 June 2000) function [optimized, BL50 matrix (15:-5)] ktup: 2 # join: 36, opt: 24, gap-pen: -12/ -2, width: 16 # $_ = $self->_readline(); if (/(?:gap\-pen|open\/ext):\s+([\-\+]?\d+)\s*\/\s*([\-\+]?\d+)/) { $self->element( { 'Name' => 'Parameters_gap-open', 'Data' => $1 } ); $self->element( { 'Name' => 'Parameters_gap-ext', 'Data' => $2 } ); } $self->element( { 'Name' => 'FastaOutput_program', 'Data' => $self->{'_reporttype'} } ); } elsif (/^Algorithm:\s+(\S+)\s+.*\s*\(([^)]+)\)\s+(\S+)/) { $self->{'_reporttype'} = $1 if ( $self->{'_reporttype'} !~ /FAST[PN]/i ); } elsif ( /^Parameters:/ ) { # FASTA 35.04/FASTA 36 m/Parameters:\s+(\S+)\s+matrix\s+\([^\)]+\)(xS)?,?\s/; $self->element( { 'Name' => 'Parameters_matrix', 'Data' => $1 } ); $self->element( { 'Name' => 'Parameters_filter', 'Data' => defined $2 ? $2 : 0, } ); if (/ktup:\s(\d+)/) { $self->element( { 'Name' => 'Parameters_ktup', 'Data' => $1 } ); if (/ktup:\s\d+$/) { $_ = $self->_readline(); } } if (/(?:gap\-pen|open\/ext):\s+([\-\+]?\d+)\s*\/\s*([\-\+]?\d+)/) { $self->element( { 'Name' => 'Parameters_gap-open', 'Data' => $1 } ); $self->element( { 'Name' => 'Parameters_gap-ext', 'Data' => $2 } ); } $self->element( { 'Name' => 'FastaOutput_program', 'Data' => $self->{'_reporttype'} } ); } elsif ( /^\s+ktup:\s*(\d+),/ ) { $self->element( { 'Name' => 'Parameters_ktup', 'Data' => $1 } ); } elsif (/^(>--)$/ || /^>>(?!>)(.+?)\s+(?:\((\d+)\s*(aa|nt)\))?$/) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } my $firstHSP = 0; if ($1 ne ">--") { $firstHSP = 1; my ($hit_id, $len, $alphabet) = ($1, $2, $3); if (!$len || !$alphabet) { WRAPPED: while (defined($_ = $self->_readline)) { if (/(.*?)\s+\((\d+)\s*(aa|nt)\)/) { ($len, $alphabet) = ($2, $3); $hit_id .= $1 ? " ".$1 : ''; last WRAPPED; } if (/^>>(?!>)/) { # too far, throw $self->throw("Couldn't find length, bailing"); } } } if ( $self->in_element('hit') ) { $self->end_element( { 'Name' => 'Hit' } ); shift @hit_signifs if @hit_signifs; } $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_len', 'Data' => $len } ); my ( $id, $desc ) = split( /\s+/, $hit_id, 2 ); $self->element( { 'Name' => 'Hit_id', 'Data' => $id } ); #$self->debug("Hit ID is $id\n"); my @pieces = split( /\|/, $id ); my $acc = pop @pieces; $acc =~ s/\.\d+$//; $self->element( { 'Name' => 'Hit_accession', 'Data' => $acc } ); $self->element( { 'Name' => 'Hit_def', 'Data' => $desc } ); } else { # push @{$hit_signifs[0]->{HSPs}}, $current_hsp; } $_ = $self->_readline(); my ( $score, $bits, $e, $e2 ) = /Z-score: \s* (\S+) \s* (?: bits: \s* (\S+) \s+ )? (?: E|expect ) \s* \((?:\d+)?\) :? \s*(\S+) (?: \s* E2 \s* \(\) :? \s*(\S+) )? /ox; $bits = $score unless defined $bits; my ($v); if ($firstHSP && !$m9HSP) { $v = shift @{$hit_signifs[0]->{HSPs}} if (@hit_signifs && @{$hit_signifs[0]->{HSPs}}); $current_hsp = $v; } else { $v = $current_hsp; } if ( defined $v ) { @{$v}{qw(evalue evalue2 bits z-sc)} = ( $e, $e2, $bits, $score ); } if ($firstHSP) { $self->element( { 'Name' => 'Hit_signif', 'Data' => $v ? $v->{evalue} : $e } ); $self->element( { 'Name' => 'Hit_score', 'Data' => $v ? $v->{bits} : $bits } ); } $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => $v ? $v->{'z-sc'} : $score } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => $v ? $v->{evalue} : $e } ); $self->element( { 'Name' => 'Hsp_evalue2', 'Data' => $v && exists($v->{evalue2}) ? $v->{evalue2} : $e2 } ) if (($v && exists($v->{evalue2})) || defined $e2); $self->element( { 'Name' => 'Hsp_bit-score', 'Data' => $v ? $v->{bits} : $bits } ); $_ = $self->_readline(); if (s/global\/.* score:\s*(\d+)\;?//) { $self->element( { 'Name' => 'Hsp_sw-score', 'Data' => $1 } ); } if (s/Smith-Waterman score:\s*(\d+)\;?//) { $self->element( { 'Name' => 'Hsp_sw-score', 'Data' => $1 } ); } if ( / (\d*\.?\d+)\% \s* identity (?:\s* \(\s*(\S+)\% \s* (?:ungapped|similar) \) )? \s* in \s* (\d+) \s+ (?:aa|nt) \s+ overlap \s* \( (\d+) \- (\d+) : (\d+) \- (\d+) \) /x ) { my ( $identper, $gapper, $len, $querystart, $queryend, $hitstart, $hitend ) = ( $1, $2, $3, $4, $5, $6, $7 ); my $ident = sprintf( "%.0f", ( $identper / 100 ) * $len ); my $positive = sprintf( "%.0f", ( $gapper / 100 ) * $len ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => $ident } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => $positive } ); $self->element( { 'Name' => 'Hsp_align-len', 'Data' => $len } ); $self->element( { 'Name' => 'Hsp_query-from', 'Data' => $querystart } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => $queryend } ); $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => $hitstart } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => $hitend } ); } if ($v) { $self->element( { 'Name' => 'Hsp_querygaps', 'Data' => $v->{qgaps} } ) if exists $v->{qgaps}; $self->element( { 'Name' => 'Hsp_hitgaps', 'Data' => $v->{lgaps} } ) if exists $v->{lgaps}; if ( $self->{'_reporttype'} =~ m/^FAST[NXY]$/o ) { if ( 8 == scalar grep { exists $v->{$_} } qw(an0 ax0 pn0 px0 an1 ax1 pn1 px1) ) { if ( $v->{ax0} < $v->{an0} ) { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => "-@{[(($v->{px0} - $v->{ax0}) % 3) + 1]}" } ); } else { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => "+@{[(($v->{an0} - $v->{pn0}) % 3) + 1]}" } ); } if ( $v->{ax1} < $v->{an1} ) { $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => "-@{[(($v->{px1} - $v->{ax1}) % 3) + 1]}" } ); } else { $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => "+@{[(($v->{an1} - $v->{pn1}) % 3) + 1]}" } ); } } else { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => $v->{lframe} } ); $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => 0 } ); } } else { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => $v->{lframe} } ); } } else { $self->warn("unable to parse FASTA score line: $_"); } } elsif (/\d+\s*residues\s*in\s*\d+\s*query\s*sequences/) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } if ( $self->in_element('hit') ) { $self->end_element( { 'Name' => 'Hit' } ); shift @hit_signifs if @hit_signifs; } # $_ = $self->_readline(); # my ( $liblen,$libsize) = /(\d+)\s+residues\s*in(\d+)\s*library/; # fast forward to the end of the file as there is # nothing else left to do with this file and want to be sure and # reset it while ( defined( $_ = $self->_readline() ) ) { last if (/^Function used was/); if ( /(\S+)\s+searches\s+a\s+(protein\s+or\s+DNA\s+)? sequence/oxi || /(\S+)\s+compares\s+a/oi ) { $self->_pushback($_); } } $self->_processHits(@hit_signifs) if @hit_signifs; $self->end_element( { 'Name' => 'FastaOutput' } ); return $self->end_document(); } elsif (/^\s*\d+\s*>>>/) { if ( $self->within_element('FastaOutput') ) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } if ( $self->in_element('hit') ) { $self->end_element( { 'Name' => 'Hit' } ); shift @hit_signifs if @hit_signifs; } $self->_processHits(@hit_signifs) if (@hit_signifs); $self->end_element( { 'Name' => 'FastaOutput' } ); $self->_pushback($_); return $self->end_document(); } else { $self->start_element( { 'Name' => 'FastaOutput' } ); $self->{'_result_count'}++; $seentop = 1; $self->element( { 'Name' => 'FastaOutput_program', 'Data' => $self->{'_reporttype'} } ); $self->element( { 'Name' => 'FastaOutput_version', 'Data' => $self->{'_version'} } ); my ( $type, $querylen, $querytype, $querydef ); if (/^\s*\d+\s*>>>(.*)/) { $querydef = $1; if ( $querydef =~ /^(.*?)\s+(?:\-\s+)?(\d+)\s+(aa|nt).*$/o ) { ( $querydef, $querylen, $querytype ) = ( $1, $2, $3 ); } } if ( $self->{'_reporttype'} && $self->{'_reporttype'} eq 'FASTA' ) { if ( $querytype eq 'nt' ) { $self->{'_reporttype'} = 'FASTN'; } elsif ( $querytype eq 'aa' ) { $self->{'_reporttype'} = 'FASTP'; } } my ( $name, $descr ) = ( $querydef =~ m/^(\S+)(?:\s+(.*))?\s*$/o ); $self->element( { 'Name' => 'FastaOutput_query-def', 'Data' => $name } ); $self->element( { 'Name' => 'FastaOutput_querydesc', 'Data' => $descr } ); if ($querylen) { $self->element( { 'Name' => 'FastaOutput_query-len', 'Data' => $querylen } ); } else { $self->warn("unable to find and set query length"); } if ( defined( $_ = $self->_readline() ) && ( /^\s*vs\s+(\S+)/ || /^Library:\s+(\S+)/ ) ) { $self->element( { 'Name' => 'FastaOutput_db', 'Data' => $1 } ); } } } elsif ( $self->in_element('hsp') ) { my @data = ( [], [], [] ); my $count = 0; my $len = $self->idlength + 1; my ($seq1_id); while ( defined($_) ) { chomp; #$self->debug("$count $_\n"); if (/residues in \d+\s+query\s+sequences/o) { $self->_pushback($_); last; } elsif (/^>>>\*\*\*/o) { $self->end_element( { Name => "Hsp" } ); last; } elsif (/^>>/o) { $self->_pushback($_); last; } elsif (/^\s*\d+\s*>>>/o) { $self->_pushback($_); last; } if ( $count == 0 ) { if (/^(\S+)\s+/) { $self->_pushback($_); $count = 2; } elsif ( /^\s+\d+/ || /^\s+$/ ) { # do nothing, this is really a 0 line } elsif ( length($_) == 0 ) { $count = -1; } else { $self->_pushback($_); $count = 0; } } elsif ( $count == 1 || $count == 3 ) { if (/^(\S+)\s+/) { $len = CORE::length($1) if $len < CORE::length($1); s/\s+$//; # trim trailing spaces,we don't want them push @{ $data[ $count - 1 ] }, substr( $_, $len ); } elsif (/^\s+(\d+)/) { $count = -1; $self->_pushback($_); } elsif ( /^\s+$/ || length($_) == 0 ) { $count = 5; # going to skip these } elsif ( /\s+\S+fasta3\d\s+/) { # this is something that looks like a path but contains # the fasta3x executable string, such as: # /usr/local/fasta3/bin/fasta35 -n -U -Q -H -A -E 2.0 -C 19 -m 0 -m 9i test.fa ../other_mirs.fa -O test.fasta35 last; } else { $self->throw( "Unrecognized alignment line ($count) '$_'"); } } elsif ( $count == 2 ) { if (/^\s+\d+\s+/) { $self->warn("$_\n") if $self->verbose > 0; # we are on a Subject part of the alignment # but we THOUGHT we were on the Query # move that last line to the proper place push @{ $data[2] }, pop @{ $data[0] }; $count = 4; } else { # toss the first IDLENGTH characters of the line if ( length($_) >= $len ) { push @{ $data[ $count - 1 ] }, substr( $_, $len ); } } } last if ( $count++ >= 5 ); $_ = $self->_readline(); } if ( @{ $data[0] } || @{ $data[2] } ) { $self->characters( { 'Name' => 'Hsp_qseq', 'Data' => join( '', @{ $data[0] } ) } ); $self->characters( { 'Name' => 'Hsp_midline', 'Data' => join( '', @{ $data[1] } ) } ); $self->characters( { 'Name' => 'Hsp_hseq', 'Data' => join( '', @{ $data[2] } ) } ); } } else { if ( !$seentop ) { $self->debug($_); #$self->warn("unrecognized FASTA Family report file!"); #return; } } } if ( $self->in_element('result') ) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } if ( $self->in_element('hit') ) { $self->end_element( { 'Name' => 'Hit' } ); shift @hit_signifs if @hit_signifs; } $self->end_element( { 'Name' => 'FastaOutput' } ); } return $self->end_document(); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if ( my $type = $MODEMAP{$nm} ) { $self->_mode($type); if ( my $handler = $self->_will_handle($type) ) { my $func = sprintf( "start_%s", lc $type ); $handler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( $nm eq 'FastaOutput' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_mode'} = ''; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $rc; # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if ( $nm eq 'Hsp' ) { foreach (qw(Hsp_qseq Hsp_midline Hsp_hseq)) { $self->element( { 'Name' => $_, 'Data' => $self->{'_last_hspdata'}->{$_} } ); } $self->{'_last_hspdata'} = {}; } if ( my $type = $MODEMAP{$nm} ) { if ( my $handler = $self->_will_handle($type) ) { my $func = sprintf( "end_%s", lc $type ); $rc = $handler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { $self->warn("unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( $nm eq 'FastaOutput' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; return unless ( defined $data->{'Data'} ); if ( $data->{'Data'} =~ /^\s+$/ ) { return unless $data->{'Name'} =~ /Hsp\_(midline|qseq|hseq)/; } if ( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/ ) { $self->{'_last_hspdata'}->{ $data->{'Name'} } .= $data->{'Data'}; } $self->{'_last_data'} = $data->{'Data'}; } =head2 _mode Title : _mode Usage : $obj->_mode($newval) Function: Example : Returns : value of _mode Args : newvalue (optional) =cut sub _mode { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_mode'} = $value; } return $self->{'_mode'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if (!defined $name && !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { if ( $_ eq $name || $_ eq $MODEMAP{$name} ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name || ( exists $MODEMAP{$name} && $self->{'_elements'}->[0] eq $MODEMAP{$name} ) ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handles a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_mode'} = ''; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ( $self, @args ) = @_; return $self->{'_result'}; } =head2 idlength Title : idlength Usage : $obj->idlength($newval) Function: Internal storage of the length of the ID desc in the HSP alignment blocks. Defaults to $IDLENGTH class variable value Returns : value of idlength Args : newvalue (optional) =cut sub idlength { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_idlength'} = $value; } return $self->{'_idlength'} || $IDLENGTH; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } sub attach_EventHandler { my ( $self, $handler ) = @_; $self->SUPER::attach_EventHandler($handler); # Optimization: caching the EventHandler since it is used a lot # during the parse. $self->{'_handler_cache'} = $handler; return; } =head2 _will_handle Title : _will_handle Usage : Private method. For internal use only. if( $self->_will_handle($type) ) { ... } Function: Provides an optimized way to check whether or not an element of a given type is to be handled. Returns : Reference to EventHandler object if the element type is to be handled. undef if the element type is not to be handled. Args : string containing type of element. Optimizations: =over 2 =item 1 Using the cached pointer to the EventHandler to minimize repeated lookups. =item 2 Caching the will_handle status for each type that is encountered so that it only need be checked by calling handler-Ewill_handle($type) once. =back This does not lead to a major savings by itself (only 5-10%). In combination with other optimizations, or for large parse jobs, the savings good be significant. To test against the unoptimized version, remove the parentheses from around the third term in the ternary " ? : " operator and add two calls to $self-E_eventHandler(). =cut sub _will_handle { my ( $self, $type ) = @_; my $handler = $self->{'_handler_cache'}; my $will_handle = defined( $self->{'_will_handle_cache'}->{$type} ) ? $self->{'_will_handle_cache'}->{$type} : ( $self->{'_will_handle_cache'}->{$type} = $handler->will_handle($type) ); return $will_handle ? $handler : undef; } =head2 _processHits Title : _processHits Usage : Private method. For internal use only. Function: Process/report any hits/hsps we saw in the top table, not in alignments. Returns : nothing. Args : array of hits to process. =cut sub _processHits { my ($self, @hit_signifs) = @_; # process remaining best hits for my $hit (@hit_signifs) { # Hsp_score Hsp_evalue Hsp_bit-score # Hsp_sw-score Hsp_gaps Hsp_identity Hsp_positive # Hsp_align-len Hsp_query-from Hsp_query-to # Hsp_hit-from Hsp_hit-to Hsp_qseq Hsp_midline $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_len', 'Data' => $hit->{hit_len} } ) if exists $hit->{hit_len}; $self->element( { 'Name' => 'Hit_id', 'Data' => $hit->{id} } ) if exists $hit->{id}; $self->element( { 'Name' => 'Hit_accession', 'Data' => $hit->{acc} } ) if exists $hit->{acc}; $self->element( { 'Name' => 'Hit_def', 'Data' => $hit->{desc} } ) if exists $hit->{desc}; $self->element( { 'Name' => 'Hit_signif', 'Data' => $hit->{evalue} } ) if exists $hit->{evalue}; $self->element( { 'Name' => 'Hit_score', 'Data' => $hit->{bits} } ) if exists $hit->{bits}; for my $hsp (@{$hit->{HSPs}}) { $self->start_element( { 'Name' => 'Hsp' } ); $self->element({'Name' => 'Hsp_score', 'Data' => $hsp->{'z-sc'}}) if exists $hsp->{'z-sc'}; $self->element({'Name' => 'Hsp_evalue', 'Data' => $hsp->{evalue} } ) if exists $hsp->{evalue}; $self->element({'Name' => 'Hsp_evalue2', 'Data' => $hsp->{evalue2} } ) if exists $hsp->{evalue2}; $self->element({'Name' => 'Hsp_bit-score', 'Data' => $hsp->{bits} } ) if exists $hsp->{bits}; $self->element({'Name' => 'Hsp_sw-score', 'Data' => $hsp->{'n-w'} } ) if exists $hsp->{'n-w'}; $self->element({'Name' => 'Hsp_sw-score', 'Data' => $hsp->{sw} } ) if exists $hsp->{sw}; $self->element({'Name' => 'Hsp_gaps', 'Data' => $hsp->{'%_gid'} } ) if exists $hsp->{'%_gid'}; $self->element({ 'Name' => 'Hsp_identity', 'Data' => sprintf( "%.0f", $hsp->{'%_id'} * $hsp->{alen} ) }) if ( exists $hsp->{'%_id'} && exists $hsp->{alen} ); if ( exists $hsp->{'%_gid'} ) { $self->element( { 'Name' => 'Hsp_positive', 'Data' => sprintf( "%.0f", $hsp->{'%_gid'} * $hsp->{alen} ) } ) if exists $hsp->{'%_gid'} && exists $hsp->{alen}; } else { $self->element( { 'Name' => 'Hsp_positive', 'Data' => sprintf( "%.0f", $hsp->{'%_id'} * $hsp->{alen} ) } ) if ( exists $hsp->{'%_id'} && exists $hsp->{alen} ); } $self->element( { 'Name' => 'Hsp_align-len', 'Data' => $hsp->{alen} } ) if exists $hsp->{alen}; $self->element( { 'Name' => 'Hsp_query-from', 'Data' => $hsp->{an0} } ) if exists $hsp->{an0}; $self->element( { 'Name' => 'Hsp_query-to', 'Data' => $hsp->{ax0} } ) if exists $hsp->{ax0}; $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => $hsp->{an1} } ) if exists $hsp->{an1}; $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => $hsp->{ax1} } ) if exists $hsp->{ax1}; $self->element( { 'Name' => 'Hsp_querygaps', 'Data' => $hsp->{qgaps} } ) if exists $hsp->{qgaps}; $self->element( { 'Name' => 'Hsp_hitgaps', 'Data' => $hsp->{lgaps} } ) if exists $hsp->{lgaps}; if ( $self->{'_reporttype'} =~ m/^FAST[NXY]$/o ) { if ( 8 == scalar grep { exists $hsp->{$_} } qw(an0 ax0 pn0 px0 an1 ax1 pn1 px1) ) { if ( $hsp->{ax0} < $hsp->{an0} ) { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => "-@{[(($hsp->{px0} - $hsp->{ax0}) % 3) + 1]}" } ); } else { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => "+@{[(($hsp->{an0} - $hsp->{pn0}) % 3) + 1]}" } ); } if ( $hsp->{ax1} < $hsp->{an1} ) { $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => "-@{[(($hsp->{px1} - $hsp->{ax1}) % 3) + 1]}" } ); } else { $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => "+@{[(($hsp->{an1} - $hsp->{pn1}) % 3) + 1]}" } ); } } else { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => $hsp->{lframe} } ); $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => 0 } ); } } else { $self->element( { 'Name' => 'Hsp_query-frame', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_hit-frame', 'Data' => $hsp->{lframe} } ); } $self->end_element( { 'Name' => 'Hsp' } ); } $self->end_element( { 'Name' => 'Hit' } ); } } 1; BioPerl-1.6.923/Bio/SearchIO/FastHitEventBuilder.pm000444000765000024 1757512254227314 22054 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::FastHitEventBuilder # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::FastHitEventBuilder - Event Handler for SearchIO events. =head1 SYNOPSIS # Do not use this object directly, this object is part of the SearchIO # event based parsing system. # to use the FastHitEventBuilder do this use Bio::SearchIO::FastHitEventBuilder; my $searchio = Bio::SearchIO->new(-format => $format, -file => $file); $searchio->attach_EventHandler(Bio::SearchIO::FastHitEventBuilder->new()); while( my $r = $searchio->next_result ) { while( my $h = $r->next_hit ) { # note that Hits will NOT have HSPs } } =head1 DESCRIPTION This object handles Search Events generated by the SearchIO classes and build appropriate Bio::Search::* objects from them. This object is intended for lightweight parsers which only want Hits and not deal with the overhead of HSPs. It is a lot faster than the standard parser event handler but of course you are getting less information and less objects out. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::FastHitEventBuilder; use vars qw(%KNOWNEVENTS); use strict; use Bio::Search::HSP::HSPFactory; use Bio::Search::Hit::HitFactory; use Bio::Search::Result::ResultFactory; use base qw(Bio::Root::Root Bio::SearchIO::EventHandlerI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::FastHitEventBuilder->new(); Function: Builds a new Bio::SearchIO::FastHitEventBuilder object Returns : Bio::SearchIO::FastHitEventBuilder Args : -hit_factory => Bio::Factory::ObjectFactoryI -result_factory => Bio::Factory::ObjectFactoryI See L for more information =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hitF,$resultF) = $self->_rearrange([qw(HIT_FACTORY RESULT_FACTORY)],@args); $self->register_factory('hit', $hitF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::GenericHit', -interface => 'Bio::Search::Hit::HitI')); $self->register_factory('result', $resultF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::GenericResult', -interface => 'Bio::Search::Result::ResultI')); return $self; } # new comes from the superclass =head2 will_handle Title : will_handle Usage : if( $handler->will_handle($event_type) ) { ... } Function: Tests if this event builder knows how to process a specific event Returns : boolean Args : event type name =cut sub will_handle{ my ($self,$type) = @_; # these are the events we recognize return ( $type eq 'hit' || $type eq 'result' ); } =head2 SAX methods =cut =head2 start_result Title : start_result Usage : $handler->start_result($resulttype) Function: Begins a result event cycle Returns : none Args : Type of Report =cut sub start_result { my ($self,$type) = @_; $self->{'_resulttype'} = $type; $self->{'_hits'} = []; return; } =head2 end_result Title : end_result Usage : my @results = $parser->end_result Function: Finishes a result handler cycle Returns : A Bio::Search::Result::ResultI Args : none =cut sub end_result { my ($self,$type,$data) = @_; if( defined $data->{'runid'} && $data->{'runid'} !~ /^\s+$/ ) { if( $data->{'runid'} !~ /^lcl\|/) { $data->{"RESULT-query_name"}= $data->{'runid'}; } else { ($data->{"RESULT-query_name"},$data->{"RESULT-query_description"}) = split(/\s+/,$data->{"RESULT-query_description"},2); } if( my @a = split(/\|/,$data->{'RESULT-query_name'}) ) { my $acc = pop @a ; # this is for accession |1234|gb|AAABB1.1|AAABB1 # this is for |123|gb|ABC1.1| $acc = pop @a if( ! defined $acc || $acc =~ /^\s+$/); $data->{"RESULT-query_accession"}= $acc; } delete $data->{'runid'}; } my %args = map { my $v = $data->{$_}; s/RESULT//; ($_ => $v); } grep { /^RESULT/ } keys %{$data}; $args{'-algorithm'} = uc( $args{'-algorithm_name'} || $type); $args{'-hits'} = $self->{'_hits'}; my $result = $self->factory('result')->create(%args); $self->{'_hits'} = []; return $result; } =head2 start_hit Title : start_hit Usage : $handler->start_hit() Function: Starts a Hit event cycle Returns : none Args : type of event and associated hashref =cut sub start_hit{ my ($self,$type) = @_; return; } =head2 end_hit Title : end_hit Usage : $handler->end_hit() Function: Ends a Hit event cycle Returns : Bio::Search::Hit::HitI object Args : type of event and associated hashref =cut sub end_hit{ my ($self,$type,$data) = @_; my %args = map { my $v = $data->{$_}; s/HIT//; ($_ => $v); } grep { /^HIT/ } keys %{$data}; $args{'-algorithm'} = uc( $args{'-algorithm_name'} || $type); $args{'-query_len'} = $data->{'RESULT-query_length'}; my ($hitrank) = scalar @{$self->{'_hits'}} + 1; $args{'-rank'} = $hitrank; my $hit = $self->factory('hit')->create(%args); push @{$self->{'_hits'}}, $hit; $self->{'_hsps'} = []; return $hit; } =head2 Factory methods =cut =head2 register_factory Title : register_factory Usage : $handler->register_factory('TYPE',$factory); Function: Register a specific factory for a object type class Returns : none Args : string representing the class and Bio::Factory::ObjectFactoryI See L for more information =cut sub register_factory{ my ($self, $type,$f) = @_; if( ! defined $f || ! ref($f) || ! $f->isa('Bio::Factory::ObjectFactoryI') ) { $self->throw("Cannot set factory to value $f".ref($f)."\n"); } $self->{'_factories'}->{lc($type)} = $f; } =head2 factory Title : factory Usage : my $f = $handler->factory('TYPE'); Function: Retrieves the associated factory for requested 'TYPE' Returns : a Bio::Factory::ObjectFactoryI or undef if none registered Args : name of factory class to retrieve See L for more information =cut sub factory{ my ($self,$type) = @_; return $self->{'_factories'}->{lc($type)} || $self->throw("No factory registered for $type"); } =head2 inclusion_threshold See L. =cut sub inclusion_threshold { my $self = shift; return $self->{'_inclusion_threshold'} = shift if @_; return $self->{'_inclusion_threshold'}; } 1; BioPerl-1.6.923/Bio/SearchIO/gmap_f9.pm000444000765000024 2772312254227340 17516 0ustar00cjfieldsstaff000000000000# $Id: gmap_f9.pm 15987 2009-08-18 21:08:55Z lstein $ # # BioPerl module for Bio::SearchIO::gmap_f9 # # Cared for by George Hartzell # # Copyright George Hartzell # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::gmap_f9 - Event generator for parsing gmap reports (Z format) =head1 SYNOPSIS # Do not use this object directly - it is used as part of the # Bio::SearchIO system. use Bio::SearchIO; my $searchio = Bio::SearchIO->new(-format => 'gmap', -file => 't/data/her2.gmapz'); while( my $result = $searchio->next_result ) { while( my $hit = $result->next_hit ) { while( my $hsp = $hit->next_hsp ) { # ... } } } =head1 DESCRIPTION This object encapsulated the necessary methods for generating events suitable for building Bio::Search objects from a GMAP "compressed" report (from gmap run with -Z flag) Read the L for more information about how to use this. =head2 REVERSE STRAND AND BIOPERL COORDINATES I believe that I'm doing the correct thing when reporting hits on the negative strand of the genome. In particular, I've compared the "exons" this code generates with the set returned by ncbi's megablast web service. NCBI's hsp's are ordered differently and have a different genomic location (off by ~18,000,000 bases, padding?) but the starts, ends, and lengths were similar and my strand handling matches theirs. E.g. CDNA GENOME start end strand start end strand blast 1913 2989 1 86236731 86237808 -1 1 475 1 86260509 86260983 -1 1510 1727 1 86240259 86240476 -1 841 989 1 86243034 86243182 -1 1381 1514 1 86240630 86240763 -1 989 1122 1 86242457 86242590 -1 599 729 1 86247470 86247600 -1 473 608 1 86259972 86260107 -1 1255 1382 1 86240837 86240964 -1 730 842 1 86244040 86244152 -1 1813 1921 1 86238123 86238231 -1 1725 1814 1 86239747 86239836 -1 1167 1256 1 86241294 86241383 -1 1120 1188 1 86242319 86242387 -1 gmap 1 475 1 104330509 104330983 -1 476 600 1 104329980 104330104 -1 601 729 1 104317470 104317598 -1 730 841 1 104314041 104314152 -1 842 989 1 104313034 104313181 -1 990 1121 1 104312458 104312589 -1 1122 1187 1 104312320 104312385 -1 1188 1256 1 104311294 104311362 -1 1257 1382 1 104310837 104310962 -1 1383 1511 1 104310633 104310761 -1 1512 1726 1 104310260 104310474 -1 1727 1814 1 104309747 104309834 -1 1815 1917 1 104308127 104308229 -1 1918 2989 1 104306731 104307802 -1 =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - George Hartzell Email hartzell@alerce.com =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with an underscore (_). =cut # Let the code begin... package Bio::SearchIO::gmap_f9; use strict; use warnings; use Bio::Search::Hit::GenericHit; use Bio::Search::HSP::GenericHSP; use base qw(Bio::SearchIO ); use Data::Dumper; =head2 next_result Title : next_result Usage : $result = stream->next_result Function: Reads the next ResultI object from the stream and returns it. Returns : A Bio::Search::Result::ResultI object Args : n/a =cut sub next_result { my $self = shift; my $info = []; my $result; my $hit; my @hsp_info; my $previous_hit_pos; while ( $_ = $self->_readline ) { if ( $_ =~ /^>/ ) { # looking at the start of a result if ($result) { # and done if there's one in progress $self->_pushback($_); goto DONE; } else { # otherwise start a new one. my ($id, $desc, $md5) = m|>([^ ]*)\s*(.*)\s*(?:md5:(.*))?|; $result = Bio::Search::Result::GenericResult->new(); $result->algorithm('gmap'); $result->query_name($id); $result->query_accession($id); $result->query_description($desc); #$self->warn("Take care of MD5!\n"); $hit ||= Bio::Search::Hit::GenericHit->new( -name => "NONE_SPECIFIED"); } } else { # add another position to the hit/hsp # 468 H 1956 C -14:104307764 2298317517 C H # 468 1957 A -14:104307763 2298317516 A my $c; # info about a column ($c->{query_aa_pos}, $c->{query_aa}, $c->{query_pos}, $c->{query_base}, $c->{hit_strand}, $c->{hit_chromo}, $c->{hit_pos}, $c->{hit_concat_pos}, $c->{hit_base}, $c->{hit_aa}) = ($_ =~ m| (\d+)[ ]?(.)?[\t] (\d+)[ ]?(.)?[\t] # TODO chromosome isn't a number... X, Y, MT.... (\+\|\-)([\dxXyY]+\|MT):(\d+)[ ](\d+)[ ](.) [\t]?(.)? |xo ); if ($previous_hit_pos && (abs($c->{hit_pos} - $previous_hit_pos) > 1)) { $hit ||= Bio::Search::Hit::GenericHit->new( -name => "NONE_SPECIFIED", ); $hit->add_hsp( $self->_hsp_from_info(\@hsp_info) ); @hsp_info = (); } push @hsp_info, $c; $previous_hit_pos = $c->{hit_pos}; } } DONE: if ($result) { $hit->add_hsp( $self->_hsp_from_info(\@hsp_info) ) if (@hsp_info); my ($hit_length,$query_length); for my $hsp ($hit->hsps) { $hit_length += $hsp->length(); $query_length += $hsp->length('query'); } $hit->length($hit_length); $hit->query_length($query_length); # update this now that we actually know something useful.q $hit->name($hsp_info[0]->{hit_chromo}); $result->add_hit($hit) if ($hit); } return($result); } sub _hsp_from_info { my $self = shift; my $info = shift; my $a = {}; # args w/ which we'll create hsp my $hsp; my $identical; $a->{-algorithm} = 'GMAP'; for my $c (@{$info}) { $a->{-query_seq} .= $c->{query_base}; $a->{-hit_seq} .= $c->{hit_base}; $a->{-homology_seq} .= $c->{query_base} eq $c->{hit_base} ? $c->{hit_base} : ' '; $identical++ if ( $c->{query_base} eq $c->{hit_base} ); } $a->{-query_seq} =~ s| |\-|g; # switch to bioperl gaps. $a->{-hit_seq} =~ s| |\-|g; $a->{-conserved} = $a->{-identical} = $identical; # use the coordinates from from gmap's -f 9 output to # determine whether gmap revcomped the query sequence # to generate the alignment. Note that this is not # the same as the cDNA's sense/anti-sense-ness. $a->{-stranded} = 'both'; $a->{-query_start} = $info->[0]->{query_pos}; $a->{-query_end} = $info->[-1]->{query_pos}; $a->{-query_length} = $a->{-query_end} - $a->{-query_start} + 1; # hit can be either strand, -f 9 output tells us which. # we don't have to worry about it here, but telling the generichsp code # that this hit is 'stranded', it compares the start and end positions # sets it for us. $a->{-hit_start} = $info->[0]->{hit_pos}; $a->{-hit_end} = $info->[-1]->{hit_pos}; $a->{-hit_length} = abs($a->{-hit_end} - $a->{-hit_start}) + 1; $a->{-hsp_length} = $a->{-query_length} > $a->{-hit_length} ? $a->{-query_length} : $a->{-hit_length}; $hsp = Bio::Search::HSP::GenericHSP->new( %$a ); return $hsp; } # TODO (adjust regexp to swallow lines w/out md5 sig's. sub _parse_path_header { my $self = shift; my $path_line = shift; my $path = {}; ( $path->{query}, $path->{db}, $path->{path_num}, $path->{path_total_num}, $path->{query_length}, $path->{exon_count}, $path->{trimmed_coverage}, $path->{percent_identity}, $path->{query_start}, $path->{query_end}, $path->{whole_genome_start}, $path->{whole_genome_end}, $path->{chromosome}, $path->{chromo_start}, $path->{chromo_end}, $path->{strand}, $path->{sense}, $path->{md5}, ) = ($_ =~ qr| > ([^ ]*)[ ] # the query id}, followed by a space ([^ ]*)[ ] # the genome database, followed by a space (\d+)/(\d+)[ ] # path_num/path_total_num (e.g. 3/12) (\d+)[ ] # query length, followed by a space (\d+)[ ] # hsp/exon count, followed by a space (\d+\.\d*)[ ] # trimmed coverage (\d+\.\d*)[ ] # percent identity (\d+)\.\.(\d+)[ ] # query start .. query end, followed by space (\d+)\.\.(\d+)[ ] # whole genome s..e, followed by space (\d+): # chromosome number (\d+)\.\.(\d+)[ ] # chromo s..e, followed by a space ([+-])[ ] # strand, followed by a space dir:(.*) # dir:sense or dir:antisense [ ]md5:([\dabcdefg]+) # md5 signature |x ); $path->{query} or $self->throw("query was not found in path line."); $path->{db} or $self->throw("db was not found in path line."); $path->{path_num} or $self->throw("path_num was not found in path line."); $path->{path_total_num} or $self->throw("path_total_num was not found in path line."); $path->{query_length} or $self->throw("query_length was not found in path line."); $path->{exon_count} or $self->throw("exon_count was not found in path line."); $path->{trimmed_coverage} or $self->throw("trimmed_coverage was not found in path line."); $path->{percent_identity} or $self->throw("percent_identity was not found in path line."); $path->{query_start} or $self->throw("query_start was not found in path line."); $path->{query_end} or $self->throw("query_end was not found in path line."); $path->{whole_genome_start} or $self->throw("whole_genome_start was not found in path line."); $path->{whole_genome_end} or $self->throw("whole_genome_end was not found in path line."); $path->{chromosome} or $self->throw("chromosome was not found in path line."); $path->{chromo_start} or $self->throw("chromo_start was not found in path line."); $path->{chromo_end} or $self->throw("chromo_end was not found in path line."); $path->{strand} or $self->throw("strand was not found in path line."); $path->{sense} or $self->throw("sense was not found in path line."); return $path; } sub _parse_alignment_line { my $self = shift; my $a_line = shift; my $align = {}; ( $align->{chromo_start}, $align->{chromo_end}, $align->{query_start}, $align->{query_end}, $align->{percent_identity}, $align->{align_length}, $align->{intron_length}, ) = ($_ =~ qr| [\t] ([\d]+)[ ] # start in chromosome coord. ([\d]+)[ ] # end in chromosome coord. ([\d]+)[ ] # start in query coord. ([\d]+)[ ] # end in query coord. ([\d]+) # percent identity (as integer) [\t].*[\t] # skip the edit script ([\d]+) # length of alignment block. [\t]*([\d]+)* # length of following intron. |x ); $align->{chromo_start} or $self->throw("chromo_start missing in alignment line."); $align->{chromo_end}, or $self->throw("chromo_end was missing in alignment line."); $align->{query_start}, or $self->throw("query_start was missing in alignment line."); $align->{query_end}, or $self->throw("query_end was missing in alignment line."); $align->{percent_identity}, or $self->throw("percent_identity was missing in alignment line."); $align->{align_length}, or $self->throw("align_length was missing in alignment line."); return $align; } 1; BioPerl-1.6.923/Bio/SearchIO/hmmer.pm000444000765000024 1002712254227321 17270 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::hmmer # # Please direct questions and support issues to # # Cared for by Kai Blin # # Copyright Kai Blin # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::hmmer - A parser for HMMER2 and HMMER3 output (hmmscan, hmmsearch, hmmpfam) =head1 SYNOPSIS # do not use this class directly it is available through Bio::SearchIO use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer', -file => 't/data/L77119.hmmer'); while( my $result = $in->next_result ) { # this is a Bio::Search::Result::HMMERResult object print $result->query_name(), " for HMM ", $result->hmm_name(), "\n"; while( my $hit = $result->next_hit ) { print $hit->name(), "\n"; while( my $hsp = $hit->next_hsp ) { print "length is ", $hsp->length(), "\n"; } } } =head1 DESCRIPTION This object implements a parser for HMMER output. It works with both HMMER2 and HMMER3 =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kai Blin Email kai.blin-at-biotech.uni-tuebingen.de =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::hmmer; use strict; use Bio::Factory::ObjectFactory; use base qw(Bio::SearchIO); sub new { my ( $caller, @args ) = @_; my $class = ref($caller) || $caller; my $self = $class->SUPER::new(@args); $self->_initialize(@args); # Try to guess the hmmer format version if it's not specified. my $version; my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys # If the caller specified a version, go for that if (defined($param{"-version"})) { $version = $param{"-version"}; } else { # read second line of the file my $first_line = $self->_readline; $_ = $self->_readline; if ( m/HMMER\s3/ ) { $version = "3"; } else { $version = "2"; } $self->_pushback($_); $self->_pushback($first_line); } my $format = "hmmer$version"; return unless( $class->_load_format_module($format) ); bless($self, "Bio::SearchIO::$format"); return $self; } sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my $handler = $self->_eventHandler; $handler->register_factory( 'result', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::HMMERResult', -interface => 'Bio::Search::Result::ResultI' ) ); $handler->register_factory( 'hit', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::HMMERHit', -interface => 'Bio::Search::Hit::HitI' ) ); $handler->register_factory( 'hsp', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::HMMERHSP', -interface => 'Bio::Search::HSP::HSPI' ) ); } 1; BioPerl-1.6.923/Bio/SearchIO/hmmer2.pm000444000765000024 13001712254227322 17375 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::hmmer2 # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::hmmer2 - A parser for HMMER output (hmmpfam, hmmsearch) =head1 SYNOPSIS # do not use this class directly it is available through Bio::SearchIO use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer2', -file => 't/data/L77119.hmmer'); while( my $result = $in->next_result ) { # this is a Bio::Search::Result::HMMERResult object print $result->query_name(), " for HMM ", $result->hmm_name(), "\n"; while( my $hit = $result->next_hit ) { print $hit->name(), "\n"; while( my $hsp = $hit->next_hsp ) { print "length is ", $hsp->length(), "\n"; } } } =head1 DESCRIPTION This object implements a parser for HMMER output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::hmmer2; use strict; use Bio::Factory::ObjectFactory; use vars qw(%MAPPING %MODEMAP ); use base qw(Bio::SearchIO::hmmer); BEGIN { # mapping of HMMER items to Bioperl hash keys %MODEMAP = ( 'HMMER_Output' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame' => 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_desc' => 'HIT-description', 'Hit_signif' => 'HIT-significance', 'Hit_score' => 'HIT-score', 'HMMER_program' => 'RESULT-algorithm_name', 'HMMER_version' => 'RESULT-algorithm_version', 'HMMER_query-def' => 'RESULT-query_name', 'HMMER_query-len' => 'RESULT-query_length', 'HMMER_query-acc' => 'RESULT-query_accession', 'HMMER_querydesc' => 'RESULT-query_description', 'HMMER_hmm' => 'RESULT-hmm_name', 'HMMER_seqfile' => 'RESULT-sequence_file', 'HMMER_db' => 'RESULT-database_name', ); } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; my $seentop = 0; my $reporttype; my ( $last, @hitinfo, @hspinfo, %hspinfo, %hitinfo ); local $/ = "\n"; local $_; my $verbose = $self->verbose; # cache for speed? $self->start_document(); local ($_); while ( defined( $_ = $self->_readline ) ) { my $lineorig = $_; chomp; if (/^HMMER\s+(\S+)\s+\((.+)\)/o) { my ( $prog, $version ) = split; if ($seentop) { $self->_pushback($_); $self->end_element( { 'Name' => 'HMMER_Output' } ); return $self->end_document(); } $self->{'_hmmidline'} = $_; $self->start_element( { 'Name' => 'HMMER_Output' } ); $self->{'_result_count'}++; $seentop = 1; if ( defined $last ) { ($reporttype) = split( /\s+/, $last ); $reporttype = uc($reporttype) if defined $reporttype; $self->element( { 'Name' => 'HMMER_program', 'Data' => $reporttype } ); } $self->element( { 'Name' => 'HMMER_version', 'Data' => $version } ); } elsif (s/^HMM file:\s+//o) { $self->{'_hmmfileline'} = $lineorig; $self->element( { 'Name' => 'HMMER_hmm', 'Data' => $_ } ); } elsif (s/^Sequence\s+(file|database):\s+//o) { $self->{'_hmmseqline'} = $lineorig; if ( $1 eq 'database' ) { $self->element( { 'Name' => 'HMMER_db', 'Data' => $_ } ); } $self->element( { 'Name' => 'HMMER_seqfile', 'Data' => $_ } ); } elsif (s/^Query(\s+(sequence|HMM))?(?:\s+\d+)?:\s+//o) { if ( !$seentop ) { # we're in a multi-query report $self->_pushback($lineorig); $self->_pushback( $self->{'_hmmseqline'} ); $self->_pushback( $self->{'_hmmfileline'} ); $self->_pushback( $self->{'_hmmidline'} ); next; } s/\s+$//; $self->element( { 'Name' => 'HMMER_query-def', 'Data' => $_ } ); } elsif (s/^Accession:\s+//o) { s/\s+$//; $self->element( { 'Name' => 'HMMER_query-acc', 'Data' => $_ } ); } elsif (s/^Description:\s+//o) { s/\s+$//; $self->element( { 'Name' => 'HMMER_querydesc', 'Data' => $_ } ); } elsif ( defined $self->{'_reporttype'} && $self->{'_reporttype'} eq 'HMMSEARCH' ) { # PROCESS HMMSEARCH RESULTS HERE if (/^Scores for complete sequences/o) { while ( defined( $_ = $self->_readline ) ) { last if (/^\s+$/); next if ( /^Sequence\s+Description/o || /^\-\-\-/o ); my @line = split; my ( $name, $n, $evalue, $score ) = ( shift @line, pop @line, pop @line, pop @line ); my $desc = join( ' ', @line ); push @hitinfo, [ $name, $desc, $evalue, $score ]; $hitinfo{$name} = $#hitinfo; } } elsif (/^Parsed for domains:/o) { @hspinfo = (); while ( defined( $_ = $self->_readline ) ) { last if (/^\s+$/); if (m!^//!) { $self->_pushback($_); last; } next if ( /^(Model|Sequence)\s+Domain/ || /^\-\-\-/ ); chomp; if ( my ( $n, $domainnum, $domainct, @vals ) = ( m!^(\S+)\s+ # host name (\d+)/(\d+)\s+ # num/num (ie 1 of 2) (\d+)\s+(\d+).+? # sequence start and end (\d+)\s+(\d+)\s+ # hmm start and end \S+\s+ # [] (\S+)\s+ # score (\S+) # evalue \s*$!ox ) ) { # array lookup so that we can get rid of things # when they've been processed my $info = $hitinfo[ $hitinfo{$n} ]; if ( !defined $info ) { $self->warn( "Incomplete Sequence information, can't find $n hitinfo says $hitinfo{$n}" ); next; } push @hspinfo, [ $n, @vals ]; } } } elsif (/^Alignments of top/o) { my ( $prelength, $lastdomain, $count, $width ); $count = 0; my %domaincounter; my $second_tier = 0; while ( defined( $_ = $self->_readline ) ) { next if ( /^Align/o || /^\s+RF\s+[x\s]+$/o ); if ( /^Histogram/o || m!^//!o ) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } if ( $self->within_element('hit') ) { $self->end_element( { 'Name' => 'Hit' } ); } last; } chomp; if ( m/^\s*(.+):\s+domain\s+(\d+)\s+of\s+(\d+)\,\s+ from\s+(\d+)\s+to\s+(\d+)/x ) { my ( $name, $domainct, $domaintotal, $from, $to ) = ( $1, $2, $3, $4, $5 ); $domaincounter{$name}++; if ( $self->within_element('hit') ) { if ( $self->within_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } $self->end_element( { 'Name' => 'Hit' } ); } $self->start_element( { 'Name' => 'Hit' } ); my $info = [ @{ $hitinfo[ $hitinfo{$name} ] || $self->throw( "Could not find hit info for $name: Insure that your database contains only unique sequence names" ) } ]; if ( $info->[0] ne $name ) { $self->throw( "Somehow the Model table order does not match the order in the domains (got " . $info->[0] . ", expected $name)" ); } $self->element( { 'Name' => 'Hit_id', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_desc', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_signif', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_score', 'Data' => shift @{$info} } ); $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); my $HSPinfo = shift @hspinfo; my $id = shift @$HSPinfo; if ( $id ne $name ) { $self->throw( "Somehow the domain list details do not match the table (got $id, expected $name)" ); } if ( $domaincounter{$name} == $domaintotal ) { $hitinfo[ $hitinfo{$name} ] = undef; } $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_query-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => shift @$HSPinfo } ); $lastdomain = $name; } else { # Might want to change this so that it # accumulates all the of the alignment lines into # three array slots and then tests for the # end of the line if (/^(\s+\*\-\>)(\S+)/o) { # start of domain $prelength = CORE::length($1); $width = 0; # deal with fact that start en stop is on same line my $data = $2; if ($data =~ s/\<\-?\*?\s*$//) { $width = CORE::length($data); } $self->element( { 'Name' => 'Hsp_qseq', 'Data' => $data } ); $count = 0; $second_tier = 0; } elsif (/^(\s+)(\S+)\<\-\*\s*$/o) { #end of domain $self->element( { 'Name' => 'Hsp_qseq', 'Data' => $2 } ); $width = CORE::length($2); $count = 0; } elsif (( $count != 1 && /^\s+$/o ) || CORE::length($_) == 0 || /^\s+\-?\*\s*$/ ) { next; } elsif ( $count == 0 ) { $prelength -= 3 unless ( $second_tier++ ); unless ( defined $prelength ) { # $self->warn("prelength not set"); next; } $self->element( { 'Name' => 'Hsp_qseq', 'Data' => substr( $_, $prelength ) } ); } elsif ( $count == 1 ) { if ( !defined $prelength ) { $self->warn("prelength not set"); } if ($width) { $self->element( { 'Name' => 'Hsp_midline', 'Data' => substr( $_, $prelength, $width ) } ); } else { $self->element( { 'Name' => 'Hsp_midline', 'Data' => substr( $_, $prelength ) } ); } } elsif ( $count == 2 ) { if (/^\s+(\S+)\s+(\d+|\-)\s+(\S*)\s+(\d+|\-)/o) { $self->element( { 'Name' => 'Hsp_hseq', 'Data' => $3 } ); } else { $self->warn("unrecognized line: $_\n"); } } $count = 0 if $count++ >= 2; } } } elsif ( /^Histogram/o || m!^//!o ) { while ( my $HSPinfo = shift @hspinfo ) { my $id = shift @$HSPinfo; my $info = [ @{ $hitinfo[ $hitinfo{$id} ] } ]; next unless defined $info; $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_id', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_desc', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_signif', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_score', 'Data' => shift @{$info} } ); $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_query-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); $self->end_element( { 'Name' => 'Hsp' } ); $self->end_element( { 'Name' => 'Hit' } ); } @hitinfo = (); %hitinfo = (); last; } } elsif ( defined $self->{'_reporttype'} && $self->{'_reporttype'} eq 'HMMPFAM' ) { # process HMMPFAM results here if (/^Scores for sequence family/o) { while ( defined( $_ = $self->_readline ) ) { last if (/^\s+$/); next if ( /^Model\s+Description/o || /^\-\-\-/o ); chomp; my @line = split; my ( $model, $n, $evalue, $score ) = ( shift @line, pop @line, pop @line, pop @line ); my $desc = join( ' ', @line ); push @hitinfo, [ $model, $desc, $score, $evalue, $n ]; $hitinfo{$model} = $#hitinfo; } } elsif (/^Parsed for domains:/o) { @hspinfo = (); while ( defined( $_ = $self->_readline ) ) { last if (/^\s+$/); if (m!^//!) { $self->_pushback($_); last; } next if ( /^Model\s+Domain/o || /^\-\-\-/o ); chomp; if ( my ( $n, $domainnum, $domainct, @vals ) = ( m!^(\S+)\s+ # domain name (\d+)/(\d+)\s+ # domain num out of num (\d+)\s+(\d+).+? # seq start, end (\d+)\s+(\d+)\s+ # hmm start, end \S+\s+ # [] (\S+)\s+ # score (\S+) # evalue \s*$!ox ) ) { my $hindex = $hitinfo{$n}; if ( !defined $hindex ) { push @hitinfo, [ $n, '', $vals[5], $vals[6], $domainct ]; $hitinfo{$n} = $#hitinfo; $hindex = $#hitinfo; } my $info = $hitinfo[$hindex]; if ( !defined $info ) { $self->warn( "incomplete Domain information, can't find $n hitinfo says $hitinfo{$n}" ); next; } push @hspinfo, [ $n, @vals ]; } } } elsif (/^Alignments of top/o) { my ( $prelength, $lastdomain, $count, $width ); $count = 0; my $second_tier = 0; while ( defined( $_ = $self->_readline ) ) { next if ( /^Align/o || ( $count != 1 && /^\s+RF\s+[x\s]+$/o ) ); # fix for bug 2632 next if ($_ =~ m/^\s+CS\s+/o && $count == 0); if ( /^Histogram/o || m!^//!o || /^Query sequence/o ) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } if ( $self->in_element('hit') ) { $self->end_element( { 'Name' => 'Hit' } ); } $self->_pushback($_); last; } chomp; if (m/(\S+):.*from\s+(\d+)\s+to\s+(\d+)/o) { my ( $name, $from, $to ) = ( $1, $2, $3 ); if ( $self->within_element('hit') ) { if ( $self->in_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } $self->end_element( { 'Name' => 'Hit' } ); } my $info = [ @{ $hitinfo[ $hitinfo{$name} ] } ]; if ( !defined $info || $info->[0] ne $name ) { $self->warn( "Somehow the Model table order does not match the order in the domains (got " . $info->[0] . ", expected $name). We're back loading this from the alignment information instead" ); $info = [ $name, '', /score\s+([^,\s]+),\s+E\s+=\s+(\S+)/ox ]; push @hitinfo, $info; $hitinfo{$name} = $#hitinfo; } $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_id', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_desc', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_score', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_signif', 'Data' => shift @{$info} } ); $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); my $HSPinfo = shift @hspinfo; my $id = shift @$HSPinfo; if ( $id ne $name ) { $self->throw( "Somehow the domain list details do not match the table (got $id, expected $name)" ); } $self->element( { 'Name' => 'Hsp_query-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => shift @$HSPinfo } ); $lastdomain = $name; } else { if (/^(\s+\*\-\>)(\S+)/o) { # start of domain $prelength = CORE::length($1); $width = 0; # deal with fact that start en stop is on same line my $data = $2; if ($data =~ s/\<\-?\*?\s*$//) { $width = CORE::length($data); } $self->element( { 'Name' => 'Hsp_hseq', 'Data' => $data } ); $count = 0; $second_tier = 0; } elsif (/^(\s+)(\S+)\<\-?\*?\s*$/o) { #end of domain $prelength -= 3 unless ( $second_tier++ ); $self->element( { 'Name' => 'Hsp_hseq', 'Data' => $2 } ); $width = CORE::length($2); $count = 0; } elsif (CORE::length($_) == 0 || ( $count != 1 && /^\s+$/o ) || /^\s+\-?\*\s*$/ || /^\s+\S+\s+\-\s+\-\s*$/ ) { next; } elsif ( $count == 0 ) { $prelength -= 3 unless ( $second_tier++ ); unless ( defined $prelength ) { # $self->warn("prelength not set"); next; } $self->element( { 'Name' => 'Hsp_hseq', 'Data' => substr( $_, $prelength ) } ); } elsif ( $count == 1 ) { if ( !defined $prelength ) { $self->warn("prelength not set"); } if ($width) { $self->element( { 'Name' => 'Hsp_midline', 'Data' => substr( $_, $prelength, $width ) } ); } else { $self->element( { 'Name' => 'Hsp_midline', 'Data' => substr( $_, $prelength ) } ); } } elsif ( $count == 2 ) { if ( /^\s+(\S+)\s+(\d+)\s+(\S+)\s+(\d+)/o || /^\s+(\S+)\s+(\-)\s+(\S*)\s+(\-)/o ) { $self->element( { 'Name' => 'Hsp_qseq', 'Data' => $3 } ); } else { $self->throw( "unrecognized line ($count): $_\n"); } } $count = 0 if $count++ >= 2; } } } elsif ( /^Histogram/o || m!^//!o ) { while ( my $HSPinfo = shift @hspinfo ) { my $id = shift @$HSPinfo; my $info = [ @{ $hitinfo[ $hitinfo{$id} ] } ]; next unless defined $info; $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_id', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_desc', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_signif', 'Data' => shift @{$info} } ); $self->element( { 'Name' => 'Hit_score', 'Data' => shift @{$info} } ); $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_query-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => shift @$HSPinfo } ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); $self->end_element( { 'Name' => 'Hsp' } ); $self->end_element( { 'Name' => 'Hit' } ); } @hitinfo = (); %hitinfo = (); last; } # uncomment to see missed lines with verbose on #else { # $self->debug($_); #} } $last = $_; } $self->end_element( { 'Name' => 'HMMER_Output' } ) unless !$seentop; return $self->end_document(); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "start_%s", lc $type ); $self->_eventHandler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( defined $type && $type eq 'result' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if ( $nm eq 'HMMER_program' ) { if ( $self->{'_last_data'} =~ /(HMM\S+)/i ) { $self->{'_reporttype'} = uc $1; } } # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if ( $nm eq 'Hsp' ) { foreach (qw(Hsp_qseq Hsp_midline Hsp_hseq)) { my $data = $self->{'_last_hspdata'}->{$_}; if ($data && $_ eq 'Hsp_hseq') { # replace hmm '.' gap symbol by '-' $data =~ s/\./-/g; } $self->element( { 'Name' => $_, 'Data' => $data } ); } $self->{'_last_hspdata'} = {}; } if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "end_%s", lc $type ); $rc = $self->_eventHandler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } my $lastelem = shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { $self->debug("unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; if ( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/o && defined $data->{'Data'} ) { $self->{'_last_hspdata'}->{ $data->{'Name'} } .= $data->{'Data'}; } return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/o ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if ( !defined $name || !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { return 1 if ( $_ eq $name ); } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'within' because 'in' only tests its immediete parent. Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ($self) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } 1; BioPerl-1.6.923/Bio/SearchIO/hmmer3.pm000444000765000024 11357512254227317 17414 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::hmmer3 # # Please direct questions and support issues to # # Cared for by Thomas Sharpton # # Copyright Thomas Sharpton # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::hmmer3 =head1 SYNOPSIS use Bio::SearchIO; my $searchio = Bio::SearchIO->new( -format => 'hmmer', -version => 3, -file => 'hmmsearch.out' ); my $result = $searchio->next_result; my $hit = $result->next_hit; print $hit->name, $hit->description, $hit->significance, $hit->score, "\n"; my $hsp = $hit->next_hsp; print $hsp->start('hit'), $hsp->end('hit'), $hsp->start('query'), $hsp->end('query'), "\n"; =head1 DESCRIPTION Code to parse output from hmmsearch, hmmscan, and nhmmer, compatible with both version 2 and version 3 of the HMMER package from L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: L rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Thomas Sharpton Email thomas.sharpton@gmail.com Describe contact details here =head1 CONTRIBUTORS Additional contributors names and emails here briano at bioteam.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::hmmer3; use strict; use Data::Dumper; use Bio::Factory::ObjectFactory; use Bio::Tools::IUPAC; use vars qw(%MAPPING %MODEMAP); use base qw(Bio::SearchIO::hmmer); BEGIN { # mapping of HMMER items to Bioperl hash keys %MODEMAP = ( 'HMMER_Output' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_query-strand' => 'HSP-query_strand', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_hit-strand' => 'HSP-hit_strand', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame' => 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_desc' => 'HIT-description', 'Hit_signif' => 'HIT-significance', 'Hit_score' => 'HIT-score', 'HMMER_program' => 'RESULT-algorithm_name', 'HMMER_version' => 'RESULT-algorithm_version', 'HMMER_query-def' => 'RESULT-query_name', 'HMMER_query-len' => 'RESULT-query_length', 'HMMER_query-acc' => 'RESULT-query_accession', 'HMMER_querydesc' => 'RESULT-query_description', 'HMMER_hmm' => 'RESULT-hmm_name', 'HMMER_seqfile' => 'RESULT-sequence_file', 'HMMER_db' => 'RESULT-database_name', ); } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; my $seentop = 0; # Placeholder for when we deal with multi-query reports my $reporttype; my ( $last, @hit_list, @hsp_list, %hspinfo, %hitinfo, %domaincounter ); local $/ = "\n"; local $_; my @ambiguous_nt = keys %Bio::Tools::IUPAC::IUB; my $ambiguous_nt = join '', @ambiguous_nt; my $verbose = $self->verbose; # cache for speed? JES's idea in hmmer.pm $self->start_document(); local ($_); # This is here to ensure that next_result doesn't produce infinite loop if ( !defined( $_ = $self->_readline ) ) { return undef; } else { $self->_pushback($_); } # Regex goes here for HMMER3 # Start with hmmsearch processing while ( defined( $_ = $self->_readline ) ) { my $lineorig = $_; chomp; # Grab the program name if ( $_ =~ m/^\#\s(\S+)\s\:\:\s/ ) { my $prog = $1; # TO DO: customize the above regex to adapt to other # program types (hmmscan, etc) $self->start_element( { 'Name' => 'HMMER_Output' } ); $self->{'_result_count'}++; #Might need to move to another block $self->element( { 'Name' => 'HMMER_program', 'Data' => uc($prog) } ); } # Get the HMMER package version and release date elsif ( $_ =~ m/^\#\sHMMER\s+(\S+)\s+\((.+)\)/ ) { my $version = $1; my $versiondate = $2; $self->{'_hmmidline'} = $_; $self->element( { 'Name' => 'HMMER_version', 'Data' => $version } ); } # Get the query info elsif ( $_ =~ /^\#\squery \w+ file\:\s+(\S+)/ ) { if ( $self->{'_reporttype'} eq 'HMMSEARCH' || $self->{'_reporttype'} eq 'NHMMER' ) { $self->{'_hmmfileline'} = $lineorig; $self->element( { 'Name' => 'HMMER_hmm', 'Data' => $1 } ); } elsif ( $self->{'_reporttype'} eq 'HMMSCAN' ) { $self->{'_hmmseqline'} = $lineorig; $self->element( { 'Name' => 'HMMER_seqfile', 'Data' => $1 } ); } } # If this is a report without alignments elsif ( $_ =~ m/^\#\sshow\salignments\sin\soutput/ ) { $self->{'_alnreport'} = 0; } # Get the database info elsif ( $_ =~ m/^\#\starget\s\S+\sdatabase\:\s+(\S+)/ ) { if ( $self->{'_reporttype'} eq 'HMMSEARCH' || $self->{'_reporttype'} eq 'NHMMER' ) { $self->{'_hmmseqline'} = $lineorig; $self->element( { 'Name' => 'HMMER_seqfile', 'Data' => $1 } ); } elsif ( $self->{'_reporttype'} eq 'HMMSCAN' ) { $self->{'_hmmfileline'} = $lineorig; $self->element( { 'Name' => 'HMMER_hmm', 'Data' => $1 } ); } } # Get query data elsif ( $_ =~ s/^Query:\s+// ) { # TO DO: code to deal with multi-query report unless (s/\s+\[[L|M]\=(\d+)\]$//) { warn "Error parsing length for query, offending line $_\n"; exit(0); } my $querylen = $1; $self->element( { 'Name' => 'HMMER_query-len', 'Data' => $querylen } ); $self->element( { 'Name' => 'HMMER_query-def', 'Data' => $_ } ); } # Get Accession data elsif ( $_ =~ s/^Accession:\s+// ) { s/\s+$//; $self->element( { 'Name' => 'HMMER_query-acc', 'Data' => $_ } ); } # Get description data elsif ( $_ =~ s/^Description:\s+// ) { s/\s+$//; $self->element( { 'Name' => 'HMMER_querydesc', 'Data' => $_ } ); } # hmmsearch, nhmmer, and hmmscan-specific formatting here elsif ( defined $self->{'_reporttype'} && ( $self->{'_reporttype'} eq 'HMMSEARCH' || $self->{'_reporttype'} eq 'HMMSCAN' || $self->{'_reporttype'} eq 'NHMMER' ) ) { # Complete sequence table data above inclusion threshold, # hmmsearch or hmmscan if ( $_ =~ m/Scores for complete sequence/ ) { while ( defined( $_ = $self->_readline ) ) { if ( $_ =~ m/inclusion threshold/ || m/Domain( and alignment)? annotation for each/ || m/\[No hits detected/ || m!^//! ) { $self->_pushback($_); last; } # Grab table data next if ( m/\-\-\-/ || m/^\s+E-value\s+score/ || m/^$/ ); my ($eval_full, $score_full, $bias_full, $eval_best, $score_best, $bias_best, $exp, $n, $hitid, $desc, @hitline ); @hitline = split( " ", $_ ); $eval_full = shift @hitline; $score_full = shift @hitline; $bias_full = shift @hitline; $eval_best = shift @hitline; $score_best = shift @hitline; $bias_best = shift @hitline; $exp = shift @hitline; $n = shift @hitline; $hitid = shift @hitline; $desc = join " ", @hitline; if ( !defined($desc) ) { $desc = ""; } push @hit_list, [ $hitid, $desc, $eval_full, $score_full ]; $hitinfo{$hitid} = $#hit_list; } } # nhmmer if ( /Scores for complete hits/ ) { while ( defined( $_ = $self->_readline ) ) { if ( /inclusion threshold/ || /Annotation for each hit/ || /\[No hits detected/ || m!^//! ) { $self->_pushback($_); last; } # Grab table data next if ( /\-\-\-/ || /^\s+E-value\s+score/ || /^$/ ); my ($eval, $score, $bias, $hitid, $start, $end, $desc, @hitline ); @hitline = split( " ", $_ ); $eval = shift @hitline; $score = shift @hitline; $bias = shift @hitline; $hitid = shift @hitline; $start = shift @hitline; $end = shift @hitline; $desc = join ' ', @hitline; $desc = '' if ( !defined($desc) ); push @hit_list, [ $hitid, $desc, $eval, $score ]; $hitinfo{$hitid} = $#hit_list; } } # Complete sequence table data below inclusion threshold # not currently fully implemented - # Should all these lines simply be skipped? elsif ( /inclusion threshold/ ) { while ( defined( $_ = $self->_readline ) ) { if ( /Domain( and alignment)? annotation for each/ || /Internal pipeline statistics summary/ || /Annotation for each hit\s+\(and alignments\)/ ) { $self->_pushback($_); last; } next if ( $_ =~ m/^$/ ); my ($eval_full, $score_full, $bias_full, $eval_best, $score_best, $bias_best, $exp, $n, $hitid, $desc, @hitline ); @hitline = split( " ", $_ ); $eval_full = shift @hitline; $score_full = shift @hitline; $bias_full = shift @hitline; $eval_best = shift @hitline; $score_best = shift @hitline; $bias_best = shift @hitline; $exp = shift @hitline; $n = shift @hitline; $hitid = shift @hitline; $desc = join " ", @hitline; $hitinfo{$hitid} = "below_inclusion" if defined $hitid; } } # Domain annotation for each sequence table data, hmmscan elsif ( /Domain( and alignment)? annotation for each/ ) { @hsp_list = (); # Here for multi-query reports my $name; while ( defined( $_ = $self->_readline ) ) { if ( /Internal pipeline statistics/ || /\[No targets detected/ ) { $self->_pushback($_); last; } if ( $_ =~ m/^\>\>\s(.*?)\s+/ ) { $name = $1; # Skip hits below inclusion threshold next if ( $hitinfo{$name} eq "below_inclusion" ); $domaincounter{$name} = 0; while ( defined( $_ = $self->_readline ) ) { # Grab table data for sequence if ( $_ =~ m/Internal pipeline statistics/ || $_ =~ m/^\>\>/ ) { $self->_pushback($_); last; } if ( $_ =~ m/Alignments for each domain/ ) { $self->_pushback($_); last; } if ( $_ =~ m/^\s+\#\s+score/ || $_ =~ m/^\s\-\-\-\s+/ || # $_ =~ m/^\>\>/ || $_ =~ m/^$/ ) { next; } # Grab hsp data from table, push into @hsp; if (my ($domain_num, $score, $bias, $ceval, $ieval, $hmmstart, $hmmstop, $qalistart, $qalistop, $envstart, $envstop, $envbound, $acc ) = m|^\s+(\d+)\s\!*\?*\s+ # domain number (\S+)\s+(\S+)\s+ # score, bias (\S+)\s+(\S+)\s+ # c-eval, i-eval (\d+)\s+(\d+).+? # hmm start, stop (\d+)\s+(\d+).+? # query start, stop (\d+)\s+(\d+).+? # env start, stop (\S+) # Accession \s*$|ox ) { # Keep it simple for now. let's customize later my @vals = ( $hmmstart, $hmmstop, $qalistart, $qalistop, $score, $ceval, '', '', '' ); my $info = $hit_list[ $hitinfo{$name} ]; if ( !defined $info ) { $self->warn( "Incomplete sequence information; can't find $name, hitinfo says $hitinfo{$name}\n" ); next; } $domaincounter{$name}++; my $hsp_key = $name . "_" . $domaincounter{$name}; push @hsp_list, [ $name, @vals ]; $hspinfo{$hsp_key} = $#hsp_list; } else { print "missed this line: $_\n"; } } } elsif ( /Alignments for each domain/ ) { my $domain_count = 0; #line counter my $count = 0; # There's an optional block, so we sometimes need to # count to 3, and sometimes to 4. my $max_count = 3; my $lastdomain; my $hsp; my ( $hline, $midline, $qline ); while ( defined( $_ = $self->_readline ) ) { if ( $_ =~ m/^\>\>/ || $_ =~ m/Internal pipeline statistics/ ) { $self->_pushback($_); last; } elsif ($hitinfo{$name} eq "below_inclusion" || $_ =~ m/^$/ ) { next; } elsif ( $_ =~ /\s\s\=\=\sdomain\s(\d+)\s+/ ) { my $domainnum = $1; $count = 0; my $key = $name . "_" . $domainnum; $hsp = $hsp_list[ $hspinfo{$key} ]; $hline = $$hsp[-3]; $midline = $$hsp[-2]; $qline = $$hsp[-1]; $lastdomain = $name; } # model data track, some reports don't have elsif ( $_ =~ m/\s+\S+\sCS$/ ) { my $modeltrack = $_; $max_count++; $count++; next; } elsif ( $count == $max_count - 3 ) { # hit sequence my @data = split( " ", $_ ); my $seq = $data[-2]; $hline .= $seq; $count++; next; } elsif ( $count == $max_count - 2 ) { # conservation track # storage isn't quite right - need to remove # leading/lagging whitespace while preserving # gap data (latter isn't done, former is) $_ =~ s/^\s+//; $_ =~ s/\s+$//; $midline .= $_; $count++; next; } elsif ( $count == $max_count - 1 ) { # query track my @data = split( " ", $_ ); my $seq = $data[-2]; $qline .= $seq; $count++; next; } elsif ( $count == $max_count ) { #pval track my $pvals = $_; $count = 0; $max_count = 3; $$hsp[-3] = $hline; $$hsp[-2] = $midline; $$hsp[-1] = $qline; next; } else { print "missed $_\n"; } } } } } # Annotation for each hit, nhmmer # This code is currently incomplete, the alignment strings # are not being captured elsif ( /Annotation for each hit\s+\(and alignments\)/ ) { @hsp_list = (); my $name; while ( defined( $_ = $self->_readline ) ) { if ( $_ =~ m/Internal pipeline statistics/ || m/\[No targets detected/ ) { $self->_pushback($_); last; } if ( /^>>\s+(\S+)\s+/ ) { $name = $1; while ( defined( $_ = $self->_readline ) ) { if ( $_ =~ m/Internal pipeline statistics/ || $_ =~ m/^>>/ ) { $self->_pushback($_); last; } elsif ( $_ =~ /^\s+#\s+score/ || $_ =~ /^\s+------\s+/ || $_ =~ /^>>/ || $_ =~ /^$/ || $_ =~ /^\s+Alignment:/ || $_ =~ /^\s+score:/ || $_ =~ /^\s+score\s+bias/ || $_ =~ /^\s+\S+\s+\d+\s+([\s+.$ambiguous_nt-]+)/i # Alignment, line 1 || $_ =~ /^\s{20,}([\s+gatc-]+)/i # Alignment, line 2 || $_ =~ /^\s+$name\s+[\d-]+\s+([\s+$ambiguous_nt-]+)/i # Alignment, line 3 || $_ =~ /^\s+[\d.\*]+/ # Alignment, line 4 ) { next; } elsif ( /^\s+[!?]\s+(\S+)\s+ (\S+)\s+(\S+)\s+ (\d+)\s+(\d+)\s+[.\[\]]*\s+ (\d+)\s+(\d+)\s+[.\[\]]*\s+ (\d+)\s+(\d+)\s+[.\[\]]*\s+ (\d+)\s+(\S+).*$/ox ) { my ($score, $bias, $eval, $hmmstart, $hmmstop, $hitstart, $hitstop, $envstart, $envstop, $length, $acc ) = ( $1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11 ); my @vals = ( $hitstart, $hitstop, $hmmstart, $hmmstop, $score, $eval, '', '', '' ); my $info = $hit_list[ $hitinfo{$name} ]; if ( !defined $info ) { $self->warn( "Incomplete information: can't find HSP $name in list of hits\n" ); next; } $domaincounter{$name}++; my $hsp_key = $name . "_" . $domaincounter{$name}; push @hsp_list, [ $name, @vals ]; $hspinfo{$hsp_key} = $#hsp_list; } else { print "Missed this line: $_\n"; } } } } } elsif ( m/Internal pipeline statistics/ || m!^//! ) { # If within hit, hsp close; if ( $self->within_element('hit') ) { if ( $self->within_element('hsp') ) { $self->end_element( { 'Name' => 'Hsp' } ); } $self->end_element( { 'Name' => 'Hit' } ); } # Grab summary statistics of run while ( defined( $_ = $self->_readline ) ) { last if ( $_ =~ m/^\/\/$/ ); } # Do a lot of processing of hits and hsps here while ( my $hit = shift @hit_list ) { my $hit_name = shift @$hit; my $hit_desc = shift @$hit; my $hit_signif = shift @$hit; my $hit_score = shift @$hit; my $num_domains = $domaincounter{$hit_name} || 0; $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_id', 'Data' => $hit_name } ); $self->element( { 'Name' => 'Hit_desc', 'Data' => $hit_desc } ); $self->element( { 'Name' => 'Hit_signif', 'Data' => $hit_signif } ); $self->element( { 'Name' => 'Hit_score', 'Data' => $hit_score } ); for my $i ( 1 .. $num_domains ) { my $key = $hit_name . "_" . $i; my $hsp = $hsp_list[ $hspinfo{$key} ]; if ( defined $hsp ) { my $hsp_name = shift @$hsp; $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => 0 } ); $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_query-from', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_evalue', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_hseq', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_midline', 'Data' => shift @$hsp } ); $self->element( { 'Name' => 'Hsp_qseq', 'Data' => shift @$hsp } ); # Only nhmmer output has strand information if ( $self->{'_reporttype'} eq 'NHMMER' ) { my $hstart = $self->get_from_element('HSP-hit_start'); my $hend = $self->get_from_element('HSP-hit_end'); my $hstrand = ( $hstart < $hend ) ? 1 : -1; my $qstart = $self->get_from_element('HSP-query_start'); my $qend = $self->get_from_element('HSP-query_end'); my $qstrand = ( $qstart < $qend ) ? 1 : -1; $self->element( { 'Name' => 'Hsp_query-strand', 'Data' => $qstrand } ); $self->element( { 'Name' => 'Hsp_hit-strand', 'Data' => $hstrand } ); } $self->end_element( { 'Name' => 'Hsp' } ); } } $self->end_element( { 'Name' => 'Hit' } ); } @hit_list = (); %hitinfo = (); last; } } else { print "Missed line: $_\n"; $self->debug($_); } $last = $_; } $self->end_element( { 'Name' => 'HMMER_Output' } ); my $result = $self->end_document(); return $result; } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "start_%s", lc $type ); $self->_eventHandler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( defined $type && $type eq 'result' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; } } =head2 end_element Title : end_element Usage : $eventgeneartor->end_element Function: Handles and end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if ( $nm eq 'HMMER_program' ) { if ( $self->{'_last_data'} =~ /(N?HMM\S+)/i ) { $self->{'_reporttype'} = uc $1; } } # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if ( $nm eq 'Hsp' ) { foreach (qw(Hsp_qseq Hsp_midline Hsp_hseq)) { my $data = $self->{'_last_hspdata'}->{$_}; if ( $data && $_ eq 'Hsp_hseq' ) { # replace hmm '.' gap symbol by '-' $data =~ s/\./-/g; } $self->element( { 'Name' => $_, 'Data' => $data } ); } $self->{'_last_hspdata'} = {}; } if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "end_%s", lc $type ); $rc = $self->_eventHandler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } my $lastelem = shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; # print "lastdata is " . $self->{'_last_data'} . "\n"; } } else { $self->debug("unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convenience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 get_from_element Title : get_from_element Usage : $self->get_from_element('HSP-hit_start'); Function: Convenience method to retrieve data from '_values' hash Returns : string Args : key =cut sub get_from_element { my ($self,$key) = @_; my $values = $self->{_values}; $values->{$key}; } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; if ( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/o && defined $data->{'Data'} ) { $self->{'_last_hspdata'}->{ $data->{'Name'} } .= $data->{'Data'}; } return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/o ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element( $element ) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if ( !defined $name || !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { return 1 if ( $_ eq $name ); } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element( $element ) ) {} Function: Test if we are in a particular element This is different than 'within' because 'in' only tests its immediate parent Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ($self) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results processed Returns : interger Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } 1; BioPerl-1.6.923/Bio/SearchIO/hmmer_pull.pm000555000765000024 2205412254227325 20336 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::hmmer_pull # # Please direct questions and support issues to # # Cared for by Sendu Bala # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::hmmer_pull - A parser for HMMER output =head1 SYNOPSIS # do not use this class directly it is available through Bio::SearchIO use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'hmmer_pull', -file => 't/data/hmmpfam.bigout'); while (my $result = $in->next_result) { # this is a Bio::Search::Result::HmmpfamResult object print $result->query_name(), " for HMM ", $result->hmm_name(), "\n"; while (my $hit = $result->next_hit) { print $hit->name(), "\n"; while (my $hsp = $hit->next_hsp) { print "length is ", $hsp->length(), "\n"; } } } =head1 DESCRIPTION This object implements a pull-parser for HMMER output. It is fast since it only does work on request (hence 'pull'). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::hmmer_pull; use strict; use base qw(Bio::SearchIO Bio::PullParserI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::hmmer_pull->new(); Function: Builds a new Bio::SearchIO::hmmer_pull object Returns : Bio::SearchIO::hmmer_pull Args : -fh/-file => HMMER output filename -format => 'hmmer_pull' -evalue => float or scientific notation number to be used as an evalue cutoff for hits -score => integer or scientific notation number to be used as a score value cutoff for hits -hsps => integer minimum number of hsps (domains) a hit must have -piped_behaviour => 'temp_file'|'memory'|'sequential_read' -piped_behaviour defines what the parser should do if the input is an unseekable filehandle (eg. piped input), see Bio::PullParserI::chunk for details. Default is 'sequential_read'. =cut sub _initialize { my ($self, @args) = @_; # don't do normal SearchIO initialization my ($writer, $file, $fh, $piped_behaviour, $evalue, $score, $hsps) = $self->_rearrange([qw(WRITER FILE FH PIPED_BEHAVIOUR EVALUE SCORE HSPS)], @args); $self->writer($writer) if $writer; $self->_fields( { ( header => undef, algorithm => undef, algorithm_version => undef, algorithm_reference => '', hmm_file => undef, hmm_name => undef, sequence_file => undef, sequence_database => undef, database_name => undef, database_letters => undef, database_entries => undef, next_result => undef, evalue_cutoff => '[unset]', score_cutoff => '[unset]', hsps_cutoff => '[unset]' ) } ); $self->_fields->{evalue_cutoff} = $evalue if $evalue; $self->_fields->{score_cutoff} = $score if $score; $self->_fields->{hsps_cutoff} = $hsps if $hsps; $self->_dependencies( { ( algorithm => 'header', algorithm_version => 'header', hmm_file => 'header', hmm_name => 'header', sequence_file => 'header', sequence_database => 'header' ) } ); $self->chunk($file || $fh || $self->throw("-file or -fh must be supplied"), -piped_behaviour => $piped_behaviour || 'sequential_read'); } sub _discover_header { my $self = shift; $self->_chunk_seek(0); my $header = $self->_get_chunk_by_nol(8); $self->{_after_header} = $self->_chunk_tell; my ($algo) = $header =~ /^(hmm\S+) - search/m; $self->_fields->{algorithm} = uc $algo; ($self->_fields->{algorithm_version}) = $header =~ /^HMMER\s+?(\S+)/m; ($self->_fields->{hmm_file}) = $header =~ /^HMM file:\s.+?(\S+)$/m; $self->_fields->{hmm_name} = $self->_fields->{hmm_file}; ($self->_fields->{sequence_file}) = $header =~ /^Sequence (?:file|database):\s.+?(\S+)$/m; $self->_fields->{sequence_database} = $self->_fields->{sequence_file}; $self->_fields->{header} = 1; } sub _discover_database_name { my $self = shift; my $type = $self->get_field('algorithm'); if ($type eq 'HMMPFAM') { $self->_fields->{database_name} = $self->get_field('hmm_file'); } elsif ($type eq 'HMMSEARCH') { $self->_fields->{database_name} = $self->get_field('sequence_file'); } } sub _discover_next_result { my $self = shift; my $type = $self->get_field('algorithm'); # also sets _after_header if not set if ($type eq 'HMMPFAM') { use Bio::Search::Result::HmmpfamResult; unless ($self->_sequential) { $self->_chunk_seek($self->{_end_of_previous_result} || $self->{_after_header}); my ($start, $end) = $self->_find_chunk_by_end("//\n"); return if $start == $end; $self->_fields->{next_result} = Bio::Search::Result::HmmpfamResult->new(-chunk => [($self->chunk, $start, $end)], -parent => $self); $self->{_end_of_previous_result} = $end; } else { # deliberatly don't cache these, which means rewind won't work; # if we cached we may as well have used 'memory' option to # -piped_behaviour my $chunk = $self->_get_chunk_by_end("//\n"); $chunk || return; $self->_fields->{next_result} = Bio::Search::Result::HmmpfamResult->new(-chunk => [$chunk], -parent => $self); } } elsif ($type eq 'HMMSEARCH') { $self->throw("Can't handle hmmsearch yet\n"); } else { $self->throw("Unknown report type"); } } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my $self = shift; my $result = $self->get_field('next_result') || return; undef $self->_fields->{next_result}; $self->{'_result_count'}++; return $result; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed. Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } =head2 rewind Title : rewind Usage : $searchio->rewind; Function: Allow one to reset the Result iterator to the beginning, so that next_result() will subsequently return the first result and so on. NB: result objects are not cached, so you will get new result objects each time you rewind. Also, note that result_count() counts the number of times you have called next_result(), so will not be able tell you how many results there were in the file if you use rewind(). Returns : n/a Args : none =cut sub rewind { my $self = shift; if ($self->_sequential) { $self->warn("rewind has no effect on piped input when you have chosen 'sequential_read' mode"); } delete $self->{_end_of_previous_result}; } 1; BioPerl-1.6.923/Bio/SearchIO/infernal.pm000444000765000024 12326012254227317 20007 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::infernal # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::infernal - SearchIO-based Infernal parser =head1 SYNOPSIS my $parser = Bio::SearchIO->new(-format => 'infernal', -file => 'purine.inf'); while( my $result = $parser->next_result ) { # general result info, such as model used, Infernal version while( my $hit = $result->next_hit ) { while( my $hsp = $hit->next_hsp ) { # ... } } } =head1 DESCRIPTION This is a SearchIO-based parser for Infernal output from the cmsearch program. It currently parses cmsearch output for Infernal versions 0.7-1.0; older versions may work but will not be supported. As the first stable version has been released (and output has stabilized) it is highly recommended that users upgrade to using the latest Infernal release. Support for the older pre-v.1 developer releases will be dropped for future core 1.6 releases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields-at-uiuc-dot-edu =head1 CONTRIBUTORS Jeffrey Barrick, Michigan State University =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::infernal; use strict; use Data::Dumper; use base qw(Bio::SearchIO); our %MODEMAP = ( 'Result' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); our %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', # evalues only in v0.81, optional 'Hsp_pvalue' => 'HSP-pvalue', # pvalues only in v0.81, optional 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_structure' => 'HSP-meta', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_stranded' => 'HSP-stranded', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_gi' => 'HIT-ncbi_gi', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_signif' => 'HIT-significance', # evalues only in v0.81, optional 'Hit_p' => 'HIT-p', # pvalues in 1.0, optional 'Hit_score' => 'HIT-score', # best HSP bit score 'Hit_bits' => 'HIT-bits', # best HSP bit score 'Infernal_program' => 'RESULT-algorithm_name', # get/set 'Infernal_version' => 'RESULT-algorithm_version', # get/set 'Infernal_query-def'=> 'RESULT-query_name', # get/set 'Infernal_query-len'=> 'RESULT-query_length', 'Infernal_query-acc'=> 'RESULT-query_accession', # get/set 'Infernal_querydesc'=> 'RESULT-query_description', # get/set 'Infernal_db' => 'RESULT-database_name', # get/set 'Infernal_db-len' => 'RESULT-database_entries', # none yet 'Infernal_db-let' => 'RESULT-database_letters', # none yet ); my $MINSCORE = 0; my $DEFAULT_ALGORITHM = 'cmsearch'; my $DEFAULT_VERSION = '1.0'; my @VALID_SYMBOLS = qw(5-prime 3-prime single-strand unknown gap); my %STRUCTURE_SYMBOLS = ( '5-prime' => '<', '3-prime' => '>', 'single-strand' => ':', 'unknown' => '?', 'gap' => '.' ); =head2 new Title : new Usage : my $obj = Bio::SearchIO::infernal->new(); Function: Builds a new Bio::SearchIO::infernal object Returns : Bio::SearchIO::infernal Args : -fh/-file => cmsearch (infernal) filename -format => 'infernal' -model => query model (Rfam ID) (default undef) -database => database name (default undef) -query_acc => query accession, eg. Rfam accession RF#### -query_desc => query description, eg. Rfam description -hsp_minscore => minimum HSP score cutoff -convert_meta => boolean, set to convert meta string to simple WUSS format -symbols => hash ref of structure symbols to use (default symbols in %STRUCTURE_SYMBOLS hash) =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ($model, $database, $convert, $symbols, $cutoff, $desc, $accession, $algorithm, $version) = $self->_rearrange([qw(MODEL DATABASE CONVERT_META SYMBOLS HSP_MINSCORE QUERY_DESC QUERY_ACC ALGORITHM VERSION)],@args); my $handler = $self->_eventHandler; $handler->register_factory( 'result', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::GenericResult', -interface => 'Bio::Search::Result::ResultI', -verbose => $self->verbose ) ); $handler->register_factory( 'hit', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::ModelHit', -interface => 'Bio::Search::Hit::HitI', -verbose => $self->verbose ) ); $handler->register_factory( 'hsp', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::ModelHSP', -interface => 'Bio::Search::HSP::HSPI', -verbose => $self->verbose ) ); defined $model && $self->model($model); defined $database && $self->database($database); defined $accession && $self->query_accession($accession); defined $convert && $self->convert_meta($convert); defined $desc && $self->query_description($desc); $version ||= $DEFAULT_VERSION; $self->version($version); $symbols ||= \%STRUCTURE_SYMBOLS; $self->structure_symbols($symbols); $cutoff ||= $MINSCORE; $self->hsp_minscore($cutoff); $algorithm ||= $DEFAULT_ALGORITHM; $self->algorithm($algorithm); } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; unless (exists $self->{'_handlerset'}) { my $line; while ($line = $self->_readline) { # advance to first line next if $line =~ m{^\s*$}; # newer output starts with model name if ($line =~ m{^\#\s+cmsearch\s}) { $self->{'_handlerset'} = 'latest'; } elsif ($line =~ m{^CM\s\d+:}) { $self->{'_handlerset'} = 'pre-1.0'; } else { $self->{'_handlerset'} ='old'; } last; } $self->_pushback($line); #if ($self->{'_handlerset'} ne '1.0') { # $self->deprecated( # -message => "Parsing of Infernal pre-1.0 release is deprecated;\n". # "upgrading to Infernal 1.0 or above is highly recommended", # -version => 1.007); #} } return ($self->{'_handlerset'} eq 'latest') ? $self->_parse_latest : ($self->{'_handlerset'} eq 'pre-1.0') ? $self->_parse_pre : $self->_parse_old; } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "start_%s", lc $type ); $self->_eventHandler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( defined $type && $type eq 'result' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys, 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "end_%s", lc $type ); $rc = $self->_eventHandler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } my $lastelem = shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { $self->debug("unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convenience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; # simple data calls (%MAPPING) do not need start_element $self->characters($data); $self->end_element($data); } =head2 element_hash Title : element Usage : $eventhandler->element_hash({'Hsp_hit-from' => $start, 'Hsp_hit-to' => $end, 'Hsp_score' => $lastscore}); Function: Convenience method that takes multiple simple data elements and maps to appropriate parameters Returns : none Args : Hash ref with the mapped key (in %MAPPING) and value =cut sub element_hash { my ($self, $data) = @_; $self->throw("Must provide data hash ref") if !$data || !ref($data); for my $nm (sort keys %{$data}) { next if $data->{$nm} && $data->{$nm} =~ m{^\s*$}o; if ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $data->{$nm}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $data->{$nm}; } } } } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/o ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if ( !defined $name || !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { return 1 if ( $_ eq $name ); } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'within' because 'in' only tests its immediate parent. Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ($self) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } =head2 model Title : model Usage : my $model = $parser->model(); Function: Get/Set model; Infernal currently does not output the model name (Rfam ID) Returns : String (name of model) Args : [optional] String (name of model) =cut sub model { my $self = shift; return $self->{'_model'} = shift if @_; return $self->{'_model'}; } =head2 database Title : database Usage : my $database = $parser->database(); Function: Get/Set database; Infernal currently does not output the database name Returns : String (database name) Args : [optional] String (database name) =cut sub database { my $self = shift; return $self->{'_database'} = shift if @_; return $self->{'_database'}; } =head2 algorithm Title : algorithm Usage : my $algorithm = $parser->algorithm(); Function: Get/Set algorithm; current versions of Infernal do not output the algorithm name Returns : String (algorithm name) Args : [optional] String (algorithm name) =cut sub algorithm { my $self = shift; return $self->{'_algorithm'} = shift if @_; return $self->{'_algorithm'}; } =head2 query_accession Title : query_accession Usage : my $acc = $parser->query_accession(); Function: Get/Set query (model) accession; Infernal currently does not output the accession number (Rfam accession #) Returns : String (accession) Args : [optional] String (accession) =cut sub query_accession { my $self = shift; return $self->{'_query_accession'} = shift if @_; return $self->{'_query_accession'}; } =head2 query_description Title : query_description Usage : my $acc = $parser->query_description(); Function: Get/Set query (model) description; Infernal currently does not output the Rfam description Returns : String (description) Args : [optional] String (description) =cut sub query_description { my $self = shift; return $self->{'_query_description'} = shift if @_; return $self->{'_query_description'}; } =head2 hsp_minscore Title : hsp_minscore Usage : my $cutoff = $parser->hsp_minscore(); Function: Get/Set min bit score cutoff (for generating Hits/HSPs) Returns : score (number) Args : [optional] score (number) =cut sub hsp_minscore { my $self = shift; return $self->{'_hsp_minscore'} = shift if @_; return $self->{'_hsp_minscore'}; } =head2 convert_meta Title : convert_meta Usage : $parser->convert_meta(1); Function: Get/Set boolean flag for converting Infernal WUSS format to a simple bracketed format (simple WUSS by default) Returns : boolean flag (TRUE or FALSE) Args : [optional] boolean (eval's to TRUE or FALSE) =cut sub convert_meta { my $self = shift; return $self->{'_convert_meta'} = shift if @_; return $self->{'_convert_meta'}; } =head2 version Title : version Usage : $parser->version(); Function: Set the Infernal cmsearch version Returns : version Args : [optional] version =cut sub version { my $self = shift; return $self->{'_version'} = shift if @_; return $self->{'_version'}; } =head2 structure_symbols Title : structure_symbols Usage : my $hashref = $parser->structure_symbols(); Function: Get/Set RNA structure symbols Returns : Hash ref of delimiters (5' stem, 3' stem, single-strand, etc) : default = < (5-prime) > (3-prime) : (single-strand) ? (unknown) . (gap) Args : Hash ref of substitute delimiters, using above keys. =cut sub structure_symbols { my ($self, $delim) = @_; if ($delim) { if (ref($delim) =~ m{HASH}) { my %data = %{ $delim }; for my $d (@VALID_SYMBOLS) { if ( exists $data{$d} ) { $self->{'_delimiter'}->{$d} = $data{$d}; } } } else { $self->throw("Args to helix_delimiters() should be in a hash reference"); } } return $self->{'_delimiter'}; } =head2 simple_meta Title : simple_meta Usage : my $string = $parser->simple_meta($str); Function: converts more complex WUSS meta format into simple bracket format using symbols defined in structure_symbols() Returns : converted string Args : [required] string to convert Note : This is a very simple conversion method to get simple bracketed format from Infernal data. If the convert_meta() flag is set, this is the method used to convert the strings. =cut sub simple_meta { my ($self, $str) = @_; $self->throw("No string arg sent!") if !$str; my $structs = $self->structure_symbols(); my ($ls, $rs, $ss, $unk, $gap) = ($structs->{'5-prime'}, $structs->{'3-prime'}, $structs->{'single-strand'}, $structs->{'unknown'}, $structs->{'gap'}); $str =~ s{[\(\<\[\{]}{$ls}g; $str =~ s{[\)\>\]\}]}{$rs}g; $str =~ s{[:,_-]}{$ss}g; $str =~ s{\.}{$gap}g; # unknown not handled yet return $str; } ## private methods # this is a hack which guesses the format and sets the handler for parsing in # an instance; it'll be taken out when infernal 1.0 is released sub _parse_latest { my ($self) = @_; my $seentop = 0; local $/ = "\n"; my ($accession, $description) = ($self->query_accession, $self->query_description); my ($maxscore, $mineval, $minpval); $self->start_document(); my ($lasthit, $lastscore, $lasteval, $lastpval, $laststart, $lastend); PARSER: while (my $line = $self->_readline) { next if $line =~ m{^\s+$}; # stats aren't parsed yet... if ($line =~ m{^\#\s+cmsearch}xms) { $seentop = 1; $self->start_element({'Name' => 'Result'}); $self->element_hash({ 'Infernal_program' => 'CMSEARCH' }); } elsif ($line =~ m{^\#\sINFERNAL\s+(\d+\.\d+)}xms) { $self->element_hash({ 'Infernal_version' => $1, }); } elsif ($line =~ m{^\#\scommand:.*?\s(\S+)$}xms) { $self->element_hash({ 'Infernal_db' => $1, }); } elsif ($line =~ m{^\#\s+dbsize\(Mb\):\s+(\d+\.\d+)}xms) { # store absolute DB length $self->element_hash({ 'Infernal_db-let' => $1 * 1e6 }); } elsif ($line =~ m{^CM(?:\s(\d+))?:\s*(\S+)}xms) { # not sure, but it's possible single reports may contain multiple # models; if so, they should be rolled over into a new ResultI #print STDERR "ACC: $accession\nDESC: $description\n"; $self->element_hash({ 'Infernal_query-def' => $2, # present in output now 'Infernal_query-acc' => $accession, 'Infernal_querydesc' => $description }); } elsif ($line =~ m{^>\s*(\S+)} ){ #$self->debug("Start Hit: Found hit:$1\n"); if ($self->in_element('hit')) { $self->element_hash({'Hit_score' => $maxscore, 'Hit_bits' => $maxscore}); ($maxscore, $minpval, $mineval) = undef; $self->end_element({'Name' => 'Hit'}); } $lasthit = $1; } elsif ($line =~ m{ ^\sQuery\s=\s\d+\s-\s\d+,\s # Query start/end Target\s=\s(\d+)\s-\s(\d+) # Target start/end }xmso) { # Query (model) start/end always the same, determined from # the HSP length ($laststart, $lastend) = ($1, $2); #$self->debug("Found hit coords:$laststart - $lastend\n"); } elsif ($line =~ m{ ^\sScore\s=\s([\d\.]+),\s # Score = Bitscore (for now) (?:E\s=\s([\d\.e-]+),\s # E-val optional P\s=\s([\d\.e-]+),\s)? # P-val optional GC\s= # GC not captured }xmso ) { ($lastscore, $lasteval, $lastpval) = ($1, $2, $3); #$self->debug(sprintf("Found hit data:Score:%s,Eval:%s,Pval:%s\n",$lastscore, $lasteval||'', $lastpval||'')); $maxscore ||= $lastscore; if ($lasteval && $lastpval) { $mineval ||= $lasteval; $minpval ||= $lastpval; $mineval = ($mineval > $lasteval) ? $lasteval : $mineval; $minpval = ($minpval > $lastpval) ? $lastpval : $minpval; } $maxscore = ($maxscore < $lastscore) ? $lastscore : $maxscore; if (!$self->within_element('hit')) { my ($gi, $acc, $ver) = $self->_get_seq_identifiers($lasthit); $self->start_element({'Name' => 'Hit'}); $self->element_hash({ 'Hit_id' => $lasthit, 'Hit_accession' => $ver ? "$acc.$ver" : $acc ? $acc : $lasthit, 'Hit_gi' => $gi }); } if (!$self->in_element('hsp')) { $self->start_element({'Name' => 'Hsp'}); } # hsp is similar to older output } elsif ($line =~ m{^(\s+)[<>\{\}\(\)\[\]:_,-\.]+}xms) { # start of HSP $self->_pushback($line); # set up for loop #$self->debug("Start HSP\n"); # what is length of the gap to the structure data? my $offset = length($1); my ($ct, $strln) = 0; my $hsp; HSP: my %hsp_key = ('0' => 'meta', '1' => 'query', '2' => 'midline', '3' => 'hit'); HSP: while (defined ($line = $self->_readline)) { chomp $line; next if (!$line); # toss empty lines # next if $line =~ m{^\s*$}; # toss empty lines # it is possible to have homology lines consisting # entirely of spaces if the subject has a large # insertion where nothing matches the model # exit loop if at end of file or upon next hit/HSP if ($line =~ m{^\s{0,2}\S+}) { $self->_pushback($line); last HSP; } # iterate to keep track of each line (4 lines per hsp block) my $iterator = $ct % 4; # strlen set only with structure lines (proper length) $strln = length($line) if $iterator == 0; # only grab the data needed (hit start and stop in hit line above) my $data = substr($line, $offset, $strln-$offset); $hsp->{ $hsp_key{$iterator} } .= $data; $ct++; } # query start, end are from the actual query length (entire hit is # mapped to CM data, so all CM data is represented) # works for now... if ($self->in_element('hsp')) { # In some cases with HSPs unaligned residues are present in # the hit or query (Ex: '*[ 8]*' is 8 unaligned residues). # This info needs to be passed on unmodifed to the HSP class # and handled there as it is subjectively changed based on # use. my $strlen = 0; # catch any insertions and add them into the actual length while ($hsp->{'query'} =~ m{\*\[\s*(\d+)\s*\]\*}g) { $strlen += $1; } # add on the actual residues $strlen += $hsp->{'query'} =~ tr{A-Za-z}{A-Za-z}; my $metastr = ($self->convert_meta) ? ($self->simple_meta($hsp->{'meta'})) : $hsp->{'meta'}; $self->element_hash( {'Hsp_stranded' => 'HIT', 'Hsp_qseq' => $hsp->{'query'}, 'Hsp_hseq' => $hsp->{'hit'}, 'Hsp_midline' => $hsp->{'midline'}, 'Hsp_structure' => $metastr, 'Hsp_query-from' => 1, 'Infernal_query-len' => $strlen, 'Hsp_query-to' => $strlen, 'Hsp_hit-from' => $laststart, 'Hsp_hit-to' => $lastend, 'Hsp_score' => $lastscore, 'Hsp_bit-score' => $lastscore, }); $self->element_hash( {'Hsp_evalue' => $lasteval, 'Hsp_pvalue' => $lastpval, }) if ($lasteval && $lastpval); $self->end_element({'Name' => 'Hsp'}); } # result now ends with // and 'Fin' } elsif ($line =~ m{^//}xms ) { if ($self->within_element('result') && $seentop) { if ($self->in_element('hit')) { $self->element_hash({'Hit_score' => $maxscore, 'Hit_bits' => $maxscore}); # don't know where to put minpval yet $self->element_hash({'Hit_signif' => $mineval}) if $mineval; $self->element_hash({'Hit_p' => $minpval}) if $minpval; $self->end_element({'Name' => 'Hit'}); } last PARSER; } } } $self->within_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); $self->end_element( { 'Name' => 'Result' } ) if $seentop; return $self->end_document(); } # cmsearch 0.81 (pre-1.0) sub _parse_pre { my ($self) = @_; my $seentop = 0; local $/ = "\n"; my ($accession, $db, $algorithm, $description, $version) = ($self->query_accession, $self->database, $self->algorithm, $self->query_description, '0.81'); my ($maxscore, $mineval, $minpval); $self->start_document(); my ($lasthit, $lastscore, $lasteval, $lastpval, $laststart, $lastend); PARSER: while (my $line = $self->_readline) { next if $line =~ m{^\s+$}; # stats aren't parsed yet... if ($line =~ m{CM\s\d+:\s*(\S+)}xms) { #$self->debug("Start Result: Found model:$1\n"); if (!$self->within_element('result')) { $seentop = 1; $self->start_element({'Name' => 'Result'}); $self->element_hash({ 'Infernal_program' => $algorithm, 'Infernal_query-def' => $1, # present in output now 'Infernal_query-acc' => $accession, 'Infernal_querydesc' => $description, 'Infernal_db' => $db }); } } elsif ($line =~ m{^>\s*(\S+)} ){ #$self->debug("Start Hit: Found hit:$1\n"); if ($self->in_element('hit')) { $self->element_hash({'Hit_score' => $maxscore, 'Hit_bits' => $maxscore}); ($maxscore, $minpval, $mineval) = undef; $self->end_element({'Name' => 'Hit'}); } $lasthit = $1; } elsif ($line =~ m{ ^\sQuery\s=\s\d+\s-\s\d+,\s # Query start/end Target\s=\s(\d+)\s-\s(\d+) # Target start/end }xmso) { # Query (model) start/end always the same, determined from # the HSP length ($laststart, $lastend) = ($1, $2); #$self->debug("Found hit coords:$laststart - $lastend\n"); } elsif ($line =~ m{ ^\sScore\s=\s([\d\.]+),\s # Score = Bitscore (for now) (?:E\s=\s([\d\.e-]+),\s # E-val optional P\s=\s([\d\.e-]+),\s)? # P-val optional GC\s= # GC not captured }xmso ) { ($lastscore, $lasteval, $lastpval) = ($1, $2, $3); #$self->debug(sprintf("Found hit data:Score:%s,Eval:%s,Pval:%s\n",$lastscore, $lasteval||'', $lastpval||'')); $maxscore ||= $lastscore; if ($lasteval && $lastpval) { $mineval ||= $lasteval; $minpval ||= $lastpval; $mineval = ($mineval > $lasteval) ? $lasteval : $mineval; $minpval = ($minpval > $lastpval) ? $lastpval : $minpval; } $maxscore = ($maxscore < $lastscore) ? $lastscore : $maxscore; if (!$self->within_element('hit')) { my ($gi, $acc, $ver) = $self->_get_seq_identifiers($lasthit); $self->start_element({'Name' => 'Hit'}); $self->element_hash({ 'Hit_id' => $lasthit, 'Hit_accession' => $ver ? "$acc.$ver" : $acc ? $acc : $lasthit, 'Hit_gi' => $gi }); } if (!$self->in_element('hsp')) { $self->start_element({'Name' => 'Hsp'}); } # hsp is similar to older output } elsif ($line =~ m{^(\s+)[<>\{\}\(\)\[\]:_,-\.]+}xms) { # start of HSP $self->_pushback($line); # set up for loop #$self->debug("Start HSP\n"); # what is length of the gap to the structure data? my $offset = length($1); my ($ct, $strln) = 0; my $hsp; HSP: my %hsp_key = ('0' => 'meta', '1' => 'query', '2' => 'midline', '3' => 'hit'); HSP: while (defined ($line = $self->_readline)) { chomp $line; next if (!$line); # toss empty lines # next if $line =~ m{^\s*$}; # toss empty lines # it is possible to have homology lines consisting # entirely of spaces if the subject has a large # insertion where nothing matches the model # exit loop if at end of file or upon next hit/HSP if ($line =~ m{^\s{0,2}\S+}) { $self->_pushback($line); last HSP; } # iterate to keep track of each line (4 lines per hsp block) my $iterator = $ct%4; # strlen set only with structure lines (proper length) $strln = length($line) if $iterator == 0; # only grab the data needed (hit start and stop in hit line above) my $data = substr($line, $offset, $strln-$offset); $hsp->{ $hsp_key{$iterator} } .= $data; $ct++; } # query start, end are from the actual query length (entire hit is # mapped to CM data, so all CM data is represented) # works for now... if ($self->in_element('hsp')) { my $strlen = $hsp->{'query'} =~ tr{A-Za-z}{A-Za-z}; my $metastr; $metastr = ($self->convert_meta) ? ($self->simple_meta($hsp->{'meta'})) : ($hsp->{'meta'}); $self->element_hash( {'Hsp_stranded' => 'HIT', 'Hsp_qseq' => $hsp->{'query'}, 'Hsp_hseq' => $hsp->{'hit'}, 'Hsp_midline' => $hsp->{'midline'}, 'Hsp_structure' => $metastr, 'Hsp_query-from' => 1, 'Infernal_query-len' => $strlen, 'Hsp_query-to' => $strlen, 'Hsp_hit-from' => $laststart, 'Hsp_hit-to' => $lastend, 'Hsp_score' => $lastscore, 'Hsp_bit-score' => $lastscore, }); $self->element_hash( {'Hsp_evalue' => $lasteval, 'Hsp_pvalue' => $lastpval, }) if ($lasteval && $lastpval); $self->end_element({'Name' => 'Hsp'}); } # result now ends with // and 'Fin' } elsif ($line =~ m{^//}xms ) { if ($self->within_element('result') && $seentop) { $self->element( {'Name' => 'Infernal_version', 'Data' => $version} ); if ($self->in_element('hit')) { $self->element_hash({'Hit_score' => $maxscore, 'Hit_bits' => $maxscore}); # don't know where to put minpval yet $self->element_hash({'Hit_signif' => $mineval}) if $mineval; $self->end_element({'Name' => 'Hit'}); } last PARSER; } } } $self->within_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); $self->end_element( { 'Name' => 'Result' } ) if $seentop; return $self->end_document(); } # cmsearch 0.72 and below; will likely be dropped when Infernal 1.0 is released sub _parse_old { my ($self) = @_; my $seentop = 0; local $/ = "\n"; my ($accession, $db, $algorithm, $model, $description, $version) = ($self->query_accession, $self->database, $self->algorithm, $self->model, $self->query_description, $self->version); my $maxscore; my $cutoff = $self->hsp_minscore; $self->start_document(); local ($_); my $line; my ($lasthit, $lastscore, $laststart, $lastend); my $hitline; PARSER: while ( defined( $line = $self->_readline ) ) { next if $line =~ m{^\s+$}; # bypass this for now... next if $line =~ m{^HMM\shit}; # pre-0.81 if ($line =~ m{^sequence:\s+(\S+)} ){ if (!$self->within_element('result')) { $seentop = 1; $self->start_element({'Name' => 'Result'}); $self->element_hash({ 'Infernal_program' => $algorithm, 'Infernal_query-def' => $model, 'Infernal_query-acc' => $accession, 'Infernal_querydesc' => $description, 'Infernal_db' => $db }); } if ($self->in_element('hit')) { $self->element_hash({'Hit_score' => $maxscore, 'Hit_bits' => $maxscore}); $maxscore = undef; $self->end_element({'Name' => 'Hit'}); } $lasthit = $1; } elsif ($line =~ m{^hit\s+\d+\s+:\s+(\d+)\s+(\d+)\s+(\d+\.\d+)\s+bits}xms) { ($laststart, $lastend, $lastscore) = ($1, $2, $3); $maxscore = $lastscore unless $maxscore; if ($lastscore > $cutoff) { if (!$self->within_element('hit')) { my ($gi, $acc, $ver) = $self->_get_seq_identifiers($lasthit); $self->start_element({'Name' => 'Hit'}); $self->element_hash({ 'Hit_id' => $lasthit, 'Hit_accession' => $ver ? "$acc.$ver" : $acc ? $acc : $lasthit, 'Hit_gi' => $gi }); } # necessary as infernal 0.71 has repeated hit line if (!$self->in_element('hsp')) { $self->start_element({'Name' => 'Hsp'}); } $maxscore = ($maxscore < $lastscore) ? $lastscore : $maxscore; } } elsif ($line =~ m{^(\s+)[<>\{\}\(\)\[\]:_,-\.]+}xms) { # start of HSP $self->_pushback($line); # set up for loop # what is length of the gap to the structure data? my $offset = length($1); my ($ct, $strln) = 0; my $hsp; HSP: my %hsp_key = ('0' => 'meta', '1' => 'query', '2' => 'midline', '3' => 'hit'); HSP: while ($line = $self->_readline) { next if $line =~ m{^\s*$}; # toss empty lines chomp $line; # exit loop if at end of file or upon next hit/HSP if (!defined($line) || $line =~ m{^\S+}) { $self->_pushback($line); last HSP; } # iterate to keep track of each line (4 lines per hsp block) my $iterator = $ct%4; # strlen set only with structure lines (proper length) $strln = length($line) if $iterator == 0; # only grab the data needed (hit start and stop in hit line above) my $data = substr($line, $offset, $strln-$offset); $hsp->{ $hsp_key{$iterator} } .= $data; $ct++; } # query start, end are from the actual query length (entire hit is # mapped to CM data, so all CM data is represented) # works for now... if ($self->in_element('hsp')) { my $strlen = $hsp->{'query'} =~ tr{A-Za-z}{A-Za-z}; my $metastr; # Ugh...these should be passed in a hash $metastr = ($self->convert_meta) ? ($self->simple_meta($hsp->{'meta'})) : ($hsp->{'meta'}); $self->element_hash( {'Hsp_stranded' => 'HIT', 'Hsp_qseq' => $hsp->{'query'}, 'Hsp_hseq' => $hsp->{'hit'}, 'Hsp_midline' => $hsp->{'midline'}, 'Hsp_structure' => $metastr, 'Hsp_query-from' => 1, 'Infernal_query-len' => $strlen, 'Hsp_query-to' => $strlen, 'Hsp_hit-from' => $laststart, 'Hsp_hit-to' => $lastend, 'Hsp_score' => $lastscore, 'Hsp_bit-score' => $lastscore }); $self->end_element({'Name' => 'Hsp'}); } } elsif ($line =~ m{^memory}xms || $line =~ m{^CYK\smemory}xms ) { if ($self->within_element('result') && $seentop) { $self->element( {'Name' => 'Infernal_version', 'Data' => $version} ); if ($self->in_element('hit')) { $self->element_hash({'Hit_score' => $maxscore, 'Hit_bits' => $maxscore}); $self->end_element({'Name' => 'Hit'}); } last PARSER; } } } $self->within_element('hit') && $self->end_element( { 'Name' => 'Hit' } ); $self->end_element( { 'Name' => 'Result' } ) if $seentop; return $self->end_document(); } 1; BioPerl-1.6.923/Bio/SearchIO/IteratedSearchResultEventBuilder.pm000444000765000024 4563312254227325 24576 0ustar00cjfieldsstaff000000000000#------------------------------------------------------------------ # # BioPerl module for Bio::SearchIO::IteratedSearchResultEventBuilder # # Please direct questions and support issues to # # Cared for by Steve Chervitz and Jason Stajich # # Copyright Steve Chervitz # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------ # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::IteratedSearchResultEventBuilder - Event Handler for SearchIO events. =head1 SYNOPSIS # Do not use this object directly, this object is part of the SearchIO # event based parsing system. =head1 DESCRIPTION This object handles Search Events generated by the SearchIO classes and build appropriate Bio::Search::* objects from them. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Steve Chervitz Email sac-at-bioperl.org =head1 CONTRIBUTORS Parts of code based on SearchResultEventBuilder by Jason Stajich jason@bioperl.org Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::IteratedSearchResultEventBuilder; use vars qw(%KNOWNEVENTS $DEFAULT_INCLUSION_THRESHOLD $MAX_HSP_OVERLAP ); use strict; use Bio::Factory::ObjectFactory; use base qw(Bio::SearchIO::SearchResultEventBuilder); # e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) # NOTE: Executing `blastpgp -` incorrectly reports that the default is 0.005. # (version 2.2.2 [Jan-08-2002]) $DEFAULT_INCLUSION_THRESHOLD = 0.001; $MAX_HSP_OVERLAP = 2; # Used when tiling multiple HSPs. =head2 new Title : new Usage : my $obj = Bio::SearchIO::IteratedSearchResultEventBuilder->new(); Function: Builds a new Bio::SearchIO::IteratedSearchResultEventBuilder object Returns : Bio::SearchIO::IteratedSearchResultEventBuilder Args : -hsp_factory => Bio::Factory::ObjectFactoryI -hit_factory => Bio::Factory::ObjectFactoryI -result_factory => Bio::Factory::ObjectFactoryI -iteration_factory => Bio::Factory::ObjectFactoryI -inclusion_threshold => e-value threshold for inclusion in the PSI-BLAST score matrix model (blastpgp) -signif => float or scientific notation number to be used as a P- or Expect value cutoff -score => integer or scientific notation number to be used as a blast score value cutoff -bits => integer or scientific notation number to be used as a bit score value cutoff -hit_filter => reference to a function to be used for filtering hits based on arbitrary criteria. See L for more information =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hitF, $resultF, $hspF, $iterationF) = $self->_rearrange([qw( HIT_FACTORY RESULT_FACTORY HSP_FACTORY ITERATION_FACTORY )],@args); $self->_init_parse_params(@args); # Note that we need to override the setting of result and factories here # so that we can set different default factories than are set by the super class. $self->register_factory('result', $resultF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::BlastResult', -interface => 'Bio::Search::Result::ResultI')); $self->register_factory('hit', $hitF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::BlastHit', -interface => 'Bio::Search::Hit::HitI')); $self->register_factory('hsp', $hspF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::GenericHSP', -interface => 'Bio::Search::HSP::HSPI')); # TODO: Change this to BlastIteration (maybe) $self->register_factory('iteration', $iterationF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Iteration::GenericIteration', -interface => 'Bio::Search::Iteration::IterationI')); return $self; } #Initializes parameters used during parsing of Blast reports. sub _init_parse_params { my ($self, @args) = @_; # -FILT_FUNC has been replaced by -HIT_FILTER. # Leaving -FILT_FUNC in place for backward compatibility my($ithresh, $signif, $score, $bits, $hit_filter, $filt_func) = $self->_rearrange([qw(INCLUSION_THRESHOLD SIGNIF SCORE BITS HIT_FILTER FILT_FUNC )], @args); $self->inclusion_threshold( defined($ithresh) ? $ithresh : $DEFAULT_INCLUSION_THRESHOLD); my $hit_filt = $hit_filter || $filt_func; defined $hit_filter && $self->hit_filter($hit_filt); defined $signif && $self->max_significance($signif); defined $score && $self->min_score($score); defined $bits && $self->min_bits($bits); } =head2 will_handle Title : will_handle Usage : if( $handler->will_handle($event_type) ) { ... } Function: Tests if this event builder knows how to process a specific event Returns : boolean Args : event type name =cut sub will_handle{ my ($self,$type) = @_; # these are the events we recognize return ( $type eq 'hsp' || $type eq 'hit' || $type eq 'result' || $type eq 'iteration' || $type eq 'newhits' || $type eq 'oldhits' ); } =head2 SAX methods =cut =head2 start_result Title : start_result Usage : $handler->start_result($resulttype) Function: Begins a result event cycle Returns : none Args : Type of Report =cut sub start_result { my $self = shift; #print STDERR "ISREB: start_result()\n"; $self->SUPER::start_result(@_); $self->{'_iterations'} = []; $self->{'_iteration_count'} = 0; $self->{'_old_hit_names'} = undef; $self->{'_hit_names_below'} = undef; return; } =head2 end_result Title : end_result Usage : my @results = $parser->end_result Function: Finishes a result handler cycle Returns : A Bio::Search::Result::ResultI Args : none =cut sub end_result { my ($self,$type,$data) = @_; #print STDERR "ISREB: end_result\n"; ## How is runid getting set? Purpose? if( defined $data->{'runid'} && $data->{'runid'} !~ /^\s+$/ ) { if( $data->{'runid'} !~ /^lcl\|/) { $data->{"RESULT-query_name"}= $data->{'runid'}; } else { ($data->{"RESULT-query_name"},$data->{"RESULT-query_description"}) = split(/\s+/,$data->{"RESULT-query_description"},2); } if( my @a = split(/\|/,$data->{'RESULT-query_name'}) ) { my $acc = pop @a ; # this is for accession |1234|gb|AAABB1.1|AAABB1 # this is for |123|gb|ABC1.1| $acc = pop @a if( ! defined $acc || $acc =~ /^\s+$/); $data->{"RESULT-query_accession"}= $acc; } delete $data->{'runid'}; } my %args = map { my $v = $data->{$_}; s/RESULT//; ($_ => $v); } grep { /^RESULT/ } keys %{$data}; $args{'-algorithm'} = uc( $args{'-algorithm_name'} || $data->{'RESULT-algorithm_name'} || $type); $args{'-iterations'} = $self->{'_iterations'}; my $result = $self->factory('result')->create_object(%args); $result->hit_factory($self->factory('hit')); $self->{'_iterations'} = []; return $result; } # Title : _add_hit (private function for internal use only) # Purpose : Applies hit filtering and calls _store_hit if it passes filtering. # Argument: Bio::Search::Hit::HitI object sub _add_hit { my ($self, $hit) = @_; my $hit_name = uc($hit->{-name}); my $hit_signif = $hit->{-significance}; my $ithresh = $self->{'_inclusion_threshold'}; # Test significance using custom function (if supplied) my $add_hit = 1; my $hit_filter = $self->{'_hit_filter'}; if($hit_filter) { # since &hit_filter is out of our control and would expect a HitI object, # we're forced to make one for it $hit = $self->factory('hit')->create_object(%{$hit}); $add_hit = 0 unless &$hit_filter($hit); } else { if($self->{'_confirm_significance'}) { $add_hit = 0 unless $hit_signif <= $self->{'_max_significance'}; } if($self->{'_confirm_score'}) { my $hit_score = $hit->{-score} || $hit->{-hsps}->[0]->{-score}; $add_hit = 0 unless $hit_score >= $self->{'_min_score'}; } if($self->{'_confirm_bits'}) { my $hit_bits = $hit->{-bits} || $hit->{-hsps}->[0]->{-bits}; $add_hit = 0 unless $hit_bits >= $self->{'_min_bits'}; } } $add_hit && $self->_store_hit($hit, $hit_name, $hit_signif); # Building hit lookup hashes for determining if the hit is old/new and # above/below threshold. $self->{'_old_hit_names'}->{$hit_name}++; $self->{'_hit_names_below'}->{$hit_name}++ if $hit_signif <= $ithresh; } # Title : _store_hit (private function for internal use only) # Purpose : Collects hit objects into defined sets that are useful for # analyzing PSI-blast results. # These are ultimately added to the iteration object in end_iteration(). # # Strategy: # Primary split = old vs. new # Secondary split = below vs. above threshold # 1. Has this hit occurred in a previous iteration? # 1.1. If yes, was it below threshold? # 1.1.1. If yes, ---> [oldhits_below] # 1.1.2. If no, is it now below threshold? # 1.1.2.1. If yes, ---> [oldhits_newly_below] # 1.1.2.2. If no, ---> [oldhits_not_below] # 1.2. If no, is it below threshold? # 1.2.1. If yes, ---> [newhits_below] # 1.2.2. If no, ---> [newhits_not_below] # 1.2.3. If don't know (no inclusion threshold data), ---> [newhits_unclassified] # Note: As long as there's a default inclusion threshold, # there won't be an unclassified set. # # For the first iteration, it might be nice to detect non-PSI blast reports # and put the hits in the unclassified set. # However, it shouldn't matter where the hits get put for the first iteration # for non-PSI blast reports since they'll get flattened out in the # result and iteration search objects. sub _store_hit { my ($self, $hit, $hit_name, $hit_signif) = @_; my $ithresh = $self->{'_inclusion_threshold'}; # This is the assumption leading to Bug 1986. The assumption here is that # the hit name is unique (and thus new), therefore any subsequent encounters # with a hit containing the same name are filed as old hits. This isn't # always true (see the bug report for a few examples). Adding an explicit # check for the presence of iterations, adding to new hits otherwise. if (exists $self->{'_old_hit_names'}->{$hit_name} && scalar @{$self->{_iterations}}) { if (exists $self->{'_hit_names_below'}->{$hit_name}) { push @{$self->{'_oldhits_below'}}, $hit; } elsif ($hit_signif <= $ithresh) { push @{$self->{'_oldhits_newly_below'}}, $hit; } else { push @{$self->{'_oldhits_not_below'}}, $hit; } } else { if ($hit_signif <= $ithresh) { push @{$self->{'_newhits_below'}}, $hit; } else { push @{$self->{'_newhits_not_below'}}, $hit; } } $self->{'_hitcount'}++; } =head2 start_iteration Title : start_iteration Usage : $handler->start_iteration() Function: Starts an Iteration event cycle Returns : none Args : type of event and associated hashref =cut sub start_iteration { my ($self,$type) = @_; #print STDERR "ISREB: start_iteration()\n"; $self->{'_iteration_count'}++; # Reset arrays for the various classes of hits. # $self->{'_newhits_unclassified'} = []; $self->{'_newhits_below'} = []; $self->{'_newhits_not_below'} = []; $self->{'_oldhits_below'} = []; $self->{'_oldhits_newly_below'} = []; $self->{'_oldhits_not_below'} = []; $self->{'_hitcount'} = 0; return; } =head2 end_iteration Title : end_iteration Usage : $handler->end_iteration() Function: Ends an Iteration event cycle Returns : Bio::Search::Iteration object Args : type of event and associated hashref =cut sub end_iteration { my ($self,$type,$data) = @_; # print STDERR "ISREB: end_iteration()\n"; my %args = map { my $v = $data->{$_}; s/ITERATION//; ($_ => $v); } grep { /^ITERATION/ } keys %{$data}; $args{'-number'} = $self->{'_iteration_count'}; $args{'-oldhits_below'} = $self->{'_oldhits_below'}; $args{'-oldhits_newly_below'} = $self->{'_oldhits_newly_below'}; $args{'-oldhits_not_below'} = $self->{'_oldhits_not_below'}; $args{'-newhits_below'} = $self->{'_newhits_below'}; $args{'-newhits_not_below'} = $self->{'_newhits_not_below'}; $args{'-hit_factory'} = $self->factory('hit'); my $it = $self->factory('iteration')->create_object(%args); push @{$self->{'_iterations'}}, $it; return $it; } =head2 max_significance Usage : $obj->max_significance(); Purpose : Set/Get the P or Expect value used as significance screening cutoff. This is the value of the -signif parameter supplied to new(). Hits with P or E-value above this are skipped. Returns : Scientific notation number with this format: 1.0e-05. Argument : Number (sci notation, float, integer) (when setting) Throws : Bio::Root::BadParameter exception if the supplied argument is : not a valid number. Comments : Screening of significant hits uses the data provided on the : description line. For NCBI BLAST1 and WU-BLAST, this data : is P-value. for NCBI BLAST2 it is an Expect value. =cut sub max_significance { my $self = shift; if (@_) { my $sig = shift; if( $sig =~ /[^\d.e-]/ or $sig <= 0) { $self->throw(-class => 'Bio::Root::BadParameter', -text => "Invalid significance value: $sig\n". "Must be a number greater than zero.", -value=>$sig); } $self->{'_confirm_significance'} = 1; $self->{'_max_significance'} = $sig; } sprintf "%.1e", $self->{'_max_significance'}; } =head2 signif Synonym for L =cut sub signif { shift->max_significance } =head2 min_score Usage : $obj->min_score(); Purpose : Gets the Blast score used as screening cutoff. This is the value of the -score parameter supplied to new(). Hits with scores below this are skipped. Returns : Integer (or undef if not set) Argument : Integer (when setting) Throws : Bio::Root::BadParameter exception if the supplied argument is : not a valid number. Comments : Screening of significant hits uses the data provided on the : description line. =cut sub min_score { my $self = shift; if (@_) { my $score = shift; if( $score =~ /[^\de+]/ or $score <= 0) { $self->throw(-class => 'Bio::Root::BadParameter', -text => "Invalid score value: $score\n". "Must be an integer greater than zero.", -value => $score); } $self->{'_confirm_score'} = 1; $self->{'_min_score'} = $score; } return $self->{'_min_score'}; } =head2 min_bits Usage : $obj->min_bits(); Purpose : Gets the Blast bit score used as screening cutoff. This is the value of the -bits parameter supplied to new(). Hits with bits score below this are skipped. Returns : Integer (or undef if not set) Argument : Integer (when setting) Throws : Bio::Root::BadParameter exception if the supplied argument is : not a valid number. Comments : Screening of significant hits uses the data provided on the : description line. =cut sub min_bits { my $self = shift; if (@_) { my $bits = shift; if( $bits =~ /[^\de+]/ or $bits <= 0) { $self->throw(-class => 'Bio::Root::BadParameter', -text => "Invalid bits value: $bits\n". "Must be an integer greater than zero.", -value => $bits); } $self->{'_confirm_bits'} = 1; $self->{'_min_bits'} = $bits; } return $self->{'_min_bits'}; } =head2 hit_filter Usage : $obj->hit_filter(); Purpose : Set/Get a function reference used for filtering out hits. This is the value of the -hit_filter parameter supplied to new(). Hits that fail to pass the filter are skipped. Returns : Function ref (or undef if not set) Argument : Function ref (when setting) Throws : Bio::Root::BadParameter exception if the supplied argument is : not a function reference. =cut sub hit_filter { my $self = shift; if (@_) { my $func = shift; if(not ref $func eq 'CODE') { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Not a function reference: $func\n". "The -hit_filter parameter must be function reference.", -value=> $func); } $self->{'_hit_filter'} = $func; } return $self->{'_hit_filter'}; } =head2 inclusion_threshold See L. =cut sub inclusion_threshold { my $self = shift; return $self->{'_inclusion_threshold'} = shift if @_; return $self->{'_inclusion_threshold'}; } 1; BioPerl-1.6.923/Bio/SearchIO/megablast.pm000444000765000024 3204012254227332 20120 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::megablast # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::megablast - a driver module for Bio::SearchIO to parse megablast reports (format 0) =head1 SYNOPSIS # do not use this module directly use Bio::SearchIO; # for default format output from megablast my $in = Bio::SearchIO->new(-file => 'file.mbl', -format => 'megablast', -report_format => 0); while( my $r = $in->next_result ) { while( my $hit = $r->next_hit ) { while( my $hsp = $hit->next_hsp ) { } } } =head1 DESCRIPTION Beware! Because of the way megablast report format 0 is coded, realize that score means # gap characters + # mismatches for a HSP. The docs from NCBI regarding FORMAT 0 # 0: Produce one-line output for each alignment, in the form # # 'subject-id'=='[+-]query-id' (s_off q_off s_end q_end) score # # Here subject(query)-id is a gi number, an accession or some other type of # identifier found in the FASTA definition line of the respective sequence. # # + or - corresponds to same or different strand alignment. # # Score for non-affine gapping parameters means the total number of # differences (mismatches + gap characters). For affine case it is the # actual (raw) score of the alignment. FORMAT 1 parsing has not been implemented FORMAT 2 parsing should work with the SearchIO 'blast' parser =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::megablast; use strict; use vars qw(%MAPPING %MODEMAP $DEFAULT_BLAST_WRITER_CLASS); use base qw(Bio::SearchIO); BEGIN { # mapping of MegaBlast terms to Bioperl hash keys %MODEMAP = ('MegaBlastOutput' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); # This should really be done more intelligently, like with # XSLT %MAPPING = ( 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hit_score' => 'HIT-score', 'Hsp_score' => 'HSP-score', 'Hsp_identity' => 'HSP-identical', 'Hsp_positive' => 'HSP-conserved', 'Hit_id' => 'HIT-name', 'MegaBlastOutput_program' => 'RESULT-algorithm_name', 'MegaBlastOutput_query-def'=> 'RESULT-query_name', ); $DEFAULT_BLAST_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; } =head2 new Title : new Usage : my $obj = Bio::SearchIO::blast->new(); Function: Builds a new Bio::SearchIO::blast object Returns : Bio::SearchIO::blast Args : -fh/-file => filehandle/filename to BLAST file -format => 'blast' =cut sub _initialize { my ($self,@args) = @_; $self->SUPER::_initialize(@args); my ($fmt) = $self->_rearrange([qw(REPORT_FORMAT)], @args); $self->throw("Must provide a value for -report_format when initializing a megablast parser") unless defined $fmt ; $self->report_format($fmt); return 1; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result{ my ($self) = @_; local $/ = "\n"; local $_; my $fmt = $self->report_format; my ($lastquery,$lasthit); while( defined($_ = $self->_readline) ) { if( $fmt == 0 ) { if( /^\'(\S+)\'\=\=\'(\+|\-)(\S+)\'\s+ \((\d+)\s+(\d+)\s+(\d+)\s+(\d+)\)\s+ (\d+)/ox ) { my ($hit,$strand,$query, $h_start,$q_start,$h_end,$q_end, $score) = ($1,$2,$3,$4,$5,$6,$7,$8); if( ! defined $lastquery ) { $self->start_element({'Name' => 'MegaBlastOutput'}); $self->element({'Name' => 'MegaBlastOutput_program', 'Data' => 'MEGABLAST'}); $self->element({'Name' => 'MegaBlastOutput_query-def', 'Data' => $query}); } elsif( $lastquery ne $query ) { $self->_pushback($_); $self->end_element({'Name' => 'Hit'}) if( defined $lasthit); $self->end_element({ 'Name' => 'MegaBlastOutput'}); $lasthit = undef; $lastquery = undef; return $self->end_document(); } if( ! defined $lasthit || $lasthit ne $hit ) { $self->end_element({'Name' => 'Hit'}) if( defined $lasthit); $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hit}); } $self->start_element({'Name' => 'Hsp'}); $self->element({'Name' => 'Hsp_score', 'Data' => $score}); # flip flop start/end if strand is < 0 # since strandedness is inferred from the query # because of the way it is coded all queries will # be on the forward strand and hits will be either # +/- # also the NCBI docs state: # 0: Produce one-line output for each alignment, in the form # # 'subject-id'=='[+-]query-id' (s_off q_off s_end q_end) score # # Here subject(query)-id is a gi number, an accession or some other type of # identifier found in the FASTA definition line of the respective sequence. # # + or - corresponds to same or different strand alignment. # # Score for non-affine gapping parameters means the total number of # differences (mismatches + gap characters). For affine case it is the # actual (raw) score of the alignment. # and yet when rev strand hits are made I see # (MBL 2.2.4) # 'Contig634'=='-503384' (1 7941 321 7620) 19 # so the query is on the rev strand and the # subject is on the fwd strand # so I am flip-flopping everything when I see a '-' if( $strand eq '-' ) { ($h_start,$h_end) = ( $h_end,$h_start); ($q_start,$q_end) = ( $q_end,$q_start); } $self->element({'Name' => 'Hsp_hit-from', 'Data' => $h_start}); $self->element({'Name' => 'Hsp_hit-to', 'Data' => $h_end}); $self->element({'Name' => 'Hsp_query-from', 'Data' => $q_start}); $self->element({'Name' => 'Hsp_query-to', 'Data' => $q_end}); # might not be quite right -- need to know length of the HSP my $numid = (abs($q_end - $q_start) - $score); $self->element({'Name' => 'Hsp_identity', 'Data' => $numid}); $self->element({'Name' => 'Hsp_positive', 'Data' => $numid}); $self->end_element({'Name' => 'Hsp'}); $lasthit = $hit; $lastquery = $query; } else { $self->debug("Unknown line in fmt0 parsing: $_"); } } } if( defined $lastquery && $fmt == 0 ) { $self->end_element({'Name' => 'Hit'}) if( defined $lasthit); $self->end_element({ 'Name' => 'MegaBlastOutput'}); return $self->end_document(); } return 0; } =head2 report_format Title : report_format Usage : $obj->report_format($newval) Function: Get/Set the report_format value Returns : value of report_format (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub report_format{ my $self = shift; return $self->{'_report_format'} = shift if @_; return $self->{'_report_format'}; } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently do not care about attributes my $nm = $data->{'Name'}; if( my $type = $MODEMAP{$nm} ) { $self->_mode($type); if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; } if($nm eq 'MegaBlastOutput') { $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $rc; if( my $type = $MODEMAP{$nm} ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->warn( "unknown nm $nm ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( $nm eq 'MegaBlastOutput' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; return unless defined $data->{'Data'}; $self->{'_last_data'} = $data->{'Data'}; } =head2 _mode Title : _mode Usage : $obj->_mode($newval) Function: Example : Returns : value of _mode Args : newvalue (optional) =cut sub _mode{ my ($self,$value) = @_; if( defined $value) { $self->{'_mode'} = $value; } return $self->{'_mode'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handles a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } 1; BioPerl-1.6.923/Bio/SearchIO/psl.pm000444000765000024 4447412254227314 16775 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::psl # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::psl - A parser for PSL output (UCSC) =head1 SYNOPSIS use Bio::SearchIO; my $parser = Bio::SearchIO->new(-file => 'file.psl', -format => 'psl'); while( my $result = $parser->next_result ) { } =head1 DESCRIPTION This is a SearchIO driver for PSL format. PSL format is documented here: http://genome.ucsc.edu/goldenPath/help/customTrack.html#PSL By default it assumes PSL output came from BLAT you can override that by specifying -program_name =E 'BLASTZ' when initializing the SearchIO object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::psl; use vars qw(%MAPPING %MODEMAP $DEFAULT_WRITER_CLASS $DefaultProgramName); use strict; use Bio::Search::HSP::HSPFactory; use Bio::Search::Hit::HitFactory; use Bio::Search::Result::ResultFactory; $DefaultProgramName = 'BLAT'; $DEFAULT_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; # mapping of terms to Bioperl hash keys %MODEMAP = ( 'PSLOutput' => 'result', 'Result' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_mismatches' => 'HSP-mismatches', 'Hsp_qgapblocks' => 'HSP-query_gapblocks', 'Hsp_hgapblocks' => 'HSP-hit_gapblocks', 'Hsp_gaps' => 'HSP-hsp_gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame' => 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_signif' => 'HIT-significance', 'Hit_score' => 'HIT-score', 'Hit_bits' => 'HIT-bits', 'PSLOutput_program' => 'RESULT-algorithm_name', 'PSLOutput_version' => 'RESULT-algorithm_version', 'PSLOutput_query-def' => 'RESULT-query_name', 'PSLOutput_query-len' => 'RESULT-query_length', 'PSLOutput_query-acc' => 'RESULT-query_accession', 'PSLOutput_querydesc' => 'RESULT-query_description', 'PSLOutput_db' => 'RESULT-database_name', 'PSLOutput_db-len' => 'RESULT-database_entries', 'PSLOutput_db-let' => 'RESULT-database_letters', ); use base qw(Bio::SearchIO); =head2 new Title : new Usage : my $obj = Bio::SearchIO::psl->new(); Function: Builds a new Bio::SearchIO::psl object Returns : an instance of Bio::SearchIO::psl Args : =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ($pname) = $self->_rearrange( [qw(PROGRAM_NAME)], @args ); $self->program_name( $pname || $DefaultProgramName ); $self->_eventHandler->register_factory( 'result', Bio::Search::Result::ResultFactory->new( -type => 'Bio::Search::Result::GenericResult' ) ); $self->_eventHandler->register_factory( 'hit', Bio::Search::Hit::HitFactory->new( -type => 'Bio::Search::Hit::GenericHit' ) ); $self->_eventHandler->register_factory( 'hsp', Bio::Search::HSP::HSPFactory->new( -type => 'Bio::Search::HSP::PSLHSP' ) ); } =head2 next_result Title : next_result Usage : my $result = $parser->next_result Function: Parse the next result from the data stream Returns : L or undef if no more results Args : none =cut sub next_result { my ($self) = @_; my ( $lastquery, $lasthit ); local $/ = "\n"; local $_; # skip over any header lines while( defined($_ = $self->_readline) and ! /^\d+\s+\d+\s+/ ) {} $self->_pushback($_); # now start the main parsing loop while ( defined( $_ = $self->_readline ) ) { my ( $matches, $mismatches, $rep_matches, $n_count, $q_num_insert, $q_base_insert, $t_num_insert, $t_base_insert, $strand, $q_name, $q_length, $q_start, $q_end, $t_name, $t_length, $t_start, $t_end, $block_count, $block_sizes, $q_starts, $t_starts ) = split; $q_length > 0 or $self->throw("parse error, invalid query length '$q_length'"); my $score = sprintf( "%.2f", 100 * ( $matches + $mismatches + $rep_matches ) / $q_length ); # this is overall percent identity... my $match_total = $matches + $mismatches + $rep_matches; $match_total > 0 or $self->throw("parse error, matches + mismatches + rep_matches must be > 0!"); my $percent_id = sprintf("%.2f", 100 * ( $matches + $rep_matches ) / $match_total ); # Remember Jim's code is 0 based if ( defined $lastquery && $lastquery ne $q_name ) { $self->end_element( { 'Name' => 'Hit' } ); $self->end_element( { 'Name' => 'PSLOutput' } ); $self->_pushback($_); return $self->end_document; } elsif ( !defined $lastquery ) { $self->{'_result_count'}++; $self->start_element( { 'Name' => 'PSLOutput' } ); $self->element( { 'Name' => 'PSLOutput_program', 'Data' => $self->program_name } ); $self->element( { 'Name' => 'PSLOutput_query-def', 'Data' => $q_name } ); $self->element( { 'Name' => 'PSLOutput_query-len', 'Data' => $q_length } ); $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_id', 'Data' => $t_name } ); $self->element( { 'Name' => 'Hit_len', 'Data' => $t_length } ); $self->element( { 'Name' => 'Hit_score', 'Data' => $score } ); } elsif ( $lasthit ne $t_name ) { $self->end_element( { 'Name' => 'Hit' } ); $self->start_element( { 'Name' => 'Hit' } ); $self->element( { 'Name' => 'Hit_id', 'Data' => $t_name } ); $self->element( { 'Name' => 'Hit_len', 'Data' => $t_length } ); $self->element( { 'Name' => 'Hit_score', 'Data' => $score } ); } my $identical = $matches + $rep_matches; $self->start_element( { 'Name' => 'Hsp' } ); $self->element( { 'Name' => 'Hsp_score', 'Data' => $score } ); $self->element( { 'Name' => 'Hsp_identity', 'Data' => $identical } ); $self->element( { 'Name' => 'Hsp_positive', 'Data' => $identical } ); $self->element( { 'Name' => 'Hsp_mismatches', 'Data' => $mismatches } ); $self->element( { 'Name' => 'Hsp_gaps', 'Data' => $q_base_insert + $t_base_insert } ); # query gaps are the number of target inserts and vice-versa $self->element( { 'Name' => 'Hsp_querygaps', 'Data' => $t_base_insert } ); $self->element( { 'Name' => 'Hsp_hitgaps', 'Data' => $q_base_insert } ); if ( $strand eq '+' ) { $self->element( { 'Name' => 'Hsp_query-from', 'Data' => $q_start + 1 } ); $self->element( { 'Name' => 'Hsp_query-to', 'Data' => $q_end } ); } else { $self->element( { 'Name' => 'Hsp_query-to', 'Data' => $q_start + 1 } ); $self->element( { 'Name' => 'Hsp_query-from', 'Data' => $q_end } ); } my $hsplen = ($q_base_insert + $t_base_insert + abs( $t_end - $t_start ) + abs( $q_end - $q_start ))/2; $self->element( { 'Name' => 'Hsp_hit-from', 'Data' => $t_start + 1 } ); $self->element( { 'Name' => 'Hsp_hit-to', 'Data' => $t_end } ); $self->element( { 'Name' => 'Hsp_align-len', 'Data' => $hsplen } ); # cleanup trailing commas in some output $block_sizes =~ s/\,$//; $q_starts =~ s/\,$//; $t_starts =~ s/\,$//; my @blocksizes = split( /,/, $block_sizes ); # block sizes my @qstarts = split( /,/, $q_starts ); # starting position of each block # in query my @tstarts = split( /,/, $t_starts ); # starting position of each block # in target my ( @qgapblocks, @hgapblocks ); for ( my $i = 0 ; $i < $block_count ; $i++ ) { if ( $strand eq '+' ) { push @qgapblocks, [ $qstarts[$i] + 1, $blocksizes[$i] ]; } else { push @qgapblocks, [ $q_length - $qstarts[$i], $blocksizes[$i] ]; } push @hgapblocks, [ $tstarts[$i] + 1, $blocksizes[$i] ]; } $self->element( { 'Name' => 'Hsp_qgapblocks', 'Data' => \@qgapblocks } ); $self->element( { 'Name' => 'Hsp_hgapblocks', 'Data' => \@hgapblocks } ); $self->end_element( { 'Name' => 'Hsp' } ); $lastquery = $q_name; $lasthit = $t_name; } if ( defined $lasthit || defined $lastquery ) { $self->end_element( { 'Name' => 'Hit' } ); $self->end_element( { 'Name' => 'Result' } ); return $self->end_document; } } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if ( my $type = $MODEMAP{$nm} ) { $self->_mode($type); if ( $self->_eventHandler->will_handle($type) ) { my $func = 'start_'.lc $type; $self->_eventHandler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( $nm eq 'PSLOutput' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_mode'} = ''; } } =head2 end_element Title : end_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : return value from the associated end_$type event handler Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $rc; # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if ( my $type = $MODEMAP{$nm} ) { if ( $self->_eventHandler->will_handle($type) ) { my $func = 'end_'.lc $type; $rc = $self->_eventHandler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { $self->warn( __PACKAGE__ . "::end_element: unknown nm '$nm', ignoring\n" ); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $nm && defined $MODEMAP{$nm} && $MODEMAP{$nm} eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; return unless ( defined $data->{'Data'} ); if ( $data->{'Data'} =~ /^\s+$/ ) { return unless $data->{'Name'} =~ /Hsp\_(midline|qseq|hseq)/; } if ( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/ ) { $self->{'_last_hspdata'}->{ $data->{'Name'} } .= $data->{'Data'}; } $self->{'_last_data'} = $data->{'Data'}; } =head2 _mode Title : _mode Usage : $obj->_mode($newval) Function: Example : Returns : value of _mode Args : newvalue (optional) =cut sub _mode { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_mode'} = $value; } return $self->{'_mode'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if (!defined $name && !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { if ( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handles a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_mode'} = ''; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ( $self, @args ) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } =head2 program_name Title : program_name Usage : $obj->program_name($newval) Function: Get/Set the program name Returns : value of program_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub program_name { my $self = shift; $self->{'program_name'} = shift if @_; return $self->{'program_name'} || $DefaultProgramName; } 1; BioPerl-1.6.923/Bio/SearchIO/rnamotif.pm000444000765000024 6003012254227331 17777 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::rnamotif # # Please direct questions and support issues to # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::rnamotif - SearchIO-based RNAMotif parser =head1 SYNOPSIS # do not call this module directly. Use Bio::SearchIO. =head1 DESCRIPTION This is a highly experimental SearchIO-based parser for output from the rnamotif program (one of the programs in the RNAMotif suite). It currently parses only raw rnamotif output for RNAMotif versions 3.0 and above; older versions may work but will not be supported. rmfmt output will not be supported at this time. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields-at-uiuc-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::rnamotif; use strict; use base qw(Bio::SearchIO); my %MODEMAP = ( 'Result' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); my %MAPPING = ( # commented out tags have not been assigned 'Hsp_score' => 'HSP-score', 'Hsp_custom-data' => 'HSP-custom_score', # rnamotif has no evalue # descriptor has no start, end; same as hit start, end 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', # descriptor has no start, end 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_align-len' => 'HSP-hsp_length', # build this from scratch, simple WUSS-format 'Hsp_structure' => 'HSP-meta', 'Hsp_stranded' => 'HSP-stranded', # not supported for RNAMotif 'Hit_id' => 'HIT-name', 'Hit_accession' => 'HIT-accession', 'Hit_gi' => 'HIT-ncbi_gi', 'Hit_def' => 'HIT-description', 'Hit_score' => 'HIT-score', # best HSP score 'RNAMotif_program' => 'RESULT-algorithm_name', # get/set 'RNAMotif_version' => 'RESULT-algorithm_version', # get/set 'RNAMotif_query-def'=> 'RESULT-query_name', # get/set # No length (query is a descriptor) 'RNAMotif_query-acc'=> 'RESULT-query_accession', # get/set 'RNAMotif_querydesc'=> 'RESULT-query_description', # get/set 'RNAMotif_db' => 'RESULT-database_name', # get/set ); # use structure_delimiters to set custom delimiters my @VALID_SYMBOLS = qw(5-prime 3-prime single-strand unknown); my %STRUCTURE_SYMBOLS = ( '5-prime' => '<', '3-prime' => '>', 'single-strand' => '.', 'unknown' => '?' # may add more for quartets, triplets ); my $DEFAULT_VERSION = '3.0.3'; =head2 new Title : new Usage : my $obj = Bio::SearchIO->new(); Function: Builds a new Bio::SearchIO::rnamotif object Returns : Bio::SearchIO::rnamotif parser Args : -fh/-file => RNAMotif filename -format => 'rnamotif' -model => query model (or descriptor, in this case) -database => database name (default undef) -query_acc => query accession (default undef) -hsp_minscore => minimum HSP score cutoff -hsp_maxscore => maximum HSP score cutoff -symbols => hash ref of structure symbols to use (default symbols in %STRUCTURE_SYMBOLS hash) =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my ($version, $model, $database, $maxcutoff, $mincutoff, $seqdistance, $accession, $symbols) = $self->_rearrange([qw(VERSION MODEL DATABASE HSP_MAXSCORE HSP_MINSCORE SEQ_DISTANCE QUERY_ACC SYMBOLS)],@args); my $handler = $self->_eventHandler; $handler->register_factory( 'result', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::GenericResult', -interface => 'Bio::Search::Result::ResultI', -verbose => $self->verbose ) ); $handler->register_factory( 'hit', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::ModelHit', -interface => 'Bio::Search::Hit::HitI', -verbose => $self->verbose ) ); $handler->register_factory( 'hsp', Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::ModelHSP', -interface => 'Bio::Search::HSP::HSPI', -verbose => $self->verbose ) ); $model && $self->model($model); $database && $self->database($database); $accession && $self->query_accession($accession); $version ||= $DEFAULT_VERSION; $self->algorithm_version($version); $self->throw("Cannot define both a minimal and maximal cutoff") if (defined($mincutoff) && defined($maxcutoff)); defined($mincutoff) && $self->hsp_minscore($mincutoff); defined($maxcutoff) && $self->hsp_maxscore($maxcutoff); $symbols ||= \%STRUCTURE_SYMBOLS; $self->structure_symbols($symbols); } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; my $seentop = 0; local $/ = "\n"; local $_; my ($rm, $d, $descriptor, $file, $oktobuild); my ($hitid, $hitdesc, $hspid, $lastid, $lastscore); my $sprintf; # user-determined Result data my ($accession, $db, $model) = ($self->query_accession, $self->database, $self->model); # HSP building options my $hsp_min = $self->hsp_minscore; my $hsp_max = $self->hsp_maxscore; my $version = $self->algorithm_version; my $laststart; my $verbose = $self->verbose; # cache for speed? $self->start_document(); PARSER: while ( defined( my $line = $self->_readline ) ) { # start of report next if $line =~ m{^\s+$}; if (index($line,'#RM') == 0) { if (index($line,'#RM scored') == 0 ) { if ($seentop) { $self->_pushback($line); last PARSER; } $self->start_element({'Name' => 'Result'}); $self->element_hash({ 'RNAMotif_program' => 'rnamotif', 'RNAMotif_version' => $version, 'RNAMotif_query-acc' => $accession, 'RNAMotif_db' => $db }); $seentop = 1; #$self->debug("Start result\n"); } elsif (index($line,'#RM descr') == 0) { ($rm, $d, $descriptor) = split ' ', $line, 3; # toss $rm, $d; keep $descr chomp $descriptor; $self->{'_descriptor'} = $descriptor; $self->element( {'Name' => 'RNAMotif_querydesc', 'Data' => $descriptor} ); } elsif(index($line,'#RM dfile') == 0) { ($rm, $d, $file) = split ' ', $line, 3; # toss $rm, $d; keep $file chomp $file; $self->element( {'Name' => 'RNAMotif_query-def', 'Data' => $file} ); } else { $self->debug("Unrecognized line: $line"); } } elsif ($line =~ s{^>}{}) { chomp $line; ($hitid, $hitdesc) = split ' ',$line,2; if ($self->within_element('hit') && ($hitid ne $lastid)) { $self->element( {'Name' => 'Hit_score', 'Data' => $lastscore} ) if $lastscore; $self->end_element({'Name' => 'Hit'}); $self->start_element({'Name' => 'Hit'}); } elsif (!$self->within_element('hit')) { $self->start_element({'Name' => 'Hit'}); } my ($gi, $acc, $ver) = $self->_get_seq_identifiers($hitid); $self->element_hash({ 'Hit_id' => $hitid, 'Hit_gi' => $gi, 'Hit_accession' => $ver ? "$acc.$ver" : $acc ? $acc : $hitid, 'Hit_def' => $hitdesc} ); $lastid = $hitid; } elsif ($line =~ m{^(\S+)\s+(.+?)\s+(\d+)\s+(\d+)\s+(\d+)\s(.*)$}xm) { chomp $line; my $hspid = $1; my ($score, $strand, $start, $length , $seq) = ($2, $3, $4, $5, $6); $score *= 1; # implicitly cast any odd '0.000' to float # sanity check ids unless ($hitid eq $hspid) { $self->throw("IDs do not match!"); } # check score for possible sprintf data, mark as such, cache result if (!defined($sprintf)) { if ($score =~ m{[^0-9.-]+}gxms) { if (defined $hsp_min || defined $hsp_max ) { $self->warn("HSP data likely contains custom score; ". "ignoring min/maxscore"); } $sprintf = $oktobuild = 1; } else { $sprintf = 0; } } if (!$sprintf) { if (($hsp_min && $score <= $hsp_min) || ($hsp_max && ($score >= $hsp_max)) ) { # do not build HSP $oktobuild = 0; } else { $oktobuild = 1; # store best hit score based on the hsp min/maxscore only if (defined $hsp_min && $score > $hsp_min) { $lastscore = $score if !$lastscore || $score > $lastscore; } elsif (defined $hsp_max && $score < $hsp_max) { $lastscore = $score if !$lastscore || $score < $lastscore; } } } # build HSP if ($oktobuild) { my $end; # calculate start/end if( $strand==0 ) { $end = $start + $length -1; } else { $end = $start - $length + 1; } my ($rna, $meta) = $self->_motif2meta($seq, $descriptor); $self->start_element({'Name' => 'Hsp'}); my $rnalen = $rna =~ tr{ATGCatgc}{ATGCatgc}; $self->element_hash({ 'Hsp_stranded' => 'HIT', 'Hsp_hseq' => $rna, 'Hsp_query-from' => 1, 'Hsp_query-to' =>length($rna), 'Hsp_hit-from' => $start, 'Hsp_hit-to' => $end, 'Hsp_structure' => $meta, 'Hsp_align-len' => length($rna), 'Hsp_score' => $sprintf ? undef : $score, 'Hsp_custom-data' => $sprintf ? $score : undef, }); $self->end_element({'Name' => 'Hsp'}); $oktobuild = 0 if (!$sprintf); } } } if ($self->within_element('hit')) { $self->element( {'Name' => 'Hit_score', 'Data' => $lastscore} ) if $lastscore; $self->end_element( { 'Name' => 'Hit' } ); } if ($seentop) { $self->end_element( { 'Name' => 'Result' } ); } return $self->end_document(); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element { my ( $self, $data ) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "start_%s", lc $type ); $self->_eventHandler->$func( $data->{'Attributes'} ); } unshift @{ $self->{'_elements'} }, $type; } if ( defined $type && $type eq 'result' ) { $self->{'_values'} = {}; $self->{'_result'} = undef; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys, 'Data' and 'Name' =cut sub end_element { my ( $self, $data ) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if ($type) { if ( $self->_eventHandler->will_handle($type) ) { my $func = sprintf( "end_%s", lc $type ); $rc = $self->_eventHandler->$func( $self->{'_reporttype'}, $self->{'_values'} ); } my $lastelem = shift @{ $self->{'_elements'} }; } elsif ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $self->{'_last_data'}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $self->{'_last_data'}; } } else { $self->debug("unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if ( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convenience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element { my ( $self, $data ) = @_; # simple data calls (%MAPPING) do not need start_element $self->characters($data); $self->end_element($data); } =head2 element_hash Title : element Usage : $eventhandler->element_hash({'Hsp_hit-from' => $start, 'Hsp_hit-to' => $end, 'Hsp_score' => $lastscore}); Function: Convenience method that takes multiple simple data elements and maps to appropriate parameters Returns : none Args : Hash ref with the mapped key (in %MAPPING) and value =cut sub element_hash { my ($self, $data) = @_; $self->throw("Must provide data hash ref") if !$data || !ref($data); for my $nm (sort keys %{$data}) { next if $data->{$nm} && $data->{$nm} =~ m{^\s*$}o; if ( $MAPPING{$nm} ) { if ( ref( $MAPPING{$nm} ) =~ /hash/i ) { my $key = ( keys %{ $MAPPING{$nm} } )[0]; $self->{'_values'}->{$key}->{ $MAPPING{$nm}->{$key} } = $data->{$nm}; } else { $self->{'_values'}->{ $MAPPING{$nm} } = $data->{$nm}; } } } } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters { my ( $self, $data ) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/o ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element { my ( $self, $name ) = @_; return 0 if ( !defined $name || !defined $self->{'_elements'} || scalar @{ $self->{'_elements'} } == 0 ); foreach ( @{ $self->{'_elements'} } ) { return 1 if ( $_ eq $name ); } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'within' because 'in' only tests its immediate parent. Returns : boolean Args : string element name =cut sub in_element { my ( $self, $name ) = @_; return 0 if !defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name ); } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'} = undef; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document { my ($self) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } =head2 descriptor Title : descriptor Usage : my $descr = $parser->descriptor(); Function: Get/Set descriptor name. Some versions of RNAMotif do not add the descriptor name to the output. This also overrides any name found while parsing. Returns : String (name of model) Args : [optional] String (name of model) =cut sub descriptor { my $self = shift; return $self->{'_descriptor'} = shift if @_; return $self->{'_descriptor'}; } =head2 model Title : model Usage : my $model = $parser->model(); Function: Get/Set model; Infernal currently does not output the model name (Rfam ID) Returns : String (name of model) Args : [optional] String (name of model) Note : this is a synonym for descriptor() =cut sub model { shift->descriptor(@_) } =head2 database Title : database Usage : my $database = $parser->database(); Function: Get/Set database; Infernal currently does not output the database name Returns : String (database name) Args : [optional] String (database name) =cut sub database { my $self = shift; return $self->{'_database'} = shift if @_; return $self->{'_database'}; } =head2 query_accession Title : query_accession Usage : my $acc = $parser->query_accession(); Function: Get/Set query (model) accession; RNAMotif currently does not output the accession number Returns : String (accession) Args : [optional] String (accession) =cut sub query_accession { my $self = shift; return $self->{'_query_accession'} = shift if @_; return $self->{'_query_accession'}; } =head2 algorithm_version Title : algorithm_version Usage : my $ver = $parser->algorithm_version(); Function: Get/Set algorithm version (not defined in RNAMotif output) Returns : String (accession) Args : [optional] String (accession) =cut sub algorithm_version { my $self = shift; return $self->{'_algorithm'} = shift if @_; return $self->{'_algorithm'}; } =head2 hsp_minscore Title : hsp_minscore Usage : my $cutoff = $parser->hsp_minscore(); Function: Get/Set min score cutoff (for generating Hits/HSPs). Returns : score (number) Args : [optional] score (number) Note : Cannot be set along with hsp_maxscore() =cut sub hsp_minscore { my ($self, $score) = shift; $self->throw('Minscore not set to a number') if ($score && $score !~ m{[0-9.]+}); return $self->{'_hsp_minscore'} = shift if @_; return $self->{'_hsp_minscore'}; } =head2 hsp_maxscore Title : hsp_maxscore Usage : my $cutoff = $parser->hsp_maxscore(); Function: Get/Set max score cutoff (for generating Hits/HSPs). Returns : score (number) Args : [optional] score (number) Note : Cannot be set along with hsp_minscore() =cut sub hsp_maxscore { my ($self, $score) = shift; $self->throw('Maxscore not set to a number') if ($score && $score !~ m{[0-9.]+}); return $self->{'_hsp_maxscore'} = shift if @_; return $self->{'_hsp_maxscore'}; } =head2 structure_symbols Title : structure_symbols Usage : my $hashref = $parser->structure_symbols(); Function: Get/Set RNA structure symbols Returns : Hash ref of delimiters (5' stem, 3' stem, single-strand, etc) : default = < (5-prime) > (3-prime) . (single-strand) ? (unknown) Args : Hash ref of substitute delimiters, using above keys. =cut sub structure_symbols { my ($self, $delim) = @_; if ($delim) { if (ref($delim) =~ m{HASH}) { my %data = %{ $delim }; for my $d (@VALID_SYMBOLS) { if ( exists $data{$d} ) { $self->{'_delimiter'}->{$d} = $data{$d}; } } } else { $self->throw("Args to helix_delimiters() should be in a hash reference"); } } return $self->{'_delimiter'}; } #Private methods =head2 _motif2meta Title : _motif2meta Usage : my ($rna, $meta) = $parser->_motif2meta($str, $descr); Function: Creates meta string from sequence and descriptor Returns : array of sequence, meta strings Args : Array of string data and descriptor data Note: This is currently a quick and simple way of making simple RNA structures (stem-loops, helices, etc) from RNAMotif descriptor data in the output file. It does not currently work with pseudoknots, triplets, G-quartets, or other more complex RNA structural motifs. =cut sub _motif2meta { my ($self, $str, $descriptor) = @_; my ($rna, $meta); my @desc_el = split ' ',$descriptor; my @seq_el = split ' ',$str; my $symbol = $self->structure_symbols(); if ($#desc_el != $#seq_el) { $self->throw("Descriptor elements and seq elements do not match"); } while (@desc_el) { my $struct; my ($seq, $motif) = (shift @seq_el, shift @desc_el); $struct = (index($motif,'h5') == 0) ? $symbol->{'5-prime'} : (index($motif,'h3') == 0) ? $symbol->{'3-prime'} : (index($motif,'ss') == 0) ? $symbol->{'single-strand'} : (index($motif,'ctx')== 0) ? $symbol->{'single-strand'} : $symbol->{'unknown'}; $meta .= $struct x (length($seq)); $rna .= $seq; } return ($rna, $meta); } 1; BioPerl-1.6.923/Bio/SearchIO/SearchResultEventBuilder.pm000444000765000024 3246712254227331 23112 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::SearchResultEventBuilder # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::SearchResultEventBuilder - Event Handler for SearchIO events. =head1 SYNOPSIS # Do not use this object directly, this object is part of the SearchIO # event based parsing system. =head1 DESCRIPTION This object handles Search Events generated by the SearchIO classes and build appropriate Bio::Search::* objects from them. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::SearchResultEventBuilder; use vars qw(%KNOWNEVENTS); use strict; use Bio::Factory::ObjectFactory; use base qw(Bio::Root::Root Bio::SearchIO::EventHandlerI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::SearchResultEventBuilder->new(); Function: Builds a new Bio::SearchIO::SearchResultEventBuilder object Returns : Bio::SearchIO::SearchResultEventBuilder Args : -hsp_factory => Bio::Factory::ObjectFactoryI -hit_factory => Bio::Factory::ObjectFactoryI -result_factory => Bio::Factory::ObjectFactoryI See L for more information =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($hspF,$hitF,$resultF) = $self->_rearrange([qw(HSP_FACTORY HIT_FACTORY RESULT_FACTORY)],@args); $self->register_factory('hsp', $hspF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::HSP::GenericHSP', -interface => 'Bio::Search::HSP::HSPI')); $self->register_factory('hit', $hitF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Hit::GenericHit', -interface => 'Bio::Search::Hit::HitI')); $self->register_factory('result', $resultF || Bio::Factory::ObjectFactory->new( -type => 'Bio::Search::Result::GenericResult', -interface => 'Bio::Search::Result::ResultI')); return $self; } # new comes from the superclass =head2 will_handle Title : will_handle Usage : if( $handler->will_handle($event_type) ) { ... } Function: Tests if this event builder knows how to process a specific event Returns : boolean Args : event type name =cut sub will_handle{ my ($self,$type) = @_; # these are the events we recognize return ( $type eq 'hsp' || $type eq 'hit' || $type eq 'result' ); } =head2 SAX methods =cut =head2 start_result Title : start_result Usage : $handler->start_result($resulttype) Function: Begins a result event cycle Returns : none Args : Type of Report =cut sub start_result { my ($self,$type) = @_; $self->{'_resulttype'} = $type; $self->{'_hits'} = []; $self->{'_hsps'} = []; $self->{'_hitcount'} = 0; return; } =head2 end_result Title : end_result Usage : my @results = $parser->end_result Function: Finishes a result handler cycle Returns : A Bio::Search::Result::ResultI Args : none =cut # this is overridden by IteratedSearchResultEventBuilder # so keep that in mind when debugging sub end_result { my ($self,$type,$data) = @_; if( defined $data->{'runid'} && $data->{'runid'} !~ /^\s+$/ ) { if( $data->{'runid'} !~ /^lcl\|/) { $data->{"RESULT-query_name"}= $data->{'runid'}; } else { ($data->{"RESULT-query_name"}, $data->{"RESULT-query_description"}) = split(/\s+/,$data->{"RESULT-query_description"},2); } if( my @a = split(/\|/,$data->{'RESULT-query_name'}) ) { my $acc = pop @a ; # this is for accession |1234|gb|AAABB1.1|AAABB1 # this is for |123|gb|ABC1.1| $acc = pop @a if( ! defined $acc || $acc =~ /^\s+$/); $data->{"RESULT-query_accession"}= $acc; } delete $data->{'runid'}; } my %args = map { my $v = $data->{$_}; s/RESULT//; ($_ => $v); } grep { /^RESULT/ } keys %{$data}; $args{'-algorithm'} = uc( $args{'-algorithm_name'} || $data->{'RESULT-algorithm_name'} || $type); $args{'-hits'} = $self->{'_hits'}; my $result = $self->factory('result')->create_object(%args); $result->hit_factory($self->factory('hit')); $self->{'_hits'} = []; return $result; } =head2 start_hsp Title : start_hsp Usage : $handler->start_hsp($name,$data) Function: Begins processing a HSP event Returns : none Args : type of element associated data (hashref) =cut sub start_hsp { my ($self,@args) = @_; return; } =head2 end_hsp Title : end_hsp Usage : $handler->end_hsp() Function: Finish processing a HSP event Returns : none Args : type of event and associated hashref =cut sub end_hsp { my ($self,$type,$data) = @_; if( defined $data->{'runid'} && $data->{'runid'} !~ /^\s+$/ ) { if( $data->{'runid'} !~ /^lcl\|/) { $data->{"RESULT-query_name"}= $data->{'runid'}; } else { ($data->{"RESULT-query_name"}, $data->{"RESULT-query_description"}) = split(/\s+/,$data->{"RESULT-query_description"},2); } if( my @a = split(/\|/,$data->{'RESULT-query_name'}) ) { my $acc = pop @a ; # this is for accession |1234|gb|AAABB1.1|AAABB1 # this is for |123|gb|ABC1.1| $acc = pop @a if( ! defined $acc || $acc =~ /^\s+$/); $data->{"RESULT-query_accession"}= $acc; } delete $data->{'runid'}; } # this code is to deal with the fact that Blast XML data # always has start < end and one has to infer strandedness # from the frame which is a problem for the Search::HSP object # which expect to be able to infer strand from the order of # of the begin/end of the query and hit coordinates if( defined $data->{'HSP-query_frame'} && # this is here to protect from undefs (( $data->{'HSP-query_frame'} < 0 && $data->{'HSP-query_start'} < $data->{'HSP-query_end'} ) || $data->{'HSP-query_frame'} > 0 && ( $data->{'HSP-query_start'} > $data->{'HSP-query_end'} ) ) ) { # swap ($data->{'HSP-query_start'}, $data->{'HSP-query_end'}) = ($data->{'HSP-query_end'}, $data->{'HSP-query_start'}); } if( defined $data->{'HSP-hit_frame'} && # this is here to protect from undefs ((defined $data->{'HSP-hit_frame'} && $data->{'HSP-hit_frame'} < 0 && $data->{'HSP-hit_start'} < $data->{'HSP-hit_end'} ) || defined $data->{'HSP-hit_frame'} && $data->{'HSP-hit_frame'} > 0 && ( $data->{'HSP-hit_start'} > $data->{'HSP-hit_end'} ) ) ) { # swap ($data->{'HSP-hit_start'}, $data->{'HSP-hit_end'}) = ($data->{'HSP-hit_end'}, $data->{'HSP-hit_start'}); } $data->{'HSP-query_frame'} ||= 0; $data->{'HSP-hit_frame'} ||= 0; # handle Blast 2.1.2 which did not support data member: hsp_align-len $data->{'HSP-query_length'} ||= $data->{'RESULT-query_length'}; $data->{'HSP-query_length'} ||= length ($data->{'HSP-query_seq'} || ''); $data->{'HSP-hit_length'} ||= $data->{'HIT-length'}; $data->{'HSP-hit_length'} ||= length ($data->{'HSP-hit_seq'} || ''); $data->{'HSP-hsp_length'} ||= length ($data->{'HSP-homology_seq'} || ''); my %args = map { my $v = $data->{$_}; s/HSP//; ($_ => $v) } grep { /^HSP/ } keys %{$data}; $args{'-algorithm'} = uc( $args{'-algorithm_name'} || $data->{'RESULT-algorithm_name'} || $type); # copy this over from result $args{'-query_name'} = $data->{'RESULT-query_name'}; $args{'-hit_name'} = $data->{'HIT-name'}; my ($rank) = scalar @{$self->{'_hsps'} || []} + 1; $args{'-rank'} = $rank; $args{'-hit_desc'} = $data->{'HIT-description'}; $args{'-query_desc'} = $data->{'RESULT-query_description'}; my $bits = $args{'-bits'}; my $hsp = \%args; push @{$self->{'_hsps'}}, $hsp; return $hsp; } =head2 start_hit Title : start_hit Usage : $handler->start_hit() Function: Starts a Hit event cycle Returns : none Args : type of event and associated hashref =cut sub start_hit{ my ($self,$type) = @_; $self->{'_hsps'} = []; return; } =head2 end_hit Title : end_hit Usage : $handler->end_hit() Function: Ends a Hit event cycle Returns : Bio::Search::Hit::HitI object Args : type of event and associated hashref =cut sub end_hit{ my ($self,$type,$data) = @_; # Skip process unless there is HSP data or Hit Significance (e.g. a bl2seq with no similarity # gives a hit with the subject, but shows a "no hits found" message instead # of the alignment data and don't have a significance value). # This way, we avoid false positives my @hsp_data = grep { /^HSP/ } keys %{$data}; return unless (scalar @hsp_data > 0 or exists $data->{'HIT-significance'}); my %args = map { my $v = $data->{$_}; s/HIT//; ($_ => $v); } grep { /^HIT/ } keys %{$data}; # I hate special cases, but this is here because NCBI BLAST XML # doesn't play nice and is undergoing mutation -jason if(exists $args{'-name'} && $args{'-name'} =~ /BL_ORD_ID/ ) { ($args{'-name'}, $args{'-description'}) = split(/\s+/,$args{'-description'},2); } $args{'-algorithm'} = uc( $args{'-algorithm_name'} || $data->{'RESULT-algorithm_name'} || $type); $args{'-hsps'} = $self->{'_hsps'}; $args{'-query_len'} = $data->{'RESULT-query_length'}; $args{'-rank'} = $self->{'_hitcount'} + 1; unless( defined $args{'-significance'} ) { if( defined $args{'-hsps'} && $args{'-hsps'}->[0] ) { # use pvalue if present (WU-BLAST), otherwise evalue (NCBI BLAST) $args{'-significance'} = $args{'-hsps'}->[0]->{'-pvalue'} || $args{'-hsps'}->[0]->{'-evalue'}; } } my $hit = \%args; $hit->{'-hsp_factory'} = $self->factory('hsp'); $self->_add_hit($hit); $self->{'_hsps'} = []; return $hit; } # TODO: Optionally impose hit filtering here sub _add_hit { my ($self, $hit) = @_; push @{$self->{'_hits'}}, $hit; $self->{'_hitcount'} = scalar @{$self->{'_hits'}}; } =head2 Factory methods =cut =head2 register_factory Title : register_factory Usage : $handler->register_factory('TYPE',$factory); Function: Register a specific factory for a object type class Returns : none Args : string representing the class and Bio::Factory::ObjectFactoryI See L for more information =cut sub register_factory{ my ($self, $type,$f) = @_; if( ! defined $f || ! ref($f) || ! $f->isa('Bio::Factory::ObjectFactoryI') ) { $self->throw("Cannot set factory to value $f".ref($f)."\n"); } $self->{'_factories'}->{lc($type)} = $f; } =head2 factory Title : factory Usage : my $f = $handler->factory('TYPE'); Function: Retrieves the associated factory for requested 'TYPE' Returns : a Bio::Factory::ObjectFactoryI Throws : Bio::Root::BadParameter if none registered for the supplied type Args : name of factory class to retrieve See L for more information =cut sub factory{ my ($self,$type) = @_; return $self->{'_factories'}->{lc($type)} || $self->throw(-class=>'Bio::Root::BadParameter', -text=>"No factory registered for $type"); } =head2 inclusion_threshold See L. =cut sub inclusion_threshold { my $self = shift; return $self->{'_inclusion_threshold'} = shift if @_; return $self->{'_inclusion_threshold'}; } 1; BioPerl-1.6.923/Bio/SearchIO/SearchWriterI.pm000444000765000024 653712254227320 20665 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::SearchIO::SearchWriterI # # Please direct questions and support issues to # # Cared for by Steve Chervitz # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- =head1 NAME Bio::SearchIO::SearchWriterI - Interface for outputting parsed Search results =head1 SYNOPSIS Bio::SearchIO::SearchWriterI objects cannot be instantiated since this module defines a pure interface. Given an object that implements the Bio::SearchIO::SearchWriterI interface, you can do the following things with it: print $writer->to_string( $result_obj, @args ); =head1 DESCRIPTION This module defines abstract methods that all subclasses must implement to be used for outputting results from L objects. =head1 AUTHOR Steve Chervitz Esac-at-bioperl.orgE =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::SearchIO::SearchWriterI; use base qw(Bio::Root::RootI); =head2 to_string Purpose : Produces data for each Search::Result::ResultI in a string. : This is an abstract method. For some useful implementations, : see ResultTableWriter.pm, HitTableWriter.pm, : and HSPTableWriter.pm. Usage : print $writer->to_string( $result_obj, @args ); Argument : $result_obj = A Bio::Search::Result::ResultI object : @args = any additional arguments used by your implementation. Returns : String containing data for each search Result or any of its : sub-objects (Hits and HSPs). Throws : n/a =cut sub to_string { my ($self, $result, @args) = @_; $self->throw_not_implemented; } =head2 start_report Title : start_report Usage : $self->start_report() Function: The method to call when starting a report. You can override it to make a custom header Returns : string Args : none =cut sub start_report { return '' } =head2 end_report Title : end_report Usage : $self->end_report() Function: The method to call when ending a report, this is mostly for cleanup for formats which require you to have something at the end of the document () for HTML Returns : string Args : none =cut sub end_report { return '' } =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference =cut # yes this is an implementation in the interface, # yes it assumes that the underlying class is hash-based # yes that might not be a good idea, but until people # start extending the SearchWriterI interface I think # this is an okay way to go sub filter { my ($self,$method,$code) = @_; return unless $method; $method = uc($method); if( $method ne 'HSP' && $method ne 'HIT' && $method ne 'RESULT' ) { $self->warn("Unknown method $method"); return; } if( $code ) { $self->throw("Must provide a valid code reference") unless ref($code) =~ /CODE/; $self->{$method} = $code; } return $self->{$method}; } 1; BioPerl-1.6.923/Bio/SearchIO/sim4.pm000444000765000024 5247112254227321 17045 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::sim4 # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::sim4 - parser for Sim4 alignments =head1 SYNOPSIS # do not use this module directly, it is a driver for SearchIO use Bio::SearchIO; my $searchio = Bio::SearchIO->new(-file => 'results.sim4', -format => 'sim4'); while ( my $result = $searchio->next_result ) { while ( my $hit = $result->next_hit ) { while ( my $hsp = $hit->next_hsp ) { # ... } } } =head1 DESCRIPTION This is a driver for the SearchIO system for parsing Sim4. http://globin.cse.psu.edu/html/docs/sim4.html Cannot parse LAV or 'exon file' formats (A=2 or A=5) =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Luc Gauthier (lgauthie@hotmail.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::sim4; use strict; use vars qw($DEFAULTFORMAT %ALIGN_TYPES %MAPPING %MODEMAP $DEFAULT_WRITER_CLASS); use POSIX; use Bio::SearchIO::SearchResultEventBuilder; use base qw(Bio::SearchIO); $DEFAULTFORMAT = 'SIM4'; $DEFAULT_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; %ALIGN_TYPES = ( 0 => 'Ruler', 1 => 'Query', 2 => 'Mid', 3 => 'Sbjct' ); %MODEMAP = ( 'Sim4Output' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_query-from'=> 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_qlength' => 'HSP-query_length', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_hlength' => 'HSP-hit_length', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_score' => 'HSP-score', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_identity' => 'HSP-identical', 'Hit_id' => 'HIT-name', 'Hit_desc' => 'HIT-description', 'Hit_len' => 'HIT-length', 'Sim4Output_program' => 'RESULT-algorithm_name', 'Sim4Output_query-def' => 'RESULT-query_name', 'Sim4Output_query-desc'=> 'RESULT-query_description', 'Sim4Output_query-len' => 'RESULT-query_length', ); =head2 new Title : new Usage : my $obj = Bio::SearchIO::sim4->new(); Function: Builds a new Bio::SearchIO::sim4 object Returns : an instance of Bio::SearchIO::sim4 Args : =cut =head2 next_result Title : next_result Usage : my $result = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result { my ($self) = @_; local $/ = "\n"; local $_; # Declare/adjust needed variables $self->{'_last_data'} = ''; my ($seentop, $qfull, @hsps, %alignment, $format); my $hit_direction = 1; # Start document and main element $self->start_document(); $self->start_element({'Name' => 'Sim4Output'}); my $lastquery = ''; # Read output report until EOF while( defined($_ = $self->_readline) ) { # Skip empty lines, chomp filled ones next if( /^\s+$/); chomp; # Make sure sim4 output format is not 2 or 5 if (!$seentop) { if ( /^\#:lav/ ) { $format = 2; } elsif ( /^<|>/ ) { $format = 5; } $self->throw("Bio::SearchIO::sim4 module cannot parse 'type $format' outputs.") if $format; } # This line indicates the start of a new hit if( /^seq1\s*=\s*(\S+),\s+(\d+)/ ) { my ($nm,$desc) = ($1,$2); # First hit? Adjust some parameters if so if ( ! $seentop ) { $self->element( {'Name' => 'Sim4Output_query-def', 'Data' => $nm} ); $self->element( {'Name' => 'Sim4Output_query-len', 'Data' => $desc} ); $seentop = 1; } elsif( $nm ne $lastquery ) { $self->_pushback($_); last; } $lastquery = $nm; # A previous HSP may need to be ended $self->end_element({'Name' => 'Hsp'}) if ( $self->in_element('hsp') ); # A previous hit exists? End it and reset needed variables if ( $self->in_element('hit') ) { foreach (@hsps) { $self->start_element({'Name' => 'Hsp'}); while (my ($name, $data) = each %$_) { $self->{'_currentHSP'}{$name} = $data; } $self->end_element({'Name' => 'Hsp'}); $self->{'_currentHSP'} = {}; } $format = 0 if @hsps; @hsps = (); %alignment = (); $qfull = 0; $hit_direction = 1; $self->end_element({'Name' => 'Hit'}); } # This line describes the current hit... so let's start it } elsif( /^seq2\s*=\s*(\S+)\s+\(>?(\S+)\s*\),\s*(\d+)/ ) { $self->start_element({'Name' => 'Hit'}); $self->element( {'Name' => 'Hit_id', 'Data' => $2} ); $self->element( {'Name' => 'Hit_desc', 'Data' => $1} ); $self->element( {'Name' => 'Hit_len', 'Data' => $3} ); # This line may give additional details about query or subject } elsif( /^>(\S+)\s*(.*)?/ ) { # Previous line was query details... this time subject details if( $qfull ) { $format = 4 if !$format; $self->element({'Name' => 'Hit_desc', 'Data' => $2}); # First line of this type is always query details for a given hit } else { $self->element({'Name' => 'Sim4Output_query-desc', 'Data' => $2}); $qfull = 1; } # This line indicates that subject is on reverse strand } elsif( /^\(complement\)/ ) { $hit_direction = -1; # This line describes the current HSP... so add it to @hsps array } elsif( /^\(?(\d+)\-(\d+)\)?\s+\(?(\d+)\-(\d+)\)?\s+(\d+)/ ) { my ($qs,$qe,$hs,$he,$pid) = ($1,$2,$3,$4,$5); push @hsps, { 'Hsp_query-from' => $qs, 'Hsp_query-to' => $qe, 'Hsp_hit-from' => $hit_direction >= 0 ? $hs : $he, 'Hsp_hit-to' => $hit_direction >= 0 ? $he : $hs, 'Hsp_identity' => 0, #can't determine correctly from raw pct 'Hsp_qlength' => abs($qe - $qs) + 1, 'Hsp_hlength' => abs($he - $hs) + 1, 'Hsp_align-len' => abs($qe - $qs) + 1, }; # This line indicates the start of an alignment block } elsif( /^\s+(\d+)\s/ ) { # Store the current alignment block in a hash for( my $i = 0; defined($_) && $i < 4; $i++ ) { my ($start, $string) = /^\s+(\d*)\s(.*)/; $alignment{$ALIGN_TYPES{$i}} = { start => $start, string => $i != 2 ? $string : (' ' x (length($alignment{$ALIGN_TYPES{$i-1}}{string}) - length($string))) . $string }; $_ = $self->_readline(); } # 'Ruler' line indicates the start of a new HSP if ($alignment{Ruler}{start} == 0) { $format = @hsps ? 3 : 1 if !$format; # A previous HSP may need to be ended $self->end_element({'Name' => 'Hsp'}) if ( $self->in_element('hsp') ); # Start the new HSP and fill the '_currentHSP' property with available details $self->start_element({'Name' => 'Hsp'}); $self->{'_currentHSP'} = @hsps ? shift @hsps : { 'Hsp_query-from' => $alignment{Query}{start}, 'Hsp_hit-from' => $alignment{Sbjct}{start}, } } # Midline indicates a boundary between two HSPs if ( $alignment{Mid}{string} =~ /<|>/g ) { my ($hsp_start, $hsp_end); # Are we currently in an open HSP? if ( $self->in_element('hsp') ) { # Find end pos, adjust 'gaps', 'seq' and 'midline' properties... then close HSP $hsp_end = (pos $alignment{Mid}{string}) - 1; $self->{'_currentHSP'}{'Hsp_querygaps'} += ($self->{'_currentHSP'}{'Hsp_qseq'} .= substr($alignment{Query}{string}, 0, $hsp_end)) =~ s/ /-/g; $self->{'_currentHSP'}{'Hsp_hitgaps'} += ($self->{'_currentHSP'}{'Hsp_hseq'} .= substr($alignment{Sbjct}{string}, 0, $hsp_end)) =~ s/ /-/g; ($self->{'_currentHSP'}{'Hsp_midline'} .= substr($alignment{Mid}{string}, 0, $hsp_end)) =~ s/-/ /g; $self->end_element({'Name' => 'Hsp'}); # Does a new HSP start in the current alignment block? if ( $alignment{Mid}{string} =~ /\|/g ) { # Find start pos, start new HSP and fill it with available details $hsp_start = (pos $alignment{Mid}{string}) - 1; $self->start_element({'Name' => 'Hsp'}); $self->{'_currentHSP'} = @hsps ? shift @hsps : {}; $self->{'_currentHSP'}{'Hsp_querygaps'} += ($self->{'_currentHSP'}{'Hsp_qseq'} = substr($alignment{Query}{string}, $hsp_start)) =~ s/ /-/g; $self->{'_currentHSP'}{'Hsp_hitgaps'} += ($self->{'_currentHSP'}{'Hsp_hseq'} = substr($alignment{Sbjct}{string}, $hsp_start)) =~ s/ /-/g; ($self->{'_currentHSP'}{'Hsp_midline'} = substr($alignment{Mid}{string}, $hsp_start)) =~ s/-/ /g; } } # No HSP is currently open... else { # Find start pos, start new HSP and fill it with available # details then skip to next alignment block $hsp_start = index($alignment{Mid}{string}, '|'); $self->start_element({'Name' => 'Hsp'}); $self->{'_currentHSP'} = @hsps ? shift @hsps : { 'Hsp_query-from' => $alignment{Query}{start}, }; $self->{'_currentHSP'}{'Hsp_querygaps'} += ($self->{'_currentHSP'}{'Hsp_qseq'} = substr($alignment{Query}{string}, $hsp_start)) =~ s/ /-/g; $self->{'_currentHSP'}{'Hsp_hitgaps'} += ($self->{'_currentHSP'}{'Hsp_hseq'} = substr($alignment{Sbjct}{string}, $hsp_start)) =~ s/ /-/g; ($self->{'_currentHSP'}{'Hsp_midline'} = substr($alignment{Mid}{string}, $hsp_start)) =~ s/-/ /g; next; } } # Current alignment block does not contain HSPs boundary else { # Start a new HSP if none is currently open # (Happens if last boundary finished at the very end of previous block) if ( !$self->in_element('hsp') ) { $self->start_element({'Name' => 'Hsp'}); $self->{'_currentHSP'} = @hsps ? shift @hsps : { 'Hsp_query-from' => $alignment{Query}{start}, 'Hsp_hit-from' => $alignment{Sbjct}{start}, } } # Adjust details of the current HSP $self->{'_currentHSP'}{'Hsp_query-from'} ||= $alignment{Query}{start} - length($self->{'_currentHSP'}{'Hsp_qseq'} || ''); $self->{'_currentHSP'}{'Hsp_hit-from'} ||= $alignment{Sbjct}{start} - length($self->{'_currentHSP'}{'Hsp_hseq'} || ''); $self->{'_currentHSP'}{'Hsp_querygaps'} += ($self->{'_currentHSP'}{'Hsp_qseq'} .= $alignment{Query}{string}) =~ s/ /-/g; $self->{'_currentHSP'}{'Hsp_hitgaps'} += ($self->{'_currentHSP'}{'Hsp_hseq'} .= $alignment{Sbjct}{string}) =~ s/ /-/g; ($self->{'_currentHSP'}{'Hsp_midline'} .= $alignment{Mid}{string}) =~ s/-/ /g; } } } # We are done reading the sim4 report, end everything and return if( $seentop ) { # end HSP if needed $self->end_element({'Name' => 'Hsp'}) if ( $self->in_element('hsp') ); # end Hit if needed if ( $self->in_element('hit') ) { foreach (@hsps) { $self->start_element({'Name' => 'Hsp'}); while (my ($name, $data) = each %$_) { $self->{'_currentHSP'}{$name} = $data; } $self->end_element({'Name' => 'Hsp'}); } $self->end_element({'Name' => 'Hit'}); } # adjust result's algorithm name, end output and return $self->element({'Name' => 'Sim4Output_program', 'Data' => $DEFAULTFORMAT . ' (A=' . (defined $format ? $format : '?') . ')'}); $self->end_element({'Name' => 'Sim4Output'}); return $self->end_document(); } return; } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if( $type ) { if( $self->_will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; if($type eq 'result') { $self->{'_values'} = {}; $self->{'_result'}= undef; } } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if( $nm eq 'Hsp' ) { $self->{'_currentHSP'}{'Hsp_midline'} ||= ''; $self->{'_currentHSP'}{'Hsp_query-to'} ||= $self->{'_currentHSP'}{'Hsp_query-from'} + length($self->{'_currentHSP'}{'Hsp_qseq'}) - 1 - $self->{'_currentHSP'}{'Hsp_querygaps'}; $self->{'_currentHSP'}{'Hsp_hit-to'} ||= $self->{'_currentHSP'}{'Hsp_hit-from'} + length($self->{'_currentHSP'}{'Hsp_hseq'}) - 1 - $self->{'_currentHSP'}{'Hsp_hitgaps'}; $self->{'_currentHSP'}{'Hsp_identity'} ||= ($self->{'_currentHSP'}{'Hsp_midline'} =~ tr/\|//); $self->{'_currentHSP'}{'Hsp_qlength'} ||= abs($self->{'_currentHSP'}{'Hsp_query-to'} - $self->{'_currentHSP'}{'Hsp_query-from'}) + 1; $self->{'_currentHSP'}{'Hsp_hlength'} ||= abs($self->{'_currentHSP'}{'Hsp_hit-to'} - $self->{'_currentHSP'}{'Hsp_hit-from'}) + 1; $self->{'_currentHSP'}{'Hsp_align-len'} ||= abs($self->{'_currentHSP'}{'Hsp_query-to'} - $self->{'_currentHSP'}{'Hsp_query-from'}) + 1; $self->{'_currentHSP'}{'Hsp_score'} ||= int(100 * ($self->{'_currentHSP'}{'Hsp_identity'} / $self->{'_currentHSP'}{'Hsp_align-len'})); foreach (keys %{$self->{'_currentHSP'}}) { $self->element({'Name' => $_, 'Data' => delete ${$self->{'_currentHSP'}}{$_}}); } } if( $type = $MODEMAP{$nm} ) { if( $self->_will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->debug( "unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/ ); if( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/ ) { $self->{'_last_hspdata'}->{$data->{'Name'}} .= $data->{'Data'}; } $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_elements'} = []; $self->{'_reporttype'} = $DEFAULTFORMAT; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } sub write_result { my ($self, $blast, @args) = @_; if( not defined($self->writer) ) { $self->warn("Writer not defined. Using a $DEFAULT_WRITER_CLASS"); $self->writer( $DEFAULT_WRITER_CLASS->new() ); } $self->SUPER::write_result( $blast, @args ); } sub result_count { return 1; # can a sim4 report contain more than one result? } sub report_count { shift->result_count } =head2 _will_handle Title : _will_handle Usage : Private method. For internal use only. if( $self->_will_handle($type) ) { ... } Function: Provides an optimized way to check whether or not an element of a given type is to be handled. Returns : Reference to EventHandler object if the element type is to be handled. undef if the element type is not to be handled. Args : string containing type of element. Optimizations: 1. Using the cached pointer to the EventHandler to minimize repeated lookups. 2. Caching the will_handle status for each type that is encountered so that it only need be checked by calling handler->will_handle($type) once. This does not lead to a major savings by itself (only 5-10%). In combination with other optimizations, or for large parse jobs, the savings good be significant. To test against the unoptimized version, remove the parentheses from around the third term in the ternary " ? : " operator and add two calls to $self-E_eventHandler(). =cut sub _will_handle { my ($self,$type) = @_; my $handler = $self->{'_handler_cache'} ||= $self->_eventHandler; my $will_handle = defined($self->{'_will_handle_cache'}->{$type}) ? $self->{'_will_handle_cache'}->{$type} : ($self->{'_will_handle_cache'}->{$type} = $handler->will_handle($type)); return $will_handle ? $handler : undef; } 1; BioPerl-1.6.923/Bio/SearchIO/waba.pm000444000765000024 3161112254227324 17077 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::waba # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::waba - SearchIO parser for Jim Kent WABA program alignment output =head1 SYNOPSIS # do not use this object directly, rather through Bio::SearchIO use Bio::SearchIO; my $in = Bio::SearchIO->new(-format => 'waba', -file => 'output.wab'); while( my $result = $in->next_result ) { while( my $hit = $result->next_hit ) { while( my $hsp = $result->next_hsp ) { } } } =head1 DESCRIPTION This parser will process the waba output (NOT the human readable format). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::waba; use vars qw(%MODEMAP %MAPPING @STATES); use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Search::Result::ResultFactory; use Bio::Search::HSP::HSPFactory; use POSIX; BEGIN { # mapping of NCBI Blast terms to Bioperl hash keys %MODEMAP = ('WABAOutput' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); @STATES = qw(Hsp_qseq Hsp_hseq Hsp_stateseq); %MAPPING = ( 'Hsp_query-from'=> 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_stateseq' => 'HSP-hmmstate_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hit_id' => 'HIT-name', 'Hit_accession' => 'HIT-accession', 'WABAOutput_program' => 'RESULT-algorithm_name', 'WABAOutput_version' => 'RESULT-algorithm_version', 'WABAOutput_query-def'=> 'RESULT-query_name', 'WABAOutput_query-db' => 'RESULT-query_database', 'WABAOutput_db' => 'RESULT-database_name', ); } use base qw(Bio::SearchIO); =head2 new Title : new Usage : my $obj = Bio::SearchIO::waba->new(); Function: Builds a new Bio::SearchIO::waba object Returns : Bio::SearchIO::waba Args : see Bio::SearchIO =cut sub _initialize { my ($self,@args) = @_; $self->SUPER::_initialize(@args); $self->_eventHandler->register_factory('result', Bio::Search::Result::ResultFactory->new(-type => 'Bio::Search::Result::WABAResult')); $self->_eventHandler->register_factory('hsp', Bio::Search::HSP::HSPFactory->new(-type => 'Bio::Search::HSP::WABAHSP')); } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result{ my ($self) = @_; local $/ = "\n"; local $_; my ($curquery,$curhit); my $state = -1; $self->start_document(); my @hit_signifs; while( defined ($_ = $self->_readline )) { if( $state == -1 ) { my ($qid, $qhspid,$qpercent, $junk, $alnlen,$qdb,$qacc,$qstart,$qend,$qstrand, $hitdb,$hacc,$hstart,$hend, $hstrand) = ( /^(\S+)\.(\S+)\s+align\s+ # get the queryid (\d+(\.\d+)?)\%\s+ # get the percentage of\s+(\d+)\s+ # get the length of the alignment (\S+)\s+ # this is the query database (\S+):(\-?\d+)\-(\-?\d+) # The accession:start-end for query \s+([\-\+]) # query strand \s+(\S+)\. # hit db (\S+):(\-?\d+)\-(\-?\d+) # The accession:start-end for hit \s+([\-\+])\s*$ # hit strand /ox ); # Curses. Jim's code is 0 based, the following is to readjust if( $hstart < 0 ) { $hstart *= -1} if( $hend < 0 ) { $hend *= -1} if( $qstart < 0 ) { $qstart *= -1} if( $qend < 0 ) { $qend *= -1} $hstart++; $hend++; $qstart++; $qend++; if( ! defined $alnlen ) { $self->warn("Unable to parse the rest of the WABA alignment info for: '$_'"); last; } $self->{'_reporttype'} = 'WABA'; # hardcoded - only # one type of WABA AFAIK if( defined $curquery && $curquery ne $qid ) { $self->end_element({'Name' => 'Hit'}); $self->_pushback($_); $self->end_element({'Name' => 'WABAOutput'}); return $self->end_document(); } if( defined $curhit && $curhit ne $hacc) { # slight duplication here -- keep these in SYNC $self->end_element({'Name' => 'Hit'}); $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hacc}); $self->element({'Name' => 'Hit_accession', 'Data' => $hacc}); } elsif ( ! defined $curquery ) { $self->start_element({'Name' => 'WABAOutput'}); $self->{'_result_count'}++; $self->element({'Name' => 'WABAOutput_query-def', 'Data' => $qid }); $self->element({'Name' => 'WABAOutput_program', 'Data' => 'WABA'}); $self->element({'Name' => 'WABAOutput_query-db', 'Data' => $qdb}); $self->element({'Name' => 'WABAOutput_db', 'Data' => $hitdb}); # slight duplication here -- keep these N'SYNC ;-) $self->start_element({'Name' => 'Hit'}); $self->element({'Name' => 'Hit_id', 'Data' => $hacc}); $self->element({'Name' => 'Hit_accession', 'Data' => $hacc}); } # strand is inferred by start,end values # in the Result Builder if( $qstrand eq '-' ) { ($qstart,$qend) = ($qend,$qstart); } if( $hstrand eq '-' ) { ($hstart,$hend) = ($hend,$hstart); } $self->start_element({'Name' => 'Hsp'}); $self->element({'Name' => 'Hsp_query-from', 'Data' => $qstart}); $self->element({'Name' => 'Hsp_query-to', 'Data' => $qend}); $self->element({'Name' => 'Hsp_hit-from', 'Data' => $hstart}); $self->element({'Name' => 'Hsp_hit-to', 'Data' => $hend}); $self->element({'Name' => 'Hsp_align-len', 'Data' => $alnlen}); $curquery = $qid; $curhit = $hacc; $state = 0; } elsif( ! defined $curquery ) { $self->warn("skipping because no Hit begin line was recognized\n$_") if( $_ !~ /^\s+$/ ); next; } else { chomp; $self->element({'Name' => $STATES[$state++], 'Data' => $_}); if( $state >= scalar @STATES ) { $state = -1; $self->end_element({'Name' => 'Hsp'}); } } } if( defined $curquery ) { $self->end_element({'Name' => 'Hit'}); $self->end_element({'Name' => 'WABAOutput'}); return $self->end_document(); } return; } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if( my $type = $MODEMAP{$nm} ) { $self->_mode($type); if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; } if($nm eq 'WABAOutput') { $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $rc; # Hsp are sort of weird, in that they end when another # object begins so have to detect this in end_element for now if( $nm eq 'Hsp' ) { foreach ( qw(Hsp_qseq Hsp_midline Hsp_hseq) ) { $self->element({'Name' => $_, 'Data' => $self->{'_last_hspdata'}->{$_}}); } $self->{'_last_hspdata'} = {} } if( my $type = $MODEMAP{$nm} ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->warn( "unknown nm $nm ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( $nm eq 'WABAOutput' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} ); if( $data->{'Data'} =~ /^\s+$/ ) { return unless $data->{'Name'} =~ /Hsp\_(midline|qseq|hseq)/; } if( $self->in_element('hsp') && $data->{'Name'} =~ /Hsp\_(qseq|hseq|midline)/ ) { $self->{'_last_hspdata'}->{$data->{'Name'}} .= $data->{'Data'}; } $self->{'_last_data'} = $data->{'Data'}; } =head2 _mode Title : _mode Usage : $obj->_mode($newval) Function: Example : Returns : value of _mode Args : newvalue (optional) =cut sub _mode{ my ($self,$value) = @_; if( defined $value) { $self->{'_mode'} = $value; } return $self->{'_mode'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handles a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_mode'} = ''; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } =head2 result_count Title : result_count Usage : my $count = $searchio->result_count Function: Returns the number of results we have processed Returns : integer Args : none =cut sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } 1; BioPerl-1.6.923/Bio/SearchIO/wise.pm000444000765000024 3051312254227317 17136 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::wise # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::wise - Parsing of wise output as alignments =head1 SYNOPSIS use Bio::SearchIO; my $parser = Bio::SearchIO->new(-file => 'file.genewise', -format => 'wise', -wisetype=> 'genewise'); while( my $result = $parser->next_result ) {} =head1 DESCRIPTION This object parsers Wise output using Bio::Tools::Genewise or Bio::Tools::Genomewise as a helper. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::wise; use vars qw(%MAPPING %MODEMAP $DEFAULT_WRITER_CLASS); use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SearchIO); %MODEMAP = ('WiseOutput' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); %MAPPING = ( 'Hsp_query-from'=> 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_score' => 'HSP-score', 'Hsp_qlength' => 'HSP-query_length', 'Hsp_hlength' => 'HSP-hit_length', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', #'Hsp_gaps' => 'HSP-hsp_gaps', #'Hsp_hitgaps' => 'HSP-hit_gaps', #'Hsp_querygaps' => 'HSP-query_gaps', 'Hit_id' => 'HIT-name', # 'Hit_desc' => 'HIT-description', # 'Hit_len' => 'HIT-length', 'Hit_score' => 'HIT-score', 'WiseOutput_program' => 'RESULT-algorithm_name', 'WiseOutput_query-def' => 'RESULT-query_name', 'WiseOutput_query-desc'=> 'RESULT-query_description', 'WiseOutput_query-len' => 'RESULT-query_length', ); $DEFAULT_WRITER_CLASS = 'Bio::SearchIO::Writer::HitTableWriter'; use Bio::Tools::Genewise; use Bio::Tools::Genomewise; =head2 new Title : new Usage : my $obj = Bio::SearchIO::wise->new(); Function: Builds a new Bio::SearchIO::wise object Returns : an instance of Bio::SearchIO::wise Args : -wise => a Bio::Tools::Genewise or Bio::Tools::Genomewise object =cut sub _initialize { my ($self,@args) = @_; my ( $wisetype, $file,$fh ) = $self->_rearrange([qw(WISETYPE FILE FH)], @args); my @newargs; while( @args ) { my $a = shift @args; if( $a =~ /FILE|FH/i ) { shift @args; next; } push @newargs, $a, shift @args; } $self->SUPER::_initialize(@newargs); # Optimization: caching the EventHandler # since it's use a lot during the parse. $self->{'_handler_cache'} = $self->_eventHandler; $self->wisetype($wisetype); my @ioargs; if( $fh ) { push @ioargs, ('-fh' => $fh); } elsif( $file ) { push @ioargs, ('-file' => $file); } if( $wisetype =~ /genewise/i ) { $self->wise(Bio::Tools::Genewise->new(@ioargs)); } elsif( $wisetype =~ /genomewise/i ) { $self->wise(Bio::Tools::Genomewise->new(@ioargs)); } else { $self->throw("Must supply a -wisetype to ".ref($self)." which is one of 'genomewise' 'genewise'\n"); } return $self; } =head2 next_result Title : next_result Usage : my $hit = $searchio->next_result; Function: Returns the next Result from a search Returns : Bio::Search::Result::ResultI object Args : none =cut sub next_result{ my ($self) = @_; local $/ = "\n"; local $_; return unless $self->wise; my $prediction = $self->wise->next_prediction; return unless $prediction; $self->{'_reporttype'} = uc $self->wisetype; $self->start_element({'Name' => 'WiseOutput'}); $self->element({'Name' => 'WiseOutput_program', 'Data' => $self->wisetype}); $self->element({'Name' => 'WiseOutput_query-def', 'Data' => $self->wise->_prot_id}); my @transcripts = $prediction->transcripts; foreach my $transcript ( @transcripts ) { my @exons = $transcript->exons; my $protid; $self->start_element({'Name' => 'Hit'}); if( $exons[0]->has_tag('supporting_feature') ) { my ($supporting_feature) = $exons[0]->get_tag_values('supporting_feature'); $protid = $supporting_feature->feature2->seq_id; $self->element({'Name' => 'Hit_id', 'Data' => $self->wise->_target_id}); } $self->element({'Name' => 'Hit_score', 'Data' => $self->wise->_score}); foreach my $exon ( @exons ) { $self->start_element({'Name' => 'Hsp'}); if( $exon->strand < 0 ) { $self->element({'Name' => 'Hsp_query-from', 'Data' => $exon->end}); $self->element({'Name' => 'Hsp_query-to', 'Data' => $exon->start}); } else { $self->element({'Name' => 'Hsp_query-from', 'Data' => $exon->start}); $self->element({'Name' => 'Hsp_query-to', 'Data' => $exon->end}); } $self->element({'Name' => 'Hsp_score', 'Data' => $self->wise->_score}); if( $exon->has_tag('supporting_feature') ) { my ($sf) = $exon->get_tag_values('supporting_feature'); my $protein = $sf->feature2; if( $protein->strand < 0 ) { $self->element({'Name' => 'Hsp_hit-from', 'Data' => $protein->end}); $self->element({'Name' => 'Hsp_hit-to', 'Data' => $protein->start}); } else { $self->element({'Name' => 'Hsp_hit-from', 'Data' => $protein->start}); $self->element({'Name' => 'Hsp_hit-to', 'Data' => $protein->end}); } } $self->element({'Name' => 'Hsp_identity', 'Data' => 0}); $self->element({'Name' => 'Hsp_positive', 'Data' => 0}); $self->end_element({'Name' => 'Hsp'}); } $self->end_element({'Name' => 'Hit'}); } $self->end_element({'Name' => 'WiseOutput'}); return $self->end_document(); } =head2 start_element Title : start_element Usage : $eventgenerator->start_element Function: Handles a start element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; if( $type ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->_eventHandler->$func($data->{'Attributes'}); } unshift @{$self->{'_elements'}}, $type; if($type eq 'result') { $self->{'_values'} = {}; $self->{'_result'}= undef; } } } =head2 end_element Title : start_element Usage : $eventgenerator->end_element Function: Handles an end element event Returns : none Args : hashref with at least 2 keys 'Data' and 'Name' =cut sub end_element { my ($self,$data) = @_; my $nm = $data->{'Name'}; my $type = $MODEMAP{$nm}; my $rc; if( $type = $MODEMAP{$nm} ) { if( $self->_eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->_eventHandler->$func($self->{'_reporttype'}, $self->{'_values'}); } shift @{$self->{'_elements'}}; } elsif( $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } else { $self->debug( "unknown nm $nm, ignoring\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element $self->{'_result'} = $rc if( defined $type && $type eq 'result' ); return $rc; } =head2 element Title : element Usage : $eventhandler->element({'Name' => $name, 'Data' => $str}); Function: Convience method that calls start_element, characters, end_element Returns : none Args : Hash ref with the keys 'Name' and 'Data' =cut sub element{ my ($self,$data) = @_; $self->start_element($data); $self->characters($data); $self->end_element($data); } =head2 characters Title : characters Usage : $eventgenerator->characters($str) Function: Send a character events Returns : none Args : string =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/ ); $self->{'_last_data'} = $data->{'Data'}; } =head2 within_element Title : within_element Usage : if( $eventgenerator->within_element($element) ) {} Function: Test if we are within a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub within_element{ my ($self,$name) = @_; return 0 if ( ! defined $name && ! defined $self->{'_elements'} || scalar @{$self->{'_elements'}} == 0) ; foreach ( @{$self->{'_elements'}} ) { if( $_ eq $name ) { return 1; } } return 0; } =head2 in_element Title : in_element Usage : if( $eventgenerator->in_element($element) ) {} Function: Test if we are in a particular element This is different than 'in' because within can be tested for a whole block. Returns : boolean Args : string element name =cut sub in_element{ my ($self,$name) = @_; return 0 if ! defined $self->{'_elements'}->[0]; return ( $self->{'_elements'}->[0] eq $name) } =head2 start_document Title : start_document Usage : $eventgenerator->start_document Function: Handle a start document event Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= undef; $self->{'_elements'} = []; $self->{'_reporttype'} = 'exonerate'; } =head2 end_document Title : end_document Usage : $eventgenerator->end_document Function: Handles an end document event Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; return $self->{'_result'}; } sub write_result { my ($self, $blast, @args) = @_; if( not defined($self->writer) ) { $self->warn("Writer not defined. Using a $DEFAULT_WRITER_CLASS"); $self->writer( $DEFAULT_WRITER_CLASS->new() ); } $self->SUPER::write_result( $blast, @args ); } sub result_count { my $self = shift; return $self->{'_result_count'}; } sub report_count { shift->result_count } =head2 wise Title : wise Usage : $obj->wise($newval) Function: Get/Set the Wise object parser Returns : value of wise (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub wise{ my $self = shift; return $self->{'wise'} = shift if @_; return $self->{'wise'}; } =head2 wisetype Title : wisetype Usage : $obj->wisetype($newval) Function: Wise program type Returns : value of wisetype (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub wisetype{ my $self = shift; return $self->{'wisetype'} = shift if @_; return $self->{'wisetype'}; } 1; BioPerl-1.6.923/Bio/SearchIO/Writer000755000765000024 012254227336 16727 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/Bio/SearchIO/Writer/BSMLResultWriter.pm000444000765000024 2606512254227322 22577 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::Writer::BSMLResultWriter # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::Writer::BSMLResultWriter - BSML output writer =head1 SYNOPSIS use Bio::SearchIO; my $in = Bio::SearchIO->new(-file => 'result.blast', -format => 'blast'); my $out = Bio::SearchIO->new(-output_format => 'BSMLResultWriter', -file => ">result.bsml"); while( my $r = $in->next_result ) { $out->write_result($r); } =head1 DESCRIPTION This is a writer to produce BSML for a search result. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::Writer::BSMLResultWriter; use strict; use XML::Writer; use IO::String; use base qw(Bio::Root::Root Bio::SearchIO::SearchWriterI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::Writer::BSMLResultWriter->new(); Function: Builds a new Bio::SearchIO::Writer::BSMLResultWriter object Returns : an instance of Bio::SearchIO::Writer::BSMLResultWriter Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 to_string Purpose : Produces data for each Search::Result::ResultI in a string. : This is an abstract method. For some useful implementations, : see ResultTableWriter.pm, HitTableWriter.pm, : and HSPTableWriter.pm. Usage : print $writer->to_string( $result_obj, @args ); Argument : $result_obj = A Bio::Search::Result::ResultI object : @args = any additional arguments used by your implementation. Returns : String containing data for each search Result or any of its : sub-objects (Hits and HSPs). Throws : n/a =cut # this implementation is largely adapted from the Incogen XSLT stylesheet # to convert NCBI BLAST XML to BSML sub to_string { my ($self,$result,$num) = @_; my $str = new IO::String(); my $writer = new XML::Writer(OUTPUT => $str, DATA_INDENT => 1, DATA_MODE => 1); $writer->xmlDecl('UTF-8'); $writer->doctype('Bsml','-//EBI//Labbook, Inc. BSML DTD//EN', 'http://www.labbook.com/dtd/bsml3_1.dtd'); $writer->startTag('Bsml'); $writer->startTag('Definitions'); $writer->startTag('Sequences'); my $reporttype = $result->algorithm; my ($qmoltype,$hmoltype); my $hit = $result->next_hit; my $hsp = $hit->next_hsp; if( $hsp->query->strand == 0 ) { $qmoltype = 'aa' } else { $qmoltype = 'nt' } if( $hsp->hit->strand == 0 ) { $hmoltype = 'aa' } else { $hmoltype = 'nt' } $writer->startTag('Sequence', 'length' => $result->query_length, 'title' => $result->query_name . " ". $result->query_description, 'molecule' => $qmoltype, 'representation' => 'virtual', 'id' => $result->query_name ); # Here we're annotating the Query sequence with hits # hence the Feature-table $writer->startTag('Feature-tables'); $writer->startTag('Feature-table', 'title' => "$reporttype Result", 'class' => $reporttype); my ($hitnum,$hspnum) = (1,1); foreach my $hit ( $result->hits ) { $hspnum = 1; foreach my $hsp ( $hit->hsps ) { $writer->startTag('Feature', 'class' => $reporttype, 'value-type' => 'alignment', 'title' => $hit->name. " ". $hit->description, ); $writer->emptyTag('Interval-loc', 'startpos' => $hsp->query->start, 'endpos' => $hsp->query->end); $writer->emptyTag('Qualifier', 'value-type' => 'score', 'value' => $hsp->score, ); $writer->emptyTag('Qualifier', 'value-type' => 'target-start', 'value' => $hsp->hit->start, ); $writer->emptyTag('Qualifier', 'value-type' => 'target-end', 'value' => $hsp->hit->end, ); $writer->emptyTag('Link', 'title' => 'alignment', 'href' => sprintf("#SPA%d.%d",$hitnum,$hspnum) ); if( $hsp->hit->strand < 0 ) { $writer->emptyTag('Qualifier', 'value-type' => 'target-on-complement', 'value' => 1, ); } $hspnum++; $writer->endTag('Feature'); } $hitnum++; } $writer->endTag('Feature-table'); $writer->endTag('Feature-tables'); $writer->endTag('Sequence'); $writer->endTag('Sequences'); $writer->startTag('Tables'); $writer->startTag('Sequence-search-table', 'search-type' => $reporttype, 'query-length' => $result->query_length); $hitnum = $hspnum = 1; foreach my $hit ( $result->hits ) { $hspnum = 1; foreach my $hsp ( $hit->hsps ) { $writer->startTag('Seq-pair-alignment', 'id' => sprintf("SPA%d.%d",$hitnum,$hspnum), 'method' => join(' ',$result->algorithm), 'compxref' => sprintf("%s:%s", '',$result->query_name), 'refxref' => sprintf("%s:%s", $result->database_name, $hit->name), 'refseq' => $hit->name, 'title' => $result->query_name, 'compseq' => $result->query_name, 'compcaption' => $result->query_name . ' ' . $result->query_description, 'refcaption' => $hit->name . " ". $hit->description, 'totalscore' => $hsp->score, 'refstart' => $hsp->query->start, 'refend' => $hsp->query->end, 'compstart' => $hsp->hit->start, 'compend' => $hsp->hit->end, 'complength' => $hit->length, 'reflength' => $result->query_length); $writer->emptyTag('Attribute', 'name' => 'hit-num', 'content' => $hitnum); $writer->emptyTag('Attribute', 'name' => 'hit-id', 'content' => $hit->name); $writer->emptyTag('Attribute', 'name' => 'hsp-num', 'content' => $hspnum); $writer->emptyTag('Attribute', 'name' => 'hsp-bit-score', 'content' => $hsp->bits); $writer->emptyTag('Attribute', 'name' => 'hsp-evalue', 'content' => $hsp->evalue); $writer->emptyTag('Attribute', 'name' => 'pattern-from', 'content' => 0); $writer->emptyTag('Attribute', 'name' => 'pattern-to', 'content' => 0); $writer->emptyTag('Attribute', 'name' => 'query-frame', 'content' => $hsp->query->frame); $writer->emptyTag('Attribute', 'name' => 'hit-frame', 'content' => $hsp->hit->frame * $hsp->hit->strand); $writer->emptyTag('Attribute', 'name' => 'percent_identity', 'content' => sprintf("%.2f",$hsp->percent_identity)); $writer->emptyTag('Attribute', 'name' => 'percent_similarity', 'content' => sprintf("%.2f",$hsp->frac_conserved('total') * 100)); my $cons = $hsp->frac_conserved('total') * $hsp->length('total'); my $ident = $hsp->frac_identical('total') * $hsp->length('total'); $writer->emptyTag('Attribute', 'name' => 'identity', 'content' => $ident); $writer->emptyTag('Attribute', 'name' => 'positive', 'content' => $cons); $writer->emptyTag('Attribute', 'name' => 'gaps', 'content' => $hsp->gaps('total')); $writer->emptyTag('Attribute', 'name' => 'align-len', 'content' => $hsp->length('total')); $writer->emptyTag('Attribute', 'name' => 'density', 'content' => 0); $writer->emptyTag('Attribute', 'name' => 'hit-len', 'content' => $hit->length); my @extrafields; $writer->emptyTag('Seq-pair-run', 'runlength' => $hsp->hit->length, 'comprunlength' => $hsp->hsp_length, 'complength' => $hsp->hit->length, 'compcomplement'=> $hsp->hit->strand < 0 ? 1 :0, 'refcomplement' => $hsp->query->strand < 0 ? 1 :0, 'refdata' => $hsp->query_string, 'compdata' => $hsp->hit_string, 'alignment' => $hsp->homology_string, ); $hspnum++; $writer->endTag('Seq-pair-alignment'); } $hitnum++; } $writer->endTag('Sequence-search-table'); $writer->endTag('Tables'); $writer->startTag('Research'); $writer->startTag('Analyses'); $writer->startTag('Analysis'); $writer->emptyTag('Attribute', 'name' => 'program', 'content' => $reporttype); $writer->emptyTag('Attribute', 'name' => 'version', 'content' => join(' ',$reporttype, $result->algorithm_version)); $writer->emptyTag('Attribute', 'name' => 'reference', 'content' => $result->algorithm_reference); $writer->emptyTag('Attribute', 'name' => 'db', 'content' => $result->database_name); $writer->emptyTag('Attribute', 'name' => 'db-size', 'content' => $result->database_entries); $writer->emptyTag('Attribute', 'name' => 'db-length', 'content' => $result->database_letters); # $writer->emptyTag('Attribute', # 'name' => 'iter-num', # 'content' => $result->iteration_num); foreach my $attr ( $result->available_parameters ) { $writer->emptyTag('Attribute', 'name' => $attr, 'content' => $result->get_parameter($attr)); } foreach my $attr ( $result->available_statistics ) { $writer->emptyTag('Attribute', 'name' => $attr, 'content' => $result->get_statistic($attr)); } $writer->endTag('Analysis'); $writer->endTag('Analyses'); $writer->endTag('Research'); $writer->endTag('Definitions'); $writer->endTag('Bsml'); $writer->end(); return ${$str->string_ref}; } 1; BioPerl-1.6.923/Bio/SearchIO/Writer/GbrowseGFF.pm000444000765000024 3753112254227327 21406 0ustar00cjfieldsstaff000000000000#----------------------------------------------------------------- # # BioPerl module Bio::SearchIO::Writer::GbrowseGFF.pm # # Please direct questions and support issues to # # Cared for by Mark Wilkinson # # You may distribute this module under the same terms as perl itself #----------------------------------------------------------------- =head1 NAME Bio::SearchIO::Writer::GbrowseGFF - Interface for outputting parsed search results in Gbrowse GFF format =head1 SYNOPSIS use Bio::SearchIO; my $in = Bio::SearchIO->new(-file => 'result.blast', -format => 'blast'); my $out = Bio::SearchIO->new(-output_format => 'GbrowseGFF', -output_cigar => 1, -output_signif => 1, -file => ">result.gff"); while( my $r = $in->next_result ) { $out->write_result($r); } =head1 DESCRIPTION This writer produces Gbrowse flavour GFF from a Search::Result object. =head1 AUTHOR Mark Wilkinson Email markw-at-illuminae-dot-com =head1 CONTRIBUTORS Susan Miller sjmiller at email-DOT-arizon-DOT-edu Jason Stajich jason at bioperl-dot-org =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SearchIO::Writer::GbrowseGFF; use vars qw(%Defaults); use strict; $Defaults{'Prefix'} = 'EST'; $Defaults{'HSPTag'} = 'HSP'; $Defaults{'MatchTag'} = 'match'; use base qw(Bio::Root::Root Bio::SearchIO::SearchWriterI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::Writer::GbrowseGFF->new(@args); Function: Builds a new Bio::SearchIO::Writer::GbrowseGFF object Returns : an instance of Bio::SearchIO::Writer::GbrowseGFF Args : -e_value => 10 : set e_value parsing cutoff (default undef) (note the -e_value flag is deprecated.) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); ($self->{'_evalue'}, $self->{'_cigar'}, $self->{'_prefix'}, $self->{'_signif'} ) = $self->_rearrange([qw(E_VALUE OUTPUT_CIGAR PREFIX OUTPUT_SIGNIF)], @args); $self->{'_evalue'} && warn( "Use of the -e_value argument is deprecated.\nIn future, use \$writer->filter(\"type\", \&code) instead.\n\tparsing will proceed correctly with this e_value\n"); $self->{Gbrowse_HSPID} = 0; $self->{Gbrowse_HITID} = 0; $self->{'_prefix'} ||= $Defaults{'Prefix'}; return $self; } sub _incrementHSP { my ($self) = @_; return ++$self->{Gbrowse_HSPID}; } sub _incrementHIT { my ($self) = @_; return ++$self->{Gbrowse_HITID} } # according to the GFF3 spec: #"match". In addition to the generic "match" #type, there are the subclasses "cDNA_match," "EST_match," #"translated_nucleotide_match," "nucleotide_to_protein_match," and #"nucleotide_motif." =head2 to_string Purpose : Produce the Gbrowse format GFF lines for a Result Usage : print $writer->to_string( $result_obj, @args); Argument : $result_obj = A Bio::Search::Result::ResultI object -version => 1|2|2.5|3 ; the GFF format you want to output (default 3) -match_tag => match|cDNA_match|EST_match|translated_nucleotide_match nucleotide_to_protein_match|nucleotide_motif This is the SO term to be placed in GFF column 3. -prefix => String to prefix the group by, default is EST (see %Defaults class variable) A default can also be set on object init Returns : String containing data for each search Result or any of its : sub-objects (Hits and HSPs). Throws : n/a =cut #-reference => 'hit'|'query' ; whether the hit sequence name or the # query sequence name is used as the # 'reference' sequence (GFF column 1) sub to_string { my ($self, $result, @args) = @_; my ($format, $reference, $match_tag,$hsp_tag, $prefix) = $self->_rearrange([qw (VERSION REFERENCE MATCH_TAG HSP_TAG PREFIX)], @args); $self->warn($reference) if $reference; $reference ||='hit'; # default is that the hit sequence (db sequence) becomes the reference sequence. I think this is fairly typical... $match_tag ||= $Defaults{'MatchTag'}; # default is the generic 'match' tag. $hsp_tag ||= $Defaults{'HSPTag'}; # default is the generic 'hsp' tag. $prefix ||= $self->{'_prefix'}; $self->throw("$reference must be one of 'query', or 'hit'\n") unless $reference; #************* THIS IS WHERE I STOPPED **************** # ***************************************************** #************************************************* $format ||='3'; my $gffio = Bio::Tools::GFF->new(-gff_version => $format); # try to set it # just in case that behaviour changes (at the moment, an invalid format throws an exception, but it might return undef in the future return "" unless defined $gffio; # be kind and don't return undef in case the person is putting teh output directly into a printstatement without testing it # now $gffio is either false, or a valid GFF formatter my ($GFF,$cigar,$score); my ($resultfilter,$hitfilter,$hspfilter) = ( $self->filter('RESULT'), $self->filter('HIT'), $self->filter('HSP')); $result->can('rewind') && $result->rewind(); # ensure we're at the beginning next if (defined $resultfilter && ! (&{$resultfilter}($result)) ); while( my $hit = $result->next_hit ) { if (defined $self->{_evalue}){ next unless ($hit->significance < $self->{_evalue}); } next if( defined $hitfilter && ! &{$hitfilter}($hit) ); # test against filter code my $refseq = $reference eq 'hit' ? $hit->name : $result->query_name; my $seqname = $reference eq 'hit' ? $result->query_name : $hit->name; # hopefully this will be a simple identifier without a full description line!! if ($self->{_signif}) { $score = $hit->significance; } else { $score = $hit->raw_score; } $self->throw("No reference sequence name found in hit; required for GFF (this may not be your fault if your report type does not include reference sequence names)\n") unless $refseq; my $source = $hit->algorithm; $self->throw("No algorithm name found in hit; required for GFF (this may not be your fault if your report type does not include algorithm names)\n") unless $refseq; $self->throw("This module only works on BLASTN reports at this time. Sorry.\n") unless $source eq "BLASTN"; my @plus_hsps; my @minus_hsps; # pre-process the HSP's because we later need to know # the extents of the plus and munus strand # on both the subject and query strands individually my ($qpmin, $qpmax, $qmmin, $qmmax, $spmin, $spmax, $smmin, $smmax); # variables for the plus/minus strand min start and max end to know the full extents of the hit while( my $hsp = $hit->next_hsp ) { if ( defined $self->{_evalue} ) { # for backward compatibility only next unless ($hsp->significance < $self->{_evalue}); } next if( defined $hspfilter && ! &{$hspfilter}($hsp) ); # test against HSP filter if ($hsp->hit->strand >= 0 ){ push @plus_hsps, $hsp; if (defined $qpmin){ # set or reset the minimum and maximum extent of the plus-strand hit $qpmin = $hsp->query->start if $hsp->query->start < $qpmin; $qpmax = $hsp->query->end if $hsp->query->end > $qpmax; $spmin = $hsp->hit->start if $hsp->hit->start < $spmin; $spmax = $hsp->hit->end if $hsp->hit->end > $spmax; } else { $qpmin = $hsp->query->start; $qpmax = $hsp->query->end; $spmin = $hsp->hit->start; $spmax = $hsp->hit->end; } } if ($hsp->hit->strand < 0 ){ push @minus_hsps, $hsp; if (defined $qmmin){ # set or reset the minimum and maximum extent of the minus-strand hit $qmmin = $hsp->query->start if $hsp->query->start < $qmmin; $qmmax = $hsp->query->end if $hsp->query->end > $qmmax; $smmin = $hsp->hit->start if $hsp->hit->start < $smmin; $smmax = $hsp->hit->end if $hsp->hit->end > $smmax; } else { $qmmin = $hsp->query->start; $qmmax = $hsp->query->end; $smmin = $hsp->hit->start; $smmax = $hsp->hit->end; } } #else next if there is no strand, but that makes no sense..?? } next unless (scalar(@plus_hsps) + scalar(@minus_hsps)); # next if no hsps (??) my $ID = $self->_incrementHIT(); # okay, write out the index line for the entire hit before # processing HSP's # unfortunately (or not??), HitI objects do not implement # SeqFeatureI, so we can't just call ->gff_string # as a result, this module is quite brittle to changes # in the GFF format since we are hard-coding the GFF output here :-( if (scalar(@plus_hsps)){ my %tags = ( 'ID' => "match_sequence$ID"); if ($format==2.5) { $tags{'Target'} = "$prefix:$seqname"; $tags{'tstart'} = $qmmin; $tags{'tend'} = $qmmax; } else { $tags{'Target'} = "$prefix:$seqname $qpmin $qpmax"; } if ( $self->{'_cigar'} ) { $tags{'Gap'} = $cigar; } my $feat = Bio::SeqFeature::Generic->new( -seq_id => $refseq, -source_tag => $source, -primary_tag => $match_tag, -start => $spmin, -end => $spmax, -score => $score, -strand => '+', -frame => '.', -tag => \%tags ); my $formatter = Bio::Tools::GFF->new(-gff_version => $format); $GFF .= $feat->gff_string($formatter)."\n"; } if (scalar(@minus_hsps)){ my %tags = ( 'ID' => "match_sequence$ID"); if ($format==2.5) { $tags{'Target'} = "$prefix:$seqname"; $tags{'tstart'} = $qpmax; $tags{'tend'} = $qpmin; } else { $tags{'Target'} = "$prefix:$seqname $qpmax $qpmin"; } my $feat = Bio::SeqFeature::Generic->new( -seq_id => $refseq, -source_tag => $source, -primary_tag => $match_tag, -start => $smmin, -end => $smmax, -score => $score, -strand => '-', -frame => '.', -tag => \%tags ); my $formatter = Bio::Tools::GFF->new(-gff_version => $format); $GFF .= $feat->gff_string($formatter)."\n"; } # process + strand hsps foreach my $hsp (@plus_hsps){ my $hspID = $self->_incrementHSP(); my $qstart = $hsp->query->start; my $qend = $hsp->query->end; my $sstart = $hsp->hit->start; my $send = $hsp->hit->end; my $score = $hsp->score; my %tags = ( 'ID' => "match_hsp$hspID", 'Parent' => "match_sequence$ID" ); if ($format==2.5) { $tags{'Target'} = "$prefix:$seqname"; $tags{'tstart'} = $qstart; $tags{'tend'} = $qend; } else { $tags{'Target'} = "$prefix:$seqname $qstart $qend"; } if ( $self->{'_cigar'} ) { $tags{'Gap'} = $hsp->cigar_string; } my $feat = Bio::SeqFeature::Generic->new( -seq_id => $refseq, -source_tag => $source, -primary_tag => $hsp_tag, -start => $sstart, -end => $send, -score => $score, -strand => '+', -frame => '.', -tag => \%tags ); my $formatter = Bio::Tools::GFF->new(-gff_version => $format); $GFF .= $feat->gff_string($formatter)."\n"; } foreach my $hsp (@minus_hsps) { my $hspID = $self->_incrementHSP(); my $qstart = $hsp->query->start; my $qend = $hsp->query->end; my $sstart = $hsp->hit->start; my $send = $hsp->hit->end; my $score = $hsp->score; my %tags = ( 'ID' => "match_hsp$hspID", 'Parent' => "match_sequence$ID" ); if ($format==2.5) { $tags{'Target'} = "$prefix:$seqname"; $tags{'tstart'} = $qend; $tags{'tend'} = $qstart; } else { $tags{'Target'} = "$prefix:$seqname $qend $qstart"; } if ( $self->{'_cigar'} ) { $tags{'Gap'} = $hsp->cigar_string; } my $feat = Bio::SeqFeature::Generic->new( -seq_id => $refseq, -source_tag => $source, -primary_tag => $hsp_tag, -start => $sstart, -end => $send, -score => $score, -strand => '-', -frame => '.', -tag => \%tags ); my $formatter = Bio::Tools::GFF->new(-gff_version => $format); $GFF .= $feat->gff_string($formatter) ."\n"; } } return $GFF; } sub significance_filter { my ($self,$method,$code) = @_; return unless $method; $method = uc($method); if( $method ne 'HSP' && $method ne 'HIT' && $method ne 'RESULT' ) { $self->warn("Unknown method $method"); return; } if( $code ) { $self->throw("Must provide a valid code reference") unless ref($code) =~ /CODE/; $self->{$method} = $code; } return $self->{$method}; } =head2 start_report Title : start_report Usage : $self->start_report() Function: has no function, returns nothing Returns : empty string Args : none =cut sub start_report { return '' } =head2 end_report Title : end_report Usage : $self->end_report() Function: has no function, returns nothing Returns : empty string Args : none =cut sub end_report { return '' } =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference Note : GbrowseGFF.pm makes no changes to the default filter code =cut 1; BioPerl-1.6.923/Bio/SearchIO/Writer/HitTableWriter.pm000444000765000024 3104612254227317 22336 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::SearchIO::Writer::HitTableWriter - Tab-delimited data for Bio::Search::Hit::HitI objects =head1 SYNOPSIS =head2 Example 1: Using the default columns use Bio::SearchIO; use Bio::SearchIO::Writer::HitTableWriter; my $in = Bio::SearchIO->new(); my $writer = Bio::SearchIO::Writer::HitTableWriter->new(); my $out = Bio::SearchIO->new( -writer => $writer ); while ( my $result = $in->next_result() ) { $out->write_result($result, ($in->report_count - 1 ? 0 : 1) ); } =head2 Example 2: Specifying a subset of columns use Bio::SearchIO; use Bio::SearchIO::Writer::HitTableWriter; my $in = Bio::SearchIO->new(); my $writer = Bio::SearchIO::Writer::HitTableWriter->new( -columns => [qw( query_name query_length hit_name hit_length frac_identical_query expect )] ); my $out = Bio::SearchIO->new( -writer => $writer, -file => ">searchio.out" ); while ( my $result = $in->next_result() ) { $out->write_result($result, ($in->report_count - 1 ? 0 : 1) ); } =head2 Custom Labels You can also specify different column labels if you don't want to use the defaults. Do this by specifying a C<-labels> hash reference parameter when creating the HitTableWriter object. The keys of the hash should be the column number (left-most column = 1) for the label(s) you want to specify. Here's an example: my $writer = Bio::SearchIO::Writer::HitTableWriter->new( -columns => [qw( query_name query_length hit_name hit_length )], -labels => { 1 => 'QUERY_GI', 3 => 'HIT_IDENTIFIER' } ); =head1 DESCRIPTION Bio::SearchIO::Writer::HitTableWriter outputs summary data for each Hit within a search result. Output is in tab-delimited format, one row per Hit. The reason why this is considered summary data is that if a hit contains multiple HSPs, the HSPs will be tiled and the data represents a summary across all HSPs. See below for which columns are affected. See the docs in L for more details on HSP tiling. =head2 Available Columns Here are the columns that can be specified in the C<-columns> parameter when creating a HitTableWriter object. If a C<-columns> parameter is not specified, this list, in this order, will be used as the default. query_name # Sequence identifier of the query. query_length # Full length of the query sequence hit_name # Sequence identifier of the hit hit_length # Full length of the hit sequence round # Round number for hit (PSI-BLAST) expect # Expect value for the alignment score # Score for the alignment (e.g., BLAST score) bits # Bit score for the alignment num_hsps # Number of HSPs (not the "N" value) frac_identical_query* # fraction of identical substitutions in query frac_identical_hit* # fraction of identical substitutions in hit frac_conserved_query* # fraction of conserved substitutions in query frac_conserved_hit* # fraction of conserved substitutions in hit frac_aligned_query* # fraction of the query sequence that is aligned frac_aligned_hit* # fraction of the hit sequence that is aligned length_aln_query* # Length of the aligned portion of the query sequence length_aln_hit* # Length of the aligned portion of the hit sequence gaps_query* # Number of gap characters in the aligned query sequence gaps_hit* # Number of gap characters in the aligned hit sequence gaps_total* # Number of gap characters in the aligned query and hit sequences start_query* # Starting coordinate of the aligned portion of the query sequence end_query* # Ending coordinate of the aligned portion of the query sequence start_hit* # Starting coordinate of the aligned portion of the hit sequence end_hit* # Ending coordinate of the aligned portion of the hit sequence strand_query # Strand of the aligned query sequence strand_hit # Strand of the aligned hit sequence frame # Frame of the alignment (0,1,2) ambiguous_aln # Ambiguous alignment indicator ('qs', 'q', 's') hit_description # Full description of the hit sequence query_description # Full description of the query sequence rank # The rank order of the hit num_hits # Number of hits for the query finding this hit Items marked with a C<*> report data summed across all HSPs after tiling them to avoid counting data from overlapping regions multiple times. For more details about these columns, see the documentation for the corresponding method in Bio::Search::Result::BlastHit. =head1 TODO Figure out the best way to incorporate algorithm-specific score columns. The best route is probably to have algorithm-specific subclasses (e.g., BlastHitTableWriter, FastaHitTableWriter). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 2001, 2002 Steve Chervitz. All Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO L, L =head1 METHODS =cut package Bio::SearchIO::Writer::HitTableWriter; use strict; use base qw(Bio::SearchIO::Writer::ResultTableWriter); # Array fields: column, object, method[/argument], printf format, # column label Methods for result object are defined in # Bio::Search::Result::ResultI. Methods for hit object are defined in # Bio::Search::Hit::HitI. Tech note: If a bogus method is supplied, # it will result in all values to be zero. Don't know why this is. # TODO (maybe): Allow specification of separate mantissa/exponent for # significance data. my %column_map = ( 'query_name' => ['1', 'result', 'query_name', 's', 'QUERY' ], 'query_length' => ['2', 'result', 'query_length', 'd', 'LEN_Q'], 'hit_name' => ['3', 'hit', 'name', 's', 'HIT'], 'hit_length' => ['4', 'hit', 'length', 'd', 'LEN_H'], 'round' => ['5', 'hit', 'iteration', 'd', 'ROUND'], 'expect' => ['6', 'hit', 'significance', '.1e', 'EXPCT'], 'score' => ['7', 'hit', 'raw_score', 'd', 'SCORE'], 'bits' => ['8', 'hit', 'bits', 'd', 'BITS'], 'num_hsps' => ['9', 'hit', 'num_hsps', 'd', 'HSPS'], 'frac_identical_query' => ['10', 'hit', 'frac_identical/query', '.2f', 'FR_IDQ'], 'frac_identical_hit' => ['11', 'hit', 'frac_identical/hit', '.2f', 'FR_IDH'], 'frac_conserved_query' => ['12', 'hit', 'frac_conserved/query', '.2f', 'FR_CNQ'], 'frac_conserved_hit' => ['13', 'hit', 'frac_conserved/hit', '.2f', 'FR_CNH'], 'frac_aligned_query' => ['14', 'hit', 'frac_aligned_query', '.2f', 'FR_ALQ'], 'frac_aligned_hit' => ['15', 'hit', 'frac_aligned_hit', '.2f', 'FR_ALH'], 'length_aln_query' => ['16', 'hit', 'length_aln/query', 'd', 'LN_ALQ'], 'length_aln_hit' => ['17', 'hit', 'length_aln/hit', 'd', 'LN_ALH'], 'gaps_query' => ['18', 'hit', 'gaps/query', 'd', 'GAPS_Q'], 'gaps_hit' => ['19', 'hit', 'gaps/hit', 'd', 'GAPS_H'], 'gaps_total' => ['20', 'hit', 'gaps/total', 'd', 'GAPS_QH'], 'start_query' => ['21', 'hit', 'start/query', 'd', 'START_Q'], 'end_query' => ['22', 'hit', 'end/query', 'd', 'END_Q'], 'start_hit' => ['23', 'hit', 'start/hit', 'd', 'START_H'], 'end_hit' => ['24', 'hit', 'end/hit', 'd', 'END_H'], 'strand_query' => ['25', 'hit', 'strand/query', 's', 'STRND_Q'], 'strand_hit' => ['26', 'hit', 'strand/hit', 's', 'STRND_H'], 'frame' => ['27', 'hit', 'frame', 'd', 'FRAME'], 'ambiguous_aln' => ['28', 'hit', 'ambiguous_aln', 's', 'AMBIG'], 'hit_description' => ['29', 'hit', 'description', 's', 'DESC_H'], 'query_description' => ['30', 'result', 'query_description', 's', 'DESC_Q'], 'rank' => ['31', 'hit', 'rank', 's', 'RANK'], 'num_hits' => ['32', 'result', 'num_hits', 's', 'NUM_HITS'], ); sub column_map { return %column_map } =head2 to_string() Note: this method is not intended for direct use. The SearchIO::write_result() method calls it automatically if the writer is hooked up to a SearchIO object as illustrated in L. Title : to_string() : Usage : print $writer->to_string( $result_obj, [$include_labels] ); : Argument : $result_obj = A Bio::Search::Result::BlastResult object : $include_labels = boolean, if true column labels are included (default: false) : Returns : String containing tab-delimited set of data for each hit : in a BlastResult object. Some data is summed across multiple HSPs. : Throws : n/a =cut #---------------- sub to_string { #---------------- my ($self, $result, $include_labels) = @_; my $str = $include_labels ? $self->column_labels() : ''; my $func_ref = $self->row_data_func; my $printf_fmt = $self->printf_fmt; my ($resultfilter,$hitfilter) = ( $self->filter('RESULT'), $self->filter('HIT') ); if( ! defined $resultfilter || &{$resultfilter}($result) ) { $result->can('rewind') && $result->rewind(); # insure we're at the beginning foreach my $hit($result->hits) { next if( defined $hitfilter && ! &{$hitfilter}($hit)); my @row_data = map { defined $_ ? $_ : 0 } &{$func_ref}($result, $hit); $str .= sprintf "$printf_fmt\n", @row_data; } } $str =~ s/\t\n/\n/gs; return $str; } =head2 end_report Title : end_report Usage : $self->end_report() Function: The method to call when ending a report, this is mostly for cleanup for formats which require you to have something at the end of the document. Nothing for a text message. Returns : string Args : none =cut sub end_report { return ''; } =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference =cut 1; BioPerl-1.6.923/Bio/SearchIO/Writer/HSPTableWriter.pm000444000765000024 3005512254227316 22242 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::SearchIO::Writer::HSPTableWriter - Tab-delimited data for Bio::Search::HSP::HSPI objects =head1 SYNOPSIS =head2 Example 1: Using the default columns use Bio::SearchIO; use Bio::SearchIO::Writer::HSPTableWriter; my $in = Bio::SearchIO->new(); my $writer = Bio::SearchIO::Writer::HSPTableWriter->new(); my $out = Bio::SearchIO->new( -writer => $writer ); while ( my $result = $in->next_result() ) { $out->write_result($result, ($in->report_count - 1 ? 0 : 1) ); } =head2 Example 2: Specifying a subset of columns use Bio::SearchIO; use Bio::SearchIO::Writer::HSPTableWriter; my $in = Bio::SearchIO->new(); my $writer = Bio::SearchIO::Writer::HSPTableWriter->new( -columns => [qw( query_name query_length hit_name hit_length rank frac_identical_query expect )] ); my $out = Bio::SearchIO->new( -writer => $writer, -file => ">searchio.out" ); while ( my $result = $in->next_result() ) { $out->write_result($result, ($in->report_count - 1 ? 0 : 1) ); } =head2 Custom Labels You can also specify different column labels if you don't want to use the defaults. Do this by specifying a C<-labels> hash reference parameter when creating the HSPTableWriter object. The keys of the hash should be the column number (left-most column = 1) for the label(s) you want to specify. Here's an example: my $writer = Bio::SearchIO::Writer::HSPTableWriter->new( -columns => [qw( query_name query_length hit_name hit_length )], -labels => { 1 => 'QUERY_GI', 3 => 'HIT_IDENTIFIER' } ); =head1 DESCRIPTION Bio::SearchIO::Writer::HSPTableWriter generates output at the finest level of granularity for data within a search result. Data for each HSP within each hit in a search result is output in tab-delimited format, one row per HSP. =head2 Available Columns Here are the columns that can be specified in the C<-columns> parameter when creating a HSPTableWriter object. If a C<-columns> parameter is not specified, this list, in this order, will be used as the default. query_name # Sequence identifier of the query. query_length # Full length of the query sequence hit_name # Sequence identifier of the hit hit_length # Full length of the hit sequence round # Round number for hit (PSI-BLAST) rank expect # Expect value for the alignment score # Score for the alignment (e.g., BLAST score) bits # Bit score for the alignment frac_identical_query # fraction of identical substitutions in query frac_identical_hit # fraction of identical substitutions in hit frac_conserved_query # fraction of conserved substitutions in query frac_conserved_hit # fraction of conserved substitutions in hit length_aln_query # Length of the aligned portion of the query sequence length_aln_hit # Length of the aligned portion of the hit sequence gaps_query # Number of gap characters in the aligned query sequence gaps_hit # Number of gap characters in the aligned hit sequence gaps_total # Number of gap characters in the aligned query and hit sequences start_query # Starting coordinate of the aligned portion of the query sequence end_query # Ending coordinate of the aligned portion of the query sequence start_hit # Starting coordinate of the aligned portion of the hit sequence end_hit # Ending coordinate of the aligned portion of the hit sequence strand_query # Strand of the aligned query sequence strand_hit # Strand of the aligned hit sequence frame # Reading frame of the aligned query sequence hit_description # Full description of the hit sequence query_description # Full description of the query sequence frac_identical_total # fraction of total identical substitutions frac_conserved_total # fraction of total conserved substitutions For more details about these columns, see the documentation for the corresponding method in Bio::Search::HSP::HSPI. =head1 TODO Figure out the best way to incorporate algorithm-specific score columns. The best route is probably to have algorith-specific subclasses (e.g., BlastHSPTableWriter, FastaHSPTableWriter). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO Bio::SearchIO::Writer::HitTableWriter Bio::SearchIO::Writer::ResultTableWriter =head1 METHODS =cut package Bio::SearchIO::Writer::HSPTableWriter; use strict; use base qw(Bio::SearchIO::Writer::ResultTableWriter); # Array fields: column, object, method[/argument], printf format, column label # Methods for result object are defined in Bio::Search::Result::ResultI. # Methods for hit object are defined in Bio::Search::Hit::HitI. # Methods for hsp object are defined in Bio::Search::HSP::HSPI. # Tech note: If a bogus method is supplied, it will result in all values to be zero. # Don't know why this is. # TODO (maybe): Allow specification of signif_format (i.e., separate mantissa/exponent) my %column_map = ( 'query_name' => ['1', 'result', 'query_name', 's', 'QUERY' ], 'query_length' => ['2', 'result', 'query_length', 'd', 'LEN_Q'], 'hit_name' => ['3', 'hit', 'name', 's', 'HIT'], 'hit_length' => ['4', 'hit', 'hit_length', 'd', 'LEN_H'], 'round' => ['5', 'hit', 'iteration', 'd', 'ROUND', 'hit'], 'rank' => ['6', 'hsp', 'rank', 'd', 'RANK'], 'expect' => ['7', 'hsp', 'expect', '.1e', 'EXPCT'], 'score' => ['8', 'hsp', 'score', 'd', 'SCORE'], 'bits' => ['9', 'hsp', 'bits', 'd', 'BITS'], 'frac_identical_query' => ['10', 'hsp', 'frac_identical/query', '.2f', 'FR_IDQ'], 'frac_identical_hit' => ['11', 'hsp', 'frac_identical/hit', '.2f', 'FR_IDH'], 'frac_conserved_query' => ['12', 'hsp', 'frac_conserved/query', '.2f', 'FR_CNQ'], 'frac_conserved_hit' => ['13', 'hsp', 'frac_conserved/hit', '.2f', 'FR_CNH'], 'length_aln_query' => ['14', 'hsp', 'length/query', 'd', 'LN_ALQ'], 'length_aln_hit' => ['15', 'hsp', 'length/hit', 'd', 'LN_ALH'], 'gaps_query' => ['16', 'hsp', 'gaps/query', 'd', 'GAPS_Q'], 'gaps_hit' => ['17', 'hsp', 'gaps/hit', 'd', 'GAPS_H'], 'gaps_total' => ['18', 'hsp', 'gaps/total', 'd', 'GAPS_QH'], 'start_query' => ['19', 'hsp', 'start/query', 'd', 'START_Q'], 'end_query' => ['20', 'hsp', 'end/query', 'd', 'END_Q'], 'start_hit' => ['21', 'hsp', 'start/hit', 'd', 'START_H'], 'end_hit' => ['22', 'hsp', 'end/hit', 'd', 'END_H'], 'strand_query' => ['23', 'hsp', 'strand/query', 'd', 'STRND_Q'], 'strand_hit' => ['24', 'hsp', 'strand/hit', 'd', 'STRND_H'], 'frame_hit' => ['25', 'hsp', 'frame/hit', 's', 'FRAME_H'], 'frame_query' => ['26', 'hsp', 'frame/query', 's', 'FRAME_Q'], 'hit_description' => ['27', 'hit', 'hit_description', 's', 'DESC_H'], 'query_description' => ['28', 'result', 'query_description', 's', 'DESC_Q'], 'frac_identical_total' => ['29', 'hsp', 'frac_identical/total', '.2f', 'FR_IDT'], 'frac_conserved_total' => ['30', 'hsp', 'frac_conserved/total', '.2f', 'FR_CNT'], ); sub column_map { return %column_map } =head2 to_string() Note: this method is not intended for direct use. The SearchIO::write_result() method calls it automatically if the writer is hooked up to a SearchIO object as illustrated in L. Title : to_string() : Usage : print $writer->to_string( $result_obj, [$include_labels] ); : Argument : $result_obj = A Bio::Search::Result::ResultI object : $include_labels = boolean, if true column labels are included (default: false) : Returns : String containing tab-delimited set of data for each HSP : in each Hit of the supplied ResultI object. : Throws : n/a =cut sub to_string { my ($self, $result, $include_labels) = @_; my $str = $include_labels ? $self->column_labels() : ''; my ($resultfilter,$hitfilter, $hspfilter) = ( $self->filter('RESULT'), $self->filter('HIT'), $self->filter('HSP')); if( ! defined $resultfilter || &{$resultfilter}($result) ) { my $func_ref = $self->row_data_func; my $printf_fmt = $self->printf_fmt; $result->can('rewind') && $result->rewind(); # insure we're at the beginning while( my $hit = $result->next_hit) { next if( defined $hitfilter && ! &{$hitfilter}($hit) ); $hit->can('rewind') && $hit->rewind;# insure we're at the beginning while(my $hsp = $hit->next_hsp) { next if ( defined $hspfilter && ! &{$hspfilter}($hsp)); my @row_data = &{$func_ref}($result, $hit, $hsp); $str .= sprintf("$printf_fmt\n", map {$_ || ($printf_fmt eq 's' ? '' : 0)} @row_data); } } } $str =~ s/\t\n/\n/gs; return $str; } =head2 end_report Title : end_report Usage : $self->end_report() Function: The method to call when ending a report, this is mostly for cleanup for formats which require you to have something at the end of the document. Nothing for a text message. Returns : string Args : none =cut sub end_report { return ''; } =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference =cut 1; BioPerl-1.6.923/Bio/SearchIO/Writer/HTMLResultWriter.pm000444000765000024 7425712254227327 22621 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::Writer::HTMLResultWriter # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # Changes 2003-07-31 (jason) # Gary has cleaned up the code a lot to produce better looking HTML # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::Writer::HTMLResultWriter - write a Bio::Search::ResultI in HTML =head1 SYNOPSIS use Bio::SearchIO; use Bio::SearchIO::Writer::HTMLResultWriter; my $in = Bio::SearchIO->new(-format => 'blast', -file => shift @ARGV); my $writer = Bio::SearchIO::Writer::HTMLResultWriter->new(); my $out = Bio::SearchIO->new(-writer => $writer); $out->write_result($in->next_result); # to filter your output my $MinLength = 100; # need a variable with scope outside the method sub hsp_filter { my $hsp = shift; return 1 if $hsp->length('total') > $MinLength; } sub result_filter { my $result = shift; return $hsp->num_hits > 0; } my $writer = Bio::SearchIO::Writer::HTMLResultWriter->new (-filters => { 'HSP' => \&hsp_filter} ); my $out = Bio::SearchIO->new(-writer => $writer); $out->write_result($in->next_result); # can also set the filter via the writer object $writer->filter('RESULT', \&result_filter); =head1 DESCRIPTION This object implements the SearchWriterI interface which will produce a set of HTML for a specific L interface. See L for more info on the filter method. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Gary Williams G.Williams@hgmp.mrc.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SearchIO::Writer::HTMLResultWriter; use strict; use vars qw(%RemoteURLDefault $MaxDescLen $DATE $AlignmentLineWidth $Revision); # Object preamble - inherits from Bio::Root::RootI BEGIN { $Revision = '$Id$'; $DATE = localtime(time); %RemoteURLDefault = ( 'PROTEIN' => 'http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=protein&cmd=search&term=%s', 'NUCLEOTIDE' => 'http://www.ncbi.nlm.nih.gov/entrez/query.fcgi?db=nucleotide&cmd=search&term=%s' ); $MaxDescLen = 60; $AlignmentLineWidth = 60; } use base qw(Bio::Root::Root Bio::SearchIO::SearchWriterI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::Writer::HTMLResultWriter->new(); Function: Builds a new Bio::SearchIO::Writer::HTMLResultWriter object Returns : Bio::SearchIO::Writer::HTMLResultWriter Args : -filters => hashref with any or all of the keys (HSP HIT RESULT) which have values pointing to a subroutine reference which will expect to get a -nucleotide_url => URL sprintf string base for the nt sequences -protein_url => URL sprintf string base for the aa sequences -no_wublastlinks => boolean. Do not display WU-BLAST lines even if they are parsed out. Links = (1) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($p,$n,$filters, $nowublastlinks) = $self->_rearrange([qw(PROTEIN_URL NUCLEOTIDE_URL FILTERS NO_WUBLASTLINKS)],@args); $self->remote_database_url('p',$p || $RemoteURLDefault{'PROTEIN'}); $self->remote_database_url('n',$n || $RemoteURLDefault{'NUCLEOTIDE'}); $self->no_wublastlinks(! $nowublastlinks); if( defined $filters ) { if( !ref($filters) =~ /HASH/i ) { $self->warn("Did not provide a hashref for the FILTERS option, ignoring."); } else { while( my ($type,$code) = each %{$filters} ) { $self->filter($type,$code); } } } return $self; } =head2 remote_database_url Title : remote_database_url Usage : $obj->remote_database_url($type,$newval) Function: This should return or set a string that contains a %s which can be filled in with sprintf. Returns : value of remote_database_url Args : $type - 'PROTEIN' or 'P' for protein URLS 'NUCLEOTIDE' or 'N' for nucleotide URLS $value - new value to set [optional] =cut sub remote_database_url{ my ($self,$type,$value) = @_; if( ! defined $type || $type !~ /^(P|N)/i ) { $self->warn("Must provide a type (PROTEIN or NUCLEOTIDE)"); return ''; } $type = uc $1; if( defined $value) { $self->{'remote_database_url'}->{$type} = $value; } return $self->{'remote_database_url'}->{$type}; } =head2 to_string Purpose : Produces data for each Search::Result::ResultI in a string. : This is an abstract method. For some useful implementations, : see ResultTableWriter.pm, HitTableWriter.pm, : and HSPTableWriter.pm. Usage : print $writer->to_string( $result_obj, @args ); Argument : $result_obj = A Bio::Search::Result::ResultI object : @args = any additional arguments used by your implementation. Returns : String containing data for each search Result or any of its : sub-objects (Hits and HSPs). Throws : n/a =cut sub to_string { my ($self,$result,$num) = @_; $num ||= 0; return unless defined $result; my $links = $self->no_wublastlinks; my ($resultfilter,$hitfilter, $hspfilter) = ( $self->filter('RESULT'), $self->filter('HIT'), $self->filter('HSP') ); return '' if( defined $resultfilter && ! &{$resultfilter}($result) ); my ($qtype,$dbtype,$dbseqtype,$type); my $alg = $result->algorithm; # This is actually wrong for the FASTAs I think if( $alg =~ /T(FAST|BLAST)([XY])/i ) { $qtype = $dbtype = 'translated'; $dbseqtype = $type = 'PROTEIN'; } elsif( $alg =~ /T(FAST|BLAST)N/i ) { $qtype = ''; $dbtype = 'translated'; $type = 'PROTEIN'; $dbseqtype = 'NUCLEOTIDE'; } elsif( $alg =~ /(FAST|BLAST)N/i || $alg =~ /(WABA|EXONERATE)/i ) { $qtype = $dbtype = ''; $type = $dbseqtype = 'NUCLEOTIDE'; } elsif( $alg =~ /(FAST|BLAST)P/ || $alg =~ /SSEARCH|HMM(PFAM|SEARCH)/i ) { $qtype = $dbtype = ''; $type = $dbseqtype = 'PROTEIN'; } elsif( $alg =~ /(FAST|BLAST)[XY]/i ) { $qtype = 'translated'; $dbtype = 'PROTEIN'; $dbseqtype = $type = 'PROTEIN'; } else { $self->warn("algorithm was ", $result->algorithm, " couldn't match\n"); } my %baselens = ( 'Sbjct:' => ( $dbtype eq 'translated' ) ? 3 : 1, 'Query:' => ( $qtype eq 'translated' ) ? 3 : 1); my $str; if( $num <= 1 ) { $str = &{$self->start_report}($result); } $str .= &{$self->title}($result); $str .= $result->algorithm_reference || $self->algorithm_reference($result); $str .= &{$self->introduction}($result); $str .= ""; my $hspstr = '

'; if( $result->can('rewind')) { $result->rewind(); # support stream based parsing routines } while( my $hit = $result->next_hit ) { next if( $hitfilter && ! &{$hitfilter}($hit) ); my $nm = $hit->name(); $self->debug( "no $nm for name (".$hit->description(). "\n") unless $nm; my ($gi,$acc) = &{$self->id_parser}($nm); my $p = "%-$MaxDescLen". "s"; my $descsub; if( length($hit->description) > ($MaxDescLen - 3) ) { $descsub = sprintf($p, substr($hit->description,0,$MaxDescLen-3) . "..."); } else { $descsub = sprintf($p,$hit->description); } my $url_desc = &{$self->hit_link_desc()}($self,$hit, $result); my $url_align = &{$self->hit_link_align()}($self,$hit, $result); my @hsps = $hit->hsps; if( ! @hsps ) { # no HSPs so no link $str .= sprintf('

'."\n", $url_desc, $descsub, ($hit->bits ? $hit->bits : (defined $hsps[0] ? $hsps[0]->bits : ' ')), ( $hit->significance ? $hit->significance : (defined $hsps[0] ? $hsps[0]->evalue : ' ')) ); } else { # failover to first HSP if the data does not contain a # bitscore/significance value for the Hit (NCBI XML data for one) $str .= sprintf(''."\n", $url_desc, $descsub, ($hit->bits ? $hit->bits : (defined $hsps[0] ? $hsps[0]->bits : ' ')), $acc, ( $hit->significance ? $hit->significance : (defined $hsps[0] ? $hsps[0]->evalue : ' ')) ); my $dline = &{$self->hit_desc_line}($self, $hit, $result); $hspstr .= "\n". sprintf(">%s %s
Length = %s

\n\n", $url_align, $dline , &_numwithcommas($hit->length)); my $ct = 0; foreach my $hsp (@hsps ) { next if( $hspfilter && ! &{$hspfilter}($hsp) ); $hspstr .= sprintf(" Score = %s bits (%s), Expect = %s", $hsp->bits || $hsp->score, $hsp->score || $hsp->bits, $hsp->evalue || ''); if( defined $hsp->pvalue ) { $hspstr .= ", P = ".$hsp->pvalue; } $hspstr .= "
\n"; $hspstr .= sprintf(" Identities = %d/%d (%d%%)", ( $hsp->frac_identical('total') * $hsp->length('total')), $hsp->length('total'), $hsp->frac_identical('total') * 100); if( $type eq 'PROTEIN' ) { $hspstr .= sprintf(", Positives = %d/%d (%d%%)", ( $hsp->frac_conserved('total') * $hsp->length('total')), $hsp->length('total'), $hsp->frac_conserved('total') * 100); } if( $hsp->gaps ) { $hspstr .= sprintf(", Gaps = %d/%d (%d%%)", $hsp->gaps('total'), $hsp->length('total'), (100 * $hsp->gaps('total') / $hsp->length('total'))); } my ($hframe,$qframe) = ( $hsp->hit->frame, $hsp->query->frame); my ($hstrand,$qstrand) = ($hsp->hit->strand,$hsp->query->strand); # so TBLASTX will have Query/Hit frames # BLASTX will have Query frame # TBLASTN will have Hit frame if( $hstrand || $qstrand ) { $hspstr .= ", Frame = "; my ($signq, $signh); unless( $hstrand ) { $hframe = undef; # if strand is null or 0 then it is protein # and this no frame } else { $signh = $hstrand < 0 ? '-' : '+'; } unless( $qstrand ) { $qframe = undef; # if strand is null or 0 then it is protein } else { $signq =$qstrand < 0 ? '-' : '+'; } # remember bioperl stores frames as 0,1,2 (GFF way) # BLAST reports reports as 1,2,3 so # we have to add 1 to the frame values if( defined $hframe && ! defined $qframe) { $hspstr .= "$signh".($hframe+1); } elsif( defined $qframe && ! defined $hframe) { $hspstr .= "$signq".($qframe+1); } else { $hspstr .= sprintf(" %s%d / %s%d", $signq,$qframe+1, $signh, $hframe+1); } } if($links && $hsp->can('links') && defined(my $lnks = $hsp->links) ) { $hspstr .= sprintf("
\nLinks = %s\n",$lnks); } $hspstr .= "

\n

";

		my @hspvals = ( {'name' => 'Query:',
				 'seq'  => $hsp->query_string,
				 'start' => ($qstrand >= 0 ? 
					     $hsp->query->start : 
					     $hsp->query->end),
					     'end'   => ($qstrand >= 0 ? 
							 $hsp->query->end : 
							 $hsp->query->start),
							 'index' => 0,
							 'direction' => $qstrand || 1
						     },
				{ 'name' => ' 'x6,
				  'seq'  => $hsp->homology_string,
				  'start' => undef,
				  'end'   => undef,
				  'index' => 0,
				  'direction' => 1
				  },
				{ 'name'  => 'Sbjct:',
				  'seq'   => $hsp->hit_string,
				  'start' => ($hstrand >= 0 ? 
					      $hsp->hit->start : 
					      $hsp->hit->end),
					      'end'   => ($hstrand >= 0 ? 
							  $hsp->hit->end : 
							  $hsp->hit->start),
							  'index' => 0, 
							  'direction' => $hstrand || 1
						      }
				);	    


		# let's set the expected length (in chars) of the starting number
		# in an alignment block so we can have things line up
		# Just going to try and set to the largest

		my ($numwidth) = sort { $b <=> $a }(length($hspvals[0]->{'start'}),
						    length($hspvals[0]->{'end'}),
						    length($hspvals[2]->{'start'}),
						    length($hspvals[2]->{'end'}));
		my $count = 0;
		while ( $count < $hsp->length('total') ) {
		    foreach my $v ( @hspvals ) {
			my $piece = substr($v->{'seq'}, $v->{'index'} + $count,
					   $AlignmentLineWidth);
			my $cp = $piece;
			my $plen = scalar ( $cp =~ tr/\-//);
			my ($start,$end) = ('','');
			if( defined $v->{'start'} ) { 
			    $start = $v->{'start'};
			    # since strand can be + or - use the direction
			    # to signify which whether to add or substract from end
			    my $d = $v->{'direction'} * ( $AlignmentLineWidth - $plen )*
				$baselens{$v->{'name'}};
			    if( length($piece) < $AlignmentLineWidth ) {
				$d = (length($piece) - $plen) * $v->{'direction'} * 
				    $baselens{$v->{'name'}};
			    }
			    $end   = $v->{'start'} + $d - $v->{'direction'};
			    $v->{'start'} += $d;
			}
			$hspstr .= sprintf("%s %-".$numwidth."s %s %s\n",
					   $v->{'name'},
					   $start,
					   $piece,
					   $end
					   );
		    }
		    $count += $AlignmentLineWidth;
		    $hspstr .= "\n\n";
		}
		$hspstr .= "
\n"; } } # $hspstr .= "\n"; } $str .= "
Sequences producing significant alignments: Score
(bits)		E
value
%s %s%s%.2g
%s %s%s%.2g

\n".$hspstr; my ($pav, $sav) = ($result->available_parameters, $result->available_statistics); if ($pav || $sav) { # make table of search statistics and end the web page $str .= "

Search Parameters

"; if ($pav) { $str .= "\n"; foreach my $param ( sort $result->available_parameters ) { $str .= "\n"; } $str .= "
ParameterValue
$param". $result->get_parameter($param) ."
"; } if ($sav) { $str .= "

Search Statistics

\n"; foreach my $stat ( sort $result->available_statistics ) { $str .= "\n"; } $str .= "
StatisticValue
$stat". $result->get_statistic($stat). "
"; } } $str .= $self->footer() . "

\n"; return $str; } =head2 hit_link_desc Title : hit_link_desc Usage : $self->hit_link_desc(\&link_function); Function: Get/Set the function which provides an HTML link(s) for the given hit to be used within the description section at the top of the BLAST report. This allows a person reading the report within a web browser to go to one or more database entries for the given hit from the description section. Returns : Function reference Args : Function reference See Also: L =cut sub hit_link_desc{ my( $self, $code ) = @_; if ($code) { $self->{'_hit_link_desc'} = $code; } return $self->{'_hit_link_desc'} || \&default_hit_link_desc; } =head2 default_hit_link_desc Title : default_hit_link_desc Usage : $self->default_hit_link_desc($hit, $result) Function: Provides an HTML link(s) for the given hit to be used within the description section at the top of the BLAST report. This allows a person reading the report within a web browser to go to one or more database entries for the given hit from the description section. Returns : string containing HTML markup ", L, L =cut sub default_hit_link_desc { my($self, $hit, $result) = @_; my $type = ( $result->algorithm =~ /(P|X|Y)$/i ) ? 'PROTEIN' : 'NUCLEOTIDE'; my ($gi,$acc) = &{$self->id_parser}($hit->name); my $url = length($self->remote_database_url($type)) > 0 ? sprintf('%s', sprintf($self->remote_database_url($type),$gi || $acc), $hit->name()) : $hit->name(); return $url; } =head2 hit_link_align Title : hit_link_align Usage : $self->hit_link_align(\&link_function); Function: Get/Set the function which provides an HTML link(s) for the given hit to be used within the HSP alignment section of the BLAST report. This allows a person reading the report within a web browser to go to one or more database entries for the given hit from the alignment section. Returns : string containing HTML markup ", L, L =cut sub hit_link_align { my ($self,$code) = @_; if ($code) { $self->{'_hit_link_align'} = $code; } return $self->{'_hit_link_align'} || \&default_hit_link_desc; } =head2 hit_desc_line Title : hit_desc_line Usage : $self->hit_desc_line(\&link_function); Function: Get/Set the function which provides HTML for the description information from a hit. This allows one to parse the rest of the description and split up lines, add links, etc. Returns : Function reference Args : Function reference See Also: L =cut sub hit_desc_line{ my( $self, $code ) = @_; if ($code) { $self->{'_hit_desc_line'} = $code; } return $self->{'_hit_desc_line'} || \&default_hit_desc_line; } =head2 default_hit_desc_line Title : default_hit_desc_line Usage : $self->default_hit_desc_line($hit, $result) Function: Parses the description line information, splits based on the hidden \x01 between independent descriptions, checks the lines for possible web links, and adds HTML link(s) for the given hit to be used. Returns : string containing HTML markup ", L, L =cut sub default_hit_desc_line { my($self, $hit, $result) = @_; my $type = ( $result->algorithm =~ /(P|X|Y)$/i ) ? 'PROTEIN' : 'NUCLEOTIDE'; my @descs = split /\x01/, $hit->description; #my $descline = join("
",@descs)."
"; my $descline = ''; #return $descline; for my $sec (@descs) { my $url = ''; if ($sec =~ s/((?:gi\|(\d+)\|)? # optional GI (\w+)\|([A-Z\d\.\_]+) # main (\|[A-Z\d\_]+)?) # optional secondary ID//xms) { my ($name, $gi, $db, $acc) = ($1, $2, $3, $4); #$acc ||= ($rest) ? $rest : $gi; $acc =~ s/^\s+(\S+)/$1/; $acc =~ s/(\S+)\s+$/$1/; $url = length($self->remote_database_url($type)) > 0 ? sprintf('%s %s', sprintf($self->remote_database_url($type), $gi || $acc || $db), $name, $sec) : $sec; } else { $url = $sec; } $descline .= "$url
\n"; } return $descline; } =head2 start_report Title : start_report Usage : $index->start_report( CODE ) Function: Stores or returns the code to write the start of the block, the block and the start of the <BODY> block of HTML. Useful for (for instance) specifying alternative HTML if you are embedding the output in an HTML page which you have already started. (For example a routine returning a null string). Returns \&default_start_report (see below) if not set. Example : $index->start_report( \&my_start_report ) Returns : ref to CODE if called without arguments Args : CODE =cut sub start_report { my( $self, $code ) = @_; if ($code) { $self->{'_start_report'} = $code; } return $self->{'_start_report'} || \&default_start_report; } =head2 default_start_report Title : default_start_report Usage : $self->default_start_report($result) Function: The default method to call when starting a report. Returns : sting Args : First argument is a Bio::Search::Result::ResultI =cut sub default_start_report { my ($result) = @_; return sprintf( qq{<HTML> <HEAD> <CENTER><TITLE>Bioperl Reformatted HTML of %s output with Bioperl Bio::SearchIO system },$result->algorithm,$Revision); } =head2 title Title : title Usage : $self->title($CODE) Function: Stores or returns the code to provide HTML for the given BLAST report that will appear at the top of the BLAST report HTML output. Useful for (for instance) specifying alternative routines to write your own titles. Returns \&default_title (see below) if not set. Example : $index->title( \&my_title ) Returns : ref to CODE if called without arguments Args : CODE =cut sub title { my( $self, $code ) = @_; if ($code) { $self->{'_title'} = $code; } return $self->{'_title'} || \&default_title; } =head2 default_title Title : default_title Usage : $self->default_title($result) Function: Provides HTML for the given BLAST report that will appear at the top of the BLAST report HTML output. Returns : string containing HTML markup The default implementation returns

HTML containing text such as: "Bioperl Reformatted HTML of BLASTP Search Report for gi|1786183|gb|AAC73113.1|" Args : First argument is a Bio::Search::Result::ResultI =cut sub default_title { my ($result) = @_; return sprintf( qq{

Bioperl Reformatted HTML of %s Search Report
for %s

}, $result->algorithm, $result->query_name()); } =head2 introduction Title : introduction Usage : $self->introduction($CODE) Function: Stores or returns the code to provide HTML for the given BLAST report detailing the query and the database information. Useful for (for instance) specifying routines returning alternative introductions. Returns \&default_introduction (see below) if not set. Example : $index->introduction( \&my_introduction ) Returns : ref to CODE if called without arguments Args : CODE =cut sub introduction { my( $self, $code ) = @_; if ($code) { $self->{'_introduction'} = $code; } return $self->{'_introduction'} || \&default_introduction; } =head2 default_introduction Title : default_introduction Usage : $self->default_introduction($result) Function: Outputs HTML to provide the query and the database information Returns : string containing HTML Args : First argument is a Bio::Search::Result::ResultI Second argument is string holding literature citation =cut sub default_introduction { my ($result) = @_; return sprintf( qq{ Query= %s %s
(%s letters)

Database: %s

%s sequences; %s total letters

}, $result->query_name, $result->query_description, &_numwithcommas($result->query_length), $result->database_name(), &_numwithcommas($result->database_entries()), &_numwithcommas($result->database_letters()), ); } =head2 end_report Title : end_report Usage : $self->end_report() Function: The method to call when ending a report, this is mostly for cleanup for formats which require you to have something at the end of the document () for HTML Returns : string Args : none =cut sub end_report { return "\n\n"; } # copied from Bio::Index::Fasta # useful here as well =head2 id_parser Title : id_parser Usage : $index->id_parser( CODE ) Function: Stores or returns the code used by record_id to parse the ID for record from a string. Useful for (for instance) specifying a different parser for different flavours of FASTA file. Returns \&default_id_parser (see below) if not set. If you supply your own id_parser subroutine, then it should expect a fasta description line. An entry will be added to the index for each string in the list returned. Example : $index->id_parser( \&my_id_parser ) Returns : ref to CODE if called without arguments Args : CODE =cut sub id_parser { my( $self, $code ) = @_; if ($code) { $self->{'_id_parser'} = $code; } return $self->{'_id_parser'} || \&default_id_parser; } =head2 default_id_parser Title : default_id_parser Usage : $id = default_id_parser( $header ) Function: The default Fasta ID parser for Fasta.pm Returns $1 from applying the regexp /^>\s*(\S+)/ to $header. Returns : ID string The default implementation checks for NCBI-style identifiers in the given string ('gi|12345|AA54321'). For these IDs, it extracts the GI and accession and returns a two-element list of strings (GI, acc). Args : a fasta header line string =cut sub default_id_parser { my ($string) = @_; my ($gi,$acc); if( $string =~ s/gi\|(\d+)\|?// ) { $gi = $1; $acc = $1;} if( $string =~ /(\w+)\|([A-Z\d\.\_]+)(\|[A-Z\d\_]+)?/ ) { $acc = defined $2 ? $2 : $1; } else { $acc = $string; $acc =~ s/^\s+(\S+)/$1/; $acc =~ s/(\S+)\s+$/$1/; } return ($gi,$acc); } sub MIN { $a <=> $b ? $a : $b; } sub MAX { $a <=> $b ? $b : $a; } sub footer { my ($self) = @_; return "

Produced by Bioperl module ".ref($self)." on $DATE
Revision: $Revision
\n" } =head2 algorithm_reference Title : algorithm_reference Usage : my $reference = $writer->algorithm_reference($result); Function: Returns the appropriate Bibliographic reference for the algorithm format being produced Returns : String Args : L to reference =cut sub algorithm_reference { my ($self,$result) = @_; return '' if( ! defined $result || !ref($result) || ! $result->isa('Bio::Search::Result::ResultI')) ; if( $result->algorithm =~ /BLAST/i ) { my $res = $result->algorithm . ' ' . $result->algorithm_version . "

"; if( $result->algorithm_version =~ /WashU/i ) { return $res . "Copyright (C) 1996-2000 Washington University, Saint Louis, Missouri USA.
All Rights Reserved.

Reference: Gish, W. (1996-2000) http://blast.wustl.edu

"; } else { return $res . "Reference: Altschul, Stephen F., Thomas L. Madden, Alejandro A. Schaffer,
Jinghui Zhang, Zheng Zhang, Webb Miller, and David J. Lipman (1997),
\"Gapped BLAST and PSI-BLAST: a new generation of protein database search
programs\", Nucleic Acids Res. 25:3389-3402.

"; } } elsif( $result->algorithm =~ /FAST/i ) { return $result->algorithm . " " . $result->algorithm_version . "
" . "\nReference: Pearson et al, Genomics (1997) 46:24-36

"; } else { return ''; } } # from Perl Cookbook 2.17 sub _numwithcommas { my $num = reverse( $_[0] ); $num =~ s/(\d{3})(?=\d)(?!\d*\.)/$1,/g; return scalar reverse $num; } =head2 Methods Bio::SearchIO::SearchWriterI L inherited methods. =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference =cut =head2 no_wublastlinks Title : no_wublastlinks Usage : $obj->no_wublastlinks($newval) Function: Get/Set boolean value regarding whether or not to display Link = (1) type output in the report output (WU-BLAST only) Returns : boolean Args : on set, new boolean value (a scalar or undef, optional) =cut sub no_wublastlinks{ my $self = shift; return $self->{'no_wublastlinks'} = shift if @_; return $self->{'no_wublastlinks'}; } 1; BioPerl-1.6.923/Bio/SearchIO/Writer/ResultTableWriter.pm000444000765000024 3241112254227317 23065 0ustar00cjfieldsstaff000000000000 =head1 NAME Bio::SearchIO::Writer::ResultTableWriter - Outputs tab-delimited data for each Bio::Search::Result::ResultI object. =head1 SYNOPSIS =head2 Example 1: Using the default columns use Bio::SearchIO; use Bio::SearchIO::Writer::ResultTableWriter; my $in = Bio::SearchIO->new(); my $writer = Bio::SearchIO::Writer::ResultTableWriter->new(); my $out = Bio::SearchIO->new( -writer => $writer ); while ( my $result = $in->next_result() ) { $out->write_result($result, ($in->report_count - 1 ? 0 : 1) ); } =head2 Example 2: Specifying a subset of columns use Bio::SearchIO; use Bio::SearchIO::Writer::ResultTableWriter; my $in = Bio::SearchIO->new(); my $writer = Bio::SearchIO::Writer::ResultTableWriter->new( -columns => [qw( query_name query_length num_hits )] ); my $out = Bio::SearchIO->new( -writer => $writer, -file => ">result.out" ); while ( my $result = $in->next_result() ) { $out->write_result($result, ($in->report_count - 1 ? 0 : 1) ); } =head2 Custom Labels You can also specify different column labels if you don't want to use the defaults. Do this by specifying a C<-labels> hash reference parameter when creating the ResultTableWriter object. The keys of the hash should be the column number (left-most column = 1) for the label(s) you want to specify. Here's an example: my $writer = Bio::SearchIO::Writer::ResultTableWriter->new( -columns => [qw( query_name query_length query_description num_hits)], -labels => { 1 => 'QUERY_GI', 2 => 'QUERY_LENGTH' } ); =head1 DESCRIPTION Bio::SearchIO::Writer::ResultTableWriter outputs data in tab-delimited format for each search result, one row per search result. This is a very coarse-grain level of information since it only includes data stored in the Bio::Search::Result::ResultI object itself and does not include any information about hits or HSPs. You most likely will never use this object but instead will use one of its subclasses: Bio::SearchIO::Writer::HitTableWriter or Bio::SearchIO::Writer::HSPTableWriter. =head2 Available Columns Here are the columns that can be specified in the C<-columns> parameter when creating a ResultTableWriter object. If a C<-columns> parameter is not specified, this list, in this order, will be used as the default. query_name query_length query_description For more details about these columns, see the documentation for the corresponding method in L. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz Esac@bioperl.orgE See L for where to send bug reports and comments. =head1 COPYRIGHT Copyright (c) 2001 Steve Chervitz. All Rights Reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 SEE ALSO L, L =head1 METHODS =cut package Bio::SearchIO::Writer::ResultTableWriter; use strict; use base qw(Bio::Root::Root Bio::SearchIO::SearchWriterI); # Array fields: column, object, method[/argument], printf format, column label # Methods are defined in Bio::Search::Result::ResultI. # Tech note: If a bogus method is supplied, it will result in all values to be zero. # Don't know why this is. my %column_map = ( 'query_name' => ['1', 'result', 'query_name', 's', 'QUERY' ], 'query_length' => ['2', 'result', 'query_length', 'd', 'LEN_Q'], 'query_description' => ['3', 'result', 'query_description', 's', 'DESC_Q'], 'num_hits' => ['4', 'result', 'num_hits', 'd', 'NUM_HITS'], ); sub column_map { return %column_map } sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my( $col_spec, $label_spec, $filters ) = $self->_rearrange( [qw(COLUMNS LABELS FILTERS)], @args); $self->_set_cols( $col_spec ); $self->_set_labels( $label_spec ) if $label_spec; $self->_set_printf_fmt(); $self->_set_row_data_func(); $self->_set_column_labels(); if( defined $filters ) { if( !ref($filters) =~ /HASH/i ) { $self->warn("Did not provide a hashref for the FILTERS option, ignoring."); } else { while( my ($type,$code) = each %{$filters} ) { $self->filter($type,$code); } } } return $self; } # Purpose : Stores the column spec internally. Also performs QC on the # user-supplied column specification. # sub _set_cols { my ($self, $col_spec_ref) = @_; return if defined $self->{'_cols'}; # only set columns once my %map = $self->column_map; if( not defined $col_spec_ref) { print STDERR "\nUsing default column map.\n"; $col_spec_ref = [ map { $_ } sort { $map{$a}->[0] <=> $map{$b}->[0] } keys %map ]; } if( ref($col_spec_ref) eq 'ARRAY') { # printf "%d columns to process\n", scalar(@$col_spec_ref); my @col_spec = @{$col_spec_ref}; while( my $item = shift @col_spec ) { $item = lc($item); if( not defined ($map{$item}) ) { $self->throw(-class =>'Bio::Root::BadParameter', -text => "Unknown column name: $item" ); } push @{$self->{'_cols'}}, $item; #print "pushing on to col $col_num, $inner: $item\n"; } } else { $self->throw(-class =>'Bio::Root::BadParameter', -text => "Can't set columns: not a ARRAY ref", -value => $col_spec_ref ); } } sub _set_printf_fmt { my ($self) = @_; my @cols = $self->columns(); my %map = $self->column_map; my $printf_fmt = ''; foreach my $col ( @cols ) { $printf_fmt .= "\%$map{$col}->[3]\t"; } $printf_fmt =~ s/\\t$//; $self->{'_printf_fmt'} = $printf_fmt; } sub printf_fmt { shift->{'_printf_fmt'} } # Sets the data to be used for the labels. sub _set_labels { my ($self, $label_spec) = @_; if( ref($label_spec) eq 'HASH') { foreach my $col ( sort { $a <=> $b } keys %$label_spec ) { # print "LABEL: $col $label_spec->{$col}\n"; $self->{'_custom_labels'}->{$col} = $label_spec->{$col}; } } else { $self->throw(-class =>'Bio::Root::BadParameter', -text => "Can't set labels: not a HASH ref: $label_spec" ); } } sub _set_column_labels { my $self = shift; my @cols = $self->columns; my %map = $self->column_map; my $printf_fmt = ''; my (@data, $label, @underbars); my $i = 0; foreach my $col( @cols ) { $i++; $printf_fmt .= "\%s\t"; if(defined $self->{'_custom_labels'}->{$i}) { $label = $self->{'_custom_labels'}->{$i}; } else { $label = $map{$col}->[4]; } push @data, $label; push @underbars, '-' x length($label); } $printf_fmt =~ s/\\t$//; my $str = sprintf "$printf_fmt\n", @data; $str =~ s/\t\n/\n/; $str .= sprintf "$printf_fmt\n", @underbars; $str =~ s/\t\n/\n/gs; $self->{'_column_labels'} = $str; } # Purpose : Generate a function that will call the appropriate # methods on the result, hit, and hsp objects to retrieve the column data # specified in the column spec. # # We should only have to go through the column spec once # for a given ResultTableWriter. To permit this, we'll generate code # for a method that returns an array of the data for a row of output # given a result, hit, and hsp object as arguments. # sub _set_row_data_func { my $self = shift; # Now we need to generate a string that can be eval'd to get the data. my @cols = $self->columns(); my %map = $self->column_map; my @data; while( my $col = shift @cols ) { my $object = $map{$col}->[1]; my $method = $map{$col}->[2]; my $arg = ''; if( $method =~ m!(\w+)/(\w+)! ) { $method = $1; $arg = "\"$2\""; } push @data, "\$$object->$method($arg)"; } my $code = join( ",", @data); if( $self->verbose > 0 ) { ## Begin Debugging $self->debug( "Data to print:\n"); foreach( 0..$#data) { $self->debug( " [". ($_+ 1) . "] $data[$_]\n");} $self->debug( "CODE:\n$code\n"); $self->debug("Printf format: ". $self->printf_fmt. "\n"); ## End Debugging } my $func = sub { my ($result, $hit, $hsp) = @_; my @r = eval $code; # This should reduce the occurrence of those opaque "all zeros" bugs. if( $@ ) { $self->throw("Trouble in ResultTableWriter::_set_row_data_func() eval: $@\n\n"); } return @r; }; $self->{'_row_data_func'} = $func; } sub row_data_func { shift->{'_row_data_func'} } =head2 to_string() Note: this method is not intended for direct use. The SearchIO::write_result() method calls it automatically if the writer is hooked up to a SearchIO object as illustrated in L. Title : to_string() : Usage : print $writer->to_string( $result_obj, [$include_labels] ); : Argument : $result_obj = A Bio::Search::Result::ResultI object : $include_labels = boolean, if true column labels are included (default: false) : Returns : String containing tab-delimited set of data for each hit : in a ResultI object. Some data is summed across multiple HSPs. : Throws : n/a =cut #---------------- sub to_string { #---------------- my ($self, $result, $include_labels) = @_; my $str = $include_labels ? $self->column_labels() : ''; my $resultfilter = $self->filter('RESULT'); if( ! defined $resultfilter || &{$resultfilter}($result) ) { my @row_data = &{$self->{'_row_data_func'}}( $result ); $str .= sprintf "$self->{'_printf_fmt'}\n", @row_data; $str =~ s/\t\n/\n/gs; } return $str; } sub columns { my $self = shift; my @cols; if( ref $self->{'_cols'} ) { @cols = @{$self->{'_cols'}}; } else { my %map = $self->column_map; @cols = sort { $map{$a}->[0] <=> $map{$b}->[0] } keys %map; } return @cols; } =head2 column_labels Usage : print $result_obj->column_labels(); Purpose : Get column labels for to_string(). Returns : String containing column labels. Tab-delimited. Argument : n/a Throws : n/a =cut sub column_labels { shift->{'_column_labels'} } =head2 end_report Title : end_report Usage : $self->end_report() Function: The method to call when ending a report, this is mostly for cleanup for formats which require you to have something at the end of the document. Nothing for a text message. Returns : string Args : none =cut sub end_report { return ''; } =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference =cut # Is this really needed? #=head2 signif_format # # Usage : $writer->signif_format( [FMT] ); # Purpose : Allows retrieval of the P/Expect exponent values only # : or as a two-element list (mantissa, exponent). # Usage : $writer->signif_format('exp'); # : $writer->signif_format('parts'); # Returns : String or '' if not set. # Argument : String, FMT = 'exp' (return the exponent only) # : = 'parts'(return exponent + mantissa in 2-elem list) # : = undefined (return the raw value) # Comments : P/Expect values are still stored internally as the full, # : scientific notation value. # #=cut # ##------------- #sub signif_format { ##------------- # my $self = shift; # if(@_) { $self->{'_signif_format'} = shift; } # return $self->{'_signif_format'}; #} 1; BioPerl-1.6.923/Bio/SearchIO/Writer/TextResultWriter.pm000444000765000024 5735512254227336 23001 0ustar00cjfieldsstaff000000000000# # BioPerl module for Bio::SearchIO::Writer::TextResultWriter # # Please direct questions and support issues to # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::Writer::TextResultWriter - Object to implement writing a Bio::Search::ResultI in Text. =head1 SYNOPSIS use Bio::SearchIO; use Bio::SearchIO::Writer::TextResultWriter; my $in = Bio::SearchIO->new(-format => 'blast', -file => shift @ARGV); my $writer = Bio::SearchIO::Writer::TextResultWriter->new(); my $out = Bio::SearchIO->new(-writer => $writer); $out->write_result($in->next_result); =head1 DESCRIPTION This object implements the SearchWriterI interface which will produce a set of Text for a specific Bio::Search::Report::ReportI interface. You can also provide the argument -filters =E \%hash to filter the at the hsp, hit, or result level. %hash is an associative array which contains any or all of the keys (HSP, HIT, RESULT). The values pointed to by these keys would be references to a subroutine which expects to be passed an object - one of Bio::Search::HSP::HSPI, Bio::Search::Hit::HitI, and Bio::Search::Result::ResultI respectively. Each function needs to return a boolean value as to whether or not the passed element should be included in the output report - true if it is to be included, false if it to be omitted. For example to filter on sequences in the database which are too short for your criteria you would do the following. Define a hit filter method sub hit_filter { my $hit = shift; return $hit->length E 100; # test if length of the hit sequence # long enough } my $writer = Bio::SearchIO::Writer::TextResultWriter->new( -filters => { 'HIT' =E \&hit_filter } ); Another example would be to filter HSPs on percent identity, let's only include HSPs which are 75% identical or better. sub hsp_filter { my $hsp = shift; return $hsp->percent_identity E 75; } my $writer = Bio::SearchIO::Writer::TextResultWriter->new( -filters => { 'HSP' =E \&hsp_filter } ); See L for more info on the filter method. This module will use the module Text::Wrap if it is installed to wrap the Query description line. If you do not have Text::Wrap installed this module will work fine but you won't have the Query line wrapped. You will see a warning about this when you first instantiate a TextResultWriter - to avoid these warnings from showing up, simply set the verbosity upon initialization to -1 like this: my $writer = new Bio::SearchIO::Writer::TextResultWriter(-verbose =E -1); =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::Writer::TextResultWriter; use vars qw($MaxNameLen $MaxDescLen $AlignmentLineWidth $DescLineLen $TextWrapLoaded); use strict; # Object preamble - inherits from Bio::Root::RootI BEGIN { $MaxDescLen = 65; $AlignmentLineWidth = 60; eval { require Text::Wrap; $TextWrapLoaded = 1;}; if( $@ ) { $TextWrapLoaded = 0; } } use POSIX; use base qw(Bio::Root::Root Bio::SearchIO::SearchWriterI); =head2 new Title : new Usage : my $obj = Bio::SearchIO::Writer::TextResultWriter->new(); Function: Builds a new Bio::SearchIO::Writer::TextResultWriter object Returns : Bio::SearchIO::Writer::TextResultWriter Args : -filters => hashref with any or all of the keys (HSP HIT RESULT) which have values pointing to a subroutine reference which will expect to get a Hit,HSP, Result object respectively -no_wublastlinks => boolean. Do not display WU-BLAST lines even if they are parsed out Links = (1) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($filters,$nowublastlinks) = $self->_rearrange([qw(FILTERS NO_WUBLASTLINKS)], @args); if( defined $filters ) { if( !ref($filters) =~ /HASH/i ) { $self->warn("Did not provide a hashref for the FILTERS option, ignoring."); } else { while( my ($type,$code) = each %{$filters} ) { $self->filter($type,$code); } } } $self->no_wublastlinks(! $nowublastlinks); unless( $TextWrapLoaded ) { $self->warn("Could not load Text::Wrap - the Query Description will not be line wrapped\n"); } else { $Text::Wrap::columns = $MaxDescLen; } return $self; } =head2 to_string Purpose : Produces data for each Search::Result::ResultI in a string. : This is an abstract method. For some useful implementations, : see ResultTableWriter.pm, HitTableWriter.pm, : and HSPTableWriter.pm. Usage : print $writer->to_string( $result_obj, @args ); Argument : $result_obj = A Bio::Search::Result::ResultI object : @args = any additional arguments used by your implementation. Returns : String containing data for each search Result or any of its : sub-objects (Hits and HSPs). Throws : n/a =cut sub to_string { my ($self,$result,$num) = @_; $num ||= 0; return unless defined $result; my $links = $self->no_wublastlinks; my ($resultfilter,$hitfilter, $hspfilter) = ( $self->filter('RESULT'), $self->filter('HIT'), $self->filter('HSP') ); return '' if( defined $resultfilter && ! &{$resultfilter}($result) ); my ($qtype,$dbtype,$dbseqtype,$type); my $alg = $result->algorithm; my $wublast = ($result->algorithm_version =~ /WashU/) ? 1 : 0; # This is actually wrong for the FASTAs I think if( $alg =~ /T(FAST|BLAST)([XY])/i ) { $qtype = $dbtype = 'translated'; $dbseqtype = $type = 'PROTEIN'; } elsif( $alg =~ /T(FAST|BLAST)N/i ) { $qtype = ''; $dbtype = 'translated'; $type = 'PROTEIN'; $dbseqtype = 'NUCLEOTIDE'; } elsif( $alg =~ /(FAST|BLAST)N/i || $alg =~ /(WABA|EXONERATE)/i ) { $qtype = $dbtype = ''; $type = $dbseqtype = 'NUCLEOTIDE'; } elsif( $alg =~ /(FAST|BLAST)P/ || $alg =~ /SSEARCH|(HMM|SEARCH|PFAM)/i ) { $qtype = $dbtype = ''; $type = $dbseqtype = 'PROTEIN'; } elsif( $alg =~ /(FAST|BLAST)[XY]/i ) { $qtype = 'translated'; $dbtype = 'PROTEIN'; $dbseqtype = $type = 'PROTEIN'; } else { print STDERR "algorithm was ", $result->algorithm, " couldn't match\n"; } my %baselens = ( 'Sbjct:' => ( $dbtype eq 'translated' ) ? 3 : 1, 'Query:' => ( $qtype eq 'translated' ) ? 3 : 1); my $str; if( ! defined $num || $num <= 1 ) { $str = &{$self->start_report}($result); } $str .= &{$self->title}($result); $str .= $result->algorithm . " " . $result->algorithm_version . "\n\n\n"; $str .= $result->algorithm_reference || $self->algorithm_reference($result); $str .= &{$self->introduction}($result); $str .= qq{ Score E Sequences producing significant alignments: (bits) value }; my $hspstr = ''; if( $result->can('rewind')) { $result->rewind(); # support stream based parsing routines } while( my $hit = $result->next_hit ) { next if( defined $hitfilter && ! &{$hitfilter}($hit) ); my $nm = $hit->name(); $self->debug( "no $nm for name (".$hit->description(). "\n") unless $nm; my ($gi,$acc) = &{$self->id_parser}($nm); my $p = "%-$MaxDescLen". "s"; my $descsub; my $desc = sprintf("%s %s",$nm,$hit->description); if( length($desc) - 3 > $MaxDescLen) { $descsub = sprintf($p, substr($desc,0,$MaxDescLen-3) . "..."); } else { $descsub = sprintf($p,$desc); } $str .= $wublast ? sprintf("%s %-4s %s\n", $descsub, defined $hit->raw_score ? $hit->raw_score : ' ', defined $hit->significance ? $hit->significance : '?') : sprintf("%s %-4s %s\n", $descsub, defined $hit->bits ? $hit->bits: ' ', defined $hit->significance ? $hit->significance : '?'); my @hsps = $hit->hsps; if( @hsps ) { $hspstr .= sprintf(">%s %s\n%9sLength = %d\n\n", $hit->name, defined $hit->description ? $hit->description : '', '', # empty is for the %9s in the str formatting $hit->length); foreach my $hsp ( @hsps ) { next if( defined $hspfilter && ! &{$hspfilter}($hsp) ); $hspstr .= sprintf(" Score = %4s bits (%s), Expect = %s", $hsp->bits, $hsp->score, $hsp->evalue); if( $hsp->pvalue ) { $hspstr .= ", P = ".$hsp->pvalue; } $hspstr .= "\n"; $hspstr .= sprintf(" Identities = %d/%d (%d%%)", ( $hsp->frac_identical('total') * $hsp->length('total')), $hsp->length('total'), POSIX::floor($hsp->frac_identical('total') * 100)); if( $type eq 'PROTEIN' ) { $hspstr .= sprintf(", Positives = %d/%d (%d%%)", ( $hsp->frac_conserved('total') * $hsp->length('total')), $hsp->length('total'), POSIX::floor($hsp->frac_conserved('total') * 100)); } if( $hsp->gaps ) { $hspstr .= sprintf(", Gaps = %d/%d (%d%%)", $hsp->gaps('total'), $hsp->length('total'), POSIX::floor(100 * $hsp->gaps('total') / $hsp->length('total'))); } $hspstr .= "\n"; my ($hframe,$qframe) = ( $hsp->hit->frame, $hsp->query->frame); my ($hstrand,$qstrand) = ($hsp->hit->strand,$hsp->query->strand); # so TBLASTX will have Query/Hit frames # BLASTX will have Query frame # TBLASTN will have Hit frame if( $hstrand || $qstrand ) { $hspstr .= " Frame = "; my ($signq, $signh); unless( $hstrand ) { $hframe = undef; # if strand is null or 0 then it is protein # and this no frame } else { $signh = $hstrand < 0 ? '-' : '+'; } unless( $qstrand ) { $qframe = undef; # if strand is null or 0 then it is protein } else { $signq =$qstrand < 0 ? '-' : '+'; } # remember bioperl stores frames as 0,1,2 (GFF way) # BLAST reports reports as 1,2,3 so # we have to add 1 to the frame values if( defined $hframe && ! defined $qframe) { $hspstr .= "$signh".($hframe+1); } elsif( defined $qframe && ! defined $hframe) { $hspstr .= "$signq".($qframe+1); } else { $hspstr .= sprintf(" %s%d / %s%d", $signq,$qframe+1, $signh, $hframe+1); } } if( $links && $hsp->can('links') && defined(my $lnks = $hsp->links) ) { $hspstr .= sprintf(" Links = %s\n",$lnks); } $hspstr .= "\n\n"; my @hspvals = ( {'name' => 'Query:', 'seq' => $hsp->query_string, 'start' => ( $qstrand >= 0 ? $hsp->query->start : $hsp->query->end), 'end' => ($qstrand >= 0 ? $hsp->query->end : $hsp->query->start), 'index' => 0, 'direction' => $qstrand || 1 }, { 'name' => ' 'x6, # this might need to adjust for long coordinates?? 'seq' => $hsp->homology_string, 'start' => undef, 'end' => undef, 'index' => 0, 'direction' => 1 }, { 'name' => 'Sbjct:', 'seq' => $hsp->hit_string, 'start' => ($hstrand >= 0 ? $hsp->hit->start : $hsp->hit->end), 'end' => ($hstrand >= 0 ? $hsp->hit->end : $hsp->hit->start), 'index' => 0, 'direction' => $hstrand || 1 } ); # let's set the expected length (in chars) of the starting number # in an alignment block so we can have things line up # Just going to try and set to the largest my ($numwidth) = sort { $b <=> $a }(length($hspvals[0]->{'start'}), length($hspvals[0]->{'end'}), length($hspvals[2]->{'start'}), length($hspvals[2]->{'end'})); my $count = 0; while ( $count <= $hsp->length('total') ) { foreach my $v ( @hspvals ) { my $piece = substr($v->{'seq'}, $v->{'index'} +$count, $AlignmentLineWidth); my $cp = $piece; my $plen = scalar ( $cp =~ tr/\-//); my ($start,$end) = ('',''); if( defined $v->{'start'} ) { $start = $v->{'start'}; # since strand can be + or - use the direction # to signify which whether to add or substract from end my $d = $v->{'direction'} * ( $AlignmentLineWidth - $plen )* $baselens{$v->{'name'}}; if( length($piece) < $AlignmentLineWidth ) { $d = (length($piece) - $plen) * $v->{'direction'} * $baselens{$v->{'name'}}; } $end = $v->{'start'} + $d - $v->{'direction'}; $v->{'start'} += $d; } $hspstr .= sprintf("%s %-".$numwidth."s %s %s\n", $v->{'name'}, $start, $piece, $end ); } $count += $AlignmentLineWidth; $hspstr .= "\n"; } } $hspstr .= "\n"; } } $str .= "\n\n".$hspstr; $str .= sprintf(qq{ Database: %s Posted date: %s Number of letters in database: %s Number of sequences in database: %s Matrix: %s }, $result->database_name(), $result->get_statistic('posted_date') || POSIX::strftime("%b %d, %Y %I:%M %p",localtime), &_numwithcommas($result->database_letters()), &_numwithcommas($result->database_entries()), $result->get_parameter('matrix') || ''); if( defined (my $open = $result->get_parameter('gapopen')) ) { $str .= sprintf("Gap Penalties Existence: %d, Extension: %d\n", $open || 0, $result->get_parameter('gapext') || 0); } # skip those params we've already output foreach my $param ( grep { ! /matrix|gapopen|gapext/i } $result->available_parameters ) { $str .= "$param: ". $result->get_parameter($param) ."\n"; } $str .= "Search Statistics\n"; # skip posted date, we already output it foreach my $stat ( sort grep { ! /posted_date/ } $result->available_statistics ) { my $expect = $result->get_parameter('expect'); my $v = $result->get_statistic($stat); if( $v =~ /^\d+$/ ) { $v = &_numwithcommas($v); } if( defined $expect && $stat eq 'seqs_better_than_cutoff' ) { $str .= "seqs_better_than_$expect: $v\n"; } else { my $v = $str .= "$stat: $v\n"; } } $str .= "\n\n"; return $str; } =head2 start_report Title : start_report Usage : $index->start_report( CODE ) Function: Stores or returns the code to write the start of the block, the block and the start of the <BODY> block of HTML. Useful for (for instance) specifying alternative HTML if you are embedding the output in an HTML page which you have already started. (For example a routine returning a null string). Returns \&default_start_report (see below) if not set. Example : $index->start_report( \&my_start_report ) Returns : ref to CODE if called without arguments Args : CODE =cut sub start_report { my( $self, $code ) = @_; if ($code) { $self->{'_start_report'} = $code; } return $self->{'_start_report'} || \&default_start_report; } =head2 default_start_report Title : default_start_report Usage : $self->default_start_report($result) Function: The default method to call when starting a report. Returns : sting Args : First argument is a Bio::Search::Result::ResultI =cut sub default_start_report { my ($result) = @_; return ""; } =head2 title Title : title Usage : $self->title($CODE) Function: Stores or returns the code to provide HTML for the given BLAST report that will appear at the top of the BLAST report HTML output. Useful for (for instance) specifying alternative routines to write your own titles. Returns \&default_title (see below) if not set. Example : $index->title( \&my_title ) Returns : ref to CODE if called without arguments Args : CODE =cut sub title { my( $self, $code ) = @_; if ($code) { $self->{'_title'} = $code; } return $self->{'_title'} || \&default_title; } =head2 default_title Title : default_title Usage : $self->default_title($result) Function: Provides HTML for the given BLAST report that will appear at the top of the BLAST report output. Returns : empty for text implementation Args : First argument is a Bio::Search::Result::ResultI =cut sub default_title { my ($result) = @_; return ""; # The HTML implementation # return sprintf( # qq{<CENTER><H1><a href="http://bioperl.org">Bioperl</a> Reformatted HTML of %s Search Report<br> for %s</H1></CENTER>}, # $result->algorithm, # $result->query_name()); } =head2 introduction Title : introduction Usage : $self->introduction($CODE) Function: Stores or returns the code to provide HTML for the given BLAST report detailing the query and the database information. Useful for (for instance) specifying routines returning alternative introductions. Returns \&default_introduction (see below) if not set. Example : $index->introduction( \&my_introduction ) Returns : ref to CODE if called without arguments Args : CODE =cut sub introduction { my( $self, $code ) = @_; if ($code) { $self->{'_introduction'} = $code; } return $self->{'_introduction'} || \&default_introduction; } =head2 default_introduction Title : default_introduction Usage : $self->default_introduction($result) Function: Outputs HTML to provide the query and the database information Returns : string containing HTML Args : First argument is a Bio::Search::Result::ResultI Second argument is string holding literature citation =cut sub default_introduction { my ($result) = @_; return sprintf( qq{ Query= %s (%s letters) Database: %s %s sequences; %s total letters }, &_linewrap($result->query_name . " " . $result->query_description), &_numwithcommas($result->query_length), $result->database_name(), &_numwithcommas($result->database_entries()), &_numwithcommas($result->database_letters()), ); } =head2 end_report Title : end_report Usage : $self->end_report() Function: The method to call when ending a report, this is mostly for cleanup for formats which require you to have something at the end of the document (</BODY></HTML>) for HTML Returns : string Args : none =cut sub end_report { return ""; } # copied from Bio::Index::Fasta # useful here as well =head2 id_parser Title : id_parser Usage : $index->id_parser( CODE ) Function: Stores or returns the code used by record_id to parse the ID for record from a string. Useful for (for instance) specifying a different parser for different flavours of FASTA file. Returns \&default_id_parser (see below) if not set. If you supply your own id_parser subroutine, then it should expect a fasta description line. An entry will be added to the index for each string in the list returned. Example : $index->id_parser( \&my_id_parser ) Returns : ref to CODE if called without arguments Args : CODE =cut sub id_parser { my( $self, $code ) = @_; if ($code) { $self->{'_id_parser'} = $code; } return $self->{'_id_parser'} || \&default_id_parser; } =head2 default_id_parser Title : default_id_parser Usage : $id = default_id_parser( $header ) Function: The default Fasta ID parser for Fasta.pm Returns $1 from applying the regexp /^>\s*(\S+)/ to $header. Returns : ID string Args : a fasta header line string =cut sub default_id_parser { my ($string) = @_; my ($gi,$acc); if( $string =~ s/gi\|(\d+)\|?// ) { $gi = $1; $acc = $1;} if( $string =~ /(\w+)\|([A-Z\d\.\_]+)(\|[A-Z\d\_]+)?/ ) { $acc = defined $2 ? $2 : $1; } else { $acc = $string; $acc =~ s/^\s+(\S+)/$1/; $acc =~ s/(\S+)\s+$/$1/; } return ($gi,$acc); } sub MIN { $a <=> $b ? $a : $b; } sub MAX { $a <=> $b ? $b : $a; } =head2 algorithm_reference Title : algorithm_reference Usage : my $reference = $writer->algorithm_reference($result); Function: Returns the appropriate Bibliographic reference for the algorithm format being produced Returns : String Args : L<Bio::Search::Result::ResultI> to reference =cut sub algorithm_reference{ my ($self,$result) = @_; return '' if( ! defined $result || !ref($result) || ! $result->isa('Bio::Search::Result::ResultI')) ; if( $result->algorithm =~ /BLAST/i ) { my $res = $result->algorithm . ' '. $result->algorithm_version. "\n"; if( $result->algorithm_version =~ /WashU/i ) { return $res .qq{ Copyright (C) 1996-2000 Washington University, Saint Louis, Missouri USA. All Rights Reserved. Reference: Gish, W. (1996-2000) http://blast.wustl.edu }; } else { return $res . qq{ Reference: Altschul, Stephen F., Thomas L. Madden, Alejandro A. Schaffer, Jinghui Zhang, Zheng Zhang, Webb Miller, and David J. Lipman (1997), "Gapped BLAST and PSI-BLAST: a new generation of protein database search programs", Nucleic Acids Res. 25:3389-3402. }; } } elsif( $result->algorithm =~ /FAST/i ) { return $result->algorithm. " ". $result->algorithm_version . "\n". "\nReference: Pearson et al, Genomics (1997) 46:24-36\n"; } else { return ''; } } # from Perl Cookbook 2.17 sub _numwithcommas { my $num = reverse( $_[0] ); $num =~ s/(\d{3})(?=\d)(?!\d*\.)/$1,/g; return scalar reverse $num; } sub _linewrap { my ($str) = @_; if($TextWrapLoaded) { return Text::Wrap::wrap("","",$str); # use Text::Wrap } else { return $str; } # cannot wrap } =head2 Methods Bio::SearchIO::SearchWriterI L<Bio::SearchIO::SearchWriterI> inherited methods. =head2 filter Title : filter Usage : $writer->filter('hsp', \&hsp_filter); Function: Filter out either at HSP,Hit,or Result level Returns : none Args : string => data type, CODE reference =cut =head2 no_wublastlinks Title : no_wublastlinks Usage : $obj->no_wublastlinks($newval) Function: Get/Set boolean value regarding whether or not to display Link = (1) type output in the report output (WU-BLAST only) Returns : boolean Args : on set, new boolean value (a scalar or undef, optional) =cut sub no_wublastlinks{ my $self = shift; return $self->{'no_wublastlinks'} = shift if @_; return $self->{'no_wublastlinks'}; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SearchIO/XML��������������������������������������������������������������������000755��000765��000024�� 0�12254227330� 16105� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SearchIO/XML/BlastHandler.pm����������������������������������������������������000444��000765��000024�� 24225�12254227320� 21167� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SearchIO::XML::BlastHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich, Chris Fields # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::XML::BlastHandler - XML Handler for NCBI Blast XML parsing. =head1 SYNOPSIS # This is not to be used directly. =head1 DESCRIPTION This is the XML handler for BLAST XML parsing. Currently it passes elements off to the event handler, which is ultimately responsible for Bio::Search object generation. This was recently split off from the original code for Bio::SearchIO::blastxml primarily for maintenance purposes. =head1 DEPENDENCIES In addition to parts of the Bio:: hierarchy, this module uses: XML::SAX::Base which comes with the XML::SAX distribution. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Chris Fields Email jason-at-bioperl.org Email cjfields-at-uiuc dot edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::XML::BlastHandler; use base qw(Bio::Root::Root XML::SAX::Base); my %MODEMAP = ( 'Iteration' => 'result', 'Hit' => 'hit', 'Hsp' => 'hsp' ); # major post 2.2.12 BLAST XML changes # 1) moved XML Handler to it's own class # 2) reconfigure blastxml to deal with old and new BLAST XML output my %MAPPING = ( # Result-specific fields 'BlastOutput_program' => 'RESULT-algorithm_name', 'BlastOutput_version' => 'RESULT-algorithm_version', 'BlastOutput_db' => 'RESULT-database_name', 'BlastOutput_reference' => 'RESULT-program_reference', 'BlastOutput_query-def' => 'RESULT-query_description', 'BlastOutput_query-len' => 'RESULT-query_length', 'BlastOutput_query-ID' => 'runid', 'Parameters_matrix' => { 'RESULT-parameters' => 'matrix'}, 'Parameters_expect' => { 'RESULT-parameters' => 'expect'}, 'Parameters_include' => { 'RESULT-parameters' => 'include'}, 'Parameters_sc-match' => { 'RESULT-parameters' => 'match'}, 'Parameters_sc-mismatch' => { 'RESULT-parameters' => 'mismatch'}, 'Parameters_gap-open' => { 'RESULT-parameters' => 'gapopen'}, 'Parameters_gap-extend' => { 'RESULT-parameters' => 'gapext'}, 'Parameters_filter' => {'RESULT-parameters' => 'filter'}, 'Statistics_db-num' => 'RESULT-database_entries', 'Statistics_db-len' => 'RESULT-database_letters', 'Statistics_hsp-len' => { 'RESULT-statistics' => 'hsplength'}, 'Statistics_eff-space' => { 'RESULT-statistics' => 'effectivespace'}, 'Statistics_kappa' => { 'RESULT-statistics' => 'kappa' }, 'Statistics_lambda' => { 'RESULT-statistics' => 'lambda' }, 'Statistics_entropy' => { 'RESULT-statistics' => 'entropy'}, # HSP specific fields 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame'=> 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', # Hit specific fields 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_num' => 'HIT-order', 'Iteration_iter-num' => 'HIT-iteration', 'Iteration_stat' => 'HIT-iteration_statistic', # if these tags are present, they will overwrite the # above with more current data (i.e. multiquery hits) 'Iteration_query-def' => 'RESULT-query_description', 'Iteration_query-len' => 'RESULT-query_length', 'Iteration_query-ID' => 'runid', ); # these XML tags are ignored for now my %IGNOREDTAGS = ( 'Hsp_num' => 1,#'HSP-order', 'Hsp_pattern-from' => 1,#'patternend', 'Hsp_pattern-to' => 1,#'patternstart', 'Hsp_density' => 1,#'hspdensity', 'Iteration_message' => 1, 'Hit_hsps' => 1, 'BlastOutput_param' => 1, 'Iteration_hits' => 1, 'Statistics' => 1, 'Parameters' => 1, 'BlastOutput' => 1, 'BlastOutput_iterations' => 1, ); =head2 SAX methods =cut =head2 start_document Title : start_document Usage : $parser->start_document; Function: SAX method to indicate starting to parse a new document Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= []; } =head2 end_document Title : end_document Usage : $parser->end_document; Function: SAX method to indicate finishing parsing a new document Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; # reset data carried throughout parse $self->{'_resultdata'} = undef; # pass back ref to results queue; caller must reset handler results queue return $self->{'_result'}; } =head2 start_element Title : start_element Usage : $parser->start_element($data) Function: SAX method to indicate starting a new element Returns : none Args : hash ref for data =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if( my $type = $MODEMAP{$nm} ) { if( $self->eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->eventHandler->$func($data->{'Attributes'}); } } } =head2 end_element Title : end_element Usage : $parser->end_element($data) Function: Signals finishing an element Returns : Bio::Search object dpending on what type of element Args : hash ref for data =cut sub end_element{ my ($self,$data) = @_; my $nm = $data->{'Name'}; my $rc; if($nm eq 'BlastOutput_program' && $self->{'_last_data'} =~ /(t?blast[npx])/i ) { $self->{'_type'} = uc $1; } if ($nm eq 'Iteration') { map { $self->{'_values'}->{$_} = $self->{'_resultdata'}->{$_}; } keys %{ $self->{'_resultdata'} }; } if( my $type = $MODEMAP{$nm} ) { if( $self->eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->eventHandler->$func($self->{'_type'}, $self->{'_values'}); } } elsif( exists $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } elsif( exists $IGNOREDTAGS{$nm} ){ # ignores these elements for now } else { $self->debug("ignoring unrecognized element type $nm\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element # add to ResultI array $self->{'_result'} = $rc if( $nm eq 'Iteration' ); # reset values for each Result round if ($nm eq 'Iteration') { $self->{'_values'} = {}; } } =head2 characters Title : characters Usage : $parser->characters($data) Function: Signals new characters to be processed Returns : characters read Args : hash ref with the key 'Data' =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/ ); $self->{'_last_data'} .= $data->{'Data'}; } sub eventHandler { my $self = shift; return $self->{'_handler'} = shift if @_; return $self->{'_handler'}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SearchIO/XML/PsiBlastHandler.pm�������������������������������������������������000444��000765��000024�� 23623�12254227330� 21645� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SearchIO::XML::PsiBlastHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich, Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SearchIO::XML::PsiBlastHandler - XML Handler for NCBI Blast PSIBLAST XML parsing. =head1 SYNOPSIS # This is not to be used directly. =head1 DESCRIPTION This is the XML handler for BLAST PSIBLAST XML parsing. Currently it passes elements off to the event handler, which is ultimately responsible for Bio::Search object generation. This was recently split off from the original code for Bio::SearchIO::blastxml primarily for maintenance purposes. =head1 DEPENDENCIES In addition to parts of the Bio:: hierarchy, this module uses: XML::SAX::Base which comes with the XML::SAX distribution. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Chris Fields Email jason-at-bioperl.org Email cjfields-at-uiuc dot edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SearchIO::XML::PsiBlastHandler; use base qw(Bio::Root::Root XML::SAX::Base); my %MODEMAP = ( 'BlastOutput' => 'result', 'Iteration' => 'iteration', 'Hit' => 'hit', 'Hsp' => 'hsp' ); # MAPPING is distinct from BlastHandler, can't really mix the two... my %MAPPING = ( # Result-specific fields 'BlastOutput_program' => 'RESULT-algorithm_name', 'BlastOutput_version' => 'RESULT-algorithm_version', 'BlastOutput_db' => 'RESULT-database_name', 'BlastOutput_reference' => 'RESULT-program_reference', 'BlastOutput_query-def' => 'RESULT-query_description', 'BlastOutput_query-len' => 'RESULT-query_length', 'BlastOutput_query-ID' => 'runid', 'Parameters_matrix' => { 'RESULT-parameters' => 'matrix'}, 'Parameters_expect' => { 'RESULT-parameters' => 'expect'}, 'Parameters_include' => { 'RESULT-parameters' => 'include'}, 'Parameters_sc-match' => { 'RESULT-parameters' => 'match'}, 'Parameters_sc-mismatch' => { 'RESULT-parameters' => 'mismatch'}, 'Parameters_gap-open' => { 'RESULT-parameters' => 'gapopen'}, 'Parameters_gap-extend' => { 'RESULT-parameters' => 'gapext'}, 'Parameters_filter' => {'RESULT-parameters' => 'filter'}, 'Statistics_db-num' => 'RESULT-database_entries', 'Statistics_db-len' => 'RESULT-database_letters', 'Statistics_hsp-len' => { 'RESULT-statistics' => 'hsplength'}, 'Statistics_eff-space' => { 'RESULT-statistics' => 'effectivespace'}, 'Statistics_kappa' => { 'RESULT-statistics' => 'kappa' }, 'Statistics_lambda' => { 'RESULT-statistics' => 'lambda' }, 'Statistics_entropy' => { 'RESULT-statistics' => 'entropy'}, # Iteration-specific parameters 'Iteration_iter-num' => 'ITERATION-number', 'Iteration_converged' => 'ITERATION-converged', # HSP specific fields 'Hsp_bit-score' => 'HSP-bits', 'Hsp_score' => 'HSP-score', 'Hsp_evalue' => 'HSP-evalue', 'Hsp_query-from' => 'HSP-query_start', 'Hsp_query-to' => 'HSP-query_end', 'Hsp_hit-from' => 'HSP-hit_start', 'Hsp_hit-to' => 'HSP-hit_end', 'Hsp_positive' => 'HSP-conserved', 'Hsp_identity' => 'HSP-identical', 'Hsp_gaps' => 'HSP-gaps', 'Hsp_hitgaps' => 'HSP-hit_gaps', 'Hsp_querygaps' => 'HSP-query_gaps', 'Hsp_qseq' => 'HSP-query_seq', 'Hsp_hseq' => 'HSP-hit_seq', 'Hsp_midline' => 'HSP-homology_seq', 'Hsp_align-len' => 'HSP-hsp_length', 'Hsp_query-frame'=> 'HSP-query_frame', 'Hsp_hit-frame' => 'HSP-hit_frame', # Hit specific fields 'Hit_id' => 'HIT-name', 'Hit_len' => 'HIT-length', 'Hit_accession' => 'HIT-accession', 'Hit_def' => 'HIT-description', 'Hit_num' => 'HIT-order', 'Iteration_iter-num' => 'HIT-iteration', 'Iteration_stat' => 'HIT-iteration_statistic', ); # these XML tags are ignored for now my %IGNOREDTAGS = ( 'Hsp_num' => 1,#'HSP-order', 'Hsp_pattern-from' => 1,#'patternend', 'Hsp_pattern-to' => 1,#'patternstart', 'Hsp_density' => 1,#'hspdensity', 'Iteration_message' => 1, 'Hit_hsps' => 1, 'BlastOutput_param' => 1, 'Iteration_hits' => 1, 'Statistics' => 1, 'Parameters' => 1, 'BlastOutput' => 1, 'BlastOutput_iterations' => 1, ); =head2 SAX methods =cut =head2 start_document Title : start_document Usage : $parser->start_document; Function: SAX method to indicate starting to parse a new document Returns : none Args : none =cut sub start_document{ my ($self) = @_; $self->{'_lasttype'} = ''; $self->{'_values'} = {}; $self->{'_result'}= []; } =head2 end_document Title : end_document Usage : $parser->end_document; Function: SAX method to indicate finishing parsing a new document Returns : Bio::Search::Result::ResultI object Args : none =cut sub end_document{ my ($self,@args) = @_; # reset data carried throughout parse $self->{'_resultdata'} = undef; # pass back ref to results queue; caller must reset handler results queue return $self->{'_result'}; } =head2 start_element Title : start_element Usage : $parser->start_element($data) Function: SAX method to indicate starting a new element Returns : none Args : hash ref for data =cut sub start_element{ my ($self,$data) = @_; # we currently don't care about attributes my $nm = $data->{'Name'}; if( my $type = $MODEMAP{$nm} ) { if( $self->eventHandler->will_handle($type) ) { my $func = sprintf("start_%s",lc $type); $self->eventHandler->$func($data->{'Attributes'}); } } } =head2 end_element Title : end_element Usage : $parser->end_element($data) Function: Signals finishing an element Returns : Bio::Search object dpending on what type of element Args : hash ref for data =cut sub end_element{ my ($self,$data) = @_; my $nm = $data->{'Name'}; my $rc; if($nm eq 'BlastOutput_program' && $self->{'_last_data'} =~ /(t?blast[npx])/i ) { $self->{'_type'} = uc $1; } if ($nm eq 'Iteration') { map { $self->{'_values'}->{$_} = $self->{'_resultdata'}->{$_}; } keys %{ $self->{'_resultdata'} }; } if( my $type = $MODEMAP{$nm} ) { if( $self->eventHandler->will_handle($type) ) { my $func = sprintf("end_%s",lc $type); $rc = $self->eventHandler->$func($self->{'_type'}, $self->{'_values'}); } } elsif( exists $MAPPING{$nm} ) { if ( ref($MAPPING{$nm}) =~ /hash/i ) { my $key = (keys %{$MAPPING{$nm}})[0]; $self->{'_values'}->{$key}->{$MAPPING{$nm}->{$key}} = $self->{'_last_data'}; } else { $self->{'_values'}->{$MAPPING{$nm}} = $self->{'_last_data'}; } } elsif( exists $IGNOREDTAGS{$nm} ){ # ignores these elements for now } else { $self->debug("ignoring unrecognized element type $nm\n"); } $self->{'_last_data'} = ''; # remove read data if we are at # end of an element # add to ResultI array $self->{'_result'} = $rc if( $nm eq 'BlastOutput' ); # reset values for each Result round if ($nm eq 'BlastOutput') { $self->{'_values'} = {}; } } =head2 characters Title : characters Usage : $parser->characters($data) Function: Signals new characters to be processed Returns : characters read Args : hash ref with the key 'Data' =cut sub characters{ my ($self,$data) = @_; return unless ( defined $data->{'Data'} && $data->{'Data'} !~ /^\s+$/ ); $self->{'_last_data'} .= $data->{'Data'}; } sub eventHandler { my $self = shift; return $self->{'_handler'} = shift if @_; return $self->{'_handler'}; } 1; �������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq�����������������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 14541� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/BaseSeqProcessor.pm���������������������������������������������������������000444��000765��000024�� 20073�12254227326� 20505� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::BaseSeqProcessor # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp at gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Seq::BaseSeqProcessor - Base implementation for a SequenceProcessor =head1 SYNOPSIS # you need to derive your own processor from this one =head1 DESCRIPTION This provides just a basic framework for implementations of L<Bio::Factory::SequenceProcessorI>. Essentially what it does is support a parameter to new() to set sequence factory and source stream, and a next_seq() implementation that will use a queue to be filled by a class overriding process_seq(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::BaseSeqProcessor; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::Factory::SequenceProcessorI); =head2 new Title : new Usage : my $obj = Bio::Seq::BaseSeqProcessor->new(); Function: Builds a new Bio::Seq::BaseSeqProcessor object Returns : an instance of Bio::Seq::BaseSeqProcessor Args : Named parameters. Currently supported are -seqfactory the Bio::Factory::SequenceFactoryI object to use -source_stream the Bio::Factory::SequenceStreamI object to which we are chained =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($stream,$fact) = $self->_rearrange([qw(SOURCE_STREAM SEQFACTORY)], @args); $self->{'_queue'} = []; $self->sequence_factory($fact) if $fact; $self->source_stream($stream) if $stream; return $self; } =head1 L<Bio::Factory::SequenceProcessorI> methods =cut =head2 source_stream Title : source_stream Usage : $obj->source_stream($newval) Function: Get/set the source sequence stream for this sequence processor. Example : Returns : A Bio::Factory::SequenceStreamI compliant object Args : on set, new value (a Bio::Factory::SequenceStreamI compliant object) =cut sub source_stream{ my $self = shift; if(@_) { my $stream = shift; my $fact = $stream->sequence_factory(); $self->sequence_factory($fact) unless $self->sequence_factory() || (! $fact); return $self->{'source_stream'} = $stream; } return $self->{'source_stream'}; } =head1 L<Bio::Factory::SequenceStreamI> methods =cut =head2 next_seq Title : next_seq Usage : $seq = stream->next_seq Function: Reads the next sequence object from the stream and returns it. This implementation will obtain objects from the source stream as necessary and pass them to process_seq() for processing. This method will return the objects one at a time that process_seq() returns. Returns : a Bio::Seq sequence object Args : none See L<Bio::Factory::SequenceStreamI::next_seq> =cut sub next_seq{ my $self = shift; my $seq; # if the queue is empty, fetch next from source and process it if(@{$self->{'_queue'}} == 0) { my @seqs = (); while($seq = $self->source_stream->next_seq()) { @seqs = $self->process_seq($seq); # we may get zero seqs returned last if @seqs; } push(@{$self->{'_queue'}}, @seqs) if @seqs; } # take next from the queue of seqs $seq = shift(@{$self->{'_queue'}}); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: Writes the result(s) of processing the sequence object into the stream. You need to override this method in order not to alter (process) sequence objects before output. Returns : 1 for success and 0 for error. The method stops attempting to write objects after the first error returned from the source stream. Otherwise the return value is the value returned from the source stream from writing the last object resulting from processing the last sequence object given as argument. Args : Bio::SeqI object, or an array of such objects =cut sub write_seq{ my ($self, @seqs) = @_; my $ret; foreach my $seq (@seqs) { foreach my $processed ($self->process_seq($seq)) { $ret = $self->source_stream->write_seq($seq); return unless $ret; } } return $ret; } =head2 sequence_factory Title : sequence_factory Usage : $seqio->sequence_factory($seqfactory) Function: Get the Bio::Factory::SequenceFactoryI Returns : Bio::Factory::SequenceFactoryI Args : none =cut sub sequence_factory{ my $self = shift; return $self->{'sequence_factory'} = shift if @_; return $self->{'sequence_factory'}; } =head2 object_factory Title : object_factory Usage : $obj->object_factory($newval) Function: This is an alias to sequence_factory with a more generic name. Example : Returns : a L<Bio::Factory::ObjectFactoryI> compliant object Args : on set, new value (a L<Bio::Factory::ObjectFactoryI> compliant object or undef, optional) =cut sub object_factory{ return shift->sequence_factory(@_); } =head2 close Title : close Usage : Function: Closes the stream. We override this here in order to cascade to the source stream. Example : Returns : Args : none =cut sub close{ my $self = shift; return $self->source_stream() ? $self->source_stream->close(@_) : 1; } =head1 To be overridden by a derived class =cut =head2 process_seq Title : process_seq Usage : Function: This is the method that is supposed to do the actual processing. It needs to be overridden to do what you want it to do. Generally, you do not have to override or implement any other method to derive your own sequence processor. The implementation provided here just returns the unaltered input sequence and hence is not very useful other than serving as a neutral default processor. Example : Returns : An array of zero or more Bio::PrimarySeqI (or derived interface) compliant object as the result of processing the input sequence. Args : A Bio::PrimarySeqI (or derived interface) compliant object to be processed. =cut sub process_seq{ my ($self,$seq) = @_; return ($seq); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/EncodedSeq.pm���������������������������������������������������������������000444��000765��000024�� 52326�12254227340� 17276� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::EncodedSeq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::EncodedSeq - subtype of L<Bio::LocatableSeq|Bio::LocatableSeq> to store DNA that encodes a protein =head1 SYNOPSIS $obj = Bio::Seq::EncodedSeq->new( -seq => $dna, -encoding => "CCCCCCCIIIIICCCCC", -start => 1, -strand => 1, -length => 17 ); # splice out (and possibly revcomp) the coding sequence $cds = obj->cds; # obtain the protein translation of the sequence $prot = $obj->translate; # other access/inspection routines as with Bio::LocatableSeq and # Bio::SeqI; note that coordinates are relative only to the DNA # sequence, not it's implicit encoded protein sequence. =head1 DESCRIPTION Bio::Seq::EncodedSeq is a L<Bio::LocatableSeq|Bio::LocatableSeq> object that holds a DNA sequence as well as information about the coding potential of that DNA sequence. It is meant to be useful in an alignment context, where the DNA may contain frameshifts, gaps and/or introns, or in describing the transcript of a gene. An EncodedSeq provides the ability to access the "spliced" coding sequence, meaning that all introns and gaps are removed, and any frameshifts are adjusted to provide a "clean" CDS. In order to make simultaneous use of either the DNA or the implicit encoded protein sequence coordinates, please see L<Bio::Coordinate::EncodingPair>. =head1 ENCODING We use the term "encoding" here to refer to the series of symbols that we use to identify which residues of a DNA sequence are protein-coding (i.e. part of a codon), intronic, part of a 5' or 3', frameshift "mutations", etc. From this information, a Bio::Seq::EncodedSeq is able to "figure out" its translational CDS. There are two sets of coding characters, one termed "implicit" and one termed "explicit". The "implicit" encoding is a bit simpler than the "explicit" encoding: 'C' is used for any nucleotide that's part of a codon, 'U' for any UTR, etc. The full list is shown below: Code Meaning ---- ------- C coding I intronic U untranslated G gapped (for use in alignments) F a "forward", +1 frameshift B a "backward", -1 frameshift The "explicit" encoding is just an expansion of the "implicit" encoding, to denote phase: Code Meaning ---- ------- C coding, 1st codon position D coding, 2nd codon position E coding, 3rd codon position I intronic, phase 0 (relative to intron begin) J intronic, phase 1 K intronic, phase 2 U untranslated 3'UTR V untranslated 5'UTR G gapped (for use in alignments) F a "forward", +1 frameshift B a "backward", -1 frameshift Note that the explicit coding is meant to provide easy access to position/phase specific nucleotides: $obj = Bio::Seq::EncodedSeq->new(-seq => "ACAATCAGACTACG...", -encoding => "CCCCCCIII..." ); # fetch arrays of nucleotides at each codon position: my @pos1 = $obj->dnaseq(encoding => 'C', explicit => 1); my @pos2 = $obj->dnaseq(encoding => 'D'); my @pos3 = $obj->dnaseq(encoding => 'E'); # fetch arrays of "3-1" codon dinucleotides, useful for genomic # signature analyses without compounding influences of codon bias: my @pairs = $obj->dnaseq(encoding => 'EC'); =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Seq::EncodedSeq; use strict; use base qw(Bio::LocatableSeq); =head2 new Title : new Usage : $obj = Bio::Seq::EncodedSeq->new(-seq => "AGTACGTGTCATG", -encoding => "CCCCCCFCCCCCC", -id => "myseq", -start => 1, -end => 13, -strand => 1 ); Function: creates a new Bio::Seq::EncodedSeq object from a supplied DNA sequence Returns : a new Bio::Seq::EncodedSeq object Args : seq - primary nucleotide sequence used to encode the protein; note that any positions involved in a gap ('G') or backward frameshift ('B') should have one or more gap characters; if the encoding specifies G or B, but no (or not enough) gap characters exist, *they'll be added*; similary, if there are gap characters without a corresponding G or B encoding, G's will be inserted into the encoding. This allows some flexibility in specifying your sequence and coding without having to calculate a lot of the encoding for yourself. encoding - a string of characters (see Encoding Table) describing backwards frameshifts implied by the encoding but not present in the sequence will be added (as '-'s) to the sequence. If not supplied, it will be assumed that all positions are coding (C). Encoding may include either implicit phase encoding characters (i.e. "CCC") and/or explicit encoding characters (i.e. "CDE"). Additionally, prefixed numbers may be used to denote repetition (i.e. "27C3I28C"). Alternatively, encoding may be a hashref datastructure, with encoding characters as keys and Bio::LocationI objects (or arrayrefs of Bio::LocationI objects) as values, e.g.: { C => [ Bio::Location::Simple->new(1,9), Bio::Location::Simple->new(11,13) ], F => Bio::Location::Simple->new(10,10), } # same as "CCCCCCCCCFCCC" Note that if the location ranges overlap, the behavior of the encoding will be undefined (well, it will be defined, but only according to the order in which the hash keys are read, which is basically undefined ... just don't do that). id, start, end, strand - as with Bio::LocatableSeq; note that the coordinates are relative to the encoding DNA sequence, not the implicit protein sequence. If strand is reversed, then the encoding is assumed to be relative to the reverse strand as well. =cut sub new { my ($self, @args) = @_; $self = $self->SUPER::new(@args, -alphabet => 'dna'); my ($enc) = $self->_rearrange([qw(ENCODING)], @args); # set the real encoding: if ($enc) { $self->encoding($enc); } else { $self->_recheck_encoding; } return $self; } =head2 encoding Title : encoding Usage : $obj->encoding("CCCCCC"); $obj->encoding( -encoding => { I => $location } ); $enc = $obj->encoding(-explicit => 1); $enc = $obj->encoding("CCCCCC", -explicit => 1); $enc = $obj->encoding(-location => $location, -explicit => 1, -absolute => 1 ); Function: get/set the objects encoding, either globally or by location(s). Returns : the (possibly new) encoding string. Args : encoding - see the encoding argument to the new() function. explicit - whether or not to return explicit phase information in the coding (i.e. "CCC" becomes "CDE", "III" becomes "IJK", etc); defaults to 0. location - optional; location to get/set the encoding. Defaults to the entire sequence. absolute - whether or not the locational elements (either in the encoding hashref or the location argument) are relative to the absolute start/end of the Bio::LocatableSeq, or to the internal, relative coordinate system (beginning at 1); defaults to 0 (i.e. relative) =cut sub encoding { my ($self, @args) = @_; my ($enc, $loc, $exp, $abs) = $self->_rearrange([qw(ENCODING LOCATION EXPLICIT ABSOLUTE)], @args); if (!$enc) { # do nothing; _recheck_encoding will fix for us, if necessary } elsif (ref $enc eq 'HASH') { $self->throw( -class => 'Bio::Root::NotImplemented', -text => "Hashref functionality not yet implemented;\nplease email me if you really need this."); #TODO: finish all this while (my ($char, $locs) = each %$enc) { if (ref $locs eq 'ARRAY') { } elsif (UNIVERSAL::isa($locs, "Bio::LocationI")) { } else { $self->throw("Only a scalar or a ref to a hash; not a ref to a @{{lc ref $enc}}"); } } } elsif (! ref $enc) { $enc = uc $enc; $exp = 1 if (!defined $exp && $enc =~ m/[DEJKV]/o); if ($enc =~ m/\d/o) { # numerically "enhanced" encoding my $numenc = $enc; $enc = ''; while ($numenc =~ m/\G(\d*)([CDEIJKUVGFB])/g) { my ($num, $char) = ($1, $2); $num = 1 unless $num; $enc .= $char x $num; } } if (defined $exp && $exp == 0 && $enc =~ m/([^CIUGFB])/) { $self->throw("Unrecognized character '$1' in implicit encoding"); } elsif ($enc =~ m/[^CDEIJKUVGFB]/) { $self->throw("Unrecognized character '$1' in explicit encoding"); } if ($loc) { # a global location, over which to apply the specified encoding. # balk if too many non-gap characters present in encoding: my ($ct) = $enc =~ tr/GB/GB/; $ct = length($enc) - $ct; $self->throw("Location length doesn't match number of coding chars in encoding!") if ($loc->location_type eq 'EXACT' && $loc->length != $ct); my $start = $loc->start; my $end = $loc->end; # strip any encoding that hangs off the ends of the sequence: if ($start < $self->start) { my $diff = $self->start - $start; $start = $self->start; $enc = substr($enc, $diff); } if ($end > $self->end) { my $diff = $end - $self->end; $end = $self->end; $enc = substr($enc, -$diff); } my $currenc = $self->{_encoding}; my $currseq = $self->seq; my ($spanstart, $spanend) = ($self->column_from_residue_number($start), $self->column_from_residue_number($end) ); if ($currseq) { # strip any gaps in sequence spanned by this location: ($spanstart, $spanend) = ($spanend, $spanstart) if $self->strand < 0; my ($before, $in, $after) = $currseq =~ m/(.{@{[ $spanstart - ($loc->location_type eq 'IN-BETWEEN' ? 0 : 1) ]}}) (.{@{[ $spanend - $spanstart + ($loc->location_type eq 'IN-BETWEEN' ? -1 : 1) ]}}) (.*) /x; $in ||= ''; $in =~ s/[\.\-]+//g; $currseq = ($before||'') . $in. ($after||''); # change seq without changing the alphabet $self->seq($currseq,$self->alphabet()); } $currenc = reverse $currenc if $self->strand < 0; substr($currenc, $spanstart, $spanend - $spanstart + ($loc->location_type eq 'IN-BETWEEN' ? -1 : 1), $self->strand >= 0 ? $enc : reverse $enc); $currenc = reverse $currenc if $self->strand < 0; $self->{_encoding} = $currenc; $self->_recheck_encoding; $currenc = $self->{_encoding}; $currenc = reverse $currenc if $self->strand < 0; $enc = substr($currenc, $spanstart, length $enc); $enc = reverse $enc if $self->strand < 0; return $exp ? $enc: $self->_convert2implicit($enc); } else { # presume a global redefinition; strip any current gap # characters in the sequence so they don't corrupt the # encoding my $dna = $self->seq; $dna =~ s/[\.\-]//g; $self->seq($dna, 'dna'); $self->{_encoding} = $enc; } } else { $self->throw("Only a scalar or a ref to a hash; not a ref to a @{{lc ref $enc}}"); } $self->_recheck_encoding(); return $exp ? $self->{_encoding} : $self->_convert2implicit($self->{_encoding}); } sub _convert2implicit { my ($self, $enc) = @_; $enc =~ s/[DE]/C/g; $enc =~ s/[JK]/I/g; $enc =~ s/V/U/g; return $enc; } sub _recheck_encoding { my $self = shift; my @enc = split //, ($self->{_encoding} || ''); my @nt = split(//, $self->SUPER::seq); @nt = reverse @nt if $self->strand && $self->strand < 0; # make sure an encoding exists! @enc = ('C') x scalar grep { !/[\.\-]/o } @nt unless @enc; # check for gaps to be truly present in the sequence # and vice versa my $i; for ($i = 0 ; $i < @nt && $i < @enc ; $i++) { if ($nt[$i] =~ /[\.\-]/o && $enc[$i] !~ m/[GB]/o) { splice(@enc, $i, 0, 'G'); } elsif ($nt[$i] !~ /[\.\-]/o && $enc[$i] =~ m/[GB]/o) { splice(@nt, $i, 0, '-'); } } if ($i < @enc) { # extra encoding; presumably all gaps? for ( ; $i < @enc ; $i++) { if ($enc[$i] =~ m/[GB]/o) { push @nt, '-'; } else { $self->throw("Extraneous encoding info: " . join('', @enc[$i..$#enc])); } } } elsif ($i < @nt) { for ( ; $i < @nt ; $i++) { if ($nt[$i] =~ m/[\.\-]/o) { push @enc, 'G'; } else { push @enc, 'C'; } } } my @cde_array = qw(C D E); my @ijk_array = qw(I J K); # convert any leftover implicit coding into explicit coding my ($Cct, $Ict, $Uct, $Vct, $Vwarned) = (0, 0, 0, 0); for ($i = 0 ; $i < @enc ; $i++) { if ($enc[$i] =~ m/[CDE]/o) { my $temp_index = $Cct %3; $enc[$i] = $cde_array[$temp_index]; $Cct++; $Ict = 0; $Uct = 1; $self->warn("3' untranslated encoding (V) seen prior to other coding symbols") if ($Vct && !$Vwarned++); } elsif ($enc[$i] =~ m/[IJK]/o) { $enc[$i] = $ijk_array[$Ict % 3]; $Ict++; $Uct = 1; $self->warn("3' untranslated encoding (V) seen before other coding symbols") if ($Vct && !$Vwarned++); } elsif ($enc[$i] =~ m/[UV]/o) { if ($Uct == 1) { $enc[$i] = 'V'; $Vct = 1; } } elsif ($enc[$i] eq 'B') { $Cct++; $Ict++ } elsif ($enc[$i] eq 'G') { # gap; leave alone } } @nt = reverse @nt if $self->strand && $self->strand < 0; $self->seq(join('', @nt), 'dna'); $self->{_encoding} = join '', @enc; } =head2 cds Title : cds Usage : $cds = $obj->cds(-nogaps => 1); Function: obtain the "spliced" DNA sequence, by removing any nucleotides that participate in an UTR, forward frameshift or intron, and replacing any unknown nucleotide implied by a backward frameshift or gap with N's. Returns : a Bio::Seq::EncodedSeq object, with an encoding consisting only of "CCCC..". Args : nogaps - strip any gap characters (resulting from 'G' or 'B' encodings), rather than replacing them with N's. =cut sub cds { my ($self, @args) = @_; my ($nogaps, $loc) = $self->_rearrange([qw(NOGAPS LOCATION)], @args); $nogaps = 0 unless defined $nogaps; my @nt = split //, $self->strand < 0 ? $self->revcom->seq : $self->seq; my @enc = split //, $self->_convert2implicit($self->{_encoding}); my ($start, $end) = (0, scalar @nt); if ($loc) { $start = $loc->start; $start++ if $loc->location_type eq 'IN-BETWEEN'; $start = $self->column_from_residue_number($start); $start--; $end = $loc->end; $end = $self->column_from_residue_number($end); ($start, $end) = ($end, $start) if $self->strand < 0; $start--; } for (my $i = $start ; $i < $end ; $i++) { if ($enc[$i] eq 'I' || $enc[$i] eq 'U' || $enc[$i] eq 'F') { # remove introns, untranslated and forward frameshift nucleotides $nt[$i] = undef; } elsif ($enc[$i] eq 'G' || $enc[$i] eq 'B') { # replace gaps and backward frameshifts with N's, unless asked not to. $nt[$i] = $nogaps ? undef : 'N'; } } return ($self->can_call_new ? ref($self) : __PACKAGE__)->new( -seq => join('', grep { defined } @nt[$start..--$end]), -start => $self->start, -end => $self->end, -strand => 1, -alphabet => 'dna' ); } =head2 translate Title : translate Usage : $prot = $obj->translate(@args); Function: obtain the protein sequence encoded by the underlying DNA sequence; same as $obj->cds()->translate(@args). Returns : a Bio::PrimarySeq object. Args : same as the translate() function of Bio::PrimarySeqI =cut sub translate { shift->cds(-nogaps => 1, @_)->SUPER::translate(@_) }; =head2 protseq Title : seq Usage : $protseq = $obj->protseq(); Function: obtain the raw protein sequence encoded by the underlying DNA sequence; This is the same as calling $obj->translate()->seq(); Returns : a string of single-letter amino acid codes Args : same as the seq() function of Bio::PrimarySeq; note that this function may not be used to set the protein sequence; see the dnaseq() function for that. =cut sub protseq { shift->cds(-nogaps => 1, @_)->SUPER::translate(@_)->seq }; =head2 dnaseq Title : dnaseq Usage : $dnaseq = $obj->dnaseq(); $obj->dnaseq("ACGTGTCGT", "CCCCCCCCC"); $obj->dnaseq(-seq => "ATG", -encoding => "CCC", -location => $loc ); @introns = $obj->$dnaseq(-encoding => 'I') Function: get/set the underlying DNA sequence; will overwrite any current DNA and/or encoding information present. Returns : a string of single-letter nucleotide codes, including any gaps implied by the encoding. Args : seq - the DNA sequence to be used as a replacement encoding - the encoding of the DNA sequence (see the new() constructor); defaults to all 'C' if setting a new DNA sequence. If no new DNA sequence is being provided, then the encoding is used as a "filter" for which to return fragments of non-overlapping DNA that match the encoding. location - optional, the location of the DNA sequence to get/set; defaults to the entire sequence. =cut sub dnaseq { my ($self, @args) = @_; my ($seq, $enc, $loc) = $self->_rearrange([qw(DNASEQ ENCODING LOCATION)], @args); return $self; } # need to overload this so that we truncate both the seq and the encoding! sub trunc { my ($self, $start, $end) = @_; my $new = $self->SUPER::trunc($start, $end); $start--; my $enc = $self->{_encoding}; $enc = reverse $enc if $self->strand < 0; $enc = substr($enc, $start, $end - $start); $enc = reverse $enc if $self->strand < 0; $new->encoding($enc); return $new; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/LargeLocatableSeq.pm��������������������������������������������������������000444��000765��000024�� 20326�12254227322� 20571� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Seq::LargeLocatableSeq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Albert Vilella # # based on the Bio::LargePrimarySeq module # by Ewan Birney <birney@sanger.ac.uk> # # and the Bio::LocatableSeq module # by Ewan Birney <birney@sanger.ac.uk> # # Copyright Albert Vilella # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::LargeLocatableSeq - LocatableSeq object that stores sequence as files in the tempdir =head1 SYNOPSIS # normal primary seq usage use Bio::Seq::LargeLocatableSeq; my $seq = Bio::Seq::LargeLocatableSeq->new(-seq => "CAGT-GGT", -id => "seq1", -start => 1, -end => 7); =head1 DESCRIPTION Bio::Seq::LargeLocatableSeq - object with start/end points on it that can be projected into a MSA or have coordinates relative to another seq. This object, unlike Bio::LocatableSeq, stores a sequence as a series of files in a temporary directory. The aim is to allow someone the ability to store very large sequences (eg, E<gt> 100MBases) in a file system without running out of memory (eg, on a 64 MB real memory machine!). Of course, to actually make use of this functionality, the programs which use this object B<must> not call $primary_seq-E<gt>seq otherwise the entire sequence will come out into memory and probably crash your machine. However, calls like $primary_seq-E<gt>subseq(10,100) will cause only 90 characters to be brought into real memory. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Albert Vilella Email avilella-AT-gmail-DOT-com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::LargeLocatableSeq; use vars qw($AUTOLOAD); use strict; use base qw(Bio::Seq::LargePrimarySeq Bio::LocatableSeq Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Seq::LargeLocatableSeq->new(); Function: Builds a new Bio::Seq::LargeLocatableSeq object Returns : an instance of Bio::Seq::LargeLocatableSeq Args : =cut sub new { my ($class, %params) = @_; # don't let PrimarySeq set seq until we have # opened filehandle my $seq = $params{'-seq'} || $params{'-SEQ'}; if($seq ) { delete $params{'-seq'}; delete $params{'-SEQ'}; } my $self = $class->SUPER::new(%params); my $mapping = exists $params{'-mapping'} ? $params{'-mapping'} : [1,1]; $self->mapping($mapping); $self->_initialize_io(%params); my $tempdir = $self->tempdir( CLEANUP => 1); my ($tfh,$file) = $self->tempfile( DIR => $tempdir ); $tfh && $self->_fh($tfh); $file && $self->_filename($file); $self->length(0); $seq && $self->seq($seq); return $self; } =head2 length Title : length Usage : Function: Example : Returns : Args : =cut sub length { my ($obj,$value) = @_; if( defined $value) { $obj->{'length'} = $value; } return (defined $obj->{'length'}) ? $obj->{'length'} : 0; } =head2 seq Title : seq Usage : Function: Example : Returns : Args : =cut sub seq { my ($self, $data) = @_; if( defined $data ) { if( $self->length() == 0) { $self->add_sequence_as_string($data); } else { $self->warn("Trying to reset the seq string, cannot do this with a LargeLocatableSeq - must allocate a new object"); } } return $self->subseq(1,$self->length); } =head2 subseq Title : subseq Usage : Function: Example : Returns : Args : =cut sub subseq{ my ($self,$start,$end) = @_; my $string; my $fh = $self->_fh(); if( ref($start) && $start->isa('Bio::LocationI') ) { my $loc = $start; if( $loc->length == 0 ) { $self->warn("Expect location lengths to be > 0"); return ''; } elsif( $loc->end < $loc->start ) { # what about circular seqs $self->warn("Expect location start to come before location end"); } my $seq = ''; if( $loc->isa('Bio::Location::SplitLocationI') ) { foreach my $subloc ( $loc->sub_Location ) { if(! seek($fh,$subloc->start() - 1,0)) { $self->throw("Unable to seek on file $start:$end $!"); } my $ret = read($fh, $string, $subloc->length()); if( !defined $ret ) { $self->throw("Unable to read $start:$end $!"); } if( $subloc->strand < 0 ) { # $string = Bio::PrimarySeq->new(-seq => $string)->revcom()->seq(); $string = Bio::Seq::LargePrimarySeq->new(-seq => $string)->revcom()->seq(); } $seq .= $string; } } else { if(! seek($fh,$loc->start()-1,0)) { $self->throw("Unable to seek on file ".$loc->start.":". $loc->end ." $!"); } my $ret = read($fh, $string, $loc->length()); if( !defined $ret ) { $self->throw("Unable to read ".$loc->start.":". $loc->end ." $!"); } $seq = $string; } if( defined $loc->strand && $loc->strand < 0 ) { # $seq = Bio::PrimarySeq->new(-seq => $string)->revcom()->seq(); $seq = Bio::Seq::LargePrimarySeq->new(-seq => $seq)->revcom()->seq(); } return $seq; } if( $start <= 0 || $end > $self->length ) { $self->throw("Attempting to get a subseq out of range $start:$end vs ". $self->length); } if( $end < $start ) { $self->throw("Attempting to subseq with end ($end) less than start ($start). To revcom use the revcom function with trunc"); } if(! seek($fh,$start-1,0)) { $self->throw("Unable to seek on file $start:$end $!"); } my $ret = read($fh, $string, $end-$start+1); if( !defined $ret ) { $self->throw("Unable to read $start:$end $!"); } return $string; } =head2 add_sequence_as_string Title : add_sequence_as_string Usage : $seq->add_sequence_as_string("CATGAT"); Function: Appends additional residues to an existing LargeLocatableSeq object. This allows one to build up a large sequence without storing entire object in memory. Returns : Current length of sequence Args : string to append =cut sub add_sequence_as_string{ my ($self,$str) = @_; my $len = $self->length + CORE::length($str); my $fh = $self->_fh(); if(! seek($fh,0,2)) { $self->throw("Unable to seek end of file: $!"); } $self->_print($str); $self->length($len); } =head2 _filename Title : _filename Usage : $obj->_filename($newval) Function: Example : Returns : value of _filename Args : newvalue (optional) =cut sub _filename{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_filename'} = $value; } return $obj->{'_filename'}; } =head2 alphabet Title : alphabet Usage : $obj->alphabet($newval) Function: Example : Returns : value of alphabet Args : newvalue (optional) =cut sub alphabet{ my ($self,$value) = @_; if( defined $value) { $self->SUPER::alphabet($value); } return $self->SUPER::alphabet() || 'dna'; } sub DESTROY { my $self = shift; my $fh = $self->_fh(); close($fh) if( defined $fh ); # this should be handled by Tempfile removal, but we'll unlink anyways. unlink $self->_filename() if defined $self->_filename() && -e $self->_filename; $self->SUPER::DESTROY(); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/LargePrimarySeq.pm����������������������������������������������������������000444��000765��000024�� 17170�12254227321� 20330� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::LargePrimarySeq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # # updated to utilize File::Temp - jason 2000-12-12 # POD documentation - main docs before the code =head1 NAME Bio::Seq::LargePrimarySeq - PrimarySeq object that stores sequence as files in the tempdir (as found by File::Temp) or the default method in Bio::Root::Root =head1 SYNOPSIS # normal primary seq usage =head1 DESCRIPTION This object stores a sequence as a series of files in a temporary directory. The aim is to allow someone the ability to store very large sequences (eg, E<gt> 100MBases) in a file system without running out of memory (eg, on a 64 MB real memory machine!). Of course, to actually make use of this functionality, the programs which use this object B<must> not call $primary_seq-E<gt>seq otherwise the entire sequence will come out into memory and probably paste your machine. However, calls $primary_seq-E<gt>subseq(10,100) will cause only 90 characters to be brought into real memory. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney, Jason Stajich Email birney@ebi.ac.uk Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::LargePrimarySeq; use vars qw($AUTOLOAD); use strict; use base qw(Bio::PrimarySeq Bio::Root::IO Bio::Seq::LargeSeqI); sub new { my ($class, %params) = @_; # don't let PrimarySeq set seq until we have # opened filehandle my $seq = $params{'-seq'} || $params{'-SEQ'}; if($seq ) { delete $params{'-seq'}; delete $params{'-SEQ'}; } my $self = $class->SUPER::new(%params); $self->_initialize_io(%params); my $tempdir = $self->tempdir( CLEANUP => 1); my ($tfh,$file) = $self->tempfile( DIR => $tempdir ); $self->{tempdir} = $tempdir; $tfh && $self->_fh($tfh); $file && $self->_filename($file); $self->length(0); $seq && $self->seq($seq); return $self; } =head2 length Title : length Usage : Function: Example : Returns : Args : =cut sub length { my ($obj,$value) = @_; if( defined $value) { $obj->{'length'} = $value; } return (defined $obj->{'length'}) ? $obj->{'length'} : 0; } =head2 seq Title : seq Usage : Function: Example : Returns : Args : =cut sub seq { my ($self, $data) = @_; if( defined $data ) { if( $self->length() == 0) { $self->add_sequence_as_string($data); } else { $self->warn("Trying to reset the seq string, cannot do this with a LargePrimarySeq - must allocate a new object"); } } return $self->subseq(1,$self->length); } =head2 subseq Title : subseq Usage : Function: Example : Returns : Args : =cut sub subseq{ my ($self,$start,$end) = @_; my $string; my $fh = $self->_fh(); if( ref($start) && $start->isa('Bio::LocationI') ) { my $loc = $start; if( $loc->length == 0 ) { $self->warn("Expect location lengths to be > 0"); return ''; } elsif( $loc->end < $loc->start ) { # what about circular seqs $self->warn("Expect location start to come before location end"); } my $seq = ''; if( $loc->isa('Bio::Location::SplitLocationI') ) { foreach my $subloc ( $loc->sub_Location ) { if(! seek($fh,$subloc->start() - 1,0)) { $self->throw("Unable to seek on file $start:$end $!"); } my $ret = read($fh, $string, $subloc->length()); if( !defined $ret ) { $self->throw("Unable to read $start:$end $!"); } if( $subloc->strand < 0 ) { $string = Bio::PrimarySeq->new(-seq => $string)->revcom()->seq(); } $seq .= $string; } } else { if(! seek($fh,$loc->start()-1,0)) { $self->throw("Unable to seek on file ".$loc->start.":". $loc->end ." $!"); } my $ret = read($fh, $string, $loc->length()); if( !defined $ret ) { $self->throw("Unable to read ".$loc->start.":". $loc->end ." $!"); } $seq = $string; } if( defined $loc->strand && $loc->strand < 0 ) { $seq = Bio::PrimarySeq->new(-seq => $seq)->revcom()->seq(); } return $seq; } if( $start <= 0 || $end > $self->length ) { $self->throw("Attempting to get a subseq out of range $start:$end vs ". $self->length); } if( $end < $start ) { $self->throw("Attempting to subseq with end ($end) less than start ($start). To revcom use the revcom function with trunc"); } if(! seek($fh,$start-1,0)) { $self->throw("Unable to seek on file $start:$end $!"); } my $ret = read($fh, $string, $end-$start+1); if( !defined $ret ) { $self->throw("Unable to read $start:$end $!"); } return $string; } =head2 add_sequence_as_string Title : add_sequence_as_string Usage : $seq->add_sequence_as_string("CATGAT"); Function: Appends additional residues to an existing LargePrimarySeq object. This allows one to build up a large sequence without storing entire object in memory. Returns : Current length of sequence Args : string to append =cut sub add_sequence_as_string{ my ($self,$str) = @_; my $len = $self->length + CORE::length($str); my $fh = $self->_fh(); if(! seek($fh,0,2)) { $self->throw("Unable to seek end of file: $!"); } $self->_print($str); $self->length($len); } =head2 _filename Title : _filename Usage : $obj->_filename($newval) Function: Example : Returns : value of _filename Args : newvalue (optional) =cut sub _filename{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_filename'} = $value; } return $obj->{'_filename'}; } =head2 alphabet Title : alphabet Usage : $obj->alphabet($newval) Function: Example : Returns : value of alphabet Args : newvalue (optional) =cut sub alphabet{ my ($self,$value) = @_; if( defined $value) { $self->SUPER::alphabet($value); } return $self->SUPER::alphabet() || 'dna'; } sub DESTROY { my $self = shift; my $fh = $self->_fh(); close($fh) if( defined $fh ); # this should be handled by Tempfile removal, but we'll unlink anyways. unlink $self->_filename() if defined $self->_filename() && -e $self->_filename; # remove tempdirs as well rmdir $self->{tempdir} if defined $self->{tempdir} && -e $self->{tempdir}; $self->SUPER::DESTROY(); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/LargeSeq.pm�����������������������������������������������������������������000444��000765��000024�� 7225�12254227335� 16751� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::LargeSeq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney, Jason Stajich # # Copyright Ewan Birney, Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::LargeSeq - SeqI compliant object that stores sequence as files in /tmp =head1 SYNOPSIS # normal primary seq usage =head1 DESCRIPTION This object stores a sequence as a series of files in a temporary directory. The aim is to allow someone the ability to store very large sequences (eg, E<gt> 100MBases) in a file system without running out of memory (eg, on a 64 MB real memory machine!). Of course, to actually make use of this functionality, the programs which use this object B<must> not call $primary_seq-E<gt>seq otherwise the entire sequence will come out into memory and probably paste your machine. However, calls $primary_seq-E<gt>subseq(10,100) will cause only 90 characters to be brought into real memory. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::LargeSeq; use vars qw($AUTOLOAD); use strict; # Object preamble use Bio::Seq::LargePrimarySeq; use base qw(Bio::Seq Bio::Seq::LargeSeqI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($pseq) = $self->_rearrange([qw(PRIMARYSEQ)], @args); if( ! defined $pseq ) { $pseq = Bio::Seq::LargePrimarySeq->new(@args); } $self->primary_seq($pseq); return $self; } =head2 trunc Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence, Example : Returns : a fresh Bio::SeqI object Args : =cut sub trunc { my ($self, $s, $e) = @_; return new Bio::Seq::LargeSeq ('-display_id' => $self->display_id, '-accession_number' => $self->accession_number, '-desc' => $self->desc, '-alphabet' => $self->alphabet, -primaryseq => $self->primary_seq->trunc($s,$e)); } =head2 Bio::Seq::LargePrimarySeq methods =cut =head2 add_sequence_as_string Title : add_sequence_as_string Usage : $seq->add_sequence_as_string("CATGAT"); Function: Appends additional residues to an existing LargePrimarySeq object. This allows one to build up a large sequence without storing entire object in memory. Returns : Current length of sequence Args : string to append =cut sub add_sequence_as_string { my ($self,$str) = @_; return $self->primary_seq->add_sequence_as_string($str); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/LargeSeqI.pm����������������������������������������������������������������000444��000765��000024�� 5457�12254227320� 17061� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::LargeSeqI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Albert Vilella # # Copyright Albert Vilella # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::LargeSeqI - Interface class for sequences that cache their residues in a temporary file =head1 SYNOPSIS # =head1 DESCRIPTION The interface class defines a group of sequence classes that do not keep their sequence information in memory but store it in a file. This makes it possible to work with very large files even with limited RAM. The most important consequence of file caching for sequences is that you do not want to inspect the sequence unless absolutely necessary. These sequences typically override the length() method not to check the sequence. The seq() method is not resetable, if you want to add to the end of the sequence you have to use add_sequence_as_string(), for any other sequence changes you'll have to create a new object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Albert Vilella Email avilella-AT-gmail-DOT-com =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::LargeSeqI; use strict; use base qw(Bio::Root::RootI); =head2 add_sequence_as_string Title : add_sequence_as_string Usage : $seq->add_sequence_as_string("CATGAT"); Function: Appends additional residues to an existing object. This allows one to build up a large sequence without storing entire object in memory. Returns : Current length of sequence Args : string to append =cut sub add_sequence_as_string { my ($self) = @_; $self->throw_not_implemented(); } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/Meta.pm���������������������������������������������������������������������000444��000765��000024�� 46752�12254227336� 16165� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::Meta # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::Meta - Generic superclass for sequence objects with residue-based meta information =head1 SYNOPSIS use Bio::LocatableSeq; use Bio::Seq::Meta; use Bio::Tools::OddCodes; use Bio::SeqIO; my $seq = Bio::Seq::Meta->new(-id=>'test', -seq=>'ACTGCTAGCT', -start=>2434, -end=>2443, -strand=>1, -verbose=>1, # to see warnings ); # the existing sequence object can be a Bio::PrimarySeq, too # to test this is a meta seq object $seq->isa("Bio::Seq::Meta") || $seq->throw("$seq is not a Bio::Seq::Meta"); $seq->meta('1234567890'); $seq = Bio::Seq::Meta->new(-id=>'test', -seq=>'HACILMIFGT', -start=>2434, -end=>2443, -strand=>1, -meta=>'1234567890', -verbose=>1, # to see warnings ); # accessors $string = $seq->meta_text(); $substring = $seq->submeta_text(2,5); $unique_key = $seq->accession_number(); # storing output from Bio::Tools::OddCodes as meta data my $protcodes = Bio::Tools::OddCodes->new(-seq => $seq); my @codes = qw(structural chemical functional charge hydrophobic); map { $seq->named_meta($_, ${$protcodes->$_($seq) } )} @codes; my $out = Bio::SeqIO->new(-format=>'metafasta'); $out->write_seq($seq); =head1 DESCRIPTION This class implements generic methods for sequences with residue-based meta information. Meta sequences with meta data are Bio::LocatableSeq objects with additional methods to store that meta information. See L<Bio::LocatableSeq> and L<Bio::Seq::MetaI>. The meta information in this class is always one character per residue long and blank values are space characters (ASCII 32). After the latest rewrite, the meta information no longer covers all the residues automatically. Methods to check the length of meta information (L<meta_length>)and to see if the ends are flushed to the sequence have been added (L<is_flush>). To force the old functionality, set L<force_flush> to true. It is assumed that meta data values do not depend on the nucleotide sequence strand value. Application specific implementations should inherit from this class to override and add to these methods. L<Bio::Seq::Meta::Array> allows for more complex meta values (scalars or objects) to be used. =head2 Method naming Character based meta data is read and set by method meta() and its variants. These are the suffixes and prefixes used in the variants: [named_] [sub] meta [_text] =over 3 =item _text Suffix B<_text> guaranties that output is a string. Note that it does not limit the input. In this implementation, the output is always text, so these methods are redundant. =item sub Prefix B<sub>, like in subseq(), means that the method applies to sub region of the sequence range and takes start and end as arguments. Unlike subseq(), these methods are able to set values. If the range is not defined, it defaults to the complete sequence. =item named Prefix B<named_> in method names allows the used to attach multiple meta strings to one sequence by explicitly naming them. The name is always the first argument to the method. The "unnamed" methods use the class wide default name for the meta data and are thus special cases "named" methods. Note that internally names are keys in a hash and any misspelling of a name will silently store the data under a wrong name. The used names (keys) can be retrieved using method meta_names(). See L<meta_names>. =back =head1 NOTE This Bio::Seq::MetaI implementation inherits from Bio::LocatableSeq, which itself inherits from Bio::PrimarySeq. It is not a Bio::SeqI, so bless-ing objects of this class into a Bio::SeqI or vice versa and will not work as expected (see bug 2262). This may be addressed in a future refactor of Bio::LocatableSeq. =head1 SEE ALSO L<Bio::LocatableSeq>, L<Bio::Seq::MetaI>, L<Bio::Seq::Meta::Array> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Chad Matsalla, bioinformatics@dieselwurks.com Aaron Mackey, amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::Meta; use vars qw($DEFAULT_NAME $GAP $META_GAP); use strict; #use overload '""' => \&to_string; use base qw(Bio::LocatableSeq Bio::Seq::MetaI); BEGIN { $DEFAULT_NAME = 'DEFAULT'; $GAP = '-'; $META_GAP = ' '; } =head2 new Title : new Usage : $metaseq = Bio::Seq::Meta->new ( -meta => 'aaaaaaaabbbbbbbb', -seq => 'TKLMILVSHIVILSRM' -id => 'human_id', -accession_number => 'S000012', ); Function: Constructor for Bio::Seq::Meta class, meta data being in a string. Note that you can provide an empty quality string. Returns : a new Bio::Seq::Meta object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($meta, $forceflush, $nm) = $self->_rearrange([qw(META FORCE_FLUSH NAMED_META)], @args); #$self->{'_meta'} = {}; $self->{'_meta'}->{$DEFAULT_NAME} = ""; $meta && $self->meta($meta); if ($nm && ref($nm) eq 'HASH') { while (my ($name, $meta) = each %$nm) { $self->named_meta($name, $meta); } } $forceflush && $self->force_flush($forceflush); return $self; } =head2 meta Title : meta Usage : $meta_values = $obj->meta($values_string); Function: Get and set method for the meta data starting from residue position one. Since it is dependent on the length of the sequence, it needs to be manipulated after the sequence. The length of the returned value always matches the length of the sequence, if force_flush() is set. See L<force_flush>. Returns : meta data in a string Args : new value, string, optional =cut sub meta { shift->named_meta($DEFAULT_NAME, shift); } =head2 meta_text Title : meta_text Usage : $meta_values = $obj->meta_text($values_arrayref); Function: Variant of meta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : new value, optional =cut sub meta_text { shift->meta(shift); } =head2 named_meta Title : named_meta() Usage : $meta_values = $obj->named_meta($name, $values_arrayref); Function: A more general version of meta(). Each meta data set needs to be named. See also L<meta_names>. Returns : a string Args : scalar, name of the meta data set new value, optional =cut sub named_meta { my ($self, $name, $value) = @_; $name ||= $DEFAULT_NAME; if( defined $value) { $self->throw("I need a scalar value, not [". ref($value). "]") if ref($value); # test for length my $diff = $self->length - CORE::length($value); if ($diff > 0) { $value .= (" " x $diff); } $self->{'_meta'}->{$name} = $value; #$self->_test_gap_positions($name) if $self->verbose > 0; } return " " x $self->length if $self->force_flush && not defined $self->{'_meta'}->{$name}; $self->_do_flush if $self->force_flush; return $self->{'_meta'}->{$name}; } =head2 _test_gap_positions Title : _test_gap_positions Usage : $meta_values = $obj->_test_gap_positions($name); Function: Internal test for correct position of gap characters. Gap being only '-' this time. This method is called from named_meta() when setting meta data but only if verbose is positive as this can be an expensive process on very long sequences. Set verbose(1) to see warnings when gaps do not align in sequence and meta data and turn them into errors by setting verbose(2). Returns : true on success, prints warnings Args : none =cut sub _test_gap_positions { my $self = shift; my $name = shift; my $success = 1; $self->seq || return $success; my $len = CORE::length($self->seq); for (my $i=0; $i < $len; $i++) { my $s = substr $self->{seq}, $i, 1; my $m = substr $self->{_meta}->{$name}, $i, 1; $self->warn("Gap mismatch [$m/$s] in column [". ($i+1). "] of [$name] meta data in seq [". $self->id. "]") and $success = 0 if ($s eq $META_GAP) && $s ne $m; } return $success; } =head2 named_meta_text Title : named_meta_text() Usage : $meta_values = $obj->named_meta_text($name, $values_arrayref); Function: Variant of named_meta() guarantied to return a textual representation of the named meta data. For details, see L<meta>. Returns : a string Args : scalar, name of the meta data set new value, optional =cut sub named_meta_text { shift->named_meta(@_); } =head2 submeta Title : submeta Usage : $subset_of_meta_values = $obj->submeta(10, 20, $value_string); $subset_of_meta_values = $obj->submeta(10, undef, $value_string); Function: Get and set method for meta data for subsequences. Numbering starts from 1 and the number is inclusive, ie 1-2 are the first two residue of the sequence. Start cannot be larger than end but can be equal. If the second argument is missing the returned values should extend to the end of the sequence. The return value may be a string or an array reference, depending on the implementation. If in doubt, use submeta_text() which is a variant guarantied to return a string. See L<submeta_text>. Returns : A reference to an array or a string Args : integer, start position integer, end position, optional when a third argument present new value, optional =cut sub submeta { shift->named_submeta($DEFAULT_NAME, @_); } =head2 submeta_text Title : submeta_text Usage : $meta_values = $obj->submeta_text(20, $value_string); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : new value, optional =cut sub submeta_text { shift->submeta(@_); } =head2 named_submeta Title : named_submeta Usage : $subset_of_meta_values = $obj->named_submeta($name, 10, 20, $value_string); $subset_of_meta_values = $obj->named_submeta($name, 10); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : A reference to an array or a string Args : scalar, name of the meta data set integer, start position integer, end position, optional when a third argument present new value, optional =cut sub named_submeta { my ($self, $name, $start, $end, $value) = @_; $name ||= $DEFAULT_NAME; $start ||=1; $start =~ /^[+]?\d+$/ and $start > 0 or $self->throw("Need at least a positive integer start value"); if ($value) { $end ||= $start+length($value)-1; $self->warn("You are setting meta values beyond the length of the sequence\n". "[$start > ". length($self->seq)."] in sequence ". $self->id) if $start > length $self->seq; # pad meta data if needed $self->{_meta}->{$name} = () unless defined $self->{_meta}->{$name}; if (length($self->{_meta}->{$name}) < $start) { $self->{'_meta'}->{$name} .= " " x ( $start - length($self->{'_meta'}->{$name}) -1); } my $tail = ''; $tail = substr ($self->{_meta}->{$name}, $start-1+length($value)) if length($self->{_meta}->{$name}) >= $start-1+length($value); substr ($self->{_meta}->{$name}, --$start) = $value; $self->{_meta}->{$name} .= $tail; return substr ($self->{_meta}->{$name}, $start, $end - $start + 1); } else { $end or $end = length $self->seq; # pad meta data if needed if (length($self->{_meta}->{$name}) < $end) { $self->{'_meta'}->{$name} .= " " x ( $start - length($self->{'_meta'}->{$name})); } return substr ($self->{_meta}->{$name}, $start-1, $end - $start + 1) } } =head2 named_submeta_text Title : named_submeta_text Usage : $meta_values = $obj->named_submeta_text($name, 20, $value_string); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : scalar, name of the meta data Args : integer, start position, optional integer, end position, optional new value, optional =cut sub named_submeta_text { shift->named_submeta(@_); } =head2 meta_names Title : meta_names Usage : @meta_names = $obj->meta_names() Function: Retrieves an array of meta data set names. The default (unnamed) set name is guarantied to be the first name. Returns : an array of names Args : none =cut sub meta_names { my ($self) = @_; my @r; foreach ( sort keys %{$self->{'_meta'}} ) { push (@r, $_) unless $_ eq $DEFAULT_NAME; } unshift @r, $DEFAULT_NAME if $self->{'_meta'}->{$DEFAULT_NAME}; return @r; } =head2 meta_length Title : meta_length() Usage : $meeta_len = $obj->meta_length(); Function: return the number of elements in the meta set Returns : integer Args : - =cut sub meta_length { my ($self) = @_; return $self->named_meta_length($DEFAULT_NAME); } =head2 named_meta_length Title : named_meta_length() Usage : $meta_len = $obj->named_meta_length($name); Function: return the number of elements in the named meta set Returns : integer Args : - =cut sub named_meta_length { my ($self, $name) = @_; $name ||= $DEFAULT_NAME; return length ($self->{'_meta'}->{$name}); } =head2 force_flush Title : force_flush() Usage : $force_flush = $obj->force_flush(1); Function: Automatically pad with empty values or truncate meta values to sequence length. Not done by default. Returns : boolean 1 or 0 Args : optional boolean value Note that if you turn this forced padding off, the previously padded values are not changed. =cut sub force_flush { my ($self, $value) = @_; if (defined $value) { if ($value) { $self->{force_flush} = 1; $self->_do_flush; } else { $self->{force_flush} = 0; } } return $self->{force_flush}; } =head2 _do_flush Title : _do_flush Usage : Function: internal method to do the force that meta values are same length as the sequence . Called from L<force_flush> Returns : Args : =cut sub _do_flush { my ($self) = @_; foreach my $name ( ('DEFAULT', $self->meta_names) ) { # elongnation if ($self->length > $self->named_meta_length($name)) { $self->{'_meta'}->{$name} .= $META_GAP x ($self->length - $self->named_meta_length($name)) ; } # truncation elsif ( $self->length < $self->named_meta_length($name) ) { $self->{_meta}->{$name} = substr($self->{_meta}->{$name}, 0, $self->length-1); } } } =head2 is_flush Title : is_flush Usage : $is_flush = $obj->is_flush() or $is_flush = $obj->is_flush($my_meta_name) Function: Boolean to tell if all meta values are in flush with the sequence length. Returns true if force_flush() is set Set verbosity to a positive value to see failed meta sets Returns : boolean 1 or 0 Args : optional name of the meta set =cut sub is_flush { my ($self, $name) = shift; return 1 if $self->force_flush; my $sticky = ''; if ($name) { $sticky .= "$name " if $self->length != $self->named_meta_length($name); } else { foreach my $m ($self->meta_names) { $sticky .= "$m " if ($self->named_meta_length($m) > 0) && ($self->length != $self->named_meta_length($m)); } } if ($sticky) { print "These meta set are not flush: $sticky\n" if $self->verbose; return 0; } return 1; } =head1 Bio::PrimarySeqI methods =head2 revcom Title : revcom Usage : $newseq = $seq->revcom(); Function: Produces a new Bio::Seq::MetaI implementing object where the order of residues and their meta information is reversed. Returns : A new (fresh) Bio::Seq::Meta object Args : none Throws : if the object returns false on is_flush() Note: The method does nothing to meta values, it reorders them, only. =cut sub revcom { my $self = shift; $self->throw("Can not get a reverse complement. The object is not flush.") unless $self->is_flush; my $new = $self->SUPER::revcom; foreach (keys %{$self->{_meta}}) { $new->named_meta($_, scalar reverse $self->{_meta}->{$_} ); }; return $new; } =head2 trunc Title : trunc Usage : $subseq = $seq->trunc(10,100); Function: Provides a truncation of a sequence together with meta data Returns : a fresh Bio::Seq::Meta implementing object Args : Two integers denoting first and last residue of the sub-sequence. =cut sub trunc { my ($self, $start, $end) = @_; # test arguments $start =~ /^[+]?\d+$/ and $start > 0 or $self->throw("Need at least a positive integer start value as start"); $end =~ /^[+]?\d+$/ and $end > 0 or $self->throw("Need at least a positive integer start value as end"); $end >= $start or $self->throw("End position has to be larger or equal to start"); $end <= $self->length or $self->throw("End position can not be larger than sequence length"); my $new = $self->SUPER::trunc($start, $end); $start--; foreach (keys %{$self->{_meta}}) { $new->named_meta($_, substr($self->{_meta}->{$_}, $start, $end - $start) ); }; return $new; } sub to_string { my ($self) = @_; my $out = Bio::SeqIO->new(-format=>'metafasta'); $out->write_seq($self); return 1; } 1; ����������������������BioPerl-1.6.923/Bio/Seq/MetaI.pm��������������������������������������������������������������������000444��000765��000024�� 27412�12254227322� 16261� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::MetaI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::MetaI - Interface for sequence objects with residue-based meta information =head1 SYNOPSIS # get a Bio::Seq::MetaI compliant object somehow # to test this is a meta seq object $obj->isa("Bio::Seq::MetaI") || $obj->throw("$obj not a Bio::Seq::MetaI"); # accessors $string = $obj->meta; $string = $obj->meta_text; $substring = $obj->submeta(12,50); $unique_key = $obj->accession_number(); =head1 DESCRIPTION This class defines an abstract interface for basic residue-based meta information. Examples of this kind of meta data are secondary structures (RNA and protein), protein hydrophobicity assignments, or other alternative alphabets for polypeptides, sequence quality data and nucleotide alignments with translations. The length of the meta data sequence is not dependent on the amount of the meta information. The meta information always covers all the residues, but a blank value is used to denote unavailable information. If necessary the implementation quietly truncates or extends meta information with blank values. Definition of blank is implementation dependent. Gaps in MSAs should not have meta information. At this point a residue in a sequence object can have only one meta value. If you need more, use multiple copies of the sequence object. Meta data storage can be implemented in various ways, e.g: string, array of scalars, array of hashes, array of objects. If the implementation so chooses, there can be more then one meta values associated to each residue. See L<named_meta> and L<names_submeta>. Note that use of arbitrary names is very prone to typos leading to creation of additional copies of meta data sets. Bio::Seq::Meta provides basic, pure perl implementation of sequences with meta information. See L<Bio::Seq::Meta>. Application specific implementations will override and add to these methods. =head2 Method naming Character based meta data is read and set by method meta() and its variants. These are the suffixes and prefixes used in the variants: [named_] [sub] meta [_text] =over 3 =item _text Suffix B<_text> guaranties that output is a string. Note that it does not limit the input. =item sub Prefix B<sub>, like in subseq(), means that the method applies to sub region of the sequence range and takes start and end as arguments. Unlike subseq(), these methods are able to set values. If the range is not defined, it defaults to the complete sequence. =item named_ Prefix B<named_> in method names allows the used to attach multiple meta strings to one sequence by explicitly naming them. The name is always the first argument to the method. The "unnamed" methods use the class wide default name for the meta data and are thus special cases "named" methods. Note that internally names are keys in a hash and any misspelling of a name will silently store the data under a wrong name. The used names (keys) can be retrieved using method meta_names(). See L<meta_names>. =back =head1 SEE ALSO L<Bio::Seq::Meta>, L<Bio::Seq::Meta::Array>, L<Bio::Seq::EncodedSeq>, L<Bio::Tools::OddCodes>, L<Bio::Seq::Quality> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Chad Matsalla, bioinformatics@dieselwurks.com; Aaron Mackey, amackey@virginia.edu; Peter Schattner schattner@alum.mit.edu; Richard Adams, Richard.Adams@ed.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::MetaI; use strict; use base qw(Bio::Root::RootI); =head2 meta Title : meta Usage : $meta_values = $obj->meta($values_string); Function: Get and set method for the unnamed meta data starting from residue position one. Since it is dependent on the length of the sequence, it needs to be manipulated after the sequence. The implementation may choose to accept argument values in a string or in an array (reference) or in a hash (reference). The return value may be a string or an array reference, depending on the implentation. If in doubt, use meta_text() which is a variant guarantied to return a string. See L<meta_text>. The length of the returned value always matches the length of the sequence. Returns : A reference to an array or a string Args : new value, optional =cut sub meta { shift->throw_not_implemented } =head2 meta_text Title : meta_text() Usage : $meta_values = $obj->meta_text($values_arrayref); Function: Variant of meta() guarantied to return a textual representation of the meta data. For details, see L<meta>. Returns : a string Args : new value, optional =cut sub meta_text { shift->throw_not_implemented } =head2 named_meta Title : named_meta() Usage : $meta_values = $obj->named_meta($name, $values_arrayref); Function: A more general version of meta(). Each meta data set needs to be named. See also L<meta_names>. Returns : a string Args : scalar, name of the meta data set new value, optional =cut sub named_meta { shift->throw_not_implemented } =head2 named_meta_text Title : named_meta_text() Usage : $meta_values = $obj->named_meta_text($name, $values_arrayref); Function: Variant of named_meta() guarantied to return a textual representation of the named meta data. For details, see L<meta>. Returns : a string Args : scalar, name of the meta data set new value, optional =cut sub named_meta_text { shift->throw_not_implemented } =head2 submeta Title : submeta Usage : $subset_of_meta_values = $obj->submeta(10, 20, $value_string); $subset_of_meta_values = $obj->submeta(10, undef, $value_string); Function: Get and set method for meta data for subsequences. Numbering starts from 1 and the number is inclusive, ie 1-2 are the first two residue of the sequence. Start cannot be larger than end but can be equal. If the second argument is missing the returned values should extend to the end of the sequence. If implementation tries to set values beyond the current sequence, they should be ignored. The return value may be a string or an array reference, depending on the implentation. If in doubt, use submeta_text() which is a variant guarantied to return a string. See L<submeta_text>. Returns : A reference to an array or a string Args : integer, start position, optional integer, end position, optional new value, optional =cut sub submeta { shift->throw_not_implemented } =head2 submeta_text Title : submeta_text Usage : $meta_values = $obj->submeta_text(20, $value_string); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : integer, start position, optional integer, end position, optional new value, optional =cut sub submeta_text { shift->throw_not_implemented } =head2 named_submeta Title : named_submeta Usage : $subset_of_meta_values = $obj->named_submeta($name, 10, 20, $value_string); $subset_of_meta_values = $obj->named_submeta($name, 10); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : A reference to an array or a string Args : scalar, name of the meta data set integer, start position integer, end position, optional when a third argument present new value, optional =cut sub named_submeta { shift->throw_not_implemented } =head2 named_submeta_text Title : named_submeta_text Usage : $meta_values = $obj->named_submeta_text($name, 20, $value_string); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : scalar, name of the meta data Args : integer, start position, optional integer, end position, optional new value, optional =cut sub named_submeta_text { shift->throw_not_implemented } =head2 meta_names Title : meta_names Usage : @meta_names = $obj->meta_names() Function: Retrives an array of meta data set names. The default (unnamed) set name is guarantied to be the first name. Returns : an array of names Args : none =cut sub meta_names { shift->throw_not_implemented } =head2 force_flush Title : force_flush() Usage : $force_flush = $obj->force_flush(1); Function: Automatically pad with empty values or truncate meta values to sequence length Returns : boolean 1 or 0 Args : optional boolean value =cut sub force_flush { shift->throw_not_implemented } =head2 is_flush Title : is_flush Usage : $is_flush = $obj->is_flush() or $is_flush = $obj->is_flush($my_meta_name) Function: Boolean to tell if all meta values are in flush with the sequence length. Returns true if force_flush() is set Set verbosity to a positive value to see failed meta sets Returns : boolean 1 or 0 Args : optional name of the meta set =cut sub is_flush { shift->throw_not_implemented } =head2 meta_length Title : meta_length() Usage : $meeta_len = $obj->meta_length(); Function: return the number of elements in the meta set Returns : integer Args : - =cut sub meta_length { shift->throw_not_implemented } =head2 named_meta_length Title : named_meta_length() Usage : $meeta_len = $obj->named_meta_length($name); Function: return the number of elements in the named meta set Returns : integer Args : - =cut sub named_meta_length { shift->throw_not_implemented } =head1 Bio::PrimarySeqI methods Implemeting classes will need to rewrite these Bio::PrimaryI methods. =cut =head2 revcom Title : revcom Usage : $newseq = $seq->revcom(); Function: Produces a new Bio::Seq::MetaI implementing object where the order of residues and their meta information is reversed. Returns : A new (fresh) Bio::Seq::MetaI object Args : none =cut sub revcom { shift->throw_not_implemented } =head2 trunc Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence Returns : a fresh Bio::Seq::MetaI implementing object Args : Two integers denoting first and last residue of the sub-sequence. =cut sub trunc { shift->throw_not_implemented } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/PrimaryQual.pm��������������������������������������������������������������000444��000765��000024�� 33360�12254227313� 17527� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::PrimaryQual # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla <bioinformatics@dieselwurks.com> # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::PrimaryQual - Bioperl lightweight Quality Object =head1 SYNOPSIS use Bio::Seq::PrimaryQual; # you can use either a space-delimited string for quality my $string_quals = "10 20 30 40 50 40 30 20 10"; my $qualobj = Bio::Seq::PrimaryQual->new( -qual => $string_quals, -id => 'QualityFragment-12', -accession_number => 'X78121', ); # _or_ you can use an array of quality values my @q2 = split/ /,$string_quals; $qualobj = Bio::Seq::PrimaryQual->new( -qual => \@q2, -primary_id => 'chads primary_id', -desc => 'chads desc', -accession_number => 'chads accession_number', -id => 'chads id' ); # to get the quality values out: my @quals = @{$qualobj->qual()}; # to give _new_ quality values my $newqualstring = "50 90 1000 20 12 0 0"; $qualobj->qual($newqualstring); =head1 DESCRIPTION This module provides a mechanism for storing quality values. Much more useful as part of Bio::Seq::SeqWithQuality where these quality values are associated with the sequence information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics@dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Seq::PrimaryQual; use strict; use base qw(Bio::Root::Root Bio::Seq::QualI); our $MATCHPATTERN = '0-9eE\.\s+-'; =head2 new() Title : new() Usage : $qual = Bio::Seq::PrimaryQual->new( -qual => '10 20 30 40 50 50 20 10', -id => 'human_id', -accession_number => 'AL000012', ); Function: Returns a new Bio::Seq::PrimaryQual object from basic constructors, being a string _or_ a reference to an array for the sequence and strings for id and accession_number. Note that you can provide an empty quality string. Returns : a new Bio::Seq::PrimaryQual object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); # default: turn ON the warnings (duh) my($qual,$id,$acc,$pid,$desc,$given_id,$header) = $self->_rearrange([qw(QUAL DISPLAY_ID ACCESSION_NUMBER PRIMARY_ID DESC ID HEADER )], @args); if( defined $id && defined $given_id ) { if( $id ne $given_id ) { $self->throw("Provided both id and display_id constructor functions. [$id] [$given_id]"); } } if( defined $given_id ) { $id = $given_id; } # note: the sequence string may be empty $self->qual(defined($qual) ? $qual : []); $header && $self->header($header); $id && $self->display_id($id); $acc && $self->accession_number($acc); $pid && $self->primary_id($pid); $desc && $self->desc($desc); return $self; } =head2 qual() Title : qual() Usage : @quality_values = @{$obj->qual()}; Function: Get or set the quality as a reference to an array containing the quality values. An error is generated if the quality scores are invalid, see validate_qual(). Returns : A reference to an array. =cut sub qual { my ($self,$value) = @_; if( ! defined $value || length($value) == 0 ) { $self->{'qual'} ||= []; } elsif( ref($value) =~ /ARRAY/i ) { # if the user passed in a reference to an array $self->{'qual'} = $value; } else { $self->validate_qual($value, 1); $value =~ s/^\s+//; $self->{'qual'} = [split(/\s+/,$value)]; } return $self->{'qual'}; } =head2 seq() Title : seq() Usager : $sequence = $obj->seq(); Function : Returns the quality numbers as a space-separated string. Returns : Single string. Args : None. =cut sub seq { return join ' ', @{ shift->qual }; } =head2 validate_qual($qualstring) Title : validate_qual($qualstring) Usage : print("Valid.") if { &validate_qual($self, $quality_string); } Function: Test that the given quality string is valid. It is expected to contain space-delimited numbers that can be parsed using split /\d+/. However, this validation takes shortcuts and only tests that the string contains characters valid in numbers: 0-9 . eE +- Note that empty quality strings are valid too. Returns : 1 for a valid sequence, 0 otherwise Args : - Scalar containing the quality string to validate. - Boolean to optionally throw an error if validation failed =cut sub validate_qual { my ($self, $qualstr, $throw) = @_; if ( (defined $qualstr ) && ($qualstr !~ /^[$MATCHPATTERN]*$/) ) { if ($throw) { $self->throw("Failed validation of quality score from '". (defined($self->id)||'[unidentified sequence]')."'. No numeric ". "value found.\n"); } return 0; } return 1; } =head2 subqual($start,$end) Title : subqual($start,$end) Usage : @subset_of_quality_values = @{$obj->subqual(10,40)}; Function: returns the quality values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A reference to an array. Args : a start position and an end position =cut sub subqual { my ($self,$start,$end) = @_; if( $start > $end ){ $self->throw("in subqual, start [$start] has to be greater than end [$end]"); } if( $start <= 0 || $end > $self->length ) { $self->throw("You have to have start positive and length less than the total length of sequence [$start:$end] Total ".$self->length.""); } # remove one from start, and then length is end-start $start--; $end--; my @sub_qual_array = @{$self->{qual}}[$start..$end]; # return substr $self->seq(), $start, ($end-$start); return \@sub_qual_array; } =head2 display_id() Title : display_id() Usage : $id_string = $obj->display_id(); Function: returns the display id, aka the common name of the Quality object. The semantics of this is that it is the most likely string to be used as an identifier of the quality sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convience issues Returns : A string Args : None =cut sub display_id { my ($obj,$value) = @_; if( defined $value) { $obj->{'display_id'} = $value; } return $obj->{'display_id'}; } =head2 header() Title : header() Usage : $header = $obj->header(); Function: Get/set the header that the user wants printed for this quality object. Returns : A string Args : None =cut sub header { my ($obj,$value) = @_; if( defined $value) { $obj->{'header'} = $value; } return $obj->{'header'}; } =head2 accession_number() Title : accession_number() Usage : $unique_biological_key = $obj->accession_number(); Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". Returns : A string Args : None =cut sub accession_number { my( $obj, $acc ) = @_; if (defined $acc) { $obj->{'accession_number'} = $acc; } else { $acc = $obj->{'accession_number'}; $acc = 'unknown' unless defined $acc; } return $acc; } =head2 primary_id() Title : primary_id() Usage : $unique_implementation_key = $obj->primary_id(); Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no accession number, this method should return a stringified memory location. Returns : A string Args : None =cut sub primary_id { my ($obj,$value) = @_; if( defined $value) { $obj->{'primary_id'} = $value; } return $obj->{'primary_id'}; } =head2 desc() Title : desc() Usage : $qual->desc($newval); $description = $qual->desc(); Function: Get/set description text for a qual object Example : Returns : Value of desc Args : newvalue (optional) =cut sub desc { my ($obj,$value) = @_; if( defined $value) { $obj->{'desc'} = $value; } return $obj->{'desc'}; } =head2 id() Title : id() Usage : $id = $qual->id(); Function: Return the ID of the quality. This should normally be (and actually is in the implementation provided here) just a synonym for display_id(). Returns : A string. Args : None. =cut sub id { my ($self,$value) = @_; if( defined $value ) { return $self->display_id($value); } return $self->display_id(); } =head2 length() Title : length() Usage : $length = $qual->length(); Function: Return the length of the array holding the quality values. Under most circumstances, this should match the number of quality values but no validation is done when the PrimaryQual object is constructed and non-digits could be put into this array. Is this a bug? Just enough rope... Returns : A scalar (the number of elements in the quality array). Args : None. =cut sub length { my $self = shift; if (ref($self->{qual}) ne "ARRAY") { $self->warn("{qual} is not an array here. Why? It appears to be ".ref($self->{qual})."(".$self->{qual}."). Good thing this can _never_ happen."); } return scalar(@{$self->{qual}}); } =head2 qualat() Title : qualat Usage : $quality = $obj->qualat(10); Function: Return the quality value at the given location, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A scalar. Args : A position. =cut sub qualat { my ($self,$val) = @_; my @qualat = @{$self->subqual($val,$val)}; if (scalar(@qualat) == 1) { return $qualat[0]; } else { $self->throw("qualat() provided more than one quality."); } } =head2 to_string() Title : to_string() Usage : $quality = $obj->to_string(); Function: Return a textual representation of what the object contains. For this module, this function will return: qual display_id accession_number primary_id desc id length Returns : A scalar. Args : None. =cut sub to_string { my ($self,$out,$result) = shift; $out = "qual: ".join(',',@{$self->qual()}); foreach (qw(display_id accession_number primary_id desc id length)) { $result = $self->$_(); if (!$result) { $result = "<unset>"; } $out .= "$_: $result\n"; } return $out; } sub to_string_automatic { my ($self,$sub_result,$out) = shift; foreach (sort keys %$self) { print("Working on $_\n"); eval { $self->$_(); }; if ($@) { $sub_result = ref($_); } elsif (!($sub_result = $self->$_())) { $sub_result = "<unset>"; } if (ref($sub_result) eq "ARRAY") { print("This thing ($_) is an array!\n"); $sub_result = join(',',@$sub_result); } $out .= "$_: ".$sub_result."\n"; } return $out; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/PrimedSeq.pm����������������������������������������������������������������000444��000765��000024�� 34542�12254227323� 17156� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # This is the original copyright statement. I have relied on Chad's module # extensively for this module. # # Copyright (c) 1997-2001 bioperl, Chad Matsalla. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # # But I have modified lots of it, so I guess I should add: # # Copyright (c) 2003 bioperl, Rob Edwards. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::PrimedSeq - A sequence and a pair of primers matching on it =head1 SYNOPSIS use Bio::Seq; use Bio::Seq::PrimedSeq; my $template = Bio::Seq->new( -seq => 'AGCTTTTCATTCTGACTGCAAC' ); my $left = Bio::Seq->new( -seq => 'AGCT' ); my $right = Bio::Seq->new( -seq => 'GTTGC' ); my $primedseq = Bio::Seq::PrimedSeq->new( -seq => $template, # sequence object -left_primer => $left, # sequence or primer object -right_primer => $right # sequence or primer object ); # Get the primers as Bio::SeqFeature::Primer objects my @primer_objects = $primedseq->get_primer(); # Sequence object representing the PCR product, i.e. the section of the target # sequence contained between the primers (primers included) my $amplicon_seq = $primedseq->amplicon(); print 'Got amplicon sequence: '.$amplicon_seq->seq."\n"; # Amplicon should be: agctTTTCATTCTGACTgcaac =head1 DESCRIPTION This module was created to address the fact that a primer is more than a SeqFeature and that there is a need to represent the primer-sequence complex and the attributes that are associated with the complex. A PrimedSeq object is initialized with a target sequence and two primers. The location of the primers on the target sequence is calculated if needed so that one can then get the PCR product, or amplicon sequence. From the PrimedSeq object you can also retrieve information about melting temperatures and what not on each of the primers and the amplicon. The L<Bio::Tools::Primer3> module uses PrimedSeq objects extensively. Note that this module does not simulate PCR. It assumes that the primers will match in a single location on the target sequence and does not understand degenerate primers. =over =item * Providing primers as sequence objects If the primers are specified as sequence objects, e.g. L<Bio::PrimarySeq> or L<Bio::Seq>, they are first converted to L<Bio::SeqFeature::Primer> objects. Their location on the target sequence is then calculated and added to the L<Bio::SeqFeature::Primer> objects, which you can retrieve using the get_primer() method. =item * Providing primers as primer objects Because of the limitations of specifying primers as sequence objects, the recommended method is to provide L<Bio::SeqFeature::Primer> objects. If you did not record the location of the primers in the primer object, it will be calculated. =back L<Bio::Seq::PrimedSeq> was initially started by Chad Matsalla, and later improved on by Rob Edwards. =head1 RECIPES =over =item 1. Run Primer3 to get PrimedSeq objects: use Bio::SeqIO; use Bio::Tools::Run::Primer3; # Read a target sequences from a FASTA file my $file = shift || die "Need a file to read"; my $seqin = Bio::SeqIO->new(-file => $file); my $seq = $seqin->next_seq; # Use Primer3 to design some primers my $primer3 = Bio::Tools::Run::Primer3->new(-seq => $seq); my $results = $primer3->run; # default parameters # Write all the results in a Genbank file my $seqout = Bio::SeqIO->new(-file => ">primed_sequence.gbk", -format => 'genbank'); while (my $primedseq = $results->next_primer) { $seqout->write_seq( $primedseq->annotated_seq ); } =item 2. Create a genbank file for a sequence and its cognate primers: use Bio::SeqIO; use Bio::Seq::PrimedSeq; # Read a FASTA file that contains the target sequence and its two primers my $file = shift || die "$0 <file>"; my $seqin = Bio::SeqIO->new(-file => $file); my ($template, $leftprimer, $rightprimer) = ($seqin->next_seq, $seqin->next_seq, $seqin->next_seq); # Set up a PrimedSeq object my $primedseq = Bio::Seq::PrimedSeq->new(-seq => $template, -left_primer => $leftprimer, -right_primer => $rightprimer); # Write the sequences in an output Genbank file my $seqout = Bio::SeqIO->new(-file => ">primed_sequence.gbk", -format => 'genbank'); $seqout->write_seq($primedseq->annotated_sequence); =back =head1 FEEDBACK User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu Based on a module written by Chad Matsalla, bioinformatics1@dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::PrimedSeq; use strict; use Bio::SeqFeature::Primer; use base qw(Bio::Root::Root Bio::SeqFeature::Generic); # Since this module occupies the Bio::Seq::* namespace, it should probably # inherit from Bio::Seq before it inherits from Bio::SeqFeature::Generic. But # then, Bio::SeqI and Bio::SeqFeatureI both request a seq() method that return # different things. So, being Bio::SeqI is incompatible with being Bio::SeqFeatureI =head2 new Title : new() Usage : my $primedseq = Bio::SeqFeature::Primer->new( -seq => $sequence, -left_primer => $left_primer, -right_primer => $right_primer ); Function: Construct a primed sequence. Returns : A Bio::Seq::PrimedSeq object Args : -seq => a Bio::Seq object (required) -left_primer => a Bio::SeqFeature::Primer or sequence object (required) -right_primer => a Bio::SeqFeature::Primer or sequence object (required) If you pass a sequence object to specify a primer, it will be used to construct a Bio::SeqFeature::Primer that you can retrieve with the L<get_primer> method. Many other parameters can be included including all of the output parameters from the primer3 program (see L<Bio::Tools::Primer3>). At the moment these parameters will simply be stored and do anything. =cut sub new { my($class,%args) = @_; my $self = $class->SUPER::new(%args); # Need an amplicon sequence $self->{seq} = delete $args{-seq} || delete $args{-target_sequence} || $self->throw("Need to provide a sequence during PrimedSeq object construction"); if (! ref($self->{seq}) || ! $self->{seq}->isa('Bio::SeqI') ) { $self->throw("The target_sequence must be a Bio::Seq to create this object."); } # Need a left and right primers for my $primer ( 'left', 'right' ) { $self->{$primer} = delete $args{'-'.$primer.'_primer'} || $self->throw("Need to provide both primers during PrimedSeq object construction"); if ( ref $self->{$primer} && $self->{$primer}->isa('Bio::PrimarySeqI') ) { # Convert Bio::Seq or Bio::PrimarySeq objects to Bio::SeqFeature::Primer $self->{$primer} = Bio::SeqFeature::Primer->new(-seq => $self->{$primer}); } if (not (ref $self->{$primer} && $self->{$primer}->isa("Bio::SeqFeature::Primer"))) { $self->throw("Primers must be Bio::SeqFeature::Primer objects but got a ".ref($self->{$primer})); } } # Save remaining arguments while (my ($arg, $val) = each %args) { $self->{$arg} = $val; } # Determine primer location on target if needed if ( not( $self->{'left'}->start && $self->{'left'}->end && $self->{'right'}->start && $self->{'right'}->end ) ) { $self->_place_primers(); } return $self; } =head2 get_primer Title : get_primer(); Usage : my @primers = $primedseq->get_primer(); or my $primer = $primedseq->get_primer('-left_primer'); Function: Get the primers associated with the PrimedSeq object. Returns : A Bio::SeqFeature::Primer object Args : For the left primer, use: l, left, left_primer or -left_primer For the right primer, use: r, right, right_primer or -right_primer For both primers [default], use: b, both, both_primers or -both_primers =cut sub get_primer { my ($self, $arg) = @_; if (! defined $arg ) { return ($self->{left}, $self->{right}); } elsif ( $arg =~ /^-?l/ ) { # What a cheat, I couldn't be bothered to write all the exact statements! # Hah, now you can write 'leprechaun' to get the left primer. return $self->{left} } elsif ( $arg =~ /^-?r/ ) { return $self->{right}; } elsif ( $arg =~ /^-?b/ ) { return ($self->{left}, $self->{right}); } } =head2 annotated_sequence Title : annotated_sequence Usage : my $annotated_sequence_object = $primedseq->annotate_sequence(); Function: Get an annotated sequence object containg the left and right primers Returns : An annotated sequence object or 0 if not defined. Args : Note : Use this method to return a sequence object that you can write out (e.g. in GenBank format). See the example above. =cut sub annotated_sequence { my $self = shift; my $seq = $self->{'seq'}; ### clone?? $seq->add_SeqFeature($self->{'left'}); $seq->add_SeqFeature($self->{'right'}); return $seq; } =head2 amplicon Title : amplicon Usage : my $amplicon = $primedseq->amplicon(); Function: Retrieve the amplicon as a sequence object. The amplicon sequnce is only the section of the target sequence between the primer matches (primers included). Returns : A Bio::Seq object. To get the sequence use $amplicon->seq Args : None Note : =cut sub amplicon { my ($self) = @_; my $left = $self->{left}; my $right = $self->{right}; my $target = $self->{seq}; return Bio::PrimarySeq->new( -id => 'Amplicon_from_'.($target->id || 'unidentified'), -seq => lc( $left->seq->seq ). uc( $target->subseq($left->end+1, $right->start-1) ). lc( $right->seq->revcom->seq ), ); } =head2 seq Title : seq Usage : my $seqobj = $primedseq->seq(); Function: Retrieve the target sequence as a sequence object Returns : A seq object. To get the sequence use $seqobj->seq Args : None Note : =cut sub seq { my $self = shift; return $self->{seq}; } =head2 _place_primers Title : _place_primers Usage : $self->_place_primers(); Function: An internal method to place the primers on the sequence and set up the ranges of the sequences Returns : Nothing Args : None Note : Internal use only =cut sub _place_primers { my $self = shift; # Get the target and primer sequence strings, all in uppercase my $left = $self->{left}; my $right = $self->{right}; my $target_seq = uc $self->{seq}->seq(); my $left_seq = uc $left->seq()->seq(); my $right_seq = uc $right->seq()->revcom()->seq(); # Locate primers on target sequence my ($before, $middle, $after) = ($target_seq =~ /^(.*)$left_seq(.*)$right_seq(.*)$/); if (not defined $before || not defined $middle || not defined $after) { if ($target_seq !~ /$left_seq/) { $self->throw("Could not place left primer on target"); } if ($target_seq !~ /$right_seq/) { $self->throw("Could not place right primer on target") } } # Save location information in primer object my $left_location = length($before) + 1; my $right_location = length($target_seq) - length($after); $left->start($left_location); $left->end($left_location + $left->seq->length - 1); $left->strand(1); $right->start($right_location - $right->seq->length + 1); $right->end($right_location); $right->strand(-1); # If Primer3 information was recorded, compare it to what we calculated if ( exists($left->{PRIMER_LEFT}) || exists($right->{PRIMER_RIGHT}) || exists($self->{PRIMER_PRODUCT_SIZE}) ) { # Bio::Seq::PrimedSeq positions my $amplicon_size = length($left_seq) + length($middle) + length($right_seq); $left_location = $left_location.','.length($left_seq); $right_location = $right_location.','.length($right_seq); # Primer3 positions my $primer_product = $self->{PRIMER_PRODUCT_SIZE}; my $primer_left = $left->{PRIMER_LEFT}; my $primer_right = $right->{PRIMER_RIGHT}; if ( defined($primer_left) && (not $primer_left eq $left_location) ) { $self->warn("Got |$primer_left| from primer3 but calculated ". "|$left_location| for the left primer."); } if ( defined($primer_right) && (not $primer_right eq $right_location) ) { $self->warn("Got |$primer_right| from primer3 but calculated ". "|$right_location| for the right primer."); } if ( defined($primer_product) && (not $primer_product eq $amplicon_size) ) { $self->warn("Got |$primer_product| from primer3 but calculated ". "|$amplicon_size| for the size."); } } } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/QualI.pm��������������������������������������������������������������������000444��000765��000024�� 41623�12254227325� 16300� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::QualI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla <bioinformatics@dieselwurks.com # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::QualI - Interface definition for a Bio::Seq::Qual =head1 SYNOPSIS # get a Bio::Seq::Qual compliant object somehow # to test this is a seq object $obj->isa("Bio::Seq::QualI") || $obj->throw("$obj does not implement the Bio::Seq::QualI interface"); # accessors $string = $obj->qual(); $substring = $obj->subqual(12,50); $display = $obj->display_id(); # for human display $id = $obj->primary_id(); # unique id for this object, # implementation defined $unique_key= $obj->accession_number(); # unique biological id =head1 DESCRIPTION This object defines an abstract interface to basic quality information. PrimaryQual is an object just for the quality and its name(s), nothing more. There is a pure perl implementation of this in Bio::Seq::PrimaryQual. If you just want to use Bio::Seq::PrimaryQual objects, then please read that module first. This module defines the interface, and is of more interest to people who want to wrap their own Perl Objects/RDBs/FileSystems etc in way that they "are" bioperl quality objects, even though it is not using Perl to store the sequence etc. This interface defines what bioperl consideres necessary to "be" a sequence of qualities, without providing an implementation of this. (An implementation is provided in Bio::Seq::PrimaryQual). If you want to provide a Bio::Seq::PrimaryQual 'compliant' object which in fact wraps another object/database/out-of-perl experience, then this is the correct thing to wrap, generally by providing a wrapper class which would inherit from your object and this Bio::Seq::QualI interface. The wrapper class then would have methods lists in the "Implementation Specific Functions" which would provide these methods for your object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla This module is heavily based on Bio::Seq::PrimarySeq and is modeled after or outright copies sections of it. Thanks Ewan! Email bioinformatics@dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::QualI; use strict; use Carp; use base qw(Bio::Root::RootI); =head1 Implementation Specific Functions These functions are the ones that a specific implementation must define. =head2 qual() Title : qual() Usage : @quality_values = @{$obj->qual()}; Function: Returns the quality as a reference to an array containing the quality values. The individual elements of the quality array are not validated and can be any numeric value. Returns : A reference to an array. Status : =cut sub qual { my ($self) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::QualI definition of qual - implementing class did not provide this method"); } else { confess("Bio::Seq::QualI definition of qual - implementing class did not provide this method"); } } =head2 subqual($start,$end) Title : subqual($start,$end) Usage : @subset_of_quality_values = @{$obj->subseq(10,40)}; Function: returns the quality values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A reference to an array. Args : a start position and an end position =cut sub subqual { my ($self) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::QualI definition of subqual - implementing class did not provide this method"); } else { confess("Bio::Seq::QualI definition of subqual - implementing class did not provide this method"); } } =head2 display_id() Title : display_id() Usage : $id_string = $obj->display_id() _or_ $id_string = $obj->display_id($new_display_id); Function: Returns the display id, aka the common name of the Quality object. The semantics of this is that it is the most likely string to be used as an identifier of the quality sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convience issues Returns : A string Args : If an arg is provided, it will replace the existing display_id in the object. =cut sub display_id { my ($self) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::QualI definition of id - implementing class did not provide this method"); } else { confess("Bio::Seq::QualI definition of id - implementing class did not provide this method"); } } =head2 accession_number() Title : accession_number() Usage : $unique_biological_key = $obj->accession_number(); _or_ $unique_biological_key = $obj->accession_number($new_acc_num); Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". Returns : A string. Args : If an arg is provided, it will replace the existing accession_number in the object. =cut sub accession_number { my ($self,@args) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::QualI definition of seq - implementing class did not provide this method"); } else { confess("Bio::Seq::QualI definition of seq - implementing class did not provide this method"); } } =head2 primary_id() Title : primary_id() Usage : $unique_implementation_key = $obj->primary_id(); _or_ $unique_implementation_key = $obj->primary_id($new_prim_id); Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no accession number, this method should return a stringified memory location. Returns : A string Args : If an arg is provided, it will replace the existing primary_id in the object. =cut sub primary_id { my ($self,@args) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::QualI definition of qual - implementing class did not provide this method"); } else { confess("Bio::Seq::QualI definition of qual - implementing class did not provide this method"); } } =head2 can_call_new() Title : can_call_new() Usage : if( $obj->can_call_new ) { $newobj = $obj->new( %param ); } Function: can_call_new returns 1 or 0 depending on whether an implementation allows new constructor to be called. If a new constructor is allowed, then it should take the followed hashed constructor list. $myobject->new( -qual => $quality_as_string, -display_id => $id, -accession_number => $accession, ); Example : Returns : 1 or 0 Args : =cut sub can_call_new{ my ($self,@args) = @_; # we default to 0 here return 0; } =head2 qualat($position) Title : qualat($position) Usage : $quality = $obj->qualat(10); Function: Return the quality value at the given location, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A scalar. Args : A position. =cut sub qualat { my ($self,$value) = @_; if( $self->can('warn') ) { $self->warn("Bio::Seq::QualI definition of qualat - implementing class did not provide this method"); } else { warn("Bio::Seq::QualI definition of qualat - implementing class did not provide this method"); } return ''; } =head1 Optional Implementation Functions The following functions rely on the above functions. A implementing class does not need to provide these functions, as they will be provided by this class, but is free to override these functions. All of revcom(), trunc(), and translate() create new sequence objects. They will call new() on the class of the sequence object instance passed as argument, unless can_call_new() returns FALSE. In the latter case a Bio::PrimarySeq object will be created. Implementors which really want to control how objects are created (eg, for object persistence over a database, or objects in a CORBA framework), they are encouraged to override these methods =head2 revcom Title : revcom Usage : @rev = @{$qual->revcom()}; Function: Produces a new Bio::Seq::QualI implementing object which is reversed from the original quality array. The id is the same id as the orginal sequence, and the accession number is also indentical. If someone wants to track that this sequence has been reversed, it needs to define its own extensions To do an inplace edit of an object you can go: $qual = $qual->revcom(); This of course, causes Perl to handle the garbage collection of the old object, but it is roughly speaking as efficient as an inplace edit. Returns : A new (fresh) Bio::Seq::PrimaryQualI object Args : none =cut sub revcom{ my ($self) = @_; # this is the cleanest way my @qualities = @{$self->qual()}; my @reversed_qualities = reverse(@qualities); my $seqclass; if($self->can_call_new()) { $seqclass = ref($self); } else { $seqclass = 'Bio::Seq::PrimaryQual'; # Wassat? # $self->_attempt_to_load_Seq(); } # the \@reverse_qualities thing works simply because I will it to work. my $out = $seqclass->new( '-qual' => \@reversed_qualities, '-display_id' => $self->display_id, '-accession_number' => $self->accession_number, '-desc' => $self->desc() ); return $out; } =head2 trunc() Title : trunc Usage : $subseq = $myseq->trunc(10,100); Function: Provides a truncation of a sequence, Returns : a fresh Bio::Seq::QualI implementing object Args : Two integers denoting first and last base of the sub-sequence. =cut sub trunc { my ($self,$start,$end) = @_; if( !$end ) { if( $self->can('throw') ) { $self->throw("trunc start,end"); } else { confess("[$self] trunc start,end"); } } if( $end < $start ) { if( $self->can('throw') ) { $self->throw("$end is smaller than $start. if you want to truncated and reverse complement, you must call trunc followed by revcom. Sorry."); } else { confess("[$self] $end is smaller than $start. If you want to truncated and reverse complement, you must call trunc followed by revcom. Sorry."); } } my $r_qual = $self->subqual($start,$end); my $seqclass; if($self->can_call_new()) { $seqclass = ref($self); } else { $seqclass = 'Bio::Seq::PrimaryQual'; # wassat? # $self->_attempt_to_load_Seq(); } my $out = $seqclass->new( '-qual' => $r_qual, '-display_id' => $self->display_id, '-accession_number' => $self->accession_number, '-desc' => $self->desc() ); return $out; } =head2 translate() Title : translate() Usage : $protein_seq_obj = $dna_seq_obj->translate #if full CDS expected: $protein_seq_obj = $cds_seq_obj->translate(undef,undef,undef,undef,1); Function: Completely useless in this interface. Returns : Nothing. Args : Nothing. =cut sub translate { return 0; } =head2 id() Title : id() Usage : $id = $qual->id() Function: ID of the quality. This should normally be (and actually is in the implementation provided here) just a synonym for display_id(). Example : Returns : A string. Args : =cut sub id { my ($self)= @_; return $self->display_id(); } =head2 length() Title : length() Usage : $length = $qual->length(); Function: Return the length of the array holding the quality values. Under most circumstances, this should match the number of quality values but no validation is done when the PrimaryQual object is constructed and non-digits could be put into this array. Is this a bug? Just enough rope... Returns : A scalar (the number of elements in the quality array). Args : None. =cut sub length { my ($self)= @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::QualI definition of length - implementing class did not provide this method"); } else { confess("Bio::Seq::QualI definition of length - implementing class did not provide this method"); } } =head2 desc() Title : desc() Usage : $qual->desc($newval); $description = $seq->desc(); Function: Get/set description text for a qual object Example : Returns : value of desc Args : newvalue (optional) =cut sub desc { my ($self,$value) = @_; if( $self->can('warn') ) { $self->warn("Bio::Seq::QualI definition of desc - implementing class did not provide this method"); } else { warn("Bio::Seq::QualI definition of desc - implementing class did not provide this method"); } return ''; } # These methods are here for backward compatibility with the old, 0.5 # Seq objects. They all throw warnings that someone is using a # deprecated method, and may eventually be removed completely from # this object. However, they are important to ease the transition from # the old system. =head1 Private functions These are some private functions for the PrimarySeqI interface. You do not need to implement these functions =head2 _attempt_to_load_Seq Title : _attempt_to_load_Seq Usage : Function: Example : Returns : Args : =cut sub _attempt_to_load_Seq{ my ($self) = @_; if( $main::{'Bio::Seq::PrimaryQual'} ) { return 1; } else { eval { require Bio::Seq::PrimaryQual; }; if( $@ ) { if( $self->can('throw') ) { $self->throw("Bio::Seq::PrimaryQual could not be loaded for $self\nThis indicates that you are using Bio::Seq::PrimaryQualI without Bio::Seq::PrimaryQual loaded and without providing a complete solution\nThe most likely problem is that there has been a misconfiguration of the bioperl environment\nActual exception\n\n$@\n"); } else { confess("Bio::Seq::PrimarySeq could not be loaded for $self\nThis indicates that you are usnig Bio::Seq::PrimaryQualI without Bio::Seq::PrimaryQual loaded and without providing a complete solution\nThe most likely problem is that there has been a misconfiguration of the bioperl environment\nActual exception\n\n$@\n"); } return 0; } return 1; } } =head2 qualtype() Title : qualtype() Usage : if( $obj->qualtype eq 'phd' ) { /Do Something/ } Function: At this time, this function is not used for Bio::Seq::PrimaryQual objects. In fact, now it is a month later and I just completed the Bio::Seq::SeqWithQuality object and this is definitely deprecated. Returns : Nothing. (not implemented) Args : none Status : Virtual =cut sub qualtype { my ($self,@args) = @_; if( $self->can('throw') ) { # $self->throw("Bio::Seq::QualI definition of qual - implementing class did not provide this method"); $self->throw("qualtypetype is not used with quality objects."); } else { # confess("Bio::Seq::QualI definition of qual - implementing class did not provide this method"); confess("qualtype is not used with quality objects."); } } 1; �������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/Quality.pm������������������������������������������������������������������000444��000765��000024�� 51020�12254227330� 16701� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::Quality # # Please direct questions and support issues to # <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::Quality - Implementation of sequence with residue quality and trace values =head1 SYNOPSIS use Bio::Seq::Quality; # input can be space delimited string or array ref my $qual = '0 1 2 3 4 5 6 7 8 9 11 12'; my $trace = '0 5 10 15 20 25 30 35 40 45 50 55'; my $seq = Bio::Seq::Quality->new ( -qual => $qual, -trace_indices => $trace, -seq => 'atcgatcgatcg', -id => 'human_id', -accession_number => 'S000012', -verbose => -1 # to silence deprecated methods ); my $quals = $seq->qual; # array ref my $traces = $seq->trace; # array ref my $quals = $seq->qual_text; # string my $traces = $seq->trace_text; # string # get sub values $quals = $seq->subqual(2, 3); # array ref $traces = $seq->subtrace(2, 3); # array ref $quals = $seq->subqual_text(2, 3); # string $quals = $seq->subtrace_text(2, 3); # string # set sub values $seq->subqual(2, 3, "9 9"); $seq->subtrace(2, 3, "9 9"); =head1 DESCRIPTION This object stores base quality values together with the sequence string. It is a reimplementation of Chad Matsalla's Bio::Seq::SeqWithQuality module using Bio::Seq::MetaI. The implementation is based on Bio::Seq::Meta::Array. qual() and trace() are base methods to store and retrieve information that have extensions to retrieve values as a scalar (e.g. qual_text() ), or get or set subvalues (e.g. subqual() ). See L<Bio::Seq::MetaI> for more details. All the functional code is in Bio::Seq::Meta::Array. There deprecated methods that are included for compatibility with Bio::Seq::SeqWithQuality. These will print a warning unless verbosity of the object is set to be less than zero. =head2 Differences from Bio::Seq::SeqWithQuality It is not possible to fully follow the interface of Bio::Seq::SeqWithQuality since internally a Bio::Seq::SeqWithQuality object is a composite of two independent objects: a Bio::PrimarySeq object and Bio::Seq::PrimaryQual object. Both of these objects can be created separately and merged into Bio::Seq::SeqWithQuality. This implementation is based on Bio::Seq::Meta::Array that is a subclass of Bio::PrimarySeq that stores any number of meta information in unnamed arrays. Here we assume that two meta sets, called 'qual' and 'trace_indices' are attached to a sequence. (But there is nothing that prevents you to add as many named meta sets as you need using normal meta() methods). qual() is an alias to meta(), qualat($loc) is an alias to submeta($loc,$loc). trace_indices() in Bio::Seq::SeqWithQuality has been abbreviated to trace() and is an alias to named_meta('trace'). You can create an object without passing any arguments to the constructor (Bio::Seq::SeqWithQuality fails without alphabet). It will warn about not being able to set alphabet unless you set verbosity of the object to a negative value. After the latest rewrite, the meta information sets (quality and trace) no longer cover all the residues automatically. Methods to check the length of meta information (L<quality_length>, L<trace_length>)and to see if the ends are flushed to the sequence have been added (L<quality_is_flush>, L<trace_is_flush>). To force the old functinality, set L<force_flush> to true. qual_obj() and seq_obj() methods do not exist! Finally, there is only one set of descriptors (primary_id, display_id, accession_number) for the object. =head1 SEE ALSO L<Bio::Seq::MetaI>, L<Bio::Seq::Meta::Array> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Chad Matsalla, bioinformatics at dieselwurks dot com Dan Bolser, dan dot bolser at gmail dot com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::Quality; use strict; use base qw(Bio::Seq::Meta::Array); ## Is this the right place (and way) to define this? our $MASK_CHAR = 'X'; our $DEFAULT_NAME = 'DEFAULT'; our $GAP = '-'; our $META_GAP = ' '; =head2 new Title : new Usage : $metaseq = Bio::Seq::Quality->new ( -qual => '0 1 2 3 4 5 6 7 8 9 11 12', -trace => '0 5 10 15 20 25 30 35 40 45 50 55', -seq => 'atcgatcgatcg', -id => 'human_id', -accession_number => 'S000012', ); Function: Constructor for Bio::Seq::Quality class. Note that you can provide an empty quality and trace strings. Returns : a new Bio::Seq::Quality object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($meta, $qual, $trace, $trace_indices, $trace_data) = $self->_rearrange([qw(META QUAL TRACE TRACE_INDICES TRACE_DATA)], @args); $self->{'_meta'}->{$DEFAULT_NAME} = []; $self->{'_meta'}->{'trace'} = []; $self->{trace_data} = $trace_data; $meta && $self->meta($meta); $qual && $self->qual($qual); $trace && $self->named_meta('trace', $trace); $trace_indices && $self->named_meta('trace', $trace_indices); return $self; } ## QUAL =head2 qual Title : qual Usage : $qual_values = $obj->qual($values_string); Function: Get and set method for the meta data starting from residue position one. Since it is dependent on the length of the sequence, it needs to be manipulated after the sequence. The length of the returned value always matches the length of the sequence. Returns : reference to an array of meta data Args : new value, string or array ref or Bio::Seq::PrimaryQual, optional Setting quality values resets the clear range. =cut sub qual { my $self = shift; my $value = shift; $value = $value->qual if ref($value) and ref($value) ne 'ARRAY' and $value->isa('Bio::Seq::PrimaryQual'); $self->_empty_cache if $value; return $self->named_meta($DEFAULT_NAME, $value); } =head2 qual_text Title : qual_text Usage : $qual_values = $obj->qual_text($values_arrayref); Function: Variant of meta() and qual() guarantied to return a string representation of meta data. For details, see L<meta>. Returns : a string Args : new value, optional =cut sub qual_text { return join ' ', @{shift->named_submeta($DEFAULT_NAME, @_)}; } =head2 subqual Title : subqual Usage : $subset_of_qual_values = $obj->subqual(10, 20, $value_string); $subset_of_qual_values = $obj->subqual(10, undef, $value_string); Function: Get and set method for meta data for subsequences. Numbering starts from 1 and the number is inclusive, ie 1-2 are the first two residue of the sequence. Start cannot be larger than end but can be equal. If the second argument is missing the returned values should extend to the end of the sequence. Returns : A reference to an array Args : integer, start position integer, end position, optional when a third argument present new value, optional =cut sub subqual { shift->named_submeta($DEFAULT_NAME, @_); } =head2 subqual_text Title : subqual_text Usage : $meta_values = $obj->subqual_text(20, $value_string); Function: Variant of subqual() returning a stringified representation of meta data. For details, see L<Bio::Seq::MetaI>. Returns : a string Args : new value, optional =cut sub subqual_text { return join ' ', @{shift->named_submeta($DEFAULT_NAME, @_)}; } =head2 quality_length Title : quality_length() Usage : $qual_len = $obj->quality_length(); Function: return the number of elements in the quality array Returns : integer Args : - =cut sub quality_length { my ($self) = @_; return $self->named_meta_length($DEFAULT_NAME); } =head2 quality_is_flush Title : quality_is_flush Usage : $quality_is_flush = $obj->quality_is_flush() Function: Boolean to tell if the trace length equals the sequence length. Returns true if force_flush() is set. Returns : boolean 1 or 0 Args : none =cut sub quality_is_flush { return shift->is_flush('quality'); } ## TRACE =head2 trace Title : trace Usage : $trace_values = $obj->trace($values_string); Function: Get and set method for the meta data starting from residue position one. Since it is dependent on the length of the sequence, it needs to be manipulated after the sequence. The length of the returned value always matches the length of the sequence. Returns : reference to an array of meta data Args : new value, string or array ref, optional =cut sub trace { my $self = shift; my $value = shift; return $self->named_meta('trace', $value); } =head2 trace_text Title : trace_text Usage : $trace_values = $obj->trace_text($values_arrayref); Function: Variant of meta() and trace() guarantied to return a string representation of meta data. For details, see L<meta>. Returns : a string Args : new value, optional =cut sub trace_text { return join ' ', @{shift->named_submeta('trace', @_)}; } =head2 subtrace Title : subtrace Usage : $subset_of_trace_values = $obj->subtrace(10, 20, $value_string); $subset_of_trace_values = $obj->subtrace(10, undef, $value_string); Function: Get and set method for meta data for subsequences. Numbering starts from 1 and the number is inclusive, ie 1-2 are the first two residue of the sequence. Start cannot be larger than end but can be equal. If the second argument is missing the returned values should extend to the end of the sequence. Returns : A reference to an array Args : integer, start position integer, end position, optional when a third argument present new value, optional =cut sub subtrace { return shift->named_submeta('trace', @_); } =head2 subtrace_text Title : subtrace_text Usage : $meta_values = $obj->subtrace_text(20, $value_string); Function: Variant of subtrace() returning a stringified representation of meta data. For details, see L<Bio::Seq::MetaI>. Returns : a string Args : new value, optional =cut sub subtrace_text { return join ' ', @{shift->named_submeta('trace', @_)}; } =head2 trace_length Title : trace_length() Usage : $trace_len = $obj->trace_length(); Function: return the number of elements in the trace set Returns : integer Args : - =cut sub trace_length { my ($self) = @_; return $self->named_meta_length('trace'); } =head2 trace_is_flush Title : trace_is_flush Usage : $trace_is_flush = $obj->trace_is_flush() Function: Boolean to tell if the trace length equals the sequence length. Returns true if force_flush() is set. Returns : boolean 1 or 0 Args : none =cut sub trace_is_flush { return shift->is_flush('trace'); } =head2 get_trace_graph Title : get_trace_graph Usage : @trace_values = $obj->get_trace_graph( -trace => 'a', -scale => 100) Function : Returns array of raw trace values for a trace file, or false if no trace data exists. Requires a value for trace to get either the a, g, c or t trace information, and an optional value for scale, which rescales the data between 0 and the provided value, a scale value of '0' performs no scaling Returns : Array or 0 Args : string, trace to retrieve, one of a, g, c or t integer, scale, for scaling of trace between 0 and scale, or 0 for no scaling, optional =cut sub get_trace_graph { my $self = shift; my($trace, $scale) = $self->_rearrange([qw(TRACE SCALE )], @_); unless (defined($self->{trace_data})) { return 0 } unless (grep { lc($trace) eq $_ } ('a', 'g', 'c', 't')) { return 0 } $trace = lc($trace) . "_trace"; my @trace_data = exists $self->{trace_data}->{$trace} && ref $self->{trace_data}->{$trace} eq 'ARRAY' ? @{$self->{trace_data}->{$trace}} : (); my $max = $self->{trace_data}->{max_height}; if (defined($scale) and $scale != 0) { @trace_data = map { $_ / $max * $scale } @trace_data; } return @trace_data; } =head2 threshold Title : threshold Usage : $qual->threshold($value); Function: Sets the quality threshold. Returns : an integer Args : new value, optional Value used by *clear_range* method below. =cut sub threshold { my $self = shift; my $value = shift; if (defined $value) { $self->throw("Threshold needs to be an integer [$value]") unless $value =~ /^[-+]?\d+$/; $self->_empty_cache if defined $self->{_threshold} and $self->{_threshold} ne $value; $self->{_threshold} = $value; } return $self->{_threshold}; } =head2 mask_below_threshold Title : mask_below_threshold Usage : $count = $obj->count_clear_ranges($threshold); Function: Counts number of ranges in the sequence where quality values are above the threshold Returns : count integer Args : threshold integer, optional Set threshold first using method L<threshold>. =cut sub mask_below_threshold { my $self = shift; my $threshold = shift; $self->threshold($threshold) if defined $threshold; # populate the cache if needed $self->_find_clear_ranges unless defined $self->{_ranges}; my $maskSeq = $self->seq; my $maskQual = $self->qual; ## There must be a more efficient way than this! for(my $i=0; $i<length($maskSeq); $i++){ #print join ("\t", $i, $maskQual->[$i]), "\n"; substr($maskSeq, $i, 1, $MASK_CHAR) if $maskQual->[$i] < $self->{_threshold}; } ## This is the *wrong* way to do it! #for my $r (@{$self->{_ranges}} ){ # substr($maskSeq, $r->{start}, $r->{length}, $MASK_CHAR x $r->{length}); #} return $maskSeq; } =head2 count_clear_ranges Title : count_clear_ranges Usage : $count = $obj->count_clear_ranges($threshold); Function: Counts number of ranges in the sequence where quality values are above the threshold Returns : count integer Args : threshold integer, optional Set threshold first using method L<threshold>. =cut sub count_clear_ranges { my $self = shift; my $threshold = shift; $self->threshold($threshold) if defined $threshold; # populate the cache if needed $self->_find_clear_ranges unless defined $self->{_ranges}; return scalar @{$self->{_ranges}}; } =head2 clear_ranges_length Title : clear_ranges_length Usage : $total_lenght = $obj->clear_ranges_length($threshold); Function: Return number of residues with quality values above the threshold in all clear ranges Returns : an integer Args : threshold, optional Set threshold first using method L<threshold>. I think this method needs a better name! count_high_quality_bases? or sum_clear_ranges? =cut sub clear_ranges_length { my $self = shift; my $threshold = shift; $self->threshold($threshold) if defined $threshold; # populate the cache if needed $self->_find_clear_ranges unless defined $self->{_ranges}; my $sum; map {$sum += $_->{length}} @{$self->{_ranges}}; return $sum; } =head2 get_clear_range Title : get_clear_range Usage : $newqualobj = $obj->get_clear_range($threshold); Function: Return longest subsequence that has quality values above the given threshold, or a default value of 13 Returns : a new Bio::Seq::Quality object Args : threshold, optional Set threshold first using method L<threshold>. Note, this method could be implemented using some gaussian smoothing of the quality scores. Currently one base below the threshold is enough to end the clear range. =cut sub get_clear_range { my $self = shift; my $threshold = shift; $self->threshold($threshold) if defined $threshold; # populate the cache if needed $self->_find_clear_ranges unless defined $self->{_ranges}; # fix for bug 2847 return unless defined $self->{_ranges}; # pick the longest for (sort {$b->{length} <=> $a->{length} } @{$self->{_ranges}} ){ my $newqualobj = Bio::Seq::Quality->new( -seq => $self->subseq( $_->{start}, $_->{end}), -qual => $self->subqual($_->{start}, $_->{end}), -id => $self->id); $newqualobj->threshold($threshold); return $newqualobj; } } =head2 get_all_clean_ranges Title : get_all_clean_ranges Usage : @ranges = $obj->get_all_clean_ranges($minlength); Function: Return all ranges where quality values are above the threshold. Original ordering. Returns : an ordered array of new Bio::Seq::Quality objects Args : minimum length , optional Set threshold first using method L<threshold>. =cut sub get_all_clean_ranges { my $self = shift; my $minl = shift || 0; $self->throw("Mimimum length needs to be zero or a positive integer [$minl]") unless $minl =~ /^\+?\d+$/; # populate the cache if needed $self->_find_clear_ranges unless defined $self->{_ranges}; # return in the order of occurrence my @ranges; for my $r (sort {$b->{start} <=> $a->{start} } @{$self->{_ranges}} ){ next if $r->{length} < $minl; ## Constructor should allow "-threshold => ..."! push @ranges, Bio::Seq::Quality->new ( -seq => $self->subseq( $r->{start}, $r->{end}), -qual => $self->subqual($r->{start}, $r->{end}), -id => $self->id ); } return @ranges; } # # _find_clear_ranges: where range/threshold calculations happen # sub _find_clear_ranges { my $self = shift; my $qual = $self->qual; $self->throw("You need to set the threshold value first") unless defined $self->threshold; my $threshold = $self->threshold; my $rangeFlag = 0; for(my $i=0; $i<@$qual; $i++){ ## Are we currently within a clear range or not? if($rangeFlag){ ## Did we just leave the clear range? if($qual->[$i]<$threshold){ ## Log the range my $range; $range->{end} = $i-1; $range->{start} = $rangeFlag; $range->{length} = $i - $rangeFlag; push @{$self->{_ranges}}, $range; ## and reset the range flag. $rangeFlag = 0; } ## else nothing changes } else{ ## Did we just enter a clear range? if($qual->[$i]>=$threshold){ ## then set the range flag! $rangeFlag = $i; } ## else nothing changes } } ## Did we exit the last clear range? if($rangeFlag){ my $i = scalar(@$qual); ## Log the range my $range; $range->{end} = $i-1; $range->{start} = $rangeFlag; $range->{length} = $i - $rangeFlag; push @{$self->{_ranges}}, $range; } 1; } sub _empty_cache { my $self = shift; undef $self->{_ranges}; } ################## deprecated methods ################## sub trace_indices { my $self = shift; return $self->named_meta('trace'); } sub trace_index_at { my ($self, $val) =@_; return shift @{$self->named_submeta('trace', $val, $val)}; } sub sub_trace_index { my $self = shift; return $self->named_submeta('trace', @_); } sub qualat { my ($self, $val) =@_; return shift @{$self->submeta($val, $val)}; } sub baseat { my ($self,$val) = @_; return $self->subseq($val,$val); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/RichSeq.pm������������������������������������������������������������������000444��000765��000024�� 24452�12254227340� 16621� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::RichSeq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::RichSeq - Module implementing a sequence created from a rich sequence database entry =head1 SYNOPSIS See L<Bio::Seq::RichSeqI> and documentation of methods. =head1 DESCRIPTION This module implements Bio::Seq::RichSeqI, an interface for sequences created from or created for entries from/of rich sequence databanks, like EMBL, GenBank, and SwissProt. Methods added to the Bio::SeqI interface therefore focus on databank-specific information. Note that not every rich databank format may use all of the properties provided. For more information, please see the relevant =head1 Implemented Interfaces This class implementes the following interfaces. =over 4 =item L<Bio::Seq::RichSeqI> Note that this includes implementing L<Bio::PrimarySeqI> and L<Bio::SeqI>, specifically via L<Bio::Seq> and L<Bio::PrimarySeq>. Please review the documentation for those modules on implementation details relevant to those interfaces, as well as the ones below. =item L<Bio::IdentifiableI> =item L<Bio::DescribableI> =item L<Bio::AnnotatableI> =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::RichSeq; use vars qw($AUTOLOAD); use strict; use base qw(Bio::Seq Bio::Seq::RichSeqI); =head2 new Title : new Usage : $seq = Bio::Seq::RichSeq->new( -seq => 'ATGGGGGTGGTGGTACCCT', -id => 'human_id', -accession_number => 'AL000012', ); Function: Returns a new seq object from basic constructors, being a string for the sequence and strings for id and accession_number Returns : a new Bio::Seq::RichSeq object =cut sub new { # standard new call.. my($caller,@args) = @_; my $self = $caller->SUPER::new(@args); $self->{'_dates'} = []; $self->{'_secondary_accession'} = []; my ($dates, $xtra, $sv, $keywords, $pid, $mol, $division ) = $self->_rearrange([qw(DATES SECONDARY_ACCESSIONS SEQ_VERSION KEYWORDS PID MOLECULE DIVISION )], @args); defined $division && $self->division($division); defined $mol && $self->molecule($mol); if(defined($keywords)) { if(ref($keywords) && (ref($keywords) eq "ARRAY")) { $self->add_keyword(@$keywords); } else { # got a string - use the old API $self->keywords($keywords); } } defined $sv && $self->seq_version($sv); defined $pid && $self->pid($pid); if( defined $dates ) { if( ref($dates) eq "ARRAY" ) { foreach ( @$dates) { $self->add_date($_); } } else { $self->add_date($dates); } } if( defined $xtra ) { if( ref($xtra) eq "ARRAY" ) { foreach ( @$xtra) { $self->add_secondary_accession($_); } } else { $self->add_secondary_accession($xtra); } } return $self; } =head2 division Title : division Usage : $obj->division($newval) Function: Returns : value of division Args : newvalue (optional) =cut sub division { my $obj = shift; if( @_ ) { my $value = shift; $obj->{'_division'} = $value; } return $obj->{'_division'}; } =head2 molecule Title : molecule Usage : $obj->molecule($newval) Function: Returns : type of molecule (DNA, mRNA) Args : newvalue (optional) =cut sub molecule { my $obj = shift; if( @_ ) { my $value = shift; $obj->{'_molecule'} = $value; } return $obj->{'_molecule'}; } =head2 add_date Title : add_date Usage : $self->add_date($datestr) Function: adds one or more dates This implementation stores dates as keyed annotation, the key being 'date_changed'. You can take advantage of this fact when accessing the annotation collection directly. Example : Returns : Args : a date string or an array of such strings =cut sub add_date { return shift->_add_annotation_value('date_changed',@_); } =head2 get_dates Title : get_dates Usage : my @dates = $seq->get_dates; Function: Get the dates of the sequence (usually, when it was created and changed. Returns : an array of date strings Args : =cut sub get_dates{ return shift->_get_annotation_values('date_changed'); } =head2 pid Title : pid Usage : my $pid = $seq->pid(); Function: Get (and set, depending on the implementation) the PID property for the sequence. Returns : a string Args : =cut sub pid{ my $self = shift; return $self->{'_pid'} = shift if @_; return $self->{'_pid'}; } =head2 accession Title : accession Usage : $obj->accession($newval) Function: Whilst the underlying sequence object does not have an accession, so we need one here. In this implementation this is merely a synonym for accession_number(). Example : Returns : value of accession Args : newvalue (optional) =cut sub accession { my ($obj,@args) = @_; return $obj->accession_number(@args); } =head2 add_secondary_accession Title : add_secondary_accession Usage : $self->add_domment($ref) Function: adds a secondary_accession This implementation stores secondary accession numbers as keyed annotation, the key being 'secondary_accession'. You can take advantage of this fact when accessing the annotation collection directly. Example : Returns : Args : a string or an array of strings =cut sub add_secondary_accession { return shift->_add_annotation_value('secondary_accession',@_); } =head2 get_secondary_accessions Title : get_secondary_accessions Usage : my @acc = $seq->get_secondary_accessions(); Function: Get the secondary accession numbers as strings. Returns : An array of strings Args : none =cut sub get_secondary_accessions{ return shift->_get_annotation_values('secondary_accession'); } =head2 seq_version Title : seq_version Usage : $obj->seq_version($newval) Function: Get/set the sequence version Returns : value of seq_version (a scalar) Args : on set, new value (a scalar or undef, optional) Note : this differs from Bio::PrimarySeq version() in that this explicitly refers to the sequence record version one would find in a typical sequence file. =cut sub seq_version{ my $self = shift; return $self->{'_seq_version'} = shift if @_; return $self->{'_seq_version'}; } =head2 add_keyword Title : add_keyword Usage : $obj->add_keyword($newval) Function: Add a new keyword to the annotation of the sequence. This implementation stores keywords as keyed annotation, the key being 'keyword'. You can take advantage of this fact when accessing the annotation collection directly. Returns : Args : value to be added (optional) (a string) =cut sub add_keyword { return shift->_add_annotation_value('keyword',@_); } =head2 get_keywords Title : get_keywords Usage : $obj->get_keywords($newval) Function: Get the keywords for this sequence as an array of strings. Returns : an array of strings Args : =cut sub get_keywords { return shift->_get_annotation_values('keyword'); } =head1 Private methods and synonyms for backward compatibility =cut =head2 _add_annotation_value Title : _add_annotation_value Usage : Function: Adds a value to the annotation collection under the specified key. Note that this is not a public method. Returns : Args : key (a string), value(s) (one or more scalars) =cut sub _add_annotation_value{ my $self = shift; my $key = shift; foreach my $val (@_) { $self->annotation->add_Annotation( Bio::Annotation::SimpleValue->new(-tagname => $key, -value => $val) ); } } =head2 _get_annotation_values Title : _get_annotation_values Usage : Function: Gets the values of a specific annotation as identified by the key from the annotation collection. Note that this is not a public method. Example : Returns : an array of strings Args : the key (a string) =cut sub _get_annotation_values{ my $self = shift; return map { $_->value(); } $self->annotation->get_Annotations(shift); } # ## ### Deprecated methods kept for ease of transition ## # sub keywords { my $self = shift; # have we been called in set mode? if(@_) { # yes; translate to the new API foreach my $kwd (@_) { $self->add_keyword(split(/\s*;\s*/,$kwd)); } } else { # no; translate read-only to the new API return join("; ",$self->get_keywords()); } } sub each_date { my ($self) = @_; $self->warn("Deprecated method... please use get_dates"); return $self->get_dates; } sub each_secondary_accession { my ($self) = @_; $self->warn("each_secondary_accession - deprecated method. use get_secondary_accessions"); return $self->get_secondary_accessions; } sub sv { my ($obj,$value) = @_; $obj->warn("sv - deprecated method. use seq_version"); $obj->seq_version($value); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/RichSeqI.pm�����������������������������������������������������������������000444��000765��000024�� 12662�12254227315� 16734� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::RichSeqI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::RichSeqI - interface for sequences from rich data sources, mostly databases =head1 SYNOPSIS @secondary = $richseq->get_secondary_accessions; $division = $richseq->division; $mol = $richseq->molecule; @dates = $richseq->get_dates; $seq_version = $richseq->seq_version; $pid = $richseq->pid; @keywords = $richseq->get_keywords; =head1 DESCRIPTION This interface extends the L<Bio::SeqI> interface to give additional functionality to sequences with richer data sources, in particular from database sequences (EMBL, GenBank and Swissprot). For a general implementation, please see the documentation for L<Bio::Seq::RichSeq>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::RichSeqI; use strict; use base qw(Bio::SeqI); =head2 get_secondary_accessions Title : get_secondary_accessions Usage : Function: Get the secondary accessions for a sequence. An implementation that allows modification of this array property should provide the methods add_secondary_accession and remove_secondary_accessions, with obvious purpose. Example : Returns : an array of strings Args : none =cut sub get_secondary_accessions{ my ($self,@args) = @_; $self->throw("hit get_secondary_accessions in interface definition - error"); } =head2 division Title : division Usage : Function: Get (and set, depending on the implementation) the divison for a sequence. Examples from GenBank are PLN (plants), PRI (primates), etc. Example : Returns : a string Args : =cut sub division{ my ($self,@args) = @_; $self->throw("hit division in interface definition - error"); } =head2 molecule Title : molecule Usage : Function: Get (and set, depending on the implementation) the molecule type for the sequence. This is not necessarily the same as Bio::PrimarySeqI::alphabet(), because it is databank-specific. Example : Returns : a string Args : =cut sub molecule{ my ($self,@args) = @_; $self->throw("hit molecule in interface definition - error"); } =head2 pid Title : pid Usage : Function: Get (and set, depending on the implementation) the PID property for the sequence. Example : Returns : a string Args : =cut sub pid { my ($self,@args) = @_; $self->throw("hit pid in interface definition - error"); } =head2 get_dates Title : get_dates Usage : Function: Get (and set, depending on the implementation) the dates the databank entry specified for the sequence An implementation that allows modification of this array property should provide the methods add_date and remove_dates, with obvious purpose. Example : Returns : an array of strings Args : =cut sub get_dates{ my ($self,@args) = @_; $self->throw("hit get_dates in interface definition - error"); } =head2 seq_version Title : seq_version Usage : Function: Get (and set, depending on the implementation) the version string of the sequence. Example : Returns : a string Args : Note : this differs from Bio::PrimarySeq version() in that this explicitly refers to the sequence record version one would find in a typical sequence file. It is up to the implementation whether this is set separately or falls back to the more generic Bio::Seq::version() =cut sub seq_version{ my ($self,@args) = @_; $self->throw("hit seq_version in interface definition - error"); } =head2 get_keywords Title : get_keywords Usage : $obj->get_keywords() Function: Get the keywords for this sequence object. An implementation that allows modification of this array property should provide the methods add_keyword and remove_keywords, with obvious purpose. Returns : an array of strings Args : =cut sub get_keywords { my ($self) = @_; $self->throw("hit keywords in interface definition - error"); } 1; ������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/SeqBuilder.pm���������������������������������������������������������������000444��000765��000024�� 42363�12254227322� 17323� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::SeqBuilder # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp at gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Seq::SeqBuilder - Configurable object builder for sequence stream parsers =head1 SYNOPSIS use Bio::SeqIO; # usually you won't instantiate this yourself - a SeqIO object - # you will have one already my $seqin = Bio::SeqIO->new(-fh => \*STDIN, -format => "genbank"); my $builder = $seqin->sequence_builder(); # if you need only sequence, id, and description (e.g. for # conversion to FASTA format): $builder->want_none(); $builder->add_wanted_slot('display_id','desc','seq'); # if you want everything except the sequence and features $builder->want_all(1); # this is the default if it's untouched $builder->add_unwanted_slot('seq','features'); # if you want only human sequences shorter than 5kb and skip all # others $builder->add_object_condition(sub { my $h = shift; return 0 if $h->{'-length'} > 5000; return 0 if exists($h->{'-species'}) && ($h->{'-species'}->binomial() ne "Homo sapiens"); return 1; }); # when you are finished with configuring the builder, just use # the SeqIO API as you would normally while(my $seq = $seqin->next_seq()) { # do something } =head1 DESCRIPTION This is an implementation of L<Bio::Factory::ObjectBuilderI> used by parsers of rich sequence streams. It provides for a relatively easy-to-use configurator of the parsing flow. Configuring the parsing process may be for you if you need much less information, or much less sequence, than the stream actually contains. Configuration can in both cases speed up the parsing time considerably, because unwanted sections or the rest of unwanted sequences are skipped over by the parser. This configuration could also conserve memory if you're running out of available RAM. See the methods of the class-specific implementation section for further documentation of what can be configured. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::SeqBuilder; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::Factory::ObjectBuilderI); my %slot_param_map = ("add_SeqFeature" => "features", ); my %param_slot_map = ("features" => "add_SeqFeature", ); =head2 new Title : new Usage : my $obj = Bio::Seq::SeqBuilder->new(); Function: Builds a new Bio::Seq::SeqBuilder object Returns : an instance of Bio::Seq::SeqBuilder Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'wanted_slots'} = []; $self->{'unwanted_slots'} = []; $self->{'object_conds'} = []; $self->{'_objhash'} = {}; $self->want_all(1); return $self; } =head1 Methods for implementing L<Bio::Factory::ObjectBuilderI> =cut =head2 want_slot Title : want_slot Usage : Function: Whether or not the object builder wants to populate the specified slot of the object to be built. The slot can be specified either as the name of the respective method, or the initialization parameter that would be otherwise passed to new() of the object to be built. Note that usually only the parser will call this method. Use add_wanted_slots and add_unwanted_slots for configuration. Example : Returns : TRUE if the object builder wants to populate the slot, and FALSE otherwise. Args : the name of the slot (a string) =cut sub want_slot{ my ($self,$slot) = @_; my $ok = 0; $slot = substr($slot,1) if substr($slot,0,1) eq '-'; if($self->want_all()) { foreach ($self->get_unwanted_slots()) { # this always overrides in want-all mode return 0 if($slot eq $_); } if(! exists($self->{'_objskel'})) { $self->{'_objskel'} = $self->sequence_factory->create_object(); } if(exists($param_slot_map{$slot})) { $ok = $self->{'_objskel'}->can($param_slot_map{$slot}); } else { $ok = $self->{'_objskel'}->can($slot); } return $ok if $ok; # even if the object 'cannot' do this slot, it might have been # added to the list of wanted slot, so carry on } foreach ($self->get_wanted_slots()) { if($slot eq $_) { $ok = 1; last; } } return $ok; } =head2 add_slot_value Title : add_slot_value Usage : Function: Adds one or more values to the specified slot of the object to be built. Naming the slot is the same as for want_slot(). The object builder may further filter the content to be set, or even completely ignore the request. If this method reports failure, the caller should not add more values to the same slot. In addition, the caller may find it appropriate to abandon the object being built altogether. This implementation will allow the caller to overwrite the return value from want_slot(), because the slot is not checked against want_slot(). Note that usually only the parser will call this method, but you may call it from anywhere if you know what you are doing. A derived class may be used to further manipulate the value to be added. Example : Returns : TRUE on success, and FALSE otherwise Args : the name of the slot (a string) parameters determining the value to be set OR alternatively, a list of slotname/value pairs in the style of named parameters as they would be passed to new(), where each element at an even index is the parameter (slot) name starting with a dash, and each element at an odd index is the value of the preceding name. =cut sub add_slot_value{ my ($self,$slot,@args) = @_; my $h = $self->{'_objhash'}; return unless $h; # multiple named parameter variant of calling? if((@args > 1) && (@args % 2) && (substr($slot,0,1) eq '-')) { unshift(@args, $slot); while(@args) { my $key = shift(@args); $h->{$key} = shift(@args); } } else { if($slot eq 'add_SeqFeature') { $slot = '-'.$slot_param_map{$slot}; $h->{$slot} = [] unless $h->{$slot}; push(@{$h->{$slot}}, @args); } else { $slot = '-'.$slot unless substr($slot,0,1) eq '-'; $h->{$slot} = $args[0]; } } return 1; } =head2 want_object Title : want_object Usage : Function: Whether or not the object builder is still interested in continuing with the object being built. If this method returns FALSE, the caller should not add any more values to slots, or otherwise risks that the builder throws an exception. In addition, make_object() is likely to return undef after this method returned FALSE. Note that usually only the parser will call this method. Use add_object_condition for configuration. Example : Returns : TRUE if the object builder wants to continue building the present object, and FALSE otherwise. Args : none =cut sub want_object{ my $self = shift; my $ok = 1; foreach my $cond ($self->get_object_conditions()) { $ok = &$cond($self->{'_objhash'}); last unless $ok; } delete $self->{'_objhash'} unless $ok; return $ok; } =head2 make_object Title : make_object Usage : Function: Get the built object. This method is allowed to return undef if no value has ever been added since the last call to make_object(), or if want_object() returned FALSE (or would have returned FALSE) before calling this method. For an implementation that allows consecutive building of objects, a caller must call this method once, and only once, between subsequent objects to be built. I.e., a call to make_object implies 'end_object.' Example : Returns : the object that was built Args : none =cut sub make_object{ my $self = shift; my $obj; if(exists($self->{'_objhash'}) && %{$self->{'_objhash'}}) { $obj = $self->sequence_factory->create_object(%{$self->{'_objhash'}}); } $self->{'_objhash'} = {}; # reset return $obj; } =head1 Implementation specific methods These methods allow to conveniently configure this sequence object builder as to which slots are desired, and under which circumstances a sequence object should be abandoned altogether. The default mode is want_all(1), which means the builder will report all slots as wanted that the object created by the sequence factory supports. You can add specific slots you want through add_wanted_slots(). In most cases, you will want to call want_none() before in order to relax zero acceptance through a list of wanted slots. Alternatively, you can add specific unwanted slots through add_unwanted_slots(). In this case, you will usually want to call want_all(1) before (which is the default if you never touched the builder) to restrict unrestricted acceptance. I.e., want_all(1) means want all slots except for the unwanted, and want_none() means only those explicitly wanted. If a slot is in both the unwanted and the wanted list, the following rules hold. In want-all mode, the unwanted list overrules. In want-none mode, the wanted list overrides the unwanted list. If this is confusing to you, just try to avoid having slots at the same time in the wanted and the unwanted lists. =cut =head2 get_wanted_slots Title : get_wanted_slots Usage : $obj->get_wanted_slots($newval) Function: Get the list of wanted slots Example : Returns : a list of strings Args : =cut sub get_wanted_slots{ my $self = shift; return @{$self->{'wanted_slots'}}; } =head2 add_wanted_slot Title : add_wanted_slot Usage : Function: Adds the specified slots to the list of wanted slots. Example : Returns : TRUE Args : an array of slot names (strings) =cut sub add_wanted_slot{ my ($self,@slots) = @_; my $myslots = $self->{'wanted_slots'}; foreach my $slot (@slots) { if(! grep { $slot eq $_; } @$myslots) { push(@$myslots, $slot); } } return 1; } =head2 remove_wanted_slots Title : remove_wanted_slots Usage : Function: Removes all wanted slots added previously through add_wanted_slots(). Example : Returns : the previous list of wanted slot names Args : none =cut sub remove_wanted_slots{ my $self = shift; my @slots = $self->get_wanted_slots(); $self->{'wanted_slots'} = []; return @slots; } =head2 get_unwanted_slots Title : get_unwanted_slots Usage : $obj->get_unwanted_slots($newval) Function: Get the list of unwanted slots. Example : Returns : a list of strings Args : none =cut sub get_unwanted_slots{ my $self = shift; return @{$self->{'unwanted_slots'}}; } =head2 add_unwanted_slot Title : add_unwanted_slot Usage : Function: Adds the specified slots to the list of unwanted slots. Example : Returns : TRUE Args : an array of slot names (strings) =cut sub add_unwanted_slot{ my ($self,@slots) = @_; my $myslots = $self->{'unwanted_slots'}; foreach my $slot (@slots) { if(! grep { $slot eq $_; } @$myslots) { push(@$myslots, $slot); } } return 1; } =head2 remove_unwanted_slots Title : remove_unwanted_slots Usage : Function: Removes the list of unwanted slots added previously through add_unwanted_slots(). Example : Returns : the previous list of unwanted slot names Args : none =cut sub remove_unwanted_slots{ my $self = shift; my @slots = $self->get_unwanted_slots(); $self->{'unwanted_slots'} = []; return @slots; } =head2 want_none Title : want_none Usage : Function: Disables all slots. After calling this method, want_slot() will return FALSE regardless of slot name. This is different from removed_wanted_slots() in that it also sets want_all() to FALSE. Note that it also resets the list of unwanted slots in order to avoid slots being in both lists. Example : Returns : TRUE Args : none =cut sub want_none{ my $self = shift; $self->want_all(0); $self->remove_wanted_slots(); $self->remove_unwanted_slots(); return 1; } =head2 want_all Title : want_all Usage : $obj->want_all($newval) Function: Whether or not this sequence object builder wants to populate all slots that the object has. Whether an object supports a slot is generally determined by what can() returns. You can add additional 'virtual' slots by calling add_wanted_slot. This will be ON by default. Call $obj->want_none() to disable all slots. Example : Returns : TRUE if this builder wants to populate all slots, and FALSE otherwise. Args : on set, new value (a scalar or undef, optional) =cut sub want_all{ my $self = shift; return $self->{'want_all'} = shift if @_; return $self->{'want_all'}; } =head2 get_object_conditions Title : get_object_conditions Usage : Function: Get the list of conditions an object must meet in order to be 'wanted.' See want_object() for where this is used. Conditions in this implementation are closures (anonymous functions) which are passed one parameter, a hash reference the keys of which are equal to initialization paramaters. The closure must return TRUE to make the object 'wanted.' Conditions will be implicitly ANDed. Example : Returns : a list of closures Args : none =cut sub get_object_conditions{ my $self = shift; return @{$self->{'object_conds'}}; } =head2 add_object_condition Title : add_object_condition Usage : Function: Adds a condition an object must meet in order to be 'wanted.' See want_object() for where this is used. Conditions in this implementation must be closures (anonymous functions). These will be passed one parameter, which is a hash reference with the sequence object initialization parameters being the keys. Conditions are implicitly ANDed. If you want other operators, perform those tests inside of one closure instead of multiple. This will also be more efficient. Example : Returns : TRUE Args : the list of conditions =cut sub add_object_condition{ my ($self,@conds) = @_; if(grep { ref($_) ne 'CODE'; } @conds) { $self->throw("conditions against which to validate an object ". "must be anonymous code blocks"); } push(@{$self->{'object_conds'}}, @conds); return 1; } =head2 remove_object_conditions Title : remove_object_conditions Usage : Function: Removes the conditions an object must meet in order to be 'wanted.' Example : Returns : The list of previously set conditions (an array of closures) Args : none =cut sub remove_object_conditions{ my $self = shift; my @conds = $self->get_object_conditions(); $self->{'object_conds'} = []; return @conds; } =head1 Methods to control what type of object is built =cut =head2 sequence_factory Title : sequence_factory Usage : $obj->sequence_factory($newval) Function: Get/set the sequence factory to be used by this object builder. Example : Returns : the Bio::Factory::SequenceFactoryI implementing object to use Args : on set, new value (a Bio::Factory::SequenceFactoryI implementing object or undef, optional) =cut sub sequence_factory{ my $self = shift; if(@_) { delete $self->{'_objskel'}; return $self->{'sequence_factory'} = shift; } return $self->{'sequence_factory'}; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/SeqFactory.pm���������������������������������������������������������������000444��000765��000024�� 7663�12254227336� 17335� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::SeqFactory # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::SeqFactory - Instantiation of generic Bio::PrimarySeqI (or derived) objects through a factory =head1 SYNOPSIS use Bio::Seq::SeqFactory; my $factory = Bio::Seq::SeqFactory->new(); my $primaryseq = $factory->create( -seq => 'WYRAVLC', -id => 'name' ); # Create Bio::Seq instead of Bio::PrimarySeq objects: my $factory = Bio::Seq::SeqFactory->new( -type => 'Bio::Seq' ); =head1 DESCRIPTION This object will build L<Bio::PrimarySeqI> and L<Bio::SeqI> objects generically. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::SeqFactory; use strict; use base qw(Bio::Root::Root Bio::Factory::SequenceFactoryI); =head2 new Title : new Usage : my $obj = Bio::Seq::SeqFactory->new(); Function: Builds a new Bio::Seq::SeqFactory object Returns : Bio::Seq::SeqFactory Args : -type => string, name of a PrimarySeqI derived class This is optional. Default=Bio::PrimarySeq. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($type) = $self->_rearrange([qw(TYPE)], @args); if( ! defined $type ) { $type = 'Bio::PrimarySeq'; } $self->type($type); return $self; } =head2 create Title : create Usage : my $seq = $seqbuilder->create(-seq => 'CAGT', -id => 'name'); Function: Instantiates new Bio::SeqI (or one of its child classes) This object allows us to genericize the instantiation of sequence objects. Returns : Bio::PrimarySeq object (default) The return type is configurable using new(-type =>"..."). Args : initialization parameters specific to the type of sequence object we want. Typically -seq => $str, -display_id => $name =cut sub create { my ($self,@args) = @_; return $self->type->new(-verbose => $self->verbose, @args); } =head2 type Title : type Usage : $obj->type($newval) Function: Returns : value of type Args : newvalue (optional) =cut sub type { my ($self, $value) = @_; if (defined $value) { eval "require $value"; if( $@ ) { $self->throw("$@: Unrecognized Sequence type for SeqFactory '$value'");} my $a = bless {},$value; unless( $a->isa('Bio::PrimarySeqI') || $a->isa('Bio::Seq::QualI' ) ) { $self->throw("Must provide a valid Bio::PrimarySeqI or Bio::Seq::QualI or child class to SeqFactory Not $value"); } $self->{'type'} = $value; } return $self->{'type'}; } 1; �����������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/SeqFastaSpeedFactory.pm�����������������������������������������������������000444��000765��000024�� 7566�12254227334� 21275� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::SeqFastaSpeedFactory # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::SeqFastaSpeedFactory - Rapid creation of Bio::Seq objects through a factory =head1 SYNOPSIS use Bio::Seq::SeqFastaSpeedFactory; my $factory = Bio::Seq::SeqFastaSpeedFactory->new(); my $seq = $factory->create( -seq => 'WYRAVLC', -id => 'name' ); =head1 DESCRIPTION This factory was designed to build Bio::Seq objects as quickly as possible, but is not as generic as L<Bio::Seq::SeqFactory>. It can be used to create sequences from non-rich file formats. The L<Bio::SeqIO::fasta> sequence parser uses this factory. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::SeqFastaSpeedFactory; use strict; use Bio::Seq; use Bio::PrimarySeq; use base qw(Bio::Root::Root Bio::Factory::SequenceFactoryI); =head2 new Title : new Usage : my $obj = Bio::Seq::SeqFastaSpeedFactory->new(); Function: Builds a new Bio::Seq::SeqFastaSpeedFactory object Returns : Bio::Seq::SeqFastaSpeedFactory Args : None =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 create Title : create Usage : my $seq = $seqbuilder->create(-seq => 'CAGT', -id => 'name'); Function: Instantiates a new Bio::Seq object, correctly built but very fast, knowing stuff about Bio::PrimarySeq and Bio::Seq Returns : A Bio::Seq object Args : Initialization parameters for the sequence object we want: -id -primary_id -display_id -desc -seq -alphabet =cut sub create { my ($self,@args) = @_; my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $sequence = $param{'-seq'}; my $fulldesc = $param{'-desc'}; my $id = defined $param{'-id'} ? $param{'-id'} : $param{'-primary_id'}; my $alphabet = $param{'-alphabet'}; my $seq = bless {}, 'Bio::Seq'; my $t_pseq = $seq->{'primary_seq'} = bless {}, 'Bio::PrimarySeq'; $t_pseq->{'seq'} = $sequence; $t_pseq->{'length'} = CORE::length($sequence); $t_pseq->{'desc'} = $fulldesc; $t_pseq->{'display_id'} = $id; $t_pseq->{'primary_id'} = $id; $seq->{'primary_id'} = $id; # currently Bio::Seq does not delegate this if( $sequence and !$alphabet ) { $t_pseq->_guess_alphabet(); } elsif ( $sequence and $alphabet ) { $t_pseq->{'alphabet'} = $alphabet; } return $seq; } 1; ������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/SequenceTrace.pm������������������������������������������������������������000555��000765��000024�� 102013�12254227330� 20022� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::SequenceTrace # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla <bioinformatics@dieselwurks.com # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::SequenceTrace - Bioperl object packaging a sequence with its trace =head1 SYNOPSIS # example code here =head1 DESCRIPTION This object stores a sequence with its trace. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics@dieselwurks.com The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Seq::SequenceTrace; use strict; use Bio::Seq::QualI; use Bio::PrimarySeqI; use Bio::PrimarySeq; use Bio::Seq::PrimaryQual; use base qw(Bio::Root::Root Bio::Seq::Quality Bio::Seq::TraceI); =head2 new() Title : new() Usage : $st = Bio::Seq::SequenceTrace->new ( -swq => Bio::Seq::SequenceWithQuality, -trace_a => \@trace_values_for_a_channel, -trace_t => \@trace_values_for_t_channel, -trace_g => \@trace_values_for_g_channel, -trace_c => \@trace_values_for_c_channel, -accuracy_a => \@a_accuracies, -accuracy_t => \@t_accuracies, -accuracy_g => \@g_accuracies, -accuracy_c => \@c_accuracies, -peak_indices => '0 5 10 15 20 25 30 35' ); Function: Returns a new Bio::Seq::SequenceTrace object from basic constructors. Returns : a new Bio::Seq::SequenceTrace object Arguments: I think that these are all describes in the usage above. =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); # default: turn OFF the warnings $self->{supress_warnings} = 1; my($swq,$peak_indices,$trace_a,$trace_t, $trace_g,$trace_c,$acc_a,$acc_t,$acc_g,$acc_c) = $self->_rearrange([qw( SWQ PEAK_INDICES TRACE_A TRACE_T TRACE_G TRACE_C ACCURACY_A ACCURACY_T ACCURACY_G ACCURACY_C )], @args); # first, deal with the sequence and quality information if ($swq && ref($swq) eq "Bio::Seq::Quality") { $self->{swq} = $swq; } else { $self->throw("A Bio::Seq::SequenceTrace object must be created with a Bio::Seq::Quality object. You provided this type of object: " .ref($swq)); } if (!$acc_a) { # this means that you probably did not provide traces and accuracies # and that they need to be synthesized $self->set_accuracies(); } else { $self->accuracies('a',$acc_a); $self->accuracies('t',$acc_t); $self->accuracies('g',$acc_g); $self->accuracies('c',$acc_c); } if (!$trace_a) { $self->_synthesize_traces(); } else { $self->trace('a',$trace_a); $self->trace('t',$trace_t); $self->trace('g',$trace_g); $self->trace('c',$trace_c); $self->peak_indices($peak_indices); } $self->id($self->seq_obj->id); return $self; } sub swq_obj { my $self = shift; $self->warn('swq_obj() is deprecated: use seq_obj()'); return $self->{swq}; } =head2 trace($base,\@new_values) Title : trace($base,\@new_values) Usage : @trace_Values = @{$obj->trace($base,\@new_values)}; Function: Returns the trace values as a reference to an array containing the trace values. The individual elements of the trace array are not validated and can be any numeric value. Returns : A reference to an array. Status : Arguments: $base : which color channel would you like the trace values for? - $base must be one of "A","T","G","C" \@new_values : a reference to an array of values containing trace data for this base =cut sub trace { my ($self,$base_channel,$values) = @_; if (!$base_channel) { $self->throw('You must provide a valid base channel (atgc) to use trace()'); } $base_channel =~ tr/A-Z/a-z/; if ($base_channel !~ /[acgt]/) { $self->throw('You must provide a valid base channel (atgc) to use trace()'); } if ($values) { if (ref($values) eq "ARRAY") { $self->{trace}->{$base_channel} = $values; } else { my @trace = split(' ',$values); $self->{trace}->{$base_channel} = \@trace; } } if ($self->{trace}->{$base_channel}) { return $self->{trace}->{$base_channel}; } else { return; } } =head2 peak_indices($new_indices) Title : peak_indices($new_indices) Usage : $indices = $obj->peak_indices($new_indices); Function: Return the trace index points for this object. Returns : A scalar Args : If used, the trace indices will be set to the provided value. =cut sub peak_indices { my ($self,$peak_indices)= @_; if ($peak_indices) { if (ref($peak_indices) eq "ARRAY") { $self->{peak_indices} = $peak_indices; } else { my @indices = split(' ',$peak_indices); $self->{peak_indices} = \@indices; } } if (!$self->{peak_indices}) { my @temp = (); $self->{peak_indices} = \@temp; } return $self->{peak_indices}; } =head2 _reset_peak_indices() Title : _rest_peak_indices() Usage : $obj->_reset_peak_indices(); Function: Reset the peak indices. Returns : Nothing. Args : None. Notes : When you create a sub_trace_object, the peak indices will still be pointing to the apporpriate location _in the original trace_. In order to fix this, the initial value must be subtracted from each value here. ie. The first peak index must be "1". =cut sub _reset_peak_indices { my $self = shift; my $length = $self->length(); my $subtractive = $self->peak_index_at(1); my ($original,$new); $self->peak_index_at(1,"null"); for (my $counter=2; $counter<= $length; $counter++) { my $original = $self->peak_index_at($counter); $new = $original - $subtractive; $self->peak_index_at($counter,$new); } return; } =head2 peak_index_at($position) Title : peak_index_at($position) Usage : $peak_index = $obj->peak_index_at($postition); Function: Return the trace iindex point at this position Returns : A scalar Args : If used, the trace index at this position will be set to the provided value. =cut sub peak_index_at { my ($self,$position,$value)= @_; if ($value) { if ($value eq "null") { $self->peak_indices->[$position-1] = "0"; } else { $self->peak_indices->[$position-1] = $value; } } return $self->peak_indices()->[$position-1]; } =head2 alphabet() Title : alphabet(); Usage : $molecule_type = $obj->alphabet(); Function: Get the molecule type from the PrimarySeq object. Returns : What what PrimarySeq says the type of the sequence is. Args : None. =cut sub alphabet { my $self = shift; return $self->{swq}->alphabet; } =head2 display_id() Title : display_id() Usage : $id_string = $obj->display_id(); Function: Returns the display id, aka the common name of the Quality object. The semantics of this is that it is the most likely string to be used as an identifier of the quality sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convience issues. This method sets the display_id for the Quality object. Returns : A string Args : If a scalar is provided, it is set as the new display_id for the Quality object. Status : Virtual =cut sub display_id { my ($self,$value) = @_; if( defined $value) { $self->{swq}->display_id($value); } return $self->{swq}->display_id(); } =head2 accession_number() Title : accession_number() Usage : $unique_biological_key = $obj->accession_number(); Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". This method sets the accession_number for the Quality object. Returns : A string (the value of accession_number) Args : If a scalar is provided, it is set as the new accession_number for the Quality object. Status : Virtual =cut sub accession_number { my( $self, $acc ) = @_; if (defined $acc) { $self->{swq}->accession_number($acc); } else { $acc = $self->{swq}->accession_number(); $acc = 'unknown' unless defined $acc; } return $acc; } =head2 primary_id() Title : primary_id() Usage : $unique_implementation_key = $obj->primary_id(); Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no accession number, this method should return a stringified memory location. This method sets the primary_id for the Quality object. Returns : A string. (the value of primary_id) Args : If a scalar is provided, it is set as the new primary_id for the Quality object. =cut sub primary_id { my ($self,$value) = @_; if ($value) { $self->{swq}->primary_id($value); } return $self->{swq}->primary_id(); } =head2 desc() Title : desc() Usage : $qual->desc($newval); _or_ $description = $qual->desc(); Function: Get/set description text for this Quality object. Returns : A string. (the value of desc) Args : If a scalar is provided, it is set as the new desc for the Quality object. =cut sub desc { # a mechanism to set the desc for the Quality object. # probably will be used most often by set_common_features() my ($self,$value) = @_; if( defined $value) { $self->{swq}->desc($value); } return $self->{swq}->desc(); } =head2 id() Title : id() Usage : $id = $qual->id(); Function: Return the ID of the quality. This should normally be (and actually is in the implementation provided here) just a synonym for display_id(). Returns : A string. (the value of id) Args : If a scalar is provided, it is set as the new id for the Quality object. =cut sub id { my ($self,$value) = @_; if (!$self) { $self->throw("no value for self in $value"); } if( defined $value ) { $self->{swq}->display_id($value); } return $self->{swq}->display_id(); } =head2 seq Title : seq() Usage : $string = $obj->seq(); _or_ $obj->seq("atctatcatca"); Function: Returns the sequence that is contained in the imbedded in the PrimarySeq object within the Quality object Returns : A scalar (the seq() value for the imbedded PrimarySeq object.) Args : If a scalar is provided, the Quality object will attempt to set that as the sequence for the imbedded PrimarySeq object. Otherwise, the value of seq() for the PrimarySeq object is returned. Notes : This is probably not a good idea because you then should call length() to make sure that the sequence and quality are of the same length. Even then, how can you make sure that this sequence belongs with that quality? I provided this to give you rope to hang yourself with. Tie it to a strong device and use a good knot. =cut sub seq { my ($self,$value) = @_; if( defined $value) { $self->{swq}->seq($value); } return $self->{swq}->seq(); } =head2 qual() Title : qual() Usage : @quality_values = @{$obj->qual()}; _or_ $obj->qual("10 10 20 40 50"); Function: Returns the quality as imbedded in the PrimaryQual object within the Quality object. Returns : A reference to an array containing the quality values in the PrimaryQual object. Args : If a scalar is provided, the Quality object will attempt to set that as the quality for the imbedded PrimaryQual object. Otherwise, the value of qual() for the PrimaryQual object is returned. Notes : This is probably not a good idea because you then should call length() to make sure that the sequence and quality are of the same length. Even then, how can you make sure that this sequence belongs with that quality? I provided this to give you a strong board with which to flagellate yourself. =cut sub qual { my ($self,$value) = @_; if( defined $value) { $self->{swq}->qual($value); } return $self->{swq}->qual(); } =head2 length() Title : length() Usage : $length = $seqWqual->length(); Function: Get the length of the Quality sequence/quality. Returns : Returns the length of the sequence and quality Args : None. =cut sub length { my $self = shift; return $self->seq_obj->length; } =head2 qual_obj Title : qual_obj($different_obj) Usage : $qualobj = $seqWqual->qual_obj(); _or_ $qualobj = $seqWqual->qual_obj($ref_to_primaryqual_obj); Function: Get the Qualilty object that is imbedded in the Quality object or if a reference to a PrimaryQual object is provided, set this as the PrimaryQual object imbedded in the Quality object. Returns : A reference to a Bio::Seq::Quality object. Identical to L<seq_obj>. =cut sub qual_obj { my ($self,$value) = @_; # return $self->{swq}->qual_obj($value); return $self->{swq}; } =head2 seq_obj Title : seq_obj() Usage : $seqobj = $seqWqual->seq_obj(); _or_ $seqobj = $seqWqual->seq_obj($ref_to_primary_seq_obj); Function: Get the PrimarySeq object that is imbedded in the Quality object or if a reference to a PrimarySeq object is provided, set this as the PrimarySeq object imbedded in the Quality object. Returns : A reference to a Bio::PrimarySeq object. =cut sub seq_obj { my ($self,$value) = @_; return $self->{swq}; } =head2 _set_descriptors Title : _set_descriptors() Usage : $seqWqual->_qual_obj($qual,$seq,$id,$acc,$pid,$desc,$given_id, $alphabet); Function: Set the descriptors for the Quality object. Try to match the descriptors in the PrimarySeq object and in the PrimaryQual object if descriptors were not provided with construction. Returns : Nothing. Args : $qual,$seq,$id,$acc,$pid,$desc,$given_id,$alphabet as found in the new() method. Notes : Really only intended to be called by the new() method. If you want to invoke a similar function try set_common_descriptors(). =cut sub _set_descriptors { my ($self,$qual,$seq,$id,$acc,$pid,$desc,$given_id,$alphabet) = @_; $self->{swq}->_seq_descriptors($qual,$seq,$id,$acc,$pid, $desc,$given_id,$alphabet); } =head2 subseq($start,$end) Title : subseq($start,$end) Usage : $subsequence = $obj->subseq($start,$end); Function: Returns the subseq from start to end, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Returns : A string. Args : Two positions. =cut sub subseq { my ($self,@args) = @_; # does a single value work? return $self->{swq}->subseq(@args); } =head2 baseat($position) Title : baseat($position) Usage : $base_at_position_6 = $obj->baseat("6"); Function: Returns a single base at the given position, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Returns : A scalar. Args : A position. =cut sub baseat { my ($self,$val) = @_; return $self->{swq}->subseq($val,$val); } =head2 subqual($start,$end) Title : subqual($start,$end) Usage : @qualities = @{$obj->subqual(10,20); Function: returns the quality values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A reference to an array. Args : a start position and an end position =cut sub subqual { my ($self,@args) = @_; return $self->{swq}->subqual(@args); } =head2 qualat($position) Title : qualat($position) Usage : $quality = $obj->qualat(10); Function: Return the quality value at the given location, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A scalar. Args : A position. =cut sub qualat { my ($self,$val) = @_; return $self->{swq}->qualat($val); } =head2 sub_peak_index($start,$end) Title : sub_peak_index($start,$end) Usage : @peak_indices = @{$obj->sub_peak_index(10,20); Function: returns the trace index values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two trace indices for this channel. Returns : A reference to an array. Args : a start position and an end position =cut sub sub_peak_index { my ($self,$start,$end) = @_; if( $start > $end ){ $self->throw("in sub_peak_index, start [$start] has to be greater than end [$end]"); } if( $start <= 0 || $end > $self->length ) { $self->throw("You have to have start positive and length less than the total length of sequence [$start:$end] Total ".$self->length.""); } # remove one from start, and then length is end-start $start--; $end--; my @sub_peak_index_array = @{$self->{peak_indices}}[$start..$end]; # return substr $self->seq(), $start, ($end-$start); return \@sub_peak_index_array; } =head2 sub_trace($start,$end) Title : sub_trace($base_channel,$start,$end) Usage : @trace_values = @{$obj->sub_trace('a',10,20)}; Function: returns the trace values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be e_peak_index. Returns : A reference to an array. Args : a start position and an end position =cut sub sub_trace { my ($self,$base_channel,$start,$end) = @_; if( $start > $end ){ $self->throw("in sub_trace, start [$start] has to be greater than end [$end]"); } if( $start <= 0 || $end > $self->trace_length() ) { $self->throw("You have to have start positive and length less than the total length of traces [$start:$end] Total ".$self->trace_length.""); } # remove one from start, and then length is end-start $start--; $end--; my @sub_peak_index_array = @{$self->trace($base_channel)}[$start..$end]; # return substr $self->seq(), $start, ($end-$start); return \@sub_peak_index_array; } =head2 trace_length() Title : trace_length() Usage : $trace_length = $obj->trace_length(); Function: Return the length of the trace if all four traces (atgc) are the same. Otherwise, throw an error. Returns : A scalar. Args : none =cut sub trace_length { my $self = shift; if ( !$self->trace('a') || !$self->trace('t') || !$self->trace('g') || !$self->trace('c') ) { $self->warn("One or more of the trace channels are missing. Cannot give you a length."); } my $lengtha = scalar(@{$self->trace('a')}); my $lengtht = scalar(@{$self->trace('t')}); my $lengthg = scalar(@{$self->trace('g')}); my $lengthc = scalar(@{$self->trace('c')}); if (($lengtha == $lengtht) && ($lengtha == $lengthg) && ($lengtha == $lengthc) ) { return $lengtha; } $self->warn("Not all of the trace indices are the same length". " Here are their lengths: a: $lengtha t:$lengtht ". " g: $lengthg c: $lengthc"); } =head2 sub_trace_object($start,$end) Title : sub_trace_object($start,$end) Usage : $smaller_object = $object->sub_trace_object('1','100'); Function: Get a subset of the sequence, its quality, and its trace. Returns : A reference to a Bio::Seq::SequenceTrace object Args : a start position and an end position Notes : - the start and end position refer to the positions of _bases_. - for example, to get a sub SequenceTrace for bases 5-10, use this routine. - you will get the bases, qualities, and the trace values - you can then use this object to synthesize a new scf using seqIO::scf. =cut sub sub_trace_object { my ($self,$start,$end) = @_; my ($start2,$end2); my @subs = @{$self->sub_peak_index($start,$end)}; $start2 = shift(@subs); $end2 = pop(@subs); my $new_object = Bio::Seq::SequenceTrace->new( -swq => Bio::Seq::Quality->new( -seq => $self->subseq($start,$end), -qual => $self->subqual($start,$end), -id => $self->id() ), -trace_a => $self->sub_trace('a',$start2,$end2), -trace_t => $self->sub_trace('t',$start2,$end2), -trace_g => $self->sub_trace('g',$start2,$end2), -trace_c => $self->sub_trace('c',$start2,$end2), -peak_indices => $self->sub_peak_index($start,$end) ); $new_object->set_accuracies(); $new_object->_reset_peak_indices(); return $new_object; } =head2 _synthesize_traces() Title : _synthesize_traces() Usage : $obj->_synthesize_traces(); Function: Synthesize false traces for this object. Returns : Nothing. Args : None. Notes : This method is intended to be invoked when this object is created with a SWQ object- that is to say that there is a sequence and a set of qualities but there was no actual trace data. =cut sub _synthesize_traces { my ($self) = shift; $self->peak_indices(qw()); #ml my $version = 2; # the user should be warned if traces already exist # # #ml ( my $sequence = $self->seq() ) =~ tr/a-z/A-Z/; #ml my @quals = @{$self->qual()}; #ml my $info; # build the ramp for the first base. # a ramp looks like this "1 4 13 29 51 71 80 71 51 29 13 4 1" times the quality score. # REMEMBER: A C G T # note to self-> smooth this thing out a bit later my $ramp_data; @{$ramp_data->{'ramp'}} = qw( 1 4 13 29 51 75 80 75 51 29 13 4 1 ); # the width of the ramp $ramp_data->{'ramp_width'} = scalar(@{$ramp_data->{'ramp'}}); # how far should the peaks overlap? $ramp_data->{'ramp_overlap'} = 1; # where should the peaks be located? $ramp_data->{'peak_at'} = 7; $ramp_data->{'ramp_total_length'} = $self->seq_obj()->length() * $ramp_data->{'ramp_width'} - $self->seq_obj()->length() * $ramp_data->{'ramp_overlap'}; my $pos; my $total_length = $ramp_data->{ramp_total_length}; $self->initialize_traces("0",$total_length+2); # now populate them my ($current_base,$place_base_at,$peak_quality,$ramp_counter,$current_ramp,$ramp_position); #ml my $sequence_length = $self->length(); my $half_ramp = int($ramp_data->{'ramp_width'}/2); for ($pos = 0; $pos<$self->length();$pos++) { $current_base = uc $self->seq_obj()->subseq($pos+1,$pos+1); # print("Synthesizing the ramp for $current_base\n"); my $all_bases = "ATGC"; $peak_quality = $self->qual_obj()->qualat($pos+1); # where should the peak for this base be placed? Modeled after a mktrace scf $place_base_at = ($pos * $ramp_data->{'ramp_width'}) - ($pos * $ramp_data->{'ramp_overlap'}) - $half_ramp + $ramp_data->{'ramp_width'} - 1; # print("Placing this base at this position: $place_base_at\n"); push @{$self->peak_indices()},$place_base_at; $ramp_position = $place_base_at - $half_ramp; if ($current_base =~ "N" ) { $current_base = "A"; } for ($current_ramp = 0; $current_ramp < $ramp_data->{'ramp_width'}; $current_ramp++) { # print("Placing a trace value here: $current_base ".($ramp_position+$current_ramp+1)." ".$peak_quality*$ramp_data->{'ramp'}->[$current_ramp]."\n"); $self->trace_value_at($current_base,$ramp_position+$current_ramp+1,$peak_quality*$ramp_data->{'ramp'}->[$current_ramp]); } $self->peak_index_at($pos+1, $place_base_at+1 ); #ml my $other_bases = $self->_get_other_bases($current_base); # foreach ( split('',$other_bases) ) { # push @{$self->{'text'}->{"v3_base_accuracy"}->{$_}},0; #} } } =head2 _dump_traces($transformed) Title : _dump_traces("transformed") Usage : &_dump_traces($ra,$rc,$rg,$rt); Function: Used in debugging. Prints all traces one beside each other. Returns : Nothing. Args : References to the arrays containing the traces for A,C,G,T. Notes : Beats using dumpValue, I'll tell ya. Much better then using join' ' too. - if a scalar is included as an argument (any scalar), this procedure will dump the _delta'd trace. If you don't know what that means you should not be using this. =cut #' sub _dump_traces { my ($self) = @_; my (@sA,@sT,@sG,@sC); print ("Count\ta\tc\tg\tt\n"); my $length = $self->trace_length(); for (my $curr=1; $curr <= $length; $curr++) { print(($curr-1)."\t".$self->trace_value_at('a',$curr). "\t".$self->trace_value_at('c',$curr). "\t".$self->trace_value_at('g',$curr). "\t".$self->trace_value_at('t',$curr)."\n"); } return; } =head2 _initialize_traces() Title : _initialize_traces() Usage : $trace_object->_initialize_traces(); Function: Creates empty arrays to hold synthetic trace values. Returns : Nothing. Args : None. =cut sub initialize_traces { my ($self,$value,$length) = @_; foreach (qw(a t g c)) { my @temp; for (my $count=0; $count<$length; $count++) { $temp[$count] = $value; } $self->trace($_,\@temp); } } =head2 trace_value_at($channel,$position) Title : trace_value_at($channel,$position) Usage : $value = $trace_object->trace_value_at($channel,$position); Function: What is the value of the trace for this base at this position? Returns : A scalar represnting the trace value here. Args : a base channel (a,t,g,c) a position ( < $trace_object->trace_length() ) =cut sub trace_value_at { my ($self,$channel,$position,$value) = @_; if ($value) { $self->trace($channel)->[$position] = $value; } return $self->sub_trace($channel,($position),($position))->[0]; } sub _deprecated_get_scf_version_2_base_structure { # this sub is deprecated- check inside SeqIO::scf my $self = shift; my (@structure,$current); my $length = $self->length(); for ($current=1; $current <= $self->length() ; $current++) { my $base_here = $self->seq_obj()->subseq($current,$current); $base_here = lc($base_here); my $probabilities; $probabilities->{$base_here} = $self->qual_obj()->qualat($current); my $other_bases = "atgc"; my $empty = ""; $other_bases =~ s/$base_here/$empty/e; foreach ( split('',$other_bases) ) { $probabilities->{$_} = "0"; } @structure = ( @structure, $self->peak_index_at($current), $probabilities->{'a'}, $probabilities->{'t'}, $probabilities->{'g'}, $probabilities->{'c'} ); } return \@structure; } sub _deprecated_get_scf_version_3_base_structure { my $self = shift; my $structure; $structure = join('',$self->peak_indices()); return $structure; } =head2 accuracies($channel,$position) Title : trace_value_at($channel,$position) Usage : $value = $trace_object->trace_value_at($channel,$position); Function: What is the value of the trace for this base at this position? Returns : A scalar representing the trace value here. Args : a base channel (a,t,g,c) a position ( < $trace_object->trace_length() ) =cut sub accuracies { my ($self,$channel,$value) = @_; if ($value) { if (ref($value) eq "ARRAY") { $self->{accuracies}->{$channel} = $value; } else { my @acc = split(' ',$value); $self->{accuracies}->{$channel} = \@acc; } } return $self->{accuracies}->{$channel}; } =head2 set_accuracies() Title : set_sccuracies() Usage : $trace_object->set_accuracies(); Function: Take a sequence's quality and synthesize proper scf-style base accuracies that can then be accessed with accuracies("a") or something like it. Returns : Nothing. Args : None. =cut sub set_accuracies { my $self = shift; my $count = 0; my $length = $self->length(); for ($count=1; $count <= $length; $count++) { my $base_here = $self->seq_obj()->subseq($count,$count); my $qual_here = $self->qual_obj()->qualat($count); $self->accuracy_at($base_here,$count,$qual_here); my $other_bases = $self->_get_other_bases($base_here); foreach (split('',$other_bases)) { $self->accuracy_at($_,$count,"null"); } } } =head2 scf_dump() Title : scf_dump() Usage : $trace_object->scf_dump(); Function: Prints out the contents of the structures representing the SequenceTrace in a manner similar to io_lib's scf_dump. Returns : Nothing. Prints out the contents of the structures used to represent the sequence and its trace. Args : None. Notes : Used in debugging, obviously. =cut sub scf_dump { my $self = shift; my $count; for ($count=1;$count<=$self->length();$count++) { my $base_here = lc($self->seq_obj()->subseq($count,$count)); print($base_here." ".sprintf("%05d",$self->peak_index_at($count))."\t"); foreach (sort qw(a c g t)) { print(sprintf("%03d",$self->accuracy_at($_,$count))."\t"); } print("\n"); } $self->_dump_traces(); } =head2 _get_other_bases($this_base) Title : _get_other_bases($this_base) Usage : $other_bases = $trace_object->_get_other_bases($this_base); Function: A utility routine to return bases other then the one provided. I was doing this over and over so I put it here. Returns : Three of a,t,g and c. Args : A base (atgc) Notes : $obj->_get_other_bases("a") returns "tgc" =cut sub _get_other_bases { my ($self,$this_base) = @_; $this_base = lc($this_base); my $all_bases = "atgc"; my $empty = ""; $all_bases =~ s/$this_base/$empty/e; return $all_bases; } =head2 accuracy_at($base,$position) Title : accuracy_at($base,$position) Usage : $accuracy = $trace_object->accuracy_at($base,$position); Function: Returns : Returns the accuracy of finding $base at $position. Args : 1. a base channel (atgc) 2. a value to _set_ the accuracy Notes : $obj->_get_other_bases("a") returns "tgc" =cut sub accuracy_at { my ($self,$base,$position,$value) = @_; $base = lc($base); if ($value) { if ($value eq "null") { $self->{accuracies}->{$base}->[$position-1] = "0"; } else { $self->{accuracies}->{$base}->[$position-1] = $value; } } return $self->{accuracies}->{$base}->[$position-1]; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/SeqWithQuality.pm�����������������������������������������������������������000444��000765��000024�� 73401�12254227323� 20217� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::QualI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla <bioinformatics@dieselwurks.com # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::SeqWithQuality - Bioperl object packaging a sequence with its quality. Deprecated class, use Bio::Seq::Quality instead! =head1 SYNOPSIS use Bio::PrimarySeq; use Bio::Seq::PrimaryQual; use Bio::Seq::SeqWithQuality; # make from memory my $qual = Bio::Seq::SeqWithQuality->new ( -qual => '10 20 30 40 50 50 20 10', -seq => 'ATCGATCG', -id => 'human_id', -accession_number => 'AL000012', ); # make from objects # first, make a PrimarySeq object my $seqobj = Bio::PrimarySeq->new ( -seq => 'atcgatcg', -id => 'GeneFragment-12', -accession_number => 'X78121', -alphabet => 'dna' ); # now make a PrimaryQual object my $qualobj = Bio::Seq::PrimaryQual->new ( -qual => '10 20 30 40 50 50 20 10', -id => 'GeneFragment-12', -accession_number => 'X78121', -alphabet => 'dna' ); # now make the SeqWithQuality object my $swqobj = Bio::Seq::SeqWithQuality->new ( -seq => $seqobj, -qual => $qualobj ); # done! $swqobj->id(); # the id of the SeqWithQuality object # may not match the the id of the sequence or # of the quality (check the pod, luke) $swqobj->seq(); # the sequence of the SeqWithQuality object $swqobj->qual(); # the quality of the SeqWithQuality object # to get out parts of the sequence. print "Sequence ", $seqobj->id(), " with accession ", $seqobj->accession, " and desc ", $seqobj->desc, "\n"; $string2 = $seqobj->subseq(1,40); =head1 DESCRIPTION This object stores base quality values together with the sequence string. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics@dieselwurks.com =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Seq::SeqWithQuality; use strict; use Bio::PrimarySeq; use Bio::Seq::PrimaryQual; use base qw(Bio::Root::Root Bio::PrimarySeqI Bio::Seq::QualI); =head2 new() Title : new() Usage : $qual = Bio::Seq::SeqWithQuality ->new ( -qual => '10 20 30 40 50 50 20 10', -seq => 'ATCGATCG', -id => 'human_id', -accession_number => 'AL000012', -trace_indices => '0 5 10 15 20 25 30 35' ); Function: Returns a new Bio::Seq::SeqWithQual object from basic constructors. Returns : a new Bio::Seq::PrimaryQual object Args : -qual can be a quality string (see Bio::Seq::PrimaryQual for more information on this) or a reference to a Bio::Seq::PrimaryQual object. -seq can be a sequence string (see Bio::PrimarySeq for more information on this) or a reference to a Bio::PrimaryQual object. -seq, -id, -accession_number, -primary_id, -desc, -id behave like this: 1. if they are provided on construction of the Bio::Seq::SeqWithQuality they will be set as the descriptors for the object unless changed by one of the following mechanisms: a) $obj->set_common_descriptors() is used and both the -seq and the -qual object have the same descriptors. These common descriptors will then become the descriptors for the Bio::Seq::SeqWithQual object. b) the descriptors are manually set using the seq(), id(), desc(), or accession_number(), primary_id(), 2. if no descriptors are provided, the new() constructor will see if the descriptor used in the PrimarySeq and in the PrimaryQual objects match. If they do, they will become the descriptors for the SeqWithQuality object. To eliminate ambiguity, I strongly suggest you set the descriptors manually on construction of the object. Really. -trace_indices : a space_delimited list of trace indices (where would the peaks be drawn if this list of qualities was to be plotted?) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); # default: turn OFF the warnings $self->{supress_warnings} = 1; my($qual,$seq,$id,$acc,$pid,$desc,$given_id,$alphabet,$trace_indices) = $self->_rearrange([qw( QUAL SEQ DISPLAY_ID ACCESSION_NUMBER PRIMARY_ID DESC ID ALPHABET TRACE_INDICES )], @args); # Deal with the ID if ( defined $id && defined $given_id ) { if( $id ne $given_id ) { $self->throw("Provided both id and display_id constructor functions. [$id] [$given_id]"); } } if( defined $given_id ) { $self->display_id($given_id); $id = $given_id; } # Import sequence first if (!$seq) { my $id; unless ($self->{supress_warnings} == 1) { $self->warn("You did not provide sequence information during the ". "construction of a Bio::Seq::SeqWithQuality object. Sequence ". "components for this object will be empty."); } if (!$alphabet) { $self->throw("If you want me to create a PrimarySeq object for your ". "empty sequence <boggle> you must specify a -alphabet to satisfy ". "the constructor requirements for a Bio::PrimarySeq object with no ". "sequence. Read the POD for it, luke."); } $self->{seq_ref} = Bio::PrimarySeq->new( -seq => "", -accession_number => $acc, -primary_id => $pid, -desc => $desc, -display_id => $id, -alphabet => $alphabet ); } elsif ($seq->isa('Bio::PrimarySeqI') || $seq->isa('Bio::SeqI')) { $self->{seq_ref} = $seq; } elsif (ref($seq)) { $self->throw("You passed a seq argument into a SeqWithQUality object and". " it was a reference ($seq) which did not inherit from Bio::SeqI or ". "Bio::PrimarySeqI. I don't know what to do with this!"); } else { my $seqobj = Bio::PrimarySeq->new( -seq => $seq, -accession_number => $acc, -primary_id => $pid, -desc => $desc, -display_id => $id ); $self->{seq_ref} = $seqobj; } # Then import the quality scores if (!defined($qual)) { $self->{qual_ref} = Bio::Seq::PrimaryQual->new( -qual => "", -accession_number => $acc, -primary_id => $pid, -desc => $desc, -display_id => $id, ); } elsif (ref($qual) eq "Bio::Seq::PrimaryQual") { $self->{qual_ref} = $qual; } else { my $qualobj = Bio::Seq::PrimaryQual->new( -qual => $qual, -accession_number => $acc, -primary_id => $pid, -desc => $desc, -display_id => $id, -trace_indices => $trace_indices ); $self->{qual_ref} = $qualobj; } # Now try to set the descriptors for this object $self->_set_descriptors($qual,$seq,$id,$acc,$pid,$desc,$given_id,$alphabet); $self->length(); $self->deprecated("deprecated class - use Bio::Seq::Quality instead"); return $self; } =head2 _common_id() Title : _common_id() Usage : $common_id = $self->_common_id(); Function: Compare the display_id of {qual_ref} and {seq_ref}. Returns : Nothing if they don't match. If they do return {seq_ref}->display_id() Args : None. =cut #' sub _common_id { my $self = shift; return if (!$self->{seq_ref} || !$self->{qual_ref}); my $sid = $self->{seq_ref}->display_id(); return if (!$sid); return if (!$self->{qual_ref}->display_id()); return $sid if ($sid eq $self->{qual_ref}->display_id()); # should this become a warning? # print("ids $sid and $self->{qual_ref}->display_id() do not match. Bummer.\n"); } =head2 _common_display_id() Title : _common_id() Usage : $common_id = $self->_common_display_id(); Function: Compare the display_id of {qual_ref} and {seq_ref}. Returns : Nothing if they don't match. If they do return {seq_ref}->display_id() Args : None. =cut #' sub _common_display_id { my $self = shift; $self->common_id(); } =head2 _common_accession_number() Title : _common_accession_number() Usage : $common_id = $self->_common_accession_number(); Function: Compare the accession_number() of {qual_ref} and {seq_ref}. Returns : Nothing if they don't match. If they do return {seq_ref}->accession_number() Args : None. =cut #' sub _common_accession_number { my $self = shift; return if ($self->{seq_ref} || $self->{qual_ref}); my $acc = $self->{seq_ref}->accession_number(); # if (!$acc) { print("the seqref has no acc.\n"); } return if (!$acc); # if ($acc eq $self->{qual_ref}->accession_number()) { print("$acc matches ".$self->{qual_ref}->accession_number()."\n"); } return $acc if ($acc eq $self->{qual_ref}->accession_number()); # should this become a warning? # print("accession numbers $acc and $self->{qual_ref}->accession_number() do not match. Bummer.\n"); } =head2 _common_primary_id() Title : _common_primary_id() Usage : $common_primard_id = $self->_common_primary_id(); Function: Compare the primary_id of {qual_ref} and {seq_ref}. Returns : Nothing if they don't match. If they do return {seq_ref}->primary_id() Args : None. =cut #' sub _common_primary_id { my $self = shift; return if ($self->{seq_ref} || $self->{qual_ref}); my $pid = $self->{seq_ref}->primary_id(); return if (!$pid); return $pid if ($pid eq $self->{qual_ref}->primary_id()); # should this become a warning? # print("primary_ids $pid and $self->{qual_ref}->primary_id() do not match. Bummer.\n"); } =head2 _common_desc() Title : _common_desc() Usage : $common_desc = $self->_common_desc(); Function: Compare the desc of {qual_ref} and {seq_ref}. Returns : Nothing if they don't match. If they do return {seq_ref}->desc() Args : None. =cut #' sub _common_desc { my $self = shift; return if ($self->{seq_ref} || $self->{qual_ref}); my $des = $self->{seq_ref}->desc(); return if (!$des); return $des if ($des eq $self->{qual_ref}->desc()); # should this become a warning? # print("descriptions $des and $self->{qual_ref}->desc() do not match. Bummer.\n"); } =head2 set_common_descriptors() Title : set_common_descriptors() Usage : $self->set_common_descriptors(); Function: Compare the descriptors (id,accession_number,display_id, primary_id, desc) for the PrimarySeq and PrimaryQual objects within the SeqWithQuality object. If they match, make that descriptor the descriptor for the SeqWithQuality object. Returns : Nothing. Args : None. =cut sub set_common_descriptors { my $self = shift; return if ($self->{seq_ref} || $self->{qual_ref}); &_common_id(); &_common_display_id(); &_common_accession_number(); &_common_primary_id(); &_common_desc(); } =head2 alphabet() Title : alphabet(); Usage : $molecule_type = $obj->alphabet(); Function: Get the molecule type from the PrimarySeq object. Returns : What what PrimarySeq says the type of the sequence is. Args : None. =cut sub alphabet { my $self = shift; return $self->{seq_ref}->alphabet(); } =head2 display_id() Title : display_id() Usage : $id_string = $obj->display_id(); Function: Returns the display id, aka the common name of the Quality object. The semantics of this is that it is the most likely string to be used as an identifier of the quality sequence, and likely to have "human" readability. The id is equivalent to the ID field of the GenBank/EMBL databanks and the id field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convience issues. This method sets the display_id for the SeqWithQuality object. Returns : A string Args : If a scalar is provided, it is set as the new display_id for the SeqWithQuality object. Status : Virtual =cut sub display_id { my ($obj,$value) = @_; if( defined $value) { $obj->{'display_id'} = $value; } return $obj->{'display_id'}; } =head2 accession_number() Title : accession_number() Usage : $unique_biological_key = $obj->accession_number(); Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". This method sets the accession_number for the SeqWithQuality object. Returns : A string (the value of accession_number) Args : If a scalar is provided, it is set as the new accession_number for the SeqWithQuality object. Status : Virtual =cut sub accession_number { my( $obj, $acc ) = @_; if (defined $acc) { $obj->{'accession_number'} = $acc; } else { $acc = $obj->{'accession_number'}; $acc = 'unknown' unless defined $acc; } return $acc; } =head2 primary_id() Title : primary_id() Usage : $unique_implementation_key = $obj->primary_id(); Function: Returns the unique id for this object in this implementation. This allows implementations to manage their own object ids in a way the implementaiton can control clients can expect one id to map to one object. For sequences with no accession number, this method should return a stringified memory location. This method sets the primary_id for the SeqWithQuality object. Returns : A string. (the value of primary_id) Args : If a scalar is provided, it is set as the new primary_id for the SeqWithQuality object. =cut sub primary_id { my ($obj,$value) = @_; if ($value) { $obj->{'primary_id'} = $value; } return $obj->{'primary_id'}; } =head2 desc() Title : desc() Usage : $qual->desc($newval); _or_ $description = $qual->desc(); Function: Get/set description text for this SeqWithQuality object. Returns : A string. (the value of desc) Args : If a scalar is provided, it is set as the new desc for the SeqWithQuality object. =cut sub desc { # a mechanism to set the disc for the SeqWithQuality object. # probably will be used most often by set_common_features() my ($obj,$value) = @_; if( defined $value) { $obj->{'desc'} = $value; } return $obj->{'desc'}; } =head2 id() Title : id() Usage : $id = $qual->id(); Function: Return the ID of the quality. This should normally be (and actually is in the implementation provided here) just a synonym for display_id(). Returns : A string. (the value of id) Args : If a scalar is provided, it is set as the new id for the SeqWithQuality object. =cut sub id { my ($self,$value) = @_; if (!$self) { $self->throw("no value for self in $value"); } if( defined $value ) { return $self->display_id($value); } return $self->display_id(); } =head2 seq Title : seq() Usage : $string = $obj->seq(); _or_ $obj->seq("atctatcatca"); Function: Returns the sequence that is contained in the imbedded in the PrimarySeq object within the SeqWithQuality object Returns : A scalar (the seq() value for the imbedded PrimarySeq object.) Args : If a scalar is provided, the SeqWithQuality object will attempt to set that as the sequence for the imbedded PrimarySeq object. Otherwise, the value of seq() for the PrimarySeq object is returned. Notes : This is probably not a good idea because you then should call length() to make sure that the sequence and quality are of the same length. Even then, how can you make sure that this sequence belongs with that quality? I provided this to give you rope to hang yourself with. Tie it to a strong device and use a good knot. =cut sub seq { my ($self,$value) = @_; if( defined $value) { $self->{seq_ref}->seq($value); $self->length(); } return $self->{seq_ref}->seq(); } =head2 qual() Title : qual() Usage : @quality_values = @{$obj->qual()}; _or_ $obj->qual("10 10 20 40 50"); Function: Returns the quality as imbedded in the PrimaryQual object within the SeqWithQuality object. Returns : A reference to an array containing the quality values in the PrimaryQual object. Args : If a scalar is provided, the SeqWithQuality object will attempt to set that as the quality for the imbedded PrimaryQual object. Otherwise, the value of qual() for the PrimaryQual object is returned. Notes : This is probably not a good idea because you then should call length() to make sure that the sequence and quality are of the same length. Even then, how can you make sure that this sequence belongs with that quality? I provided this to give you a strong board with which to flagellate yourself. =cut sub qual { my ($self,$value) = @_; if( defined $value) { $self->{qual_ref}->qual($value); # update the lengths $self->length(); } return $self->{qual_ref}->qual(); } =head2 trace_indices() Title : trace_indices() Usage : @trace_indice_values = @{$obj->trace_indices()}; _or_ $obj->trace_indices("10 10 20 40 50"); Function: Returns the trace_indices as imbedded in the Primaryqual object within the SeqWithQualiity object. Returns : A reference to an array containing the trace_indice values in the PrimaryQual object. Args : If a scalar is provided, the SeqWithuQuality object will attempt to set that as the trace_indices for the imbedded PrimaryQual object. Otherwise, the value of trace_indices() for the PrimaryQual object is returned. Notes : This is probably not a good idea because you then should call length() to make sure that the sequence and trace_indices are of the same length. Even then, how can you make sure that this sequence belongs with that trace_indicex? I provided this to give you a strong board with which to flagellate yourself. =cut sub trace_indices { my ($self,$value) = @_; if( defined $value) { $self->{qual_ref}->trace_indices($value); # update the lengths $self->length(); } return $self->{qual_ref}->trace_indices(); } =head2 length() Title : length() Usage : $length = $seqWqual->length(); Function: Get the length of the SeqWithQuality sequence/quality. Returns : Returns the length of the sequence and quality if they are both the same. Returns "DIFFERENT" if they differ. Args : None. =cut sub length { my $self = shift; if (!$self->{seq_ref}) { unless ($self->{supress_warnings} == 1) { $self->warn("Can't find {seq_ref} here in length()."); } return; } if (!$self->{qual_ref}) { unless ($self->{supress_warnings} == 1) { $self->warn("Can't find {qual_ref} here in length()."); } return; } my $seql = $self->{seq_ref}->length(); if ($seql != $self->{qual_ref}->length()) { unless ($self->{supress_warnings} == 1) { $self->warn("Sequence length (".$seql.") is different from quality ". "length (".$self->{qual_ref}->length().") in the SeqWithQuality ". "object. This can only lead to problems later."); } $self->{'length'} = "DIFFERENT"; } else { $self->{'length'} = $seql; } return $self->{'length'}; } =head2 qual_obj Title : qual_obj($different_obj) Usage : $qualobj = $seqWqual->qual_obj(); _or_ $qualobj = $seqWqual->qual_obj($ref_to_primaryqual_obj); Function: Get the PrimaryQual object that is imbedded in the SeqWithQuality object or if a reference to a PrimaryQual object is provided, set this as the PrimaryQual object imbedded in the SeqWithQuality object. Returns : A reference to a Bio::Seq::SeqWithQuality object. =cut sub qual_obj { my ($self,$value) = @_; if (defined($value)) { if (ref($value) eq "Bio::Seq::PrimaryQual") { $self->{qual_ref} = $value; $self->debug("You successfully changed the PrimaryQual object within ". "a SeqWithQuality object. ID's for the SeqWithQuality object may ". "now not be what you expect. Use something like ". "set_common_descriptors() to fix them if you care,"); } else { $self->debug("You tried to change the PrimaryQual object within a ". "SeqWithQuality object but you passed a reference to an object that". " was not a Bio::Seq::PrimaryQual object. Thus your change failed. ". "Sorry.\n"); } } return $self->{qual_ref}; } =head2 seq_obj Title : seq_obj() Usage : $seqobj = $seqWqual->qual_obj(); _or_ $seqobj = $seqWqual->seq_obj($ref_to_primary_seq_obj); Function: Get the PrimarySeq object that is imbedded in the SeqWithQuality object or if a reference to a PrimarySeq object is provided, set this as the PrimarySeq object imbedded in the SeqWithQuality object. Returns : A reference to a Bio::PrimarySeq object. =cut sub seq_obj { my ($self,$value) = @_; if( defined $value) { if (ref($value) eq "Bio::PrimarySeq") { $self->debug("You successfully changed the PrimarySeq object within a". " SeqWithQuality object. ID's for the SeqWithQuality object may now". " not be what you expect. Use something like ". "set_common_descriptors() to fix them if you care,"); } else { $self->debug("You tried to change the PrimarySeq object within a ". "SeqWithQuality object but you passed a reference to an object that". " was not a Bio::PrimarySeq object. Thus your change failed. Sorry.\n"); } } return $self->{seq_ref}; } =head2 _set_descriptors Title : _set_descriptors() Usage : $seqWqual->_qual_obj($qual,$seq,$id,$acc,$pid,$desc,$given_id, $alphabet); Function: Set the descriptors for the SeqWithQuality object. Try to match the descriptors in the PrimarySeq object and in the PrimaryQual object if descriptors were not provided with construction. Returns : Nothing. Args : $qual,$seq,$id,$acc,$pid,$desc,$given_id,$alphabet as found in the new() method. Notes : Really only intended to be called by the new() method. If you want to invoke a similar function try set_common_descriptors(). =cut sub _set_descriptors { my ($self,$qual,$seq,$id,$acc,$pid,$desc,$given_id,$alphabet) = @_; my ($c_id,$c_acc,$c_pid,$c_desc); if (!$self->display_id()) { if ($c_id = $self->_common_id() ) { $self->display_id($c_id); } else { if ($self->{seq_ref}) { # print("Using seq_ref to set id to ".$self->{seq_ref}->display_id()."\n"); # ::dumpValue($self->{seq_ref}); $self->display_id($self->{seq_ref}->id()); } elsif ($self->{qual_ref}) { $self->display_id($self->{qual_ref}->id()); } } } if ($acc) { $self->accession_number($acc); } elsif ($c_acc = $self->_common_accession_number() ) { $self->accession_number($c_acc); } if ($pid) { $self->primary_id($pid); } elsif ($c_pid = $self->_common_primary_id() ) { $self->primary_id($c_pid); } if ($desc) { $self->desc($desc); } elsif ($c_desc = $self->_common_desc() ) { $self->desc($c_desc); } } =head2 subseq($start,$end) Title : subseq($start,$end) Usage : $subsequence = $obj->subseq($start,$end); Function: Returns the subseq from start to end, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Returns : A string. Args : Two positions. =cut sub subseq { my ($self,@args) = @_; # does a single value work? return $self->{seq_ref}->subseq(@args); } =head2 baseat($position) Title : baseat($position) Usage : $base_at_position_6 = $obj->baseat("6"); Function: Returns a single base at the given position, where the first base is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Returns : A scalar. Args : A position. =cut sub baseat { my ($self,$val) = @_; return $self->{seq_ref}->subseq($val,$val); } =head2 subqual($start,$end) Title : subqual($start,$end) Usage : @qualities = @{$obj->subqual(10,20); Function: returns the quality values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A reference to an array. Args : a start position and an end position =cut sub subqual { my ($self,@args) = @_; return $self->{qual_ref}->subqual(@args); } =head2 qualat($position) Title : qualat($position) Usage : $quality = $obj->qualat(10); Function: Return the quality value at the given location, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A scalar. Args : A position. =cut sub qualat { my ($self,$val) = @_; return $self->{qual_ref}->qualat($val); } =head2 sub_trace_index($start,$end) Title : sub_trace_index($start,$end) Usage : @trace_indices = @{$obj->sub_trace_index(10,20); Function: returns the trace index values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be e_trace_index. Returns : A reference to an array. Args : a start position and an end position =cut sub sub_trace_index { my ($self,@args) = @_; return $self->{qual_ref}->sub_trace_index(@args); } =head2 trace_index_at($position) Title : trace_index_at($position) Usage : $trace_index = $obj->trace_index_at(10); Function: Return the trace_index value at the given location, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be etrace_index_. Returns : A scalar. Args : A position. =cut sub trace_index_at { my ($self,$val) = @_; return $self->{qual_ref}->trace_index_at($val); } =head2 to_string() Title : to_string() Usage : $quality = $obj->to_string(); Function: Return a textual representation of what the object contains. For this module, this function will return: qual seq display_id accession_number primary_id desc id length_sequence length_quality Returns : A scalar. Args : None. =cut sub to_string { my ($self,$out,$result) = shift; $out = "qual: ".join(',',@{$self->qual()})."\n"; foreach (qw(seq display_id accession_number primary_id desc id)) { $result = $self->$_(); if (!$result) { $result = "<unset>"; } $out .= "$_: $result\n"; } return $out; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/SimulatedRead.pm������������������������������������������������������������000444��000765��000024�� 54076�12254227330� 20012� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package Bio::Seq::SimulatedRead; =head1 NAME Bio::Seq::SimulatedRead - Read with sequencing errors taken from a reference sequence =head1 SYNOPSIS use Bio::Seq::SimulatedRead; use Bio::PrimarySeq; # Create a reference sequence my $genome = Bio::PrimarySeq->new( -id => 'human_chr2', -seq => 'TAAAAAAACCCCTG', -desc => 'The human genome' ); # A 10-bp error-free read taken from a genome my $read = Bio::Seq::SimulatedRead->new( -reference => $genome , # sequence to generate the read from -id => 'read001', # read ID -start => 3 , # start of the read on the genome forward strand -end => 12 , # end of the read on the genome forward strand -strand => 1 , # genome strand that the read is on ); # Display the sequence of the read print $read->seq."\n"; # Add a tag or MID to the beginning of the read $read->mid('ACGT'); # Add sequencing errors (error positions are 1-based and relative to the # error-free MID-containing read) my $errors = {}; $errors->{'8'}->{'+'} = 'AAA'; # insertion of AAA after residue 8 $errors->{'1'}->{'%'} = 'G'; # substitution of residue 1 by a G $errors->{'4'}->{'-'} = undef; # deletion of residue 4 $read->errors($errors); # Display the sequence of the read with errors print $read->seq."\n"; # String representation of where the read came from and its errors print $read->desc."\n"; =head1 DESCRIPTION This object is a simulated read with sequencing errors. The user can provide a reference sequence to take a read from, the position and orientation of the read on the reference sequence, and the sequencing errors to generate. The sequence of the read is automatically calculated based on this information. By default, the description of the reads contain tracking information and will look like this (Bioperl-style): reference=human_chr2 start=3 end=12 strand=-1 mid=ACGT errors=1%G,4-,8+AAA description="The human genome" or Genbank-style: reference=human_chr2 position=complement(3..12) mid=ACGT errors=1%G,4-,8+AAA description="The human genome" Creating a simulated read follows these steps: 1/ Define the read start(), end(), strand() and qual_levels() if you want quality scores to be generated. Do not change these values once set because the read will not be updated. 2/ Specify the reference sequence that the read should be taken from. Once this is done, you have a fully functional read. Do not use the reference() method again after you have gone to the next step. 3/ Use mid() to input a MID (or tag or barcode) to add to the beginning of the read. You can change the MID until you go to next step. 4/ Give sequencing error specifications using errors() as the last step. You can do that as many times as you like, and the read will be updated. =head1 AUTHOR Florent E Angly E<lt>florent . angly @ gmail-dot-comE<gt>. Copyright (c) 2011 Florent E Angly. This library is free software; you can redistribute it under the GNU General Public License version 3. =cut use strict; use warnings; use Bio::LocatableSeq; use base qw( Bio::Seq::Quality Bio::LocatableSeq ); =head2 new Title : new Function : Create a new simulated read object Usage : my $read = Bio::Seq::SimulatedRead->new( -id => 'read001', -reference => $seq_obj , -errors => $errors , -start => 10 , -end => 135 , -strand => 1 , ); Arguments: -reference => Bio::SeqI, Bio::PrimarySeqI object representing the reference sequence to take the read from. See reference(). -errors => Hashref representing the position of errors in the read See errors(). -mid => String of a MID to prepend to the read. See mid(). -track => Track where the read came from in the read description? See track(). -coord_style => Define what coordinate system to use. See coord_style(). All other methods from Bio::LocatableSeq are available. Returns : new Bio::Seq::SimulatedRead object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($qual_levels, $reference, $mid, $errors, $track, $coord_style) = $self->_rearrange([qw(QUAL_LEVELS REFERENCE MID ERRORS TRACK COORD_STYLE)], @args); $coord_style = defined $coord_style ? $coord_style : 'bioperl'; $self->coord_style($coord_style); $track = defined $track ? $track : 1; $self->track($track); $qual_levels = defined $qual_levels ? $qual_levels : []; $self->qual_levels($qual_levels) if defined $qual_levels; $self->reference($reference) if defined $reference; $self->mid($mid) if defined $mid; $self->{_mutated} = 0; $self->errors($errors) if defined $errors; return $self; } =head2 qual_levels Title : qual_levels Function : Get or set the quality scores to give to the read. By default, if your reference sequence does not have quality scores, no quality scores are generated for the simulated read. The generated quality scores are very basic. If a residue is error-free, it gets the quality score defined for good residues. If the residue has an error (is an addition or a mutation), the residue gets the quality score specified for bad residues. Call the qual_levels() method before using the reference() method. Usage : my $qual_levels = $read->qual_levels( ); Arguments: Array reference containing the quality scores to use for: 1/ good residues (e.g. 30) 2/ bad residues (e.g. 10) Returns : Array reference containing the quality scores to use. =cut sub qual_levels { my ($self, $qual_levels) = @_; if (defined $qual_levels) { if ( (scalar @$qual_levels != 0) && (scalar @$qual_levels != 2) ) { $self->throw("The quality score specification must define the score". " to use for good and for bad residues\n"); } $self->{qual_levels} = $qual_levels; } return $self->{qual_levels}; } =head2 reference Title : reference Function : Get or set the reference sequence that the read comes from. Once the reference has been set, you have a functional simulated read which supports all the Bio::LocatableSeq methods. This method must be called after qual_levels() but before mid() or errors(). Usage : my $seq_obj = $read->reference(); Arguments: Bio::SeqI or Bio::PrimarySeqI object Returns : Bio::SeqI or Bio::PrimarySeqI object =cut sub reference { my ($self, $reference) = @_; if (defined $reference) { # Sanity check 1 if ( (not $reference->isa('Bio::SeqI')) && (not $reference->isa('Bio::PrimarySeqI')) ) { $self->throw("Expected a Bio::SeqI object as reference, but got: $reference\n"); } # Sanity check 2 if ($self->{mid} || $self->{errors}) { $self->throw("Cannot change the reference sequence after an MID or ". "sequencing errors have been added to the read\n"); } # Use beginning of reference sequence as start default if (not defined $self->start) { $self->start(1); } # Use end of reference sequence as end default if (not defined $self->end) { $self->end($reference->length); } # Use strand 1 as strand default if (not defined $self->strand) { $self->strand(1); } # Set the reference sequence object $self->{reference} = $reference; # Create a sequence, quality scores and description from the reference $self->_create_seq; $self->_create_qual if scalar @{$self->qual_levels}; $self->_create_desc if $self->track; } return $self->{reference}; } sub _create_seq { my $self = shift; # Get a truncation of the reference sequence my $reference = $self->reference; my $read_obj = $reference->trunc( $self->start, $self->end ); # Reverse complement the read if needed if ($self->strand == -1) { $read_obj = $read_obj->revcom(); } $self->seq($read_obj->seq); return 1; } sub _create_qual { my $self = shift; $self->qual([ ($self->qual_levels->[0]) x ($self->end - $self->start + 1) ]); return 1; } sub _create_desc { # Create the read description of the error-free read my $self = shift; # Reference sequence ID my $desc_str = ''; my $ref_id = $self->reference->id; if (defined $ref_id) { $desc_str .= 'reference='.$ref_id.' '; } # Position of read on reference sequence: start, end and strand my $strand = $self->strand; if ($self->coord_style eq 'bioperl') { $desc_str .= 'start='.$self->start.' end='.$self->end.' '; if (defined $strand) { # Strand of the reference sequence that the read is on $strand = '+1' if $strand == 1; $desc_str .= 'strand='.$strand.' '; } } else { if ( (defined $strand) && ($strand == -1) ) { # Reverse complemented $desc_str .= 'position=complement('.$self->start.'..'.$self->end.') '; } else { # Regular (forward) orientation $desc_str .= 'position='.$self->start.'..'.$self->end.' '; } } # Description of the original sequence my $ref_desc = $self->reference->desc; if ( (defined $self->reference->desc) && ($self->reference->desc !~ m/^\s*$/) ) { $ref_desc =~ s/"/\\"/g; # escape double-quotes to \" $desc_str .= 'description="'.$ref_desc.'" '; } $desc_str =~ s/\s$//g; # Record new description $self->desc($desc_str); return 1; } =head2 mid Title : mid Function : Get or set a multiplex identifier (or MID, or tag, or barcode) to add to the read. By default, no MID is used. This method must be called after reference() but before errors(). Usage : my $mid = read->mid(); Arguments: MID sequence string (e.g. 'ACGT') Returns : MID sequence string =cut sub mid { my ($self, $mid) = @_; if (defined $mid) { # Sanity check 1 if (not defined $self->reference) { $self->throw("Cannot add MID because the reference sequence was not ". "set\n"); } # Sanity check 2 if ($self->{errors}) { $self->throw("Cannot add an MID after sequencing errors have been ". "introduced in the read\n"); } # Sanity check 3 if (not $self->validate_seq($mid)) { $self->throw("MID is not a valid DNA sequence\n"); } # Update sequence, quality scores and description with the MID $self->_update_seq_mid($mid); $self->_update_qual_mid($mid) if scalar @{$self->qual_levels}; $self->_update_desc_mid($mid) if $self->track; # Set the MID value $self->{mid} = $mid; } return $self->{mid} } sub _update_seq_mid { # Update the MID of a sequence my ($self, $mid) = @_; # Remove old MID my $seq = $self->seq; my $old_mid = $self->{mid}; if (defined $old_mid) { $seq =~ s/^$old_mid//; } # Add new MID $seq = $mid . $seq; $self->seq( $seq ); return 1; } sub _update_qual_mid { # Update the MID of a quality scores my ($self, $mid) = @_; # Remove old MID my $qual = $self->qual; my $old_mid = $self->{mid}; if (defined $old_mid) { splice @$qual, 0, length($old_mid); } $qual = [($self->qual_levels->[0]) x length($mid), @$qual]; $self->qual( $qual ); return 1; } sub _update_desc_mid { # Update MID specifications in the read description my ($self, $mid) = @_; if ($mid) { # Sequencing errors introduced in the read my $mid_str = "mid=".$mid; my $desc_str = $self->desc; $desc_str =~ s/((position|strand)=\S+)( mid=\S+)?/$1 $mid_str/g; $self->desc( $desc_str ); } return 1; } =head2 errors Title : errors Function : Get or set the sequencing errors and update the read. By default, no errors are made. This method must be called after the mid() method. Usage : my $errors = $read->errors(); Arguments: Reference to a hash of the position and nature of sequencing errors. The positions are 1-based relative to the error-free MID-containing read (not relative to the reference sequence). For example: $errors->{34}->{'%'} = 'T' ; # substitution of residue 34 by a T $errors->{23}->{'+'} = 'GG' ; # insertion of GG after residue 23 $errors->{45}->{'-'} = undef; # deletion of residue 45 Substitutions and deletions are for a single residue, but additions can be additions of several residues. An alternative way to specify errors is by using array references instead of scalar for the hash values. This allows to specify redundant mutations. For example, the case presented above would result in the same read sequence as the example below: $errors->{34}->{'%'} = ['C', 'T'] ; # substitution by a C and then a T $errors->{23}->{'+'} = ['G', 'G'] ; # insertion of G and then a G $errors->{45}->{'-'} = [undef, undef]; # deletion of residue, and again Returns : Reference to a hash of the position and nature of sequencing errors. =cut sub errors { my ($self, $errors) = @_; if (defined $errors) { # Verify that we have a hashref if ( (not defined ref $errors) || (not ref $errors eq 'HASH') ) { $self->throw("Error specification has to be a hashref. Got: $errors\n"); } # Verify that we have a reference sequence if (not defined $self->reference) { $self->throw("Cannot add errors because the reference sequence was not set\n"); } # Convert scalar error specs to arrayref specs $errors = $self->_scalar_to_arrayref($errors); # Check validity of error specifications $errors = $self->_validate_error_specs($errors); # Set the error specifications $self->{errors} = $errors; # Need to recalculate the read from the reference if previously mutated if ($self->{_mutated}) { $self->_create_seq; $self->_create_qual if scalar @{$self->qual_levels}; $self->_create_desc if $self->track; } # Now mutate the read, quality score and description $self->_update_seq_errors; $self->_update_qual_errors if scalar @{$self->qual_levels}; $self->_update_desc_errors if $self->track; } return $self->{errors}; } sub _scalar_to_arrayref { # Replace the scalar values in the error specs by more versatile arrayrefs my ($self, $errors) = @_; while ( my ($pos, $ops) = each %$errors ) { while ( my ($op, $res) = each %$ops ) { if (ref $res eq '') { my $arr = [ split //, ($res || '') ]; $arr = [undef] if scalar @$arr == 0; $$errors{$pos}{$op} = $arr; } } } return $errors; } sub _validate_error_specs { # Clean error specifications and warn of any issues encountered my ($self, $errors) = @_; my %valid_ops = ('%' => undef, '-' => undef, '+' => undef); # valid operations # Calculate read length my $read_length = $self->length; while ( my ($pos, $ops) = each %$errors ) { # Position cannot be no longer than the read length if ( (defined $read_length) && ($pos > $read_length) ) { $self->warn("Position $pos is beyond end of read ($read_length ". "residues). Skipping errors specified at this position.\n"); delete $errors->{$pos}; } # Position has to be 0+ for addition, 1+ for substitution and deletion if ( $pos < 1 && (exists $ops->{'%'} || exists $ops->{'-'}) ) { $self->warn("Positions of substitutions and deletions have to be ". "strictly positive but got $pos. Skipping substitution or deletion". " at this position\n"); delete $ops->{'%'}; delete $ops->{'-'}; } if ( $pos < 0 && exists $ops->{'+'}) { $self->warn("Positions of additions have to be zero or more. ". "Skipping addition at position $pos.\n"); delete $ops->{'+'}; } # Valid operations are '%', '+' and '-' while ( my ($op, $res) = each %$ops ) { if (not exists $valid_ops{$op}) { $self->warn("Skipping unknown error operation '$op' at position". " $pos\n"); delete $ops->{$op}; } else { # Substitutions: have to have at least one residue to substitute if ( ($op eq '%') && (scalar @$res < 1) ) { $self->warn("At least one residue must be provided for substitutions,". "but got ".scalar(@$res)." at position $pos.\n"); } # Additions: have to have at least one residue to add if ( ($op eq '+') && (scalar @$res < 1) ) { $self->warn("At least one residue must be provided for additions,". "but got ".scalar(@$res)." at position $pos.\n"); } # Deletions if ( ($op eq '-') && (scalar @$res < 1) ) { $self->warn("At least one 'undef' must be provided for deletions,". "but got ".scalar(@$res)." at position $pos.\n"); } } } delete $errors->{$pos} unless scalar keys %$ops; } return $errors; } sub _update_seq_errors { my $self = shift; my $seq_str = $self->seq; my $errors = $self->errors; if (scalar keys %$errors > 0) { my $off = 0; for my $pos ( sort {$a <=> $b} (keys %$errors) ) { # Process sequencing errors at that position for my $type ( '%', '-', '+' ) { next if not exists $$errors{$pos}{$type}; my $arr = $$errors{$pos}{$type}; if ($type eq '%') { # Substitution at residue position. If there are multiple # substitutions to do, directly skip to the last one. substr $seq_str, $pos - 1 + $off, 1, $$arr[-1]; } elsif ($type eq '-') { # Deletion at residue position substr $seq_str, $pos - 1 + $off, 1, ''; $off--; } elsif ($type eq '+') { # Insertion after residue position substr $seq_str, $pos + $off, 0, join('', @$arr); $off += scalar @$arr; } } } $self->{_mutated} = 1; } else { $self->{_mutated} = 0; } $self->seq($seq_str); return 1; } sub _update_qual_errors { my $self = shift; my $qual = $self->qual; my $errors = $self->errors; my $bad_qual = $self->qual_levels->[1]; if (scalar keys %$errors > 0) { my $off = 0; for my $pos ( sort {$a <=> $b} (keys %$errors) ) { # Process sequencing errors at that position for my $type ( '%', '-', '+' ) { next if not exists $$errors{$pos}{$type}; my $arr = $$errors{$pos}{$type}; if ($type eq '%') { # Substitution at residue position splice @$qual, $pos - 1 + $off, 1, $bad_qual; } elsif ($type eq '-') { # Deletion at residue position splice @$qual, $pos - 1 + $off, 1; $off--; } elsif ($type eq '+') { # Insertion after residue position splice @$qual, $pos + $off, 0, ($bad_qual) x scalar(@$arr); $off += scalar @$arr; } } } } $self->qual($qual); return 1; } sub _update_desc_errors { # Add or update error specifications in the read description my $self = shift; my $errors = $self->errors; if (defined $errors and scalar keys %$errors > 0) { # Sequencing errors introduced in the read my $err_str = 'errors='; for my $pos ( sort {$a <=> $b} (keys %$errors) ) { # Process sequencing errors at that position for my $type ( '%', '-', '+' ) { next if not exists $$errors{$pos}{$type}; for my $val ( @{$$errors{$pos}{$type}} ) { $val = '' if not defined $val; $err_str .= $pos . $type . $val . ','; } } } $err_str =~ s/,$//; my $desc_str = $self->desc; $desc_str =~ s/((position|strand)=\S+( mid=\S+)?)( errors=\S+)?/$1 $err_str/g; $self->desc( $desc_str ); } return 1; } =head2 track Title : track Function : Get or set the tracking status in the read description. By default, tracking is on. This method can be called at any time. Usage : my $track = $read->track(); Arguments: 1 for tracking, 0 otherwise Returns : 1 for tracking, 0 otherwise =cut sub track { my ($self, $track) = @_; if (defined $track) { if (defined $self->reference) { if ($track == 1) { $self->_create_desc; $self->_update_desc_mid($self->mid); $self->_update_desc_errors; } else { $self->desc(undef); } } $self->{track} = $track; } return $self->{track}; } =head2 coord_style Title : coord_style Function : When tracking is on, define which 1-based coordinate system to use in the read description: * 'bioperl' uses the start, end and strand keywords (default), similarly to the GFF3 format. Example: start=1 end=10 strand=+1 start=1 end=10 strand=-1 * 'genbank' does only provide the position keyword. Example: position=1..10 position=complement(1..10) Usage : my $coord_style = $read->track(); Arguments: 'bioperl' or 'genbank' Returns : 'bioperl' or 'genbank' =cut sub coord_style { my ($self, $coord_style) = @_; my %styles = ( 'bioperl' => undef, 'genbank' => undef ); if (defined $coord_style) { if (not exists $styles{$coord_style}) { die "Error: Invalid coordinate style '$coord_style'\n"; } $self->{coord_style} = $coord_style; } return $self->{coord_style}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/TraceI.pm�������������������������������������������������������������������000555��000765��000024�� 16310�12254227333� 16431� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Seq::TraceI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla <bioinformatics@dieselwurks.com # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::TraceI - Interface definition for a Bio::Seq::Trace =head1 SYNOPSIS # get a Bio::Seq::Qual compliant object somehow $st = &get_object_somehow(); # to test this is a seq object $st->isa("Bio::Seq::TraceI") || $obj->throw("$obj does not implement the Bio::Seq::TraceI interface"); # set the trace for T to be @trace_points my $arrayref = $st->trace("T",\@trace_points); # get the trace points for "C" my $arrayref = $st->trace("C"); # get a subtrace for "G" from 10 to 100 $arrayref = $st->subtrace("G",10,100); # what is the trace value for "A" at position 355? my $trace_calue = $st->traceat("A",355); # create a false trace for "A" with $accuracy $arrayref = $st->false_trace("A",Bio::Seq::Quality, $accuracy); # does this trace have entries for each base? $bool = $st->is_complete(); # how many entries are there in this trace? $length = $st->length(); =head1 DESCRIPTION This object defines an abstract interface to basic trace information. This information may have come from an ABI- or scf- formatted file or may have been made up. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics@dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::TraceI; use strict; use Carp; use Dumpvalue; use Bio::Root::RootI; =head1 Implementation Specific Functions These functions are the ones that a specific implementation must define. =head2 trace($base,\@new_values) Title : trace($base,\@new_values) Usage : @trace_Values = @{$obj->trace($base,\@new_values)}; Function: Returns the trace values as a reference to an array containing the trace values. The individual elements of the trace array are not validated and can be any numeric value. Returns : A reference to an array. Status : Arguments: $base : which color channel would you like the trace values for? - $base must be one of "A","T","G","C" \@new_values : a reference to an array of values containing trace data for this base =cut sub trace { my ($self) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::TraceI definition of trace - implementing class did not provide this method"); } else { confess("Bio::Seq::TraceI definition of trace - implementing class did not provide this method"); } } =head2 subtrace($base,$start,$end) Title : subtrace($base,$start,$end) Usage : @subset_of_traces = @{$obj->subtrace("A",10,40)}; Function: returns the trace values from $start to $end, where the first value is 1 and the number is inclusive, ie 1-2 are the first two trace values of this base. Start cannot be larger than end but can be equal. Returns : A reference to an array. Args : $base: "A","T","G" or "C" $start: a start position $end : an end position =cut sub subtrace { my ($self) = @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::TraceI definition of subtrace - implementing class did not provide this method"); } else { confess("Bio::Seq::TraceI definition of subtrace - implementing class did not provide this method"); } } =head2 can_call_new() Title : can_call_new() Usage : if( $obj->can_call_new ) { $newobj = $obj->new( %param ); } Function: can_call_new returns 1 or 0 depending on whether an implementation allows new constructor to be called. If a new constructor is allowed, then it should take the followed hashed constructor list. $myobject->new( -qual => $quality_as_string, -display_id => $id, -accession_number => $accession, ); Example : Returns : 1 or 0 Args : =cut sub can_call_new{ my ($self,@args) = @_; # we default to 0 here return 0; } =head2 traceat($channel,$position) Title : qualat($channel,$position) Usage : $trace = $obj->traceat(500); Function: Return the trace value at the given location, where the first value is 1 and the number is inclusive, ie 1-2 are the first two bases of the sequence. Start cannot be larger than end but can be equal. Returns : A scalar. Args : A base and a position. =cut sub traceat { my ($self,$value) = @_; if( $self->can('warn') ) { $self->warn("Bio::Seq::TraceI definition of traceat - implementing class did not provide this method"); } else { warn("Bio::Seq::TraceI definition of traceat - implementing class did not provide this method"); } return ''; } =head2 length() Title : length() Usage : $length = $obj->length("A"); Function: Return the length of the array holding the trace values for the "A" channel. A check should be done to make sure that this Trace object is_complete() before doing this to prevent hazardous results. Returns : A scalar (the number of elements in the quality array). Args : If used, get the traces from that channel. Default to "A" =cut sub length { my ($self)= @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::TraceI definition of length - implementing class did not provide this method"); } else { confess("Bio::Seq::TraceI definition of length - implementing class did not provide this method"); } } =head2 trace_indices($new_indices) Title : trace_indices($new_indices) Usage : $indices = $obj->trace_indices($new_indices); Function: Return the trace iindex points for this object. Returns : A scalar Args : If used, the trace indices will be set to the provided value. =cut sub trace_indices { my ($self)= @_; if( $self->can('throw') ) { $self->throw("Bio::Seq::TraceI definition of trace_indices - implementing class did not provide this method"); } else { confess("Bio::Seq::TraceI definition of trace_indices - implementing class did not provide this method"); } } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/Meta������������������������������������������������������������������������000755��000765��000024�� 0�12254227334� 15432� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Seq/Meta/Array.pm���������������������������������������������������������������000444��000765��000024�� 45553�12254227334� 17237� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Seq::Meta::Array # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Seq::Meta::Array - array-based generic implementation of a sequence class with residue-based meta information =head1 SYNOPSIS use Bio::LocatableSeq; use Bio::Seq::Meta::Array; my $seq = Bio::Seq::Meta::Array->new(-id=>'test', -seq=>'ACTGCTAGCT', -start=>2434, -start=>2443, -strand=>1, -verbose=>1, # to see warnings ); # to test this is a meta seq object $seq->isa("Bio::Seq::Meta::Array") || $seq->throw("$seq is not a Bio::Seq::Meta::Array"); $seq->meta('1 2 3 4 5 6 7 8 9 10'); # or you could create the Meta object directly $seq = Bio::Seq::Meta::Array->new(-id=>'test', -seq=>'ACTGCTAGCT', -start=>2434, -start=>2443, -strand=>1, -meta=>'1 2 3 4 5 6 7 8 9 10', -verbose=>1, # to see warnings ); # accessors $arrayref = $seq->meta(); $string = $seq->meta_text(); $substring = $seq->submeta_text(2,5); $unique_key = $seq->accession_number(); =head1 DESCRIPTION This class implements generic methods for sequences with residue-based meta information. Meta sequences with meta data are Bio::LocatableSeq objects with additional methods to store that meta information. See L<Bio::LocatableSeq> and L<Bio::Seq::MetaI>. The meta information in this class can be a string of variable length and can be a complex structure. Blank values are undef or zero. Application specific implementations should inherit from this class to override and add to these methods. This class can be used for storing sequence quality values but Bio::Seq::Quality has named methods that make it easier. =head1 SEE ALSO L<Bio::LocatableSeq>, L<Bio::Seq::MetaI>, L<Bio::Seq::Meta>, L<Bio::Seq::Quality> =head1 NOTE This Bio::Seq::MetaI implementation inherits from Bio::LocatableSeq, which itself inherits from Bio::PrimarySeq. It is not a Bio::SeqI, so bless-ing objects of this class into a Bio::SeqI or vice versa and will not work as expected (see bug 2262). This may be addressed in a future refactor of Bio::LocatableSeq. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Chad Matsalla, bioinformatics@dieselwurks.com Aaron Mackey, amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Seq::Meta::Array; use strict; use base qw(Bio::LocatableSeq Bio::Seq Bio::Seq::MetaI); our $DEFAULT_NAME = 'DEFAULT'; our $GAP = '-'; our $META_GAP = 0; =head2 new Title : new Usage : $metaseq = Bio::Seq::Meta::Array->new ( -meta => 'aaaaaaaabbbbbbbb', -seq => 'TKLMILVSHIVILSRM' -id => 'human_id', -accession_number => 'S000012', ); Function: Constructor for Bio::Seq::Meta::Array class, meta data being in a string. Note that you can provide an empty quality string. Returns : a new Bio::Seq::Meta::Array object =cut sub new { my ($class, %args) = @_; # run-time modification of @ISA is extremely evil (you should't pick your # interface on the fly); this has no obvious effect on any tests so # commenting out - cjfields 2011-4-6 #defined inheritance according to stated baseclass, #if undefined then will be PrimarySeq #if (defined($args{'-baseclass'})) { # @ISA = ($args{'-baseclass'},"Bio::Seq::MetaI"); # } #else { # @ISA = qw( Bio::LocatableSeq Bio::Seq Bio::Seq::MetaI ); # } my $self = $class->SUPER::new(%args); my($meta, $forceflush) = $self->_rearrange([qw(META FORCE_FLUSH )], %args); $self->{'_meta'}->{$DEFAULT_NAME} = []; $meta && $self->meta($meta); $forceflush && $self->force_flush($forceflush); return $self; } =head2 meta Title : meta Usage : $meta_values = $obj->meta($values_string); Function: Get and set method for the meta data starting from residue position one. Since it is dependent on the length of the sequence, it needs to be manipulated after the sequence. The length of the returned value always matches the length of the sequence. Returns : reference to an array of meta data Args : new value, string or array ref, optional =cut sub meta { shift->named_meta($DEFAULT_NAME, shift); } =head2 meta_text Title : meta_text Usage : $meta_values = $obj->meta_text($values_arrayref); Function: Variant of meta() guarantied to return a string representation of meta data. For details, see L<meta>. Returns : a string Args : new value, string or array ref, optional =cut sub meta_text { return join ' ', map {0 unless $_} @{shift->meta(shift)}; } =head2 named_meta Title : named_meta() Usage : $meta_values = $obj->named_meta($name, $values_arrayref); Function: A more general version of meta(). Each meta data set needs to be named. See also L<meta_names>. Returns : reference to an array of meta data Args : scalar, name of the meta data set new value, string or array ref, optional =cut sub named_meta { my ($self, $name, $value) = @_; $name ||= $DEFAULT_NAME; if (defined $value) { my ($arrayref); if (ref $value eq 'ARRAY' ) { # array ref $arrayref = $value; } elsif (not ref($value)) { # scalar $arrayref = [split /\s+/, $value]; } else { $self->throw("I need a scalar or array ref, not [". ref($value). "]"); } # test for length my $diff = $self->length - @{$arrayref}; if ($diff > 0) { foreach (1..$diff) { push @{$arrayref}, 0;} } $self->{'_meta'}->{$name} = $arrayref; #$self->_test_gap_positions($name) if $self->verbose > 0; } $self->_do_flush if $self->force_flush; return $self->{'_meta'}->{$name} || (" " x $self->length); } =head2 _test_gap_positions Title : _test_gap_positions Usage : $meta_values = $obj->_test_gap_positions($name); Function: Internal test for correct position of gap characters. Gap being only '-' this time. This method is called from named_meta() when setting meta data but only if verbose is positive as this can be an expensive process on very long sequences. Set verbose(1) to see warnings when gaps do not align in sequence and meta data and turn them into errors by setting verbose(2). Returns : true on success, prints warnings Args : none =cut sub _test_gap_positions { my $self = shift; my $name = shift; my $success = 1; $self->seq || return $success; my $len = CORE::length($self->seq); for (my $i=0; $i < $len; $i++) { my $s = substr $self->{seq}, $i, 1; my $m = substr $self->{_meta}->{$name}, $i, 1; $self->warn("Gap mismatch in column [". ($i+1). "] of [$name] meta data in seq [". $self->id. "]") and $success = 0 if ($m eq '-') && $s ne $m; } return $success; } =head2 named_meta_text Title : named_meta_text() Usage : $meta_values = $obj->named_meta_text($name, $values_arrayref); Function: Variant of named_meta() guarantied to return a textual representation of the named meta data. For details, see L<meta>. Returns : a string Args : scalar, name of the meta data set new value, string or array ref, optional =cut sub named_meta_text { return join ' ', @{shift->named_meta(@_)}; } =head2 submeta Title : submeta Usage : $subset_of_meta_values = $obj->submeta(10, 20, $value_string); $subset_of_meta_values = $obj->submeta(10, undef, $value_string); Function: Get and set method for meta data for subsequences. Numbering starts from 1 and the number is inclusive, ie 1-2 are the first two residue of the sequence. Start cannot be larger than end but can be equal. If the second argument is missing the returned values should extend to the end of the sequence. The return value may be a string or an array reference, depending on the implentation. If in doubt, use submeta_text() which is a variant guarantied to return a string. See L<submeta_text>. Returns : A reference to an array or a string Args : integer, start position integer, end position, optional when a third argument present new value, string or array ref, optional =cut sub submeta { shift->named_submeta($DEFAULT_NAME, @_); } =head2 submeta_text Title : submeta_text Usage : $meta_values = $obj->submeta_text(20, $value_string); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : new value, string or array ref, optional =cut sub submeta_text { return join ' ', @{shift->named_submeta($DEFAULT_NAME, @_)}; } =head2 named_submeta Title : named_submeta Usage : $subset_of_meta_values = $obj->named_submeta($name, 10, 20, $value_string); $subset_of_meta_values = $obj->named_submeta($name, 10); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : A reference to an array or a string Args : scalar, name of the meta data set integer, start position integer, end position, optional when a third argument present (can be undef) new value, string or array ref, optional =cut sub named_submeta { my ($self, $name, $start, $end, $value) = @_; $name ||= $DEFAULT_NAME; $start ||=1; $start =~ /^[+]?\d+$/ and $start > 0 or $self->throw("Need at least a positive integer start value"); $start--; my $meta_len = scalar(@{$self->{_meta}->{$name}}); if (defined $value) { my $arrayref; if (ref $value eq 'ARRAY' ) { # array ref $arrayref = $value; } elsif (not ref($value)) { # scalar $arrayref = [split /\s+/, $value]; } else { $self->throw("I need a space separated scalar or array ref, not [". ref($value). "]"); } $self->warn("You are setting meta values beyond the length of the sequence\n". "[$start > ". length($self->seq)."] in sequence ". $self->id) if $start + scalar @{$arrayref} -1 > $self->length; $end or $end = @{$arrayref} + $start; $end--; # test for length; pad if needed my $diff = $end - $start - scalar @{$arrayref}; if ($diff > 0) { foreach (1..$diff) { push @{$arrayref}, $META_GAP} } @{$self->{_meta}->{$name}}[$start..$end] = @{$arrayref}; $self->_do_flush if $self->force_flush; return $arrayref; } else { # don't set by seq length; use meta array length instead; bug 2478 $end ||= $meta_len; if ($end > $meta_len) { $self->warn("End is longer than meta sequence $name length; resetting to $meta_len"); $end = $meta_len; } # warn but don't reset (push use of trunc() instead) $self->warn("End is longer than sequence length; use trunc() \n". "if you want a fully truncated object") if $end > $self->length; $end--; return [@{$self->{_meta}->{$name}}[$start..$end]]; } } =head2 named_submeta_text Title : named_submeta_text Usage : $meta_values = $obj->named_submeta_text($name, 20, $value_string); Function: Variant of submeta() guarantied to return a textual representation of meta data. For details, see L<meta>. Returns : a string Args : scalar, name of the meta data Args : integer, start position, optional integer, end position, optional new value, string or array ref, optional =cut sub named_submeta_text { return join ' ', @{shift->named_submeta(@_)}; } =head2 meta_names Title : meta_names Usage : @meta_names = $obj->meta_names() Function: Retrives an array of meta data set names. The default (unnamed) set name is guarantied to be the first name if it contains any data. Returns : an array of names Args : none =cut sub meta_names { my ($self) = @_; my @r; foreach ( sort keys %{$self->{'_meta'}} ) { push (@r, $_) unless $_ eq $DEFAULT_NAME; } unshift @r, $DEFAULT_NAME if $self->{'_meta'}->{$DEFAULT_NAME}; return @r; } =head2 meta_length Title : meta_length() Usage : $meta_len = $obj->meta_length(); Function: return the number of elements in the meta set Returns : integer Args : - =cut sub meta_length { my ($self) = @_; return $self->named_meta_length($DEFAULT_NAME); } =head2 named_meta_length Title : named_meta_length() Usage : $meeta_len = $obj->named_meta_length($name); Function: return the number of elements in the named meta set Returns : integer Args : - =cut sub named_meta_length { my ($self, $name) = @_; $name ||= $DEFAULT_NAME; return scalar @{$self->{'_meta'}->{$name}}; } =head2 force_flush Title : force_flush() Usage : $force_flush = $obj->force_flush(1); Function: Automatically pad with empty values or truncate meta values to sequence length. Not done by default. Returns : boolean 1 or 0 Args : optional boolean value Note that if you turn this forced padding off, the previously padded values are not changed. =cut sub force_flush { my ($self, $value) = @_; if (defined $value) { if ($value) { $self->{force_flush} = 1; $self->_do_flush; } else { $self->{force_flush} = 0; } } return $self->{force_flush}; } =head2 _do_flush Title : _do_flush Usage : Function: internal method to do the force that meta values are same length as sequence . Called from L<force_flush> Returns : Args : =cut sub _do_flush { my ($self) = @_; foreach my $name ($self->meta_names) { #print "seq: ", $self->length , " ", $name, ": ", $self->named_meta_length($name), "======\n"; # elongnation if ($self->length > $self->named_meta_length($name)) { my $diff = $self->length - $self->named_meta_length($name); foreach (1..$diff) { push @{$self->{'_meta'}->{$name}}, $META_GAP} } # truncation elsif ( $self->length < $self->named_meta_length($name) ) { $self->{_meta}->{$name} = [@{$self->{_meta}->{$name}}[0..($self->length-1)]] } } } =head2 is_flush Title : is_flush Usage : $is_flush = $obj->is_flush() or $is_flush = $obj->is_flush($my_meta_name) Function: Boolean to tell if all meta values are in flush with the sequence length. Returns true if force_flush() is set Set verbosity to a positive value to see failed meta sets Returns : boolean 1 or 0 Args : optional name of the meta set =cut sub is_flush { my ($self, $name) = shift; return 1 if $self->force_flush; my $sticky = ''; if ($name) { $sticky .= "$name " if $self->length != $self->named_meta_length($name); } else { foreach my $m ($self->meta_names) { $sticky .= "$m " if ($self->named_meta_length($m) > 0) && ($self->length != $self->named_meta_length($m)) ; } } if ($sticky) { print "These meta set are not flush: $sticky\n" if $self->verbose; return 0; } return 1; } =head1 Bio::PrimarySeqI methods =head2 revcom Title : revcom Usage : $newseq = $seq->revcom(); Function: Produces a new Bio::Seq::MetaI implementing object where the order of residues and their meta information is reversed. Returns : A new (fresh) Bio::Seq::Meta object Args : none Throws : if the object returns false on is_flush() Note: The method does nothing to meta values, it reorders them, only. =cut sub revcom { my $self = shift; $self->throw("Can not get a reverse complement. The object is not flush.") unless $self->is_flush; my $new = $self->SUPER::revcom; my $end = $self->length - 1; map { $new->{_meta}->{$_} = [ reverse @{$self->{_meta}->{$_}}[0..$end]] } keys %{$self->{_meta}}; return $new; } =head2 trunc Title : trunc Usage : $subseq = $seq->trunc(10,100); Function: Provides a truncation of a sequence together with meta data Returns : a fresh Bio::Seq::Meta implementing object Args : Two integers denoting first and last residue of the sub-sequence. =cut sub trunc { my ($self, $start, $end) = @_; # test arguments $start =~ /^[+]?\d+$/ and $start > 0 or $self->throw("Need at least a positive integer start value as start; got [$start]"); $end =~ /^[+]?\d+$/ and $end > 0 or $self->throw("Need at least a positive integer start value as end; got [$end]"); $end >= $start or $self->throw("End position has to be larger or equal to start; got [$start..$end]"); $end <= $self->length or $self->throw("End position can not be larger than sequence length; got [$end]"); my $new = $self->SUPER::trunc($start, $end); $start--; $end--; map { $new->{_meta}->{$_} = [@{$self->{_meta}->{$_}}[$start..$end]] } keys %{$self->{_meta}}; return $new; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqEvolution��������������������������������������������������������������������000755��000765��000024�� 0�12254227337� 16454� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqEvolution/DNAPoint.pm��������������������������������������������������������000444��000765��000024�� 24013�12254227313� 20575� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqEvolution::DNAPoint # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki at bioperl dot org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqEvolution::DNAPoint - evolve a sequence by point mutations =head1 SYNOPSIS # $seq is a Bio::PrimarySeqI to mutate $evolve = Bio::SeqEvolution::Factory->new (-rate => 5, -seq => $seq, -identity => 50 ); $newseq = $evolve->next_seq; =head1 DESCRIPTION Bio::SeqEvolution::DNAPoint implements the simplest evolution model: nucleotides change by point mutations, only. Transition/transversion rate of the change, rate(), can be set. The new sequences are named with the id of the reference sequence added with a running number. Placing a new sequence into a factory to be evolved resets that counter. It can also be called directly with L<reset_sequence_counter>. The default sequence type returned is Bio::PrimarySeq. This can be changed to any Bio::PrimarySeqI compliant sequence class. Internally the probability of the change of one nucleotide is mapped to scale from 0 to 100. The probability of the transition occupies range from 0 to some value. The remaining range is divided equally among the two transversion nucleotides. A random number is then generated to pick up one change. Not that the default transition/transversion rate, 1:1, leads to observed transition/transversion ratio of 1:2 simply because there is only one transition nucleotide versus two transversion nucleotides. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho E<lt>heikki at bioperl dot orgE<gt> =head1 CONTRIBUTORS Additional contributor's names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqEvolution::DNAPoint; use strict; use Bio::Root::Root; use Bio::SeqEvolution::Factory; use Bio::Variation::DNAMutation; use Bio::Variation::Allele; use Bio::SimpleAlign; use base qw(Bio::SeqEvolution::Factory); sub _initialize { my($self, @args) = @_; $self->SUPER::_initialize(@args); my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys exists $param{'-rate'} && $self->rate($param{'-rate'}); $self->_init_mutation_engine; } sub _init_mutation_engine { my $self = shift; # arrays of possible changes have transitions as first items my %changes; $self->{'_changes'}->{'a'} = ['t', 'c', 'g']; $self->{'_changes'}->{'t'} = ['a', 'c', 'g']; $self->{'_changes'}->{'c'} = ['g', 'a', 't']; $self->{'_changes'}->{'g'} = ['c', 'a', 't']; # given the desired rate, find out where cut off points need to be # when random numbers are generated from 0 to 100 # we are ignoring identical mutations (e.g. A->A) to speed things up my $bin_size = 100/($self->rate + 2); $self->{'_transition'} = 100 - (2*$bin_size); $self->{'_first_transversion'} = $self->{'_transition'} + $bin_size; $self->_init_alignment; } sub _init_alignment { my $self = shift; # put the initial sequence into the alignment object $self->{'_align'} = Bio::SimpleAlign->new(-verbose => -1); return unless $self->seq; $self->{'_ori_locatableseq'} = Bio::LocatableSeq->new(-id => 'ori', -seq=> $self->seq->seq); $self->{'_mut_locatableseq'} = Bio::LocatableSeq->new(-id => 'mut', -seq=> $self->seq->seq); $self->{'_align'}->add_seq($self->{'_ori_locatableseq'}); $self->{'_align'}->add_seq($self->{'_mut_locatableseq'}); } =head2 seq Title : seq Usage : $obj->seq($newval) Function: Set the sequence object for the original sequence Returns : The sequence object Args : newvalue (optional) Setting this will reset mutation and generated mutation counters. =cut sub seq{ my $self = shift; if (@_) { my $seq = shift; $self->throw('Need a valid Bio::PrimarySeqI, not [', ref($seq), ']') unless $seq->isa('Bio::PrimarySeqI'); $self->throw('Only nucleotide sequences are supported') if $seq->alphabet eq 'protein'; $self->throw('No ambiquos nucleotides allowed in the input sequence') if $seq->seq =~ m/[^acgt]/; $self->{'_seq'} = $seq; # unify the look of sequence strings and cache the information $self->{'_ori_string'} = lc $seq->seq; # lower case $self->{'_ori_string'} =~ s/u/t/; # simplyfy our life; modules should deal with the change anyway $self->{'_seq_length'} = $seq->length; $self->reset_sequence_counter; } return $self->{'_seq'}; } =head2 set_mutated_seq Title : seq_mutated_seq Usage : $obj->set_mutated_seq($newval) Function: In case of mutating a sequence with multiple evolvers, this Returns : set_mutated_seq Args : newvalue (optional) =cut sub set_mutated_seq { my $self = shift; if (@_) { my $seq = shift; $self->throw('Need a valid Bio::PrimarySeqI, not [', ref($seq), ']') unless $seq->isa('Bio::PrimarySeqI'); $self->throw('Only nucleotide sequences are supported') if $seq->alphabet eq 'protein'; $self->throw('No ambiquos nucleotides allowed in the input sequence') if $seq->seq =~ m/[^acgt]/; $self->{'_seq_mutated'} = $seq; # unify the look of sequence strings and cache the information $self->{'_mut_string'} = lc $seq->seq; # lower case $self->{'_mut_string'} =~ s/u/t/; # simplyfy our life; modules should deal with the change anyway $self->reset_sequence_counter; } #set returned sequence to be the last mutated string $self->{'_seq'}->seq($self->{'_mut_string'}); return $self->{'_seq'}; } =head2 rate Title : rate Usage : $obj->rate($newval) Function: Set the transition/transversion rate. Returns : value of rate Args : newvalue (optional) Transition/transversion ratio is an observed attribute of an sequence comparison. We are dealing here with the transition/transversion rate that we set for our model of sequence evolution. Note that we are using standard nucleotide alphabet and that there can there is only one transition versus two possible transversions. Rate 2 is needed to have an observed transition/transversion ratio of 1. =cut sub rate{ my $self = shift; if (@_) { $self->{'_rate'} = shift @_; $self->_init_mutation_engine; } return $self->{'_rate'} || 1; } =head2 next_seq Title : next_seq Usage : $obj->next_seq Function: Evolve the reference sequence to desired level Returns : A new sequence object mutated from the reference sequence Args : - =cut sub next_seq { my $self = shift; $self->{'_mut_string'} = $self->{'_ori_string'}; $self->reset_mutation_counter; $self->{'_mutations'} = []; while (1) { # find the location in the string to change my $loc = int (rand length($self->{'_mut_string'})) + 1; $self->mutate($loc); # for modularity # stop evolving if any of the limit has been reached last if $self->identity && $self->get_alignment_identity <= $self->identity; last if $self->pam && 100*$self->get_mutation_counter/$self->{'_seq_length'} >= $self->pam; last if $self->mutation_count && $self->get_mutation_counter >= $self->mutation_count; } $self->_increase_sequence_counter; my $type = $self->seq_type; return $type->new(-id => $self->seq->id. "-". $self->get_sequence_counter, -description => $self->seq->description, -seq => $self->{'_mut_string'} ) } =head2 mutate Title : mutate Usage : $obj->mutate Function: mutate the sequence at the given location according to the model Returns : true Args : integer, start location of the mutation, required argument Called from next_seq(). =cut sub mutate { my $self = shift; my $loc = shift; $self->throw('the first argument is the location of the mutation') unless $loc; # nucleotide to change my $oldnuc = substr $self->{'_mut_string'}, $loc-1, 1; my $newnuc; # find the nucleotide it is changed to my $choose = rand(100); # scale is 0-100 if ($choose < $self->{'_transition'} ) { $newnuc = $self->{'_changes'}->{$oldnuc}[0]; } elsif ($choose < $self->{'_first_transversion'} ) { $newnuc = $self->{'_changes'}->{$oldnuc}[1]; } else { $newnuc = $self->{'_changes'}->{$oldnuc}[2]; } # do the change substr $self->{'_mut_string'}, $loc-1, 1 , $newnuc; $self->_increase_mutation_counter; $self->{'_mut_locatableseq'}->seq($self->{'_mut_string'}); print STDERR "$loc$oldnuc>$newnuc\n" if $self->verbose > 0; push @{$self->{'_mutations'}}, "$loc$oldnuc>$newnuc"; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqEvolution/EvolutionI.pm������������������������������������������������������000444��000765��000024�� 6370�12254227337� 21252� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqEvolution::EvolutionI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki at bioperl dot org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqEvolution::EvolutionI - the interface for evolving sequences =head1 SYNOPSIS # not an instantiable class =head1 DESCRIPTION This is the interface that all classes that mutate sequence objects in constant fashion must implement. A good example is Bio::SeqEvolution::DNAPoint. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho E<lt>heikki at bioperl dot orgE<gt> =head1 CONTRIBUTORS Additional contributor's names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqEvolution::EvolutionI; use strict; use base qw(Bio::Root::RootI); =head2 annotation Title : annotation Usage : $obj->annotation($newval) Function: Get the annotation collection for this annotatable object. Example : Returns : a Bio::AnnotationCollectionI implementing object, or undef Args : on set, new value (a Bio::AnnotationCollectionI implementing object, optional) (an implementation may not support changing the annotation collection) See L<Bio::AnnotationCollectionI> =cut =head2 seq Title : seq Usage : $obj->seq($newval) Function: Set the sequence object for the original sequence Returns : The sequence object Args : newvalue (optional) Setting this will reset mutation and generated mutation counters. =cut sub seq { shift->throw_not_implemented(); } =head2 next_seq Title : next_seq Usage : $obj->next_seq Function: Evolve the reference sequence to desired level Returns : A new sequence object mutated from the reference sequence Args : - =cut sub next_seq{ shift->throw_not_implemented(); } =head2 mutate Title : mutate Usage : $obj->mutate Function: mutate the sequence at the given location according to the model Returns : true Args : integer, start location of the mutation, required argument Called from next_seq(). =cut sub mutate { shift->throw_not_implemented(); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqEvolution/Factory.pm���������������������������������������������������������000444��000765��000024�� 25071�12254227326� 20601� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqEvolution::Factory # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki at bioperl dot org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqEvolution::Factory - Factory object to instantiate sequence evolving classes =head1 SYNOPSIS # not an instantiable class =head1 DESCRIPTION This is the factory class that can be used to call for a specific model to mutate a sequence. Bio::SeqEvolution::DNAPoint is the default for nucleotide sequences and the only implementation at this point. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Heikki Lehvaslaiho E<lt>heikki at bioperl dot orgE<gt> =head1 CONTRIBUTORS Additional contributor's names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqEvolution::Factory; use strict; use Bio::Root::Root; use Bio::SeqEvolution::EvolutionI; use base qw(Bio::Root::Root Bio::SeqEvolution::EvolutionI); =head2 new Title : new Usage : my $obj = Bio::SeqEvolution::Factory->new(); Function: Builds a new Bio:SeqEvolution::EvolutionI object Returns : Bio:SeqEvolution::EvolutionI object Args : -type => class name See L<Bio:SeqEvolution::EvolutionI> =cut sub new { my($caller,@args) = @_; my $class = ref($caller) || $caller; my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys if ( $class eq 'Bio::SeqEvolution::Factory') { #my %param = @args; #@param{ map { lc $_ } keys %param } = values %param; # lowercase keys if (exists $param{'-type'}) { # $self->type($param{'-type'}); } else { $param{'-type'} = 'Bio::SeqEvolution::DNAPoint'; #$self->type('Bio::SeqEvolution::DNAPoint'} unless $seq->alphabet == 'protein' } my $type = $param{'-type'}; return unless( $class->_load_format_module($param{'-type'}) ); return $type->new(%param); } else { my ($self) = $class->SUPER::new(%param); $self->_initialize(%param); return $self; } } sub _initialize { my($self, @args) = @_; $self->SUPER::_initialize(@args); my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys exists $param{'-seq'} && $self->seq($param{'-seq'}); exists $param{'-set_mutated_seq'} && $self->set_mutated_seq($param{'-set_mutated_seq'}); exists $param{'-identity'} && $self->identity($param{'-identity'}); exists $param{'-pam'} && $self->pam($param{'-pam'}); exists $param{'-mutation_count'} && $self->mutation_count($param{'-mutation_count'}); } =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL SeqIO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($self, $format) = @_; my $module = $format; my $ok; eval { $ok = $self->_load_module($module); }; if ( $@ ) { print STDERR <<END; $self: $format cannot be found Exception $@ END ; } return $ok; } =head2 type Title : type Usage : $obj->type($newval) Function: Set used evolution model. It is set by giving a valid Bio::SeqEvolution::* class name Returns : value of type Args : newvalue (optional) Defaults to Bio::SeqEvolution::DNAPoint. =cut sub type{ my $self = shift; if (@_) { $self->{'_type'} = shift @_; $self->_load_module($self->{'_type'}); } return $self->{'_type'} || 'Bio::SeqEvolution::DNAPoint'; } =head1 mutation counters The next three methods set a value to limit the number of mutations introduced the the input sequence. =cut =head2 identity Title : identity Usage : $obj->identity($newval) Function: Set the desired identity between original and mutated sequence Returns : value of identity Args : newvalue (optional) =cut sub identity{ my $self = shift; $self->{'_identity'} = shift @_ if @_; return $self->{'_identity'}; } =head2 pam Title : pam Usage : $obj->pam($newval) Function: Set the wanted Percentage of Accepted Mutations, PAM Returns : value of PAM Args : newvalue (optional) When you are measuring sequence divergence, PAM needs to be estimated. When you are generating sequences, PAM is simply the count of mutations introduced to the reference sequence normalised to the original sequence length. =cut sub pam{ my $self = shift; $self->{'_pam'} = shift @_ if @_; return $self->{'_pam'}; } =head2 mutation_count Title : mutation_count Usage : $obj->mutation_count($newval) Function: Set the number of wanted mutations to the sequence Returns : value of mutation_count Args : newvalue (optional) =cut sub mutation_count{ my $self = shift; $self->{'_mutation_count'} = shift @_ if @_; return $self->{'_mutation_count'}; } =head2 seq Title : seq Usage : $obj->seq($newval) Function: Set the sequence object for the original sequence Returns : The sequence object Args : newvalue (optional) Setting this will reset mutation and generated mutation counters. =cut sub seq { my $self = shift; if (@_) { $self->{'_seq'} = shift @_ ; return $self->{'_seq'}; $self->reset_mutation_counter; $self->reset_sequence_counter; } return $self->{'_seq'}; } =head2 seq_type Title : seq_type Usage : $obj->seq_type($newval) Function: Set the returned seq_type to one needed Returns : value of seq_type Args : newvalue (optional) Defaults to Bio::PrimarySeq. =cut sub seq_type{ my $self = shift; if (@_) { $self->{'_seq_type'} = shift @_; $self->_load_module($self->{'_seq_type'}); } return $self->{'_seq_type'} || 'Bio::PrimarySeq'; } =head2 get_mutation_counter Title : get_mutation_counter Usage : $obj->get_mutation_counter() Function: Get the count of sequences created Returns : value of counter Args : - =cut sub get_mutation_counter{ return shift->{'_mutation_counter'}; } =head2 reset_mutation_counter Title : reset_mutation_counter Usage : $obj->reset_mutation_counter() Function: Resert the counter of mutations Returns : value of counter Args : - =cut sub reset_mutation_counter{ shift->{'_mutation_counter'} = 0; return 1; } =head2 get_sequence_counter Title : get_sequence_counter Usage : $obj->get_sequence_counter() Function: Get the count of sequences created Returns : value of counter Args : - =cut sub get_sequence_counter{ return shift->{'_sequence_counter'}; } =head2 reset_sequence_counter Title : reset_sequence_counter Usage : $obj->reset_sequence_counter() Function: Resert the counter of sequences created Returns : value of counter Args : - This is called when ever mutated sequences are reassigned new values using methods seq() and mutated_seq(). As a side affect, this method also recreates the intermal alignment that is used to calculate the sequence identity. =cut sub reset_sequence_counter{ my $self = shift; $self->{'_sequence_counter'} = 0; $self->_init_alignment; return 1; } =head2 each_seq Title : each_seq Usage : $obj->each_seq($int) Function: Returns : an array of sequences mutated from the reference sequence according to evolutionary parameters given Args : - =cut sub each_seq{ my $self = shift; my $number = shift; $self->throw("[$number] ". ' should be a positive integer') unless $number =~ /^[+\d]+$/; my @array; for (my $count=1; $count<$number; $count++) { push @array, $self->next_seq(); } return @array; } =head2 each_mutation Title : each_mutation Usage : $obj->each_mutation Function: return the mutations leading to the last generated sequence in objects Returns : an array of Bio::Variation::DNAMutation objects Args : optional argument to return an array of stringified names =cut sub each_mutation { my $self = shift; my $string = shift; return @{$self->{'_mutations'}} if $string; return map { /(\d+)(\w*)>(\w*)/; # print; my $dnamut = Bio::Variation::DNAMutation->new ('-start' => $1, '-end' => $1, '-length' => 1, '-isMutation' => 1 ); $dnamut->allele_ori( Bio::Variation::Allele->new(-seq => $2, -alphabet => 'dna') ); $dnamut->add_Allele( Bio::Variation::Allele->new(-seq => $3, -alphabet => 'dna') ); $dnamut; } @{$self->{'_mutations'}} } sub get_alignment_identity { my $self = shift; return $self->{'_align'}->overall_percentage_identity; } sub get_alignmet { my $self = shift; return $self->{'_align'}->remove_gaps('-', 'all-gaps'); } =head1 Internal methods =cut =head2 _increase_mutation_counter Title : _increase_mutation_counter Usage : $obj->_increase_mutation_counter() Function: Internal method to increase the counter of mutations performed Returns : value of counter Args : - =cut sub _increase_mutation_counter{ return shift->{'_mutation_counter'}++; } =head2 _increase_sequence_counter Title : _increase_sequence_counter Usage : $obj->_increase_sequence_counter() Function: Internal method to increase the counter of sequences created Returns : value of counter Args : - =cut sub _increase_sequence_counter{ return shift->{'_sequence_counter'}++; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature����������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 16055� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Amplicon.pm����������������������������������������������������������000444��000765��000024�� 11453�12254227314� 20337� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Amplicon # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Copyright Florent Angly # # You may distribute this module under the same terms as perl itself =head1 NAME Bio::SeqFeature::Amplicon - Amplicon feature =head1 SYNOPSIS # Amplicon with explicit sequence use Bio::SeqFeature::Amplicon; my $amplicon = Bio::SeqFeature::Amplicon->new( -seq => $seq_object, -fwd_primer => $primer_object_1, -rev_primer => $primer_object_2, ); # Amplicon with implicit sequence use Bio::Seq; my $template = Bio::Seq->new( -seq => 'AAAAACCCCCGGGGGTTTTT' ); $amplicon = Bio::SeqFeature::Amplicon->new( -start => 6, -end => 15, ); $template->add_SeqFeature($amplicon); print "Amplicon start : ".$amplicon->start."\n"; print "Amplicon end : ".$amplicon->end."\n"; print "Amplicon sequence: ".$amplicon->seq->seq."\n"; # Amplicon sequence should be 'CCCCCGGGGG' =head1 DESCRIPTION Bio::SeqFeature::Amplicon extends L<Bio::SeqFeature::Subseq> to represent an amplicon sequence and optional primer sequences. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Florent Angly <florent.angly@gmail.com> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqFeature::Amplicon; use strict; use base qw(Bio::SeqFeature::SubSeq); =head2 new Title : new() Usage : my $amplicon = Bio::SeqFeature::Amplicon( -seq => $seq_object ); Function: Instantiate a new Bio::SeqFeature::Amplicon object Args : -seq , the sequence object or sequence string of the amplicon (optional) -fwd_primer , a Bio::SeqFeature primer object with specified location on amplicon (optional) -rev_primer , a Bio::SeqFeature primer object with specified location on amplicon (optional) Returns : A Bio::SeqFeature::Amplicon object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($fwd_primer, $rev_primer) = $self->_rearrange([qw(FWD_PRIMER REV_PRIMER)], @args); $fwd_primer && $self->fwd_primer($fwd_primer); $rev_primer && $self->rev_primer($rev_primer); return $self; } sub _primer { # Get or set a primer. Type is either 'fwd' or 'rev'. my ($self, $type, $primer) = @_; if (defined $primer) { if ( not(ref $primer) || not $primer->isa('Bio::SeqFeature::Primer') ) { $self->throw("Expected a primer object but got a '".ref($primer)."'\n"); } if ( not defined $self->location ) { $self->throw("Location of $type primer on amplicon is not known. ". "Use start(), end() or location() to set it."); } $primer->primary_tag($type.'_primer'); $self->add_SeqFeature($primer); } return (grep { $_->primary_tag eq $type.'_primer' } $self->get_SeqFeatures)[0]; } =head2 fwd_primer Title : fwd_primer Usage : my $primer = $feat->fwd_primer(); Function: Get or set the forward primer. When setting it, the primary tag 'fwd_primer' is added to the primer and its start, stop and strand attributes are set if needed, assuming that the forward primer is at the beginning of the amplicon and the reverse primer at the end. Args : A Bio::SeqFeature::Primer object (optional) Returns : A Bio::SeqFeature::Primer object =cut sub fwd_primer { my ($self, $primer) = @_; return $self->_primer('fwd', $primer); } =head2 rev_primer Title : rev_primer Usage : my $primer = $feat->rev_primer(); Function: Get or set the reverse primer. When setting it, the primary tag 'rev_primer' is added to the primer. Args : A Bio::SeqFeature::Primer object (optional) Returns : A Bio::SeqFeature::Primer object =cut sub rev_primer { my ($self, $primer) = @_; return $self->_primer('rev', $primer); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/AnnotationAdaptor.pm�������������������������������������������������000444��000765��000024�� 36474�12254227330� 22232� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::AnnotationAdaptor # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp at gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # # (c) Hilmar Lapp, hlapp at gmx.net, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::AnnotationAdaptor - integrates SeqFeatureIs annotation =head1 SYNOPSIS use Bio::SeqFeature::Generic; use Bio::SeqFeature::AnnotationAdaptor; # obtain a SeqFeatureI implementing object somehow my $feat = Bio::SeqFeature::Generic->new(-start => 10, -end => 20); # add tag/value annotation $feat->add_tag_value("mytag", "value of tag mytag"); $feat->add_tag_value("mytag", "another value of tag mytag"); # Bio::SeqFeature::Generic also provides annotation(), which returns a # Bio::AnnotationCollectionI compliant object $feat->annotation->add_Annotation("dbxref", $dblink); # to integrate tag/value annotation with AnnotationCollectionI # annotation, use this adaptor, which also implements # Bio::AnnotationCollectionI my $anncoll = Bio::SeqFeature::AnnotationAdaptor->new(-feature => $feat); # this will now return tag/value pairs as # Bio::Annotation::SimpleValue objects my @anns = $anncoll->get_Annotations("mytag"); # other added before annotation is available too my @dblinks = $anncoll->get_Annotations("dbxref"); # also supports transparent adding of tag/value pairs in # Bio::AnnotationI flavor my $tagval = Bio::Annotation::SimpleValue->new(-value => "some value", -tagname => "some tag"); $anncoll->add_Annotation($tagval); # this is now also available from the feature's tag/value system my @vals = $feat->get_tag_values("some tag"); =head1 DESCRIPTION L<Bio::SeqFeatureI> defines light-weight annotation of features through tag/value pairs. Conversely, L<Bio::AnnotationCollectionI> together with L<Bio::AnnotationI> defines an annotation bag, which is better typed, but more heavy-weight because it contains every single piece of annotation as objects. The frequently used base implementation of Bio::SeqFeatureI, Bio::SeqFeature::Generic, defines an additional slot for AnnotationCollectionI-compliant annotation. This adaptor provides a L<Bio::AnnotationCollectionI> compliant, unified, and integrated view on the annotation of L<Bio::SeqFeatureI> objects, including tag/value pairs, and annotation through the annotation() method, if the object supports it. Code using this adaptor does not need to worry about the different ways of possibly annotating a SeqFeatureI object, but can instead assume that it strictly follows the AnnotationCollectionI scheme. The price to pay is that retrieving and adding annotation will always use objects instead of light-weight tag/value pairs. In other words, this adaptor allows us to keep the best of both worlds. If you create tens of thousands of feature objects, and your only annotation is tag/value pairs, you are best off using the features' native tag/value system. If you create a smaller number of features, but with rich and typed annotation mixed with tag/value pairs, this adaptor may be for you. Since its implementation is by double-composition, you only need to create one instance of the adaptor. In order to transparently annotate a feature object, set the feature using the feature() method. Every annotation you add will be added to the feature object, and hence will not be lost when you set feature() to the next object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' Let the code begin... package Bio::SeqFeature::AnnotationAdaptor; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Annotation::SimpleValue; use base qw(Bio::Root::Root Bio::AnnotationCollectionI Bio::AnnotatableI); =head2 new Title : new Usage : my $obj = Bio::SeqFeature::AnnotationAdaptor->new(); Function: Builds a new Bio::SeqFeature::AnnotationAdaptor object Returns : an instance of Bio::SeqFeature::AnnotationAdaptor Args : Named parameters -feature the Bio::SeqFeatureI implementing object to adapt (mandatory to be passed here, or set via feature() before calling other methods) -annotation the Bio::AnnotationCollectionI implementing object for storing richer annotation (this will default to the $feature->annotation() if it supports it) -tagvalue_factory the object factory to use for creating tag/value pair representing objects =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($feat,$anncoll,$fact) = $self->_rearrange([qw(FEATURE ANNOTATION TAGVALUE_FACTORY)], @args); $self->feature($feat) if $feat; $self->annotation($anncoll) if $feat; $self->tagvalue_object_factory($fact) if $fact; return $self; } =head2 feature Title : feature Usage : $obj->feature($newval) Function: Get/set the feature that this object adapts to an AnnotationCollectionI. Example : Returns : value of feature (a Bio::SeqFeatureI compliant object) Args : new value (a Bio::SeqFeatureI compliant object, optional) =cut sub feature{ my ($self,$value) = @_; if( defined $value) { $self->{'feature'} = $value; } return $self->{'feature'}; } =head2 annotation Title : annotation Usage : $obj->annotation($newval) Function: Get/set the AnnotationCollectionI implementing object used by this adaptor to store additional annotation that cannot be stored by the SeqFeatureI itself. If requested before having been set, the value will default to the annotation object of the feature if it has one. Example : Returns : value of annotation (a Bio::AnnotationCollectionI compliant object) Args : new value (a Bio::AnnotationCollectionI compliant object, optional) =cut sub annotation{ my ($self,$value) = @_; if( defined $value) { $self->{'annotation'} = $value; } if((! exists($self->{'annotation'})) && $self->feature()->can('annotation')) { return $self->feature()->annotation(); } return $self->{'annotation'}; } =head1 AnnotationCollectionI implementing methods =cut =head2 get_all_annotation_keys Title : get_all_annotation_keys Usage : $ac->get_all_annotation_keys() Function: gives back a list of annotation keys, which are simple text strings Returns : list of strings Args : none =cut sub get_all_annotation_keys{ my ($self) = @_; my @keys = (); # get the tags from the feature object if ($self->feature()->can('get_all_tags')) { push(@keys, $self->feature()->get_all_tags()); } else { push(@keys, $self->feature()->all_tags()); } # ask the annotation implementation in addition, while avoiding duplicates if($self->annotation()) { push(@keys, grep { ! $self->feature->has_tag($_); } $self->annotation()->get_all_annotation_keys()); } # done return @keys; } =head2 get_Annotations Title : get_Annotations Usage : my @annotations = $collection->get_Annotations('key') Function: Retrieves all the Bio::AnnotationI objects for a specific key Returns : list of Bio::AnnotationI - empty if no objects stored for a key Args : string which is key for annotations =cut sub get_Annotations{ my ($self, @keys) = @_; my @anns = (); # we need a annotation object factory my $fact = $self->tagvalue_object_factory(); # get all tags if no keys have been provided @keys = $self->feature->all_tags() unless @keys; # build object for each value for each tag foreach my $key (@keys) { # protect against keys that aren't tags next unless $self->feature->has_tag($key); # add each tag/value pair as a SimpleValue object foreach my $val ($self->feature()->get_tag_values($key)) { my $ann; if($fact) { $ann = $fact->create_object(-value => $val, -tagname => $key); } else { $ann = Bio::Annotation::SimpleValue->new(-value => $val, -tagname => $key); } push(@anns, $ann); } } # add what is in the annotation implementation if any if($self->annotation()) { push(@anns, $self->annotation->get_Annotations(@keys)); } # done return @anns; } =head2 get_num_of_annotations Title : get_num_of_annotations Usage : my $count = $collection->get_num_of_annotations() Function: Returns the count of all annotations stored in this collection Returns : integer Args : none =cut sub get_num_of_annotations{ my ($self) = @_; # first, count the number of tags on the feature my $num_anns = 0; foreach ($self->feature()->all_tags()) { $num_anns += scalar( $self->feature()->get_tag_values($_)); } # add from the annotation implementation if any if($self->annotation()) { $num_anns += $self->annotation()->get_num_of_annotations(); } # done return $num_anns; } =head1 Implementation specific functions - to allow adding =cut =head2 add_Annotation Title : add_Annotation Usage : $self->add_Annotation('reference',$object); $self->add_Annotation($object,'Bio::MyInterface::DiseaseI'); $self->add_Annotation($object); $self->add_Annotation('disease',$object,'Bio::MyInterface::DiseaseI'); Function: Adds an annotation for a specific key. If the key is omitted, the object to be added must provide a value via its tagname(). If the archetype is provided, this and future objects added under that tag have to comply with the archetype and will be rejected otherwise. This implementation will add all Bio::Annotation::SimpleValue objects to the adapted features as tag/value pairs. Caveat: this may potentially result in information loss if a derived object is supplied. Returns : none Args : annotation key ('disease', 'dblink', ...) object to store (must be Bio::AnnotationI compliant) [optional] object archetype to map future storage of object of these types to =cut sub add_Annotation{ my ($self,$key,$object,$archetype) = @_; # if there's no key we use the tagname() as key if(ref($key) && $key->isa("Bio::AnnotationI") && (! ($object && ref($object)))) { $archetype = $object if $object; $object = $key; $key = $object->tagname(); $key = $key->name() if $key && ref($key); # OntologyTermI $self->throw("Annotation object must have a tagname if key omitted") unless $key; } if( !defined $object ) { $self->throw("Must have at least key and object in add_Annotation"); } if( ! (ref($object) && $object->isa("Bio::AnnotationI")) ) { $self->throw("object must be a Bio::AnnotationI compliant object, otherwise we wont add it!"); } # ready to add -- if it's a SimpleValue, we add to the feature's tags, # otherwise we'll add to the annotation collection implementation if($object->isa("Bio::Annotation::SimpleValue") && $self->feature()->can('add_tag_value')) { return $self->feature()->add_tag_value($key, $object->value()); } else { my $anncoll = $self->annotation(); if(! $anncoll) { $anncoll = Bio::Annotation::Collection->new(); $self->annotation($anncoll); } if($anncoll->can('add_Annotation')) { return $anncoll->add_Annotation($key,$object,$archetype); } $self->throw("Annotation implementation does not allow adding!"); } } =head2 remove_Annotations Title : remove_Annotations Usage : Function: Remove the annotations for the specified key from this collection. If the key happens to be a tag, then the tag is removed from the feature. Example : Returns : an array Bio::AnnotationI compliant objects which were stored under the given key(s) Args : the key(s) (tag name(s), one or more strings) for which to remove annotations (optional; if none given, flushes all annotations) =cut sub remove_Annotations{ my ($self, @keys) = @_; # set to all keys if none are supplied @keys = $self->get_all_annotation_keys() unless @keys; # collect existing annotation my @anns = $self->get_Annotations(@keys); # flush foreach my $key (@keys) { # delete the tag if it is one $self->feature->remove_tag($key) if $self->feature->has_tag($key); # and delegate to the annotation implementation my $anncoll = $self->annotation(); if($anncoll && $anncoll->can('remove_Annotations')) { $anncoll->remove_Annotations($key); } elsif($anncoll) { $self->warn("Annotation bundle implementation ".ref($anncoll). " does not allow remove!"); } } return @anns; } =head1 Additional methods =cut =head2 tagvalue_object_factory Title : tagvalue_object_factory Usage : $obj->tagval_object_factory($newval) Function: Get/set the object factory to use for creating objects that represent tag/value pairs (e.g., Bio::Annotation::SimpleValue). The object to be created is expected to follow Bio::Annotation::SimpleValue in terms of supported arguments at creation time, and the methods. Example : Returns : A Bio::Factory::ObjectFactoryI compliant object Args : new value (a Bio::Factory::ObjectFactoryI compliant object, optional) =cut sub tagvalue_object_factory{ my ($self,$value) = @_; if( defined $value) { $self->{'tagval_object_factory'} = $value; } return $self->{'tagval_object_factory'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Collection.pm��������������������������������������������������������000444��000765��000024�� 36220�12254227315� 20670� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Collection # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Collection - A container class for SeqFeatures suitable for performing operations such as finding features within a range, that match a certain feature type, etc. =head1 SYNOPSIS use Bio::SeqFeature::Collection; use Bio::Location::Simple; use Bio::Tools::GFF; use Bio::Root::IO; use File::Spec; # let's first input some features my $gffio = Bio::Tools::GFF->new(-file => File::Spec->catfile ("t","data","myco_sites.gff"), -gff_version => 2); my @features = (); # loop over the input stream while(my $feature = $gffio->next_feature()) { # do something with feature push @features, $feature; } $gffio->close(); # build the Collection object my $col = Bio::SeqFeature::Collection->new(); # add these features to the object my $totaladded = $col->add_features(\@features); my @subset = $col->features_in_range(-start => 1, -end => 25000, -strand => 1, -contain => 0); # subset should have 18 entries for this dataset print "size is ", scalar @subset, "\n"; @subset = $col->features_in_range(-range => Bio::Location::Simple->new (-start => 70000, -end => 150000, -strand => -1), -contain => 1, -strandmatch => 'strong'); # subset should have 22 entries for this dataset print "size is ", scalar @subset, "\n"; print "total number of features in collection is ", $col->feature_count(),"\n"; =head1 DESCRIPTION This object will efficiently allow one for query subsets of ranges within a large collection of sequence features (in fact the objects just have to be Bio::RangeI compliant). This is done by the creation of bins which are stored in order in a B-Tree data structure as provided by the DB_File interface to the Berkeley DB. This is based on work done by Lincoln for storage in a mysql instance - this is intended to be an embedded in-memory implementation for easily querying for subsets of a large range set. Collections can be made persistent by keeping the indexfile and passing in the -keep flag like this: my $collection = Bio::SeqFeature::Collection->new(-keep => 1, -file => 'col.idx'); $collaction->add_features(\@features); undef $collection; # To reuse this collection, next time you initialize a Collection object # specify the filename and the index will be reused. $collection = Bio::SeqFeature::Collection->new(-keep => 1, -file => 'col.idx'); =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Using code and strategy developed by Lincoln Stein (lstein@cshl.org) in Bio::DB::GFF implementation. Credit also to Lincoln for suggesting using Storable to serialize features rather than my previous implementation which kept the features in memory. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Collection; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::DB::GFF::Util::Binning; use DB_File; use Bio::Location::Simple; use Bio::SeqFeature::Generic; use Storable qw(freeze thaw); use base qw(Bio::Root::Root Bio::SeqFeature::CollectionI); # This may need to get re-optimized for BDB usage as these # numbers were derived empirically by Lincoln on a mysql srv # running on his laptop # this is the largest that any reference sequence can be (100 megabases) use constant MAX_BIN => 100_000_000; # this is the smallest bin (1 K) use constant MIN_BIN => 1_000; =head2 new Title : new Usage : my $obj = Bio::SeqFeature::Collection->new(); Function: Builds a new Bio::SeqFeature::Collection object Returns : Bio::SeqFeature::Collection Args : -minbin minimum value to use for binning (default is 100,000,000) -maxbin maximum value to use for binning (default is 1,000) -file filename to store/read the BTREE from rather than an in-memory structure (default is false and in-memory). -keep boolean, will not remove index file on object destruction. -features Array ref of features to add initially =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($maxbin,$minbin, $file, $keep, $features) = $self->_rearrange([qw(MAXBIN MINBIN FILE KEEP FEATURES)],@args); defined $maxbin && $self->max_bin($maxbin); defined $minbin && $self->min_bin($minbin); defined $features && $self->add_features($features); $DB_BTREE->{'flags'} = R_DUP ; $DB_BTREE->{'compare'} = \&_compare; $self->{'_btreehash'} = {}; if( $file ) { $self->debug("using file $file"); $self->indexfile($file); } $self->keep($keep); $self->{'_btree'} = tie %{$self->{'_btreehash'}}, 'DB_File', $self->indexfile, O_RDWR|O_CREAT, 0640, $DB_BTREE; $self->{'_btree'} || $self->throw("Unable to tie DB_File handle"); return $self; } =head2 add_features Title : add_features Usage : $collection->add_features(\@features); Function: Returns : number of features added Args : arrayref of Bio::SeqFeatureI objects to index =cut sub add_features{ my ($self,$feats) = @_; if( ref($feats) !~ /ARRAY/i ) { $self->warn("Must provide a valid Array reference to add_features"); return 0; } my $count = 0; foreach my $f ( @$feats ) { if( ! $f || ! ref($f) || ! $f->isa('Bio::RangeI') ) { $self->warn("Must provide valid Bio::RangeI objects to add_features, skipping object '$f'\n"); next; } my $bin = bin($f->start,$f->end,$self->min_bin); my $serialized = &feature_freeze($f); $self->{'_btree'}->put($bin,$serialized); if( $f->isa('Bio::SeqFeature::Generic') ) { $self->debug( "$bin for ". $f->location->to_FTstring(). " matches ".$#{$self->{'_features'}}. "\n"); } $count++; } return $count; } =head2 features_in_range Title : features_in_range Usage : my @features = $collection->features_in_range($range) Function: Retrieves a list of features which were contained or overlap the the requested range (see Args for way to specify overlap or only those containe)d Returns : List of Bio::SeqFeatureI objects Args : -range => Bio::RangeI object defining range to search, OR -start => start, -end => end, -strand => strand -contain => boolean - true if feature must be completely contained with range OR false if should include features that simply overlap the range. Default: true. -strandmatch => 'strong', ranges must have the same strand 'weak', ranges must have the same strand or no strand 'ignore', ignore strand information Default. 'ignore'. =cut sub features_in_range{ my $self = shift; my (@args) = @_; my ($range, $contain, $strandmatch,$start,$end,$strand); if( @args == 1 ) { $range = shift @args; } else { ($start,$end,$strand,$range, $contain,$strandmatch) = $self->_rearrange([qw(START END STRAND RANGE CONTAIN STRANDMATCH)], @args); $contain = 1 unless defined $contain; } $strand = 1 unless defined $strand; if( $strand !~ /^([\-\+])$/ && $strand !~ /^[\-\+]?1$/ ) { $self->warn("must provide a valid numeric or +/- for strand"); return (); } if( defined $1 ) { $strand .= 1; } if( !defined $start && !defined $end ) { if( ! defined $range || !ref($range) || ! $range->isa("Bio::RangeI") ) { $self->warn("Must defined a valid Range for the method feature_in_range"); return (); } ($start,$end,$strand) = ($range->start,$range->end,$range->strand); } my $r = Bio::Location::Simple->new(-start => $start, -end => $end, -strand => $strand); my @features; my $maxbin = $self->max_bin; my $minbin = $self->min_bin; my $tier = $maxbin; my ($k,$v,@bins) = ("",undef); while ($tier >= $minbin) { my ($tier_start,$tier_stop) = (bin_bot($tier,$start), bin_top($tier,$end)); if( $tier_start == $tier_stop ) { my @vals = $self->{'_btree'}->get_dup($tier_start); if( scalar @vals > 0 ) { push @bins, map { thaw($_) } @vals; } } else { $k = $tier_start; my @vals; for( my $rc = $self->{'_btree'}->seq($k,$v,R_CURSOR); $rc == 0; $rc = $self->{'_btree'}->seq($k,$v, R_NEXT) ) { last if( $k > $tier_stop || $k < $tier_start); push @bins, thaw($v); } } $tier /= 10; } my %seen = (); foreach my $t ( map { ref($_) } @bins) { next if $seen{$t}++; eval "require $t"; if( $@ ) { $self->warn("Trying to thaw a stored feature $t which does not appear in your Perl library. $@"); next; } } $strandmatch = 'ignore' unless defined $strandmatch; return ( $contain ) ? grep { $r->contains($_,$strandmatch) } @bins : grep { $r->overlaps($_,$strandmatch)} @bins; } =head2 remove_features Title : remove_features Usage : $collection->remove_features(\@array) Function: Removes the requested sequence features (based on features which have the same location) Returns : Number of features removed Args : Arrayref of Bio::RangeI objects =cut sub remove_features{ my ($self,$feats) = @_; if( ref($feats) !~ /ARRAY/i ) { $self->warn("Must provide a valid Array reference to remove_features"); return 0; } my $countprocessed = 0; foreach my $f ( @$feats ) { next if ! ref($f) || ! $f->isa('Bio::RangeI'); my $bin = bin($f->start,$f->end,$self->min_bin); my @vals = $self->{'_btree'}->get_dup($bin); my $vcount = scalar @vals; foreach my $v ( @vals ) { # Once we have uniquely identifiable field # I think it will work better. if( $v eq &feature_freeze($f) ) { $self->{'_btree'}->del_dup($bin,$v); $vcount--; $countprocessed++; } } if( $vcount == 0 ) { $self->{'_btree'}->del($bin); } } $countprocessed; } =head2 get_all_features Title : get_all_features Usage : my @f = $col->get_all_features() Function: Return all the features stored in this collection (Could be large) Returns : Array of Bio::RangeI objects Args : None =cut sub get_all_features{ my ($self) = @_; my @features; my ($key,$value); for (my $status = $self->{'_btree'}->seq($key, $value, R_FIRST) ; $status == 0 ; $status = $self->{'_btree'}->seq($key, $value, R_NEXT) ) { next unless defined $value; push @features, &thaw($value); } if( scalar @features != $self->feature_count() ) { $self->warn("feature count does not match actual count\n"); } return @features; } =head2 min_bin Title : min_bin Usage : my $minbin= $self->min_bin; Function: Get/Set the minimum value to use for binning Returns : integer Args : [optional] minimum bin value =cut sub min_bin { my ($self,$min) = @_; if( defined $min ) { $self->{'_min_bin'} = $min; } return $self->{'_min_bin'} || MIN_BIN; } =head2 max_bin Title : max_bin Usage : my $maxbin= $self->max_bin; Function: Get/Set the maximum value to use for binning Returns : integer Args : [optional] maximum bin value =cut sub max_bin { my ($self,$max) = @_; if( defined $max ) { $self->{'_max_bin'} = $max; } return $self->{'max_bin'} || MAX_BIN; } =head2 feature_count Title : feature_count Usage : my $c = $col->feature_count() Function: Retrieve the total number of features in the collection Returns : integer Args : none =cut sub feature_count { my $self = shift; my $count = 0; for ( keys %{$self->{'_btreehash'}} ) { my $v = $self->{'_btreehash'}->{$_}; next unless defined $v; $count++; } $count; } =head2 indexfile Title : indexfile Usage : $obj->indexfile($newval) Function: Get/set the filename where index is kept Returns : value of indexfile (a filename string) Args : on set, new value (a filename string ) =cut sub indexfile{ my $self = shift; return $self->{'indexfile'} = shift if @_; return $self->{'indexfile'}; } =head2 keep Title : keep Usage : $obj->keep($newval) Function: Get/set boolean flag to keep the indexfile after exiting program Example : Returns : value of keep (boolean) Args : on set, new value (boolean) =cut sub keep{ my $self = shift; return $self->{'keep'} = shift if @_; return $self->{'keep'}; } sub _compare{ if( defined $_[0] && ! defined $_[1]) { return -1; } elsif ( defined $_[1] && ! defined $_[0]) { return 1; } $_[0] <=> $_[1]; } sub feature_freeze { my $obj = shift; _remove_cleanup_methods($obj); return freeze($obj); } sub _remove_cleanup_methods { my $obj = shift; # we have to remove any cleanup methods here for Storable for my $funcref ( $obj->_cleanup_methods ) { $obj->_unregister_for_cleanup($funcref); } # ... and the same for any contained features; hopefully any implementations # adhere to implementing Bio::SeqFeatureI::sub_SeqFeature for my $contained ($obj->sub_SeqFeature) { _remove_cleanup_methods($contained); } 1; } sub feature_thaw { return thaw(shift); } sub DESTROY { my $self = shift; $self->{'_btree'} = undef; untie(%{$self->{'_btreehash'}}); if( ! $self->keep && $self->indexfile ) { my $f = $self->indexfile; $self->debug( "unlinking ".$f. "\n"); close($f); unlink($f); } $self->SUPER::DESTROY(); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/CollectionI.pm�������������������������������������������������������000444��000765��000024�� 7342�12254227340� 20762� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::CollectionI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::CollectionI - An interface for a collection of SeqFeatureI objects. =head1 SYNOPSIS # get a Bio::SeqFeature::CollectionI somehow # perhaps a Bio::SeqFeature::Collection use Bio::SeqFeature::Collection; my $collection = Bio::SeqFeature::Collection->new(); $collection->add_features(\@featurelist); $collection->features(-attributes => [ { 'location' => Bio::Location::Simple->new (-start=> 1, -end => 300) , 'overlaps' }]); =head1 DESCRIPTION This interface describes the basic methods needed for a collection of Sequence Features. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::CollectionI; use strict; use Carp; use base qw(Bio::Root::RootI); =head2 add_features Title : add_features Usage : $collection->add_features(\@features); Function: Returns : number of features added Args : arrayref of Bio::SeqFeatureI objects to index =cut sub add_features{ shift->throw_not_implemented(); } =head2 features Title : features Usage : my @f = $collection->features(@args); Returns : a list of Bio::SeqFeatureI objects Args : see below Status : public This routine will retrieve features associated with this collection object. It can be used to return all features, or a subset based on their type, location, or attributes. -types List of feature types to return. Argument is an array of Bio::Das::FeatureTypeI objects or a set of strings that can be converted into FeatureTypeI objects. -callback A callback to invoke on each feature. The subroutine will be passed to each Bio::SeqFeatureI object in turn. -attributes A hash reference containing attributes to match. The -attributes argument is a hashref containing one or more attributes to match against: -attributes => { Gene => 'abc-1', Note => 'confirmed' } Attribute matching is simple exact string matching, and multiple attributes are ANDed together. See L<Bio::DB::ConstraintsI> for a more sophisticated take on this. If one provides a callback, it will be invoked on each feature in turn. If the callback returns a false value, iteration will be interrupted. When a callback is provided, the method returns undef. =cut sub features{ shift->throw_not_implemented(); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Computation.pm�������������������������������������������������������000444��000765��000024�� 35213�12254227321� 21075� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Generic # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by mark Fiers <m.w.e.j.fiers@plant.wag-ur.nl> # # Copyright Ewan Birney, Mark Fiers # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Computation - Computation SeqFeature =head1 SYNOPSIS $feat = Bio::SeqFeature::Computation->new( -start => 10, -end => 100, -strand => -1, -primary => 'repeat', -program_name => 'GeneMark', -program_date => '12-5-2000', -program_version => 'x.y', -database_name => 'Arabidopsis', -database_date => '12-dec-2000', -computation_id => 2231, -score => { no_score => 334 } ); =head1 DESCRIPTION Bio::SeqFeature::Computation extends the Generic seqfeature object with a set of computation related fields and a more flexible set of storing more types of score and subseqfeatures. It is compatible with the Generic SeqFeature object. The new way of storing score values is similar to the tag structure in the Generic object. For storing sets of subseqfeatures the array containg the subseqfeatures is now a hash which contains arrays of seqfeatures Both the score and subSeqfeature methods can be called in exactly the same way, the value's will be stored as a 'default' score or subseqfeature. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney, Mark Fiers Ewan Birney E<lt>birney@sanger.ac.ukE<gt> Mark Fiers E<lt>m.w.e.j.fiers@plant.wag-ur.nlE<gt> =head1 DEVELOPERS This class has been written with an eye out of inheritance. The fields the actual object hash are: _gsf_sub_hash = reference to a hash containing sets of sub arrays _gsf_score_hash= reference to a hash for the score values =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Computation; use strict; use base qw(Bio::SeqFeature::Generic); sub new { my ( $class, @args) = @_; my $self = $class->SUPER::new(@args); my ( $computation_id, $program_name, $program_date, $program_version, $database_name, $database_date, $database_version) = $self->_rearrange([qw( COMPUTATION_ID PROGRAM_NAME PROGRAM_DATE PROGRAM_VERSION DATABASE_NAME DATABASE_DATE DATABASE_VERSION )],@args); $program_name && $self->program_name($program_name); $program_date && $self->program_date($program_date); $program_version && $self->program_version($program_version); $database_name && $self->database_name($database_name); $database_date && $self->database_date($database_date); $database_version && $self->database_version($database_version); $computation_id && $self->computation_id($computation_id); return $self; } =head2 has_score Title : has_score Usage : $value = $self->has_score('some_score') Function: Tests wether a feature contains a score Returns : TRUE if the SeqFeature has the score, and FALSE otherwise. Args : The name of a score =cut sub has_score { my ($self, $score) = @_; return unless defined $score; return exists $self->{'_gsf_score_hash'}->{$score}; } =head2 add_score_value Title : add_score_value Usage : $self->add_score_value('P_value',224); Returns : TRUE on success Args : score (string) and value (any scalar) =cut sub add_score_value { my ($self, $score, $value) = @_; if( ! defined $score || ! defined $value ) { $self->warn("must specify a valid $score and $value to add_score_value"); return 0; } if ( !defined $self->{'_gsf_score_hash'}->{$score} ) { $self->{'_gsf_score_hash'}->{$score} = []; } push(@{$self->{'_gsf_score_hash'}->{$score}},$value); } =head2 score Title : score Usage : $value = $comp_obj->score() $comp_obj->score($value) Function: Returns the 'default' score or sets the 'default' score This method exist for compatibility options It would equal ($comp_obj->each_score_value('default'))[0]; Returns : A value Args : (optional) a new value for the 'default' score =cut sub score { my ($self, $value) = @_; my @v; if (defined $value) { if( ref($value) =~ /HASH/i ) { while( my ($t,$val) = each %{ $value } ) { $self->add_score_value($t,$val); } } else { @v = $value; $self->add_score_value('default', $value); } } else { @v = $self->each_score_value('default'); } return $v[0]; } =head2 each_score_value Title : each_score_value Usage : @values = $gsf->each_score_value('note'); Function: Returns a list of all the values stored under a particular score. Returns : A list of scalars Args : The name of the score =cut sub each_score_value { my ($self, $score) = @_; if ( ! exists $self->{'_gsf_score_hash'}->{$score} ) { $self->warn("asking for score value that does not exist $score"); return; } return @{$self->{'_gsf_score_hash'}->{$score}}; } =head2 all_scores Title : all_scores Usage : @scores = $feat->all_scores() Function: Get a list of all the scores in a feature Returns : An array of score names Args : none =cut sub all_scores { my ($self, @args) = @_; return keys %{$self->{'_gsf_score_hash'}}; } =head2 remove_score Title : remove_score Usage : $feat->remove_score('some_score') Function: removes a score from this feature Returns : nothing Args : score (string) =cut sub remove_score { my ($self, $score) = @_; if ( ! exists $self->{'_gsf_score_hash'}->{$score} ) { $self->warn("trying to remove a score that does not exist: $score"); } delete $self->{'_gsf_score_hash'}->{$score}; } =head2 computation_id Title : computation_id Usage : $computation_id = $feat->computation_id() $feat->computation_id($computation_id) Function: get/set on program name information Returns : string Args : none if get, the new value if set =cut sub computation_id { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_computation_id'} = $value; } return $self->{'_gsf_computation_id'}; } =head2 program_name Title : program_name Usage : $program_name = $feat->program_name() $feat->program_name($program_name) Function: get/set on program name information Returns : string Args : none if get, the new value if set =cut sub program_name { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_program_name'} = $value; } return $self->{'_gsf_program_name'}; } =head2 program_date Title : program_date Usage : $program_date = $feat->program_date() $feat->program_date($program_date) Function: get/set on program date information Returns : date (string) Args : none if get, the new value if set =cut sub program_date { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_program_date'} = $value; } return $self->{'_gsf_program_date'}; } =head2 program_version Title : program_version Usage : $program_version = $feat->program_version() $feat->program_version($program_version) Function: get/set on program version information Returns : date (string) Args : none if get, the new value if set =cut sub program_version { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_program_version'} = $value; } return $self->{'_gsf_program_version'}; } =head2 database_name Title : database_name Usage : $database_name = $feat->database_name() $feat->database_name($database_name) Function: get/set on program name information Returns : string Args : none if get, the new value if set =cut sub database_name { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_database_name'} = $value; } return $self->{'_gsf_database_name'}; } =head2 database_date Title : database_date Usage : $database_date = $feat->database_date() $feat->database_date($database_date) Function: get/set on program date information Returns : date (string) Args : none if get, the new value if set =cut sub database_date { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_database_date'} = $value; } return $self->{'_gsf_database_date'}; } =head2 database_version Title : database_version Usage : $database_version = $feat->database_version() $feat->database_version($database_version) Function: get/set on program version information Returns : date (string) Args : none if get, the new value if set =cut sub database_version { my ($self,$value) = @_; if (defined($value)) { $self->{'_gsf_database_version'} = $value; } return $self->{'_gsf_database_version'}; } =head2 get_SeqFeature_type Title : get_SeqFeature_type Usage : $SeqFeature_type = $feat->get_SeqFeature_type() $feat->get_SeqFeature_type($SeqFeature_type) Function: Get SeqFeature type which is automatically set when adding a computation (SeqFeature) to a computation object Returns : SeqFeature_type (string) Args : none if get, the new value if set =cut sub get_SeqFeature_type { my ($self, $value) = @_; if (defined($value)) { $self->{'_gsf_sub_SeqFeature_type'} = $value; } return $self->{'_gsf_sub_SeqFeature_type'}; } =head2 get_all_SeqFeature_types Title : get_all_SeqFeature_types Usage : @all_SeqFeature_types = $comp->get_all_SeqFeature_types(); Function: Returns an array with all subseqfeature types Returns : An array Args : none =cut sub get_all_SeqFeature_types { my ($self) = @_; return keys ( %{$self->{'gsf_sub_hash'}} ); } =head2 get_SeqFeatures Title : get_SeqFeatures('feature_type') Usage : @feats = $feat->get_SeqFeatures(); @feats = $feat->get_SeqFeatures('feature_type'); Function: Returns an array of sub Sequence Features of a specific type or, if the type is ommited, all sub Sequence Features Returns : An array Args : (optional) a SeqFeature type (ie exon, pattern) =cut sub get_SeqFeatures { my ($self, $ssf_type) = @_; my (@return_array) = (); if ($ssf_type eq '') { #return all SeqFeatures foreach (keys ( %{$self->{'gsf_sub_hash'}} )){ push @return_array, @{$self->{'gsf_sub_hash'}->{$_}}; } return @return_array; } else { if (defined ($self->{'gsf_sub_hash'}->{$ssf_type})) { return @{$self->{'gsf_sub_hash'}->{$ssf_type}}; } else { $self->warn("$ssf_type is not a valid sub SeqFeature type"); } } } =head2 add_SeqFeature Title : add_SeqFeature Usage : $feat->add_SeqFeature($subfeat); $feat->add_SeqFeature($subfeat,'seqfeature_type') $feat->add_SeqFeature($subfeat,'EXPAND') $feat->add_SeqFeature($subfeat,'EXPAND','seqfeature_type') Function: adds a SeqFeature into a specific subSeqFeature array. with no 'EXPAND' qualifer, subfeat will be tested as to whether it lies inside the parent, and throw an exception if not. If EXPAND is used, the parents start/end/strand will be adjusted so that it grows to accommodate the new subFeature, optionally a seqfeature type can be defined. Returns : nothing Args : An object which has the SeqFeatureI interface (optional) 'EXPAND' (optional) 'SeqFeature_type' =cut sub add_SeqFeature{ my ($self,$feat,$var1, $var2) = @_; $var1 = '' unless( defined $var1); $var2 = '' unless( defined $var2); my ($expand, $ssf_type) = ('', $var1 . $var2); $expand = 'EXPAND' if ($ssf_type =~ s/EXPAND//); if ( !$feat->isa('Bio::SeqFeatureI') ) { $self->warn("$feat does not implement Bio::SeqFeatureI. Will add it anyway, but beware..."); } if($expand eq 'EXPAND') { $self->_expand_region($feat); } else { if ( !$self->contains($feat) ) { $self->throw("$feat is not contained within parent feature, and expansion is not valid"); } } $ssf_type = 'default' if ($ssf_type eq ''); if (!(defined ($self->{'gsf_sub_hash'}->{$ssf_type}))) { @{$self->{'gsf_sub_hash'}->{$ssf_type}} = (); } $feat->get_SeqFeature_type($ssf_type); push @{$self->{'gsf_sub_hash'}->{$ssf_type}}, $feat; } =head2 remove_SeqFeatures Title : remove_SeqFeatures Usage : $sf->remove_SeqFeatures $sf->remove_SeqFeatures('SeqFeature_type'); Function: Removes all sub SeqFeature or all sub SeqFeatures of a specified type (if you want to remove a more specific subset, take an array of them all, flush them, and add back only the guys you want) Example : Returns : none Args : none =cut sub remove_SeqFeatures { my ($self, $ssf_type) = @_; if ($ssf_type) { if ((defined ($self->{'gsf_sub_hash'}->{$ssf_type}))) { delete $self->{'gsf_sub_hash'}->{$ssf_type}; } else { $self->warn("$ssf_type is not a valid sub SeqFeature type"); } } else { $self->{'_gsf_sub_hash'} = {}; # zap the complete hash implicitly. } } # Aliases to better match Bio::SeqFeature function names *sub_SeqFeature_type = \&get_SeqFeature_type; *all_sub_SeqFeature_types = \&get_all_SeqFeature_types; *sub_SeqFeature = \&get_SeqFeatures; *add_sub_SeqFeature = \&add_SeqFeature; *flush_sub_SeqFeatures = \&remove_SeqFeatures; *flush_sub_SeqFeature = \&remove_SeqFeatures; 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/FeaturePair.pm�������������������������������������������������������000444��000765��000024�� 31726�12254227314� 21011� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::FeaturePair # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::FeaturePair - hold pair feature information e.g. blast hits =head1 SYNOPSIS my $feat = Bio::SeqFeature::FeaturePair->new( -feature1 => $f1, -feature2 => $f2, ); # Bio::SeqFeatureI methods can be used my $start = $feat->start; my $end = $feat->end; # Bio::FeaturePair methods can be used my $hstart = $feat->hstart; my $hend = $feat->hend; my $feature1 = $feat->feature1; # returns feature1 object =head1 DESCRIPTION A sequence feature object where the feature is itself a feature on another sequence - e.g. a blast hit where residues 1-40 of a protein sequence SW:HBA_HUMAN has hit to bases 100 - 220 on a genomic sequence HS120G22. The genomic sequence coordinates are used to create one sequence feature $f1 and the protein coordinates are used to create feature $f2. A FeaturePair object can then be made my $fp = Bio::SeqFeature::FeaturePair->new( -feature1 => $f1, # genomic -feature2 => $f2, # protein ); This object can be used as a standard Bio::SeqFeatureI in which case my $gstart = $fp->start # returns start coord on feature1 - genomic seq. my $gend = $fp->end # returns end coord on feature1. In general standard Bio::SeqFeatureI method calls return information in feature1. Data in the feature 2 object are generally obtained using the standard methods prefixed by h (for hit!) my $pstart = $fp->hstart # returns start coord on feature2 = protein seq. my $pend = $fp->hend # returns end coord on feature2. If you wish to swap feature1 and feature2 around : $feat->invert so... $feat->start # etc. returns data in $feature2 object No sub_SeqFeatures or tags can be stored in this object directly. Any features or tags are expected to be stored in the contained objects feature1, and feature2. =head1 CONTACT Ewan Birney E<lt>birney@sanger.ac.ukE<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::FeaturePair; use vars qw($AUTOLOAD); use strict; use Bio::SeqFeatureI; use Bio::Factory::ObjectFactory; use base qw(Bio::SeqFeature::Generic); =head2 new Title : new Usage : Function: Constructor for this module. Accepts the following parameters: -feature1 Bio::SeqFeatureI-compliant object -feature2 Bio::SeqFeatureI-compliant object -feature_factory Bio::Factory::ObjectFactoryI compliant object to be used when feature1 and/or feature2 are accessed without explicitly set before. This is mostly useful for derived classes who want to set their preferred class for feature objects. Example : Returns : Args : see above =cut sub new { my ($class, @args) = @_; # # We've got a certain problem here that somewhat relates to chicken and # eggs. The problem is, we override a lot of SeqFeatureI methods here # to delegate them to either feature1 or feature2. If we pass along # those attributes right away, we need feature1 or feature2 or the feature # factory in place, or there is no way around the dreaded default, which # is ugly too (as it necessitates subsequent copying if you wanted a # different feature object class). # # So I decided to go with the lesser of two evils here: we need to assume # here that we can set all attributes through set_attributes(), which we # assume is no different from setting them through the constructor. This # gives us a window to set the feature objects and the factory, such that # any derived class doesn't have to worry about this any more. # # I'm happy to hear a better solution, but I think this one isn't so bad. # my $self = $class->SUPER::new(); my ($feature1,$feature2,$featfact) = $self->_rearrange([qw( FEATURE1 FEATURE2 FEATURE_FACTORY )],@args); $self->_register_for_cleanup(\&cleanup_fp); # initialize the feature object factory if not provided if(! $featfact) { $featfact = Bio::Factory::ObjectFactory->new( -type => "Bio::SeqFeature::Generic", -interface => "Bio::SeqFeatureI" ); } $self->feature_factory($featfact); # Store the features in the object $feature1 && $self->feature1($feature1); $feature2 && $self->feature2($feature2); # OK. Now we're setup to store all the attributes, and they'll go right # away into the right objects. $self->set_attributes(@args); # done - we hope return $self; } =head2 feature1 Title : feature1 Usage : $f = $featpair->feature1 $featpair->feature1($feature) Function: Get/set for the query feature Returns : Bio::SeqFeatureI Args : Bio::SeqFeatureI =cut sub feature1 { my ($self,$arg) = @_; if ( defined($arg) || !defined $self->{'feature1'} ) { $self->throw("internal error: feature factory not set!") unless $self->feature_factory; $arg = $self->feature_factory->create_object() unless( defined $arg); $self->throw("Argument [$arg] must be a Bio::SeqFeatureI") unless (ref($arg) && $arg->isa("Bio::SeqFeatureI")); $self->{'feature1'} = $arg; } return $self->{'feature1'}; } =head2 feature2 Title : feature2 Usage : $f = $featpair->feature2 $featpair->feature2($feature) Function: Get/set for the hit feature Returns : Bio::SeqFeatureI Args : Bio::SeqFeatureI =cut sub feature2 { my ($self,$arg) = @_; if ( defined($arg) || ! defined $self->{'feature2'}) { $self->throw("internal error: feature factory not set!") unless $self->feature_factory; $arg = $self->feature_factory->create_object() unless( defined $arg); $self->throw("Argument [$arg] must be a Bio::SeqFeatureI") unless (ref($arg) && $arg->isa("Bio::SeqFeatureI")); $self->{'feature2'} = $arg; } return $self->{'feature2'}; } =head2 start Title : start Usage : $start = $featpair->start $featpair->start(20) Function: Get/set on the start coordinate of feature1 Returns : integer Args : [optional] beginning of feature =cut sub start { return shift->feature1->start(@_); } =head2 end Title : end Usage : $end = $featpair->end $featpair->end($end) Function: get/set on the end coordinate of feature1 Returns : integer Args : [optional] ending point of feature =cut sub end { return shift->feature1->end(@_); } =head2 strand Title : strand Usage : $strand = $feat->strand() $feat->strand($strand) Function: get/set on strand information, being 1,-1 or 0 Returns : -1,1 or 0 Args : [optional] strand information to set =cut sub strand { return shift->feature1->strand(@_); } =head2 location Title : location Usage : $location = $featpair->location $featpair->location($location) Function: Get/set location object (using feature1) Returns : Bio::LocationI object Args : [optional] LocationI to store =cut sub location { return shift->feature1->location(@_); } =head2 score Title : score Usage : $score = $feat->score() $feat->score($score) Function: get/set on score information Returns : float Args : none if get, the new value if set =cut sub score { return shift->feature1->score(@_); } =head2 frame Title : frame Usage : $frame = $feat->frame() $feat->frame($frame) Function: get/set on frame information Returns : 0,1,2 Args : none if get, the new value if set =cut sub frame { return shift->feature1->frame(@_); } =head2 primary_tag Title : primary_tag Usage : $ptag = $featpair->primary_tag Function: get/set on the primary_tag of feature1 Returns : 0,1,2 Args : none if get, the new value if set =cut sub primary_tag { return shift->feature1->primary_tag(@_); } =head2 source_tag Title : source_tag Usage : $tag = $feat->source_tag() $feat->source_tag('genscan'); Function: Returns the source tag for a feature, eg, 'genscan' Returns : a string Args : none =cut sub source_tag { return shift->feature1->source_tag(@_); } =head2 seqname Title : seqname Usage : $obj->seq_id($newval) Function: There are many cases when you make a feature that you do know the sequence name, but do not know its actual sequence. This is an attribute such that you can store the seqname. This attribute should *not* be used in GFF dumping, as that should come from the collection in which the seq feature was found. Returns : value of seqname Args : newvalue (optional) =cut sub seq_id { return shift->feature1->seq_id(@_); } =head2 hseqname Title : hseqname Usage : $featpair->hseqname($newval) Function: Get/set method for the name of feature2. Returns : value of $feature2->seq_id Args : newvalue (optional) =cut sub hseq_id { return shift->feature2->seq_id(@_); } =head2 hstart Title : hstart Usage : $start = $featpair->hstart $featpair->hstart(20) Function: Get/set on the start coordinate of feature2 Returns : integer Args : none =cut sub hstart { return shift->feature2->start(@_); } =head2 hend Title : hend Usage : $end = $featpair->hend $featpair->hend($end) Function: get/set on the end coordinate of feature2 Returns : integer Args : none =cut sub hend { return shift->feature2->end(@_); } =head2 hstrand Title : hstrand Usage : $strand = $feat->strand() $feat->strand($strand) Function: get/set on strand information, being 1,-1 or 0 Returns : -1,1 or 0 Args : none =cut sub hstrand { return shift->feature2->strand(@_); } =head2 hscore Title : hscore Usage : $score = $feat->score() $feat->score($score) Function: get/set on score information Returns : float Args : none if get, the new value if set =cut sub hscore { return shift->feature2->score(@_); } =head2 hframe Title : hframe Usage : $frame = $feat->frame() $feat->frame($frame) Function: get/set on frame information Returns : 0,1,2 Args : none if get, the new value if set =cut sub hframe { return shift->feature2->frame(@_); } =head2 hprimary_tag Title : hprimary_tag Usage : $ptag = $featpair->hprimary_tag Function: Get/set on the primary_tag of feature2 Returns : 0,1,2 Args : none if get, the new value if set =cut sub hprimary_tag { return shift->feature2->primary_tag(@_); } =head2 hsource_tag Title : hsource_tag Usage : $tag = $feat->hsource_tag() $feat->source_tag('genscan'); Function: Returns the source tag for a feature, eg, 'genscan' Returns : a string Args : none =cut sub hsource_tag { return shift->feature2->source_tag(@_); } =head2 invert Title : invert Usage : $tag = $feat->invert Function: Swaps feature1 and feature2 around Returns : Nothing Args : none =cut sub invert { my ($self) = @_; my $tmp = $self->feature1; $self->feature1($self->feature2); $self->feature2($tmp); return 1; } =head2 feature_factory Title : feature_factory Usage : $obj->feature_factory($newval) Function: Get/set the feature object factory for this feature pair. The feature object factory will be used to create a feature object if feature1() or feature2() is called in get mode without having been set before. The default is an instance of Bio::Factory::ObjectFactory and hence allows the type to be changed dynamically at any time. Example : Returns : The feature object factory in use (a Bio::Factory::ObjectFactoryI compliant object) Args : on set, a Bio::Factory::ObjectFactoryI compliant object =cut sub feature_factory { my $self = shift; return $self->{'feature_factory'} = shift if @_; return $self->{'feature_factory'}; } ################################################################# # aliases for backwards compatibility # ################################################################# # seqname() is already aliased in Generic.pm, and we overwrite seq_id sub hseqname { my $self = shift; $self->warn("SeqFeatureI::seqname() is deprecated. Please use seq_id() instead."); return $self->hseq_id(@_); } sub cleanup_fp { my $self = shift; $self->{'feature1'} = $self->{'feature2'} = undef; } 1; ������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Generic.pm�����������������������������������������������������������000444��000765��000024�� 74406�12254227332� 20160� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Generic # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Generic - Generic SeqFeature =head1 SYNOPSIS $feat = Bio::SeqFeature::Generic->new( -start => 10, -end => 100, -strand => -1, -primary => 'repeat', # -primary_tag is a synonym -source_tag => 'repeatmasker', -display_name => 'alu family', -score => 1000, -tag => { new => 1, author => 'someone', sillytag => 'this is silly!' } ); $feat = Bio::SeqFeature::Generic->new( -gff_string => $string ); # if you want explicitly GFF1 $feat = Bio::SeqFeature::Generic->new( -gff1_string => $string ); # add it to an annotated sequence $annseq->add_SeqFeature($feat); =head1 DESCRIPTION Bio::SeqFeature::Generic is a generic implementation for the Bio::SeqFeatureI interface, providing a simple object to provide all the information for a feature on a sequence. For many Features, this is all you will need to use (for example, this is fine for Repeats in DNA sequence or Domains in protein sequence). For other features, which have more structure, this is a good base class to extend using inheritence to have new things: this is what is done in the L<Bio::SeqFeature::Gene>, L<Bio::SeqFeature::Transcript> and L<Bio::SeqFeature::Exon>, which provide well coordinated classes to represent genes on DNA sequence (for example, you can get the protein sequence out from a transcript class). For many Features, you want to add some piece of information, for example a common one is that this feature is 'new' whereas other features are 'old'. The tag system, which here is implemented using a hash can be used here. You can use the tag system to extend the L<Bio::SeqFeature::Generic> programmatically: that is, you know that you have read in more information into the tag 'mytag' which you can then retrieve. This means you do not need to know how to write inherited Perl to provide more complex information on a feature, and/or, if you do know but you do not want to write a new class every time you need some extra piece of information, you can use the tag system to easily store and then retrieve information. The tag system can be written in/out of GFF format, and also into EMBL format via the L<Bio::SeqIO> system =head1 Implemented Interfaces This class implements the following interfaces. =over 4 =item L<Bio::SeqFeatureI> Note that this includes implementing Bio::RangeI. =item L<Bio::AnnotatableI> =item L<Bio::FeatureHolderI> Features held by a feature are essentially sub-features. =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Ewan Birney E<lt>birney@sanger.ac.ukE<gt> =head1 DEVELOPERS This class has been written with an eye out for inheritance. The fields the actual object hash are: _gsf_tag_hash = reference to a hash for the tags _gsf_sub_array = reference to an array for subfeatures =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Generic; use strict; use Bio::Annotation::Collection; use Bio::Location::Simple; use Bio::Location::Split; use Bio::Tools::GFF; #use Tie::IxHash; use base qw(Bio::Root::Root Bio::SeqFeatureI Bio::FeatureHolderI Bio::AnnotatableI); sub new { my ( $caller, @args) = @_; my ($self) = $caller->SUPER::new(@args); $self->_register_for_cleanup(\&cleanup_generic); $self->{'_parse_h'} = {}; $self->{'_gsf_tag_hash'} = {}; # bulk-set attributes $self->set_attributes(@args); # done - we hope return $self; } =head2 set_attributes Title : set_attributes Usage : Function: Sets a whole array of parameters at once. Example : Returns : none Args : Named parameters, in the form as they would otherwise be passed to new(). Currently recognized are: -start start position -end end position -strand strand -phase the phase of the feature (0..2) -primary_tag primary tag -primary (synonym for -primary_tag) -source source tag -frame frame -score score value -tag a reference to a tag/value hash -gff_string GFF v.2 string to initialize from -gff1_string GFF v.1 string to initialize from -seq_id the display name of the sequence -annotation the AnnotationCollectionI object -location the LocationI object =cut sub set_attributes { my ($self,@args) = @_; my ($start, $end, $strand, $primary_tag, $source_tag, $primary, $source, $frame, $score, $tag, $gff_string, $gff1_string, $seqname, $seqid, $annot, $location,$display_name, $pid,$phase) = $self->_rearrange([qw(START END STRAND PRIMARY_TAG SOURCE_TAG PRIMARY SOURCE FRAME SCORE TAG GFF_STRING GFF1_STRING SEQNAME SEQ_ID ANNOTATION LOCATION DISPLAY_NAME PRIMARY_ID PHASE )], @args); $location && $self->location($location); $gff_string && $self->_from_gff_string($gff_string); $gff1_string && do { $self->gff_format(Bio::Tools::GFF->new('-gff_version' => 1)); $self->_from_gff_stream($gff1_string); }; $pid && $self->primary_id($pid); $primary_tag && $self->primary_tag($primary_tag); $source_tag && $self->source_tag($source_tag); $primary && $self->primary_tag($primary); $source && $self->source_tag($source); defined $start && $self->start($start); defined $end && $self->end($end); defined $strand && $self->strand($strand); defined $frame && $self->frame($frame); defined $display_name && $self->display_name($display_name); defined $score && $self->score($score); $annot && $self->annotation($annot); if($seqname) { $self->warn("-seqname is deprecated. Please use -seq_id instead."); $seqid = $seqname unless $seqid; } $self->seq_id($seqid) if (defined($seqid)); $tag && do { foreach my $t ( keys %$tag ) { $self->add_tag_value($t, UNIVERSAL::isa($tag->{$t}, "ARRAY") ? @{$tag->{$t}} : $tag->{$t}); } }; defined $phase && $self->phase($phase); } =head2 direct_new Title : direct_new Usage : my $feat = Bio::SeqFeature::Generic->direct_new; Function: create a blessed hash - for performance improvement in object creation Returns : Bio::SeqFeature::Generic object Args : none =cut sub direct_new { my ( $class) = @_; my ($self) = {}; bless $self,$class; return $self; } =head2 location Title : location Usage : my $location = $feat->location(); Function: returns a location object suitable for identifying location of feature on sequence or parent feature Returns : Bio::LocationI object Args : [optional] Bio::LocationI object to set the value to. =cut sub location { my($self, $value ) = @_; if (defined($value)) { unless (ref($value) and $value->isa('Bio::LocationI')) { $self->throw("object $value pretends to be a location but ". "does not implement Bio::LocationI"); } $self->{'_location'} = $value; } elsif (! $self->{'_location'}) { # guarantees a real location object is returned every time $self->{'_location'} = Bio::Location::Simple->new(); } return $self->{'_location'}; } =head2 start Title : start Usage : my $start = $feat->start; $feat->start(20); Function: Get/set on the start coordinate of the feature Returns : integer Args : none =cut sub start { my ($self, $value) = @_; # Return soon if setting value if (defined $value) { return $self->location->start($value); } return $self->location->start() if not defined $self->{'_gsf_seq'}; # Check circular sequences cut by origin my $start; if ( $self->{'_gsf_seq'}->is_circular and $self->location->isa('Bio::Location::SplitLocationI') ) { my $primary_seq_length = $self->{'_gsf_seq'}->length; my @sublocs = $self->location->sub_Location; my $cut_by_origin = 0; my ($a_end, $a_strand) = (0, 0); my ($b_start, $b_strand) = (0, 0); for (my $i = 1; $i < scalar @sublocs; $i++) { $a_end = $sublocs[$i-1]->end; $a_strand = $sublocs[$i-1]->strand; $b_start = $sublocs[$i]->start; $b_strand = $sublocs[$i]->strand; # cut by origin condition if ( $a_end == $primary_seq_length and $b_start == 1 and $a_strand == $b_strand ) { $cut_by_origin = 1; last; } } $start = ($cut_by_origin == 1) ? ($sublocs[0]->start) : ($self->location->start); } else { $start = $self->location->start; } return $start; } =head2 end Title : end Usage : my $end = $feat->end; $feat->end($end); Function: get/set on the end coordinate of the feature Returns : integer Args : none =cut sub end { my ($self, $value) = @_; # Return soon if setting value if (defined $value) { return $self->location->end($value); } return $self->location->end() if not defined $self->{'_gsf_seq'}; # Check circular sequences cut by origin my $end; if ( $self->{'_gsf_seq'}->is_circular and $self->location->isa('Bio::Location::SplitLocationI') ) { my $primary_seq_length = $self->{'_gsf_seq'}->length; my @sublocs = $self->location->sub_Location; my $cut_by_origin = 0; my ($a_end, $a_strand) = (0, 0); my ($b_start, $b_strand) = (0, 0); for (my $i = 1; $i < scalar @sublocs; $i++) { $a_end = $sublocs[$i-1]->end; $a_strand = $sublocs[$i-1]->strand; $b_start = $sublocs[$i]->start; $b_strand = $sublocs[$i]->strand; # cut by origin condition if ( $a_end == $primary_seq_length and $b_start == 1 and $a_strand == $b_strand ) { $cut_by_origin = 1; last; } } $end = ($cut_by_origin == 1) ? ($sublocs[-1]->end) : ($self->location->end); } else { $end = $self->location->end; } return $end; } =head2 length Title : length Usage : my $len = $feat->length; Function: Get the feature length computed as: $feat->end - $feat->start + 1 Returns : integer Args : none =cut sub length { my $self = shift; my $length = $self->end() - $self->start() + 1; # In circular sequences cut by origin $start > $end, # e.g., join(5075..5386,1..51)), $start = 5075, $end = 51, # then adjust using the primary_seq length (5386) if ($length < 0 and defined $self->{'_gsf_seq'}) { $length += $self->{'_gsf_seq'}->length; } return $length; } =head2 strand Title : strand Usage : my $strand = $feat->strand(); $feat->strand($strand); Function: get/set on strand information, being 1,-1 or 0 Returns : -1,1 or 0 Args : none =cut sub strand { my $self = shift; return $self->location->strand(@_); } =head2 score Title : score Usage : my $score = $feat->score(); $feat->score($score); Function: get/set on score information Returns : float Args : none if get, the new value if set =cut sub score { my $self = shift; if (@_) { my $value = shift; if ( defined $value && $value && $value !~ /^[A-Za-z]+$/ && $value !~ /^[+-]?\d+\.?\d*(e-\d+)?/ and $value != 0) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"'$value' is not a valid score", -value=>$value); } if ($self->has_tag('score')) { $self->warn("Removing score value(s)"); $self->remove_tag('score'); } $self->add_tag_value('score',$value); } my ($score) = $self->has_tag('score') ? $self->get_tag_values('score') : undef; return $score; } =head2 frame Title : frame Usage : my $frame = $feat->frame(); $feat->frame($frame); Function: get/set on frame information Returns : 0,1,2, '.' Args : none if get, the new value if set =cut sub frame { my $self = shift; if ( @_ ) { my $value = shift; if ( defined $value && $value !~ /^[0-2.]$/ ) { $self->throw("'$value' is not a valid frame"); } if( defined $value && $value eq '.' ) { $value = '.' } return $self->{'_gsf_frame'} = $value; } return $self->{'_gsf_frame'}; } =head2 primary_tag Title : primary_tag Usage : my $tag = $feat->primary_tag(); $feat->primary_tag('exon'); Function: get/set on the primary tag for a feature, eg 'exon' Returns : a string Args : none =cut sub primary_tag { my $self = shift; return $self->{'_primary_tag'} = shift if @_; return $self->{'_primary_tag'} || ''; } =head2 source_tag Title : source_tag Usage : my $tag = $feat->source_tag(); $feat->source_tag('genscan'); Function: Returns the source tag for a feature, eg, 'genscan' Returns : a string Args : none =cut sub source_tag { my $self = shift; return $self->{'_source_tag'} = shift if @_; return $self->{'_source_tag'} || ''; } =head2 has_tag Title : has_tag Usage : my $value = $feat->has_tag('some_tag'); Function: Tests wether a feature contaings a tag Returns : TRUE if the SeqFeature has the tag, and FALSE otherwise. Args : The name of a tag =cut sub has_tag { my ($self, $tag) = @_; return exists $_[0]->{'_gsf_tag_hash'}->{$tag}; } =head2 add_tag_value Title : add_tag_value Usage : $feat->add_tag_value('note',"this is a note"); Returns : TRUE on success Args : tag (string) and one or more values (any scalar(s)) =cut sub add_tag_value { my $self = shift; my $tag = shift; $self->{'_gsf_tag_hash'}->{$tag} ||= []; push(@{$self->{'_gsf_tag_hash'}->{$tag}},@_); } =head2 get_tag_values Title : get_tag_values Usage : my @values = $feat->get_tag_values('note'); Function: Returns a list of all the values stored under a particular tag. Returns : A list of scalars Args : The name of the tag =cut sub get_tag_values { my ($self, $tag) = @_; if( ! defined $tag ) { return (); } if ( ! exists $self->{'_gsf_tag_hash'}->{$tag} ) { $self->throw("asking for tag value that does not exist $tag"); } return @{$self->{'_gsf_tag_hash'}->{$tag}}; } =head2 get_all_tags Title : get_all_tags Usage : my @tags = $feat->get_all_tags(); Function: Get a list of all the tags in a feature Returns : An array of tag names Args : none # added a sort so that tags will be returned in a predictable order # I still think we should be able to specify a sort function # to the object at some point # -js =cut sub get_all_tags { my ($self, @args) = @_; return sort keys %{ $self->{'_gsf_tag_hash'}}; } =head2 remove_tag Title : remove_tag Usage : $feat->remove_tag('some_tag'); Function: removes a tag from this feature Returns : the array of values for this tag before removing it Args : tag (string) =cut sub remove_tag { my ($self, $tag) = @_; if ( ! exists $self->{'_gsf_tag_hash'}->{$tag} ) { $self->throw("trying to remove a tag that does not exist: $tag"); } my @vals = @{$self->{'_gsf_tag_hash'}->{$tag}}; delete $self->{'_gsf_tag_hash'}->{$tag}; return @vals; } =head2 attach_seq Title : attach_seq Usage : $feat->attach_seq($seq); Function: Attaches a Bio::Seq object to this feature. This Bio::Seq object is for the *entire* sequence: ie from 1 to 10000 Example : Returns : TRUE on success Args : a Bio::PrimarySeqI compliant object =cut sub attach_seq { my ($self, $seq) = @_; if ( ! ($seq && ref($seq) && $seq->isa("Bio::PrimarySeqI")) ) { $self->throw("Must attach Bio::PrimarySeqI objects to SeqFeatures but got '".ref($seq)."'"); } $self->{'_gsf_seq'} = $seq; # attach to sub features if they want it foreach ( $self->sub_SeqFeature() ) { $_->attach_seq($seq); } return 1; } =head2 seq Title : seq Usage : my $tseq = $feat->seq(); Function: returns the truncated sequence (if there) for this Example : Returns : sub seq (a Bio::PrimarySeqI compliant object) on attached sequence bounded by start & end, or undef if there is no sequence attached Args : none =cut sub seq { my ($self, $arg) = @_; if ( defined $arg ) { $self->throw("Calling SeqFeature::Generic->seq with an argument. You probably want attach_seq"); } if ( ! exists $self->{'_gsf_seq'} ) { return; } # assumming our seq object is sensible, it should not have to yank # the entire sequence out here. my $seq = $self->{'_gsf_seq'}->trunc($self->start(), $self->end()); if ( defined $self->strand && $self->strand == -1 ) { # ok. this does not work well (?) #print STDERR "Before revcom", $seq->str, "\n"; $seq = $seq->revcom; #print STDERR "After revcom", $seq->str, "\n"; } return $seq; } =head2 entire_seq Title : entire_seq Usage : my $whole_seq = $feat->entire_seq(); Function: gives the entire sequence that this seqfeature is attached to Example : Returns : a Bio::PrimarySeqI compliant object, or undef if there is no sequence attached Args : =cut sub entire_seq { return shift->{'_gsf_seq'}; } =head2 seq_id Title : seq_id Usage : $feat->seq_id($newval) Function: There are many cases when you make a feature that you do know the sequence name, but do not know its actual sequence. This is an attribute such that you can store the ID (e.g., display_id) of the sequence. This attribute should *not* be used in GFF dumping, as that should come from the collection in which the seq feature was found. Returns : value of seq_id Args : newvalue (optional) =cut sub seq_id { my $obj = shift; return $obj->{'_gsf_seq_id'} = shift if @_; return $obj->{'_gsf_seq_id'}; } =head2 display_name Title : display_name Usage : my $featname = $feat->display_name; Function: Implements the display_name() method, which is a human-readable name for the feature. Returns : value of display_name (a string) Args : Optionally, on set the new value or undef =cut sub display_name { my $self = shift; return $self->{'display_name'} = shift if @_; return $self->{'display_name'} || ''; } =head1 Methods for implementing Bio::AnnotatableI =head2 annotation Title : annotation Usage : $feat->annotation($annot_obj); Function: Get/set the annotation collection object for annotating this feature. Example : Returns : A Bio::AnnotationCollectionI object Args : newvalue (optional) =cut sub annotation { my ($obj,$value) = @_; # we are smart if someone references the object and there hasn't been # one set yet if(defined $value || ! defined $obj->{'annotation'} ) { $value = Bio::Annotation::Collection->new() unless ( defined $value ); $obj->{'annotation'} = $value; } return $obj->{'annotation'}; } =head1 Methods to implement Bio::FeatureHolderI This includes methods for retrieving, adding, and removing features. Since this is already a feature, features held by this feature holder are essentially sub-features. =head2 get_SeqFeatures Title : get_SeqFeatures Usage : my @feats = $feat->get_SeqFeatures(); Function: Returns an array of sub Sequence Features Returns : An array Args : none =cut sub get_SeqFeatures { return @{ shift->{'_gsf_sub_array'} || []}; } =head2 add_SeqFeature Title : add_SeqFeature Usage : $feat->add_SeqFeature($subfeat); $feat->add_SeqFeature($subfeat,'EXPAND'); Function: Adds a SeqFeature into the subSeqFeature array. With no 'EXPAND' qualifer, subfeat will be tested as to whether it lies inside the parent, and throw an exception if not. If EXPAND is used, the parent's start/end/strand will be adjusted so that it grows to accommodate the new subFeature !IMPORTANT! The coordinates of the subfeature should not be relative to the parent feature it is attached to, but relative to the sequence the parent feature is located on. Returns : nothing Args : An object which has the SeqFeatureI interface =cut sub add_SeqFeature { my ($self,$feat,$expand) = @_; unless( defined $feat ) { $self->warn("Called add_SeqFeature with no feature, ignoring"); return; } if ( !$feat->isa('Bio::SeqFeatureI') ) { $self->warn("$feat does not implement Bio::SeqFeatureI. Will add it anyway, but beware..."); } if($expand && ($expand eq 'EXPAND')) { $self->_expand_region($feat); } else { if ( !$self->contains($feat) ) { $self->throw("$feat is not contained within parent feature, and expansion is not valid"); } } $self->{'_gsf_sub_array'} = [] unless exists($self->{'_gsf_sub_array'}); push(@{$self->{'_gsf_sub_array'}},$feat); } =head2 remove_SeqFeatures Title : remove_SeqFeatures Usage : $feat->remove_SeqFeatures; Function: Removes all SeqFeatures If you want to remove only a subset of features then remove that subset from the returned array, and add back the rest. Example : Returns : The array of Bio::SeqFeatureI implementing features that was deleted. Args : none =cut sub remove_SeqFeatures { my ($self) = @_; my @subfeats = @{$self->{'_gsf_sub_array'} || []}; $self->{'_gsf_sub_array'} = []; # zap the array implicitly. return @subfeats; } =head1 GFF-related methods =head2 gff_format Title : gff_format Usage : # get: my $gffio = $feat->gff_format(); # set (change the default version of GFF2): $feat->gff_format(Bio::Tools::GFF->new(-gff_version => 1)); Function: Get/set the GFF format interpreter. This object is supposed to format and parse GFF. See Bio::Tools::GFF for the interface. If this method is called as class method, the default for all newly created instances will be changed. Otherwise only this instance will be affected. Example : Returns : a Bio::Tools::GFF compliant object Args : On set, an instance of Bio::Tools::GFF or a derived object. =cut sub gff_format { my ($self, $gffio) = @_; if(defined($gffio)) { if(ref($self)) { $self->{'_gffio'} = $gffio; } else { $Bio::SeqFeatureI::static_gff_formatter = $gffio; } } return (ref($self) && exists($self->{'_gffio'}) ? $self->{'_gffio'} : $self->_static_gff_formatter); } =head2 gff_string Title : gff_string Usage : my $str = $feat->gff_string; my $str = $feat->gff_string($gff_formatter); Function: Provides the feature information in GFF format. We override this here from Bio::SeqFeatureI in order to use the formatter returned by gff_format(). Returns : A string Args : Optionally, an object implementing gff_string(). =cut sub gff_string { my ($self,$formatter) = @_; $formatter = $self->gff_format() unless $formatter; return $formatter->gff_string($self); } =head2 slurp_gff_file Title : slurp_file Usage : my @features = Bio::SeqFeature::Generic::slurp_gff_file(\*FILE); Function: Sneaky function to load an entire file as in memory objects. Beware of big files. This method is deprecated. Use Bio::Tools::GFF instead, which can also handle large files. Example : Returns : Args : =cut sub slurp_gff_file { my ($f) = @_; my @out; if ( !defined $f ) { Bio::Root::Root->throw("Must have a filehandle"); } Bio::Root::Root->deprecated( -message => "deprecated method slurp_gff_file() called in Bio::SeqFeature::Generic. Use Bio::Tools::GFF instead.", -warn_version => '1.005', -throw_version => '1.007', ); while(<$f>) { my $sf = Bio::SeqFeature::Generic->new('-gff_string' => $_); push(@out, $sf); } return @out; } =head2 _from_gff_string Title : _from_gff_string Usage : Function: Set feature properties from GFF string. This method uses the object returned by gff_format() for the actual interpretation of the string. Set a different GFF format interpreter first if you need a specific version, like GFF1. (The default is GFF2.) Example : Returns : Args : a GFF-formatted string =cut sub _from_gff_string { my ($self, $string) = @_; $self->gff_format()->from_gff_string($self, $string); } =head2 _expand_region Title : _expand_region Usage : $feat->_expand_region($feature); Function: Expand the total region covered by this feature to accommodate for the given feature. May be called whenever any kind of subfeature is added to this feature. add_SeqFeature() already does this. Returns : Args : A Bio::SeqFeatureI implementing object. =cut sub _expand_region { my ($self, $feat) = @_; if(! $feat->isa('Bio::SeqFeatureI')) { $self->warn("$feat does not implement Bio::SeqFeatureI"); } # if this doesn't have start set - forget it! # changed to reflect sanity checks for LocationI if(!$self->location->valid_Location) { $self->start($feat->start); $self->end($feat->end); $self->strand($feat->strand) unless $self->strand; } else { my ($start,$end,$strand) = $self->union($feat); $self->start($start); $self->end($end); $self->strand($strand); } } =head2 _parse Title : _parse Usage : Function: Parsing hints Example : Returns : Args : =cut sub _parse { my ($self) = @_; return $self->{'_parse_h'}; } =head2 _tag_value Title : _tag_value Usage : Function: For internal use only. Convenience method for those tags that may only have a single value. Returns : The first value under the given tag as a scalar (string) Args : The tag as a string. Optionally, the value on set. =cut sub _tag_value { my $self = shift; my $tag = shift; if(@_ || (! $self->has_tag($tag))) { $self->remove_tag($tag) if($self->has_tag($tag)); $self->add_tag_value($tag, @_); } return ($self->get_tag_values($tag))[0]; } ####################################################################### # aliases for methods that changed their names in an attempt to make # # bioperl names more consistent # ####################################################################### sub seqname { my $self = shift; $self->warn("SeqFeatureI::seqname() is deprecated. Please use seq_id() instead."); return $self->seq_id(@_); } sub display_id { my $self = shift; $self->warn("SeqFeatureI::display_id() is deprecated. Please use display_name() instead."); return $self->display_name(@_); } # this is towards consistent naming sub each_tag_value { return shift->get_tag_values(@_); } sub all_tags { return shift->get_all_tags(@_); } # we revamped the feature containing property to implementing # Bio::FeatureHolderI *sub_SeqFeature = \&get_SeqFeatures; *add_sub_SeqFeature = \&add_SeqFeature; *flush_sub_SeqFeatures = \&remove_SeqFeatures; # this one is because of inconsistent naming ... *flush_sub_SeqFeature = \&remove_SeqFeatures; sub cleanup_generic { my $self = shift; foreach my $f ( @{$self->{'_gsf_sub_array'} || []} ) { $f = undef; } $self->{'_gsf_seq'} = undef; foreach my $t ( keys %{$self->{'_gsf_tag_hash'} } ) { $self->{'_gsf_tag_hash'}->{$t} = undef; delete($self->{'_gsf_tag_hash'}->{$t}); # bug 1720 fix } } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Lite.pm��������������������������������������������������������������000444��000765��000024�� 60030�12254227320� 17462� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package Bio::SeqFeature::Lite; =head1 NAME Bio::SeqFeature::Lite - Lightweight Bio::SeqFeatureI class =head1 SYNOPSIS # create a simple feature with no internal structure $f = Bio::SeqFeature::Lite->new(-start => 1000, -stop => 2000, -type => 'transcript', -name => 'alpha-1 antitrypsin', -desc => 'an enzyme inhibitor', ); # create a feature composed of multiple segments, all of type "similarity" $f = Bio::SeqFeature::Lite->new(-segments => [[1000,1100],[1500,1550],[1800,2000]], -name => 'ABC-3', -type => 'gapped_alignment', -subtype => 'similarity'); # build up a gene exon by exon $e1 = Bio::SeqFeature::Lite->new(-start=>1,-stop=>100,-type=>'exon'); $e2 = Bio::SeqFeature::Lite->new(-start=>150,-stop=>200,-type=>'exon'); $e3 = Bio::SeqFeature::Lite->new(-start=>300,-stop=>500,-type=>'exon'); $f = Bio::SeqFeature::Lite->new(-segments=>[$e1,$e2,$e3],-type=>'gene'); =head1 DESCRIPTION This is a simple Bio::SeqFeatureI-compliant object that is compatible with Bio::Graphics::Panel. With it you can create lightweight feature objects for drawing. All methods are as described in L<Bio::SeqFeatureI> with the following additions: =head2 The new() Constructor $feature = Bio::SeqFeature::Lite->new(@args); This method creates a new feature object. You can create a simple feature that contains no subfeatures, or a hierarchically nested object. Arguments are as follows: -seq_id the reference sequence -start the start position of the feature -end the stop position of the feature -stop an alias for end -name the feature name (returned by seqname()) -type the feature type (returned by primary_tag()) -primary_tag the same as -type -source the source tag -score the feature score (for GFF compatibility) -desc a description of the feature -segments a list of subfeatures (see below) -subtype the type to use when creating subfeatures -strand the strand of the feature (one of -1, 0 or +1) -phase the phase of the feature (0..2) -seq a dna or protein sequence string to attach to feature -id an alias for -name -seqname an alias for -name -display_id an alias for -name -display_name an alias for -name (do you get the idea the API has changed?) -primary_id unique database ID -url a URL to link to when rendered with Bio::Graphics -attributes a hashref of tag value attributes, in which the key is the tag and the value is an array reference of values -factory a reference to a feature factory, used for compatibility with more obscure parts of Bio::DB::GFF The subfeatures passed in -segments may be an array of Bio::SeqFeature::Lite objects, or an array of [$start,$stop] pairs. Each pair should be a two-element array reference. In the latter case, the feature type passed in -subtype will be used when creating the subfeatures. If no feature type is passed, then it defaults to "feature". =head2 Non-SeqFeatureI methods A number of new methods are provided for compatibility with Ace::Sequence, which has a slightly different API from SeqFeatureI: =over 4 =item url() Get/set the URL that the graphical rendering of this feature will link to. =item add_segment(@segments) Add one or more segments (a subfeature). Segments can either be Feature objects, or [start,stop] arrays, as in the -segments argument to new(). The feature endpoints are automatically adjusted. =item segments() An alias for sub_SeqFeature(). =item get_SeqFeatures() Alias for sub_SeqFeature() =item get_all_SeqFeatures() Alias for sub_SeqFeature() =item merged_segments() Another alias for sub_SeqFeature(). =item stop() An alias for end(). =item name() An alias for seqname(). =item exons() An alias for sub_SeqFeature() (you don't want to know why!) =back =cut use strict; use base qw(Bio::Root::Root Bio::SeqFeatureI Bio::LocationI Bio::SeqI); *stop = \&end; *info = \&name; *seqname = \&name; *exons = *sub_SeqFeature = *merged_segments = \&segments; *get_all_SeqFeatures = *get_SeqFeatures = \&segments; *method = \&primary_tag; *source = \&source_tag; *get_tag_values = \&each_tag_value; *add_SeqFeature = \&add_segment; *get_all_tags = \&all_tags; *abs_ref = \&ref; # implement Bio::SeqI and FeatureHolderI interface sub primary_seq { return $_[0] } sub annotation { my ($obj,$value) = @_; if( defined $value ) { $obj->throw("object of class ".ref($value)." does not implement ". "Bio::AnnotationCollectionI. Too bad.") unless $value->isa("Bio::AnnotationCollectionI"); $obj->{'_annotation'} = $value; } elsif( ! defined $obj->{'_annotation'}) { $obj->{'_annotation'} = Bio::Annotation::Collection->new(); } return $obj->{'_annotation'}; } sub species { my ($self, $species) = @_; if ($species) { $self->{'species'} = $species; } else { return $self->{'species'}; } } sub is_remote { return } sub feature_count { return scalar @{shift->{segments} || []} } sub target { return; } sub hit { shift->target } sub type { my $self = shift; my $method = $self->primary_tag; my $source = $self->source_tag; return $source ne '' ? "$method:$source" : $method; } # usage: # Bio::SeqFeature::Lite->new( # -start => 1, # -end => 100, # -name => 'fred feature', # -strand => +1); # # Alternatively, use -segments => [ [start,stop],[start,stop]...] # to create a multisegmented feature. sub new { my $class= shift; $class = ref($class) if ref $class; my %arg = @_; my $self = bless {},$class; $arg{-strand} ||= 0; if ($arg{-strand} =~ /^[\+\-\.]$/){ $arg{-strand} = "+" && $self->{strand} ='1'; $arg{-strand} = "-" && $self->{strand} = '-1'; $arg{-strand} = "." && $self->{strand} = '0'; } else { $self->{strand} = $arg{-strand} ? ($arg{-strand} >= 0 ? +1 : -1) : 0; } $self->{name} = $arg{-name} || $arg{-seqname} || $arg{-display_id} || $arg{-display_name} || $arg{-id}; $self->{type} = $arg{-type} || $arg{-primary_tag} || 'feature'; $self->{subtype} = $arg{-subtype} if exists $arg{-subtype}; $self->{source} = $arg{-source} || $arg{-source_tag} || ''; $self->{score} = $arg{-score} if exists $arg{-score}; $self->{start} = $arg{-start}; $self->{stop} = exists $arg{-end} ? $arg{-end} : $arg{-stop}; $self->{ref} = $arg{-seq_id} || $arg{-ref}; $self->{attributes} = $arg{-attributes} || $arg{-tag}; for my $option (qw(class url seq phase desc primary_id)) { $self->{$option} = $arg{"-$option"} if exists $arg{"-$option"}; } # is_circular is needed for Bio::PrimarySeqI compliance $self->{is_circular} = $arg{-is_circular} || 0; # fix start, stop if (defined $self->{stop} && defined $self->{start} && $self->{stop} < $self->{start}) { @{$self}{'start','stop'} = @{$self}{'stop','start'}; $self->{strand} *= -1; } my @segments; if (my $s = $arg{-segments}) { # NB: when $self ISA Bio::DB::SeqFeature the following invokes # Bio::DB::SeqFeature::add_segment and not # Bio::DB::SeqFeature::add_segment (as might be expected?) $self->add_segment(@$s); } $self; } sub add_segment { my $self = shift; my $type = $self->{subtype} || $self->{type}; $self->{segments} ||= []; my $ref = $self->seq_id; my $name = $self->name; my $class = $self->class; my $source_tag = $self->source_tag; my $min_start = $self->start || 999_999_999_999; my $max_stop = $self->end || -999_999_999_999; my @segments = @{$self->{segments}}; for my $seg (@_) { if (ref($seg) eq 'ARRAY') { my ($start,$stop) = @{$seg}; next unless defined $start && defined $stop; # fixes an obscure bug somewhere above us my $strand = $self->{strand}; if ($start > $stop) { ($start,$stop) = ($stop,$start); $strand = -1; } push @segments,$self->new(-start => $start, -stop => $stop, -strand => $strand, -ref => $ref, -type => $type, -name => $name, -class => $class, -phase => $self->{phase}, -score => $self->{score}, -source_tag => $source_tag, -attributes => $self->{attributes}, ); $min_start = $start if $start < $min_start; $max_stop = $stop if $stop > $max_stop; } elsif (ref $seg) { push @segments,$seg; $min_start = $seg->start if ($seg->start && $seg->start < $min_start); $max_stop = $seg->end if ($seg->end && $seg->end > $max_stop); } } if (@segments) { local $^W = 0; # some warning of an uninitialized variable... $self->{segments} = \@segments; $self->{ref} ||= $self->{segments}[0]->seq_id; $self->{start} = $min_start; $self->{stop} = $max_stop; } } sub segments { my $self = shift; my $s = $self->{segments} or return wantarray ? () : 0; @$s; } sub score { my $self = shift; my $d = $self->{score}; $self->{score} = shift if @_; $d; } sub primary_tag { my $self = shift; my $d = $self->{type}; $self->{type} = shift if @_; $d; } sub name { my $self = shift; my $d = $self->{name}; $self->{name} = shift if @_; $d; } sub seq_id { shift->ref(@_) } sub ref { my $self = shift; my $d = $self->{ref}; $self->{ref} = shift if @_; $d; } sub start { my $self = shift; my $d = $self->{start}; $self->{start} = shift if @_; if (my $rs = $self->{refseq}) { my $strand = $rs->strand || 1; return $strand >= 0 ? ($d - $rs->start + 1) : ($rs->end - $d + 1); } else { return $d; } } sub end { my $self = shift; my $d = $self->{stop}; $self->{stop} = shift if @_; if (my $rs = $self->{refseq}) { my $strand = $rs->strand || 1; return $strand >= 0 ? ($d - $rs->start + 1) : ($rs->end - $d + 1); } $d; } sub strand { my $self = shift; my $d = $self->{strand}; $self->{strand} = shift if @_; if (my $rs = $self->{refseq}) { my $rstrand = $rs->strand; return 0 unless $d; return 1 if $rstrand == $d; return -1 if $rstrand != $d; } $d; } # this does nothing, but it is here for compatibility reasons sub absolute { my $self = shift; my $d = $self->{absolute}; $self->{absolute} = shift if @_; $d; } sub abs_start { my $self = shift; local $self->{refseq} = undef; $self->start(@_); } sub abs_end { my $self = shift; local $self->{refseq} = undef; $self->end(@_); } sub abs_strand { my $self = shift; local $self->{refseq} = undef; $self->strand(@_); } sub length { my $self = shift; return $self->end - $self->start + 1; } #is_circular is needed for Bio::PrimarySeqI sub is_circular { my $self = shift; my $d = $self->{is_circular}; $self->{is_circular} = shift if @_; $d; } sub seq { my $self = shift; my $seq = exists $self->{seq} ? $self->{seq} : ''; return $seq; } sub dna { my $seq = shift->seq; $seq = $seq->seq if CORE::ref($seq); return $seq; } =head2 display_name Title : display_name Usage : $id = $obj->display_name or $obj->display_name($newid); Function: Gets or sets the display id, also known as the common name of the Seq object. The semantics of this is that it is the most likely string to be used as an identifier of the sequence, and likely to have "human" readability. The id is equivalent to the LOCUS field of the GenBank/EMBL databanks and the ID field of the Swissprot/sptrembl database. In fasta format, the >(\S+) is presumed to be the id, though some people overload the id to embed other information. Bioperl does not use any embedded information in the ID field, and people are encouraged to use other mechanisms (accession field for example, or extending the sequence object) to solve this. Notice that $seq->id() maps to this function, mainly for legacy/convenience issues. Returns : A string Args : None or a new id =cut sub display_name { shift->name(@_) } *display_id = \&display_name; =head2 accession_number Title : accession_number Usage : $unique_biological_key = $obj->accession_number; Function: Returns the unique biological id for a sequence, commonly called the accession_number. For sequences from established databases, the implementors should try to use the correct accession number. Notice that primary_id() provides the unique id for the implemetation, allowing multiple objects to have the same accession number in a particular implementation. For sequences with no accession number, this method should return "unknown". Returns : A string Args : None =cut sub accession_number { return 'unknown'; } =head2 alphabet Title : alphabet Usage : if( $obj->alphabet eq 'dna' ) { /Do Something/ } Function: Returns the type of sequence being one of 'dna', 'rna' or 'protein'. This is case sensitive. This is not called <type> because this would cause upgrade problems from the 0.5 and earlier Seq objects. Returns : a string either 'dna','rna','protein'. NB - the object must make a call of the type - if there is no type specified it has to guess. Args : none Status : Virtual =cut sub alphabet{ return 'dna'; # no way this will be anything other than dna! } =head2 desc Title : desc Usage : $seqobj->desc($string) or $seqobj->desc() Function: Sets or gets the description of the sequence Example : Returns : The description Args : The description or none =cut sub desc { my $self = shift; my ($d) = $self->notes; $self->{desc} = shift if @_; $d; } sub attributes { my $self = shift; if (@_) { return $self->get_tag_values(@_); } else { return $self->{attributes} ? %{$self->{attributes}} : (); } } sub primary_id { my $self = shift; my $d = $self->{primary_id}; $self->{primary_id} = shift if @_; return $d; # return $d if defined $d; # return (overload::StrVal($self) =~ /0x([a-f0-9]+)/)[0]; } sub notes { my $self = shift; my $notes = $self->{desc}; return $notes if defined $notes; return $self->attributes('Note'); } sub aliases { my $self = shift; return $self->attributes('Alias'); } sub low { my $self = shift; return $self->start < $self->end ? $self->start : $self->end; } sub high { my $self = shift; return $self->start > $self->end ? $self->start : $self->end; } =head2 location Title : location Usage : my $location = $seqfeature->location() Function: returns a location object suitable for identifying location of feature on sequence or parent feature Returns : Bio::LocationI object Args : none =cut sub location { my $self = shift; require Bio::Location::Split unless Bio::Location::Split->can('new'); my $location; if (my @segments = $self->segments) { $location = Bio::Location::Split->new(); foreach (@segments) { $location->add_sub_Location($_); } } else { $location = $self; } $location; } sub each_Location { my $self = shift; require Bio::Location::Simple unless Bio::Location::Simple->can('new'); if (my @segments = $self->segments) { return map { Bio::Location::Simple->new(-start => $_->start, -end => $_->end, -strand => $_->strand); } @segments; } else { return Bio::Location::Simple->new(-start => $self->start, -end => $self->end, -strand => $self->strand); } } =head2 location_string Title : location_string Usage : my $string = $seqfeature->location_string() Function: Returns a location string in a format recognized by gbrowse Returns : a string Args : none This is a convenience function used by the generic genome browser. It returns the location of the feature and its subfeatures in the compact form "start1..end1,start2..end2,...". Use $seqfeature-E<gt>location()-E<gt>toFTString() to obtain a standard GenBank/EMBL location representation. =cut sub location_string { my $self = shift; my @segments = $self->segments or return $self->to_FTstring; join ',',map {$_->to_FTstring} @segments; } sub coordinate_policy { require Bio::Location::WidestCoordPolicy unless Bio::Location::WidestCoordPolicy->can('new'); return Bio::Location::WidestCoordPolicy->new(); } sub min_start { shift->low } sub max_start { shift->low } sub min_end { shift->high } sub max_end { shift->high} sub start_pos_type { 'EXACT' } sub end_pos_type { 'EXACT' } sub to_FTstring { my $self = shift; my $low = $self->min_start; my $high = $self->max_end; my $strand = $self->strand; my $str = defined $strand && $strand<0 ? "complement($low..$high)" : "$low..$high"; if (my $id = $self->seq_id()) { $str = $id . ":" . $str; } $str; } sub phase { my $self = shift; my $d = $self->{phase}; $self->{phase} = shift if @_; $d; } sub class { my $self = shift; my $d = $self->{class}; $self->{class} = shift if @_; return defined($d) ? $d : 'Sequence'; # acedb is still haunting me - LS } # set GFF dumping version sub version { my $self = shift; my $d = $self->{gff3_version} || 2; $self->{gff3_version} = shift if @_; $d; } sub gff_string { my $self = shift; if ($self->version == 3) { return $self->gff3_string(@_); } my $recurse = shift; my $name = $self->name; my $class = $self->class; my $group = "$class $name" if $name; my $strand = ('-','.','+')[$self->strand+1]; my $string; $string .= join("\t", $self->ref||'.',$self->source||'.',$self->method||'.', $self->start||'.',$self->stop||'.', defined($self->score) ? $self->score : '.', $strand||'.', defined($self->phase) ? $self->phase : '.', $group||'' ); $string .= "\n"; if ($recurse) { foreach ($self->sub_SeqFeature) { $string .= $_->gff_string($recurse); } } $string; } # Suggested strategy for dealing with the multiple parentage issue. # First recurse through object tree and record parent tree. # Then recurse again, skipping objects we've seen before. sub gff3_string { my ($self,$recurse,$parent_tree,$seenit,$force_id) = @_; $parent_tree ||= {}; $seenit ||= {}; my @rsf = (); my @parent_ids; if ($recurse) { $self->_traverse($parent_tree) unless %$parent_tree; # this will record parents of all children my $primary_id = defined $force_id ? $force_id : $self->_real_or_dummy_id; return if $seenit->{$primary_id}++; @rsf = $self->get_SeqFeatures; if (@rsf) { # Detect case in which we have a split location feature. In this case we # skip to the grandchildren and trick them into thinking that our parent is theirs. my %types = map {$_->primary_tag=>1} @rsf; my @types = keys %types; if (@types == 1 && $types[0] eq $self->primary_tag) { return join ("\n",map {$_->gff3_string(1,$parent_tree,{},$primary_id)} @rsf); } } @parent_ids = keys %{$parent_tree->{$primary_id}}; } my $group = $self->format_attributes(\@parent_ids,$force_id); my $name = $self->name; my $class = $self->class; my $strand = ('-','.','+')[$self->strand+1]; my $p = join("\t", $self->seq_id||'.', $self->source||'.', $self->method||'.', $self->start||'.', $self->stop||'.', defined($self->score) ? $self->score : '.', $strand||'.', defined($self->phase) ? $self->phase : '.', $group||''); return join("\n", $p, map {$_->gff3_string(1,$parent_tree,$seenit)} @rsf); } sub _real_or_dummy_id { my $self = shift; my $id = $self->primary_id; return $id if defined $id; return return (overload::StrVal($self) =~ /0x([a-f0-9]+)/)[0]; } sub _traverse { my $self = shift; my $tree = shift; # tree => {$child}{$parent} = 1 my $parent = shift; my $id = $self->_real_or_dummy_id; defined $id or return; $tree->{$id}{$parent->_real_or_dummy_id}++ if $parent; $_->_traverse($tree,$self) foreach $self->get_SeqFeatures; } sub db { return } sub source_tag { my $self = shift; my $d = $self->{source}; $self->{source} = shift if @_; $d; } # This probably should be deleted. Not sure why it's here, but might # have been added for Ace::Sequence::Feature-compliance. sub introns { my $self = shift; return; } sub has_tag { my $self = shift; my $tag = shift; return exists $self->{attributes}{$tag}; } sub escape { my $self = shift; my $toencode = shift; $toencode =~ s/([^a-zA-Z0-9_.:?^*\(\)\[\]@!+-])/uc sprintf("%%%02x",ord($1))/eg; $toencode; } sub all_tags { my $self = shift; return keys %{$self->{attributes}}; } sub add_tag_value { my $self = shift; my ($tag_name,@tag_values) = @_; push @{$self->{attributes}{$tag_name}},@tag_values; } sub remove_tag { my $self = shift; my $tag_name = shift; delete $self->{attributes}{$tag_name}; } sub each_tag_value { my $self = shift; my $tag = shift; my $value = $self->{attributes}{$tag} or return; my $ref = CORE::ref $value; return $ref && $ref eq 'ARRAY' ? @{$self->{attributes}{$tag}} : $self->{attributes}{$tag}; } sub get_Annotations { my $self = shift; my $tag = shift; my @values = $self->get_tag_values($tag); return $values[0] if @values == 1; return @values; } sub format_attributes { my $self = shift; my $parent = shift; my $fallback_id = shift; my @tags = $self->get_all_tags; my @result; for my $t (@tags) { my @values = $self->get_tag_values($t); push @result,join '=',$self->escape($t),join(',', map {$self->escape($_)} @values) if @values; } #my $id = $self->escape($self->_real_or_dummy_id) || $fallback_id; my $id = $fallback_id || $self->escape($self->_real_or_dummy_id); my $parent_id; if (@$parent) { $parent_id = join (',',map {$self->escape($_)} @$parent); } my $name = $self->display_name; unshift @result,"ID=".$id if defined $id; unshift @result,"Parent=".$parent_id if defined $parent_id; unshift @result,"Name=".$self->escape($name) if defined $name; return join ';',@result; } =head2 clone Title : clone Usage : my $feature = $seqfeature->clone Function: Create a deep copy of the feature Returns : A copy of the feature Args : none =cut sub clone { my $self = shift; my %clone = %$self; # overwrite attributes my $clone = bless \%clone,CORE::ref($self); $clone{attributes} = {}; for my $k (keys %{$self->{attributes}}) { @{$clone{attributes}{$k}} = @{$self->{attributes}{$k}}; } return $clone; } =head2 refseq Title : refseq Usage : $ref = $s->refseq([$newseq] [,$newseqclass]) Function: get/set reference sequence Returns : current reference sequence Args : new reference sequence and class (optional) Status : Public This method will get or set the reference sequence. Called with no arguments, it returns the current reference sequence. Called with any Bio::SeqFeatureI object that provides the seq_id(), start(), end() and strand() methods. The method will generate an exception if you attempt to set the reference sequence to a sequence that has a different seq_id from the current feature. =cut sub refseq { my $self = shift; my $d = $self->{refseq}; if (@_) { my $newref = shift; $self->throw("attempt to set refseq using a feature that does not share the same seq_id") unless $newref->seq_id eq $self->seq_id; $self->{refseq} = $newref; } return $d; } sub DESTROY { } 1; __END__ =head1 SEE ALSO L<Bio::Graphics::Feature> =head1 AUTHOR Lincoln Stein E<lt>lstein@cshl.eduE<gt>. Copyright (c) 2006 Cold Spring Harbor Laboratory This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See DISCLAIMER.txt for disclaimers of warranty. =cut ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/PositionProxy.pm�����������������������������������������������������000444��000765��000024�� 22331�12254227321� 21436� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::PositionProxy # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::PositionProxy - handle features when truncation/revcom sequences span a feature =head1 SYNOPSIS $proxy = Bio::SeqFeature::PositionProxy->new( -loc => $loc, -parent => $basefeature); $seq->add_SeqFeature($feat); =head1 DESCRIPTION PositionProxy is a Proxy Sequence Feature to handle truncation and revcomp without duplicating all the data within the sequence features. It holds a new location for a sequence feature and the original feature it came from to provide the additional annotation information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Ewan Birney E<lt>birney@sanger.ac.ukE<gt> =head1 DEVELOPERS This class has been written with an eye out of inheritence. The fields the actual object hash are: _gsf_tag_hash = reference to a hash for the tags _gsf_sub_array = reference to an array for sub arrays _gsf_start = scalar of the start point _gsf_end = scalar of the end point _gsf_strand = scalar of the strand =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::PositionProxy; use strict; use Bio::Tools::GFF; use base qw(Bio::Root::Root Bio::SeqFeatureI); sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); my ($feature,$location) = $self->_rearrange([qw(PARENT LOC)],@args); if( !defined $feature || !ref $feature || !$feature->isa('Bio::SeqFeatureI') ) { $self->throw("Must have a parent feature, not a [$feature]"); } if( $feature->isa("Bio::SeqFeature::PositionProxy") ) { $feature = $feature->parent(); } if( !defined $location || !ref $location || !$location->isa('Bio::LocationI') ) { $self->throw("Must have a location, not a [$location]"); } return $self; } =head2 location Title : location Usage : my $location = $seqfeature->location() Function: returns a location object suitable for identifying location of feature on sequence or parent feature Returns : Bio::LocationI object Args : none =cut sub location { my($self, $value ) = @_; if (defined($value)) { unless (ref($value) and $value->isa('Bio::LocationI')) { $self->throw("object $value pretends to be a location but ". "does not implement Bio::LocationI"); } $self->{'_location'} = $value; } elsif (! $self->{'_location'}) { # guarantees a real location object is returned every time $self->{'_location'} = Bio::Location::Simple->new(); } return $self->{'_location'}; } =head2 parent Title : parent Usage : my $sf = $proxy->parent() Function: returns the seqfeature parent of this proxy Returns : Bio::SeqFeatureI object Args : none =cut sub parent { my($self, $value ) = @_; if (defined($value)) { unless (ref($value) and $value->isa('Bio::SeqFeatureI')) { $self->throw("object $value pretends to be a location but ". "does not implement Bio::SeqFeatureI"); } $self->{'_parent'} = $value; } return $self->{'_parent'}; } =head2 start Title : start Usage : $start = $feat->start $feat->start(20) Function: Get Returns : integer Args : none =cut sub start { my ($self,$value) = @_; return $self->location->start($value); } =head2 end Title : end Usage : $end = $feat->end $feat->end($end) Function: get Returns : integer Args : none =cut sub end { my ($self,$value) = @_; return $self->location->end($value); } =head2 length Title : length Usage : Function: Example : Returns : Args : =cut sub length { my ($self) = @_; return $self->end - $self->start() + 1; } =head2 strand Title : strand Usage : $strand = $feat->strand() $feat->strand($strand) Function: get/set on strand information, being 1,-1 or 0 Returns : -1,1 or 0 Args : none =cut sub strand { my ($self,$value) = @_; return $self->location->strand($value); } =head2 attach_seq Title : attach_seq Usage : $sf->attach_seq($seq) Function: Attaches a Bio::Seq object to this feature. This Bio::Seq object is for the *entire* sequence: ie from 1 to 10000 Example : Returns : TRUE on success Args : =cut sub attach_seq { my ($self, $seq) = @_; if ( !defined $seq || !ref $seq || ! $seq->isa("Bio::PrimarySeqI") ) { $self->throw("Must attach Bio::PrimarySeqI objects to SeqFeatures"); } $self->{'_gsf_seq'} = $seq; # attach to sub features if they want it foreach my $sf ( $self->sub_SeqFeature() ) { if ( $sf->can("attach_seq") ) { $sf->attach_seq($seq); } } return 1; } =head2 seq Title : seq Usage : $tseq = $sf->seq() Function: returns the truncated sequence (if there) for this Example : Returns : sub seq on attached sequence bounded by start & end Args : none =cut sub seq { my ($self, $arg) = @_; if ( defined $arg ) { $self->throw("Calling SeqFeature::PositionProxy->seq with an argument. You probably want attach_seq"); } if ( ! exists $self->{'_gsf_seq'} ) { return; } # assumming our seq object is sensible, it should not have to yank # the entire sequence out here. my $seq = $self->{'_gsf_seq'}->trunc($self->start(), $self->end()); if ( $self->strand == -1 ) { $seq = $seq->revcom; } return $seq; } =head2 entire_seq Title : entire_seq Usage : $whole_seq = $sf->entire_seq() Function: gives the entire sequence that this seqfeature is attached to Example : Returns : Args : =cut sub entire_seq { my ($self) = @_; return unless exists($self->{'_gsf_seq'}); return $self->{'_gsf_seq'}; } =head2 seqname Title : seqname Usage : $obj->seq_id($newval) Function: There are many cases when you make a feature that you do know the sequence name, but do not know its actual sequence. This is an attribute such that you can store the seqname. This attribute should *not* be used in GFF dumping, as that should come from the collection in which the seq feature was found. Returns : value of seqname Args : newvalue (optional) =cut sub seqname { my ($obj,$value) = @_; if ( defined $value ) { $obj->{'_gsf_seqname'} = $value; } return $obj->{'_gsf_seqname'}; } =head2 Proxies These functions chain back to the parent for all non sequence related stuff. =cut =head2 primary_tag Title : primary_tag Usage : $tag = $feat->primary_tag() Function: Returns the primary tag for a feature, eg 'exon' Returns : a string Args : none =cut sub primary_tag { my ($self,@args) = @_; return $self->parent->primary_tag(); } =head2 source_tag Title : source_tag Usage : $tag = $feat->source_tag() Function: Returns the source tag for a feature, eg, 'genscan' Returns : a string Args : none =cut sub source_tag { my ($self) = @_; return $self->parent->source_tag(); } =head2 has_tag Title : has_tag Usage : $tag_exists = $self->has_tag('some_tag') Function: Returns : TRUE if the specified tag exists, and FALSE otherwise Args : =cut sub has_tag { my ($self,$tag) = @_; return $self->parent->has_tag($tag); } =head2 get_tag_values Title : get_tag_values Usage : @values = $self->get_tag_values('some_tag') Function: Returns : An array comprising the values of the specified tag. Args : =cut *each_tag_value = \&get_tag_values; sub get_tag_values { my ($self,$tag) = @_; return $self->parent->get_tag_values($tag); } =head2 get_all_tags Title : get_all_tags Usage : @tags = $feat->get_all_tags() Function: gives all tags for this feature Returns : an array of strings Args : none =cut *all_tags = \&get_all_tags; sub get_all_tags { my ($self) = @_; return $self->parent->all_tags(); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Primer.pm������������������������������������������������������������000444��000765��000024�� 30127�12254227340� 20031� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Primer # # This is the original copyright statement. I have relied on Chad's module # extensively for this module. # # Copyright (c) 1997-2001 bioperl, Chad Matsalla. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # # But I have modified lots of it, so I guess I should add: # # Copyright (c) 2003 bioperl, Rob Edwards. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Primer - Primer Generic SeqFeature =head1 SYNOPSIS use Bio::SeqFeature::Primer; # Primer object with explicitly-defined sequence object or sequence string my $primer = Bio::SeqFeature::Primer->new( -seq => 'ACGTAGCT' ); $primer->display_name('test_id'); print "These are the details of the primer:\n". "Name: ".$primer->display_name."\n". "Tag: ".$primer->primary_tag."\n". # always 'Primer' "Sequence: ".$primer->seq->seq."\n". "Tm: ".$primer->Tm."\n\n"; # melting temperature # Primer object with implicit sequence object # It is a lighter approach for when the primer location on a template is known use Bio::Seq; my $template = Bio::Seq->new( -seq => 'ACGTAGCTCTTTTCATTCTGACTGCAACG' ); $primer = Bio::SeqFeature::Primer->new( -start => 1, -end =>5, -strand => 1 ); $template->add_SeqFeature($primer); print "Primer sequence is: ".$primer->seq->seq."\n"; # Primer sequence is 'ACGTA' =head1 DESCRIPTION This module handles PCR primer sequences. The L<Bio::SeqFeature::Primer> object is a L<Bio::SeqFeature::Subseq> object that can additionally contain a primer sequence and its coordinates on a template sequence. The primary_tag() for this object is 'Primer'. A method is provided to calculate the melting temperature Tm of the primer. L<Bio::SeqFeature::Primer> objects are useful to build L<Bio::Seq::PrimedSeq> amplicon objects such as the ones returned by L<Bio::Tools::Primer3>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Rob Edwards, redwards@utmem.edu The original concept and much of the code was written by Chad Matsalla, bioinformatics1@dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqFeature::Primer; use strict; use Bio::PrimarySeq; use Bio::Tools::SeqStats; use base qw(Bio::SeqFeature::SubSeq); =head2 new() Title : new() Usage : my $primer = Bio::SeqFeature::Primer( -seq => $seq_object ); Function: Instantiate a new Bio::SeqFeature::Primer object Returns : A Bio::SeqFeature::Primer object Args : -seq , a sequence object or a sequence string (optional) -id , the ID to give to the primer sequence, not feature (optional) =cut sub new { my ($class, %args) = @_; # Legacy stuff my $sequence = delete $args{-sequence}; if ($sequence) { Bio::Root::Root->deprecated( -message => 'Creating a Bio::SeqFeature::Primer with -sequence is deprecated. Use -seq instead.', -warn_version => '1.006', -throw_version => '1.008', ); $args{-seq} = $sequence; } # Initialize Primer object my $self = $class->SUPER::new(%args); my ($id) = $self->_rearrange([qw(ID)], %args); $id && $self->seq->id($id); $self->primary_tag('Primer'); return $self; } # Bypass B::SF::Generic's location() when a string is passed (for compatibility) sub location { my ($self, $location) = @_; if ($location) { if ( not ref $location ) { # Use location as a string for backward compatibility Bio::Root::Root->deprecated( -message => 'Passing a string to location() is deprecated. Pass a Bio::Location::Simple object or use start() and end() instead.', -warn_version => '1.006', -throw_version => '1.008', ); $self->{'_location'} = $location; } else { $self->SUPER::location($location); } } return $self->SUPER::location; } =head2 Tm() Title : Tm() Usage : my $tm = $primer->Tm(-salt => 0.05, -oligo => 0.0000001); Function: Calculate the Tm (melting temperature) of the primer Returns : A scalar containing the Tm. Args : -salt : set the Na+ concentration on which to base the calculation (default=0.05 molar). : -oligo : set the oligo concentration on which to base the calculation (default=0.00000025 molar). Notes : Calculation of Tm as per Allawi et. al Biochemistry 1997 36:10581-10594. Also see documentation at http://www.idtdna.com/Scitools/Scitools.aspx as they use this formula and have a couple nice help pages. These Tm values will be about are about 0.5-3 degrees off from those of the idtdna web tool. I don't know why. This was suggested by Barry Moore (thanks!). See the discussion on the bioperl-l with the subject "Bio::SeqFeature::Primer Calculating the PrimerTM" =cut sub Tm { my ($self, %args) = @_; my $salt_conc = 0.05; # salt concentration (molar units) my $oligo_conc = 0.00000025; # oligo concentration (molar units) if ($args{'-salt'}) { # Accept object defined salt concentration $salt_conc = $args{'-salt'}; } if ($args{'-oligo'}) { # Accept object defined oligo concentration $oligo_conc = $args{'-oligo'}; } my $seqobj = $self->seq(); my $length = $seqobj->length(); my $sequence = uc $seqobj->seq(); my @dinucleotides; my $enthalpy; my $entropy; # Break sequence string into an array of all possible dinucleotides while ($sequence =~ /(.)(?=(.))/g) { push @dinucleotides, $1.$2; } # Build a hash with the thermodynamic values my %thermo_values = ('AA' => {'enthalpy' => -7.9, 'entropy' => -22.2}, 'AC' => {'enthalpy' => -8.4, 'entropy' => -22.4}, 'AG' => {'enthalpy' => -7.8, 'entropy' => -21}, 'AT' => {'enthalpy' => -7.2, 'entropy' => -20.4}, 'CA' => {'enthalpy' => -8.5, 'entropy' => -22.7}, 'CC' => {'enthalpy' => -8, 'entropy' => -19.9}, 'CG' => {'enthalpy' => -10.6, 'entropy' => -27.2}, 'CT' => {'enthalpy' => -7.8, 'entropy' => -21}, 'GA' => {'enthalpy' => -8.2, 'entropy' => -22.2}, 'GC' => {'enthalpy' => -9.8, 'entropy' => -24.4}, 'GG' => {'enthalpy' => -8, 'entropy' => -19.9}, 'GT' => {'enthalpy' => -8.4, 'entropy' => -22.4}, 'TA' => {'enthalpy' => -7.2, 'entropy' => -21.3}, 'TC' => {'enthalpy' => -8.2, 'entropy' => -22.2}, 'TG' => {'enthalpy' => -8.5, 'entropy' => -22.7}, 'TT' => {'enthalpy' => -7.9, 'entropy' => -22.2}, 'A' => {'enthalpy' => 2.3, 'entropy' => 4.1}, 'C' => {'enthalpy' => 0.1, 'entropy' => -2.8}, 'G' => {'enthalpy' => 0.1, 'entropy' => -2.8}, 'T' => {'enthalpy' => 2.3, 'entropy' => 4.1} ); # Loop through dinucleotides and calculate cumulative enthalpy and entropy values for (@dinucleotides) { $enthalpy += $thermo_values{$_}{enthalpy}; $entropy += $thermo_values{$_}{entropy}; } # Account for initiation parameters $enthalpy += $thermo_values{substr($sequence, 0, 1)}{enthalpy}; $entropy += $thermo_values{substr($sequence, 0, 1)}{entropy}; $enthalpy += $thermo_values{substr($sequence, -1, 1)}{enthalpy}; $entropy += $thermo_values{substr($sequence, -1, 1)}{entropy}; # Symmetry correction $entropy -= 1.4; my $r = 1.987; # molar gas constant my $tm = $enthalpy * 1000 / ($entropy + ($r * log($oligo_conc))) - 273.15 + (12* (log($salt_conc)/log(10))); return $tm; } =head2 Tm_estimate Title : Tm_estimate Usage : my $tm = $primer->Tm_estimate(-salt => 0.05); Function: Estimate the Tm (melting temperature) of the primer Returns : A scalar containing the Tm. Args : -salt set the Na+ concentration on which to base the calculation. Notes : This is only an estimate of the Tm that is kept in for comparative reasons. You should probably use Tm instead! This Tm calculations are taken from the Primer3 docs: They are based on Bolton and McCarthy, PNAS 84:1390 (1962) as presented in Sambrook, Fritsch and Maniatis, Molecular Cloning, p 11.46 (1989, CSHL Press). Tm = 81.5 + 16.6(log10([Na+])) + .41*(%GC) - 600/length where [Na+] is the molar sodium concentration, %GC is the %G+C of the sequence, and length is the length of the sequence. However.... I can never get this calculation to give me the same result as primer3 does. Don't ask why, I never figured it out. But I did want to include a Tm calculation here because I use these modules for other things besides reading primer3 output. The primer3 calculation is saved as 'PRIMER_LEFT_TM' or 'PRIMER_RIGHT_TM' and this calculation is saved as $primer->Tm so you can get both and average them! =cut sub Tm_estimate { # This should probably be put into seqstats as it is more generic, but what the heck. my ($self, %args) = @_; my $salt = 0.2; if ($args{'-salt'}) { $salt = $args{'-salt'} }; my $seqobj = $self->seq(); my $length = $seqobj->length(); my $seqdata = Bio::Tools::SeqStats->count_monomers($seqobj); my $gc=$$seqdata{'G'} + $$seqdata{'C'}; my $percent_gc = ($gc/$length)*100; my $tm = 81.5+(16.6*(log($salt)/log(10)))+(0.41*$percent_gc) - (600/$length); return $tm; } =head2 primary_tag, source_tag, location, start, end, strand... The documentation of L<Bio::SeqFeature::Generic> describes all the methods that L<Bio::SeqFeature::Primer> object inherit. =cut 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Similarity.pm��������������������������������������������������������000444��000765��000024�� 11015�12254227323� 20715� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Similarity # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Similarity - A sequence feature based on similarity =head1 SYNOPSIS # obtain a similarity feature somehow print "significance: ", $sim_fea->significance(), "\n"; print "bit score: ", $sim_fea->bits(), "\n"; print "score: ", $sim_fea->score(), "\n"; print "fraction of identical residues: ", $sim_fea->frac_identical(), "\n"; =head1 DESCRIPTION This module is basically a sequence features based on similarity, and therefore has support for measures assessing the similarity. Everything else is inherited from L<Bio::SeqFeature::Generic>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net or hilmar.lapp@pharma.novartis.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Similarity; use strict; use base qw(Bio::SeqFeature::Generic); sub new { my ( $caller, @args) = @_; my ($self) = $caller->SUPER::new(@args); my ($primary,$evalue, $bits, $frac,$seqlen,$seqdesc) = $self->_rearrange([qw(PRIMARY EXPECT BITS FRAC SEQLENGTH SEQDESC )],@args); defined $evalue && $self->significance($evalue); defined $bits && $self->bits($bits); defined $frac && $self->frac_identical($frac); defined $seqlen && $self->seqlength($seqlen); defined $seqdesc && $self->seqdesc($seqdesc); $primary = 'similarity' unless defined $primary; $self->primary_tag($primary) unless( defined $self->primary_tag() ); $self->strand(0) unless( defined $self->strand() ); return $self; } =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Returns : Args : =cut sub significance { return shift->_tag_value('signif', @_); } =head2 bits Title : bits Usage : $bits = $obj->bits(); $obj->bits($value); Function: Returns : Args : =cut sub bits { return shift->_tag_value('Bits', @_); } =head2 frac_identical Title : frac_identical Usage : $fracid = $obj->frac_identical(); $obj->frac_identical($value); Function: Returns : Args : =cut sub frac_identical { return shift->_tag_value('FracId', @_); } =head2 seqlength Title : seqlength Usage : $len = $obj->seqlength(); $obj->seqlength($len); Function: Returns : Args : =cut sub seqlength { return shift->_tag_value('SeqLength', @_); } =head2 seqdesc Title : seqdesc Usage : $desc = $obj->seqdesc(); $obj->seqdesc($desc); Function: At present this method is a shorthand for $obj->annotation()->description(). Note that this is not stored in the tag system and hence will not be included in the return value of gff_string(). Returns : Args : =cut sub seqdesc { my ( $self, $value ) = @_; if ( defined $value ) { my $v = Bio::Annotation::SimpleValue->new(); $v->value($value); $self->annotation->add_Annotation( 'description', $v ); } my ($v) = $self->annotation()->get_Annotations('description'); return defined $v ? $v->value : undef; } # # Everything else is just inherited from SeqFeature::Generic. # 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/SimilarityPair.pm����������������������������������������������������000444��000765��000024�� 16525�12254227324� 21545� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::SimilarityPair # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::SimilarityPair - Sequence feature based on the similarity of two sequences. =head1 SYNOPSIS $sim_pair = Bio::SeqFeature::SimilarityPair->from_searchResult($blastHit); $sim = $sim_pair->query(); # a Bio::SeqFeature::Similarity object - the query $sim = $sim_pair->hit(); # dto - the hit. # some properties for the similarity pair $expect = $sim_pair->significance(); $score = $sim_pair->score(); $bitscore = $sim_pair->bits(); # this will not write the description for the sequence (only its name) print $sim_pair->query()->gff_string(), "\n"; =head1 DESCRIPTION Lightweight similarity search result as a pair of Similarity features. This class inherits off Bio::SeqFeature::FeaturePair and therefore implements Bio::SeqFeatureI, whereas the two features of the pair are descendants of Bio::SeqFeature::Generic, with better support for representing similarity search results in a cleaner way. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net or hilmar.lapp@pharma.novartis.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::SimilarityPair; use strict; use Bio::SeqFeature::Similarity; use Bio::Factory::ObjectFactory; use base qw(Bio::SeqFeature::FeaturePair); =head2 new Title : new Usage : my $similarityPair = Bio::SeqFeature::SimilarityPair->new (-hit => $hit, -query => $query, -source => 'blastp'); Function: Initializes a new SimilarityPair object Returns : Bio::SeqFeature::SimilarityPair Args : -query => The query in a Feature pair -hit => (formerly '-subject') the subject/hit in a Feature pair =cut sub new { my($class,@args) = @_; if(! grep { lc($_) eq "-feature_factory"; } @args) { # if no overriding factory is provided, provide our preferred one my $fact = Bio::Factory::ObjectFactory->new( -type => "Bio::SeqFeature::Similarity", -interface => "Bio::SeqFeatureI"); push(@args, '-feature_factory', $fact); } my $self = $class->SUPER::new(@args); my ($primary, $hit, $query, $fea1, $source,$sbjct) = $self->_rearrange([qw(PRIMARY HIT QUERY FEATURE1 SOURCE SUBJECT )],@args); if( $sbjct ) { # undeprecated by Jason before 1.1 release # $self->deprecated("use of -subject deprecated: SimilarityPair now uses 'hit'"); if(! $hit) { $hit = $sbjct } else { $self->warn("-hit and -subject were specified, using -hit and ignoring -subject"); } } # set the query and subject feature if provided $self->query( $query) if $query && ! $fea1; $hit && $self->hit($hit); # the following refer to feature1, which is guaranteed to exist if( defined $primary || ! defined $self->primary_tag) { $primary = 'similarity' unless defined $primary; $self->primary_tag($primary); } $source && $self->source_tag($source); return $self; } # # Everything else is just inherited from SeqFeature::FeaturePair. # =head2 query Title : query Usage : $query_feature = $obj->query(); $obj->query($query_feature); Function: The query object for this similarity pair Returns : Bio::SeqFeature::Similarity Args : [optional] Bio::SeqFeature::Similarity See L<Bio::SeqFeature::Similarity>, L<Bio::SeqFeature::FeaturePair> =cut sub query { return shift->feature1(@_); } =head2 subject Title : subject Usage : $sbjct_feature = $obj->subject(); $obj->subject($sbjct_feature); Function: Get/Set Subject for a SimilarityPair Returns : Bio::SeqFeature::Similarity Args : [optional] Bio::SeqFeature::Similarity Notes : Deprecated. Use the method 'hit' instead =cut sub subject { my $self = shift; # $self->deprecated("Method subject deprecated: use hit() instead"); $self->hit(@_); } =head2 hit Title : hit Usage : $sbjct_feature = $obj->hit(); $obj->hit($sbjct_feature); Function: Get/Set Hit for a SimilarityPair Returns : Bio::SeqFeature::Similarity Args : [optional] Bio::SeqFeature::Similarity =cut sub hit { return shift->feature2(@_); } =head2 source_tag Title : source_tag Usage : $source = $obj->source_tag(); # i.e., program $obj->source_tag($evalue); Function: Gets the source tag (program name typically) for a feature Returns : string Args : [optional] string =cut sub source_tag { my ($self, @args) = @_; if(@args) { $self->hit()->source_tag(@args); } return $self->query()->source_tag(@args); } =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Returns : Args : =cut sub significance { my ($self, @args) = @_; if(@args) { $self->hit()->significance(@args); } return $self->query()->significance(@args); } =head2 score Title : score Usage : $score = $obj->score(); $obj->score($value); Function: Returns : Args : =cut sub score { my ($self, @args) = @_; if(@args) { $self->hit()->score(@args); } # Note: You might think it's only getting set on the hit object. # Actually, it's getting set on both hit and query. return $self->query()->score(@args); } =head2 bits Title : bits Usage : $bits = $obj->bits(); $obj->bits($value); Function: Returns : Args : =cut sub bits { my ($self, @args) = @_; if(@args) { $self->hit()->bits(@args); } return $self->query()->bits(@args); } ################################################################# # aliases for backwards compatibility or convenience # ################################################################# *sbjct = \&subject; 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/SubSeq.pm������������������������������������������������������������000444��000765��000024�� 14170�12254227317� 20001� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::SubSeq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Copyright Florent Angly # # You may distribute this module under the same terms as perl itself =head1 NAME Bio::SeqFeature::SubSeq - Feature representing a subsequence =head1 SYNOPSIS # SubSeq with implicit sequence use Bio::Seq; my $template = Bio::Seq->new( -seq => 'AAAAACCCCCGGGGGTTTTT' ); $subseq = Bio::SeqFeature::Amplicon->new( -start => 6, -end => 15, -template => $template, ); print "Subsequence is: ".$amplicon->seq->seq."\n"; # Should be 'CCCCCGGGGG' # SubSeq with explicit sequence use Bio::SeqFeature::Subseq; my $subseq = Bio::SeqFeature::Amplicon->new( -seq => $seq_object, ); =head1 DESCRIPTION Bio::SeqFeature::SubSeq extends L<Bio::SeqFeature::Generic> features to represent a subsequence. When this feature is attached to a template sequence, the sequence of feature is the subsequence of the template at this location. The purpose of this class is to represent a sequence as a feature without having to explictly store its sequence string. Of course, you might have reasons to explicitly set a sequence. In that case, note that the length of the sequence is allowed to not match the position of the feature. For example, you can set sequence of length 10 in a SubSeq feature that spans positions 30 to 50 of the template if you so desire. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Florent Angly <florent.angly@gmail.com> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqFeature::SubSeq; use strict; use base qw(Bio::SeqFeature::Generic); =head2 new Title : new() Usage : my $subseq = Bio::SeqFeature::SubSeq( -start => 1, -end => 10, -strand => -1); Function: Instantiate a new Bio::SeqFeature::SubSeq feature object Args : -seq , the sequence object or sequence string of the feature (optional) -template , attach the feature to the provided parent template sequence or feature (optional). Note that you must specify the feature location to do this. -start, -end, -location, -strand and all other L<Bio::SeqFeature::Generic> argument can be used. Returns : A Bio::SeqFeature::SubSeq object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($seq, $template) = $self->_rearrange([qw(SEQ TEMPLATE)], @args); if (defined $seq) { # Set the subsequence explicitly if (not ref $seq) { # Convert string to sequence object $seq = Bio::PrimarySeq->new( -seq => $seq ); } else { # Sanity check if (not $seq->isa('Bio::PrimarySeqI')) { $self->throw("Expected a sequence object but got a '".ref($seq)."'\n"); } } $self->seq($seq); } if ($template) { if ( not($self->start) || not($self->end) ) { $self->throw('Could not attach feature to template $template because'. ' the feature location was not specified.'); } # Need to attach to parent sequence and then add sequence feature my $template_seq; if ($template->isa('Bio::SeqFeature::Generic')) { $template_seq = $template->entire_seq; } elsif ($template->isa('Bio::SeqI')) { $template_seq = $template; } else { $self->throw("Expected a Bio::SeqFeature::Generic or Bio::SeqI object". " as template, but got '$template'."); } $self->attach_seq($template_seq); $template->add_SeqFeature($self); } return $self; } =head2 seq Title : seq() Usage : my $seq = $subseq->seq(); Function: Get or set the sequence object of this SubSeq feature. If no sequence was provided, but the subseq is attached to a sequence, get the corresponding subsequence. Returns : A sequence object or undef Args : None. =cut sub seq { my ($self, $value) = @_; if (defined $value) { # The sequence is explicit if ( not(ref $value) || not $value->isa('Bio::PrimarySeqI') ) { $self->throw("Expected a sequence object but got a '".ref($value)."'\n"); } $self->{seq} = $value; } my $seq = $self->{seq}; if (not defined $seq) { # The sequence is implied $seq = $self->SUPER::seq; } return $seq; } =head2 length Title : seq() Usage : my $length = $subseq->seq(); Function: Get the length of the SubSeq feature. It is similar to the length() method of L<Bio::Generic::SeqFeature>, which computes length based on the location of the feature. However, if the feature was not given a location, return the length of the subsequence if possible. Returns : integer or undef Args : None. =cut sub length { my ($self) = @_; # Try length from location first if ($self->start && $self->end) { return $self->SUPER::length(); } # Then try length from subsequence my $seq = $self->seq; if (defined $seq) { return length $seq->seq; } # We failed return undef; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/TypedSeqFeatureI.pm��������������������������������������������������000444��000765��000024�� 6313�12254227326� 21742� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::TypedSeqFeatureI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::TypedSeqFeatureI - a strongly typed SeqFeature =head1 SYNOPSIS # get Sequence Features in some manner, eg # from a Sequence object foreach $sf ( $seq->get_SeqFeatures() ) { # all sequence features must have primary_tag() return a string $type_as_string = $sf->primary_tag(); if( $sf->isa("Bio::SeqFeature::TypedSeqFeatureI") ) { $ot = $sf->ontology_term(); print "Ontology identifier:",$ot->identifier(), " name:",$ot->name(), " Description:",$ot->description(),"\n"; } else { print "Sequence Feature does not have an ontology type\n"; } } =head1 DESCRIPTION This interface describes the extension of SeqFeatureI to being a strongly typed SeqFeature. Bio::SeqFeature::TypedSeqFeatureI extends the Bio::SeqFeatureI interface (ie, a TypedSeqFeatureI feature must also implement all the Bio::SeqFeatureI interface as well). It is suggested that the primary_tag() method of SeqFeatureI return the same as the ontology_term()-E<gt>name() of the OntologyTypedI (ie, the "string" name of the ontology type is used as the primary tag), but this should not be assummed by client code as they are scenarios where one would like to maintain the difference. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email - please email the BioPerl mailing list above. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::TypedSeqFeatureI; use strict; use Bio::Root::RootI; use base qw(Bio::SeqFeatureI); =head2 ontology_term Title : ontology_term Usage : my $ot = $seqfeature->ontology_term() Returns : a Bio::Ontology::TermI compliant object Args : none Status : public This method returns the ontology term for a strongly typed sequence feature. =cut sub ontology_term { shift->throw_not_implemented(); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene�����������������������������������������������������������������000755��000765��000024�� 0�12254227340� 16733� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/Exon.pm���������������������������������������������������������000444��000765��000024�� 14265�12254227312� 20366� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::Exon # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::Exon - a feature representing an exon =head1 SYNOPSIS # obtain an exon instance $exon somehow print "exon from ", $exon->start(), " to ", $exon->end(), " on seq ", $exon->seq_id(), ", strand ", $exon->strand(), ", encodes the peptide sequence ", $exon->cds()->translate()->seq(), "\n"; =head1 DESCRIPTION This module implements a feature representing an exon by implementing the Bio::SeqFeature::Gene::ExonI interface. By default an Exon is coding. Supply -is_coding =E<gt> 0 to the constructor or call $exon-E<gt>is_coding(0) otherwise. Apart from that, this class also implements Bio::SeqFeatureI by inheriting off Bio::SeqFeature::Generic. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::Exon; use strict; use base qw(Bio::SeqFeature::Generic Bio::SeqFeature::Gene::ExonI); # # A list of allowed exon types. See primary_tag(). # my @valid_exon_types = ('initial', 'internal', 'terminal'); sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); my ($is_coding) = $self->_rearrange([qw(IS_CODING)],@args); $self->primary_tag('exon') unless $self->primary_tag(); $self->is_coding(defined($is_coding) ? $is_coding : 1); $self->strand(0) if(! defined($self->strand())); return $self; } =head2 is_coding Title : is_coding Usage : if($exon->is_coding()) { # do something } if($is_utr) { $exon->is_coding(0); } Function: Get/set whether or not the exon codes for amino acid. Returns : TRUE if the object represents a feature translated into protein, and FALSE otherwise. Args : A boolean value on set. =cut sub is_coding { my ($self,$val) = @_; if(defined($val)) { $self->{'_iscoding'} = $val; } return $self->{'_iscoding'}; } =head2 primary_tag Title : primary_tag Usage : $tag = $feat->primary_tag() $feat->primary_tag('exon') Function: Get/set the primary tag for the exon feature. This method is overridden here in order to allow only for tag values following a certain convention. For consistency reasons, the tag value must either contain the string 'exon' or the string 'utr' (both case-insensitive). In the case of 'exon', a string describing the type of exon may be appended or prefixed. Presently, the following types are allowed: initial, internal, and terminal (all case-insensitive). If the supplied tag value matches 'utr' (case-insensitive), is_coding() will automatically be set to FALSE, and to TRUE otherwise. Returns : A string. Args : A string on set. =cut # sub primary_tag { # my ($self,$value) = @_; # if(defined($value)) { # if((lc($value) =~ /utr/i) || (lc($value) eq "exon") || # ((lc($value) =~ /exon/i) && # (grep { $value =~ /$_/i; } @valid_exon_types))) { # $self->is_coding($value =~ /utr/i ? 0 : 1); # } else { # $self->throw("primary tag $value is invalid for object of class ". # ref($self)); # } # } # return $self->SUPER::primary_tag($value); # } =head2 location Title : location Usage : my $location = $exon->location() Function: Returns a location object suitable for identifying the location of the exon on the sequence or parent feature. This method is overridden here to restrict allowed location types to non-compound locations. Returns : Bio::LocationI object Args : none =cut sub location { my ($self,$value) = @_; if(defined($value) && $value->isa('Bio::Location::SplitLocationI')) { $self->throw("split or compound location is not allowed ". "for an object of type " . ref($self)); } return $self->SUPER::location($value); } =head2 cds Title : cds() Usage : $cds = $exon->cds(); Function: Get the coding sequence of the exon as a sequence object. The sequence of the returned object is prefixed by Ns (lower case) if the frame of the exon is defined and different from zero. The result is that the first base starts a codon (frame 0). This implementation returns undef if the particular exon is not translated to protein, i.e., is_coding() returns FALSE. Undef will also be returned if no sequence is attached to this exon feature. Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub cds { my ($self) = @_; # UTR is not translated return if(! $self->is_coding()); my $seq = $self->seq(); if(defined($seq) && defined($self->frame()) && ($self->frame() != 0)) { my $prefix = "n" x $self->frame(); $seq->seq($prefix . $seq->seq()); } return $seq; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/ExonI.pm��������������������������������������������������������000444��000765��000024�� 5447�12254227317� 20466� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::ExonI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::ExonI - Interface for a feature representing an exon =head1 SYNOPSIS See documentation of methods. =head1 DESCRIPTION A feature representing an exon. An exon in this definition is transcribed and at least for one particular transcript not spliced out of the pre-mRNA. However, it does not necessarily code for amino acid. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::ExonI; use strict; use base qw(Bio::SeqFeatureI); =head2 is_coding Title : is_coding Usage : if($exon->is_coding()) { # do something } Function: Whether or not the exon codes for amino acid. Returns : TRUE if the object represents a feature translated into protein, and FALSE otherwise. Args : =cut sub is_coding { my ($self) = @_; $self->throw_not_implemented(); } =head2 cds Title : cds() Usage : $cds = $exon->cds(); Function: Get the coding sequence of the exon as a sequence object. The returned sequence object must be in frame 0, i.e., the first base starts a codon. An implementation may return undef, indicating that a coding sequence does not exist, e.g. for a UTR (untranslated region). Returns : A L<Bio::PrimarySeqI> implementing object. Args : =cut sub cds { my ($self) = @_; $self->throw_not_implemented(); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/GeneStructure.pm������������������������������������������������000444��000765��000024�� 24552�12254227340� 22255� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::GeneStructure # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::GeneStructure - A feature representing an arbitrarily complex structure of a gene =head1 SYNOPSIS # See documentation of methods. =head1 DESCRIPTION A feature representing a gene structure. As of now, a gene structure really is only a collection of transcripts. See L<Bio::SeqFeature::Gene::TranscriptI> (interface) and L<Bio::SeqFeature::Gene::Transcript> (implementation) for the features of such objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp-at-gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::GeneStructure; use vars qw($WeakRefs); use strict; BEGIN { eval "use Scalar::Util qw(weaken);"; if ($@) { $Bio::SeqFeature::Gene::GeneStructure::WeakRefs = 0; } else { $Bio::SeqFeature::Gene::GeneStructure::WeakRefs = 1; } } use base qw(Bio::SeqFeature::Generic Bio::SeqFeature::Gene::GeneStructureI); sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); $self->_register_for_cleanup(\&gene_cleanup); my ($primary) = $self->_rearrange([qw(PRIMARY )],@args); $primary = 'genestructure' unless $primary; $self->primary_tag($primary); $self->strand(0) if(! defined($self->strand())); return $self; } =head2 transcripts Title : transcripts Usage : @transcripts = $gene->transcripts(); Function: Get the transcripts of this gene structure. Many gene structures will have only one transcript. Returns : An array of Bio::SeqFeature::Gene::TranscriptI implementing objects. Args : =cut sub transcripts { return @{shift->{'_transcripts'} || []}; } =head2 add_transcript Title : add_transcript() Usage : $gene->add_transcript($transcript); Function: Add a transcript to this gene structure. Returns : Args : A Bio::SeqFeature::Gene::TranscriptI implementing object. =cut sub add_transcript { my ($self, $fea) = @_; if(!$fea || ! $fea->isa('Bio::SeqFeature::Gene::TranscriptI') ) { $self->throw("$fea does not implement Bio::SeqFeature::Gene::TranscriptI"); } unless( exists $self->{'_transcripts'} ) { $self->{'_transcripts'} = []; } $self->_expand_region($fea); if( $Bio::SeqFeature::Gene::GeneStructure::WeakRefs ) { $fea->parent(weaken $self); } else { $fea->parent($self); } push(@{$self->{'_transcripts'}}, $fea); } =head2 flush_transcripts Title : flush_transcripts() Usage : $gene->flush_transcripts(); Function: Remove all transcripts from this gene structure. Returns : Args : =cut sub flush_transcripts { my ($self) = @_; if( defined $self->{'_transcripts'} ) { foreach my $t ( grep {defined} @{$self->{'_transcripts'} || []} ) { $t->parent(undef); # remove bkwds pointers $t = undef; } delete($self->{'_transcripts'}); } } =head2 add_transcript_as_features Title : add_transcript_as_features Usage : $gene->add_transcript_as_features(@featurelist); Function: take a list of Bio::SeqFeatureI objects and turn them into a Bio::SeqFeature::Gene::Transcript object. Add that transcript to the gene. Returns : nothing Args : a list of Bio::SeqFeatureI compliant objects =cut sub add_transcript_as_features { my ($self,@features) = @_; my $transcript=Bio::SeqFeature::Gene::Transcript->new; foreach my $fea (@features) { if ($fea->primary_tag =~ /utr/i) { #UTR / utr/ 3' utr / utr5 etc. $transcript->add_utr($fea); } elsif ($fea->primary_tag =~ /promot/i) { #allow for spelling differences $transcript->add_promoter($fea); } elsif ($fea->primary_tag =~ /poly.*A/i) { #polyA, POLY_A, etc. $transcript->poly_A_site($fea); } else { #assume the rest are exons $transcript->add_exon($fea); } } $self->add_transcript($transcript); } =head2 promoters Title : promoters Usage : @prom_sites = $gene->promoters(); Function: Get the promoter features of this gene structure. This method basically merges the promoters returned by transcripts. Note that OO-modeling of regulatory elements is not stable yet. This means that this method might change or even disappear in a future release. Be aware of this if you use it. Returns : An array of Bio::SeqFeatureI implementing objects. Args : =cut sub promoters { my ($self) = @_; my @transcripts = $self->transcripts(); my @feas = (); foreach my $tr (@transcripts) { push(@feas, $tr->promoters()); } return @feas; } =head2 exons Title : exons() Usage : @exons = $gene->exons(); @inital_exons = $gene->exons('Initial'); Function: Get all exon features or all exons of a specified type of this gene structure. Exon type is treated as a case-insensitive regular expression and optional. For consistency, use only the following types: initial, internal, terminal, utr, utr5prime, and utr3prime. A special and virtual type is 'coding', which refers to all types except utr. This method basically merges the exons returned by transcripts. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects. Args : An optional string specifying the type of exon. =cut sub exons { my ($self, @args) = @_; my @transcripts = $self->transcripts(); my @feas = (); foreach my $tr (@transcripts) { push(@feas, $tr->exons(@args)); } return @feas; } =head2 introns Title : introns() Usage : @introns = $gene->introns(); Function: Get all introns of this gene structure. Note that this class currently generates these features on-the-fly, that is, it simply treats all regions between exons as introns. It assumes that the exons in the transcripts do not overlap. This method basically merges the introns returned by transcripts. Returns : An array of Bio::SeqFeatureI implementing objects. Args : =cut sub introns { my ($self) = @_; my @transcripts = $self->transcripts(); my @feas = (); foreach my $tr (@transcripts) { push(@feas, $tr->introns()); } return @feas; } =head2 poly_A_sites Title : poly_A_sites() Usage : @polyAsites = $gene->poly_A_sites(); Function: Get the poly-adenylation sites of this gene structure. This method basically merges the poly-adenylation sites returned by transcripts. Returns : An array of Bio::SeqFeatureI implementing objects. Args : =cut sub poly_A_sites { my ($self) = @_; my @transcripts = $self->transcripts(); my @feas = (); foreach my $tr (@transcripts) { push(@feas, $tr->poly_A_site()); } return @feas; } =head2 utrs Title : utrs() Usage : @utr_sites = $gene->utrs('3prime'); @utr_sites = $gene->utrs('5prime'); @utr_sites = $gene->utrs(); Function: Get the features representing untranslated regions (UTR) of this gene structure. You may provide an argument specifying the type of UTR. Currently the following types are recognized: 5prime 3prime for UTR on the 5' and 3' end of the CDS, respectively. This method basically merges the UTRs returned by transcripts. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects representing the UTR regions or sites. Args : Optionally, either 3prime, or 5prime for the the type of UTR feature. =cut sub utrs { my ($self,@args) = @_; my @transcripts = $self->transcripts(); my @feas = (); foreach my $tr (@transcripts) { push(@feas, $tr->utrs(@args)); } return @feas; } =head2 sub_SeqFeature Title : sub_SeqFeature Usage : @feats = $gene->sub_SeqFeature(); Function: Returns an array of all subfeatures. This method is defined in Bio::SeqFeatureI. We override this here to include the transcripts. Returns : An array Bio::SeqFeatureI implementing objects. Args : none =cut sub sub_SeqFeature { my ($self) = @_; my @feas = (); # get what the parent already has @feas = $self->SUPER::sub_SeqFeature(); push(@feas, $self->transcripts()); return @feas; } =head2 flush_sub_SeqFeature Title : flush_sub_SeqFeature Usage : $gene->flush_sub_SeqFeature(); $gene->flush_sub_SeqFeature(1); Function: Removes all subfeatures. This method is overridden from Bio::SeqFeature::Generic to flush all additional subfeatures, i.e., transcripts, which is almost certainly not what you want. To remove only features added through $gene->add_sub_SeqFeature($feature) pass any argument evaluating to TRUE. Example : Returns : none Args : Optionally, an argument evaluating to TRUE will suppress flushing of all gene structure-specific subfeatures (transcripts). =cut sub flush_sub_SeqFeature { my ($self,$fea_only) = @_; $self->SUPER::flush_sub_SeqFeature(); if(! $fea_only) { $self->flush_transcripts(); } } sub gene_cleanup { my $self = shift; $self->flush_transcripts; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/GeneStructureI.pm�����������������������������������������������000444��000765��000024�� 11265�12254227336� 22370� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::GeneStructureI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::GeneStructureI - A feature representing an arbitrarily complex structure of a gene =head1 SYNOPSIS #documentation needed =head1 DESCRIPTION A feature representing a gene structure. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::GeneStructureI; use strict; use Carp; use base qw(Bio::SeqFeatureI); =head2 transcripts Title : transcripts() Usage : @transcripts = $gene->transcripts(); Function: Get the transcript features/sites of this gene structure. See Bio::SeqFeature::Gene::TranscriptI for properties of the returned objects. Returns : An array of Bio::SeqFeature::Gene::TranscriptI implementing objects representing the promoter regions or sites. Args : =cut sub transcripts { my ($self) = @_; $self->throw_not_implemented(); } =head2 promoters Title : promoters() Usage : @prom_sites = $gene->promoters(); Function: Get the promoter features/sites of this gene structure. Note that OO-modeling of regulatory elements is not stable yet. This means that this method might change or even disappear in a future release. Be aware of this if you use it. Returns : An array of Bio::SeqFeatureI implementing objects representing the promoter regions or sites. Args : =cut sub promoters { my ($self) = @_; $self->throw_not_implemented(); } =head2 exons Title : exons() Usage : @exons = $gene->exons(); @inital = $gene->exons('Initial'); Function: Get all exon features or all exons of specified type of this gene structure. Refer to the documentation of the class that produced this gene structure object for information about the possible types. See Bio::SeqFeature::Gene::ExonI for properties of the returned objects. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects representing the exon regions. Args : An optional string specifying the type of the exon. =cut sub exons { my ($self, $type) = @_; $self->throw_not_implemented(); } =head2 introns Title : introns() Usage : @introns = $gene->introns(); Function: Get all introns of this gene structure. Returns : An array of Bio::SeqFeatureI implementing objects representing the introns. Args : =cut sub introns { my ($self) = @_; $self->throw_not_implemented(); } =head2 poly_A_sites Title : poly_A_sites() Usage : @polyAsites = $gene->poly_A_sites(); Function: Get the poly-adenylation features/sites of this gene structure. Returns : An array of Bio::SeqFeatureI implementing objects representing the poly-adenylation regions or sites. Args : =cut sub poly_A_sites { my ($self) = @_; $self->throw_not_implemented(); } =head2 utrs Title : utrs() Usage : @utr_sites = $gene->utrs(); Function: Get the UTR features/sites of this gene structure. See Bio::SeqFeature::Gene::ExonI for properties of the returned objects. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects representing the UTR regions or sites. Args : =cut sub utrs { my ($self) = @_; $self->throw_not_implemented(); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/Intron.pm�������������������������������������������������������000444��000765��000024�� 21636�12254227330� 20726� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::Intron # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by David Block <dblock@gene.pbi.nrc.ca> # # Copyright David Block # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::Intron - An intron feature =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - David Block Email dblock@gene.pbi.nrc.ca =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::Intron; use strict; use Bio::SeqFeature::Gene::Exon; use base qw(Bio::SeqFeature::Gene::NC_Feature); sub new { my($class,@args) = @_; # introns are non-coding by default if(! grep { lc($_) eq '-is_coding'; } @args) { push(@args, '-is_coding', 0); } my $self = $class->SUPER::new(@args); my ($primary, $prim) = $self->_rearrange([qw(PRIMARY PRIMARY_TAG)],@args); $self->primary_tag('intron') unless $primary || $prim; return $self; } =head2 upstream_Exon Title : upstream_Exon Usage : $intron->upstream_Exon() Function: exon upstream of the intron Returns : Bio::EnsEMBL::Exon Args : =cut sub upstream_Exon { my( $self, $exon ) = @_; if ($exon) { $self->{'_intron_location'} = undef; $self->throw("'$exon' is not a Bio::SeqFeature::Gene::ExonI") unless $exon->isa('Bio::SeqFeature::Gene::ExonI'); $self->{'_upstream_exon'} = $exon; } return $self->{'_upstream_exon'}; } =head2 downstream_Exon Title : downstream_Exon Usage : $intron->downstream_Exon() Function: exon downstream of the intron Returns : Bio::EnsEMBL::Exon Args : =cut sub downstream_Exon { my( $self, $exon ) = @_; if ($exon) { $self->{'_intron_location'} = undef; $self->throw("'$exon' is not a Bio::SeqFeature::Gene::ExonI") unless $exon->isa('Bio::SeqFeature::Gene::ExonI'); $self->{'_downstream_exon'} = $exon; } return $self->{'_downstream_exon'}; } =head2 phase Title : phase Usage : $intron->phase() Function: returns the phase of the intron(where it interrupts the codon) Returns : int(0,1,2) Args : =cut sub phase { my ($self) = @_; return $self->downstream_Exon->phase; } =head2 acceptor_splice_site Title : acceptor_splice_site Usage : $intron->acceptor_splice_site(21,3) Function: returns the sequence corresponding to the consensus acceptor splice site. If start and end are provided, it will number of base pairs left and right of the canonical AG. Here 21 means 21 bp into intron and 3 means 3 bp into the exon. --Intron--21----|AG|-3-----Exon Defaults to 21,3 Returns : Bio::Seq Args : start and end =cut sub acceptor_splice_site { my ($self,$ss_start,$ss_end) = @_; $ss_start = 21 unless defined $ss_start; $ss_end = 3 unless defined $ss_end; if($self->strand < 0){ my $tmp= $ss_start; $ss_start = $ss_end; $ss_end = $tmp; } my $intron_end= $self->location->end; my $down_exon = $self->downstream_Exon; my $acceptor; if($self->strand < 0){ $ss_start= $ss_start > $down_exon->length ? $down_exon->length: $ss_start; $ss_end= $ss_end > $self->length-2 ? $self->length-2 : $ss_end; $acceptor = Bio::SeqFeature::Generic->new(-start=>$self->start - ($ss_start) , -end=>$self->start + ($ss_end+1), -strand=>$self->strand, -primary_tag=>"donor splice site"); } else { $ss_start = $ss_start > $self->length-2 ? $self->length-2 : $ss_start; $ss_end = $ss_end > $down_exon->length ? $down_exon->length : $ss_end; $acceptor = Bio::SeqFeature::Generic->new(-start=>$self->end - ($ss_start + 1), -end=>$self->end + $ss_end, -strand=>$self->strand, -primary_tag=>"donor splice site"); } $acceptor->attach_seq($self->entire_seq); return $acceptor; } =head2 donor_splice_site Title : donor_splice_site Usage : $intron->donor_splice_site(3,6) Function: returns the sequence corresponding to the consensus donor splice site. If start and end are provided, it will number of base pairs left and right of the canonical GT. Here 3 means 3 bp into exon and 6 means 6 bp into the intron. --Exon-3--|GT|-6----Intron- Defaults to 3,6 Returns : Bio::Seq Args : start and end =cut sub donor_splice_site { my ($self,$ss_start,$ss_end) = @_; $ss_start = 3 unless defined $ss_start; $ss_end = 10 unless defined $ss_end; if($self->strand < 0){ my $tmp= $ss_start; $ss_start = $ss_end; $ss_end = $tmp; } my $up_exon = $self->upstream_Exon; my $donor; if($self->strand < 0){ $ss_end = $ss_end > $up_exon->length ? $up_exon->length : $ss_end; $ss_start = $ss_start> $self->length -2 ? $self->length -2 : $ss_start; $donor = Bio::SeqFeature::Generic->new(-start=>$self->end - ($ss_start+1), -end => $self->end + ($ss_end), -strand=>$self->strand, -primary_tag=>"acceptor splice site"); } else { $ss_start = $ss_start > $up_exon->length ? $up_exon->length : $ss_start; $ss_end = $ss_end > $self->length -2 ? $self->length -2 : $ss_end; $donor = Bio::SeqFeature::Generic->new(-start=>$self->start - $ss_start, -end => $self->start +($ss_end+1), -strand=>$self->strand, -primary_tag=>"acceptor splice site"); } $donor->attach_seq($self->entire_seq); return $donor; } sub location { my( $self ) = @_; unless ($self->{'_intron_location'}) { my $loc = Bio::Location::Simple->new; my $up_exon = $self->upstream_Exon; my $down_exon = $self->downstream_Exon; # Get the PrimarySeqs attached to both and check it is the same sequence my $up_seq = $up_exon ->entire_seq; my $down_seq = $down_exon->entire_seq; unless (ref($up_seq) eq ref($down_seq) ) { $self->throw("upstream and downstream exons are attached to different sequences\n'$up_seq' and '$down_seq'"); } # Check that the exons are on the same strand. (Do I need to bother?) my $up_strand = $up_exon ->strand; my $down_strand = $down_exon->strand; unless ($up_strand == $down_strand) { $self->throw("upstream and downstream exons are on different strands " . "('$up_strand' and '$down_strand')"); } $loc->strand($up_strand); # $exon_end is the end of the exon which is 5' of the intron on the genomic sequence. # $exon_start is the start of the exon which is 3' of the intron on the genomic sequence. my( $exon_end, $exon_start ); if ($up_strand == 1) { $exon_end = $up_exon ->end; $exon_start = $down_exon->start; } else { $exon_end = $down_exon->end; $exon_start = $up_exon ->start; } unless ($exon_end < $exon_start) { $self->throw("Intron gap begins after '$exon_end' and ends before '$exon_start'"); } $loc->start($exon_end + 1); $loc->end ($exon_start - 1); # Attach the sequence and location objects to the intron $self->{'_intron_location'} = $loc; } return $self->{'_intron_location'}; } 1; ��������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/NC_Feature.pm���������������������������������������������������000444��000765��000024�� 5125�12254227330� 21403� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::NC_Feature.pm # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by David Block <dblock@gene.pbi.nrc.ca> # # Copyright David Block # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::NC_Feature.pm - superclass for non-coding features =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - David Block Email dblock@gnf.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::NC_Feature; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SeqFeature::Generic); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($is_coding) = $self->_rearrange([qw(IS_CODING)],@args); # default is non-coding $self->is_coding(defined($is_coding) ? $is_coding : 0); return $self; } =head2 is_coding Title : is_coding Usage : if ($feature->is_coding()) { #do something } Function: Whether or not the feature codes for amino acid. Returns : FALSE Args : none =cut sub is_coding{ my $self = shift; return $self->{'is_coding'} = shift if @_; return $self->{'is_coding'}; } =head2 cds Title : cds Usage : $cds=$feature->cds(); Function: get the coding sequence of this feature Returns : undef Args : none =cut sub cds { my ($self,@args) = @_; return; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/Poly_A_site.pm��������������������������������������������������000444��000765��000024�� 3614�12254227323� 21642� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::Poly_A_site # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by David Block <dblock@gene.pbi.nrc.ca> # # Copyright David Block # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::Poly_A_site - poly A feature =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Inherits from L<Bio::SeqFeature::Gene::NC_Feature>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - David Block Email dblock@gene.pbi.nrc.ca =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::Poly_A_site; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SeqFeature::Gene::NC_Feature); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); } 1; ��������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/Promoter.pm�����������������������������������������������������000444��000765��000024�� 3565�12254227313� 21246� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::Promoter # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by David Block <dblock@gene.pbi.nrc.ca> # # Copyright David Block # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::Promoter - Describes a promoter =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - David Block Email dblock@gene.pbi.nrc.ca =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::Promoter; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SeqFeature::Gene::NC_Feature); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); } 1; �������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/Transcript.pm���������������������������������������������������000444��000765��000024�� 53724�12254227314� 21613� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::Transcript # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::Transcript - A feature representing a transcript =head1 SYNOPSIS # See documentation of methods. =head1 DESCRIPTION A feature representing a transcript. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::Transcript; use strict; use Bio::PrimarySeq; use base qw(Bio::SeqFeature::Generic Bio::SeqFeature::Gene::TranscriptI); sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); $self->_register_for_cleanup(\&transcript_destroy); my ($primary) = $self->_rearrange([qw(PRIMARY)],@args); $primary = 'transcript' unless $primary; $self->primary_tag($primary); $self->strand(0) if(! defined($self->strand())); return $self; } =head2 promoters Title : promoters() Usage : @proms = $transcript->promoters(); Function: Get the promoter features/sites of this transcript. Note that OO-modeling of regulatory elements is not stable yet. This means that this method might change or even disappear in a future release. Be aware of this if you use it. Returns : An array of Bio::SeqFeatureI implementing objects representing the promoter regions or sites. Args : =cut sub promoters { my ($self) = @_; return $self->get_feature_type('Bio::SeqFeature::Gene::Promoter'); } =head2 add_promoter Title : add_promoter() Usage : $transcript->add_promoter($feature); Function: Add a promoter feature/site to this transcript. Note that OO-modeling of regulatory elements is not stable yet. This means that this method might change or even disappear in a future release. Be aware of this if you use it. Returns : Args : A Bio::SeqFeatureI implementing object. =cut sub add_promoter { my ($self, $fea) = @_; $self->_add($fea,'Bio::SeqFeature::Gene::Promoter'); } =head2 flush_promoters Title : flush_promoters() Usage : $transcript->flush_promoters(); Function: Remove all promoter features/sites from this transcript. Note that OO-modeling of regulatory elements is not stable yet. This means that this method might change or even disappear in a future release. Be aware of this if you use it. Returns : the removed features as a list Args : none =cut sub flush_promoters { my ($self) = @_; return $self->_flush('Bio::SeqFeature::Gene::Promoter'); } =head2 exons Title : exons() Usage : @exons = $gene->exons(); ($inital_exon) = $gene->exons('Initial'); Function: Get all exon features or all exons of specified type of this transcript. Exon type is treated as a case-insensitive regular expression and is optional. For consistency, use only the following types: initial, internal, terminal. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects. Args : An optional string specifying the primary_tag of the feature. =cut sub exons { my ($self, $type) = @_; return $self->get_unordered_feature_type('Bio::SeqFeature::Gene::ExonI', $type); } =head2 exons_ordered Title : exons_ordered Usage : @exons = $gene->exons_ordered(); @exons = $gene->exons_ordered("Internal"); Function: Get an ordered list of all exon features or all exons of specified type of this transcript. Exon type is treated as a case-insensitive regular expression and is optional. For consistency, use only the following types: Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects. Args : An optional string specifying the primary_tag of the feature. =cut sub exons_ordered { my ($self,$type) = @_; return $self->get_feature_type('Bio::SeqFeature::Gene::ExonI', $type); } =head2 add_exon Title : add_exon() Usage : $transcript->add_exon($exon,'initial'); Function: Add a exon feature to this transcript. The second argument denotes the type of exon. Mixing exons with and without a type is likely to cause trouble in exons(). Either leave out the type for all exons or for none. Presently, the following types are known: initial, internal, terminal, utr, utr5prime, and utr3prime (all case-insensitive). UTR should better be added through utrs()/add_utr(). If you wish to use other or additional types, you will almost certainly have to call exon_type_sortorder() in order to replace the default sort order, or mrna(), cds(), protein(), and exons() may yield unexpected results. Returns : Args : A Bio::SeqFeature::Gene::ExonI implementing object. A string indicating the type of the exon (optional). =cut sub add_exon { my ($self, $fea, $type) = @_; if(! $fea->isa('Bio::SeqFeature::Gene::ExonI') ) { $self->throw("$fea does not implement Bio::SeqFeature::Gene::ExonI"); } $self->_add($fea,'Bio::SeqFeature::Gene::Exon', $type); } =head2 flush_exons Title : flush_exons() Usage : $transcript->flush_exons(); $transcript->flush_exons('terminal'); Function: Remove all or a certain type of exon features from this transcript. See add_exon() for documentation about types. Calling without a type will not flush UTRs. Call flush_utrs() for this purpose. Returns : the deleted features as a list Args : A string indicating the type of the exon (optional). =cut sub flush_exons { my ($self, $type) = @_; return $self->_flush('Bio::SeqFeature::Gene::Exon',$type); } =head2 introns Title : introns() Usage : @introns = $gene->introns(); Function: Get all intron features this gene structure. Note that this implementation generates these features on-the-fly, that is, it simply treats all regions between exons as introns, assuming that exons do not overlap. A consequence is that a consistent correspondence between the elements in the returned array and the array that exons() returns will exist only if the exons are properly sorted within their types (forward for plus- strand and reverse for minus-strand transcripts). To ensure correctness the elements in the array returned will always be sorted. Returns : An array of Bio::SeqFeature::Gene::Intron objects representing the intron regions. Args : =cut sub introns { my ($self) = @_; my @introns = (); my @exons = $self->exons(); my ($strand, $rev_order); # if there's 1 or less exons we're done return () unless($#exons > 0); # record strand and order (a minus-strand transcript is likely to have # the exons stacked in reverse order) foreach my $exon (@exons) { $strand = $exon->strand(); last if $strand; # we're done if we've got 1 or -1 } $rev_order = ($exons[0]->end() < $exons[1]->start() ? 0 : 1); # Make sure exons are sorted. Because we assume they don't overlap, we # simply sort by start position. if((! defined($strand)) || ($strand != -1) || (! $rev_order)) { # always sort forward for plus-strand transcripts, and for negative- # strand transcripts that appear to be unsorted or forward sorted @exons = map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->start * ($_->strand || 1)] } @exons; } else { # sort in reverse order for transcripts on the negative strand and # found to be in reverse order @exons = map { $_->[0] } sort { $b->[1] <=> $a->[1] } map { [ $_, $_->start()] } @exons; } # loop over all intervening gaps while ((my $exonA = shift (@exons)) &&(my $exonB = shift(@exons))){ my $intron = Bio::SeqFeature::Gene::Intron->new(-primary=>'intron'); $intron->upstream_Exon($exonA); $intron->downstream_Exon($exonB); $intron->attach_seq($self->entire_seq) if $self->entire_seq; unshift(@exons,$exonB); push @introns,$intron; } return @introns; } =head2 poly_A_site Title : poly_A_site() Usage : $polyAsite = $transcript->poly_A_site(); Function: Get/set the poly-adenylation feature/site of this transcript. Returns : A Bio::SeqFeatureI implementing object representing the poly-adenylation region. Args : A Bio::SeqFeatureI implementing object on set, or FALSE to flush a previously set object. =cut sub poly_A_site { my ($self, $fea) = @_; if ($fea) { $self->_add($fea,'Bio::SeqFeature::Gene::Poly_A_site'); } return ($self->get_feature_type('Bio::SeqFeature::Gene::Poly_A_site'))[0]; } =head2 utrs Title : utrs() Usage : @utr_sites = $transcript->utrs('utr3prime'); @utr_sites = $transcript->utrs('utr5prime'); @utr_sites = $transcript->utrs(); Function: Get the features representing untranslated regions (UTR) of this transcript. You may provide an argument specifying the type of UTR. Currently the following types are recognized: utr5prime utr3prime for UTR on the 5' and 3' end of the CDS, respectively. Returns : An array of Bio::SeqFeature::Gene::UTR objects representing the UTR regions or sites. Args : Optionally, either utr3prime, or utr5prime for the the type of UTR feature. =cut sub utrs { my ($self, $type) = @_; return $self->get_feature_type('Bio::SeqFeature::Gene::UTR',$type); } =head2 add_utr Title : add_utr() Usage : $transcript->add_utr($utrobj, 'utr3prime'); $transcript->add_utr($utrobj); Function: Add a UTR feature/site to this transcript. The second parameter is optional and denotes the type of the UTR feature. Presently recognized types include 'utr5prime' and 'utr3prime' for UTR on the 5' and 3' end of a gene, respectively. Calling this method is the same as calling add_exon($utrobj, 'utr'.$type). In this sense a UTR object is a special exon object, which is transcribed, not spliced out, but not translated. Note that the object supplied should return FALSE for is_coding(). Otherwise cds() and friends will become confused. Returns : Args : A Bio::SeqFeature::Gene::UTR implementing object. =cut sub add_utr { my ($self, $fea, $type) = @_; $self->_add($fea,'Bio::SeqFeature::Gene::UTR',$type); } =head2 flush_utrs Title : flush_utrs() Usage : $transcript->flush_utrs(); $transcript->flush_utrs('utr3prime'); Function: Remove all or a specific type of UTR features/sites from this transcript. Cf. add_utr() for documentation about recognized types. Returns : a list of the removed features Args : Optionally a string denoting the type of UTR feature. =cut sub flush_utrs { my ($self, $type) = @_; return $self->_flush('Bio::SeqFeature::Gene::UTR',$type); } =head2 sub_SeqFeature Title : sub_SeqFeature Usage : @feats = $transcript->sub_SeqFeature(); Function: Returns an array of all subfeatures. This method is defined in Bio::SeqFeatureI. We override this here to include the exon etc features. Returns : An array Bio::SeqFeatureI implementing objects. Args : none =cut sub sub_SeqFeature { my ($self) = @_; my @feas; # get what the parent already has @feas = $self->SUPER::sub_SeqFeature(); # add the features we have in addition push(@feas, $self->exons()); # this includes UTR features push(@feas, $self->promoters()); push(@feas, $self->poly_A_site()) if($self->poly_A_site()); return @feas; } =head2 flush_sub_SeqFeature Title : flush_sub_SeqFeature Usage : $transcript->flush_sub_SeqFeature(); $transcript->flush_sub_SeqFeature(1); Function: Removes all subfeatures. This method is overridden from Bio::SeqFeature::Generic to flush all additional subfeatures like exons, promoters, etc., which is almost certainly not what you want. To remove only features added through $transcript->add_sub_SeqFeature($feature) pass any argument evaluating to TRUE. Example : Returns : none Args : Optionally, an argument evaluating to TRUE will suppress flushing of all transcript-specific subfeatures (exons etc.). =cut sub flush_sub_SeqFeature { my ($self,$fea_only) = @_; $self->SUPER::flush_sub_SeqFeature(); if(! $fea_only) { $self->flush_promoters(); $self->flush_exons(); $self->flush_utrs(); $self->poly_A_site(0); } } =head2 cds Title : cds Usage : $seq = $transcript->cds(); Function: Returns the CDS (coding sequence) as defined by the exons of this transcript and the attached sequence. If no sequence is attached this method will return false. Note that the implementation provided here returns a concatenation of all coding exons, thereby assuming that exons do not overlap. Note also that you cannot set the CDS via this method. Set a single CDS feature as a single exon, or derive your own class if you want to store a predicted CDS. Example : Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub cds { my ($self) = @_; my @exons = $self->exons_ordered(); #this is always sorted properly according to strand my $strand; return unless(@exons); # record strand (a minus-strand transcript must have the exons sorted in # reverse order) foreach my $exon (@exons) { if(defined($exon->strand()) && (! $strand)) { $strand = $exon->strand(); } if($exon->strand() && (($exon->strand() * $strand) < 0)) { $self->throw("Transcript mixes coding exons on plus and minus ". "strand. This makes no sense."); } } my $cds = $self->_make_cds(@exons); return unless $cds; return Bio::PrimarySeq->new('-id' => $self->seq_id(), '-seq' => $cds, '-alphabet' => "dna"); } =head2 protein Title : protein() Usage : $protein = $transcript->protein(); Function: Get the protein encoded by the transcript as a sequence object. The implementation provided here simply calls translate() on the object returned by cds(). Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub protein { my ($self) = @_; my $seq; $seq = $self->cds(); return $seq->translate() if $seq; return; } =head2 mrna Title : mrna() Usage : $mrna = $transcript->mrna(); Function: Get the mRNA of the transcript as a sequence object. The difference to cds() is that the sequence object returned by this methods will also include UTR and the poly-adenylation site, but not promoter sequence (TBD). HL: do we really need this method? Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub mrna { my ($self) = @_; my ($seq, $mrna, $elem); # get the coding part $seq = $self->cds(); if(! $seq) { $seq = Bio::PrimarySeq->new('-id' => $self->seq_id(), '-alphabet' => "rna", '-seq' => ""); } # get and add UTR sequences $mrna = ""; foreach $elem ($self->utrs('utr5prime')) { $mrna .= $elem->seq()->seq(); } $seq->seq($mrna . $seq->seq()); $mrna = ""; foreach $elem ($self->utrs('utr3prime')) { $mrna .= $elem->seq()->seq(); } $seq->seq($seq->seq() . $mrna); if($self->poly_A_site()) { $seq->seq($seq->seq() . $self->poly_A_site()->seq()->seq()); } return if($seq->length() == 0); return $seq; } sub _get_typed_keys { my ($self, $keyprefix, $type) = @_; my @keys = (); my @feas = (); # make case-insensitive $type = ($type ? lc($type) : ""); # pull out all feature types that exist and match @keys = grep { /^_$keyprefix$type/i; } (keys(%{$self})); return @keys; } sub _make_cds { my ($self,@exons) = @_; my $cds = ""; foreach my $exon (@exons) { next if((! defined($exon->seq())) || (! $exon->is_coding())); my $phase = length($cds) % 3; # let's check the simple case if((! defined($exon->frame())) || ($phase == $exon->frame())) { # this one fits exactly, or frame of the exon is undefined (should # we warn about that?); we bypass the $exon->cds() here (hmm, # not very clean style, but I don't see where this screws up) $cds .= $exon->seq()->seq(); } else { # this one is probably from exon shuffling and needs some work my $seq = $exon->cds(); # now $seq is guaranteed to be in frame 0 next if(! $seq); $seq = $seq->seq(); # adjustment needed? if($phase > 0) { # how many Ns can we chop off the piece to be added? my $n_crop = 0; if($seq =~ /^(n+)/i) { $n_crop = length($1); } if($n_crop >= $phase) { # chop off to match the phase $seq = substr($seq, $phase); } else { # fill in Ns $seq = ("n" x (3-$phase)) . $seq; } } $cds .= $seq; } } return $cds; } =head2 features Title : features Usage : my @features=$transcript->features; Function: returns all the features associated with this transcript Returns : a list of SeqFeatureI implementing objects Args : none =cut sub features { my $self = shift; return grep { defined } @{$self->{'_features'} || []}; } =head2 features_ordered Title : features_ordered Usage : my @features=$transcript->features_ordered; Function: returns all the features associated with this transcript, in order by feature start, according to strand Returns : a list of SeqFeatureI implementing objects Args : none =cut sub features_ordered{ my ($self) = @_; return $self->_stranded_sort(@{$self->{'_features'} || []}); } sub get_unordered_feature_type{ my ($self, $type, $pri)=@_; my @list; foreach ( $self->features) { if ($_->isa($type)) { if ($pri && $_->primary_tag !~ /$pri/i) { next; } push @list,$_; } } return @list; } sub get_feature_type { my ($self)=shift; return $self->_stranded_sort($self->get_unordered_feature_type(@_)); } #This was fixed by Gene Cutler - the indexing on the list being reversed #fixed a bad bug. Thanks Gene! sub _flush { my ($self, $type, $pri)=@_; my @list=$self->features; my @cut; for (reverse (0..$#list)) { if (defined $list[$_] && $list[$_]->isa($type)) { if ($pri && $list[$_]->primary_tag !~ /$pri/i) { next; } push @cut, splice @list, $_, 1; #remove the element of $type from @list #and return each of them in @cut } } $self->{'_features'}=\@list; return reverse @cut; } sub _add { my ($self, $fea, $type, $pri)=@_; require Bio::SeqFeature::Gene::Promoter; require Bio::SeqFeature::Gene::UTR; require Bio::SeqFeature::Gene::Exon; require Bio::SeqFeature::Gene::Intron; require Bio::SeqFeature::Gene::Poly_A_site; if(! $fea->isa('Bio::SeqFeatureI') ) { $self->throw("$fea does not implement Bio::SeqFeatureI"); } if(! $fea->isa($type) || $pri) { $fea=$self->_new_of_type($fea,$type,$pri); } if (! $self->strand) { $self->strand($fea->strand); } else { if ($self->strand * $fea->strand == -1) { $self->throw("$fea is on opposite strand from $self"); } } $self->_expand_region($fea); if(defined($self->entire_seq()) && (! defined($fea->entire_seq())) && $fea->can('attach_seq')) { $fea->attach_seq($self->entire_seq()); } if (defined $self->parent) { $self->parent->_expand_region($fea); } push(@{$self->{'_features'}}, $fea); 1; } sub _stranded_sort { my ($self,@list)=@_; my $strand; foreach my $fea (@list) { if($fea->strand()) { # defined and != 0 $strand = $fea->strand() if(! $strand); if(($fea->strand() * $strand) < 0) { $strand = undef; last; } } } if (defined $strand && $strand == - 1) { #reverse strand return map { $_->[0] } sort {$b->[1] <=> $a->[1]} map { [$_, $_->start] } @list; } else { #undef or forward strand return map { $_->[0] } sort {$a->[1] <=> $b->[1]} map { [$_, $_->start] } @list; } } sub _new_of_type { my ($self, $fea, $type, $pri)= @_; my $primary; if ($pri) { $primary = $pri; #can set new primary tag if desired } else { ($primary) = $type =~ /.*::(.+)/; #or else primary is just end of type string } bless $fea,$type; $fea->primary_tag($primary); return $fea; } sub transcript_destroy { my $self = shift; # We're going to be really explicit to insure memory leaks # don't occur foreach my $f ( $self->features ) { $f = undef; } $self->parent(undef); } 1; ��������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/TranscriptI.pm��������������������������������������������������000444��000765��000024�� 13230�12254227326� 21713� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::TranscriptI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::TranscriptI - Interface for a feature representing a transcript of exons, promoter(s), UTR, and a poly-adenylation site. =head1 SYNOPSIS #documentation needed =head1 DESCRIPTION A feature representing a transcript. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::TranscriptI; use strict; use Carp; use base qw(Bio::SeqFeatureI); =head2 promoters Title : promoters() Usage : @proms = $transcript->promoters(); Function: Get the promoter features of this transcript. Note that OO-modeling of regulatory elements is not stable yet. This means that this method might change or even disappear in a future release. Be aware of this if you use it. Returns : An array of Bio::SeqFeatureI implementing objects representing the promoter regions or sites. Args : =cut sub promoters { my ($self) = @_; $self->throw_not_implemented(); } =head2 exons Title : exons() Usage : @exons = $transcript->exons(); @inital = $transcript->exons('Initial'); Function: Get the individual exons this transcript comprises of, or all exons of a specified type. Refer to the documentation of the class that produced this transcript object for information about the possible types. See Bio::SeqFeature::Gene::ExonI for properties of the returned objects. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects Args : An optional string specifying the type of the exon. =cut sub exons { my ($self, $type) = @_; $self->throw_not_implemented(); } =head2 introns Title : introns() Usage : @introns = $transcript->introns(); Function: Get all introns this transcript comprises of. Returns : An array of Bio::SeqFeatureI implementing objects representing the introns. Args : =cut sub introns { my ($self) = @_; $self->throw_not_implemented(); } =head2 poly_A_site Title : poly_A_site() Usage : $polyAsite = $transcript->poly_A_site(); Function: Get the poly-adenylation site of this transcript. Returns : A Bio::SeqFeatureI implementing object. Args : =cut sub poly_A_site { my ($self) = @_; $self->throw_not_implemented(); } =head2 utrs Title : utrs() Usage : @utr_sites = $transcript->utrs(); Function: Get the UTR regions this transcript comprises of. See Bio::SeqFeature::Gene::ExonI for properties of the returned objects. Returns : An array of Bio::SeqFeature::Gene::ExonI implementing objects Args : =cut sub utrs { my ($self) = @_; $self->throw_not_implemented(); } =head2 mrna Title : mrna() Usage : $mrna = $transcript->mrna(); Function: Get the mRNA of the transcript as a sequence object. Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub mrna { my ($self) = @_; $self->throw_not_implemented(); } =head2 cds Title : cds() Usage : $cds = $transcript->cds(); Function: Get the CDS (coding sequence) of the transcript as a sequence object. Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub cds { my ($self) = @_; $self->throw_not_implemented(); } =head2 protein Title : protein() Usage : $protein = $transcript->protein(); Function: Get the protein encoded by the transcript as a sequence object. Returns : A Bio::PrimarySeqI implementing object. Args : =cut sub protein { my ($self) = @_; $self->throw_not_implemented(); } =head2 parent Title : parent Usage : $obj->parent($newval) Function: get the parent gene of the transcript Returns : value of parent - a Bio::SeqFeature::Gene::GeneStructureI-compliant object Args : a Bio::SeqFeature::Gene::GeneStructureI-compliant object (optional) =cut sub parent{ my $self = shift; if( @_ ) { my $value = shift; # I really mean ! defined $value - # we will allow re-setting the parent to undef if (! defined $value || $value->isa("Bio::SeqFeature::Gene::GeneStructureI")) { $self->{'_parent'} = $value; } else { $self->throw("$value must be a Bio::SeqFeature::Gene::GeneStructureI") } } return $self->{'_parent'}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Gene/UTR.pm����������������������������������������������������������000444��000765��000024�� 6251�12254227340� 20104� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::Gene::UTR # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by David Block <dblock@gene.pbi.nrc.ca> # # Copyright David Block # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Gene::UTR - A feature representing an untranslated region that is part of a transcriptional unit =head1 SYNOPSIS See documentation of methods =head1 DESCRIPTION A UTR is a Bio::SeqFeature::Gene::ExonI compliant object that is non-coding, and can be either 5' or 3' in a transcript. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - David Block Email dblock@gene.pbi.nrc.ca =head1 CONTRIBUTORS This is based on the Gene Structure scaffolding erected by Hilmar Lapp (hlapp@gmx.net). =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Gene::UTR; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::SeqFeature::Gene::Exon); =head2 new Title : new Usage : Function: We override the constructor here to set is_coding to false unless explicitly overridden. Example : Returns : Args : =cut sub new{ my ($caller, @args) = @_; if(! grep { lc($_) eq '-is_coding'; } @args) { push(@args, '-is_coding', 0); } my $self = $caller->SUPER::new(@args); my ($primary, $prim) = $self->_rearrange([qw(PRIMARY PRIMARY_TAG)],@args); $self->primary_tag('utr') unless $primary || $prim; return $self; } =head2 primary_tag Title : primary_tag Usage : $tag = $feat->primary_tag() Function: Returns the primary tag for a feature, eg 'utr5prime'. This method insures that 5prime/3prime information is uniformly stored Returns : a string Args : none =cut sub primary_tag{ my $self = shift; if(@_ && defined($_[0])) { my $val = shift; if ($val =~ /(3|5)/ ) { $val = "utr$1prime"; } else { $self->warn("Primary tag should indicate if this is 3 or 5'. ". "Preferred text is 'utr3prime' or 'utr5prime'."); } unshift(@_,$val); } return $self->SUPER::primary_tag(@_); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/SiRNA����������������������������������������������������������������000755��000765��000024�� 0�12254227327� 16776� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/SiRNA/Oligo.pm�������������������������������������������������������000444��000765��000024�� 12214�12254227327� 20562� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::SiRNA::Pair # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Donald Jackson # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::SiRNA::Oligo - Perl object for small inhibitory RNAs. =head1 SYNOPSIS use Bio::SeqFeature::SiRNA::Oligo; my $oligo = Bio::SeqFeature::SiRNA::Oligo-> new( -seq => 'AUGCCGAUUGCAAGUCAGATT', -start => 10, -end => 31, -strand => -1, -primary => 'SiRNA::Oligo', -source_tag => 'Bio::Tools::SiRNA', -tag => { note => 'A note' }, ); # normally two complementary Oligos are combined in an SiRNA::Pair # object $pair->antisense($oligo); =head1 DESCRIPTION Object methods for single SiRNA oligos - inherits L<Bio::SeqFeature::Generic>. Does B<not> include methods for designing SiRNAs - see L<Bio::Tools::SiRNA> for that. =head1 SEE ALSO L<Bio::Tools::SiRNA>, L<Bio::SeqFeature::SiRNA::Pair>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Donald Jackson (donald.jackson@bms.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqFeature::SiRNA::Oligo; use strict; use warnings; use base qw(Bio::SeqFeature::Generic); our @ARGNAMES = qw(SEQ START END STRAND PRIMARY SOURCE_TAG SCORE TAG SEQ_ID ANNOTATION LOCATION); =head2 new Title : new Usage : my $sirna_oligo = Bio::SeqFeature::SiRNA::Oligo->new(); Function : Create a new SiRNA::Oligo object Returns : Bio::Tools::SiRNA object Args : -seq sequence of the RNAi oligo. Should be in RNA alphabet except for the final TT overhang. -start start position -end end position -strand strand -primary primary tag - defaults to 'SiRNA::Oligo' -source source tag -score score value -tag a reference to a tag/value hash -seq_id the display name of the sequence -annotation the AnnotationCollectionI object -location the LocationI object Currently passing arguments in gff_string or gff1_string is not supported. SiRNA::Oligo objects are typically created by a design algorithm such as Bio::Tools::SiRNA =cut sub new { my ($proto, @args) = @_; my $pkg = ref($proto) || $proto; my (%args); my $self = $pkg->SUPER::new(); @args{@ARGNAMES} = $self->_rearrange(\@ARGNAMES, @args); # default primary tag $args{'PRIMARY'} ||= 'SiRNA::Oligo'; $args{'PRIMARY'} && $self->primary_tag($args{'PRIMARY'}); $args{'SOURCE_TAG'} && $self->source_tag($args{'SOURCE_TAG'}); $args{'SEQNAME'} && $self->seqname($args{'SEQNAME'}); $args{'SEQ'} && $self->seq($args{'SEQ'}); $args{'ANNOTATION'} && $self->annotation($args{'ANNOTATION'}); $args{'LOCATION'} && $self->location($args{'LOCATION'}); defined($args{'START'}) && $self->start($args{'START'}); defined($args{'END'}) && $self->end($args{'END'}); defined($args{'STRAND'}) && $self->strand($args{'STRAND'}); defined($args{'SCORE'}) && $self->score($args{'SCORE'}); if ($args{'TAG'}) { foreach my $t ( keys %{ $args{'TAG'} } ) { $self->add_tag_value($t, $args{'TAG'}->{$t}); } } return $self; } =head2 seq Title : Seq Usage : my $oligo_sequence = $sirna_oligo->seq(); Purpose : Get/set the sequence of the RNAi oligo Returns : Sequence for the RNAi oligo Args : Sequence of the RNAi oligo (optional) Note : Overloads Bio::SeqFeature::Generic seq method - the oligo and parent sequences are different. Note that all but the last 2 nucleotides are RNA (per Tuschl and colleagues). SiRNA::Pair objects are typically created by a design algorithm such as Bio::Tools::SiRNA. =cut sub seq { my ($self, $seq) = @_; if ($seq) { # check alphabet if ($seq =~ /[^ACGTUacgtu]/ ) { warn "Sequence contains illegal characters"; return; } else { $self->{'seq'} = $seq; } } return $self->{'seq'}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/SiRNA/Pair.pm��������������������������������������������������������000444��000765��000024�� 17631�12254227324� 20411� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqFeature::SiRNA::Pair # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Donald Jackson # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::SiRNA::Pair - Perl object for small inhibitory RNA (SiRNA) oligo pairs =head1 SYNOPSIS use Bio::SeqFeature::SiRNA::Pair; my $pair = Bio::SeqFeature::SiRNA::Pair-> new( -sense => $bio_seqfeature_sirna_oligo, # strand=1 -antisense => $bio_seqfeature_sirna_oligo, # strand= -1 -primary => 'SiRNA::Pair', -source_tag => 'Bio::Tools::SiRNA', -start => 8, -end => 31, -rank => 1, -fxgc => 0.5, -tag => { note => 'a note' } ); $target_sequence->add_SeqFeature($pair); =head1 DESCRIPTION Object methods for (complementary) pairs of L<Bio::SeqFeature::SiRNA::Oligo> objects - inherits L<Bio::SeqFeature::Generic>. See that package for information on inherited methods. Does B<not> include methods for designing SiRNAs -- see L<Bio::Tools::SiRNA> =head1 SEE ALSO L<Bio::SeqFeature::Oligo>, L<Bio::Tools::SiRNA>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Donald Jackson (donald.jackson@bms.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqFeature::SiRNA::Pair; use strict; use warnings; use base qw(Bio::SeqFeature::Generic); # arguments to new(). Taken from Bio::SeqFeature Generic. # Omit frame (not relevant), GFF_STRING and GFF1_STRING # because I'm not sure how to handle them. Add RANK, FXGC, SENSE, ANTISENSE our @ARGNAMES = qw(RANK FXGC SENSE ANTISENSE START END STRAND PRIMARY SOURCE_TAG SCORE TAG SEQNAME ANNOTATION LOCATION); =head1 METHODS =head2 new Title : new Usage : my $sirna_pair = Bio::SeqFeature::SiRNA::Pair->new(); Purpose : Create a new SiRNA::Pair object Returns : Bio::Tools::SiRNA object Args : -start 10 -end 31 -rank 1 # 'Rank' in Tuschl group's rules -fxgc 0.5 # GC fraction for target sequence -primary 'SiRNA::Pair', # default value -source_tag 'Bio::Tools::SiRNA' -tag { note => 'A note' } -sense a Bio::SeqFeature::SiRNA::Oligo object with strand = 1 -antisense a Bio::SeqFeature::SiRNA::Oligo object with strand = -1 ); Note : SiRNA::Pair objects are typically created by a design algorithm such as Bio::Tools::SiRNA =cut sub new { my ($proto, @args) = @_; my $pkg = ref($proto) || $proto; my $self = $pkg->SUPER::new(); my %args; @args{@ARGNAMES} = $self->_rearrange(\@ARGNAMES, @args); # default primary tag $args{'PRIMARY'} ||= 'SiRNA::Pair'; $args{'PRIMARY'} && $self->primary_tag($args{'PRIMARY'}); $args{'SOURCE_TAG'} && $self->source_tag($args{'SOURCE_TAG'}); $args{'SEQNAME'} && $self->seqname($args{'SEQNAME'}); $args{'ANNOTATION'} && $self->annotation($args{'ANNOTATION'}); $args{'LOCATION'} && $self->location($args{'LOCATION'}); $args{'SENSE'} && $self->sense($args{'SENSE'}); $args{'ANTISENSE'} && $self->antisense($args{'ANTISENSE'}); defined($args{'START'}) && $self->start($args{'START'}); defined($args{'END'}) && $self->end($args{'END'}); defined($args{'STRAND'}) && $self->strand($args{'STRAND'}); defined($args{'SCORE'}) && $self->score($args{'SCORE'}); defined($args{'RANK'}) && $self->rank($args{'RANK'}); defined($args{'FXGC'}) && $self->fxGC($args{'FXGC'}); if ($args{'TAG'}) { foreach my $t (keys %{$args{'TAG'}}) { $self->add_tag_value($t, $args{'TAG'}->{$t}); } } return $self; } =head2 rank Title : rank Usage : my $pair_rank = $sirna_pair->rank() Purpose : Get/set the 'quality rank' for this pair. See Bio::Tools::SiRNA for a description of ranks. Returns : scalar Args : scalar (optional) indicating pair rank =cut sub rank { my ($self, $rank) = @_; if (defined $rank) { # first clear out old tags $self->remove_tag('rank') if ( $self->has_tag('rank') ); $self->add_tag_value('rank', $rank); } else { if ($self->has_tag('rank')) { my @ranks = $self->get_tag_values('rank'); return shift @ranks; } else { $self->throw("Rank not defined for this Pair\n"); return; } } } =head2 fxGC Title : fxGC Usage : my $fxGC = $sirna_pair->fxGC(); Purpose : Get/set the fraction of GC for this pair - based on TARGET sequence, not oligos. Returns : scalar between 0-1 Args : scalar between 0-1 (optional) =cut sub fxGC { my ($self, $fxGC) = @_; if (defined $fxGC) { # is this an integer? if ($fxGC =~ /[^.\d]/) { $self->throw( -class => 'Bio::Root::BadParameter', -text => "Fraction GC must be a number between 0, 1 - NOT <$fxGC>", -value => $fxGC ); } if ( $fxGC < 0 or $fxGC > 1 ) { $self->throw( -class => 'Bio::Root::BadParameter', -text => "Fraction GC must be a number between 0, 1 - NOT <$fxGC>", -value => $fxGC ); } # clear out old tags $self->remove_tag('fxGC') if ( $self->has_tag('fxGC') ); $self->add_tag_value('fxGC', $fxGC) or $self->throw("Unable to set fxGC"); } else { if ($self->has_tag('fxGC')) { my @fxGCs = $self->get_tag_values('fxGC'); return shift @fxGCs; } else { $self->throw("FxGC not defined for this Pair"); } } } =head2 sense Title : sense Usage : my $sense_oligo = $sirna_pair->sense() Purpose : Get/set the SiRNA::Oligo object corresponding to the sense strand Returns : Bio::SeqFeature::SiRNA::Oligo object Args : Bio::SeqFeature::SiRNA::Oligo object =cut sub sense { my ($self, $soligo) = @_; if ($soligo) { $self->_add_oligo($soligo, 1) or return; } else { return $self->_get_oligo(1); } } =head2 antisense Title : antisense Usage : my $antisense_oligo = $sirna_pair->antisense() Purpose : Get/set the SiRNA::Oligo object corresponding to the antisense strand Returns : Bio::SeqFeature::SiRNA::Oligo object Args : Bio::SeqFeature::SiRNA::Oligo object =cut sub antisense { my ($self, $asoligo) = @_; if ($asoligo) { $self->_add_oligo($asoligo, -1) or return; } else { return $self->_get_oligo(-1); } } sub _add_oligo { my ($self, $oligo, $strand) = @_; unless ($oligo->isa('Bio::SeqFeature::SiRNA::Oligo')) { $self->throw( -class => 'Bio::Root::BadParameter', -text => "Oligos must be passed as Bio::SeqFeature::SiRNA::Oligo objects\n"); } $oligo->strand($strand); return $self->add_sub_SeqFeature($oligo, 'EXPAND'); } sub _get_oligo { my ($self, $strand) = @_; my $feat; my @feats = $self->sub_SeqFeature; foreach $feat (@feats) { next unless ($feat->primary_tag eq 'SiRNA::Oligo'); next unless ($feat->strand == $strand); return $feat; } return; } 1; �������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Tools����������������������������������������������������������������000755��000765��000024�� 0�12254227333� 17157� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Tools/FeatureNamer.pm������������������������������������������������000444��000765��000024�� 14066�12254227333� 22257� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::SeqFeature::Tools::FeatureNamer # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Mungall <cjm@fruitfly.org> # # Copyright Chris Mungall # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Tools::FeatureNamer - generates unique persistent names for features =head1 SYNOPSIS use Bio::SeqIO; use Bio::SeqFeature::Tools::FeatureNamer; # first fetch a genbank SeqI object $seqio = Bio::SeqIO->new(-file=>'AE003644.gbk', -format=>'GenBank'); $seq = $seqio->next_seq(); $namer = Bio::SeqFeature::Tools::FeatureNamer->new; my @features = $seq->get_SeqFeatures; foreach my $feature (@features) { $namer->name_feature($feature) unless $feature->display_name; } =head1 DESCRIPTION This is a helper class for providing names for SeqFeatures The L<Bio::SeqFeatureI> class provides a display_name method. Typically the display_name is not set when parsing formats such as genbank - instead properties such as B<label>, B<product> or B<gene> are set in a somewhat inconsistent manner. In addition, when generating subfeatures (for example, exons that are subfeatures of a transcript feature), it is often desirable to name these subfeatures before either exporting to another format or reporting to the user. This module is intended to help given uniform display_names to features and their subfeatures. =head1 TODO Currently the naming policy is hardcoded. It may be desirable to allow plugging in variations on naming policies; this could be done either by subclassing, anonymous subroutines (closures) or parameterization. Contact the author if you feel you have need for a different naming policy =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email: cjm AT fruitfly DOT org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Tools::FeatureNamer; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); =head2 new Title : new Usage : $unflattener = Bio::SeqFeature::Tools::FeatureNamer->new(); Function: constructor Example : Returns : a new Bio::SeqFeature::Tools::FeatureNamer Args : see below =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); # my($typemap) = # $self->_rearrange([qw(TYPEMAP # )], # @args);# # $typemap && $self->typemap($typemap); return $self; # success - we hope! } =head2 name_feature Title : name_feature Usage : $namer->name_feature($sf); Function: sets display_name Example : Returns : Args : L<Bio::SeqFeatureI> This method calls generate_feature_name() and uses the returned value to set the display_name of the feature =cut sub name_feature { my ($self, $sf) = @_; my $name = $self->generate_feature_name($sf); $sf->display_name($name); } =head2 name_contained_features Title : name_contained_features Usage : $namer->name_contained_features($sf); Function: sets display_name for all features contained by sf Example : Returns : Args : L<Bio::SeqFeatureI> iterates through all subfeatures of a certain feature (using get_all_SeqFeatures) and names each subfeatures, based on the generated name for the holder feature A subfeature is named by concatenating the generated name of the container feature with the type and a number. For example, if the containing feature is a gene with display name B<dpp>, subfeatures will be named dpp-mRNA-1 dpp-mRNA2 dpp-exon1 dpp-exon2 etc =cut sub name_contained_features{ my ($self,$sf) = @_; my $cname = $self->generate_feature_name($sf); my @subsfs = $sf->get_all_SeqFeatures; my %num_by_type = (); foreach my $ssf (@subsfs) { my $type = $ssf->primary_tag; my $num = $num_by_type{$type} || 0; $num++; $num_by_type{$type} = $num; $ssf->display_name("$cname-$type-$num"); } return; } =head2 generate_feature_name Title : generate_feature_name Usage : $name = $namer->generate_feature_name($sf); Function: derives a sensible human readable name for a $sf Example : Returns : str Args : L<Bio::SeqFeatureI> returns a generated name (but does not actually set display_name). If display_name is already set, the method will return this Otherwise, the name will depend on the property: =over =item label =item product =item gene =item locus_tag =back (in order of priority) =cut sub generate_feature_name { my ($self, $sf) = @_; my $name = $sf->display_name; if (!$name) { if ($sf->has_tag("label")) { ($name) = $sf->get_tag_values("label"); } elsif ($sf->has_tag("product")) { ($name) = $sf->get_tag_values("product"); } elsif ($sf->primary_tag eq 'gene' && $sf->has_tag("gene")) { ($name) = $sf->get_tag_values("gene"); } elsif ($sf->primary_tag eq 'gene' && $sf->has_tag("locus_tag")) { ($name) = $sf->get_tag_values("locus_tag"); } else { $name = $sf->display_name; } } return $name; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Tools/IDHandler.pm���������������������������������������������������000444��000765��000024�� 15666�12254227322� 21500� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::SeqFeature::Tools::IDHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Mungall <cjm@fruitfly.org> # # Copyright Chris Mungall # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Tools::IDHandler - maps $seq_feature-E<gt>primary_tag =head1 SYNOPSIS use Bio::SeqIO; use Bio::SeqFeature::Tools::IDHandler; =head1 DESCRIPTION Class to map $seq_feature-E<gt>primary_tag =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email: cjm@fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Tools::IDHandler; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); =head2 new Title : new Usage : $unflattener = Bio::SeqFeature::Tools::IDHandler->new(); Function: constructor Example : Returns : a new Bio::SeqFeature::Tools::IDHandler Args : see below =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($generate_id_sub) = $self->_rearrange([qw(GENERATE_ID_SUB )], @args); return $self; # success - we hope! } =head2 set_ParentIDs_from_hierarchy() Title : set_ParentIDs_from_hierarchy() Usage : $idhandler->set_ParentIDs_from_hierarchy($fholder) Function: populates tags Parent and ID via holder hierarchy Example : Returns : Args : Bio::featureHolderI (either a SeqFeature or a Seq) This is mainly for GFF3 export GFF3 uses the tags ID and Parent to represent the feature containment hierarchy; it does NOT use the feature holder tree This method sets Parent (and ID for any parents not set) based on feature holder/containement hierarchy, ready for GFF3 output =cut # method author: cjm@fruitfly.org sub set_ParentIDs_from_hierarchy(){ my $self = shift; my ($featholder) = @_; # we will traverse the tree of contained seqfeatures # (a seqfeature is itself a holder) # start with the top-level features my @sfs = $featholder->get_SeqFeatures; # clear existing parent tags # (we assume this is the desired behaviour) my @all_sfs = $featholder->get_all_SeqFeatures; foreach (@all_sfs) { if ($_->has_tag('Parent')) { $_->remove_tag('Parent'); } } # iterate until entire tree traversed while (@sfs) { my $sf = shift @sfs; my @subsfs = $sf->get_SeqFeatures; # see if the ID tag my $id = $sf->primary_id; if (!$id) { # the skolem function feature(seq,start,end,type) # is presumed to uniquely identify this feature, and # to also be persistent $id = $sf->generate_unique_persistent_id; } foreach my $subsf (@subsfs) { $subsf->add_tag_value('Parent', $id); } # push children on to end of stack (breadth first search) push(@sfs, @subsfs); } return; } =head2 create_hierarchy_from_ParentIDs Title : create_hierarchy_from_ParentIDs Usage : $idhandler->set_ParentIDs_from_hierarchy($fholder) Function: inverse of set_ParentIDs_from_hierarchy Example : Returns : list of top SeqFeatures Args : =cut sub create_hierarchy_from_ParentIDs{ my ($self,$featholder,@args) = @_; my @sfs = $featholder->get_all_SeqFeatures; my %sf_by_ID = (); foreach (@sfs) { my $id = $_->primary_id; next unless $id; if ($sf_by_ID{$id}) { $featholder->throw("DUPLICATE ID: $id"); } $sf_by_ID{$id} = $_; $_->remove_SeqFeatures; # clear existing hierarchy (assume this is desired) } if (!%sf_by_ID) { # warn?? # this is actually expected behaviour for some kinds of data; # eg lists of STSs - no containment hierarchy return; } my @topsfs = grep { my @parents = $_->get_tagset_values('Parent'); foreach my $parent (@parents) { $sf_by_ID{$parent}->add_SeqFeature($_) if exists $sf_by_ID{$parent}; } !@parents; } @sfs; $featholder->remove_SeqFeatures; $featholder->add_SeqFeature($_) foreach @topsfs; return @topsfs; } =head2 generate_unique_persistent_id Title : generate_unique_persistent_id Usage : Function: generates a unique and persistent identifier for this Example : Returns : value of primary_id (a scalar) Args : Will generate an ID, B<and> set primary_id() (see above) The ID is a string generated from seq_id primary_tag start end There are three underlying assumptions: that all the above accessors are set; that seq_id is a persistent and unique identifier for the sequence containing this feature; and that (seq_id, primary_tag, start, end) is a "unique constraint" over features The ID is persistent, so long as none of these values change - if they do, it is considered a separate entity =cut # method author: cjm@fruitfly.org sub generate_unique_persistent_id{ my ($self,$sf,@args) = @_; my $id; if (!$sf->isa("Bio::SeqFeatureI")) { $sf->throw("not a Bio::SeqFeatureI"); } my $seq_id = $sf->seq_id || $sf->throw("seq_id must be set: ".$sf->display_name); #my $seq_id = $sf->seq_id || 'unknown_seq'; if ($sf->has_tag('transcript_id')) { ($id) = $sf->get_tag_values('transcript_id'); } elsif ($sf->has_tag('protein_id')) { ($id) = $sf->get_tag_values('protein_id'); } else { my $source = $sf->source_tag || $sf->throw("source tag must be set: ".$sf->display_name); #my $source = $sf->source_tag || 'unknown_source'; my $start = $sf->start || $sf->throw("start must be set or is zero: ".$sf->display_name); my $end = $sf->end || $sf->throw("end must be set"); my $type = $sf->primary_tag || $sf->throw("primary_tag/type must be set: ".$sf->display_name); $id = "$source:$type:$seq_id:$start:$end"; } $sf->primary_id($id); return $id; } 1; ��������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Tools/TypeMapper.pm��������������������������������������������������000444��000765��000024�� 34071�12254227325� 21766� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::SeqFeature::Tools::TypeMapper # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Mungall <cjm@fruitfly.org> # # Copyright Chris Mungall # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Tools::TypeMapper - maps $seq_feature-E<gt>primary_tag =head1 SYNOPSIS use Bio::SeqIO; use Bio::SeqFeature::Tools::TypeMapper; # first fetch a genbank SeqI object $seqio = Bio::SeqIO->new(-file=>'AE003644.gbk', -format=>'GenBank'); $seq = $seqio->next_seq(); $tm = Bio::SeqFeature::Tools::TypeMapper->new; # map all the types in the sequence $tm->map_types(-seq=>$seq, {CDS=>'ORF', variation=>sub { my $f = shift; $f->length > 1 ? 'variation' : 'SNP' }, }); # alternatively, use the hardcoded SO mapping $tm->map_types_to_SO(-seq=>$seq); =head1 DESCRIPTION This class implements an object for mapping between types; for example, the types in a genbank feature table, and the types specified in the Sequence Ontology. You can specify your own mapping, either as a simple hash index, or by providing your own subroutines. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email: cjm@fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Tools::TypeMapper; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); =head2 new Title : new Usage : $unflattener = Bio::SeqFeature::Tools::TypeMapper->new(); Function: constructor Example : Returns : a new Bio::SeqFeature::Tools::TypeMapper Args : see below =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($typemap) = $self->_rearrange([qw(TYPEMAP )], @args); $typemap && $self->typemap($typemap); return $self; # success - we hope! } =head2 typemap Title : typemap Usage : $obj->typemap($newval) Function: Example : Returns : value of typemap (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub typemap{ my $self = shift; return $self->{'typemap'} = shift if @_; return $self->{'typemap'}; } =head2 map_types Title : map_types Usage : Function: Example : Returns : Args : dgg: added -undefined => "region" option to produce all valid SO mappings. =cut sub map_types{ my ($self,@args) = @_; my($sf, $seq, $type_map, $undefmap) = $self->_rearrange([qw(FEATURE SEQ TYPE_MAP UNDEFINED )], @args); if (!$sf && !$seq) { $self->throw("you need to pass in either -feature or -seq"); } my @sfs = ($sf); if ($seq) { $seq->isa("Bio::SeqI") || $self->throw("$seq NOT A SeqI"); @sfs = $seq->get_all_SeqFeatures; } $type_map = $type_map || $self->typemap; # dgg: was type_map; foreach my $sf (@sfs) { $sf->isa("Bio::SeqFeatureI") || $self->throw("$sf NOT A SeqFeatureI"); $sf->isa("Bio::FeatureHolderI") || $self->throw("$sf NOT A FeatureHolderI"); my $type = $sf->primary_tag; my $mtype = $type_map->{$type}; if ($mtype) { if (ref($mtype)) { if (ref($mtype) eq 'CODE') { $mtype = $mtype->($sf); } else { $self->throw('type_map values must be scalar or CODE ref. You said: '.$mtype.' for type: '.$type); } } elsif ($undefmap && $mtype eq 'undefined') { # dgg $mtype= $undefmap; } $sf->primary_tag($mtype); } } return; } =head2 map_types_to_SO Title : map_types_to_SO Usage : Function: Example : Returns : Args : hardcodes the genbank to SO mapping Based on revision 1.22 of SO Please see the actual code for the mappings Taken from L<http://sequenceontology.org/resources/mapping/FT_SO.txt> dgg: separated out FT_SO_map for caller changes. Update with: open(FTSO,"curl -s http://sequenceontology.org/resources/mapping/FT_SO.txt|"); while(<FTSO>){ chomp; ($ft,$so,$sid,$ftdef,$sodef)= split"\t"; print " '$ft' => '$so',\n" if($ft && $so && $ftdef); } =cut sub FT_SO_map { # $self= shift; # note : some of the ft_so mappings are commented out and overriden... return { "-" => ["located_sequence_feature", "so:0000110"], "-10_signal" => ["minus_10_signal", "so:0000175"], "-35_signal" => ["minus_35_signal", "so:0000176"], "3'utr" => ["three_prime_utr", "so:0000205"], "3'clip" => ["three_prime_clip", "so:0000557"], "5'utr" => ["five_prime_utr", "so:0000204"], "5'clip" => ["five_prime_clip", "so:0000555"], "caat_signal" => ["caat_signal", "so:0000172"], "cds" => ["cds", "so:0000316"], "c_region" => ["undefined", ""], "d-loop" => ["d_loop", "so:0000297"], "d_segment" => ["d_gene", "so:0000458"], "gc_signal" => ["gc_rich_region", "so:0000173"], "j_segment" => ["undefined", ""], "ltr" => ["long_terminal_repeat", "so:0000286"], "n_region" => ["undefined", ""], "rbs" => ["ribosome_entry_site", "so:0000139"], "sts" => ["sts", "so:0000331"], "s_region" => ["undefined", ""], "tata_signal" => ["tata_box", "so:0000174"], "v_region" => ["undefined", ""], "v_segment" => ["undefined", ""], "attenuator" => ["attenuator", "so:0000140"], "conflict" => ["undefined", ""], "enhancer" => ["enhancer", "so:0000165"], "exon" => ["exon", "so:0000147"], "gap" => ["gap", "so:0000730"], "gene" => ["gene", "so:0000704"], "idna" => ["idna", "so:0000723"], "intron" => ["intron", "so:0000188"], "mRNA" => ["mRNA", "so:0000234"], "mat_peptide" => ["mature_protein_region", "so:0000419"], "mature_peptide" => ["mature_protein_region", "so:0000419"], #"misc_RNA" => ["transcript", "so:0000673"], "misc_binding" => ["binding_site", "so:0000409"], "misc_difference" => ["sequence_difference", "so:0000413"], "misc_feature" => ["region", undef], "misc_recomb" => ["recombination_feature", "so:0000298"], "misc_signal" => ["regulatory_region", "so:0005836"], "misc_structure" => ["sequence_secondary_structure", "so:0000002"], "modified_base" => ["modified_base_site", "so:0000305"], "old_sequence" => ["undefined", ""], "operon" => ["operon", "so:0000178"], "oriT" => ["origin_of_transfer", "so:0000724"], "polya_signal" => ["polyA_signal_sequence", "so:0000551"], "polya_site" => ["polyA_site", "so:0000553"], "precursor_RNA" => ["primary_transcript", "so:0000185"], "prim_transcript" => ["primary_transcript", "so:0000185"], "primer_bind" => ["primer_binding_site", "so:0005850"], "promoter" => ["promoter", "so:0000167"], "protein_bind" => ["protein_binding_site", "so:0000410"], "rRNA" => ["rRNA", "so:0000252"], "repeat_region" => ["repeat_region", "so:0000657"], "repeat_unit" => ["repeat_unit", "so:0000726"], "satellite" => ["satellite_dna", "so:0000005"], "scRNA" => ["scRNA", "so:0000013"], "sig_peptide" => ["signal_peptide", "so:0000418"], "snRNA" => ["snRNA", "so:0000274"], "snoRNA" => ["snoRNA", "so:0000275"], #"source" => ["databank_entry", "so:2000061"], "stem_loop" => ["stem_loop", "so:0000313"], "tRNA" => ["tRNA", "so:0000253"], "terminator" => ["terminator", "so:0000141"], "transit_peptide" => ["transit_peptide", "so:0000725"], "unsure" => "undefined", "variation" => ["sequence_variant", "so:0000109"], # manually added ## has parent = pseudogene ; dgg "pseudomRNA" => ["pseudogenic_transcript", "so:0000516"], ## from unflattener misc_rna ; dgg "pseudotranscript" => ["pseudogenic_transcript", "so:0000516"], "pseudoexon" => ["pseudogenic_exon", "so:0000507"], "pseudoCDS" => ["pseudogenic_exon", "so:0000507"], "pseudomisc_feature" => ["pseudogenic_region", "so:0000462"], "pseudointron" => ["pseudogenic_region", "so:0000462"], ## "undefined" => "region", # this is the most generic form for rnas; # we always represent the processed form of # the transcript misc_RNA => ['mature_transcript',"so:0000233"], # not sure about this one... source=>['contig', "SO:0000149"], rep_origin=>['origin_of_replication',"SO:0000296"], Protein=>['polypeptide',"SO:0000104"], }; # return { #"FT term" => "SO term", #"-" => "located_sequence_feature", #"-10_signal" => "minus_10_signal", #"-35_signal" => "minus_35_signal", #"3'UTR" => "three_prime_UTR", #"3'clip" => "three_prime_clip", #"5'UTR" => "five_prime_UTR", #"5'clip" => "five_prime_clip", #"CAAT_signal" => "CAAT_signal", #"CDS" => "CDS", #"C_region" => "undefined", #"D-loop" => "D_loop", #"D_segment" => "D_gene", #"GC_signal" => "GC_rich_region", #"J_segment" => "undefined", #"LTR" => "long_terminal_repeat", #"N_region" => "undefined", #"RBS" => "ribosome_entry_site", #"STS" => "STS", #"S_region" => "undefined", #"TATA_signal" => "TATA_box", #"V_region" => "undefined", #"V_segment" => "undefined", #"attenuator" => "attenuator", #"conflict" => "undefined", #"enhancer" => "enhancer", #"exon" => "exon", #"gap" => "gap", #"gene" => "gene", #"iDNA" => "iDNA", #"intron" => "intron", #"mRNA" => "mRNA", #"mat_peptide" => "mature_protein_region", #"mature_peptide" => "mature_protein_region", ## "misc_RNA" => "transcript", #"misc_binding" => "binding_site", #"misc_difference" => "sequence_difference", #"misc_feature" => "region", #"misc_recomb" => "recombination_feature", #"misc_signal" => "regulatory_region", #"misc_structure" => "sequence_secondary_structure", #"modified_base" => "modified_base_site", #"old_sequence" => "undefined", #"operon" => "operon", #"oriT" => "origin_of_transfer", #"polyA_signal" => "polyA_signal_sequence", #"polyA_site" => "polyA_site", #"precursor_RNA" => "primary_transcript", #"prim_transcript" => "primary_transcript", #"primer_bind" => "primer_binding_site", #"promoter" => "promoter", #"protein_bind" => "protein_binding_site", #"rRNA" => "rRNA", #"repeat_region" => "repeat_region", #"repeat_unit" => "repeat_unit", #"satellite" => "satellite_DNA", #"scRNA" => "scRNA", #"sig_peptide" => "signal_peptide", #"snRNA" => "snRNA", #"snoRNA" => "snoRNA", ## "source" => "databank_entry", #"stem_loop" => "stem_loop", #"tRNA" => "tRNA", #"terminator" => "terminator", #"transit_peptide" => "transit_peptide", #"unsure" => "undefined", #"variation" => "sequence_variant", #"pseudomRNA" => "pseudogenic_transcript", ## has parent = pseudogene ; dgg #"pseudotranscript" => "pseudogenic_transcript", ## from Unflattener misc_RNA ; dgg #"pseudoexon" => "pseudogenic_exon", #"pseudoCDS" => "pseudogenic_exon", #"pseudomisc_feature" => "pseudogenic_region", #"pseudointron" => "pseudogenic_region", ### "undefined" => "region", ## this is the most generic form for RNAs; ## we always represent the processed form of ## the transcript #misc_RNA=>'processed_transcript', ## not sure about this one... #source=>'contig', #rep_origin=>'origin_of_replication', #Protein=>'protein', #}; } sub map_types_to_SO{ my ($self,@args) = @_; push(@args, (-type_map=> $self->FT_SO_map() ) ); return $self->map_types(@args); } =head2 get_relationship_type_by_parent_child Title : get_relationship_type_by_parent_child Usage : $type = $tm->get_relationship_type_by_parent_child($parent_sf, $child_sf); Usage : $type = $tm->get_relationship_type_by_parent_child('mRNA', 'protein'); Function: given two features where the parent contains the child, will determine what the relationship between them in Example : Returns : Args : parent SeqFeature, child SeqFeature OR parent type string, child type string OR bioperl Seq::FeatureHolderI hierarchies are equivalent to unlabeled graphs (where parent nodes are the containers, and child nodes are the features being contained). For example, a feature of type mRNA can contain features of type exon. Some external representations (eg chadoxml or chaosxml) require that the edges in the feature relationship graph are labeled. For example, the type between mRNA and exon would be B<part_of>. Although it stretches the bioperl notion of containment, we could have a CDS contained by an mRNA (for example, the L<Bio::SeqFeature::Tools::Unflattener> module takes genbank records and makes these kind of links. The relationship here would be B<produced_by> In chado speak, the child is the B<subject> feature and the parent is the B<object> feature =cut sub get_relationship_type_by_parent_child { my ($self,$parent,$child) = @_; $parent = ref($parent) ? $parent->primary_tag : $parent; $child = ref($child) ? $child->primary_tag : $child; my $type = 'part_of'; # default # TODO - do this with metadata, or infer via SO itself if (lc($child) eq 'protein') { $type = 'derives_from'; } if (lc($child) eq 'polypeptide') { $type = 'derives_from'; } return $type; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqFeature/Tools/Unflattener.pm�������������������������������������������������000444��000765��000024�� 262140�12254227315� 22206� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::SeqFeature::Tools::Unflattener # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Mungall <cjm@fruitfly.org> # # Copyright Chris Mungall # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqFeature::Tools::Unflattener - turns flat list of genbank-sourced features into a nested SeqFeatureI hierarchy =head1 SYNOPSIS # standard / generic use - unflatten a genbank record use Bio::SeqIO; use Bio::SeqFeature::Tools::Unflattener; # generate an Unflattener object $unflattener = Bio::SeqFeature::Tools::Unflattener->new; # first fetch a genbank SeqI object $seqio = Bio::SeqIO->new(-file=>'AE003644.gbk', -format=>'GenBank'); my $out = Bio::SeqIO->new(-format=>'asciitree'); while ($seq = $seqio->next_seq()) { # get top level unflattended SeqFeatureI objects $unflattener->unflatten_seq(-seq=>$seq, -use_magic=>1); $out->write_seq($seq); @top_sfs = $seq->get_SeqFeatures; foreach my $sf (@top_sfs) { # do something with top-level features (eg genes) } } =head1 DESCRIPTION Most GenBank entries for annotated genomic DNA contain a B<flat> list of features. These features can be parsed into an equivalent flat list of L<Bio::SeqFeatureI> objects using the standard L<Bio::SeqIO> classes. However, it is often desirable to B<unflatten> this list into something resembling actual B<gene models>, in which genes, mRNAs and CDSs are B<nested> according to the nature of the gene model. The BioPerl object model allows us to store these kind of associations between SeqFeatures in B<containment hierarchies> -- any SeqFeatureI object can contain nested SeqFeatureI objects. The Bio::SeqFeature::Tools::Unflattener object facilitates construction of these hierarchies from the underlying GenBank flat-feature-list representation. For example, if you were to look at a typical GenBank DNA entry, say, B<AE003644>, you would see a flat list of features: source gene CG4491 mRNA CG4491-RA CDS CG4491-PA gene tRNA-Pro tRNA tRNA-Pro gene CG32954 mRNA CG32954-RA mRNA CG32954-RC mRNA CG32954-RB CDS CG32954-PA CDS CG32954-PB CDS CG32954-PC These features have sequence locations, but it is not immediately clear how to write code such that each mRNA is linked to the appropriate CDS (other than relying on IDs which is very bad) We would like to convert the above list into the B<containment hierarchy>, shown below: source gene mRNA CG4491-RA CDS CG4491-PA exon exon gene tRNA tRNA-Pro exon gene mRNA CG32954-RA CDS CG32954-PA exon exon mRNA CG32954-RC CDS CG32954-PC exon exon mRNA CG32954-RB CDS CG32954-PB exon exon Where each feature is nested underneath its container. Note that exons have been automatically inferred (even for tRNA genes). We do this using a call on a L<Bio::SeqFeature::Tools::Unflattener> object @sfs = $unflattener->unflatten_seq(-seq=>$seq); This would return a list of the B<top level> (i.e. container) SeqFeatureI objects - in this case, genes. Other top level features are possible; for instance, the B<source> feature which is always present, and other features such as B<variation> or B<misc_feature> types. The containment hierarchy can be accessed using the get_SeqFeature() call on any feature object - see L<Bio::SeqFeature::FeatureHolderI>. The following code will traverse the containment hierarchy for a feature: sub traverse { $sf = shift; # $sf isa Bio::SeqfeatureI # ...do something with $sf! # depth first traversal of containment tree @contained_sfs = $sf->get_SeqFeatures; traverse($_) foreach @contained_sfs; } Once you have built the hierarchy, you can do neat stuff like turn the features into 'rich' feature objects (eg L<Bio::SeqFeature::Gene::GeneStructure>) or convert to a suitable format such as GFF3 or chadoxml (after mapping to the Sequence Ontology); this step is not described here. =head1 USING MAGIC Due to the quixotic nature of how features are stored in GenBank/EMBL/DDBJ, there is no guarantee that the default behaviour of this module will produce perfect results. Sometimes it is hard or impossible to build a correct containment hierarchy if the information provided is simply too lossy, as is often the case. If you care deeply about your data, you should always manually inspect the resulting containment hierarchy; you may have to customise the algorithm for building the hierarchy, or even manually tweak the resulting hierarchy. This is explained in more detail further on in the document. However, if you are satisfied with the default behaviour, then you do not need to read any further. Just make sure you set the parameter B<use_magic> - this will invoke incantations which will magically produce good results no matter what the idiosyncracies of the particular GenBank record in question. For example $unflattener->unflatten_seq(-seq=>$seq, -use_magic=>1); The success of this depends on the phase of the moon at the time the entry was submitted to GenBank. Note that the magical recipe is being constantly improved, so the results of invoking magic may vary depending on the bioperl release. If you are skeptical of magic, or you wish to exact fine grained control over how the entry is unflattened, or you simply wish to understand more about how this crazy stuff works, then read on! =head1 PROBLEMATIC DATA AND INCONSISTENCIES Occasionally the Unflattener will have problems with certain records. For example, the record may contain inconsistent data - maybe there is an B<exon> entry that has no corresponding B<mRNA> location. The default behaviour is to throw an exception reporting the problem, if the problem is relatively serious - for example, inconsistent data. You can exert more fine grained control over this - perhaps you want the Unflattener to do the best it can, and report any problems. This can be done - refer to the methods. error_threshold() get_problems() report_problems() ignore_problems() =head1 ALGORITHM This is the default algorithm; you should be able to override any part of it to customise. The core of the algorithm is in two parts =over =item Partitioning the flat feature list into groups =item Resolving the feature containment hierarchy for each group =back There are other optional steps after the completion of these two steps, such as B<inferring exons>; we now describe in more detail what is going on. =head2 Partitioning into groups First of all the flat feature list is partitioned into B<group>s. The default way of doing this is to use the B<gene> attribute; if we look at two features from GenBank accession AE003644.3: gene 20111..23268 /gene="noc" /locus_tag="CG4491" /note="last curated on Thu Dec 13 16:51:32 PST 2001" /map="35B2-35B2" /db_xref="FLYBASE:FBgn0005771" mRNA join(20111..20584,20887..23268) /gene="noc" /locus_tag="CG4491" /product="CG4491-RA" /db_xref="FLYBASE:FBgn0005771" Both these features share the same /gene tag which is "noc", so they correspond to the same gene model (the CDS feature is not shown, but this also has a tag-value /gene="noc"). Not all groups need to correspond to gene models, but this is the most common use case; later on we shall describe how to customise the grouping. Sometimes other tags have to be used; for instance, if you look at the entire record for AE003644.3 you will see you actually need the use the /locus_tag attribute. This attribute is actually B<not present> in most records! You can override this: $collection->unflatten_seq(-seq=>$seq, -group_tag=>'locus_tag'); Alternatively, if you B<-use_magic>, the object will try and make a guess as to what the correct group_tag should be. At the end of this step, we should have a list of groups - there is no structure within a group; the group just serves to partition the flat features. For the example data above, we would have the following groups. [ source ] [ gene mRNA CDS ] [ gene mRNA CDS ] [ gene mRNA CDS ] [ gene mRNA mRNA mRNA CDS CDS CDS ] =head3 Multicopy Genes Multicopy genes are usually rRNAs or tRNAs that are duplicated across the genome. Because they are functionally equivalent, and usually have the same sequence, they usually have the same group_tag (ie gene symbol); they often have a /note tag giving copy number. This means they will end up in the same group. This is undesirable, because they are spatially disconnected. There is another step, which involves splitting spatially disconnected groups into distinct groups this would turn this [gene-rrn3 rRNA-rrn3 gene-rrn3 rRNA-rrn3] into this [gene-rrn3 rRNA-rrn3] [gene-rrn3 rRNA-rrn3] based on the coordinates =head3 What next? The next step is to add some structure to each group, by making B<containment hierarchies>, trees that represent how the features interrelate =head2 Resolving the containment hierarchy After the grouping is done, we end up with a list of groups which probably contain features of type 'gene', 'mRNA', 'CDS' and so on. Singleton groups (eg the 'source' feature) are ignored at this stage. Each group is itself flat; we need to add an extra level of organisation. Usually this is because different spliceforms (represented by the 'mRNA' feature) can give rise to different protein products (indicated by the 'CDS' feature). We want to correctly associate mRNAs to CDSs. We want to go from a group like this: [ gene mRNA mRNA mRNA CDS CDS CDS ] to a containment hierarchy like this: gene mRNA CDS mRNA CDS mRNA CDS In which each CDS is nested underneath the correct corresponding mRNA. For entries that contain no alternate splicing, this is simple; we know that the group [ gene mRNA CDS ] Must resolve to the tree gene mRNA CDS How can we do this in entries with alternate splicing? The bad news is that there is no guaranteed way of doing this correctly for any GenBank entry. Occasionally the submission will have been done in such a way as to reconstruct the containment hierarchy. However, this is not consistent across databank entries, so no generic solution can be provided by this object. This module does provide the framework within which you can customise a solution for the particular dataset you are interested in - see later. The good news is that there is an inference we can do that should produce pretty good results the vast majority of the time. It uses splice coordinate data - this is the default behaviour of this module, and is described in detail below. =head2 Using splice site coordinates to infer containment If an mRNA is to be the container for a CDS, then the splice site coordinates (or intron coordinates, depending on how you look at it) of the CDS must fit inside the splice site coordinates of the mRNA. Ambiguities can still arise, but the results produced should still be reasonable and consistent at the sequence level. Look at this fake example: mRNA XXX---XX--XXXXXX--XXXX join(1..3,7..8,11..16,19..23) mRNA XXX-------XXXXXX--XXXX join(1..3,11..16,19..23) CDS XXXX--XX join(13..16,19..20) CDS XXXX--XX join(13..16,19..20) [obviously the positions have been scaled down] We cannot unambiguously match mRNA with CDS based on splice sites, since both CDS share the splice site locations 16^17 and 18^19. However, the consequences of making a wrong match are probably not very severe. Any annotation data attached to the first CDS is probably identical to the seconds CDS, other than identifiers. The default behaviour of this module is to make an arbitrary call where it is ambiguous (the mapping will always be bijective; i.e. one mRNA -E<gt> one CDS). [TODO: NOTE: not tested on EMBL data, which may not be bijective; ie two mRNAs can share the same CDS??] This completes the building of the containment hierarchy; other optional step follow =head1 POST-GROUPING STEPS =head2 Inferring exons from mRNAs This step always occurs if B<-use_magic> is invoked. In a typical GenBank entry, the exons are B<implicit>. That is they can be inferred from the mRNA location. For example: mRNA join(20111..20584,20887..23268) This tells us that this particular transcript has two exons. In bioperl, the mRNA feature will have a 'split location'. If we call $unflattener->feature_from_splitloc(-seq=>$seq); This will generate the necessary exon features, and nest them under the appropriate mRNAs. Note that the mRNAs will no longer have split locations - they will have simple locations spanning the extent of the exons. This is intentional, to avoid redundancy. Occasionally a GenBank entry will have both implicit exons (from the mRNA location) B<and> explicit exon features. In this case, exons will still be transferred. Tag-value data from the explicit exon will be transfered to the implicit exon. If exons are shared between mRNAs these will be represented by different objects. Any inconsistencies between implicit and explicit will be reported. =head3 tRNAs and other noncoding RNAs exons will also be generated from these features =head2 Inferring mRNAs from CDS Some GenBank entries represent gene models using features of type gene, mRNA and CDS; some entries just use gene and CDS. If we only have gene and CDS, then the containment hierarchies will look like this: gene CDS If we want the containment hierarchies to be uniform, like this gene mRNA CDS Then we must create an mRNA feature. This will have identical coordinates to the CDS. The assumption is that there is either no untranslated region, or it is unknown. To do this, we can call $unflattener->infer_mRNA_from_CDS(-seq=>$seq); This is taken care of automatically, if B<-use_magic> is invoked. =head1 ADVANCED =head2 Customising the grouping of features The default behaviour is suited mostly to building models of protein coding genes and noncoding genes from genbank genomic DNA submissions. You can change the tag used to partition the feature by passing in a different group_tag argument - see the unflatten_seq() method Other behaviour may be desirable. For example, even though SNPs (features of type 'variation' in GenBank) are not actually part of the gene model, it may be desirable to group SNPs that overlap or are nearby gene models. It should certainly be possible to extend this module to do this. However, I have yet to code this part!!! If anyone would find this useful let me know. In the meantime, you could write your own grouping subroutine, and feed the results into unflatten_groups() [see the method documentation below] =head2 Customising the resolution of the containment hierarchy Once the flat list of features has been partitioned into groups, the method unflatten_group() is called on each group to build a tree. The algorithm for doing this is described above; ambiguities are resolved by using splice coordinates. As discussed, this can be ambiguous. Some submissions may contain information in tags/attributes that hint as to the mapping that needs to be made between the features. For example, with the Drosophila Melanogaster release 3 submission, we see that CDS features in alternately spliced mRNAs have a form like this: CDS join(145588..145686,145752..146156,146227..146493) /locus_tag="CG32954" /note="CG32954 gene product from transcript CG32954-RA" ^^^^^^^^^^^^^^^^^^^^^^^^^^^ /codon_start=1 /product="CG32954-PA" /protein_id="AAF53403.1" /db_xref="GI:7298167" /db_xref="FLYBASE:FBgn0052954" /translation="MSFTLTNKNVIFVAGLGGIGLDTSKELLKRDLKNLVILDRIENP..." Here the /note tag provides the clue we need to link CDS to mRNA (highlighted with ^^^^). We just need to find the mRNA with the tag /product="CG32954-RA" I have no idea how consistent this practice is across submissions; it is consistent for the fruitfly genome submission. We can customise the behaviour of unflatten_group() by providing our own resolver method. This obviously requires a bit of extra programming, but there is no way to get around this. Here is an example of how to pass in your own resolver; this example basically checks the parent (container) /product tag to see if it matches the required string in the child (contained) /note tag. $unflattener->unflatten_seq(-seq=>$seq, -group_tag=>'locus_tag', -resolver_method=>sub { my $self = shift; my ($sf, @candidate_container_sfs) = @_; if ($sf->has_tag('note')) { my @notes = $sf->get_tag_values('note'); my @trnames = map {/from transcript\s+(.*)/; $1} @notes; @trnames = grep {$_} @trnames; my $trname; if (@trnames == 0) { $self->throw("UNRESOLVABLE"); } elsif (@trnames == 1) { $trname = $trnames[0]; } else { $self->throw("AMBIGUOUS: @trnames"); } my @container_sfs = grep { my ($product) = $_->has_tag('product') ? $_->get_tag_values('product') : (''); $product eq $trname; } @candidate_container_sfs; if (@container_sfs == 0) { $self->throw("UNRESOLVABLE"); } elsif (@container_sfs == 1) { # we got it! return $container_sfs[0]; } else { $self->throw("AMBIGUOUS"); } } }); the resolver method is only called when there is more than one spliceform. =head2 Parsing mRNA records Some of the entries in sequence databanks are for mRNA sequences as well as genomic DNA. We may want to build models from these too. NOT YET DONE - IN PROGRESS!!! Open question - what would these look like? Ideally we would like a way of combining a mRNA record with the corresponding SeFeature entry from the appropriate genomic DNA record. This could be problemmatic in some cases - for example, the mRNA sequences may not match 100% (due to differences in strain, assembly problems, sequencing problems, etc). What then...? =head1 SEE ALSO Feature table description http://www.ebi.ac.uk/embl/Documentation/FT_definitions/feature_table.html =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email: cjm@fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqFeature::Tools::Unflattener; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Location::Simple; use Bio::SeqFeature::Generic; use Bio::Range; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $unflattener = Bio::SeqFeature::Tools::Unflattener->new(); $unflattener->unflatten_seq(-seq=>$seq); Function: constructor Example : Returns : a new Bio::SeqFeature::Tools::Unflattener Args : see below Arguments -seq : A L<Bio::SeqI> object (optional) the sequence to unflatten; this can also be passed in when we call unflatten_seq() -group_tag : a string representing the /tag used to partition flat features (see discussion above) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($seq, $group_tag, $trust_grouptag) = $self->_rearrange([qw(SEQ GROUP_TAG TRUST_GROUPTAG )], @args); $seq && $self->seq($seq); $group_tag && $self->group_tag($group_tag); # $self->{'trust_grouptag'}= $trust_grouptag if($trust_grouptag); #dgg suggestion return $self; # success - we hope! } sub DESTROY { my $self = shift; return if $self->{_reported_problems}; return if $self->{_ignore_problems}; my @probs = $self->get_problems; if (!$self->{_problems_reported} && scalar(@probs)) { $self->warn( "WARNING: There are UNREPORTED PROBLEMS.\n". "You may wish to use the method report_problems(), \n", "or ignore_problems() on the Unflattener object\n"); } return; } =head2 seq Title : seq Usage : $unflattener->seq($newval) Function: Example : Returns : value of seq (a Bio::SeqI) Args : on set, new value (a Bio::SeqI, optional) The Bio::SeqI object should hold a flat list of Bio::SeqFeatureI objects; this is the list that will be unflattened. The sequence object can also be set when we call unflatten_seq() =cut sub seq{ my $self = shift; return $self->{'seq'} = shift if @_; return $self->{'seq'}; } =head2 group_tag Title : group_tag Usage : $unflattener->group_tag($newval) Function: Example : Returns : value of group_tag (a scalar) Args : on set, new value (a scalar or undef, optional) This is the tag that will be used to collect elements from the flat feature list into groups; for instance, if we look at two typical GenBank features: gene 20111..23268 /gene="noc" /locus_tag="CG4491" /note="last curated on Thu Dec 13 16:51:32 PST 2001" /map="35B2-35B2" /db_xref="FLYBASE:FBgn0005771" mRNA join(20111..20584,20887..23268) /gene="noc" /locus_tag="CG4491" /product="CG4491-RA" /db_xref="FLYBASE:FBgn0005771" We can see that these comprise the same gene model because they share the same /gene attribute; we want to collect these together in groups. Setting group_tag is optional. The default is to use 'gene'. In the example above, we could also use /locus_tag =cut sub group_tag{ my $self = shift; return $self->{'group_tag'} = shift if @_; return $self->{'group_tag'}; } =head2 partonomy Title : partonomy Usage : $unflattener->partonomy({mRNA=>'gene', CDS=>'mRNA') Function: Example : Returns : value of partonomy (a scalar) Args : on set, new value (a scalar or undef, optional) A hash representing the containment structure that the seq_feature nesting should conform to; each key represents the contained (child) type; each value represents the container (parent) type. =cut sub partonomy{ my $self = shift; return $self->{'partonomy'} = shift if @_; if (!$self->{'partonomy'}) { $self->{'partonomy'} = $self->_default_partonomy; } return $self->{'partonomy'}; } sub _default_partonomy{ return { mRNA => 'gene', tRNA => 'gene', rRNA => 'gene', scRNA => 'gene', snRNA => 'gene', snoRNA => 'gene', misc_RNA => 'gene', CDS => 'mRNA', exon => 'mRNA', intron => 'mRNA', pseudoexon => 'pseudogene', pseudointron => 'pseudogene', pseudotranscript => 'pseudogene', }; } =head2 structure_type Title : structure_type Usage : $unflattener->structure_type($newval) Function: Example : Returns : value of structure_type (a scalar) Args : on set, new value (an int or undef, optional) GenBank entries conform to different flavours, or B<structure types>. Some have mRNAs, some do not. Right now there are only two base structure types defined. If you set the structure type, then appropriate unflattening action will be taken. The presence or absence of explicit exons does not affect the structure type. If you invoke B<-use_magic> then this will be set automatically, based on the content of the record. =over =item Type 0 (DEFAULT) typically contains source gene mRNA CDS with this structure type, we want the seq_features to be nested like this gene mRNA CDS exon exons and introns are implicit from the mRNA 'join' location to get exons from the mRNAs, you will need this call (see below) $unflattener->feature_from_splitloc(-seq=>$seq); =item Type 1 typically contains source gene CDS exon [optional] intron [optional] there are no mRNA features with this structure type, we want the seq_features to be nested like this gene CDS exon intron exon and intron may or may not be present; they may be implicit from the CDS 'join' location =back =cut sub structure_type{ my $self = shift; return $self->{'structure_type'} = shift if @_; return $self->{'structure_type'}; } =head2 get_problems Title : get_problems Usage : @probs = get_problems() Function: Get the list of problem(s) for this object. Example : Returns : An array of [severity, description] pairs Args : In the course of unflattening a record, problems may occur. Some of these problems are non-fatal, and can be ignored. Problems are represented as arrayrefs containing a pair [severity, description] severity is a number, the higher, the more severe the problem the description is a text string =cut sub get_problems{ my $self = shift; return @{$self->{'_problems'}} if exists($self->{'_problems'}); return (); } =head2 clear_problems Title : clear_problems Usage : Function: resets the problem list to empty Example : Returns : Args : =cut sub clear_problems{ my ($self,@args) = @_; $self->{'_problems'} = []; return; } # PRIVATE # see get_problems sub add_problem{ my $self = shift; $self->{'_problems'} = [] unless exists($self->{'_problems'}); if ($self->verbose > 0) { warn( "PROBLEM: $_\n") foreach @_; } push(@{$self->{'_problems'}}, @_); } # PRIVATE # see get_problems sub problem { my $self = shift; my ($severity, $desc, @sfs) = @_; if (@sfs) { foreach my $sf (@sfs) { $desc .= sprintf("\nSF [$sf]: %s\n", join('; ', $sf->primary_tag, map { $sf->has_tag($_) ? $sf->get_tag_values($_) : () } qw(gene product label))); } } my $thresh = $self->error_threshold; if ($severity > $thresh) { $self->{_problems_reported} = 1; $self->throw("PROBLEM, SEVERITY==$severity\n$desc"); } $self->add_problem([$severity, $desc]); return; } =head2 report_problems Title : report_problems Usage : $unflattener->report_problems(\*STDERR); Function: Example : Returns : Args : FileHandle (defaults to STDERR) =cut sub report_problems{ my ($self, $fh) = @_; if (!$fh) { $fh = \*STDERR; } foreach my $problem ($self->get_problems) { my ($sev, $desc) = @$problem; printf $fh "PROBLEM, SEVERITY==$sev\n$desc\n"; } $self->{_problems_reported} = 1; return; } =head2 ignore_problems Title : ignore_problems Usage : $obj->ignore_problems(); Function: Example : Returns : Args : Unflattener is very particular about problems it finds along the way. If you have set the error_threshold such that less severe problems do not cause exceptions, Unflattener still expects you to report_problems() at the end, so that the user of the module is aware of any inconsistencies or problems with the data. In fact, a warning will be produced if there are unreported problems. To silence, this warning, call the ignore_problems() method before the Unflattener object is destroyed. =cut sub ignore_problems{ my ($self) = @_; $self->{_ignore_problems} = 1; return; } =head2 error_threshold Title : error_threshold Usage : $obj->error_threshold($severity) Function: Example : Returns : value of error_threshold (a scalar) Args : on set, new value (an integer) Sets the threshold above which errors cause this module to throw an exception. The default is 0; all problems with a severity E<gt> 0 will cause an exception. If you raise the threshold to 1, then the unflattening process will be more lax; problems of severity==1 are generally non-fatal, but may indicate that the results should be inspected, for example, to make sure there is no data loss. =cut sub error_threshold{ my $self = shift; return $self->{'error_threshold'} = shift if @_; return $self->{'error_threshold'} || 0; } # PRIVATE # # given a type (eg mRNA), will return the container type (eg gene) sub get_container_type{ my ($self,$type) = @_; my @roots = $self->_get_partonomy_roots; if (grep {$_ eq $type} @roots) { # it is a root - no parents/containers return; } my $ch = $self->partonomy; my $ctype = $ch->{$type}; if (!$ctype) { # asterix acts as a wild card $ctype = $ch->{'*'}; } return $ctype; } # get root node of partonomy hierarchy (usually gene) sub _get_partonomy_roots { my $self = shift; my $ch = $self->partonomy; my @parents = values %$ch; # find parents that do not have parents themselves return grep {!$ch->{$_}} @parents; } =head2 unflatten_seq Title : unflatten_seq Usage : @sfs = $unflattener->unflatten_seq($seq); Function: turns a flat list of features into a list of holder features Example : Returns : list of Bio::SeqFeatureI objects Args : see below partitions a list of features then arranges them in a nested tree; see above for full explanation. note - the Bio::SeqI object passed in will be modified Arguments -seq : a Bio::SeqI object; must contain Bio::SeqFeatureI objects (this is optional if seq has already been set) -use_magic: if TRUE (ie non-zero) then magic will be invoked; see discussion above. -resolver_method: a CODE reference see the documentation above for an example of a subroutine that can be used to resolve hierarchies within groups. this is optional - if nothing is supplied, a default subroutine will be used (see below) -group_tag: a string [ see the group_tag() method ] this overrides the default group_tag which is 'gene' =cut sub unflatten_seq{ my ($self,@args) = @_; my($seq, $resolver_method, $group_tag, $partonomy, $structure_type, $resolver_tag, $use_magic, $noinfer) = $self->_rearrange([qw(SEQ RESOLVER_METHOD GROUP_TAG PARTONOMY STRUCTURE_TYPE RESOLVER_TAG USE_MAGIC NOINFER )], @args); # seq we want to unflatten $seq = $seq || $self->seq; if (!$self->seq) { $self->seq($seq); } # prevent bad argument combinations if ($partonomy && defined($structure_type)) { $self->throw("You cannot set both -partonomy and -structure_type\n". "(the former is implied by the latter)"); } # remember the current value of partonomy, to reset later my $old_partonomy = $self->partonomy; $self->partonomy($partonomy) if defined $partonomy; # remember old structure_type my $old_structure_type = $self->structure_type; $self->structure_type($structure_type) if defined $structure_type; # if we are sourcing our data from genbank, all the # features should be flat (eq no sub_SeqFeatures) my @flat_seq_features = $seq->get_SeqFeatures; my @all_seq_features = $seq->get_all_SeqFeatures; # sanity checks if (@all_seq_features > @flat_seq_features) { $self->throw("It looks as if this sequence has already been unflattened"); } if (@all_seq_features < @flat_seq_features) { $self->throw("ASSERTION ERROR: something is seriously wrong with your features"); } # tag for ungrouping; usually /gene or /locus_tag # for example: /gene="foo" $group_tag = $group_tag || $self->group_tag; if ($use_magic) { # use magic to guess the group tag my @sfs_with_locus_tag = grep {$_->has_tag("locus_tag")} @flat_seq_features; my @sfs_with_gene_tag = grep {$_->has_tag("gene")} @flat_seq_features; my @sfs_with_product_tag = grep {$_->has_tag("product")} @flat_seq_features; # if ($group_tag && $self->{'trust_grouptag'}) { # dgg suggestion # # } # elsif if (@sfs_with_locus_tag) { # dgg note: would like to -use_magic with -group_tag = 'gene' for ensembl genomes # where ensembl gene FT have both /locus_tag and /gene, but mRNA, CDS have /gene only if ($group_tag && $group_tag ne 'locus_tag') { $self->throw("You have explicitly set group_tag to be '$group_tag'\n". "However, I detect that some features use /locus_tag\n". "I believe that this is the correct group_tag to use\n". "You can resolve this by either NOT setting -group_tag\n". "OR you can unset -use_magic to regain control"); } # use /locus_tag instead of /gene tag for grouping # see GenBank entry AE003677 (version 3) for an example $group_tag = 'locus_tag'; if ($self->verbose > 0) { warn "Set group tag to: $group_tag\n"; } } # on rare occasions, records will have no /gene or /locus_tag # but it WILL have /product tags. These serve the same purpose # for grouping. For an example, see AY763288 (also in t/data) if (@sfs_with_locus_tag==0 && @sfs_with_gene_tag==0 && @sfs_with_product_tag>0 && !$group_tag) { $group_tag = 'product'; if ($self->verbose > 0) { warn "Set group tag to: $group_tag\n"; } } } if (!$group_tag) { $group_tag = 'gene'; } # ------------------------------ # GROUP FEATURES using $group_tag # collect features into unstructured groups # ------------------------------ # ------------- # we want to generate a list of groups; # each group is a list of SeqFeatures; this # group probably (but not necessarily) # corresponds to a gene model. # # this array will look something like this: # ([$f1], [$f2, $f3, $f4], ...., [$f97, $f98, $f99]) # # there are also 'singleton' groups, with one member. # for instance, the 'source' feature is in a singleton group; # the same with others such as 'misc_feature' my @groups = (); # ------------- # -------------------- # we hope that the genbank record allows us to group by some grouping # tag. # for instance, most of the time a gene model can be grouped using # the gene tag - that is where you see # /gene="foo" # in a genbank record # -------------------- # keep an index of groups by their # grouping tag my %group_by_tag = (); # iterate through all features, putting them into groups foreach my $sf (@flat_seq_features) { if (!$sf->has_tag($group_tag)) { # SINGLETON # this is an ungroupable feature; # add it to a group of its own push(@groups, [$sf]); } else { # NON-SINGLETON my @group_tagvals = $sf->get_tag_values($group_tag); if (@group_tagvals > 1) { # sanity check: # currently something can only belong to one group $self->problem(2, ">1 value for /$group_tag: @group_tagvals\n". "At this time this module is not equipped to handle this adequately", $sf); } # get value of group tag my $gtv = shift @group_tagvals; $gtv || $self->throw("Empty /$group_tag vals not allowed!"); # is this a new group? my $group = $group_by_tag{$gtv}; if ($group) { # this group has been encountered before - add current # sf to the end of the group push(@$group, $sf); } else { # new group; add to index and create new group $group = [$sf]; # currently one member; probably more to come $group_by_tag{$gtv} = $group; push(@groups, $group); } } } # as well as having the same group_tag, a group should be spatially # connected. if not, then the group should be split into subgroups. # this turns out to be necessary in the case of multicopy genes. # the standard way to represent these is as spatially disconnected # gene models (usually a 'gene' feature and some kind of RNA feature) # with the same group tag; the code below will split these into # seperate groups, one per copy. @groups = map { $self->_split_group_if_disconnected($_) } @groups; # remove any duplicates; most of the time the method below has # no effect. there are some unusual genbank records for which # duplicate removal is necessary. see the comments in the # _remove_duplicates_from_group() method if you want to know # the ugly details foreach my $group (@groups) { $self->_remove_duplicates_from_group($group); } # - # PSEUDOGENES, PSEUDOEXONS AND PSEUDOINTRONS # these are indicated with the /pseudo tag # these are mapped to a different type; they should NOT # be treated as normal genes foreach my $sf (@all_seq_features) { if ($sf->has_tag('pseudo')) { my $type = $sf->primary_tag; # SO type is typically the same as the normal # type but preceeded by "pseudo" if ($type eq 'misc_RNA' || $type eq 'mRNA') { # dgg: see TypeMapper; both pseudo mRNA,misc_RNA should be pseudogenic_transcript $sf->primary_tag("pseudotranscript"); } else { $sf->primary_tag("pseudo$type"); } } } # now some of the post-processing that follows which applies to # genes will NOT be applied to pseudogenes; this is deliberate # for example, gene models are normalised to be gene-transcript-exon # for pseudogenes we leave them as pseudogene-pseudoexon # --- MAGIC --- my $need_to_infer_exons = 0; my $need_to_infer_mRNAs = 0; my @removed_exons = (); if ($use_magic) { if (defined($structure_type)) { $self->throw("Can't combine use_magic AND setting structure_type"); } my $n_introns = scalar(grep {$_->primary_tag eq 'exon'} @flat_seq_features); my $n_exons = scalar(grep {$_->primary_tag eq 'exon'} @flat_seq_features); my $n_mrnas = scalar(grep {$_->primary_tag eq 'mRNA'} @flat_seq_features); my $n_mrnas_attached_to_gene = scalar(grep {$_->primary_tag eq 'mRNA' && $_->has_tag($group_tag)} @flat_seq_features); my $n_cdss = scalar(grep {$_->primary_tag eq 'CDS'} @flat_seq_features); my $n_rnas = scalar(grep {$_->primary_tag =~ /RNA/} @flat_seq_features); # Are there any CDS features in the record? if ($n_cdss > 0) { # YES # - a pc gene model should contain at the least a CDS # Are there any mRNA features in the record? if ($n_mrnas == 0) { # NO mRNAs: # looks like structure_type == 1 $structure_type = 1; $need_to_infer_mRNAs = 1; } elsif ($n_mrnas_attached_to_gene == 0) { # $n_mrnas > 0 # $n_mrnas_attached_to_gene = 0 # # The entries _do_ contain mRNA features, # but none of them are part of a group/gene, i.e. they # are 'floating' # this is an annoying weird file that has some floating # mRNA features; # eg ftp.ncbi.nih.gov/genomes/Schizosaccharomyces_pombe/ if ($self->verbose) { my @floating_mrnas = grep {$_->primary_tag eq 'mRNA' && !$_->has_tag($group_tag)} @flat_seq_features; printf STDERR "Unattached mRNAs:\n"; foreach my $mrna (@floating_mrnas) { $self->_write_sf_detail($mrna); } printf STDERR "Don't know how to deal with these; filter at source?\n"; } foreach (@flat_seq_features) { if ($_->primary_tag eq 'mRNA') { # what should we do?? # I think for pombe we just have to filter # out bogus mRNAs prior to starting } } # looks like structure_type == 2 $structure_type = 2; $need_to_infer_mRNAs = 1; } else { } # we always infer exons in magic mode $need_to_infer_exons = 1; } else { # this doesn't seem to be any kind of protein coding gene model if ( $n_rnas > 0 ) { $need_to_infer_exons = 1; } } $need_to_infer_exons = 0 if $noinfer; #NML if ($need_to_infer_exons) { # remove exons and introns from group - # we will infer exons later, and we # can always infer introns from exons foreach my $group (@groups) { @$group = grep { my $type = $_->primary_tag(); if ($type eq 'exon') { # keep track of all removed exons, # so we can do a sanity check later push(@removed_exons, $_); } $type ne 'exon' && $type ne 'intron' } @$group; } # get rid of any groups that have zero members @groups = grep {scalar(@$_)} @groups; } } # --- END OF MAGIC --- # LOGICAL ASSERTION if (grep {!scalar(@$_)} @groups) { $self->throw("ASSERTION ERROR: empty group"); } # LOGGING if ($self->verbose > 0) { printf STDERR "GROUPS:\n"; foreach my $group (@groups) { $self->_write_group($group, $group_tag); } } # - # --------- FINISHED GROUPING ------------- # TYPE CONTAINMENT HIERARCHY (aka partonomy) # set the containment hierarchy if desired # see docs for structure_type() method if ($structure_type) { if ($structure_type == 1) { $self->partonomy( {CDS => 'gene', exon => 'CDS', intron => 'CDS', } ); } else { $self->throw("structure_type $structure_type is currently unknown"); } } # see if we have an obvious resolver_tag if ($use_magic) { foreach my $sf (@all_seq_features) { if ($sf->has_tag('derived_from')) { $resolver_tag = 'derived_from'; } } } if ($use_magic) { # point all feature types without a container type to the root type. # # for example, if we have an unanticipated feature_type, say # 'aberration', this should by default point to the parent 'gene' foreach my $group (@groups) { my @sfs = @$group; if (@sfs > 1) { foreach my $sf (@sfs) { my $type = $sf->primary_tag; next if $type eq 'gene'; my $container_type = $self->get_container_type($type); if (!$container_type) { $self->partonomy->{$type} = 'gene'; } } } } } # we have done the first part of the unflattening. # we now have a list of groups; each group is a list of seqfeatures. # the actual group itself is flat; we may want to unflatten this further; # for instance, a gene model can contain multiple mRNAs and CDSs. We may want # to link the correct mRNA to the correct CDS via the bioperl sub_SeqFeature tree. # # what we would end up with would be # gene1 # mRNA-a # CDS-a # mRNA-b # CDS-b my @top_sfs = $self->unflatten_groups(-groups=>\@groups, -resolver_method=>$resolver_method, -resolver_tag=>$resolver_tag); # restore settings $self->partonomy($old_partonomy); # restore settings $self->structure_type($old_structure_type); # modify the original Seq object - the top seqfeatures are now # the top features from each group $seq->remove_SeqFeatures; $seq->add_SeqFeature($_) foreach @top_sfs; # --------- FINISHED UNFLATTENING ------------- # lets see if there are any post-unflattening tasks we need to do # INFERRING mRNAs if ($need_to_infer_mRNAs) { if ($self->verbose > 0) { printf STDERR "** INFERRING mRNA from CDS\n"; } $self->infer_mRNA_from_CDS(-seq=>$seq, -noinfer=>$noinfer); } # INFERRING exons if ($need_to_infer_exons) { # infer exons, one group/gene at a time foreach my $sf (@top_sfs) { my @sub_sfs = ($sf, $sf->get_all_SeqFeatures); $self->feature_from_splitloc(-features=>\@sub_sfs); } # some exons are stated explicitly; ie there is an "exon" feature # most exons are inferred; ie there is a "mRNA" feature with # split locations # # if there were exons explicitly stated in the entry, we need to # do two things: # # make sure these exons are consistent with the inferred exons # (you never know) # # transfer annotation (tag-vals) from the explicit exon to the # new inferred exon if (@removed_exons) { my @allfeats = $seq->get_all_SeqFeatures; # find all the inferred exons that are children of mRNA my @mrnas = grep {$_->primary_tag eq 'mRNA'} @allfeats; my @exons = grep {$_->primary_tag eq 'exon'} map {$_->get_SeqFeatures} @mrnas; my %exon_h = (); # index of exons by location; # there CAN be >1 exon at a location; we can represent these redundantly # (ie as a tree, not a graph) push(@{$exon_h{$self->_locstr($_)}}, $_) foreach @exons; my @problems = (); # list of problems; # each problem is a # [$severity, $description] pair my $problem = ''; my ($n_exons, $n_removed_exons) = (scalar(keys %exon_h), scalar(@removed_exons)); foreach my $removed_exon (@removed_exons) { my $locstr = $self->_locstr($removed_exon); my $inferred_exons = $exon_h{$locstr}; delete $exon_h{$locstr}; if ($inferred_exons) { my %exons_done = (); foreach my $exon (@$inferred_exons) { # make sure we don't move stuff twice next if $exons_done{$exon}; $exons_done{$exon} = 1; # we need to tranfer any tag-values from the explicit # exon to the implicit exon foreach my $tag ($removed_exon->get_all_tags) { my @vals = $removed_exon->get_tag_values($tag); if (!$exon->can("add_tag_value")) { # I'm puzzled as to what should be done here; # SeqFeatureIs are not necessarily mutable, # but we know that in practice the implementing # class is mutable $self->throw("The SeqFeature object does not ". "implement add_tag_value()"); } $exon->add_tag_value($tag, @vals); } } } else { # no exons inferred at $locstr push(@problems, [1, "there is a conflict with exons; there was an explicitly ". "stated exon with location $locstr, yet I cannot generate ". "this exon from the supplied mRNA locations\n"]); } } # do we have any inferred exons left over, that were not # covered in the explicit exons? if (keys %exon_h) { # TODO - we ignore this problem for now push(@problems, [1, sprintf("There are some inferred exons that are not in the ". "explicit exon list; they are the exons at locations:\n". join("\n", keys %exon_h)."\n")]); } # report any problems if (@problems) { my $thresh = $self->error_threshold; my @bad_problems = grep {$_->[0] > $thresh} @problems; if (@bad_problems) { printf STDERR "PROBLEM:\n"; $self->_write_hier(\@top_sfs); # TODO - allow more fine grained control over this $self->{_problems_reported} = 1; $self->throw(join("\n", map {"@$_"} @bad_problems)); } $self->problem(@$_) foreach @problems; } } } # --- end of inferring exons -- # return new top level features; this can also # be retrieved via # $seq->get_SeqFeatures(); # return @top_sfs; return $seq->get_SeqFeatures; } # _split_group_if_disconnected([@sfs]) # # as well as having the same group_tag, a group should be spatially # connected. if not, then the group should be split into subgroups. # this turns out to be necessary in the case of multicopy genes. # the standard way to represent these is as spatially disconnected # gene models (usually a 'gene' feature and some kind of RNA feature) # with the same group tag; the code below will split these into # seperate groups, one per copy. sub _split_group_if_disconnected { my $self = shift; my $group = shift; my @sfs = @$group; my @ranges = Bio::Range->disconnected_ranges(@sfs); my @groups; if (@ranges == 0) { $self->throw("ASSERTION ERROR"); } elsif (@ranges == 1) { # no need to split the group @groups = ($group); } else { # @ranges > 1 # split the group into disconnected ranges if ($self->verbose > 0) { printf STDERR "GROUP PRE-SPLIT:\n"; $self->_write_group($group, $self->group_tag); } @groups = map { my $range = $_; [grep { $_->intersection($range); } @sfs] } @ranges; if ($self->verbose > 0) { printf STDERR "SPLIT GROUPS:\n"; $self->_write_group($_, $self->group_tag) foreach @groups; } } return @groups; } sub _remove_duplicates_from_group { my $self = shift; my $group = shift; # ::: WEIRD BOUNDARY CASE CODE ::: # for some reason, there are some gb records with two gene # features for one gene; for example, see ATF14F8.gbk # in the t/data directory # # in this case, we get rid of one of the genes my @genes = grep {$_->primary_tag eq 'gene'} @$group; if (@genes > 1) { # OK, if we look at ATF14F8.gbk we see that some genes # just exist as a single location, some exist as a multisplit location; # # eg # gene 16790..26395 # /gene="F14F8_60" # ... # gene complement(join(16790..19855,20136..20912,21378..21497, # 21654..21876,22204..22400,22527..23158,23335..23448, # 23538..23938,24175..24536,24604..24715,24889..24984, # 25114..25171,25257..25329,25544..25589,25900..26018, # 26300..26395)) # /gene="F14F8_60" # the former is the 'standard' way of representing the gene in genbank; # the latter is redundant with the CDS entry. So we shall get rid of # the latter with the following filter if ($self->verbose > 0) { printf STDERR "REMOVING DUPLICATES:\n"; } @genes = grep { my $loc = $_->location; if ($loc->isa("Bio::Location::SplitLocationI")) { my @locs = $loc->each_Location; if (@locs > 1) { 0; } else { 1; } } else { 1; } } @genes; if (@genes > 1) { # OK, that didn't work. Our only resort is to just pick one at random @genes = ($genes[0]); } if (@genes) { @genes == 1 || $self->throw("ASSERTION ERROR"); @$group = ($genes[0], grep {$_->primary_tag ne 'gene'} @$group); } } # its a dirty job but someone's gotta do it return; } =head2 unflatten_groups Title : unflatten_groups Usage : Function: iterates over groups, calling unflatten_group() [see below] Example : Returns : list of Bio::SeqFeatureI objects that are holders Args : see below Arguments -groups: list of list references; inner list is of Bio::SeqFeatureI objects e.g. ( [$sf1], [$sf2, $sf3, $sf4], [$sf5, ...], ...) -resolver_method: a CODE reference see the documentation above for an example of a subroutine that can be used to resolve hierarchies within groups. this is optional - a default subroutine will be used NOTE: You should not need to call this method, unless you want fine grained control over how the unflattening process. =cut sub unflatten_groups{ my ($self,@args) = @_; my($groups, $resolver_method, $resolver_tag) = $self->_rearrange([qw(GROUPS RESOLVER_METHOD RESOLVER_TAG )], @args); # this is just a simple wrapper for unflatten_group() return map { $self->unflatten_group(-group=>$_, -resolver_method=>$resolver_method, -resolver_tag=>$resolver_tag) } @$groups; } =head2 unflatten_group Title : unflatten_group Usage : Function: nests a group of features into a feature containment hierarchy Example : Returns : Bio::SeqFeatureI objects that holds other features Args : see below Arguments -group: reference to list of Bio::SeqFeatureI objects -resolver_method: a CODE reference see the documentation above for an example of a subroutine that can be used to resolve hierarchies within groups this is optional - a default subroutine will be used NOTE: You should not need to call this method, unless you want fine grained control over how the unflattening process. =cut sub unflatten_group{ my ($self,@args) = @_; my($group, $resolver_method, $resolver_tag) = $self->_rearrange([qw(GROUP RESOLVER_METHOD RESOLVER_TAG )], @args); if ($self->verbose > 0) { printf STDERR "UNFLATTENING GROUP:\n"; $self->_write_group($group, $self->group_tag); } my @sfs = @$group; # we can safely ignore singletons (e.g. [source]) return $sfs[0] if @sfs == 1; my $partonomy = $self->partonomy; # $resolver_method is a reference to a SUB that will resolve # ambiguous parent/child containment; for example, determining # which mRNAs go with which CDSs $resolver_method = $resolver_method || \&_resolve_container_for_sf; # TAG BASED RESOLVING OF HIERARCHIES # # if the user specifies $resolver_tag, then we use this tag # to pair up ambiguous parents and children; # # for example, the CDS feature may have a resolver tag of /derives_from # which is a 'foreign key' into the /label tag of the mRNA feature # # this kind of tag-based resolution is possible for a certain subset # of genbank records # # if no resolver tag is specified, we revert to the normal # resolver_method if ($resolver_tag) { my $backup_resolver_method = $resolver_method; # closure: $resolver_tag is remembered by this sub my $sub = sub { my ($self, $sf, @possible_container_sfs) = @_; my @container_sfs = (); if ($sf->has_tag($resolver_tag)) { my ($resolver_tagval) = $sf->get_tag_values($resolver_tag); # if a feature has a resolver_tag (e.g. /derives_from) # this specifies the /product, /symbol or /label for the # parent feature @container_sfs = grep { my $match = 0; $self->_write_sf($_) if $self->verbose > 0; foreach my $tag (qw(product symbol label)) { if ($_->has_tag($tag)) { my @vals = $_->get_tag_values($tag); if (grep {$_ eq $resolver_tagval} @vals) { $match = 1; last; } } } $match; } @possible_container_sfs; } else { return $backup_resolver_method->($sf, @possible_container_sfs); } return map {$_=>0} @container_sfs; }; $resolver_method = $sub; } else { # CONDITION: $resolver_tag is NOT set $self->throw("assertion error") if $resolver_tag; } # we have now set $resolver_method to a subroutine for # disambiguatimng parent/child relationships. we will # now build the whole containment hierarchy for this group # FIND TOP/ROOT SEQFEATURES # # find all the features for which there is no # containing feature type (eg genes) my @top_sfs = grep { !$self->get_container_type($_->primary_tag); } @sfs; # CONDITION: there must be at most one root if (@top_sfs > 1) { $self->_write_group($group, $self->group_tag); printf STDERR "TOP SFS:\n"; $self->_write_sf($_) foreach @top_sfs; $self->throw("multiple top-sfs in group"); } my $top_sf = $top_sfs[0]; # CREATE INDEX OF SEQFEATURES BY TYPE my %sfs_by_type = (); foreach my $sf (@sfs) { push(@{$sfs_by_type{$sf->primary_tag}}, $sf); } # containment index; keyed by child; lookup parent # note: this index uses the stringified object reference of # the object as a surrogate lookup key my %container = (); # child -> parent # ALGORITHM: build containment graph # # find all possible containers for each SF; # for instance, for a CDS, the possible containers are all # the mRNAs in the same group. For a mRNA, the possible # containers are any SFs of type 'gene' (should only be 1). # (these container-type mappings can be overridden) # # contention is resolved by checking coordinates of splice sites # (this is the default, but can be overridden) # # most of the time, there is no problem identifying a unique # parent for every child; this can be ambiguous when constructing # CDS to mRNA relationships with lots of alternate splicing # # a hash of child->parent relationships is constructed (%container) # any mappings that need further resolution (eg CDS to mRNA) are # placed in %unresolved # %unresolved index # (keyed by stringified object reference of child seqfeature) my %unresolved = (); # child -> [parent,score] to be resolved # index of seqfeatures by their stringified object reference; # this is essentially a way of 'reviving' an object from its stringified # reference # (see NOTE ON USING OBJECTS AS KEYS IN HASHES, below) my %idxsf = map {$_=>$_} @sfs; foreach my $sf (@sfs) { my $type = $sf->primary_tag; # container type (e.g. the container type for CDS is usually mRNA) my $container_type = $self->get_container_type($type); if ($container_type) { my @possible_container_sfs = @{$sfs_by_type{$container_type} || []}; # we now have a list of possible containers # (eg for a CDS in an alternately spliced gene, this # would be a list of all the mRNAs for this gene) if (!@possible_container_sfs) { # root of hierarchy } else { if (@possible_container_sfs == 1) { # this is the easy situation, whereby the containment # hierarchy is unambiguous. this will probably be the # case if the genbank record has no alternate splicing # within it # ONE OPTION ONLY - resolved! $container{$sf} = $possible_container_sfs[0]; } else { # MULTIPLE CONTAINER CHOICES $self->throw("ASSERTION ERROR") unless @possible_container_sfs > 1; # push this onto the %unresolved graph, and deal with it # later # for now we hardcode things such that the only type # with ambiguous parents is a CDS; if this is violated, # it has a weak problem class of '1' so the API user # can easily set things to ignore these if ($sf->primary_tag ne 'CDS') { $self->problem(1, "multiple container choice for non-CDS; ". "CDS to mRNA should be the only ". "relationships requiring resolving", $sf); } # previously we set the SUB $resolver_method $self->throw("ASSERTION ERROR") unless $resolver_method; # $resolver_method will assign scores to # parent/child combinations; later on we # will use these scores to find the optimal # parent/child pairings # the default $resolver_method uses splice sites to # score possible parent/child matches my %container_sfh = $resolver_method->($self, $sf, @possible_container_sfs); if (!%container_sfh) { $self->problem(2, "no containers possible for SeqFeature of ". "type: $type; this SF is being placed at ". "root level", $sf); # RESOLVED! (sort of - placed at root/gene level) $container{$sf} = $top_sf; # this sort of thing happens if the record is # badly messed up and there is absolutely no indication # of where to put the CDS. Perhaps we should just # place it with a random mRNA? } foreach my $jsf (keys %container_sfh) { # add [score, parent] pairs to the %unresolved # lookup table/graph push(@{$unresolved{$sf}}, [$idxsf{$jsf}, $container_sfh{$jsf} || 0]); } } } } else { # CONDITION: # not container type for $sf->primary_tag # CONDITION: # $sf must be a root/top node (eg gene) } } if (0) { # CODE CURRENTLY DISABLED # we require a 1:1 mapping between mRNAs and CDSs; # create artificial duplicates if we can't do this... if (%unresolved) { my %childh = map {$_=>1} keys %unresolved; my %parenth = map {$_->[0]=>1} map {@$_} values %unresolved; if ($self->verbose > 0) { printf STDERR "MATCHING %d CHILDREN TO %d PARENTS\n", scalar(keys %childh), scalar(keys %parenth); } # 99.99% of the time in genbank genomic record of structure type 0, we # see one CDS for every mRNA; one exception is the S Pombe # genome, which is all CDS, bar a few spurious mRNAs; we have to # filter out the spurious mRNAs in this case # # another strange case is in the mouse genome, NT_078847.1 # for Pcdh13 you will notice there is 4 mRNAs and 5 CDSs. # most unusual! # I'm at a loss for a really clever thing to do here. I think the # best thing is to create duplicate features to preserve the 1:1 mapping # my $suffix_id = 1; # while (keys %childh > keys %parenth) { # # } } } # DEBUGGING CODE if ($self->verbose > 0 && scalar(keys %unresolved)) { printf STDERR "UNRESOLVED PAIRS:\n"; foreach my $childsf (keys %unresolved) { my @poss = @{$unresolved{$childsf}}; foreach my $p (@poss) { my $parentsf = $p->[0]; $childsf = $idxsf{$childsf}; my @clabels = ($childsf->get_tagset_values(qw(protein_id label product)), "?"); my @plabels = ($parentsf->get_tagset_values(qw(transcript_id label product)), "?"); printf STDERR (" PAIR: $clabels[0] => $plabels[0] (of %d)\n", scalar(@poss)); } } } # -- end of verbose # Now we have to fully resolve the containment hierarchy; remember, # the graph %container has the fully resolved child->parent links; # # the graph %unresolved is keyed by children missing parents; we # need to put all these orphans in the %container graph # # we do this using the scores in %unresolved, with the # find_best_matches() algorithm my $unresolved_problem_reported = 0; if (%unresolved) { my $new_pairs = $self->find_best_matches(\%unresolved, []); if (!$new_pairs) { my ($g) = $sfs[0]->get_tagset_values($self->group_tag || 'gene'); $self->problem(2, "Could not resolve hierarchy for $g"); $new_pairs = []; $unresolved_problem_reported = 1; } foreach my $pair (@$new_pairs) { if ($self->verbose > 0) { printf STDERR " resolved pair @$pair\n"; } $container{$pair->[0]} = $pair->[1]; delete $unresolved{$pair->[0]}; } } # CONDITION: containment hierarchy resolved if (%unresolved) { $self->throw("UNRESOLVED: %unresolved") unless $unresolved_problem_reported; } # make nested SeqFeature hierarchy from @containment_pairs # ie put child SeqFeatures into parent SeqFeatures my @top = (); foreach my $sf (@sfs) { my $container_sf = $container{$sf}; if ($container_sf) { # make $sf nested inside $container_sf # first check if the container spatially contains the containee if ($container_sf->contains($sf)) { # add containee $container_sf->add_SeqFeature($sf); } else { # weird case - the container does NOT spatially # contain the containee; # we expand and throw a warning # # for an example of this see ZFP91-CNTF dicistronic gene # in NCBI chrom 11 build 34.3 $self->problem(1, "Container feature does not spatially contain ". "subfeature. Perhaps this is a dicistronic gene? ". "I am expanding the parent feature", $container_sf, $sf); $container_sf->add_SeqFeature($sf, 'EXPAND'); } } else { push(@top, $sf); } } return @top; } # -- end of unflatten_group # ------- # A NOTE ON USING OBJECTS AS KEYS IN HASHES (stringified objects) # # Often we with to use seqfeatures as keys in a hashtable; because seqfeatures # in bioperl have no unique ID, we use a surrogate ID in the form of the # stringified object references - this is just what you get if you say # # print "$sf\n"; # # this is guaranteed to be unique (within a particular perl execution) # # often we want to 'revive' the objects used as keys in a hash - once the # objects are used as keys, remember it is the *strings* used as keys and # not the object itself, so the object needs to be revived using another # hashtable that looks like this # # %sfidx = map { $_ => $_ } @sfs # # ------- # recursively finds the best set of pairings from a matrix of possible pairings # # tries to make sure nothing is unpaired # # given a matrix of POSSIBLE matches # (matrix expressed as hash/lookup; keyed by child object; val = [parent, score] # # sub find_best_matches { my $self = shift; my $matrix = shift; my $pairs = shift; # [child,parent] pairs already selected my $verbose = $self->verbose; #################################print "I"; if ($verbose > 0) { printf STDERR "find_best_matches: (/%d)\n", scalar(@$pairs); } my %selected_children = map {($_->[0]=>1)} @$pairs; my %selected_parents = map {($_->[1]=>1)} @$pairs; # make a copy of the matrix with the portions still to be # resolved my %unresolved_parents = (); my %unresolved = map { if ($verbose > 0) { printf STDERR " $_ : %s\n", join("; ", map {"[@$_]"} @{$matrix->{$_}}); } if ($selected_children{$_}) { (); } else { my @parents = grep { !$selected_parents{$_->[0]} } @{$matrix->{$_}}; $unresolved_parents{$_} = 1 foreach @parents; # new parents ($_ => [@parents]); } } keys %$matrix; my @I = keys %unresolved; return $pairs if !scalar(keys %unresolved_parents); # NECESSARY CONDITION: # all possible parents have a child match return $pairs if !scalar(@I); # NECESSARY CONDITION: # all possible children have a parent match # give those with fewest choices highest priority @I = sort { # n possible parents scalar(@{$unresolved{$a}}) <=> scalar(@{$unresolved{$b}}) ; } @I; my $csf = shift @I; my @J = @{$unresolved{$csf}}; # array of [parent, score] # sort by score, highest first @J = sort { $b->[1] <=> $a->[1] } @J; # select pair(s) from remaining matrix of possible pairs # by iterating through possible parents my $successful_pairs; foreach my $j (@J) { my ($psf, $score) = @$j; # would selecting $csf, $psf as a pair # remove all choices from another? my $bad = 0; foreach my $sf (@I) { if (!grep {$_->[0] ne $psf} @{$unresolved{$sf}}) { # $psf was the only parent choice for $sf $bad = 1; last; } } if (!$bad) { my $pair = [$csf, $psf]; my $new_pairs = [@$pairs, $pair]; my $set = $self->find_best_matches($matrix, $new_pairs); if ($set) { $successful_pairs = $set; last; } } } # success return $successful_pairs if $successful_pairs; # fail return 0; } # ---------------------------------------------- # writes a group to stdout # # mostly for logging/debugging # ---------------------------------------------- sub _write_group { my $self = shift; my $group = shift; my $group_tag = shift || 'gene'; my $f = $group->[0]; my $label = '?'; if ($f->has_tag($group_tag)) { ($label) = $f->get_tag_values($group_tag); } if( $self->verbose > 0 ) { printf STDERR (" GROUP [%s]:%s\n", $label, join(' ', map { $_->primary_tag } @$group)); } } sub _write_sf { my $self = shift; my $sf = shift; printf STDERR "TYPE:%s\n", $sf->primary_tag; return; } sub _write_sf_detail { my $self = shift; my $sf = shift; printf STDERR "TYPE:%s\n", $sf->primary_tag; my @locs = $sf->location->each_Location; printf STDERR " %s,%s [%s]\n", $_->start, $_->end, $_->strand foreach @locs; return; } sub _write_hier { my $self = shift; my @sfs = @{shift || []}; my $indent = shift || 0; if( $self->verbose > 0 ) { foreach my $sf (@sfs) { my $label = '?'; if ($sf->has_tag('product')) { ($label) = $sf->get_tag_values('product'); } printf STDERR "%s%s $label\n", ' ' x $indent, $sf->primary_tag; my @sub_sfs = $sf->sub_SeqFeature; $self->_write_hier(\@sub_sfs, $indent+1); } } } # ----------------------------------------------- # # returns all possible containers for an SF based # on splice site coordinates; splice site coords # must be contained # ----------------------------------------------- sub _resolve_container_for_sf{ my ($self, $sf, @possible_container_sfs) = @_; my @coords = $self->_get_splice_coords_for_sf($sf); my $start = $sf->start; my $end = $sf->end; my $splice_uniq_str = "@coords"; my @sf_score_pairs = (); # a CDS is contained by a mRNA if the locations of the splice # coordinates are identical foreach (@possible_container_sfs) { my @container_coords = $self->_get_splice_coords_for_sf($_); my $inside = !$splice_uniq_str || index("@container_coords", $splice_uniq_str) > -1; if ($inside) { # the container cannot be smaller than the thing contained if ($_->start > $start || $_->end < $end) { $inside = 0; } } # SPECIAL CASE FOR /ribosomal_slippage # See: http://www.ncbi.nlm.nih.gov/collab/FT/ if (!$inside && $sf->has_tag('ribosomal_slippage')) { if ($self->verbose > 0) { printf STDERR " Checking for ribosomal_slippage\n"; } # TODO: rewrite this to match introns; # each slippage will be a "fake" small CDS exon my @transcript_splice_sites = @container_coords; my @cds_splice_sites = @coords; ##printf STDERR "xxTR SSs: @transcript_splice_sites :: %s\n", $_->get_tag_values('product'); ##printf STDERR "xxCD SSs: @cds_splice_sites :: %s\n\n", $sf->get_tag_values('product'); # find the the first splice site within the CDS while (scalar(@transcript_splice_sites) && $transcript_splice_sites[0] < $cds_splice_sites[0]) { shift @transcript_splice_sites; } ##print STDERR "TR SSs: @transcript_splice_sites\n"; ##print STDERR "CD SSs: @cds_splice_sites\n\n"; if (!(scalar(@transcript_splice_sites)) || $transcript_splice_sites[0] == $cds_splice_sites[0]) { # we will now try and align all splice remaining sites in the transcript and CDS; # any splice site that can't be aligned is assumed to be a ribosomal slippage my @slips = (); my $in_exon = 1; $inside = 1; # innocent until proven guilty.. while (@cds_splice_sites) { if (!@transcript_splice_sites) { # ribosomal slippage is after the last transcript splice site # Example: (NC_00007, isoform 3 of PEG10) # mRNA join(85682..85903,92646..99007) # mRNA join(85682..85903,92646..99007) # CDS join(85899..85903,92646..93825,93825..94994) # OR: None of the splice sites align; # may be a single CDS exon with one slippage inside it. # Example: (NC_00007, isoform 4 of PEG10) # mRNA join(85637..85892,92646..99007) # CDS join(92767..93825,93825..94994) # Yes, this code is repeated below... my $p1 = shift @cds_splice_sites; my $p2 = shift @cds_splice_sites; if ($self->verbose > 0) { printf STDERR " Found the ribosomal_slippage: $p1..$p2\n"; } push(@slips, ($p2-$p1)-1); } elsif ($cds_splice_sites[0] == $transcript_splice_sites[0]) { # splice sites align: this is not the slippage shift @cds_splice_sites; shift @transcript_splice_sites; ##print STDERR "MATCH\n"; } else { # mismatch if ($cds_splice_sites[0] < $transcript_splice_sites[0]) { # potential slippage # v # ---TTTTTTTTTT---- # ---CCCC--CCCC---- # ^ my $p1 = shift @cds_splice_sites; my $p2 = shift @cds_splice_sites; if ($self->verbose > 0) { printf STDERR " Found the ribosomal_slippage: $p1..$p2\n"; } push(@slips, ($p2-$p1)-1); } else { # not a potential ribosomal slippage $inside = 0; # guilty! ##print STDERR "FAIL\n"; last; } } } if ($inside) { # TODO: this is currently completely arbitrary. How many ribosomal slippages do we allow? # perhaps we need some mini-statistical model here....? if (@slips > 1) { $inside = 0; } # TODO: this is currently completely arbitrary. What is the maximum size of a ribosomal slippage? # perhaps we need some mini-statistical model here....? if (grep {$_ > 2} @slips) { $inside = 0; } } } else { # not a ribosomal_slippage, sorry } } if ($self->verbose > 0) { printf STDERR " Checking containment:[$inside] (@container_coords) IN ($splice_uniq_str)\n"; } if ($inside) { # SCORE: matching (ss-scoords+2)/(n-container-ss-coords+2) my $score = (scalar(@coords)+2)/(scalar(@container_coords)+2); push(@sf_score_pairs, $_=>$score); } } return @sf_score_pairs; } sub _get_splice_coords_for_sf { my $self = shift; my $sf = shift; my @locs = $sf->location; if ($sf->location->isa("Bio::Location::SplitLocationI")) { @locs = $sf->location->each_Location; } # get an ordered list of (start, end) positions # my @coords = # map { # $_->strand > 0 ? ($_->start, $_->end) : ($_->end, $_->start) # } @locs; my @coords = map {($_->start, $_->end)} @locs; # remove first and last leaving only splice sites pop @coords; shift @coords; return @coords; } =head2 feature_from_splitloc Title : feature_from_splitloc Usage : $unflattener->feature_from_splitloc(-features=>$sfs); Function: Example : Returns : Args : see below At this time all this method does is generate exons for mRNA or other RNA features Arguments: -feature: a Bio::SeqFeatureI object (that conforms to Bio::FeatureHolderI) -seq: a Bio::SeqI object that contains Bio::SeqFeatureI objects -features: an arrayref of Bio::SeqFeatureI object =cut sub feature_from_splitloc{ my ($self,@args) = @_; my($sf, $seq, $sfs) = $self->_rearrange([qw(FEATURE SEQ FEATURES )], @args); my @sfs = (@{$sfs || []}); push(@sfs, $sf) if $sf; if ($seq) { $seq->isa("Bio::SeqI") || $self->throw("$seq NOT A SeqI"); @sfs = $seq->get_all_SeqFeatures; } my @exons = grep {$_->primary_tag eq 'exon'} @sfs; if (@exons) { $self->problem(2, "There are already exons, so I will not infer exons"); } # index of features by type+location my %loc_h = (); # infer for every feature foreach my $sf (@sfs) { $sf->isa("Bio::SeqFeatureI") || $self->throw("$sf NOT A SeqFeatureI"); $sf->isa("Bio::FeatureHolderI") || $self->throw("$sf NOT A FeatureHolderI"); my $type = $sf->primary_tag; next unless $type eq 'mRNA' or $type =~ /RNA/; # an mRNA from genbank will have a discontinuous location, # with each sub-location being equivalent to an exon my @locs = $sf->location; if ($sf->location->isa("Bio::Location::SplitLocationI")) { @locs = $sf->location->each_Location; } if (!@locs) { use Data::Dumper; print Dumper $sf; $self->throw("ASSERTION ERROR: sf has no location objects"); } # make exons from locations my @subsfs = map { my $subsf = Bio::SeqFeature::Generic->new(-location=>$_, -primary_tag=>'exon'); ## Provide seq_id to new feature: $subsf->seq_id($sf->seq_id) if $sf->seq_id; $subsf->source_tag($sf->source_tag) if $sf->source_tag; ## Transfer /locus_tag and /gene tag values to inferred ## features. TODO: Perhaps? this should not be done ## indiscriminantly but rather by virtue of the setting ## of group_tag. foreach my $tag (grep /gene|locus_tag/, $sf->get_all_tags) { my @vals = $sf->get_tag_values($tag); $subsf->add_tag_value($tag, @vals); } my $locstr = 'exon::'.$self->_locstr($subsf); # re-use feature if type and location the same if ($loc_h{$locstr}) { $subsf = $loc_h{$locstr}; } else { $loc_h{$locstr} = $subsf; } $subsf; } @locs; # PARANOID CHECK $self->_check_order_is_consistent($sf->location->strand,@subsfs); #---- $sf->location(Bio::Location::Simple->new()); # we allow the exons to define the boundaries of the transcript $sf->add_SeqFeature($_, 'EXPAND') foreach @subsfs; if (!$sf->location->strand) { # correct weird bioperl bug in previous versions; # strand was not being set correctly $sf->location->strand($subsfs[0]->location->strand); } } return; } #sub merge_features_with_same_loc { # my ($self,@args) = @_; # my($sfs, $seq) = # $self->_rearrange([qw(FEATURES # SEQ # )], # @args); # my @sfs = (@$sfs); # if ($seq) { # $seq->isa("Bio::SeqI") || $self->throw("$seq NOT A SeqI"); # @sfs = $seq->get_all_SeqFeatures; # } # my %loc_h = (); # foreach my $sf (@sfs) { # my $type = $sf->primary_tag; # my $locstr = $self->_locstr($sf); ## $loc_h{$type.$locstr} # push(@{$exon_h{$self->_locstr($_)}}, $_) foreach @exons; # } #} =head2 infer_mRNA_from_CDS Title : infer_mRNA_from_CDS Usage : Function: Example : Returns : Args : given a "type 1" containment hierarchy gene CDS exon this will infer the uniform "type 0" containment hierarchy gene mRNA CDS exon all the children of the CDS will be moved to the mRNA a "type 2" containment hierarchy is mixed type "0" and "1" (for example, see ftp.ncbi.nih.gov/genomes/Schizosaccharomyces_pombe/) =cut sub infer_mRNA_from_CDS{ my ($self,@args) = @_; my($sf, $seq, $noinfer) = $self->_rearrange([qw(FEATURE SEQ NOINFER )], @args); my @sfs = ($sf); if ($seq) { $seq->isa("Bio::SeqI") || $self->throw("$seq NOT A SeqI"); @sfs = $seq->get_all_SeqFeatures; } foreach my $sf (@sfs) { $sf->isa("Bio::SeqFeatureI") || $self->throw("$sf NOT A SeqFeatureI"); $sf->isa("Bio::FeatureHolderI") || $self->throw("$sf NOT A FeatureHolderI"); if ($self->verbose > 0) { printf STDERR " Checking $sf %s\n", $sf->primary_tag; } if ($sf->primary_tag eq 'mRNA') { $self->problem(2, "Inferring mRNAs when there are already mRNAs present"); } my @cdsl = grep {$_->primary_tag eq 'CDS' } $sf->get_SeqFeatures; if (@cdsl) { my @children = grep {$_->primary_tag ne 'CDS'} $sf->get_SeqFeatures; my @mrnas = (); foreach my $cds (@cdsl) { if ($self->verbose > 0) { print " Inferring mRNA from CDS $cds\n"; } $self->_check_order_is_consistent($cds->location->strand,$cds->location->each_Location); my $loc = Bio::Location::Split->new; foreach my $cdsexonloc ($cds->location->each_Location) { my $subloc = Bio::Location::Simple->new(-start=>$cdsexonloc->start, -end=>$cdsexonloc->end, -strand=>$cdsexonloc->strand); $loc->add_sub_Location($subloc); } if ($noinfer) { push(@mrnas, $cds); } else { # share the same location my $mrna = Bio::SeqFeature::Generic->new(-location=>$loc, -primary_tag=>'mRNA'); ## Provide seq_id to new feature: $mrna->seq_id($cds->seq_id) if $cds->seq_id; $mrna->source_tag($cds->source_tag) if $cds->source_tag; $self->_check_order_is_consistent($mrna->location->strand,$mrna->location->each_Location); # make the mRNA hold the CDS; no EXPAND option, # the CDS cannot be wider than the mRNA $mrna->add_SeqFeature($cds); # mRNA steals children of CDS foreach my $subsf ($cds->get_SeqFeatures) { $mrna->add_SeqFeature($subsf); } $cds->remove_SeqFeatures; push(@mrnas, $mrna); } } # change gene/CDS to gene/mRNA $sf->remove_SeqFeatures; $sf->add_SeqFeature($_) foreach (@mrnas, @children); } } return; } =head2 remove_types Title : remove_types Usage : $unf->remove_types(-seq=>$seq, -types=>["mRNA"]); Function: Example : Returns : Args : removes features of a set type useful for pre-filtering a genbank record; eg to get rid of STSs also, there is no way to unflatten ftp.ncbi.nih.gov/genomes/Schizosaccharomyces_pombe/ UNLESS the bogus mRNAs in these records are removed (or changed to a different type) - they just confuse things too much =cut sub remove_types{ my ($self,@args) = @_; my($seq, $types) = $self->_rearrange([qw( SEQ TYPES )], @args); $seq->isa("Bio::SeqI") || $self->throw("$seq NOT A SeqI"); my @sfs = $seq->get_all_SeqFeatures; my %rh = map {$_=>1} @$types; @sfs = grep {!$rh{$_->primary_tag}} @sfs; $seq->remove_SeqFeatures; $seq->add_SeqFeature($_) foreach @sfs; return; } # _check_order_is_consistent($strand,$ranges) RETURNS BOOL # # note: the value of this test is moot - there are many valid, # if unusual cases where it would flag an anomaly. for example # transpliced genes such as mod(mdg4) in dmel on AE003744, and # the following spliced gene on NC_001284: # # mRNA complement(join(20571..20717,21692..22086,190740..190761, # 140724..141939,142769..142998)) # /gene="nad5" # /note="trans-splicing, RNA editing" # /db_xref="GeneID:814567" # # note how the exons are not in order # this will flag a level-3 warning, the user of this module # can ignore this and deal appropriately with the resulting # unordered exons sub _check_order_is_consistent { my $self = shift; my $parent_strand = shift; # this does nothing..? my @ranges = @_; return unless @ranges; my $rangestr = join(" ",map{sprintf("[%s,%s]",$_->start,$_->end)} @ranges); my $strand = $ranges[0]->strand; for (my $i=1; $i<@ranges;$i++) { if ($ranges[$i]->strand != $strand) { $self->problem(1,"inconsistent strands. Trans-spliced gene? Range: $rangestr"); return 1; # mixed ranges - autopass # some mRNAs have exons on both strands; for # example, the dmel mod(mdg4) gene which is # trans-spliced (in actual fact two mRNAs) } } my $pass = 1; for (my $i=1; $i<@ranges;$i++) { my $rangeP = $ranges[$i-1]; my $range = $ranges[$i]; if ($rangeP->start > $range->end) { if ($self->seq->is_circular) { # see for example NC_006578.gbk # we make exceptions for circular genomes here. # see Re: [Gmod-ajax] flatfile-to-json.pl error with GFF # 2010-07-26 } else { # failed - but still get one more chance.. $pass = 0; $self->problem(2,"Ranges not in correct order. Strange ensembl genbank entry? Range: $rangestr"); last; } } } if (!$pass) { # sometimes (eg ensembl flavour genbank files) # exons on reverse strand listed in reverse order # eg join(complement(R1),...,complement(Rn)) # where R1 > R2 for (my $i=1; $i<@ranges;$i++) { my $rangeP = $ranges[$i-1]; my $range = $ranges[$i]; if ($rangeP->end < $range->start) { $self->problem(3,"inconsistent order. Range: $rangestr"); return 0; } } } return 1; # pass } # PRIVATE METHOD: _locstr($sf) # # returns a location string for a feature; just the outer boundaries sub _locstr { my $self = shift; my $sf = shift; return sprintf("%d..%d", $sf->start, $sf->end); } sub iterate_containment_tree { my $self = shift; my $feature_holder = shift; my $sub = shift; $sub->($feature_holder); my @sfs = $feature_holder->get_SeqFeatures; $self->iterate_containment_tree($_) foreach @sfs; } sub find_best_pairs { my $matrix = shift; my $size = shift; my $i = shift || 0; for (my $j=0; $j < $size; $j++) { my $score = $matrix->[$i][$j]; if (!defined($score)) { next; } } } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO���������������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 14771� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/abi.pm��������������������������������������������������������������������000444��000765��000024�� 11323�12254227312� 16236� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::abi # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::abi - abi trace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from abi trace files. To optionally read the trace graph data (which can be used to draw chromatographs, for instance), set the optional '-get_trace_data' flag or the get_trace_data method to a value evaluating to TRUE. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Aaron Mackey Email: amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::abi; use vars qw(@ISA $READ_AVAIL); use strict; use Bio::SeqIO; use Bio::Seq::SeqFactory; push @ISA, qw( Bio::SeqIO ); sub BEGIN { eval { require Bio::SeqIO::staden::read; }; if ($@) { $READ_AVAIL = 0; } else { push @ISA, "Bio::SeqIO::staden::read"; $READ_AVAIL = 1; } } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($get_trace) = $self->_rearrange([qw(get_trace_data)],@args); $get_trace && $self->get_trace_data(1); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } unless ($READ_AVAIL) { Bio::Root::Root->throw( -class => 'Bio::Root::SystemException', -text => "Bio::SeqIO::staden::read is not available; make sure the bioperl-ext package has been installed successfully!" ); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self) = @_; my ($seq, $id, $desc, $qual) = $self->read_trace($self->_fh, 'abi'); # create the seq object my ($base_locs, $a_trace, $c_trace, $g_trace, $t_trace, $points, $max_height); if ($self->get_trace_data) { ($base_locs, $a_trace, $c_trace, $g_trace, $t_trace, $points, $max_height) = $self->read_trace_with_graph($self->_fh, 'abi'); } else { $base_locs = []; } # create the seq object $seq = $self->sequence_factory->create(-seq => $seq, -id => $id, -primary_id => $id, -desc => $desc, -alphabet => 'DNA', -qual => $qual, -trace => join (" ", @{$base_locs}), -trace_data => { a_trace => $a_trace, c_trace => $c_trace, g_trace => $g_trace, t_trace => $t_trace, max_height => $max_height, num_points => $points } ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh; foreach my $seq (@seq) { $self->write_trace($fh, $seq, 'abi'); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 get_trace_data Title : get_trace_data Usage : $stream->get_trace_data(1) Function: set boolean flag to retrieve the trace data (possibly for output) Returns : bool value, TRUE = retrieve trace data (default FALSE) Args : bool value =cut sub get_trace_data { my ($self, $val) = @_; $self->{_get_trace_data} = $val ? 1 : 0 if (defined $val); $self->{_get_trace_data}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/ace.pm��������������������������������������������������������������������000444��000765��000024�� 12454�12254227326� 16246� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::ace # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by James Gilbert <jgrg@sanger.ac.uk> # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::ace - ace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from ace file format. It only parses a DNA or Peptide objects contained in the ace file, producing PrimarySeq objects from them. All other objects in the files will be ignored. It doesn't attempt to parse any annotation attatched to the containing Sequence or Protein objects, which would probably be impossible, since everyone's ACeDB schema can be different. It won't parse ace files containing Timestamps correctly either. This can easily be added if considered necessary. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - James Gilbert Email: jgrg@sanger.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' # Let the code begin... package Bio::SeqIO::ace; use strict; use Bio::Seq; use Bio::Seq::SeqFactory; use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::PrimarySeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : NONE =cut { my %bio_mol_type = ( 'dna' => 'dna', 'peptide' => 'protein', ); sub next_seq { my( $self ) = @_; local $/ = ""; # Split input on blank lines my $fh = $self->_filehandle; my( $type, $id ); while (<$fh>) { if (($type, $id) = /^(DNA|Peptide)[\s:]+(.+?)\s*\n/si) { s/^.+$//m; # Remove first line s/\s+//g; # Remove whitespace last; } } # Return if there weren't any DNA or peptide objects return unless $type; # Choose the molecule type my $mol_type = $bio_mol_type{lc $type} or $self->throw("Can't get Bio::Seq molecule type for '$type'"); # Remove quotes from $id $id =~ s/^"|"$//g; # Un-escape forward slashes, double quotes, percent signs, # semi-colons, tabs, and backslashes (if you're mad enough # to have any of these as part of object names in your acedb # database). $id =~ s/\\([\/"%;\t\\])/$1/g; #" # Called as next_seq(), so give back a Bio::Seq return $self->sequence_factory->create( -seq => $_, -primary_id => $id, -display_id => $id, -alphabet => $mol_type, ); } } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object(s) =cut sub write_seq { my ($self, @seq) = @_; foreach my $seq (@seq) { $self->throw("Did not provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); my $mol_type = $seq->alphabet; my $id = $seq->display_id; # Escape special charachers in id $id =~ s/([\/"%;\t\\])/\\$1/g; #" # Print header for DNA or Protein object if ($mol_type eq 'dna') { $self->_print( qq{\nSequence : "$id"\nDNA "$id"\n}, qq{\nDNA : "$id"\n}, ); } elsif ($mol_type eq 'protein') { $self->_print( qq{\nProtein : "$id"\nPeptide "$id"\n}, qq{\nPeptide : "$id"\n}, ); } else { $self->throw("Don't know how to produce ACeDB output for '$mol_type'"); } # Print the sequence my $str = $seq->seq; my( $formatted_seq ); while ($str =~ /(.{1,60})/g) { $formatted_seq .= "$1\n"; } $self->_print($formatted_seq, "\n"); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/agave.pm������������������������������������������������������������������000444��000765��000024�� 157077�12254227323� 16631� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module: Bio::SeqIO::agave # # AGAVE: Architecture for Genomic Annotation, Visualization and Exchange. # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # # The original version of the module can be found here: # http://www.agavexml.org/ # # ### TODO: live link for this anymore? # The DTD for AGAVE XML was once located here (dead link): # http://www.lifecde.com/products/agave/schema/v2_3/agave.dtd # # =head1 NAME Bio::SeqIO::agave - AGAVE sequence output stream. =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system. Go: $in = Bio::SeqIO->new('-file' => "$file_in", '-format' => 'EMBL'); $out = Bio::SeqIO->new('-file' => ">$file_out", '-format' => 'AGAVE'); while (my $seq = $in->next_seq){ $out->write_seq($seq); } =head1 DESCRIPTION This object can transform Bio::Seq objects to agave xml file and vice-versa. I (Simon) coded up this module because I needed a parser to extract data from AGAVE xml to be utitlized by the GenQuire genome annotation system (See http://www.bioinformatics.org/Genquire). ***NOTE*** At the moment, not all of the tags are implemented. In general, I followed the output format for the XEMBL project http://www.ebi.ac.uk/xembl/ =cut =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Simon K. Chan Email: =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # =================== # Let the code begin... package Bio::SeqIO::agave; use strict; use IO::File; use Bio::SeqFeature::Generic; use Bio::Seq; use Bio::PrimarySeq; use Bio::Seq::SeqFactory; use Bio::Annotation::Reference; use Bio::Species; use XML::Writer; use Data::Dumper; use base qw(Bio::SeqIO); # ================================================================================== sub _initialize { my ($self,@args) = @_; $self->SUPER::_initialize(@args); # Run the constructor of the parent class. my %tmp = @args ; $self->{'file'} = $tmp{'-file'}; if ($self->{'file'} !~ /^>/) { $self->_process; # Parse the thing, but only if it is the input file (ie not # outputing agave file, but reading it). $self->{'parsed'} = 1; # Set the flag to let the code know that the agave xml file # has been parsed. } $self->{'seqs_stored'} = 0; } # ================================================================================== =head2 _process Title : _process Usage : $self->_process Function : Parses the agave xml file. Args : None. Returns : Nothing. Note : Method(s) that call(s) this method : _initialize Method(s) that this method calls : _process_sciobj FIRST/START sub. =cut sub _process { my ($self) = @_; while (1) { my $line = $self->_readline; next unless $line; next if $line =~ /^\s*$/; if ($line =~ /<\?xml version/o) { # do nothing } elsif ($line =~ /\<!DOCTYPE (\w+) SYSTEM "([\w\.]+)"\>/) { $self->throw("Error: This xml file is not in AGAVE format! DOCTYPE: $1 , SYSTEM: $2\n\n") if $1 ne 'sciobj' || $2 ne 'sciobj.dtd'; } elsif ($line =~ /<sciobj (.*)>/) { push @{$self->{'sciobj'}}, $self->_process_sciobj($1); } elsif ($line =~ /<\/sciobj>/) { last; # It is finished. } else { # throw an error message. The above conditions should # take care all of the possible options...? # $self->throw("Error: Do not recognize this AGAVE xml # line: $line\n\n"); } } # close while loop return; } # ================================================================================== =head2 _process_sciobj Title : _process_sciobj Usage : $self->_process_sciobj Function : Parses the data between the <sciobj></sciobj> tags. Args : The string that holds the attributes for <sciobj>. Returns : Data structure holding the values parsed between the <sciobj></sciobj> tags. Note : Method(s) that call(s) this method : _process Method(s) that this method calls : _helper_store_attribute_list , _process_contig =cut sub _process_sciobj { my ($self, $attribute_line) = @_; my $sciobj; $self->_helper_store_attribute_list($attribute_line, \$sciobj); my $line = $self->_readline; # Zero or more <contig> while ($line =~ /<contig\s?(.*?)\s?>/) { my $contig = $self->_process_contig(\$line, $1); push @{$sciobj->{'contig'}}, $contig; # print "line in _process_sciobj: $line\n"; # $line changes value within the subs called in this sub (_process_contig). } return $sciobj; } # ================================================================================== =head2 _process_contig Title : _process_contig Usage : $self->_process_contig Function : Parses the data between the <contig></contig> tags. Args : 2 scalars: - reference to a scalar holding the line to be parsed. - scalar holding the attributes for the <contig> tag to be parsed. Returns : Data structure holding the values parsed between the <contig></contig> tags. Note : Method(s) that call(s) this method : _process_sciobj Method(s) that this method calls : _helper_store_attribute_list, _one_tag , _process_fragment_order =cut sub _process_contig { my ($self, $line, $attribute_line) = @_; my $contig; $self->_helper_store_attribute_list($attribute_line, \$contig); $$line = $self->_readline; # One <db_id>: $self->_one_tag($line, \$contig, 'db_id'); # Zero or more <fragment_order> $self->_process_fragment_order($line, \$contig); return $contig; } # ================================================================================== =head2 _process_fragment_order Title : _process_fragment_order Usage : $self->_process_fragment_order Function : Parses the data between the <fragment_order></fragment_order> tags. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the <fragment_order> data. Returns : Nothing. Note : Method(s) that call(s) this method : _process_contig Method(s) that this method calls : _helper_store_attribute_list , _process_fragment_orientation =cut sub _process_fragment_order { my ($self, $line, $data_structure) = @_; # Because I'm passing a reference to a data structure, I don't need to return it # after values have been added. while ($$line =~ /<fragment_order\s?(.*?)\s?>/) { my $fragment_order; $self->_helper_store_attribute_list($1, \$fragment_order); # Store the attribute(s) for <fragment_order> into the # $fragment_order data structure. $$line = $self->_readline; # One or more <fragment_orientation> $self->_process_fragment_orientation($line, \$fragment_order); # Don't forget: $line is a reference to a scalar. push @{$$data_structure->{'fragment_order'}}, $fragment_order; # Store the data between <fragment_order></fragment_order> # in $$data_structure. } return; } # ================================================================================== =head2 _process_fragment_orientation Title : _process_fragment_orientation Usage : $self->_process_fragment_orientation Function : Parses the data between the <fragment_orientation> and </fragment_orientation> tags. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the <fragment_orientation> data. Returns : Nothing. Note : Method(s) that call(s) this method : _process_fragment_order Method(s) that this method calls : _helper_store_attribute_list , _process_bio_sequence =cut sub _process_fragment_orientation { my ($self, $line, $data_structure) = @_; # counter to determine the number of iterations within this while loop. my $count = 0; # One or more <fragment_orientation> while ($$line =~ /<fragment_orientation\s?(.*?)\s?>/) { my $fragment_orientation; $self->_helper_store_attribute_list($1, \$fragment_orientation); $$line = $self->_readline; # One <bio_sequence> $$line =~ /<bio_sequence\s?(.*?)\s?>/; # Process the data between <bio_sequence></bio_sequence> my $bio_sequence = $self->_process_bio_sequence($line, $1); $fragment_orientation->{'bio_sequence'} = $bio_sequence; push @{$$data_structure->{'fragment_orientation'}}, $fragment_orientation; ++$count; } $self->throw("Error: Missing <fragment_orientation> tag. Got this: $$line\n\n") if $count == 0; return; } # ================================================================================== =head2 _process_bio_sequence Title : _process_bio_sequence Usage : $self->_process_bio_sequence Function : Parses the data between the <bio_sequence></bio_sequence> tags. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - scalar holding the value of the attributes for <bio_sequence> Returns : data structure holding the values between <bio_sequence></bio_sequence> Note : Method(s) that call(s) this method : _process_fragment_orientation Method(s) that this method calls : _helper_store_attribute_list , _one_tag , _question_mark_tag , _star_tag , _process_alt_ids , _process_xrefs , _process_sequence_map =cut sub _process_bio_sequence { my ($self, $line, $attribute_line) = @_; my $bio_sequence; $self->_helper_store_attribute_list($attribute_line, \$bio_sequence); $$line = $self->_readline; # One <db_id>. $self->_one_tag($line, \$bio_sequence, 'db_id'); # Zero or one <note>. $self->_question_mark_tag($line, \$bio_sequence, 'note'); # Zero or more <description> $self->_question_mark_tag($line, \$bio_sequence, 'description'); # Zero or more <keyword> $self->_star_tag($line, \$bio_sequence, 'keyword'); # Zero or one <sequence> $self->_question_mark_tag($line, \$bio_sequence, 'sequence'); # Zero or one <alt_ids> # NOT IMPLEMENTED!!!! #if ($line =~ /<alt_ids>/){ # NOT DONE YET! # my $alt_ids; # $bio_sequence->{'alt_ids'} = $self->_process_alt_ids(\$alt_ids); #} # Zero or one <xrefs> if ($$line =~ /<xrefs\s?(.*?)\s?>/) { my $xrefs = $self->_process_xrefs($line, \$bio_sequence); $bio_sequence->{'xrefs'} = $xrefs || 'null'; } # Zero or more <sequence_map> if ($$line =~ /<sequence_map\s?(.*?)\s?>/) { my $sequence_map = $self->_process_sequence_map($line); push @{$bio_sequence->{'sequence_map'}}, $sequence_map; } # print Data::Dumper->Dump([$bio_sequence]); exit; return $bio_sequence; } # ================================================================================== =head2 _process_xrefs Title : _process_xrefs Usage : $self->_process_xrefs Function : Parse the data between the <xrefs></xrefs> tags. Args : reference to a scalar holding the value of the line to be parsed. Return : Nothing. Note : Method(s) that call(s) this method: _process_bio_sequence Method(s) that this method calls: _one_tag , _process_xref =cut sub _process_xrefs { my ($self, $line) = @_; my $xrefs; $$line = $self->_readline; # One or more <db_id> or <xref> within <xrefs></xrefs>. Check if # to see if there's at least one. if ($$line =~ /<db_id|xref\s?(.*?)\s?>/) { while ($$line =~ /<(db_id|xref)\s?(.*?)\s?>/) { if ($1 eq "db_id") { my $db_id; $self->_one_tag($line, \$db_id, 'db_id'); push @{$xrefs->{'db_id'}}, $db_id; } elsif ($1 eq "xref") { my $xref; $self->_process_xref($line, \$xref); push @{$xrefs->{'xref'}}, $xref; } else { $self->throw("Error: Tag type should be one of db_id or xref! Got this: $$line\n\n"); } } # close while loop if ($$line =~ /<\/xrefs>/) { $$line = $self->_readline; # get the next line to be _processed by the next sub. return $xrefs; } else { $self->throw("Error: Missing </xrefs> tag. Got this: $$line\n\n"); } } else { $self->throw("Error: Missing <db_id> or <xref> tag. Got this: $$line\n\n"); } return; } # ================================================================================== =head2 _process_xref Title : _process_xref Usage : $self->_process_xref Function : Parses the data between the <xref></xref> tags. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the <xref> data. Returns : Nothing. Note : Method(s) that call(s) this method : _process_xrefs (note the 's' in 'xrefs') Method(s) that this method calls : _helper_store_attribute_list , _star_tag =cut sub _process_xref { my ($self, $line, $xref) = @_; $$line = $self->_readline; # One <db_id> if ($$line =~ /<db_id\s?(.*?)\s?>/) { $self->_helper_store_attribute_list($1, $xref); } else { $self->throw("Error: Missing <db_id> tag. Got this: $$line\n\n"); } # Zero or more <xref_property> $self->_star_tag($line, $xref, 'xref_propery'); return; } # ================================================================================== =head2 _process_sequence_map Title : _process_sequence_map Usage : $self->_process_sequence_map Function : Parses the data between the <sequence_map></sequence_map> tags. Args : Reference to scalar holding the line to be parsed. Returns : Data structure that holds the values that were parsed. Note : Method(s) that call(s) this method : _process_bio_sequence Method(s) that this method calls : _helper_store_attribute_list , _question_mark_tag , _process_annotations =cut sub _process_sequence_map { my ($self, $line) = @_; my $sequence_map; # Zero or more <sequence_map> while ($$line =~ /<sequence_map\s?(.*?)\s?>/) { $self->_helper_store_attribute_list($1, \$sequence_map) if defined $1; $$line = $self->_readline; # Zero or one <note> $self->_question_mark_tag($line, \$sequence_map, 'note'); # NOT IMPLEMENTED!!! #if ($$line =~ /<computations\?(.*?)\s?>/){ # # $self->_process_computations(); #} # Zero or one <annotations> if ($$line =~ /<annotations\s?(.*?)\s?>/) { my $annotations = $self->_process_annotations($line); $sequence_map->{'annotations'} = $annotations; } } # closes the while loop # Match closing tag: if ($$line =~ /<\/sequence_map>/) { return $sequence_map; } else { $self->throw("Error: Missing </sequence_map> tag. Got this: $$line\n\n"); } } # ================================================================================== =head2 _process_annotations Title : _process_annotations Usage : $self->_process_annotations Function : Parse the data between the <annotations></annotations> tags. Args : Reference to scalar holding the line to be parsed. Returns : Data structure that holds the values that were parsed. Note : Method(s) that call(s) this method : _process_sequence_map Method(s) that this method calls : _process_seq_feature =cut sub _process_annotations { my ($self, $line) = @_; # ( seq_feature | gene | comp_result )+ my $annotations; $$line = $self->_readline; my $count = 0; # counter to keep track of number of iterations in the loop. # One or more of these: while ($$line =~ /<(seq_feature|gene|comp_result)\s?(.*?)\s?>/) { if ($$line =~ /<seq_feature\s?(.*?)\s?>/) { my $seq_feature = $self->_process_seq_feature($line, $1); push @{$annotations->{'seq_feature'}}, $seq_feature; } elsif ($$line =~ /<gene\s?(.*?)\s?>/) { # gene } elsif ($$line =~ /<comp_result\s?(.*?)\s?>/) { # comp_result } ++$count; } # closes the while loop. $self->throw("Error: Missing <seq_feature> tag. Got: $$line\n\n") if $count == 0; # Match closing tag: if ($$line =~ /<\/annotations/) { $$line = $self->_readline; # get the next line to be _processed by the next sub. return $annotations; } else { $self->throw("Error: Missing </annotations> tag. Got this: $$line\n\n"); } } # ================================================================================== =head2 _process_seq_feature Title : _process_seq_feature Usage : $self->_process_seq_feature Function : Parses the data between the <seq_feature></seq_feature> tag. Args : 2 scalars: - Reference to scalar holding the line to be parsed. - Scalar holding the attributes for <seq_feature>. Returns : Data structure holding the values parsed. Note : Method(s) that call(s) this method: _process_annotations Method(s) that this method calls: _helper_store_attribute_list , _process_classification , _question_mark_tag , _one_tag , _process_evidence , _process_qualifier , _process_seq_feature , _process_related_annot =cut sub _process_seq_feature { my ($self, $line, $attribute_line) = @_; my $seq_feature; $self->_helper_store_attribute_list($attribute_line, \$seq_feature); $$line = $self->_readline; # Zero or more <classification> $self->_process_classification($line, \$seq_feature); # Zero or one <note> $self->_question_mark_tag($line, \$seq_feature, 'note'); # One <seq_location> $self->_one_tag($line, \$seq_feature, 'seq_location'); # Zero or one <xrefs> $self->_question_mark_tag($line, \$seq_feature, 'xrefs'); # Zero or one <evidence> $self->_process_evidence($line, \$seq_feature); # Zero or more <qualifier> $self->_process_qualifier($line, \$seq_feature); # Zero or more <seq_feature>. A <seq_feature> tag within a <seq_feature> tag? Oh, well. Whatever... while ($$line =~ /<seq_feature\s?(.*?)\s?>/) { $self->_process_seq_feature($line, $1); $$line = $self->_readline; } # Zero or more <related_annot> while ($$line =~ /<related_annot\s?(.*?)\s?>/) { $self->_process_related_annot($line, $1); $$line = $self->_readline; } # Match the closing tag: if ($$line =~ /<\/seq_feature>/) { $$line = $self->_readline; # for the next sub... return $seq_feature; } else { $self->throw("Error. Missing </seq_feature> tag. Got this: $$line\n"); } } # ================================================================================== =head2 _process_qualifier Title : _process_qualifier Usage : $self->_process_qualifier Function : Parse the data between the <qualifier></qualifier> tags. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the <qualifer> data. Returns : Nothing. Note : Method(s) that call(s) this method : _process_seq_feature Method(s) that this method calls : _star_tag =cut sub _process_qualifier { my ($self, $line, $data_structure) = @_; my $qualifier; $self->_star_tag($line, \$qualifier, 'qualifier'); push @{$$data_structure->{'qualifier'}},$qualifier; return; # No need to return the data structure since its reference was what was modified. } # ================================================================================== =head2 _process_classification Title : _process_classification Usage : $self->_process_classification Function: Parse the data between the <classification></classification> tags. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the <qualifer> data. Returns : Nothing. Note : Method(s) that call(s) this method: _process_seq_feature Method(s) that this method calls: _helper_store_attribute_list , _question_mark_tag , _star_tag, _process_evidence =cut sub _process_classification { # NOT IN USE. my ($self, $line, $data_structure) = @_; my $classification = $$data_structure->{'classification'}; while ($$line =~ /<classification\s?(.*?)\s?>/) { $self->_helper_store_attribute_list($1, \$classification); # Zero or one <description> $self->_question_mark_tag($line, \$classification, 'description'); # Zero or more <id_alias> $self->_star_tag($line, \$classification, 'id_alias'); # Zero or one <evidence> $self->_process_evidence($line, \$classification); } } # ================================================================================== sub _process_evidence { # NOT done. my ($self, $line, $data_structure) = @_; if ($$line =~ /<evidence>/) { $$line = $self->_readline; # One or more <element_id> OR One or more <comp_result> while ($$line =~ /<(element_id|comp_result)\s?(.*?)\s?>/) { if ($$line =~ /<element_id\s?(.*?)\s?>/) { my $element_id; $self->_plus_tag($line, \$element_id, 'element_id'); push @{$$data_structure->{'element_id'}}, $element_id; } elsif ($$line =~ /<comp_result\s?(.*?)\s?>/) { my $comp_result; $self->_process_comp_result($line, \$comp_result, $1); push @{$$data_structure->{'comp_result'}}, $comp_result; } $$line = $self->_readline; } } } # ================================================================================== sub _process_comp_result { # NOT IN USE. my ($self, $line, $comp_result, $attribute_line) = @_; $self->_helper_store_attribute_list($attribute_line, $comp_result); $$line = $self->_readline; # Zero or one <note> $self->_question_mark_tag($line, $comp_result, 'note'); # Zero or one <match_desc> $self->_question_mark_tag($line, $comp_result, 'match_desc'); # Zero or one <match_align> $self->_question_mark_tag($line, $comp_result, 'match_align'); # Zero or one <query_region> $self->_process_query_region($line, $comp_result); # Zero or one <match_region> $self->_process_match_region($line, $comp_result); # Zero or more <result_property> $self->_star_tag($line, $comp_result, 'result_property'); # Zero or more <result_group> $self->_process_result_group($line, $comp_result); # Zero or more <related_annot> $self->_process_related_annot($line, $comp_result); } # ================================================================================== sub _process_related_annot { # NOT IN USE. my ($self, $line, $data_structure) = @_; while ($$line =~ /<related_annot\s?(.*?)\s?>/) { my $related_annot; # Zero or one <related_annot> $self->_helper_store_attribute_list($1, \$related_annot); $$line = $self->_readline; # One or more <element_id> my $element_id_count = 0; while ($$line =~ /<element_id\s?(.*?)\s?>/) { my $element_id; $self->_helper_store_attribute_list($1, \$element_id); push @{$related_annot->{'element_id'}}, $element_id; $$line = $self->_readline; ++$element_id_count; } if ($element_id_count == 0) { $self->throw("Error. Missing <element_id> tag. Got: $$line"); } # Zero or more <sci_property> $self->_star_tag($line, \$related_annot, 'sci_property'); # while ($$line =~ /<sci_property\s?(.*?)\s?>/){ # # } push @{$data_structure->{'related_annot'}}, $related_annot; unless ($$line =~ /<\/related_annot>/){ $self->throw("Error. Missing </related_tag>. Got: $$line\n"); } } } # ================================================================================== sub _process_result_group { # NOT IN USE. my ($self, $line, $data_structure) = @_; while ($$line =~ /<result_group\s?(.*?)\s?>/) { my $result_group = $$data_structure->{'result_group'}; $self->_helper_store_attribute_list($1, \$result_group); my $count = 0; $$line = $self->_readline; while ($$line =~ /<comp_result\s?(.*?)\s?>/) { # one or more <comp_result> $self->_process_comp_result(\$line, \$result_group, $1); $$line = $self->_readline; ++$count; } $self->throw("Error. No <comp_result></comp_result> tag! Got this: $$line") if $count == 0; # in the last iteration in the inner while loop, $line will # have a value of the closing tag of 'result_group' if ($line =~ /<\/result_group>/) { $$line = $self->_readline; } else { $self->throw("Error. No </result_tag>! Got this: $$line"); } } } # ================================================================================== sub _process_match_region { # NOT IN USE. my ($self, $line, $data_structure) = @_; my $match_region = $data_structure->{'match_region'}; if ($$line =~ /<match_region\s?(.*?)\s?>(.*?)>/) { $self->_helper_store_attribute_line($1, \$match_region); $$line = $self->_readline; # Zero or one db_id | element_id | bio_sequence if ($$line =~ /<db_id\s?(.*?)\s?>(.*?)<\/db_id>/) { $self->_question_mark_tag($line, \$match_region, 'db_id'); } elsif ($$line =~ /<element_id\s?(.*?)\s?>/) { # empty... $self->_question_mark_tag($line, \$match_region, 'element_id'); } elsif ($$line =~ /<bio_sequence\s?(.*?)\s?>/) { $match_region->{'bio_sequence'} = $self->_process_bio_sequence($line, $1); } $$line = $self->_readline; if ($$line =~ /<\/match_region>/o) { $$line = $self->_readline; # get the next line to be _processed by the next sub return; } else { $self->throw("No closing tag </match_region>! Got this: $$line\n"); } } } # ================================================================================== sub _process_query_region { # NOT IN USE. my ($self, $line, $data_structure) = @_; my $query_region = $data_structure->{'query_region'}; if ($$line =~ /<query_region\s?(.*?)\s?>/) { $self->_helper_store_attribute_list($1, \$query_region); $$line = $self->_readline; # Zero or one <db_id> $self->_question_mark_tag($line, \$query_region, 'db_id'); if ($$line =~ /<\/query_region>/) { $$line = $self->_readline; # get the next line to _process. return; } else { $self->throw("No closing tag </query_region>. Got this: $$line\n"); } } } # ================================================================================== =head2 _tag_processing_helper Title : _tag_processing_helper Usage : $self->_tag_processing_helper Function : Stores the tag value within the data structure. Also calls _helper_store_attribute_list to store the attributes and their values in the data structure. Args : 5 scalars: - Scalar holding the value of the attributes - Reference to a data structure to store the data for <$tag_name> - Scalar holding the tag name. - Scalar holding the value of the tag. - Scalar holding the value of either 'star', 'plus', or 'question mark' which specifies what type of method called this method. Returns : Nothing. Note : Method(s) that call(s) this method: Method(s) that this method calls: _helper_store_attribute_list =cut sub _tag_processing_helper { my ($self, $attribute_list, $data_structure, $tag_name, $tag_value, $caller) = @_; # Add the attributes to the $$data_structure if they exist. # print "tag_name: $tag_name , attribute_list: $attribute_list\n"; if (defined $attribute_list) { $self->_helper_store_attribute_list($attribute_list, $data_structure); } if ($caller eq 'star' || $caller eq 'plus') { push @{$$data_structure->{$tag_name}}, $tag_value; # There's either zero or more tags (*) or one or more (+) } else { $$data_structure->{$tag_name} = $tag_value || 'null'; # There's zero or one tag (?) } return; } # ================================================================================== =head2 _one_tag Title : _one_tag Usage : $self->_one_tag Function : A method to store data from tags that occurs just once. Args : 2 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the data for <$tag_name> Returns : Nothing. Note : Method(s) that call(s) this method : many Method(s) that this method calls : _tag_processing_helper =cut sub _one_tag { my ($self, $line, $data_structure, $tag_name) = @_; $self->throw("Error: Missing <$tag_name></$tag_name>. Got: $$line\n\n") if $$line !~ /\<$tag_name/; # check to see if $$line is in correct format. if ($$line =~ /<$tag_name\s?(.*?)\s?\/?>(.*?)<\/$tag_name>/) { $self->_tag_processing_helper($1, $data_structure, $tag_name, $2, 'one'); # $1 = attributes $data_structure = to hold the parsed values # # $tag_name = name of the tag $2 = tag value 'one' = lets # _tag_processing_helper know that it was called from the # _one_tag method. } elsif ($$line =~ /<$tag_name\s?(.*?)\s?\/?>/) { $self->_tag_processing_helper($1, $data_structure, $tag_name, '', 'one'); } else { $self->throw("Error: Cannot parse this line: $$line\n\n"); } $$line = $self->_readline; # get the next line. return; } # ================================================================================== =head2 _question_mark_tag Title : _question_mark_tag Usage : $self->_question_mark_tag Function : Parses values from tags that occurs zero or one time. ie: tag_name? Args : 3 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the data for <$tag_name> - scalar holding the name of the tag. Returns : Nothing. Note : Method(s) that call(s) this method : many. Method(s) that this method calls : _tag_processing_helper =cut sub _question_mark_tag { my ($self, $line, $data_structure, $tag_name) = @_; if ($$line =~ /<$tag_name\s?(.*?)\s?>(.*?)<\/$tag_name>/) { $self->_tag_processing_helper($1, $data_structure, $tag_name, $2, 'question mark'); $$line = $self->_readline; } return; } # ================================================================================== =head2 _star_tag Title : _star_tag Usage : $self->_star_tag Function : Parses values from tags that occur zero or more times. ie: tag_name* Args : 3 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the data for <$tag_name> - scalar holding the name of the tag. Returns : Nothing. Note : Method(s) that call(s) this method : many. Method(s) that this method calls : _tag_processing_helper =cut sub _star_tag { my ($self, $line, $data_structure, $tag_name) = @_; #print "tag_name: $tag_name\n"; while ($$line =~ /<$tag_name\s?(.*?)\s?>(.*?)<\/$tag_name>/) { $self->_tag_processing_helper ($1, $data_structure, $tag_name, $2, 'star'); # The tag and attribute values are stored within # $$data_structure within the _tag_processing_helper method. $$line = $self->_readline; } #if ($tag_name eq 'qualifier'){ # print "this one:\n"; # print Data::Dumper->Dump([$data_structure]); exit; #} return; } # ================================================================================== =head2 _plus_tag Title : _plus_tag Usage : $self->_plus_tag Function : Handles 'plus' tags (tags that occur one or more times). tag_name+ Args : 3 scalars: - reference to a scalar holding the value of the line to be parsed. - reference to a data structure to store the data for <$tag_name> - scalar holding the name of the tag. Returns : Nothing. Note : Method(s) that call(s) this method : many. Method(s) that this method calls : _star_tag =cut sub _plus_tag { my ($self, $line, $data_structure, $tag_name) = @_; if ($$line =~ /<$tag_name\s?(.*?)\s?>(.*?)<\/$tag_name>/) { # Store value of the first occurence of $tag_name. # All subsequent values, if any, will be stored in the method _star_tag. $self->_tag_processing_helper($1, $data_structure, $tag_name, $2, 'plus'); # If the flow gets within this block, we've already determined # that there's at least one of <$tag_name> Are there more? To # answer this, we could just treat the tag as a * tag now # (zero or more). We've already determined that it's NOT # zero, so how many more? Thus, call _star_tag. $$line = $self->_readline; $self->_star_tag($line, $data_structure, $tag_name); } else { $self->throw("Error: Missing <$tag_name></$tag_name>. Got: $$line\n\n"); } return; } # ================================================================================== =head2 _helper_store_attribute_list Title : _helper_store_attribute_list Usage : $self->_helper_store_attribute_list Function : A helper method used to store the attributes from the tags into the data structure. Args : 2 scalars: - scalar holding the attribute values to be parsed. - reference to a data structure to store the data between the 2 tags. Returns : Nothing. Note : Method(s) that call(s) this method : Many. Method(s) that this method call(s) : None. =cut sub _helper_store_attribute_list { my ($self, $attribute_line, $data_structure) = @_; my %attribs = ($attribute_line =~ /(\w+)\s*=\s*"([^"]*)"/g); my $attribute_list; for my $key (keys %attribs) { # print "\tkey: $key , value: $attribs{$key}\n"; ###$$data_structure->{$key} = $attribs{$key}; # <- The ORIGINAL. push @{$$data_structure->{$key}}, $attribs{$key}; # Now, store them in an array because there may be > 1 tag, thus # > 1 attribute of the same name. # Doing this has made it necessary to change the _store_seqs method. # ie: Change $bio_sequence->{'molecule_type'}; # to # $bio_sequence->{'molecule_type'}->[0]; } return; } # ================================================================================== =head2 _store_seqs Title : _store_seqs Usage : $self->_store_seqs Function : This method is called once in the life time of the script. It stores the data parsed from the agave xml file into the Bio::Seq object. Args : None. Returns : Nothing. Note : Method(s) that call(s) this method : next_seq Method(s) that this method calls : None. =cut sub _store_seqs { my ($self) = @_; for my $sciobj (@{$self->{'sciobj'}}) { ### $sciobj = $self->{'sciobj'}; # The root node. for my $contig (@{$sciobj->{'contig'}}) { # Each contig has a fragment order. for my $fragment_order (@{$contig->{'fragment_order'}}) { # Each fragment order has a fragment_orientation. for my $fragment_orientation (@{$fragment_order->{'fragment_orientation'}}) { # Each fragment_orientation contain 1 bio sequence. my $bio_sequence = $fragment_orientation->{'bio_sequence'}; # <bio_sequence> contains all the # interesting stuff: my $sequence = $bio_sequence->{'sequence'}; my $accession_number = $bio_sequence->{'sequence_id'}->[0]; # also use for primary_id my $organism = $bio_sequence->{'organism'}; my $description = $bio_sequence->{'description'}; my $molecule_type = $bio_sequence->{'molecule_type'}->[0]; my $primary_seq = Bio::PrimarySeq->new( -id => $accession_number, -alphabet => $molecule_type, -seq => $sequence, -desc => $description, ); my $seq = Bio::Seq->new ( -display_id => $accession_number, -accession_number => $accession_number, -primary_seq => $primary_seq, -seq => $sequence, -description => $description, ); my $organism_name = $bio_sequence->{organism_name}->[0]; if (defined $organism_name) { my @classification = split(' ', $organism_name); my $species = Bio::Species->new(); $species->classification(@classification); $seq->species($species); } # Pull out the keywords: $keywords is an array ref. my $keywords = $bio_sequence->{keyword}; my %key_to_value; for my $keywords (@$keywords) { # print "keywords: $keywords\n"; my @words = split(':', $keywords); for (my $i = 0; $i < scalar @words - 1; $i++) { if ($i % 2 == 0) { my $j = $i; $j++; # print "$words[$i] , $words[$j]\n"; $key_to_value{$words[$i]} = $words[$j]; } } # print Data::Dumper->Dump([%key_to_value]); my $reference = Bio::Annotation::Reference-> new(-authors => $key_to_value{authors}, -title => $key_to_value{title}, -database => $key_to_value{database}, -pubmed => $key_to_value{pubmed}, ); $seq->annotation->add_Annotation('reference', $reference); } # close for my $keywords # print Data::Dumper->Dump([$bio_sequence]); print "here\n"; exit; if (defined $bio_sequence->{'sequence_map'}) { for my $sequence_map (@{$bio_sequence->{'sequence_map'}}) { # print Data::Dumper->Dump([$sequence_map]); print "here\n"; exit; my $label = $sequence_map->{label}; if (defined $sequence_map->{annotations} && ref($sequence_map->{annotations}) eq 'HASH') { # Get the sequence features (ie genes, exons, etc) from this $sequence_map for my $seq_feature (@{$sequence_map->{'annotations'}->{'seq_feature'}}) { # print Data::Dumper->Dump([$seq_feature]); exit; my $seq_location = $seq_feature->{'seq_location'}; my $start_coord = $seq_feature->{'least_start'}->[0]; my $feature_type = $seq_feature->{'feature_type'}->[0]; my $end_coord = $seq_feature->{'greatest_end'}->[0]; my $is_on_complement = $seq_feature->{'is_on_complement'}->[0]; # Specify the coordinates and the tag for this seq feature. # print "Primary Tag for this SeqFeature: $feature_type\n"; my $feat = Bio::SeqFeature::Generic-> new( -start => $start_coord, -end => $end_coord, -primary_tag => $feature_type, ); if (defined $seq_feature->{'qualifier'} && ref($seq_feature->{'qualifier'}) eq 'ARRAY') { for my $feature (@{$seq_feature->{'qualifier'}}) { my $value = $feature->{'qualifier'}; my $feature_type = $feature->{'qualifier_type'}; for (my $i = 0; $i < scalar @{$value}; $i++) { $feat->add_tag_value( $feature_type->[$i] => $value->[$i] ); } # close the for loop } } # close if (defined $seq_feature->... $seq->add_SeqFeature($feat); } # close for my $seq_feature (@{$sequence_map->... } # close if (defined $sequence_map->{annotations} && } # close for my $sequence_map (@{$bio_sequence->{'sequence_map'}}){ } # close if (defined $bio_sequence->{'sequence_map'}){ # This is where the Bio::Seq objects are stored: push @{$self->{'sequence_objects'}}, $seq; } # close for my $fragment_orientation } # close for my $fragment_order } # close for my $contig } # close for my $sciobj # Flag is set so that we know that the sequence objects are now stored in $self. $self->{'seqs_stored'} = 1; return; } # ================================================================================== =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function : Returns the next sequence in the stream. Args : None. Returns : Bio::Seq object Method is called from the script. Method(s) that this method calls: _store_seqs (only once throughout the life time of script execution). =cut sub next_seq { my ($self) = @_; # convert agave to genbank/fasta/embl whatever. $self->_store_seqs if $self->{'seqs_stored'} == 0; $self->throw("Error: No Bio::Seq objects stored yet!\n\n") if !defined $self->{'sequence_objects'}; # This should never occur... if (scalar @{$self->{'sequence_objects'}} > 0) { return shift @{$self->{'sequence_objects'}}; } else { # All done. Nothing more to parse. # print "returning nothing!\n"; return 0; } } # ================================================================================== =head2 next_primary_seq Title : next_primary_seq Usage : $seq = $stream->next_primary_seq() Function: returns the next primary sequence (ie no seq_features) in the stream Returns : Bio::PrimarySeq object Args : NONE =cut sub next_primary_seq { my $self=shift; return 0; } # ================================================================================== =head2 write_seq Title : write_seq Usage : Not Yet Implemented! $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { # Convert the Bio::Seq object(s) to AGAVE xml file. my ($self,@seqs) = @_; foreach my $seq ( @seqs ) { $self->_write_each_record( $seq ); # where most of the work actually takes place. } return; } # ================================================================================== =head2 _write_each_record Title : _write_each_record Usage : $agave->_write_each_record( $seqI ) Function: change data into agave format Returns : NONE Args : Bio::SeqI object =cut sub _write_each_record { my ($self,$seq) = @_; # $self->{'file'} =~ s/>//g; my $output = IO::File->new(">" . $self->{'file'}); my $writer = XML::Writer->new(OUTPUT => $output, NAMESPACES => 0, DATA_MODE => 1, DATA_INDENT => 2 ) ; $writer->xmlDecl("UTF-8"); $writer->doctype("sciobj", '', "sciobj.dtd"); $writer ->startTag('sciobj', 'version', '2', 'release', '2'); $writer->startTag('contig', 'length', $seq->length); my $annotation = $seq ->annotation; # print "annotation: $annotation\n"; exit; Bio::Annotation::Collection=HASH(0x8112e6c) if ( $annotation->get_Annotations('dblink') ) { # used to be $annotation->each_DBLink, but Bio::Annotation::Collection::each_DBLink # is now replaced with get_Annotations('dblink') my $dblink = $annotation->get_Annotations('dblink')->[0] ; $writer ->startTag('db_id', 'id', $dblink->primary_id , 'db_code', $dblink->database ); } else { $writer ->startTag('db_id', 'id', $seq->display_id , 'db_code', 'default' ); } $writer ->endTag('db_id') ; $writer->startTag('fragment_order'); $writer->startTag('fragment_orientation'); ##start bio_sequence ####my $organism = $seq->species->genus . " " . $seq->species->species; $writer ->startTag('bio_sequence', 'sequence_id', $seq->display_id, 'seq_length', $seq->length, # 'molecule_type', $seq->moltype, # deprecated 'molecule_type', $self->alphabet, #'organism_name', $organism ); # my $desc = $seq->{primary_seq}->{desc}; # print "desc: $desc\n"; exit; # print Data::Dumper->Dump([$seq]); exit; ##start db_id under bio_sequence $annotation = $seq ->annotation; # print "annotation: $annotation\n"; exit; Bio::Annotation::Collection=HASH(0x8112e6c) if ( $annotation->get_Annotations('dblink') ) { # used to be $annotation->each_DBLink, but Bio::Annotation::Collection::each_DBLink # is now replaced with get_Annotations('dblink') my $dblink = $annotation->get_Annotations('dblink')->[0] ; $writer ->startTag('db_id', 'id', $dblink->primary_id , 'db_code', $dblink->database ); } else { $writer ->startTag('db_id', 'id', $seq->display_id , 'db_code', 'default' ); } $writer ->endTag('db_id') ; ##start note my $note = "" ; foreach my $comment ( $annotation->get_Annotations('comment') ) { # used to be $annotations->each_Comment(), but that's now been replaced # with get_Annotations() # $comment is a Bio::Annotation::Comment object $note .= $comment->text() . "\n"; } $writer ->startTag('note'); $writer ->characters( $note ) ; $writer ->endTag('note'); ##start description $writer ->startTag('description'); # $writer ->characters( $annotation->get_Annotations('description') ) ; # used to be $annotations->each_description(), but that's now been # replaced with get_Annotations. # Simon added this: this is the primary_seq's desc (the DEFINITION tag in a genbank file) $writer->characters($seq->{primary_seq}->{desc}); $writer ->endTag('description'); ##start keywords foreach my $genename ( $annotation->get_Annotations('gene_name') ) { # used to be $annotations->each_gene_name, but that's now been # replaced with get_Annotations() $writer ->startTag('keyword'); $writer ->characters( $genename ) ; $writer ->endTag('keyword'); } foreach my $ref ( $annotation->get_Annotations('reference') ) { # used to be $annotation->each_Reference, but # that's now been replaced with get_Annotations('reference'); # link is a Bio::Annotation::Reference object $writer ->startTag('keyword'); # print Data::Dumper->Dump([$ref]); exit; my $medline = $ref->medline || 'null'; my $pubmed = $ref->pubmed || 'null'; my $database = $ref->database || 'null'; my $authors = $ref->authors || 'null'; my $title = $ref->title || 'null'; $writer ->characters( 'medline:' . "$medline" . ':' . 'pubmed:' . "$pubmed" . ':' . 'database:' . "$database" . ':' .'authors:' . "$authors" . ':' . 'title:' . "$title" ) ; $writer ->endTag('keyword'); } ## start sequence $writer ->startTag('sequence'); $writer ->characters( $seq->seq ) ; $writer ->endTag('sequence'); ## start xrefs $writer ->startTag('xrefs'); foreach my $link ( $annotation->get_Annotations('dblink') ) { # link is a Bio::Annotation::DBLink object $writer ->startTag('db_id', 'db_code', $link->database, 'id', $link->primary_id); $writer ->characters( $link->comment ) ; $writer ->endTag('db_id'); } $writer ->endTag('xrefs') ; ##start sequence map ##we can not use : my @feats = $seq->all_SeqFeatures; ##rather, we use top_SeqFeatures() to keep the tree structure my @feats = $seq->top_SeqFeatures ; my $features; ##now we need cluster top level seqfeature by algorithm my $maps; foreach my $feature (@feats) { my $map_type = $feature ->source_tag; push (@{$maps->{ $map_type }}, $feature); } ##now we enter each sequence_map foreach my $map_type (keys %$maps ) { $writer->startTag('sequence_map', 'label', $map_type ); $writer->startTag('annotations'); # the original author accidently entered 'annotation' instead of 'annotations' foreach my $feature ( @{$maps->{ $map_type }} ) { $self->_write_seqfeature( $feature, $writer ) ; } $writer->endTag('annotations'); $writer->endTag('sequence_map'); } $writer->endTag('bio_sequence'); $writer->endTag('fragment_orientation'); $writer->endTag('fragment_order'); $writer->endTag('contig'); $writer->endTag('sciobj'); } # ================================================================================== =head2 _write_seqfeature Usage : $agave->_write_each_record( $seqfeature, $write ) Function: change seeqfeature data into agave format Returns : NONE Args : Bio::SeqFeature object and XML::writer object =cut sub _write_seqfeature{ my ($self,$seqf, $writer) = @_; ##now enter seq feature $writer ->startTag('seq_feature', 'feature_type', $seqf->primary_tag() ); my $strand = $seqf->strand(); $strand = 0 if !defined $strand; # $strand == 1 ? 'false' : 'true'; my $is_on_complement; if ($strand == 1) { $is_on_complement = 'true'; } else { $is_on_complement = 'false'; } # die Data::Dumper->Dump([$seqf]) if !defined $strand; $writer ->startTag('seq_location', 'lease_start', $seqf->start(), 'greatest_end', $seqf->end(), # 'is_on_complement', $seqf->strand() == 1 ? 'false' : 'true') ; 'is_on_complement' , $is_on_complement); # is_on_complement: is the feature found on the complementary # strand (true) or not (false)? $writer ->endTag('seq_location'); ##enter qualifier foreach my $tag ( $seqf->all_tags() ) { $writer ->startTag('qualifier', 'qualifier_type', $tag); $writer ->characters( $seqf->each_tag_value($tag) ) ; $writer ->endTag('qualifier'); } ##now recursively travel the seqFeature foreach my $subfeat ( $seqf->sub_SeqFeature ) { $self->_write_seqfeature( $subfeat, $writer ) ; } $writer->endTag('seq_feature'); return; } # ================================================================================== =head2 _filehandle Title : _filehandle Usage : $obj->_filehandle($newval) Function: Example : Returns : value of _filehandle Args : newvalue (optional) =cut sub _filehandle{ my ($obj,$value) = @_; if ( defined $value) { $obj->{'_filehandle'} = $value; } return $obj->{'_filehandle'}; } # ================================================================================== =head2 throw Title : throw Usage : $self->throw; Function : Throw's error message. Calls SeqIO's throw method. Args : Array of string(s), holding error message(s). Returns : Nothing. Note : Method(s) that call(s) this method: many. Method(s) that this method calls: Bio::SeqIO's throw method. =cut sub throw { my ($self, @s) = @_; my $string = "[$.]" . join('', @s); $self->SUPER::throw($string); return; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/alf.pm��������������������������������������������������������������������000444��000765��000024�� 6731�12254227335� 16241� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::alf # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::alf - alf trace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from alf trace files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Aaron Mackey Email: amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::alf; use vars qw(@ISA $READ_AVAIL); use strict; use Bio::SeqIO; use Bio::Seq::SeqFactory; push @ISA, qw( Bio::SeqIO ); sub BEGIN { eval { require Bio::SeqIO::staden::read; }; if ($@) { $READ_AVAIL = 0; } else { push @ISA, "Bio::SeqIO::staden::read"; $READ_AVAIL = 1; } } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } unless ($READ_AVAIL) { Bio::Root::Root->throw( -class => 'Bio::Root::SystemException', -text => "Bio::SeqIO::staden::read is not available; make sure the bioperl-ext package has been installed successfully!" ); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self) = @_; my ($seq, $id, $desc, $qual) = $self->read_trace($self->_fh, 'alf'); # create the seq object $seq = $self->sequence_factory->create(-seq => $seq, -id => $id, -primary_id => $id, -desc => $desc, -alphabet => 'DNA', -qual => $qual ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh; foreach my $seq (@seq) { $self->write_trace($fh, $seq, 'alf'); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ���������������������������������������BioPerl-1.6.923/Bio/SeqIO/asciitree.pm��������������������������������������������������������������000444��000765��000024�� 12723�12254227327� 17466� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::asciitree # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Mungall <cjm@fruitfly.org> # # Copyright Chris Mungall # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::asciitree - asciitree sequence input/output stream =head1 SYNOPSIS # It is probably best not to use this object directly, but # rather go through the SeqIO handler system. Go: $instream = Bio::SeqIO->new(-file => $filename, -format => 'chadoxml'); $outstream = Bio::SeqIO->new(-file => $filename, -format => 'asciitree'); while ( my $seq = $instream->next_seq() ) { $outstream->write_seq(); } =head1 DESCRIPTION This is a WRITE-ONLY SeqIO module. It writes a Bio::SeqI object containing nested SeqFeature objects in such a way that the SeqFeature containment hierarchy is visible as a tree structure =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email cjm@fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::asciitree; use strict; use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. } =head2 show_detail Title : show_detail Usage : $obj->show_detail($newval) Function: Example : Returns : value of show_detail (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub show_detail{ my $self = shift; return $self->{'show_detail'} = shift if @_; return $self->{'show_detail'}; } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my ($self,@args) = @_; $self->throw("This is a WRITE-ONLY adapter"); } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { my ($self,@seqs) = @_; foreach my $seq ( @seqs ) { $self->throw("Attempting to write with no seq!") unless defined $seq; if( ! ref $seq || ! $seq->isa('Bio::SeqI') ) { $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!"); } $self->_print("Seq: ".$seq->accession_number); $self->_print("\n"); my @top_sfs = $seq->get_SeqFeatures; $self->write_indented_sf(1, @top_sfs); } } sub write_indented_sf { my $self = shift; my $indent = shift; my @sfs = @_; foreach my $sf (@sfs) { my $label = ''; if ($sf->has_tag('standard_name')) { ($label) = $sf->get_tag_values('standard_name'); } if ($sf->has_tag('product')) { ($label) = $sf->get_tag_values('product'); } my $COLS = 60; my $tab = ' ' x 10; my @lines = (); if ($self->show_detail) { my @tags = $sf->all_tags; foreach my $tag (@tags) { my @vals = $sf->get_tag_values($tag); foreach my $val (@vals) { $val = "\"$val\""; push(@lines, "$tab/$tag="); while (my $cut = substr($val, 0, $COLS - length($lines[-1]), '')) { $lines[-1] .= "$cut"; if ($val) { push(@lines, $tab); } } } } } my $detail = join("\n", @lines); my @sub_sfs = $sf->get_SeqFeatures; my $locstr = ''; if (!@sub_sfs) { $locstr = $self->_locstr($sf); } my $col1 = sprintf("%s%s $label", ' ' x $indent, $sf->primary_tag); my $line = sprintf("%-50s %s\n", substr($col1, 0, 50), $locstr); $self->_print($line); if ($detail) { $self->_print($detail."\n"); } $self->write_indented_sf($indent+1, @sub_sfs); } return; } sub _locstr { my $self = shift; my $sf = shift; my $strand = $sf->strand || 0; my $ss = '.'; $ss = '+' if $strand > 0; $ss = '-' if $strand < 0; my $splitlocstr = ''; if ($sf->isa("Bio::SeqFeatureI")) { my @locs = ($sf->location); if ($sf->location->isa("Bio::Location::SplitLocationI")) { @locs = $sf->location->each_Location; $splitlocstr = "; SPLIT: ".join(" ", map {$self->_locstr($_)} @locs); } } return sprintf("%d..%d[%s] $splitlocstr", $sf->start, $sf->end, $ss); } 1; ���������������������������������������������BioPerl-1.6.923/Bio/SeqIO/bsml.pm�������������������������������������������������������������������000444��000765��000024�� 137256�12254227327� 16504� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::bsml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Charles Tilford (tilfordc@bms.com) # Copyright (C) Charles Tilford 2001 # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2.1 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # Also at: http://www.gnu.org/copyleft/lesser.html # Much of the basic documentation in this module has been # cut-and-pasted from the embl.pm (Ewan Birney) SeqIO module. =head1 NAME Bio::SeqIO::bsml - BSML sequence input/output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system. To read a BSML file: $stream = Bio::SeqIO->new( -file => $filename, -format => 'bsml'); while ( my $bioSeqObj = $stream->next_seq() ) { # do something with $bioSeqObj } To write a Seq object to the current file handle in BSML XML format: $stream->write_seq( -seq => $seqObj); If instead you would like a XML::DOM object containing the BSML, use: my $newXmlObject = $stream->to_bsml( -seq => $seqObj); =head1 DEPENDENCIES In addition to parts of the Bio:: hierarchy, this module uses: XML::DOM =head1 DESCRIPTION This object can transform Bio::Seq objects to and from BSML (XML) flatfiles. =head2 NOTE: 2/1/02 - I have changed the API to more closely match argument passing used by other BioPerl methods ( -tag => value ). Internal methods are using the same API, but you should not be calling those anyway... =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head2 Things Still to Do * The module now uses the new Collection.pm system. However, Annotations associated with a Feature object still seem to use the old system, so parsing with the old methods are included.. * Generate Seq objects with no sequence data but an assigned length. This appears to be an issue with Bio::Seq. It is possible (and reasonable) to make a BSML document with features but no sequence data. * Support <Seq-data-import>. Do not know how commonly this is used. * Some features are awaiting implementation in later versions of BSML. These include: * Nested feature support * Complex feature (ie joins) * Unambiguity in strand (ie -1,0,1, not just 'complement' ) * More friendly dblink structures * Location.pm (or RangeI::union?) appears to have a bug when 'expand' is used. * More intelligent hunting for sequence and feature titles? It is not terribly clear where the most appropriate field is located, better grepping (eg looking for a reasonable count for spaces and numbers) may allow for titles better than "AE008041". =head1 AUTHOR - Charles Tilford Bristol-Myers Squibb Bioinformatics Email tilfordc@bms.com I have developed the BSML specific code for this package, but have used code from other SeqIO packages for much of the nuts-and-bolts. In particular I have used code from the embl.pm module either directly or as a framework for many of the subroutines that are common to SeqIO modules. =cut package Bio::SeqIO::bsml; use strict; use Bio::SeqFeature::Generic; use Bio::Species; use XML::DOM; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO); my $idcounter = {}; # Used to generate unique id values my $nvtoken = ": "; # The token used if a name/value pair has to be stuffed # into a single line =head1 METHODS =cut # LS: this seems to get overwritten on line 1317, generating a redefinition error. Dead code? # CAT: This was inappropriately added in revision 1.10 - I added the check for existance of a sequence factory to the actual _initialize # sub _initialize { # my($self,@args) = @_; # $self->SUPER::_initialize(@args); # if( ! defined $self->sequence_factory ) { # $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); # } # } =head2 next_seq Title : next_seq Usage : my $bioSeqObj = $stream->next_seq Function: Retrieves the next sequence from a SeqIO::bsml stream. Returns : A reference to a Bio::Seq::RichSeq object Args : =cut sub next_seq { my $self = shift; my ($desc); my $bioSeq = $self->sequence_factory->create(-verbose =>$self->verbose()); unless (exists $self->{'domtree'}) { $self->throw("A BSML document has not yet been parsed."); return; } my $dom = $self->{'domtree'}; my $seqElements = $dom->getElementsByTagName ("Sequence"); if ($self->{'current_node'} == $seqElements->getLength ) { # There are no more <Sequence>s to process return; } my $xmlSeq = $seqElements->item($self->{'current_node'}); # Assume that title attribute contains the best display id if (my $val = $xmlSeq->getAttribute( "title")) { $bioSeq->display_id($val); } # Set the molecule type if (my $val = $xmlSeq->getAttribute( "molecule" )) { my %mol = ('dna' => 'DNA', 'rna' => 'RNA', 'aa' => 'protein'); $bioSeq->molecule($mol{ lc($val) }); } # Set the accession number if (my $val = $xmlSeq->getAttribute( "ic-acckey" )) { $bioSeq->accession_number($val); } # Get the sequence data for the element if (my $seqData = &FIRSTDATA($xmlSeq->getElementsByTagName("Seq-data") ->item(0) ) ) { # Sequence data exists, transfer to the Seq object # Remove white space and CRs (not neccesary?) $seqData =~ s/[\s\n\r]//g; $bioSeq->seq($seqData); } elsif (my $import = $xmlSeq->getElementsByTagName("Seq-dataimport") ->item(0) ) { #>>>> # What about <Seq-data-import> ?? } elsif (my $val = $xmlSeq->getAttribute("length")) { # No sequence defined, set the length directly #>>>> # This does not appear to work - length is apparently calculated # from the sequence. How to make a "virtual" sequence??? Such # creatures are common in BSML... $bioSeq->length($val); } my $species = Bio::Species->new(); my @classification = (); # Peruse the generic <Attributes> - those that are direct children of # the <Sequence> or the <Feature-tables> element # Sticky wicket here - data not controlled by schema, could be anything my @seqDesc = (); my %specs = ('common_name' => 'y', 'genus' => 'y', 'species' => 'y', 'sub_species' => 'y', ); my %seqMap = ( 'add_date' => [ qw(date date-created date-last-updated)], 'keywords' => [ 'keyword', ], 'seq_version' => [ 'version' ], 'division' => [ 'division' ], 'add_secondary_accession' => ['accession'], 'pid' => ['pid'], 'primary_id' => [ 'primary.id', 'primary_id' ], ); my @links; my $floppies = &GETFLOPPIES($xmlSeq); for my $attr (@{$floppies}) { # Don't want to get attributes from <Feature> or <Table> elements yet my $parent = $attr->getParentNode->getNodeName; next unless($parent eq "Sequence" || $parent eq "Feature-tables"); my ($name, $content) = &FLOPPYVALS($attr); $name = lc($name); if (exists $specs{$name}) { # It looks like part of species... $species->$name($content); next; } my $value = ""; # Cycle through the Seq methods: for my $method (keys %seqMap) { # Cycle through potential matching attributes: for my $match (@{$seqMap{$method}}) { # If the <Attribute> name matches one of the keys, # set $value, unless it has already been set $value ||= $content if ($name =~ /$match/i); } if ($value ne "") { if( $method eq 'seq_version'&& $value =~ /\S+\.(\d+)/ ) { # hack for the fact that data in version is actually # ACCESSION.VERSION ($value) = $1; } $bioSeq->$method($value); last; } } if( $name eq 'database-xref' ) { my ($link_id,$link_db) = split(/:/,$value); push @links, Bio::Annotation::DBLink->new(-primary_id => $link_id, -database => $link_db); } next if ($value ne ""); if ($name =~ /^species$/i) { # Uh, it's the species designation? if ($content =~ / /) { # Assume that a full species name has been provided # This will screw up if the last word is the subspecies... my @break = split " ", $content; @classification = reverse @break; } else { $classification[0] = $content; } next; } if ($name =~ /sub[_ ]?species/i) { # Should be the subspecies... $species->sub_species( $content ); next; } if ($name =~ /classification/i) { # Should be species classification # We will assume that there are spaces separating the terms: my @bits = split " ", $content; # Now make sure there is not other cruft as well (eg semi-colons) for my $i (0..$#bits) { $bits[$i] =~ /(\w+)/; $bits[$i] = $1; } $species->classification( @bits ); next; } if ($name =~ /comment/) { my $com = Bio::Annotation::Comment->new('-text' => $content); # $bioSeq->annotation->add_Comment($com); $bioSeq->annotation->add_Annotation('comment', $com); next; } # Description line - collect all descriptions for later assembly if ($name =~ /descr/) { push @seqDesc, $content; next; } # Ok, we have no idea what this attribute is. Dump to SimpleValue my $simp = Bio::Annotation::SimpleValue->new( -value => $content); $bioSeq->annotation->add_Annotation($name, $simp); } unless ($#seqDesc < 0) { $bioSeq->desc( join "; ", @seqDesc); } #>>>> This should be modified so that any IDREF associated with the # <Reference> is then used to associate the reference with the # appropriate Feature # Extract out <Reference>s associated with the sequence my @refs; my %tags = ( -title => "RefTitle", -authors => "RefAuthors", -location => "RefJournal", ); for my $ref ( $xmlSeq->getElementsByTagName ("Reference") ) { my %refVals; for my $tag (keys %tags) { my $rt = &FIRSTDATA($ref->getElementsByTagName($tags{$tag}) ->item(0)); next unless ($rt); $rt =~ s/^[\s\r\n]+//; # Kill leading space $rt =~ s/[\s\r\n]+$//; # Kill trailing space $rt =~ s/[\s\r\n]+/ /; # Collapse internal space runs $refVals{$tag} = $rt; } my $reference = Bio::Annotation::Reference->new( %refVals ); # Pull out any <Reference> information hidden in <Attributes> my %refMap = ( comment => [ 'comment', 'remark' ], medline => [ 'medline', ], pubmed => [ 'pubmed' ], start => [ 'start', 'begin' ], end => [ 'stop', 'end' ], ); my @refCom = (); my $floppies = &GETFLOPPIES($ref); for my $attr (@{$floppies}) { my ($name, $content) = &FLOPPYVALS($attr); my $value = ""; # Cycle through the Seq methods: for my $method (keys %refMap) { # Cycle through potential matching attributes: for my $match (@{$refMap{$method}}) { # If the <Attribute> name matches one of the keys, # set $value, unless it has already been set $value ||= $content if ($name =~ /$match/i); } if ($value ne "") { my $str = '$reference->' . $method . "($value)"; eval($str); next; } } next if ($value ne ""); # Don't know what the <Attribute> is, dump it to comments: push @refCom, $name . $nvtoken . $content; } unless ($#refCom < 0) { # Random stuff was found, tack it to the comment field my $exist = $reference->comment; $exist .= join ", ", @refCom; $reference->comment($exist); } push @refs, $reference; } $bioSeq->annotation->add_Annotation('reference' => $_) for @refs; my $ann_col = $bioSeq->annotation; # Extract the <Feature>s for this <Sequence> for my $feat ( $xmlSeq->getElementsByTagName("Feature") ) { $bioSeq->add_SeqFeature( $self->_parse_bsml_feature($feat) ); } $species->classification( @classification ); $bioSeq->species( $species ); $bioSeq->annotation->add_Annotation('dblink' => $_) for @links; $self->{'current_node'}++; return $bioSeq; } #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Get all the <Attribute> and <Qualifier> children for an object, and # return them as an array reference # ('floppy' since these elements have poor/no schema control) sub GETFLOPPIES { my $obj = shift; my @floppies; my $attributes = $obj->getElementsByTagName ("Attribute"); for (my $i = 0; $i < $attributes->getLength; $i++) { push @floppies, $attributes->item($i); } my $qualifiers = $obj->getElementsByTagName ("Qualifier"); for (my $i = 0; $i < $qualifiers->getLength; $i++) { push @floppies, $qualifiers->item($i); } return \@floppies; } #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Given a DOM <Attribute> or <Qualifier> object, return the [name, value] pair sub FLOPPYVALS { my $obj = shift; my ($name, $value); if ($obj->getNodeName eq "Attribute") { $name = $obj->getAttribute('name'); $value = $obj->getAttribute('content'); } elsif ($obj->getNodeName eq "Qualifier") { # Wheras <Attribute>s require both 'name' and 'content' attributes, # <Qualifier>s can technically have either blank (and sometimes do) my $n = $obj->getAttribute('value-type'); $name = $n if ($n ne ""); my $v = $obj->getAttribute('value'); $value = $v if ($v ne ""); } return ($name, $value); } #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Returns the value of the first TEXT_NODE encountered below an element # Rational - avoid grabbing a comment rather than the PCDATA. Not foolproof... sub FIRSTDATA { my $element = shift; return unless ($element); my $hopefuls = $element->getChildNodes; my $data; for (my $i = 0; $i < $hopefuls->getLength; $i++) { if ($hopefuls->item($i)->getNodeType == XML::DOM::Node::TEXT_NODE() ) { $data = $hopefuls->item($i)->getNodeValue; last; } } return $data; } #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Just collapses whitespace runs in a string sub STRIP { my $string = shift; $string =~ s/[\s\r\n]+/ /g; return $string; } =head2 to_bsml Title : to_bsml Usage : my $domDoc = $obj->to_bsml(@args) Function: Generates an XML structure for one or more Bio::Seq objects. If $seqref is an array ref, the XML tree generated will include all the sequences in the array. Returns : A reference to the XML DOM::Document object generated / modified Args : Argument array in form of -key => val. Recognized keys: -seq A Bio::Seq reference, or an array reference of many of them -xmldoc Specifies an existing XML DOM document to add the sequences to. If included, then only data (no page formatting) will be added. If not, a new XML::DOM::Document will be made, and will be populated with both <Sequence> data, as well as <Page> display elements. -nodisp Do not generate <Display> elements, or any children thereof, even if -xmldoc is not set. -skipfeat If set to 'all', all <Feature>s will be skipped. If it is a hash reference, any <Feature> with a class matching a key in the hash will be skipped - for example, to skip 'source' and 'score' features, use: -skipfeat => { source => 'Y', score => 'Y' } -skiptags As above: if set to 'all', no tags are included, and if a hash reference, those specific tags will be ignored. Skipping some or all tags and features can result in noticeable speed improvements. -nodata If true, then <Seq-data> will not be included. This may be useful if you just want annotations and do not care about the raw ACTG information. -return Default is 'xml', which will return a reference to the BSML XML object. If set to 'seq' will return an array ref of the <Sequence> objects added (rather than the whole XML object) -close Early BSML browsers will crash if an element *could* have children but does not, and is closed as an empty element e.g. <Styles/>. If -close is true, then such tags are given a comment child to explicitly close them e.g. <Styles><!-- --></Styles>. This is default true, set to "0" if you do not want this behavior. Examples : my $domObj = $stream->to_bsml( -seq => \@fourCoolSequenceObjects, -skipfeat => { source => 1 }, ); # Or add sequences to an existing BSML document: $stream->to_bsml( -seq => \@fourCoolSequenceObjects, -skipfeat => { source => 1 }, -xmldoc => $myBsmlDocumentInProgress, ); =cut sub to_bsml { my $self = shift; my $args = $self->_parseparams( -close => 1, -return => 'xml', @_); $args->{NODISP} ||= $args->{NODISPLAY}; my $seqref = $args->{SEQ}; $seqref = (ref($seqref) eq 'ARRAY') ? $seqref : [ $seqref ]; ############################# # Basic BSML XML Components # ############################# my $xml; my ($bsmlElem, $defsElem, $seqsElem, $dispElem); if ($args->{XMLDOC}) { # The user has provided an existing XML DOM object $xml = $args->{XMLDOC}; unless ($xml->isa("XML::DOM::Document")) { $self->throw('SeqIO::bsml.pm error:\n'. 'When calling ->to_bsml( { xmldoc => $myDoc }), $myDoc \n' . 'should be an XML::DOM::Document object, or an object that\n'. 'inherits from that class (like BsmlHelper.pm)'); } } else { # The user has not provided a new document, make one from scratch $xml = XML::DOM::Document->new(); $xml->setXMLDecl( $xml->createXMLDecl("1.0") ); my $url = "http://www.labbook.com/dtd/bsml2_2.dtd"; my $doc = $xml->createDocumentType("Bsml",$url); $xml->setDoctype($doc); $bsmlElem = $self->_addel( $xml, 'Bsml'); $defsElem = $self->_addel( $bsmlElem, 'Definitions'); $seqsElem = $self->_addel( $defsElem, 'Sequences'); unless ($args->{NODISP}) { $dispElem = $self->_addel( $bsmlElem, 'Display'); my $stylElem = $self->_addel( $dispElem, 'Styles'); my $style = $self->_addel( $stylElem, 'Style', { type => "text/css" }); my $styleText = qq(Interval-widget { display : "1"; }\n) . qq(Feature { display-auto : "1"; }); $style->appendChild( $xml->createTextNode($styleText) ); } } # Establish fundamental BSML elements, if they do not already exist $bsmlElem ||= $xml->getElementsByTagName("Bsml")->item(0); $defsElem ||= $xml->getElementsByTagName("Definitions")->item(0); $seqsElem ||= $xml->getElementsByTagName("Sequences")->item(0); ############### # <Sequences> # ############### # Map over Bio::Seq to BSML my %mol = ('dna' => 'DNA', 'rna' => 'RNA', 'protein' => 'AA'); my @xmlSequences; for my $bioSeq (@{$seqref}) { my $xmlSeq = $xml->createElement("Sequence"); my $FTs = $xml->createElement("Feature-tables"); # Array references to hold <Reference> objects: my $seqRefs = []; my $featRefs = []; # Array references to hold <Attribute> values (not objects): my $seqDesc = []; push @{$seqDesc}, ["comment" , "This file generated to BSML 2.2 standards - joins will be collapsed to a single feature enclosing all members of the join"]; push @{$seqDesc}, ["description" , eval{$bioSeq->desc}]; for my $kwd ( eval{$bioSeq->get_keywords} ) { push @{$seqDesc}, ["keyword" , $kwd]; } push @{$seqDesc}, ["keyword" , eval{$bioSeq->keywords}]; push @{$seqDesc}, ["version" , eval{ join(".", $bioSeq->accession_number, $bioSeq->seq_version); }]; push @{$seqDesc}, ["division" , eval{$bioSeq->division}]; push @{$seqDesc}, ["pid" , eval{$bioSeq->pid}]; # push @{$seqDesc}, ["bio_object" , ref($bioSeq)]; push @{$seqDesc}, ["primary_id" , eval{$bioSeq->primary_id}]; for my $dt (eval{$bioSeq->get_dates()} ) { push @{$seqDesc}, ["date" , $dt]; } for my $ac (eval{$bioSeq->get_secondary_accessions()} ) { push @{$seqDesc}, ["secondary_accession" , $ac]; } # Determine the accession number and a unique identifier my $acc = $bioSeq->accession_number eq "unknown" ? "" : $bioSeq->accession_number; my $id; my $pi = $bioSeq->primary_id; if ($pi && $pi !~ /Bio::/) { # Not sure I understand what primary_id is... It sometimes # is a string describing a reference to a BioSeq object... $id = "SEQ" . $bioSeq->primary_id; } else { # Nothing useful found, make a new unique ID $id = $acc || ("SEQ-io" . $idcounter->{Sequence}++); } # print "$id->",ref($bioSeq->primary_id),"\n"; # An id field with spaces is interpreted as an idref - kill the spaces $id =~ s/ /-/g; # Map over <Sequence> attributes my %attr = ( 'title' => $bioSeq->display_id, 'length' => $bioSeq->length, 'ic-acckey' => $acc, 'id' => $id, 'representation' => 'raw', ); $attr{molecule} = $mol{ lc($bioSeq->molecule) } if $bioSeq->can('molecule'); for my $a (keys %attr) { $xmlSeq->setAttribute($a, $attr{$a}) if (defined $attr{$a} && $attr{$a} ne ""); } # Orphaned Attributes: $xmlSeq->setAttribute('topology', 'circular') if ($bioSeq->is_circular); # <Sequence> strand, locus $self->_add_page($xml, $xmlSeq) if ($dispElem); ################ # <Attributes> # ################ # Check for Bio::Annotations on the * <Sequence> *. $self->_parse_annotation( -xml => $xml, -obj => $bioSeq, -desc => $seqDesc, -refs => $seqRefs); # Incorporate species data if (ref($bioSeq->species) eq 'Bio::Species') { # Need to peer into Bio::Species ... my @specs = ('common_name', 'genus', 'species', 'sub_species'); for my $sp (@specs) { next unless (my $val = $bioSeq->species()->$sp()); push @{$seqDesc}, [$sp , $val]; } push @{$seqDesc}, ['classification', (join " ", $bioSeq->species->classification) ]; # Species::binomial will return "genus species sub_species" ... } elsif (my $val = $bioSeq->species) { # Ok, no idea what it is, just dump it in there... push @{$seqDesc}, ["species", $val]; } # Add the description <Attribute>s for the <Sequence> for my $seqD (@{$seqDesc}) { $self->_addel($xmlSeq, "Attribute", { name => $seqD->[0], content => $seqD->[1]}) if ($seqD->[1]); } # If sequence references were added, make a Feature-table for them unless ($#{$seqRefs} < 0) { my $seqFT = $self->_addel($FTs, "Feature-table", { title => "Sequence References", }); for my $feat (@{$seqRefs}) { $seqFT->appendChild($feat); } } # This is the appropriate place to add <Feature-tables> $xmlSeq->appendChild($FTs); ############# # <Feature> # ############# #>>>> # Perhaps it is better to loop through top_Seqfeatures?... #>>>> # ...however, BSML does not have a hierarchy for Features if (defined $args->{SKIPFEAT} && $args->{SKIPFEAT} eq 'all') { $args->{SKIPFEAT} = { all => 1}; } else { $args->{SKIPFEAT} ||= {} } for my $class (keys %{$args->{SKIPFEAT}}) { $args->{SKIPFEAT}{lc($class)} = $args->{SKIPFEAT}{$class}; } # Loop through all the features my @features = $bioSeq->all_SeqFeatures(); if (@features && !$args->{SKIPFEAT}{all}) { my $ft = $self->_addel($FTs, "Feature-table", { title => "Features", }); for my $bioFeat (@features ) { my $featDesc = []; my $class = lc($bioFeat->primary_tag); # The user may have specified to ignore this type of feature next if ($args->{SKIPFEAT}{$class}); my $id = "FEAT-io" . $idcounter->{Feature}++; my $xmlFeat = $self->_addel( $ft, 'Feature', { 'id' => $id, 'class' => $class , 'value-type' => $bioFeat->source_tag }); # Check for Bio::Annotations on the * <Feature> *. $self->_parse_annotation( -xml => $xml, -obj => $bioFeat, -desc => $featDesc, -id => $id, -refs =>$featRefs, ); # Add the description stuff for the <Feature> for my $de (@{$featDesc}) { $self->_addel($xmlFeat, "Attribute", { name => $de->[0], content => $de->[1]}) if ($de->[1]); } $self->_parse_location($xml, $xmlFeat, $bioFeat); # loop through the tags, add them as <Qualifiers> next if (defined $args->{SKIPTAGS} && $args->{SKIPTAGS} =~ /all/i); # Tags can consume a lot of CPU cycles, and can often be # rather non-informative, so -skiptags can allow total or # selective omission of tags. for my $tag ($bioFeat->all_tags()) { next if (exists $args->{SKIPTAGS}{$tag}); for my $val ($bioFeat->each_tag_value($tag)) { $self->_addel( $xmlFeat, 'Qualifier', { 'value-type' => $tag , 'value' => $val }); } } } } ############## # <Seq-data> # ############## # Add sequence data if ( (my $data = $bioSeq->seq) && !$args->{NODATA} ) { my $d = $self->_addel($xmlSeq, 'Seq-data'); $d->appendChild( $xml->createTextNode($data) ); } # If references were added, make a Feature-table for them unless ($#{$featRefs} < 0) { my $seqFT = $self->_addel($FTs, "Feature-table", { title => "Feature References", }); for my $feat (@{$featRefs}) { $seqFT->appendChild($feat); } } # Place the completed <Sequence> tree as a child of <Sequences> $seqsElem->appendChild($xmlSeq); push @xmlSequences, $xmlSeq; } # Prevent browser crashes by explicitly closing empty elements: if ($args->{CLOSE}) { my @problemChild = ('Sequences', 'Sequence', 'Feature-tables', 'Feature-table', 'Screen', 'View',); for my $kid (@problemChild) { for my $prob ($xml->getElementsByTagName($kid)) { unless ($prob->hasChildNodes) { $prob->appendChild( $xml->createComment(" Must close <$kid> explicitly ")); } } } } if (defined $args->{RETURN} && $args->{RETURN} =~ /seq/i) { return \@xmlSequences; } else { return $xml; } } =head2 write_seq Title : write_seq Usage : $obj->write_seq(@args) Function: Prints out an XML structure for one or more Bio::Seq objects. If $seqref is an array ref, the XML tree generated will include all the sequences in the array. This method is fairly simple, most of the processing is performed within to_bsml. Returns : A reference to the XML object generated / modified Args : Argument array. Recognized keys: -seq A Bio::Seq reference, or an array reference of many of them Alternatively, the method may be called simply as... $obj->write_seq( $bioseq ) ... if only a single argument is passed, it is assumed that it is the sequence object (can also be an array ref of many Seq objects ) -printmime If true prints "Content-type: $mimetype\n\n" at top of document, where $mimetype is the value designated by this key. For generic XML use text/xml, for BSML use text/x-bsml -return This option will be supressed, since the nature of this method is to print out the XML document. If you wish to retrieve the <Sequence> objects generated, use the to_bsml method directly. =cut sub write_seq { my $self = shift; my $args = $self->_parseparams( @_); if ($#_ == 0 ) { # If only a single value is passed, assume it is the seq object unshift @_, "-seq"; } # Build a BSML XML DOM object based on the sequence(s) my $xml = $self->to_bsml( @_, -return => undef ); # Convert to a string my $out = $xml->toString; # Print after putting a return after each element - more readable $out =~ s/>/>\n/g; $self->_print("Content-type: " . $args->{PRINTMIME} . "\n\n") if ($args->{PRINTMIME}); $self->_print( $out ); # Return the DOM tree in case the user wants to do something with it $self->flush if $self->_flush_on_write && defined $self->_fh; return $xml; } =head1 INTERNAL METHODS #-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#- The following methods are used for internal processing, and should probably not be accessed by the user. =head2 _parse_location Title : _parse_location Usage : $obj->_parse_location($xmlDocument, $parentElem, $SeqFeatureObj) Function: Adds <Interval-loc> and <Site-loc> children to <$parentElem> based on locations / sublocations found in $SeqFeatureObj. If sublocations exist, the original location will be ignored. Returns : An array ref containing the elements added to the parent. These will have already been added to <$parentElem> Args : 0 The DOM::Document being modified 1 The DOM::Element parent that you want to add to 2 Reference to the Bio::SeqFeature being analyzed =cut ############################### # <Interval-loc> & <Site-loc> # ############################### sub _parse_location { my $self = shift; my ($xml, $xmlFeat, $bioFeat) = @_; my $bioLoc = $bioFeat->location; my @locations; if (ref($bioLoc) =~ /Split/) { @locations = $bioLoc->sub_Location; # BSML 2.2 does not recognize / support joins. For this reason, # we will just use the upper-level location. The line below can # be deleted or commented out if/when BSML 3 supports complex # interval deffinitions: @locations = ($bioLoc); } else { @locations = ($bioLoc); } my @added = (); # Add the site or interval positional information: for my $loc (@locations) { my ($start, $end) = ($loc->start, $loc->end); my %locAttr; # Strand information is not well described in BSML $locAttr{complement} = 1 if ($loc->strand == -1); if ($start ne "" && ($start == $end || $end eq "")) { $locAttr{sitepos} = $start; push @added, $self->_addel($xmlFeat,'Site-loc',\%locAttr); } elsif ($start ne "" && $end ne "") { if ($start > $end) { # The feature is on the complementary strand ($start, $end) = ($end, $start); $locAttr{complement} = 1; } $locAttr{startpos} = $start; $locAttr{endpos} = $end; push @added, $self->_addel($xmlFeat,'Interval-loc',\%locAttr); } else { warn "Failure to parse SeqFeature location. Start = '$start' & End = '$end'"; } } return \@added; } =head2 _parse_bsml_feature Title : _parse_bsml_feature Usage : $obj->_parse_bsml_feature($xmlFeature ) Function: Will examine the <Feature> element provided by $xmlFeature and return a generic seq feature. Returns : Bio::SeqFeature::Generic Args : 0 XML::DOM::Element <Feature> being analyzed. =cut sub _parse_bsml_feature { my $self = shift; my ($feat) = @_; my $basegsf = Bio::SeqFeature::Generic->new(); # score # frame # source_tag # Use the class as the primary tag value, if it is present if ( my $val = $feat->getAttribute("class") ) { $basegsf->primary_tag($val); } # Positional information is in <Interval-loc>s or <Site-loc>s # We need to grab these in order, to try to recreate joins... my @locations = (); for my $kid ($feat->getChildNodes) { my $nodeName = $kid->getNodeName; next unless ($nodeName eq "Interval-loc" || $nodeName eq "Site-loc"); push @locations, $kid; } if ($#locations == 0) { # There is only one location specified $self->_parse_bsml_location($locations[0], $basegsf); } elsif ($#locations > 0) { #>>>> # This is not working, I think the error is somewhere downstream # of add_sub_SeqFeature, probably in RangeI::union ? # The sub features are added fine, but the EXPANDed parent feature # location has a messed up start - Bio::SeqFeature::Generic ref # instead of an integer - and an incorrect end - the end of the first # sub feature added, not of the union of all of them. # Also, the SeqIO::genbank.pm output is odd - the sub features appear # to be listed with the *previous* feature, not this one. for my $location (@locations) { my $subgsf = $self->_parse_bsml_location($location); # print "start ", $subgsf->start,"\n"; # print "end ", $subgsf->end,"\n"; $basegsf->add_sub_SeqFeature($subgsf, 'EXPAND'); } # print $feat->getAttribute('id'),"\n"; # print $basegsf->primary_tag,"\n"; } else { # What to do if there are no locations? Nothing needed? } # Look at any <Attribute>s or <Qualifier>s that are present: my $floppies = &GETFLOPPIES($feat); for my $attr (@{$floppies}) { my ($name, $content) = &FLOPPYVALS($attr); # Don't know what the object is, dump it to a tag: $basegsf->add_tag_value(lc($name), $content); } # Mostly this helps with debugging, but may be of utility... # Add a tag holding the BSML id value if ( (my $val = $feat->getAttribute('id')) && !$basegsf->has_tag('bsml-id')) { # Decided that this got a little sloppy... # $basegsf->add_tag_value("bsml-id", $val); } return $basegsf; } =head2 _parse_bsml_location Title : _parse_bsml_location Usage : $obj->_parse_bsml_feature( $intOrSiteLoc, $gsfObject ) Function: Will examine the <Interval-loc> or <Site-loc> element provided Returns : Bio::SeqFeature::Generic Args : 0 XML::DOM::Element <Interval/Site-loc> being analyzed. 1 Optional SeqFeature::Generic to use =cut sub _parse_bsml_location { my $self = shift; my ($loc, $gsf) = @_; $gsf ||= Bio::SeqFeature::Generic->new(); my $type = $loc->getNodeName; my ($start, $end); if ($type eq 'Interval-loc') { $start = $loc->getAttribute('startpos'); $end = $loc->getAttribute('endpos'); } elsif ($type eq 'Site-loc') { $start = $end = $loc->getAttribute('sitepos'); } else { warn "Unknown location type '$type', could not make GSF\n"; return; } $gsf->start($start); $gsf->end($end); # BSML does not have an explicit method to set undefined strand if (my $s = $loc->getAttribute("complement")) { if ($s) { $gsf->strand(-1); } else { $gsf->strand(1); } } else { # We're setting "strand nonspecific" here - bad idea? # In most cases the user likely meant it to be on the + strand $gsf->strand(0); } return $gsf; } =head2 _parse_reference Title : _parse_reference Usage : $obj->_parse_reference(@args ) Function: Makes a new <Reference> object from a ::Reference, which is then stored in an array provide by -refs. It will be appended to the XML tree later. Returns : Args : Argument array. Recognized keys: -xml The DOM::Document being modified -refobj The Annotation::Reference Object -refs An array reference to hold the new <Reference> DOM object -id Optional. If the XML id for the 'calling' element is provided, it will be placed in any <Reference> refs attribute. =cut sub _parse_reference { my $self = shift; my $args = $self->_parseparams( @_); my ($xml, $ref, $refRef) = ($args->{XML}, $args->{REFOBJ}, $args->{REFS}); ############### # <Reference> # ############### my $xmlRef = $xml->createElement("Reference"); #>> This may not be the right way to make a BSML dbxref... if (my $link = $ref->medline) { $xmlRef->setAttribute('dbxref', $link); } # Make attributes for some of the characteristics my %stuff = ( start => $ref->start, end => $ref->end, rp => $ref->rp, comment => $ref->comment, pubmed => $ref->pubmed, ); for my $s (keys %stuff) { $self->_addel($xmlRef, "Attribute", { name => $s, content => $stuff{$s} }) if ($stuff{$s}); } $xmlRef->setAttribute('refs', $args->{ID}) if ($args->{ID}); # Add the basic information # Should probably check for content before creation... $self->_addel($xmlRef, "RefAuthors")-> appendChild( $xml->createTextNode(&STRIP($ref->authors)) ); $self->_addel($xmlRef, "RefTitle")-> appendChild( $xml->createTextNode(&STRIP($ref->title)) ); $self->_addel($xmlRef, "RefJournal")-> appendChild( $xml->createTextNode(&STRIP($ref->location)) ); # References will be added later in a <Feature-Table> push @{$refRef}, $xmlRef; } =head2 _parse_annotation Title : _parse_annotation Usage : $obj->_parse_annotation(@args ) Function: Will examine any Annotations found in -obj. Data found in ::Comment and ::DBLink structures, as well as Annotation description fields are stored in -desc for later generation of <Attribute>s. <Reference> objects are generated from ::References, and are stored in -refs - these will be appended to the XML tree later. Returns : Args : Argument array. Recognized keys: -xml The DOM::Document being modified -obj Reference to the Bio object being analyzed -descr An array reference for holding description text items -refs An array reference to hold <Reference> DOM objects -id Optional. If the XML id for the 'calling' element is provided, it will be placed in any <Reference> refs attribute. =cut sub _parse_annotation { my $self = shift; my $args = $self->_parseparams( @_); my ($xml, $obj, $descRef, $refRef) = ( $args->{XML}, $args->{OBJ}, $args->{DESC}, $args->{REFS} ); # No good place to put any of this (except for references). Most stuff # just gets dumped to <Attribute>s my $ann = $obj->annotation; return unless ($ann); # use BMS::Branch; my $debug = BMS::Branch->new( ); warn "$obj :"; $debug->branch($ann); unless (ref($ann) =~ /Collection/) { # Old style annotation. It seems that Features still use this # form of object $self->_parse_annotation_old(@_); return; } for my $key ($ann->get_all_annotation_keys()) { for my $thing ($ann->get_Annotations($key)) { if ($key eq 'description') { push @{$descRef}, ["description" , $thing->value]; } elsif ($key eq 'comment') { push @{$descRef}, ["comment" , $thing->text]; } elsif ($key eq 'dblink') { # DBLinks get dumped to attributes, too push @{$descRef}, ["db_xref" , $thing->database . ":" . $thing->primary_id ]; if (my $com = $thing->comment) { push @{$descRef}, ["link" , $com->text ]; } } elsif ($key eq 'reference') { $self->_parse_reference( @_, -refobj => $thing ); } elsif (ref($thing) =~ /SimpleValue/) { push @{$descRef}, [$key , $thing->value]; } else { # What is this?? push @{$descRef}, ["error", "bsml.pm did not understand ". "'$key' = '$thing'" ]; } } } } =head2 _parse_annotation_old Title : _parse_annotation_old Usage : $obj->_parse_annotation_old(@args) Function: As above, but for the old Annotation system. Apparently needed because Features are still using the old-style annotations? Returns : Args : Argument array. Recognized keys: -xml The DOM::Document being modified -obj Reference to the Bio object being analyzed -descr An array reference for holding description text items -refs An array reference to hold <Reference> DOM objects -id Optional. If the XML id for the 'calling' element is provided, it will be placed in any <Reference> refs attribute. =cut ############### # <Reference> # ############### sub _parse_annotation_old { my $self = shift; my $args = $self->_parseparams( @_); my ($xml, $obj, $descRef, $refRef) = ( $args->{XML}, $args->{OBJ}, $args->{DESC}, $args->{REFS} ); # No good place to put any of this (except for references). Most stuff # just gets dumped to <Attribute>s if (my $ann = $obj->annotation) { push @{$descRef}, ["annotation", $ann->description]; for my $com ($ann->each_Comment) { push @{$descRef}, ["comment" , $com->text]; } # Gene names just get dumped to <Attribute name="gene"> for my $gene ($ann->each_gene_name) { push @{$descRef}, ["gene" , $gene]; } # DBLinks get dumped to attributes, too for my $link ($ann->each_DBLink) { push @{$descRef}, ["db_xref" , $link->database . ":" . $link->primary_id ]; if (my $com = $link->comment) { push @{$descRef}, ["link" , $com->text ]; } } # References get produced and temporarily held for my $ref ($ann->each_Reference) { $self->_parse_reference( @_, -refobj => $ref ); } } } =head2 _add_page Title : _add_page Usage : $obj->_add_page($xmlDocument, $xmlSequenceObject) Function: Adds a simple <Page> and <View> structure for a <Sequence> Returns : a reference to the newly created <Page> Args : 0 The DOM::Document being modified 1 Reference to the <Sequence> object =cut sub _add_page { my $self = shift; my ($xml, $seq) = @_; my $disp = $xml->getElementsByTagName("Display")->item(0); my $page = $self->_addel($disp, "Page"); my ($width, $height) = ( 7.8, 5.5); my $screen = $self->_addel($page, "Screen", { width => $width, height => $height, }); # $screen->appendChild($xml->createComment("Must close explicitly")); my $view = $self->_addel($page, "View", { seqref => $seq->getAttribute('id'), title => $seq->getAttribute('title'), title1 => "{NAME}", title2 => "{LENGTH} {UNIT}", }); $self->_addel($view, "View-line-widget", { shape => 'horizontal', hcenter => $width/2 + 0.7, 'linear-length' => $width - 2, }); $self->_addel($view, "View-axis-widget"); return $page; } =head2 _addel Title : _addel Usage : $obj->_addel($parentElem, 'ChildName', { anAttr => 'someValue', anotherAttr => 'aValue',}) Function: Add an element with attribute values to a DOM tree Returns : a reference to the newly added element Args : 0 The DOM::Element parent that you want to add to 1 The name of the new child element 2 Optional hash reference containing attribute name => attribute value assignments =cut sub _addel { my $self = shift; my ($root, $name, $attr) = @_; # Find the DOM::Document for the parent my $doc = $root->getOwnerDocument || $root; my $elem = $doc->createElement($name); for my $a (keys %{$attr}) { $elem->setAttribute($a, $attr->{$a}); } $root->appendChild($elem); return $elem; } =head2 _show_dna Title : _show_dna Usage : $obj->_show_dna($newval) Function: (cut-and-pasted directly from embl.pm) Returns : value of _show_dna Args : newvalue (optional) =cut sub _show_dna { my $obj = shift; if( @_ ) { my $value = shift; $obj->{'_show_dna'} = $value; } return $obj->{'_show_dna'}; } =head2 _initialize Title : _initialize Usage : $dom = $obj->_initialize(@args) Function: Coppied from embl.pm, and augmented with initialization of the XML DOM tree Returns : Args : -file => the XML file to be parsed =cut sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. $self->{'_func_ftunit_hash'} = {}; $self->_show_dna(1); # sets this to one by default. People can change it my %param = @args; # From SeqIO.pm @param{ map { lc $_ } keys %param } = values %param; # lowercase keys if ( exists $param{-file} && $param{-file} !~ /^>/) { # Is it blasphemy to add your own keys to an object in another package? # domtree => the parsed DOM tree retruned by XML::DOM $self->{'domtree'} = $self->_parse_xml( $param{-file} ); # current_node => the <Sequence> node next in line for next_seq $self->{'current_node'} = 0; } $self->sequence_factory( Bio::Seq::SeqFactory->new ( -verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')) if( ! defined $self->sequence_factory ); } =head2 _parseparams Title : _parseparams Usage : my $paramHash = $obj->_parseparams(@args) Function: Borrowed from Bio::Parse.pm, who borrowed it from CGI.pm Lincoln Stein -> Richard Resnick -> here Returns : A hash reference of the parameter keys (uppercase) pointing to their values. Args : An array of key, value pairs. Easiest to pass values as: -key1 => value1, -key2 => value2, etc Leading "-" are removed. =cut sub _parseparams { my $self = shift; my %hash = (); my @param = @_; # Hacked out from Parse.pm # The next few lines strip out the '-' characters which # preceed the keys, and capitalizes them. for (my $i=0;$i<@param;$i+=2) { $param[$i]=~s/^\-//; $param[$i]=~tr/a-z/A-Z/; } pop @param if @param %2; # not an even multiple %hash = @param; return \%hash; } =head2 _parse_xml Title : _parse_xml Usage : $dom = $obj->_parse_xml($filename) Function: uses XML::DOM to construct a DOM tree from the BSML document Returns : a reference to the parsed DOM tree Args : 0 Path to the XML file needing to be parsed =cut sub _parse_xml { my $self = shift; my $file = shift; unless (-e $file) { $self->throw("Could not parse non-existant XML file '$file'."); return; } my $parser = XML::DOM::Parser->new(); my $doc = $parser->parsefile ($file); return $doc; } sub DESTROY { my $self = shift; # Reports off the net imply that DOM::Parser will memory leak if you # do not explicitly dispose of it: # http://aspn.activestate.com/ASPN/Mail/Message/perl-xml/788458 my $dom = $self->{'domtree'}; # For some reason the domtree can get undef-ed somewhere... $dom->dispose if ($dom); } =head1 TESTING SCRIPT The following script may be used to test the conversion process. You will need a file of the format you wish to test. The script will convert the file to BSML, store it in /tmp/bsmltemp, read that file into a new SeqIO stream, and write it back as the original format. Comparison of this second file to the original input file will allow you to track where data may be lost or corrupted. Note that you will need to specify $readfile and $readformat. use Bio::SeqIO; # Tests preservation of details during round-trip conversion: # $readformat -> BSML -> $readformat my $tempspot = "/tmp/bsmltemp"; # temp folder to hold generated files my $readfile = "rps4y.embl"; # The name of the file you want to test my $readformat = "embl"; # The format of the file being tested system "mkdir $tempspot" unless (-d $tempspot); # Make Seq object from the $readfile my $biostream = Bio::SeqIO->new( -file => "$readfile" ); my $seq = $biostream->next_seq(); # Write BSML from SeqObject my $bsmlout = Bio::SeqIO->new( -format => 'bsml', -file => ">$tempspot/out.bsml"); warn "\nBSML written to $tempspot/out.bsml\n"; $bsmlout->write_seq($seq); # Need to kill object for following code to work... Why is this so? $bsmlout = ""; # Make Seq object from BSML my $bsmlin = Bio::SeqIO->new( -file => "$tempspot/out.bsml", -format => 'bsml'); my $seq2 = $bsmlin->next_seq(); # Write format back from Seq Object my $genout = Bio::SeqIO->new( -format => $readformat, -file => ">$tempspot/out.$readformat"); $genout->write_seq($seq2); warn "$readformat written to $tempspot/out.$readformat\n"; # BEING LOST: # Join information (not possible in BSML 2.2) # Sequence type (??) =cut 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/bsml_sax.pm���������������������������������������������������������������000444��000765��000024�� 17625�12254227332� 17330� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::bsml_sax # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich # =head1 NAME Bio::SeqIO::bsml_sax - BSML sequence input/output stream using SAX =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system. To read a BSML file: $stream = Bio::SeqIO->new( -file => $filename, -format => 'bsml'); while ( my $bioSeqObj = $stream->next_seq() ) { # do something with $bioSeqObj } To write a Seq object to the current file handle in BSML XML format: $stream->write_seq( -seq => $seqObj); If instead you would like a XML::DOM object containing the BSML, use: my $newXmlObject = $stream->to_bsml( -seq => $seqObj); =head1 DEPENDENCIES In addition to parts of the Bio:: hierarchy, this module uses: XML::SAX =head1 DESCRIPTION This object can transform Bio::Seq objects to and from BSML (XML) flatfiles. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =cut package Bio::SeqIO::bsml_sax; use vars qw($Default_Source); use strict; use Bio::SeqFeature::Generic; use Bio::Species; use XML::SAX; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO XML::SAX::Base); $Default_Source = 'BSML'; sub _initialize { my ($self) = shift; $self->SUPER::_initialize(@_); $self->{'_parser'} = XML::SAX::ParserFactory->parser('Handler' => $self); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } return; } =head1 METHODS =cut =head2 next_seq Title : next_seq Usage : my $bioSeqObj = $stream->next_seq Function: Retrieves the next sequence from a SeqIO::bsml stream. Returns : A reference to a Bio::Seq::RichSeq object Args : =cut sub next_seq { my $self = shift; if( @{$self->{'_seendata'}->{'_seqs'} || []} || eof($self->_fh)) { return shift @{$self->{'_seendata'}->{'_seqs'}}; } $self->{'_parser'}->parse_file($self->_fh); return shift @{$self->{'_seendata'}->{'_seqs'}}; } # XML::SAX::Base methods sub start_document { my ($self,$doc) = @_; $self->{'_seendata'} = {'_seqs' => [], '_authors' => [], '_feats' => [] }; $self->SUPER::start_document($doc); } sub end_document { my ($self,$doc) = @_; $self->SUPER::end_document($doc); } sub start_element { my ($self,$ele) = @_; my $name = uc($ele->{'LocalName'}); my $attr = $ele->{'Attributes'}; my $seqid = defined $self->{'_seendata'}->{'_seqs'}->[-1] ? $self->{'_seendata'}->{'_seqs'}->[-1]->display_id : undef; for my $k ( keys %$attr ) { $attr->{uc $k} = $attr->{$k}; delete $attr->{$k}; } if( $name eq 'BSML' ) { } elsif( $name eq 'DEFINITIONS' ) { } elsif( $name eq 'SEQUENCES' ) { } elsif( $name eq 'SEQUENCE' ) { my ($id,$acc,$title, $desc,$length,$topology, $mol) = map { $attr->{'{}'.$_}->{'Value'} } qw(ID IC-ACCKEY TITLE COMMENT LENGTH TOPOLOGY MOLECULE); push @{$self->{'_seendata'}->{'_seqs'}}, $self->sequence_factory->create ( -display_id => $id, -accession_number => $acc, -description => $desc, -length => $length, -is_circular => ($topology =~ /^linear$/i) ? 0 : 1, -molecule => $mol, ); } elsif( $name eq 'FEATURE-TABLES' ) { } elsif( $name eq 'ATTRIBUTE' ) { my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; my ($name,$content) = map { $attr->{'{}'.$_}->{'Value'} } qw(NAME CONTENT); if($name =~ /^version$/i ) { my ($version); if($content =~ /^[^\.]+\.(\d+)/) { $version = $1; } else { $version = $content } $curseq->seq_version($version); } elsif( $name eq 'organism-species') { my ($genus,$species,$subsp) = split(/\s+/,$content,3); $curseq->species(Bio::Species->new(-sub_species => $subsp, -classification => [$species,$genus])); } elsif( $name eq 'organism-classification' ) { my (@class) =(split(/\s*;\s*/,$content),$curseq->species->species); $curseq->species->classification([reverse @class]); } elsif( $name eq 'database-xref' ) { my ($db,$id) = split(/:/,$content); $curseq->annotation->add_Annotation('dblink', Bio::Annotation::DBLink->new ( -database => $db, -primary_id=> $id)); } elsif( $name eq 'date-created' || $name eq 'date-last-updated' ) { $curseq->add_date($content); } } elsif( $name eq 'FEATURE' ) { my ($id,$class,$type,$title,$display_auto) = map { $attr->{'{}'.$_}->{'Value'} } qw(ID CLASS VALUE-TYPE TITLE DISPLAY-AUTO); push @{$self->{'_seendata'}->{'_feats'}}, Bio::SeqFeature::Generic->new ( -seq_id => $self->{'_seendata'}->{'_seqs'}->[-1]->display_id, -source_tag => $Default_Source, -primary_tag => $type, -tag => {'ID' => $id, }); } elsif( $name eq 'QUALIFIER') { my ($type,$value) = map { $attr->{'{}'.$_}->{'Value'} } qw(VALUE-TYPE VALUE); my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; $curfeat->add_tag_value($type,$value); } elsif( $name eq 'INTERVAL-LOC' ) { my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; my ($start,$end,$strand) = map { $attr->{'{}'.$_}->{'Value'} } qw(STARTPOS ENDPOS COMPLEMENT); $curfeat->start($start); $curfeat->end($end); $curfeat->strand(-1) if($strand); } elsif( $name eq 'REFERENCE' ) { push @{$self->{'_seendata'}->{'_annot'}}, Bio::Annotation::Reference->new(); } push @{$self->{'_state'}}, $name; $self->SUPER::start_element($ele); } sub end_element { my ($self,$ele) = @_; pop @{$self->{'_state'}}; my $name = uc $ele->{'LocalName'}; my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; if( $name eq 'REFERENCE') { my $ref = pop @{$self->{'_seendata'}->{'_annot'}}; $curseq->annotation->add_Annotation('reference',$ref); } elsif( $name eq 'FEATURE' ) { my $feat = pop @{$self->{'_seendata'}->{'_feats'}}; $curseq->add_SeqFeature($feat); } $self->SUPER::end_element($ele); } sub characters { my ($self,$data) = @_; if( ! @{$self->{'_state'}} ) { $self->warn("Calling characters with no previous start_element call. Ignoring data"); } else { my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; my $curannot = $self->{'_seendata'}->{'_annot'}->[-1]; my $name = $self->{'_state'}->[-1]; if( $name eq 'REFAUTHORS' ) { $curannot->authors($data->{'Data'}); } elsif( $name eq 'REFTITLE') { $curannot->title($data->{'Data'}); } elsif( $name eq 'REFJOURNAL') { $curannot->location($data->{'Data'}); } elsif( $name eq 'SEQ-DATA') { $data->{'Data'} =~ s/\s+//g; $curseq->seq($data->{'Data'}); } } $self->SUPER::characters($data); } 1; �����������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/chadoxml.pm���������������������������������������������������������������000444��000765��000024�� 203347�12254227322� 17334� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::chadoxml # # Peili Zhang <peili@morgan.harvard.edu> # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::chadoxml - chadoxml sequence output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system: $writer = Bio::SeqIO->new(-file => ">chado.xml", -format => 'chadoxml'); # assume you already have Sequence or SeqFeature objects $writer->write_seq($seq_obj); #after writing all seqs $writer->close_chadoxml(); =head1 DESCRIPTION This object can transform Bio::Seq objects to chadoxml flat file databases (for chadoxml DTD, see http://gmod.cvs.sourceforge.net/gmod/schema/chado/dat/chado.dtd). This is currently a write-only module. $seqio = Bio::SeqIO->new(-file => '>outfile.xml', -format => 'chadoxml' -suppress_residues => 1, -allow_residues => 'chromosome', ); # we have a Bio::Seq object $seq which is a gene located on # chromosome arm 'X', to be written out to chadoxml # before converting to chadoxml, $seq object B<must> be transformed # so that all the coordinates in $seq are against the source # feature to be passed into Bio::SeqIO::chadoxml->write_seq() # -- chromosome arm X in the example below. $seqio->write_seq(-seq=>$seq, -genus => 'Homo', -species => 'sapiens', -seq_so_type=>'gene', -src_feature=>'X', -src_feat_type=>'chromosome_arm', -nounflatten=>1, -is_analysis=>'true', -data_source=>'GenBank'); The chadoxml output of Bio::SeqIO::chadoxml-E<gt>write_seq() method can be passed to the loader utility in XORT package (http://gmod.cvs.sourceforge.net/gmod/schema/XMLTools/XORT/) to be loaded into chado. This object is currently implemented to work with sequence and annotation data from whole genome projects deposited in GenBank. It may not be able to handle all different types of data from all different sources. In converting a Bio::Seq object into chadoxml, a top-level feature is created to represent the object and all sequence features inside the Bio::Seq object are treated as subfeatures of the top-level feature. The Bio::SeqIO::chadoxml object calls Bio::SeqFeature::Tools::Unflattener to unflatten the flat feature list contained in the subject Bio::Seq object, to build gene model containment hierarchy conforming to chado central dogma model: gene --E<gt> mRNA --E<gt> exons and protein. Destination of data in the subject Bio::Seq object $seq is as following: *$seq->display_id: name of the top-level feature; *$seq->accession_number: if defined, uniquename and feature_dbxref of the top-level feature if not defined, $seq->display_id is used as the uniquename of the top-level feature; *$seq->molecule: transformed to SO type, used as the feature type of the top-level feature if -seq_so_type argument is supplied, use the supplied SO type as the feature type of the top-level feature; *$seq->species: organism of the top-level feature; *$seq->seq: residues of the top-level feature; *$seq->is_circular, $seq->division: feature_cvterm; *$seq->keywords, $seq->desc, comments: featureprop; *references: pub and feature_pub; medline/pubmed ids: pub_dbxref; comments: pubprop; *feature "source" span: featureloc for top-level feature; *feature "source" db_xref: feature_dbxref for top-level feature; *feature "source" other tags: featureprop for top-level feature; *subfeature 'symbol' or 'label' tag: feature uniquename, if none of these is present, the chadoxml object generates feature uniquenames as: <gene>-<feature_type>-<span> (e.g. foo-mRNA--1000..3000); *gene model: feature_relationship built based on the containment hierarchy; *feature span: featureloc; *feature accession numbers: feature_dbxref; *feature tags (except db_xref, symbol and gene): featureprop; Things to watch out for: *chado schema change: this version works with the chado version tagged chado_1_01 in GMOD CVS. *feature uniquenames: especially important if using XORT loader to do incremental load into chado. may need pre-processing of the source data to put the correct uniquenames in place. *pub uniquenames: chadoxml->write_seq() has the FlyBase policy on pub uniquenames hard-coded, it assigns pub uniquenames in the following way: for journals and books, use ISBN number; for published papers, use MEDLINE ID; for everything else, use FlyBase unique identifier FBrf#. need to modify the code to implement your policy. look for the comments in the code. *for pubs possibly existing in chado but with no knowledge of its uniquename:put "op" as "match", then need to run the output chadoxml through a special filter that talks to chado database and tries to find the pub by matching with the provided information instead of looking up by the unique key. after matching, the filter also resets the "match" operation to either "force" (default), or "lookup", or "insert", or "update". the "match" operation is for a special FlyBase use case. please modify to work according to your rules. *chado initialization for loading: cv & cvterm: in the output chadoxml, all cv's and cvterm's are lookup only. Therefore, before using XORT loader to load the output into chado, chado must be pre-loaded with all necessary CVs and CVterms, including "SO" , "property type", "relationship type", "pub type", "pubprop type", "pub relationship type", "sequence topology", "GenBank feature qualifier", "GenBank division". A pub by the uniquename 'nullpub' of type 'null pub' needs to be inserted. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peili Zhang Email peili@morgan.harvard.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::chadoxml; use strict; use English; use Carp; use Data::Dumper; use XML::Writer; use IO::File; use IO::Handle; use Bio::Seq; use Bio::Seq::RichSeq; use Bio::SeqIO::FTHelper; use Bio::Species; use Bio::Seq::SeqFactory; use Bio::Factory::SequenceStreamI; use Bio::SeqFeature::Generic; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use Bio::SeqFeature::Tools::Unflattener; #global variables undef(my %finaldatahash); #data from Bio::Seq object stored in a hash undef(my %datahash); #data from Bio::Seq object stored in a hash my $chadotables = 'feature featureprop feature_relationship featureloc feature_cvterm cvterm cv feature_pub pub pub_dbxref pub_author author pub_relationship pubprop feature_dbxref dbxref db synonym feature_synonym'; my %fkey = ( "cvterm.cv_id" => "cv", "cvterm.dbxref_id" => "dbxref", "dbxref.db_id" => "db", "feature.type_id" => "cvterm", "feature.organism_id" => "organism", "feature.dbxref_id" => "dbxref", "featureprop.type_id" => "cvterm", "feature_pub.pub_id" => "pub", "feature_cvterm.cvterm_id" => "cvterm", "feature_cvterm.pub_id" => "pub", "feature_cvterm.feature_id" => "feature", "feature_dbxref.dbxref_id" => "dbxref", "feature_relationship.object_id" => "feature", "feature_relationship.subject_id" => "feature", "feature_relationship.type_id" => "cvterm", "featureloc.srcfeature_id" => "feature", "pub.type_id" => "cvterm", "pub_dbxref.dbxref_id" => "dbxref", "pub_author.author_id" => "author", "pub_relationship.obj_pub_id" => "pub", "pub_relationship.subj_pub_id" => "pub", "pub_relationship.type_id" => "cvterm", "pubprop.type_id" => "cvterm", "feature_synonym.feature_id" => "feature", "feature_synonym.synonym_id" => "synonym", "feature_synonym.pub_id" => "pub", "synonym.type_id" => "cvterm", ); my %cv_name = ( 'relationship' => 'relationship', 'sequence' => 'sequence', 'feature_property' => 'feature_property', ); my %feattype_args2so = ( "aberr" => "aberration_junction", # "conflict" => "sequence_difference", # "polyA_signal" => "polyA_signal_sequence", "variation" => "sequence_variant", "mutation1" => "point_mutation", #for single-base mutation "mutation2" => "sequence_variant", #for multi-base mutation "rescue" => "rescue_fragment", # "rfrag" => "restriction_fragment", "protein_bind" => "protein_binding_site", "misc_feature" => "region", # "prim_transcript" => "primary_transcript", "CDS" => "polypeptide", "reg_element" => "regulatory_region", "seq_variant" => "sequence_variant", "mat_peptide" => "mature_peptide", "sig_peptide" => "signal_peptide", ); undef(my %organism); use base qw(Bio::SeqIO); sub _initialize { my($self,%args) = @_; $self->SUPER::_initialize(%args); unless( defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } #optional arguments that can be passed in $self->suppress_residues($args{'-suppress_residues'}) if defined $args{'-suppress_residues'}; $self->allow_residues($args{'-allow_residues'}) if defined $args{'-allow_residues'}; return; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(-seq=>$seq, -seq_so_type=>$seqSOtype, -src_feature=>$srcfeature, -src_feat_type=>$srcfeattype, -nounflatten=>0 or 1, -is_analysis=>'true' or 'false', -data_source=>$datasource) Function: writes the $seq object (must be seq) into chadoxml. Returns : 1 for success and 0 for error Args : A Bio::Seq object $seq, optional $seqSOtype, $srcfeature, $srcfeattype, $nounflatten, $is_analysis and $data_source. When $srcfeature (a string, the uniquename of the source feature) is given, the location and strand information of the top-level feature against the source feature will be derived from the sequence feature called 'source' of the $seq object, a featureloc record is generated for the top -level feature on $srcfeature. when $srcfeature is given, $srcfeattype must also be present. All feature coordinates in $seq should be against $srcfeature. $seqSOtype is the optional SO term to use as the type of the top-level feature. For example, a GenBank data file for a Drosophila melanogaster genome scaffold has the molecule type of "DNA", when converting to chadoxml, a $seqSOtype argument of "golden_path_region" can be supplied to save the scaffold as a feature of type "golden_path_region" in chadoxml, instead of "DNA". a feature with primary tag of 'source' must be present in the sequence feature list of $seq, to decribe the whole sequence record. In the current implementation: =over 3 =item * non-mRNA records A top-level feature of type $seq-E<gt>alphabet is generated for the whole GenBank record, features listed are unflattened for DNA records to build gene model feature graph, and for the other types of records all features in $seq are treated as subfeatures of the top-level feature. =item * mRNA records If a 'gene' feature is present, it B<must> have a /symbol or /label tag to contain the uniquename of the gene. a top-level feature of type 'gene' is generated. the mRNA is written as a subfeature of the top-level gene feature, and the other sequence features listed in $seq are treated as subfeatures of the mRNA feature. =back =cut sub write_seq { my $usage = <<EOUSAGE; Bio::SeqIO::chadoxml->write_seq() Usage : \$stream->write_seq(-seq=>\$seq, -seq_so_type=>\$SOtype, -src_feature=>\$srcfeature, -src_feat_type=>\$srcfeattype, -nounflatten=>0 or 1, -is_analysis=>'true' or 'false', -data_source=>\$datasource) Args : \$seq : a Bio::Seq object \$SOtype : the SO term to use as the feature type of the \$seq record, optional \$srcfeature : unique name of the source feature, a string containing at least one alphabetical letter (a-z, A-Z), optional \$srcfeattype : feature type of \$srcfeature. one of SO terms. optional when \$srcfeature is given, \$srcfeattype becomes mandatory, \$datasource : source of the sequence annotation data, e.g. 'GenBank' or 'GFF'. EOUSAGE my ($self,@args) = @_; my ($seq, $seq_so_type, $srcfeature, $srcfeattype, $nounflatten, $isanalysis, $datasource, $genus, $species) = $self->_rearrange([qw(SEQ SEQ_SO_TYPE SRC_FEATURE SRC_FEAT_TYPE NOUNFLATTEN IS_ANALYSIS DATA_SOURCE GENUS SPECIES )], @args); #print "$seq_so_type, $srcfeature, $srcfeattype\n"; if( !defined $seq ) { $self->throw("Attempting to write with no seq!"); } if( ! ref $seq || ! $seq->isa('Bio::Seq::RichSeqI') ) { ## FIXME $self->warn(" $seq is not a RichSeqI compliant module. Attempting to dump, but may fail!"); } # try to get the srcfeature from the seqFeature object # for this to work, the user has to pass in the srcfeature type if (!$srcfeature) { if ($seq->can('seq_id')) { $srcfeature=$seq->seq_id if ($seq->seq_id ne $seq->display_name); } } #$srcfeature, when provided, should contain at least one alphabetical letter if (defined $srcfeature) { if ($srcfeature =~ /[a-zA-Z]/) { chomp($srcfeature); } else { $self->throw( $usage ); } #check for mandatory $srcfeattype if (! defined $srcfeattype) { $self->throw( $usage ); #$srcfeattype must be a string of non-whitespace characters } else { if ($srcfeattype =~ /\S+/) { chomp($srcfeattype); } else { $self->throw( $usage ); } } } # variables local to write_seq() my $div = undef; my $hkey = undef; undef(my @top_featureprops); undef(my @featuresyns); undef(my @top_featurecvterms); my $name = $seq->display_id if $seq->can('display_id'); $name = $seq->display_name if $seq->can('display_name'); undef(my @feature_cvterms); undef(my %sthash); undef(my %dvhash); undef(my %h1); undef(my %h2); my $temp = undef; my $ann = undef; undef(my @references); undef(my @feature_pubs); my $ref = undef; my $location = undef; my $fbrf = undef; my $journal = undef; my $issue = undef; my $volume = undef; my $volumeissue = undef; my $pages = undef; my $year = undef; my $pubtype = undef; # my $miniref= undef; my $uniquename = undef; my $refhash = undef; my $feat = undef; my $tag = undef; my $tag_cv = undef; my $ftype = undef; my $subfeatcnt = undef; undef(my @top_featrels); undef (my %srcfhash); local($^W) = 0; # supressing warnings about uninitialized fields. if (!$name && $seq->can('attributes') ) { ($name) = $seq->attributes('Alias'); } if ($seq->can('accession_number') && defined $seq->accession_number && $seq->accession_number ne 'unknown') { $uniquename = $seq->accession_number; } elsif ($seq->can('accession') && defined $seq->accession && $seq->accession ne 'unknown') { $uniquename = $seq->accession; } elsif ($seq->can('attributes')) { ($uniquename) = $seq->attributes('load_id'); } else { $uniquename = $name; } my $len = $seq->length(); if ($len == 0) { $len = undef; } undef(my $gb_type); if (!$seq->can('molecule') || ! defined ($gb_type = $seq->molecule()) ) { $gb_type = $seq->can('alphabet') ? $seq->alphabet : 'DNA'; } $gb_type = 'DNA' if $ftype eq 'dna'; $gb_type = 'RNA' if $ftype eq 'rna'; if(length $seq_so_type > 0) { if (defined $seq_so_type) { $ftype = $seq_so_type; } elsif ($seq->type) { $ftype = ($seq->type =~ /(.*):/) ? $1 : $seq->type; } else { $ftype = $gb_type; } } else { $ftype = $gb_type; } my %ftype_hash = $self->return_ftype_hash($ftype); if ($species) { %organism = ("genus"=>$genus, "species" => $species); } else { my $spec = $seq->species(); if (!defined $spec) { $self->throw("$seq does not know what organism it is from, which is required by chado. cannot proceed!\n"); } else { %organism = ("genus"=>$spec->genus(), "species" => $spec->species()); } } my $residues; if (!$self->suppress_residues || ($self->suppress_residues && $self->allow_residues eq $ftype)) { $residues = $seq->seq->isa('Bio::PrimarySeq') ? $seq->seq->seq : $seq->seq; } else { $residues = ''; } #set is_analysis flag for gene model features undef(my $isanal); if ($ftype eq 'gene' || $ftype eq 'mRNA' || $ftype eq 'exon' || $ftype eq 'protein' || $ftype eq 'polypeptide') { $isanal = $isanalysis; $isanal = 'false' if !defined $isanal; } %datahash = ( "name" => $name, "uniquename" => $uniquename, "seqlen" => $len, "residues" => $residues, "type_id" => \%ftype_hash, "organism_id" => \%organism, "is_analysis" => $isanal || 'false', ); if (defined $srcfeature) { %srcfhash = $self->_srcf_hash($srcfeature, $srcfeattype, \%organism); my ($phase,$strand); if ($seq->can('phase')) { $phase = $seq->phase; } if ($seq->can('strand')) { $strand = $seq->strand; } my %fl = ( "srcfeature_id" => \%srcfhash, "fmin" => $seq->start - 1, "fmax" => $seq->end, "strand" => $strand, "phase" => $phase, ); $datahash{'featureloc'} = \%fl; } #if $srcfeature is not given, use the Bio::Seq object itself as the srcfeature for featureloc's if (!defined $srcfeature) { $srcfeature = $uniquename; $srcfeattype = $ftype; } #default data source is 'GenBank' if (!defined $datasource) { $datasource = 'GenBank'; } if ($datasource =~ /GenBank/i) { #sequence topology as feature_cvterm if ($seq->can('is_circular') && $seq->is_circular) { %sthash = ( "cvterm_id" => {'name' => 'circular', 'cv_id' => { 'name' => 'sequence topology', }, }, "pub_id" => {'uniquename' => 'nullpub', 'type_id' => { 'name' => 'null pub', 'cv_id' => { 'name'=> 'pub type', }, }, }, ); } else { %sthash = ( "cvterm_id" => { 'name' => 'linear', 'cv_id' => { 'name' => 'sequence topology', } }, "pub_id" => {'uniquename' => 'nullpub', 'type_id' => { 'name' => 'null pub', 'cv_id' => { 'name'=> 'pub type', }, }, }, ); } push(@feature_cvterms, \%sthash); #division as feature_cvterm if ($seq->can('division') && defined $seq->division()) { $div = $seq->division(); %dvhash = ( "cvterm_id" => {'name' => $div, 'cv_id' => { 'name' => 'GenBank division'}}, "pub_id" => {'uniquename' => 'nullpub', 'type_id' => { 'name' => 'null pub', 'cv_id' => { 'name'=> 'pub type'}, }}, ); push(@feature_cvterms, \%dvhash); } $datahash{'feature_cvterm'} = \@feature_cvterms; } # closes if GenBank #featureprop's #DEFINITION if ($seq->can('desc') && defined $seq->desc()) { $temp = $seq->desc(); my %prophash = ( "type_id" => {'name' => 'description', 'cv_id' => { 'name' => $cv_name{'feature_property'} }, }, "value" => $temp, ); push(@top_featureprops, \%prophash); } #KEYWORDS if ($seq->can('keywords')) { $temp = $seq->keywords(); if (defined $temp && $temp ne '.' && $temp ne '') { my %prophash = ( "type_id" => {'name' => 'keywords', 'cv_id' => { 'name' => $cv_name{'feature_property'} } }, "value" => $temp, ); push(@top_featureprops, \%prophash); } } #COMMENT if ($seq->can('annotation')) { $ann = $seq->annotation(); foreach my $comment ($ann->get_Annotations('comment')) { $temp = $comment->as_text(); #print "fcomment: $temp\n"; my %prophash = ( "type_id" => {'name' => 'comment', 'cv_id' => { 'name' => $cv_name{'feature_property'} } }, "value" => $temp, ); push(@top_featureprops, \%prophash); } } my @top_dbxrefs = (); #feature object from Bio::DB::SeqFeature::Store if ($seq->can('attributes')) { my %attributes = $seq->attributes; for my $key (keys %attributes) { next if ($key eq 'parent_id'); next if ($key eq 'load_id'); if ($key eq 'Alias') { @featuresyns = $self->handle_Alias_tag($seq,@featuresyns); } ###FIXME deal with Dbxref, Ontology_term,source, elsif ($key eq 'Ontology_term') { @top_featurecvterms = $self->handle_Ontology_tag($seq,@top_featurecvterms); } elsif ($key eq 'dbxref' or $key eq 'Dbxref') { @top_dbxrefs = $self->handle_dbxref($seq, $key, @top_dbxrefs); } elsif ($key =~ /^[a-z]/) { @top_featureprops = $self->handle_unreserved_tags($seq,$key,@top_featureprops); } } } $datahash{'feature_synonym'} = \@featuresyns; if ($seq->can('source')) { @top_dbxrefs = $self->handle_source($seq,@top_dbxrefs); } #accession and version as feature_dbxref if ($seq->can('accession_number') && defined $seq->accession_number && $seq->accession_number ne 'unknown') { my $db = $self->_guess_acc_db($seq, $seq->accession_number); my %acchash = ( "db_id" => {'name' => $db}, "accession" => $seq->accession_number, "version" => $seq->seq_version, ); my %fdbx = ('dbxref_id' => \%acchash); push(@top_dbxrefs, \%fdbx); } if( $seq->isa('Bio::Seq::RichSeqI') && defined $seq->get_secondary_accessions() ) { my @secacc = $seq->get_secondary_accessions(); my $acc; foreach $acc (@secacc) { my %acchash = ( "db_id" => {'name' => 'GB'}, "accession" => $acc, ); my %fdbx = ('dbxref_id' => \%acchash); push(@top_dbxrefs, \%fdbx); } } #GI number if( $seq->isa('Bio::Seq::RichSeqI') && defined ($seq->pid)) { my $id = $seq->pid; #print "reftype: ", ref($id), "\n"; #if (ref($id) eq 'HASH') { my %acchash = ( "db_id" => {'name' => 'GI'}, "accession" => $id, ); my %fdbx = ('dbxref_id' => \%acchash); push (@top_dbxrefs, \%fdbx); } #REFERENCES as feature_pub if (defined $ann) { #get the references @references = $ann->get_Annotations('reference'); foreach $ref (@references) { undef(my %pubhash); $refhash = $ref->hash_tree(); $location = $ref->location || $refhash->{'location'}; #print "location: $location\n"; #get FBrf#, special for FlyBase SEAN loading if (index($location, ' ==') >= 0) { $location =~ /\s==/; #print "match: $MATCH\n"; #print "prematch: $PREMATCH\n"; #print "postmatch: $POSTMATCH\n"; $fbrf = $PREMATCH; $location = $POSTMATCH; $location =~ s/^\s//; } #print "location: $location\n"; #unpublished reference if ($location =~ /Unpublished/) { $pubtype = 'unpublished'; %pubhash = ( "title" => $ref->title || $refhash->{'title'}, #"miniref" => substr($location, 0, 255), #"uniquename" => $fbrf, "type_id" => {'name' => $pubtype, 'cv_id' => {'name' =>'pub type'}} ); } #submitted elsif ($location =~ /Submitted/) { $pubtype = 'submitted'; %pubhash = ( "title" => $ref->title || $refhash->{'title'}, #"miniref" => substr($location, 0, 255), #"uniquename" => $fbrf, "type_id" => {'name' => $pubtype, 'cv_id' => {'name' =>'pub type'}} ); undef(my $pyear); $pyear = $self->_getSubmitYear($location); if (defined $pyear) { $pubhash{'pyear'} = $pyear; } } #published journal paper elsif ($location =~ /\D+\s\d+\s\((\d+|\d+-\d+)\),\s(\d+-\d+|\d+--\d+)\s\(\d\d\d\d\)$/) { $pubtype = 'paper'; #parse location to get journal, volume, issue, pages & year $location =~ /\(\d\d\d\d\)$/; $year = $MATCH; my $stuff = $PREMATCH; $year =~ s/\(//; #remove the leading parenthesis $year =~ s/\)//; #remove the trailing parenthesis $stuff =~ /,\s(\d+-\d+|\d+--\d+)\s$/; $pages = $MATCH; $stuff = $PREMATCH; $pages =~ s/^, //; #remove the leading comma and space $pages =~ s/ $//; #remove the last space $stuff =~ /\s\d+\s\((\d+|\d+-\d+)\)$/; $volumeissue = $MATCH; $journal = $PREMATCH; $volumeissue =~ s/^ //; #remove the leading space $volumeissue =~ /\((\d+|\d+-\d+)\)$/; $issue = $MATCH; $volume = $PREMATCH; $issue =~ s/^\(//; #remove the leading parentheses $issue =~ s/\)$//; #remove the last parentheses $volume =~ s/^\s//; #remove the leading space $volume =~ s/\s$//; #remove the last space %pubhash = ( "title" => $ref->title || $refhash->{'title'}, "volume" => $volume, "issue" => $issue, "pyear" => $year, "pages" => $pages, #"miniref" => substr($location, 0, 255), #"miniref" => ' ', #"uniquename" => $fbrf, "type_id" => {'name' => $pubtype, 'cv_id' => {'name' =>'pub type'}}, "pub_relationship" => { 'obj_pub_id' => { 'uniquename' => $journal, 'title' => $journal, #'miniref' => substr($journal, 0, 255), 'type_id' =>{'name' => 'journal', 'cv_id' => {'name' => 'pub type' }, }, #'pubprop' =>{'value'=> $journal, # 'type_id'=>{'name' => 'abbreviation', 'cv_id' => {'name' => 'pubprop type'}}, # }, }, 'type_id' => { 'name' => 'published_in', 'cv_id' => { 'name' => 'pub relationship type'}, }, }, ); } #other references else { $pubtype = 'other'; %pubhash = ( "title" => $ref->title || $refhash->{'title'}, #"miniref" => $fbrf, "type_id" => { 'name' => $pubtype, 'cv_id' => {'name' =>'pub type'} } ); } #pub_author my $autref = $self->_getRefAuthors($ref); if (defined $autref) { $pubhash{'pub_author'} = $autref; } # if no author and is type 'submitted' and has submitter address, use the first 100 characters of submitter address as the author lastname. else { if ($pubtype eq 'submitted') { my $autref = $self->_getSubmitAddr($ref); if (defined $autref) { $pubhash{'pub_author'} = $autref; } } } #$ref->comment as pubprop #print "ref comment: ", $ref->comment, "\n"; #print "ref comment: ", $refhash->{'comment'}, "\n"; if (defined $ref->comment || defined $refhash->{'comment'}) { my $comnt = $ref->comment || $refhash->{'comment'}; #print "remark: ", $comnt, "\n"; $pubhash{'pubprop'} = { "type_id" => {'name' => 'comment', 'cv_id' => {'name' => 'pubprop type'}}, "value" => $comnt, }; } #pub_dbxref undef(my @pub_dbxrefs); if (defined $fbrf) { push(@pub_dbxrefs, {dbxref_id => {accession => $fbrf, db_id => {'name' => 'FlyBase'}}}); } if (defined ($temp = $ref->medline)) { push(@pub_dbxrefs, {dbxref_id => {accession => $temp, db_id => {'name' => 'MEDLINE'}}}); #use medline # as the pub's uniquename $pubhash{'uniquename'} = $temp; } if (defined ($temp = $ref->pubmed)) { push(@pub_dbxrefs, {dbxref_id => {accession => $temp, db_id => {'name' => 'PUBMED'}}}); } $pubhash{'pub_dbxref'} = \@pub_dbxrefs; #if the pub uniquename is not defined or blank, put its FBrf# as its uniquename #this is unique to FlyBase #USERS OF THIS MODULE: PLEASE MODIFY HERE TO IMPLEMENT YOUR POLICY # ON PUB UNIQUENAME!!! if (!defined $pubhash{'uniquename'} || $pubhash{'uniquename'} eq '') { if (defined $fbrf) { $pubhash{'uniquename'} = $fbrf; } #else { # $pubhash{'uniquename'} = $self->_CreatePubUname($ref); #} } #add to collection of references #if the pub covers the entire sequence of the top-level feature, add it to feature_pubs if (($ref->start == 1 && $ref->end == $len) || (!defined $ref->start && !defined $ref->end)) { push(@feature_pubs, {"pub_id" => \%pubhash}); } #the pub is about a sub-sequence of the top-level feature #create a feature for the sub-sequence and add pub as its feature_pub #featureloc of this sub-sequence is against the top-level feature, in interbase coordinates. else { my %parf = ( 'uniquename' => $uniquename . ':' . $ref->start . "\.\." . $ref->end, 'organism_id' =>\%organism, 'type_id' =>{'name' =>'region', 'cv_id' => {'name' => $cv_name{'sequence'} }}, ); my %parfsrcf = ( 'uniquename' => $uniquename, 'organism_id' =>\%organism, ); my %parfloc = ( 'srcfeature_id' => \%parfsrcf, 'fmin' => $ref->start - 1, 'fmax' => $ref->end, ); $parf{'featureloc'} = \%parfloc; $parf{'feature_pub'} = {'pub_id' => \%pubhash}; my %ffr = ( 'subject_id' => \%parf, 'type_id' => { 'name' => 'partof', 'cv_id' => { 'name' => $cv_name{'relationship'}}}, ); push(@top_featrels, \%ffr); } } $datahash{'feature_pub'} = \@feature_pubs; } ##construct srcfeature hash for use in featureloc if (defined $srcfeature) { %srcfhash = $self->_srcf_hash($srcfeature, $srcfeattype, \%organism); # my %fr = ( # "object_id" => \%srcfhash, # "type_id" => { 'name' => 'partof', 'cv_id' => { 'name' => 'relationship type'}}, # ); # push (@top_featrels, \%fr); } #unflatten the seq features in $seq if $seq is a gene or a DNA sequence if (($gb_type eq 'gene' || $gb_type eq 'DNA') && !$nounflatten) { my $u = Bio::SeqFeature::Tools::Unflattener->new; $u->unflatten_seq(-seq=>$seq, -use_magic=>1); } my @top_sfs = $seq->get_SeqFeatures; #print $#top_sfs, "\n"; #SUBFEATURES if ($datasource =~ /GenBank/i) { $tag_cv = 'GenBank feature qualifier'; } elsif ($datasource =~ /GFF/i) { $tag_cv = 'feature_property'; } else { $tag_cv = $cv_name{'feature_property'}; } my $si = 0; foreach $feat (@top_sfs) { #$feat = $top_sfs[$si]; #print "si: $si\n"; my $prim_tag = $feat->primary_tag; #print $prim_tag, "\n"; # get all qualifiers of the 'source' feature, load these as top_featureprops of the top level feature if ($prim_tag eq 'source') { foreach $tag ($feat->all_tags()) { #db_xref if ($tag eq 'db_xref' or $tag eq 'Dbxref' or $tag eq 'dbxref') { my @t1 = $feat->each_tag_value($tag); foreach $temp (@t1) { $temp =~ /([^:]*?):(.*)/; my $db = $1; my $xref = $2; #PRE/POST very inefficent #my $db = $PREMATCH; #my $xref = $POSTMATCH; my %acchash = ( "db_id" => {'name' => $db}, "accession" => $xref, ); my %fdbx = ('dbxref_id' => \%acchash); push (@top_dbxrefs, \%fdbx); } #Ontology_term } elsif ($tag eq 'Ontology_term') { my @t1 = $feat->each_tag_value($tag); foreach $temp (@t1) { ###FIXME } #other tags as featureprop } elsif ($tag ne 'gene') { my %prophash = undef; %prophash = ( "type_id" => {'name' => $tag, 'cv_id' => {'name' => $tag_cv}}, "value" => join(' ',$feat->each_tag_value($tag)), ); push(@top_featureprops, \%prophash); } } if ($feat->can('source')) { my $source = $feat->source(); @top_dbxrefs = $self->handle_source($feat, @top_dbxrefs); } #featureloc for the top-level feature my $fmin = undef; my $fmax = undef; my $strand = undef; my $phase = undef; my %fl = undef; $fmin = $feat->start - 1; $fmax = $feat->end; $strand = $feat->strand; if ($feat->can('phase')) { $phase = $feat->phase; } %fl = ( "srcfeature_id" => \%srcfhash, "fmin" => $fmin, "fmax" => $fmax, "strand" => $strand, "phase" => $phase, ); $datahash{'featureloc'} = \%fl; #delete 'source' feature from @top_sfs splice(@top_sfs, $si, 1); } $si ++; #close loop over top_sfs } #the top-level features other than 'source' foreach $feat (@top_sfs) { #print $feat->primary_tag, "\n"; my $r = $self->_subfeat2featrelhash($name, $ftype, $feat, \%srcfhash, $tag_cv, $isanalysis); if (!($ftype eq 'mRNA' && $feat->primary_tag eq 'gene')) { my %fr = %$r; push(@top_featrels, \%fr); } else { %finaldatahash = %$r; } } if (@top_dbxrefs) { $datahash{'feature_dbxref'} = \@top_dbxrefs; } if (@top_featureprops) { $datahash{'featureprop'} = \@top_featureprops; } if (@top_featrels) { $datahash{'feature_relationship'} = \@top_featrels; } if (@top_featurecvterms) { $datahash{'feature_cvterm'} = \@top_featurecvterms; } if ($ftype eq 'mRNA' && %finaldatahash) { $finaldatahash{'feature_relationship'} = { 'subject_id' => \%datahash, 'type_id' => { 'name' => 'partof', 'cv_id' => { 'name' => $cv_name{'relationship'} }}, }; } else { %finaldatahash = %datahash; } my $mainTag = 'feature'; $self->_hash2xml(undef, $mainTag, \%finaldatahash); return 1; } sub _hash2xml { my $self = shift; my $isMatch = undef; $isMatch = shift; my $ult = shift; my $ref = shift; my %mh = %$ref; my $key; my $v; my $sh; my $xx; my $yy; my $nt; my $ntref; my $output; my $root = shift if (@_); #print "ult: $ult\n"; if (!defined $self->{'writer'}) { $root = 1; $self->_create_writer(); } my $temp; my %subh = undef; #start opeing tag #if pub record of type 'journal', form the 'ref' attribute for special pub lookup #requires that the journal name itself is also stored as a pubprop record for the journal with value equal #to the journal name and type of 'abbreviation'. if ($ult eq 'pub' && $mh{'type_id'}->{'name'} eq 'journal') { $self->{'writer'}->startTag($ult, 'ref' => $mh{'title'} . ':journal:abbreviation'); } #special pub match if pub uniquename not known elsif ($ult eq 'pub' && !defined $mh{'uniquename'}) { $self->{'writer'}->startTag($ult, 'op' => 'match'); #set the match flag, all the sub tags should also have "op"="match" $isMatch = 1; } #if cvterm or cv, lookup only elsif (($ult eq 'cvterm') || ($ult eq 'cv')) { $self->{'writer'}->startTag($ult, 'op' => 'lookup'); } #if nested tables of match table, match too elsif ($isMatch) { $self->{'writer'}->startTag($ult, 'op' => 'match'); } else { $self->{'writer'}->startTag($ult); } #first loop to produce xml for all the table columns foreach $key (keys %mh) { #print "key: $key\n"; $xx = ' ' . $key; $yy = $key . ' '; if (index($chadotables, $xx) < 0 && index($chadotables, $yy) < 0) { if ($isMatch) { $self->{'writer'}->startTag($key, 'op' => 'match'); } else { $self->{'writer'}->startTag($key); } my $x = $ult . '.' . $key; #the column is a foreign key if (defined $fkey{$x}) { $nt = $fkey{$x}; $sh = $mh{$key}; $self->_hash2xml($isMatch, $nt, $sh, 0); } else { #print "$key: $mh{$key}\n"; $self->{'writer'}->characters($mh{$key}); } $self->{'writer'}->endTag($key); } } #second loop to produce xml for all the nested tables foreach $key (keys %mh) { #print "key: $key\n"; $xx = ' ' . $key; $yy = $key . ' '; #a nested table if (index($chadotables, $xx) > 0 || index($chadotables, $yy) > 0) { #$writer->startTag($key); $ntref = $mh{$key}; #print "$key: ", ref($ntref), "\n"; if (ref($ntref) =~ 'HASH') { $self->_hash2xml($isMatch, $key, $ntref, 0); } elsif (ref($ntref) =~ 'ARRAY') { #print "array dim: ", $#$ntref, "\n"; foreach $ref (@$ntref) { #print "\n"; $self->_hash2xml($isMatch, $key, $ref, 0); } } #$writer->endTag($key); } } #end tag $self->{'writer'}->endTag($ult); #if ($root == 1) { # $self->{'writer'}->endTag('chado'); # } } sub _guess_acc_db { my $self = shift; my $seq = shift; my $acc = shift; #print "acc: $acc\n"; if ($acc =~ /^NM_\d{6}/ || $acc =~ /^NP_\d{6}/ || $acc =~ /^NT_\d{6}/ || $acc =~ /^NC_\d{6}/) { return "RefSeq"; } elsif ($acc =~ /^XM_\d{6}/ || $acc =~ /^XP_\d{6}/ || $acc =~ /^XR_\d{6}/) { return "RefSeq"; } elsif ($acc =~ /^[a-zA-Z]{1,2}\d{5,6}/) { return "GB"; } elsif ($seq->molecule() eq 'protein' && $acc =~ /^[a-zA-z]\d{5}/) { return "PIR"; } elsif ($seq->molecule() eq 'protein' && $acc =~ /^\d{6,7}[a-zA-Z]/) { return "PRF"; } elsif ($acc =~ /\d+/ && $acc !~ /[a-zA-Z]/) { return "LocusID"; } elsif ($acc =~ /^CG\d+/ || $acc =~ /^FB[a-z][a-z]\d+/) { return "FlyBase"; } else { return "unknown"; } } sub _subfeat2featrelhash { my $self = shift; my $genename = shift; my $seqtype = shift; my $feat = shift; my $r = shift; my %srcf = %$r; #srcfeature hash for featureloc.srcfeature_id my $tag_cv = shift; my $isanalysis = shift; my $prim_tag = $feat->primary_tag; my $sfunique = undef; #subfeature uniquename my $sfname = undef; #subfeature name my $sftype = undef; #subfeature type if ($feat->has_tag('symbol')) { ($sfunique) = $feat->each_tag_value("symbol"); } elsif ($feat->has_tag('label')) { ($sfunique) = $feat->each_tag_value("label"); } else { #$self->throw("$prim_tag at " . $feat->start . "\.\." . $feat->end . " does not have symbol or label! To convert into chadoxml, a seq feature must have a /symbol or /label tag holding its unique name."); #generate feature unique name as <genename>-<feature-type>-<span> $sfunique = $self->_genFeatUniqueName($genename, $feat); } if ($feat->has_tag('Name')) { ($sfname) = $feat->each_tag_value("Name"); } #feature type translation if (defined $feattype_args2so{$prim_tag}) { $sftype = $feattype_args2so{$prim_tag}; } else { $sftype = $prim_tag; } if ($prim_tag eq 'mutation') { if ($feat->start == $feat->end) { $sftype = $feattype_args2so{'mutation1'}; } else { $sftype = $feattype_args2so{'mutation2'}; } } #set is_analysis flag for gene model features undef(my $isanal); if ($sftype eq 'gene' || $sftype eq 'mRNA' || $sftype eq 'exon' || $sftype eq 'protein' || $sftype eq 'polypeptide') { $isanal = $isanalysis; } my %sfhash = ( "name" => $sfname, "uniquename" => $sfunique, "organism_id" => \%organism, "type_id" => { 'name' => $sftype, 'cv_id' => { 'name' => $cv_name{'sequence'} }}, "is_analysis" => $isanal || 'false', ); #make a copy of %sfhash for passing to this method when recursively called #my %srcfeat = ( # "name" => $sfname, # "uniquename" => $sfunique, # "organism_id" => \%organism, # "type_id" => { 'name' => $sftype, 'cv_id' => { 'name' => 'SO'}}, # ); #featureloc for subfeatures undef(my $sfmin); undef(my $sfmax); undef(my $is_sfmin_partial); undef(my $is_sfmax_partial); undef(my $sfstrand); undef(my $sfphase); $sfmin = $feat->start - 1; $sfmax = $feat->end; $sfstrand = $feat->strand(); if ($feat->can('phase')) { $sfphase = $feat->phase; } #if the gene feature in an mRNA record, cannot use its coordinates, omit featureloc if ($seqtype eq 'mRNA' && $sftype eq 'gene') { } else { if ($feat->location->isa('Bio::Location::FuzzyLocationI')) { if ($feat->location->start_pos_type() ne 'EXACT') { $is_sfmin_partial = 'true'; } if ($feat->location->end_pos_type() ne 'EXACT') { $is_sfmax_partial = 'true'; } } my %sfl = ( "srcfeature_id" => \%srcf, "fmin" => $sfmin, "is_fmin_partial" => $is_sfmin_partial || 'false', "fmax" => $sfmax, "is_fmax_partial" => $is_sfmax_partial || 'false', "strand" => $sfstrand, "phase" => $sfphase, ); $sfhash{'featureloc'} = \%sfl; } #subfeature tags undef(my @sfdbxrefs); #subfeature dbxrefs undef(my @sub_featureprops); #subfeature props undef(my @sub_featuresyns); #subfeature synonyms undef(my @sub_featurecvterms); #subfeature cvterms foreach my $tag ($feat->all_tags()) { #feature_dbxref for features if ($tag eq 'db_xref' or $tag eq 'dbxref' or $tag eq 'Dbxref') { my @t1 = $feat->each_tag_value($tag); #print "# of dbxref: @t1\n"; for my $temp (@t1) { $temp =~ /:/; my $db = $PREMATCH; my $xref = $POSTMATCH; #print "db: $db; xref: $xref\n"; my %acchash = ( "db_id" => {'name' => $db}, "accession" => $xref, ); my %sfdbx = ('dbxref_id' => \%acchash); push (@sfdbxrefs, \%sfdbx); } #Alias tags } elsif ($tag eq 'Alias') { @sub_featuresyns = $self->handle_Alias_tag($feat, @sub_featuresyns); } elsif ($tag eq 'Ontology_term') { @sub_featurecvterms = $self->handle_Ontology_tag($feat, @sub_featurecvterms); #featureprop for features, excluding GFF Name & Parent tags } elsif ($tag ne 'gene' && $tag ne 'symbol' && $tag ne 'Name' && $tag ne 'Parent') { next if ($tag eq 'parent_id'); next if ($tag eq 'load_id'); foreach my $val ($feat->each_tag_value($tag)) { my %prophash = undef; %prophash = ( "type_id" => {'name' => $tag, 'cv_id' => {'name' => $tag_cv}}, "value" => $val, ); push(@sub_featureprops, \%prophash); } } } if ($feat->can('source')) { @sfdbxrefs = $self->handle_source($feat,@sfdbxrefs); } if (@sub_featureprops) { $sfhash{'featureprop'} = \@sub_featureprops; } if (@sfdbxrefs) { $sfhash{'feature_dbxref'} = \@sfdbxrefs; } if (@sub_featuresyns) { $sfhash{'feature_synonym'} = \@sub_featuresyns; } if (@sub_featurecvterms) { $sfhash{'feature_cvterm'} = \@sub_featurecvterms; } undef(my @ssfeatrel); if ($feat->has_tag('locus_tag')) { ($genename)= $feat->each_tag_value('locus_tag'); } elsif ($feat->has_tag('gene')) { ($genename)= $feat->each_tag_value('gene'); } foreach my $sf ($feat->get_SeqFeatures()) { #print $sf->primary_tag, "\n"; my $rref = $self->_subfeat2featrelhash($genename, $sftype, $sf, \%srcf, $tag_cv, $isanalysis); if (defined $rref) { push(@ssfeatrel, $rref); } } if (@ssfeatrel) { $sfhash{'feature_relationship'} = \@ssfeatrel; } #subj-obj relationship type undef(my $reltypename); $reltypename = return_reltypename($sftype); my %fr = ( "subject_id" => \%sfhash, "type_id" => { 'name' => $reltypename, 'cv_id' => { 'name' => $cv_name{'relationship'} }}, ); if ($seqtype eq 'mRNA' && $sftype eq 'gene') { return \%sfhash; } else { return \%fr; } } #generate uniquename for feature as: <genename>-<feature-type>-<span> (foo-mRNA-10..1000) sub _genFeatUniqueName { my $self = shift; my $genename = shift; my $feat = shift; undef(my $uniquename); my $ftype = $feat->primary_tag; my $start = $feat->start; my $end = $feat->end; if ($feat->has_tag('locus_tag')) { ($genename) = $feat->each_tag_value("locus_tag"); } elsif ($feat->has_tag('gene')) { ($genename) = $feat->each_tag_value("gene"); } $uniquename = $genename . '-' . $ftype . '-' . $start . "\.\." . $end; return $uniquename; } #create uniquename for pubs with no medline id and no FBrf# #use "<authors>, <year>, <type>" as the uniquename (same as miniref) #<authors> is <sole-author-surname> if one author, # or <first-author-surname> and <second-author-surname> if two, # or <first-author-surname> et al. if more #sub _CreatePubUname { # my $self = shift; # my $pub = shift; # undef(my $pubuname); # # return $pubuname; #} #get authors of a reference #returns ref to the array of author hashes sub _getRefAuthors { my $self = shift; my $ref = shift; my $temp = $ref->authors; undef(my @authors); undef(my @aut); #there are authors if ($temp ne '.') { if (index($temp, ' and ') > 0) { $temp =~ / and /; my $lastauthor = $POSTMATCH; @authors = split(/\, /, $PREMATCH); push (@authors, $lastauthor); } else { @authors = split(/\, /, $temp); } my $a; my $i = 0; foreach $a (@authors) { $i ++; #parse the author lastname and givennames undef(my $last); undef(my $given); if (index($a, ',') > 0) { #genbank format, last,f.m. ($last, $given) = split(/\,/, $a); } elsif (index($a, ' ') > 0) { #embl format, last f.m. ($last, $given) = split(/ /, $a); } my %au = ( 'surname' => $last, 'givennames' => $given, ); push(@aut, {author_id => \%au, arank => $i}); } return \@aut; } #no authors, Bio::SeqIO::genbank doesn't pick up 'CONSRTM' line. else { return; } } #extract submission year from the citation of the submitted reference #genbank format for the submitted citation: JOURNAL Submitted (DD-MON-YYYY) submitter address sub _getSubmitYear { my $self = shift; my $citation = shift; if ($citation !~ /Submitted/) { $self->warn("not citation for a submitted reference. cannot extract submission year."); return; } else { $citation =~ /Submitted \(\d\d-[a-zA-Z]{3}-\d{4}\)/; my $a = $MATCH; $a =~ /\d{4}/; my $year = $MATCH; return $year; } } sub _getSubmitAddr { my $self = shift; my $ref = shift; undef(my %author); my $citation = $ref->location; if ($citation !~ /Submitted/) { $self->warn("not citation for a submitted reference. cannot extract submission year."); return; } else { $citation =~ /Submitted \(\d\d-[a-zA-Z]{3}-\d{4}\)/; my $a = $POSTMATCH; if (defined $a) { $a =~ s/^\s//; %author = ( 'author_id' => {'surname' => substr($a, 0, 100)}, ); return \%author; } else { return; } } } =head2 suppress_residues Title : suppress_residues Usage : $obj->suppress_residues() #get existing value $obj->suppress_residues($newval) #set new value Function : Keep track of the flag to suppress printing of residues in the chadoxml file. The default it to allow all residues to go into the file. Returns : value of suppress_residues (a scalar) Args : new value of suppress_residues (to set) =cut sub suppress_residues { my $self = shift; my $suppress_residues = shift if @_; return $self->{'suppress_residues'} = $suppress_residues if defined($suppress_residues); return $self->{'suppress_residues'}; } =head2 allow_residues Title : allow_residues Usage : $obj->allow_residues() #get existing value $obj->allow_residues($feature_type) #set new value Function : Track the allow_residues type. This can be used in conjunction with the suppress_residues flag to only allow residues from a specific feature type to be printed in the xml file, for example, only printing chromosome residues. When suppress_residues is set to true, then only chromosome features would would go into the xml file. If suppress_residues is not set, this function has no effect (since the default is to put all residues in the xml file). Returns : value of allow_residues (string that corresponds to a feature type) Args : new value of allow_residues (to set) Status : =cut sub allow_residues { my $self = shift; my $allow_residues = shift if @_; return $self->{'allow_residues'} = $allow_residues if defined($allow_residues); return $self->{'allow_residues'}; } =head2 return_ftype_hash Title : return_ftype_hash Usage : $obj->return_ftype_hash() Function : A simple hash where returning it has be factored out of the main code to allow subclasses to override it. Returns : A hash that indicates what the name of the SO term is and what the name of the Sequence Ontology is in the cv table. Args : The string that represents the SO term. Status : =cut sub return_ftype_hash { my $self = shift; my $ftype = shift; my %ftype_hash = ( "name" => $ftype, "cv_id" => {"name" => $cv_name{'sequence'} }); return %ftype_hash; } =head2 return_reltypename Title : return_reltypename Usage : $obj->return_reltypename Function : Return the appropriate relationship type name depending on the feature type (typically part_of, but derives_from for polypeptide). Returns : A relationship type name. Args : A SO type name. Status : =cut sub return_reltypename { my $self = shift; my $sftype = shift; my $reltypename; if ($sftype eq 'protein' || $sftype eq 'polypeptide') { $reltypename = 'derives_from'; } else { $reltypename = 'part_of'; } return $reltypename; } =head2 next_seq Title : next_seq Usage : $obj->next_seq Function : Returns : Args : Status : Not implemented (write only adaptor) =cut sub next_seq { my ($self, %argv) = @_; $self->throw('next_seq is not implemented; this is a write-only adapter.'); } =head2 _create_writer Title : _create_writer Usage : $obj->_create_writer Function : Creates XML::Writer object and writes start tag Returns : Nothing, though the writer persists as part of the chadoxml object Args : None Status : =cut sub _create_writer { my $self = shift; $self->{'writer'} = XML::Writer->new(OUTPUT => $self->_fh, DATA_MODE => 1, DATA_INDENT => 3); #print header $self->{'writer'}->xmlDecl("UTF-8"); $self->{'writer'}->comment("created by Peili Zhang, Flybase, Harvard University\n". "and Scott Cain, GMOD, Cold Spring Harbor Laboratory"); #start chadoxml $self->{'writer'}->startTag('chado'); return; } =head2 close_chadoxml Title : close_chadoxml Usage : $obj->close_chadoxml Function : Writes the closing xml tag Returns : None Args : None Status : =cut sub close_chadoxml { my $self = shift; $self->{'writer'}->endTag('chado'); return; } =head2 handle_unreserved_tags Title : handle_unreserved_tags Usage : $obj->handle_unreserved_tags Function : Converts tag value pairs to xml-ready hashrefs Returns : The array containing the hashrefs Args : In order: the Seq or SeqFeature object, the key, and the hasharray Status : =cut sub handle_unreserved_tags { my $self = shift; my $seq = shift; my $key = shift; my @arr = @_; my @values = $seq->attributes($key); for my $value (@values) { my %prophash = ( "type_id" => {'name' => $key, 'cv_id' => { 'name' => $cv_name{'feature_property'} } }, "value" => $value, ); push(@arr, \%prophash); } return @arr; } =head2 handle_Alias_tag Title : handle_Alias_tag Usage : $obj->handle_Alias_tag Function : Convert Alias values to synonym hash refs Returns : An array of synonym hash tags Args : The seq or seqFeature object and the synonym hash array Status : =cut sub handle_Alias_tag { my $self = shift; my $seq = shift; my @arr = @_; my @Aliases = $seq->attributes('Alias'); for my $Alias (@Aliases) { my %synhash = ( "type_id" => { 'name' => 'exact', 'cv_id' => { 'name' => 'synonym_type' } }, "name" => $Alias, "synonym_sgml" => $Alias, ); push(@arr, {'synonym_id' => \%synhash, 'pub_id' => {'uniquename' => 'null', 'type_id' => { 'name' => 'null', 'cv_id' => { 'name' => 'null', }, }, }, }); } return @arr; } =head2 handle_Ontology_tag Title : handle_Ontology_tag Usage : $obj->handle_Ontology_tag Function : Convert Ontology_term values to ontology term hash refs Returns : An array of ontology term hash refs Args : The seq or seqFeature object and the ontology term array Status : =cut sub handle_Ontology_tag { my $self = shift; my $seq = shift; my @arr = @_; my @terms = $seq->attributes('Ontology_term'); for my $term (@terms) { my $hashref; if ($term =~ /(\S+):(\S+)/) { my $db = $1; my $acc = $2; $hashref = { 'cvterm_id' => { 'dbxref_id' => { 'db_id' => { 'name' => $db }, 'accession' => $acc }, }, }; } push(@arr, {cvterm_id => $hashref}); } return @arr; } =head2 handle_dbxref Title : handle_dbxref Usage : $obj->handle_dbxref Function : Convert Dbxref values to dbxref hashref Returns : An array of dbxref hashrefs Args : A seq or seqFeature object and the dbxref array Status : =cut sub handle_dbxref { my $self = shift; my $seq = shift; my $tag = shift; my @arr = @_; my @terms = $seq->attributes($tag); for my $term (@terms) { my $hashref; if ($term =~ /(\S+):(\S+)/) { my $db = $1; my $acc= $2; my $version = 1; if ($acc =~ /(\S+)\.(\S+)/) { $acc = $1; $version = $2; } $hashref = { 'dbxref_id' => { 'db_id' => { 'name' => $db }, 'accession' => $acc, 'version' => $version, }, }; } else { $self->throw("I don't know how to handle a dbxref like $term"); } push(@arr, {'dbxref_id' => $hashref}); } return @arr; } =head2 handle_source Title : handle_source Usage : $obj->handle_source Function : Returns : Args : Status : =cut sub handle_source { my $self = shift; my $seq = shift; my @arr = @_; my $source = $seq->source(); return @arr unless $source; my $hashref = { 'dbxref_id' => { 'db_id' => {'name' => 'GFF_source'}, 'accession' => $source, } }; push(@arr, {'dbxref_id' => $hashref}); return @arr; } =head2 _srcf_hash Title : _srcf_hash Usage : $obj->_srcf_hash Function : Creates the srcfeature hash for use in featureloc hashes Returns : The srcfeature hash Args : The srcfeature name, the srcfeature type and a reference to the organism hash. Status : =cut sub _srcf_hash { my $self = shift; my $srcf = shift; my $stype= shift; my $orgref = shift; my %hash = ('uniquename' => $srcf, 'organism_id' => $orgref, 'type_id' => {'name' => $stype, 'cv_id' => {'name' => $cv_name{'sequence'} }}, ); return %hash; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/chaos.pm������������������������������������������������������������������000444��000765��000024�� 47677�12254227323� 16627� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::chaos # # Chris Mungall <cjm@fruitfly.org> # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::chaos - chaos sequence input/output stream =head1 SYNOPSIS #In general you will not want to use this module directly; #use the chaosxml format via SeqIO $outstream = Bio::SeqIO->new(-file => $filename, -format => 'chaosxml'); while ( my $seq = $instream->next_seq() ) { $outstream->write_seq($seq); } =head1 DESCRIPTION This is the guts of L<Bio::SeqIO::chaosxml> - please refer to the documentation for this module B<CURRENTLY WRITE ONLY> ChaosXML is an XML mapping of the chado relational database; for more information, see http://www.fruitfly.org/chaos-xml chaos can be represented in various syntaxes - XML, S-Expressions or indented text. You should see the relevant SeqIO file. You will probably want to use L<Bio::SeqIO::chaosxml>, which is a wrapper to this module. =head2 USING STAG OBJECTS B<non-standard bioperl stuff you don't necessarily need to know follows> This module (in write mode) is an B<event producer> - it generates XML events via the L<Data::Stag> module. If you only care about the final end-product xml, use L<Bio::SeqIO::chaosxml> You can treat the resulting chaos-xml stream as stag XML objects; $outstream = Bio::SeqIO->new(-file => $filename, -format => 'chaos'); while ( my $seq = $instream->next_seq() ) { $outstream->write_seq($seq); } my $chaos = $outstream->handler->stag; # stag provides get/set methods for xml elements # (these are chaos objects, not bioperl objects) my @features = $chaos->get_feature; my @feature_relationships = $chaos->get_feature_relationships; # stag objects can be queried with functional-programming # style queries my @features_in_range = $chaos->where('feature', sub { my $featureloc = shift->get_featureloc; $featureloc->strand == 1 && $featureloc->nbeg > 10000 && $featureloc->nend < 20000; }); foreach my $feature (@features_in_range) { my $featureloc = $feature->get_featureloc; printf "%s [%d->%d on %s]\n", $feature->sget_name, $featureloc->sget_nbeg, $featureloc->sget_end, $featureloc->sget_srcfeature_id; } =head1 MODULES REQUIRED L<Data::Stag> Downloadable from CPAN; see also http://stag.sourceforge.net =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email cjm@fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::chaos; use strict; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use Bio::SeqFeature::Tools::TypeMapper; use Bio::SeqFeature::Tools::FeatureNamer; use Bio::SeqFeature::Tools::IDHandler; use Data::Stag qw(:all); use base qw(Bio::SeqIO); our $TM = 'Bio::SeqFeature::Tools::TypeMapper'; our $FNAMER = 'Bio::SeqFeature::Tools::FeatureNamer'; our $IDH = 'Bio::SeqFeature::Tools::IDHandler'; sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } my $wclass = $self->default_handler_class; $self->handler($wclass); if ($self->_fh) { $self->handler->fh($self->_fh); } $self->{_end_of_data} = 0; $self->_type_by_id_h({}); my $t = time; my $ppt = localtime $t; $self->handler->S("chaos"); $self->handler->ev(chaos_metadata=>[ [chaos_version=>1], [chaos_flavour=>'bioperl'], [feature_unique_key=>'feature_id'], [equiv_chado_release=>'chado_1_01'], [export_unixtime=>$t], [export_localtime=>$ppt], [export_host=>$ENV{HOST}], [export_user=>$ENV{USER}], [export_perl5lib=>$ENV{PERL5LIB}], [export_program=>$0], [export_module=>'Bio::SeqIO::chaos'], [export_module_cvs_id=>'$Id$'], ]); return; } sub DESTROY { my $self = shift; $self->end_of_data(); $self->SUPER::DESTROY(); } sub end_of_data { my $self = shift; return if $self->{_end_of_data}; $self->{_end_of_data} = 1; $self->handler->E("chaos"); } sub default_handler_class { return Data::Stag->makehandler; } =head2 context_namespace Title : context_namespace Usage : $obj->context_namespace($newval) Function: Example : Returns : value of context_namespace (a scalar) Args : on set, new value (a scalar or undef, optional) IDs will be preceded with the context namespace =cut sub context_namespace{ my $self = shift; return $self->{'context_namespace'} = shift if @_; return $self->{'context_namespace'}; } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my ($self,@args) = @_; my $seq = $self->sequence_factory->create ( # '-verbose' =>$self->verbose(), # %params, # -seq => $seqc, # -annotation => $annotation, # -features => \@features ); return $seq; } sub handler { my $self = shift; $self->{_handler} = shift if @_; return $self->{_handler}; } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : Bio::Seq =cut sub write_seq { my ($self,$seq) = @_; if( !defined $seq ) { $self->throw("Attempting to write with no seq!"); } if( ! ref $seq || ! $seq->isa('Bio::SeqI') ) { $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!"); } # get a handler - must inherit from Data::Stag::BaseHandler; my $w = $self->handler; # start of data ### $w->S("chaos_block"); my $seq_chaos_feature_id; # different seq objects have different version accessors - # weird but true my $version = $seq->can('seq_version') ? $seq->seq_version : $seq->version; my $accversion = $seq->accession_number; if ($version) { $accversion .= ".$version"; } if ($accversion) { $seq_chaos_feature_id = $accversion; } else { $seq_chaos_feature_id = $self->get_chaos_feature_id($seq); $accversion = $seq_chaos_feature_id; } # All ids must have a namespace prefix if ($seq_chaos_feature_id !~ /:/) { $seq_chaos_feature_id = "GenericSeqDB:$seq_chaos_feature_id"; } # if ($seq->accession_number eq 'unknown') { # $seq_chaos_feature_id = $self->get_chaos_feature_id('contig', $seq); # } my $haplotype; if ($seq->desc =~ /haplotype(.*)/i) { # yikes, no consistent way to specify haplotype in gb $haplotype = $1; $haplotype =~ s/\s+/_/g; $haplotype =~ s/\W+//g; } my $OS; # Organism lines if (my $spec = $seq->species) { my ($species, $genus, @class) = $spec->classification(); $OS = "$genus $species"; if (my $ssp = $spec->sub_species) { $OS .= " $ssp"; } $self->genus_species($OS); if( $spec->common_name ) { my $common = $spec->common_name; # genbank parser sets species->common_name to # be "Genus Species (common name)" which is wrong; # we will correct for this; if common_name is set # correctly then carry on if ($common =~ /\((.*)\)/) { $common = $1; } $OS .= " (".$common.")"; } } if ($OS) { $self->organismstr($OS); } if ($haplotype) { # genus_species is part of uniquename - add haplotype # to make it genuinely unique $self->genus_species($self->genus_species .= " $haplotype"); } my $uname = $self->make_uniquename($self->genus_species, $accversion); # data structure representing the core sequence for this record my $seqnode = Data::Stag->new(feature=>[ [feature_id=>$seq_chaos_feature_id], [dbxrefstr=>'SEQDB:'.$accversion], [name=>$seq->display_name], [uniquename=>$uname], [residues=>$seq->seq], ]); # soft properties my %prop = (); $seqnode->set_type('databank_entry'); map { $prop{$_} = $seq->$_() if $seq->can($_); } qw(desc keywords division molecule is_circular); $prop{dates} = join("; ", $seq->get_dates) if $seq->can("get_dates"); local($^W) = 0; # supressing warnings about uninitialized fields. # Reference lines my $count = 1; foreach my $ref ( $seq->annotation->get_Annotations('reference') ) { # TODO } # Comment lines $seqnode->add_featureprop([[type=>'haplotype'],[value=>$haplotype]]) if $haplotype; foreach my $comment ( $seq->annotation->get_Annotations('comment') ) { $seqnode->add_featureprop([[type=>'comment'],[value=>$comment->text]]); } if ($OS) { $seqnode->set_organismstr($OS); } my @sfs = $seq->get_SeqFeatures; # genbank usually includes a 'source' feature - we just # migrate the data from this to the actual source feature my @sources = grep {$_->primary_tag eq 'source'} @sfs; @sfs = grep {$_->primary_tag ne 'source'} @sfs; $self->throw(">1 source types") if @sources > 1; my $source = shift @sources; if ($source) { my $tempw = Data::Stag->makehandler; $self->write_sf($source, $seq_chaos_feature_id, $tempw); my $snode = $tempw->stag; $seqnode->add($_->name, $_->data) foreach ($snode->get_featureprop, $snode->get_feature_dbxref); } # throw the writer an event $w->ev(@$seqnode); $seqnode = undef; # free memory # make events for all the features within the record foreach my $sf ( @sfs ) { $FNAMER->name_feature($sf); $FNAMER->name_contained_features($sf); $self->write_sf($sf, $seq_chaos_feature_id); } # data end ### $w->E("chaos_block"); return 1; } sub organismstr{ my $self = shift; return $self->{'organismstr'} = shift if @_; return $self->{'organismstr'}; } sub genus_species{ my $self = shift; return $self->{'genus_species'} = shift if @_; return $self->{'genus_species'}; } # maps ID to type sub _type_by_id_h { my $self = shift; $self->{_type_by_id_h} = shift if @_; return $self->{_type_by_id_h}; } # ---- # writes a seq feature # ---- sub write_sf { my $self = shift; my $sf = shift; my $seq_chaos_feature_id = shift; my $w = shift || $self->handler; my %props = map { lc($_)=>[$sf->each_tag_value($_)] } $sf->all_tags; my $loc = $sf->location; my $name = $FNAMER->generate_feature_name($sf); my $type = $sf->primary_tag; # The CDS (eg in a genbank feature) implicitly represents # the protein $type =~ s/CDS/polypeptide/; my @subsfs = $sf->sub_SeqFeature; my @locnodes = (); my $sid = $loc->is_remote ? $loc->seq_id : $seq_chaos_feature_id; my $CREATE_SPLIT_SFS = 0; if($CREATE_SPLIT_SFS && $loc->isa("Bio::Location::SplitLocationI") ) { # turn splitlocs into subfeatures my $n = 1; push(@subsfs, map { my $ssf = Bio::SeqFeature::Generic->new( -start=>$_->start, -end=>$_->end, -strand=>$_->strand, -primary=>$self->subpartof($type), ); if ($_->is_remote) { $ssf->location->is_remote(1); $ssf->location->seq_id($_->seq_id); } $ssf; } $loc->each_Location); } elsif( $loc->isa("Bio::Location::RemoteLocationI") ) { # turn splitlocs into subfeatures my $n = 1; push(@subsfs, map { Bio::SeqFeature::Generic->new( # -name=>$name.'.'.$n++, -start=>$_->start, -end=>$_->end, -strand=>$_->strand, -primary=>$self->subpartof($type), ) } $loc->each_Location); } else { my ($beg, $end, $strand) = $self->bp2ib($loc); if (!$strand) { use Data::Dumper; print Dumper $sf, $loc; $self->throw("($beg, $end, $strand) - no strand\n"); } @locnodes = ( [featureloc=>[ [nbeg=>$beg], [nend=>$end], [strand=>$strand], [srcfeature_id=>$sid], [locgroup=>0], [rank=>0], ] ] ); } my $feature_id = $self->get_chaos_feature_id($sf); delete $props{id} if $props{id}; # do something with genbank stuff my $pid = $props{'protein_id'}; my $tn = $props{'translation'}; my @xrefs = @{$props{'db_xref'} || []}; if ($pid) { push(@xrefs, "protein:$pid->[0]"); } my $org = $props{organism} ? $props{organism}->[0] : undef; if (!$org && $self->organismstr) { $org = $self->organismstr; } my $uname = $name ? $name.'/'.$feature_id : $feature_id; if ($self->genus_species && $name) { $uname = $self->make_uniquename($self->genus_species, $name); } if (!$uname) { $self->throw("cannot make uniquename for $feature_id $name"); } $self->_type_by_id_h->{$feature_id} = $type; my $fnode = [feature=>[ [feature_id=>$feature_id], $name ? ([name=>$name]) : (), [uniquename=>$uname], [type=>$type], $tn ? ([residues=>$tn->[0]], [seqlen=>length($tn->[0])], #####[md5checksum=>md5checksum($tn->[0])], ) :(), $org ? ([organismstr=>$org]) : (), @locnodes, (map { [feature_dbxref=>[ [dbxrefstr=>$_] ] ] } @xrefs), (map { my $k = $_; my $rank=0; map { [featureprop=>[[type=>$k],[value=>$_],[rank=>$rank++]]] } @{$props{$k}} } keys %props), ]]; $w->ev(@$fnode); my $rank = 0; if (@subsfs) { # strand is always determined by FIRST feature listed # (see genbank entry for trans-spliced mod(mdg4) AE003734) my $strand = $subsfs[0]; # almost all the time, all features are on same strand my @sfs_on_main_strand = grep {$_->strand == $strand} @subsfs; my @sfs_on_other_strand = grep {$_->strand != $strand} @subsfs; sort_by_strand($strand, \@sfs_on_main_strand); sort_by_strand(0-$strand, \@sfs_on_other_strand); @subsfs = (@sfs_on_main_strand, @sfs_on_other_strand); foreach my $ssf (@subsfs) { my $ssfid = $self->write_sf($ssf, $sid); #my $rtype = 'part_of'; my $rtype = $TM->get_relationship_type_by_parent_child($sf,$ssf); if ($ssf->primary_tag eq 'CDS') { $rtype = 'derives_from'; } $w->ev(feature_relationship=>[ [subject_id=>$ssfid], [object_id=>$feature_id], [type=>$rtype], [rank=>$rank++], ] ); } } else { # parents not stored as bioperl containment hierarchy my @parent_ids = @{$props{parent} || []}; foreach my $parent_id (@parent_ids) { my $ptype = $self->_type_by_id_h->{$parent_id} || 'unknown'; my $rtype = $TM->get_relationship_type_by_parent_child($ptype,$type); $w->ev(feature_relationship=>[ [subject_id=>$feature_id], [object_id=>$parent_id], [type=>$rtype], [rank=>$rank++], ] ); } } return $feature_id; } sub sort_by_strand { my $strand = shift || 1; my $sfs = shift; @$sfs = sort { ($a->start <=> $b->start) * $strand } @$sfs; return; } sub make_uniquename { my $self = shift; my $org = shift; my $name = shift; my $os = $org; $os =~ s/\s+/_/g; $os =~ s/\(/_/g; $os =~ s/\)/_/g; $os =~ s/_+/_/g; $os =~ s/^_+//g; $os =~ s/_+$//g; return "$os:$name"; } sub get_chaos_feature_id { my $self = shift; my $ob = shift; my $id; if ($ob->isa("Bio::SeqI")) { $id = $ob->accession_number . '.' . ($ob->can('seq_version') ? $ob->seq_version : $ob->version); } else { $ob->isa("Bio::SeqFeatureI") || $self->throw("$ob must be either SeqI or SeqFeatureI"); if ($ob->primary_id) { $id = $ob->primary_id; } else { eval { $id = $IDH->generate_unique_persistent_id($ob); }; if ($@) { $self->warn($@); $id = "$ob"; # last resort - use memory pointer ref # will not be persistent, but will be unique } } } if (!$id) { if ($ob->isa("Bio::SeqFeatureI")) { $id = $IDH->generate_unique_persistent_id($ob); } else { $self->throw("Cannot generate a unique persistent ID for a Seq without either primary_id or accession"); } } if ($id) { $id = $self->context_namespace ? $self->context_namespace . ":" . $id : $id; } return $id; } # interbase and directional semantics sub bp2ib { my $self = shift; my $loc = shift; my ($s, $e, $str) = ref($loc) eq "ARRAY" ? (@$loc) : ($loc->start, $loc->end, $loc->strand); $s--; if ($str < 0) { ($s, $e) = ($e, $s); } return ($s, $e, $str || 1); } sub subpartof { my $self = shift; my $type = 'partof_'.shift; $type =~ s/partof_CDS/CDS_exon/; $type =~ s/partof_protein/CDS_exon/; $type =~ s/partof_polypeptide/CDS_exon/; $type =~ s/partof_\w*RNA/exon/; return $type; } 1; �����������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/chaosxml.pm���������������������������������������������������������������000444��000765��000024�� 4521�12254227326� 17310� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::chaosxml # # Chris Mungall <cjm@fruitfly.org> # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::chaosxml - chaosxml sequence input/output stream =head1 SYNOPSIS #In general you will not want to use this module directly; #use the chaosxml format via SeqIO $outstream = Bio::SeqIO->new(-file => $filename, -format => 'chaosxml'); while ( my $seq = $instream->next_seq() ) { $outstream->write_seq($seq); } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from chaos files. B<CURRENTLY WRITE ONLY> ChaosXML is an XML mapping of the chado relational database; for more information, see http://www.fruitfly.org/chaos-xml Chaos can have other syntaxes than XML (eg S-Expressions, Indented text) See L<Bio::SeqIO::chaos> for a full description =head1 VERY VERY IMPORTANT !!!!!!!!!!!CHADO AND CHAOS USE INTERBASE COORDINATES!!!!!!!!!!!!!!!! =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Mungall Email cjm@fruitfly.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::chaosxml; use strict; use Data::Stag::XMLWriter; use base qw(Bio::SeqIO::chaos); sub default_handler_class { return Data::Stag->getformathandler('xml'); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/ctf.pm��������������������������������������������������������������������000444��000765��000024�� 6731�12254227315� 16251� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::ctf # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::ctf - ctf trace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from ctf trace files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Aaron Mackey Email: amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::ctf; use vars qw(@ISA $READ_AVAIL); use strict; use Bio::SeqIO; use Bio::Seq::SeqFactory; push @ISA, qw( Bio::SeqIO ); sub BEGIN { eval { require Bio::SeqIO::staden::read; }; if ($@) { $READ_AVAIL = 0; } else { push @ISA, "Bio::SeqIO::staden::read"; $READ_AVAIL = 1; } } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } unless ($READ_AVAIL) { Bio::Root::Root->throw( -class => 'Bio::Root::SystemException', -text => "Bio::SeqIO::staden::read is not available; make sure the bioperl-ext package has been installed successfully!" ); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self) = @_; my ($seq, $id, $desc, $qual) = $self->read_trace($self->_fh, 'ctf'); # create the seq object $seq = $self->sequence_factory->create(-seq => $seq, -id => $id, -primary_id => $id, -desc => $desc, -alphabet => 'DNA', -qual => $qual ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh; foreach my $seq (@seq) { $self->write_trace($fh, $seq, 'ctf'); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ���������������������������������������BioPerl-1.6.923/Bio/SeqIO/embl.pm�������������������������������������������������������������������000444��000765��000024�� 142570�12254227321� 16453� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::EMBL # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::embl - EMBL sequence input/output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system. Go: $stream = Bio::SeqIO->new(-file => $filename, -format => 'EMBL'); while ( (my $seq = $stream->next_seq()) ) { # do something with $seq } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from EMBL flat file databases. There is a lot of flexibility here about how to dump things which should be documented more fully. There should be a common object that this and Genbank share (probably with Swissprot). Too much of the magic is identical. =head2 Optional functions =over 3 =item _show_dna() (output only) shows the dna or not =item _post_sort() (output only) provides a sorting func which is applied to the FTHelpers before printing =item _id_generation_func() This is function which is called as print "ID ", $func($annseq), "\n"; To generate the ID line. If it is not there, it generates a sensible ID line using a number of tools. If you want to output annotations in EMBL format they need to be stored in a Bio::Annotation::Collection object which is accessible through the Bio::SeqI interface method L<annotation()|annotation>. The following are the names of the keys which are polled from a L<Bio::Annotation::Collection> object. reference - Should contain Bio::Annotation::Reference objects comment - Should contain Bio::Annotation::Comment objects dblink - Should contain Bio::Annotation::DBLink objects =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::embl; use vars qw(%FTQUAL_NO_QUOTE); use strict; use Bio::SeqIO::FTHelper; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO); # Note that a qualifier that exceeds one line (i.e. a long label) will # automatically be quoted regardless: %FTQUAL_NO_QUOTE=( 'anticodon'=>1, 'citation'=>1, 'codon'=>1, 'codon_start'=>1, 'cons_splice'=>1, 'direction'=>1, 'evidence'=>1, 'label'=>1, 'mod_base'=> 1, 'number'=> 1, 'rpt_type'=> 1, 'rpt_unit'=> 1, 'transl_except'=> 1, 'transl_table'=> 1, 'usedin'=> 1, ); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. $self->{'_func_ftunit_hash'} = {}; # sets this to one by default. People can change it $self->_show_dna(1); if ( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my ($self,@args) = @_; my ($pseq,$c,$line,$name,$desc,$acc,$seqc,$mol,$div, $date, $comment, @date_arr); my ($annotation, %params, @features) = Bio::Annotation::Collection->new(); $line = $self->_readline; # This needs to be before the first eof() test if ( !defined $line ) { return; # no throws - end of file } if ( $line =~ /^\s+$/ ) { while ( defined ($line = $self->_readline) ) { $line =~/^\S/ && last; } # return without error if the whole next sequence was just a single # blank line and then eof return unless $line; } # no ID as 1st non-blank line, need short circuit and exit routine $self->throw("EMBL stream with no ID. Not embl in my book") unless $line =~ /^ID\s+\S+/; # At this point we are sure that $line contains an ID header line my $alphabet; if ( $line =~ tr/;/;/ == 6) { # New style headers contain exactly six semicolons. # New style header (EMBL Release >= 87, after June 2006) my $topology; my $sv; # ID DQ299383; SV 1; linear; mRNA; STD; MAM; 431 BP. # This regexp comes from the new2old.pl conversion script, from EBI if ($line =~ m/^ID (\w+);\s+SV (\d+); (\w+); ([^;]+); (\w{3}); (\w{3}); (\d+) BP./) { ($name, $sv, $topology, $mol, $div) = ($1, $2, $3, $4, $6); } if (defined $sv) { $params{'-seq_version'} = $sv; $params{'-version'} = $sv; } if (defined $topology && $topology eq 'circular') { $params{'-is_circular'} = 1; } if (defined $mol ) { if ($mol =~ /DNA/) { $alphabet = 'dna'; } elsif ($mol =~ /RNA/) { $alphabet = 'rna'; } elsif ($mol =~ /AA/) { $alphabet = 'protein'; } } } else { # Old style header (EMBL Release < 87, before June 2006) if ($line =~ /^ID\s+(\S+)[^;]*;\s+(\S+)[^;]*;\s+(\S+)[^;]*;/) { ($name, $mol, $div) = ($1, $2, $3); } if ($mol) { if ( $mol =~ /circular/ ) { $params{'-is_circular'} = 1; $mol =~ s|circular ||; } if (defined $mol ) { if ($mol =~ /DNA/) { $alphabet='dna'; } elsif ($mol =~ /RNA/) { $alphabet='rna'; } elsif ($mol =~ /AA/) { $alphabet='protein'; } } } } unless( defined $name && length($name) ) { $name = "unknown_id"; } # $self->warn("not parsing upper annotation in EMBL file yet!"); my $buffer = $line; local $_; BEFORE_FEATURE_TABLE : my $ncbi_taxid; until ( !defined $buffer ) { $_ = $buffer; # Exit at start of Feature table if ( /^(F[HT]|SQ)/ ) { $self->_pushback($_) if( $1 eq 'SQ' || $1 eq 'FT'); last; } # Description line(s) if (/^DE\s+(\S.*\S)/) { $desc .= $desc ? " $1" : $1; } #accession number if ( /^AC\s+(.*)?/ || /^PA\s+(.*)?/) { my @accs = split(/[; ]+/, $1); # allow space in addition $params{'-accession_number'} = shift @accs unless defined $params{'-accession_number'}; push @{$params{'-secondary_accessions'}}, @accs; } #version number if ( /^SV\s+\S+\.(\d+);?/ ) { my $sv = $1; #$sv =~ s/\;//; $params{'-seq_version'} = $sv; $params{'-version'} = $sv; } #date (NOTE: takes last date line) if ( /^DT\s+(.+)$/ ) { my $line = $1; my ($date, $version) = split(' ', $line, 2); $date =~ tr/,//d; # remove comma if new version if ($version) { if ($version =~ /\(Rel\. (\d+), Created\)/xms ) { my $release = Bio::Annotation::SimpleValue->new( -tagname => 'creation_release', -value => $1 ); $annotation->add_Annotation($release); } elsif ($version =~ /\(Rel\. (\d+), Last updated, Version (\d+)\)/xms ) { my $release = Bio::Annotation::SimpleValue->new( -tagname => 'update_release', -value => $1 ); $annotation->add_Annotation($release); my $update = Bio::Annotation::SimpleValue->new( -tagname => 'update_version', -value => $2 ); $annotation->add_Annotation($update); } } push @{$params{'-dates'}}, $date; } #keywords if ( /^KW (.*)\S*$/ ) { my @kw = split(/\s*\;\s*/,$1); push @{$params{'-keywords'}}, @kw; } # Organism name and phylogenetic information elsif (/^O[SC]/) { # pass the accession number so we can give an informative throw message if necessary my $species = $self->_read_EMBL_Species(\$buffer, $params{'-accession_number'}); $params{'-species'}= $species; } # NCBI TaxID Xref elsif (/^OX/) { if (/NCBI_TaxID=(\d+)/) { $ncbi_taxid=$1; } my @links = $self->_read_EMBL_TaxID_DBLink(\$buffer); foreach my $dblink ( @links ) { $annotation->add_Annotation('dblink',$dblink); } } # References elsif (/^R/) { my @refs = $self->_read_EMBL_References(\$buffer); foreach my $ref ( @refs ) { $annotation->add_Annotation('reference',$ref); } } # DB Xrefs elsif (/^DR/) { my @links = $self->_read_EMBL_DBLink(\$buffer); foreach my $dblink ( @links ) { $annotation->add_Annotation('dblink',$dblink); } } # Comments elsif (/^CC\s+(.*)/) { $comment .= $1; $comment .= " "; while (defined ($_ = $self->_readline) ) { if (/^CC\s+(.*)/) { $comment .= $1; $comment .= " "; } else { last; } } my $commobj = Bio::Annotation::Comment->new(); $commobj->text($comment); $annotation->add_Annotation('comment',$commobj); $comment = ""; } # Get next line. $buffer = $self->_readline; } while ( defined ($_ = $self->_readline) ) { /^FT\s{3}\w/ && last; /^SQ / && last; /^CO / && last; } $buffer = $_; if (defined($buffer) && $buffer =~ /^FT /) { until ( !defined ($buffer) ) { my $ftunit = $self->_read_FTHelper_EMBL(\$buffer); # process ftunit my $feat = $ftunit->_generic_seqfeature($self->location_factory(), $name); # add taxon_id from source if available # Notice, this will override what is found in the OX line. # this is by design as this seems to be the official way # of specifying a TaxID if ($params{'-species'} && ($feat->primary_tag eq 'source') && $feat->has_tag('db_xref') && (! $params{'-species'}->ncbi_taxid())) { foreach my $tagval ($feat->get_tag_values('db_xref')) { if (index($tagval,"taxon:") == 0) { $params{'-species'}->ncbi_taxid(substr($tagval,6)); last; } } } # add feature to list of features push(@features, $feat); if ( $buffer !~ /^FT/ ) { last; } } } # Set taxid found in OX line if ($params{'-species'} && defined $ncbi_taxid && (! $params{'-species'}->ncbi_taxid())) { $params{'-species'}->ncbi_taxid($ncbi_taxid); } # skip comments while ( defined ($buffer) && $buffer =~ /^XX/ ) { $buffer = $self->_readline(); } if ( $buffer =~ /^CO/ ) { # bug#2982 # special : create contig as annotation while ( defined ($buffer) ) { $annotation->add_Annotation($_) for $self->_read_EMBL_Contig(\$buffer); if ( !$buffer || $buffer !~ /^CO/ ) { last; } } $buffer ||= ''; } if ($buffer !~ /^\/\//) { # if no SQ lines following CO (bug#2958) if ( $buffer !~ /^SQ/ ) { while ( defined ($_ = $self->_readline) ) { /^SQ/ && last; } } $seqc = ""; while ( defined ($_ = $self->_readline) ) { m{^//} && last; $_ = uc($_); s/[^A-Za-z]//g; $seqc .= $_; } } my $seq = $self->sequence_factory->create (-verbose => $self->verbose(), -division => $div, -seq => $seqc, -desc => $desc, -display_id => $name, -annotation => $annotation, -molecule => $mol, -alphabet => $alphabet, -features => \@features, %params); return $seq; } =head2 _write_ID_line Title : _write_ID_line Usage : $self->_write_ID_line($seq); Function: Writes the EMBL Release 87 format ID line to the stream, unless : there is a user-supplied ID line generation function in which : case that is used instead. : ( See Bio::SeqIO::embl::_id_generation_function(). ) Returns : nothing Args : Bio::Seq object =cut sub _write_ID_line { my ($self, $seq) = @_; my $id_line; # If there is a user-supplied ID generation function, use it. if ( $self->_id_generation_func ) { $id_line = "ID " . &{$self->_id_generation_func}($seq) . "\nXX\n"; } # Otherwise, generate a standard EMBL release 87 (June 2006) ID line. else { # The sequence name is supposed to be the primary accession number, my $name = $seq->accession_number(); if ( not(defined $name) || $name eq 'unknown') { # but if it is not present, use the sequence ID or the empty string $name = $seq->id() || ''; } $self->warn("No whitespace allowed in EMBL id [". $name. "]") if $name =~ /\s/; # Use the sequence version, or default to 1. my $version = $seq->version() || 1; my $len = $seq->length(); # Taxonomic division. my $div; if ( $seq->can('division') && defined($seq->division) && $self->_is_valid_division($seq->division) ) { $div = $seq->division(); } else { $div ||= 'UNC'; # 'UNC' is the EMBL division code for 'unclassified'. } my $mol; # If the molecule type is a valid EMBL type, use it. if ( $seq->can('molecule') && defined($seq->molecule) && $self->_is_valid_molecule_type($seq->molecule) ) { $mol = $seq->molecule(); } # Otherwise, choose unassigned DNA or RNA based on the alphabet. elsif ($seq->can('primary_seq') && defined $seq->primary_seq->alphabet) { my $alphabet =$seq->primary_seq->alphabet; if ($alphabet eq 'dna') { $mol ='unassigned DNA'; } elsif ($alphabet eq 'rna') { $mol='unassigned RNA'; } elsif ($alphabet eq 'protein') { $self->warn("Protein sequence found; EMBL is a nucleotide format."); $mol='AA'; # AA is not a valid EMBL molecule type. } } my $topology = 'linear'; if ($seq->is_circular) { $topology = 'circular'; } $mol ||= ''; # 'unassigned'; ? $id_line = "ID $name; SV $version; $topology; $mol; STD; $div; $len BP.\nXX\n"; $self->_print($id_line); } } =head2 _is_valid_division Title : _is_valid_division Usage : $self->_is_valid_division($div) Function: tests division code for validity Returns : true if $div is a valid EMBL release 87 taxonomic division. Args : taxonomic division code string =cut sub _is_valid_division { my ($self, $division) = @_; my %EMBL_divisions = ( "PHG" => 1, # Bacteriophage "ENV" => 1, # Environmental Sample "FUN" => 1, # Fungal "HUM" => 1, # Human "INV" => 1, # Invertebrate "MAM" => 1, # Other Mammal "VRT" => 1, # Other Vertebrate "MUS" => 1, # Mus musculus "PLN" => 1, # Plant "PRO" => 1, # Prokaryote "ROD" => 1, # Other Rodent "SYN" => 1, # Synthetic "UNC" => 1, # Unclassified "VRL" => 1 # Viral ); return exists($EMBL_divisions{$division}); } =head2 _is_valid_molecule_type Title : _is_valid_molecule_type Usage : $self->_is_valid_molecule_type($mol) Function: tests molecule type for validity Returns : true if $mol is a valid EMBL release 87 molecule type. Args : molecule type string =cut sub _is_valid_molecule_type { my ($self, $moltype) = @_; my %EMBL_molecule_types = ( "genomic DNA" => 1, "genomic RNA" => 1, "mRNA" => 1, "tRNA" => 1, "rRNA" => 1, "snoRNA" => 1, "snRNA" => 1, "scRNA" => 1, "pre-RNA" => 1, "other RNA" => 1, "other DNA" => 1, "unassigned DNA" => 1, "unassigned RNA" => 1 ); return exists($EMBL_molecule_types{$moltype}); } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and undef for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { my ($self,@seqs) = @_; foreach my $seq ( @seqs ) { $self->throw("Attempting to write with no seq!") unless defined $seq; unless ( ref $seq && $seq->isa('Bio::SeqI' ) ) { $self->warn("$seq is not a SeqI compliant sequence object!") if $self->verbose >= 0; unless ( ref $seq && $seq->isa('Bio::PrimarySeqI' ) ) { $self->throw("$seq is not a PrimarySeqI compliant sequence object!"); } } my $str = $seq->seq || ''; # Write the ID line. $self->_write_ID_line($seq); # Write the accession line if present my( $acc ); { if ( my $func = $self->_ac_generation_func ) { $acc = &{$func}($seq); } elsif ( $seq->isa('Bio::Seq::RichSeqI') && defined($seq->accession_number) ) { $acc = $seq->accession_number; $acc = join("; ", $acc, $seq->get_secondary_accessions); } elsif ( $seq->can('accession_number') ) { $acc = $seq->accession_number; } if (defined $acc) { $self->_print("AC $acc;\n", "XX\n") || return; } } # Date lines my $switch=0; if ( $seq->can('get_dates') ) { my @dates = $seq->get_dates(); my $ct = 1; my $date_flag = 0; my ($cr) = $seq->annotation->get_Annotations("creation_release"); my ($ur) = $seq->annotation->get_Annotations("update_release"); my ($uv) = $seq->annotation->get_Annotations("update_version"); unless ($cr && $ur && $ur) { $date_flag = 1; } foreach my $dt (@dates) { if (!$date_flag) { $self->_write_line_EMBL_regex("DT ","DT ", $dt." (Rel. $cr, Created)", '\s+|$',80) if $ct == 1; $self->_write_line_EMBL_regex("DT ","DT ", $dt." (Rel. $ur, Last updated, Version $uv)", '\s+|$',80) if $ct == 2; } else { # other formats? $self->_write_line_EMBL_regex("DT ","DT ", $dt,'\s+|$',80); } $switch =1; $ct++; } if ($switch == 1) { $self->_print("XX\n") || return; } } # Description lines $self->_write_line_EMBL_regex("DE ","DE ",$seq->desc(),'\s+|$',80) || return; #' $self->_print( "XX\n") || return; # if there, write the kw line { my( $kw ); if ( my $func = $self->_kw_generation_func ) { $kw = &{$func}($seq); } elsif ( $seq->can('keywords') ) { $kw = $seq->keywords; } if (defined $kw) { $self->_write_line_EMBL_regex("KW ", "KW ", $kw, '\s+|$', 80) || return; #' $self->_print( "XX\n") || return; } } # Organism lines if ($seq->can('species') && (my $spec = $seq->species)) { my @class = $spec->classification(); shift @class; # get rid of species name. Some embl files include # the species name in the OC lines, but this seems # more like an error than something we need to # emulate my $OS = $spec->scientific_name; if ($spec->common_name) { $OS .= ' ('.$spec->common_name.')'; } $self->_print("OS $OS\n") || return; my $OC = join('; ', reverse(@class)) .'.'; $self->_write_line_EMBL_regex("OC ","OC ",$OC,'; |$',80) || return; if ($spec->organelle) { $self->_write_line_EMBL_regex("OG ","OG ",$spec->organelle,'; |$',80) || return; } my $ncbi_taxid = $spec->ncbi_taxid; if ($ncbi_taxid) { $self->_print("OX NCBI_TaxID=$ncbi_taxid\n") || return; } $self->_print("XX\n") || return; } # Reference lines my $t = 1; if ( $seq->can('annotation') && defined $seq->annotation ) { foreach my $ref ( $seq->annotation->get_Annotations('reference') ) { $self->_print( "RN [$t]\n") || return; # Having no RP line is legal, but we need both # start and end for a valid location. if ($ref->comment) { $self->_write_line_EMBL_regex("RC ", "RC ", $ref->comment, '\s+|$', 80) || return; #' } my $start = $ref->start; my $end = $ref->end; if ($start and $end) { $self->_print( "RP $start-$end\n") || return; } elsif ($start or $end) { $self->throw("Both start and end are needed for a valid RP line.". " Got: start='$start' end='$end'"); } if (my $med = $ref->medline) { $self->_print( "RX MEDLINE; $med.\n") || return; } if (my $pm = $ref->pubmed) { $self->_print( "RX PUBMED; $pm.\n") || return; } my $authors = $ref->authors; $authors =~ s/([\w\.]) (\w)/$1#$2/g; # add word wrap protection char '#' $self->_write_line_EMBL_regex("RA ", "RA ", $authors . ";", '\s+|$', 80) || return; #' # If there is no title to the reference, it appears # as a single semi-colon. All titles must end in # a semi-colon. my $ref_title = $ref->title || ''; $ref_title =~ s/[\s;]*$/;/; $self->_write_line_EMBL_regex("RT ", "RT ", $ref_title, '\s+|$', 80) || return; #' $self->_write_line_EMBL_regex("RL ", "RL ", $ref->location, '\s+|$', 80) || return; #' $self->_print("XX\n") || return; $t++; } # DB Xref lines if (my @db_xref = $seq->annotation->get_Annotations('dblink') ) { for my $dr (@db_xref) { my $db_name = $dr->database; my $prim = $dr->primary_id; my $opt = $dr->optional_id || ''; my $line = $opt ? "$db_name; $prim; $opt." : "$db_name; $prim."; $self->_write_line_EMBL_regex("DR ", "DR ", $line, '\s+|$', 80) || return; #' } $self->_print("XX\n") || return; } # Comment lines foreach my $comment ( $seq->annotation->get_Annotations('comment') ) { $self->_write_line_EMBL_regex("CC ", "CC ", $comment->text, '\s+|$', 80) || return; #' $self->_print("XX\n") || return; } } # "\\s\+\|\$" ## FEATURE TABLE $self->_print("FH Key Location/Qualifiers\n") || return; $self->_print("FH\n") || return; my @feats = $seq->can('top_SeqFeatures') ? $seq->top_SeqFeatures : (); if ($feats[0]) { if ( defined $self->_post_sort ) { # we need to read things into an array. # Process. Sort them. Print 'em my $post_sort_func = $self->_post_sort(); my @fth; foreach my $sf ( @feats ) { push(@fth,Bio::SeqIO::FTHelper::from_SeqFeature($sf,$seq)); } @fth = sort { &$post_sort_func($a,$b) } @fth; foreach my $fth ( @fth ) { $self->_print_EMBL_FTHelper($fth) || return; } } else { # not post sorted. And so we can print as we get them. # lower memory load... foreach my $sf ( @feats ) { my @fth = Bio::SeqIO::FTHelper::from_SeqFeature($sf,$seq); foreach my $fth ( @fth ) { if ( $fth->key eq 'CONTIG') { $self->_show_dna(0); } $self->_print_EMBL_FTHelper($fth) || return; } } } } if ( $self->_show_dna() == 0 ) { $self->_print( "//\n") || return; return; } $self->_print( "XX\n") || return; # finished printing features. # print contig if present : bug#2982 if ( $seq->can('annotation') && defined $seq->annotation) { foreach my $ctg ( $seq->annotation->get_Annotations('contig') ) { if ($ctg->value) { $self->_write_line_EMBL_regex("CO ","CO ", $ctg->value, '[,]|$', 80) || return; } } } # print sequence lines only if sequence is present! bug#2982 if (length($str)) { $str =~ tr/A-Z/a-z/; # Count each nucleotide my $alen = $str =~ tr/a/a/; my $clen = $str =~ tr/c/c/; my $glen = $str =~ tr/g/g/; my $tlen = $str =~ tr/t/t/; my $len = $seq->length(); my $olen = $seq->length() - ($alen + $tlen + $clen + $glen); if ( $olen < 0 ) { $self->warn("Weird. More atgc than bases. Problem!"); } $self->_print("SQ Sequence $len BP; $alen A; $clen C; $glen G; $tlen T; $olen other;\n") || return; my $nuc = 60; # Number of nucleotides per line my $whole_pat = 'a10' x 6; # Pattern for unpacking a whole line my $out_pat = 'A11' x 6; # Pattern for packing a line my $length = length($str); # Calculate the number of nucleotides which fit on whole lines my $whole = int($length / $nuc) * $nuc; # Print the whole lines my( $i ); for ($i = 0; $i < $whole; $i += $nuc) { my $blocks = pack $out_pat, unpack $whole_pat, substr($str, $i, $nuc); $self->_print(sprintf(" $blocks%9d\n", $i + $nuc)) || return; } # Print the last line if (my $last = substr($str, $i)) { my $last_len = length($last); my $last_pat = 'a10' x int($last_len / 10) .'a'. $last_len % 10; my $blocks = pack $out_pat, unpack($last_pat, $last); $self->_print(sprintf(" $blocks%9d\n", $length)) || return; # Add the length to the end } } $self->_print( "//\n") || return; $self->flush if $self->_flush_on_write && defined $self->_fh; } return 1; } =head2 _print_EMBL_FTHelper Title : _print_EMBL_FTHelper Usage : Function: Internal function Returns : 1 if writing suceeded, otherwise undef Args : =cut sub _print_EMBL_FTHelper { my ($self,$fth) = @_; if ( ! ref $fth || ! $fth->isa('Bio::SeqIO::FTHelper') ) { $fth->warn("$fth is not a FTHelper class. Attempting to print, but there could be tears!"); } #$self->_print( "FH Key Location/Qualifiers\n"); #$self->_print( sprintf("FT %-15s %s\n",$fth->key,$fth->loc)); # let if ( $fth->key eq 'CONTIG' ) { $self->_print("XX\n") || return; $self->_write_line_EMBL_regex("CO ", "CO ",$fth->loc, '\,|$',80) || return; #' return 1; } $self->_write_line_EMBL_regex(sprintf("FT %-15s ",$fth->key), "FT ",$fth->loc, '\,|$',80) || return; #' foreach my $tag ( keys %{$fth->field} ) { if ( ! defined $fth->field->{$tag} ) { next; } foreach my $value ( @{$fth->field->{$tag}} ) { $value =~ s/\"/\"\"/g; if ($value eq "_no_value") { $self->_write_line_EMBL_regex("FT ", "FT ", "/$tag",'.|$',80) || return; #' } # there are almost 3x more quoted qualifier values and they # are more common too so we take quoted ones first # # Long qualifiers, that will be line wrapped, are always quoted elsif (!$FTQUAL_NO_QUOTE{$tag} or length("/$tag=$value")>=60) { my $pat = $value =~ /\s/ ? '\s|\-|$' : '.|\-|$'; $self->_write_line_EMBL_regex("FT ", "FT ", "/$tag=\"$value\"",$pat,80) || return; } else { $self->_write_line_EMBL_regex("FT ", "FT ", "/$tag=$value",'.|$',80) || return; #' } } } return 1; } =head2 _read_EMBL_Contig() Title : _read_EMBL_Contig Usage : Function: convert CO lines into annotations Returns : Args : =cut sub _read_EMBL_Contig { my ($self, $buffer) = @_; my @ret; if ( $$buffer !~ /^CO/ ) { warn("Not parsing line '$$buffer' which maybe important"); } $self->_pushback($$buffer); while ( defined ($_ = $self->_readline) ) { /^C/ || last; /^CO\s+(.*)/ && do { push @ret, Bio::Annotation::SimpleValue->new( -tagname => 'contig', -value => $1); }; } $$buffer = $_; return @ret; } #' =head2 _read_EMBL_References Title : _read_EMBL_References Usage : Function: Reads references from EMBL format. Internal function really Example : Returns : Args : =cut sub _read_EMBL_References { my ($self,$buffer) = @_; my (@refs); # assume things are starting with RN if ( $$buffer !~ /^RN/ ) { warn("Not parsing line '$$buffer' which maybe important"); } my $b1; my $b2; my $title; my $loc; my $au; my $med; my $pm; my $com; while ( defined ($_ = $self->_readline) ) { /^R/ || last; /^RP (\d+)-(\d+)/ && do {$b1=$1;$b2=$2;}; /^RX MEDLINE;\s+(\d+)/ && do {$med=$1}; /^RX PUBMED;\s+(\d+)/ && do {$pm=$1}; /^RA (.*)/ && do { $au = $self->_concatenate_lines($au,$1); next; }; /^RT (.*)/ && do { $title = $self->_concatenate_lines($title,$1); next; }; /^RL (.*)/ && do { $loc = $self->_concatenate_lines($loc,$1); next; }; /^RC (.*)/ && do { $com = $self->_concatenate_lines($com,$1); next; }; } my $ref = Bio::Annotation::Reference->new(); $au =~ s/;\s*$//g; $title =~ s/;\s*$//g; $ref->start($b1); $ref->end($b2); $ref->authors($au); $ref->title($title); $ref->location($loc); $ref->medline($med); $ref->comment($com); $ref->pubmed($pm); push(@refs,$ref); $$buffer = $_; return @refs; } =head2 _read_EMBL_Species Title : _read_EMBL_Species Usage : Function: Reads the EMBL Organism species and classification lines. Example : Returns : A Bio::Species object Args : a reference to the current line buffer, accession number =cut sub _read_EMBL_Species { my( $self, $buffer, $acc ) = @_; my $org; $_ = $$buffer; my( $sub_species, $species, $genus, $common, $sci_name, $class_lines ); while (defined( $_ ||= $self->_readline )) { if (/^OS\s+(.+)/) { $sci_name .= ($sci_name) ? ' '.$1 : $1; } elsif (s/^OC\s+(.+)$//) { $class_lines .= $1; } elsif (/^OG\s+(.*)/) { $org = $1; } else { last; } $_ = undef; # Empty $_ to trigger read of next line } # $$buffer = $_; $self->_pushback($_); $sci_name =~ s{\.$}{}; $sci_name || return; # Convert data in classification lines into classification array. # only split on ';' or '.' so that classification that is 2 or more words # will still get matched, use map() to remove trailing/leading/intervening # spaces my @class = map { s/^\s+//; s/\s+$//; s/\s{2,}/ /g; $_; } split /(?<!subgen)[;\.]+/, $class_lines; # do we have a genus? my $possible_genus = $class[-1]; $possible_genus .= "|$class[-2]" if $class[-2]; if ($sci_name =~ /^($possible_genus)/) { $genus = $1; ($species) = $sci_name =~ /^$genus\s+(.+)/; } else { $species = $sci_name; } # Don't make a species object if it is "Unknown" or "None" if ($genus) { return if $genus =~ /^(Unknown|None)$/i; } # is this organism of rank species or is it lower? # (doesn't catch everything, but at least the guess isn't dangerous) if ($species =~ /subsp\.|var\./) { ($species, $sub_species) = $species =~ /(.+)\s+((?:subsp\.|var\.).+)/; } # sometimes things have common name in brackets, like # Schizosaccharomyces pombe (fission yeast), so get rid of the common # name bit. Probably dangerous if real scientific species name ends in # bracketed bit. unless ($class[-1] eq 'Viruses') { ($species, $common) = $species =~ /^(.+)\s+\((.+)\)$/; $sci_name =~ s/\s+\(.+\)$// if $common; } # Bio::Species array needs array in Species -> Kingdom direction unless ($class[-1] eq $sci_name) { push(@class, $sci_name); } @class = reverse @class; # do minimal sanity checks before we hand off to Bio::Species which won't # be able to give informative throw messages if it has to throw because # of problems here $self->throw("$acc seems to be missing its OS line: invalid.") unless $sci_name; my %names; foreach my $i (0..$#class) { my $name = $class[$i]; $names{$name}++; # this code breaks examples like: Xenopus (Silurana) tropicalis # commenting out, see bug 3158 #if ($names{$name} > 1 && ($name ne $class[$i - 1])) { # $self->warn("$acc seems to have an invalid species classification:$name ne $class[$i - 1]"); #} } my $make = Bio::Species->new(); $make->scientific_name($sci_name); $make->classification(@class); unless ($class[-1] eq 'Viruses') { $make->genus($genus) if $genus; $make->species($species) if $species; $make->sub_species($sub_species) if $sub_species; $make->common_name($common) if $common; } $make->organelle($org) if $org; return $make; } =head2 _read_EMBL_DBLink Title : _read_EMBL_DBLink Usage : Function: Reads the EMBL database cross reference ("DR") lines Example : Returns : A list of Bio::Annotation::DBLink objects Args : =cut sub _read_EMBL_DBLink { my( $self,$buffer ) = @_; my( @db_link ); $_ = $$buffer; while (defined( $_ ||= $self->_readline )) { if ( /^DR ([^\s;]+);\s*([^\s;]+);?\s*([^\s;]+)?\.$/) { my ($databse, $prim_id, $sec_id) = ($1,$2,$3); my $link = Bio::Annotation::DBLink->new(-database => $databse, -primary_id => $prim_id, -optional_id => $sec_id); push(@db_link, $link); } else { last; } $_ = undef; # Empty $_ to trigger read of next line } $$buffer = $_; return @db_link; } =head2 _read_EMBL_TaxID_DBLink Title : _read_EMBL_TaxID_DBLink Usage : Function: Reads the EMBL database cross reference to NCBI TaxID ("OX") lines Example : Returns : A list of Bio::Annotation::DBLink objects Args : =cut sub _read_EMBL_TaxID_DBLink { my( $self,$buffer ) = @_; my( @db_link ); $_ = $$buffer; while (defined( $_ ||= $self->_readline )) { if ( /^OX (\S+)=(\d+);$/ ) { my ($databse, $prim_id) = ($1,$2); my $link = Bio::Annotation::DBLink->new(-database => $databse, -primary_id => $prim_id,); push(@db_link, $link); } else { last; } $_ = undef; # Empty $_ to trigger read of next line } $$buffer = $_; return @db_link; } =head2 _filehandle Title : _filehandle Usage : $obj->_filehandle($newval) Function: Example : Returns : value of _filehandle Args : newvalue (optional) =cut sub _filehandle{ my ($obj,$value) = @_; if ( defined $value) { $obj->{'_filehandle'} = $value; } return $obj->{'_filehandle'}; } =head2 _read_FTHelper_EMBL Title : _read_FTHelper_EMBL Usage : _read_FTHelper_EMBL($buffer) Function: reads the next FT key line Example : Returns : Bio::SeqIO::FTHelper object Args : filehandle and reference to a scalar =cut sub _read_FTHelper_EMBL { my ($self,$buffer) = @_; my ($key, # The key of the feature $loc, # The location line from the feature @qual, # An arrray of lines making up the qualifiers ); if ($$buffer =~ /^FT\s{3}(\S+)\s+(\S+)/ ) { $key = $1; $loc = $2; # Read all the lines up to the next feature while ( defined($_ = $self->_readline) ) { if (/^FT(\s+)(.+?)\s*$/) { # Lines inside features are preceeded by 19 spaces # A new feature is preceeded by 3 spaces if (length($1) > 4) { # Add to qualifiers if we're in the qualifiers if (@qual) { push(@qual, $2); } # Start the qualifier list if it's the first qualifier elsif (substr($2, 0, 1) eq '/') { @qual = ($2); } # We're still in the location line, so append to location else { $loc .= $2; } } else { # We've reached the start of the next feature last; } } else { # We're at the end of the feature table last; } } } elsif ( $$buffer =~ /^CO\s+(\S+)/) { $key = 'CONTIG'; $loc = $1; # Read all the lines up to the next feature while ( defined($_ = $self->_readline) ) { if (/^CO\s+(\S+)\s*$/) { $loc .= $1; } else { # We've reached the start of the next feature last; } } } else { # No feature key return; } # Put the first line of the next feature into the buffer $$buffer = $_; # Make the new FTHelper object my $out = Bio::SeqIO::FTHelper->new(); $out->verbose($self->verbose()); $out->key($key); $out->loc($loc); # Now parse and add any qualifiers. (@qual is kept # intact to provide informative error messages.) QUAL: for (my $i = 0; $i < @qual; $i++) { $_ = $qual[$i]; my( $qualifier, $value ) = m{^/([^=]+)(?:=(.+))?} or $self->throw("Can't see new qualifier in: $_\nfrom:\n" . join('', map "$_\n", @qual)); if (defined $value) { # Do we have a quoted value? if (substr($value, 0, 1) eq '"') { # Keep adding to value until we find the trailing quote # and the quotes are balanced QUOTES: while ($value !~ /"$/ or $value =~ tr/"/"/ % 2) { #" $i++; my $next = $qual[$i]; if (!defined($next)) { $self->warn("Unbalanced quote in:\n".join("\n", @qual). "\nAdding quote to close...". "Check sequence quality!"); $value .= '"'; last QUOTES; } # Protein sequence translations need to be joined without spaces, # other qualifiers need those. if ($qualifier eq "translation") { $value .= $next; } else { $value .= " $next"; } } # Trim leading and trailing quotes $value =~ s/^"|"$//g; # Undouble internal quotes $value =~ s/""/"/g; #" } } else { $value = '_no_value'; } # Store the qualifier $out->field->{$qualifier} ||= []; push(@{$out->field->{$qualifier}},$value); } return $out; } =head2 _write_line_EMBL Title : _write_line_EMBL Usage : Function: internal function Example : Returns : 1 if writing suceeded, else undef Args : =cut sub _write_line_EMBL { my ($self,$pre1,$pre2,$line,$length) = @_; $length || $self->throw("Miscalled write_line_EMBL without length. Programming error!"); my $subl = $length - length $pre2; my $linel = length $line; my $i; my $sub = substr($line,0,$length - length $pre1); $self->_print( "$pre1$sub\n") || return; for ($i= ($length - length $pre1);$i < $linel;) { $sub = substr($line,$i,($subl)); $self->_print( "$pre2$sub\n") || return; $i += $subl; } return 1; } =head2 _write_line_EMBL_regex Title : _write_line_EMBL_regex Usage : Function: internal function for writing lines of specified length, with different first and the next line left hand headers and split at specific points in the text Example : Returns : nothing Args : file handle, first header, second header, text-line, regex for line breaks, total line length =cut sub _write_line_EMBL_regex { my ($self,$pre1,$pre2,$line,$regex,$length) = @_; #print STDOUT "Going to print with $line!\n"; $length || $self->throw("Programming error - called write_line_EMBL_regex without length."); my $subl = $length - (length $pre1) -1 ; my( @lines ); CHUNK: while($line) { foreach my $pat ($regex, '[,;\.\/-]\s|'.$regex, '[,;\.\/-]|'.$regex) { if ($line =~ m/^(.{0,$subl})($pat)(.*)/ ) { my $l = $1.$2; $l =~ s/#/ /g # remove word wrap protection char '#' if $pre1 eq "RA "; my $newl = $3; $line = substr($line,length($l)); # be strict about not padding spaces according to # genbank format $l =~ s/\s+$//; next CHUNK if ($l eq ''); push(@lines, $l); next CHUNK; } } # if we get here none of the patterns matched $subl or less chars $self->warn("trouble dissecting \"$line\"\n into chunks ". "of $subl chars or less - this tag won't print right"); # insert a space char to prevent infinite loops $line = substr($line,0,$subl) . " " . substr($line,$subl); } my $s = shift @lines; ($self->_print("$pre1$s\n") || return) if $s; foreach my $s ( @lines ) { $self->_print("$pre2$s\n") || return; } return 1; } =head2 _post_sort Title : _post_sort Usage : $obj->_post_sort($newval) Function: Returns : value of _post_sort Args : newvalue (optional) =cut sub _post_sort{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_post_sort'} = $value; } return $obj->{'_post_sort'}; } =head2 _show_dna Title : _show_dna Usage : $obj->_show_dna($newval) Function: Returns : value of _show_dna Args : newvalue (optional) =cut sub _show_dna{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_show_dna'} = $value; } return $obj->{'_show_dna'}; } =head2 _id_generation_func Title : _id_generation_func Usage : $obj->_id_generation_func($newval) Function: Returns : value of _id_generation_func Args : newvalue (optional) =cut sub _id_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_id_generation_func'} = $value; } return $obj->{'_id_generation_func'}; } =head2 _ac_generation_func Title : _ac_generation_func Usage : $obj->_ac_generation_func($newval) Function: Returns : value of _ac_generation_func Args : newvalue (optional) =cut sub _ac_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_ac_generation_func'} = $value; } return $obj->{'_ac_generation_func'}; } =head2 _sv_generation_func Title : _sv_generation_func Usage : $obj->_sv_generation_func($newval) Function: Returns : value of _sv_generation_func Args : newvalue (optional) =cut sub _sv_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_sv_generation_func'} = $value; } return $obj->{'_sv_generation_func'}; } =head2 _kw_generation_func Title : _kw_generation_func Usage : $obj->_kw_generation_func($newval) Function: Returns : value of _kw_generation_func Args : newvalue (optional) =cut sub _kw_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_kw_generation_func'} = $value; } return $obj->{'_kw_generation_func'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/embldriver.pm�������������������������������������������������������������000444��000765��000024�� 25023�12254227321� 17640� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::embldriver # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::embldriver - EMBL sequence input/output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system. Go: $stream = Bio::SeqIO->new(-file => $filename, -format => 'embldriver'); while ( (my $seq = $stream->next_seq()) ) { # do something with $seq } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from EMBL flat file databases. There is a lot of flexibility here about how to dump things which should be documented more fully. There should be a common object that this and Genbank share (probably with Swissprot). Too much of the magic is identical. =head2 Optional functions =over 3 =item _show_dna() (output only) shows the dna or not =item _post_sort() (output only) provides a sorting func which is applied to the FTHelpers before printing =item _id_generation_func() This is function which is called as print "ID ", $func($annseq), "\n"; To generate the ID line. If it is not there, it generates a sensible ID line using a number of tools. If you want to output annotations in EMBL format they need to be stored in a Bio::Annotation::Collection object which is accessible through the Bio::SeqI interface method L<annotation()|annotation>. The following are the names of the keys which are polled from a L<Bio::Annotation::Collection> object. reference - Should contain Bio::Annotation::Reference objects comment - Should contain Bio::Annotation::Comment objects dblink - Should contain Bio::Annotation::DBLink objects =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::embldriver; use vars qw(%FTQUAL_NO_QUOTE); use strict; use Bio::SeqIO::Handler::GenericRichSeqHandler; use Data::Dumper; use base qw(Bio::SeqIO); my %FTQUAL_NO_QUOTE = map {$_ => 1} qw( anticodon citation codon codon_start cons_splice direction evidence label mod_base number rpt_type rpt_unit transl_except transl_table usedin LOCATION ); my %DATA_KEY = ( ID => 'ID', AC => 'ACCESSION', DT => 'DATE', DE => 'DESCRIPTION', KW => 'KEYWORDS', OS => 'SOURCE', OC => 'CLASSIFICATION', OG => 'ORGANELLE', RN => 'REFERENCE', RA => 'AUTHORS', RC => 'COMMENT', RG => 'CONSRTM', RP => 'POSITION', RX => 'CROSSREF', RT => 'TITLE', RL => 'LOCATION', XX => 'SPACER', FH => 'FEATHEADER', FT => 'FEATURES', AH => 'TPA_HEADER', # Third party annotation AS => 'TPA_DATA', # Third party annotation DR => 'DBLINK', CC => 'COMMENT', CO => 'CO', CON => 'CON', WGS => 'WGS', ANN => 'ANN', TPA => 'TPA', SQ => 'SEQUENCE', ); my %SEC = ( OC => 'CLASSIFICATION', OH => 'HOST', # not currently handled, bundled with organism data for now OG => 'ORGANELLE', OX => 'CROSSREF', RA => 'AUTHORS', RC => 'COMMENT', RG => 'CONSRTM', RP => 'POSITION', RX => 'CROSSREF', RT => 'TITLE', RL => 'JOURNAL', AS => 'ASSEMBLYINFO', # Third party annotation ); my %DELIM = ( #CC => "\n", #DR => "\n", #DT => "\n", ); # signals to process what's in the hash prior to next round # these should be changed to map secondary data my %PRIMARY = map {$_ => 1} qw(ID AC DT DE SV KW OS RN AH DR FH CC SQ FT WGS CON ANN TPA //); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my $handler = $self->_rearrange([qw(HANDLER)],@args); # hash for functions for decoding keys. $handler ? $self->seqhandler($handler) : $self->seqhandler(Bio::SeqIO::Handler::GenericRichSeqHandler->new( -format => 'embl', -verbose => $self->verbose, -builder => $self->sequence_builder )); # if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my $self = shift; my $hobj = $self->seqhandler; local($/) = "\n"; my ($featkey, $qual, $annkey, $delim, $seqdata); my $lastann = ''; my $ct = 0; PARSER: while(defined(my $line = $self->_readline)) { next PARSER if $line =~ m{^\s*$}; chomp $line; my ($ann,$data) = split m{\s{2,3}}, $line , 2; next PARSER if ($ann eq 'XX' || $ann eq 'FH'); if ($ann) { $data ||=''; if ($ann eq 'FT') { # seqfeatures if ($data =~ m{^(\S+)\s+([^\n]+)}) { $hobj->data_handler($seqdata) if $seqdata; $seqdata = (); ($seqdata->{FEATURE_KEY}, $data) = ($1, $2); $seqdata->{NAME} = $ann; $qual = 'LOCATION'; } elsif ($data =~ m{^\s+/([^=]+)=?(.+)?}) { ($qual, $data) = ($1, $2 ||''); $ct = (exists $seqdata->{$qual}) ? ((ref($seqdata->{$qual})) ? scalar(@{ $seqdata->{$qual} }) : 1) : 0 ; } $data =~ s{^\s+}{}; $data =~ tr{"}{}d; # we don't care about quotes yet... my $delim = ($FTQUAL_NO_QUOTE{$qual}) ? '' : ' '; if ($ct == 0) { $seqdata->{$qual} .= ($seqdata->{$qual}) ? $delim.$data : $data; } else { if (!ref($seqdata->{$qual})) { $seqdata->{$qual} = [$seqdata->{$qual}]; } (exists $seqdata->{$qual}->[$ct]) ? (($seqdata->{$qual}->[$ct]) .= $delim.$data) : (($seqdata->{$qual}->[$ct]) .= $data); } } else { # simple annotations $data =~ s{;$}{}; last PARSER if $ann eq '//'; if ($ann ne $lastann) { if (!$SEC{$ann} && $seqdata) { $hobj->data_handler($seqdata); # can't use undef here; it can lead to subtle mem leaks $seqdata = (); } $annkey = (!$SEC{$ann}) ? 'DATA' : # primary data $SEC{$ann}; $seqdata->{'NAME'} = $ann if !$SEC{$ann}; } # toss the data for SQ lines; this needs to be done after the # call to the data handler next PARSER if $ann eq 'SQ'; my $delim = $DELIM{$ann} || ' '; $seqdata->{$annkey} .= ($seqdata->{$annkey}) ? $delim.$data : $data; $lastann = $ann; } } else { # this should only be sequence (fingers crossed!) SEQUENCE: while (defined ($line = $self->_readline)) { if (index($line, '//') == 0) { $data =~ tr{0-9 \n}{}d; $seqdata->{DATA} = $data; #$self->debug(Dumper($seqdata)); $hobj->data_handler($seqdata); $seqdata = (); last PARSER; } else { $data .= $line; $line = undef; } } } } $hobj->data_handler($seqdata) if $seqdata; $seqdata = (); return $hobj->build_sequence; } sub next_chunk { my $self = shift; my $ct = 0; PARSER: while(defined(my $line = $self->_readline)) { next if $line =~ m{^\s*$}; chomp $line; my ($ann,$data) = split m{\s{2,3}}, $line , 2; $data ||= ''; $self->debug("Ann: [$ann]\n\tData: [$data]\n"); last PARSER if $ann =~ m{//}; } } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { shift->throw("Use Bio::SeqIO::embl for output"); # maybe make a Writer class as well???? } =head2 seqhandler Title : seqhandler Usage : $stream->seqhandler($handler) Function: Get/Set teh Bio::Seq::HandlerBaseI object Returns : Bio::Seq::HandlerBaseI Args : Bio::Seq::HandlerBaseI =cut sub seqhandler { my ($self, $handler) = @_; if ($handler) { $self->throw("Not a Bio::HandlerBaseI") unless ref($handler) && $handler->isa("Bio::HandlerBaseI"); $self->{'_seqhandler'} = $handler; } return $self->{'_seqhandler'}; } 1; __END__ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/entrezgene.pm�������������������������������������������������������������000444��000765��000024�� 125227�12254227315� 17705� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::entrezgene # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::entrezgene - Entrez Gene ASN1 parser =head1 SYNOPSIS use Bio::SeqIO; # don't instantiate directly - instead do my $seqio = Bio::SeqIO->new(-format => 'entrezgene', -file => $file); my $gene = $seqio->next_seq; =head1 DESCRIPTION This is EntrezGene ASN bioperl parser. It is built on top of L<Bio::ASN1::EntrezGene>, a low level ASN parser built by Mingyi Liu (L<http://sourceforge.net/projects/egparser>). The easiest way to use it is shown above. You will get most of the Entrez Gene annotation such as gene symbol, gene name and description, accession numbers associated with the gene, etc. Almost all of these are given as L<Bio::AnnotationI> objects. If you need all the data do: my $seqio = Bio::SeqIO->new(-format => 'entrezgene', -file => $file, -debug => 'on' ); my ($gene,$genestructure,$uncaptured) = $seqio->next_seq; The second variable returned, C<$genestructure>, is a L<Bio::Cluster::SequenceFamily> object. It contains all Refseqs and the genomic contigs that are associated with the particular gene. The third variable, C<$uncaptured>, is a reference to a plain array. You can also modify the output to allow back compatibility with the old LocusLink parser: my $seqio = Bio::SeqIO->new(-format => 'entrezgene', -file => $file, -locuslink => 'convert'); The C<-debug> and C<-locuslink> options slow down the parser. Example code which looks for ontology terms: my $eio = new Bio::SeqIO(-file => $file, -format => 'entrezgene', -service_record => 'yes'); while (my $seq = $eio->next_seq) { my $gid = $seq->accession_number; foreach my $ot ($ann->get_Annotations('OntologyTerm')) { next if ($ot->term->authority eq 'STS marker'); # No STS markers my $evid = $ot->comment; $evid =~ s/evidence: //i; my @ref = $ot->term->get_references; my $id = $ot->identifier; my $fid = 'GO:' . sprintf("%07u",$id); print join("\t",$gid, $ot->ontology->name, $ot->name, $evid, $fid, @ref?$ref[0]->medline:''), "\n"; } } =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Stefan Kirov Email skirov at utk.edu =head1 CONTRIBUTORS Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX This parser is based on Bio::ASN1::EntrezGene module. The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::entrezgene; use strict; use Bio::ASN1::EntrezGene; use Bio::Seq; use Bio::Species; use Bio::Annotation::SimpleValue; use Bio::Annotation::DBLink; use Bio::Annotation::Comment; use Bio::SeqFeature::Generic; use Bio::Annotation::Reference; use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::GeneStructure; use Bio::Cluster::SequenceFamily; #use Bio::Ontology::Ontology; Relationships.... later use Bio::Ontology::Term; use Bio::Annotation::OntologyTerm; use Data::Dumper; use base qw(Bio::SeqIO); %main::eg_to_ll = ( 'Official Full Name' => 'OFFICIAL_GENE_NAME', 'chromosome' => 'CHR', 'cyto' => 'MAP', 'Official Symbol' => 'OFFICIAL_SYMBOL' ); @main::egonly = keys %main::eg_to_ll; # We define $xval and some other variables so we don't have # to pass them as arguments my ( $seq, $ann, $xval, %seqcollection, $buf ); sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys $self->{_debug} = $param{-debug} || 'off'; $self->{_locuslink} = $param{-locuslink} || 'no'; $self->{_service_record} = $param{-service_record} || 'no'; $self->{_parser} = Bio::ASN1::EntrezGene->new( file => $param{-file} ); #Instantiate the low level parser here (it is -file in Bioperl #-should tell M.) #$self->{_parser}->next_seq; #First empty record- bug in Bio::ASN::Parser } sub next_seq { my $self = shift; my $value = $self->{_parser}->next_seq(1); # $value contains data structure for the # record being parsed. 2 indicates the recommended # trimming mode of the data structure #I use 1 as I prefer not to descend into size 0 arrays return unless ($value); my $debug = $self->{_debug}; $self->{_ann} = Bio::Annotation::Collection->new(); $self->{_currentann} = Bio::Annotation::Collection->new(); my @alluncaptured; # parse the entry #my @keys=keys %{$value}; obsolete $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 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; my $seq = Bio::Seq->new( -display_id => $xval->{gene}{locus}, -accession_number => $xval->{'track-info'}{geneid}, -desc => $xval->{summary} ); #Source data here $self->_add_to_ann( $xval->{'track-info'}->{status}, 'Entrez Gene Status' ); my $lineage = $xval->{source}{org}{orgname}{lineage}; $lineage =~ s/[\s\n]//g; my ( $comp, @lineage ); while ($lineage) { ( $comp, $lineage ) = split( /;/, $lineage, 2 ); unshift @lineage, $comp; } unless ( exists( $xval->{source}{org}{orgname}{name}{binomial} ) ) { shift @lineage; my ( $gen, $sp ) = split( /\s/, $xval->{source}{org}{taxname} ); if ( ($sp) && ( $sp ne '' ) ) { if ( $gen =~ /plasmid/i ) { $sp = $gen . $sp; } unshift @lineage, $sp; } else { unshift @lineage, 'unknown'; } } else { my $sp = $xval->{source}{org}{orgname}{name}{binomial}{species}; if ( ($sp) && ( $sp ne '' ) ) { my ( $spc, $strain ) = split( 'sp.', $sp ); #Do we need strain? $spc =~ s/\s//g; if ( ($spc) && ( $spc ne '' ) ) { unshift @lineage, $spc; } else { unshift @lineage, 'unknown'; } } else { unshift @lineage, 'unknown'; } } #print Dumper($xval->{source}{org}); my $ncbiid; if ( ref( $xval->{source}{org}{db} ) eq 'ARRAY' ) { foreach my $taxonomy ( @{ $xval->{source}{org}{db} } ) { if ( lc( $taxonomy->{db} ) eq 'taxon' ) { $ncbiid = $taxonomy->{tag}{id}; } else { push @alluncaptured, $taxonomy; } delete $xval->{source}{org}{db}; } } $ncbiid = $ncbiid || $xval->{source}{org}{db}{tag}{id}; my $s1 = shift @lineage; my $s2 = shift @lineage; my $specie = Bio::Species->new( -classification => [ $s1, $s2 ], -ncbi_taxid => $ncbiid ); $specie->common_name( $xval->{source}{org}{common} ); if ( exists( $xval->{source}->{subtype} ) && ( $xval->{source}->{subtype} ) ) { if ( ref( $xval->{source}->{subtype} ) eq 'ARRAY' ) { foreach my $subtype ( @{ $xval->{source}->{subtype} } ) { $self->_add_to_ann( $subtype->{name}, $subtype->{subtype} ); } } else { $self->_add_to_ann( $xval->{source}->{subtype}->{name}, $xval->{source}->{subtype}->{subtype} ); } } #Synonyms if ( ref( $xval->{gene}->{syn} ) eq 'ARRAY' ) { foreach my $symsyn ( @{ $xval->{gene}->{syn} } ) { $self->_add_to_ann( $symsyn, 'ALIAS_SYMBOL' ); } } else { $self->_add_to_ann( $xval->{gene}->{syn}, 'ALIAS_SYMBOL' ) if ( $xval->{gene}->{syn} ); } #COMMENTS (STS not dealt with yet) if ( exists( $xval->{comments} ) ) { if ( ref( $xval->{comments} ) eq 'ARRAY' ) { for my $i ( 0 .. $#{ $xval->{comments} } ) { $self->{_current} = $xval->{comments}->[$i]; push @alluncaptured, $self->_process_all_comments(); } } else { $self->{_current} = $xval->{comments}; push @alluncaptured, $self->_process_all_comments(); } } #Gene if ( exists( $xval->{gene}->{db} ) ) { if ( ref( $xval->{gene}->{db} ) eq 'ARRAY' ) { foreach my $genedb ( @{ $xval->{gene}->{db} } ) { my $id = exists( $genedb->{tag}->{id} ) ? $genedb->{tag}->{id} : $genedb->{tag}->{str}; $self->_add_to_ann( $id, $genedb->{db} ); } } else { my $id = ( $xval->{gene}->{db}->{tag}->{id} ) ? $xval->{gene}->{db}->{tag}->{id} : $xval->{gene}->{db}->{tag}->{str}; $self->_add_to_ann( $id, $xval->{gene}->{db}->{db} ); } $self->_add_to_ann( $xval->{gene}->{'locus-tag'}, 'LOCUS_SYNONYM' ); delete $xval->{gene}->{db} unless ( $debug eq 'off' ); } #LOCATION To do: uncaptured stuff if ( exists( $xval->{location} ) ) { if ( ref( $xval->{location} ) eq 'ARRAY' ) { foreach my $loc ( @{ $xval->{location} } ) { $self->_add_to_ann( $loc->{'display-str'}, $loc->{method}->{'map-type'} ); } } else { $self->_add_to_ann( $xval->{location}->{'display-str'}, $xval->{location}->{method}->{'map-type'} ); } delete $xval->{location} unless ( $debug eq 'off' ); } #LOCUS if ( ref( $xval->{locus} ) eq 'ARRAY' ) { foreach my $locus ( @{ $xval->{locus} } ) { $self->{_current} = $locus; push @alluncaptured, $self->_process_locus(); } } else { push @alluncaptured, $self->_process_locus( $xval->{locus} ); } #Homology my ( $uncapt, $hom, $anchor ) = _process_src( $xval->{homology}->{source} ); foreach my $homann (@$hom) { $self->{_ann}->add_Annotation( 'dblink', $homann ); } push @alluncaptured, $uncapt; #Index terms if ( ( exists( $xval->{'xtra-index-terms'} ) ) && ( $xval->{'xtra-index-terms'} ) ) { if ( ref( $xval->{'xtra-index-terms'} ) eq 'ARRAY' ) { foreach my $term ( @{ $xval->{'xtra-index-terms'} } ) { $self->_add_to_ann( $term, 'Index terms' ); } } else { $self->_add_to_ann( $xval->{'xtra-index-terms'}, 'Index terms' ); } } #PROPERTIES my @prop; if ( exists( $xval->{properties} ) ) { if ( ref( $xval->{properties} ) eq 'ARRAY' ) { foreach my $property ( @{ $xval->{properties} } ) { push @alluncaptured, $self->_process_prop($property); } } else { push @alluncaptured, $self->_process_prop( $xval->{properties} ); } } $seq->annotation( $self->{_ann} ); $seq->species($specie); my @seqs; foreach my $key ( keys %seqcollection ) { #Optimize this, no need to go through hash? push @seqs, @{ $seqcollection{$key} }; } my $cluster = Bio::Cluster::SequenceFamily->new( -family_id => $seq->accession_number, -description => "Entrez Gene " . $seq->accession_number, -members => \@seqs ); #Our EntrezGene object #clean unless ( $debug eq 'off' ) { delete $xval->{homology}->{source}; delete( $xval->{summary} ); delete( $xval->{'track-info'} ); delete( $xval->{gene}{locus} ); delete( $xval->{source}{org}{orgname}{lineage} ); delete $xval->{source}{org}{orgname}{name}{binomial}{species}; delete $xval->{gene}{syn}; delete $xval->{source}->{subtype}; delete $xval->{comments}; delete $xval->{properties}; delete $xval->{'xtra-index-terms'}; delete $xval->{status}; } push @alluncaptured, $xval; undef %seqcollection; $seq->annotation( _backcomp_ll( $self->{_ann} ) ) if ( $self->{_locuslink} eq 'convert' ); #Fix this! return wantarray ? ( $seq, $cluster, \@alluncaptured ) : $seq; #Hilmar's suggestion } sub _process_refseq { my $self = shift; my $products = shift; my $ns = shift; my $iter = shift; $iter++; my $pid; my ( @uncaptured, @products ); if ( ref($products) eq 'ARRAY' ) { @products = @{$products}; } else { push @products, $products; } foreach my $product (@products) { if ( ( ref($product) eq 'ARRAY' ) && ( $#{$product} > -1 ) ) { $self->_process_refseq( $product, $ns, $iter ); next; } if ( ( exists( $product->{products} ) && ( !exists( $product->{accession} ) ) ) ) { $self->_process_refseq( $product->{products}, $ns ); next; } #if ((exists($product->{products})&&($product->{products}))) { # $self->_process_refseq($product->{products},$ns,$iter); #} if ( ( exists( $product->{seqs}->{whole}->{gi} ) ) && ( ref( $product->{seqs}->{whole}->{gi} ) eq 'ARRAY' ) ) { $product->{seqs}->{whole}->{gi} = $product->{seqs}->{whole}->{gi}->[0]; } #Lose some data if ( ( exists( $product->{seqs}->{whole}->{gi} ) ) || ( exists( $product->{accession} ) ) ) { #Minimal data required my $cann = Bio::Annotation::Collection->new(); $pid = $product->{accession}; my $authority = exists( $product->{type} ) ? $product->{type} : $product->{heading}; my $nseq = Bio::Seq->new( -accession_number => $product->{seqs}->{whole}->{gi}, -display_id => $product->{accession}, -authority => $authority, -namespace => $ns ); if ( exists( $product->{source} ) && ( $product->{source} ) ) { if ( ( !defined( $nseq->authority ) ) && ( exists( $product->{source}->{src} ) ) && ( exists( $product->{source}->{src}->{db} ) ) ) { $nseq->authority( $product->{source}->{src}->{db} ); } my ( $uncapt, $allann ) = _process_src( $product->{source} ); push @uncaptured, $uncapt; delete $product->{source}; foreach my $annotation ( @{$allann} ) { $cann->add_Annotation( 'dblink', $annotation ); } } delete $product->{seqs}->{whole}->{gi}; delete $product->{accession}; delete $product->{source}; delete $product->{heading}; my ( $uncapt, $ann, $cfeat ) = $self->_process_comments( $product->{comment} ) if ( exists( $product->{comment} ) ); push @uncaptured, $uncapt; foreach my $feat ( @{$cfeat} ) { $nseq->add_SeqFeature($feat); } if ( exists( $product->{products} ) && ( $product->{products} ) ) { my ( $uncapt, $prodid ) = $self->_process_refseq( $product->{products} ); push @uncaptured, $uncapt; my $simann = Bio::Annotation::SimpleValue->new( -value => $prodid, -tagname => 'product' ); $cann->add_Annotation($simann); } foreach my $key ( keys %$ann ) { foreach my $val ( @{ $ann->{$key} } ) { $cann->add_Annotation( $key, $val ); } } $nseq->annotation($cann); push @{ $seqcollection{seq} }, $nseq; } } undef @products; undef $products; #my $ti2=new Benchmark; # my $td= timediff($ti2, $ti1); # print "\tITER $iter:",timestr($td),"\n"; return \@uncaptured, $pid, $seqcollection{seq}, $iter; } sub _process_links { my $self = shift; my $links = shift; my ( @annot, @uncapt ); if ( ref($links) eq 'ARRAY' ) { foreach my $link (@$links) { my ( $uncapt, $annot ) = _process_src( $link->{source} ) if ( exists( $link->{source} ) ); push @uncapt, $uncapt; foreach my $annotation (@$annot) { $self->{_ann}->add_Annotation( 'dblink', $annotation ); } } } else { my ( $uncapt, $annot ) = _process_src( $links->{source} ) if ( exists( $links->{source} ) ); push @uncapt, $uncapt; foreach my $annotation (@$annot) { $self->{_ann}->add_Annotation( 'dblink', $annotation ); } } return @uncapt; } sub _add_to_ann { #Highest level only my ( $self, $val, $tag ) = @_; # $val=~s/\n//g;#Low level EG parser leaves this so we take care of them here unless ($tag) { $self->warn( "No tagname for value $val, tag $tag " . $seq->id . "\n" ); return; } my $simann = Bio::Annotation::SimpleValue->new( -value => $val, -tagname => $tag ); $self->{_ann}->add_Annotation($simann); } sub _process_comments { my $self = shift; my $prod = shift; my ( %cann, @feat, @uncaptured, @comments, @sfann ); if ( ( ref($prod) eq 'HASH' ) && ( exists( $prod->{comment} ) ) ) { $prod = $prod->{comment}; } if ( ref($prod) eq 'ARRAY' ) { @comments = @{$prod}; } else { push @comments, $prod; } my $i = 0; for my $comm (@comments) { # Each comments is a hash reference $self->throw("Comment not a hash reference") unless ref($comm) eq 'HASH'; my ( $desc, $nfeat, $add, @ann, @comm ); # next unless (exists($comm->{comment}));#Should be more careful when calling _process_comment:To do my $heading = $comm->{heading} || 'description'; if ( !exists( $comm->{comment} ) ) { if ( ( exists( $comm->{type} ) ) && ( $comm->{type} ) && ( $self->{_current_heading} ) ) { $comm->{type} = $self->{_current_heading}; } if ( ( exists( $comm->{source} ) ) && ( exists( $comm->{type} ) ) && ( exists( $comm->{text} ) ) && ( $comm->{type} ne 'comment' ) ) { my ( $uncapt, $annot, $anchor ) = _process_src( $comm->{source} ); my $cann = shift(@$annot); if ( defined $cann ) { $cann->optional_id( $comm->{text} ); $cann->authority( $comm->{type} ); $cann->version( $comm->{version} ); push @sfann, $cann; } } } while (ref($comm) eq 'HASH' && ( exists( $comm->{comment} ) ) && ( $comm->{comment} ) ) { if ( ( exists( $comm->{source} ) ) && ( $comm->{source} ) ) { my ( $uncapt, $allann, $anchor ) = _process_src( $comm->{source} ); if ($allann) { delete $comm->{source}; push @uncaptured, $uncapt; foreach my $annotation ( @{$allann} ) { if ( $annotation->{_anchor} ) { $desc .= $annotation->{_anchor} . ' '; } $annotation->optional_id($heading); push @sfann, $annotation; push @{ $cann{'dblink'} }, $annotation; } } } $comm = $comm->{comment}; if ( ref($comm) eq 'ARRAY' ) { @comm = @{$comm}; } else { push @comm, $comm if ($comm); } foreach my $ccomm (@comm) { next unless ($ccomm); if ( exists( $ccomm->{source} ) ) { my ( $uncapt, $allann, $anchor ) = _process_src( $ccomm->{source} ); if ($allann) { @sfann = @{$allann}; delete $ccomm->{source}; push @uncaptured, $uncapt; } } $ccomm = $ccomm->{comment} if ( exists( $ccomm->{comment} ) ); #Alice in Wonderland??? my @loc; if ($ccomm) { if ( ref($ccomm) eq 'ARRAY' ) { @loc = @{$ccomm}; } else { push @loc, $ccomm; } } foreach my $loc (@loc) { if ( ( exists( $loc->{text} ) ) && ( $loc->{text} =~ /Location/i ) ) { my ( $l1, $rest ) = split( /-/, $loc->{text} ); $l1 =~ s/\D//g; $rest =~ s/^\s//; my ( $l2, $scorestr ) = split( /\s/, $rest, 2 ); my ( $scoresrc, $score ) = split( /:/, $scorestr ); $score =~ s/\D//g; my ( %tags, $tag ); unless ($l1) { next; } $nfeat = Bio::SeqFeature::Generic->new( -start => $l1, -end => $l2, -strand => $tags{strand}, -source => $loc->{type}, -seq_id => $desc, -primary => $heading, -score => $score, -tag => { score_src => $scoresrc } ); my $sfeatann = Bio::Annotation::Collection->new(); foreach my $sfann (@sfann) { $sfeatann->add_Annotation( 'dblink', $sfann ); } undef @sfann; $nfeat->annotation($sfeatann) ; #Thus the annotation will be available both in the seq and seqfeat? push @feat, $nfeat; delete $loc->{text}; delete $loc->{type}; } elsif ( exists( $loc->{label} ) ) { my $simann = Bio::Annotation::SimpleValue->new( -value => $loc->{text}, -tagname => $loc->{label} ); delete $loc->{text}; delete $loc->{label}; push @{ $cann{'simple'} }, $simann; push @uncaptured, $loc; } elsif ( exists( $loc->{text} ) ) { my $simann = Bio::Annotation::SimpleValue->new( -value => $loc->{text}, -tagname => $heading ); delete $loc->{text}; push @{ $cann{'simple'} }, $simann; push @uncaptured, $loc; } } } #Bit clumsy but that's what we get from the low level parser } $i++; } if (@sfann) { push @{ $cann{'dblink'} }, @sfann; } #Annotation that is not location specific, for example phenotype #undef $self->{_current_heading}; return \@uncaptured, \%cann, \@feat; } sub _process_src { my $src = shift; #Trick we do because sometimes we have an array ref my ( @ann, $anch, @uncapt ); if ( ref($src) eq 'ARRAY' ) { foreach my $msrc (@$src) { my ( $uncapt, $ann, $anchor ) = _process_src($msrc); push @ann, @$ann; push @uncapt, $uncapt; $anch = $anchor; } return \@uncapt, \@ann, $anch; } return unless ( exists( $src->{src}->{tag} ) ); #my $t0=new Benchmark my $db = $src->{src}->{db}; delete $src->{src}->{db}; my $anchor = $src->{anchor} || ''; delete $src->{anchor}; my $url; if ( exists( $src->{url} ) && ( $src->{url} ) ) { $url = $src->{url}; $url =~ s/\n//g; delete $src->{url}; } if ( ( exists( $src->{src}->{tag}->{str} ) ) && ( $src->{src}->{tag}->{str} ) ) { my @sq = split( /[,;]/, $src->{src}->{tag}->{str} ); delete $src->{src}->{tag}; foreach my $id (@sq) { $id =~ s/\n//g; undef $anchor if ( $anchor eq 'id' ); my $simann = Bio::Annotation::DBLink->new( -database => $db, -primary_id => $id, -authority => $src->{heading} ); $simann->url($url) if ($url); #DBLink should have URL! push @ann, $simann; } } else { my $id = $src->{src}->{tag}->{id} || ''; delete $src->{src}->{tag}; undef $anchor if ( $anchor eq 'id' ); $id =~ s/\n//g; my $simann = Bio::Annotation::DBLink->new( -database => $db, -primary_id => $id, -authority => $src->{heading} ); if ($anchor) { $simann->{_anchor} = $anchor; $simann->optional_id($anchor); } $simann->url($url) if ($url); #DBLink should have URL! push @ann, $simann; } #my $t1=new Benchmark; #my $td= timediff($t1, $t0); #print "\t\tSRC:",timestr($td),"\n"; return $src, \@ann, $anchor; } sub _add_references { my $self = shift; my $refs = shift; if ( ref($refs) eq 'ARRAY' ) { foreach my $ref (@$refs) { my $refan = Bio::Annotation::Reference->new( -database => 'Pubmed', -primary_id => $ref ); $self->{_ann}->add_Annotation( 'Reference', $refan ); } } else { my $refan = Bio::Annotation::Reference->new( -database => 'Pubmed', -primary_id => $refs ); $self->{_ann}->add_Annotation( 'Reference', $refan ); } } #Should we do this at all if no seq coord are present? sub _process_locus { my $self = shift; my @uncapt; return $self unless ( exists( $self->{_current}->{accession} ) && ( $self->{_current}->{accession} ) ); my $gseq = Bio::Seq->new( -display_id => $self->{_current}->{accession}, -version => $self->{_current}->{version}, -accession_number => $self->{_current}->{seqs}->{'int'}->{id}->{gi}, -authority => $self->{_current}->{type}, -namespace => $self->{_current}->{heading} ); delete $self->{_current}->{accession}; delete $self->{_current}->{version}; delete $self->{_current}->{'int'}->{id}->{gi}; my ( $start, $end, $strand ); if ( exists( $self->{_current}->{seqs}->{'int'}->{from} ) ) { $start = $self->{_current}->{seqs}->{'int'}->{from}; delete $self->{_current}->{seqs}->{'int'}->{from}; #unless ($start) {print $locus->{seqs}->{'int'}->{from},"\n",$locus,"\n";} $end = $self->{_current}->{seqs}->{'int'}->{to}; delete $self->{_current}->{seqs}->{'int'}->{to}; delete $self->{_current}->{seqs}->{'int'}->{strand}; $strand = $self->{_current}->{seqs}->{'int'}->{strand} eq 'minus' ? -1 : 1 if ( exists( $self->{_current}->{seqs}->{'int'}->{strand} ) ) ; #1 being default my $nfeat = Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -strand => $strand, primary => 'gene location' ); $gseq->add_SeqFeature($nfeat); } my @products; if ( ref( $self->{_current}->{products} ) eq 'ARRAY' ) { @products = @{ $self->{_current}->{products} }; } else { push @products, $self->{_current}->{products}; } delete $self->{_current}->{products}; my $gstruct = Bio::SeqFeature::Gene::GeneStructure->new(); foreach my $product (@products) { my ( $tr, $uncapt ) = _process_products_coordinates( $product, $start, $end, $strand ); $gstruct->add_transcript($tr) if ($tr); undef $tr->{parent}; #Because of a cycleG push @uncapt, $uncapt; } $gseq->add_SeqFeature($gstruct); push @{ $seqcollection{genestructure} }, $gseq; return @uncapt; } =head1 _process_products_coordinates To do: =cut sub _process_products_coordinates { my $coord = shift; my $start = shift || 0; #In case it is not known: should there be an entry at all? my $end = shift || 1; my $strand = shift || 1; my ( @coords, @uncapt ); return unless ( exists( $coord->{accession} ) ); my $transcript = Bio::SeqFeature::Gene::Transcript->new( -primary => $coord->{accession}, #Desc is actually non functional... -start => $start, -end => $end, -strand => $strand, -desc => $coord->{type} ); if ( ( exists( $coord->{'genomic-coords'}->{mix}->{'int'} ) ) || ( exists( $coord->{'genomic-coords'}->{'packed-int'} ) ) ) { @coords = exists( $coord->{'genomic-coords'}->{mix}->{'int'} ) ? @{ $coord->{'genomic-coords'}->{mix}->{'int'} } : @{ $coord->{'genomic-coords'}->{'packed-int'} }; foreach my $exon (@coords) { next unless ( exists( $exon->{from} ) ); my $exonobj = Bio::SeqFeature::Gene::Exon->new( -start => $exon->{from}, -end => $exon->{to}, -strand => $strand ); $transcript->add_exon($exonobj); delete $exon->{from}; delete $exon->{to}; delete $exon->{strand}; push @uncapt, $exon; } } my ( $prot, $uncapt ); if ( exists( $coord->{products} ) ) { my ( $prot, $uncapt ) = _process_products_coordinates( $coord->{products}, $start, $end, $strand ); $transcript->add_SeqFeature($prot); push @uncapt, $uncapt; } return $transcript, \@uncapt; } =head1 _process_prop To do: process GO =cut sub _process_prop { my $self = shift; my $prop = shift; my @uncapt; if ( exists( $prop->{properties} ) ) { #Iterate if ( ref( $prop->{properties} ) eq 'ARRAY' ) { foreach my $propn ( @{ $prop->{properties} } ) { push @uncapt, $self->_process_prop($propn); } } else { push @uncapt, $self->_process_prop( $prop->{properties} ); } } unless ( ( exists( $prop->{heading} ) ) && ( $prop->{heading} eq 'GeneOntology' ) ) { $self->_add_to_ann( $prop->{text}, $prop->{label} ) if ( exists( $prop->{text} ) ); delete $prop->{text}; delete $prop->{label}; push @uncapt, $prop; return \@uncapt; } #Will do GO later if ( exists( $prop->{comment} ) ) { push @uncapt, $self->_process_go( $prop->{comment} ); } } sub _process_all_comments { my $self = shift; my $product = $self->{_current}; #Better without copying my @alluncaptured; my $heading = $product->{heading} if ( exists( $product->{heading} ) ); if ($heading) { #my $tx1=new Benchmark; delete $product->{heading}; CLASS: { if ( $heading =~ 'RefSeq Status' ) { #IN case NCBI changes slightly the spacing:-) $self->_add_to_ann( $product->{label}, 'RefSeq status' ); last CLASS; } if ( $heading =~ 'NCBI Reference Sequences' ) { #IN case NCBI changes slightly the spacing:-) if ( ( exists( $product->{comment} ) ) && ( !exists( $product->{products} ) ) ) { $product->{products} = $product->{comment}; } #unless (($product->{products})&&(exists($product->{comment}))) { #if (ref ($product->{comment}) eq 'ARRAY') { # foreach my $pc (@{$product->{comment}}) { # push @{$product->{products}},$pc->{products}; # } #} #else { # $product->{products}=exists($product->{comments}->{products})?$product->{comments}->{products}:$product->{comment}; #} #} my @uncaptured = $self->_process_refseq( $product->{products}, 'refseq' ); push @alluncaptured, @uncaptured; last CLASS; } if ( ( $heading =~ 'Related Sequences' ) && ( exists( $product->{products} ) ) ) { #IN case NCBI changes slightly the spacing:-) my @uncaptured = $self->_process_refseq( $product->{products} ); push @alluncaptured, @uncaptured; last CLASS; } if ( ( $heading =~ 'Additional Links' ) && ( exists( $product->{comment} ) ) ) { #IN case NCBI changes slightly the spacing:-) push @alluncaptured, $self->_process_links( $product->{comment} ); last CLASS; } if ( $heading =~ 'LocusTagLink' ) { #IN case NCBI changes slightly the spacing:-) $self->_add_to_ann( $product->{source}->{src}->{tag}->{id}, $product->{source}->{src}->{db} ); last CLASS; } if ( ( $heading =~ 'Sequence Tagged Sites' ) && ( exists( $product->{comment} ) ) ) { #IN case NCBI changes slightly the spacing:-) push @alluncaptured, $self->_process_STS( $product->{comment} ); delete $product->{comment}; last CLASS; } if ( $heading =~ 'Pathways' ) { $self->{_current_heading} = 'Pathways'; last CLASS; } } # my $tx2=new Benchmark; # my $td= timediff($tx2, $tx1); #print "\t\t$heading:",timestr($td),"\n"; } if ( exists( $product->{type} ) && ( $product->{type} eq 'generif' ) ) { push @alluncaptured, $self->_process_grif($product); return @alluncaptured; #Maybe still process the comments? } if ( exists( $product->{refs} ) ) { $self->_add_references( $product->{refs}->{pmid} ); delete $product->{refs}->{pmid}; push @alluncaptured, $product; } if ( exists( $product->{comment} ) ) { my ( $uncapt, $allan, $allfeat ) = $self->_process_comments( $product->{comment} ); foreach my $key ( keys %$allan ) { foreach my $val ( @{ $allan->{$key} } ) { $self->{_ann}->add_Annotation( $key, $val ); } } delete $product->{refs}->{comment}; push @alluncaptured, $uncapt; } #if (exists($product->{source})) { # my ($uncapt,$ann,$anchor)=_process_src($product->{source}); # foreach my $dbl (@$ann) { # $self->{_ann}->add_Annotation('dblink',$dbl); # } #} return @alluncaptured; } sub _process_STS { my $self = shift; my $comment = shift; my @comm; push @comm, ( ref($comment) eq 'ARRAY' ) ? @{$comment} : $comment; foreach my $product (@comm) { my $sts = Bio::Ontology::Term->new( -identifier => $product->{source}->{src}->{tag}->{id}, -name => $product->{source}->{anchor}, -comment => $product->{source}->{'post-text'} ); $sts->namespace( $product->{source}->{src}->{db} ); $sts->authority('STS marker'); my @alt; if ( exists( $product->{comment} ) ) { push @alt, ( ref( $product->{comment} ) eq 'ARRAY' ) ? @{ $product->{comment} } : $product->{comment}; foreach my $alt (@alt) { $sts->add_synonym( $alt->{text} ); } } my $annterm = Bio::Annotation::OntologyTerm->new(); $annterm->term($sts); $self->{_ann}->add_Annotation( 'OntologyTerm', $annterm ); } } sub _process_go { my $self = shift; my $comm = shift; my @comm; push @comm, ( ref($comm) eq 'ARRAY' ) ? @{$comm} : $comm; foreach my $comp (@comm) { my $category = $comp->{label}; if ( ref( $comp->{comment} ) eq 'ARRAY' ) { foreach my $go ( @{ $comp->{comment} } ) { my $term = _get_go_term( $go, $category ); my $annterm = Bio::Annotation::OntologyTerm->new( -tagname => 'Gene Ontology' ); $annterm->term($term); $self->{_ann}->add_Annotation( 'OntologyTerm', $annterm ); } } else { my $term = _get_go_term( $comp->{comment}, $category ); my $annterm = Bio::Annotation::OntologyTerm->new( -tagname => 'Gene Ontology' ); $annterm->term($term); $self->{_ann}->add_Annotation( 'OntologyTerm', $annterm ); } } } sub _process_grif { my $self = shift; my $grif = shift; if ( ( exists( $grif->{comment} ) ) && ( ref( $grif->{comment} ) eq 'ARRAY' ) ) { my @uncapt; foreach my $product ( @{ $grif->{comment} } ) { next unless ( exists( $product->{text} ) ); my $uproduct = $self->_process_grif($product); #$self->{_ann->add_Annotation($type,$grifobj); push @uncapt, $uproduct; } return \@uncapt; } if ( exists( $grif->{comment}->{comment} ) ) { $grif = $grif->{comment}; } my $ref = ( ref( $grif->{refs} ) eq 'ARRAY' ) ? shift @{ $grif->{refs} } : $grif->{refs}; my $refergene = ''; my $refdb = ''; my ( $obj, $type ); if ( $ref->{pmid} ) { if ( exists( $grif->{source} ) ) { #unfortunatrely we cannot put yet everything in $refergene = $grif->{source}->{src}->{tag}->{id}; $refdb = $grif->{source}->{src}->{db}; } my $grifobj = Bio::Annotation::Comment->new( -text => $grif->{text} ); $obj = Bio::Annotation::DBLink->new( -database => 'generif', -primary_id => $ref->{pmid} , #The pubmed id (at least the first one) which is a base for the conclusion -version => $grif->{version}, -optional_id => $refergene, -authority => $refdb ); $obj->comment($grifobj); $type = 'dblink'; } else { $obj = Bio::Annotation::SimpleValue->new( $grif->{text}, 'generif' ); $type = 'generif'; } delete $grif->{text}; delete $grif->{version}; delete $grif->{type}; delete $grif->{refs}; $self->{_ann}->add_Annotation( $type, $obj ); return $grif; } sub _get_go_term { my $go = shift; my $category = shift; my $refan = Bio::Annotation::Reference->new( #We expect one ref per GO -medline => $go->{refs}->{pmid}, -title => 'no title' ); my $term = Bio::Ontology::Term->new( -identifier => $go->{source}->{src}->{tag}->{id}, -name => $go->{source}->{anchor}, -definition => $go->{source}->{anchor}, -comment => $go->{source}->{'post-text'}, -version => $go->{version} ); $term->add_reference($refan); $term->namespace($category); return $term; } sub _backcomp_ll { my $ann = shift; my $newann = Bio::Annotation::Collection->new(); #$newann->{_annotation}->{ALIAS_SYMBOL}=$ann->{_annotation}->{ALIAS_SYMBOL}; # $newann->{_annotation}->{CHR}=$ann->{_annotation}->{chromosome}; # $newann->{_annotation}->{MAP}=$ann->{_annotation}->{cyto}; foreach my $tagmap ( keys %{ $ann->{_typemap}->{_type} } ) { next if ( grep( /$tagmap/, @main::egonly ) ); $newann->{_annotation}->{$tagmap} = $ann->{_annotation}->{$tagmap}; } #$newann->{_annotation}->{Reference}=$ann->{_annotation}->{Reference}; #$newann->{_annotation}->{generif}=$ann->{_annotation}->{generif}; #$newann->{_annotation}->{comment}=$ann->{_annotation}->{comment}; # $newann->{_annotation}->{OFFICIAL_GENE_NAME}=$ann->{_annotation}->{'Official Full Name'}; $newann->{_typemap}->{_type} = $ann->{_typemap}->{_type}; foreach my $ftype ( keys %main::eg_to_ll ) { my $newkey = $main::eg_to_ll{$ftype}; $newann->{_annotation}->{$newkey} = $ann->{_annotation}->{$ftype}; $newann->{_typemap}->{_type}->{$newkey} = 'Bio::Annotation::SimpleValue'; delete $newann->{_typemap}->{_type}->{$ftype}; $newann->{_annotation}->{$newkey}->[0]->{tagname} = $newkey; } foreach my $dblink ( @{ $newann->{_annotation}->{dblink} } ) { next unless ( $dblink->{_url} ); my $simann = Bio::Annotation::SimpleValue->new( -value => $dblink->{_url}, -tagname => 'URL' ); $newann->add_Annotation($simann); } # my $simann=Bio::Annotation::SimpleValue->new(-value=>$seq->desc,-tagname=>'comment'); # $newann->add_Annotation($simann); return $newann; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/excel.pm������������������������������������������������������������������000444��000765��000024�� 20306�12254227314� 16606� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::excel # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp at gmx.net> # # # (c) Hilmar Lapp, hlapp at gmx.net, 2005. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2005. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::excel - sequence input/output stream from a MSExcel-formatted table =head1 SYNOPSIS #It is probably best not to use this object directly, but #rather go through the SeqIO handler system. Go: $stream = Bio::SeqIO->new(-file => $filename, -format => 'excel'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This class transforms records in a MS Excel workbook file into Bio::Seq objects. It is derived from the table format module and merely defines additional properties and overrides the way to get data from the file and advance to the next record. The module permits specifying which columns hold which type of annotation. The semantics of certain attributes, if present, are pre-defined, e.g., accession number and sequence. Additional attributes may be added to the annotation bundle. See L<Bio::SeqIO::table> for a complete list of parameters and capabilities. You may also specify the worksheet from which to obtain the data, and after finishing one worksheet you may change the name to keep reading from another worksheet (in the same file). This module depends on Spreadsheet::ParseExcel to parse the underlying Excel file. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::excel; use strict; use Bio::SeqIO; use Spreadsheet::ParseExcel; #use Spreadsheet::ParseExcel::Workbook; use base qw(Bio::SeqIO::table); =head2 new Title : new Usage : $stream = Bio::SeqIO->new(-file => $filename, -format => 'excel') Function: Returns a new seqstream Returns : A Bio::SeqIO stream for a MS Excel format Args : Supports the same named parameters as Bio::SeqIO::table, except -delim, which obviously does not apply to a binary format. In addition, the following parameters are supported. -worksheet the name of the worksheet holding the table; if unspecified the first worksheet will be used =cut sub _initialize { my($self,@args) = @_; # chained initialization $self->SUPER::_initialize(@args); # our own parameters my ($worksheet) = $self->_rearrange([qw(WORKSHEET)], @args); # store options and apply defaults $self->worksheet($worksheet || 0); } =head2 worksheet Title : worksheet Usage : $obj->worksheet($newval) Function: Get/set the name of the worksheet holding the table. The worksheet name may also be a numeric index. You may change the value during parsing at any time in order to start reading from a different worksheet (in the same file). Example : Returns : value of worksheet (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub worksheet{ my $self = shift; if (@_) { my $sheetname = shift; # on set we reset the parser here in order to allow reading # from multiple worksheets in a row $self->_worksheet(undef) if defined($sheetname); return $self->{'worksheet'} = $sheetname; } return $self->{'worksheet'}; } =head2 close Title : close Usage : Function: Close and/or release the resources used by this parser instance. We override this here in order to free up the worksheet and other related objects. Example : Returns : Args : =cut sub close{ my $self = shift; $self->_worksheet(undef); # make sure we chain to the inherited method $self->SUPER::close(@_); } =head1 Internal methods All methods with a leading underscore are not meant to be part of the 'official' API. They are for use by this module only, consider them private unless you are a developer trying to modify this module. =cut =head2 _worksheet Title : _worksheet Usage : $obj->_worksheet($newval) Function: Get/set the worksheet object to be used for accessing cells. Example : Returns : value of _worksheet (a Spreadsheet::ParseExcel::Worksheet object) Args : on set, new value (a Spreadsheet::ParseExcel::Worksheet object or undef, optional) =cut sub _worksheet{ my $self = shift; return $self->{'_worksheet'} = shift if @_; return $self->{'_worksheet'}; } =head2 _next_record Title : _next_record Usage : Function: Navigates the underlying file to the next record. We override this here in order to adapt navigation to data in an Excel worksheet. Example : Returns : TRUE if the navigation was successful and FALSE otherwise. Unsuccessful navigation will usually be treated as an end-of-file condition. Args : =cut sub _next_record{ my $self = shift; my $wsheet = $self->_worksheet(); if (! defined($wsheet)) { # worksheet hasn't been initialized yet, do so now my $wbook = Spreadsheet::ParseExcel::Workbook->Parse($self->_fh); $wsheet = $wbook->Worksheet($self->worksheet); # store the result $self->_worksheet($wsheet); # re-initialize the current row $self->{'_row'} = -1; } # we need a valid worksheet to continue return unless defined($wsheet); # check whether we are at or beyond the last defined row my ($minrow, $maxrow) = $wsheet->RowRange(); return if $self->{'_row'} >= $maxrow; # we don't check for empty rows here as in order to do that we'd # have to know in which column to look # so, just advance to the next row $self->{'_row'}++; # done return 1; } =head2 _get_row_values Title : _get_row_values Usage : Function: Get the values for the current line (or row) as an array in the order of columns. We override this here in order to adapt access to column values to data contained in an Excel worksheet. Example : Returns : An array of column values for the current row. Args : =cut sub _get_row_values{ my $self = shift; # obtain the range of columns - we use all that are defined my $wsheet = $self->_worksheet(); my ($colmin,$colmax) = $wsheet->ColRange(); # build the array of columns for the current row my @cols = (); my $row = $self->{'_row'}; for (my $i = $colmin; $i <= $colmax; $i++) { my $cell = $wsheet->Cell($row, $i); push(@cols, defined($cell) ? $cell->Value : $cell); } # done return @cols; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/exp.pm��������������������������������������������������������������������000444��000765��000024�� 6724�12254227326� 16275� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::exp # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::exp - exp trace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from exp trace files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Aaron Mackey Email: amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::exp; use vars qw(@ISA $READ_AVAIL); use strict; use Bio::SeqIO; use Bio::Seq::SeqFactory; push @ISA, qw( Bio::SeqIO ); sub BEGIN { eval { require Bio::SeqIO::staden::read; }; if ($@) { $READ_AVAIL = 0; } else { push @ISA, "Bio::SeqIO::staden::read"; $READ_AVAIL = 1; } } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } unless ($READ_AVAIL) { Bio::Root::Root->throw( -class => 'Bio::Root::SystemException', -text => "Bio::SeqIO::staden::read is not available; make sure the bioperl-ext package has been installed successfully!" ); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self) = @_; my ($seq, $id, $desc, $qual) = $self->read_trace($self->_fh, 'exp'); # create the seq object $seq = $self->sequence_factory->create(-seq => $seq, -id => $id, -primary_id => $id, -desc => $desc, -alphabet => 'DNA', -qual => $qual ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh; foreach my $seq (@seq) { $self->write_trace($fh, $seq, 'exp'); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ��������������������������������������������BioPerl-1.6.923/Bio/SeqIO/fasta.pm������������������������������������������������������������������000444��000765��000024�� 24361�12254227317� 16614� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::fasta # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # and Lincoln Stein <lstein@cshl.org> # # Copyright Ewan Birney & Lincoln Stein # # You may distribute this module under the same terms as perl itself # _history # October 18, 1999 Largely rewritten by Lincoln Stein # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::fasta - fasta sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from fasta flat file databases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Ewan Birney & Lincoln Stein Email: birney@ebi.ac.uk lstein@cshl.org =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::fasta; use strict; use warnings; use Bio::Seq::SeqFastaSpeedFactory; use parent qw(Bio::SeqIO); sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize(@args); ## Initialize fasta specific parameters ## There are some problems with _rearrange. If there's no value for one of ## the parameters, it will return an empty value (not undef). This means we ## can't just merge two hashes since the empty values would override the ## defaults anyway. my (%defs) = ( "width" => 60, "block" => "", # default is same as width "preferred_id_type" => "display", ); foreach my $param (keys %defs) { $self->$param( $self->_rearrange([$param], @args) || $defs{$param}); } unless ( defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFastaSpeedFactory->new()); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object, or nothing if no more available Args : NONE =cut sub next_seq { my( $self ) = @_; my $seq; my $alphabet; local $/ = "\n>"; return unless my $entry = $self->_readline; # Replacing chomp for s///, since chomp is not working in some cases $entry =~ s/\n$//; $entry =~ s/\r$//; if ($entry =~ m/\A\s*\Z/s) { # very first one return unless $entry = $self->_readline; chomp($entry); } # this just checks the initial input; beyond that, due to setting $/ above, # the > is part of the record separator and is removed $self->throw("The sequence does not appear to be FASTA format ". "(lacks a descriptor line '>')") if $. == 1 && $entry !~ /^>/; $entry =~ s/^>//; my ($top,$sequence) = split(/\n/,$entry,2); defined $sequence && $sequence =~ s/>//g; #my ($top,$sequence) = $entry =~ /^>?(.+?)\n+([^>]*)/s # or $self->throw("Can't parse fasta entry"); my ($id,$fulldesc); if( $top =~ /^\s*(\S+)\s*(.*)/ ) { ($id,$fulldesc) = ($1,$2); } if (defined $id && $id eq '') {$id=$fulldesc;} # FIX incase no space # between > and name \AE defined $sequence && $sequence =~ tr/ \t\n\r//d; # Remove whitespace # for empty sequences we need to know the mol.type $alphabet = $self->alphabet(); if(defined $sequence && length($sequence) == 0) { if(! defined($alphabet)) { # let's default to dna $alphabet = "dna"; } }# else { # we don't need it really, so disable # we want to keep this if SeqIO alphabet was set by user # not sure if this could break something #$alphabet = undef; #} $seq = $self->sequence_factory->create( -seq => $sequence, -id => $id, # Ewan's note - I don't think this healthy # but obviously to taste. #-primary_id => $id, -desc => $fulldesc, -alphabet => $alphabet, -direct => 1, ); # if there wasn't one before, set the guessed type #unless ( defined $alphabet ) { # don't assume that all our seqs are the same as the first one found #$self->alphabet($seq->alphabet()); #} return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: Writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Array of 1 or more Bio::PrimarySeqI objects =cut sub write_seq { my ($self,@seq) = @_; my $width = $self->width; my $block = $self->block; ## take a reference for single string (the sequence) and add the whitespace local *format_str = sub { my $str = $_[0]; my @lines = unpack ("(A$width)*", $$str); if ($block >= $width) { $$str = join ("\n", @lines)."\n"; } else { $$str = ""; $$str .= join (" ", unpack ("(A$block)*", $_)) . "\n" foreach (@lines); } }; foreach my $seq (@seq) { $self->throw("Did not provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); # Allow for different ids my $top; my $id_type = $self->preferred_id_type; if( $id_type =~ /^acc/i ) { $top = $seq->accession_number(); if( $id_type =~ /vers/i ) { $top .= "." . $seq->version(); } } elsif($id_type =~ /^displ/i ) { $self->warn("No whitespace allowed in FASTA ID [". $seq->display_id. "]") if defined $seq->display_id && $seq->display_id =~ /\s/; $top = $seq->display_id(); $top = '' unless defined $top; $self->warn("No whitespace allowed in FASTA ID [". $top. "]") if defined $top && $top =~ /\s/; } elsif($id_type =~ /^pri/i ) { $top = $seq->primary_id(); } if ($seq->can('desc') and my $desc = $seq->desc()) { $desc =~ s/\n//g; $top .= " $desc"; } if( $seq->isa('Bio::Seq::LargeSeqI') ) { $self->_print(">$top\n"); # for large seqs, don't call seq(), it defeats the # purpose of the largeseq functionality. instead get # chunks of the seq, $width at a time my $buff_max = 2000; my $buff_size = int($buff_max/$width)*$width; #< buffer is even multiple of widths my $seq_length = $seq->length; my $num_chunks = int($seq_length/$buff_size+1); for( my $c = 0; $c < $num_chunks; $c++ ) { my $buff_end = $buff_size*($c+1); $buff_end = $seq_length if $buff_end > $seq_length; my $buff = $seq->subseq($buff_size*$c+1,$buff_end); if($buff) { format_str (\$buff); $self->_print($buff); } else { $self->_print("\n"); } } } else { my $str = $seq->seq; if(defined $str && length($str) > 0) { format_str (\$str); } else { $str = "\n"; } $self->_print (">",$top,"\n",$str) or return; } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 width Title : width Usage : $obj->width($newval) Function: Get/Set the line width for FASTA output (not counting whitespace). Returns : value of width Args : newvalue (optional) =cut sub width { my ($self,$value) = @_; if (defined $value) { $self->{'width'} = $value; } return $self->{'width'}; } =head2 block Title : block Usage : $obj->block($newval) Function: Get/Set the length of each block for FASTA output. Sequence blocks will be split with a space. Configuring block, to a value of 10 for example, allows to easily indentify a position in a sequence by eye. Default : same value used for width. Returns : value of block Args : newvalue (optional) =cut sub block { my ($self,$value) = @_; if (defined $value) { $self->{'block'} = $value; } return $self->{'block'} || $self->width; } =head2 preferred_id_type Title : preferred_id_type Usage : $obj->preferred_id_type('accession') Function: Get/Set the preferred type of identifier to use in the ">ID" position for FASTA output. Returns : string, one of values defined in @Bio::SeqIO::fasta::SEQ_ID_TYPES. Default : display Args : string when setting. This must be one of values defined in @Bio::SeqIO::fasta::SEQ_ID_TYPES. Allowable values: accession, accession.version, display, primary Throws : fatal exception if the supplied id type is not in @SEQ_ID_TYPES. =cut our @SEQ_ID_TYPES = qw(accession accession.version display primary); sub preferred_id_type { my ($self,$type) = @_; if (defined $type) { if( ! grep lc($type) eq $_, @SEQ_ID_TYPES) { $self->throw(-class=>'Bio::Root::BadParameter', -text=>"Invalid ID type \"$type\". Must be one of: @SEQ_ID_TYPES"); } $self->{'_seq_id_type'} = lc($type); } $self->{'_seq_id_type'}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/fastq.pm������������������������������������������������������������������000444��000765��000024�� 43434�12254227321� 16631� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# POD at __END__, let the code begin... package Bio::SeqIO::fastq; use strict; use Bio::Seq::SeqFactory; use base qw(Bio::SeqIO); our %variant = ( sanger => { 'offset' => 33, 'qual_start' => 0, 'qual_end' => 93 }, solexa => { 'offset' => 64, 'qual_start' => -5, 'qual_end' => 62 }, illumina => { 'offset' => 64, 'qual_start' => 0, 'qual_end' => 62 }, ); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($variant, $validate, $header) = $self->_rearrange([qw(VARIANT VALIDATE QUALITY_HEADER)], @args); $variant ||= 'sanger'; $self->variant($variant); $self->_init_tables($variant); $validate = defined $validate ? $validate : 1; $self->validate($validate); $header && $self->quality_header($header); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new( -verbose => $self->verbose(), -type => 'Bio::Seq::Quality') ); } } sub next_seq { my( $self ) = @_; while (defined(my $data = $self->next_dataset)) { # Are FASTQ sequences w/o any sequence valid? Removing for now # -cjfields 6.22.09 my $seq = $self->sequence_factory->create(%$data); return $seq; } return; } # pure perl version sub next_dataset { my $self = shift; local $/ = "\n"; my $data; my $mode = '-seq'; # speed this up by directly accessing the filehandle and in-lining the # _readline stuff vs. making the repeated method calls. Tradeoff is speed # over repeated code. # we can probably normalize line endings using PerlIO::eol or # Encode::Newlines my $fh = $self->_fh; my $line = $self->{lastline} || <$fh>; FASTQ: while (defined $line) { $line =~ s/\015\012/\012/; $line =~ tr/\015/\n/; if ($mode eq '-seq' && $line =~ m{^@([^\n]+)$}xmso) { $data->{-descriptor} = $1; my ($id,$fulldesc); if ($data->{-descriptor} =~ /^\s*(\S+)\s*(.*)/) { ($id,$fulldesc) = ($1, $2); } else { $self->throw("Can't parse fastq header"); } $data->{-id} = $id; $data->{-desc} = $fulldesc; $data->{-namespace} = $self->variant; } elsif ($mode eq '-seq' && $line =~ m{^\+([^\n]*)}xmso) { my $desc = $1; $self->throw("No description line parsed") unless $data->{-descriptor}; if ($desc && $data->{-descriptor} ne $desc) { $self->throw("Quality descriptor [$desc] doesn't match seq ". "descriptor ".$data->{-descriptor}.", line: $." ); } $mode = '-raw_quality'; } else { if ($mode eq '-raw_quality' && defined($data->{-raw_quality}) && (length($data->{-raw_quality}) >= length($data->{-seq}))) { $self->{lastline} = $line; last FASTQ } chomp $line; if ($line =~ /^$/) { delete $self->{lastline}; last FASTQ; } $data->{$mode} .= $line } $line = <$fh>; if (!defined $line) { delete $self->{lastline}; last FASTQ; } } return unless $data; if (!$data->{-seq} || !defined($data->{-raw_quality})) { $self->throw("Missing sequence and/or quality data; line: $."); } # simple quality control tests if (length $data->{-seq} != length $data->{-raw_quality}) { $self->throw("Quality string [".$data->{-raw_quality}."] of length [". length($data->{-raw_quality})."]\ndoesn't match length of sequence ". $data->{-seq}."\n[".length($data->{-seq})."], line: $."); } $data->{-qual} = [map { if ($self->{_validate_qual} && !exists($self->{chr2qual}->{$_})) { $self->throw("Unknown symbol with ASCII value ".ord($_)." outside ". "of quality range") # TODO: fallback? } $self->variant eq 'solexa' ? $self->{sol2phred}->{$self->{chr2qual}->{$_}}: $self->{chr2qual}->{$_}; } unpack("A1" x length($data->{-raw_quality}), $data->{-raw_quality})]; return $data; } # This should be creating fastq output only. Bio::SeqIO::fasta and # Bio::SeqIO::qual should be used for that output sub write_seq { my ($self,@seq) = @_; my $var = $self->variant; foreach my $seq (@seq) { unless ($seq->isa("Bio::Seq::Quality")){ $self->warn("You can't write FASTQ without supplying a Bio::Seq::". "Quality object! ".ref($seq)."\n"); next; } my $str = $seq->seq || ''; my @qual = @{$seq->qual}; # this should be the origin of the sequence (illumina, solexa, sanger) my $ns= $seq->namespace; my $top = $seq->display_id(); if (my $desc = $seq->desc()) { $desc =~ s/\n//g; $top .= " $desc"; } my $qual = ''; my $qual_map = ($ns eq 'solexa' && $var eq 'solexa') ? $self->{phred_fp2chr} : ($var eq 'solexa') ? $self->{phred_int2chr} : $self->{qual2chr}; my %bad_qual; for my $q (@qual) { $q = sprintf("%.0f", $q) if ($var ne 'solexa' && $ns eq 'solexa'); if (exists $qual_map->{$q}) { $qual .= $qual_map->{$q}; next; } else { # fuzzy mapping, for edited qual scores my $qr = sprintf("%.0f",$q); my $bounds = sprintf("%.1f-%.1f",$qr-0.5, $qr+0.5); if (exists $self->{fuzzy_qual2chr}->{$bounds}) { $qual .= $self->{fuzzy_qual2chr}->{$bounds}; next; } else { my $rep = ($q <= $self->{qual_start}) ? $qual_map->{$self->{qual_start}} : $qual_map->{$self->{qual_end}}; $qual .= $rep; $bad_qual{$q}++; } } } if ($self->{_validate_qual} && %bad_qual) { $self->warn("Data loss for $var: following values not found\n". join(',',sort {$a <=> $b} keys %bad_qual)) } $self->_print("\@",$top,"\n",$str,"\n") or return; $self->_print("+",($self->{_quality_header} ? $top : ''),"\n",$qual,"\n") or return; } return 1; } sub write_fastq { my ($self,@seq) = @_; return $self->write_seq(@seq); } sub write_fasta { my ($self,@seq) = @_; if (!exists($self->{fasta_proxy})) { $self->{fasta_proxy} = Bio::SeqIO->new(-format => 'fasta', -fh => $self->_fh); } return $self->{fasta_proxy}->write_seq(@seq); } sub write_qual { my ($self,@seq) = @_; if (!exists($self->{qual_proxy})) { $self->{qual_proxy} = Bio::SeqIO->new(-format => 'qual', -fh => $self->_fh); } return $self->{qual_proxy}->write_seq(@seq); } # variant() method inherited from Bio::Root::IO sub _init_tables { my ($self, $var) = @_; # cache encode/decode values for quicker accession ($self->{qual_start}, $self->{qual_end}, $self->{qual_offset}) = @{ $variant{$var} }{qw(qual_start qual_end offset)}; if ($var eq 'solexa') { for my $q ($self->{qual_start} .. $self->{qual_end}) { my $char = chr($q + $self->{qual_offset}); $self->{chr2qual}->{$char} = $q; $self->{qual2chr}->{$q} = $char; my $s2p = 10 * log(1 + 10 ** ($q / 10.0)) / log(10); # solexa <=> solexa mapping speedup (retain floating pt precision) $self->{phred_fp2chr}->{$s2p} = $char; $self->{sol2phred}->{$q} = $s2p; # this is for mapping values fuzzily (fallback) $self->{fuzzy_qual2chr}->{sprintf("%.1f-%.1f",$q - 0.5, $q + 0.5)} = $char; next if $q < 0; # skip loop; PHRED scores greater than 0 my $p2s = sprintf("%.0f",($q <= 1) ? -5 : 10 * log(-1 + 10 ** ($q / 10.0)) / log(10)); # sanger/illumina PHRED <=> Solexa char mapping speedup $self->{phred_int2chr}->{$q} = chr($p2s + $self->{qual_offset}); } } else { for my $c ($self->{qual_start}..$self->{qual_end}) { # PHRED mapping my $char = chr($c + $self->{qual_offset}); $self->{chr2qual}->{$char} = $c; $self->{qual2chr}->{$c} = $char; # this is for mapping values not found with above $self->{fuzzy_qual2chr}->{sprintf("%.1f-%.1f",$c - 0.5, $c + 0.5)} = $char; } } } sub validate { my ($self, $val) = @_; if (defined $val) { $self->{_validate_qual} = $val; } return $self->{_validate_qual}; } sub quality_header{ my ($self, $val) = @_; if (defined $val) { $self->{_quality_header} = $val; } return $self->{_quality_header} || 0; } 1; __END__ # BioPerl module for Bio::SeqIO::fastq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for Chris Fields # # Completely refactored from the original FASTQ parser # by Tony Cox <avc@sanger.ac.uk> # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # # _history # # October 29, 2001 incept data (Tony Cox) # June 20, 2009 updates for Illumina variant FASTQ formats for Solexa and later # Aug 26, 2009 fixed bugs and added tests for fastq.t # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::fastq - fastq sequence input/output stream =head1 SYNOPSIS ################## pertains to FASTQ parsing only ################## # grabs the FASTQ parser, specifies the Illumina variant my $in = Bio::SeqIO->new(-format => 'fastq-illumina', -file => 'mydata.fq'); # simple 'fastq' format defaults to 'sanger' variant my $out = Bio::SeqIO->new(-format => 'fastq', -file => '>mydata.fq'); # $seq is a Bio::Seq::Quality object while (my $seq = $in->next_seq) { $out->write_seq($seq); # convert Illumina 1.3 to Sanger format } # for 4x faster parsing, one can do something like this for raw data use Bio::Seq::Quality; # $data is a hash reference containing all arguments to be passed to # the Bio::Seq::Quality constructor while (my $data = $in->next_dataset) { # process $data, such as trim, etc my $seq = Bio::Seq::Quality->new(%$data); # for now, write_seq only accepts Bio::Seq::Quality, but may be modified # to allow raw hash references for speed $out->write_seq($data); } =head1 DESCRIPTION This object can transform Bio::Seq and Bio::Seq::Quality objects to and from FASTQ flat file databases. FASTQ is a file format used frequently at the Sanger Centre and in next-gen sequencing to bundle a FASTA sequence and its quality data. A typical FASTQ entry takes the form: @HCDPQ1D0501 GATTTGGGGTTCAAAGCAGTATCGATCAAATAGTAAATCCATTTGTTCAACTCACAGTTT..... +HCDPQ1D0501 !''*((((***+))%%%++)(%%%%).1***-+*''))**55CCF>>>>>>CCCCCCC65..... where: @ = descriptor, followed by one or more sequence lines + = optional descriptor (if present, must match first one), followed by one or more qual lines When writing FASTQ output the redundant descriptor following the '+' is by default left off to save disk space. If needed, one can set the quality_header() flag in order for this to be printed. =head2 FASTQ and Bio::Seq::Quality mapping FASTQ files have sequence and quality data on single line or multiple lines, and the quality values are single-byte encoded. Data are mapped very simply to Bio::Seq::Quality instances: Data Bio::Seq::Quality method ------------------------------------------------------------------------ first non-whitespace chars in descriptor id^ descriptor line desc^ sequence lines seq quality qual* FASTQ variant namespace ^ first nonwhitespace chars are id(), everything else after (to end of line) is in desc() * Converted to PHRED quality scores where applicable ('solexa') =head2 FASTQ variants This parser supports all variants of FASTQ, including Illumina v 1.0 and 1.3: variant note ----------------------------------------------------------- sanger original solexa Solexa, Inc. (2004), aka Illumina 1.0 illumina Illumina 1.3 The variant can be specified by passing by either passing the additional -variant parameter to the constructor: my $in = Bio::SeqIO->new(-format => 'fastq', -variant => 'solexa', -file => 'mysol.fq'); or by passing the format and variant together (Bio::SeqIO will now handle this and convert it accordingly to the proper argument): my $in = Bio::SeqIO->new(-format => 'fastq-solexa', -file => 'mysol.fq'); Variants can be converted back and forth from one another; however, due to the difference in scaling for solexa quality reads, converting from 'illumina' or 'sanger' FASTQ to solexa is not recommended. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Chris Fields (taken over from Tony Cox) Email: cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =head1 Bio::SeqIO interface methods =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function : returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE Status : Stable =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function : writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq::Quality Note : This now conforms to SeqIO spec (module output is same format as next_seq) Status : Stable =head2 variant Title : variant Usage : $format = $obj->variant(); Function: Get and set method for the quality sequence variant. This is important for indicating the encoding/decoding to be used for quality data. Current values accepted are: 'sanger' (orginal FASTQ) ASCII encoding from 33-126, PHRED quality score from 0 to 93 'solexa' (aka illumina1.0) ASCII encoding from 59-104, SOLEXA quality score from -5 to 40 'illumina' (aka illumina1.3) ASCII encoding from 64-104, PHRED quality score from 0 to 40 (Derived from the MAQ website): For 'solexa', scores are converted to PHRED qual scores using: $Q = 10 * log(1 + 10 ** (ord($sq) - 64) / 10.0)) / log(10) Returns : string Args : new value, string =head1 Plugin-specific methods =head2 next_dataset Title : next_dataset Usage : $obj->next_dataset Function : returns a hash reference containing the parsed data Returns : hash reference Args : none Status : Stable =head2 write_fastq Title : write_fastq Usage : $stream->write_fastq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq::Quality object Status : Deprecated (delegates to write_seq) =head2 write_fasta Title : write_fasta Usage : $stream->write_fasta(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object Note : This method does not currently delegate to Bio::SeqIO::fasta (maybe it should?). Not sure whether we should keep this as a convenience method. Status : Unstable =head2 write_qual Title : write_qual Usage : $stream->write_qual(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq::Quality object Note : This method does not currently delegate to Bio::SeqIO::qual (maybe it should?). Not sure whether we should keep this as a convenience method. Status : Unstable =head2 validate Title : validate Usage : $obj->validate(0) Function : flag for format/qual range validation - default is 1, validate Returns : Bool (0/1) Args : Bool (0/1) Status : Stable (may be moved to interface) =head2 quality_header Title : quality_header Usage : $obj->quality_header Function : flag for printing quality header - default is 0, no header Returns : Bool (0/1) Args : Bool (0/1) Status : Unstable (name may change dep. on feedback) =cut ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/flybase_chadoxml.pm�������������������������������������������������������000444��000765��000024�� 10766�12254227322� 21022� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::flybase_chadoxml # # Peili Zhang <peili@morgan.harvard.edu> # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::flybase_chadoxml - FlyBase variant of chadoxml with sequence output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system: $writer = Bio::SeqIO->new(-file => ">chado.xml", -format => 'flybase_chadoxml'); # assume you already have Sequence or SeqFeature objects $writer->write_seq($seq_obj); #after writing all seqs $writer->close_chadoxml(); =head1 DESCRIPTION This is a simple subclass of L<Bio::SeqIO::chadoxml>; please see its documentation for details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peili Zhang Email peili@morgan.harvard.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::flybase_chadoxml; use strict; use base 'Bio::SeqIO::chadoxml'; sub _initialize { my($self,%args) = @_; $self->SUPER::_initialize(%args); #default for standard chado is polypeptide $Bio::SeqIO::chadoxml::feattype_args2so{'CDS'} = 'protein'; $Bio::SeqIO::chadoxml::cv_name{'sequence'} = 'SO'; $Bio::SeqIO::chadoxml::cv_name{'relationship'} = 'relationship type'; $Bio::SeqIO::chadoxml::cv_name{'feature_property'} = 'property type'; return; } =head2 return_ftype_hash Title : return_ftype_hash Usage : $obj->return_ftype_hash() Function : A simple hash where returning it has be factored out of the main code to allow subclasses to override it. Returns : A hash that indicates what the name of the SO term is and what the name of the Sequence Ontology is in the cv table. Args : The string that represents the SO term. Status : =cut sub return_ftype_hash { my $self = shift; my $ftype = shift; my %ftype_hash = ( "name" => $ftype, "cv_id" => {"name" => $Bio::SeqIO::chadoxml::cv_name{'sequence'} }); return %ftype_hash; } =head2 return_reltypename Title : return_reltypename Usage : $obj->return_reltypename Function : Return the appropriate relationship type name depending on the feature type (typically part_of, but derives_from for polypeptide). Returns : A relationship type name. Args : A SO type name. Status : =cut sub return_reltypename { my $self = shift; my $sftype = shift; my $reltypename; if ($sftype eq 'protein' || $sftype eq 'polypeptide') { $reltypename = 'producedby'; } else { $reltypename = 'partof'; } return $reltypename; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(-seq=>$seq, -seq_so_type=>$seqSOtype, -src_feature=>$srcfeature, -src_feat_type=>$srcfeattype, -nounflatten=>0 or 1, -is_analysis=>'true' or 'false', -data_source=>$datasource) Function: writes the $seq object (must be seq) into chadoxml. Returns : 1 for success and 0 for error Args : A Bio::Seq object $seq, optional $seqSOtype, $srcfeature, $srcfeattype, $nounflatten, $is_analysis and $data_source. Overrides Bio::SeqIO::chadoxml's write_seq method just to add an internal close_chadoxml (mimics original use by FlyBase). =cut sub write_seq { my ($self, @argv) = @_; $self->SUPER::write_seq(@argv); $self->close_chadoxml; return 1; } 1; ����������BioPerl-1.6.923/Bio/SeqIO/FTHelper.pm���������������������������������������������������������������000444��000765��000024�� 16653�12254227337� 17176� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::FTHelper # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::FTHelper - Helper class for Embl/Genbank feature tables =head1 SYNOPSIS Used by Bio::SeqIO::EMBL,Bio::SeqIO::genbank, and Bio::SeqIO::swiss to help process the Feature Table =head1 DESCRIPTION Represents one particular Feature with the following fields key - the key of the feature loc - the location string of the feature <other fields> - other fields =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 CONTRIBUTORS Jason Stajich jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::FTHelper; use strict; use Bio::SeqFeature::Generic; use Bio::Location::Simple; use Bio::Location::Fuzzy; use Bio::Location::Split; use base qw(Bio::Root::Root); sub new { my ($class, @args) = @_; # no chained new because we make lots and lots of these. my $self = {}; bless $self,$class; $self->{'_field'} = {}; return $self; } =head2 _generic_seqfeature Title : _generic_seqfeature Usage : $fthelper->_generic_seqfeature($annseq, "GenBank") Function: processes fthelper into a generic seqfeature Returns : TRUE on success and otherwise FALSE Args : The Bio::Factory::LocationFactoryI object to use for parsing location strings. The ID (e.g., display_id) of the sequence on which this feature is located, optionally a string indicating the source (GenBank/EMBL/SwissProt) =cut sub _generic_seqfeature { my ($fth, $locfac, $seqid, $source) = @_; my ($sf); # set a default if not specified if(! defined($source)) { $source = "EMBL/GenBank/SwissProt"; } # initialize feature object $sf = Bio::SeqFeature::Generic->direct_new(); # parse location; this may cause an exception, in which case we gently # recover and ignore this feature my $loc; eval { $loc = $locfac->from_string($fth->loc); }; if(! $loc) { $fth->warn("exception while parsing location line [" . $fth->loc . "] in reading $source, ignoring feature " . $fth->key() . " (seqid=" . $seqid . "): " . $@); return; } # set additional location attributes if($seqid && (! $loc->is_remote())) { $loc->seq_id($seqid); # propagates if it is a split location } # set attributes of feature $sf->location($loc); $sf->primary_tag($fth->key); $sf->source_tag($source); $sf->seq_id($seqid); foreach my $key ( keys %{$fth->field} ){ foreach my $value ( @{$fth->field->{$key}} ) { $sf->add_tag_value($key,$value); } } return $sf; } =head2 from_SeqFeature Title : from_SeqFeature Usage : @fthelperlist = Bio::SeqIO::FTHelper::from_SeqFeature($sf, $context_annseq); Function: constructor of fthelpers from SeqFeatures : : The additional annseq argument is to allow the building of FTHelper : lines relevant to particular sequences (ie, when features are spread over : enteries, knowing how to build this) Returns : an array of FThelpers Args : seq features =cut sub from_SeqFeature { my ($sf, $context_annseq) = @_; my @ret; # # If this object knows how to make FThelpers, then let it # - this allows us to store *really* weird objects that can write # themselves to the EMBL/GenBank... # if ( $sf->can("to_FTHelper") ) { return $sf->to_FTHelper($context_annseq); } my $fth = Bio::SeqIO::FTHelper->new(); my $key = $sf->primary_tag(); my $locstr = $sf->location->to_FTstring; # ES 25/06/01 Commented out this code, Jason to double check #The location FT string for all simple subseqfeatures is already #in the Split location FT string # going into sub features #foreach my $sub ( $sf->sub_SeqFeature() ) { #my @subfth = &Bio::SeqIO::FTHelper::from_SeqFeature($sub); #push(@ret, @subfth); #} $fth->loc($locstr); $fth->key($key); $fth->field->{'note'} = []; # the lines below take specific tags (e.g. /score=23 ) and re-enter them as # new tags like /note="score=25" - if the file is round-tripped this creates # duplicate values #$sf->source_tag && do { push(@{$fth->field->{'note'}},"source=" . $sf->source_tag ); }; #($sf->can('score') && $sf->score) && do { push(@{$fth->field->{'note'}}, # "score=" . $sf->score ); }; #($sf->can('frame') && $sf->frame) && do { push(@{$fth->field->{'note'}}, # "frame=" . $sf->frame ); }; #$sf->strand && do { push(@{$fth->field->{'note'}},"strand=" . $sf->strand ); }; foreach my $tag ( $sf->get_all_tags ) { # Tags which begin with underscores are considered # private, and are therefore not printed next if $tag =~ /^_/; if ( !defined $fth->field->{$tag} ) { $fth->field->{$tag} = []; } foreach my $val ( $sf->get_tag_values($tag) ) { push(@{$fth->field->{$tag}},$val); } } push(@ret, $fth); unless (@ret) { $context_annseq->throw("Problem in processing seqfeature $sf - no fthelpers. Error!"); } foreach my $ft (@ret) { if ( !$ft->isa('Bio::SeqIO::FTHelper') ) { $sf->throw("Problem in processing seqfeature $sf - made a $fth!"); } } return @ret; } =head2 key Title : key Usage : $obj->key($newval) Function: Example : Returns : value of key Args : newvalue (optional) =cut sub key { my ($obj, $value) = @_; if ( defined $value ) { $obj->{'key'} = $value; } return $obj->{'key'}; } =head2 loc Title : loc Usage : $obj->loc($newval) Function: Example : Returns : value of loc Args : newvalue (optional) =cut sub loc { my ($obj, $value) = @_; if ( defined $value ) { $obj->{'loc'} = $value; } return $obj->{'loc'}; } =head2 field Title : field Usage : Function: Example : Returns : Args : =cut sub field { my ($self) = @_; return $self->{'_field'}; } =head2 add_field Title : add_field Usage : Function: Example : Returns : Args : =cut sub add_field { my ($self, $key, $val) = @_; if ( !exists $self->field->{$key} ) { $self->field->{$key} = []; } push( @{$self->field->{$key}} , $val); } 1; �������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/game.pm�������������������������������������������������������������������000444��000765��000024�� 10556�12254227332� 16425� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::game # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::game -- a class for parsing and writing game-XML =head1 SYNOPSIS This module is not used directly, use SeqIO. use Bio::SeqIO; my $in = Bio::SeqIO->new ( -file => 'file.xml', -format => 'game', -verbose => 1 ); my $seq = $in->next_seq; =head1 DESCRIPTION Bio::SeqIO::game will parse game XML (version 1.2) or write game XML from a Bio::SeqI implementing object. The XML is readable by the genome annotation editor 'Apollo' (www.gmod.org). It is not backwards compatible with the previous version of game XML. The XML format currently used by Apollo contains a single 'main' annotated sequence, so we will only get a single annotated sequence in the stream when parsing a game-XML record. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::game; use Bio::SeqIO::game::gameHandler; use Bio::SeqIO::game::gameWriter; use base qw(Bio::SeqIO); sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize(@args); } =head2 next_seq Title : next_seq Usage : my $seq = $seqio->next_seq; Function: get the main sequence object Returns : a Bio::Seq::RichSeq object Args : none =cut sub next_seq { my $self = shift; my $seq_l = $self->_getseqs; my $annseq = shift @{$seq_l}; my $seq = $annseq->[0]; my $feats = $annseq->[1]; for ( @{$feats} ) { $seq->add_SeqFeature( $_ ); } return $seq; } =head2 write_seq Title : write_seq Usage : $seqio->write_seq($seq) Function: writes a sequence object as game XML Returns : nothing Args : a Bio::SeqI compliant object =cut sub write_seq { my ($self, $seq) = @_; my $writer = Bio::SeqIO::game::gameWriter->new($seq); my $xml = $writer->write_to_game; $self->_print($xml); } =head2 _getseqs Title : _getseqs Usage : $self->_getseqs Function: An internal method to invoke the PerlSAX XML handler and get the sequence objects Returns : an reference to an array with sequence object and annotations Args : none =cut sub _getseqs { my $self = shift; if ( defined $self->{seq_l} ) { return $self->{seq_l}; } else { my $fh = $self->_fh; my $text = join '', <$fh>; $text || $self->throw("Input file is empty or does not exist"); my $source = $text =~ /type>(source|origin|\bregion\b)<\/type/gm ? 1 : 0; my $handler = Bio::SeqIO::game::gameHandler->new; $handler->{has_source} = $source if $source; $handler->{verbose} = 1 if $self->verbose; my $parser = XML::Parser::PerlSAX->new( Handler => $handler ); my $game = $parser->parse( $text ); $self->{seq_l} = $game->load; } } =head2 _hide_dna Title : _hide_dna Usage : $seqio->_hide_dna Function: Hide the DNA for really huge sequences Returns : nothing Args : none =cut sub _hide_dna { my $self = shift; my $annseqs = $self->_getseqs; for ( @{$annseqs} ) { my $seq = $_->[0]; $seq->seq(''); } return 0; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/gbdriver.pm���������������������������������������������������������������000444��000765��000024�� 37337�12254227317� 17331� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::gbdriver # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Bioperl project bioperl-l(at)bioperl.org # # Copyright Chris Fields and contributors see AUTHORS section # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::gbdriver - GenBank handler-based push parser =head1 SYNOPSIS #It is probably best not to use this object directly, but #rather go through the SeqIO handler: $stream = Bio::SeqIO->new(-file => $filename, -format => 'gbdriver'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from GenBank flat file databases. The key difference between this parser and the tried-and-true Bio::SeqIO::genbank parser is this version separates the parsing and data manipulation into a 'driver' method (next_seq) and separate object handlers which deal with the data passed to it. =head2 The Driver The main purpose of the driver routine, in this case next_seq(), is to carve out the data into meaningful chunks which are passed along to relevant handlers (see below). Each chunk of data in the has a NAME tag attached to it, similar to that for XML parsing. This designates the type of data passed (annotation type or seqfeature) and the handler to be called for processing the data. For GenBank annotations, the data is divided up and passed along to handlers according to whether the data is tagged with a field name (i.e. LOCUS) and whether the field name represents 'primary' annotation (in this case, is present at the beginning of the line, such as REFERENCE). If the field is primary, it is assigned to the NAME tag. Field names which aren't primary (have at least 2 spaces before the name, like ORGANISM) are appended to the preceding primary field name as additional tags. For feature table data each new feature name signals the beginning of a new chunk of data. 'FEATURES' is attached to NAME, the feature key ('CDS', 'gene', etc) is attached as the PRIMARY_ID, and the location is assigned to it's own tag name (LOCATION). Feature qualifiers are added as additional keys, with multiple keys included in an array. Once a particular event occurs (new primary tag, sequence, end of record), the data is passed along to be processed by a handler or (if no handler is defined) tossed away. Internally, the hash ref for a representative annotation (here a REFERENCE) looks like this: $VAR1 = { 'JOURNAL' => 'Unpublished (2003)', 'TITLE' => 'The DNA sequence of Homo sapiens', 'NAME' => 'REFERENCE', 'REFERENCE' => '1 (bases 1 to 10001)', 'AUTHORS' => 'International Human Genome Sequencing Consortium.' }; and a SeqFeature as this: $VAR1 = { 'db_xref' => [ 'GeneID:127086', 'InterimID:127086' ], 'LOCATION' => 'complement(3024..6641)', 'NAME' => 'FEATURES', 'FEATURE_KEY' => 'gene', 'gene' => 'LOC127086', 'note' => 'Derived by automated computational analysis using gene prediction method: GNOMON.' }; Note that any driver implementation would suffice as long as it fulfilled the requirements above. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Bioperl Project bioperl-l at bioperl.org Original author Elia Stupka, elia -at- tigem.it =head1 CONTRIBUTORS Ewan Birney birney at ebi.ac.uk Jason Stajich jason at bioperl.org Chris Mungall cjm at fruitfly.bdgp.berkeley.edu Lincoln Stein lstein at cshl.org Heikki Lehvaslaiho, heikki at ebi.ac.uk Hilmar Lapp, hlapp at gmx.net Donald G. Jackson, donald.jackson at bms.com James Wasmuth, james.wasmuth at ed.ac.uk Brian Osborne, bosborne at alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # POD is at the end of the module # Let the code begin... package Bio::SeqIO::gbdriver; use strict; use warnings; use Data::Dumper; use Bio::SeqIO::Handler::GenericRichSeqHandler; use Bio::Seq::SeqFactory; use base qw(Bio::SeqIO); # map all annotation keys to consistent INSDC-based tags for all handlers my %FTQUAL_NO_QUOTE = map {$_ => 1} qw( anticodon citation codon codon_start cons_splice direction evidence label mod_base number rpt_type rpt_unit transl_except transl_table usedin ); # 1) change this to indicate what should be secondary, not primary, which allows # unknown or new stuff to be passed to handler automatically; current behavior # appends unknowns to previous data, which isn't good since it's subtly passing # by important data # 2) add mapping details about how to separate data using specific delimiters # Features are the only ones postprocessed for now # Uncomment relevant code in next_seq and add keys as needed... my %POSTPROCESS_DATA = map {$_ => 1} qw (FEATURES); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my $handler = $self->_rearrange([qw(HANDLER)],@args); # hash for functions for decoding keys. $handler ? $self->seqhandler($handler) : $self->seqhandler(Bio::SeqIO::Handler::GenericRichSeqHandler->new( -format => 'genbank', -verbose => $self->verbose, -builder => $self->sequence_builder )); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut # at this point there is minimal sequence validation, # but the parser seems to hold up nicely so far... sub next_seq { my $self = shift; local($/) = "\n"; my ($ann, $data, $annkey); my $endrec = my $seenfeat = 0; my $seqdata; my $seenlocus; my $hobj = $self->seqhandler; my $handlers = $self->seqhandler->handler_methods; #$self->debug(Dumper($handlers)); PARSER: while (defined(my $line = $self->_readline)) { next if $line =~ m{^\s*$}; # have to catch this at the top of the loop, then exit SEQ loop on // # The reason? The regex match for ann/feat keys also matches some lines # in the sequence; no easy way around it since some feature keys may # start with a number as well if ($ann && $ann eq 'ORIGIN') { SEQ: while (defined($line)) { last SEQ if index($line,'//') == 0; $seqdata->{DATA} .= uc $line; $line = $self->_readline; } $seqdata->{DATA} =~ tr{0-9 \n}{}d; } $endrec = 1 if (index($line,'//')==0); if ($line =~ m{^(\s{0,5})(\w+)\s+(.*)$}ox || $endrec) { ($ann, $data) = ($2, $3); unless ($seenlocus) { $self->throw("No LOCUS found. Not GenBank in my book!") if ($ann ne 'LOCUS'); $seenlocus = 1; } # use the spacer to determine the annotation type my $len = length($1 || ''); $annkey = ($len == 0 || $len > 4) ? 'DATA' : $ann; # Push off the previously cached data to the handler # whenever a new primary annotation or seqfeature is found # Note use of $endrec for catching end of record if (($annkey eq 'DATA') && $seqdata) { chomp $seqdata->{DATA}; # postprocessing for some data if ($seqdata->{NAME} eq 'FEATURES') { $self->_process_features($seqdata) } # using handlers directly, slightly faster #my $method = (exists $handlers->{ $seqdata->{NAME} }) ? # ($handlers->{$seqdata->{NAME}}) : # (exists $handlers->{'_DEFAULT_'}) ? # ($handlers->{'_DEFAULT_'}) : # undef; #($method) ? ($hobj->$method($seqdata) ) : # $self->debug("No handler defined for ",$seqdata->{NAME},"\n"); # using handler methods in the Handler object, more centralized #$self->debug(Dumper($seqdata)); $hobj->data_handler($seqdata); # bail here on // last PARSER if $endrec; # reset for next round $seqdata = undef; } $seqdata->{NAME} = ($len == 0) ? $ann : # primary ann ($len > 4 ) ? 'FEATURES': # sf feature key $seqdata->{NAME}; # all rest are sec. ann if ($seqdata->{NAME} eq 'FEATURES') { $seqdata->{FEATURE_KEY} = $ann; } # throw back to top if seq is found to avoid regex next PARSER if $ann eq 'ORIGIN'; } else { ($data = $line) =~ s{^\s+}{}; chomp $data; } my $delim = ($seqdata && $seqdata->{NAME} eq 'FEATURES') ? "\n" : ' '; $seqdata->{$annkey} .= ($seqdata->{$annkey}) ? $delim.$data : $data; } return $hobj->build_sequence; } sub next_chunk { my $self = shift; local($/) = "\n"; my ($ann, $data, $annkey); my $endrec = my $seenfeat = 0; my $seqdata; my $seenlocus; my $hobj = $self->seqhandler; PARSER: while (defined(my $line = $self->_readline)) { next if $line =~ m{^\s*$}; # have to catch this at the top of the loop, then exit SEQ loop on // # The reason? The regex match for ann/feat keys also matches some lines # in the sequence; no easy way around it since some feature keys may # start with a number as well if ($ann && $ann eq 'ORIGIN') { SEQ: while (defined($line)) { last SEQ if index($line,'//') == 0; $seqdata->{DATA} .= uc $line; $line = $self->_readline; } $seqdata->{DATA} =~ tr{0-9 \n}{}d; } $endrec = 1 if (index($line,'//')==0); if ($line =~ m{^(\s{0,5})(\w+)\s+(.*)$}ox || $endrec) { ($ann, $data) = ($2, $3); unless ($seenlocus) { $self->throw("No LOCUS found. Not GenBank in my book!") if ($ann ne 'LOCUS'); $seenlocus = 1; } # use the spacer to determine the annotation type my $len = length($1 || ''); $annkey = ($len == 0 || $len > 4) ? 'DATA' : $ann; # Push off the previously cached data to the handler # whenever a new primary annotation or seqfeature is found # Note use of $endrec for catching end of record if (($annkey eq 'DATA') && $seqdata) { chomp $seqdata->{DATA}; # postprocessing for some data if ($seqdata->{NAME} eq 'FEATURES') { $self->_process_features($seqdata) } # using handler methods in the Handler object, more centralized $hobj->data_handler($seqdata); # bail here on // last PARSER if $endrec; # reset for next round $seqdata = undef; } $seqdata->{NAME} = ($len == 0) ? $ann : # primary ann ($len > 4 ) ? 'FEATURES': # sf feature key $seqdata->{NAME}; # all rest are sec. ann if ($seqdata->{NAME} eq 'FEATURES') { $seqdata->{FEATURE_KEY} = $ann; } # throw back to top if seq is found to avoid regex next PARSER if $ann eq 'ORIGIN'; } else { ($data = $line) =~ s{^\s+}{}; chomp $data; } my $delim = ($seqdata && $seqdata->{NAME} eq 'FEATURES') ? "\n" : ' '; $seqdata->{$annkey} .= ($seqdata->{$annkey}) ? $delim.$data : $data; } } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { shift->throw("Use Bio::SeqIO::genbank for output"); # maybe make a Writer class as well???? } =head2 seqhandler Title : seqhandler Usage : $stream->seqhandler($handler) Function: Get/Set teh Bio::Seq::HandlerBaseI object Returns : Bio::Seq::HandlerBaseI Args : Bio::Seq::HandlerBaseI =cut sub seqhandler { my ($self, $handler) = @_; if ($handler) { $self->throw("Not a Bio::HandlerBaseI") unless ref($handler) && $handler->isa("Bio::HandlerBaseI"); $self->{'_seqhandler'} = $handler; } return $self->{'_seqhandler'}; } #=head2 _process_features # # Title : _process_features # Usage : $self->_process_features($seqdata) # Function: Process feature data chunk into usable bits # Returns : # Args : data chunk # #=cut sub _process_features { my ($self, $seqdata) = @_; my @ftlines = split m{\n}, $seqdata->{DATA}; delete $seqdata->{DATA}; # don't deal with balancing quotes for now; just get rid of them... # Should we worry about checking whether these are balanced # for round-tripping tests? map { s{"}{}g } @ftlines; # all sfs start with the location... my $qual = 'LOCATION'; my $ct = 0; for my $qualdata (@ftlines) { if ($qualdata =~ m{^/([^=]+)=?(.+)?}) { ($qual, $qualdata) = ($1, $2); $qualdata ||= ''; # for those qualifiers that have no data, like 'pseudo' $ct = (exists $seqdata->{$qual}) ? ((ref($seqdata->{$qual})) ? scalar(@{ $seqdata->{$qual} }) : 1) : 0 ; } my $delim = ($qual eq 'translation' || exists $FTQUAL_NO_QUOTE{$qual}) ? '' : ' '; # if more than one, turn into an array ref and append if ($ct == 0) { (exists $seqdata->{$qual}) ? ($seqdata->{$qual}.= $delim.$qualdata || '') : ($seqdata->{$qual} .= $qualdata || ''); } else { if (!ref($seqdata->{$qual})) { $seqdata->{$qual} = [$seqdata->{$qual}]; } (exists $seqdata->{$qual}->[$ct]) ? (($seqdata->{$qual}->[$ct]) .= $delim.$qualdata) : (($seqdata->{$qual}->[$ct]) .= $qualdata); } } } 1; __END__ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/gbxml.pm������������������������������������������������������������������000444��000765��000024�� 31566�12254227315� 16632� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: gbxml.pm # # BioPerl module for Bio::SeqIO::gbxml # # Cared for by Ryan Golhar # NOTE: This module is implemented on an as needed basis. As features # are needed, they are implemented. Its very bare-bones. # # Based off http://www.insdc.org/page.php?page=documents&sid=105a8b52b69db9c36c82a2e0d923ca69 # # I tried to follow the genbank module to keep things as consistent as possible # Right now, I'm not respecting the want_slot parameters. This will need to be added. =head1 NAME Bio::SeqIO::gbxml - GenBank sequence input/output stream using SAX =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system. To read a GenBank XML file: $stream = Bio::SeqIO->new( -file => $filename, -format => 'gbxml'); while ( my $bioSeqObj = $stream->next_seq() ) { # do something with $bioSeqObj } To write a Seq object to the current file handle in GenBank XML format: $stream->write_seq( -seq => $seqObj); If instead you would like a XML::DOM object containing the GBXML, use: my $newXmlObject = $stream->to_bsml( -seq => $seqObj); =head1 DEPENDENCIES In addition to parts of the Bio:: hierarchy, this module uses: XML::SAX =head1 DESCRIPTION This object can transform Bio::Seq objects to and from GenBank XML flatfiles. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ryan Golhar Email golharam-at-umdnj-dot-edu =cut package Bio::SeqIO::gbxml; use vars qw($Default_Source); use strict; use Bio::SeqIO::FTHelper; use Bio::SeqFeature::Generic; use Bio::Species; use XML::SAX; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO XML::SAX::Base); $Default_Source = 'GBXML'; sub _initialize { my ($self) = shift; $self->SUPER::_initialize(@_); $self->{'_parser'} = XML::SAX::ParserFactory->parser('Handler' => $self); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } return; } =head1 METHODS =cut =head2 next_seq Title : next_seq Usage : my $bioSeqObj = $stream->next_seq Function: Retrieves the next sequence from a SeqIO::gbxml stream. Returns : A reference to a Bio::Seq::RichSeq object Args : =cut sub next_seq { my $self = shift; if( @{$self->{'_seendata'}->{'_seqs'} || []} || eof($self->_fh)) { return shift @{$self->{'_seendata'}->{'_seqs'}}; } $self->{'_parser'}->parse_file($self->_fh); return shift @{$self->{'_seendata'}->{'_seqs'}}; } # XML::SAX::Base methods sub start_document { my ($self,$doc) = @_; $self->{'_seendata'} = {'_seqs' => [] #, # '_authors' => [], # '_feats' => [] }; $self->SUPER::start_document($doc); } sub end_document { my ($self,$doc) = @_; $self->SUPER::end_document($doc); } sub start_element { my ($self,$ele) = @_; my $name = uc($ele->{'LocalName'}); # my $attr = $ele->{'Attributes'}; # my $seqid = defined $self->{'_seendata'}->{'_seqs'}->[-1] ? # $self->{'_seendata'}->{'_seqs'}->[-1]->display_id : undef; # for my $k ( keys %$attr ) { # $attr->{uc $k} = $attr->{$k}; # delete $attr->{$k}; # } if( $name eq 'GBSET' ) { } elsif( $name eq 'GBSEQ' ) { # Initialize, we are starting a new sequence. push @{$self->{'_seendata'}->{'_seqs'}}, $self->sequence_factory->create(); } elsif( $name eq 'GBFEATURE' ) { my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; my $fthelper = Bio::SeqIO::FTHelper->new(); $fthelper->verbose($self->verbose()); push @{$self->{'_seendata'}->{'_feats'}}, $fthelper; } # } elsif( $name eq 'FEATURE-TABLES' ) { # } elsif( $name eq 'database-xref' ) { # my ($db,$id) = split(/:/,$content); # $curseq->annotation->add_Annotation('dblink', # Bio::Annotation::DBLink->new # ( -database => $db, # -primary_id=> $id)); # } elsif( $name eq 'INTERVAL-LOC' ) { # my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; # my ($start,$end,$strand) = # map { $attr->{'{}'.$_}->{'Value'} } qw(STARTPOS # ENDPOS # COMPLEMENT); # $curfeat->start($start); # $curfeat->end($end); # $curfeat->strand(-1) if($strand); # } elsif( $name eq 'REFERENCE' ) { # push @{$self->{'_seendata'}->{'_annot'}}, # Bio::Annotation::Reference->new(); # } $self->{'_characters'} = ''; push @{$self->{'_state'}}, $name; $self->SUPER::start_element($ele); } sub end_element { my ($self,$ele) = @_; pop @{$self->{'_state'}}; my $name = uc $ele->{'LocalName'}; my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; if ($name eq 'GBSEQ_LOCUS') { $curseq->display_id($self->{'_characters'}); } elsif ($name eq 'GBSEQ_LENGTH' ) { $curseq->length($self->{'_characters'}); } elsif ($name eq 'GBSEQ_MOLTYPE' ) { if ($self->{'_characters'} =~ /mRNA|dna/) { $curseq->alphabet('dna'); } else { $curseq->alphabet('protein'); } $curseq->molecule($self->{'_characters'}); } elsif ($name eq 'GBSEQ_TOPOLOGY' ) { $curseq->is_circular(($self->{'_characters'} =~ /^linear$/i) ? 0 : 1); } elsif ($name eq 'GBSEQ_DIVISION' ) { $curseq->division($self->{'_characters'}); } elsif ($name =~ m/GBSEQ_UPDATE-DATE|GBSEQ_CREATE-DATE/ ) { my $date = $self->{'_characters'}; # This code was taken from genbank.pm if($date =~ s/\s*((\d{1,2})-(\w{3})-(\d{2,4})).*/$1/) { if( length($date) < 11 ) { # improperly formatted date # But we'll be nice and fix it for them my ($d,$m,$y) = ($2,$3,$4); $d = "0$d" if( length($d) == 1 ); # guess the century here if( length($y) == 2 ) { # arbitrarily guess that '60' means 1960 $y = ($y > 60) ? "19$y" : "20$y"; $self->warn("Date was malformed, guessing the century for $date to be $y\n"); } $date = [join('-',$d,$m,$y)]; } $curseq->add_date($date); } } elsif ($name eq 'GBSEQ_DEFINITION' ) { $curseq->description($self->{'_characters'}); } elsif ($name eq 'GBSEQ_PRIMARY-ACCESSION' ) { $curseq->accession_number($self->{'_characters'}); } elsif ($name eq 'GBSEQ_ACCESSION-VERSION' ) { # also taken from genbank.pm $self->{'_characters'} =~ m/^\w+\.(\d+)/; if ($1) { $curseq->version($1); $curseq->seq_version($1); } } elsif ($name eq 'GBSEQID' ) { if ($self->{'_characters'} =~ m/gi\|(\d+)/) { $curseq->primary_id($1); } } elsif ($name eq 'GBSEQ_SOURCE') { $self->{'_taxa'}->{'_common'} = $self->{'_characters'}; } elsif ($name eq 'GBSEQ_ORGANISM' ) { # taken from genbank.pm my @organell_names = ("chloroplast", "mitochondr"); my @spflds = split(' ', $self->{'_characters'}); $_ = $self->{'_characters'}; if (grep { $_ =~ /^$spflds[0]/i; } @organell_names) { $self->{'_taxa'}->{'_organelle'} = shift(@spflds); } $self->{'_taxa'}->{'_genus'} = shift(@spflds); $self->{'_taxa'}->{'_species'} = shift(@spflds) if (@spflds); $self->{'_taxa'}->{'_sub_species'} = shift(@spflds) if (@spflds); $self->{'_taxa'}->{'_ns_name'} = $self->{'_characters'}; } elsif ($name eq 'GBSEQ_TAXONOMY' ) { # taken from genbank.pm $_ = $self->{'_characters'}; my @class; push (@class, map { s/^\s+//; s/\s+$//; $_; } split /[;\.]+/, $_); next unless $self->{'_taxa'}->{'_genus'} and $self->{'_taxa'}->{'_genus'} !~ /^(unknown|None)$/oi; if ($class[0] eq 'Viruses') { push( @class, $self->{'_taxa'}->{'_ns_name'} ); } elsif ($class[$#class] eq $self->{'_taxa'}->{'_genus'}) { push( @class, $self->{'_taxa'}->{'_species'} ); } else { push( @class, $self->{'_taxa'}->{'_genus'}, $self->{'_taxa'}->{'_species'} ); } @class = reverse @class; my $make = Bio::Species->new(); $make->classification( \@class, "FORCE"); $make->common_name($self->{'_taxa'}->{'_common'}) if $self->{'_taxa'}->{'_common'}; unless ($class[-1] eq 'Viruses') { $make->sub_species( $self->{'_taxa'}->{'_sub_species'} ) if $self->{'_taxa'}->{'_sub_species'}; } $make->organelle( $self->{'_taxa'}->{'_organelle'} ) if $self->{'_taxa'}->{'_organelle'}; $curseq->species($make); delete $self->{'_taxa'}; } elsif( $name eq 'GBSEQ_COMMENT' ) { $curseq->annotation->add_Annotation('comment', Bio::Annotation::Comment->new(-text => $self->{'_characters'} )) if ($self->{'_characters'}); } elsif ($name eq 'GBFEATURE_KEY' ) { $curfeat->key($self->{'_characters'}); } elsif ($name eq 'GBFEATURE_LOCATION' ) { $curfeat->loc($self->{'_characters'}); } elsif ($name eq 'GBQUALIFIER_NAME' ) { $self->{'_feature'}->{"_qualifer_name"} = $self->{'_characters'}; } elsif ($name eq 'GBQUALIFIER_VALUE' ) { my $qualifier = $self->{'_feature'}->{"_qualifer_name"}; delete $self->{'_feature'}->{"_qualifer_name"}; $curfeat->field->{$qualifier} ||= []; push(@{$curfeat->field->{$qualifier}}, $self->{'_characters'}); } elsif ($name eq 'GBSEQ_SEQUENCE' ) { $curseq->seq($self->{'_characters'}); } elsif( $name eq 'GBFEATURE' ) { shift @{$self->{'_seendata'}->{'_feats'}}; # copied from genbank.pm if (!defined($curfeat)) { $self->warn("Unexpected error in feature table for ".$curseq->display_id." Skipping feature, attempting to recover"); } else { my $feat = $curfeat->_generic_seqfeature($self->location_factory(), $curseq->display_id); if ($curseq->species && ($feat->primary_tag eq 'source') && $feat->has_tag('db_xref') && (! $curseq->species->ncbi_taxid())) { foreach my $tagval ($feat->get_tag_values('db_xref')) { if (index($tagval,"taxon:") == 0) { $curseq->species->ncbi_taxid(substr($tagval,6)); } } } $curseq->add_SeqFeature($feat); } } # if( $name eq 'REFERENCE') { # my $ref = pop @{$self->{'_seendata'}->{'_annot'}}; # $curseq->annotation->add_Annotation('reference',$ref); # } $self->SUPER::end_element($ele); } # Characters should be buffered because we may not always get the entire string. Once the entire string is read # process it in end_element. sub characters { my ($self,$data) = @_; if( ! @{$self->{'_state'}} ) { $self->warn("Calling characters with no previous start_element call. Ignoring data"); } else { # my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; # my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; # my $curannot = $self->{'_seendata'}->{'_annot'}->[-1]; # my $name = $self->{'_state'}->[-1]; # if ($name eq 'GBSEQ_LOCUS' ) { $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_LENGTH' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_MOLTYPE' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_TOPOLOGY' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_DIVISION' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name =~ m/GBSEQ_UPDATE-DATE|GBSEQ_CREATE-DATE/ ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_DEFINITION' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_PRIMARY-ACCESSION' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_ACCESSION-VERSION' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQID' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_SOURCE') { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_ORGANISM' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_TAXONOMY' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBSEQ_COMMENT' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBFEATURE_KEY' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBFEATURE_LOCATION' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBQUALIFIER_NAME' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBQUALIFIER_VALUE' ) { # $self->{'_characters'} .= $data->{'Data'}; # } elsif ($name eq 'GBINTERVAL_FROM' ) { # $self->{'_feature'}->{'_interval_from'} = $data->{'Data'}; # } elsif ($name eq 'GBINTERVAL_TO' ) { # $self->{'_feature'}->{'_interval_to'} = $data->{'Data'}; # } elsif ($name eq 'GBINTERVAL_ACCESSION' ) { # $self->{'_feature'}->{'_interval_accession'} = $data->{'Data'}; # } elsif ($name eq 'GBSEQ_SEQUENCE' ) { # $self->{'_characters'} .= $data->{'Data'}; # } } $self->SUPER::characters($data); } 1; ������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/gcg.pm��������������������������������������������������������������������000444��000765��000024�� 17405�12254227331� 16253� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::gcg # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # and Lincoln Stein <lstein@cshl.org> # # Copyright Ewan Birney & Lincoln Stein # # You may distribute this module under the same terms as perl itself # # _history # October 18, 1999 Largely rewritten by Lincoln Stein # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::gcg - GCG sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from GCG flat file databases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Ewan Birney & Lincoln Stein Email: E<lt>birney@ebi.ac.ukE<gt> E<lt>lstein@cshl.orgE<gt> =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::gcg; use strict; use Bio::Seq::SeqFactory; use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my ($self,@args) = @_; my($id,$type,$desc,$line,$chksum,$sequence,$date,$len); while( defined($_ = $self->_readline()) ) { ## Get the descriptive info (anything before the line with '..') unless( /\.\.$/ ) { $desc.= $_; } ## Pull ID, Checksum & Type from the line containing '..' /\.\.$/ && do { $line = $_; chomp; if(/Check\:\s(\d+)\s/) { $chksum = $1; } if(/Type:\s(\w)\s/) { $type = $1; } if(/(\S+)\s+Length/) { $id = $1; } if(/Length:\s+(\d+)\s+(\S.+\S)\s+Type/ ) { $len = $1; $date = $2;} last; } } return if ( !defined $_); chomp($desc); # remove last "\n" while( defined($_ = $self->_readline()) ) { ## This is where we grab the sequence info. if( /\.\.$/ ) { $self->throw("Looks like start of another sequence. See documentation. "); } next if($_ eq "\n"); ## skip whitespace lines in formatted seq s/[\d\s\t]//g; ## remove anything that is not alphabet char: preserve anything that is not explicitly specified for removal (Stefan Kirov) # $_ = uc($_); ## uppercase sequence: NO. Keep the case. HL $sequence .= $_; } ##If we parsed out a checksum, we might as well test it if(defined $chksum) { unless(_validate_checksum(uc($sequence),$chksum)) { $self->throw("Checksum failure on parsed sequence."); } } ## Remove whitespace from identifier because the constructor ## will throw a warning otherwise... if(defined $id) { $id =~ s/\s+//g;} ## Turn our parsed "Type: N" or "Type: P" (if found) into the appropriate ## keyword that the constructor expects... if(defined $type) { if($type eq "N") { $type = "dna"; } if($type eq "P") { $type = "prot"; } } return $self->sequence_factory->create(-seq => $sequence, -id => $id, -desc => $desc, -type => $type, -dates => [ $date ] ); } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the formatted $seq object into the stream Returns : 1 for success and 0 for error Args : array of Bio::PrimarySeqI object =cut sub write_seq { my ($self,@seq) = @_; for my $seq (@seq) { $self->throw("Did not provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); $self->warn("No whitespace allowed in GCG ID [". $seq->display_id. "]") if $seq->display_id =~ /\s/; my $str = $seq->seq; my $comment = $seq->desc || ''; my $id = $seq->id; my $type = ( $seq->alphabet() =~ /[dr]na/i ) ? 'N' : 'P'; my $timestamp; if( $seq->can('get_dates') ) { ($timestamp) = $seq->get_dates; } else { $timestamp = localtime(time); } my($sum,$offset,$len,$i,$j,$cnt,@out); $len = length($str); ## Set the offset if we have any non-standard numbering going on $offset=1; # checksum $sum = $self->GCG_checksum($seq); #Output the sequence header info push(@out,"$comment\n"); push(@out,"$id Length: $len $timestamp Type: $type Check: $sum ..\n\n"); #Format the sequence $i = $#out + 1; for($j = 0 ; $j < $len ; ) { if( $j % 50 == 0) { $out[$i] = sprintf("%8d ",($j+$offset)); #numbering } $out[$i] .= sprintf("%s",substr($str,$j,10)); $j += 10; if( $j < $len && $j % 50 != 0 ) { $out[$i] .= " "; }elsif($j % 50 == 0 ) { $out[$i++] .= "\n\n"; } } local($^W) = 0; if($j % 50 != 0 ) { $out[$i] .= "\n"; } $out[$i] .= "\n"; return unless $self->_print(@out); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 GCG_checksum Title : GCG_checksum Usage : $cksum = $gcgio->GCG_checksum($seq); Function : returns a gcg checksum for the sequence specified This method can also be called as a class method. Example : Returns : a GCG checksum string Argument : a Bio::PrimarySeqI implementing object =cut sub GCG_checksum { my ($self,$seqobj) = @_; my $index = 0; my $checksum = 0; my $char; my $seq = $seqobj->seq(); $seq =~ tr/a-z/A-Z/; foreach $char ( split(/[\.\-]*/, $seq)) { $index++; $checksum += ($index * (unpack("c",$char) || 0) ); if( $index == 57 ) { $index = 0; } } return ($checksum % 10000); } =head2 _validate_checksum Title : _validate_checksum Usage : n/a - internal method Function: if parsed gcg sequence contains a checksum field : we compare it to a value computed here on the parsed : sequence. A checksum mismatch would indicate some : type of parsing failure occured. : Returns : 1 for success, 0 for failure Args : string containing parsed seq, value of parsed cheksum =cut sub _validate_checksum { my($seq,$parsed_sum) = @_; my($i,$len,$computed_sum,$cnt); $len = length($seq); #Generate the GCG Checksum value for($i=0; $i<$len ;$i++) { $cnt++; $computed_sum += $cnt * ord(substr($seq,$i,1)); ($cnt == 57) && ($cnt=0); } $computed_sum %= 10000; ## Compare and decide if success or failure if($parsed_sum == $computed_sum) { return 1; } else { return 0; } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/genbank.pm����������������������������������������������������������������000444��000765��000024�� 173761�12254227336� 17155� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::genbank # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Bioperl project bioperl-l(at)bioperl.org # # Copyright Elia Stupka and contributors see AUTHORS section # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::genbank - GenBank sequence input/output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler: $stream = Bio::SeqIO->new(-file => $filename, -format => 'GenBank'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from GenBank flat file databases. There is some flexibility here about how to write GenBank output that is not fully documented. =head2 Optional functions =over 3 =item _show_dna() (output only) shows the dna or not =item _post_sort() (output only) provides a sorting func which is applied to the FTHelpers before printing =item _id_generation_func() This is function which is called as print "ID ", $func($seq), "\n"; To generate the ID line. If it is not there, it generates a sensible ID line using a number of tools. If you want to output annotations in Genbank format they need to be stored in a Bio::Annotation::Collection object which is accessible through the Bio::SeqI interface method L<annotation()|annotation>. The following are the names of the keys which are pulled from a L<Bio::Annotation::Collection> object: reference - Should contain Bio::Annotation::Reference objects comment - Should contain Bio::Annotation::Comment objects dblink - Should contain a Bio::Annotation::DBLink object segment - Should contain a Bio::Annotation::SimpleValue object origin - Should contain a Bio::Annotation::SimpleValue object wgs - Should contain a Bio::Annotation::SimpleValue object =back =head1 Where does the data go? Data parsed in Bio::SeqIO::genbank is stored in a variety of data fields in the sequence object that is returned. Here is a partial list of fields. Items listed as RichSeq or Seq or PrimarySeq and then NAME() tell you the top level object which defines a function called NAME() which stores this information. Items listed as Annotation 'NAME' tell you the data is stored the associated Bio::AnnotationCollectionI object which is associated with Bio::Seq objects. If it is explicitly requested that no annotations should be stored when parsing a record of course they will not be available when you try and get them. If you are having this problem look at the type of SeqBuilder that is being used to contruct your sequence object. Comments Annotation 'comment' References Annotation 'reference' Segment Annotation 'segment' Origin Annotation 'origin' Dbsource Annotation 'dblink' Accessions PrimarySeq accession_number() Secondary accessions RichSeq get_secondary_accessions() GI number PrimarySeq primary_id() LOCUS PrimarySeq display_id() Keywords RichSeq get_keywords() Dates RichSeq get_dates() Molecule RichSeq molecule() Seq Version RichSeq seq_version() PID RichSeq pid() Division RichSeq division() Features Seq get_SeqFeatures() Alphabet PrimarySeq alphabet() Definition PrimarySeq description() or desc() Version PrimarySeq version() Sequence PrimarySeq seq() There is more information in the Feature-Annotation HOWTO about each field and how it is mapped to the Sequence object L<http://bioperl.open-bio.org/wiki/HOWTO:Feature-Annotation>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Bioperl Project bioperl-l at bioperl.org Original author Elia Stupka, elia -at- tigem.it =head1 CONTRIBUTORS Ewan Birney birney at ebi.ac.uk Jason Stajich jason at bioperl.org Chris Mungall cjm at fruitfly.bdgp.berkeley.edu Lincoln Stein lstein at cshl.org Heikki Lehvaslaiho, heikki at ebi.ac.uk Hilmar Lapp, hlapp at gmx.net Donald G. Jackson, donald.jackson at bms.com James Wasmuth, james.wasmuth at ed.ac.uk Brian Osborne, bosborne at alum.mit.edu Chris Fields, cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::genbank; use strict; use Bio::SeqIO::FTHelper; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO); # Note that a qualifier that exceeds one line (i.e. a long label) will # automatically be quoted regardless: our $FTQUAL_LINE_LENGTH = 60; our %FTQUAL_NO_QUOTE = map {$_ => 1} qw( anticodon citation codon codon_start cons_splice direction evidence label mod_base number rpt_type rpt_unit transl_except transl_table usedin ); our %DBSOURCE = map {$_ => 1} qw( EchoBASE IntAct SWISS-2DPAGE ECO2DBASE ECOGENE TIGRFAMs TIGR GO InterPro Pfam PROSITE SGD GermOnline HSSP PhosSite Ensembl RGD AGD ArrayExpress KEGG H-InvDB HGNC LinkHub PANTHER PRINTS SMART SMR MGI MIM RZPD-ProtExp ProDom MEROPS TRANSFAC Reactome UniGene GlycoSuiteDB PIRSF HSC-2DPAGE PHCI-2DPAGE PMMA-2DPAGE Siena-2DPAGE Rat-heart-2DPAGE Aarhus/Ghent-2DPAGE Biocyc MetaCyc Biocyc:Metacyc GenomeReviews FlyBase TMHOBP COMPLUYEAST-2DPAGE OGP DictyBase HAMAP PhotoList Gramene WormBase WormPep Genew ZFIN PeroxiBase MaizeDB TAIR DrugBank REBASE HPA swissprot GenBank GenPept REFSEQ embl PDB UniProtKB DIP PeptideAtlas PRIDE CYGD HOGENOME Gene3D Project); our %VALID_MOLTYPE = map {$_ => 1} qw(NA DNA RNA tRNA rRNA cDNA cRNA ms-DNA mRNA uRNA ss-RNA ss-DNA snRNA snoRNA PRT); our %VALID_ALPHABET = ( 'bp' => 'dna', 'aa' => 'protein', 'rc' => '' # rc = release candidate; file has no sequences ); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. $self->{'_func_ftunit_hash'} = {}; $self->_show_dna(1); # sets this to one by default. People can change it if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my ( $self, @args ) = @_; my %args = @args; my $builder = $self->sequence_builder(); my $seq; my %params; RECORDSTART: while (1) { my $buffer; my ( @acc, @features ); my ( $display_id, $annotation ); my $species; # initialize; we may come here because of starting over @features = (); $annotation = undef; @acc = (); $species = undef; %params = ( -verbose => $self->verbose ); # reset hash local ($/) = "\n"; while ( defined( $buffer = $self->_readline() ) ) { last if index( $buffer, 'LOCUS ' ) == 0; } return unless defined $buffer; # end of file $buffer =~ /^LOCUS\s+(\S.*)$/o || $self->throw( "GenBank stream with bad LOCUS line. Not GenBank in my book. Got '$buffer'" ); my @tokens = split( ' ', $1 ); # this is important to have the id for display in e.g. FTHelper, # otherwise you won't know which entry caused an error $display_id = shift(@tokens); $params{'-display_id'} = $display_id; # may still be useful if we don't want the seq my $seqlength = shift(@tokens); if ( exists $VALID_ALPHABET{$seqlength} ) { # moved one token too far. No locus name? $self->warn( "Bad LOCUS name? Changing [$params{'-display_id'}] to 'unknown' and length to $display_id" ); $params{'-display_id'} = 'unknown'; $params{'-length'} = $display_id; # add token back... unshift @tokens, $seqlength; } else { $params{'-length'} = $seqlength; } # the alphabet of the entry # shouldn't assign alphabet unless one is specifically designated (such as for rc files) my $alphabet = lc( shift @tokens ); $params{'-alphabet'} = ( exists $VALID_ALPHABET{$alphabet} ) ? $VALID_ALPHABET{$alphabet} : $self->warn("Unknown alphabet: $alphabet"); # for aa there is usually no 'molecule' (mRNA etc) if ( $params{'-alphabet'} eq 'protein' ) { $params{'-molecule'} = 'PRT'; } else { $params{'-molecule'} = shift(@tokens); } # take care of lower case issues if ( $params{'-molecule'} eq 'dna' || $params{'-molecule'} eq 'rna' ) { $params{'-molecule'} = uc $params{'-molecule'}; } $self->debug( "Unrecognized molecule type:" . $params{'-molecule'} ) if !exists( $VALID_MOLTYPE{ $params{'-molecule'} } ); my $circ = shift(@tokens); if ( $circ eq 'circular' ) { $params{'-is_circular'} = 1; $params{'-division'} = shift(@tokens); } else { # 'linear' or 'circular' may actually be omitted altogether $params{'-division'} = ( CORE::length($circ) == 3 ) ? $circ : shift(@tokens); } my $date = join( ' ', @tokens ); # we lump together the rest # this is per request bug #1513 # we can handle # 9-10-2003 # 9-10-03 # 09-10-2003 # 09-10-03 if ( $date =~ s/\s*((\d{1,2})-(\w{3})-(\d{2,4})).*/$1/ ) { if ( length($date) < 11 ) { # improperly formatted date # But we'll be nice and fix it for them my ( $d, $m, $y ) = ( $2, $3, $4 ); if ( length($d) == 1 ) { $d = "0$d"; } # guess the century here if ( length($y) == 2 ) { if ( $y > 60 ) { # arbitrarily guess that '60' means 1960 $y = "19$y"; } else { $y = "20$y"; } $self->warn( "Date was malformed, guessing the century for $date to be $y\n" ); } $params{'-dates'} = [ join( '-', $d, $m, $y ) ]; } else { $params{'-dates'} = [$date]; } } # set them all at once $builder->add_slot_value(%params); %params = (); # parse the rest if desired, otherwise start over if ( !$builder->want_object() ) { $builder->make_object(); next RECORDSTART; } # set up annotation depending on what the builder wants if ( $builder->want_slot('annotation') ) { $annotation = Bio::Annotation::Collection->new(); } $buffer = $self->_readline(); until ( !defined($buffer) ) { $_ = $buffer; # Description line(s) if (/^DEFINITION\s+(\S.*\S)/) { my @desc = ($1); while ( defined( $_ = $self->_readline ) ) { if (/^\s+(.*)/) { push( @desc, $1 ); next } last; } $builder->add_slot_value( -desc => join( ' ', @desc ) ); # we'll continue right here because DEFINITION always comes # at the top of the entry $buffer = $_; } # accession number (there can be multiple accessions) if (/^ACCESSION\s+(\S.*\S)/) { push( @acc, split( /\s+/, $1 ) ); while ( defined( $_ = $self->_readline ) ) { /^\s+(.*)/ && do { push( @acc, split( /\s+/, $1 ) ); next }; last; } $buffer = $_; next; } # PID elsif (/^PID\s+(\S+)/) { $params{'-pid'} = $1; } # Version number elsif (/^VERSION\s+(\S.+)$/) { my ( $acc, $gi ) = split( ' ', $1 ); if ( $acc =~ /^\w+\.(\d+)/ ) { $params{'-version'} = $1; $params{'-seq_version'} = $1; } if ( $gi && ( index( $gi, "GI:" ) == 0 ) ) { $params{'-primary_id'} = substr( $gi, 3 ); } } # Keywords elsif (/^KEYWORDS\s+(\S.*)/) { my @kw = split( /\s*\;\s*/, $1 ); while ( defined( $_ = $self->_readline ) ) { chomp; /^\s+(.*)/ && do { push( @kw, split( /\s*\;\s*/, $1 ) ); next }; last; } @kw && $kw[-1] =~ s/\.$//; $params{'-keywords'} = \@kw; $buffer = $_; next; } # Organism name and phylogenetic information elsif (/^SOURCE\s+\S/) { if ( $builder->want_slot('species') ) { $species = $self->_read_GenBank_Species( \$buffer ); $builder->add_slot_value( -species => $species ); } else { while ( defined( $buffer = $self->_readline() ) ) { last if substr( $buffer, 0, 1 ) ne ' '; } } next; } # References elsif (/^REFERENCE\s+\S/) { if ($annotation) { my @refs = $self->_read_GenBank_References( \$buffer ); foreach my $ref (@refs) { $annotation->add_Annotation( 'reference', $ref ); } } else { while ( defined( $buffer = $self->_readline() ) ) { last if substr( $buffer, 0, 1 ) ne ' '; } } next; } # Project elsif (/^PROJECT\s+(\S.*)/) { if ($annotation) { my $project = Bio::Annotation::SimpleValue->new( -value => $1 ); $annotation->add_Annotation( 'project', $project ); } } # Comments elsif (/^COMMENT\s+(\S.*)/) { if ($annotation) { my $comment = $1; while ( defined( $_ = $self->_readline ) ) { last if (/^\S/); $comment .= $_; } $comment =~ s/\n/ /g; $comment =~ s/ +/ /g; $annotation->add_Annotation( 'comment', Bio::Annotation::Comment->new( -text => $comment, -tagname => 'comment' ) ); $buffer = $_; } else { while ( defined( $buffer = $self->_readline() ) ) { last if substr( $buffer, 0, 1 ) ne ' '; } } next; } # Corresponding Genbank nucleotide id, Genpept only elsif (/^DB(?:SOURCE|LINK)\s+(\S.+)/) { if ($annotation) { my $dbsource = $1; while ( defined( $_ = $self->_readline ) ) { last if (/^\S/); $dbsource .= $_; } # deal with UniProKB dbsources if ( $dbsource =~ s/(UniProt(?:KB)?|swissprot):\s+locus\s+(\S+)\,.+\n// ) { $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $2, -database => $1, -tagname => 'dblink' ) ); if ( $dbsource =~ s/\s+created:\s+([^\.]+)\.\n// ) { $annotation->add_Annotation( 'swissprot_dates', Bio::Annotation::SimpleValue->new( -tagname => 'date_created', -value => $1 ) ); } while ( $dbsource =~ s/\s+(sequence|annotation)\s+updated:\s+([^\.]+)\.\n//g ) { $annotation->add_Annotation( 'swissprot_dates', Bio::Annotation::SimpleValue->new( -tagname => 'date_updated', -value => $2 ) ); } $dbsource =~ s/\n/ /g; if ( $dbsource =~ s/\s+xrefs:\s+((?:\S+,\s+)+\S+)\s+xrefs/xrefs/ ) { # will use $i to determine even or odd # for swissprot the accessions are paired my $i = 0; for my $dbsrc ( split( /,\s+/, $1 ) ) { if ( $dbsrc =~ /(\S+)\.(\d+)/ || $dbsrc =~ /(\S+)/ ) { my ( $id, $version ) = ( $1, $2 ); $version = '' unless defined $version; my $db; if ( $id =~ /^\d\S{3}/ ) { $db = 'PDB'; } else { $db = ( $i++ % 2 ) ? 'GenPept' : 'GenBank'; } $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $id, -version => $version, -database => $db, -tagname => 'dblink' ) ); } } } elsif ( $dbsource =~ s/\s+xrefs:\s+(.+)\s+xrefs/xrefs/i ) { # download screwed up and ncbi didn't put acc in for gi numbers my $i = 0; for my $id ( split( /\,\s+/, $1 ) ) { my ( $acc, $db ); if ( $id =~ /gi:\s+(\d+)/ ) { $acc = $1; $db = ( $i++ % 2 ) ? 'GenPept' : 'GenBank'; } elsif ( $id =~ /pdb\s+accession\s+(\S+)/ ) { $acc = $1; $db = 'PDB'; } else { $acc = $id; $db = ''; } $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $acc, -database => $db, -tagname => 'dblink' ) ); } } else { $self->debug("Cannot match $dbsource\n"); } if ( $dbsource =~ s/xrefs\s+\(non\-sequence\s+databases\):\s+ ((?:\S+,\s+)+\S+)//x ) { for my $id ( split( /\,\s+/, $1 ) ) { my $db; # this is because GenBank dropped the spaces!!! # I'm sure we're not going to get this right ##if( $id =~ s/^://i ) { ## $db = $1; ##} $db = substr( $id, 0, index( $id, ':' ) ); if ( !exists $DBSOURCE{$db} ) { $db = ''; # do we want 'GenBank' here? } $id = substr( $id, index( $id, ':' ) + 1 ); $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $id, -database => $db, -tagname => 'dblink' ) ); } } } else { if ( $dbsource =~ /^(\S*?):?\s*accession\s+(\S+)\.(\d+)/ ) { my ( $db, $id, $version ) = ( $1, $2, $3 ); $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $id, -version => $version, -database => $db || 'GenBank', -tagname => 'dblink' ) ); } elsif ( $dbsource =~ /^(\S*?):?\s*accession\s+(\S+)/ ) { my ( $db, $id ) = ( $1, $2 ); $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $id, -database => $db || 'GenBank', -tagname => 'dblink' ) ); } elsif ( $dbsource =~ /(\S+)([\.:])\s*(\S+)/ ) { my ( $db, $version ); my @ids = (); if ( $2 eq ':' ) { $db = $1; # Genbank 192 release notes say this: "The second field can consist of # multiple comma-separated identifiers, if a sequence record has # multiple DBLINK cross-references of a given type." # For example: DBLINK Project:100,200,300" @ids = split( /,/, $3 ); } else { ( $db, $version ) = ( 'GenBank', $3 ); $ids[0] = $1; } foreach my $id (@ids) { $annotation->add_Annotation( 'dblink', Bio::Annotation::DBLink->new( -primary_id => $id, -version => $version, -database => $db, -tagname => 'dblink' ) ); } } else { $self->warn( "Unrecognized DBSOURCE data: $dbsource\n"); } } $buffer = $_; } else { while ( defined( $buffer = $self->_readline() ) ) { last if substr( $buffer, 0, 1 ) ne ' '; } } next; } # Exit at start of Feature table, or start of sequence last if (/^(FEATURES|ORIGIN)/); # Get next line and loop again $buffer = $self->_readline; } return unless defined $buffer; # add them all at once for efficiency $builder->add_slot_value( -accession_number => shift(@acc), -secondary_accessions => \@acc, %params ); $builder->add_slot_value( -annotation => $annotation ) if $annotation; %params = (); # reset before possible re-use to avoid setting twice # start over if we don't want to continue with this entry if ( !$builder->want_object() ) { $builder->make_object(); next RECORDSTART; } # some "minimal" formats may not necessarily have a feature table if ( $builder->want_slot('features') && defined($_) && /^FEATURES/o ) { # need to read the first line of the feature table $buffer = $self->_readline; # DO NOT read lines in the while condition -- this is done as a side # effect in _read_FTHelper_GenBank! # part of new circular spec: # commented out for now until kinks worked out #my $sourceEnd = 0; #$sourceEnd = $2 if ($buffer =~ /(\d+?)\.\.(\d+?)$/); while ( defined($buffer) ) { # check immediately -- not at the end of the loop # note: GenPept entries obviously do not have a BASE line last if ( $buffer =~ /^BASE|ORIGIN|CONTIG|WGS/o ); # slurp in one feature at a time -- at return, the start of # the next feature will have been read already, so we need # to pass a reference, and the called method must set this # to the last line read before returning my $ftunit = $self->_read_FTHelper_GenBank( \$buffer ); # implement new circular spec: features that cross the origin are now # seamless instead of being 2 separate joined features # commented out until kinks get worked out #if ((! $args{'-nojoin'}) && $ftunit->{'loc'} =~ /^join\((\d+?)\.\.(\d+?),(\d+?)..(\d+?)\)$/ #&& $sourceEnd == $2 && $3 == 1) { #my $start = $1; #my $end = $2 + $4; #$ftunit->{'loc'} = "$start..$end"; #} # fix suggested by James Diggans if ( !defined $ftunit ) { # GRRRR. We have fallen over. Try to recover $self->warn( "Unexpected error in feature table for " . $params{'-display_id'} . " Skipping feature, attempting to recover" ); unless ( ( $buffer =~ /^\s{5,5}\S+/o ) or ( $buffer =~ /^\S+/o ) ) { $buffer = $self->_readline(); } next; # back to reading FTHelpers } # process ftunit my $feat = $ftunit->_generic_seqfeature( $self->location_factory(), $display_id ); # add taxon_id from source if available if ( $species && ( $feat->primary_tag eq 'source' ) && $feat->has_tag('db_xref') && ( !$species->ncbi_taxid() || ( $species->ncbi_taxid && $species->ncbi_taxid =~ /^list/ ) ) ) { foreach my $tagval ( $feat->get_tag_values('db_xref') ) { if ( index( $tagval, "taxon:" ) == 0 ) { $species->ncbi_taxid( substr( $tagval, 6 ) ); last; } } } # add feature to list of features push( @features, $feat ); } $builder->add_slot_value( -features => \@features ); $_ = $buffer; } if ( defined($_) ) { # CONTIG lines: TODO, this needs to be cleaned up if (/^CONTIG\s+(.*)/o) { my $ctg = $1; while ( defined( $_ = $self->_readline)) { last if m{^ORIGIN|//}o; s/\s+(.*)/$1/; $ctg .= $_; } if ($ctg) { $annotation->add_Annotation( Bio::Annotation::SimpleValue->new( -tagname => 'contig', -value => $ctg ) ); } } elsif (/^WGS|WGS_SCAFLD\s+/o) { # catch WGS/WGS_SCAFLD lines while ( $_ =~ s/(^WGS|WGS_SCAFLD)\s+// ) { # gulp lines chomp; $annotation->add_Annotation( Bio::Annotation::SimpleValue->new( -value => $_, -tagname => lc($1) ) ); $_ = $self->_readline; } } elsif ( !m{^ORIGIN|//}o ) { # advance to the sequence, if any while ( defined( $_ = $self->_readline ) ) { last if m{^(ORIGIN|//)}; } } } if ( !$builder->want_object() ) { $builder->make_object(); # implicit end-of-object next RECORDSTART; } if ( $builder->want_slot('seq') ) { # the fact that we want a sequence does not necessarily mean that # there also is a sequence ... if ( defined($_) && s/^ORIGIN\s+// ) { if ( $annotation && length($_) > 0 ) { $annotation->add_Annotation( 'origin', Bio::Annotation::SimpleValue->new( -tagname => 'origin', -value => $_ ) ); } my $seqc = ''; while ( defined( $_ = $self->_readline ) ) { last if m{^//}; $_ = uc($_); s/[^A-Za-z]//g; $seqc .= $_; } $builder->add_slot_value( -seq => $seqc ); } } elsif ( defined($_) && ( substr( $_, 0, 2 ) ne '//' ) ) { # advance to the end of the record while ( defined( $_ = $self->_readline ) ) { last if substr( $_, 0, 2 ) eq '//'; } } # Unlikely, but maybe the sequence is so weird that we don't want it # anymore. We don't want to return undef if the stream's not exhausted # yet. $seq = $builder->make_object(); next RECORDSTART unless $seq; last RECORDSTART; } # end while RECORDSTART return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { my ($self,@seqs) = @_; foreach my $seq ( @seqs ) { $self->throw("Attempting to write with no seq!") unless defined $seq; if( ! ref $seq || ! $seq->isa('Bio::SeqI') ) { $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!"); } my $str = $seq->seq; my ($div, $mol); my $len = $seq->length(); if ( $seq->can('division') ) { $div = $seq->division; } if( !defined $div || ! $div ) { $div = 'UNK'; } my $alpha = $seq->alphabet; if( !$seq->can('molecule') || ! defined ($mol = $seq->molecule()) ) { $mol = $alpha || 'DNA'; } my $circular = 'linear '; $circular = 'circular' if $seq->is_circular; local($^W) = 0; # supressing warnings about uninitialized fields. my $temp_line; if( $self->_id_generation_func ) { $temp_line = &{$self->_id_generation_func}($seq); } else { my $date = ''; if( $seq->can('get_dates') ) { ($date) = $seq->get_dates(); } $self->warn("No whitespace allowed in GenBank display id [". $seq->display_id. "]") if $seq->display_id =~ /\s/; $temp_line = sprintf ("%-12s%-15s%13s %s%4s%-8s%-8s %3s %-s\n", 'LOCUS', $seq->id(),$len, (lc($alpha) eq 'protein') ? ('aa','', '') : ('bp', '',$mol),$circular,$div,$date); } $self->_print($temp_line); $self->_write_line_GenBank_regex("DEFINITION ", " ", $seq->desc(),"\\s\+\|\$",80); # if there, write the accession line if( $self->_ac_generation_func ) { $temp_line = &{$self->_ac_generation_func}($seq); $self->_print("ACCESSION $temp_line\n"); } else { my @acc = (); push(@acc, $seq->accession_number()); if( $seq->isa('Bio::Seq::RichSeqI') ) { push(@acc, $seq->get_secondary_accessions()); } $self->_print("ACCESSION ", join(" ", @acc), "\n"); # otherwise - cannot print <sigh> } # if PID defined, print it if($seq->isa('Bio::Seq::RichSeqI') && $seq->pid()) { $self->_print("PID ", $seq->pid(), "\n"); } # if there, write the version line if( defined $self->_sv_generation_func() ) { $temp_line = &{$self->_sv_generation_func}($seq); if( $temp_line ) { $self->_print("VERSION $temp_line\n"); } } else { if($seq->isa('Bio::Seq::RichSeqI') && defined($seq->seq_version)) { my $id = $seq->primary_id(); # this may be a GI number $self->_print("VERSION ", $seq->accession_number(), ".", $seq->seq_version, ($id && ($id =~ /^\d+$/) ? " GI:".$id : ""), "\n"); } } # if there, write the PROJECT line for my $proj ( $seq->annotation->get_Annotations('project') ) { $self->_print("PROJECT ".$proj->value."\n"); } # if there, write the DBSOURCE line foreach my $ref ( $seq->annotation->get_Annotations('dblink') ) { my ($db, $id) = ($ref->database, $ref->primary_id); my $prefix = $db eq 'Project' ? 'DBLINK' : 'DBSOURCE'; my $text = $db eq 'GenBank' ? '' : $db eq 'Project' ? "$db:$id" : "$db accession $id"; $self->_print(sprintf ("%-11s %s\n",$prefix, $text)); } # if there, write the keywords line if( defined $self->_kw_generation_func() ) { $temp_line = &{$self->_kw_generation_func}($seq); $self->_print("KEYWORDS $temp_line\n"); } else { if( $seq->can('keywords') ) { my $kw = $seq->keywords; $kw .= '.' if( $kw !~ /\.$/ ); $self->_print("KEYWORDS $kw\n"); } } # SEGMENT if it exists foreach my $ref ( $seq->annotation->get_Annotations('segment') ) { $self->_print(sprintf ("%-11s %s\n",'SEGMENT', $ref->value)); } # Organism lines if (my $spec = $seq->species) { my ($on, $sn, $cn) = ($spec->can('organelle') ? $spec->organelle : '', $spec->scientific_name, $spec->common_name); my @classification; if ($spec->isa('Bio::Species')) { @classification = $spec->classification; shift(@classification); } else { # Bio::Taxon should have a DB handle of some type attached, so # derive the classification from that my $node = $spec; while ($node) { $node = $node->ancestor || last; unshift(@classification, $node->node_name); #$node eq $root && last; } @classification = reverse @classification; } my $abname = $spec->name('abbreviated') ? # from genbank file $spec->name('abbreviated')->[0] : $sn; my $sl = $on ? "$on " : ''; $sl .= $cn ? $abname." ($cn)" : "$abname"; $self->_write_line_GenBank_regex("SOURCE ", ' 'x12, $sl, "\\s\+\|\$",80); $self->_print(" ORGANISM ", $spec->scientific_name, "\n"); my $OC = join('; ', (reverse(@classification))) .'.'; $self->_write_line_GenBank_regex(' 'x12,' 'x12, $OC,"\\s\+\|\$",80); } # Reference lines my $count = 1; foreach my $ref ( $seq->annotation->get_Annotations('reference') ) { $temp_line = "REFERENCE $count"; if ($ref->start) { $temp_line .= sprintf (" (%s %d to %d)", ($seq->alphabet() eq "protein" ? "residues" : "bases"), $ref->start,$ref->end); } elsif ($ref->gb_reference) { $temp_line .= sprintf (" (%s)", $ref->gb_reference); } $self->_print("$temp_line\n"); $self->_write_line_GenBank_regex(" AUTHORS ",' 'x12, $ref->authors,"\\s\+\|\$",80); $self->_write_line_GenBank_regex(" CONSRTM ",' 'x12, $ref->consortium,"\\s\+\|\$",80) if $ref->consortium; $self->_write_line_GenBank_regex(" TITLE "," "x12, $ref->title,"\\s\+\|\$",80); $self->_write_line_GenBank_regex(" JOURNAL "," "x12, $ref->location,"\\s\+\|\$",80); if( $ref->medline) { $self->_write_line_GenBank_regex(" MEDLINE "," "x12, $ref->medline, "\\s\+\|\$",80); # I am assuming that pubmed entries only exist when there # are also MEDLINE entries due to the indentation } # This could be a wrong assumption if( $ref->pubmed ) { $self->_write_line_GenBank_regex(" PUBMED "," "x12, $ref->pubmed, "\\s\+\|\$", 80); } # put remark at the end if ($ref->comment) { $self->_write_line_GenBank_regex(" REMARK "," "x12, $ref->comment,"\\s\+\|\$",80); } $count++; } # Comment lines foreach my $comment ( $seq->annotation->get_Annotations('comment') ) { $self->_write_line_GenBank_regex("COMMENT "," "x12, $comment->text,"\\s\+\|\$",80); } $self->_print("FEATURES Location/Qualifiers\n"); if( defined $self->_post_sort ) { # we need to read things into an array. Process. Sort them. Print 'em my $post_sort_func = $self->_post_sort(); my @fth; foreach my $sf ( $seq->top_SeqFeatures ) { push(@fth,Bio::SeqIO::FTHelper::from_SeqFeature($sf,$seq)); } @fth = sort { &$post_sort_func($a,$b) } @fth; foreach my $fth ( @fth ) { $self->_print_GenBank_FTHelper($fth); } } else { # not post sorted. And so we can print as we get them. # lower memory load... foreach my $sf ( $seq->top_SeqFeatures ) { my @fth = Bio::SeqIO::FTHelper::from_SeqFeature($sf,$seq); foreach my $fth ( @fth ) { if( ! $fth->isa('Bio::SeqIO::FTHelper') ) { $sf->throw("Cannot process FTHelper... $fth"); } $self->_print_GenBank_FTHelper($fth); } } } # deal with WGS; WGS_SCAFLD present only if WGS is also present if($seq->annotation->get_Annotations('wgs')) { foreach my $wgs (map {$seq->annotation->get_Annotations($_)} qw(wgs wgs_scaffold)) { $self->_print(sprintf ("%-11s %s\n",uc($wgs->tagname), $wgs->value)); } $self->_show_dna(0); } if($seq->annotation->get_Annotations('contig')) { my $ct = 0; my $cline; foreach my $contig ($seq->annotation->get_Annotations('contig')) { unless ($ct) { $cline = uc($contig->tagname)." ".$contig->value."\n"; } else { $cline = " ".$contig->value."\n"; } $self->_print($cline); $ct++; } $self->_show_dna(0); } if( $seq->length == 0 ) { $self->_show_dna(0) } if( $self->_show_dna() == 0 ) { $self->_print("\n//\n"); return; } # finished printing features. $str =~ tr/A-Z/a-z/; my ($o) = $seq->annotation->get_Annotations('origin'); $self->_print(sprintf("%-12s%s\n", 'ORIGIN', $o ? $o->value : '')); # print out the sequence my $nuc = 60; # Number of nucleotides per line my $whole_pat = 'a10' x 6; # Pattern for unpacking a whole line my $out_pat = 'A11' x 6; # Pattern for packing a line my $length = length($str); # Calculate the number of nucleotides which fit on whole lines my $whole = int($length / $nuc) * $nuc; # Print the whole lines my $i; for ($i = 0; $i < $whole; $i += $nuc) { my $blocks = pack $out_pat, unpack $whole_pat, substr($str, $i, $nuc); chop $blocks; $self->_print(sprintf("%9d $blocks\n", $i + $nuc - 59)); } # Print the last line if (my $last = substr($str, $i)) { my $last_len = length($last); my $last_pat = 'a10' x int($last_len / 10) . 'a'. $last_len % 10; my $blocks = pack $out_pat, unpack($last_pat, $last); $blocks =~ s/ +$//; $self->_print(sprintf("%9d $blocks\n", $length - $last_len + 1)); } $self->_print("//\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } } =head2 _print_GenBank_FTHelper Title : _print_GenBank_FTHelper Usage : Function: Example : Returns : Args : =cut sub _print_GenBank_FTHelper { my ($self,$fth) = @_; if( ! ref $fth || ! $fth->isa('Bio::SeqIO::FTHelper') ) { $fth->warn("$fth is not a FTHelper class. Attempting to print, but there could be tears!"); } my $spacer = (length $fth->key >= 15) ? ' ' : ''; $self->_write_line_GenBank_regex(sprintf(" %-16s%s",$fth->key,$spacer), " "x21, $fth->loc,"\,\|\$",80); foreach my $tag ( keys %{$fth->field} ) { foreach my $value ( @{$fth->field->{$tag}} ) { $value =~ s/\"/\"\"/g; if ($value eq "_no_value") { $self->_write_line_GenBank_regex(" "x21, " "x21, "/$tag","\.\|\$",80); } # there are almost 3x more quoted qualifier values and they # are more common too so we take quoted ones first # # Long qualifiers, that will be line wrapped, are always quoted elsif (!$FTQUAL_NO_QUOTE{$tag} or length("/$tag=$value") >= $FTQUAL_LINE_LENGTH) { my ($pat) = ($value =~ /\s/ ? '\s|$' : '.|$'); $self->_write_line_GenBank_regex(" "x21, " "x21, "/$tag=\"$value\"",$pat,80); } else { $self->_write_line_GenBank_regex(" "x21, " "x21, "/$tag=$value","\.\|\$",80); } } } } =head2 _read_GenBank_References Title : _read_GenBank_References Usage : Function: Reads references from GenBank format. Internal function really Returns : Args : =cut sub _read_GenBank_References { my ($self,$buffer) = @_; my (@refs); my $ref; # assumme things are starting with RN if( $$buffer !~ /^REFERENCE/ ) { warn("Not parsing line '$$buffer' which maybe important"); } $_ = $$buffer; my (@title,@loc,@authors,@consort,@com,@medline,@pubmed); REFLOOP: while( defined($_) || defined($_ = $self->_readline) ) { if (/^\s{2}AUTHORS\s+(.*)/o) { push (@authors, $1); while ( defined($_ = $self->_readline) ) { /^\s{9,}(.*)/o && do { push (@authors, $1);next;}; last; } $ref->authors(join(' ', @authors)); } if (/^\s{2}CONSRTM\s+(.*)/o) { push (@consort, $1); while ( defined($_ = $self->_readline) ) { /^\s{9,}(.*)/o && do { push (@consort, $1);next;}; last; } $ref->consortium(join(' ', @consort)); } if (/^\s{2}TITLE\s+(.*)/o) { push (@title, $1); while ( defined($_ = $self->_readline) ) { /^\s{9,}(.*)/o && do { push (@title, $1); next; }; last; } $ref->title(join(' ', @title)); } if (/^\s{2}JOURNAL\s+(.*)/o) { push(@loc, $1); while ( defined($_ = $self->_readline) ) { # we only match when there are at least 4 spaces # there is probably a better way to match this # as it assumes that the describing tag is short enough /^\s{9,}(.*)/o && do { push(@loc, $1); next; }; last; } $ref->location(join(' ', @loc)); redo REFLOOP; } if (/^\s{2}REMARK\s+(.*)/o) { push (@com, $1); while ( defined($_ = $self->_readline) ) { /^\s{9,}(.*)/o && do { push(@com, $1); next; }; last; } $ref->comment(join(' ', @com)); redo REFLOOP; } if( /^\s{2}MEDLINE\s+(.*)/ ) { push(@medline,$1); while ( defined($_ = $self->_readline) ) { /^\s{9,}(.*)/ && do { push(@medline, $1); next; }; last; } $ref->medline(join(' ', @medline)); redo REFLOOP; } if( /^\s{3}PUBMED\s+(.*)/ ) { push(@pubmed,$1); while ( defined($_ = $self->_readline) ) { /^\s{9,}(.*)/ && do { push(@pubmed, $1); next; }; last; } $ref->pubmed(join(' ', @pubmed)); redo REFLOOP; } /^REFERENCE/o && do { # store current reference $self->_add_ref_to_array(\@refs,$ref) if defined $ref; # reset @authors = (); @title = (); @loc = (); @com = (); @pubmed = (); @medline = (); # create the new reference object $ref = Bio::Annotation::Reference->new(-tagname => 'reference'); # check whether start and end base is given if (/^REFERENCE\s+\d+\s+\([a-z]+ (\d+) to (\d+)\)/){ $ref->start($1); $ref->end($2); } elsif (/^REFERENCE\s+\d+\s+\((.*)\)/) { $ref->gb_reference($1); } }; /^(FEATURES)|(COMMENT)/o && last; $_ = undef; # Empty $_ to trigger read of next line } # store last reference $self->_add_ref_to_array(\@refs,$ref) if defined $ref; $$buffer = $_; #print "\nnumber of references found: ", $#refs+1,"\n"; return @refs; } # # This is undocumented as it shouldn't be called by anywhere else as # read_GenBank_References. For those who still want to know: # # Purpose: adds a Reference object to an array of Reference objects, takes # care of possible cleanups to be done (currently, only author and title # will be chopped of trailing semicolons). # Parameters: # a reference to an array of Reference objects # the Reference object to be added # Returns: nothing # sub _add_ref_to_array { my ($self, $refs, $ref) = @_; # first, polish author and title by removing possible trailing semicolons my $au = $ref->authors(); my $title = $ref->title(); $au =~ s/;\s*$//g if $au; $title =~ s/;\s*$//g if $title; $ref->authors($au); $ref->title($title); # the rest should be clean already, so go ahead and add it push(@{$refs}, $ref); } =head2 _read_GenBank_Species Title : _read_GenBank_Species Usage : Function: Reads the GenBank Organism species and classification lines. Able to deal with unconvential Organism naming formats, and varietas in plants Example : ORGANISM unknown marine gamma proteobacterium NOR5 $genus = undef $species = unknown marine gamma proteobacterium NOR5 ORGANISM Drosophila sp. 'white tip scutellum' $genus = Drosophila $species = sp. 'white tip scutellum' (yes, this really is a species and that is its name) $subspecies = undef ORGANISM Ajellomyces capsulatus var. farciminosus $genus = Ajellomyces $species = capsulatus $subspecies = var. farciminosus ORGANISM Hepatitis delta virus $genus = undef (though this virus has a genus in its lineage, we cannot know that without a database lookup) $species = Hepatitis delta virus Returns : A Bio::Species object Args : A reference to the current line buffer =cut sub _read_GenBank_Species { my ($self, $buffer) = @_; my @unkn_names = ('other', 'unknown organism', 'not specified', 'not shown', 'Unspecified', 'Unknown', 'None', 'unclassified', 'unidentified organism', 'not supplied'); # dictionary of synonyms for taxid 32644 my @unkn_genus = ('unknown','unclassified','uncultured','unidentified'); # all above can be part of valid species name my $line = $$buffer; my( $sub_species, $species, $genus, $sci_name, $common, $class_lines, $source_flag, $abbr_name, $organelle, $sl ); my %source = map { $_ => 1 } qw(SOURCE ORGANISM CLASSIFICATION); # upon first entering the loop, we must not read a new line -- the SOURCE # line is already in the buffer (HL 05/10/2000) my ($ann, $tag, $data); while (defined($line) || defined($line = $self->_readline())) { # de-HTMLify (links that may be encountered here don't contain # escaped '>', so a simple-minded approach suffices) $line =~ s{<[^>]+>}{}g; if ($line =~ m{^(?:\s{0,2})(\w+)\s+(.+)?$}ox) { ($tag, $data) = ($1, $2 || ''); last if ($tag && !exists $source{$tag}); } else { return unless $tag; ($data = $line) =~ s{^\s+}{}; chomp $data; $tag = 'CLASSIFICATION' if ($tag ne 'CLASSIFICATION' && $tag eq 'ORGANISM' && $line =~ m{[;\.]+}); } (exists $ann->{$tag}) ? ($ann->{$tag} .= ' '.$data) : ($ann->{$tag} .= $data); $line = undef; } ($sl, $class_lines, $sci_name) = ($ann->{SOURCE}, $ann->{CLASSIFICATION}, $ann->{ORGANISM}); $$buffer = $line; $sci_name || return; # parse out organelle, common name, abbreviated name if present; # this should catch everything, but falls back to # entire SOURCE line just in case if ($sl =~ m{^ (mitochondrion|chloroplast|plastid)? \s*(.*?) \s*(?: \( (.*?) \) )?\.? $ }xms ){ ($organelle, $abbr_name, $common) = ($1, $2, $3); # optional } else { $abbr_name = $sl; # nothing caught; this is a backup! } # Convert data in classification lines into classification array. # only split on ';' or '.' so that classification that is 2 or more words will # still get matched, use map() to remove trailing/leading/intervening spaces my @class = map { s/^\s+//; s/\s+$//; s/\s{2,}/ /g; $_; } split /(?<!subgen)[;\.]+/, $class_lines; # do we have a genus? my $possible_genus = quotemeta($class[-1]) . ($class[-2] ? "|" . quotemeta($class[-2]) : ''); if ($sci_name =~ /^($possible_genus)/) { $genus = $1; ($species) = $sci_name =~ /^$genus\s+(.+)/; } else { $species = $sci_name; } # is this organism of rank species or is it lower? # (we don't catch everything lower than species, but it doesn't matter - # this is just so we abide by previous behaviour whilst not calling a # species a subspecies) if ($species && $species =~ /(.+)\s+((?:subsp\.|var\.).+)/) { ($species, $sub_species) = ($1, $2); } # Don't make a species object if it's empty or "Unknown" or "None" # return unless $genus and $genus !~ /^(Unknown|None)$/oi; # Don't make a species object if it belongs to taxid 32644 # my $unkn = grep { $_ =~ /^\Q$sl\E$/; } @unkn_names; my $unkn = grep { $_ eq $sl } @unkn_names; return unless ($species || $genus) and $unkn == 0; # Bio::Species array needs array in Species -> Kingdom direction push(@class, $sci_name); @class = reverse @class; my $make = Bio::Species->new(); $make->scientific_name($sci_name); $make->classification(@class) if @class > 0; $make->common_name( $common ) if $common; $make->name('abbreviated', $abbr_name) if $abbr_name; $make->organelle($organelle) if $organelle; #$make->sub_species( $sub_species ) if $sub_species; return $make; } =head2 _read_FTHelper_GenBank Title : _read_FTHelper_GenBank Usage : _read_FTHelper_GenBank($buffer) Function: reads the next FT key line Example : Returns : Bio::SeqIO::FTHelper object Args : filehandle and reference to a scalar =cut sub _read_FTHelper_GenBank { my ($self,$buffer) = @_; my ($key, # The key of the feature $loc # The location line from the feature ); my @qual = (); # An array of lines making up the qualifiers if ($$buffer =~ /^\s{5}(\S+)\s+(.+?)\s*$/o) { $key = $1; $loc = $2; # Read all the lines up to the next feature while ( defined($_ = $self->_readline) ) { if (/^(\s+)(.+?)\s*$/o) { # Lines inside features are preceded by 21 spaces # A new feature is preceded by 5 spaces if (length($1) > 6) { # Add to qualifiers if we're in the qualifiers, or if it's # the first qualifier if (@qual || (index($2,'/') == 0)) { push(@qual, $2); } # We're still in the location line, so append to location else { $loc .= $2; } } else { # We've reached the start of the next feature last; } } else { # We're at the end of the feature table last; } } } else { # No feature key $self->debug("no feature key!\n"); # change suggested by JDiggans to avoid infinite loop- # see bugreport 1062. # reset buffer to prevent infinite loop $$buffer = $self->_readline(); return; } # Put the first line of the next feature into the buffer $$buffer = $_; # Make the new FTHelper object my $out = Bio::SeqIO::FTHelper->new(); $out->verbose($self->verbose()); $out->key($key); $out->loc($loc); # Now parse and add any qualifiers. (@qual is kept # intact to provide informative error messages.) QUAL: for (my $i = 0; $i < @qual; $i++) { $_ = $qual[$i]; my( $qualifier, $value ) = (m{^/([^=]+)(?:=(.+))?}) or $self->warn("cannot see new qualifier in feature $key: ". $qual[$i]); $qualifier = '' unless( defined $qualifier); if (defined $value) { # Do we have a quoted value? if (substr($value, 0, 1) eq '"') { # Keep adding to value until we find the trailing quote # and the quotes are balanced while ($value !~ /\"$/ or $value =~ tr/"/"/ % 2) { if($i >= $#qual) { $self->warn("Unbalanced quote in:\n" . join("\n", @qual) . "No further qualifiers will " . "be added for this feature"); last QUAL; } $i++; # modifying a for-loop variable inside of the loop # is not the best programming style ... my $next = $qual[$i]; # add to value with a space unless the value appears # to be a sequence (translation for example) # if(($value.$next) =~ /[^A-Za-z\"\-]/o) { # changed to explicitly look for translation tag - cjf 06/8/29 if ($qualifier !~ /^translation$/i ) { $value .= " "; } $value .= $next; } # Trim leading and trailing quotes $value =~ s/^"|"$//g; # Undouble internal quotes $value =~ s/""/\"/g; } elsif ( $value =~ /^\(/ ) { # values quoted by ()s # Keep adding to value until we find the trailing bracket # and the ()s are balanced my $left = ($value =~ tr/\(/\(/); # count left parens my $right = ($value =~ tr/\)/\)/); # count right parens while( $left != $right ) { # was "$value !~ /\)$/ or $left != $right" if( $i >= $#qual) { $self->warn("Unbalanced parens in:\n". join("\n", @qual). "\nNo further qualifiers will ". "be added for this feature"); last QUAL; } $i++; my $next = $qual[$i]; $value .= $next; $left += ($next =~ tr/\(/\(/); $right += ($next =~ tr/\)/\)/); } } } else { $value = '_no_value'; } # Store the qualifier $out->field->{$qualifier} ||= []; push(@{$out->field->{$qualifier}},$value); } return $out; } =head2 _write_line_GenBank Title : _write_line_GenBank Usage : Function: internal function Example : Returns : Args : =cut sub _write_line_GenBank { my ($self,$pre1,$pre2,$line,$length) = @_; $length || $self->throw("Miscalled write_line_GenBank without length. Programming error!"); my $subl = $length - length $pre2; my $linel = length $line; my $i; my $subr = substr($line,0,$length - length $pre1); $self->_print("$pre1$subr\n"); for($i= ($length - length $pre1);$i < $linel; $i += $subl) { $subr = substr($line,$i,$subl); $self->_print("$pre2$subr\n"); } } =head2 _write_line_GenBank_regex Title : _write_line_GenBank_regex Usage : Function: internal function for writing lines of specified length, with different first and the next line left hand headers and split at specific points in the text Example : Returns : nothing Args : file handle, first header, second header, text-line, regex for line breaks, total line length =cut sub _write_line_GenBank_regex { my ($self,$pre1,$pre2,$line,$regex,$length) = @_; #print STDOUT "Going to print with $line!\n"; $length || $self->throw( "Miscalled write_line_GenBank without length. Programming error!"); my $subl = $length - (length $pre1) - 2; my @lines = (); CHUNK: while($line) { foreach my $pat ($regex, '[,;\.\/-]\s|'.$regex, '[,;\.\/-]|'.$regex) { if($line =~ m/^(.{0,$subl})($pat)(.*)/ ) { my $l = $1.$2; $line = substr($line,length($l)); # be strict about not padding spaces according to # genbank format $l =~ s/\s+$//; next CHUNK if ($l eq ''); push(@lines, $l); next CHUNK; } } # if we get here none of the patterns matched $subl or less chars $self->warn("trouble dissecting \"$line\"\n into chunks ". "of $subl chars or less - this tag won't print right"); # insert a space char to prevent infinite loops $line = substr($line,0,$subl) . " " . substr($line,$subl); } my $s = shift @lines; $self->_print("$pre1$s\n") if $s; foreach my $s ( @lines ) { $self->_print("$pre2$s\n"); } } =head2 _post_sort Title : _post_sort Usage : $obj->_post_sort($newval) Function: Returns : value of _post_sort Args : newvalue (optional) =cut sub _post_sort { my ($obj,$value) = @_; if( defined $value) { $obj->{'_post_sort'} = $value; } return $obj->{'_post_sort'}; } =head2 _show_dna Title : _show_dna Usage : $obj->_show_dna($newval) Function: Returns : value of _show_dna Args : newvalue (optional) =cut sub _show_dna { my ($obj,$value) = @_; if( defined $value) { $obj->{'_show_dna'} = $value; } return $obj->{'_show_dna'}; } =head2 _id_generation_func Title : _id_generation_func Usage : $obj->_id_generation_func($newval) Function: Returns : value of _id_generation_func Args : newvalue (optional) =cut sub _id_generation_func { my ($obj,$value) = @_; if( defined $value ) { $obj->{'_id_generation_func'} = $value; } return $obj->{'_id_generation_func'}; } =head2 _ac_generation_func Title : _ac_generation_func Usage : $obj->_ac_generation_func($newval) Function: Returns : value of _ac_generation_func Args : newvalue (optional) =cut sub _ac_generation_func { my ($obj,$value) = @_; if( defined $value ) { $obj->{'_ac_generation_func'} = $value; } return $obj->{'_ac_generation_func'}; } =head2 _sv_generation_func Title : _sv_generation_func Usage : $obj->_sv_generation_func($newval) Function: Returns : value of _sv_generation_func Args : newvalue (optional) =cut sub _sv_generation_func { my ($obj,$value) = @_; if( defined $value ) { $obj->{'_sv_generation_func'} = $value; } return $obj->{'_sv_generation_func'}; } =head2 _kw_generation_func Title : _kw_generation_func Usage : $obj->_kw_generation_func($newval) Function: Returns : value of _kw_generation_func Args : newvalue (optional) =cut sub _kw_generation_func { my ($obj,$value) = @_; if( defined $value ) { $obj->{'_kw_generation_func'} = $value; } return $obj->{'_kw_generation_func'}; } 1; ���������������BioPerl-1.6.923/Bio/SeqIO/interpro.pm���������������������������������������������������������������000444��000765��000024�� 21403�12254227324� 17350� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for interpro # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::interpro - InterProScan XML input/output stream =head1 SYNOPSIS # do not call this module directly, use Bio::SeqIO use strict; use Bio::SeqIO; my $io = Bio::SeqIO->new(-format => "interpro", -file => $interpro_file); while (my $seq = $io->next_seq) { # use the Sequence object } =head1 DESCRIPTION L<Bio::SeqIO::interpro> will parse Interpro scan XML (version 1.2) and create L<Bio::SeqFeature::Generic> objects based on the contents of the XML document. L<Bio::SeqIO::interpro> will also attach the annotation given in the XML file to the L<Bio::SeqFeature::Generic> objects that it creates. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jared Fox Email jaredfox@ucla.edu =head1 CONTRIBUTORS Allen Day allenday@ucla.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::interpro; use strict; use Bio::SeqFeature::Generic; use XML::DOM; use XML::DOM::XPath; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO); my $idcounter = {}; # Used to generate unique id values my $nvtoken = ": "; # The token used if a name/value pair has to be stuffed # into a single line =head2 next_seq Title : next_seq Usage : my $seqobj = $stream->next_seq Function: Retrieves the next sequence from a SeqIO::interpro stream. Returns : A Bio::Seq::RichSeq object Args : =cut sub next_seq { my $self = shift; my ($desc); my $bioSeq = $self->_sequence_factory->create(-verbose =>$self->verbose()); my $zinc = "(\"zincins\")"; my $wing = "\"Winged helix\""; my $finger = "\"zinc finger\""; my $xml_fragment = undef; while(my $line = $self->_readline()){ my $where = index($line, $zinc); my $wherefinger = index($line, $finger); my $finishedline = $line; my $wingwhere = index($line, $wing); # the interpro XML is not fully formed, so we need to convert the # extra double quotes and ampersands into appropriate XML chracter codes if($where > 0){ my @linearray = split /$zinc/, $line; $finishedline = join ""zincins"", $linearray[0], $linearray[2]; } if(index($line, "&") > 0){ my @linearray = split /&/, $line; $finishedline = join "&", $linearray[0], $linearray[1]; } if($wingwhere > 0){ my @linearray = split /$wing/, $line; $finishedline = join ""Winged helix"", $linearray[0], $linearray[1]; } $xml_fragment .= $finishedline; last if $finishedline =~ m!</protein>!; } # Match <protein> but not other similar elements like <protein-matches> return unless $xml_fragment =~ /<protein[\s>]/; $self->_parse_xml($xml_fragment); my $dom = $self->_dom; my ($protein_node) = $dom->findnodes('/protein'); my @interproNodes = $protein_node->findnodes('/protein/interpro'); my @DBNodes = $protein_node->findnodes('/protein/interpro/match'); for(my $interpn=0; $interpn<scalar(@interproNodes); $interpn++){ my $ipnlevel = join "", "/protein/interpro[", $interpn + 1, "]"; my @matchNodes = $protein_node->findnodes($ipnlevel); for(my $match=0; $match<scalar(@matchNodes); $match++){ 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'), -score => $_->getAttribute('score'), -source_tag => 'IPRscan', -primary_tag => 'region', -display_name => $interproNodes[$interpn]->getAttribute('name'), -seq_id => $protein_node->getAttribute('id') ), } @locNodes; foreach my $seqFeature (@seqFeatures){ $bioSeq->add_SeqFeature($seqFeature); my $annotation1 = Bio::Annotation::DBLink->new; $annotation1->database($matchNodes[$match]->getAttribute('dbname')); $annotation1->primary_id($matchNodes[$match]->getAttribute('id')); $annotation1->comment($matchNodes[$match]->getAttribute('name')); $seqFeature->annotation->add_Annotation('dblink',$annotation1); my $annotation2 = Bio::Annotation::DBLink->new; $annotation2->database('INTERPRO'); $annotation2->primary_id($interproNodes[$interpn]->getAttribute('id')); $annotation2->comment($interproNodes[$interpn]->getAttribute('name')); $seqFeature->annotation->add_Annotation('dblink',$annotation2); # Bug 1908 (enhancement) my $annotation3 = Bio::Annotation::DBLink->new; $annotation3->database($DBNodes[$interpn]->getAttribute('dbname')); $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); } } } } my $accession = $protein_node->getAttribute('id'); my $displayname = $protein_node->getAttribute('name'); $bioSeq->accession($accession); $bioSeq->display_name($displayname); return $bioSeq; } =head2 _initialize Title : _initialize Usage : Function: Returns : Args : =cut sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. $self->{'_func_ftunit_hash'} = {}; my %param = @args; # From SeqIO.pm @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $line = undef; # fast forward to first <protein/> record. while($line = $self->_readline()){ # Match <protein> but not other similar elements like <protein-matches> if($line =~ /<protein[\s>]/){ $self->_pushback($line); last; } } $self->_xml_parser( XML::DOM::Parser->new() ); $self->_sequence_factory( Bio::Seq::SeqFactory->new ( -verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')) if ( ! defined $self->sequence_factory ); } =head2 _sequence_factory Title : _sequence_factory Usage : Function: Returns : Args : =cut sub _sequence_factory { my $self = shift; my $val = shift; $self->{'sequence_factory'} = $val if defined($val); return $self->{'sequence_factory'}; } =head2 _xml_parser Title : _xml_parser Usage : Function: Returns : Args : =cut sub _xml_parser { my $self = shift; my $val = shift; $self->{'xml_parser'} = $val if defined($val); return $self->{'xml_parser'}; } =head2 _parse_xml Title : _parse_xml Usage : Function: Returns : Args : =cut sub _parse_xml { my ($self,$xml) = @_; $self->_dom( $self->_xml_parser->parse($xml) ); return 1; } =head2 _dom Title : _dom Usage : Function: Returns : Args : =cut sub _dom { my $self = shift; my $val = shift; $self->{'dom'} = $val if defined($val); return $self->{'dom'}; } 1; __END__ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/kegg.pm�������������������������������������������������������������������000444��000765��000024�� 20262�12254227323� 16424� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::kegg # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Allen Day <allenday@ucla.edu> # # Copyright Allen Day # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::kegg - KEGG sequence input/output stream =head1 SYNOPSIS # It is probably best not to use this object directly, but # rather go through the SeqIO handler system. Go: use Bio::SeqIO; $stream = Bio::SeqIO->new(-file => $filename, -format => 'KEGG'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This class transforms KEGG gene records into Bio::Seq objects. =head2 Mapping of record properties to object properties This section is supposed to document which sections and properties of a KEGG databank record end up where in the Bioperl object model. It is far from complete and presently focuses only on those mappings which may be non-obvious. $seq in the text refers to the Bio::Seq::RichSeqI implementing object returned by the parser for each record. =over 4 =item 'ENTRY' $seq->primary_id =item 'NAME' $seq->display_id =item 'DEFINITION' $seq->annotation->get_Annotations('description'); =item 'ORTHOLOG' grep {$_->database eq 'KO'} $seq->annotation->get_Annotations('dblink') =item 'CLASS' grep {$_->database eq 'PATH'} $seq->annotation->get_Annotations('dblink') =item 'POSITION' FIXME, NOT IMPLEMENTED =item 'PATHWAY' for my $pathway ( $seq->annotation->get_Annotations('pathway') ) { # } =item 'DBLINKS' $seq->annotation->get_Annotations('dblink') =item 'CODON_USAGE' FIXME, NOT IMPLEMENTED =item 'AASEQ' $seq->translate->seq =item 'NTSEQ' $seq-E<gt>seq =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Allen Day Email allenday@ucla.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::kegg; use strict; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::DBLink; use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. $self->{'_func_ftunit_hash'} = {}; if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::RichSeq object Args : =cut sub next_seq { my ($self,@args) = @_; my $builder = $self->sequence_builder(); my $seq; my %params; my $buffer; my (@acc, @features); my ($display_id, $annotation); my $species; # initialize; we may come here because of starting over @features = (); $annotation = undef; @acc = (); $species = undef; %params = (-verbose => $self->verbose); # reset hash local($/) = "///\n"; $buffer = $self->_readline(); return if( !defined $buffer ); # end of file $buffer =~ /^ENTRY/ || $self->throw("KEGG stream with bad ENTRY line. Not KEGG in my book. Got $buffer'"); my %FIELDS; my @chunks = split /\n(?=\S)/, $buffer; foreach my $chunk (@chunks){ my($key) = $chunk =~ /^(\S+)/; $FIELDS{$key} = $chunk; } # changing to split method to get entry_ids that include # sequence version like Whatever.1 my(undef,$entry_id,$entry_seqtype,$entry_species) = split(' ',$FIELDS{ENTRY}); my($name); if ($FIELDS{NAME}) { ($name) = $FIELDS{NAME} =~ /^NAME\s+(.+)$/; } my( $definition, $aa_length, $aa_seq, $nt_length, $nt_seq ); if(( exists $FIELDS{DEFINITION} ) and ( $FIELDS{DEFINITION} =~ /^DEFINITION/ )) { ($definition) = $FIELDS{DEFINITION} =~ /^DEFINITION\s+(.+)$/s; $definition =~ s/\s+/ /gs; } if(( exists $FIELDS{AASEQ} ) and ( $FIELDS{AASEQ} =~ /^AASEQ/ )) { ($aa_length,$aa_seq) = $FIELDS{AASEQ} =~ /^AASEQ\s+(\d+)\n(.+)$/s; $aa_seq =~ s/\s+//g; } if(( exists $FIELDS{NTSEQ} ) and ( $FIELDS{NTSEQ} =~ /^NTSEQ/ )) { ($nt_length,$nt_seq) = $FIELDS{NTSEQ} =~ /^NTSEQ\s+(\d+)\n(.+)$/s; $nt_seq =~ s/\s+//g; } $annotation = Bio::Annotation::Collection->new(); $annotation->add_Annotation('description', Bio::Annotation::Comment->new(-text => $definition)); $annotation->add_Annotation('aa_seq', Bio::Annotation::Comment->new(-text => $aa_seq)); my($ortholog_db,$ortholog_id,$ortholog_desc); if ($FIELDS{ORTHOLOG}) { ($ortholog_db,$ortholog_id,$ortholog_desc) = $FIELDS{ORTHOLOG} =~ /^ORTHOLOG\s+(\S+):\s+(\S+)\s+(.*?)$/; $annotation->add_Annotation('dblink',Bio::Annotation::DBLink->new( -database => $ortholog_db, -primary_id => $ortholog_id, -comment => $ortholog_desc) ); } if($FIELDS{MOTIF}){ $FIELDS{MOTIF} =~ s/^MOTIF\s+//; while($FIELDS{MOTIF} =~/\s*?(\S+):\s+(.+?)$/mg){ my $db = $1; my $ids = $2; foreach my $id (split(/\s+/, $ids)){ $annotation->add_Annotation('dblink',Bio::Annotation::DBLink->new( -database =>$db, -primary_id => $id, -comment => "") ); } } } if($FIELDS{PATHWAY}) { $FIELDS{PATHWAY} =~ s/^PATHWAY\s+//; while($FIELDS{PATHWAY} =~ /\s*PATH:\s+(.+)$/mg){ $annotation->add_Annotation('pathway', Bio::Annotation::Comment->new(-text => "$1")); } } if($FIELDS{POSITION}) { $FIELDS{POSITION} =~ s/^POSITION\s+//; $annotation->add_Annotation('position', Bio::Annotation::Comment->new(-text => $FIELDS{POSITION})); } if ($FIELDS{CLASS}) { $FIELDS{CLASS} =~ s/^CLASS\s+//; $FIELDS{'CLASS'} =~ s/\n//g; while($FIELDS{CLASS} =~ /(.*?)\[(\S+):(\S+)\]/g){ my ($pathway,$db,$id) = ($1,$2,$3); $pathway =~ s/\s+/ /g; $pathway =~ s/\s$//g; $pathway =~ s/^\s+//; $annotation->add_Annotation('pathway', Bio::Annotation::Comment->new(-text => $pathway)); $annotation->add_Annotation('dblink',Bio::Annotation::DBLink->new( -database => $db, -primary_id => $id)); } } if($FIELDS{DBLINKS}) { $FIELDS{DBLINKS} =~ s/^DBLINKS/ /; while($FIELDS{DBLINKS} =~ /\s+(\S+):\s+(\S+)\n?/gs){ ### modified $annotation->add_Annotation('dblink',Bio::Annotation::DBLink->new( -database => $1, -primary_id => $2)) if $1; } } $params{'-alphabet'} = 'dna'; $params{'-seq'} = $nt_seq; $params{'-display_id'} = $name; $params{'-accession_number'} = $entry_id; $params{'-species'} = Bio::Species->new( -common_name => $entry_species); $params{'-annotation'} = $annotation; $builder->add_slot_value(%params); $seq = $builder->make_object(); return $seq; } =head2 write_seq Title : write_seq Note : write_seq() is not implemented for KEGG format output. =cut sub write_seq { shift->throw("write_seq() not implemented for KEGG format output."); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/largefasta.pm�������������������������������������������������������������000444��000765��000024�� 11470�12254227313� 17620� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::largefasta # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # _history # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::largefasta - method i/o on very large fasta sequence files =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from fasta flat file databases. This module handles very large sequence files by using the Bio::Seq::LargePrimarySeq module to store all the sequence data in a file. This can be a problem if you have limited disk space on your computer because this will effectively cause 2 copies of the sequence file to reside on disk for the life of the Bio::Seq::LargePrimarySeq object. The default location for this is specified by the L<File::Spec>-E<gt>tmpdir routine which is usually /tmp on UNIX. If a sequence file is larger than the swap space (capacity of the /tmp dir) this could cause problems for the machine. It is possible to set the directory where the temporary file is located by adding the following line to your code BEFORE calling next_seq. See L<Bio::Seq::LargePrimarySeq> for more information. $Bio::Seq::LargePrimarySeq::DEFAULT_TEMP_DIR = 'newdir'; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Jason Stajich Email: jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::largefasta; use vars qw($FASTALINELEN); use strict; use Bio::Seq::SeqFactory; $FASTALINELEN = 60; use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::LargePrimarySeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : A Bio::Seq::LargePrimarySeq object Args : NONE =cut sub next_seq { my ($self) = @_; # local $/ = "\n"; my $largeseq = $self->sequence_factory->create(); my ($id,$fulldesc,$entry); my $count = 0; my $seen = 0; while( defined ($entry = $self->_readline) ) { if( $seen == 1 && $entry =~ /^\s*>/ ) { $self->_pushback($entry); return $largeseq; } # if ( ($entry eq '>') || eof($self->_fh) ) { $seen = 1; next; } if ( ($entry eq '>') ) { $seen = 1; next; } elsif( $entry =~ /\s*>(.+?)$/ ) { $seen = 1; ($id,$fulldesc) = ($1 =~ /^\s*(\S+)\s*(.*)$/) or $self->warn("Can't parse fasta header"); $largeseq->display_id($id); $largeseq->primary_id($id); $largeseq->desc($fulldesc); } else { $entry =~ s/\s+//g; $largeseq->add_sequence_as_string($entry); } (++$count % 1000 == 0 && $self->verbose() > 0) && print "line $count\n"; } return unless $seen; return $largeseq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; foreach my $seq (@seq) { my $top = $seq->id(); if ($seq->can('desc') and my $desc = $seq->desc()) { $desc =~ s/\n//g; $top .= " $desc"; } $self->_print (">",$top,"\n"); my $end = $seq->length(); my $start = 1; while( $start < $end ) { my $stop = $start + $FASTALINELEN - 1; $stop = $end if( $stop > $end ); $self->_print($seq->subseq($start,$stop), "\n"); $start += $FASTALINELEN; } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/lasergene.pm��������������������������������������������������������������000444��000765��000024�� 10110�12254227337� 17450� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#-----------------------------------------5~------------------------------------ # PACKAGE : Bio::SeqIO::lasergene # AUTHOR : Malcolm Cook <mec@stowers-institute.org> # CREATED : Feb 16 1999 # # _History_ # # This code is based on the Bio::SeqIO::raw module with # the necessary minor tweaks necessary to get it to read (only) # Lasergene formatted sequences # # Cleaned up by Torsten Seemann June 2006 # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::lasergene - Lasergene sequence file input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L<Bio::SeqIO> class. =head1 DESCRIPTION This object can product Bio::Seq::RichSeq objects from Lasergene sequence files. IT DOES NOT PARSE ANY ATTIBUTE VALUE PAIRS IN THE HEADER OF THE LASERGENE FORMATTED FILE. IT DOES NOT WRITE THESE FILES EITHER. =head1 REFERENCES https://www.dnastar.com/products/lasergene.php =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Torsten Seemann - torsten.seemann AT infotech.monash.edu.au Malcolm Cook - mec AT stowers-institute.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::lasergene; use strict; use base qw(Bio::SeqIO); =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : none =cut use Bio::Seq; use Bio::Annotation::Collection; use Bio::Annotation::Comment; sub next_seq { my ($self) = @_; my $state = 0; my @comment; my @sequence; while (my $line = $self->_readline) { $state = 1 if $state == 0; chomp $line; next if $line =~ m/^\s*$/; # skip blank lines if ($line eq '^^') { # end of a comment or sequence $state++; last if $state > 2; # we have comment and sequence so exit } elsif ($state == 1) { # another piece of comment push @comment, $line; } elsif ($state == 2) { # another piece of sequence push @sequence, $line } else { $self->throw("unreachable state reached, probable bug!"); } } # return quietly if there was nothing in the file return if $state == 0; # ensure we read some comment and some sequence if ($state < 2) { $self->throw("unexpected end of file"); } my $sequence = join('', @sequence); # print STDERR "SEQ=[[$sequence]]\n"; $sequence or $self->throw("empty sequence in lasergene file"); my $seq = Bio::Seq->new(-seq => $sequence); my $comment = join('; ', @comment); # print STDERR "COM=[[$comment]]\n"; my $anno = Bio::Annotation::Collection->new; $anno->add_Annotation('comment', Bio::Annotation::Comment->new(-text => $comment) ); $seq->annotation($anno); return $seq; } =head2 write_seq (NOT IMPLEMENTED) Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Array of Bio::PrimarySeqI objects =cut sub write_seq { my ($self, @seq) = @_; $self->throw("write_seq() is not implemented for the lasergene format."); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/locuslink.pm��������������������������������������������������������������000444��000765��000024�� 36130�12254227326� 17516� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::locuslink # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Keith Ching <kching at gnf.org> # # Copyright Keith Ching # # You may distribute this module under the same terms as perl itself # # (c) Keith Ching, kching at gnf.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::locuslink - LocusLink input/output stream =head1 SYNOPSIS # don't instantiate directly - instead do my $seqio = Bio::SeqIO->new(-format => "locuslink", -file => \STDIN); =head1 DESCRIPTION This module parses LocusLink into Bio::SeqI objects with rich annotation, but no sequence. The input file has to be in the LL_tmpl format - the tabular format will not work. The way the current implementation populates the object is rather a draft work than a finished work of art. Note that at this stage the LocusLink entries cannot be round-tripped, because the parser loses certain information. For instance, most of the alternative transcript descriptions are not retained. The parser also misses any element that deals with visual representation (e.g., 'button') except for the URLs. Almost all of the pieces of the annotation are kept in a Bio::Annotation::Collection object, see L<Bio::Annotation::Collection> for more information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Keith Ching Email kching at gnf.org =head1 CONTRIBUTORS Hilmar Lapp, hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::locuslink; use strict; use Bio::Seq::SeqFactory; use Bio::Species; use Bio::Annotation::DBLink; #use Bio::Annotation::Reference; use Bio::Annotation::Comment; use Bio::Annotation::SimpleValue; use Bio::Annotation::OntologyTerm; use Bio::Annotation::Collection; use base qw(Bio::SeqIO); # list of all the field names in locuslink my @locuslink_keys = qw( ACCNUM ALIAS_PROT ALIAS_SYMBOL ASSEMBLY BUTTON CDD CHR COMP CONTIG CURRENT_LOCUSID DB_DESCR DB_LINK ECNUM EVID EXTANNOT GO GRIF LINK LOCUSID LOCUS_CONFIRMED LOCUS_TYPE MAP MAPLINK NC NG NM NP NR OFFICIAL_GENE_NAME OFFICIAL_SYMBOL OMIM ORGANISM PHENOTYPE PHENOTYPE_ID PMID PREFERRED_GENE_NAME PREFERRED_PRODUCT PREFERRED_SYMBOL PRODUCT PROT RELL STATUS STS SUMFUNC SUMMARY TRANSVAR TYPE UNIGENE XG XM XP XR ); # list of fields to make simple annotations from # fields not listed here or as a key in feature hash are ignored (lost). my %anntype_map = ( SimpleValue => [qw( ALIAS_PROT ALIAS_SYMBOL CDD CHR CURRENT_LOCUSID ECNUM EXTANNOT MAP NC NR OFFICIAL_GENE_NAME OFFICIAL_SYMBOL PHENOTYPE PREFERRED_GENE_NAME PREFERRED_PRODUCT PREFERRED_SYMBOL PRODUCT RELL SUMFUNC ) ], Comment => [qw( SUMMARY ) ], ); # certain fields are not named the same as the symgene database list my %dbname_map = ( pfam => 'Pfam', smart => 'SMART', NM => 'RefSeq', NP => 'RefSeq', XP => 'RefSeq', XM => 'RefSeq', NG => 'RefSeq', XG => 'RefSeq', XR => 'RefSeq', PROT => 'GenBank', ACCNUM => 'GenBank', CONTIG => 'GenBank', # certain fields are not named the same as the symgene # database list: rename the fields the symgene database name # key = field name in locuslink # value = database name in sym #GO => 'GO', OMIM => 'MIM', GRIF => 'GRIF', STS => 'STS', UNIGENE => 'UniGene', ); # certain CDD entries use the wrong prefix for the accession number # cddprefix will replace the key w/ the value for these entries my %cddprefix = ( pfam => 'PF', smart => 'SM', ); # alternate mappings if one field does not exist my %alternate_map = ( OFFICIAL_GENE_NAME => 'PREFERRED_GENE_NAME', OFFICIAL_SYMBOL => 'PREFERRED_SYMBOL', ); # for these field names, we only care about the first value X in value X|Y|Z my @ll_firstelements = qw( NM NP NG XG XM XP XR PROT STS ACCNUM CONTIG GRIF ); # these fields need to be flattened into a single string, using the given # join string my %flatten_tags = ( ASSEMBLY => ',', ORGANISM => '', # this should occur only once OFFICIAL_SYMBOL => '', # this should occur only once OFFICIAL_GENE_NAME => '', # this should occur only once LOCUSID => '', # this should occur only once PMID => ',', PREFERRED_SYMBOL => ', ', PREFERRED_GENE_NAME => ', ' ); # set the default search pattern for all the field names my %feature_pat_map = map { ($_ , "^$_: (.+)\n"); } @locuslink_keys; sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # overwrite the search pattern w/ the first value pattern foreach my $key(@ll_firstelements){ $feature_pat_map{$key}="^$key: ([^|]+)"; } # special search pattern for cdd entries foreach my $key(keys %cddprefix) { $feature_pat_map{$key}='^CDD: .+\|'.$key.'(\d+)'; } # special patterns for specific fields $feature_pat_map{MAP} = '^MAP: (.+?)\|'; $feature_pat_map{MAPHTML} = '^MAP: .+\|(<.+>)\|'; $feature_pat_map{GO} = '^GO: .+\|.+\|\w+\|(GO:\d+)\|'; $feature_pat_map{GO_DESC} = '^GO: .+\|(.+)\|\w+\|GO:\d+\|'; $feature_pat_map{GO_CAT} = '^GO: (.+)\|.+\|\w+\|GO:\d+\|'; $feature_pat_map{EXTANNOT} = '^EXTANNOT: (.+)\|(.+)\|\w+\|.+\|\d+'; # set the sequence factory of none has been set already if(! $self->sequence_factory()) { $self->sequence_factory(Bio::Seq::SeqFactory->new( -type => 'Bio::Seq::RichSeq')); } } ######################### # sub search_pattern{ # ######################### my ($self, $entry, #text to search $searchconfirm, #to make sure you got the right thing $searchpattern, $searchtype) = @_; my @query = $entry=~/$searchpattern/gm; if ($searchconfirm ne "FALSE"){ $self->warn("No $searchtype found\n$entry\n") unless @query; foreach (@query){ if (!($_=~/$searchconfirm/)){ $self->throw("error\n$entry\n$searchtype parse $_ does not match $searchconfirm\n"); } }#endforeach }#endsearchconfirm return(@query); }#endsub ############ # sub read_species{ # ############ my ($spline)=@_; my $species; my $genus; ($genus,$species)=$spline=~/([^ ]+) ([^ ]+)/; my $make = Bio::Species->new(); $make->classification( ($species,$genus) ); return $make; } ################ # sub read_dblink{ # ################ my ($ann,$db,$ref)=@_; my @results=$ref ? @$ref : (); foreach my $id(@results){ if($id){ $ann->add_Annotation('dblink', Bio::Annotation::DBLink->new( -database =>$db , -primary_id =>$id)); } } return($ann); } ################ # sub read_reference{ # ################ my ($ann,$db,$results)=@_; if($results){ chomp($results); my @ids=split(/,/,$results); $ann = read_dblink($ann,$db,\@ids) if @ids; } return $ann; }#endsub ################ # sub add_annotation{ # ################ my ($ac,$type,$text,$anntype)=@_; my @args; $anntype = 'SimpleValue' unless $anntype; SWITCH : { $anntype eq 'SimpleValue' && do { push(@args, -value => $text, -tagname => $type); last SWITCH; }; $anntype eq 'Comment' && do { push(@args, -text => $text, -tagname => 'comment'); last SWITCH; }; } $ac->add_Annotation("Bio::Annotation::$anntype"->new(@args)); return($ac); }#endsub ################ # sub add_annotation_ref{ # ################ my ($ann,$type,$textref)=@_; my @text=$textref ? @$textref : (); foreach my $text(@text){ $ann->add_Annotation($type,Bio::Annotation::SimpleValue->new(-value => $text)); } return($ann); }#endsub ################ # sub make_unique{ # ############## my ($ann,$key) = @_; my %seen = (); foreach my $dbl ($ann->remove_Annotations($key)) { if(!exists($seen{$dbl->as_text()})) { $seen{$dbl->as_text()} = 1; $ann->add_Annotation($dbl); } } return $ann; } ################ # sub next_seq{ # ############## my ($self, @args)=@_; my (@results,$search,$ref,$cddref); # LOCUSLINK entries begin w/ >> local $/="\n>>"; # slurp in a whole entry and return if no more entries return unless my $entry = $self->_readline; # strip the leading '>>' if it's the first entry if (index($entry,'>>') == 0) { #first entry $entry = substr($entry,2); } # we aren't interested in obsoleted entries, so we need to loop # and skip those until we've found the next not obsoleted my %record = (); while($entry && ($entry =~ /\w/)) { if (!($entry=~/LOCUSID/)){ $self->throw("No LOCUSID in first line of record. ". "Not LocusLink in my book."); } # see whether it's an obsoleted entry, and if so jump to the next # one entry right away if($entry =~ /^CURRENT_LOCUSID:/m) { # read next entry and continue $entry = $self->_readline; %record = (); next; } # loop through list of features and get field values # place into record hash as array refs foreach my $key (keys %feature_pat_map){ $search=$feature_pat_map{$key}; @results=$self->search_pattern($entry,'FALSE',$search,$search); $record{$key} = @results ? [@results] : undef; }#endfor # terminate loop as this one hasn't been obsoleted last; } # we have reached the end-of-file ... return unless %record; # special processing for CDD entries like pfam and smart my ($PRESENT,@keep); foreach my $key(keys %cddprefix){ #print "check CDD $key\n"; if($record{$key}) { @keep=(); foreach my $list (@{$record{$key}}) { # replace AC with correct AC number push(@keep,$cddprefix{$key}.$list); } # replace CDD ref with correctly prefixed AC number $record{$key} = [@keep]; } } # modify CDD references @=(); if($record{CDD}) { @keep=(); foreach my $cdd (@{$record{CDD}}) { $PRESENT = undef; foreach my $key (keys %cddprefix) { if ($cdd=~/$key/){ $PRESENT = 1; last; } } push(@keep,$cdd) if(! $PRESENT); } $record{CDD} = [@keep]; } # create annotation collection - we'll need it now my $ann = Bio::Annotation::Collection->new(); foreach my $field(keys %dbname_map){ $ann=read_dblink($ann,$dbname_map{$field},$record{$field}); } # add GO link as an OntologyTerm annotation if($record{GO}) { for(my $j = 0; $j < @{$record{GO}}; $j++) { my $goann = Bio::Annotation::OntologyTerm->new( -identifier => $record{GO}->[$j], -name => $record{GO_DESC}->[$j], -ontology => $record{GO_CAT}->[$j]); $ann->add_Annotation($goann); } } $ann=add_annotation_ref($ann,'URL',$record{LINK}); $ann=add_annotation_ref($ann,'URL',$record{DB_LINK}); # everything else gets a simple tag or comment value annotation foreach my $anntype (keys %anntype_map) { foreach my $key (@{$anntype_map{$anntype}}){ if($record{$key}){ foreach (@{$record{$key}}){ #print "$key\t\t$_\n"; $ann=add_annotation($ann,$key,$_,$anntype); } } } } # flatten designated attributes into a scalar value foreach my $field (keys %flatten_tags) { if($record{$field}) { $record{$field} = join($flatten_tags{$field}, @{$record{$field}}); } } # annotation that expects the array flattened out $ann=read_reference($ann,'PUBMED',$record{PMID}); if($record{ASSEMBLY}) { my @assembly=split(/,/,$record{ASSEMBLY}); $ann=read_dblink($ann,'GenBank',\@assembly); } # replace fields w/ alternate if original does not exist foreach my $fieldval (keys %alternate_map){ if((! $record{$fieldval}) && ($record{$alternate_map{$fieldval}})){ $record{$fieldval}=$record{$alternate_map{$fieldval}}; } } # presently we can't store types or context of dblinks - therefore # we need to remove duplicates that only differ in context make_unique($ann,'dblink'); # create sequence object (i.e., let seq.factory create one) my $seq = $self->sequence_factory->create( -verbose => $self->verbose(), -accession_number => $record{LOCUSID}, -desc => $record{OFFICIAL_GENE_NAME}, -display_id => $record{OFFICIAL_SYMBOL}, -species => read_species($record{ORGANISM}), -annotation => $ann); # dump out object contents # show_obj([$seq]); return($seq); } ################ # sub show_obj{ # ################ my ($seqlistref)=@_; my @list=@$seqlistref; my $out = Bio::SeqIO->new('-fh' => \*STDOUT, -format => 'genbank' ); my ($ann,@values,$val); foreach my $seq(@list){ $out->write_seq($seq); $ann=$seq->annotation; foreach my $key ( $ann->get_all_annotation_keys() ) { @values = $ann->get_Annotations($key); foreach my $value ( @values ) { # value is an Bio::AnnotationI, and defines a "as_text" method $val=$value->as_text; print "Annotation ",$key,"\t\t",$val,"\n"; } } } }#endsub 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/mbsout.pm�����������������������������������������������������������������000444��000765��000024�� 52106�12254227317� 17025� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# POD documentation - main docs before the code =head1 NAME Bio::SeqIO::mbsout - input stream for output by Teshima et al.'s mbs. =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION mbs (Teshima KM, Innan H (2009) mbs: modifying Hudson's ms software to generate samples of DNA sequences with a biallelic site under selection. BMC Bioinformatics 10: 166 ) can be found at http://www.biomedcentral.com/1471-2105/10/166/additional/. Currently this object can be used to read output from mbs into seq objects. However, because bioperl has no support for haplotypes created using an infinite sites model (where '1' identifies a derived allele and '0' identifies an ancestral allele), the sequences returned by mbsout are coded using A, T, C and G. To decode the bases, use the sequence conversion table (a hash) returned by get_base_conversion_table(). In the table, 4 and 5 are used when the ancestry is unclear. This should not ever happen when creating files with mbs, but it will be used when creating mbsOUT files from a collection of seq objects ( To be added later ). Alternatively, use get_next_hap() to get a string with 1's and 0's instead of a seq object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Warren Kretzschmar This module was written by Warren Kretzschmar email: wkretzsch@gmail.com This module grew out of a parser written by Aida Andres. =head1 COPYRIGHT =head2 Public Domain Notice This software/database is ``United States Government Work'' under the terms of the United States Copyright Act. It was written as part of the authors' official duties for the United States Government and thus cannot be copyrighted. This software/database is freely available to the public for use without a copyright notice. Restrictions cannot be placed on its present or future use. Although all reasonable efforts have been taken to ensure the accuracy and reliability of the software and data, the National Human Genome Research Institute (NHGRI) and the U.S. Government does not and cannot warrant the performance or results that may be obtained by using this software or data. NHGRI and the U.S. Government disclaims all warranties as to performance, merchantability or fitness for any particular purpose. =head1 METHODS =cut package Bio::SeqIO::mbsout; use version; our $API_VERSION = qv('1.1.3'); use strict; use base qw(Bio::SeqIO); # This ISA Bio::SeqIO object use Bio::Seq::SeqFactory; =head2 INTERNAL METHODS =head3 _initialize Title : _initialize Usage : $stream = Bio::SeqIO::mbsout->new($infile) Function: extracts basic information about the file. Returns : Bio::SeqIO object Args : no_og Details : include 'no_og' flag = 0 if the last population of an mbsout file contains only one haplotype and you want the last haplotype to be treated as the outgroup. =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); unless ( defined $self->sequence_factory ) { $self->sequence_factory( Bio::Seq::SeqFactory->new() ); } # Don't expect mbs to create an outgroup my ($no_og) = $self->_rearrange( [qw(NO_OG)], @args ) || 1; my %initial_values = ( RUNS => undef, SEGSITES => undef, MBS_INFO_LINE => undef, TOT_RUN_HAPS => undef, NEXT_RUN_NUM => undef, # What run is the next hap from? undef = EOF LAST_READ_HAP_NUM => undef, # What did we just read from LAST_READ_POSITIONS => [], LAST_READ_SEGSITES => undef, BUFFER_HAP => undef, NO_OUTGROUP => $no_og, OPTIONS => {}, LAST_READ_ALLELES => [], LAST_READ_TRAJECTORY_FILE => undef, LAST_READ_REPLICATION_OF_TRAJECTORY_FILE => undef, BASE_CONVERSION_TABLE_HASH_REF => { 'A' => 0, 'T' => 1, 'C' => 4, 'G' => 5, }, ); foreach my $key ( keys %initial_values ) { $self->{$key} = $initial_values{$key}; } # If the filehandle is defined open it and read a few lines if ( ref( $self->{_filehandle} ) eq 'GLOB' ) { $self->_read_start(); return $self; } # Otherwise throw a warning else { $self->throw( "No filehandle defined. Please define a file handle through -file when calling mbsout with Bio::SeqIO" ); } } =head3 _read_start Title : _read_start Usage : $stream->_read_start() Function: reads from the filehandle $stream->{_filehandle} all information up to the first haplotype (sequence). Returns : void Args : none =cut sub _read_start { my $self = shift; my $fh_IN = $self->{_filehandle}; # get the first five lines and parse for important info my ($mbs_info_line) = $self->_get_next_clean_hap( $fh_IN, 1, 1 ); my @mbs_info_line = split( /\s+/, $mbs_info_line ); # Parsing the mbs header line shift @mbs_info_line; shift @mbs_info_line; my $tot_run_haps = shift @mbs_info_line; my $runs; # $pop_mut_param_per_site is the population mutation parameter per site. my $pop_mut_param_per_site; # $pop_recomb_param_per_site is the population recombination parameter per # site. my $pop_recomb_param_per_site; # $nsites is length of the simulated region. # $selpos is position of the target site of selection relative to the first # site of the simulated region. my $nsites; my $selpos; # $nfile is number of trajectory files. # $nrep is number of replications for each trajectory. # $traj_filename is initial part of the name of the trajectory files. my $nfiles; my $nreps; my $traj_filename; foreach my $word ( 0 .. $#mbs_info_line ) { if ( $mbs_info_line[$word] eq '-t' ) { $pop_mut_param_per_site = $mbs_info_line[ $word + 1 ]; } elsif ( $mbs_info_line[$word] eq '-r' ) { $pop_recomb_param_per_site = $mbs_info_line[ $word + 1 ]; $selpos = $mbs_info_line[ $word + 2 ]; } elsif ( $mbs_info_line[$word] eq '-s' ) { $nsites = $mbs_info_line[ $word + 1 ]; $selpos = $mbs_info_line[ $word + 2 ]; } elsif ( $mbs_info_line[$word] eq '-f' ) { $nfiles = $mbs_info_line[ $word + 1 ]; $nreps = $mbs_info_line[ $word + 2 ]; $traj_filename = $mbs_info_line[ $word + 3 ]; $runs = $nfiles * $nreps; } else { next; } } # Save mbs info data $self->{RUNS} = $runs; $self->{MBS_INFO_LINE} = $mbs_info_line; $self->{TOT_RUN_HAPS} = $tot_run_haps; $self->{POP_MUT_PARAM_PER_SITE} = $pop_mut_param_per_site; $self->{POP_RECOMB_PARAM_PER_SITE} = $pop_recomb_param_per_site; $self->{NSITES} = $nsites; $self->{SELPOS} = $selpos; $self->{NFILES} = $nfiles; $self->{NREPS} = $nreps; $self->{TRAJ_FILENAME} = $traj_filename; } =head2 Methods to retrieve mbsout data =head3 get_segsites Title : get_segsites Usage : $segsites = $stream->get_segsites() Function: returns the number segsites in the mbsout file (according to the mbsout header line). Returns : scalar Args : NONE =cut sub get_segsites { my $self = shift; if ( defined $self->{SEGSITES} ) { return $self->{SEGSITES}; } else { return $self->get_current_run_segsites; } } =head3 get_current_run_segsites Title : get_current_run_segsites Usage : $segsites = $stream->get_current_run_segsites() Function: returns the number of segsites in the run of the last read haplotype (sequence). Returns : scalar Args : NONE =cut sub get_current_run_segsites { my $self = shift; return $self->{LAST_READ_SEGSITES}; } =head3 get_pop_mut_param_per_site Title : get_pop_mut_param_per_site Usage : $pop_mut_param_per_site = $stream->get_pop_mut_param_per_site() Function: returns 4*N0*mu or the "population mutation parameter per site" Returns : scalar Args : NONE =cut sub get_pop_mut_param_per_site { my $self = shift; return $self->{POP_MUT_PARAM_PER_SITE}; } =head3 get_pop_recomb_param_per_site Title : get_pop_recomb_param_per_site Usage : $pop_recomb_param_per_site = $stream->get_pop_recomb_param_per_site() Function: returns 4*N0*r or the "population recombination parameter per site" Returns : scalar Args : NONE =cut sub get_pop_recomb_param_per_site { my $self = shift; return $self->{POP_RECOMB_PARAM_PER_SITE}; } =head3 get_nsites Title : get_nsites Usage : $nsites = $stream->get_nsites() Function: returns the number of sites simulated by mbs. Returns : scalar Args : NONE =cut sub get_nsites { my $self = shift; return $self->{NSITES}; } =head3 get_selpos Title : get_selpos Usage : $selpos = $stream->get_selpos() Function: returns the location on the chromosome where the allele is located that was selected for by mbs. Returns : scalar Args : NONE =cut sub get_selpos { my $self = shift; return $self->{SELPOS}; } =head3 get_nreps Title : get_nreps Usage : $nreps = $stream->get_nreps() Function: returns the number replications done by mbs on each trajectory file to create the mbsout file. Returns : scalar Args : NONE =cut sub get_nreps { my $self = shift; return $self->{NREPS}; } =head3 get_nfiles Title : get_nfiles Usage : $nfiles = $stream->get_nfiles() Function: returns the number of trajectory files used by mbs to create the mbsout file Returns : scalar Args : NONE =cut sub get_nfiles { my $self = shift; return $self->{NFILES}; } =head3 get_traj_filename Title : get_traj_filename Usage : $traj_filename = $stream->get_traj_filename() Function: returns the prefix of the trajectory files used by mbs to create the mbsout file Returns : scalar Args : NONE =cut sub get_traj_filename { my $self = shift; return $self->{TRAJ_FILENAME}; } =head3 get_runs Title : get_runs Usage : $runs = $stream->get_runs() Function: returns the number of runs in the mbsout file Returns : scalar Args : NONE =cut sub get_runs { my $self = shift; return $self->{RUNS}; } =head3 get_Positions Title : get_Positions Usage : @positions = $stream->get_Positions() Function: returns an array of the names of each segsite of the run of the last read hap. Returns : array Args : NONE =cut sub get_Positions { my $self = shift; return @{ $self->{LAST_READ_POSITIONS} }; } =head3 get_tot_run_haps Title : get_tot_run_haps Usage : $number_of_haps_per_run = $stream->get_tot_run_haps() Function: returns the number of haplotypes (sequences) in each run of the mbsout file. Returns : scalar >= 0 Args : NONE =cut sub get_tot_run_haps { my $self = shift; return $self->{TOT_RUN_HAPS}; } =head3 get_mbs_info_line Title : get_mbs_info_line Usage : $mbs_info_line = $stream->get_mbs_info_line() Function: returns the header line of the mbsout file. Returns : scalar Args : NONE =cut sub get_mbs_info_line { my $self = shift; return $self->{MBS_INFO_LINE}; } =head3 tot_haps Title : tot_haps Usage : $number_of_haplotypes_in_file = $stream->tot_haps() Function: returns the number of haplotypes (sequences) in the mbsout file. Information gathered from mbsout header line. Returns : scalar Args : NONE =cut sub get_tot_haps { my $self = shift; return ( $self->{TOT_RUN_HAPS} * $self->{RUNS} ); } =head3 next_run_num Title : next_run_num Usage : $next_run_number = $stream->next_run_num() Function: returns the number of the mbs run that the next haplotype (sequence) will be taken from (starting at 1). Returns undef if the complete file has been read. Returns : scalar > 0 or undef Args : NONE =cut sub get_next_run_num { my $self = shift; return $self->{NEXT_RUN_NUM}; } =head3 get_last_haps_run_num Title : get_last_haps_run_num Usage : $last_haps_run_number = $stream->get_last_haps_run_num() Function: returns the number of the ms run that the last haplotype (sequence) was taken from (starting at 1). Returns undef if no hap has been read yet. Returns : scalar > 0 or undef Args : NONE =cut sub get_last_haps_run_num { my $self = shift; return $self->{LAST_HAPS_RUN_NUM}; } =head3 get_last_read_hap_num Title : get_last_read_hap_num Usage : $last_read_hap_num = $stream->get_last_read_hap_num() Function: returns the number (starting with 1) of the last haplotype read from the mbs file Returns : scalar >= 0 Args : NONE Details : 0 means that no haplotype has been read yet. =cut sub get_last_read_hap_num { my $self = shift; return $self->{LAST_READ_HAP_NUM}; } =head3 outgroup Title : outgroup Usage : $outgroup = $stream->outgroup() Function: returns '1' if the mbsout object has an outgroup. Returns '0' otherwise. Returns : 1 or 0, currently always 0 Args : NONE Details : This method will return '1' only if the last population in the mbsout file contains only one haplotype. If the last population is not an outgroup then create the mbsout object using 'no_outgroup' as input parameter for new() (see mbsout->new()). Currently there exists no way of introducing an outgroup into an mbs file, so this function will always return '0'. =cut sub outgroup { my $self = shift; if ( $self->{NO_OUTGROUP} ) { return 0; } else { return 0; } } =head3 get_next_seq Title : get_next_seq Usage : $seq = $stream->get_next_seq() Function: reads and returns the next sequence (haplotype) in the stream Returns : Bio::Seq object Args : NONE Note : This function is included only to conform to convention. It only calls next_hap() and passes on that method's return value. Use next_hap() instead for better performance. =cut sub get_next_seq { my $self = shift; my $seqstring = $self->get_next_hap; return unless defined $seqstring; # Used to create unique ID; my $run = $self->get_last_haps_run_num; # Converting numbers to letters so that the haplotypes can be stored as a # seq object my $rh_base_conversion_table = $self->get_base_conversion_table; foreach my $base ( keys %{$rh_base_conversion_table} ) { $seqstring =~ s/($rh_base_conversion_table->{$base})/$base/g; } my $last_read_hap = $self->get_last_read_hap_num; my $id = 'Hap_' . $last_read_hap . '_Run_' . $run; my $description = 'Segsites ' . $self->get_current_run_segsites . "; Positions $self->positions; Haplotype " . $last_read_hap . '; Run ' . $run . ';'; my $seq = $self->sequence_factory->create( -seq => $seqstring, -id => $id, -desc => $description, -alphabet => q(dna), -direct => 1, ); return $seq; } =head3 get_next_hap Title : get_next_hap Usage : $seq = $stream->get_next_hap() Function: reads and returns the next sequence (haplotype) in the stream. Returns void if all sequences in stream have been read. Returns : Bio::Seq object Args : NONE Note : Use this instead of get_next_seq(). =cut sub get_next_hap { my $self = shift; # Let's figure out how many haps to read from the input file so that # we get back to the beginning of the next run. my $end_run = 0; if ( $self->{TOT_RUN_HAPS} == $self->{LAST_READ_HAP_NUM} + 1 ) { $end_run = 1; } # Setting last_haps_run_num $self->{LAST_HAPS_RUN_NUM} = $self->get_next_run_num; my $fh_IN = $self->{_filehandle}; my ($seqstring) = $self->_get_next_clean_hap( $self->{_filehandle}, 1, $end_run ); return $seqstring; } =head3 get_next_run Title : get_next_run Usage : @seqs = $stream->get_next_run() Function: reads and returns all the remaining sequences (haplotypes) in the mbs run of the next sequence. Returns : array of Bio::Seq objects Args : NONE =cut sub get_next_run { my $self = shift; # Let's figure out how many haps to read from the input file so that # we get back to the beginning of the next run. my $haps_to_pull = $self->{TOT_RUN_HAPS} - $self->{LAST_READ_HAP_NUM}; # Read those haps from the input file # Next hap read will be the first hap of the next run. my @seqs; for ( 1 .. $haps_to_pull ) { my $seq = $self->get_next_seq; next unless defined $seq; push @seqs, $seq; } return @seqs; } =head2 METHODS TO RETRIEVE CONSTANTS =head3 base_conversion_table Title : get_base_conversion_table Usage : $table_hash_ref = $stream->get_base_conversion_table() Function: returns a reference to a hash. The keys of the hash are the letters 'A','T','G','C'. The values associated with each key are the value that each letter in the sequence of a seq object returned by a Bio::SeqIO::mbsout stream should be translated to. Returns : reference to a hash Args : NONE Synopsys: # retrieve the Bio::Seq object's sequence my $haplotype = $seq->seq; my $rh_base_conversion_table = $stream->get_base_conversion_table(); # need to convert all letters to their corresponding numbers. foreach my $base (keys %{$rh_base_conversion_table}){ $haplotype =~ s/($base)/$rh_base_conversion_table->{$base}/g; } # $haplotype is now an ms style haplotype. (e.g. '100101101455') =cut sub get_base_conversion_table { my $self = shift; return $self->{BASE_CONVERSION_TABLE_HASH_REF}; } ############################################################################## ## subs for internal use only ############################################################################## sub _get_next_clean_hap { #By Warren Kretzschmar # return the next non-empty line from file handle (chomped line) # skipps to the next run if '//' is encountered my ( $self, $fh, $times, $end_run ) = @_; my @data; unless ( defined $fh ) { return; } unless ( defined $times && $times > 0 ) { $times = 1; } if ( defined $self->{BUFFER_HAP} ) { push @data, $self->{BUFFER_HAP}; $self->{BUFFER_HAP} = undef; $self->{LAST_READ_HAP_NUM}++; $times--; } while ( 1 <= $times-- ) { # Find next clean line my $data = <$fh>; last if !defined($data); chomp $data; while ( $data !~ /./ ) { $data = <$fh>; chomp $data; } # If the next run is encountered here, then we have a programming # or format error if ( $data eq '//' ) { $self->throw("'//' found when not expected\n") } $self->{LAST_READ_HAP_NUM}++; push @data, $data; } if ($end_run) { $self->_load_run_info($fh); } return (@data); } sub _load_run_info { my ( $self, $fh ) = @_; my $data = <$fh>; # In this case we are at EOF if ( !defined($data) ) { $self->{NEXT_RUN_NUM} = undef; return; } chomp $data; while ( $data !~ /./ ) { $data = <$fh>; # In this case we are at EOF if ( !defined($data) ) { $self->{NEXT_RUN_NUM} = undef; return; } chomp $data; } # If the next run is encountered, then skip to the next hap and save it in # the buffer. if ( $data =~ /^\/\// ) { $self->{NEXT_RUN_NUM}++; $self->{LAST_READ_HAP_NUM} = 0; my @data = split( /\s+/, $data ); my @temp = split( /\/\//, $data[0] ); @temp = split( /-/, $temp[0] ); $self->{LAST_READ_TRAJ_FILE} = $temp[0]; $self->{LAST_LEAD_TRAJ_FILE_REPLICATION} = $temp[1]; $self->{LAST_READ_ALLELES} = \@data[ 2 .. $#data ]; for ( 1 .. 3 ) { $data = <$fh>; while ( $data !~ /./ ) { $data = <$fh>; } chomp $data; @data = split( /\s+/, $data ); if ( $_ eq '1' ) { $self->{LAST_READ_SEGSITES} = $data[1]; } elsif ( $_ eq '2' ) { $self->{LAST_READ_POSITIONS} = [ @data[ 1 .. $#data ] ]; } else { if ( !defined($data) ) { $self->throw("run $self->{NEXT_RUN_NUM} has no haps./n"); } $self->{BUFFER_HAP} = $data; } } } else { $self->throw("'//' not encountered when expected\n") } } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/metafasta.pm��������������������������������������������������������������000444��000765��000024�� 14430�12254227324� 17455� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::metafasta # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::metafasta - metafasta sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. use Bio::SeqIO; # read the metafasta file $io = Bio::SeqIO->new(-file => "test.metafasta", -format => "metafasta" ); $seq = $io->next_seq; =head1 DESCRIPTION This object can transform Bio::Seq::Meta objects to and from metafasta flat file databases. For sequence part the code is an exact copy of Bio::SeqIO::fasta module. The only added bits deal with meta data IO. The format of a metafasta file is >test ABCDEFHIJKLMNOPQRSTUVWXYZ &charge NBNAANCNJCNNNONNCNNUNNXNZ &chemical LBSAARCLJCLSMOIMCHHULRXRZ where the sequence block is followed by one or several meta blocks. Each meta block starts with the ampersand character '&' in the first column and is immediately followed by the name of the meta data which continues until the new line. The meta data follows it. All characters, except new line, are important in meta data. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::metafasta; use vars qw($WIDTH); use strict; use Bio::Seq::SeqFactory; use Bio::Seq::SeqFastaSpeedFactory; use Bio::Seq::Meta; use base qw(Bio::SeqIO); BEGIN { $WIDTH = 60} sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($width) = $self->_rearrange([qw(WIDTH)], @args); $width && $self->width($width); unless ( defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFastaSpeedFactory->new()); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : NONE =cut sub next_seq { my( $self ) = @_; my $seq; my $alphabet; local $/ = "\n>"; return unless my $entry = $self->_readline; chomp($entry); if ($entry =~ m/\A\s*\Z/s) { # very first one return unless $entry = $self->_readline; chomp($entry); } $entry =~ s/^>//; my ($top,$sequence) = split(/\n/,$entry,2); defined $sequence && $sequence =~ s/>//g; my @metas; ($sequence, @metas) = split /\n&/, $sequence; my ($id,$fulldesc); if( $top =~ /^\s*(\S+)\s*(.*)/ ) { ($id,$fulldesc) = ($1,$2); } if (defined $id && $id eq '') {$id=$fulldesc;} # FIX incase no space # between > and name \AE defined $sequence && $sequence =~ s/\s//g; # Remove whitespace # for empty sequences we need to know the mol.type $alphabet = $self->alphabet(); if(defined $sequence && length($sequence) == 0) { if(! defined($alphabet)) { # let's default to dna $alphabet = "dna"; } } else { # we don't need it really, so disable $alphabet = undef; } $seq = $self->sequence_factory->create( -seq => $sequence, -id => $id, # Ewan's note - I don't think this healthy # but obviously to taste. #-primary_id => $id, -desc => $fulldesc, -alphabet => $alphabet, -direct => 1, ); $seq = $seq->primary_seq; bless $seq, 'Bio::Seq::Meta'; foreach my $meta (@metas) { my ($name,$string) = split /\n/, $meta; # $split ||= ''; $string =~ s/\n//g; # Remove newlines, spaces are important $seq->named_meta($name, $string); } # if there wasn't one before, set the guessed type unless ( defined $alphabet ) { $self->alphabet($seq->alphabet()); } return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::PrimarySeqI objects =cut sub write_seq { my ($self,@seq) = @_; my $width = $self->width; foreach my $seq (@seq) { $self->throw("Did not provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); my $str = $seq->seq; my $top = $seq->display_id(); if ($seq->can('desc') and my $desc = $seq->desc()) { $desc =~ s/\n//g; $top .= " $desc"; } if(length($str) > 0) { $str =~ s/(.{1,$width})/$1\n/g; } else { $str = "\n"; } $self->_print (">",$top,"\n",$str) or return; if ($seq->isa('Bio::Seq::MetaI')) { foreach my $meta ($seq->meta_names) { my $str = $seq->named_meta($meta); $str =~ s/(.{1,$width})/$1\n/g; $self->_print ("&",$meta,"\n",$str); } } } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 width Title : width Usage : $obj->width($newval) Function: Get/Set the line width for METAFASTA output Returns : value of width Args : newvalue (optional) =cut sub width{ my ($self,$value) = @_; if( defined $value) { $self->{'width'} = $value; } return $self->{'width'} || $WIDTH; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/msout.pm������������������������������������������������������������������000444��000765��000024�� 62017�12254227331� 16661� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# POD documentation - main docs before the code =head1 NAME Bio::SeqIO::msout - input stream for output by Hudson's ms =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION ms ( Hudson, R. R. (2002) Generating samples under a Wright-Fisher neutral model. Bioinformatics 18:337-8 ) can be found at http://home.uchicago.edu/~rhudson1/source/mksamples.html. Currently, this object can be used to read output from ms into seq objects. However, because bioperl has no support for haplotypes created using an infinite sites model (where '1' identifies a derived allele and '0' identifies an ancestral allele), the sequences returned by msout are coded using A, T, C and G. To decode the bases, use the sequence conversion table (a hash) returned by get_base_conversion_table(). In the table, 4 and 5 are used when the ancestry is unclear. This should not ever happen when creating files with ms, but it will be used when creating msOUT files from a collection of seq objects ( To be added later ). Alternatively, use get_next_hap() to get a string with 1's and 0's instead of a seq object. =head2 Mapping to Finite Sites This object can now also be used to map haplotypes created using an infinite sites model to sequences of arbitrary finite length. See set_n_sites() for more detail. Thanks to Filipe G. Vieira <fgvieira@berkeley.edu> for the idea and code. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Warren Kretzschmar This module was written by Warren Kretzschmar email: wkretzsch@gmail.com This module grew out of a parser written by Aida Andres. =head1 COPYRIGHT =head2 Public Domain Notice This software/database is ``United States Government Work'' under the terms of the United States Copyright Act. It was written as part of the authors' official duties for the United States Government and thus cannot be copyrighted. This software/database is freely available to the public for use without a copyright notice. Restrictions cannot be placed on its present or future use. Although all reasonable efforts have been taken to ensure the accuracy and reliability of the software and data, the National Human Genome Research Institute (NHGRI) and the U.S. Government does not and cannot warrant the performance or results that may be obtained by using this software or data. NHGRI and the U.S. Government disclaims all warranties as to performance, merchantability or fitness for any particular purpose. =head1 METHODS =cut package Bio::SeqIO::msout; use version; our $API_VERSION = qv('1.1.8'); use strict; use base qw(Bio::SeqIO); # This ISA Bio::SeqIO object use Bio::Seq::SeqFactory; =head2 Methods for Internal Use =head3 _initialize Title : _initialize Usage : $stream = Bio::SeqIO::msOUT->new($infile) Function: extracts basic information about the file. Returns : Bio::SeqIO object Args : no_og, gunzip, gzip, n_sites Details : - include 'no_og' flag if the last population of an msout file contains only one haplotype and you don't want the last haplotype to be treated as the outgroup ( suggested when reading data created by ms ). - including 'n_sites' (positive integer) causes all output haplotypes to be mapped to a sequence of length 'n_sites'. See set_n_sites() for more details. =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); unless ( defined $self->sequence_factory ) { $self->sequence_factory( Bio::Seq::SeqFactory->new() ); } my ($no_og) = $self->_rearrange( [qw(NO_OG)], @args ); my ($n_sites) = $self->_rearrange( [qw(N_SITES)], @args ); my %initial_values = ( RUNS => undef, N_SITES => undef, SEGSITES => undef, SEEDS => [], MS_INFO_LINE => undef, TOT_RUN_HAPS => undef, POPS => [], NEXT_RUN_NUM => undef, # What run is the next hap from? undef = EOF LAST_READ_HAP_NUM => undef, # What did we just read from LAST_HAPS_RUN_NUM => undef, LAST_READ_POSITIONS => [], LAST_READ_SEGSITES => undef, BUFFER_HAP => undef, NO_OUTGROUP => $no_og, BASE_CONVERSION_TABLE_HASH_REF => { 'A' => 0, 'T' => 1, 'C' => 4, 'G' => 5, }, ); foreach my $key ( keys %initial_values ) { $self->{$key} = $initial_values{$key}; } $self->set_n_sites($n_sites); # If the filehandle is defined open it and read a few lines if ( ref( $self->{_filehandle} ) eq 'GLOB' ) { $self->_read_start(); return $self; } # Otherwise throw a warning else { $self->throw( "No filehandle defined. Please define a file handle through -file when calling msout with Bio::SeqIO" ); } } =head3 _read_start Title : _read_start Usage : $stream->_read_start() Function: reads from the filehandle $stream->{_filehandle} all information up to the first haplotype (sequence). Closes the filehandle if all lines have been read. Returns : void Args : none =cut sub _read_start { my $self = shift; my $fh_IN = $self->{_filehandle}; # get the first five lines and parse for important info my ( $ms_info_line, $seeds ) = $self->_get_next_clean_hap( $fh_IN, 2, 1 ); my @ms_info_line = split( /\s+/, $ms_info_line ); my ( $tot_pops, @pop_haplos ); # Parsing the ms header line shift @ms_info_line; my $tot_run_haps = shift @ms_info_line; my $runs = shift @ms_info_line; my $segsites; foreach my $word ( 0 .. $#ms_info_line ) { if ( $ms_info_line[$word] eq '-I' ) { $tot_pops = $ms_info_line[ $word + 1 ]; for my $pop_num ( 1 .. $tot_pops ) { push @pop_haplos, $ms_info_line[ $word + 1 + $pop_num ]; } # if @pop_haplos contains a non-digit, then there is an error in the msinfo line. if ( !defined $pop_haplos[-1] || $pop_haplos[-1] =~ /\D/ ) { $self->throw( "Incorrect number of populations in the ms info line (after the -I specifier)" ); } } elsif ( $ms_info_line[$word] eq '-s' ) { $segsites = $ms_info_line[ $word + 1 ]; } else { next; } } unless (@pop_haplos) { @pop_haplos = ($tot_run_haps) } my @seeds = split( /\s+/, $seeds ); # Save ms info data $self->{RUNS} = $runs; $self->{SEGSITES} = $segsites; $self->{SEEDS} = \@seeds; $self->{MS_INFO_LINE} = $ms_info_line; $self->{TOT_RUN_HAPS} = $tot_run_haps; $self->{POPS} = [@pop_haplos]; return; } =head2 Methods to Access Data =head3 get_segsites Title : get_segsites Usage : $segsites = $stream->get_segsites() Function: returns the number of segsites in the msOUT file (according to the msOUT header line's -s option), or the current run's segsites if -s was not specified in the command line (in this case the number of segsites varies from run to run). Returns : scalar Args : NONE =cut sub get_segsites { my $self = shift; if ( defined $self->{SEGSITES} ) { return $self->{SEGSITES}; } else { return $self->get_current_run_segsites; } } =head3 get_current_run_segsites Title : get_current_run_segsites Usage : $segsites = $stream->get_current_run_segsites() Function: returns the number of segsites in the run of the last read haplotype (sequence). Returns : scalar Args : NONE =cut sub get_current_run_segsites { my $self = shift; return $self->{LAST_READ_SEGSITES}; } =head3 get_n_sites Title : get_n_sites Usage : $n_sites = $stream->get_n_sites() Function: Gets the number of total sites (variable or not) to be output. Returns : scalar if n_sites option is defined at call time of new() Args : NONE Note : WARNING: Final sequence length might not be equal to n_sites if n_sites is too close to number of segregating sites in the msout file. =cut sub get_n_sites { my ($self) = @_; return $self->{N_SITES}; } =head3 set_n_sites Title : set_n_sites Usage : $n_sites = $stream->set_n_sites($value) Function: Sets the number of total sites (variable or not) to be output. Returns : 1 on success; throws an error if $value is not a positive integer or undef Args : positive integer Note : WARNING: Final sequence length might not be equal to n_sites if it is too close to number of segregating sites. - n_sites needs to be at least as large as the number of segsites of the next haplotype returned - n_sites may also be set to undef, in which case haplotypes are returned under the infinite sites model assumptions. =cut sub set_n_sites { my ( $self, $value ) = @_; # make sure $value is a positive integer if it is defined if ( defined $value ) { $self->throw( "first argument needs to be a positive integer. argument supplied: $value" ) unless ( $value =~ m/^\d+$/ && $value > 0 ); } $self->{N_SITES} = $value; return 1; } =head3 get_runs Title : get_runs Usage : $runs = $stream->get_runs() Function: returns the number of runs in the msOUT file (according to the msinfo line) Returns : scalar Args : NONE =cut sub get_runs { my $self = shift; return $self->{RUNS}; } =head3 get_Seeds Title : get_Seeds Usage : @seeds = $stream->get_Seeds() Function: returns an array of the seeds used in the creation of the msOUT file. Returns : array Args : NONE Details : In older versions, ms used three seeds. Newer versions of ms seem to use only one (longer) seed. This function will return all the seeds found. =cut sub get_Seeds { my $self = shift; return @{ $self->{SEEDS} }; } =head3 get_Positions Title : get_Positions Usage : @positions = $stream->get_Positions() Function: returns an array of the names of each segsite of the run of the last read hap. Returns : array Args : NONE Details : The Positions may or may not vary from run to run depending on the options used with ms. =cut sub get_Positions { my $self = shift; return @{ $self->{LAST_READ_POSITIONS} }; } =head3 get_tot_run_haps Title : get_tot_run_haps Usage : $number_of_haps_per_run = $stream->get_tot_run_haps() Function: returns the number of haplotypes (sequences) in each run of the msOUT file ( according to the msinfo line ). Returns : scalar >= 0 Args : NONE Details : This number should not vary from run to run. =cut sub get_tot_run_haps { my $self = shift; return $self->{TOT_RUN_HAPS}; } =head3 get_ms_info_line Title : get_ms_info_line Usage : $ms_info_line = $stream->get_ms_info_line() Function: returns the header line of the msOUT file. Returns : scalar Args : NONE =cut sub get_ms_info_line { my $self = shift; return $self->{MS_INFO_LINE}; } =head3 tot_haps Title : tot_haps Usage : $number_of_haplotypes_in_file = $stream->tot_haps() Function: returns the number of haplotypes (sequences) in the msOUT file. Information gathered from msOUT header line. Returns : scalar Args : NONE =cut sub get_tot_haps { my $self = shift; return ( $self->{TOT_RUN_HAPS} * $self->{RUNS} ); } =head3 get_Pops Title : get_Pops Usage : @pops = $stream->pops() Function: returns an array of population sizes (order taken from the -I flag in the msOUT header line). This array will include the last hap even if it looks like an outgroup. Returns : array of scalars > 0 Args : NONE =cut sub get_Pops { my $self = shift; return @{ $self->{POPS} }; } =head3 get_next_run_num Title : get_next_run_num Usage : $next_run_number = $stream->next_run_num() Function: returns the number of the ms run that the next haplotype (sequence) will be taken from (starting at 1). Returns undef if the complete file has been read. Returns : scalar > 0 or undef Args : NONE =cut sub get_next_run_num { my $self = shift; return $self->{NEXT_RUN_NUM}; } =head3 get_last_haps_run_num Title : get_last_haps_run_num Usage : $last_haps_run_number = $stream->get_last_haps_run_num() Function: returns the number of the ms run that the last haplotype (sequence) was taken from (starting at 1). Returns undef if no hap has been read yet. Returns : scalar > 0 or undef Args : NONE =cut sub get_last_haps_run_num { my $self = shift; return $self->{LAST_HAPS_RUN_NUM}; } =head3 get_last_read_hap_num Title : get_last_read_hap_num Usage : $last_read_hap_num = $stream->get_last_read_hap_num() Function: returns the number (starting with 1) of the last haplotype read from the ms file Returns : scalar >= 0 Args : NONE Details : 0 means that no haplotype has been read yet. Is reset to 0 every run. =cut sub get_last_read_hap_num { my $self = shift; return $self->{LAST_READ_HAP_NUM}; } =head3 outgroup Title : outgroup Usage : $outgroup = $stream->outgroup() Function: returns '1' if the msOUT stream has an outgroup. Returns '0' otherwise. Returns : '1' or '0' Args : NONE Details : This method will return '1' only if the last population in the msOUT file contains only one haplotype. If the last population is not an outgroup then create the msOUT object using 'no_og' as input flag. Also, return 0, if the run has only one population. =cut sub outgroup { my $self = shift; my @pops = $self->get_Pops; if ( $pops[$#pops] == 1 && !defined $self->{NO_OUTGROUP} && @pops > 1 ) { return 1; } else { return 0; } } =head3 get_next_haps_pop_num Title : get_next_haps_pop_num Usage : ($next_haps_pop_num, $num_haps_left_in_pop) = $stream->get_next_haps_pop_num() Function: First return value is the population number (starting with 1) the next hap will come from. The second return value is the number of haps left to read in the population from which the next hap will come. Returns : (scalar > 0, scalar > 0) Args : NONE =cut sub get_next_haps_pop_num { my $self = shift; my $last_read_hap = $self->get_last_read_hap_num; my @pops = $self->get_Pops; foreach my $pop_num ( 0 .. $#pops ) { if ( $last_read_hap < $pops[$pop_num] ) { return ( $pop_num + 1, $pops[$pop_num] - $last_read_hap ); } else { $last_read_hap -= $pops[$pop_num] } } # In this case we're at the beginning of the next run return ( 1, $pops[0] ); } =head3 get_next_seq Title : get_next_seq Usage : $seq = $stream->get_next_seq() Function: reads and returns the next sequence (haplotype) in the stream Returns : Bio::Seq object or void if end of file Args : NONE Note : This function is included only to conform to convention. The returned Bio::Seq object holds a halpotype in coded form. Use the hash returned by get_base_conversion_table() to convert 'A', 'T', 'C', 'G' back into 1,2,4 and 5. Use get_next_hap() to retrieve the halptoype as a string of 1,2,4 and 5s instead. =cut sub get_next_seq { my $self = shift; my $seqstring = $self->get_next_hap; return unless ($seqstring); # Used to create unique ID; my $run = $self->get_last_haps_run_num; # Converting numbers to letters so that the haplotypes can be stored as a # seq object my $rh_base_conversion_table = $self->get_base_conversion_table; foreach my $base ( keys %{$rh_base_conversion_table} ) { $seqstring =~ s/($rh_base_conversion_table->{$base})/$base/g; } # Fill in non-variable positions my $segsites = $self->get_current_run_segsites; my $n_sites = $self->get_n_sites; if ( defined($n_sites) ) { # make sure that n_sites is at least as large # as segsites for each run. Throw an exception otherwise. $self->throw( "n_sites:\t$n_sites" . "\nsegsites:\t$segsites" . "\nrun:\t$run" . "\nn_sites needs to be at least the number of segsites of every run" ) unless $segsites <= $n_sites; my $seq_len = 0; my @seq; my @pos = $self->get_Positions; for ( my $i = 0 ; $i <= $#pos ; $i++ ) { $pos[$i] *= $n_sites; push( @seq, "A" x ( $pos[$i] - 1 - $seq_len ) ); $seq_len += length( $seq[-1] ); push( @seq, substr( $seqstring, $i, 1 ) ); $seq_len += length( $seq[-1] ); } push( @seq, "A" x ( $n_sites - $seq_len ) ); $seqstring = join( "", @seq ); } my $last_read_hap = $self->get_last_read_hap_num; my $id = 'Hap_' . $last_read_hap . '_Run_' . $run; my $description = "Segsites $segsites;" . " Positions " . ( defined $n_sites ? $n_sites : $segsites ) . ";" . " Haplotype $last_read_hap;" . " Run $run;"; my $seq = $self->sequence_factory->create( -seq => $seqstring, -id => $id, -desc => $description, -alphabet => q(dna), -direct => 1, ); return $seq } =head3 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: Alias to get_next_seq() Returns : Bio::Seq object or void if end of file Args : NONE Note : This function is only included for convention. It calls get_next_seq(). See get_next_seq() for details. =cut sub next_seq { my $self = shift; return $self->get_next_seq(); } =head3 get_next_hap Title : get_next_hap Usage : $hap = $stream->next_hap() Function: reads and returns the next sequence (haplotype) in the stream. Returns undef if all sequences in stream have been read. Returns : Haplotype string (e.g. '110110000101101045454000101' Args : NONE Note : Use get_next_seq() if you want the halpotype returned as a Bio::Seq object. =cut sub get_next_hap { my $self = shift; # Let's figure out how many haps to read from the input file so that # we get back to the beginning of the next run. my $end_run = 0; if ( $self->{TOT_RUN_HAPS} == $self->{LAST_READ_HAP_NUM} + 1 ) { $end_run = 1; } # Setting last_haps_run_num $self->{LAST_HAPS_RUN_NUM} = $self->get_next_run_num; my $last_read_hap = $self->get_last_read_hap_num; my ($seqstring) = $self->_get_next_clean_hap( $self->{_filehandle}, 1, $end_run ); if ( !defined $seqstring && $last_read_hap < $self->get_tot_haps ) { $self->throw( "msout file has only $last_read_hap hap(s), which is less than indicated in msinfo line ( " . $self->get_tot_haps . " )" ); } return $seqstring; } =head3 get_next_pop Title : get_next_pop Usage : @seqs = $stream->next_pop() Function: reads and returns all the remaining sequences (haplotypes) in the population of the next sequence. Returns an empty list if no more haps remain to be read in the stream Returns : array of Bio::Seq objects Args : NONE =cut sub get_next_pop { my $self = shift; # Let's figure out how many haps to read from the input file so that # we get back to the beginning of the next run. my @pops = $self->get_Pops; my @seqs; # holds Bio::Seq objects to return # Determine number of the pop that the next hap will be taken from my ( $next_haps_pop_num, $haps_to_pull ) = $self->get_next_haps_pop_num; # If $haps_to_pull == 0, then we need to pull the whole population if ( $haps_to_pull == 0 ) { $haps_to_pull = $pops[ $next_haps_pop_num - 1 ]; } for ( 1 .. $haps_to_pull ) { my $seq = $self->get_next_seq; next unless defined $seq; # Add Population number information to description $seq->display_id(" Population number $next_haps_pop_num;"); push @seqs, $seq; } return @seqs; } =head3 next_run Title : next_run Usage : @seqs = $stream->next_run() Function: reads and returns all the remaining sequences (haplotypes) in the ms run of the next sequence. Returns an empty list if all haps have been read from the stream. Returns : array of Bio::Seq objects Args : NONE =cut sub get_next_run { my $self = shift; # Let's figure out how many haps to read from the input file so that # we get back to the beginning of the next run. my ( $next_haps_pop_num, $haps_to_pull ) = $self->get_next_haps_pop_num; my @seqs; my @pops = $self->get_Pops; foreach ( $next_haps_pop_num .. $#pops ) { $haps_to_pull += $pops[$_]; } # Read those haps from the input file # Next hap read will be the first hap of the first pop of the next run. for ( 1 .. $haps_to_pull ) { my $seq = $self->get_next_seq; next unless defined $seq; push @seqs, $seq; } return @seqs; } =head2 Methods to Retrieve Constants =head3 base_conversion_table Title : get_base_conversion_table Usage : $table_hash_ref = $stream->get_base_conversion_table() Function: returns a reference to a hash. The keys of the hash are the letters ' A','T','G','C'. The values associated with each key are the value that each letter in the sequence of a seq object returned by a Bio::SeqIO::msout stream should be translated to. Returns : reference to a hash Args : NONE Synopsys: # retrieve the Bio::Seq object's sequence my $haplotype = $seq->seq; # need to convert all letters to their corresponding numbers. foreach my $base (keys %{$rh_base_conversion_table}){ $haplotype =~ s/($base)/$rh_base_conversion_table->{$base}/g; } # $haplotype is now an ms style haplotype. (e.g. '100101101455') =cut sub get_base_conversion_table { my $self = shift; return $self->{BASE_CONVERSION_TABLE_HASH_REF}; } ############################################################################## ## subs for internal use only ############################################################################## sub _get_next_clean_hap { #By Warren Kretzschmar # return the next non-empty line from file handle (chomped line) # skipps to the next run if '//' is encountered my ( $self, $fh, $times, $end_run ) = @_; my @data; unless ( ref($fh) eq q(GLOB) ) { return; } unless ( defined $times && $times > 0 ) { $times = 1; } if ( defined $self->{BUFFER_HAP} ) { push @data, $self->{BUFFER_HAP}; $self->{BUFFER_HAP} = undef; $self->{LAST_READ_HAP_NUM}++; $times--; } while ( 1 <= $times-- ) { # Find next clean line my $data = <$fh>; last if !defined($data); chomp $data; while ( $data !~ /./ ) { $data = <$fh>; chomp $data; } # If the next run is encountered here, then we have a programming # or format error if ( $data eq '//' ) { $self->throw("'//' found when not expected\n") } $self->{LAST_READ_HAP_NUM}++; push @data, $data; } if ($end_run) { $self->_load_run_info($fh); } return (@data); } sub _load_run_info { my ( $self, $fh ) = @_; my $data = <$fh>; # getting rid of excess newlines while ( defined($data) && $data !~ /./ ) { $data = <$fh>; } # In this case we are at EOF if ( !defined($data) ) { $self->{NEXT_RUN_NUM} = undef; return; } while ( $data !~ /./ ) { $data = <$fh>; chomp $data; } chomp $data; # If the next run is encountered, then skip to the next hap and save it in # the buffer. if ( $data eq '//' ) { $self->{NEXT_RUN_NUM}++; $self->{LAST_READ_HAP_NUM} = 0; for ( 1 .. 3 ) { $data = <$fh>; while ( $data !~ /./ ) { $data = <$fh>; chomp $data; } chomp $data; if ( $_ eq '1' ) { my @sites = split( /\s+/, $data ); $self->{LAST_READ_SEGSITES} = $sites[1]; } elsif ( $_ eq '2' ) { my @positions = split( /\s+/, $data ); shift @positions; $self->{LAST_READ_POSITIONS} = \@positions; } else { if ( !defined($data) ) { $self->throw("run $self->{NEXT_RUN_NUM} has no haps./n"); } $self->{BUFFER_HAP} = $data; } } } else { $self->throw( "'//' not encountered when expected. There are more haplos in one of the msOUT runs than advertised in the msinfo line." ); } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/MultiFile.pm��������������������������������������������������������������000444��000765��000024�� 11272�12254227323� 17402� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::MultiFile # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::MultiFile - Treating a set of files as a single input stream =head1 SYNOPSIS $seqin = Bio::SeqIO::MultiFile( '-format' => 'Fasta', '-files' => ['file1','file2'] ); while((my $seq = $seqin->next_seq)) { # do something with $seq } =head1 DESCRIPTION Bio::SeqIO::MultiFile provides a simple way of bundling a whole set of identically formatted sequence input files as a single stream. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::MultiFile; use strict; use base qw(Bio::SeqIO); # _initialize is where the heavy stuff will happen when new is called sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($file_array,$format) = $self->_rearrange([qw( FILES FORMAT )], @args, ); if( !defined $file_array || ! ref $file_array ) { $self->throw("Must have an array files for MultiFile"); } if( !defined $format ) { $self->throw("Must have a format for MultiFile"); } $self->{'_file_array'} = []; $self->_set_file(@$file_array); $self->_format($format); if( $self->_load_file() == 0 ) { $self->throw("Unable even to initialise the first file"); } } =head2 next_seq Title : next_seq Usage : Function: Example : Returns : Args : =cut sub next_seq{ my ($self,@args) = @_; my $seq = $self->_current_seqio->next_seq(); if( !defined $seq ) { if( $self->_load_file() == 0) { return; } else { return $self->next_seq(); } } else { return $seq; } } =head2 next_primary_seq Title : next_primary_seq Usage : Function: Example : Returns : Args : =cut sub next_primary_seq{ my ($self,@args) = @_; my $seq = $self->_current_seqio->next_primary_seq(); if( !defined $seq ) { if( $self->_load_file() == 0) { return; } else { return $self->next_primary_seq(); } } else { return $seq; } } =head2 _load_file Title : _load_file Usage : Function: Example : Returns : Args : =cut sub _load_file{ my ($self,@args) = @_; my $file = shift(@{$self->{'_file_array'}}); if( !defined $file ) { return 0; } my $seqio = Bio::SeqIO->new( '-format' => $self->_format(), -file => $file); # should throw an exception - but if not... if( !defined $seqio) { $self->throw("no seqio built for $file!"); } $self->_current_seqio($seqio); return 1; } =head2 _set_file Title : _set_file Usage : Function: Example : Returns : Args : =cut sub _set_file{ my ($self,@files) = @_; push(@{$self->{'_file_array'}},@files); } =head2 _current_seqio Title : _current_seqio Usage : $obj->_current_seqio($newval) Function: Example : Returns : value of _current_seqio Args : newvalue (optional) =cut sub _current_seqio{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_current_seqio'} = $value; } return $obj->{'_current_seqio'}; } =head2 _format Title : _format Usage : $obj->_format($newval) Function: Example : Returns : value of _format Args : newvalue (optional) =cut sub _format{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_format'} = $value; } return $obj->{'_format'}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/nexml.pm������������������������������������������������������������������000444��000765��000024�� 10552�12254227314� 16633� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::nexml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chase Miller <chmille4@gmail.com> # # Copyright Chase Miller # # You may distribute this module under the same terms as perl itself # _history # May, 2009 Largely written by Chase Miller # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::nexml - NeXML sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from NeXML format. For more information on the NeXML standard, visit L<http://www.nexml.org>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Chase Miller Email: chmille4@gmail.com =head1 CONTRIBUTORS Mark Jensen, maj@fortinbras.us Rutger Vos, rutgeraldo@gmail.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::nexml; use strict; use lib '../..'; use Bio::Seq; use Bio::Seq::SeqFactory; use Bio::Nexml::Factory; use Bio::Phylo::IO qw (parse unparse); use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); $self->{_doc} = undef; } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : L<Bio::Seq> object Args : NONE =cut sub next_seq { my ($self) = @_; unless ( $self->{'_parsed'} ) { #use a parse function to load all the sequence objects found in the nexml file at once $self->_parse; } return $self->{'_seqs'}->[ $self->{'_seqiter'}++ ]; } =head2 rewind Title : rewind Usage : $seqio->rewind Function: Resets the stream Returns : none Args : none =cut sub rewind { my $self = shift; $self->{'_seqiter'} = 0; } =head2 doc Title : doc Usage : $treeio->doc Function: Returns the biophylo nexml document object Returns : Bio::Phylo::Project Args : none or Bio::Phylo::Project object =cut sub doc { my ($obj,$value) = @_; if( defined $value) { $obj->{'_doc'} = $value; } return $obj->{'_doc'}; } sub _parse { my ($self) = @_; my $fac = Bio::Nexml::Factory->new(); $self->{'_parsed'} = 1; $self->{'_seqiter'} = 0; $self->doc(Bio::Phylo::IO->parse( '-file' => $self->{'_file'}, '-format' => 'nexml', '-as_project' => '1' )); $self->{'_seqs'} = $fac->create_bperl_seq($self); unless(@{ $self->{'_seqs'} } == 0) { # self->debug("no seqs in $self->{_file}"); } } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: Writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Array of 1 or more L<Bio::PrimarySeqI> objects =cut sub write_seq { my ($self, $bp_seq) = @_; my $fac = Bio::Nexml::Factory->new(); my $taxa = $fac->create_bphylo_taxa($bp_seq); my ($seq) = $fac->create_bphylo_seq($bp_seq, $taxa); my $matrix = Bio::Phylo::Factory->create_matrix('-type' => $seq->get_type()); $matrix->insert($seq); $matrix->set_taxa($taxa); #set matrix label my $feat = ($bp_seq->get_SeqFeatures())[0]; $matrix->set_name($feat->get_tag_values('matrix_label')); $self->doc(Bio::Phylo::Factory->create_project()); $self->doc->insert($matrix); my $ret = $self->_print($self->doc->to_xml()); $self->flush; return $ret } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/phd.pm��������������������������������������������������������������������000444��000765��000024�� 31140�12254227336� 16263� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # Copyright (c) 1997-2001 bioperl, Chad Matsalla. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::phd - phd file input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L<Bio::SeqIO> class. =head1 DESCRIPTION This object can transform .phd files (from Phil Green's phred basecaller) to and from Bio::Seq::Quality objects. The phd format is described in section 10 at this url: http://www.phrap.org/phredphrap/phred.html =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Chad Matsalla Chad Matsalla bioinformatics@dieselwurks.com =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org Jean-Marc Frigerio, Frigerio@pierroton.inra.fr =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # 'Let the code begin... # package Bio::SeqIO::phd; use strict; use Bio::Seq::SeqFactory; use Bio::Seq::RichSeq; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Dumpvalue; my $dumper = Dumpvalue->new(); use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } } =head2 next_seq Title : next_seq() Usage : $swq = $stream->next_seq() Function: returns the next phred sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self,@args) = @_; my $seq; while (my $entry = $self->_readline) { chomp $entry; if ($entry =~ /^BEGIN_SEQUENCE\s+(\S+)/) { if (defined $seq) { # done with current sequence $self->_pushback($entry); last; } else { # start new sequence my $id = $1; $seq = $self->sequence_factory->create( -id => $id, -primary_id => $id, -display_id => $id, ); } } elsif ($entry =~ /^BEGIN_COMMENT/) { my $collection = Bio::Annotation::Collection->new; while ($entry = $self->_readline) { chomp $entry; if ($entry =~ /^(\w+):\s+(.+)$/) { my ($name, $content) = ($1, $2); my $comment = Bio::Annotation::Comment->new( -text => $content, -tagname => $name ); $collection->add_Annotation('header',$comment); } elsif ($entry =~ /^END_COMMENT/) { $seq->Bio::Seq::RichSeq::annotation($collection); last; } } } elsif ($entry =~ /^BEGIN_DNA/) { my $dna = ''; my @qualities = (); my @trace_indices = (); while ($entry = $self->_readline) { chomp $entry; if ( $entry =~ /(\S+)\s+(\S+)\s+(\S+)/ ) { # add nucleotide and quality scores to sequence $dna .= $1; push @qualities,$2; push(@trace_indices,$3) if defined $3; # required for phd file } elsif ($entry =~ /^END_DNA/) { # end of sequence, save it $seq->seq($dna); $seq->qual(\@qualities); $seq->trace(\@trace_indices); last; } } } elsif ($entry =~ /^END_SEQUENCE/) { # the sequence may be over, but some other info can come after next; } elsif ($entry =~ /^WR{/) { # Whole-Read items # Programs like Consed or Autofinish add it to phd file. See doc: # http://www.phrap.org/consed/distributions/README.16.0.txt #my ($type, $nane, $date, $time) = split(' ',$self->_readline); #my $extra_info = ''; #while ($entry = $self->_readline) { # chomp $entry; # last if ($entry =~ /\}/); # $extra_info .= $entry; #} ### fea: save WR somewhere? but where? } } return $seq; } =head2 write_header Title : write_header() Usage : $seqio->write_header() Function: Write out the header (BEGIN_COMMENTS .. END_COMMENT) part of a phd file Returns : nothing Args : a Bio::Seq::Quality object Notes : These are the comments that reside in the header of a phd file at the present time. If not provided by the Bio::Seq::Quality object, the following default values will be used: CHROMAT_FILE : $swq->id() ABI_THUMBPRINT : 0 PHRED_VERSION : 0.980904.e CALL_METHOD : phred QUALITY_LEVELS : 99 TIME : <current time> TRACE_ARRAY_MIN_INDEX : 0 TRACE_ARRAY_MAX_INDEX : unknown CHEM : unknown DYE : unknown =cut sub write_header { my ($self, $swq) = @_; $self->_print("\nBEGIN_COMMENT\n\n"); #defaults my $time = localtime(); for ([CHROMAT_FILE =>$swq->attribute('CHROMAT_FILE')], [ABI_THUMBPRINT => 0], [PHRED_VERSION => '0.980904.e'], [CALL_METHOD => 'phred'], [QUALITY_LEVELS => '99'], [TIME => $time], [TRACE_ARRAY_MIN_INDEX => 0], [TRACE_ARRAY_MAX_INDEX => 'unknown'], [CHEM => 'unknown'], [DYE => 'unknown']) { $swq->attribute($_->[0],$_->[1]) unless $swq->attribute($_->[0]); } my @annot = $swq->annotation->get_Annotations('header'); for (@annot) { $self->_print($_->tagname,": ",$_->text,"\n"); } $self->_print("\nEND_COMMENT\n\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 write_seq Title : write_seq() Usage : $seqio->write_seq($swq); Function: Write out a phd file. Returns : Nothing. Args : a Bio::Seq::Quality object =cut sub write_seq { my ($self,$swq) = @_; $self->throw("You must pass a Bio::Seq::Quality object to write_seq") unless (ref($swq) eq "Bio::Seq::Quality"); $self->throw("Can't create the phd because the sequence and the quality in the Quality object are of different lengths.") unless $swq->length() ne 'DIFFERENT'; $self->_print("BEGIN_SEQUENCE ".$swq->id()."\n"); $self->write_header($swq); $self->_print("BEGIN_DNA\n"); for my $curr(1 .. $swq->length()) { $self->_print (sprintf("%s %s %s\n", uc($swq->baseat($curr)), $swq->qualat($curr), $swq->trace_index_at($curr))); } $self->_print ("END_DNA\n\nEND_SEQUENCE\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 attribute Title : attribute() Usage : swq->attribute(name[,value]); Function: Get/Set the name attribute. Returns : a string if 1 param, nothing else. Args : a name or a pair name, value =cut sub Bio::Seq::Quality::attribute { my ($self, $name, $value) = @_; my $collection = $self->annotation; my @annot = $collection->get_Annotations('header'); my %attribute; my $annot; for (@annot) { $attribute{$_->tagname} = $_->display_text; $annot = $_ if $_->tagname eq $name; } unless (defined $attribute{$name}) { #new comment my $comment = Bio::Annotation::Comment->new(-text => $value || 'unknown'); $comment->tagname($name); $collection->add_Annotation('header',$comment); return; } return $attribute{$name} unless (defined $value);#get #print "ATTRIBUTE ",$annot," $name $attribute{$name}\n"; $annot->text($value); #set return; } =head2 chromat_file Title : chromat_file Usage : swq->chromat_file([filename]); Function: Get/Set the CHROMAT_FILE attribute. Returns : a string if 1 param, nothing else. Args : none or a filename =cut sub Bio::Seq::Quality::chromat_file { my ($self,$arg) = @_; return $self->attribute('CHROMAT_FILE',$arg); } =head2 abi_thumbprint Title : abi_thumbprint Usage : swq->abi_thumbprint([value]); Function: Get/Set the ABI_THUMBPRINT attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::abi_thumbprint { my ($self,$arg) = @_; return $self->attribute('ABI_THUMBPRINT',$arg); } =head2 phred_version Title : phred_version Usage : swq->phred_version([value]); Function: Get/Set the PHRED_VERSION attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::phred_version { my ($self,$arg) = @_; return $self->attribute('PHRED_VERSION', $arg); } =head2 call_method Title : call_method Usage : swq->call_method([value]); Function: Get/Set the CALL_METHOD attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::call_method { my ($self,$arg) = @_; return $self->attribute('CALL_METHOD', $arg); } =head2 quality_levels Title : quality_levels Usage : swq->quality_levels([value]); Function: Get/Set the quality_levels attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::quality_levels { my ($self,$arg) = @_; return $self->attribute('QUALITY_LEVELS', $arg); } =head2 trace_array_min_index Title : trace_array_min_index Usage : swq->trace_array_min_index([value]); Function: Get/Set the trace_array_min_index attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::trace_array_min_index { my ($self,$arg) = @_; return $self->attribute('TRACE_ARRAY_MIN_INDEX', $arg); } =head2 trace_array_max_index Title : trace_array_max_index Usage : swq->trace_array_max_index([value]); Function: Get/Set the trace_array_max_index attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::trace_array_max_index { my ($self,$arg) = @_; return $self->attribute('TRACE_ARRAY_MAX_INDEX', $arg); } =head2 chem Title : chem Usage : swq->chem([value]); Function: Get/Set the chem attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::chem { my ($self,$arg) = @_; return $self->attribute('CHEM', $arg); } =head2 dye Title : dye Usage : swq->dye([value]); Function: Get/Set the dye attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::dye { my ($self,$arg) = @_; return $self->attribute('DYE', $arg); } =head2 time Title : time Usage : swq->time([value]); Function: Get/Set the time attribute. Returns : a string if 1 param, nothing else. Args : none or a value =cut sub Bio::Seq::Quality::time { my ($self,$arg) = @_; return $self->attribute('TIME', $arg); } =head2 touch Title : touch Usage : swq->touch(); Function: Set the time attribute to current time. Returns : nothing Args : none =cut sub Bio::Seq::Quality::touch { my $time = localtime(); shift->attribute('TIME',$time); return; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/pir.pm��������������������������������������������������������������������000444��000765��000024�� 10776�12254227313� 16311� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::PIR # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # # _history # October 18, 1999 Largely rewritten by Lincoln Stein # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::pir - PIR sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from pir flat file databases. Note: This does not completely preserve the PIR format - quality information about sequence is currently discarded since bioperl does not have a mechanism for handling these encodings in sequence data. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Aaron Mackey E<lt>amackey@virginia.eduE<gt> Lincoln Stein E<lt>lstein@cshl.orgE<gt> Jason Stajich E<lt>jason@bioperl.orgE<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::pir; use strict; use Bio::Seq::SeqFactory; use base qw(Bio::SeqIO); our %VALID_TYPE = map {$_ => 1} qw(P1 F1 DL DC RL RC XX); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : NONE =cut sub next_seq { my ($self) = @_; local $/ = "\n>"; return unless my $line = $self->_readline; if( $line eq '>' ) { # handle the very first one having no comment return unless $line = $self->_readline; } my ($top, $desc,$seq) = ( $line =~ /^(.+?)\n(.+?)\n([^>]*)/s ) or $self->throw("Cannot parse entry PIR entry [$line]"); my ( $type,$id ); if ( $top =~ /^>?(\S{2});(\S+)\s*$/ ) { ( $type,$id ) = ($1, $2); if (!exists $VALID_TYPE{$type} ) { $self->throw("PIR stream read attempted without proper two-letter sequence code [ $type ]"); } } else { $self->throw("Line does not match PIR format [ $line ]"); } # P - indicates complete protein # F - indicates protein fragment # not sure how to stuff these into a Bio object # suitable for writing out. $seq =~ s/\*//g; $seq =~ s/[\(\)\.\/\=\,]//g; $seq =~ s/\s+//g; # get rid of whitespace my ($alphabet) = ('protein'); # TODO - not processing SFS data return $self->sequence_factory->create (-seq => $seq, -primary_id => $id, -id => $id, -desc => $desc, -alphabet => $alphabet ); } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Array of Bio::PrimarySeqI objects =cut sub write_seq { my ($self, @seq) = @_; for my $seq (@seq) { $self->throw("Did not provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); $self->warn("No whitespace allowed in PIR ID [". $seq->display_id. "]") if $seq->display_id =~ /\s/; my $str = $seq->seq(); return unless $self->_print(">P1;".$seq->id(), "\n", $seq->desc(), "\n", $str, "*\n"); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ��BioPerl-1.6.923/Bio/SeqIO/pln.pm��������������������������������������������������������������������000444��000765��000024�� 6731�12254227337� 16272� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::pln # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::pln - pln trace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from pln trace files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Aaron Mackey Email: amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::pln; use vars qw(@ISA $READ_AVAIL); use strict; use Bio::SeqIO; use Bio::Seq::SeqFactory; push @ISA, qw( Bio::SeqIO ); sub BEGIN { eval { require Bio::SeqIO::staden::read; }; if ($@) { $READ_AVAIL = 0; } else { push @ISA, "Bio::SeqIO::staden::read"; $READ_AVAIL = 1; } } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } unless ($READ_AVAIL) { Bio::Root::Root->throw( -class => 'Bio::Root::SystemException', -text => "Bio::SeqIO::staden::read is not available; make sure the bioperl-ext package has been installed successfully!" ); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self) = @_; my ($seq, $id, $desc, $qual) = $self->read_trace($self->_fh, 'pln'); # create the seq object $seq = $self->sequence_factory->create(-seq => $seq, -id => $id, -primary_id => $id, -desc => $desc, -alphabet => 'DNA', -qual => $qual ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh; foreach my $seq (@seq) { $self->write_trace($fh, $seq, 'pln'); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ���������������������������������������BioPerl-1.6.923/Bio/SeqIO/qual.pm�������������������������������������������������������������������000444��000765��000024�� 20314�12254227316� 16451� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # Copyright (c) 1997-9 bioperl, Chad Matsalla. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::qual - .qual file input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class (see L<Bio::SeqIO> for details). my $in_qual = Bio::SeqIO->new(-file => $qualfile, -format => 'qual', -width => $width, -verbose => $verbose); =head1 DESCRIPTION This object can transform .qual (similar to fasta) objects to and from Bio::Seq::Quality objects. See L<Bio::Seq::Quality> for details. Like the fasta module, it can take an argument '-width' to change the number of values per line (defaults to 50). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Chad Matsalla Chad Matsalla bioinformatics@dieselwurks.com =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::qual; use strict; use Bio::Seq::SeqFactory; use Dumpvalue; my $dumper = Dumpvalue->new(); use base qw(Bio::SeqIO); our $WIDTH = 25; sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($width) = $self->_rearrange([qw(WIDTH)], @args); $width && $self->width($width); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::PrimaryQual')); } } =head2 next_seq() Title : next_seq() Usage : $scf = $stream->next_seq() Function: returns the next scf sequence in the stream Returns : Bio::Seq::PrimaryQual object Notes : Get the next quality sequence from the stream. =cut sub next_seq { my ($self,@args) = @_; my ($qual,$seq); my $alphabet; local $/ = "\n>"; return unless my $entry = $self->_readline; if ($entry eq '>') { # very first one return unless $entry = $self->_readline; } # original: my ($top,$sequence) = $entry =~ /^(.+?)\n([^>]*)/s my ($top,$sequence) = $entry =~ /^(.+?)\n([^>]*)/s or $self->throw("Can't parse entry [$entry]"); my ($id,$fulldesc) = $top =~ /^\s*(\S+)\s*(.*)/ or $self->throw("Can't parse fasta header"); $id =~ s/^>//; # create the seq object $sequence =~ s/\n+/ /g; return $self->sequence_factory->create (-qual => $sequence, -id => $id, -primary_id => $id, -display_id => $id, -desc => $fulldesc ); } =head2 _next_qual Title : _next_qual Usage : $seq = $stream->_next_qual() (but do not do that. Use $stream->next_seq() instead) Function: returns the next quality in the stream Returns : Bio::Seq::PrimaryQual object Args : NONE Notes : An internal method. Gets the next quality in the stream. =cut sub _next_qual { my $qual = next_primary_qual( $_[0], 1 ); return $qual; } =head2 next_primary_qual() Title : next_primary_qual() Usage : $seq = $stream->next_primary_qual() Function: returns the next sequence in the stream Returns : Bio::PrimaryQual object Args : NONE =cut sub next_primary_qual { # print("CSM next_primary_qual!\n"); my( $self, $as_next_qual ) = @_; my ($qual,$seq); local $/ = "\n>"; return unless my $entry = $self->_readline; if ($entry eq '>') { # very first one return unless $entry = $self->_readline; } my ($top,$sequence) = $entry =~ /^(.+?)\n([^>]*)/s or $self->throw("Can't parse entry [$entry]"); my ($id,$fulldesc) = $top =~ /^\s*(\S+)\s*(.*)/ or $self->throw("Can't parse fasta header"); $id =~ s/^>//; # create the seq object $sequence =~ s/\n+/ /g; if ($as_next_qual) { $qual = Bio::Seq::PrimaryQual->new(-qual => $sequence, -id => $id, -primary_id => $id, -display_id => $id, -desc => $fulldesc ); } return $qual; } =head2 width Title : width Usage : $obj->width($newval) Function: Get/Set the number of values per line for FASTA-like output Returns : value of width Args : newvalue (optional) =cut sub width{ my ($self,$value) = @_; if( defined $value) { $self->{'width'} = $value; } return $self->{'width'} || $WIDTH; } =head2 write_seq Title : write_seq Usage : $obj->write_seq( -source => $source, -header => "some information" -oneline => 0); Function: Write out a list of quality values to a fasta-style file. Returns : Nothing. Args : Requires a reference to a Bio::Seq::Quality object or a PrimaryQual object as the -source. Option 1: information for the header. Option 2: whether the quality score should be on a single line or not Notes : If no -header is provided, $obj->id() will be used where $obj is a reference to either a Quality object or a PrimaryQual object. If $source->id() fails, "unknown" will be the header. If the Quality object has $source->length() of "DIFFERENT" (read the pod, luke), write_seq will use the length of the PrimaryQual object within the Quality object. =cut sub write_seq { my ($self,@args) = @_; my $width = $self->width; my ($source, $head, $oneline) = $self->_rearrange([qw(SOURCE HEADER ONELINE)], @args); if (!$source || ( !$source->isa('Bio::Seq::Quality') && !$source->isa('Bio::Seq::PrimaryQual') )) { $self->throw("You must pass a Bio::Seq::Quality or a Bio::Seq::PrimaryQual". " object to write_seq() as a parameter named \"source\""); } my $header = ($source->can("header") && $source->header) ? $source->header : ($source->can("id") && $source->id) ? $source->id : "unknown"; my @quals = $source->qual(); # ::dumpValue(\@quals); my $desc = $source->desc if $source->can('desc'); $desc ||= ''; $self->_print (">$header $desc\n"); my (@slice,$max,$length); $length = $source->length(); if ( not(defined($oneline)) || $oneline == 0) { # $width quality values per line for (my $count = 1; $count<=$length; $count+= $width) { if ($count+$width > $length) { $max = $length; } else { $max = $count+$width-1; } my @slice = @{$source->subqual($count,$max)}; $self->_print (join(' ',@slice), "\n"); } } else { # quality values on a single line my @slice = @{$source->qual}; $self->_print (join(' ',@slice), "\n"); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; __END__ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/raw.pm��������������������������������������������������������������������000444��000765��000024�� 13027�12254227316� 16303� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#----------------------------------------------------------------------------- # PACKAGE : Bio::SeqIO::raw # AUTHOR : Ewan Birney <birney@ebi.ac.uk> # CREATED : Feb 16 1999 # # Copyright (c) 1997-9 bioperl, Ewan Birney. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # _History_ # # Ewan Birney <birney@ebi.ac.uk> developed the SeqIO # schema and the first prototype modules. # # This code is based on his Bio::SeqIO::Fasta module with # the necessary minor tweaks necessary to get it to read # and write raw formatted sequences made by # chris dagdigian <dag@sonsorol.org> # # October 18, 1999 Largely rewritten by Lincoln Stein # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::raw - raw sequence file input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the L<Bio::SeqIO> class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from raw flat file databases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Ewan Birney E<lt>birney@ebi.ac.ukE<gt> Lincoln Stein E<lt>lstein@cshl.orgE<gt> =head1 CONTRIBUTORS Jason Stajich E<lt>jason@bioperl.org<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::raw; use strict; use Bio::Seq::SeqFactory; use base qw(Bio::SeqIO); our %variant = ( 'multiple' => undef, # default 'single' => undef ); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($variant) = $self->_rearrange([qw(VARIANT)], @args); $variant ||= 'multiple'; $self->variant($variant); $self->{record_separator} = $variant eq 'single' ? undef : $/; if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq')); } $self->variant; } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq{ my ($self,@args) = @_; ## When its 1 sequence per line with no formatting at all, ## grabbing it should be easy :) ## adding an option to assume the file is one sequence local $/ = $self->{record_separator}; my $nextline = $self->_readline(); return unless defined $nextline; my $sequence = uc($nextline); $sequence =~ s/\W//g; return unless $sequence; return $self->sequence_factory->create(-seq => $sequence) if $sequence; } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Array of Bio::PrimarySeqI objects =cut sub write_seq { my ($self,@seq) = @_; foreach my $seq (@seq) { $self->throw("Must provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); $self->_print($seq->seq, "\n") or return; } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 write_qual Title : write_qual Usage : $stream->write_qual($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq::Quality object =cut sub write_qual { my ($self,@seq) = @_; my @qual = (); foreach (@seq) { unless ($_->isa("Bio::Seq::Quality")){ warn("You cannot write raw qualities without supplying a Bio::Seq::". "Quality object! You passed a ".ref($_)."\n"); next; } @qual = @{$_->qual}; if(scalar(@qual) == 0) { $qual[0] = "\n"; } $self->_print (join " ", @qual,"\n") or return; } return 1; } =head2 variant Title : variant Usage : $format = $obj->variant(); Function: Get and set method for the sequence variant. For raw sequence, this indicates whether to treat the input as multiple sequences (the default) or as a single sequence. Current values accepted are: 'single' single sequence 'multiple' multiple sequences (default) Returns : string Args : new value, string =cut # variant() method inherited from Bio::Root::IO # private method for testing record separator sub _separator { shift->{record_separator}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/scf.pm��������������������������������������������������������������������000444��000765��000024�� 133274�12254227330� 16310� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # Copyright (c) 1997-2001 bioperl, Chad Matsalla. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::scf - .scf file input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class, see L<Bio::SeqIO> for more information. =head1 DESCRIPTION This object can transform .scf files to and from Bio::Seq::SequenceTrace objects. Mechanisms are present to retrieve trace data from scf files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Chad Matsalla Chad Matsalla bioinformatics@dieselwurks.com =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org Tony Cox, avc@sanger.ac.uk Heikki Lehvaslaiho, heikki-at-bioperl-dot-org Nancy Hansen, nhansen at mail.nih.gov =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::scf; use vars qw($DEFAULT_QUALITY); use strict; use Bio::Seq::SeqFactory; use Bio::Seq::SequenceTrace; use Bio::Annotation::Comment; use Dumpvalue; my $dumper = Dumpvalue->new(); $dumper->veryCompact(1); BEGIN { $DEFAULT_QUALITY= 10; } use base qw(Bio::SeqIO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } binmode $self->_fh; # for the Win32/Mac crowds } =head2 next_seq() Title : next_seq() Usage : $scf = $stream->next_seq() Function: returns the next scf sequence in the stream Returns : a Bio::Seq::SequenceTrace object Args : NONE Notes : Fills the interface specification for SeqIO. The SCF specification does not provide for having more then one sequence in a given scf. So once the filehandle has been open and passed to SeqIO do not expect to run this function more then once on a given scf unless you embraced and extended the SCF standard. SCF comments are accessible through the Bio::SeqI interface method annotation(). =cut #' sub next_seq { my ($self) = @_; my ($seq, $seqc, $fh, $buffer, $offset, $length, $read_bytes, @read, %names); # set up a filehandle to read in the scf return if $self->{_readfile}; $fh = $self->_fh(); unless ($fh) { # simulate the <> function if ( !fileno(ARGV) or eof(ARGV) ) { return unless my $ARGV = shift; open(ARGV,$ARGV) or $self->throw("Could not open $ARGV for SCF stream reading $!"); } $fh = \*ARGV; } return unless read $fh, $buffer, 128; # no exception; probably end of file # now, the master data structure will be the creator my $creator; # he first thing to do is parse the header. This is common # among all versions of scf. # the rest of the the information is different between the # the different versions of scf. $creator->{header} = $self->_get_header($buffer); if ($creator->{header}->{'version'} lt "3.00") { $self->debug("scf.pm is working with a version 2 scf.\n"); # first gather the trace information $length = $creator->{header}->{'samples'} * $creator->{header}->{sample_size}*4; $buffer = $self->read_from_buffer($fh, $buffer, $length, $creator->{header}->{samples_offset}); # @read = unpack "n$length",$buffer; # these traces need to be split # returns a reference to a hash $creator->{traces} = $self->_parse_v2_traces( $buffer,$creator->{header}->{sample_size}); # now go and get the base information $offset = $creator->{header}->{bases_offset}; $length = ($creator->{header}->{bases} * 12); seek $fh,$offset,0; $buffer = $self->read_from_buffer($fh,$buffer,$length,$creator->{header}->{bases_offset}); # now distill the information into its fractions. # the old way : $self->_set_v2_bases($buffer); # ref to an array, ref to a hash, string ($creator->{peak_indices}, $creator->{qualities}, $creator->{sequence}, $creator->{accuracies}) = $self->_parse_v2_bases($buffer); } else { $self->debug("scf.pm is working with a version 3+ scf.\n"); my $transformed_read; my $current_read_position = $creator->{header}->{sample_offset}; $length = $creator->{header}->{'samples'}* $creator->{header}->{sample_size}; # $dumper->dumpValue($creator->{header}); foreach (qw(a c g t)) { $buffer = $self->read_from_buffer($fh,$buffer,$length,$current_read_position); my $byte = "n"; if ($creator->{header}->{sample_size} == 1) { $byte = "c"; } @read = unpack "${byte}${length}",$buffer; # this little spurt of nonsense is because # the trace values are given in the binary # file as unsigned shorts but they really # are signed deltas. 30000 is an arbitrary number # (will there be any traces with a given # point greater then 30000? I hope not. # once the read is read, it must be changed # from relative foreach (@read) { if ($_ > 30000) { $_ -= 65536; } } $transformed_read = $self->_delta(\@read,"backward"); # For 8-bit data we need to emulate a signed/unsigned # cast that is implicit in the C implementations..... if ($creator->{header}->{sample_size} == 1) { foreach (@{$transformed_read}) { $_ += 256 if ($_ < 0); } } $current_read_position += $length; $creator->{'traces'}->{$_} = join(' ',@{$transformed_read}); } # now go and get the peak index information $offset = $creator->{header}->{bases_offset}; $length = ($creator->{header}->{bases} * 4); $buffer = $self->read_from_buffer($fh,$buffer,$length,$offset); $creator->{peak_indices} = $self->_get_v3_peak_indices($buffer); $offset += $length; # now go and get the accuracy information $buffer = $self->read_from_buffer($fh,$buffer,$length,$offset); $creator->{accuracies} = $self->_get_v3_base_accuracies($buffer); # OK, now go and get the base information. $offset += $length; $length = $creator->{header}->{bases}; $buffer = $self->read_from_buffer($fh,$buffer,$length,$offset); $creator->{'sequence'} = unpack("a$length",$buffer); # now, finally, extract the calls from the accuracy information. $creator->{qualities} = $self->_get_v3_quality( $creator->{'sequence'},$creator->{accuracies}); } # now go and get the comment information $offset = $creator->{header}->{comments_offset}; seek $fh,$offset,0; $length = $creator->{header}->{comment_size}; $buffer = $self->read_from_buffer($fh,$buffer,$length); $creator->{comments} = $self->_get_comments($buffer); my @name_comments = grep {$_->tagname() eq 'NAME'} $creator->{comments}->get_Annotations('comment'); my $name_comment; if (@name_comments){ $name_comment = $name_comments[0]->as_text(); $name_comment =~ s/^Comment:\s+//; } my $swq = Bio::Seq::Quality->new( -seq => $creator->{'sequence'}, -qual => $creator->{'qualities'}, -id => $name_comment ); my $returner = Bio::Seq::SequenceTrace->new( -swq => $swq, -trace_a => $creator->{'traces'}->{'a'}, -trace_t => $creator->{'traces'}->{'t'}, -trace_g => $creator->{'traces'}->{'g'}, -trace_c => $creator->{'traces'}->{'c'}, -accuracy_a => $creator->{'accuracies'}->{'a'}, -accuracy_t => $creator->{'accuracies'}->{'t'}, -accuracy_g => $creator->{'accuracies'}->{'g'}, -accuracy_c => $creator->{'accuracies'}->{'c'}, -peak_indices => $creator->{'peak_indices'} ); $returner->annotation($creator->{'comments'}); # add SCF comments $self->{'_readfile'} = 1; return $returner; } =head2 _get_v3_quality() Title : _get_v3_quality() Usage : $self->_get_v3_quality() Function: Set the base qualities from version3 scf Returns : Nothing. Alters $self. Args : None. Notes : =cut #' sub _get_v3_quality { my ($self,$sequence,$accuracies) = @_; my @bases = split//,$sequence; my (@qualities,$currbase,$currqual,$counter); for ($counter=0; $counter <= $#bases ; $counter++) { $currbase = lc($bases[$counter]); if ($currbase eq "a") { $currqual = $accuracies->{'a'}->[$counter]; } elsif ($currbase eq "c") { $currqual = $accuracies->{'c'}->[$counter]; } elsif ($currbase eq "g") { $currqual = $accuracies->{'g'}->[$counter]; } elsif ($currbase eq "t") { $currqual = $accuracies->{'t'}->[$counter]; } else { $currqual = "unknown"; } push @qualities,$currqual; } return \@qualities; } =head2 _get_v3_peak_indices($buffer) Title : _get_v3_peak_indices($buffer) Usage : $self->_get_v3_peak_indices($buffer); Function: Unpacks the base accuracies for version3 scf Returns : Nothing. Alters $self Args : A scalar containing binary data. Notes : =cut sub _get_v3_peak_indices { my ($self,$buffer) = @_; my $length = length($buffer); my @read = unpack "N$length",$buffer; return join(' ',@read); } =head2 _get_v3_base_accuracies($buffer) Title : _get_v3_base_accuracies($buffer) Usage : $self->_get_v3_base_accuracies($buffer) Function: Set the base accuracies for version 3 scf's Returns : Nothing. Alters $self. Args : A scalar containing binary data. Notes : =cut #' sub _get_v3_base_accuracies { my ($self,$buffer) = @_; my $length = length($buffer); my $qlength = $length/4; my $offset = 0; my (@qualities,@sorter,$counter,$round,$last_base,$accuracies,$currbase); foreach $currbase (qw(a c g t)) { my @read; $last_base = $offset + $qlength; for (;$offset < $last_base; $offset += $qlength) { # a bioperler (perhaps me?) changed the unpack string to include 'n' rather than 'C' # on 040322 I think that 'C' is correct. please email chad if you would like to accuse me of being incorrect @read = unpack "C$qlength", substr($buffer,$offset,$qlength); $accuracies->{$currbase} = \@read; } } return $accuracies; } =head2 _get_comments($buffer) Title : _get_comments($buffer) Usage : $self->_get_comments($buffer); Function: Gather the comments section from the scf and parse it into its components. Returns : a Bio::Annotation::Collection object Args : The buffer. It is expected that the buffer contains a binary string for the comments section of an scf file according to the scf file specifications. Notes : =cut sub _get_comments { my ($self,$buffer) = @_; my $comments = Bio::Annotation::Collection->new(); my $size = length($buffer); my $comments_retrieved = unpack "a$size",$buffer; $comments_retrieved =~ s/\0//; my @comments_split = split/\n/,$comments_retrieved; if (@comments_split) { foreach (@comments_split) { /(\w+)=(.*)/; if ($1 && $2) { my ($tagname, $text) = ($1, $2); my $comment_obj = Bio::Annotation::Comment->new( -text => $text, -tagname => $tagname); $comments->add_Annotation('comment', $comment_obj); } } } $self->{'comments'} = $comments; return $comments; } =head2 _get_header() Title : _get_header($buffer) Usage : $self->_get_header($buffer); Function: Gather the header section from the scf and parse it into its components. Returns : Reference to a hash containing the header components. Args : The buffer. It is expected that the buffer contains a binary string for the header section of an scf file according to the scf file specifications. Notes : None. =cut sub _get_header { my ($self,$buffer) = @_; my $header; ($header->{'scf'}, $header->{'samples'}, $header->{'sample_offset'}, $header->{'bases'}, $header->{'bases_left_clip'}, $header->{'bases_right_clip'}, $header->{'bases_offset'}, $header->{'comment_size'}, $header->{'comments_offset'}, $header->{'version'}, $header->{'sample_size'}, $header->{'code_set'}, @{$header->{'header_spare'}} ) = unpack "a4 NNNNNNNN a4 NN N20", $buffer; $self->{'header'} = $header; return $header; } =head2 _parse_v2_bases($buffer) Title : _parse_v2_bases($buffer) Usage : $self->_parse_v2_bases($buffer); Function: Gather the bases section from the scf and parse it into its components. Returns : Args : The buffer. It is expected that the buffer contains a binary string for the bases section of an scf file according to the scf file specifications. Notes : None. =cut sub _parse_v2_bases { my ($self,$buffer) = @_; my $length = length($buffer); my ($offset2,$currbuff,$currbase,$currqual,$sequence,@qualities,@indices); my (@read,$harvester,$accuracies); for ($offset2=0;$offset2<$length;$offset2+=12) { @read = unpack "N C C C C a C3", substr($buffer,$offset2,$length); push @indices,$read[0]; $currbase = lc($read[5]); if ($currbase eq "a") { $currqual = $read[1]; } elsif ($currbase eq "c") { $currqual = $read[2]; } elsif ($currbase eq "g") { $currqual = $read[3]; } elsif ($currbase eq "t") { $currqual = $read[4]; } else { $currqual = "UNKNOWN"; } push @{$accuracies->{"a"}},$read[1]; push @{$accuracies->{"c"}},$read[2]; push @{$accuracies->{"g"}},$read[3]; push @{$accuracies->{"t"}},$read[4]; $sequence .= $currbase; push @qualities,$currqual; } return (\@indices,\@qualities,$sequence,$accuracies) } =head2 _parse_v2_traces(\@traces_array) Title : _pares_v2_traces(\@traces_array) Usage : $self->_parse_v2_traces(\@traces_array); Function: Parses an scf Version2 trace array into its base components. Returns : Nothing. Modifies $self. Args : A reference to an array of the unpacked traces section of an scf version2 file. =cut sub _parse_v2_traces { my ($self,$buffer,$sample_size) = @_; my $byte; if ($sample_size == 1) { $byte = "c"; } else { $byte = "n"; } my $length = CORE::length($buffer); my @read = unpack "${byte}${length}",$buffer; # this will be an array to the reference holding the array my $traces; my $array = 0; for (my $offset2 = 0; $offset2< scalar(@read); $offset2+=4) { push @{$traces->{'a'}},$read[$offset2]; push @{$traces->{'c'}},$read[$offset2+1]; push @{$traces->{'g'}},$read[$offset2+3]; push @{$traces->{'t'}},$read[$offset2+2]; } return $traces; } sub get_trace_deprecated_use_the_sequencetrace_object_instead { # my ($self,$base_channel,$traces) = @_; # $base_channel =~ tr/a-z/A-Z/; # if ($base_channel !~ /A|T|G|C/) { # $self->throw("You tried to ask for a base channel that wasn't A,T,G, or C. Ask for one of those next time."); ##} elsif ($base_channel) { # my @temp = split(' ',$self->{'traces'}->{$base_channel}); #return \@temp; #} } sub _deprecated_get_peak_indices_deprecated_use_the_sequencetrace_object_instead { my ($self) = shift; my @temp = split(' ',$self->{'parsed'}->{'peak_indices'}); return \@temp; } =head2 get_header() Title : get_header() Usage : %header = %{$obj->get_header()}; Function: Return the header for this scf. Returns : A reference to a hash containing the header for this scf. Args : None. Notes : =cut sub get_header { my ($self) = shift; return $self->{'header'}; } =head2 get_comments() Title : get_comments() Usage : %comments = %{$obj->get_comments()}; Function: Return the comments for this scf. Returns : A Bio::Annotation::Collection object Args : None. Notes : =cut sub get_comments { my ($self) = shift; return $self->{'comments'}; } sub _dump_traces_outgoing_deprecated_use_the_sequencetrace_object { my ($self,$transformed) = @_; my (@sA,@sT,@sG,@sC); if ($transformed) { @sA = @{$self->{'text'}->{'t_samples_a'}}; @sC = @{$self->{'text'}->{'t_samples_c'}}; @sG = @{$self->{'text'}->{'t_samples_g'}}; @sT = @{$self->{'text'}->{'t_samples_t'}}; } else { @sA = @{$self->{'text'}->{'samples_a'}}; @sC = @{$self->{'text'}->{'samples_c'}}; @sG = @{$self->{'text'}->{'samples_g'}}; @sT = @{$self->{'text'}->{'samples_t'}}; } print ("Count\ta\tc\tg\tt\n"); for (my $curr=0; $curr < scalar(@sG); $curr++) { print("$curr\t$sA[$curr]\t$sC[$curr]\t$sG[$curr]\t$sT[$curr]\n"); } return; } sub _dump_traces_incoming_deprecated_use_the_sequencetrace_object { # my ($self) = @_; # my (@sA,@sT,@sG,@sC); # @sA = @{$self->{'traces'}->{'A'}}; # @sC = @{$self->{'traces'}->{'C'}}; # @sG = @{$self->{'traces'}->{'G'}}; # @sT = @{$self->{'traces'}->{'T'}}; # @sA = @{$self->get_trace('A')}; # @sC = @{$self->get_trace('C')}; # @sG = @{$self->get_trace('G')}; # @sT = @{$self->get_trace('t')}; # print ("Count\ta\tc\tg\tt\n"); # for (my $curr=0; $curr < scalar(@sG); $curr++) { # print("$curr\t$sA[$curr]\t$sC[$curr]\t$sG[$curr]\t$sT[$curr]\n"); #} #return; } =head2 write_seq Title : write_seq(-target => $swq, <comments>) Usage : $obj->write_seq( -target => $swq, -version => 2, -CONV => "Bioperl-Chads Mighty SCF writer."); Function: Write out an scf. Returns : Nothing. Args : Requires: a reference to a Bio::Seq::Quality object to form the basis for the scf. if -version is provided, it should be "2" or "3". A SCF of that version will be written. Any other arguments are assumed to be comments and are put into the comments section of the scf. Read the specifications for scf to decide what might be good to put in here. Notes : For best results, use a SequenceTrace object. The things that you need to write an scf: a) sequence b) quality c) peak indices d) traces - You _can_ write an scf with just a and b by passing in a Bio::Seq::Quality object- false traces will be synthesized for you. =cut sub write_seq { my ($self,%args) = @_; my %comments; my ($label,$arg); my ($swq) = $self->_rearrange([qw(TARGET)], %args); my $writer_fodder; if (ref($swq) =~ /Bio::Seq::SequenceTrace|Bio::Seq::Quality/) { if (ref($swq) eq "Bio::Seq::Quality") { # this means that the object *has no trace data* # we might as well synthesize some now, ok? $swq = Bio::Seq::SequenceTrace->new( -swq => $swq ); } } else { $self->throw("You must pass a Bio::Seq::Quality or a Bio::Seq::SequenceTrace object to write_seq as a parameter named \"target\""); } # all of the rest of the arguments are comments for the scf foreach $arg (sort keys %args) { next if ($arg =~ /target/i); ($label = $arg) =~ s/^\-//; $writer_fodder->{comments}->{$label} = $args{$arg}; } if (!$comments{'NAME'}) { $comments{'NAME'} = $swq->id(); } # HA! Bwahahahaha. $writer_fodder->{comments}->{'CONV'} = "Bioperl-Chads Mighty SCF writer." unless defined $comments{'CONV'}; # now deal with the version of scf they want to write if ($writer_fodder->{comments}->{version}) { if ($writer_fodder->{comments}->{version} != 2 && $writer_fodder->{comments}->{version} != 3) { $self->warn("This module can only write version 2.0 or 3.0 scf's. Writing a version 2.0 scf by default."); $writer_fodder->{header}->{version} = "2.00"; } elsif ($writer_fodder->{comments}->{'version'} > 2) { $writer_fodder->{header}->{'version'} = "3.00"; } else { $writer_fodder->{header}->{version} = "2"; } } else { $writer_fodder->{header}->{'version'} = "3.00"; } # set a few things in the header $writer_fodder->{'header'}->{'magic'} = ".scf"; $writer_fodder->{'header'}->{'sample_size'} = "2"; $writer_fodder->{'header'}->{'bases'} = length($swq->seq()); $writer_fodder->{'header'}->{'bases_left_clip'} = "0"; $writer_fodder->{'header'}->{'bases_right_clip'} = "0"; $writer_fodder->{'header'}->{'sample_size'} = "2"; $writer_fodder->{'header'}->{'code_set'} = "9"; @{$writer_fodder->{'header'}->{'spare'}} = qw(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0); $writer_fodder->{'header'}->{'samples_offset'} = "128"; $writer_fodder->{'header'}->{'samples'} = $swq->trace_length(); # create the binary for the comments and file it in writer_fodder $writer_fodder->{comments} = $self->_get_binary_comments( $writer_fodder->{comments}); # create the binary and the strings for the traces, bases, # offsets (if necessary), and accuracies (if necessary) $writer_fodder->{traces} = $self->_get_binary_traces( $writer_fodder->{'header'}->{'version'}, $swq,$writer_fodder->{'header'}->{'sample_size'}); my ($b_base_offsets,$b_base_accuracies,$samples_size,$bases_size); # # version 2 # if ($writer_fodder->{'header'}->{'version'} == 2) { $writer_fodder->{bases} = $self->_get_binary_bases( 2, $swq, $writer_fodder->{'header'}->{'sample_size'}); $samples_size = CORE::length($writer_fodder->{traces}->{'binary'}); $bases_size = CORE::length($writer_fodder->{bases}->{binary}); $writer_fodder->{'header'}->{'bases_offset'} = 128 + $samples_size; $writer_fodder->{'header'}->{'comments_offset'} = 128 + $samples_size + $bases_size; $writer_fodder->{'header'}->{'comments_size'} = length($writer_fodder->{'comments'}->{binary}); $writer_fodder->{'header'}->{'private_size'} = "0"; $writer_fodder->{'header'}->{'private_offset'} = 128 + $samples_size + $bases_size + $writer_fodder->{'header'}->{'comments_size'}; $writer_fodder->{'header'}->{'binary'} = $self->_get_binary_header($writer_fodder->{header}); $dumper->dumpValue($writer_fodder) if $self->verbose > 0; $self->_print ($writer_fodder->{'header'}->{'binary'}) or print("Could not write binary header...\n"); $self->_print ($writer_fodder->{'traces'}->{'binary'}) or print("Could not write binary traces...\n"); $self->_print ($writer_fodder->{'bases'}->{'binary'}) or print("Could not write binary base structures...\n"); $self->_print ($writer_fodder->{'comments'}->{'binary'}) or print("Could not write binary comments...\n"); } else { ($writer_fodder->{peak_indices}, $writer_fodder->{accuracies}, $writer_fodder->{bases}, $writer_fodder->{reserved} ) = $self->_get_binary_bases( 3, $swq, $writer_fodder->{'header'}->{'sample_size'} ); $writer_fodder->{'header'}->{'bases_offset'} = 128 + length($writer_fodder->{'traces'}->{'binary'}); $writer_fodder->{'header'}->{'comments_size'} = length($writer_fodder->{'comments'}->{'binary'}); # this is: # bases_offset + base_offsets + accuracies + called_bases + # reserved $writer_fodder->{'header'}->{'private_size'} = "0"; $writer_fodder->{'header'}->{'comments_offset'} = 128+length($writer_fodder->{'traces'}->{'binary'})+ length($writer_fodder->{'peak_indices'}->{'binary'})+ length($writer_fodder->{'accuracies'}->{'binary'})+ length($writer_fodder->{'bases'}->{'binary'})+ length($writer_fodder->{'reserved'}->{'binary'}); $writer_fodder->{'header'}->{'private_offset'} = $writer_fodder->{'header'}->{'comments_offset'} + $writer_fodder->{'header'}->{'comments_size'}; $writer_fodder->{'header'}->{'spare'}->[1] = $writer_fodder->{'header'}->{'comments_offset'} + length($writer_fodder->{'comments'}->{'binary'}); $writer_fodder->{header}->{binary} = $self->_get_binary_header($writer_fodder->{header}); $self->_print ($writer_fodder->{'header'}->{'binary'}) or print("Couldn't write header\n"); $self->_print ($writer_fodder->{'traces'}->{'binary'}) or print("Couldn't write samples\n"); $self->_print ($writer_fodder->{'peak_indices'}->{'binary'}) or print("Couldn't write peak offsets\n"); $self->_print ($writer_fodder->{'accuracies'}->{'binary'}) or print("Couldn't write accuracies\n"); $self->_print ($writer_fodder->{'bases'}->{'binary'}) or print("Couldn't write called_bases\n"); $self->_print ($writer_fodder->{'reserved'}->{'binary'}) or print("Couldn't write reserved\n"); $self->_print ($writer_fodder->{'comments'}->{'binary'}) or print ("Couldn't write comments\n"); } # kinda unnecessary, given the close() below, but maybe that'll go # away someday. $self->flush if $self->_flush_on_write && defined $self->_fh; $self->close(); return 1; } =head2 _get_binary_header() Title : _get_binary_header(); Usage : $self->_get_binary_header(); Function: Provide the binary string that will be used as the header for a scfv2 document. Returns : A binary string. Args : None. Uses the entries in the $self->{'header'} hash. These are set on construction of the object (hopefully correctly!). Notes : =cut sub _get_binary_header { my ($self,$header) = @_; my $binary = pack "a4 NNNNNNNN a4 NN N20", ( $header->{'magic'}, $header->{'samples'}, $header->{'samples_offset'}, $header->{'bases'}, $header->{'bases_left_clip'}, $header->{'bases_right_clip'}, $header->{'bases_offset'}, $header->{'comments_size'}, $header->{'comments_offset'}, $header->{'version'}, $header->{'sample_size'}, $header->{'code_set'}, @{$header->{'spare'}} ); return $binary; } =head2 _get_binary_traces($version,$ref) Title : _set_binary_tracesbases($version,$ref) Usage : $self->_set_binary_tracesbases($version,$ref); Function: Constructs the trace and base strings for all scfs Returns : Nothing. Alters self. Args : $version - "2" or "3" $sequence - a scalar containing arbitrary sequence data $ref - a reference to either a SequenceTraces or a SequenceWithQuality object. Notes : This is a really complicated thing. =cut sub _get_binary_traces { my ($self,$version,$ref,$sample_size) = @_; # ref _should_ be a Bio::Seq::SequenceTrace, but might be a # Bio::Seq::Quality my $returner; my $sequence = $ref->seq(); my $sequence_length = length($sequence); # first of all, do we need to synthesize the trace? # if so, call synthesize_base my ($traceobj,@traces,$current); if ( ref($ref) eq "Bio::Seq::Quality" ) { $traceobj = Bio::Seq::Quality->new( -target => $ref ); $traceobj->_synthesize_traces(); } else { $traceobj = $ref; if ($version eq "2") { my $trace_length = $traceobj->trace_length(); for ($current = 1; $current <= $trace_length; $current++) { foreach (qw(a c g t)) { push @traces,$traceobj->trace_value_at($_,$current); } } } elsif ($version == 3) { foreach my $current_trace (qw(a c g t)) { my @trace = @{$traceobj->trace($current_trace)}; foreach (@trace) { if ($_ > 30000) { $_ -= 65536; } } my $transformed = $self->_delta(\@trace,"forward"); if($sample_size == 1){ foreach (@{$transformed}) { $_ += 256 if ($_ < 0); } } push @traces,@{$transformed}; } } } $returner->{version} = $version; $returner->{string} = \@traces; my $length_of_traces = scalar(@traces); my $byte; if ($sample_size == 1) { $byte = "c"; } else { $byte = "n"; } # an unsigned integer should be I, but this is too long # $returner->{binary} = pack "n${length_of_traces}",@traces; $returner->{length} = CORE::length($returner->{binary}); return $returner; } sub _get_binary_bases { my ($self,$version,$trace,$sample_size) = @_; my $byte; if ($sample_size == 1) { $byte = "c"; } else { $byte = "n"; } my ($returner,@current_row,$current_base,$string,$binary); my $length = $trace->length(); if ($version == 2) { $returner->{'version'} = "2"; for (my $current_base =1; $current_base <= $length; $current_base++) { my @current_row; push @current_row,$trace->peak_index_at($current_base); push @current_row,$trace->accuracy_at("a",$current_base); push @current_row,$trace->accuracy_at("c",$current_base); push @current_row,$trace->accuracy_at("g",$current_base); push @current_row,$trace->accuracy_at("t",$current_base); push @current_row,$trace->baseat($current_base); push @current_row,0,0,0; push @{$returner->{string}},@current_row; $returner->{binary} .= pack "N C C C C a C3",@current_row; } return $returner; } else { $returner->{'version'} = "3.00"; $returner->{peak_indices}->{string} = $trace->peak_indices(); my $length = scalar(@{$returner->{peak_indices}->{string}}); $returner->{peak_indices}->{binary} = pack "N$length",@{$returner->{peak_indices}->{string}}; $returner->{peak_indices}->{length} = CORE::length($returner->{peak_indices}->{binary}); my @accuracies; foreach my $base (qw(a c g t)) { $returner->{accuracies}->{$base} = $trace->accuracies($base); push @accuracies,@{$trace->accuracies($base)}; } $returner->{sequence} = $trace->seq(); $length = scalar(@accuracies); # this really is "c" for samplesize == 2 $returner->{accuracies}->{binary} = pack "C${length}",@accuracies; $returner->{accuracies}->{length} = CORE::length($returner->{accuracies}->{binary}); $length = $trace->seq_obj()->length(); for (my $count=0; $count< $length; $count++) { push @{$returner->{reserved}->{string}},0,0,0; } } $length = scalar(@{$returner->{reserved}->{string}}); # this _must_ be "c" $returner->{'reserved'}->{'binary'} = pack "c$length",@{$returner->{reserved}->{string}}; $returner->{'reserved'}->{'length'} = CORE::length($returner->{'reserved'}->{'binary'}); # $returner->{'bases'}->{'string'} = $trace->seq(); my @bases = split('',$trace->seq()); $length = $trace->length(); $returner->{'bases'}->{'binary'} = $trace->seq(); # print("Returning this:\n"); # $dumper->dumpValue($returner); return ($returner->{peak_indices}, $returner->{accuracies}, $returner->{bases}, $returner->{reserved}); } =head2 _make_trace_string($version) Title : _make_trace_string($version) Usage : $self->_make_trace_string($version) Function: Merges trace data for the four bases to produce an scf trace string. _requires_ $version Returns : Nothing. Alters $self. Args : $version - a version number. "2" or "3" Notes : =cut sub _make_trace_string { my ($self,$version) = @_; my @traces; my @traces_view; my @as = @{$self->{'text'}->{'samples_a'}}; my @cs = @{$self->{'text'}->{'samples_c'}}; my @gs = @{$self->{'text'}->{'samples_g'}}; my @ts = @{$self->{'text'}->{'samples_t'}}; if ($version == 2) { for (my $curr=0; $curr < scalar(@as); $curr++) { $as[$curr] = $DEFAULT_QUALITY unless defined $as[$curr]; $cs[$curr] = $DEFAULT_QUALITY unless defined $cs[$curr]; $gs[$curr] = $DEFAULT_QUALITY unless defined $gs[$curr]; $ts[$curr] = $DEFAULT_QUALITY unless defined $ts[$curr]; push @traces,($as[$curr],$cs[$curr],$gs[$curr],$ts[$curr]); } } elsif ($version == 3) { @traces = (@as,@cs,@gs,@ts); } else { $self->throw("No idea what version required to make traces here. You gave #$version# Bailing."); } my $length = scalar(@traces); $self->{'text'}->{'samples_all'} = \@traces; } =head2 _get_binary_comments(\@comments) Title : _get_binary_comments(\@comments) Usage : $self->_get_binary_comments(\@comments); Function: Provide a binary string that will be the comments section of the scf file. See the scf specifications for detailed specifications for the comments section of an scf file. Hint: CODE=something\nBODE=something\n\0 Returns : Args : A reference to an array containing comments. Notes : None. =cut sub _get_binary_comments { my ($self,$rcomments) = @_; my $returner; my $comments_string = ''; my %comments = %$rcomments; foreach my $key (sort keys %comments) { $comments{$key} ||= ''; $comments_string .= "$key=$comments{$key}\n"; } $comments_string .= "\n\0"; my $length = CORE::length($comments_string); $returner->{length} = $length; $returner->{string} = $comments_string; $returner->{binary} = pack "A$length",$comments_string; return $returner; } #=head2 _fill_missing_data($swq) # # Title : _fill_missing_data($swq) # Usage : $self->_fill_missing_data($swq); # Function: If the $swq with quality has no qualities, set all qualities # to 0. # If the $swq has no sequence, set the sequence to N's. # Returns : Nothing. Modifies the Bio::Seq::Quality that was passed as an # argument. # Args : A reference to a Bio::Seq::Quality # Notes : None. # #=cut # ##' #sub _fill_missing_data { # my ($self,$swq) = @_; # my $qual_obj = $swq->qual_obj(); # my $seq_obj = $swq->seq_obj(); # if ($qual_obj->length() == 0 && $seq_obj->length() != 0) { # my $fake_qualities = ("$DEFAULT_QUALITY ")x$seq_obj->length(); # $swq->qual($fake_qualities); # } # if ($seq_obj->length() == 0 && $qual_obj->length != 0) { # my $sequence = ("N")x$qual_obj->length(); # $swq->seq($sequence); # } #} =head2 _delta(\@trace_data,$direction) Title : _delta(\@trace_data,$direction) Usage : $self->_delta(\@trace_data,$direction); Function: Returns : A reference to an array containing modified trace values. Args : A reference to an array containing trace data and a string indicating the direction of conversion. ("forward" or "backward"). Notes : This code is taken from the specification for SCF3.2. http://www.mrc-lmb.cam.ac.uk/pubseq/manual/formats_unix_4.html =cut sub _delta { my ($self,$rsamples,$direction) = @_; my @samples = @$rsamples; # /* If job == DELTA_IT: # * change a series of sample points to a series of delta delta values: # * ie change them in two steps: # * first: delta = current_value - previous_value # * then: delta_delta = delta - previous_delta # * else # * do the reverse # */ # int i; # uint_2 p_delta, p_sample; my ($i,$num_samples,$p_delta,$p_sample,@samples_converted,$p_sample1,$p_sample2); my $SLOW_BUT_CLEAR = 0; $num_samples = scalar(@samples); # c-programmers are funny people with their single-letter variables if ( $direction eq "forward" ) { if($SLOW_BUT_CLEAR){ $p_delta = 0; for ($i=0; $i < $num_samples; $i++) { $p_sample = $samples[$i]; $samples[$i] = $samples[$i] - $p_delta; $p_delta = $p_sample; } $p_delta = 0; for ($i=0; $i < $num_samples; $i++) { $p_sample = $samples[$i]; $samples[$i] = $samples[$i] - $p_delta; $p_delta = $p_sample; } } else { for ($i = $num_samples-1; $i > 1; $i--){ $samples[$i] = $samples[$i] - 2*$samples[$i-1] + $samples[$i-2]; } $samples[1] = $samples[1] - 2*$samples[0]; } } elsif ($direction eq "backward") { if($SLOW_BUT_CLEAR){ $p_sample = 0; for ($i=0; $i < $num_samples; $i++) { $samples[$i] = $samples[$i] + $p_sample; $p_sample = $samples[$i]; } $p_sample = 0; for ($i=0; $i < $num_samples; $i++) { $samples[$i] = $samples[$i] + $p_sample; $p_sample = $samples[$i]; } } else { $p_sample1 = $p_sample2 = 0; for ($i = 0; $i < $num_samples; $i++){ $p_sample1 = $p_sample1 + $samples[$i]; $samples[$i] = $p_sample1 + $p_sample2; $p_sample2 = $samples[$i]; } } } else { $self->warn("Bad direction. Use \"forward\" or \"backward\"."); } return \@samples; } =head2 _unpack_magik($buffer) Title : _unpack_magik($buffer) Usage : $self->_unpack_magik($buffer) Function: What unpack specification should be used? Try them all. Returns : Nothing. Args : A buffer containing arbitrary binary data. Notes : Eliminate the ambiguity and the guesswork. Used in the adaptation of _delta(), mostly. =cut sub _unpack_magik { my ($self,$buffer) = @_; my $length = length($buffer); my (@read,$counter); foreach (qw(c C s S i I l L n N v V)) { @read = unpack "$_$length", $buffer; for ($counter=0; $counter < 20; $counter++) { print("$read[$counter]\n"); } } } =head2 read_from_buffer($filehandle,$buffer,$length) Title : read_from_buffer($filehandle,$buffer,$length) Usage : $self->read_from_buffer($filehandle,$buffer,$length); Function: Read from the buffer. Returns : $buffer, containing a read of $length Args : a filehandle, a buffer, and a read length Notes : I just got tired of typing "unless (length($buffer) == $length)" so I put it here. =cut sub read_from_buffer { my ($self,$fh,$buffer,$length,$start_position) = @_; # print("Reading from a buffer!!! length($length) "); if ($start_position) { # print(" startposition($start_position)(".sprintf("%X", $start_position).")\n"); } # print("\n"); if ($start_position) { # print("seeking to this position in the file: (".$start_position.")\n"); seek ($fh,$start_position,0); # print("done. here is where I am now: (".tell($fh).")\n"); } else { # print("You did not specify a start position. Going from this position (the current position) (".tell($fh).")\n"); } read $fh, $buffer, $length; unless (length($buffer) == $length) { $self->warn("The read was incomplete! Trying harder."); my $missing_length = $length - length($buffer); my $buffer2; read $fh,$buffer2,$missing_length; $buffer .= $buffer2; if (length($buffer) != $length) { $self->throw("Unexpected end of file while reading from SCF file. I should have read $length but instead got ".length($buffer)."! Current file position is ".tell($fh)."."); } } return $buffer; } =head2 _dump_keys() Title : _dump_keys() Usage : &_dump_keys($a_reference_to_some_hash) Function: Dump out the keys in a hash. Returns : Nothing. Args : A reference to a hash. Notes : A debugging method. =cut sub _dump_keys { my $rhash = shift; if ($rhash !~ /HASH/) { print("_dump_keys: that was not a hash.\nIt was #$rhash# which was this reference:".ref($rhash)."\n"); return; } print("_dump_keys: The keys for $rhash are:\n"); foreach (sort keys %$rhash) { print("$_\n"); } } =head2 _dump_base_accuracies() Title : _dump_base_accuracies() Usage : $self->_dump_base_accuracies(); Function: Dump out the v3 base accuracies in an easy to read format. Returns : Nothing. Args : None. Notes : A debugging method. =cut sub _dump_base_accuracies { my $self = shift; print("Dumping base accuracies! for v3\n"); print("There are this many elements in a,c,g,t:\n"); print(scalar(@{$self->{'text'}->{'v3_base_accuracy_a'}}).",".scalar(@{$self->{'text'}->{'v3_base_accuracy_c'}}).",".scalar(@{$self->{'text'}->{'v3_base_accuracy_g'}}).",".scalar(@{$self->{'text'}->{'v3_base_accuracy_t'}})."\n"); my $number_traces = scalar(@{$self->{'text'}->{'v3_base_accuracy_a'}}); for (my $counter=0; $counter < $number_traces; $counter++ ) { print("$counter\t"); print $self->{'text'}->{'v3_base_accuracy_a'}->[$counter]."\t"; print $self->{'text'}->{'v3_base_accuracy_c'}->[$counter]."\t"; print $self->{'text'}->{'v3_base_accuracy_g'}->[$counter]."\t"; print $self->{'text'}->{'v3_base_accuracy_t'}->[$counter]."\t"; print("\n"); } } =head2 _dump_peak_indices_incoming() Title : _dump_peak_indices_incoming() Usage : $self->_dump_peak_indices_incoming(); Function: Dump out the v3 peak indices in an easy to read format. Returns : Nothing. Args : None. Notes : A debugging method. =cut sub _dump_peak_indices_incoming { my $self = shift; print("Dump peak indices incoming!\n"); my $length = $self->{'bases'}; print("The length is $length\n"); for (my $count=0; $count < $length; $count++) { print("$count\t$self->{parsed}->{peak_indices}->[$count]\n"); } } =head2 _dump_base_accuracies_incoming() Title : _dump_base_accuracies_incoming() Usage : $self->_dump_base_accuracies_incoming(); Function: Dump out the v3 base accuracies in an easy to read format. Returns : Nothing. Args : None. Notes : A debugging method. =cut sub _dump_base_accuracies_incoming { my $self = shift; print("Dumping base accuracies! for v3\n"); # print("There are this many elements in a,c,g,t:\n"); # print(scalar(@{$self->{'parsed'}->{'v3_base_accuracy_a'}}).",".scalar(@{$self->{'text'}->{'v3_base_accuracy_c'}}).",".scalar(@{$self->{'text'}->{'v3_base_accuracy_g'}}).",".scalar(@{$self->{'text'}->{'v3_base_accuracy_t'}})."\n"); my $number_traces = $self->{'bases'}; for (my $counter=0; $counter < $number_traces; $counter++ ) { print("$counter\t"); foreach (qw(A T G C)) { print $self->{'parsed'}->{'base_accuracies'}->{$_}->[$counter]."\t"; } print("\n"); } } =head2 _dump_comments() Title : _dump_comments() Usage : $self->_dump_comments(); Function: Debug dump the comments section from the scf. Returns : Nothing. Args : Nothing. Notes : None. =cut sub _dump_comments { my ($self) = @_; warn ("SCF comments:\n"); foreach my $k (keys %{$self->{'comments'}}) { warn ("\t {$k} ==> ", $self->{'comments'}->{$k}, "\n"); } } 1; __END__ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/seqxml.pm�����������������������������������������������������������������000444��000765��000024�� 70573�12254227330� 17030� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::seqxml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Dave Messina <dmessina@cpan.org> # # Copyright Dave Messina # # You may distribute this module under the same terms as perl itself # _history # December 2009 - initial version # July 2 2010 - updated for SeqXML v0.2 # November 11 2010 - added schemaLocation # December 9 2010 - SeqXML v0.3 # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::seqxml - SeqXML sequence input/output stream =head1 SYNOPSIS # Do not use this module directly. Use it via the Bio::SeqIO class. use Bio::SeqIO; # read a SeqXML file my $seqio = Bio::SeqIO->new(-format => 'seqxml', -file => 'my_seqs.xml'); while (my $seq_object = $seqio->next_seq) { print join("\t", $seq_object->display_id, $seq_object->description, $seq_object->seq, ), "\n"; } # write a SeqXML file # # Note that you can (optionally) specify the source # (usually a database) and source version. my $seqwriter = Bio::SeqIO->new(-format => 'seqxml', -file => ">outfile.xml", -source => 'Ensembl', -sourceVersion => '56'); $seqwriter->write_seq($seq_object); # once you've written all of your seqs, you may want to do # an explicit close to get the closing </seqXML> tag $seqwriter->close; =head1 DESCRIPTION This object can transform Bio::Seq objects to and from SeqXML format. For more information on the SeqXML standard, visit L<http://www.seqxml.org>. In short, SeqXML is a lightweight sequence format that takes advantage of the validation capabilities of XML while not overburdening you with a strict and complicated schema. This module is based in part (particularly the XML-parsing part) on Bio::TreeIO::phyloxml by Mira Han. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Dave Messina Email: I<dmessina@cpan.org> =head1 CONTRIBUTORS =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::seqxml; use strict; use Bio::Seq; use Bio::Seq::SeqFactory; use Bio::Species; use Bio::Annotation::DBLink; use Bio::Annotation::SimpleValue; use XML::LibXML; use XML::LibXML::Reader; use XML::Writer; use base qw(Bio::SeqIO); # define seqXML header stuff # there's no API for XMLNS XMLNS_XSI; you must set them here. use constant SEQXML_VERSION => 0.3; use constant SCHEMA_LOCATION => 'http://www.seqxml.org/0.3/seqxml.xsd'; use constant XMLNS_XSI => 'http://www.w3.org/2001/XMLSchema-instance'; =head2 _initialize Title : _initialize Usage : $self->_initialize(@args) Function: constructor (for internal use only). Besides the usual SeqIO arguments (-file, -fh, etc.), Bio::SeqIO::seqxml accepts three arguments which are used when writing out a seqxml file. They are all optional. Returns : none Args : -source => source string (usually a database name) -sourceVersion => source version. The version number of the source -seqXMLversion => the version of seqXML that will be used Throws : Exception if XML::LibXML::Reader or XML::Writer is not initialized =cut sub _initialize { my ( $self, @args ) = @_; $self->SUPER::_initialize(@args); if ( !defined $self->sequence_factory ) { $self->sequence_factory( Bio::Seq::SeqFactory->new( -verbose => $self->verbose(), -type => 'Bio::Seq', ) ); } # holds version and source data $self->{'_seqxml_metadata'} = {}; # load any passed parameters my %params = @args; if ($params{'-sourceVersion'}) { $self->sourceVersion($params{'-sourceVersion'}); } if ($params{'-source'}) { $self->source($params{'-source'}); } if ($params{'-seqXMLversion'}) { $self->seqXMLversion($params{'-seqXMLversion'}); } # reading in SeqXML if ( $self->mode eq 'r' ) { if ( $self->_fh ) { $self->{'_reader'} = XML::LibXML::Reader->new( IO => $self->_fh, no_blanks => 1, ); } if ( !$self->{'_reader'} ) { $self->throw("XML::LibXML::Reader not initialized"); } # holds data temporarily during parsing $self->{'_current_entry_data'} = {}; $self->_initialize_seqxml_node_methods(); # read SeqXML header $self->parseHeader(); } # writing out SeqXML elsif ( $self->mode eq 'w' ) { if ( $self->_fh ) { $self->{'_writer'} = XML::Writer->new( OUTPUT => $self->_fh, DATA_MODE => 1, DATA_INDENT => 1, ); if ( !$self->{'_writer'} ) { $self->throw("XML::Writer not initialized"); } # write SeqXML header $self->{'_writer'}->xmlDecl("UTF-8"); if ($self->source || $self->sourceVersion) { $self->{'_writer'}->startTag( 'seqXML', 'seqXMLversion' => $self->seqXMLversion(SEQXML_VERSION), 'xmlns:xsi' => XMLNS_XSI, 'xsi:noNamespaceSchemaLocation' => $self->schemaLocation(SCHEMA_LOCATION), 'source' => $self->source, 'sourceVersion' => $self->sourceVersion, ); } else { $self->{'_writer'}->startTag( 'seqXML', 'seqXMLversion' => $self->seqXMLversion(SEQXML_VERSION), 'xmlns:xsi' => XMLNS_XSI, 'xsi:noNamespaceSchemaLocation' => $self->schemaLocation(SCHEMA_LOCATION), ); } } } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : L<Bio::Seq> object, or nothing if no more available Args : none =cut sub next_seq { my ($self) = @_; my $reader = $self->{'_reader'}; my $entry; while ( $reader->read ) { # we're done if we hit </entry> if ( $reader->nodeType == XML_READER_TYPE_END_ELEMENT ) { if ( $reader->name eq 'entry' ) { $entry = $self->end_element_entry(); last; } } $self->processXMLnode; } return $entry; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: Writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Array of 1 or more L<Bio::PrimarySeqI> objects =cut sub write_seq { my ( $self, @seqs ) = @_; my $writer = $self->{'_writer'}; foreach my $seqobj (@seqs) { $self->throw("Trying to write with no seq!") unless defined $seqobj; if ( !ref $seqobj || !$seqobj->isa('Bio::SeqI') ) { $self->warn( " $seqobj is not a SeqI compliant module. Attempting to dump, but may fail!" ); } # opening tag, ID, and source (if present -- it's optional) my $id = $seqobj->display_id; my ($source_obj) = $seqobj->get_Annotations('source'); if (defined $source_obj && defined $id) { $writer->startTag( 'entry', 'id' => $id, 'source' => $source_obj->value ); } elsif (defined $id) { $writer->startTag( 'entry', 'id' => $id ); } else { $self->throw(" $seqobj has no ID!"); } # species and NCBI taxID if ( $seqobj->species ) { my $name = $seqobj->species->node_name; my $taxid = $seqobj->species->ncbi_taxid; if ( $name && ( $taxid =~ /[0-9]+/ ) ) { $writer->emptyTag( 'species', 'name' => $name, 'ncbiTaxID' => $taxid ); } else { $self->throw("$seqobj has malformed species data"); } } # description if ( $seqobj->desc ) { $writer->dataElement( 'description', $seqobj->desc ); } # sequence # - throws if seq is empty or missing because having a sequence # is a SeqXML requirement if ( $seqobj->seq ) { # check that there's actually sequence in there unless ( length($seqobj->seq) > 0 ) { $self->throw("sequence entry $id lacks a sequence!"); } my $alphabet = $seqobj->alphabet; my %seqtype = ( 'rna' => 'RNAseq', 'dna' => 'DNAseq', 'protein' => 'AAseq' ); unless ( exists( $seqtype{$alphabet} ) ) { $self->throw("invalid sequence alphabet $alphabet!"); } $writer->dataElement( $seqtype{$alphabet}, $seqobj->seq ); } else { $self->throw("sequence entry $id lacks a sequence!"); } # Database crossreferences my @dblinks = $seqobj->get_Annotations('dblink'); foreach my $dblink (@dblinks) { unless ( $dblink->database && $dblink->primary_id ) { $self->throw("dblink $dblink is malformed"); } if (defined($dblink->type)) { $writer->emptyTag( 'DBRef', 'type' => $dblink->type, 'source' => $dblink->database, 'id' => $dblink->primary_id, ); } else { $writer->emptyTag( 'DBRef', 'source' => $dblink->database, 'id' => $dblink->primary_id, ); } } # properties my @annotations = $seqobj->get_Annotations(); foreach my $annot_obj (@annotations) { next if ( $annot_obj->tagname eq 'dblink' ); next if ( $annot_obj->tagname eq 'source' ); # handled above # SeqXML doesn't support references next if ( $annot_obj->tagname eq 'reference' ); unless ( $annot_obj->tagname ) { $self->throw("property $annot_obj is missing a tagname"); } if ( $annot_obj->value ) { $writer->emptyTag( 'property', 'name' => $annot_obj->tagname, 'value' => $annot_obj->value, ); } else { $writer->emptyTag( 'property', 'name' => $annot_obj->tagname, ); } } # closing tag $writer->endTag('entry'); # make sure it gets written to the file $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } } =head2 _initialize_seqxml_node_methods Title : _initialize_seqxml_node_methods Usage : $self->_initialize_xml_node_methods Function: sets up code ref mapping of each seqXML node type to a method for processing that node type Returns : none Args : none =cut sub _initialize_seqxml_node_methods { my ($self) = @_; my %start_elements = ( 'seqXML' => \&element_seqXML, 'entry' => \&element_entry, 'species' => \&element_species, 'description' => \&element_description, 'RNAseq' => \&element_RNAseq, 'DNAseq' => \&element_DNAseq, 'AAseq' => \&element_AAseq, 'DBRef' => \&element_DBRef, 'property' => \&element_property, ); $self->{'_start_elements'} = \%start_elements; my %end_elements = ( 'seqXML' => \&end_element_default, 'entry' => \&end_element_entry, 'species' => \&end_element_default, 'description' => \&end_element_default, 'RNAseq' => \&end_element_RNAseq, 'DNAseq' => \&end_element_DNAseq, 'AAseq' => \&end_element_AAseq, 'DBRef' => \&end_element_default, 'property' => \&end_element_default, ); $self->{'_end_elements'} = \%end_elements; } =head2 schemaLocation Title : schemaLocation Usage : $self->schemaLocation Function: gets/sets the schema location in the <seqXML> header Returns : the schema location string Args : To set the schemaLocation, call with a schemaLocation as the argument. =cut sub schemaLocation { my ( $self, $value ) = @_; my $metadata = $self->{'_seqxml_metadata'}; # set if a value is supplied if ($value) { $metadata->{'schemaLocation'} = $value; } return $metadata->{'schemaLocation'}; } =head2 source Title : source Usage : $self->source Function: gets/sets the data source in the <seqXML> header Returns : the data source string Args : To set the source, call with a source string as the argument. =cut sub source { my ( $self, $value ) = @_; my $metadata = $self->{'_seqxml_metadata'}; # set if a value is supplied if ($value) { $metadata->{'source'} = $value; } return $metadata->{'source'}; } =head2 sourceVersion Title : sourceVersion Usage : $self->sourceVersion Function: gets/sets the data source version in the <seqXML> header Returns : the data source version string Args : To set the source version, call with a source version string as the argument. =cut sub sourceVersion { my ( $self, $value ) = @_; my $metadata = $self->{'_seqxml_metadata'}; # set if a value is supplied if ($value) { $metadata->{'sourceVersion'} = $value; } return $metadata->{'sourceVersion'}; } =head2 seqXMLversion Title : seqXMLversion Usage : $self->seqXMLversion Function: gets/sets the seqXML version in the <seqXML> header Returns : the seqXML version string. Args : To set the seqXML version, call with a seqXML version string as the argument. =cut sub seqXMLversion { my ( $self, $value ) = @_; my $metadata = $self->{'_seqxml_metadata'}; # set if a value is supplied if ($value) { $metadata->{'seqXMLversion'} = $value; } return $metadata->{'seqXMLversion'}; } =head1 Methods for parsing the XML document =cut =head2 processXMLNode Title : processXMLNode Usage : $seqio->processXMLNode Function: reads the XML node and processes according to the node type Returns : none Args : none Throws : Exception on unexpected XML node type, warnings on unexpected XML element names. =cut sub processXMLnode { my ($self) = @_; my $reader = $self->{'_reader'}; my $nodetype = $reader->nodeType; if ( $nodetype == XML_READER_TYPE_ELEMENT ) { $self->{'_current_element_name'} = $reader->name; if ( exists $self->{'_start_elements'}->{ $reader->name } ) { my $method = $self->{'_start_elements'}->{ $reader->name }; $self->$method(); } else { my $name = $reader->name; $self->warn("unexpected start element encountered: $name"); } } elsif ( $nodetype == XML_READER_TYPE_TEXT ) { # store key-value pair of element name and the corresponding text my $name = $self->{'_current_element_name'}; $self->{'_current_entry_data'}->{$name} = $reader->value; } elsif ( $nodetype == XML_READER_TYPE_END_ELEMENT ) { if ( exists $self->{'_end_elements'}->{ $reader->name } ) { my $method = $self->{'_end_elements'}->{ $reader->name }; $self->$method(); } else { my $name = $reader->name; $self->warn("unexpected end element encountered: $name"); } $self->{'_current_element_name'} = {}; # empty current element name } else { $self->throw( "unexpected node type " . $nodetype, " encountered (name: ", $reader->name, ")\n" ); } if ( $self->debug ) { printf "%d %d %s %d\n", ( $reader->depth, $reader->nodeType, $reader->name, $reader->isEmptyElement ); } } =head2 processAttribute Title : processAttribute Usage : $seqio->processAttribute(\%hash_for_attribute); Function: reads the attributes of the current element into a hash Returns : none Args : hash reference where the attributes will be stored. =cut sub processAttribute { my ( $self, $data ) = @_; my $reader = $self->{'_reader'}; # several ways of reading attributes: # read all attributes: if ( $reader->moveToFirstAttribute ) { do { $data->{ $reader->name() } = $reader->value; } while ( $reader->moveToNextAttribute ); $reader->moveToElement; } } =head2 parseHeader Title : parseHeader Usage : $self->parseHeader(); Function: reads the opening <seqXML> block and grabs the metadata from it, namely the source, sourceVersion, and seqXMLversion. Returns : none Args : none Throws : Exception if it hits an <entry> tag, because that means it's missed the <seqXML> tag and read too far into the file. =cut sub parseHeader { my ($self) = @_; my $reader = $self->{'_reader'}; while($reader->read) { # just read the header if ( $reader->nodeType == XML_READER_TYPE_ELEMENT ) { if ( $reader->name eq 'seqXML' ) { $self->element_seqXML(); last; } elsif ( $reader->name eq 'entry' ) { my $name = $reader->name; $self->throw("Missed the opening <seqXML> tag. Got $name instead."); } } } } =head2 element_seqXML Title : element_seqXML Usage : $self->element_seqXML Function: processes the opening <seqXML> node Returns : none Args : none =cut sub element_seqXML { my ($self) = @_; my $reader = $self->{'_reader'}; # reset for every new <seqXML> block $self->{'_seqxml_metadata'} = {}; if ( $reader->hasAttributes() ) { $self->processAttribute( $self->{'_seqxml_metadata'} ); } else { $self->throw("no SeqXML metadata!"); } } =head2 element_entry Title : element_entry Usage : $self->element_entry Function: processes a sequence <entry> node Returns : none Args : none Throws : Exception if sequence ID is not present in <entry> element =cut sub element_entry { my ($self) = @_; my $reader = $self->{'_reader'}; if ( $reader->hasAttributes() ) { $self->processAttribute( $self->{'_current_entry_data'} ); } else { $self->throw("no sequence ID!"); } } =head2 element_species Title : element_entry Usage : $self->element_entry Function: processes a <species> node, creating a Bio::Species object Returns : none Args : none Throws : Exception if <species> tag exists but is empty, or if the attributes 'name' or 'ncbiTaxID' are undefined =cut sub element_species { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; my $species_data = {}; my $species_obj; if ( $reader->hasAttributes() ) { $self->processAttribute($species_data); } else { $self->throw("no species information!"); } if ( defined $species_data->{'name'} && defined $species_data->{'ncbiTaxID'} ) { $species_obj = Bio::Species->new( -ncbi_taxid => $species_data->{'ncbiTaxID'}, ); $species_obj->node_name( $species_data->{'name'} ); $data->{'species'} = $species_obj; } else { $self->throw("<species> attributes name and ncbiTaxID are undefined"); } } =head2 element_description Title : element_description Usage : $self->element_description Function: processes a sequence <description> node; a no-op -- description text is read by processXMLnode Returns : none Args : none =cut sub element_description { my ($self) = @_; } =head2 element_RNAseq Title : element_RNAseq Usage : $self->element_RNAseq Function: processes a sequence <RNAseq> node Returns : none Args : none =cut sub element_RNAseq { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; $data->{'alphabet'} = 'rna'; $data->{'sequence'} = $data->{'RNAseq'}; } =head2 element_DNAseq Title : element_DNAseq Usage : $self->element_DNAseq Function: processes a sequence <DNAseq> node Returns : none Args : none =cut sub element_DNAseq { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; $data->{'alphabet'} = 'dna'; $data->{'sequence'} = $data->{'DNAseq'}; } =head2 element_AAseq Title : element_AAseq Usage : $self->element_AAseq Function: processes a sequence <AAseq> node Returns : none Args : none =cut sub element_AAseq { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; $data->{'alphabet'} = 'protein'; $data->{'sequence'} = $data->{'AAseq'}; } =head2 element_DBRef Title : element_DBRef Usage : $self->element_DBRef Function: processes a sequence <DBRef> node, creating a Bio::Annotation::DBLink object Returns : none Args : none =cut sub element_DBRef { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; my $DBRef = {}; my $annotation_obj; if ( $reader->hasAttributes() ) { $self->processAttribute($DBRef); } else { $self->throw("no DBRef data!"); } if ( defined $DBRef->{'source'} && defined $DBRef->{'id'} && defined $DBRef->{'type'}) { $annotation_obj = Bio::Annotation::DBLink->new( -primary_id => $DBRef->{'id'}, -database => $DBRef->{'source'}, -type => $DBRef->{'type'}, -tagname => 'dblink', ); push @{ $data->{'DBRefs'} }, $annotation_obj; } else { $self->throw("malformed DBRef data!"); } } =head2 element_property Title : element_property Usage : $self->element_property Function: processes a sequence <property> node, creating a Bio::Annotation::SimpleValue object Returns : none Args : none =cut sub element_property { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; my $property = {}; my $annotation_obj; if ( $reader->hasAttributes() ) { $self->processAttribute($property); } else { $self->throw("no property data!"); } if ( defined $property->{'name'} ) { $annotation_obj = Bio::Annotation::SimpleValue->new( -tagname => $property->{'name'} ); if ( defined $property->{'value'} ) { $annotation_obj->value( $property->{'value'} ); } push @{ $data->{'properties'} }, $annotation_obj; } else { $self->throw("malformated property!"); } } =head2 end_element_RNAseq Title : end_element_RNAseq Usage : $self->end_element_RNAseq Function: processes a sequence <RNAseq> node Returns : none Args : none =cut sub end_element_RNAseq { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; $data->{'alphabet'} = 'rna'; $data->{'sequence'} = $data->{'RNAseq'}; } =head2 end_element_DNAseq Title : end_element_DNAseq Usage : $self->end_element_DNAseq Function: processes a sequence <DNAseq> node Returns : none Args : none =cut sub end_element_DNAseq { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; $data->{'alphabet'} = 'dna'; $data->{'sequence'} = $data->{'DNAseq'}; } =head2 end_element_AAseq Title : end_element_AAseq Usage : $self->end_element_AAseq Function: processes a sequence <AAseq> node Returns : none Args : none =cut sub end_element_AAseq { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; $data->{'alphabet'} = 'protein'; $data->{'sequence'} = $data->{'AAseq'}; } =head2 end_element_entry Title : end_element_entry Usage : $self->end_element_entry Function: processes the closing </entry> node, creating the Seq object Returns : a Bio::Seq object Args : none Throws : Exception if sequence, sequence ID, or alphabet are missing =cut sub end_element_entry { my ($self) = @_; my $reader = $self->{'_reader'}; my $data = $self->{'_current_entry_data'}; # make sure we've got at least a seq, an ID, and an alphabet unless ( $data->{'sequence'} && length($data->{'sequence'}) > 0) { $self->throw("this entry lacks a sequence"); } unless ( $data->{'id'} ) { $self->throw("this entry lacks an id"); } unless ( $data->{'alphabet'} ) { $self->throw("this entry lacks an alphabet"); } # create new sequence object with minimum necessary parameters my $seq_obj = $self->sequence_factory->create( -seq => $data->{'sequence'}, -alphabet => $data->{'alphabet'}, -id => $data->{'id'}, -primary_id => $data->{'id'}, ); # add additional parameters if available if ( $data->{'description'} ) { $seq_obj->desc( $data->{'description'} ); } if ( $data->{'species'} ) { $seq_obj->species( $data->{'species'} ); } if ( $data->{'DBRefs'} ) { foreach my $annotation_obj ( @{ $data->{'DBRefs'} } ) { $seq_obj->add_Annotation($annotation_obj); } } if ( $data->{'properties'} ) { foreach my $annotation_obj ( @{ $data->{'properties'} } ) { $seq_obj->add_Annotation($annotation_obj); } } if ( $data->{'source'} ) { my $annotation_obj = Bio::Annotation::SimpleValue->new( '-tagname' => 'source', '-value' => $data->{'source'}, ); $seq_obj->add_Annotation($annotation_obj); } # empty the temporary data store $self->{'_current_entry_data'} = {}; return $seq_obj; } =head2 end_element_default Title : end_element_default Usage : $self->end_element_default Function: processes all other closing tags; a no-op. Returns : none Args : none =cut sub end_element_default { my ($self) = @_; } =head2 DESTROY Title : DESTROY Usage : called automatically by Perl just before object goes out of scope Function: performs a write flush Returns : none Args : none =cut sub DESTROY { my $self = shift; $self->flush if $self->_flush_on_write && defined $self->_fh; $self->SUPER::DESTROY; } =head2 close Title : close Usage : $seqio_obj->close(). Function: writes closing </seqXML> tag. close() will be called automatically by Perl when your program exits, but if you want to use the seqXML file you've written before then, you'll need to do an explicit close first to get the final </seqXML> tag. Returns : none Args : none =cut sub close { my $self = shift; if ( $self->mode eq 'w' && $self->{'_writer'}->within_element('seqXML') ) { $self->{'_writer'}->endTag("seqXML"); $self->{'_writer'}->end(); } $self->SUPER::close(); } 1; �������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/strider.pm����������������������������������������������������������������000444��000765��000024�� 15617�12254227333� 17174� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::strider # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Malcolm Cook <mec@stowers-institute.org> # # You may distribute this module under the same terms as perl itself # # _history # April 7th, 2005 Malcolm Cook authored # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::strider - DNA strider sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from strider 'binary' format, as documented in the strider manual, in which the first 112 bytes are a header, following by the sequence, followed by a sequence description. Note: it does NOT assign any sequence identifier, since they are not contained in the byte stream of the file; the Strider application simply displays the name of the file on disk as the name of the sequence. The caller should set the id, probably based on the name of the file (after possibly cleaning up whitespace, which ought not to be used as the id in most applications). Note: the strider 'comment' is mapped to the BioPerl 'description' (since there is no other text field, and description maps to defline text). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Malcolm Cook Email: mec@stowers-institute.org =head1 CONTRIBUTORS Modelled after Bio::SeqIO::fasta by Ewan Birney E<lt>birney@ebi.ac.ukE<gt> and Lincoln Stein E<lt>lstein@cshl.orgE<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::strider; use strict; use warnings; use Bio::Seq::SeqFactory; use Convert::Binary::C; use base qw(Bio::SeqIO); my $c = Convert::Binary::C->new ( ByteOrder => 'BigEndian', Alignment => 2 ); my $headerdef; {local ($/); # See this file's __DATA__ section for the c structure definitions # for strider binary header data. Here we slurp it all into $headerdef. $headerdef = <DATA>}; $c->parse($headerdef); my $size_F_HEADER = 112; die "expected strider header structure size of $size_F_HEADER" unless $size_F_HEADER eq $c->sizeof('F_HEADER'); my %alphabet2type = ( # map between BioPerl alphabet and strider # sequence type code. # From Strider Documentation: the sequence type: # 1, 2, 3 and 4 for DNA, DNA Degenerate, RNA and # Protein sequence files, respectively. # TODO: determine 'DNA Degenerate' based on # sequence alphabet? dna => 1, rna => 3, protein => 4, ); my %type2alphabet = reverse %alphabet2type; sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); unless ( defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : NONE =cut sub next_seq { my( $self ) = @_; my $fh = $self->_fh; my ($header,$sequence,$fulldesc); eval {read $fh,$header,$size_F_HEADER}; $self->throw ("$@ while attempting to reading strider header from " . $self->{'_file'}) if $@; $self->throw("required $size_F_HEADER bytes while reading strider header in " . $self->{'_file'} . " but found: " . length($header)) unless $size_F_HEADER == length($header); my $headerdata = $c->unpack('F_HEADER',$header) or return; read $fh,$sequence,$headerdata->{nLength}; read $fh,$fulldesc,$headerdata->{com_length}; $fulldesc =~ s/\cM/ /g; # gratuitous replacement of mac # linefeed with space. my $seq = $self->sequence_factory->create( # -id => $main::ARGV, #might want to set this in caller to $ARGV. -seq => $sequence, -desc => $fulldesc, -alphabet => $type2alphabet{$headerdata->{type}} || 'dna', ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::PrimarySeqI objects =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh() || *STDOUT; #die "could not determine filehandle in strider.pm"; foreach my $seq (@seq) { $self->throw("Did not provide a valid Bio::PrimarySeqI object") unless defined $seq && ref($seq) && $seq->isa('Bio::PrimarySeqI'); my $headerdata = $c->pack('F_HEADER',{ versionNb => 0, type => $alphabet2type{$seq->alphabet} || $alphabet2type{dna}, topology => $seq->is_circular ? 1 : 0, nLength => $seq->length, nMinus => 0, com_length => length($seq->desc || ""), }); print $fh $headerdata, $seq->seq() || "" , $seq->desc || ""; } } 1; __DATA__ //The following was taken from the strider 1.4 release notes Appendix (with //some comments gleaned from other parts of manual) struct F_HEADER { char versionNb; // the format version number, currently it is set to 0 char type; // 1=DNA, 2=DNA Degenerate, 3=RNA or 4=Protein char topology; // linear or circular - 0 for a linear sequence, 1 for a circular one char reserved1; int reserved2; int reserved3; int reserved4; char reserved5; char filler1; short filler2; int filler3; int reserved6; int nLength; // Sequence length - the length the Sequence field (the number of char in the text, each being a base or an aa) int nMinus; // nb of "negative" bases, i.e. the number of bases numbered with negative numbers int reserved7; int reserved8; int reserved9; int reserved10; int reserved11; char reserved12[32]; short reserved13; short filler4; char reserved14; char reserved15; char reserved16; char filler5; int com_length; // the length the Comment field (the number of char in the text). int reserved17; int filler6; int filler7; }; �����������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/swiss.pm������������������������������������������������������������������000444��000765��000024�� 145431�12254227313� 16704� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::swiss # # Copyright Elia Stupka # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::swiss - Swissprot sequence input/output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the SeqIO handler system: use Bio::SeqIO; $stream = Bio::SeqIO->new(-file => $filename, -format => 'swiss'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from Swiss-Pprot flat file databases. There is a lot of flexibility here about how to dump things which needs to be documented. =head2 GN (Gene name) line management details A Uniprot/Swiss-Prot entry holds information on one protein sequence. If that sequence is identical across genes and species, they are all merged into one entry. This creates complex needs for several annotation fields in swiss-prot format. The latest syntax for GN line is described in the user manual: http://www.expasy.ch/sprot/userman.html#GN_line Each of the possibly multiple genes in an entry can have Name, Synonyms (only if there is a name), OrderedLocusNames (names from genomic sequences) and ORFNames (temporary or cosmid names). "Name" here really means "symbol". This complexity is now dealt with the following way: A new Bio::AnnotationI class was created in order to store the data in tag-value pairs. This class (Bio::Annotation::TagTree) is stored in the Bio::Annotation::Collection object and is accessed like all other annotations. The tag name is 'gene_name'. There is a single Bio::Annotation::TagTree per sequence record, which corresponds to the original class that stored this data (Bio::Annotation::StructuredValue). Depending on how we progress this may change to represent each group of gene names. For now, to access the gene name tree annotation, one uses the below method: my ($gene) = $seq->annotation->get_Annotations('gene_name'); If you are only interested in displaying the values, value() returns a string with similar formatting. There are several ways to get directly at the information you want if you know the element (tag) for the data. For gene names all data is stored with the element-tag pairs: "element1=tag1, tag2, tag3; element2=tag4, tag5;" This normally means the element will be 'Name', 'Synonyms', etc. and the gene names the values. Using findval(), you can do the following: # grab a flattened list of all gene names my @names = $ann->findval('Name'); # or iterated through the nodes and grab the name for each group for my $node ($ann->findnode('gene_name')) { my @names = $node->findval('Name'); } The current method for parsing gene name data (and reconstructing gene name output) is very generic. This is somewhat preemptive if, for instance, UniProt decides to update and add another element name to the current ones using the same formatting layout. Under those circumstances, one can iterate through the tag tree in a safe way and retrieve all node data like so. # retrieve the gene name nodes (groups like names, synonyms, etc). for my $ann ($seq->annotation->get_Annotations('gene_name')) { # each gene name group for my $node ($ann->findnode('gene_name')) { print "Gene name:\n"; # each gene name node (tag => value pair) for my $n ($node->children) { print "\t".$n->element.": ".$n->children."\n"; } } } For more uses see Bio::Annotation::TagTree. Since Uniprot/Swiss-Prot format have been around for quite some time, the parser is also able to read in the older GN line syntax where genes are separated by AND and various symbols by OR. The first symbol is taken to be the 'Name' and the remaining ones are stored as 'Synonyms'. Also, for UniProt output we support using other Bio::AnnotationI, but in this case we only use the stringified version of the annotation. This is to allow for backwards compatibility with code that previously used Bio::Annotation::SimpleValue or other Bio::AnnotationI classes. =head2 Optional functions =over 3 =item _show_dna() (output only) shows the dna or not =item _post_sort() (output only) provides a sorting func which is applied to the FTHelpers before printing =item _id_generation_func() This is function which is called as print "ID ", $func($seq), "\n"; To generate the ID line. If it is not there, it generates a sensible ID line using a number of tools. If you want to output annotations in Swissprot format they need to be stored in a Bio::Annotation::Collection object which is accessible through the Bio::SeqI interface method L<annotation()|annotation>. The following are the names of the keys which are polled from a L<Bio::Annotation::Collection> object. reference - Should contain Bio::Annotation::Reference objects comment - Should contain Bio::Annotation::Comment objects dblink - Should contain Bio::Annotation::DBLink objects gene_name - Should contain Bio::Annotation::SimpleValue object =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions, preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Elia Stupka Email elia@tll.org.sg =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::swiss; use vars qw(@Unknown_names @Unknown_genus); use strict; use Bio::SeqIO::FTHelper; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Tools::SeqStats; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::DBLink; use Bio::Annotation::SimpleValue; use Bio::Annotation::TagTree; use base qw(Bio::SeqIO); our $LINE_LENGTH = 76; # this is for doing species name parsing @Unknown_names=('other', 'unidentified', 'unknown organism', 'not specified', 'not shown', 'Unspecified', 'Unknown', 'None', 'unclassified', 'unidentified organism', 'not supplied' ); # dictionary of synonyms for taxid 32644 # all above can be part of valid species name @Unknown_genus = qw(unknown unclassified uncultured unidentified); # if there are any other gene name tags, they are added to the end our @GENE_NAME_ORDER = qw(Name Synonyms OrderedLocusNames ORFNames); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); # hash for functions for decoding keys. $self->{'_func_ftunit_hash'} = {}; # sets this to one by default. People can change it $self->_show_dna(1); if ( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq { my ($self,@args) = @_; my ($pseq,$c,$line,$name,$desc,$acc,$seqc,$mol,$div, $sptr,$seq_div, $date,$comment,@date_arr); my $genename = ""; my ($annotation, %params, @features) = ( Bio::Annotation::Collection->new()); local $_; 1 while defined($_ = $self->_readline) && /^\s+$/; return unless defined $_ && /^ID\s/; # fixed to allow _DIVISION to be optional for bug #946 # see bug report for more information # # 9/6/06 Note: Swiss/TrEMBL sequences have no division acc. to UniProt # release notes; this is fixed to simplify the regex parsing # STANDARD (SwissProt) and PRELIMINARY (TrEMBL) added to namespace() unless( m{^ ID \s+ # (\S+) \s+ # $1 entryname ([^\s;]+); \s+ # $2 DataClass (?:PRT;)? \s+ # Molecule Type (optional) [0-9]+[ ]AA \. # Sequencelength (capture?) $ }ox ) { # I couldn't find any new current UniProt sequences # that matched this format: # || m/^ID\s+(\S+)\s+(_([^\s_]+))? /ox ) { $self->throw("swissprot stream with no ID. Not swissprot in my book"); } ($name, $seq_div) = ($1, $2); $params{'-namespace'} = ($seq_div eq 'Reviewed' || $seq_div eq 'STANDARD') ? 'Swiss-Prot' : ($seq_div eq 'Unreviewed' || $seq_div eq 'PRELIMINARY') ? 'TrEMBL' : $seq_div; # we shouldn't be setting the division, but for now... my ($junk, $division) = split q(_), $name; $params{'-division'} = $division; $params{'-alphabet'} = 'protein'; # this is important to have the id for display in e.g. FTHelper, otherwise # you won't know which entry caused an error $params{'-display_id'} = $name; BEFORE_FEATURE_TABLE : while ( defined($_ = $self->_readline) ) { # Exit at start of Feature table and at the sequence at the # latest HL 05/11/2000 last if( /^(FT|SQ)/ ); # Description line(s) if (/^DE\s+(\S.*\S)/) { $desc .= $desc ? " $1" : $1; } #Gene name elsif (/^GN\s+(.*)/) { $genename .= " " if $genename; $genename .= $1; } #accession number(s) elsif ( /^AC\s+(.+)/) { my @accs = split(/[; ]+/, $1); # allow space in addition $params{'-accession_number'} = shift @accs unless defined $params{'-accession_number'}; push @{$params{'-secondary_accessions'}}, @accs; } #date and sequence version elsif ( /^DT\s+(.*)/ ) { my $line = $1; my ($date, $version) = split(' ', $line, 2); $date =~ tr/,//d; # remove comma if new version if ($version =~ /\(Rel\. (\d+), Last sequence update\)/ || # old /sequence version (\d+)/) { #new my $update = Bio::Annotation::SimpleValue->new (-tagname => 'seq_update', -value => $1 ); $annotation->add_Annotation($update); } elsif ($version =~ /\(Rel\. (\d+), Last annotation update\)/ || #old /entry version (\d+)/) { #new $params{'-version'} = $1; } push @{$params{'-dates'}}, $date; } # Evidence level elsif ( /^PE\s+(.*)/ ) { my $line = $1; $line =~ s/;\s*//; # trim trailing semicolon and any spaces at the end of the line my $evidence = Bio::Annotation::SimpleValue->new (-tagname => 'evidence', -value => $line ); $annotation->add_Annotation($evidence); } # Organism name and phylogenetic information elsif (/^O[SCG]/) { my $species = $self->_read_swissprot_Species($_); $params{'-species'}= $species; # now we are one line ahead -- so continue without reading the next # line HL 05/11/2000 } # References elsif (/^R/) { my $refs = $self->_read_swissprot_References($_); foreach my $r (@$refs) { $annotation->add_Annotation('reference',$r); } } # Comments elsif (/^CC\s{3}(.*)/) { $comment .= $1; $comment .= "\n"; while (defined ($_ = $self->_readline) && /^CC\s{3}(.*)/ ) { $comment .= $1 . "\n"; } # note: don't try to process comments here -- they may contain # structure. LP 07/30/2000 my $commobj = Bio::Annotation::Comment->new(-tagname => 'comment', -text => $comment); $annotation->add_Annotation('comment',$commobj); $comment = ""; $self->_pushback($_); } #DBLinks # old regexp # /^DR\s+(\S+)\;\s+(\S+)\;\s+(\S+)[\;\.](.*)$/) { # new regexp from Andreas Kahari bug #1584 elsif (/^DR\s+(\S+)\;\s+(\S+)\;\s+([^;]+)[\;\.](.*)$/) { my ($database,$primaryid,$optional,$comment) = ($1,$2,$3,$4); # drop leading and training spaces and trailing . $comment =~ s/\.\s*$//; $comment =~ s/^\s+//; my $dblinkobj = Bio::Annotation::DBLink->new (-database => $database, -primary_id => $primaryid, -optional_id => $optional, -comment => $comment, -tagname => 'dblink', ); $annotation->add_Annotation('dblink',$dblinkobj); } #keywords elsif ( /^KW\s+(.*)$/ ) { my @kw = split(/\s*\;\s*/,$1); defined $kw[-1] && $kw[-1] =~ s/\.$//; push @{$params{'-keywords'}}, @kw; } } # process and parse the gene name line if there was one (note: we # can't do this above b/c GN may be multi-line and we can't # unequivocally determine whether we've seen the last GN line in # the new format) if ($genename) { my @stags; if ($genename =~ /\w=\w/) { # new format (e.g., Name=RCHY1; Synonyms=ZNF363, CHIMP) for my $n (split(m{\s+and\s+},$genename)) { my @genenames; for my $section (split(m{\s*;\s*},$n)) { my ($tag, $rest) = split("=",$section); $rest ||= ''; for my $val (split(m{\s*,\s*},$rest)) { push @genenames, [$tag => $val]; } } push @stags, ['gene_name' => \@genenames]; } } else { # old format for my $section (split(/ AND /, $genename)) { my @genenames; $section =~ s/[\(\)\.]//g; my @names = split(m{\s+OR\s+}, $section); push @genenames, ['Name' => shift @names]; push @genenames, map {['Synonyms' => $_]} @names; push @stags, ['gene_name' => \@genenames] } } #use Data::Dumper; print Dumper $gn, $genename;# exit; my $gn = Bio::Annotation::TagTree->new(-tagname => 'gene_name', -value => ['gene_names' => \@stags]); $annotation->add_Annotation('gene_name', $gn); } FEATURE_TABLE : # if there is no feature table, or if we've got beyond, exit loop or don't # even enter HL 05/11/2000 while (defined $_ && /^FT/ ) { my $ftunit = $self->_read_FTHelper_swissprot($_); # process ftunit # when parsing of the line fails we get undef returned if ($ftunit) { push(@features, $ftunit->_generic_seqfeature($self->location_factory(), $params{'-seqid'}, "SwissProt")); } else { $self->warn("failed to parse feature table line for seq " . $params{'-display_id'}. "\n$_"); } $_ = $self->_readline; } while ( defined($_) && ! /^SQ/ ) { $_ = $self->_readline; } $seqc = ""; while ( defined ($_ = $self->_readline) ) { last if m{^//}; s/[^A-Za-z]//g; $seqc .= uc($_); } my $seq= $self->sequence_factory->create (-verbose => $self->verbose, %params, -seq => $seqc, -desc => $desc, -features => \@features, -annotation => $annotation, ); # The annotation doesn't get added by the contructor $seq->annotation($annotation); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { my ($self,@seqs) = @_; foreach my $seq ( @seqs ) { $self->throw("Attempting to write with no seq!") unless defined $seq; if ( ! ref $seq || ! $seq->isa('Bio::SeqI') ) { $self->warn(" $seq is not a SeqI compliant module. Attempting to dump, but may fail!"); } my $i; my $str = $seq->seq; my $div; my $ns = ($seq->can('namespace')) && $seq->namespace(); my $len = $seq->length(); if ( !$seq->can('division') || ! defined ($div = $seq->division()) ) { $div = 'UNK'; } # namespace dictates database, takes precedent over division. Sorry! if (defined($ns) && $ns ne '') { $div = ($ns eq 'Swiss-Prot') ? 'Reviewed' : ($ns eq 'TrEMBL') ? 'Unreviewed' : $ns; } else { $ns = 'Swiss-Prot'; # division not reset; acts as fallback } $self->warn("No whitespace allowed in SWISS-PROT display id [". $seq->display_id. "]") if $seq->display_id =~ /\s/; my $temp_line; if ( $self->_id_generation_func ) { $temp_line = &{$self->_id_generation_func}($seq); } else { #$temp_line = sprintf ("%10s STANDARD; %3s; %d AA.", # $seq->primary_id()."_".$div,$mol,$len); # Reconstructing the ID relies heavily upon the input source having # been in a format that is parsed as this routine expects it -- that is, # by this module itself. This is bad, I think, and immediately breaks # if e.g. the Bio::DB::GenPept module is used as input. # Hence, switch to display_id(); _every_ sequence is supposed to have # this. HL 2000/09/03 # Changed to reflect ID line changes in UniProt # Oct 2006 - removal of molecule type - see bug 2134 $temp_line = sprintf ("%-24s%-12s%9d AA.", $seq->display_id(), $div.';', $len); } $self->_print( "ID $temp_line\n"); # if there, write the accession line local($^W) = 0; # supressing warnings about uninitialized fields if ( $self->_ac_generation_func ) { $temp_line = &{$self->_ac_generation_func}($seq); $self->_print( "AC $temp_line\n"); } elsif ($seq->can('accession_number') ) { my $ac_line = $seq->accession_number; if ($seq->can('get_secondary_accessions') ) { foreach my $sacc ($seq->get_secondary_accessions) { $ac_line .= "; ". $sacc;; } $ac_line .= ";"; } $self->_write_line_swissprot_regex("AC ","AC ",$ac_line, "\\s\+\|\$",$LINE_LENGTH); } # otherwise - cannot print <sigh> # Date lines and sequence versions (changed 6/15/2006) # This is rebuilt from scratch using the current SwissProt/UniProt format if ( $seq->can('get_dates') ) { my @dates = $seq->get_dates(); my $ct = 1; my $seq_version = $seq->version; my ($update_version) = $seq->annotation->get_Annotations("seq_update"); foreach my $dt (@dates) { $self->_write_line_swissprot_regex("DT ","DT ", $dt.', integrated into UniProtKB/'.$ns.'.', "\\s\+\|\$",$LINE_LENGTH) if $ct == 1; $self->_write_line_swissprot_regex("DT ","DT ", $dt.", sequence version ".$update_version->display_text.'.', "\\s\+\|\$",$LINE_LENGTH) if $ct == 2; $self->_write_line_swissprot_regex("DT ","DT ", $dt.", entry version $seq_version.", "\\s\+\|\$",$LINE_LENGTH) if $ct == 3; $ct++; } } #Definition lines $self->_write_line_swissprot_regex("DE ","DE ",$seq->desc(),"\\s\+\|\$",$LINE_LENGTH); #Gene name; print out new format foreach my $gene ( my @genes = $seq->annotation->get_Annotations('gene_name') ) { # gene is a Bio::Annotation::TagTree; if ($gene->isa('Bio::Annotation::TagTree')) { my @genelines; for my $node ($gene->findnode('gene_name')) { # check for Name and Synonym first, then the rest get tagged on my $geneline = "GN "; my %genedata = $node->hash; for my $tag (@GENE_NAME_ORDER) { if (exists $genedata{$tag}) { $geneline .= (ref $genedata{$tag} eq 'ARRAY') ? "$tag=".join(', ',@{$genedata{$tag}})."; " : "$tag=$genedata{$tag}; "; delete $genedata{$tag}; } } # add rest for my $tag (sort keys %genedata) { $geneline .= (ref $genedata{$tag} eq 'ARRAY') ? "$tag=".join(', ',@{$genedata{$tag}})."; " : "$tag=$genedata{$tag}; "; delete $genedata{$tag}; } push @genelines, "$geneline\n"; } $self->_print(join("GN and\n",@genelines)); } else { # fall back to getting stringified output $self->_write_line_swissprot_regex("GN ","GN ", $gene->display_text, "\\s\+\|\$", $LINE_LENGTH); } } # Organism lines if ($seq->can('species') && (my $spec = $seq->species)) { my @class = $spec->classification(); shift(@class); my $species = $spec->species; my $genus = $spec->genus; my $OS = $spec->scientific_name; if ($class[-1] =~ /viruses/i) { $OS = $species; $OS .= " ". $spec->sub_species if $spec->sub_species; } foreach (($spec->variant, $spec->common_name)) { $OS .= " ($_)" if $_; } $self->_print( "OS $OS.\n"); my $OC = join('; ', reverse(@class)) .'.'; $self->_write_line_swissprot_regex("OC ","OC ",$OC,"\; \|\$",$LINE_LENGTH); if ($spec->organelle) { $self->_write_line_swissprot_regex("OG ","OG ",$spec->organelle,"\; \|\$",$LINE_LENGTH); } if ($spec->ncbi_taxid) { $self->_print("OX NCBI_TaxID=".$spec->ncbi_taxid.";\n"); } } # Reference lines my $t = 1; foreach my $ref ( $seq->annotation->get_Annotations('reference') ) { $self->_print( "RN [$t]\n"); # changed by lorenz 08/03/00 # j.gilbert and h.lapp agreed that the rp line in swissprot seems # more like a comment than a parseable value, so print it as is if ($ref->rp) { $self->_write_line_swissprot_regex("RP ","RP ",$ref->rp, "\\s\+\|\$",$LINE_LENGTH); } if ($ref->comment) { $self->_write_line_swissprot_regex("RC ","RC ",$ref->comment, "\\s\+\|\$",$LINE_LENGTH); } if ($ref->medline or $ref->pubmed or $ref->doi) { # new RX format in swissprot LP 09/17/00 # RX line can now have a DOI, Heikki 13 Feb 2008 my $line; $line .= "MEDLINE=". $ref->medline. '; ' if $ref->medline; $line .= "PubMed=". $ref->pubmed. '; ' if $ref->pubmed; $line .= "DOI=". $ref->doi. '; ' if $ref->doi; chop $line; $self->_write_line_swissprot_regex("RX ","RX ", $line, "\\s\+\|\$",$LINE_LENGTH); } my $author = $ref->authors .';' if($ref->authors); my $title = $ref->title .';' if( $ref->title); my $rg = $ref->rg . ';' if $ref->rg; $author =~ s/([\w\.]) (\w)/$1#$2/g; # add word wrap protection char '#' $self->_write_line_swissprot_regex("RG ","RG ",$rg,"\\s\+\|\$",$LINE_LENGTH) if $rg; $self->_write_line_swissprot_regex("RA ","RA ",$author,"\\s\+\|\$",$LINE_LENGTH) if $author; $self->_write_line_swissprot_regex("RT ","RT ",$title,'[\s\-]+|$',$LINE_LENGTH) if $title; $self->_write_line_swissprot_regex("RL ","RL ",$ref->location,"\\s\+\|\$",$LINE_LENGTH); $t++; } # Comment lines foreach my $comment ( $seq->annotation->get_Annotations('comment') ) { foreach my $cline (split ("\n", $comment->text)) { while (length $cline > 74) { $self->_print("CC ",(substr $cline,0,74),"\n"); $cline = substr $cline,74; } $self->_print("CC ",$cline,"\n"); } } # Database xref lines foreach my $dblink ( $seq->annotation->get_Annotations('dblink') ) { my ($primary_id) = $dblink->primary_id; if (defined($dblink->comment) && ($dblink->comment) ) { $self->_print("DR ",$dblink->database,"; ",$primary_id,"; ", $dblink->optional_id,"; ",$dblink->comment,".\n"); } elsif ($dblink->optional_id) { $self->_print("DR ",$dblink->database,"; ", $primary_id,"; ", $dblink->optional_id,".\n"); } else { $self->_print("DR ",$dblink->database, "; ",$primary_id,"; ","-.\n"); } } # Evidence lines foreach my $evidence ( $seq->annotation->get_Annotations('evidence') ) { $self->_print("PE ",$evidence->value,";\n"); } # if there, write the kw line { my $kw; if ( my $func = $self->_kw_generation_func ) { $kw = &{$func}($seq); } elsif ( $seq->can('keywords') ) { $kw = $seq->keywords; if ( ref($kw) =~ /ARRAY/i ) { $kw = join("; ", @$kw); } $kw .= '.' if $kw and $kw !~ /\.$/ ; } $kw =~ s/([\w\.]) (\w)/$1#$2/g; # add word wrap protection char '#' $self->_write_line_swissprot_regex("KW ","KW ", $kw, "\\s\+\|\$",$LINE_LENGTH) if $kw; } #Check if there is seqfeatures before printing the FT line my @feats = $seq->can('top_SeqFeatures') ? $seq->top_SeqFeatures : (); if ($feats[0]) { if ( defined $self->_post_sort ) { # we need to read things into an array. Process. Sort them. Print 'em my $post_sort_func = $self->_post_sort(); my @fth; foreach my $sf ( @feats ) { push(@fth,Bio::SeqIO::FTHelper::from_SeqFeature($sf,$seq)); } @fth = sort { &$post_sort_func($a,$b) } @fth; foreach my $fth ( @fth ) { $self->_print_swissprot_FTHelper($fth); } } else { # not post sorted. And so we can print as we get them. # lower memory load... foreach my $sf ( @feats ) { my @fth = Bio::SeqIO::FTHelper::from_SeqFeature($sf,$seq); foreach my $fth ( @fth ) { if ( ! $fth->isa('Bio::SeqIO::FTHelper') ) { $sf->throw("Cannot process FTHelper... $fth"); } $self->_print_swissprot_FTHelper($fth); } } } if ( $self->_show_dna() == 0 ) { return; } } # finished printing features. # molecular weight my $mw = ${Bio::Tools::SeqStats->get_mol_wt($seq->primary_seq)}[0]; # checksum # was crc32 checksum, changed it to crc64 my $crc64 = $self->_crc64(\$str); $self->_print( sprintf("SQ SEQUENCE %4d AA; %d MW; %16s CRC64;\n", $len,$mw,$crc64)); $self->_print( " "); my $linepos; for ($i = 0; $i < length($str); $i += 10) { $self->_print( " ", substr($str,$i,10)); $linepos += 11; if ( ($i+10)%60 == 0 && (($i+10) < length($str))) { $self->_print( "\n "); } } $self->_print( "\n//\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } } # Thanks to James Gilbert for the following two. LP 08/01/2000 =head2 _generateCRCTable Title : _generateCRCTable Usage : Function: Example : Returns : Args : =cut sub _generateCRCTable { # 10001000001010010010001110000100 # 32 my $poly = 0xEDB88320; my ($self) = shift; $self->{'_crcTable'} = []; foreach my $i (0..255) { my $crc = $i; for (my $j=8; $j > 0; $j--) { if ($crc & 1) { $crc = ($crc >> 1) ^ $poly; } else { $crc >>= 1; } } ${$self->{'_crcTable'}}[$i] = $crc; } } =head2 _crc32 Title : _crc32 Usage : Function: Example : Returns : Args : =cut sub _crc32 { my( $self, $str ) = @_; $self->throw("Argument to crc32() must be ref to scalar") unless ref($str) eq 'SCALAR'; $self->_generateCRCTable() unless exists $self->{'_crcTable'}; my $len = length($$str); my $crc = 0xFFFFFFFF; for (my $i = 0; $i < $len; $i++) { # Get upper case value of each letter my $int = ord uc substr $$str, $i, 1; $crc = (($crc >> 8) & 0x00FFFFFF) ^ ${$self->{'_crcTable'}}[ ($crc ^ $int) & 0xFF ]; } return $crc; } =head2 _crc64 Title : _crc64 Usage : Function: Example : Returns : Args : =cut sub _crc64{ my ($self, $sequence) = @_; my $POLY64REVh = 0xd8000000; my @CRCTableh = 256; my @CRCTablel = 256; my $initialized; my $seq = $$sequence; my $crcl = 0; my $crch = 0; if (!$initialized) { $initialized = 1; for (my $i=0; $i<256; $i++) { my $partl = $i; my $parth = 0; for (my $j=0; $j<8; $j++) { my $rflag = $partl & 1; $partl >>= 1; $partl |= (1 << 31) if $parth & 1; $parth >>= 1; $parth ^= $POLY64REVh if $rflag; } $CRCTableh[$i] = $parth; $CRCTablel[$i] = $partl; } } foreach (split '', $seq) { my $shr = ($crch & 0xFF) << 24; my $temp1h = $crch >> 8; my $temp1l = ($crcl >> 8) | $shr; my $tableindex = ($crcl ^ (unpack "C", $_)) & 0xFF; $crch = $temp1h ^ $CRCTableh[$tableindex]; $crcl = $temp1l ^ $CRCTablel[$tableindex]; } my $crc64 = sprintf("%08X%08X", $crch, $crcl); return $crc64; } =head2 _print_swissprot_FTHelper Title : _print_swissprot_FTHelper Usage : Function: Example : Returns : Args : =cut sub _print_swissprot_FTHelper { my ($self,$fth,$always_quote) = @_; $always_quote ||= 0; my ($start,$end) = ('?', '?'); if ( ! ref $fth || ! $fth->isa('Bio::SeqIO::FTHelper') ) { $fth->warn("$fth is not a FTHelper class. ". "Attempting to print, but there could be tears!"); } my $desc = ""; for my $tag ( qw(description gene note product) ) { if ( exists $fth->field->{$tag} ) { $desc = @{$fth->field->{$tag}}[0]."."; last; } } $desc =~ s/\.$//; my $ftid = ""; if ( exists $fth->field->{'FTId'} ) { $ftid = @{$fth->field->{'FTId'}}[0]. '.'; } my $key =substr($fth->key,0,8); my $loc = $fth->loc; if ( $loc =~ /(\?|\d+|\>\d+|<\d+)?\.\.(\?|\d+|<\d+|>\d+)?/ ) { $start = $1 if defined $1; $end = $2 if defined $2; # to_FTString only returns one value when start == end, #JB955 # so if no match is found, assume it is both start and end #JB955 } elsif ( $loc =~ /join\((\d+)((?:,\d+)+)?\)/) { my @y = ($1); if ( defined( my $m = $2) ) { $m =~ s/^\,//; push @y, split(/,/,$m); } for my $x ( @y ) { $self->_write_line_swissprot_regex( sprintf("FT %-8s %6s %6s ", $key, $x ,$x), "FT ", $desc.'.','\s+|$',$LINE_LENGTH); } return; } else { $start = $end = $fth->loc; } if ($desc) { $self->_write_line_swissprot_regex(sprintf("FT %-8s %6s %6s ", $key, $start ,$end), "FT ", $desc. '.', '\s+|$', $LINE_LENGTH); } else { #HELIX and STRAND do not have descriptions $self->_write_line_swissprot_regex(sprintf("FT %-8s %6s %6s", $key, $start ,$end), "FT ", ' ', '\s+|$', $LINE_LENGTH); } if ($ftid) { $self->_write_line_swissprot_regex("FT ", "FT ", "/FTId=$ftid",'.|$',$LINE_LENGTH); } } #' =head2 _read_swissprot_References Title : _read_swissprot_References Usage : Function: Reads references from swissprot format. Internal function really Example : Returns : Args : =cut sub _read_swissprot_References{ my ($self,$line) = @_; my ($b1, $b2, $rp, $rg, $title, $loc, $au, $med, $com, $pubmed, $doi); my @refs; local $_ = $line; while ( defined $_ ) { if ( /^[^R]/ || /^RN/ ) { if ( $rp ) { $rg =~ s/;\s*$//g if defined($rg); if (defined($au)) { $au =~ s/;\s*$//; } else { $au = $rg; } $title =~ s/;\s*$//g if defined($title); push @refs, Bio::Annotation::Reference->new (-title => $title, -start => $b1, -end => $b2, -authors => $au, -location=> $loc, -medline => $med, -pubmed => $pubmed, -doi => $doi, -comment => $com, -rp => $rp, -rg => $rg, -tagname => 'reference', ); # reset state for the next reference $rp = ''; } if (index($_,'R') != 0) { $self->_pushback($_); # want this line to go back on the list last; # may be the safest exit point HL 05/11/2000 } # don't forget to reset the state for the next reference $b1 = $b2 = $rg = $med = $com = $pubmed = $doi = undef; $title = $loc = $au = undef; } elsif ( /^RP\s{3}(.+? OF (\d+)-(\d+).*)/) { $rp .= $1; $b1 = $2; $b2 = $3; } elsif ( /^RP\s{3}(.*)/) { if ($rp) { $rp .= " ".$1; } else { $rp = $1; } } elsif (/^RX\s{3}(.*)/) { # each reference can have only one RX line my $line = $1; $med = $1 if $line =~ /MEDLINE=(\d+);/; $pubmed = $1 if $line =~ /PubMed=(\d+);/; $doi = $1 if $line =~ /DOI=(.+);/; } elsif ( /^RA\s{3}(.*)/ ) { $au .= $au ? " $1" : $1; } elsif ( /^RG\s{3}(.*)/ ) { $rg .= $rg ? " $1" : $1; } elsif ( /^RT\s{3}(.*)/ ) { if ($title) { my $tline = $1; $title .= ($title =~ /[\w;,:\?!]$/) ? " $tline" : $tline; } else { $title = $1; } } elsif (/^RL\s{3}(.*)/ ) { $loc .= $loc ? " $1" : $1; } elsif ( /^RC\s{3}(.*)/ ) { $com .= $com ? " $1" : $1; } $_ = $self->_readline; } return \@refs; } =head2 _read_swissprot_Species Title : _read_swissprot_Species Usage : Function: Reads the swissprot Organism species and classification lines. Able to deal with unconventional species names. Example : OS Unknown prokaryotic organism $genus = undef ; $species = Unknown prokaryotic organism Returns : A Bio::Species object Args : =cut sub _read_swissprot_Species { my( $self,$line ) = @_; my $org; local $_ = $line; my( $sub_species, $species, $genus, $common, $variant, $ncbi_taxid, $sci_name, $class_lines, $descr ); my $osline = ""; my $do_genus_check = 1; while ( defined $_ ) { last unless /^O[SCGX]/; # believe it or not, but OS may come multiple times -- at this time # we can't capture multiple species if (/^OS\s+(\S.+)/ && (! defined($sci_name))) { $osline .= " " if $osline; $osline .= $1; if ($osline =~ s/(,|, and|\.)$//) { # OS lines are usually like: # Homo sapiens (human) # where we have $sci_name followed by $descr (common name) in # brackets, but we can also have: # Venerupis (Ruditapes) philippinarum # where we have brackets but they don't indicate a $descr if ($osline =~ /[^\(\)]+\(.+\)[^\(\)]+$/) { #*** Danger! no idea if this will pick up some syntaxes for # common names as well) $sci_name = $osline; $sci_name =~ s/\.$//; $descr = ''; $do_genus_check = 0; } else { ($sci_name, $descr) = $osline =~ /(\S[^\(]+)(.*)/; } $sci_name =~ s/\s+$//; while ($descr =~ /\(([^\)]+)\)/g) { my $item = $1; # strain etc may not necessarily come first (yes, swissprot # is messy) if ((! defined($variant)) && (($item =~ /(^|[^\(\w])([Ss]train|isolate|serogroup|serotype|subtype|clone)\b/) || ($item =~ /^(biovar|pv\.|type\s+)/))) { $variant = $item; } elsif ($item =~ s/^subsp\.\s+//) { if (! $sub_species) { $sub_species = $item; } elsif (! $variant) { $variant = $item; } } elsif (! defined($common)) { # we're only interested in the first common name $common = $item; if ((index($common, '(') >= 0) && (index($common, ')') < 0)) { $common .= ')'; } } } } } elsif (s/^OC\s+(\S.+)$//) { $class_lines .= $1; } elsif (/^OG\s+(.*)/) { $org = $1; } elsif (/^OX\s+(.*)/ && (! defined($ncbi_taxid))) { my $taxstring = $1; # we only keep the first one and ignore all others if ($taxstring =~ /NCBI_TaxID=([\w\d]+)/) { $ncbi_taxid = $1; } else { $self->throw("$taxstring doesn't look like NCBI_TaxID"); } } $_ = $self->_readline; } $self->_pushback($_); # pushback the last line because we need it $sci_name || return; # if the organism belongs to taxid 32644 then no Bio::Species object. return if grep { $_ eq $sci_name } @Unknown_names; # Convert data in classification lines into classification array. # Remove trailing . then split on ';' or '.;' so that classification that is 2 # or more words will still get matched, use map() to remove trailing/leading/intervening # spaces $class_lines=~s/\.\s*$//; my @class = map { s/^\s+//; s/\s+$//; s/\s{2,}/ /g; $_; } split /[;\.]*;/, $class_lines; if ($class[0] =~ /viruses/i) { # viruses have different OS/OC syntax my @virusnames = split(/\s+/, $sci_name); $species = (@virusnames > 1) ? pop(@virusnames) : ''; $genus = join(" ", @virusnames); $sub_species = $descr; } elsif ($do_genus_check) { # do we have a genus? my $possible_genus = $class[-1]; $possible_genus .= "|$class[-2]" if $class[-2]; if ($sci_name =~ /^($possible_genus)/) { $genus = $1; ($species) = $sci_name =~ /^$genus\s+(.+)/; } else { $species = $sci_name; } # is this organism of rank species or is it lower? # (doesn't catch everything, but at least the guess isn't dangerous) if ($species && $species =~ /subsp\.|var\./) { ($species, $sub_species) = $species =~ /(.+)\s+((?:subsp\.|var\.).+)/; } } # Bio::Species array needs array in Species -> Kingdom direction unless ($class[-1] eq $sci_name) { push(@class, $sci_name); } @class = reverse @class; my $taxon = Bio::Species->new(); $taxon->scientific_name($sci_name); $taxon->classification(@class); $taxon->common_name($common) if $common; $taxon->sub_species($sub_species) if $sub_species; $taxon->organelle($org) if $org; $taxon->ncbi_taxid($ncbi_taxid) if $ncbi_taxid; $taxon->variant($variant) if $variant; # done return $taxon; } =head2 _filehandle Title : _filehandle Usage : $obj->_filehandle($newval) Function: Example : Returns : value of _filehandle Args : newvalue (optional) =cut # inherited from SeqIO.pm ! HL 05/11/2000 =head2 _read_FTHelper_swissprot Title : _read_FTHelper_swissprot Usage : _read_FTHelper_swissprot(\$buffer) Function: reads the next FT key line Example : Returns : Bio::SeqIO::FTHelper object Args : =cut sub _read_FTHelper_swissprot { my ($self,$line ) = @_; # initial version implemented by HL 05/10/2000 # FIXME this may not be perfect, so please review # lots of cleaning up by JES 2004/07/01, still may not be perfect =) # FTId now sepated from description as a qualifier local $_ = $line; my ($key, # The key of the feature $loc, # The location line from the feature $desc, # The descriptive text $ftid, # feature Id is like a qualifier but there can be only one of them ); if ( m/^FT\s{3}(\w+)\s+([\d\?\<]+)\s+([\d\?\>]+)\s*(.*)$/ox) { $key = $1; my $loc1 = $2; my $loc2 = $3; $loc = "$loc1..$loc2"; if ($4 && (length($4) > 0)) { $desc = $4; chomp($desc); } else { $desc = ""; } } while ( defined($_ = $self->_readline) && /^FT\s{20,}(\S.*)$/ ) { my $continuation_line = $1; if ( $continuation_line =~ /.FTId=(.*)\./ ) { $ftid=$1; } elsif ( $desc) { $desc .= " $continuation_line"; } else { $desc = $continuation_line; } chomp $desc; } $self->_pushback($_); unless( $key ) { # No feature key. What's this? $self->warn("No feature key in putative feature table line: $line"); return; } # Make the new FTHelper object my $out = Bio::SeqIO::FTHelper->new(-verbose => $self->verbose()); $out->key($key); $out->loc($loc); # store the description if there is one if ( $desc && length($desc) ) { $desc =~ s/\.$//; push(@{$out->field->{"description"}}, $desc); } # Store the qualifier i.e. FTId if ( $ftid ) { push(@{$out->field->{"FTId"}}, $ftid); } return $out; } =head2 _write_line_swissprot Title : _write_line_swissprot Usage : Function: internal function Example : Returns : Args : =cut sub _write_line_swissprot{ my ($self,$pre1,$pre2,$line,$length) = @_; $length || $self->throw( "Miscalled write_line_swissprot without length. Programming error!"); my $subl = $length - length $pre2; my $linel = length $line; my $i; my $sub = substr($line,0,$length - length $pre1); $self->_print( "$pre1$sub\n"); for ($i= ($length - length $pre1);$i < $linel;) { $sub = substr($line,$i,($subl)); $self->_print( "$pre2$sub\n"); $i += $subl; } } =head2 _write_line_swissprot_regex Title : _write_line_swissprot_regex Usage : Function: internal function for writing lines of specified length, with different first and the next line left hand headers and split at specific points in the text Example : Returns : nothing Args : file handle, first header, second header, text-line, regex for line breaks, total line length =cut sub _write_line_swissprot_regex { my ($self,$pre1,$pre2,$line,$regex,$length) = @_; #print STDOUT "Going to print with $line!\n"; $length || $self->throw( "Miscalled write_line_swissprot without length. Programming error!"); if ( length $pre1 != length $pre2 ) { $self->warn( "len 1 is ". length ($pre1) . " len 2 is ". length ($pre2) . "\n"); $self->throw( "Programming error - cannot called write_line_swissprot_regex with different length \npre1 ($pre1) and \npre2 ($pre2) tags!"); } my $subl = $length - (length $pre1) -1 ; my $first_line = 1; while ($line =~ m/(.{1,$subl})($regex)/g) { my $s = $1.$2; $s =~ s/([\w\.])#(\w)/$1 $2/g # remove word wrap protection char '#' if $pre1 eq "RA " or $pre1 eq "KW "; # remove annoying extra spaces at the end of the wrapped lines substr($s, -1, 1, '') if substr($s, -1, 1) eq ' '; if ($first_line) { $self->_print( "$pre1$s\n"); $first_line = 0; } else { $self->_print( "$pre2$s\n"); } } } =head2 _post_sort Title : _post_sort Usage : $obj->_post_sort($newval) Function: Returns : value of _post_sort Args : newvalue (optional) =cut sub _post_sort{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_post_sort'} = $value; } return $obj->{'_post_sort'}; } =head2 _show_dna Title : _show_dna Usage : $obj->_show_dna($newval) Function: Returns : value of _show_dna Args : newvalue (optional) =cut sub _show_dna{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_show_dna'} = $value; } return $obj->{'_show_dna'}; } =head2 _id_generation_func Title : _id_generation_func Usage : $obj->_id_generation_func($newval) Function: Returns : value of _id_generation_func Args : newvalue (optional) =cut sub _id_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_id_generation_func'} = $value; } return $obj->{'_id_generation_func'}; } =head2 _ac_generation_func Title : _ac_generation_func Usage : $obj->_ac_generation_func($newval) Function: Returns : value of _ac_generation_func Args : newvalue (optional) =cut sub _ac_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_ac_generation_func'} = $value; } return $obj->{'_ac_generation_func'}; } =head2 _sv_generation_func Title : _sv_generation_func Usage : $obj->_sv_generation_func($newval) Function: Returns : value of _sv_generation_func Args : newvalue (optional) =cut sub _sv_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_sv_generation_func'} = $value; } return $obj->{'_sv_generation_func'}; } =head2 _kw_generation_func Title : _kw_generation_func Usage : $obj->_kw_generation_func($newval) Function: Returns : value of _kw_generation_func Args : newvalue (optional) =cut sub _kw_generation_func{ my $obj = shift; if ( @_ ) { my $value = shift; $obj->{'_kw_generation_func'} = $value; } return $obj->{'_kw_generation_func'}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/swissdriver.pm������������������������������������������������������������000444��000765��000024�� 21376�12254227325� 20104� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::swissdriver # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Bioperl project bioperl-l(at)bioperl.org # # Copyright Chris Fields and contributors see AUTHORS section # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::swissdriver - SwissProt/UniProt handler-based push parser =head1 SYNOPSIS #It is probably best not to use this object directly, but #rather go through the SeqIO handler: $stream = Bio::SeqIO->new(-file => $filename, -format => 'swissdriver'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This object can transform Bio::Seq objects to and from UniProt flat file databases. The key difference between this parser and the tried-and-true Bio::SeqIO::swiss parser is this version separates the parsing and data manipulation into a 'driver' method (next_seq) and separate object handlers which deal with the data passed to it. =head2 The Driver The main purpose of the driver routine, in this case next_seq(), is to carve out the data into meaningful chunks which are passed along to relevant handlers (see below). Each chunk of data in the has a NAME tag attached to it, similar to that for XML parsing. This designates the type of data passed (annotation type or seqfeature) and the handler to be called for processing the data. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Bioperl Project bioperl-l at bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # POD is at the end of the module # Let the code begin... # Let the code begin... package Bio::SeqIO::swissdriver; use vars qw(%FTQUAL_NO_QUOTE); use strict; use Bio::SeqIO::Handler::GenericRichSeqHandler; use Data::Dumper; use base qw(Bio::SeqIO); # signals to process what's in the hash prior to next round, maps ann => names my %SEC = ( OC => 'CLASSIFICATION', OH => 'HOST', # not currently handled, bundled with organism data for now OG => 'ORGANELLE', OX => 'CROSSREF', RA => 'AUTHORS', RC => 'COMMENT', RG => 'CONSRTM', RP => 'POSITION', RX => 'CROSSREF', RT => 'TITLE', RL => 'JOURNAL', AS => 'ASSEMBLYINFO', # Third party annotation '//' => 'RECORDEND' ); # add specialized delimiters here for easier postprocessing my %DELIM = ( CC => "\n", DR => "\n", DT => "\n", ); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my $handler = $self->_rearrange([qw(HANDLER)],@args); # hash for functions for decoding keys. $handler ? $self->seqhandler($handler) : $self->seqhandler(Bio::SeqIO::Handler::GenericRichSeqHandler->new( -format => 'swiss', -verbose => $self->verbose, -builder => $self->sequence_builder )); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : none =cut sub next_seq { my $self = shift; my $hobj = $self->seqhandler; local($/) = "\n"; # these contain values that need to carry over each round my ($featkey, $qual, $annkey, $seqdata, $location); my $lastann = ''; my $ct = 0; # main parser PARSER: while(defined(my $line = $self->_readline)) { chomp $line; my ($ann, $data) = split(m{\s+}, $line, 2); if ($ann) { if ($ann eq 'FT') { # sequence features if ($data =~ m{^(\w+)\s+([\d\?\<]+)\s+([\d\?\>]+)(?:\s+?(\S.*))?}ox) { # has location data and desc if ($seqdata) { $hobj->data_handler($seqdata); $seqdata = (); } ($seqdata->{FEATURE_KEY}, my $loc1, my $loc2, $data) = ($1, $2, $3, $4); $qual = 'description'; $seqdata->{$qual} = $data; $seqdata->{NAME} = $ann; $seqdata->{LOCATION} = "$loc1..$loc2" if defined $loc1; next PARSER; } elsif ($data =~ m{^\s+/([^=]+)(?:=(.+))?}ox) { # has qualifer ($qual, $data) = ($1, $2 || ''); $ct = ($seqdata->{$qual}) ? ((ref($seqdata->{$qual})) ? scalar(@{ $seqdata->{$qual} }) : 1) : 0 ; } $data =~ s{\.$}{}; if ($ct == 0) { $seqdata->{$qual} .= ($seqdata->{$qual}) ? ' '.$data : $data; } else { if (!ref($seqdata->{$qual})) { $seqdata->{$qual} = [$seqdata->{$qual}]; } ($seqdata->{$qual}->[$ct]) ? ($seqdata->{$qual}->[$ct] .= ' '.$data) : ($seqdata->{$qual}->[$ct] .= $data); } } else { # simple annotations if ($ann ne $lastann) { if (!$SEC{$ann} && $seqdata) { $hobj->data_handler($seqdata); # can't use undef here; it can lead to subtle mem leaks $seqdata = (); } $annkey = (!$SEC{$ann}) ? 'DATA' : # primary data $SEC{$ann}; $seqdata->{'NAME'} = $ann if !$SEC{$ann}; } last PARSER if $ann eq '//'; next PARSER if $ann eq 'SQ'; my $delim = $DELIM{$ann} || ' '; $seqdata->{$annkey} .= ($seqdata->{$annkey}) ? $delim.$data : $data; $lastann = $ann; } } else { # this should only be sequence (fingers crossed!) SEQUENCE: while (defined ($line = $self->_readline)) { if (index($line, '//') == 0) { $data =~ tr{0-9 \n}{}d; $seqdata->{DATA} = $data; #$self->debug(Dumper($seqdata)); $hobj->data_handler($seqdata); $seqdata = (); last PARSER; } else { $data .= $line; $line = undef; } } } } # some files have no // for the last file; this catches the last bit o' data $hobj->data_handler($seqdata) if $seqdata; return $hobj->build_sequence; } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object (must be seq) to the stream Returns : 1 for success and 0 for error Args : array of 1 to n Bio::SeqI objects =cut sub write_seq { shift->throw("Use Bio::SeqIO::swiss write_seq() for output"); # maybe make a Writer class as well???? } =head2 seqhandler Title : seqhandler Usage : $stream->seqhandler($handler) Function: Get/Set teh Bio::Seq::HandlerBaseI object Returns : Bio::Seq::HandlerBaseI Args : Bio::Seq::HandlerBaseI =cut sub seqhandler { my ($self, $handler) = @_; if ($handler) { $self->throw("Not a Bio::HandlerBaseI") unless ref($handler) && $handler->isa("Bio::HandlerBaseI"); $self->{'_seqhandler'} = $handler; } return $self->{'_seqhandler'}; } 1; __END__ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/tab.pm��������������������������������������������������������������������000444��000765��000024�� 10530�12254227330� 16250� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#----------------------------------------------------------------------------- # PACKAGE : Bio::SeqIO::tab # AUTHOR : Philip Lijnzaad <p.lijnzaad@med.uu.nl> # CREATED : Feb 6 2003 # # Copyright (c) This module is free software; you can redistribute it # and/or modify it under the same terms as Perl itself. # # _History_ # # Ewan Birney <birney@ebi.ac.uk> developed the SeqIO # schema and the first prototype modules. # # This code is based on his Bio::SeqIO::raw # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::tab - nearly raw sequence file input/output stream. Reads/writes id"\t"sequence"\n" =head1 SYNOPSIS Do not use this module directly. Use it via the L<Bio::SeqIO> class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from tabbed flat file databases. It is very useful when doing large scale stuff using the Unix command line utilities (grep, sort, awk, sed, split, you name it). Imagine that you have a format converter 'seqconvert' along the following lines: my $in = Bio::SeqIO->newFh(-fh => \*STDIN , '-format' => $from); my $out = Bio::SeqIO->newFh(-fh=> \*STDOUT, '-format' => $to); print $out $_ while <$in>; then you can very easily filter sequence files for duplicates as: $ seqconvert < foo.fa -from fasta -to tab | sort -u |\ seqconvert -from tab -to fasta > foo-unique.fa Or grep [-v] for certain sequences with: $ seqconvert < foo.fa -from fasta -to tab | grep -v '^S[a-z]*control' |\ seqconvert -from tab -to fasta > foo-without-controls.fa Or chop up a huge file with sequences into smaller chunks with: $ seqconvert < all.fa -from fasta -to tab | split -l 10 - chunk- $ for i in chunk-*; do seqconvert -from tab -to fasta < $i > $i.fa; done # (this creates files chunk-aa.fa, chunk-ab.fa, ..., each containing 10 # sequences) =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Philip Lijnzaad, p.lijnzaad@med.uu.nl =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::tab; use strict; use Bio::Seq; use base qw(Bio::SeqIO); =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : =cut sub next_seq{ my ($self,@args) = @_; ## When its 1 sequence per line with no formatting at all, ## grabbing it should be easy :) my $nextline = $self->_readline(); chomp($nextline) if defined $nextline; return unless defined $nextline; if ($nextline =~ /^([^\t]*)\t(.*)/) { my ($id, $seq)=($1, uc($2)); $seq =~ s/\s+//g; return Bio::Seq->new(-display_id=> $id, -seq => $seq); } else { $self->throw("Can't parse tabbed sequence entry:'$nextline' around line $."); } } =head2 write_seq Title : write_seq Usage : $stream->write_seq($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; foreach (@seq) { if ($_->display_id() =~ /\t/) { $self->throw("display_id [".$_->display_id()."] contains TAB -- illegal in tab format"); } $self->_print($_->display_id(), "\t",$_->seq, "\n") or return; } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/table.pm������������������������������������������������������������������000444��000765��000024�� 63553�12254227332� 16610� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::table # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp at gmx.net> # # # (c) Hilmar Lapp, hlapp at gmx.net, 2005. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2005. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::table - sequence input/output stream from a delimited table =head1 SYNOPSIS #It is probably best not to use this object directly, but #rather go through the SeqIO handler system. Go: $stream = Bio::SeqIO->new(-file => $filename, -format => 'table'); while ( my $seq = $stream->next_seq() ) { # do something with $seq } =head1 DESCRIPTION This class transforms records in a table-formatted text file into Bio::Seq objects. A table-formatted text file of sequence records for the purposes of this module is defined as a text file with each row corresponding to a sequence, and the attributes of the sequence being in different columns. Columns are delimited by a common delimiter, for instance tab or comma. The module permits specifying which columns hold which type of annotation. The semantics of certain attributes, if present, are pre-defined, e.g., accession number and sequence. Additional attributes may be added to the annotation bundle. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp at gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::table; use strict; use Bio::Species; use Bio::Seq::SeqFactory; use Bio::Annotation::Collection; use Bio::Annotation::SimpleValue; use base qw(Bio::SeqIO); =head2 new Title : new Usage : $stream = Bio::SeqIO->new(-file => $filename, -format => 'table') Function: Returns a new seqstream Returns : A Bio::SeqIO stream for a table format Args : Named parameters: -file name of file to read -fh filehandle to attach to -comment leading character(s) introducing a comment line -header the number of header lines to skip; the first non-comment header line will be used to obtain column names; column names will be used as the default tags for attaching annotation. -delim the delimiter for columns as a regular expression; consecutive occurrences of the delimiter will not be collapsed. -display_id the one-based index of the column containing the display ID of the sequence -accession_number the one-based index of the column containing the accession number of the sequence -seq the one-based index of the column containing the sequence string of the sequence -species the one-based index of the column containing the species for the sequence record; if not a number, will be used as the static species common to all records -annotation if provided and a scalar (but see below), a flag whether or not all additional columns are to be preserved as annotation, the tags used will either be 'colX' if there is no column header and where X is the one-based column index, and otherwise the column headers will be used as tags; if a reference to an array, or a square bracket-enclosed string of comma-delimited values, only those columns (one-based index) will be preserved as annotation, tags as before; if a reference to a hash, or a curly braces-enclosed string of comma-delimited key and value pairs in alternating order, the keys are one-based column indexes to be preserved, and the values are the tags under which the annotation is to be attached; if not provided or supplied as undef, no additional annotation will be preserved. -colnames a reference to an array of column labels, or a string of comma-delimited labels, denoting the columns to be converted into annotation; this is an alternative to -annotation and will be ignored if -annotation is also supplied with a valid value. -trim flag determining whether or not all values should be trimmed of leading and trailing white space and double quotes Additional arguments may be used to e.g. set factories and builders involved in the sequence object creation (see the POD of Bio::SeqIO). =cut sub _initialize { my($self,@args) = @_; # chained initialization $self->SUPER::_initialize(@args); # our own parameters my ($cmtchars, $header, $delim, $display_id, $accnr, $seq, $taxon, $useann, $colnames, $trim) = $self->_rearrange([qw(COMMENT HEADER DELIM DISPLAY_ID ACCESSION_NUMBER SEQ SPECIES ANNOTATION COLNAMES TRIM) ], @args); # store options and apply defaults $self->comment_char(defined($cmtchars) ? $cmtchars : "#") if (!defined($self->comment_char)) || defined($cmtchars); $self->delimiter(defined($delim) ? $delim : "\t") if (!defined($self->delimiter)) || defined($delim); $self->header($header) if defined($header); $self->trim_values($trim) if defined($trim); # attribute columns my $attrs = {}; $attrs->{-display_id} = $display_id if defined($display_id); $attrs->{-accession_number} = $accnr if defined($accnr); $attrs->{-seq} = $seq if defined($seq); if (defined($taxon)) { if (ref($taxon) || ($taxon =~ /^\d+$/)) { # either a static object, or a column reference $attrs->{-species} = $taxon; } else { # static species as a string $attrs->{-species} = Bio::Species->new( -classification => [reverse(split(' ',$taxon))]); } } $self->attribute_map($attrs); # annotation columns, if any if ($useann && !ref($useann)) { # it's a scalar; check whether this is in fact an array or # hash as a string rather than just a flag if ($useann =~ /^\[(.*)\]$/) { $useann = [split(/[,;]/,$1)]; } elsif ($useann =~ /^{(.*)}$/) { $useann = {split(/[,;]/,$1)}; } # else it is probably indeed just a flag } if (ref($useann)) { my $ann_map; if (ref($useann) eq "ARRAY") { my $has_header = ($self->header > 0); $ann_map = {}; foreach my $i (@$useann) { $ann_map->{$i} = $has_header ? undef : "col$i"; } } else { # no special handling necessary $ann_map = $useann; } $self->annotation_map($ann_map); } else { $self->keep_annotation($useann || $colnames); # annotation columns, if any if ($colnames && !ref($colnames)) { # an array as a string $colnames =~ s/^\[(.*)\]$/$1/; $colnames = [split(/[,;]/,$colnames)]; } $self->annotation_columns($colnames) if ref($colnames); } # make sure we have a factory defined if(!defined($self->sequence_factory)) { $self->sequence_factory( Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::RichSeq object Args : =cut sub next_seq { my $self = shift; # skip until not a comment and not an empty line my $line_ok = $self->_next_record(); # if there is a header but we haven't read past it yet then do so now if ($line_ok && (! $self->_header_skipped) && $self->header) { $line_ok = $self->_parse_header(); $self->_header_skipped(1); } # return if we reached end-of-file return unless $line_ok; # otherwise, parse the record # split into columns my @cols = $self->_get_row_values(); # trim leading and trailing whitespace and quotes if desired if ($self->trim_values) { for(my $i = 0; $i < scalar(@cols); $i++) { if ($cols[$i]) { # trim off whitespace $cols[$i] =~ s/^\s+//; $cols[$i] =~ s/\s+$//; # trim off double quotes $cols[$i] =~ s/^"//; $cols[$i] =~ s/"$//; } } } # assign values for columns in the attribute map my $attrmap = $self->_attribute_map; my %params = (); foreach my $attr (keys %$attrmap) { if ((!ref($attrmap->{$attr})) && ($attrmap->{$attr} =~ /^\d+$/)) { # this is a column index, add to instantiation parameters $params{$attr} = $cols[$attrmap->{$attr}]; } else { # not a column index; we assume it's a static value $params{$attr} = $attrmap->{$attr}; } } # add annotation columns to the annotation bundle my $annmap = $self->_annotation_map; if ($annmap && %$annmap) { my $anncoll = Bio::Annotation::Collection->new(); foreach my $col (keys %$annmap) { next unless $cols[$col]; # skip empty columns! $anncoll->add_Annotation( Bio::Annotation::SimpleValue->new(-value => $cols[$col], -tagname=> $annmap->{$col})); } $params{'-annotation'} = $anncoll; } # ask the object builder to add the slots that we've gathered my $builder = $self->sequence_builder(); $builder->add_slot_value(%params); # and instantiate the object my $seq = $builder->make_object(); # done! return $seq; } =head2 comment_char Title : comment_char Usage : $obj->comment_char($newval) Function: Get/set the leading character(s) designating a line as a comment-line. Example : Returns : value of comment_char (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub comment_char{ my $self = shift; return $self->{'comment_char'} = shift if @_; return $self->{'comment_char'}; } =head2 header Title : header Usage : $obj->header($newval) Function: Get/set the number of header lines to skip before the rows containing actual sequence records. If set to zero or undef, means that there is no header and therefore also no column headers. Example : Returns : value of header (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub header{ my $self = shift; return $self->{'header'} = shift if @_; return $self->{'header'}; } =head2 delimiter Title : delimiter Usage : $obj->delimiter($newval) Function: Get/set the column delimiter. This will in fact be treated as a regular expression. Consecutive occurrences will not be collapsed to a single one. Example : Returns : value of delimiter (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub delimiter{ my $self = shift; return $self->{'delimiter'} = shift if @_; return $self->{'delimiter'}; } =head2 attribute_map Title : attribute_map Usage : $obj->attribute_map($newval) Function: Get/set the map of sequence object initialization attributes (keys) to one-based column index. Attributes will usually need to be prefixed by a dash, just as if they were passed to the new() method of the sequence class. Example : Returns : value of attribute_map (a reference to a hash) Args : on set, new value (a reference to a hash or undef, optional) =cut sub attribute_map{ my $self = shift; # internally we store zero-based maps - so we need to convert back # and forth here if (@_) { my $arg = shift; # allow for and protect against undef return delete $self->{'_attribute_map'} unless defined($arg); # copy to avoid side-effects my $attr_map = {%$arg}; foreach my $key (keys %$attr_map) { if ((!ref($attr_map->{$key})) && ($attr_map->{$key} =~ /^\d+$/)) { $attr_map->{$key}--; } } $self->{'_attribute_map'} = $attr_map; } # there may not be a map return unless exists($self->{'_attribute_map'}); # we need to copy in order not to override the stored map! my %attr_map = %{$self->{'_attribute_map'}}; foreach my $key (keys %attr_map) { if ((!ref($attr_map{$key})) && ($attr_map{$key} =~ /^\d+$/)) { $attr_map{$key}++; } } return \%attr_map; } =head2 annotation_map Title : annotation_map Usage : $obj->annotation_map($newval) Function: Get/set the mapping between one-based column indexes (keys) and annotation tags (values). Note that the map returned by this method may change after the first next_seq() call if the file contains a column header and no annotation keys have been predefined in the map, because upon reading the column header line the tag names will be set automatically. Note also that the map may reference columns that are used as well in the sequence attribute map. Example : Returns : value of annotation_map (a reference to a hash) Args : on set, new value (a reference to a hash or undef, optional) =cut sub annotation_map{ my $self = shift; # internally we store zero-based maps - so we need to convert back # and forth here if (@_) { my $arg = shift; # allow for and protect against undef return delete $self->{'_annotation_map'} unless defined($arg); # copy to avoid side-effects my $ann_map = {%$arg}; # make sure we sort the keys numerically or otherwise we may # clobber a key with a higher index foreach my $key (sort { $a <=> $b } keys(%$ann_map)) { $ann_map->{$key-1} = $ann_map->{$key}; delete $ann_map->{$key}; } $self->{'_annotation_map'} = $ann_map; # also make a note that we want to keep annotation $self->keep_annotation(1); } # there may not be a map return unless exists($self->{'_annotation_map'}); # we need to copy in order not to override the stored map! my %ann_map = %{$self->{'_annotation_map'}}; # here we need to sort numerically in reverse order ... foreach my $key (sort { $b <=> $a } keys(%ann_map)) { $ann_map{$key+1} = $ann_map{$key}; delete $ann_map{$key}; } return \%ann_map; } =head2 keep_annotation Title : keep_annotation Usage : $obj->keep_annotation($newval) Function: Get/set flag whether or not to keep values from additional columns as annotation. Additional columns are all those columns in the input file that aren't referenced in the attribute map. Example : Returns : value of keep_annotation (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub keep_annotation{ my $self = shift; return $self->{'keep_annotation'} = shift if @_; return $self->{'keep_annotation'}; } =head2 annotation_columns Title : annotation_columns Usage : $obj->annotation_columns($newval) Function: Get/set the names (labels) of the columns to be used for annotation. This is an alternative to using annotation_map. In order to have any effect, it must be set before the first call of next_seq(), and obviously there must be a header line (or row) too giving the column labels. Example : Returns : value of annotation_columns (a reference to an array) Args : on set, new value (a reference to an array of undef, optional) =cut sub annotation_columns{ my $self = shift; return $self->{'annotation_columns'} = shift if @_; return $self->{'annotation_columns'}; } =head2 trim_values Title : trim_values Usage : $obj->trim_values($newval) Function: Get/set whether or not to trim leading and trailing whitespace off all column values. Example : Returns : value of trim_values (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub trim_values{ my $self = shift; return $self->{'trim_values'} = shift if @_; return $self->{'trim_values'}; } =head1 Internal methods All methods with a leading underscore are not meant to be part of the 'official' API. They are for use by this module only, consider them private unless you are a developer trying to modify this module. =cut =head2 _attribute_map Title : _attribute_map Usage : $obj->_attribute_map($newval) Function: Get only. Same as attribute_map, but zero-based indexes. Note that any changes made to the returned map will change the map used by this instance. You should know what you are doing if you modify the returned value (or if you call this method in the first place). Example : Returns : value of _attribute_map (a reference to a hash) Args : none =cut sub _attribute_map{ my $self = shift; return $self->{'_attribute_map'}; } =head2 _annotation_map Title : _annotation_map Usage : $obj->_annotation_map($newval) Function: Get only. Same as annotation_map, but with zero-based indexes. Note that any changes made to the returned map will change the map used by this instance. You should know what you are doing if you modify the returned value (or if you call this method in the first place). Example : Returns : value of _annotation_map (a reference to a hash) Args : none =cut sub _annotation_map{ my $self = shift; return $self->{'_annotation_map'}; } =head2 _header_skipped Title : _header_skipped Usage : $obj->_header_skipped($newval) Function: Get/set the flag whether the header was already read (and skipped) or not. Example : Returns : value of _header_skipped (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub _header_skipped{ my $self = shift; return $self->{'_header_skipped'} = shift if @_; return $self->{'_header_skipped'}; } =head2 _next_record Title : _next_record Usage : Function: Navigates the underlying file to the next record. For row-based records in delimited text files, this will skip all empty lines and lines with a leading comment character. This method is here is to serve as a hook for other formats that conceptually also represent tables but aren't formatted as row-based text files. Example : Returns : TRUE if the navigation was successful and FALSE otherwise. Unsuccessful navigation will usually be treated as an end-of-file condition. Args : =cut sub _next_record{ my $self = shift; my $cmtcc = $self->comment_char; my $line = $self->_readline(); # skip until not a comment and not an empty line while (defined($line) && (($cmtcc && ($line =~ /^\s*$cmtcc/)) || ($line =~ /^\s*$/))) { $line = $self->_readline(); } return $self->{'_line'} = $line; } =head2 _parse_header Title : _parse_header Usage : Function: Parse the table header and navigate past it. This method is called if the number of header rows has been specified equal to or greater than one, and positioned at the first header line (row). By default the first header line (row) is used for setting column names, but additional lines (rows) may be skipped too. Empty lines and comment lines do not count as header lines (rows). This method will call _next_record() to navigate to the next header line (row), if there is more than one header line (row). Upon return, the file is presumed to be positioned at the first record after the header. This method is here is to serve as a hook for other formats that conceptually also represent tables but aren't formatted as row-based text files. Note however that the only methods used to access file content or navigate the position are _get_row_values() and _next_record(), so it should usually suffice to override those. Example : Returns : TRUE if navigation past the header was successful and FALSE otherwise. Unsuccessful navigation will usually be treated as an end-of-file condition. Args : =cut sub _parse_header{ my $self = shift; # the first header line contains the column headers, see whether # we need them if ($self->keep_annotation) { my @colnames = $self->_get_row_values(); # trim leading and trailing whitespace if desired if ($self->trim_values) { # trim off whitespace @colnames = map { $_ =~ s/^\s+//; $_ =~ s/\s+$//; $_; } @colnames; # trim off double quotes @colnames = map { $_ =~ s/^"//; $_ =~ s/"$//; $_; } @colnames; } # build or complete annotation column map my $annmap = $self->annotation_map || {}; if (! %$annmap) { # check whether columns have been defined by name rather than index if (my $anncols = $self->annotation_columns) { # first sanity check: all column names must map my %colmap = map { ($_,1); } @colnames; foreach my $col (@$anncols) { if (!exists($colmap{$col})) { $self->throw("no such column labeled '$col'"); } } # now map to the column indexes %colmap = map { ($_,1); } @$anncols; for (my $i = 0; $i < scalar(@colnames); $i++) { if (exists($colmap{$colnames[$i]})) { $annmap->{$i+1} = $colnames[$i]; } } } else { # no columns specified, default to all non-attribute columns for (my $i = 0; $i < scalar(@colnames); $i++) { $annmap->{$i+1} = $colnames[$i]; } # subtract all attribute-referenced columns foreach my $attrcol (values %{$self->attribute_map}) { if ((!ref($attrcol)) && ($attrcol =~ /^\d+$/)) { delete $annmap->{$attrcol}; } } } } else { # fill in where the tag names weren't pre-defined for (my $i = 0; $i < scalar(@colnames); $i++) { if (exists($annmap->{$i+1}) && ! defined($annmap->{$i+1})) { $annmap->{$i+1} = $colnames[$i]; } } } $self->annotation_map($annmap); } # now read past the header my $header_lines = $self->header; my $line_ok = 1; while (defined($line_ok) && ($header_lines > 0)) { $line_ok = $self->_next_record(); $header_lines--; } return $line_ok; } =head2 _get_row_values Title : _get_row_values Usage : Function: Get the values for the current line (or row) as an array in the order of columns. This method is here is to serve as a hook for other formats that conceptually also represent tables but aren't formatted as row-based text files. Example : Returns : An array of column values for the current row. Args : =cut sub _get_row_values{ my $self = shift; my $delim = $self->delimiter; my $line = $self->{'_line'}; chomp($line); my @cols = split(/$delim/,$line); return @cols; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/tigr.pm�������������������������������������������������������������������000444��000765��000024�� 100622�12254227331� 16472� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::tigr # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Josh Lauricha (laurichj@bioinfo.ucr.edu) # # Copyright Josh Lauricha # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::tigr - TIGR XML sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from efa flat file databases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Josh Lauricha Email: laurichj@bioinfo.ucr.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # TODO: # - Clean up code # - Find and fix bugs ;) # Let the code begin... package Bio::SeqIO::tigr; use strict; use Bio::Seq::RichSeq; use Bio::Species; use Bio::Annotation::Comment; use Bio::SeqFeature::Generic; use Bio::Seq::SeqFactory; use Bio::Seq::RichSeq; use Data::Dumper; use Error qw/:try/; use base qw(Bio::SeqIO); sub _initialize { my($self, @args) = @_; $self->SUPER::_initialize(@args); $self->sequence_factory(Bio::Seq::SeqFactory->new( -type => 'Bio::Seq::RichSeq') ); # Parse the document $self->_process(); } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq object Args : NONE =cut sub next_seq() { my ($self) = @_; # Check for any more sequences return if !defined($self->{_sequences}) or scalar(@{$self->{_sequences}}) < 1; # get the next sequence my $seq = shift(@{ $self->{_sequences} } ); # Get the 5' and 3' ends my ($source) = grep { $_->primary_tag() eq 'source' } $seq->get_SeqFeatures(); my ($end5) = $source->get_tag_values('end5'); my ($end3) = $source->get_tag_values('end3'); # Sort the 5' and 3': my ($start, $end) = ( $end5 < $end3 ? ( $end5, $end3 ) : ( $end3, $end5 ) ); # make the start a perl index $start -= 1; # Figure out the length my $length = $end - $start; # check to make sure $start >= 0 and $end <= length(assembly_seq) if($start < 0) { throw Bio::Root::OutOfRange("the sequence start is $start < 0"); } elsif($end > length($self->{_assembly}->{seq})) { throw Bio::Root::OutOfRange("the sequence end is $end < " . length($self->{_assembly}->{seq})); } elsif($start >= $end) { throw Bio::Root::OutOfRange("the sequence start is after end $start >= $end"); } # Get and set the real sequence $seq->seq(substr($self->{_assembly}->{seq}, $start, $length)); if( $end5 > $end3 ) { # Reverse complement the sequence $seq->seq( $seq->primary_seq()->revcom()->seq() ); } # add the translation to each CDS foreach my $feat ($seq->get_SeqFeatures()) { next if $feat->primary_tag() ne "CDS"; # Check for an invalid protein try { # Get the subsq my $cds = Bio::PrimarySeq->new( -strand => 1, -id => $seq->accession_number(), -seq => $seq->subseq($feat->location()) ); # Translate it my $trans = $cds->translate(undef, undef, undef, undef, 1, 1)->seq(); # Add the tag $feat->add_tag_value(translation => $trans); } catch Bio::Root::Exception with { print STDERR 'TIGR strikes again, the CDS is not a valid protein: ', $seq->accession_number(), "\n" if $self->verbose() > 0; }; } # Set the display id to the accession number if there # is no display id $seq->display_id( $seq->accession_number() ) unless $seq->display_id(); return $seq; } sub _process { my($self) = @_; my $line; my $tu = undef; $line = $self->_readline(); do { if($line =~ /<\?xml\s+version\s+=\s+"\d+\.\d+"\?>/o) { # do nothing } elsif ($line =~ /<!DOCTYPE (\w+) SYSTEM "[\w\.]+">/o) { $self->throw("DOCTYPE of $1, not TIGR!") if $1 ne "TIGR" ; } elsif ($line =~ /<TIGR>/o) { $self->_pushback($line); $self->_process_tigr(); } elsif ($line =~ /<ASSEMBLY.*?>/o) { $self->_pushback($line); $self->_process_assembly(); } elsif ($line =~ /<\/TIGR>/o) { $self->{'eof'} = 1; return; } else { $self->throw("Unknown or Invalid process directive:", join('', ($line =~ /^\s*(<[^>]+>)/o))); } $line = $self->_readline(); } while( defined( $line ) ); } sub _process_tigr { my($self) = @_; my $line; $line = $self->_readline(); if($line !~ /<TIGR>/o) { $self->throw("Bio::SeqIO::tigr::_process_tigr called but no ", "<TIGR> found in stream"); } $line = $self->_readline(); if($line =~ /<PSEUDOCHROMOSOME>/o) { $self->_pushback($line); $self->_process_pseudochromosome(); } elsif ($line =~ /<ASSEMBLY.*?>/o) { $self->_pushback($line); $self->_process_assembly(); } } sub _process_pseudochromosome { my($self) = @_; my $line; $line = $self->_readline(); return if $line !~ /<PSEUDOCHROMOSOME>/o; $line = $self->_readline(); if($line =~ /<SCAFFOLD>/o) { $self->_pushback($line); $self->_process_scaffold(); $line = $self->_readline(); } else { $self->warn( "No Scaffold found in <PSUEDOCHROMOSOME> this " . "is a violation of the TIGR dtd, but we ignore " . "it so we are ignoring the error\n" ); } if($line =~ /<ASSEMBLY.*>/o) { $self->_pushback($line); $self->_process_assembly(); $line = $self->_readline(); } else { $self->throw("Missing required ASSEMBLY in <PSEUDOCHROMOSOME>"); } if($line =~ /<\/PSEUDOCHROMOSOME>/) { return; } $self->throw("Reached end of _process_psuedochromosome"); } sub _process_assembly { my($self) = @_; my $line; $line = $self->_readline(); if($line !~ /<ASSEMBLY([^>]*)>/o) { $self->throw("Bio::SeqIO::tigr::_process_assembly called ", "but no <ASSEMBLY> found in stream"); } my %attribs = ($1 =~ /(\w+)\s*=\s+"(.*?)"/og); $self->{_assembly}->{date} = $attribs{CURRENT_DATE}; $self->{_assembly}->{db} = $attribs{DATABASE}; $self->{_assembly}->{chromosome} = $attribs{CHROMOSOME}; $line = $self->_readline(); my($attr, $val); if(($attr, $val) = ($line =~ /<ASMBL_ID([^>]*)>([^<]*)<\/ASMBL_ID>/o)) { %attribs = ($attr =~ /(\w+)\s*=\s+"(.*?)"/og); $self->{_assembly}->{clone_name} = $attribs{CLONE_NAME}; $self->{_assembly}->{clone} = $val; $line = $self->_readtag(); } else { $self->throw("Required <ASMBL_ID> missing"); } if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); $self->{_assembly}->{end5} = $cs->{end5}; $self->{_assembly}->{end3} = $cs->{end3}; $line = $self->_readline(); } else { $self->throw("Required <COORDSET> missing"); } if($line =~ /<HEADER>/o) { $self->_pushback($line); $self->_process_header(); $line = $self->_readline(); } else { $self->throw("Required <HEADER> missing"); } if($line =~ /<TILING_PATH>/o) { $self->_pushback($line); $self->_process_tiling_path(); $line = $self->_readline(); } if($line =~ /<GENE_LIST>/o) { $self->_pushback($line); $self->_process_gene_list(); $line = $self->_readline(); } else { $self->throw("Required <GENE_LIST> missing"); } if($line =~ /<MISC_INFO>/o) { $self->_pushback($line); $self->_process_misc_info(); $line = $self->_readline(); } if($line =~ /<REPEAT_LIST>/o) { $self->_pushback($line); $self->_process_repeat_list(); $line = $self->_readline(); } if($line =~ /<ASSEMBLY_SEQUENCE>/o) { $self->_pushback($line); $self->_process_assembly_seq(); $line = $self->_readline(); } else { $self->throw("Required <ASSEMBLY_SEQUENCE> missing"); } if($line =~ /<\/ASSEMBLY>/o) { return; } $self->throw("Reached the end of <ASSEMBLY>"); } sub _process_assembly_seq() { my ($self) = @_; my $line; $line = $self->_readline(); if($line !~ /<ASSEMBLY_SEQUENCE>/o) { $self->throw("Bio::SeqIO::tigr::_process_assembly_seq called ". "with no <ASSEMBLY_SEQUENCE> in the stream"); } # Protect agains lots of smaller lines my @chunks; do { $line = $self->_readline(); last unless $line; my $seq; if (($seq) = ($line =~ /^\s*(\w+)\s*$/o)) { push(@chunks, $seq); } elsif( ($seq) = ( $line =~ /^\s*(\w+)<\/ASSEMBLY_SEQUENCE>\s*$/o) ) { push(@chunks, $seq); $self->{_assembly}->{seq} = join('', @chunks); return; } } while( $line ); $self->throw("Reached end of _proces_assembly"); } sub _process_coordset($) { my ($self) = @_; my $line; my $h; $line = $self->_readline(); if($line =~ /<COORDSET>/o) { $self->_pushback($line); $line = $self->_readtag(); ($h->{end5}, $h->{end3}) = ($line =~ /<COORDSET>\s*<END5>\s*(\d+)\s*<\/END5>\s*<END3>\s*(\d+)\s*<\/END3>/os); if(!defined($h->{end5}) or !defined($h->{end3})) { $self->throw("Invalid <COORDSET>: $line"); } return $h; } else { $self->throw("Bio::SeqIO::tigr::_process_coordset() called ", "but no <COORDSET> found in stream"); } } sub _process_header { my ($self) = @_; my $line = $self->_readline(); if($line !~ /<HEADER>/o) { $self->throw("Bio::SeqIO::tigr::_process_header called ", "but no <HEADER> found in stream"); } $line = $self->_readtag(); if($line =~ /<CLONE_NAME>([^>]+)<\/CLONE_NAME>/o) { $self->{_assembly}->{clone_name} = $1; $line = $self->_readtag(); } else { $self->throw("Required <CLONE_NAME> missing"); } if($line =~ /<SEQ_LAST_TOUCHED>/o) { # Ignored for now $line = $self->_readtag(); } else { $self->throw("Reqired <SEQ_LAST_TOUCHED> missing"); } if($line =~ /<GB_ACCESSION>([^<]*)<\/GB_ACCESSION>/o) { $self->{_assembly}->{gb} = $1; $line = $self->_readtag(); } else { $self->throw("Required <GB_ACCESSION> missing"); } if($line =~ /<ORGANISM>\s*(.+)\s*<\/ORGANISM>/o) { my( $genus, $species, @ss ) = split(/\s+/o, $1); $self->{_assembly}->{species} = Bio::Species->new(); $self->{_assembly}->{species}->genus($genus); $self->{_assembly}->{species}->species($species); $self->{_assembly}->{species}->sub_species(join(' ', @ss)) if scalar(@ss) > 0; $line = $self->_readtag(); } else { $self->throw("Required <ORGANISM> missing"); } if($line =~ /<LINEAGE>([^<]*)<\/LINEAGE>/o) { $self->{_assembly}->{species}->classification( $self->{_assembly}->{species}->species(), reverse(split(/\s*;\s*/o, $1)) ); $line = $self->_readtag(); } else { $self->throw("Required <LINEAGE> missing"); } if($line =~ /<SEQ_GROUP>([^<]*)<\/SEQ_GROUP>/o) { # ingnored $line = $self->_readtag(); } else { $self->throw("Required <SEQ_GROUP> missing"); } while($line =~ /<KEYWORDS>[^<]*<\/KEYWORDS>/o) { push(@{$self->{_assembly}->{keywords}}, $1); $line = $self->_readtag(); } while($line =~ /<GB_DESCRIPTION>([^<]+)<\/GB_DESCRIPTION>/o) { push(@{$self->{_assembly}->{gb_desc}},$1); $line = $self->_readtag(); } while($line =~ /<GB_COMMENT>([^<]+)<\/GB_COMMENT>/o) { push(@{$self->{_assembly}->{gb_comment}}, $1); $line = $self->_readtag(); } if(my %h = ($line =~ /<AUTHOR_LIST(?:\s*(\w+)\s*=\s*"([^"]+)"\s*)*>/o)) { #$header->{'AUTHOR_LIST'}=$h{'CONTACT'}; # Ignored while($line !~ /<\/AUTHOR_LIST>/o) { $self->_readtag(); } $line = $self->_readline(); } else { $self->throw("Required <AUTHOR_LIST> missing"); } if($line =~ /<\/HEADER>/o) { return; } $self->throw("Reached end of header\n"); } sub _process_gene_list { my($self) = @_; my $line; $line = $self->_readline(); if($line !~ /<GENE_LIST>/o) { $self->throw("Bio::SeqIO::tigr::_process_gene_list called ", "but no <GENE_LIST> in the stream"); } $line = $self->_readline(); if($line =~ /<PROTEIN_CODING>/o) { $self->_pushback($line); $self->_process_protein_coding(); $line = $self->_readline(); } else { $self->throw("Required <PROTEIN_CODING> missing"); } if($line =~ /<RNA_GENES>/o) { $self->_pushback($line); $self->_process_rna_genes(); $line = $self->_readline(); } else { $self->throw("Required <RNA_GENES> missing"); } if($line =~ /<\/GENE_LIST>/o) { return; } $self->throw("Reached end of _process_gene_list"); } sub _process_protein_coding { my ($self) = @_; my $line = $self->_readline(); if($line !~ /<PROTEIN_CODING>/o) { $self->throw("Bio::SeqIO::tigr::_process_protein_coding called" . "but no <GENE_LIST> in the stream"); } $line = $self->_readline(); while($line and $line =~ /<TU>/o) { $self->_pushback($line); $self->_process_tu(); $line = $self->_readline(); } # Sort the sequences @{$self->{_sequences}} = sort { my($one, $two) = ( $a, $b ); ($one) = grep { $_->primary_tag() eq 'source' } $one->get_SeqFeatures(); ($two) = grep { $_->primary_tag() eq 'source' } $two->get_SeqFeatures(); return 0 unless defined $one and defined $two; ($one) = sort { $a <=> $b } $one->get_tagset_values(qw/end5 end3/); ($two) = sort { $a <=> $b } $two->get_tagset_values(qw/end5 end3/); return $one <=> $two; } @{$self->{_sequences}}; if($line =~ /<\/PROTEIN_CODING>/o) { return; } $self->throw("Reached end of _process_protein_coding"); } sub _process_rna_genes { my ($self) = @_; my $line = $self->_readline(); if($line =~ /<RNA_GENES>/o) { while($line !~ /<\/RNA_GENES>/o) { $line = $self->_readline(); } } else { $self->throw("Bio::SeqIO::tigr::_process_rna_genes called ", "but no <RNA_GENES> in the stream"); } } sub _process_misc_info { my ($self) = @_; my $line = $self->_readline(); if($line =~ /<MISC_INFO>/o) { while($line !~ /<\/MISC_INFO>/o) { $line = $self->_readline(); } } else { $self->throw("Bio::SeqIO::tigr::_process_misc_info called ", "but no <MISC_INFO> in the stream"); } } sub _process_repeat_list { my ($self) = @_; my $line = $self->_readline(); if($line =~ /<REPEAT_LIST>/o) { while($line !~ /<\/REPEAT_LIST>/o) { $line = $self->_readline(); } } else { $self->throw("Bio::SeqIO::tigr::_process_repeat_list called ", "but no <MISC_INFO> in the stream"); } } sub _process_tiling_path { my($self) = @_; my $line = $self->_readline(); if($line =~ /<TILING_PATH>/o) { while($line !~ /<\/TILING_PATH>/o) { $line = $self->_readline(); } } else { $self->throw("Bio::SeqIO::tigr::_process_repeat_list called ", "but no <MISC_INFO> in the stream"); } } sub _process_scaffold { my ($self) = @_; my $line; # for now we just skip them $line = $self->_readline(); return if $line !~ /<SCAFFOLD>/o; do { $line = $self->_readline(); } while(defined($line) && $line !~ /<\/SCAFFOLD>/o); } sub _process_tu { my($self) = @_; my $line = $self->_readline(); try { my $tu = Bio::Seq::RichSeq->new(-strand => 1); $tu->species( $self->{_assembly}->{species} ); # Add the source tag, so we can add the GO annotations to it $tu->add_SeqFeature(Bio::SeqFeature::Generic->new(-source_tag => 'TIGR', -primary_tag => 'source')); if($line !~ /<TU>/o) { $self->throw("Process_tu called when no <TU> tag"); } $line = $self->_readtag(); if ($line =~ /<FEAT_NAME>([\w\.]+)<\/FEAT_NAME>/o) { $tu->accession_number($1); $tu->add_secondary_accession($1); $line = $self->_readtag(); } else { $self->throw("Invalid Feat_Name"); } while($line =~ /<GENE_SYNONYM>/o) { # ignore $line = $self->_readtag(); } while($line =~ /<CHROMO_LINK>\s*([\w\.]+)\s*<\/CHROMO_LINK>/o) { $tu->add_secondary_accession($1); $line = $self->_readtag(); } if ($line =~ /<DATE>([^>]*)<\/DATE>/o) { $tu->add_date($1) if $1 and $1 !~ /^\s*$/o; $line = $self->_readline(); } else { #$self->throw("Invalid Date: $line"); } if ($line =~ /<GENE_INFO>/o) { $self->_pushback($line); $self->_process_gene_info($tu); $line = $self->_readline(); } else { $self->throw("Invalid Gene_Info"); } my $source; my $end5; my $end3; if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); $end5 = $cs->{end5}; $end3 = $cs->{end3}; my $length = $end3 - $end5; my $strand = $length <=> 0; $length = $length * $strand; $length++; # Correct for starting at 1, not 0 # Add X filler sequence $tu->seq('X' x $length); # Get the source tag: my($source) = grep { $_->primary_tag() eq 'source' } $tu->get_SeqFeatures(); # Set the start and end values $source->start(1); $source->end($length); $source->strand(1); # Add a bunch of tags to it $source->add_tag_value(clone => $self->{_assembly}->{clone}); $source->add_tag_value(clone_name => $self->{_assembly}->{clone_name}); $source->add_tag_value(end5 => $end5); $source->add_tag_value(end3 => $end3); $source->add_tag_value(chromosome => $self->{_assembly}->{chromosome}); $source->add_tag_value(strand => ( $strand == 1 ? 'positive' : 'negative' )); $line = $self->_readline(); } else { $self->throw("Invalid Coordset"); } if($line =~ /<MODEL[^>]*>/o) { do { $self->_pushback($line); $self->_process_model($tu, $end5, $end3); $line = $self->_readline(); } while($line =~ /<MODEL[^>]*>/o); $self->_pushback($line); $line = $self->_readtag(); } else { $self->throw("Expected <MODEL> not found"); } if($line =~ /<TRANSCRIPT_SEQUENCE>/o) { my @chunks; $line = $self->_readline(); while ($line =~ /^\s*([ACGT]+)\s*$/o) { push( @chunks, $1 ); $line = $self->_readline(); } # $line = $self->_readline(); } if($line =~ /<GENE_EVIDENCE>/o) { $line = $self->_readtag(); } while($line =~ /<URL[^>]*>[^<]*<\/URL>/o) { $line = $self->_readtag(); } if($line =~ /<\/TU>/o) { push(@{$self->{_sequences}}, $tu); return; } else { $self->throw("Expected </TU> not found: $line"); } } catch Bio::Root::OutOfRange with { my $E = shift; $self->warn(sprintf("One sub location of a sequence is invalid near line $.\: %s", $E->text())); $line = $self->_readline() until $line =~ /<\/TU>/o; return; }; } sub _process_gene_info { my($self, $tu) = @_; my $line = $self->_readline(); $self->throw("Invalid Gene Info: $line") if $line !~ /<GENE_INFO>/o; $line = $self->_readline(); if($line =~ /<LOCUS>\s*([\w\.]+)\s*<\/LOCUS>/o) { $tu->accession_number($1); $tu->add_secondary_accession($1); $line = $self->_readline(); } elsif( $line =~ /<LOCUS>.*<\/LOCUS>/o) { # We should throw an error, but TIGR doesn't alwasy play # nice with adhering to their dtd $line = $self->_readtag(); } else { #$self->throw("Invalid Locus: $line"); } if($line =~ /<ALT_LOCUS>\s*([\w\.]+)\s*<\/ALT_LOCUS>/o) { $tu->accession_number($1); $tu->add_secondary_accession($1); $line = $self->_readline(); } if($line =~ /<PUB_LOCUS>\s*([\w\.]+)\s*<\/PUB_LOCUS>/o) { $tu->accession_number($1); $tu->add_secondary_accession($1); $line = $self->_readtag(); } elsif( $line =~ /<PUB_LOCUS>.*<\/PUB_LOCUS>/o) { $line = $self->_readtag(); # $self->throw("Invalid Pub_Locus"); } if($line =~ /<GENE_NAME.*>.*<\/GENE_NAME>/o) { # Skip the GENE_NAME $line = $self->_readtag(); } if(my($attr, $value) = ($line =~ /<COM_NAME([^>]*)>([^>]+)<\/COM_NAME>/o)) { #%attribs = ($attr =~ /(\w+)\s*=\s+"(.*?)"/og); #$geneinfo->{'CURATED'} = $attribs{CURATED}; #$geneinfo->{IS_PRIMARY} = $attribs{IS_PRIMARY} # TODO: add a tag on sources for curated $tu->desc($value); $line = $self->_readtag(); } else { $self->throw("invalid com_name: $line"); } while($line =~ /<COMMENT>([^<]+)<\/COMMENT>/o) { my $comment = Bio::Annotation::Comment->new( -text => $1 ); $tu->annotation()->add_Annotation('comment', $comment); $line = $self->_readtag(); } while($line =~ /<PUB_COMMENT>([^<]+)<\/PUB_COMMENT>/o) { my $comment = Bio::Annotation::Comment->new( -text => $1 ); $tu->annotation()->add_Annotation('comment', $comment); $line = $self->_readtag(); } if($line =~ /<EC_NUM>([\w\-\\\.]+)<\/EC_NUM>/o) { #$geneinfo->{'EC_NUM'} = $1; $line = $self->_readtag(); } if($line =~ /<GENE_SYM>\s*([^<]+)\s*<\/GENE_SYM>/o) { #$tu->add_secondary_accession($1); $line = $self->_readtag(); } if($line =~ /<IS_PSEUDOGENE>([^>]+)<\/IS_PSEUDOGENE>/o) { #$geneinfo->{'IS_PSEUDOGENE'} = $1; $line = $self->_readtag(); } else { $self->throw("invalid is_pseudogene: $line"); } if($line =~ /<FUNCT_ANNOT_EVIDENCE/o) { $line = $self->_readtag(); } if($line =~ /<DATE>([^>]+)<\/DATE>/o) { #$geneinfo->{'DATE'} = $1; $line = $self->_readtag(); } while($line =~ /<GENE_ONTOLOGY>/o) { # Get the source tag my($source) = grep { $_->primary_tag() eq 'source' } $tu->get_SeqFeatures(); my @ids = ( $line =~ /(<GO_ID.*?<\/GO_ID>)/gso); foreach my $go (@ids) { my($assignment) = ($go =~ /<GO_ID\s+ASSIGNMENT\s+=\s+"GO:(\d+)">/os); my($term) = ($go =~ /<GO_TERM>([^<]+)<\/GO_TERM>/os); my($type) = ($go =~ /<GO_TYPE>([^<]+)<\/GO_TYPE>/os); # TODO: Add GO annotation if(defined $type and defined $assignment and defined $term) { # Add the GO Annotation $source->add_tag_value( GO => "ID: $assignment; Type: $type; $term" ); } } $line = $self->_readtag(); } if($line =~ /<\/GENE_INFO/o) { return; } $self->throw("unexpected end of gene_info"); } sub _build_location { my($self, $end5, $end3, $length, $cs) = @_; # Find the start and end of the location # relative to the sequence. my $start = abs( $end5 - $cs->{end5} ) + 1; my $end = abs( $end5 - $cs->{end3} ) + 1; # Do some bounds checking: if( $start < 1 ) { throw Bio::Root::OutOfRange( -text => "locations' start( $start) must be >= 1" ); } elsif( $end > $length ) { throw Bio::Root::OutOfRange( -text => "locations' end( $end ) must be <= length( $length )" ); } elsif( $start > $end ) { throw Bio::Root::OutOfRange( -text => "locations' start ( $start ) must be < end ( $end ) $end5, $end3, $cs->{end5}, $cs->{end3}" ); } return Bio::Location::Simple->new( -start => $start, -end => $end, -strand => 1 ); } sub _process_model { my($self, $tu, $end5, $end3) = @_; my $line; my( $source ) = grep { $_->primary_tag() eq 'source' } $tu->get_SeqFeatures(); my $model = Bio::SeqFeature::Generic->new( -source_tag => 'TIGR', -primary_tag => 'MODEL', ); $line = $self->_readline(); if($line !~ /<MODEL ([^>]+)>/o) { $self->throw("Invalid Model: $line") } my %attribs = ($1 =~ /(\w+)\s*=\s*"([^"]*)"/og); #$model->{'CURATED'} = $attribs{'CURATED'}; # TODO: Add tag to model $line = $self->_readline(); if($line =~ /<FEAT_NAME>\s*([\w\.]+)\s*<\/FEAT_NAME>/o) { $model->add_tag_value( feat_name => $1 ); $tu->add_secondary_accession($1); $line = $self->_readline(); } else { $self->throw("Invalid Feature Name: $line"); } if($line =~ /<PUB_LOCUS>\s*([\w\.]+)\s*<\/PUB_LOCUS>/o) { $model->add_tag_value( pub_locus => $1 ); $tu->add_secondary_accession($1); $line = $self->_readline(); } else { # $self->throw("Invalid Pub_Locus: $line"); } if($line =~ /<CDNA_SUPPORT>/o) { $self->_pushback($line); $self->_process_cdna_support( $model ); $line = $self->_readline(); } while($line =~ /<CHROMO_LINK>([^>]+)<\/CHROMO_LINK>/o) { $model->add_tag_value( chromo_link => $1 ); $line = $self->_readline(); } if($line =~ /<DATE>([^>]+)<\/DATE>/o) { $line = $self->_readline(); } else { $self->throw("Invalid Date: $line"); } if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); my $loc = $self->_build_location($end5, $end3, $tu->length(), $cs); $model->start( $loc->start() ); $model->end( $loc->end() ); $line = $self->_readline(); } else { $self->throw("Invalid Coordset: $line"); } my $exon = Bio::SeqFeature::Generic->new( -source_tag => 'TIGR', -primary_tag => 'EXON', -location => Bio::Location::Split->new(), -tags => [ locus => $tu->accession_number() ], ); $exon->add_tag_value( model => $model->get_tag_values('feat_name') ); my $cds = Bio::SeqFeature::Generic->new( -source_tag => 'TIGR', -primary_tag => 'CDS', -location => Bio::Location::Split->new(), -tags => [ locus => $tu->accession_number() ], ); $cds->add_tag_value( model => $model->get_tag_values('feat_name') ); my $utr = []; if($line =~ /<EXON>/o) { do { $self->_pushback($line); $self->_process_exon( $tu, $exon, $cds, $utr, $end5, $end3 ); $line = $self->_readline(); } while($line =~ /<EXON>/o); } else { $self->throw("Required <EXON> missing"); } until($line =~ /<\/MODEL>/o) { $line = $self->_readline(); } $_->add_tag_value( model => $model->get_tag_values('feat_name') ) foreach @$utr; # Add the model, EXONs, CDS, and UTRs $tu->add_SeqFeature($model) if $model and $model->start() >= 1; $tu->add_SeqFeature($exon) if $exon and scalar($exon->location()->each_Location()) >= 1; $tu->add_SeqFeature($cds) if $cds and scalar($cds->location()->each_Location()) >= 1; $tu->add_SeqFeature(@$utr); return; } sub _process_cdna_support { my($self, $model) = @_; my $line = $self->_readline(); if($line !~ /<CDNA_SUPPORT>/o) { $self->throw("Bio::SeqIO::tigr::_process_cdna_support called ", "but no <CDNA_SUPPORT> in the stream"); } $line = $self->_readline(); while( $line =~ /<ACCESSION([^>]+)>(.*)<\/ACCESSION>/o) { # Save the text my $desc = $2; # Get the element's attributes my %attribs = ($1 =~ /(\w+)\s*=\s*"([^"]*)"/og); # Add the tag to the model $model->add_tag_value( cdna_support => "DBXRef: $attribs{DBXREF}; $desc" ); $line = $self->_readline(); } if( $line =~ /<\/CDNA_SUPPORT>/o) { return; } $self->throw("reached end of _process_cdna_support"); } sub _process_exon { my($self, $tu, $exon, $cds, $utr, $end5, $end3 ) = @_; my $line = $self->_readline(); if($line !~ /<EXON>/o) { $self->throw("Bio::SeqIO::tigr::_process_exon called ", "but no <EXON> in the stream"); } $line = $self->_readtag(); if($line =~ /<FEAT_NAME>([^<]+)<\/FEAT_NAME>/o) { # Ignore $line = $self->_readtag(); } else { $self->throw("Required <FEAT_NAME> missing"); } if($line =~ /<DATE>([^<]+)<\/DATE>/o) { # Ignore $line = $self->_readtag(); } else { $self->throw("Required <DATE> missing"); } if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); my $loc = $self->_build_location($end5, $end3, $tu->length(), $cs); $exon->location()->add_sub_Location($loc); $line = $self->_readline(); } else { $self->throw("Required <COORDSET> missing"); } if($line =~ /<CDS>/o) { $self->_pushback($line); $self->_process_cds($tu, $end5, $end3, $cds); $line = $self->_readline(); } if($line =~ /<UTRS>/o) { $self->_pushback($line); $self->_process_utrs($tu, $end5, $end3, $utr); $line = $self->_readline(); } if($line =~ /<\/EXON>/o) { return; } $self->throw("Reached End of Bio::SeqIO::tigr::_process_exon"); } sub _process_cds { my($self, $tu, $end5, $end3, $cds) = @_; my $line = $self->_readline(); if($line !~ /<CDS>/o) { $self->throw("Bio::SeqIO::tigr::_process_cda_support called ", "but no <CDS> in the stream"); } $line = $self->_readtag(); if($line =~ /<FEAT_NAME>([^<]+)<\/FEAT_NAME>/o) { #$cds->{'FEAT_NAME'} = $1; $line = $self->_readtag(); } else { $self->throw("Required <FEAT_NAME> missing"); } if($line =~ /<DATE>([^<]+)<\/DATE>/o) { #$cds->{'DATE'} = $1; $line = $self->_readtag(); } else { $self->throw("Required <DATE> missing"); } if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); my $loc = $self->_build_location($end5, $end3, $tu->length(), $cs); $cds->location()->add_sub_Location($loc); $line = $self->_readline(); } else { $self->throw("Required <COORDSET> missing"); } if($line =~ /<\/CDS>/o) { return; } $self->throw("Reached onf of Bio::SeqIO::tigr::_process_cds"); } sub _process_utrs { my($self, $tu, $end5, $end3, $utrs) = @_; my $line = $self->_readline(); if($line !~ /<UTRS/o) { $self->throw("Bio::SeqIO::tigr::_process_utrs called but no ", "<UTRS> found in stream"); } $line = $self->_readline(); while($line !~ /<\/UTRS>/o) { $self->_pushback($line); if($line =~ /<LEFT_UTR>/o) { $self->_process_left_utr($tu, $end5, $end3, $utrs); } elsif ($line =~ /<RIGHT_UTR>/o) { $self->_process_right_utr($tu, $end5, $end3, $utrs); } elsif ($line =~ /<EXTENDED_UTR>/o) { $self->_process_ext_utr($tu, $end5, $end3, $utrs); } else { $self->throw("Unexpected tag"); } $line = $self->_readline(); } if($line =~ /<\/UTRS>/o) { return $utrs; } $self->throw("Reached end of Bio::SeqIO::tigr::_process_utrs"); } sub _process_left_utr { my($self, $tu, $end5, $end3, $utrs) = @_; my $line = $self->_readline(); my $coordset; if($line !~ /<LEFT_UTR>/o) { $self->throw("Bio::SeqIO::tigr::_process_left_utr called but ", "no <LEFT_UTR> found in stream"); } $line = $self->_readtag(); if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); my $loc = $self->_build_location($end5, $end3, $tu->length(), $cs); push(@$utrs, Bio::SeqFeature::Generic->new( -source_tag => 'TIGR', -primary_tag => 'LEFT_UTR', -strand => 1, -start => $loc->start(), -end => $loc->end() )); $line = $self->_readline(); } else { $self->throw("Required <COORDSET> missing"); } if($line =~ /<\/LEFT_UTR>/o) { return; } $self->throw("Reached end of Bio::SeqIO::tigr::_process_left_utr"); } sub _process_right_utr { my($self, $tu, $end5, $end3, $utrs) = @_; my $line = $self->_readline(); my $coordset; if($line !~ /<RIGHT_UTR>/o) { $self->throw("Bio::SeqIO::tigr::_process_right_utr called but ", "no <RIGHT_UTR> found in stream"); } $line = $self->_readtag(); if($line =~ /<COORDSET>/o) { $self->_pushback($line); $coordset = $self->_process_coordset(); $self->_pushback($line); my $cs = $self->_process_coordset(); my $loc = $self->_build_location($end5, $end3, $tu->length(), $cs); push(@$utrs, Bio::SeqFeature::Generic->new( -source_tag => 'TIGR', -primary_tag => 'RIGHT_UTR', -strand => 1, -start => $loc->start(), -end => $loc->end() )); $line = $self->_readline(); } else { $self->throw("Required <COORDSET> missing"); } if($line =~ /<\/RIGHT_UTR>/o) { return $coordset; } $self->throw("Reached end of Bio::SeqIO::tigr::_process_right_utr"); } sub _process_ext_utr { my($self, $tu, $end5, $end3, $utrs) = @_; my $line = $self->_readline(); my $coordset; if($line !~ /<EXTENDED_UTR>/o) { $self->throw("Bio::SeqIO::tigr::_process_ext_utr called but ", "no <EXTENDED_UTR> found in stream"); } $line = $self->_readtag(); if($line =~ /<COORDSET>/o) { $self->_pushback($line); my $cs = $self->_process_coordset(); my $loc = $self->_build_location($end5, $end3, $tu->length(), $cs); push(@$utrs, Bio::SeqFeature::Generic->new( -source_tag => 'TIGR', -primary_tag => 'EXTENDED_UTR', -strand => 1, -start => $loc->start(), -end => $loc->end() )); $line = $self->_readline(); } else { $self->throw("Required <COORDSET> missing"); } if($line =~ /<\/EXTENDED_UTR>/o) { return $coordset; } $self->throw("Reached end of Bio::SeqIO::tigr::_process_ext_utr"); } sub _readtag { my($self) = @_; my $line = $self->_readline(); chomp($line); my $tag; if(($tag) = ($line =~ /^[^<]*<\/(\w+)/o)) { $self->_pushback($1) if $line =~ /<\/$tag>(.+)$/; return "</$tag>"; } until(($tag) = ($line =~ /<(\w+)[^>]*>/o)) { $line = $self->_readline(); chomp $line; } until($line =~ /<\/$tag>/) { $line .= $self->_readline(); } if(my ($val) = ($line =~ /(<$tag.*>.*?<\/$tag>)/s)) { if($line =~ /<\/$tag>\s*(\w+[\s\w]*?)\s*$/s) { $self->_pushback($1) } return $val; } $self->throw("summerror"); } sub _readline { my($self) = @_; my $line; do { $line = $self->SUPER::_readline(); } while(defined($line) and $line =~ /^\s*$/o); return $line; } sub throw { my($self, @s) = @_; my $string = "[$.]" . join('', @s); $self->SUPER::throw($string); } 1; ��������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/tigrxml.pm����������������������������������������������������������������000444��000765��000024�� 41537�12254227315� 17206� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::tigrxml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::tigrxml - Parse TIGR (new) XML =head1 SYNOPSIS use Bio::SeqIO; my $in = Bio::SeqIO->new(-format => 'tigrcoordset', -file => 'file.xml'); while( my $seq = $in->next_seq ) { # do something... } =head1 DESCRIPTION This is a parser for TIGR Coordset XML for their in-progress annotation dbs. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::tigrxml; use vars qw($Default_Source); use strict; use XML::SAX; use XML::SAX::Writer; use Data::Dumper; use Bio::Seq::SeqFactory; use Bio::Species; use Bio::SeqFeature::Generic; use Bio::Annotation::Reference; use Bio::Annotation::Comment; use Bio::Annotation::DBLink; use List::Util qw(min max); use base qw(Bio::SeqIO XML::SAX::Base); $Default_Source = 'TIGR'; sub _initialize { my ($self) = shift; $self->SUPER::_initialize(@_); $self->{'_parser'} = XML::SAX::ParserFactory->parser('Handler' => $self); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new (-verbose => $self->verbose(), -type => 'Bio::Seq::RichSeq')); } return; } sub next_seq { my $self = shift; if( @{$self->{'_seendata'}->{'_seqs'} || []} || eof($self->_fh)) { return shift @{$self->{'_seendata'}->{'_seqs'}}; } $self->{'_parser'}->parse_file($self->_fh); return shift @{$self->{'_seendata'}->{'_seqs'}}; } # XML::SAX::Base methods sub start_document { my ($self,$doc) = @_; $self->{'_seendata'} = {'_seqs' => [], '_authors' => [], '_feats' => [] }; $self->SUPER::start_document($doc); } sub end_document { my ($self,$doc) = @_; $self->SUPER::end_document($doc); } sub start_element { my ($self,$ele) = @_; # attributes my $name = uc $ele->{'LocalName'}; my $attr = $ele->{'Attributes'}; my $seqid = defined $self->{'_seendata'}->{'_seqs'}->[-1] ? $self->{'_seendata'}->{'_seqs'}->[-1]->display_id : undef; # we're going to try and be SO-nice here if( $name eq 'ASSEMBLY' ) { # New sequence my ($len) = $attr->{'{}COORDS'}->{'Value'} =~ /\d+\-(\d+)/; push @{$self->{'_seendata'}->{'_seqs'}}, $self->sequence_factory->create ( -display_id => $attr->{'{}ASMBL_ID'}->{'Value'}, -length => $len, ); } elsif( $name eq 'HEADER' ) { } elsif( $name eq 'CLONE_NAME' ) { } elsif( $name eq 'ORGANISM' ) { } elsif( $name eq 'AUTHOR_LIST' ) { $self->{'_seendata'}->{'_authors'} = []; } elsif( $name eq 'TU' ) { # gene feature my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $fname = $attr->{'{}FEAT_NAME'}->{'Value'}; my $f = Bio::SeqFeature::Generic->new (-seq_id => $seqid, -start => $s, -end => $e, -strand => $strand, -primary_tag => 'gene', # what does this really map to? -source_tag => $Default_Source, -tag => { 'Note' => $attr->{'{}COM_NAME'}->{'Value'}, 'ID' => $fname, 'locus' => $attr->{'{}LOCUS'}->{'Value'}, 'pub_locus' => $attr->{'{}PUB_LOCUS'}->{'Value'}, 'alt_locus' => $attr->{'{}ALT_LOCUS'}->{'Value'}, 'pub_comment' => $attr->{'{}PUB_COMMENT'}->{'Value'}, } ); push @{$self->{'_seendata'}->{'_feats'}}, $f; # add this feature to the current sequence $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif( $name eq 'MODEL' ) { # mRNA/transcript # reset the UTRs $self->{'_seendata'}->{"five_prime_UTR"}= undef; $self->{'_seendata'}->{"three_prime_UTR"} = undef; my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $parent = $self->{'_seendata'}->{'_feats'}->[-1]; my ($parentid) = $parent->get_tag_values('ID'); my $f = Bio::SeqFeature::Generic->new (-primary_tag => 'transcript', -source_tag => $Default_Source, -start => $s, # we use parent start/stop because 'MODEL' means CDS start/stop -end => $e, # but we want to reflect -strand => $strand, -seq_id => $seqid, -tag => { 'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, 'Parent' => $parentid, 'Note' => $attr->{'{}COMMENT'}->{'Value'}, }); $parent->add_SeqFeature($f); push @{$self->{'_seendata'}->{'_feats'}}, $f; $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif( $name eq 'EXON' ) { # exon feature my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $parent = $self->{'_seendata'}->{'_feats'}->[-1]; my ($parentid) = $parent->get_tag_values('ID'); my $f = Bio::SeqFeature::Generic->new (-primary_tag => 'exon', -source_tag => $Default_Source, -seq_id => $seqid, -start => $s, -end => $e, -strand => $strand, -tag => { 'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, 'Parent' => $parentid, }); $parent->add_SeqFeature($f,'EXPAND'); $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); # we'll still just add exons to the transcript } elsif( $name eq 'PROTEIN_SEQ' ) { } elsif( $name eq 'CDS' ) { # CDS will be the translation of the transcript my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $parent = $self->{'_seendata'}->{'_feats'}->[-1]; my ($parentid) = $parent->get_tag_values('ID'); $self->assert($parent->primary_tag eq 'transcript', 'Testing for primary tag equivalent to mRNA'); $self->assert($parent->strand == $strand || abs($s-$e) == 0, 'Testing that parent feature and current feature strand are equal '. $parentid. ' '.$attr->{'{}FEAT_NAME'}->{'Value'}); my $f = Bio::SeqFeature::Generic->new (-primary_tag => 'CDS', -source_tag => $Default_Source, -seq_id => $seqid, -start => $s, -end => $e, -strand => $parent->strand, -tag => { 'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, 'Parent' => $parentid, # should be the mRNA }); $parent->add_SeqFeature($f); $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif( $name eq 'RNA-EXON' ) { my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $parent = $self->{'_seendata'}->{'_feats'}->[-1]; my ($parentid) = $parent->get_tag_values('ID'); my $f = Bio::SeqFeature::Generic->new (-primary_tag => 'tRNA_exon', # tRNA_exon? -source_tag => $Default_Source, -seq_id => $seqid, -start => $s, -end => $e, -strand => $strand, -tag => { 'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, 'Parent' => $parentid, } ); $parent->add_SeqFeature($f); $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif( $name eq 'PRE-TRNA' ) { # tRNA gene my ($s,$e) = ( $attr->{'{}COORDS'}->{'Value'} =~/(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $f = Bio::SeqFeature::Generic->new ( -primary_tag => 'tRNA_coding_gene', -source_tag => $Default_Source, -seq_id => $seqid, -start => $s, -end => $e, -strand => $strand, -tag => {'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, } ); push @{$self->{'_seendata'}->{'_feats'}}, $f; $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif( $name eq 'TRNA' ) { # tRNA transcript my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $parent = $self->{'_seendata'}->{'_feats'}->[-1]; my ($parentid) = $parent->get_tag_values('ID'); my $f = Bio::SeqFeature::Generic->new (-primary_tag => 'tRNA_primary_transcript', -source_tag => $Default_Source, -start => $s, -end => $e, -strand => $strand, -seq_id => $seqid, -tag => { 'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, 'Parent' => $parentid, 'Note' => $attr->{'{}COM_NAME'}->{'Value'}, 'anticodon' => $attr->{'{}ANTICODON'}->{'Value'}, 'pub_locus' => $attr->{'{}PUB_LOCUS'}->{'Value'}, }); $parent->add_SeqFeature($f); push @{$self->{'_seendata'}->{'_feats'}}, $f; $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif( $name eq 'REPEAT_LIST' ) { } elsif( $name eq 'REPEAT' ) { my ($s,$e) = ($attr->{'{}COORDS'}->{'Value'} =~ /(\d+)\-(\d+)/); my $strand = 1; if( $s > $e) { ($s,$e,$strand) = ( $e,$s,-1); } my $f = Bio::SeqFeature::Generic->new (-primary_tag => 'simple_repeat', -source_tag => $Default_Source, -seq_id => $seqid, -start => $s, -end => $e, -stand => $strand, -tag => { 'ID' => $attr->{'{}FEAT_NAME'}->{'Value'}, }); push @{$self->{'_seendata'}->{'_feats'}}, $f; $self->{'_seendata'}->{'_seqs'}->[-1]->add_SeqFeature($f); } elsif ( $name eq 'AUTHOR' ) { } elsif( $name eq 'GB_DESCRIPTION' ) { } elsif( $name eq 'GB_COMMENT' ) { } elsif( $name eq 'LINEAGE' ) { } else { $self->warn("Unknown element $name, ignored\n"); } push @{$self->{'_state'}}, $name; $self->SUPER::start_element($ele); } sub end_element { my ($self,$ele) = @_; pop @{$self->{'_state'}}; my $name = $ele->{'LocalName'}; my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; if( $name eq 'AUTHOR_LIST' ) { if( $curseq->can('annotation') ) { $curseq->annotation->add_Annotation ('reference',Bio::Annotation::Reference->new (-authors => join(',',@{$self->{'_seendata'}->{'_authors'}})) ); } $self->{'_seendata'}->{'_authors'} = []; } elsif( $name eq 'ASSEMBLY' ) { if( @{$self->{'_seendata'}->{'_feats'} || []} ) { $self->warn("Leftover features which were not finished!"); } $self->debug("end element for ASSEMBLY ". $curseq->display_id. "\n"); } elsif( $name eq 'TU' || $name eq 'TRNA' || $name eq 'PRE-TRNA' || $name eq 'REPEAT' ) { pop @{$self->{'_seendata'}->{'_feats'}}; } elsif( $name eq 'MODEL' ) { # This is all to for adding UTRs my $model = pop @{$self->{'_seendata'}->{'_feats'}}; my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; # sort smallest to largest, don't forget about # strandedness my ($parentid) = $model->get_tag_values('Parent'); my @features = $model->get_SeqFeatures(); my @exons = sort { $a->start <=> $b->start } grep { $_->primary_tag eq 'exon' } @features; my @cdsexons = sort { $a->start <=> $b->start } grep { $_->primary_tag eq 'CDS' } @features; # look at the exons, find those which come after the model start my $cdsexon = shift @cdsexons; my $exon = shift @exons; # first exon if( ! defined $cdsexon ) { $self->warn( "no CDS exons $parentid!"); return; } elsif( ! defined $exon ) { $self->warn("no exons $parentid!" ); return; } my $utrct = 1; while( defined $exon && $exon->start < $cdsexon->start ) { my ($pid) = $exon->get_tag_values('Parent'); $self->debug("LeftPhase: tu-id $parentid mrna-id $pid exon is ". $exon->location->to_FTstring. " CDSexon is ".$cdsexon->location->to_FTstring."\n"); my $utr = Bio::SeqFeature::Generic->new (-seq_id => $exon->seq_id, -strand => $exon->strand, -primary_tag => $exon->strand > 0 ? "five_prime_UTR" : "three_prime_UTR", -source_tag => $Default_Source, -tag => { 'ID' => "$pid.UTR".$utrct++, 'Parent' => $pid }, ); my ($ns,$ne); if( $utr->primary_tag eq 'five_prime_UTR' ) { $ns = $exon->start; $ne = min ( $exon->end, $cdsexon->start - 1); } else { $ne = min( $exon->end, $cdsexon->start - 1); $ns = $exon->start; } $utr->start($ns); $utr->end($ne); $model->add_SeqFeature($utr); $curseq->add_SeqFeature($utr); $exon = shift @exons; } @exons = sort { $a->start <=> $b->start } grep {$_->primary_tag eq 'exon' } @features; @cdsexons = sort { $a->start <=> $b->start } grep { $_->primary_tag eq 'CDS' } @features; $cdsexon = pop @cdsexons; $exon = pop @exons; if( ! defined $cdsexon ) { $self->warn( "no CDS exons $parentid!"); return; } elsif( ! defined $exon ) { $self->warn("no exons $parentid!" ); return; } $utrct = 1; while( defined $exon &&$exon->end > $cdsexon->end ) { my ($pid) = $exon->get_tag_values('Parent'); $self->debug("RightPhase: tu-id $parentid mrna-id $pid exon is ". $exon->location->to_FTstring. " CDSexon is ".$cdsexon->location->to_FTstring."\n"); my $utr = Bio::SeqFeature::Generic->new (-seq_id => $exon->seq_id, -strand => $exon->strand, -primary_tag => $exon->strand < 0 ? "five_prime_UTR" : "three_prime_UTR", -source_tag => $Default_Source, -tag => { 'Parent' => $pid, 'ID' => "$pid.UTR".$utrct++, } ); my ($ns,$ne); if( $utr->primary_tag eq 'three_prime_UTR' ) { $ns = max ( $exon->start, $cdsexon->end + 1); $ne = $exon->end; } else { $ns = $cdsexon->end+1; $ne = max ( $exon->end, $cdsexon->start + 1); } $utr->start($ns); $utr->end($ne); $model->add_SeqFeature($utr); $curseq->add_SeqFeature($utr); $exon = pop @exons; } } $self->SUPER::end_element($ele); } sub characters { my ($self,$data) = @_; if( ! @{$self->{'_state'}} ) { $self->warn("Calling characters with no previous start_element call. Ignoring data"); } else { my $curseq = $self->{'_seendata'}->{'_seqs'}->[-1]; my $curfeat = $self->{'_seendata'}->{'_feats'}->[-1]; my $name = $self->{'_state'}->[-1]; if( defined $curseq ) { if( $name eq 'CLONE_NAME' ) { $self->debug("Clone name is ",$data->{'Data'}, "\n"); $curseq->display_id($data->{'Data'}); } elsif( $name eq 'ORGANISM' ) { my ($genus,$species,$subspec) = split(/\s+/,$data->{Data},3); $curseq->species(Bio::Species->new( -classification => [$species,$genus], -sub_species => $species)); } elsif( $name eq 'LINEAGE' ) { $curseq->species->classification( [ $curseq->species->species, $curseq->species->genus, reverse (map { s/^\s+//; s/\s+$//; $_; } split /[;\.]+/,$data->{'Data'} ), ] ); } elsif( $name eq 'AUTHOR' ) { push @{$self->{'_seendata'}->{'_authors'}}, $data->{'Data'}; } } if( defined $curfeat ) { if( $name eq 'EXON' ) { # exon feature } elsif( $name eq 'RNA-EXON' ) { } elsif( $name eq 'PROTEIN_SEQ' ) { $curfeat->add_tag_value('translation',$data->{'Data'}); } elsif( $name eq 'CDS' ) { } elsif( $name eq 'PRE-TRNA' ) { # tRNA gene } elsif( $name eq 'TRNA' ) { # tRNA transcript } elsif( $name eq 'REPEAT_LIST' ) { } elsif( $name eq 'REPEAT' ) { $curfeat->add_tag_value('Note',$data->{'Data'}); } elsif( $name eq 'GB_COMMENT' ) { $curseq->annotation->add_Annotation ('comment', Bio::Annotation::Comment->new(-text => $data->{'Data'})); } elsif( $name eq 'GB_DESCRIPTION' ) { $curseq->description($data->{'Data'}); } } } $self->SUPER::characters($data); } sub assert { my ($self,$test,$msg) = @_; $self->throw($msg) unless $test; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/tinyseq.pm����������������������������������������������������������������000444��000765��000024�� 24761�12254227315� 17214� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::tinyseq # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Bristol-Myers Squibb # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::tinyseq - reading/writing sequences in NCBI TinySeq format =head1 SYNOPSIS Do not use this module directly; use the SeqIO handler system: $stream = Bio::SeqIO->new( -file => $filename, -format => 'tinyseq' ); while ( my $seq = $stream->next_seq ) { .... } =head1 DESCRIPTION This object reads and writes Bio::Seq objects to and from TinySeq XML format. A TinySeq is a lightweight XML file of sequence information, analgous to FASTA format. See L<http://www.ncbi.nlm.nih.gov/dtd/NCBI_TSeq.mod.dtd> for the DTD. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 SEE ALSO L<Bio::SeqIO>, L<Bio::Seq>. =head1 AUTHOR Donald Jackson, E<lt>donald.jackson@bms.comE<gt> Parts of this module and the test script were patterned after Sheldon McKay's L<Bio::SeqIO::game>. If it breaks, however, it's my fault not his ;). =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::tinyseq; use strict; use Bio::Seq::SeqFastaSpeedFactory; use Bio::Species; use Bio::SeqIO::tinyseq::tinyseqHandler; use XML::Parser::PerlSAX; use XML::Writer; use base qw(Bio::SeqIO); sub _initialize { my ($self, @args) = @_; $self->SUPER::_initialize(@args); unless (defined $self->sequence_factory) { $self->sequence_factory(Bio::Seq::SeqFastaSpeedFactory->new()); } $self->{'_species_objects'} = {}; $self->{_parsed} = 0; } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function : returns the next sequence in the stream Returns : Bio::Seq object Args : NONE =cut sub next_seq { my ($self) = @_; $self->_get_seqs() unless ($self->{_parsed}); return shift @{$self->{_seqlist}}; } =head2 write_seq Title : write_seq Usage : $seq = $stream->write_seq(@sequence_objects); undef $stream Function : outputs one or more sequence objects as TinySeq XML Returns : 1 on success Args : one or more sequence objects as TinySeq XML Because the TSeq dtd includes closing tags after all sets are written, the output will not be complete until the program terminates or the object is forced out of scope (see close_writer()). May not perfectly reproduce TSeq_sid element for all sequences =cut sub write_seq { my ($self, @seqobjs) = @_; $self->throw('write_seq must be called with at least one Bio::SeqI or Bio::PrimarySeqI compliant object') unless (@seqobjs and ( $seqobjs[0]->isa('Bio::SeqI') || $seqobjs[0]->isa('Bio::PrimarySeqI'))); my $writer = $self->_get_writer; foreach my $seqobj (@seqobjs) { my ($id_element, $id_value) = $self->_get_idstring($seqobj); $writer->startTag('TSeq'); $writer->emptyTag('TSeq_seqtype', value => $self->_convert_seqtype($seqobj)); $writer->dataElement('TSeq_gi', $seqobj->primary_id || ''); $writer->dataElement($id_element, $id_value); #$writer->dataElement('TSeq_orgname', $seqobj->taxid) if ($seqobj->can('taxid'); # just a placeholder $writer->dataElement('TSeq_defline', $seqobj->desc); $writer->dataElement('TSeq_length', $seqobj->length); $writer->dataElement('TSeq_sequence', $seqobj->seq); if ($seqobj->can('species') && $seqobj->species) { $self->_write_species($writer, $seqobj->species); } $writer->endTag('TSeq'); } 1; } =head2 _get_seqs Title : _get_seqs Usage : Internal function - use next_seq() instead Function : parses the XML and creates Bio::Seq objects Returns : 1 on success Args : NONE Currently stores all sequence objects into memory. I will work on do more of a stream-based approach =cut sub _get_seqs { my ($self) = @_; my $fh = $self->_fh; my $handler = Bio::SeqIO::tinyseq::tinyseqHandler->new(); my $parser = XML::Parser::PerlSAX->new( Handler => $handler ); my @seqatts = $parser->parse( Source => { ByteStream => $fh }); my $factory = $self->sequence_factory; $self->{_seqlist} ||= []; foreach my $seqatt(@seqatts) { foreach my $subatt(@$seqatt) { # why are there two hashes? my $seqobj = $factory->create(%$subatt); $self->_assign_identifier($seqobj, $subatt); if ($seqobj->can('species')) { # my $class = [reverse(split(/ /, $subatt->{'-organism'}))]; # my $species = Bio::Species->new( -classification => $class, # -ncbi_taxid => $subatt->{'-taxid'} ); my $species = $self->_get_species($subatt->{'-organism'}, $subatt->{'-taxid'}); $seqobj->species($species) if ($species); } push(@{$self->{_seqlist}}, $seqobj); } } $self->{_parsed} = 1; } =head2 _get_species Title : _get_species Usage : Internal function Function : gets a Bio::Species object from cache or creates as needed Returns : a Bio::Species object on success, undef on failure Args : a classification string (eg 'Homo sapiens') and a NCBI taxon id (optional) Objects are cached for parsing multiple sequence files. =cut sub _get_species { my ($self, $orgname, $taxid) = @_; unless ($self->{'_species_objects'}->{$orgname}) { my $species = $self->_create_species($orgname, $taxid); $self->{'_species_objects'}->{$orgname} = $species; } return $self->{'_species_objects'}->{$orgname}; } =head2 _create_species Title : _create_species Usage : Internal function Function : creates a Bio::Species object Returns : a Bio::Species object on success, undef on failure Args : a classification string (eg 'Homo sapiens') and a NCBI taxon id (optional) =cut sub _create_species { my ($self, $orgname, $taxid) = @_; return unless ($orgname); # not required in TinySeq dtd so don't throw an error my %params; $params{'-classification'} = [reverse(split(/ /, $orgname))]; $params{'-ncbi_taxid'} = $taxid if ($taxid); my $species = Bio::Species->new(%params) or return; return $species; } =head2 _assign_identifier Title : _assign_identifier Usage : Internal function Function : looks for sequence accession Returns : 1 on success Args : NONE NCBI puts refseq accessions in TSeq_sid, others in TSeq_accver. =cut sub _assign_identifier { my ($self, $seqobj, $atts) = @_; my ($accession, $version); if ($atts->{'-accver'}) { ($accession, $version) = split(/\./, $atts->{'-accver'});; } elsif ($atts->{'-sid'}) { my $sidstring =$atts->{'-sid'}; $sidstring =~ s/^.+?\|//; $sidstring =~ s/\|[^\|]*//; ($accession, $version) = split(/\./, $sidstring);; } else { $self->throw('NO accession information found for this sequence'); } $seqobj->accession_number($accession) if ($seqobj->can('accession_number')); $seqobj->version($version) if ($seqobj->can('version')); } =head2 _convert_seqtype Title : _convert_seqtype Usage : Internal function Function : maps Bio::Seq::alphabet() values [dna/rna/protein] onto TSeq_seqtype values [protein/nucleotide] =cut sub _convert_seqtype { my ($self, $seqobj) = @_; return 'protein' if ($seqobj->alphabet eq 'protein'); return 'nucleotide' if ($seqobj->alphabet eq 'dna'); return 'nucleotide' if ($seqobj->alphabet eq 'rna'); # if we get here there's a problem! $self->throw("Alphabet not defined, can't assign type for $seqobj"); } =head2 _get_idstring Title : _get_idstring Usage : Internal function Function : parse accession and version info from TSeq_accver or TSeq_sid =cut sub _get_idstring { # NCBI puts refseq ids in TSeq_sid, others in TSeq_accver. No idea why. my ($self, $seqobj) = @_; my $accver = $seqobj->accession_number; $accver .= '.' . $seqobj->version if ($seqobj->can('version') and $seqobj->version); if ($accver =~ /^(NM_|NP_|XM_|XP_|NT_|NC_|NG_)/) { return ('TSeq_sid', join('|', 'ref', $accver, '')); } else { return ('TSeq_accver', $accver); } } =head2 _get_writer Title : _get_writer Usage : Internal function Function : instantiate XML::Writer object if needed, output initial XML =cut sub _get_writer { # initialize writer, start doc so write_seq can work one at a time my ($self) = @_; unless ($self->{_writer}) { my $fh = $self->_fh; my $writer = XML::Writer->new(OUTPUT => $fh, DATA_MODE => 1, DATA_INDENT => 2, NEWLINE => 1, ); $writer->doctype('TSeqSet', '-//NCBI//NCBI TSeq/EN', 'http://www.ncbi.nlm.nih.gov/dtd/NCBI_TSeq.dtd'); $writer->comment("Generated by Bio::SeqIO::tinyseq VERSION ".$Bio::SeqIO::tinyseq::VERSION); $writer->startTag('TSeqSet'); $self->{_writer} = $writer; } return $self->{_writer}; } =head2 close_writer Title : close_writer Usage : $self->close_writer() Function : terminate XML output Args : NONE Returns : 1 on success Called automatically by DESTROY when object goes out of scope =cut sub close_writer { # close out any dangling writer my ($self) = @_; if ($self->{_writer}) { my $writer = $self->{_writer}; $writer->endTag('TSeqSet'); $writer->end; undef $writer; } close($self->_fh) if ($self->_fh); 1; } sub _write_species { my ($self, $writer, $species) = @_; $writer->dataElement('TSeq_orgname', $species->binomial); $writer->dataElement('TSeq_taxid', $species->ncbi_taxid) if($species->ncbi_taxid); } sub DESTROY { # primarily to close out a writer! my ($self) = @_; $self->close_writer; undef $self; } 1; __END__ ���������������BioPerl-1.6.923/Bio/SeqIO/ztr.pm��������������������������������������������������������������������000444��000765��000024�� 10225�12254227340� 16323� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::ztr # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::ztr - ztr trace sequence input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::SeqIO class. =head1 DESCRIPTION This object can transform Bio::Seq objects to and from ztr trace files. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Aaron Mackey Email: amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::ztr; use vars qw(@ISA $READ_AVAIL); use strict; use Bio::SeqIO; use Bio::Seq::SeqFactory; push @ISA, qw( Bio::SeqIO ); sub BEGIN { eval { require Bio::SeqIO::staden::read; }; if ($@) { $READ_AVAIL = 0; } else { push @ISA, "Bio::SeqIO::staden::read"; $READ_AVAIL = 1; } } sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); if( ! defined $self->sequence_factory ) { $self->sequence_factory(Bio::Seq::SeqFactory->new(-verbose => $self->verbose(), -type => 'Bio::Seq::Quality')); } my ($compression) = $self->_rearrange([qw[COMPRESSION]], @args); $compression = 2 unless defined $compression; $self->compression($compression); unless ($READ_AVAIL) { Bio::Root::Root->throw( -class => 'Bio::Root::SystemException', -text => "Bio::SeqIO::staden::read is not available; make sure the bioperl-ext package has been installed successfully!" ); } } =head2 next_seq Title : next_seq Usage : $seq = $stream->next_seq() Function: returns the next sequence in the stream Returns : Bio::Seq::Quality object Args : NONE =cut sub next_seq { my ($self) = @_; my ($seq, $id, $desc, $qual) = $self->read_trace($self->_fh, 'ztr'); # create the seq object $seq = $self->sequence_factory->create(-seq => $seq, -id => $id, -primary_id => $id, -desc => $desc, -alphabet => 'DNA', -qual => $qual ); return $seq; } =head2 write_seq Title : write_seq Usage : $stream->write_seq(@seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Seq object =cut sub write_seq { my ($self,@seq) = @_; my $fh = $self->_fh; foreach my $seq (@seq) { $self->write_trace($fh, $seq, 'ztr' . $self->compression); } $self->flush if $self->_flush_on_write && defined $self->_fh; return 1; } =head2 compression Title : compression Usage : $stream->compression(3); Function: determines the level of ZTR compression Returns : the current (or newly set) value. Args : 1, 2 or 3 - any other (defined) value will cause the compression to be reset to the default of 2. =cut sub compression { my ($self, $val) = @_; if (defined $val) { if ($val =~ m/^1|2|3$/o) { $self->{_compression} = $val; } else { $self->{_compression} = 2; } } return $self->{_compression}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/game����������������������������������������������������������������������000755��000765��000024�� 0�12254227330� 15701� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/game/featHandler.pm�������������������������������������������������������000444��000765��000024�� 53730�12254227314� 20643� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # # Helper module for Bio::SeqIO::game::featHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::game::featHandler -- a class for handling feature elements =head1 SYNOPSIS This module is not used directly =head1 DESCRIPTION Bio::SeqIO::game::featHandler converts game XML E<lt>annotationE<gt> elements into flattened Bio::SeqFeature::Generic objects to be added to the sequence =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::game::featHandler; use Bio::SeqFeature::Generic; use Bio::Location::Split; use Data::Dumper; use strict; use vars qw {}; use base qw(Bio::SeqIO::game::gameSubs); =head2 new Title : new Usage : my $featHandler = Bio::SeqIO::game::featHandler->new($seq, $seq_h, $ann_l) Function: creates an object to deal with sequence features Returns : a handler object Args : $seq -- a Bio::SeqI compliant object $seq_h -- ref. to a hash of other sequences associated with the main sequence (proteins, etc) $ann_l -- ref. to a list of annotations =cut sub new { my ($caller, $seq, $seq_h, $ann_l ) = @_; my $class = ref($caller) || $caller; my $self = bless ({ seq => $seq, curr_feats => [], curr_coords => [], seq_h => $seq_h, ann_l => $ann_l, }, $class); return $self; } =head2 add_source Title : add_source Usage : $featHandler->add_source($seq->length, \%tags); Function: creates a source feature Returns : a Bio::SeqFeature::Generic object Args : sequence length and a ref. to a hash of tag/value attributes =cut sub add_source { my ($self, $length, $tags) = @_; my $feat = Bio::SeqFeature::Generic->new( -primary => 'source', -start => 1, -end => $length, ); for ( keys %{$tags} ) { for my $val ( @{$tags->{$_}} ) { $feat->add_tag_value( $_ => $val ); } } return $feat; } =head2 has_gene Title : has_gene Usage : my $gene = $self->_has_gene($gene, $gname, $id) Function: method to get/set the current gene feature Returns : a Bio::SeqFeature::Generic object (if there is a gene) Args : (optional) $gene -- an XML element for the annotation $gname -- gene name $id -- gene ID (not always the same as the name) =cut sub has_gene { my ($self, $gene, $gname, $id) = @_; # use name preferentially over id. We can't edit IDs in Apollo # AFAIK, and this will create an orphan CDS for newly created # transcipts -- I think this needs more work #$id = $gname if $id && $gname; unless ( $gene ) { if ( defined $self->{curr_gene} ) { return $self->{curr_gene}; } else { return 0; } } else { if ( $id && !$self->{curr_ltag} ) { $self->{curr_ltag} = $id; } if ( $gname && !$self->{curr_gname} ) { $self->{curr_gname} = $gname; } my $tags = {}; for my $child ( @{$gene->{Children}} ) { my $name = $child->{Name}; if ( $name eq 'dbxref' ) { $tags->{dbxref} ||= []; push @{$tags->{dbxref}}, $self->dbxref( $child ); } elsif ( $name !~ /name/ ){ $self->complain("Unrecognized element '$name'. I don't " . "know what to do with $name elements"); } } my $feat = Bio::SeqFeature::Generic->new( -primary => 'gene', ); my %seen; for ( keys %{$tags} ) { for my $val ( @{$tags->{$_}} ) { $feat->add_tag_value( $_ => $val ) unless ++$seen{$_.$val} > 1; } } $self->{curr_gene} = $feat; return $feat; } } =head2 _has_CDS Title : _has_CDS Usage : my $cds = $self->_has_CDS Function: internal getter/setter for CDS features Returns : a Bio::SeqFeature::Generic transcript object (or nothing) Args : a Bio::SeqFeature::Generic transcript feature =cut sub _has_CDS { my ($self, $transcript) = @_; if ( !$transcript ) { if ( defined $self->{curr_cds} ) { return $self->{curr_cds}; } else { return 0; } } else { my $tags = $self->{curr_tags}; $self->{curr_cds} = $self->_add_CDS( $transcript, $tags ); } } =head2 add_annotation Title : add_annotation Usage : $featHandler->add_annotation($seq, $type, $id, $tags, $feats) Function: converts a containment hierarchy into an ordered list of flat features Returns : nothing Args : $seq -- a Bio::SeqI compliant object $type -- the annotation type $id -- the anotation ID $tags -- ref. to a hash of tag/value attributes $feats -- ref to an array of Bio::SeqFeature::Generic objects =cut sub add_annotation { my ($self, $seq, $type, $id, $tags, $feats) = @_; # is this a generic feature? unless ( $self->has_gene ) { shift; $self->_add_generic_annotation(@_); return 0; } my $feat; if ( $type eq 'gene' ) { $feat = $self->has_gene; $feat->add_tag_value( gene => ($self->{curr_gname} || $id) ) unless $feat->has_tag('gene'); } else { $feat = Bio::SeqFeature::Generic->new; $feat->primary_tag($type); my $gene = $self->has_gene; $gene->add_tag_value( gene => ($self->{curr_gname} || $id) ) unless $gene->has_tag('gene'); $feat->add_tag_value( gene => ($self->{curr_gname} || $id) ) unless $feat->has_tag('gene');; } for ( keys %{$tags} ) { # or else add simple tag/value pairs if ( $_ eq 'name' && $tags->{type}->[0] eq 'gene' ) { $feat->add_tag_value( gene => $tags->{name}->[0] ) unless $feat->has_tag( 'gene' ); delete $tags->{name}; } else { next if $_ eq 'type' && $tags->{$_}->[0] eq 'gene'; next if $_ eq 'gene' && $feat->has_tag( 'gene' ); for my $val ( @{$tags->{$_}} ) { $feat->add_tag_value( $_ => $val ); } } } $feat->strand( $self->{curr_strand} ); $feat->start( $self->{curr_coords}->[0] ); $feat->end( $self->{curr_coords}->[1] ); # create an array of features for the annotation (order matters) my @annotations = ( $feat ); # add the gene feature if the annotation is not a gene if ( $self->has_gene && $type ne 'gene') { my $gene = $self->has_gene; $gene->strand( $self->{curr_strand} ); $gene->start( $self->{curr_coords}->[0] ); $gene->end( $self->{curr_coords}->[-1] ); push @annotations, $gene; $self->{curr_gene} = ''; } # add the subfeatures for ( @{$feats} ) { $self->complain("bad feature $_") unless ref($_) =~ /Bio/; push @annotations, $_; } # add the annotation array to the list for this sequence my $seqid = $seq->id; my $list = $self->{ann_l}; # make sure the feature_sets appear in ascending order if ( $list->[0] && $annotations[0]->start < $list->[0]->start ) { unshift @{$list}, @annotations; } else { push @{$list}, @annotations; } # garbage collection $self->{curr_gene} = ''; $self->{curr_ltag} = ''; $self->{curr_gname} = ''; $self->{curr_coords} = []; $self->{curr_feats} = []; $self->{curr_strand} = 0; $self->{ann_seq} = $seq; $self->flush; } =head2 _add_generic_annotation Title : _add_generic_annotation Usage : $self->_add_generic_annotation($seq, $type, $id, $tags, $feats) Function: an internal method to handle non-gene annotations Returns : nothing Args : $seq -- a Bio::SeqI compliant object $type -- the annotation type $id -- the anotation ID $tags -- ref. to a hash of tag/value attributes $feats -- ref to an array of Bio::SeqFeature::Generic objects =cut sub _add_generic_annotation { my ($self, $seq, $type, $id, $tags, $feats) = @_; for ( @$feats ) { $_->primary_tag($type); } push @{$self->{ann_l}}, @$feats; $self->{curr_coords} = []; $self->{curr_feats} = []; $self->{curr_strand} = 0; $self->{ann_seq} = $seq; $self->flush; } =head2 feature_set Title : feature_set Usage : push @feats, $featHandler->feature_set($id, $gname, $set, $anntype); Function: handles <feature_span> hierarchies (usually a transcript) Returns : a list of Bio::SeqFeature::Generic objects Args : $id -- ID of the feature set $gname -- name of the gene $set -- the <feature_set> object $anntype -- type of the parent annotation =cut sub feature_set { my ($self, $id, $gname, $set, $anntype) = @_; my $stype = $set->{_type}->{Characters}; $self->{curr_loc} = []; $self->{curr_tags} = {}; $self->{curr_subfeats} = []; $self->{curr_strand} = 0; my @feats = (); my $tags = $self->{curr_tags}; my $sname = $set->{_name}->{Characters} || $set->{Attributes}->{id}; if ( $set->{Attributes}->{problem} ) { $tags->{problem} = [$set->{Attributes}->{problem}]; } my @fcount = grep { $_->{Name} eq 'feature_span' } @{$set->{Children}}; if ( @fcount == 1 ) { $self->_build_feature_set($set, 1); my ($feat) = @{$self->{curr_subfeats}}; $feat->primary_tag('transcript') if $feat->primary_tag eq 'exon'; if ( $feat->primary_tag eq 'transcript' ) { $feat->add_tag_value( gene => ($gname || $id) ) unless $feat->has_tag('gene'); } my %seen_tag; for my $tag ( keys %{$tags} ) { for my $val ( @{$tags->{$tag}} ) { $feat->add_tag_value( $tag => $val ) if $val && ++$seen_tag{$tag.$val} < 2; } } @feats = ($feat); } else { $self->{curr_ltag} = $id; $self->{curr_cds} = ''; $gname = $id if $gname eq 'gene'; $self->{curr_gname} = $gname; if ( $self->has_gene ) { unless ( $anntype =~/RNA/i ) { $stype =~ s/transcript/mRNA/; } } $self->{curr_feat} = Bio::SeqFeature::Generic->new( -primary => $stype, -id => $id, ); my $feat = $self->{curr_feat}; $self->_build_feature_set($set); my $gene = $gname || $self->{curr_ltag}; $feat->add_tag_value( gene => $gene ) unless $feat->has_tag('gene'); # if there is an annotated protein product my $cds = $self->_has_CDS( $feat ); if ( $cds ) { $feat->primary_tag('mRNA'); # we really just want one value here $cds->remove_tag('standard_name') if $cds->has_tag('standard_name'); $cds->add_tag_value( standard_name => $sname ); $cds->remove_tag('gene') if $cds->has_tag('gene'); $cds->add_tag_value( gene => $gene ); # catch empty protein ids if ( $cds->has_tag('protein_id' ) && !$cds->get_tag_values('protein_id') ) { my $pid = $self->protein_id($cds, $sname); $cds->remove_tag('protein_id'); $cds->add_tag_value( protein_id => $pid ); } # make sure other subfeats are tied to the transcript # via a 'standard_name' qualifier and the gene via a 'gene' qualifier my @subfeats = @{$self->{curr_subfeats}}; for my $sf ( @ subfeats ) { $sf->add_tag_value( standard_name => $sname ) unless $sf->has_tag('standard_name'); $sf->add_tag_value( gene => $gene ) unless $sf->has_tag('gene'); } $feat->add_tag_value( standard_name => $sname ) unless $feat->has_tag('standard_name'); $feat->add_tag_value( gene => $gene ) unless $feat->has_tag('gene'); # if the mRNA and CDS are the same length, the mRNA is redundant # lose the mRNA, steal its tags and give them to the CDS my %seen; if ( $feat->length == $cds->length ) { for my $t ( $feat->all_tags ) { next if $t =~ /gene|standard_name/; $cds->add_tag_value( $t => $feat->get_tag_values($t) ); } undef $feat; } @feats = sort { $a->start <=> $b->start } ($cds, @subfeats); unshift @feats, $feat if $feat; } else { if ( @{$self->{curr_loc}} > 1 ) { my $loc = Bio::Location::Split->new( -splittype => 'JOIN' ); # sort the exons in ascending start order my @loc = sort { $a->start <=> $b->start } @{$self->{curr_loc}}; # then add them to the transcript location for ( @loc ) { $loc->add_sub_Location( $_ ) } $feat->location( $loc ); } else { $feat->location( $self->{curr_loc}->[0] ); } for ( keys %$tags ) { # expunge duplicate gene attributes next if /gene/ && $feat->has_tag('gene'); for my $v ( @{$tags->{$_}} ) { $feat->add_tag_value( $_ => $v ); } } # make sure other subfeats are tied to the transcript my @subfeats = @{$self->{curr_subfeats}}; for my $sf ( @ subfeats ) { $sf->add_tag_value( standard_name => $sname ) unless $sf->has_tag('standard_name'); $sf->add_tag_value( gene => $gene ) unless $sf->has_tag('gene'); } @feats = ( $feat, @subfeats ); } } # adjust the maximum extent of the annotated feature # if req'd (ie the <annotation> element) $self->{curr_coords}->[0] ||= 1000000000000; $self->{curr_coords}->[1] ||= -1000000000000; for ( @feats ) { if ( $self->{curr_coords}->[0] > $_->start ) { $self->{curr_coords}->[0] = $_->start; } if ( $self->{curr_coords}->[1] < $_->end ) { $self->{curr_coords}->[1] = $_->end; } } $self->flush( $set ); return @feats; } =head2 _build_feature_set Title : _build_feature_set Usage : $self->_build_feature_set($set, 1) # 1 flag means retain the exon as a subfeat Function: an internal method to process attributes and subfeats of a feature set Returns : nothing Args : $set -- a <feature_set> element 1 -- optional flag to retain exons as subfeats. Otherwise, they will be converted to sublocations of a parent CDS feature =cut sub _build_feature_set { my ($self, $set, $keep_subfeat) = @_; for my $child ( @{$set->{Children}} ) { my $name = $child->{Name}; # these elements require special handling if ( $name eq 'date' ) { $self->date( $child ); } elsif ( $name eq 'comment' ) { $self->comment( $child ); } elsif ( $name eq 'evidence' ) { $self->evidence( $child ); } elsif ( $name eq 'feature_span' ) { $self->_add_feature_span( $child, $keep_subfeat ); } elsif ( $name eq 'property' ) { $self->property( $child ); } # need to add the db_xref tags to the gene? # otherwise, simple tag/value pairs elsif ( $name =~ /synonym|author|description/) { $self->{curr_tags}->{$name} = [$child->{Characters}]; } elsif ( $name !~ /name|type|seq/ ){ $self->complain("Unrecognized element '$name'. I don't " . "know what to do with $name elements"); } } } =head2 _add_feature_span Title : _add_feature_span Usage : $self->_add_feature_span($el, 1) Function: an internal method to process <feature_span> elements Returns : nothing Args : $el -- a <feature_span> element 1 -- an optional flag to retain exons as subfeatures =cut sub _add_feature_span { my ($self, $el, $keep_subfeat) = @_; my $tags = $self->{curr_tags}; my $feat = $self->{curr_feat}; my $type = $el->{_type}->{Characters} || $el->{Name}; my $id = $el->{Attributes}->{id} || $el->{_name}->{Characters}; my $seqr = $el->{_seq_relationship}; my $start = int $seqr->{_span}->{_start}->{Characters}; my $end = int $seqr->{_span}->{_end}->{Characters}; my $stype = $seqr->{Attributes}->{type}; my $seqid = $seqr->{Attributes}->{seq}; push @{$self->{seq_l}}, $self->{seq_h}->{$seqid}; if ( $start > $end ) { $self->{curr_strand} = -1; ($start, $end) = ($end, $start); } else { $self->{curr_strand} = 1; } # add exons to the transcript if ( $type eq 'exon' ) { my $sl = Bio::Location::Simple->new( -start => $start, -end => $end, -strand => $self->{curr_strand} ); push @{$self->{curr_loc}}, $sl; } # apollo and gadfly use different tags for the same thing if ( $type =~ /start_codon|translate offset/ ) { $self->{curr_tags}->{codon_start} = [$start]; } else { if ( $type eq 'exon' ) { return unless $keep_subfeat; } push @{$self->{curr_subfeats}}, Bio::SeqFeature::Generic->new( -start => $start, -end => $end, -strand => $self->{curr_strand}, -primary => $type ); } # identify the translation product my $tscript = $el->{Attributes}->{produces_seq}; if ( $tscript && $tscript ne 'null') { my $subseq = $self->{seq_h}->{$el->{Attributes}->{produces_seq}}; $self->{curr_tags}->{product} = [$el->{Attributes}->{produces_seq}]; $self->{curr_tags}->{translation} = [$subseq->seq] if $subseq; } $self->flush( $el ); } =head2 _add_CDS Title : _add_CDS Usage : my $cds = $self->_add_CDS($transcript, $tags) Function: an internal method to create a CDS feature from a transcript feature Returns : a Bio::SeqFeature::Generic object Args : $transcript -- a Bio::SeqFeature::Generic object for a transcript $tags -- ref. to a hash of tag/value attributes =cut sub _add_CDS { my ($self, $feat, $tags) = @_; my $loc = {}; my $single = 0; if ( @{$self->{curr_loc}} > 1 ) { $loc = Bio::Location::Split->new; # sort the exons in ascending start order my @loc = sort { $a->start <=> $b->start } @{$self->{curr_loc}}; # then add them to the location object for ( @loc ) { $loc->add_sub_Location( $_ ); } } else { $loc = $self->{curr_loc}->[0]; $single++; } # create a CDS my @exons = $single ? $loc : $loc->sub_Location(1); $feat->location($loc); # try to find a peptide my $seq = $self->{seq_h}->{ $tags->{protein_id}->[0] }; $seq ||= $self->{seq_h}->{ $tags->{product}->[0] } || $self->{seq_h}->{ $tags->{gene}->[0] } || $self->{seq_h}->{ $tags->{standard_name}->[0] }; # Can we count on the description format being consistent? # Why is CDS coordinate info saved as description text not # specified in the DTD? Anyone have a better idea? Aww, # who am I kidding, I'm the only one who will ever read this! my ($start, $stop, $peptide) = (); if ( $seq ) { $peptide = $seq->display_id; my $desc = $seq->description || ''; $desc =~ s/,|\n//g; $desc =~ s/\)(\w)/\) $1/g; if ( $desc =~ /cds_boundaries:.+?(\d+)\.\.(\d+)/ ) { ($start, $stop) = ($1 - $self->{offset}, $2 - $self->{offset}); } else { # OK, I guess the transcript must be the CDS then $start = $loc->start; $stop = $loc->end; } } else { $self->warn("I did not find a protein sequence for " . $feat->display_name); } delete $tags->{transcript}; # now chop off the UTRs to create a CDS my @exons_to_add = (); #warn scalar(@exons), " exons, $start, $stop\n"; for ( @exons ) { my $exon = Bio::Location::Simple->new; if ( $_->end < $start || $_->start > $stop ) { #warn "exon out of range\n"; next; } if ( $_->start < $start && $_->end > $start ) { #warn "chopping off left UTR\n"; $exon->start( $start ); } if ( $_->end > $stop && $_->start < $stop ) { #warn "chopping off right UTR\n"; $exon->end( $stop ); } unless ($exon->valid_Location) { $exon->start( $_->start ); $exon->end( $_->end ); } $exon->strand ( $self->{curr_strand} ); push @exons_to_add, $exon; } my $cds_loc; if ( @exons_to_add > 1 ) { $cds_loc = Bio::Location::Split->new( -splittype => 'JOIN' ); for ( @exons_to_add ) { $cds_loc->add_sub_Location( $_ ); } } else { $cds_loc = $exons_to_add[0]; } my $parent = $self->{curr_gname} || $self->{curr_ltag}; # try not to steal too many mRNA attributes for the CDS my $cds_tags = {}; for my $k ( keys %$tags ) { if ( $k =~ /product|protein|translation|codon_start/ ) { $cds_tags->{$k} = $tags->{$k}; delete $tags->{$k}; } } for ( keys %$tags ) { for my $v ( @{$tags->{$_}} ) { $feat->add_tag_value( $_ => $v ) unless $feat->has_tag($_); } } if ( $self->{curr_gname} ) { $cds_tags->{gene} = [$self->{curr_gname}]; } my $gene = $self->has_gene; my $cds = Bio::SeqFeature::Generic->new( -primary => 'CDS', -location => $cds_loc, ); $cds_tags->{translation} = [$seq->seq]; for ( keys %{$cds_tags} ) { my %seen; for my $val (@{$cds_tags->{$_}}) { next if ++$seen{$val} > 1; $cds->add_tag_value( $_ => $val ); } } $cds; } 1; ����������������������������������������BioPerl-1.6.923/Bio/SeqIO/game/gameHandler.pm�������������������������������������������������������000444��000765��000024�� 11603�12254227313� 20625� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: # # BioPerl module for Bio::SeqIO::game::gameHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::game::gameHandler -- PerlSAX handler for game-XML =head1 SYNOPSIS This modules is not used directly =head1 DESCRIPTION Bio::SeqIO::game::gameHandler is the top-level XML handler invoked by PerlSAX =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::game::gameHandler; use Bio::SeqIO::game::seqHandler; use strict; use vars qw {}; use base qw(Bio::SeqIO::game::gameSubs); =head2 start_document Title : start_document Function: begin parsing the document =cut sub start_document { my ($self, $document) = @_; $self->SUPER::start_document($document); $self->{sequences} = {}; $self->{annotations} = {}; $self->{computations} = {}; $self->{map_position} = {}; $self->{focus} = {}; } =head2 end_document Title : end_document Function: finish parsing the document =cut sub end_document { my ($self, $document) = @_; $self->SUPER::end_document($document); return $self; } =head2 load Title : load Usage : $seqs = $handler->load Function: start parsing Returns : a ref to a list of sequence objects Args : an optional flag to supress <computation_analysis> elements (not used yet) =cut sub load { my $self = shift; my $suppress_comps = shift; my @seqs = (); for ( 1..$self->{game} ) { my $seq = $self->{sequences}->{$_} or $self->throw("No sequences defined"); my $ann = $self->{annotations}->{$_}; my $comp = $self->{computations}->{$_}; my $map = $self->{map_position}->{$_}; my $foc = $self->{focus}->{$_} or $self->throw("No main sequence defined"); my $src = $self->{has_source}; my $bio = Bio::SeqIO::game::seqHandler->new( $seq, $ann, $comp, $map, $src ); push @seqs, $bio->convert; } \@seqs; } =head2 s_game Title : s_game Function: begin parsing game element =cut sub s_game { my ($self, $e) = @_; my $el = $self->curr_element; $self->{game}++; my $version = $el->{Attributes}->{version}; unless ( defined $version ) { $self->complain("No GAME-xml version specified -- guessing v1.2\n"); $version = 1.2; } if ( defined($version) && $version == 1.2) { $self->{origin_offset} = 1; } else { $self->{origin_offset} = 0; } if (defined($version) && ($version != 1.2)) { $self->complain("GAME version $version is not supported\n", "I'll try anyway but I may fail!\n"); } } =head2 e_game Title : e_game Function: process the game element =cut sub e_game { my ($self, $el) = @_; $self->flush( $el ); } =head2 e_seq Title : e_seq Function: process the sequence element =cut sub e_seq { my ($self, $e) = @_; my $el = $self->curr_element(); $self->{sequences}->{$self->{game}} ||= []; my $seqs = $self->{sequences}->{$self->{game}}; if ( defined $el->{Attributes}->{focus} ) { $self->{focus}->{$self->{game}} = $el; } push @{$seqs}, $el; $self->flush; } =head2 e_map_position Title : e_map_position Function: process the map_position element =cut sub e_map_position { my ($self, $e) = @_; my $el = $self->curr_element; $self->{map_position}->{$self->{game}} = $el; } =head2 e_annotation Title : e_annotation Function: process the annotation =cut sub e_annotation { my ($self, $e) = shift; my $el = $self->curr_element; $self->{annotations}->{$self->{game}} ||= []; my $anns = $self->{annotations}->{$self->{game}}; push @{$anns}, $el; } 1; �����������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/game/gameSubs.pm����������������������������������������������������������000444��000765��000024�� 26422�12254227322� 20171� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# some of the following code was pillaged from the CPAN module # XML::Handler::Subs # # Copyright (C) 1999 Ken MacLeod # XML::Handler::XMLWriter is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # BioPerl module for Bio::SeqIO::game::gameSubs # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::game::gameSubs -- a base class for game-XML parsing =head1 SYNOPSIS Not used directly =head1 DESCRIPTION A bag of tricks for game-XML parsing. The PerlSAX handler methods were stolen from Chris Mungall's XML base class, which he stole from Ken MacLeod's XML::Handler::Subs =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::game::gameSubs; use XML::Parser::PerlSAX; use UNIVERSAL; use strict; use vars qw {}; use base qw(Bio::Root::Root); =head2 new Title : new Usage : not used directly Returns : a gameHandler object Args : an XML filename =cut sub new { my $type = shift; my $file = shift || ""; my $self = (@_ == 1) ? { %{ (shift) } } : { @_ }; if ($file) { $self->{file} = $file; } return bless $self, $type; } =head2 go Title : go Usage : not used directly Function: starts PerlSAX XML parsing =cut sub go { my $self = shift; XML::Parser::PerlSAX->new->parse(Source => { SystemId => "$self->{file}" }, Handler => $self); } =head2 start_document Title : start_document Usage : not used directly =cut sub start_document { my ($self, $document) = @_; $self->{Names} = []; $self->{Nodes} = []; } =head2 end_document Title : end_document Usage : not used directly =cut sub end_document { my ($self, $document) = @_; delete $self->{Names}; delete $self->{Nodes}; return(); } =head2 start_element Title : start_element Usage : not used directly =cut sub start_element { my ($self, $element) = @_; $element->{Children} = []; $element->{Name} =~ tr/A-Z/a-z/; push @{$self->{Names}}, $element->{Name}; push @{$self->{Nodes}}, $element; my $el_name = "s_" . $element->{Name}; $el_name =~ s/[^a-zA-Z0-9_]/_/g; if ($ENV{DEBUG_XML_SUBS}) { print STDERR "xml_subs:$el_name\n"; } if ($self->can($el_name)) { $self->$el_name($element); return 1; } return 0; } =head2 end_element Title : end_element Usage : not used directly =cut sub end_element { my ($self, $element) = @_; my $called_sub = 0; $element->{Name} =~ tr/A-Z/a-z/; my $el_name = "e_" . $element->{Name}; $el_name =~ s/[^a-zA-Z0-9_]/_/g; my $rval = 0; if ($ENV{DEBUG_XML_SUBS}) { print STDERR "xml_subs:$el_name\n"; } if ($self->can($ {el_name})) { $rval = $self->$el_name($element) || 0; $called_sub = 1; } my $curr_element = $self->{Nodes}->[$#{$self->{Nodes}}]; pop @{$self->{Names}}; pop @{$self->{Nodes}}; if ($rval eq -1 || !$called_sub) { if (@{$self->{Nodes}}) { my $parent = $self->{Nodes}->[$#{$self->{Nodes}}]; push(@{$parent->{Children}}, $curr_element); $parent->{"_".$curr_element->{Name}} = $curr_element; } } return $called_sub; } =head2 characters Title : characters Usage : not used directly =cut sub characters { my ($self, $characters) = @_; my $str = $self->strip_characters($characters->{Data}); my $curr_element = $self->curr_element(); $curr_element->{Characters} .= $str; 0; } =head2 strip_characters Title : strip_characters Usage : not used directly Function: cleans up XML element contents =cut sub strip_characters { my ($self, $str) = @_; $str =~ s/^[ \n\t]* *//g; $str =~ s/ *[\n\t]*$//g; $str; } =head2 curr_element Title : curr_element Usage : not used directly Function: returns the currently open element =cut sub curr_element { my $self = shift; return $self->{Nodes}->[-1]; } =head2 flush Title : flush Usage : $self->flush($element) # or $element->flush Function: prune a branch from the XML tree Returns : true if successful Args : an element object (optional) =cut sub flush { my $self = shift; my $victim = shift || $self->curr_element; $victim = {}; return 1; } # throw a non-fatal warning =head2 complain Title : complain Usage : $self->complain("This is terrible; I am not happy") Function: throw a non-fatal warning, formats message for pretty-printing Returns : nothing Args : a list of strings =cut sub complain { my $self = shift; return 0 unless $self->{verbose}; my $msg = join '', @_; $msg =~ s/\n/ /g; my @msg = split /\s+/, $msg; my $new_msg = ''; for ( @msg ) { my ($last_chunk) = $new_msg =~ /\n?(.+)$/; my $l = $last_chunk ? length $last_chunk : 0; if ( (length $_) + $l > 45 ) { $new_msg .= "\n$_ "; } else { $new_msg .= $_ . ' '; } } $self->warn($new_msg); } =head2 dbxref Title : dbxref Usage : $self->db_xref($el, $tags) Function: an internal method to flatten dbxref elements Returns : the db_xref (eg wormbase:C02D5.1) Args : an element object (reqd) and a hash ref of tag/values (optional) =cut sub dbxref { my ($self, $el, $tags) = @_; $tags ||= $self->{curr_tags}; my $db = $el->{_xref_db}->{Characters}; my $acc = $el->{_unique_id} || $el->{_db_xref_id} || $el->{_xref_db_id}; my $id = $acc->{Characters} or return 0; $self->flush( $el ); # capture both the database and accession number $id= $id =~ /^\w+$/ ? "$db:$id" : $id; $tags->{dbxref} ||= []; push @{$tags->{dbxref}}, $id; $id; } =head2 comment Title : comment Usage : $self->comment($comment_element) Function: a method to flatten comment elements Returns : a string Args : an comment element (reqd) and a hash ref of tag/values (optional) Note : The hope here is that we can unflatten structured comments in game-derived annotations happen to make a return trip =cut sub comment { my ($self, $el, $tags) = @_; $tags ||= $self->{curr_tags}; my $text = $el->{_text}->{Characters}; my $pers = $el->{_person}->{Characters}; my $date = $el->{_date}->{Characters}; my $int = $el->{_internal}->{Characters}; $self->flush( $el ); my $comment = "person=$pers; " if $pers; $comment .= "date=$date; " if $date; $comment .= "internal=$int; " if $int; $comment .= "text=$text" if $text; $tags->{comment} ||= []; push @{$tags->{comment}}, $comment; $comment; } =head2 property Title : property Usage : $self->property($property_element) Function: an internal method to flatten property elements Returns : a hash reference Args : an property/output element (reqd) and a hash ref of tag/values (optional) Note: This method is aliased to 'output' to handle structurally identical output elements =cut *output = \&property; sub property { my ($self, $el, $tags) = @_; $tags ||= $self->{curr_tags}; my $key = $el->{_type}->{Characters}; my $value = $el->{_value}->{Characters}; $self->flush( $el ); $tags->{$key} ||= []; push @{$tags->{$key}}, $value; $tags; } =head2 evidence Title : evidence Usage : $self->evidence($evidence_element) Function: a method to flatten evidence elements Returns : a string Args : an evidence element =cut sub evidence { my ($self, $el) = @_; my $tags = $self->{curr_tags}; my $text = $el->{Characters} or return 0; my $type = $el->{Attributes}->{type}; my $res = $el->{Attributes}->{result}; $self->flush( $el ); my $evidence = "type=$type; " if $type; $evidence .= "result=$res; " if $res; $evidence .= "evidence=$text"; $tags->{evidence}||= []; push @{$tags->{evidence}}, $evidence; $evidence; } =head2 date Title : date Usage : $self->date($date_element) Function: a method to flatten date elements Returns : true if successful Args : a date element =cut sub date { my ($self, $el) = @_; my $tags = $self->{curr_tags}; my $date = $el->{Characters} or return 0; my $stamp = $el->{Attributes}->{timestamp}; $self->flush( $el ); $tags->{date} ||= []; push @{$tags->{date}}, $date; $tags->{timestamp} ||= []; push @{$tags->{timestamp}}, $stamp; 1; } =head2 protein_id Title : protein_id Usage : $pid = $self->protein_id($cds, $standard_name) Function: a method to search for a protein name Returns : a string Args : the CDS object plus the transcript\'s 'standard_name' =cut sub protein_id { my ($self, $cds, $sn) = @_; my $psn; if ( $cds->has_tag('protein_id') ) { ($psn) = $cds->get_tag_values('protein_id'); } elsif ( $cds->has_tag('product') ) { ($psn) = $cds->get_tag_values('product'); $psn =~ s/.+?(\S+)$/$1/; } elsif ( $cds->has_tag('gene') ) { ($psn) = $cds->get_tag_values('gene'); } elsif ( $sn ) { $psn = $sn; } else { $self->complain("Could not find an ID for the protein"); return ''; } $psn =~ s/-R/-P/; return $psn; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/game/gameWriter.pm��������������������������������������������������������000444��000765��000024�� 104174�12254227312� 20551� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::game::gameWriter # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::game::gameWriter -- a class for writing game-XML =head1 SYNOPSIS use Bio::SeqIO; my $in = Bio::SeqIO->new( -format => 'genbank', -file => 'myfile.gbk' ); my $out = Bio::SeqIO->new( -format => 'game', -file => 'myfile.xml' ); # get a sequence object my $seq = $in->next_seq; #write it in GAME format $out->write_seq($seq); =head1 DESCRIPTION Bio::SeqIO::game::gameWriter writes GAME-XML (v. 1.2) that is readable by Apollo. It is best not used directly. It is accessed via Bio::SeqIO. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::game::gameWriter; use strict; use IO::String; use XML::Writer; use Bio::SeqFeature::Generic; use Bio::SeqFeature::Tools::Unflattener; use base qw(Bio::SeqIO::game::gameSubs); =head2 new Title : new Usage : my $writer = Bio::SeqIO::game::gameWriter->new($seq); Function: constructor method for gameWriter Returns : a game writer object Args : a Bio::SeqI implementing object optionally, an argument to set map_position to on. ( map => 1 ). This will create a map_position elemant that will cause the feature coordinates to be remapped to a parent seqeunce. A sequence name in the format seq:xxx-xxx is expected to determine the offset for the map_position. The default behavior is to have features mapped relative to the sequence contained in the GAME-XML file =cut sub new { my ($caller, $seq, %arg) = @_; my $class = ref($caller) || $caller; my $self = bless ( { seq => $seq }, $class ); # make a <map_position> element only if requested $self->{map} = 1 if $arg{map}; $self->{anon_set_counters} = {}; #counters for numbering anonymous result and feature sets return $self; } =head2 write_to_game Title : write_to_game Usage : $writer->write_to_game Function: writes the sequence object to game-XML Returns : xml as a multiline string Args : none =cut sub write_to_game { my $self = shift; my $seq = $self->{seq}; my @feats = $seq->remove_SeqFeatures; # intercept nested features my @nested_feats = grep { $_->get_SeqFeatures } @feats; @feats = grep { !$_->get_SeqFeatures } @feats; map { $seq->add_SeqFeature($_) } @feats; # NB -- Maybe this belongs in Bio::SeqFeatute::Tools::Unflattener # # intercept non-coding RNAs and transposons with contained genes # # GAME-XML has these features as top level annotations which contain # # gene elements # my @gene_containers = (); # for ( @feats ) { # if ( $_->primary_tag =~ /[^m]RNA|repeat_region|transpos/ && # $_->has_tag('gene') ) { # my @genes = $_->get_tag_values('gene'); # my ($min, $max) = (10000000000000,-10000000000000); # for my $g ( @genes ) { # my $gene; # for my $item ( @feats ) { # next unless $item->primary_tag eq 'gene'; # my ($n) = $item->get_tag_values('gene'); # next unless $n =~ /$g/; # $gene = $item; # last; # } # next unless $gene && ref $gene; # $max = $gene->end if $gene->end > $max; # $min = $gene->start if $gene->start < $min; # } # # push @gene_containers, $_ if $_->length >= ($max - $min); # } # else { # $seq->add_SeqFeature($_); # } # } # unflatten my $uf = Bio::SeqFeature::Tools::Unflattener->new; $uf->unflatten_seq( -seq => $seq, use_magic => 1 ); # rearrange snRNA and transposon hierarchies # $self->_rearrange_hierarchies($seq, @gene_containers); # add back nested feats $seq->add_SeqFeature( $_ ) foreach @nested_feats; my $atts = {}; my $xml = ''; # write the XML to a string my $xml_handle = IO::String->new($xml); my $writer = XML::Writer->new(OUTPUT => $xml_handle, DATA_MODE => 1, DATA_INDENT => 2, NEWLINE => 1 ); $self->{writer} = $writer; # $writer->xmlDecl("UTF-8"); # $writer->doctype("game", 'game', "http://www.fruitfly.org/annot/gamexml.dtd.txt"); $writer->comment("GAME-XML generated by Bio::SeqIO::game::gameWriter"); $writer->comment("Created " . localtime); $writer->comment('Questions: mckays@cshl.edu'); $writer->startTag('game', version => 1.2); my @sources = grep { $_->primary_tag =~ /source|origin|region/i } $seq->get_SeqFeatures; for my $source ( @sources ) { next unless $source->length == $seq->length; for ( qw{ name description db_xref organism md5checksum } ) { if ( $source->has_tag($_) ) { $self->{has_organism} = 1 if /organism/; ($atts->{$_}) = $source->get_tag_values($_); } } } #set a name in the attributes if none was given $atts->{name} ||= $seq->accession_number ne 'unknown' ? $seq->accession_number : $seq->display_name; $self->_seq($seq, $atts); # make a map_position element if req'd if ( $self->{map} ) { my $seqtype; if ( $atts->{mol_type} || $seq->alphabet ) { $seqtype = $atts->{mol_type} || $seq->alphabet; } else { $seqtype = 'unknown'; } $writer->startTag( 'map_position', seq => $atts->{name}, type => $seqtype ); my ($arm, $start, undef, $end) = $atts->{name} =~ /(\S+):(-?\d+)(\.\.|-)(-?\d+)/; $self->_element('arm', $arm) if $arm; $self->_span($start, $end); $writer->endTag('map_position'); } for ( $seq->top_SeqFeatures ) { if($_->isa('Bio::SeqFeature::Computation')) { $self->_comp_analysis($_); } else { # if the feature has subfeatures, we will assume it is a gene # (hope this is safe!) if ( $_->get_SeqFeatures ) { $self->_write_gene($_); } else { # non-gene stuff only next if $_->primary_tag =~ /CDS|mRNA|exon|UTR/; $self->_write_feature($_); } } } $writer->endTag('game'); $writer->end; $xml; } =head2 _rearrange_hierarchies Title : _rearrange_hierarchies Usage : $self->_rearrange_hierarchies($seq) Function: internal method to rearrange gene containment hierarchies so that snRNA or transposon features contain their genes rather than the other way around Returns : nothing Args : a Bio::RichSeq object Note : Not currently used, may be removed =cut sub _rearrange_hierarchies { #renamed to not conflict with Bio::Root::_rearrange my ($self, $seq, @containers) = @_; my @feats = $seq->remove_SeqFeatures; my @genes = grep { $_->primary_tag eq 'gene' } @feats; my @addback = grep { $_->primary_tag ne 'gene' } @feats; for ( @containers ) { my @has_genes = $_->get_tag_values('gene'); for my $has_gene ( @has_genes ) { for my $gene ( @genes ) { next unless $gene; my ($gname) = $gene->get_tag_values('gene'); if ( $gname eq $has_gene ) { $_->add_SeqFeature($gene); undef $gene; } } } } push @addback, (@containers, grep { defined $_ } @genes ); $seq->add_SeqFeature($_) foreach @addback; } =head2 _write_feature Title : _write_feature Usage : $seld->_write_feature($feat, 1) Function: internal method for writing generic features as <annotation> elements Returns : nothing Args : a Bio::SeqFeature::Generic object and an optional flag to write a bare feature set with no annotation wrapper =cut sub _write_feature { my ($self, $feat, $bare) = @_; my $writer = $self->{writer}; my $id; for ( 'standard_name', $feat->primary_tag, 'ID' ) { $id = $self->_find_name($feat, $_ ); last if $id; } $id ||= $feat->primary_tag . '_' . ++$self->{$feat->primary_tag}->{id}; unless ( $bare ) { $writer->startTag('annotation', id => $id); $self->_element('name', $id); $self->_element('type', $feat->primary_tag); } $writer->startTag('feature_set', id => $id); $self->_element('name', $id); $self->_element('type', $feat->primary_tag); $self->_render_tags( $feat, \&_render_date_tags, \&_render_comment_tags, \&_render_tags_as_properties ); $self->_feature_span($id, $feat); $writer->endTag('feature_set'); $writer->endTag('annotation') unless $bare; } =head2 _write_gene Title : _write_gene Usage : $self->_write_gene($feature) Function: internal method for rendering gene containment hierarchies into a nested <annotation> element Returns : nothing Args : a nested Bio::SeqFeature::Generic gene feature Note : A nested gene hierarchy (gene->mRNA->CDS->exon) is expected. If other gene subfeatures occur as level one subfeatures (same level as mRNA subfeats) an attempt will be made to link them to transcripts via the 'standard_name' qualifier =cut sub _write_gene { my ($self, $feat) = @_; my $writer = $self->{writer}; my $str = $feat->strand; my $id = $self->_find_name($feat, 'standard_name') || $self->_find_name($feat, 'gene') || $self->_find_name($feat, $feat->primary_tag) || $self->_find_name($feat, 'locus_tag') || $self->_find_name($feat, 'symbol') || $self->throw(<<EOM."Feature name was: '".($feat->display_name || 'not set')."'"); Could not find a gene/feature ID, feature must have a primary tag or a tag with one of the names: 'standard_name', 'gene', 'locus_tag', or 'symbol'. EOM my $gid = $self->_find_name($feat, 'gene') || $id; $writer->startTag('annotation', id => $id); $self->_element('name', $gid); $self->_element('type', $feat->primary_tag); $self->_render_tags( $feat, \&_render_date_tags, \&_render_dbxref_tags, \&_render_comment_tags, \&_render_tags_as_properties, ); my @genes; if ( $feat->primary_tag eq 'gene' ) { @genes = ($feat); } else { # we are in a gene container; gene must then be one level down @genes = grep { $_->primary_tag eq 'gene' } $feat->get_SeqFeatures; } for my $g ( @genes ) { my $id ||= $self->_find_name($g, 'standard_name') || $self->_find_name($g, 'gene') || $self->_find_name($feat, 'locus_tag') || $self->_find_name($feat, 'symbol') || $self->throw("Could not find a gene ID"); my $gid ||= $self->_find_name($g, 'gene') || $self->_find_name($g); $writer->startTag('gene', association => 'IS'); $self->_element('name', $gid); $writer->endTag('gene'); my $proteins; my @mRNAs = grep { $_->primary_tag =~ /mRNA|transcript/ } $g->get_SeqFeatures; my @other_stuff = grep { $_->primary_tag !~ /mRNA|transcript/ } $g->get_SeqFeatures; my @variants = ('A' .. 'Z'); for my $mRNA (@mRNAs) { my ($sn, @units); # if the mRNA is a generic transcript, it must be a non-spliced RNA gene # Make a synthetic exon to help build a hierarchy. We have to assume that # the location is not segmented (otherwise it should be a mRNA) if ( $mRNA->primary_tag eq 'transcript') { my $exon = Bio::SeqFeature::Generic->new ( -primary => 'exon' ); $exon->location($mRNA->location); $mRNA->add_SeqFeature($exon); } # no subfeats? Huh? revert to generic feature unless ( $mRNA->get_SeqFeatures ) { $self->_write_feature($mRNA, 1); # 1 flag writes the bare feature # with no annotation wrapper next; } my $name = $self->_find_name($mRNA, $mRNA->primary_tag) || $self->_find_name($mRNA, 'standard_name'); my %attributes; my ($cds) = grep { $_->primary_tag eq 'CDS' } $mRNA->get_SeqFeatures; # make sure we have the right CDS for alternatively spliced genes # This is meant to deal with sequences from flattened game annotations, # where both the mRNA and CDS have split locations if ( $cds && @mRNAs > 1 && $name ) { $cds = $self->_check_cds($cds, $name); } elsif ( $cds && @mRNAs == 1 ) { # The mRNA/CDS pairing must be right. Get the transcript name from the CDS if ( $cds->has_tag('standard_name') ) { ($name) = $cds->get_tag_values('standard_name'); } } if ( !$name ) { # assign a name to the transcript if it has no 'standard_name' binder $name = $id . '-R' . (shift @variants); } my $pname; if ( $cds ) { ($sn) = $cds->get_tag_values('standard_name') if $cds->has_tag('standard_name'); ($sn) ||= $cds->get_tag_values('mRNA') if $cds->has_tag('mRNA'); # the protein needs a name my $psn = $self->protein_id($cds, $sn); $self->{curr_pname} = $psn; # the mRNA need to know the name of its protein unless ( $feat->has_tag('protein_id') ) { $feat->add_tag_value('protein_id', $psn); } # define the translation offset my ($c_start, $c_end); if ( $cds->has_tag('codon_start') ){ ($c_start) = $cds->get_tag_values('codon_start'); $cds->remove_tag('codon_start'); } else { $c_start = 1; } my $cs = Bio::SeqFeature::Generic->new; if ( $c_start == 1 ) { $c_start = $cds->strand > 0 ? $cds->start : $cds->end; } if ( $cds->strand < 1 ) { $c_end = $c_start; $c_start = $c_start - 2; } else { $c_end = $c_start + 2; } $cs->start($c_start); $cs->end($c_end); $cs->strand($cds->strand); $cs->primary_tag('start_codon'); $cs->add_tag_value( 'standard_name' => $name ); push @units, $cs; if ( $cds->has_tag('problem') ) { my ($val) = $cds->get_tag_values('problem'); $cds->remove_tag('problem'); $attributes{problem} = $val; } my ($aa) = $cds->get_tag_values('translation') if $cds->has_tag('translation'); if ( $aa && $psn ) { $cds->remove_tag('translation'); my %add_seq = (); $add_seq{residues} = $aa; $add_seq{header} = ['seq', id => $psn, length => length $aa, type => 'aa' ]; if ( $cds->has_tag('product_desc') ) { ($add_seq{desc}) = $cds->get_tag_values('product_desc'); $cds->remove_tag('product_desc'); } unless ( $add_seq{desc} && $add_seq{desc} =~ /cds_boundaries/ ) { my $start = $cds->start; my $end = $cds->end; my $str = $cds->strand; my $acc = $self->{seq}->accession || $self->{seq}->display_id; $str = $str < 0 ? '[-]' : ''; $add_seq{desc} = "translation from_gene[$gid] " . "cds_boundaries:(" . $acc . ":$start..$end$str) transcript_info:[$name]"; } $self->{add_seqs} ||= []; push @{$self->{add_seqs}}, \%add_seq; } } $writer->startTag('feature_set', id => $name); $self->_element('name', $name); $self->_element('type', 'transcript'); $self->_render_tags($_, \&_render_date_tags, \&_render_comment_tags, \&_render_tags_as_properties, ) for ( $mRNA, ($cds) || () ); # any UTR's, etc associated with this transcript? for my $thing ( @other_stuff ) { if ( $thing->has_tag('standard_name') ) { my ($v) = $thing->get_tag_values('standard_name'); if ( $v eq $sn ) { push @units, $thing; } } } # add the exons push @units, grep { $_->primary_tag eq 'exon' } $mRNA->get_SeqFeatures; @units = sort { $a->start <=> $b->start } @units; my $count = 0; if ( $str < 0 ) { @units = reverse @units; } for my $unit ( @units ) { if ( $unit->primary_tag eq 'exon' ) { my $ename = $id; $ename .= ':' . ++$count; $self->_feature_span($ename, $unit); } elsif ( $unit->primary_tag eq 'start_codon' ) { $self->_feature_span(($sn || $gid), $unit, $self->{curr_pname}); } else { my $uname = $unit->primary_tag . ":$id"; $self->_feature_span($uname, $unit); } } $self->{curr_pname} = ''; $writer->endTag('feature_set'); } $self->{other_stuff} = \@other_stuff; } $writer->endTag('annotation'); # add the protein sequences for ( @{$self->{add_seqs}} ) { my %h = %$_; $writer->startTag(@{$h{header}}); my @desc = split /\s+/, $h{desc}; my $desc = ''; for my $word (@desc) { my ($lastline) = $desc =~ /.*^(.+)$/sm; $lastline ||= ''; $desc .= length $lastline < 50 ? " $word " : "\n $word "; } $self->_element('description', "\n $desc\n "); my $aa = $h{residues}; $aa =~ s/(\w{60})/$1\n /g; $aa =~ s/\n\s+$//m; $aa = "\n " . $aa . "\n "; $self->_element('residues', $aa); $writer->endTag('seq'); $self->{add_seqs} = []; } # Is there anything else associated with the gene? We have to write other # features as stand-alone annotations or apollo will assume they are # transcripts for my $thing ( @{$self->{other_stuff}} ) { next if $thing->has_tag('standard_name'); $self->_write_feature($thing); } $self->{other_stuff} = []; } =head2 _check_cds Title : _check_cds Usage : $self->_check_cds($cds, $name) Function: internal method to check if the CDS associated with an mRNA is the correct alternative splice variant Returns : a Bio::SeqFeature::Generic CDS object Args : the CDS object plus the transcript\'s 'standard_name' Note : this method only works if alternatively spliced transcripts are bound together by a 'standard_name' or 'mRNA' qualifier. If none is present, we will hope that the exons were derived from a segmented RNA or a CDS with no associated mRNA feature. Neither of these two cases would be confounded by alternative splice variants. =cut sub _check_cds { my ($self, $cds, $name) = @_; my $cname = $self->_find_name( $cds, 'standard_name' ) || $self->_find_name( $cds, 'mRNA'); if ( $cname ) { if ( $cname eq $name ) { return $cds; } else { my @CDS = grep { $_->primary_tag eq 'CDS' } @{$self->{feats}}; for ( @CDS ) { my ($sname) = $_->_find_name( $_, 'standard_name' ) || $_->_find_name( $_, $_->primary_tag ); return $_ if $sname eq $name; } return ''; } } else { return $cds; } } =head2 _comp_analysis Usage: Desc : Ret : Args : Side Effects: Example: =cut sub _comp_analysis { my ($self, $feat) = @_; my $writer = $self->{writer}; $writer->startTag('computational_analysis'); $self->_element('program', $feat->program_name || 'unknown program'); $self->_element('database', $feat->database_name) if $feat->database_name; $self->_element('version', $feat->program_version) if $feat->program_version; $self->_element('type', $feat->primary_tag) if $feat->primary_tag; $self->_render_tags($feat, \&_render_date_tags, \&_render_tags_as_properties, ); $self->_comp_result($feat); $writer->endTag('computational_analysis'); } =head2 _comp_result Usage: Desc : recursively render a feature and its subfeatures as <result_set> and <result_span> elements Ret : nothing meaningful Args : a feature =cut sub _comp_result { my ($self,$feat) = @_; #check that all our subfeatures have the same strand #write result sets for things that have subfeatures, or things #that have some tags if( my @subfeats = $feat->get_SeqFeatures or $feat->get_all_tags ) { my $writer = $self->{writer}; $writer->startTag('result_set', ($feat->can('computation_id') && defined($feat->computation_id)) ? (id => $feat->computation_id) : () ); my $fakename = $feat->primary_tag || 'no_name'; $self->_element('name', $feat->display_name || ($fakename).'_'.++$self->{anon_result_set_counters}{$fakename} ); $self->_seq_relationship('query', $feat); $self->_render_tags($feat, \&_render_output_tags ); for (@subfeats) { #render the subfeats, if any $self->_comp_result($_); } $self->_comp_result_span($feat); #also have a span to hold this info $writer->endTag('result_set'); } else { #just write result spans for simple things $self->_comp_result_span($feat); } } =head2 _comp_result_span Usage: _comp_result_span('foo12',$feature); Desc : write GAME XML for a Bio::SeqFeature::Computation feature that has no subfeatures Ret : nothing meaningful Args : name for this span (some kind of identifier), SeqFeature object to put into this span Side Effects: Example: =cut sub _comp_result_span { my ($self, $feat) = @_; my $writer = $self->{writer}; $writer->startTag('result_span', ($feat->can('computation_id') && defined($feat->computation_id) ? (id => $feat->computation_id) : ()) ); $self->_element('name', $feat->display_name) if $feat->display_name; $self->_element('type', $feat->primary_tag) if $feat->primary_tag; my $has_score = $feat->can('has_score') ? $feat->has_score : defined($feat->score); $self->_element('score', $feat->score) if $has_score; $self->_render_tags($feat, \&_render_output_tags ); $self->_seq_relationship('query', $feat); $self->_render_tags($feat, \&_render_target_tags, ); $writer->endTag('result_span'); } =head2 _render_tags Usage: Desc : Ret : Args : Side Effects: Example: =cut sub _render_tags { my ($self,$feat,@render_funcs) = @_; my @tagnames = $feat->get_all_tags; #do a chain-of-responsibility down the allowed #tag handlers types for the context in which this is #called foreach my $func (@render_funcs) { @tagnames = $self->$func($feat,@tagnames); } } =head2 _render_output_tags Usage: Desc : print out <output> elements, with contents taken from the SeqFeature::Computation's 'output' tag Ret : array of tag names this did not render Args : feature object, list of tag names to maybe render In game xml, only <result_span> and <result_set> elements can have <output> elements. =cut sub _render_output_tags { my ($self, $feat, @tagnames) = @_; my $writer = $self->{writer}; my @passed_up; for my $tag (@tagnames) { if(lc($tag) eq 'output') { my @outputs = $feat->get_tag_values($tag); while(my($type,$val) = splice @outputs,0,2) { $writer->startTag('output'); $self->_element('type',$type); $self->_element('value',$val); $writer->endTag('output'); } } else { push @passed_up,$tag; } } return @passed_up; } =head2 _render_tags_as_properties Usage: Desc : Ret : empty array Args : feature object, array of tag names Side Effects: Example: In game xml, <annotation>, <computational_analysis>, and <feature_set> elements can have properties. =cut sub _render_tags_as_properties { my ($self,$feat,@tagnames) = @_; foreach my $tag (@tagnames) { if( $tag ne $feat->primary_tag ) { $self->_property($tag,$_) for $feat->get_tag_values($tag); } } return (); } =head2 _render_comment_tags Usage: Desc : Ret : names of tags that were not comment tags Args : feature object, tag names available for us to render Side Effects: writes XML Example: In game xml, <annotation> and <feature_set> elements can have comments. =cut sub _render_comment_tags { my ($self,$feat,@tagnames) = @_; my $writer = $self->{writer}; my @passed_up; for my $tag ( @tagnames ) { if( lc($tag) eq 'comment' ) { for my $val ($feat->get_tag_values($tag)) { if ( $val =~ /=.+?;.+=/ ) { $self->_unflatten_attribute('comment', $val); } else { $writer->startTag('comment'); $self->_element('text', $val); $writer->endTag('comment'); } } } else { push @passed_up,$tag; } } return @passed_up; } =head2 _render_date_tags Usage: Desc : Ret : names of tags that were not date tags Args : feature, list of tag names available for us to render Side Effects: writes XML for <date> elements Example: In game xml, <annotation>, <computational_analysis>, <transaction>, <comment>, and <feature_set> elements can have <date>s. =cut sub _render_date_tags { my ($self,$feat,@tagnames) = @_; my @passed_up; my $date; my %timestamp; foreach my $tag (@tagnames) { if ( lc($tag) eq 'date' ) { ($date) = $feat->get_tag_values($tag); } elsif ( lc($tag) eq 'timestamp' ) { ($timestamp{'timestamp'}) = $feat->get_tag_values($tag); #ignore timestamps, they are folded in with date elem above } else { push @passed_up,$tag; } } $self->_element('date', $date, \%timestamp) if defined($date); return @passed_up; } =head2 _render_dbxref_tags Desc : look for xref tags and render them if they are there Ret : tag names that we didn't render Args : feature object, list of tag names to render Side Effects: writes a <dbxref> element if a tag with name matching /xref$/i is present In game xml, <annotation> and <seq> elements can have dbxrefs. =cut #TODO: can't sequences also have database xrefs? how to find those? sub _render_dbxref_tags { my ($self, $feat, @tagnames) = @_; my @passed_up; for my $tag ( @tagnames ) { #look through all the tags if( $tag =~ /xref$/i ) { #if they are xref tags my $writer = $self->{writer}; for my $val ( $feat->get_all_tag_values($tag) ) { #get all their values if( my ($db,$dbid) = $val =~ /(\S+):(\S+)/ ) { #and render them as xrefs $writer->startTag('dbxref'); $self->_element('xref_db', $db); $dbid = $val if $db =~ /^[A-Z]O$/; # -> ontology, like GO $self->_element('db_xref_id', $dbid); $writer->endTag('dbxref'); } } } else { push @passed_up,$tag; } } return @passed_up; } =head2 _render_target_tags Usage: Desc : process any 'Target' tags that would indicate a sequence alignment subject Ret : array of tag names that we didn't render Args : feature object Side Effects: writes a <seq_relationship> of type 'subject' if it finds any properly formed tags named 'Target' Example: In game xml, <result_span>, <feature_span>, and <result_set> can have <seq_relationship>s. <result_set> can only have one, a 'query' relation. =cut sub _render_target_tags { my ($self,$feat,@tagnames) = @_; my @passed_up; foreach my $tag (@tagnames) { if($tag eq 'Target' && (my @alignment = $feat->get_tag_values('Target')) >= 3) { $self->_seq_relationship('subject', Bio::Location::Simple->new( -start => $alignment[1], -end => $alignment[2], ), $alignment[0], $alignment[3], ); } else { push @passed_up, $tag; } } return @passed_up; } =head2 _property Title : _property Usage : $self->_property($tag => $value); Function: an internal method to write property XML elements Returns : nothing Args : a tag/value pair =cut sub _property { my ($self, $tag, $val) = @_; my $writer = $self->{writer}; if ( length $val > 45 ) { my @val = split /\s+/, $val; $val = ''; for my $word (@val) { my ($lastline) = $val =~ /.*^(.+)$/sm; $lastline ||= ''; $val .= length $lastline < 45 ? " $word " : "\n $word"; } $val = "\n $val\n "; $val =~ s/(\S)\s{2}(\S)/$1 $2/g; } $writer->startTag('property'); $self->_element('type', $tag); $self->_element('value', $val); $writer->endTag('property'); } =head2 _unflatten_attribute Title : _unflatten_attribute Usage : $self->_unflatten_attribute($name, $value) Function: an internal method to unflatten and write comment or evidence elements Returns : nothing Args : a list of strings =cut sub _unflatten_attribute { my ($self, $name, $val) = @_; my $writer = $self->{writer}; my %pair; my @pairs = split ';', $val; for my $p ( @pairs ) { my @pair = split '=', $p; $pair[0] =~ s/^\s+|\s+$//g; $pair[1] =~ s/^\s+|\s+$//g; $pair{$pair[0]} = $pair[1]; } $writer->startTag($name); for ( keys %pair ) { $self->_element($_, $pair{$_}); } $writer->endTag($name); } =head2 _xref Title : _xref Usage : $self->_xref($value) Function: an internal method to write db_xref elements Returns : nothing Args : a list of strings =cut sub _xref { my ($self, @xrefs) = @_; my $writer = $self->{writer}; for my $xref ( @xrefs ) { my ($db, $acc) = $xref =~ /(\S+):(\S+)/; $writer->startTag('dbxref'); $self->_element('xref_db', $db); $acc = $xref if $db eq 'GO'; $self->_element('db_xref_id', $acc); $writer->endTag('dbxref'); } } =head2 _feature_span Title : _feature_span Usage : $self->_feature_span($name, $type, $loc) Function: an internal method to write a feature_span element (the actual feature with coordinates) Returns : nothing Args : a feature name and Bio::SeqFeatureI-compliant object =cut sub _feature_span { my ($self, $name, $feat, $pname) = @_; my $type = $feat->primary_tag; my $writer = $self->{writer}; my %atts = ( id => $name ); if ( $pname ) { $pname =~ s/-R/-P/; $atts{produces_seq} = $pname; } $writer->startTag('feature_span', %atts ); $self->_element('name', $name); $self->_element('type', $type); $self->_seq_relationship('query', $feat); $writer->endTag('feature_span'); } =head2 _seq_relationship Title : _seq_relationship Usage : $self->_seq_relationship($type, $loc) Function: an internal method to handle feature_span sequence relationships Returns : nothing Args : feature type, a Bio::LocationI-compliant object, (optional) sequence name (defaults to the query seq) and (optional) alignment string =cut sub _seq_relationship { my ($self, $type, $loc, $seqname, $alignment) = @_; my $writer = $self->{'writer'}; $seqname ||= #if no seqname passed in, use the name of our annotating seq $self->{seq}->accession_number ne 'unknown' && $self->{seq}->accession_number || $self->{seq}->display_id || 'unknown'; $writer->startTag( 'seq_relationship', type => $type, seq => $seqname, ); $self->_span($loc); $writer->_element('alignment',$alignment) if $alignment; $writer->endTag('seq_relationship'); } =head2 _element Title : _element Usage : $self->_element($name, $chars, $atts) Function: an internal method to generate 'generic' XML elements Example : my $name = 'foo'; my $content = 'bar'; my $attributes = { baz => 1 }; # print the element $self->_element($name, $content, $attributes); Returns : nothing Args : the element name and content plus a ref to an attribute hash =cut sub _element { my ($self, $name, $chars, $atts) = @_; my $writer = $self->{writer}; my %atts = $atts ? %$atts : (); $writer->startTag($name, %atts); $writer->characters($chars); $writer->endTag($name); } =head2 _span Title : _span Usage : $self->_span($loc) Function: an internal method to write the 'span' element Returns : nothing Args : a Bio::LocationI-compliant object =cut sub _span { my ($self, @loc) = @_; my ($loc, $start, $end); if ( @loc == 1 ) { $loc = $loc[0]; } elsif ( @loc == 2 ) { ($start, $end) = @loc; } if ( $loc ) { ($start, $end) = ($loc->start, $loc->end); ($start, $end) = ($end, $start) if $loc->strand < 0; } elsif ( !$start ) { ($start, $end) = (1, $self->{seq}->length); } my $writer = $self->{writer}; $writer->startTag('span'); $self->_element('start', $start); $self->_element('end', $end); $writer->endTag('span'); } =head2 _seq Title : _seq Usage : $self->_seq($seq, $dna) Function: an internal method to print the 'sequence' element Returns : nothing Args : and Bio::SeqI-compliant object and a reference to an attribute hash =cut sub _seq { my ($self, $seq, $atts) = @_; my $writer = $self->{'writer'}; # game moltypes my $alphabet = $seq->alphabet; $alphabet ||= $seq->mol_type if $seq->can('mol_type'); $alphabet =~ s/protein/aa/; $alphabet =~ s/rna/cdna/; my @seq = ( 'seq', id => $atts->{name}, length => $seq->length, type => $alphabet, focus => "true" ); if ( $atts->{md5checksum} ) { push @seq, (md5checksum => $atts->{md5checksum}); delete $atts->{md5checksum}; } $writer->startTag(@seq); for my $k ( keys %{$atts} ) { if ( $k =~ /xref/ ) { $self->_xref($atts->{$k}); } else { $self->_element($k, $atts->{$k}); } } # add leading spaces and line breaks for # nicer xml formatting/indentation my $sp = (' ' x 6); my $dna = $seq->seq; $dna =~ s/(\w{60})/$1\n$sp/g; $dna = "\n$sp" . $dna . "\n "; if ( $seq->species && !$self->{has_organism}) { my $species = $seq->species->binomial; $self->_element('organism', $species); } $self->_element('residues', $dna); $writer->endTag('seq'); } =head2 _find_name Title : _find_name Usage : my $name = $self->_find_name($feature) Function: an internal method to look for a gene name Returns : a string Args : a Bio::SeqFeatureI-compliant object =cut sub _find_name { my ($self, $feat, $key) = @_; my $name; if ( $key && $feat->has_tag($key) ) { ($name) = $feat->get_tag_values($key); return $name; } else { # warn "Could not find name '$key'\n"; return ''; } } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/game/seqHandler.pm��������������������������������������������������������000444��000765��000024�� 33760�12254227330� 20513� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::game::seqHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::game::seqHandler -- a class for handling game-XML sequences =head1 SYNOPSIS This modules is not used directly =head1 DESCRIPTION Bio::SeqIO::game::seqHandler processes all of the sequences associated with a game record and, via feature handlers, processes the associated annotations =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::game::seqHandler; use Data::Dumper; use Bio::SeqIO::game::featHandler; use Bio::SeqFeature::Generic; use Bio::Seq::RichSeq; use Bio::Species; use strict; use vars qw {}; use base qw(Bio::SeqIO::game::gameSubs); =head2 new Title : new Usage : my $seqHandler = Bio::SeqIO::game::seqHandler->new($seq, $ann, $comp, $map, $src ) Function: constructor method to create a sequence handler Returns : a sequence handler object Args : $seq -- an XML sequence element $ann -- a ref. to a list of <annotation> elements $comp -- a ref. to a list of <computational_analysis> elements (not used yet) $map -- a <map_position> element $src -- a flag to indicate that the sequence already has a source feature =cut sub new { my ($caller, $seq, $ann, $comp, $map, $src ) = @_; my $class = ref($caller) || $caller; my $self = bless ( { seqs => $seq, anns => $ann, comps => $comp, map_pos => $map, has_source => $src, seq_h => {}, ann_l => [] }, $class ); return $self; } =head2 convert Title : convert Usage : @seqs = $seqHandler->convert Function: converts the main XML sequence element and associated annotations to Bio:: Returns : a ref. to a an array containing the sequence object and a ref. to a list of features Args : none Note : The features and sequence are kept apart to facilitate downstream filtering of features =cut sub convert { my $self = shift; my @ann = @{$self->{anns}} if defined $self->{anns};; my @seq = @{$self->{seqs}}; # not used yet my @comp; if ( $self->{comps} ) { @comp = @{$self->{comps}} } # process the sequence elements for ( @seq ) { $self->_add_seq( $_ ); } # process the annotation elements for ( @ann ) { $self->_annotation( $_ ); } return $self->_order_feats( $self->{seq_h} ); } =head2 _order_feats Title : _order_feats Usage : $self->_order_feats( $self->{seq_h} ) Function: an internal method to ensure the source feature comes first and keep gene, mRNA and CDS features together Returns : a ref. to an array containing the sequence object and a ref. to a list of features Args : a ref. to a hash of sequences =cut sub _order_feats { my ($self, $seqs) = @_; my $seq = $self->{main_seq}; my $id = $seq->id; my $ann = $self->{ann_l}; # make sure source(s) come first my @src = grep { $_->primary_tag =~ /source|origin|\bregion\b/ } @$ann; # preserve gene->mRNA->CDS or ncRNA->gene->transcript order my @genes = grep { $_->primary_tag =~ /gene|CDS|[a-z]+RNA|transcript/ } @$ann; my @other = sort { $a->start <=> $b->start || $b->end <=> $a->end } grep { $_->primary_tag !~ /source|origin|\bregion\b/ } grep { $_->primary_tag !~ /gene|mRNA|CDS/ } @$ann; return [$seq, [@src, @genes, @other]]; } =head2 _add_seq Title : _add_seq Usage : $self->_add_seq($seq_element) Function: an internal method to process the sequence elements Returns : nothing Args : a sequence element =cut sub _add_seq { my ($self, $el) = @_; my $residues = ''; if ($el->{_residues}) { $residues = $el->{_residues}->{Characters}; $residues =~ s/[ \n\r]//g; $residues =~ s/\!//g; $residues =~ tr/a-z/A-Z/; } else { return 0; } my $id = $el->{Attributes}->{id}; my $ver = $el->{Attributes}->{version}; my $name = $el->{_name}->{Characters}; if ($name && $name ne $id) { $self->complain("The sequence name and unique ID do not match. Using ID"); } # get/set the sequence object my $seq = $self->_seq($id); # get/set the feature handler my $featHandler = $self->_feat_handler; # populate the sequence object $seq->seq($residues); $seq->seq_version($ver) if $ver; # assume the id is the accession number if ( $id =~ /^\w+$/ ) { $seq->accession($id); } # If the focus attribute is set to "true", this is the main # sequence my $focus = 0; if ( defined $el->{Attributes}->{focus} ) { $self->{main_seq} = $seq; $focus++; } # make sure real and annotated lengths match my $length = $el->{Attributes}->{'length'}; $length && $seq->length(int($length)); if ( $seq->seq && defined($length) && $seq->length != int($length) ) { $self->complain("The specified sequence has length ", $seq->length(), " but the length attribute= ", $length); $seq->seq( undef ); $seq->length( int($length) ); } # deal with top-level annotations my $tags = {}; if ( $el->{Attributes}->{md5checksum} ) { $tags->{md5checksum} = [$el->{Attributes}->{md5checksum}]; } if ($el->{_dbxref}) { $tags->{dbxref} ||= []; push @{$tags->{dbxref}}, $self->dbxref( $el->{_dbxref} ); } if ($el->{_description}) { my $desc = $el->{_description}->{Characters}; $seq->description( $desc ); } if ($el->{_organism}) { my @organism = split /\s+/, $el->{_organism}->{Characters}; if (@organism < 2) { $self->complain("Species name should have at least two words"); } else { my $species = Bio::Species->new( -classification => [reverse @organism] ); $seq->species($species); } } if ( defined($seq->species) ) { $tags->{organism} = [$seq->species->binomial]; } # elsif ($seq eq $self->{main_seq}) { # $self->warn("The source organism for this sequence was\n" . # "not specified. I will guess Drosophila melanogaster.\n" . # "Otherwise, add <organism>Genus species</organism>\n" . # "to the main sequence element"); # my @class = qw/ Eukaryota Metazoa Arthropoda Insecta Pterygota # Neoptera Endopterygota Diptera Brachycera # Muscomorpha Ephydroidea Drosophilidae Drosophila melanogaster/; # my $species = Bio::Species->new( -classification => [ reverse @class ], # -common_name => 'fruit fly' ); # $seq->species( $species ); # } # convert GAME to bioperl molecule types my $alphabet = $el->{Attributes}->{type}; if ( $alphabet ) { $alphabet =~ s/aa/protein/; $alphabet =~ s/cdna/rna/; $seq->alphabet($alphabet); } # add a source feature if req'd if ( !$self->{has_source} && $focus ) { #$self->{source} = $featHandler->add_source($seq->length, $tags); } if ( $focus ) { # add the map position $self->_map_position( $self->{map_pos}, $seq ); $featHandler->{offset} = $self->{offset}; } # prune the sequence from the parse tree $self->flush; } =head2 _map_position Title : _map_position Usage : $self->_map_position($map_posn_element) Function: an internal method to process the <map_position> element Returns : nothing Args : a map_position element =cut sub _map_position { my ($self, $el) = @_; # we can live without it if ( !$el ) { $self->{offset}= 0; return 0; } # chromosome and coordinates my $arm = $el->{_arm}->{Characters}; my $type = $el->{Attributes}->{type}; my $loc = $el->{_span}; my $start = $loc->{_start}->{Characters}; my $end = $loc->{_end}->{Characters}; # define the offset (may be a partial sequence) # The coordinates will be relative but the CDS description # coordinates may be absolute if the game-XML comes from apollo # or gadfly $self->{offset} = $start - 1; my $seq_id = $el->{Attributes}->{seq}; my $seq = $self->{seq_h}->{$seq_id}; unless ( $seq ) { $self->throw("Map position with no corresponding sequence object"); } unless ($seq eq $self->{main_seq}){ $self->throw("Map position does not correspond to the main sequence"); } my $species = ''; # create/update the top-level sequence feature if req'd if ( $self->{source} ) { my $feat = $self->{source}; unless ($feat->has_tag('organism')) { $species = eval {$seq->species->binomial} || 'unknown species'; $feat->add_tag_value( organism => $species ); } my %tags = ( mol_type => "genomic dna", chromosome => $arm, location => "$start..$end", type => $type ); for (keys %tags) { $feat->add_tag_value( $_ => $tags{$_} ); } $seq->add_SeqFeature($feat); } # come up with a description if there is none my $desc = $seq->description; if ( $species && $arm && $start && $end && !$desc) { $seq->description("$species chromosome $arm $start..$end " . "segment of complete sequence"); } $self->flush; } =head2 _annotation Title : _annotation Usage : $self->_annotation($annotation_element) Function: an internal method to process <annotation> elements Returns : nothing Args : an annotation element =cut sub _annotation { my ($self, $el) = @_; my $id = $el->{Attributes}->{id}; my $type = $el->{_type}->{Characters}; my $tags = {}; my $gname = $el->{_name}->{Characters} eq $id ? '' : $el->{_name}->{Characters}; # 'transposable element' is too long (breaks Bio::SeqIO::GenBank) # $type =~ s/transposable_element/repeat_region/; # annotations must be on the main sequence my $seqid = $self->{main_seq}->id; my $featHandler = $self->_feat_handler; my @feats = (); for my $child ( @{$el->{Children}} ) { my $name = $child->{Name}; # these elements require special handling if ( $name eq 'dbxref' ) { $tags->{dbxref} ||= []; push @{$tags->{dbxref}}, $self->dbxref( $child ); } elsif ( $name eq 'aspect' ) { $tags->{dbxref} ||= []; push @{$tags->{dbxref}}, $self->dbxref( $child->{_dbxref} ); } elsif ( $name eq 'feature_set' ) { push @feats, $featHandler->feature_set( $id, $gname, $child, $type ); } elsif ( $name eq 'comment' ) { $tags->{comment} = [$self->comment( $child )]; } elsif ( $name eq 'property' ) { $self->property( $child, $tags ); } elsif ( $name eq 'gene' ) { # we may be dealing with an annotation that is not # a gene, so we have to nest the gene inside it $featHandler->has_gene( $child, $gname, $id ) } # otherwise, tag/value pairs # -- mild dtd enforcement # synonym is not in the dtd but shows up in gadfly # annotations elsif ( $name =~ /type|synonym/ ) { $tags->{$name} = [$child->{Characters}]; } elsif ( $name ne 'name' ) { $self->complain("Unrecognized element '$name'. I don't " . "know what to do with $name elements in " . "top-level sequence annotations." ); } } # add a gene annotation if required unless ( $featHandler->has_gene || $type ne 'gene' ) { $featHandler->has_gene( $el, $gname, $id ) } if ( $tags->{symbol} ) { if ( !$tags->{gene} ) { $tags->{gene} = $tags->{symbol}; } delete $tags->{symbol}; } $featHandler->add_annotation( $self->{main_seq}, $type, $id, $tags, \@feats ); $self->flush; } # get/set the sequence object =head2 _seq Title : _seq Usage : my $seq = $self->_seq Function: an internal sequence getter/setter Returns : a Bio::RichSeq object Args : a sequence ID =cut sub _seq { my ($self, $id) = @_; $id || $self->throw("A unique id must be provided for the sequence"); my $seq = {}; if ( defined $self->{seq_h}->{$id}) { $seq = $self->{seq_h}->{$id}; } else { $seq = Bio::Seq::RichSeq->new( -id => $id ); $self->{seq_h}->{$id} = $seq; # store it } return $seq; } #get/set the feature handler =head2 _feat_handler Title : _feat_handler Usage : my $featHandler = $self->_featHandler Function: an internal getter/setter for feature handling objects Returns : a Bio::SeqIO::game::featHandler object Args : none =cut sub _feat_handler { my $self = shift; my $handler = {}; my $seq = $self->{main_seq}; if ( defined $self->{feat_handler} ) { $handler = $self->{feat_handler}; } else { my @args = ( $seq, $self->{seq_h}, $self->{ann_l} ); $handler = Bio::SeqIO::game::featHandler->new( @args ); $self->{feat_handler} = $handler; } return $handler; } 1; ����������������BioPerl-1.6.923/Bio/SeqIO/Handler�������������������������������������������������������������������000755��000765��000024�� 0�12254227325� 16351� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/Handler/GenericRichSeqHandler.pm������������������������������������������000444��000765��000024�� 114117�12254227325� 23242� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::SeqIO::Handler::GenericRichSeqHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Fields # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::Handler::GenericRichSeqHandler - Bio::HandlerI-based data handler for GenBank/EMBL/UniProt (and other) sequence data =head1 SYNOPSIS # MyHandler is a GenericRichSeqHandler object. # inside a parser (driver) constructor.... $self->seq_handler($handler || MyHandler->new(-format => 'genbank')); # in next_seq() in driver... $hobj = $self->seqhandler(); # roll data up into hashref chunks, pass off into Handler for processing... $hobj->data_handler($data); # or retrieve Handler methods and pass data directly to Handler methods... my $hmeth = $hobj->handler_methods; if ($hmeth->{ $data->{NAME} }) { my $mth = $hmeth->{ $data->{NAME} }; $hobj->$mth($data); } =head1 DESCRIPTION This is an experimental implementation of a sequence-based HandlerBaseI parser and may change over time. It is possible (nay, likely) that the way handler methods are set up will change over development to allow more flexibility. Release pumpkins, please do not add this to a release until the API has settled. It is also likely that write_seq() will not work properly for some data. Standard Developer caveats: Do not use for production purposes. Not responsible for destroying (your data|computer|world). Do not stare directly at GenericRichSeqHandler. If GenericRichSeqHandler glows, back slowly away and call for help. Consider yourself warned! This class acts as a demonstration on how to handle similar data chunks derived from Bio::SeqIO::gbdriver, Bio::SeqIO::embldriver, and Bio::SeqIO::swissdriver using similar (or the same) handler methods. The modules currently pass all previous tests in t/genbank.t, t/embl.t, and t/swiss.t yet all use the same handler methods (the collected tests for handlers can be found in t/Handler.t). Some tweaking of the methods themselves is probably in order over the long run to ensure that data is consistently handled for each parser. Round-trip tests are probably in order here... Though a Bio::Seq::SeqBuilder is employed for building sequence objects no bypassing of data based on builder slots has been implemented (yet); this is planned in the near future. As a reminder: this is the current Annotation data chunk (via Data::Dumper): $VAR1 = { 'NAME' => 'REFERENCE', 'DATA' => '1 (bases 1 to 10001)' 'AUTHORS' => 'International Human Genome Sequencing Consortium.' 'TITLE' => 'The DNA sequence of Homo sapiens' 'JOURNAL' => 'Unpublished (2003)' }; ... This is the current SeqFeature data chunk (again via Data::Dumper): $VAR1 = { 'mol_type' => 'genomic DNA', 'LOCATION' => '<1..>10001', 'NAME' => 'FEATURES', 'FEATURE_KEY' => 'source', 'note' => 'Accession AL451081 sequenced by The Sanger Centre', 'db_xref' => 'taxon:9606', 'clone' => 'RP11-302I18', 'organism' => 'Homo sapiens' }; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::SeqIO::Handler::GenericRichSeqHandler; use strict; use warnings; use Bio::SeqIO::FTHelper; use Bio::Annotation::Collection; use Bio::Annotation::DBLink; use Bio::Annotation::Comment; use Bio::Annotation::Reference; use Bio::Annotation::Collection; use Bio::Annotation::SimpleValue; use Bio::Annotation::TagTree; use Bio::SeqFeature::Generic; use Bio::Species; use Bio::Taxon; use Bio::DB::Taxonomy; use Bio::Factory::FTLocationFactory; use Data::Dumper; use base qw(Bio::Root::Root Bio::HandlerBaseI); my %HANDLERS = ( 'genbank' => { 'LOCUS' => \&_genbank_locus, 'DEFINITION' => \&_generic_description, 'ACCESSION' => \&_generic_accession, 'VERSION' => \&_generic_version, 'KEYWORDS' => \&_generic_keywords, 'DBSOURCE' => \&_genbank_dbsource, 'DBLINK' => \&_genbank_dbsource, 'SOURCE' => \&_generic_species, 'REFERENCE' => \&_generic_reference, 'COMMENT' => \&_generic_comment, 'FEATURES' => \&_generic_seqfeatures, 'BASE' => \&noop, # this is generated from scratch 'ORIGIN' => \&_generic_seq, # handles anything else (WGS, WGS_SCAFLD, CONTIG, PROJECT) '_DEFAULT_' => \&_generic_simplevalue, }, 'embl' => { 'ID' => \&_embl_id, 'DT' => \&_embl_date, 'DR' => \&_generic_dbsource, 'SV' => \&_generic_version, 'RN' => \&_generic_reference, 'KW' => \&_generic_keywords, 'DE' => \&_generic_description, 'AC' => \&_generic_accession, #'AH' => \&noop, # TPA data not dealt with yet... #'AS' => \&noop, 'SQ' => \&_generic_seq, 'OS' => \&_generic_species, 'CC' => \&_generic_comment, 'FT' => \&_generic_seqfeatures, # handles anything else (WGS, TPA, ANN...) '_DEFAULT_' => \&_generic_simplevalue, }, 'swiss' => { 'ID' => \&_swiss_id, 'DT' => \&_swiss_date, 'GN' => \&_swiss_genename, 'DR' => \&_generic_dbsource, 'RN' => \&_generic_reference, 'KW' => \&_generic_keywords, 'DE' => \&_generic_description, 'AC' => \&_generic_accession, 'SQ' => \&_generic_seq, 'OS' => \&_generic_species, 'CC' => \&_generic_comment, 'FT' => \&_generic_seqfeatures, # handles anything else, though I don't know what... '_DEFAULT_' => \&_generic_simplevalue, }, ); # can we do this generically? Seems like a lot of trouble... my %DBSOURCE = map {$_ => 1} qw( EchoBASE IntAct SWISS-2DPAGE ECO2DBASE ECOGENE TIGRFAMs TIGR GO InterPro Pfam PROSITE SGD GermOnline HSSP PhosSite Ensembl RGD AGD ArrayExpress KEGG H-InvDB HGNC LinkHub PANTHER PRINTS SMART SMR MGI MIM RZPD-ProtExp ProDom MEROPS TRANSFAC Reactome UniGene GlycoSuiteDB PIRSF HSC-2DPAGE PHCI-2DPAGE PMMA-2DPAGE Siena-2DPAGE Rat-heart-2DPAGE Aarhus/Ghent-2DPAGE Biocyc MetaCyc Biocyc:Metacyc GenomeReviews FlyBase TMHOBP COMPLUYEAST-2DPAGE OGP DictyBase HAMAP PhotoList Gramene WormBase WormPep Genew ZFIN PeroxiBase MaizeDB TAIR DrugBank REBASE HPA swissprot GenBank GenPept REFSEQ embl PDB UniProtKB); my %NOPROCESS = map {$_ => 1} qw(DBSOURCE ORGANISM FEATURES); our %VALID_ALPHABET = ( 'bp' => 'dna', 'aa' => 'protein', 'rc' => '' # rc = release candidate; file has no sequences ); =head2 new Title : new Usage : Function: Returns : Args : -format Sequence format to be mapped for handler methods -builder Bio::Seq::SeqBuilder object (normally defined in SequenceStreamI object implementation constructor) Throws : On undefined '-format' sequence format parameter Note : Still under heavy development =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self = {@args}; bless $self,$class; my ($format, $builder) = $self->_rearrange([qw(FORMAT BUILDER)], @args); $self->throw("Must define sequence record format") if !$format; $self->format($format); $self->handler_methods(); $builder && $self->seqbuilder($builder); $self->location_factory(); return $self; } =head1 L<Bio::HandlerBaseI> implementing methods =head2 handler_methods Title : handler_methods Usage : $handler->handler_methods('GenBank') %handlers = $handler->handler_methods(); Function: Retrieve the handler methods used for the current format() in the handler. This assumes the handler methods are already described in the HandlerI-implementing class. Returns : a hash reference with the data type handled and the code ref associated with it. Args : [optional] String representing the sequence format. If set here this will also set sequence_format() Throws : On unimplemented sequence format in %HANDLERS =cut sub handler_methods { my $self = shift; if (!($self->{'handlers'})) { $self->throw("No handlers defined for seqformat ",$self->format) unless exists $HANDLERS{$self->format}; $self->{'handlers'} = $HANDLERS{$self->format}; } return ($self->{'handlers'}); } =head2 data_handler Title : data_handler Usage : $handler->data_handler($data) Function: Centralized method which accepts all data chunks, then distributes to the appropriate methods for processing based on the chunk name from within the HandlerBaseI object. One can also use Returns : None Args : an hash ref containing a data chunk. =cut sub data_handler { my ($self, $data) = @_; my $nm = $data->{NAME} || $self->throw("No name tag defined!"); # this should handle data on the fly w/o caching; any caching should be # done in the driver! my $method = (exists $self->{'handlers'}->{$nm}) ? ($self->{'handlers'}->{$nm}) : (exists $self->{'handlers'}->{'_DEFAULT_'}) ? ($self->{'handlers'}->{'_DEFAULT_'}) : undef; if (!$method) { $self->debug("No handler defined for $nm\n"); return; }; $self->$method($data); } =head2 reset_parameters Title : reset_parameters Usage : $handler->reset_parameters() Function: Resets the internal cache of data (normally object parameters for a builder or factory) Returns : None Args : None =cut sub reset_parameters { my $self = shift; $self->{'_params'} = undef; } =head2 format Title : format Usage : $handler->format('GenBank') Function: Get/Set the format for the report/record being parsed. This can be used to set handlers in classes which are capable of processing similar data chunks from multiple driver modules. Returns : String with the sequence format Args : [optional] String with the sequence format Note : The format may be used to set the handlers (as in the current GenericRichSeqHandler implementation) =cut sub format { my $self = shift; return $self->{'_seqformat'} = lc shift if @_; return $self->{'_seqformat'}; } =head2 get_params Title : get_params Usage : $handler->get_params('-species') Function: Convenience method used to retrieve the specified parameters from the internal parameter cache Returns : Hash ref containing parameters requested and data as key-value pairs. Note that some parameter values may be objects, arrays, etc. Args : List (array) representing the parameters requested =cut sub get_params { my ($self, @ids) = @_; my %data; for my $id (@ids) { if (!index($id, '-')==0) { $id = '-'.$id ; } $data{$id} = $self->{'_params'}->{$id} if (exists $self->{'_params'}->{$id}); } return \%data; } =head2 set_params Title : set_params Usage : $handler->set_param({'-species') Function: Convenience method used to set specific parameters Returns : None Args : Hash ref containing the data to be passed as key-value pairs =cut sub set_params { shift->throw('Not implemented yet!'); } =head1 Methods unique to this implementation =head2 seqbuilder Title : seqbuilder Usage : Function: Returns : Args : Throws : Note : =cut sub seqbuilder { my $self = shift; return $self->{'_seqbuilder'} = shift if @_; return $self->{'_seqbuilder'}; } =head2 build_sequence Title : build_sequence Usage : Function: Returns : Args : Throws : Note : =cut sub build_sequence { my $self = shift; my $builder = $self->seqbuilder(); my $seq; if (defined($self->{'_params'})) { $builder->add_slot_value(%{ $self->{'_params'} }); $seq = $builder->make_object(); $self->reset_parameters; } return $seq if $seq; return 0; } =head2 location_factory Title : location_factory Usage : Function: Returns : Args : Throws : Note : =cut sub location_factory { my ($self, $factory) = @_; if ($factory) { $self->throw("Must have a Bio::Factory::LocationFactoryI when ". "explicitly setting factory()") unless (ref($factory) && $factory->isa('Bio::Factory::LocationFactoryI')); $self->{'_locfactory'} = $factory; } elsif (!defined($self->{'_locfactory'})) { $self->{'_locfactory'} = Bio::Factory::FTLocationFactory->new() } return $self->{'_locfactory'}; } =head2 annotation_collection Title : annotation_collection Usage : Function: Returns : Args : Throws : Note : =cut sub annotation_collection { my ($self, $coll) = @_; if ($coll) { $self->throw("Must have Bio::AnnotationCollectionI ". "when explicitly setting collection()") unless (ref($coll) && $coll->isa('Bio::AnnotationCollectionI')); $self->{'_params'}->{'-annotation'} = $coll; } elsif (!exists($self->{'_params'}->{'-annotation'})) { $self->{'_params'}->{'-annotation'} = Bio::Annotation::Collection->new() } return $self->{'_params'}->{'-annotation'}; } ####################### SEQUENCE HANDLERS ####################### # any sequence data sub _generic_seq { my ($self, $data) = @_; $self->{'_params'}->{'-seq'} = $data->{DATA}; } ####################### RAW DATA HANDLERS ####################### # GenBank LOCUS line sub _genbank_locus { my ($self, $data) = @_; my (@tokens) = split m{\s+}, $data->{DATA}; my $display_id = shift @tokens; $self->{'_params'}->{'-display_id'} = $display_id; my $seqlength = shift @tokens; if (exists $VALID_ALPHABET{$seqlength}) { # moved one token too far. No locus name? $self->warn("Bad LOCUS name? Changing [".$self->{'_params'}->{'-display_id'}. "] to 'unknown' and length to ".$self->{'_params'}->{'-display_id'}); $self->{'_params'}->{'-length'} = $self->{'_params'}->{'-display_id'}; $self->{'_params'}->{'-display_id'} = 'unknown'; # add token back... unshift @tokens, $seqlength; } else { $self->{'_params'}->{'-length'} = $seqlength; } my $alphabet = lc(shift @tokens); $self->{'_params'}->{'-alphabet'} = (exists $VALID_ALPHABET{$alphabet}) ? $VALID_ALPHABET{$alphabet} : $self->warn("Unknown alphabet: $alphabet"); if (($self->{'_params'}->{'-alphabet'} eq 'dna') || (@tokens > 2)) { $self->{'_params'}->{'-molecule'} = shift(@tokens); my $circ = shift(@tokens); if ($circ eq 'circular') { $self->{'_params'}->{'-is_circular'} = 1; $self->{'_params'}->{'-division'} = shift(@tokens); } else { # 'linear' or 'circular' may actually be omitted altogether $self->{'_params'}->{'-division'} = (CORE::length($circ) == 3 ) ? $circ : shift(@tokens); } } else { $self->{'_params'}->{'-molecule'} = 'PRT' if($self->{'_params'}->{'-alphabet'} eq 'aa'); $self->{'_params'}->{'-division'} = shift(@tokens); } my $date = join(' ', @tokens); # maybe use Date::Time for dates? if($date && $date =~ s{\s*((\d{1,2})-(\w{3})-(\d{2,4})).*}{$1}) { if( length($date) < 11 ) { # improperly formatted date # But we'll be nice and fix it for them my ($d,$m,$y) = ($2,$3,$4); if( length($d) == 1 ) { $d = "0$d"; } # guess the century here if( length($y) == 2 ) { if( $y > 60 ) { # arbitrarily guess that '60' means 1960 $y = "19$y"; } else { $y = "20$y"; } $self->warn("Date was malformed, guessing the century for $date to be $y\n"); } $self->{'_params'}->{'-dates'} = [join('-',$d,$m,$y)]; } else { $self->{'_params'}->{'-dates'} = [$date]; } } } # EMBL ID line sub _embl_id { my ($self, $data) = @_; my $alphabet; my ($name, $sv, $topology, $mol, $div); my $line = $data->{DATA}; #$self->debug("$line\n"); my ($idtype) = $line =~ tr/;/;/; if ( $idtype == 6) { # New style headers contain exactly six semicolons. # New style header (EMBL Release >= 87, after June 2006) my $topology; my $sv; # ID DQ299383; SV 1; linear; mRNA; STD; MAM; 431 BP. # This regexp comes from the new2old.pl conversion script, from EBI if ($line =~ m/^(\w+);\s+SV (\d+); (\w+); ([^;]+); (\w{3}); (\w{3}); (\d+) \w{2}\./) { ($name, $sv, $topology, $mol, $div) = ($1, $2, $3, $4, $6); } else { $self->throw("Unrecognized EMBL ID line:[$line]"); } if (defined($sv)) { $self->{'_params'}->{'-seq_version'} = $sv; $self->{'_params'}->{'-version'} = $sv; } if ($topology eq "circular") { $self->{'_params'}->{'-is_circular'} = 1; } if (defined $mol ) { if ($mol =~ /DNA/) { $alphabet='dna'; } elsif ($mol =~ /RNA/) { $alphabet='rna'; } elsif ($mol =~ /AA/) { $alphabet='protein'; } } } elsif ($idtype) { # has internal ';' # Old style header (EMBL Release < 87, before June 2006) if ($line =~ m{^(\S+)[^;]*;\s+(\S+)[^;]*;\s+(\S+)[^;]*;}) { ($name, $mol, $div) = ($1, $2, $3); #$self->debug("[$name][$mol][$div]"); } if($mol) { if ( $mol =~ m{circular} ) { $self->{'_params'}->{'-is_circular'} = 1; $mol =~ s{circular }{}; } if (defined $mol ) { if ($mol =~ /DNA/) { $alphabet='dna'; } elsif ($mol =~ /RNA/) { $alphabet='rna'; } elsif ($mol =~ /AA/) { $alphabet='protein'; } } } } else { $name = $data->{DATA}; } unless( defined $name && length($name) ) { $name = "unknown_id"; } $self->{'_params'}->{'-display_id'} = $name; $self->{'_params'}->{'-alphabet'} = $alphabet; $self->{'_params'}->{'-division'} = $div if $div; $self->{'_params'}->{'-molecule'} = $mol if $mol; } # UniProt/SwissProt ID line sub _swiss_id { my ($self, $data) = @_; my ($name, $seq_div); if($data->{DATA} =~ m{^ (\S+) \s+ # $1 entryname ([^\s;]+); \s+ # $2 DataClass (?:PRT;)? \s+ # Molecule Type (optional) [0-9]+[ ]AA \. # Sequencelength (capture?) $ }ox ) { ($name, $seq_div) = ($1, $2); $self->{'_params'}->{'-namespace'} = ($seq_div eq 'Reviewed' || $seq_div eq 'STANDARD') ? 'Swiss-Prot' : ($seq_div eq 'Unreviewed' || $seq_div eq 'PRELIMINARY') ? 'TrEMBL' : $seq_div; # we shouldn't be setting the division, but for now... my ($junk, $division) = split q(_), $name; $self->{'_params'}->{'-division'} = $division; $self->{'_params'}->{'-alphabet'} = 'protein'; # this is important to have the id for display in e.g. FTHelper, otherwise # you won't know which entry caused an error $self->{'_params'}->{'-display_id'} = $name; } else { $self->throw("Unrecognized UniProt/SwissProt ID line:[".$data->{DATA}."]"); } } # UniProt/SwissProt GN line sub _swiss_genename { my ($self, $data) = @_; #$self->debug(Dumper($data)); my $genename = $data->{DATA}; my $gn; if ($genename) { my @stags; if ($genename =~ /\w=\w/) { # new format (e.g., Name=RCHY1; Synonyms=ZNF363, CHIMP) for my $n (split(m{\s+and\s+},$genename)) { my @genenames; for my $section (split(m{\s*;\s*},$n)) { my ($tag, $rest) = split("=",$section); $rest ||= ''; for my $val (split(m{\s*,\s*},$rest)) { push @genenames, [$tag => $val]; } } push @stags, ['gene_name' => \@genenames]; } } else { # old format for my $section (split(/ AND /, $genename)) { my @genenames; $section =~ s/[\(\)\.]//g; my @names = split(m{\s+OR\s+}, $section); push @genenames, ['Name' => shift @names]; push @genenames, map {['Synonyms' => $_]} @names; push @stags, ['gene_name' => \@genenames] } } #use Data::Dumper; print Dumper $gn, $genename;# exit; my $gn = Bio::Annotation::TagTree->new(-tagname => 'gene_name', -value => ['gene_names' => \@stags]); $self->annotation_collection->add_Annotation('gene_name', $gn); } } # GenBank VERSION line # old EMBL SV line (now obsolete) # UniProt/SwissProt? sub _generic_version { my ($self, $data) = @_; my ($acc,$gi) = split(' ',$data->{DATA}); if($acc =~ m{^\w+\.(\d+)}xmso) { $self->{'_params'}->{'-version'} = $1; $self->{'_params'}->{'-seq_version'} = $1; } if($gi && (index($gi,"GI:") == 0)) { $self->{'_params'}->{'-primary_id'} = substr($gi,3); } } # EMBL DT lines sub _embl_date { my ($self, $data) = @_; while ($data->{DATA} =~ m{(\S+)\s\((.*?)\)}g) { my ($date, $version) = ($1, $2); $date =~ tr{,}{}d; # remove comma if new version if ($version =~ m{\(Rel\.\s(\d+),\sCreated\)}xmso ) { my $release = Bio::Annotation::SimpleValue->new( -tagname => 'creation_release', -value => $1 ); $self->annotation_collection->add_Annotation($release); } elsif ($version =~ m{\(Rel\.\s(\d+),\sLast\supdated,\sVersion\s(\d+)\)}xmso ) { my $release = Bio::Annotation::SimpleValue->new( -tagname => 'update_release', -value => $1 ); $self->annotation_collection->add_Annotation($release); my $update = Bio::Annotation::SimpleValue->new( -tagname => 'update_version', -value => $2 ); $self->annotation_collection->add_Annotation($update); } push @{ $self->{'_params'}->{'-dates'} }, $date; } } # UniProt/SwissProt DT lines sub _swiss_date { my ($self, $data) = @_; # swissprot my @dls = split m{\n}, $data->{DATA}; for my $dl (@dls) { my ($date, $version) = split(' ', $dl, 2); $date =~ tr{,}{}d; # remove comma if new version if ($version =~ m{\(Rel\. (\d+), Last sequence update\)} || # old $version =~ m{sequence version (\d+)\.}) { #new my $update = Bio::Annotation::SimpleValue->new( -tagname => 'seq_update', -value => $1 ); $self->annotation_collection->add_Annotation($update); } elsif ($version =~ m{\(Rel\. (\d+), Last annotation update\)} || #old $version =~ m{entry version (\d+)\.}) { #new $self->{'_params'}->{'-version'} = $1; $self->{'_params'}->{'-seq_version'} = $1; } push @{ $self->{'_params'}->{'-dates'} }, $date; } } # GenBank KEYWORDS line # EMBL KW line # UniProt/SwissProt KW line sub _generic_keywords { my ($self, $data) = @_; $data->{DATA} =~ s{\.$}{}; my @kw = split m{\s*\;\s*}xo ,$data->{DATA}; $self->{'_params'}->{'-keywords'} = \@kw; } # GenBank DEFINITION line # EMBL DE line # UniProt/SwissProt DE line sub _generic_description { my ($self, $data) = @_; $self->{'_params'}->{'-desc'} = $data->{DATA}; } # GenBank ACCESSION line # EMBL AC line # UniProt/SwissProt AC line sub _generic_accession { my ($self, $data) = @_; my @accs = split m{[\s;]+}, $data->{DATA}; $self->{'_params'}->{'-accession_number'} = shift @accs; $self->{'_params'}->{'-secondary_accessions'} = \@accs if @accs; } ####################### SPECIES HANDLERS ####################### # uses Bio::Species # GenBank SOURCE, ORGANISM lines # EMBL O* lines # UniProt/SwissProt O* lines sub _generic_species { my ($self, $data) = @_; my $seqformat = $self->format; # if data is coming in from GenBank parser... if ($seqformat eq 'genbank' && $data->{ORGANISM} =~ m{(.+?)\s(\S+;[^\n\.]+)}ox) { ($data->{ORGANISM}, $data->{CLASSIFICATION}) = ($1, $2); } # SwissProt stuff... # hybrid names in swissprot files are no longer valid per intergration into # UniProt. Files containing these have been split into separate entries, so # it is probably a good idea to update if one has these lingering around... my $taxid; if ($seqformat eq 'swiss') { if ($data->{DATA} =~ m{^([^,]+)}ox) { $data->{DATA} = $1; } if ($data->{CROSSREF} && $data->{CROSSREF} =~ m{NCBI_TaxID=(\d+)}) { $taxid = $1; } } my ($sl, $class, $sci_name) = ($data->{DATA}, $data->{CLASSIFICATION}, $data->{ORGANISM} || ''); my ($organelle,$abbr_name, $common); my @class = reverse split m{\s*;\s*}, $class; # have to treat swiss different from everything else... if ($sl =~ m{^(mitochondrion|chloroplast|plastid)? # GenBank format \s*(.*?) \s*(?: \( (.*?) \) )?\.?$ }xmso ){ ($organelle, $abbr_name, $common) = ($1, $2, $3); # optional } else { $abbr_name = $sl; # nothing caught; this is a backup! } # there is no 'abbreviated name' for EMBL $sci_name = $abbr_name if $seqformat ne 'genbank'; $organelle ||= ''; $common ||= ''; $sci_name || return; unshift @class, $sci_name; # no genus/species parsing here; moving to Bio::Taxon-based taxonomy my $make = Bio::Species->new(); $make->scientific_name($sci_name); $make->classification(@class) if @class > 0; $common && $make->common_name( $common ); $abbr_name && $make->name('abbreviated', $abbr_name); $organelle && $make->organelle($organelle); $taxid && $make->ncbi_taxid($taxid); $self->{'_params'}->{'-species'} = $make; } ####################### ANNOTATION HANDLERS ####################### # GenBank DBSOURCE line sub _genbank_dbsource { my ($self, $data) = @_; my $dbsource = $data->{DATA}; my $annotation = $self->annotation_collection; # deal with swissprot dbsources # we could possibly parcel these out to subhandlers... if( $dbsource =~ s/(UniProt(?:KB)|swissprot):\s+locus\s+(\S+)\,.+\n// ) { $annotation->add_Annotation ('dblink', Bio::Annotation::DBLink->new (-primary_id => $2, -database => $1, -tagname => 'dblink')); if( $dbsource =~ s/\s*created:\s+([^\.]+)\.\n// ) { $annotation->add_Annotation ('swissprot_dates', Bio::Annotation::SimpleValue->new (-tagname => 'date_created', -value => $1)); } while( $dbsource =~ s/\s*(sequence|annotation)\s+updated:\s+([^\.]+)\.\n//g ) { $annotation->add_Annotation ('swissprot_dates', Bio::Annotation::SimpleValue->new (-tagname => 'date_updated', -value => $1)); } $dbsource =~ s/\n/ /g; if( $dbsource =~ s/\s*xrefs:\s+((?:\S+,\s+)+\S+)\s+xrefs/xrefs/ ) { # will use $i to determine even or odd # for swissprot the accessions are paired my $i = 0; for my $dbsrc ( split(/,\s+/,$1) ) { if( $dbsrc =~ /(\S+)\.(\d+)/ || $dbsrc =~ /(\S+)/ ) { my ($id,$version) = ($1,$2); $version ='' unless defined $version; my $db; if( $id =~ /^\d\S{3}/) { $db = 'PDB'; } else { $db = ($i++ % 2 ) ? 'GenPept' : 'GenBank'; } $annotation->add_Annotation ('dblink', Bio::Annotation::DBLink->new (-primary_id => $id, -version => $version, -database => $db, -tagname => 'dblink')); } } } elsif( $dbsource =~ s/\s*xrefs:\s+(.+)\s+xrefs/xrefs/i ) { # download screwed up and ncbi didn't put acc in for gi numbers my $i = 0; for my $id ( split(/\,\s+/,$1) ) { my ($acc,$db); if( $id =~ /gi:\s+(\d+)/ ) { $acc= $1; $db = ($i++ % 2 ) ? 'GenPept' : 'GenBank'; } elsif( $id =~ /pdb\s+accession\s+(\S+)/ ) { $acc= $1; $db = 'PDB'; } else { $acc= $id; $db = ''; } $annotation->add_Annotation ('dblink', Bio::Annotation::DBLink->new (-primary_id => $acc, -database => $db, -tagname => 'dblink')); } } else { $self->warn("Cannot match $dbsource\n"); } if( $dbsource =~ s/xrefs\s+\(non\-sequence\s+databases\):\s+ ((?:\S+,\s+)+\S+)//x ) { for my $id ( split(/\,\s+/,$1) ) { my $db; # this is because GenBank dropped the spaces!!! # I'm sure we're not going to get this right ##if( $id =~ s/^://i ) { ## $db = $1; ##} $db = substr($id,0,index($id,':')); if (! exists $DBSOURCE{ $db }) { $db = ''; # do we want 'GenBank' here? } $id = substr($id,index($id,':')+1); $annotation->add_Annotation ('dblink',Bio::Annotation::DBLink->new (-primary_id => $id, -database => $db, -tagname => 'dblink')); } } } else { if( $dbsource =~ /^(\S*?):?\s*accession\s+(\S+)\.(\d+)/ ) { my ($db,$id,$version) = ($1,$2,$3); $annotation->add_Annotation ('dblink', Bio::Annotation::DBLink->new (-primary_id => $id, -version => $version, -database => $db || 'GenBank', -tagname => 'dblink')); } elsif ( $dbsource =~ /(\S+)([\.:])(\d+)/ ) { my ($id, $db, $version); if ($2 eq ':') { ($db, $id) = ($1, $3); } else { ($db, $id, $version) = ('GenBank', $1, $3); } $annotation->add_Annotation('dblink', Bio::Annotation::DBLink->new( -primary_id => $id, -version => $version, -database => $db, -tagname => 'dblink') ); } else { $self->warn("Unrecognized DBSOURCE data: $dbsource\n"); } } } # EMBL DR lines # UniProt/SwissProt DR lines sub _generic_dbsource { my ($self, $data) = @_; #$self->debug(Dumper($data)); while ($data->{DATA} =~ m{([^\n]+)}og) { my $dblink = $1; $dblink =~ s{\.$}{}; my $link; my @linkdata = split '; ',$dblink; if ( $dblink =~ m{([^\s;]+);\s*([^\s;]+);?\s*([^\s;]+)?}) { #if ( $dblink =~ m{([^\s;]+);\s*([^\s;]+);?\s*([^\s;]+)?}) { my ($databse, $prim_id, $sec_id) = ($1,$2,$3); $link = Bio::Annotation::DBLink->new(-database => $databse, -primary_id => $prim_id, -optional_id => $sec_id); } else { $self->warn("No match for $dblink"); } $self->annotation_collection->add_Annotation('dblink', $link); } } # GenBank REFERENCE and related lines # EMBL R* lines # UniProt/SwissProt R* lines sub _generic_reference { my ($self, $data) = @_; my $seqformat = $self->format; my ($start, $end); # get these in EMBL/Swiss if ($data->{CROSSREF}) { while ($data->{CROSSREF} =~ m{(pubmed|doi|medline)(?:=|;\s+)(\S+)}oig) { my ($db, $ref) = (uc $1, $2); $ref =~ s{[;.]+$}{}; $data->{$db} = $ref; } } # run some cleanup for swissprot if ($seqformat eq 'swiss') { for my $val (values %{ $data }) { $val =~ s{;$}{}; $val =~ s{(\w-)\s}{$1}; } } if ( $data->{POSITION} ) { if ($seqformat eq 'embl') { ($start, $end) = split '-', $data->{POSITION},2; } elsif ($data->{POSITION} =~ m{.+? OF (\d+)-(\d+).*}) { #swiss ($start, $end) = ($1, $2); } } if ($data->{DATA} =~ m{^\d+\s+\([a-z]+\s+(\d+)\s+to\s+(\d+)\)}xmso) { ($start, $end) = ($1, $2); } my $ref = Bio::Annotation::Reference->new( -comment => $data->{REMARK}, -location => $data->{JOURNAL}, -pubmed => $data->{PUBMED}, -consortium => $data->{CONSRTM}, -title => $data->{TITLE}, -authors => $data->{AUTHORS}, -medline => $data->{MEDLINE}, -doi => $data->{DOI}, -rp => $data->{POSITION}, # JIC... -start => $start, -end => $end, ); if ($data->{DATA} =~ m{^\d+\s+\((.*)\)}xmso) { $ref->gb_reference($1); } $self->annotation_collection->add_Annotation('reference', $ref); } # GenBank COMMENT lines # EMBL CC lines # UniProt/SwissProt CC lines sub _generic_comment { my ($self, $data) = @_; $self->annotation_collection->add_Annotation('comment', Bio::Annotation::Comment->new( -text => $data->{DATA} )); } ####################### SEQFEATURE HANDLER ####################### # GenBank Feature Table sub _generic_seqfeatures { my ($self, $data) = @_; return if $data->{FEATURE_KEY} eq 'FEATURES'; my $primary_tag = $data->{FEATURE_KEY}; # grab the NCBI taxon ID from the source SF if ($primary_tag eq 'source' && exists $data->{'db_xref'}) { if ( $self->{'_params'}->{'-species'} && $data->{'db_xref'} =~ m{taxon:(\d+)}xmso ) { $self->{'_params'}->{'-species'}->ncbi_taxid($1); } } my $source = $self->format; my $seqid = ${ $self->get_params('accession_number') }{'accession_number'}; my $loc; eval { $loc = $self->{'_locfactory'}->from_string($data->{'LOCATION'}); }; if(! $loc) { $self->warn("exception while parsing location line [" . $data->{'LOCATION'} . "] in reading $source, ignoring feature " . $data->{'primary_tag'}. " (seqid=" . $seqid . "): " . $@); return; } if($seqid && (! $loc->is_remote())) { $loc->seq_id($seqid); # propagates if it is a split location } my $sf = Bio::SeqFeature::Generic->direct_new(); $sf->location($loc); $sf->primary_tag($primary_tag); $sf->seq_id($seqid); $sf->source_tag($source); delete $data->{'FEATURE_KEY'}; delete $data->{'LOCATION'}; delete $data->{'NAME'}; delete $data->{'DATA'}; $sf->set_attributes(-tag => $data); push @{ $self->{'_params'}->{'-features'} }, $sf; } ####################### ODDS AND ENDS ####################### # Those things that don't fit anywhere else. If a specific name # maps to the below table, that class and method are used, otherwise # it goes into a SimpleValue (I think this is a good argument for why # we need a generic mechanism for storing annotation) sub _generic_simplevalue { my ($self, $data) = @_; $self->annotation_collection->add_Annotation( Bio::Annotation::SimpleValue->new(-tagname => lc($data->{NAME}), -value => $data->{DATA}) ); } sub noop {} sub _debug { my ($self, $data) = @_; $self->debug(Dumper($data)); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/tinyseq�������������������������������������������������������������������000755��000765��000024�� 0�12254227337� 16473� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/SeqIO/tinyseq/tinyseqHandler.pm�������������������������������������������������000444��000765��000024�� 14213�12254227337� 22201� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::SeqIO::tinyseqHandler # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Bristol-Myers Squibb # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::SeqIO::tinyseq::tinyseqHandler - XML event handlers to support NCBI TinySeq XML parsing =head1 SYNOPSIS Do not use this module directly; use the SeqIO handler system: $stream = Bio::SeqIO->new( -file => $filename, -format => 'tinyseq' ); while ( my $seq = $stream->next_seq ) { .... } =head1 DESCRIPTION This object provides event handler methods for parsing sequence files in the NCBI TinySeq XML format. A TinySeq is a lightweight XML file of sequence information on one or more sequences, analgous to FASTA format. See L<http://www.ncbi.nlm.nih.gov/dtd/NCBI_TSeq.mod.dtd> for the DTD. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 SEE ALSO L<Bio::SeqIO>, L<Bio::Seq>. =head1 AUTHOR Donald Jackson, E<lt>donald.jackson@bms.comE<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::SeqIO::tinyseq::tinyseqHandler; use strict; use warnings; use vars qw(%ATTMAP); use base qw(Bio::Root::Root); # %ATTMAP defines correspondence between TSeq elements, PrimarySeq attributes # Format: element_name => { xml_attname => pseq_attname } %ATTMAP = ( TSeq_sequence => { Data => '-seq'}, TSeq_gi => { Data => '-primary_id' }, TSeq_defline => { Data => '-desc' }, TSeq_sid => { Data => '-sid' }, TSeq_accver => { Data => '-accver' }, TSeq_taxid => { Data => '-taxid' }, TSeq_orgname => { Data => '-organism' } ); =head2 new Title : new Usage : $handler = Bio::SeqIO::tinyseq::tinyseqHandler->new() Function : instantiates a tinyseqHandler for use by XML::Parser::PerlSAX Returns : Bio::SeqIO::tinyseq::tinyseqHandler object Args : NONE =cut sub new { my ($proto, @args) = @_; my $class = ref($proto) || $proto; my $self = bless({}, $class); return $self; } ####################################### # Event hadling methods for PerlSax # ####################################### sub doctype_decl { my ($self, $doctype) = @_; # make sure we have a tinyseq unless ($doctype->{'SystemId'} eq 'http://www.ncbi.nlm.nih.gov/dtd/NCBI_TSeq.dtd') { $self->throw("This document doesn't use the NCBI TinySeq dtd; it's a ", $doctype->{'SystemId'} ); } } =head2 start_document Title : start_document Usage : NONE Function : start_document handler for use by XML::Parser::PerlSAX Returns : NONE Args : NONE =cut sub start_document { my ($self) = @_; $self->{'_seqatts'} = []; $self->{'_elements'} = []; } =head2 end_document Title : end_document Usage : NONE Function : end_document handler for use by XML::Parser::PerlSAX Returns : NONE Args : NONE =cut sub end_document { my ($self) = @_; return $self->{'_seqatts'}; } =head2 start_element Title : start_element Usage : NONE Function : start_element handler for use by XML::Parser::PerlSAX Returns : NONE Args : NONE =cut sub start_element { my ($self, $starting) = @_; push(@{$self->{'_elements'}}, $starting); } =head2 end_element Title : end_element Usage : NONE Function : end_element handler for use by XML::Parser::PerlSAX Returns : NONE Args : NONE =cut sub end_element { my ($self, $ending) = @_; # do I have a handler for this element? my $ename = $ending->{'Name'}; $self->$ename if ($self->can($ename)); } =head2 characters Title : characters Usage : NONE Function : characters handler for use by XML::Parser::PerlSAX Returns : NONE Args : NONE =cut sub characters { my ($self, $characters) = @_; my $data = $characters->{'Data'}; return unless (defined($data) and $data =~ /\S/); my $current = $self->_current_element; $current->{'Data'} = $data; } ########################################### # Element-specific handlers # called at END of element name ########################################## =head2 TSeq Title : TSeq Usage : NONE Function : event handler for END of a TSeq element Returns : loh of parsed sequence atts for Bio::SeqIO::tinyseq Args : NONE =cut sub TSeq { my ($self) = @_; my %seqatts; # map elements onto PrimarySeq keys while (my $element = pop @{ $self->{'_elements'} }) { my $element_name = $element->{'Name'}; last if ($element_name eq 'TSeq'); my $conversion = $ATTMAP{$element_name} or next; while(my($element_att, $pseq_att) = each %$conversion) { $seqatts{$pseq_att} = $element->{$element_att}; } } push(@{ $self->{'_seqatts'} }, \%seqatts); } ############################################# # Utility method to return current element info ############################################## =head2 _current_element Title : _current_element Usage : Internal method Function : Utility method to return current element info Returns : XML::Parser::PerlSAX hash for current element Args : NONE =cut sub _current_element { my ($self) = @_; return $self->{'_elements'}->[-1]; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure�����������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 16011� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/Atom.pm���������������������������������������������������������������000444��000765��000024�� 25707�12254227330� 17436� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Structure::Atom # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright Kris Boulez # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::Atom - Bioperl structure Object, describes an Atom =head1 SYNOPSIS #add synopsis here =head1 DESCRIPTION This object stores a Bio::Structure::Atom =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::Atom; use strict; use Bio::Structure::Residue; use base qw(Bio::Root::Root); =head2 new() Title : new() Usage : $struc = Bio::Structure::Atom->new( -id => 'human_id', ); Function: Returns a new Bio::Structure::Atom object from basic constructors. Probably most called from Bio::Structure::IO. Returns : a new Bio::Structure::Atom object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($id, $x, $y, $z) = $self->_rearrange([qw( ID X Y Z )], @args); $id && $self->id($id); $x && $self->x($x); $y && $self->y($y); $z && $self->z($z); return $self; } =head2 x() Title : x Usage : $x = $atom->x($x); Function: Set/gets the X coordinate for an Atom Returns : The value for the X coordinate of the Atom (This is just a number, it is expected to be in Angstrom, but no garantees) Args : The X coordinate as a number =cut sub x { my ($self,$value) = @_; if( defined $value) { # do we want to check if $value contains really a number ? $self->{'x'} = $value; } return $self->{'x'}; } =head2 y() Title : y Usage : $y = $atom->y($y); Function: Set/gets the Y coordinate for an Atom Returns : The value for the Y coordinate of the Atom (This is just a number, it is eypected to be in Angstrom, but no garantees) Args : The Y coordinate as a number =cut sub y { my ($self,$value) = @_; if( defined $value) { # do we want to check if $value contains really a number ? $self->{'y'} = $value; } return $self->{'y'}; } =head2 z() Title : z Usage : $z = $atom->z($z); Function: Set/gets the Z coordinate for an Atom Returns : The value for the Z coordinate of the Atom (This is just a number, it is ezpected to be in Angstrom, but no garantees) Args : The Z coordinate as a number =cut sub z { my ($self,$value) = @_; if( defined $value) { # do we want to check if $value contains really a number ? $self->{'z'} = $value; } return $self->{'z'}; } =head2 xyz() Title : xyz Usage : ($x,$y,$z) = $atom->xyz; Function: Gets the XYZ coordinates for an Atom Returns : A list with the value for the XYZ coordinate of the Atom Args : =cut sub xyz { my ($self) = @_; return ($self->x, $self->y, $self->z); } =head2 residue() Title : residue Usage : Function: No code here, all parent/child stuff via Entry Returns : Args : =cut sub residue { my($self, $value) = @_; $self->throw("all parent/child stuff via Entry\n"); } =head2 icode() Title : icode Usage : $icode = $atom->icode($icode) Function: Sets/gets the icode Returns : Returns the icode for this atom Args : reference to an Atom =cut sub icode { my($self, $value) = @_; if (defined $value) { $self->{'icode'} = $value; } return $self->{'icode'}; } =head2 serial() Title : serial Usage : $serial = $atom->serial($serial) Function: Sets/gets the serial number Returns : Returns the serial number for this atom Args : reference to an Atom =cut sub serial { my($self, $value) = @_; if (defined $value) { $self->{'serial'} = $value; } return $self->{'serial'}; } =head2 occupancy() Title : occupancy Usage : $occupancy = $atom->occupancy($occupancy) Function: Sets/gets the occupancy Returns : Returns the occupancy for this atom Args : reference to an Atom =cut sub occupancy { my($self, $value) = @_; if (defined $value) { $self->{'occupancy'} = $value; } return $self->{'occupancy'}; } =head2 tempfactor() Title : tempfactor Usage : $tempfactor = $atom->tempfactor($tempfactor) Function: Sets/gets the tempfactor Returns : Returns the tempfactor for this atom Args : reference to an Atom =cut sub tempfactor { my($self, $value) = @_; if (defined $value) { $self->{'tempfactor'} = $value; } return $self->{'tempfactor'}; } =head2 segID() Title : segID Usage : $segID = $atom->segID($segID) Function: Sets/gets the segID Returns : Returns the segID for this atom Args : reference to an Atom =cut sub segID { my($self, $value) = @_; if (defined $value) { $self->{'segID'} = $value; } return $self->{'segID'}; } =head2 pdb_atomname() Title : pdb_atomname Usage : $pdb_atomname = $atom->pdb_atomname($pdb_atomname) Function: Sets/gets the pdb_atomname (atomname used in the PDB file) Returns : Returns the pdb_atomname for this atom Args : reference to an Atom =cut sub pdb_atomname { my($self, $value) = @_; if (defined $value) { $self->{'pdb_atomname'} = $value; } return $self->{'pdb_atomname'}; } =head2 element() Title : element Usage : $element = $atom->element($element) Function: Sets/gets the element Returns : Returns the element for this atom Args : reference to an Atom =cut sub element { my($self, $value) = @_; if (defined $value) { $self->{'element'} = $value; } return $self->{'element'}; } =head2 charge() Title : charge Usage : $charge = $atom->charge($charge) Function: Sets/gets the charge Returns : Returns the charge for this atom Args : reference to an Atom =cut sub charge { my($self, $value) = @_; if (defined $value) { $self->{'charge'} = $value; } return $self->{'charge'}; } =head2 sigx() Title : sigx Usage : $sigx = $atom->sigx($sigx) Function: Sets/gets the sigx Returns : Returns the sigx for this atom Args : reference to an Atom =cut sub sigx { my($self, $value) = @_; if (defined $value) { $self->{'sigx'} = $value; } return $self->{'sigx'}; } =head2 sigy() Title : sigy Usage : $sigy = $atom->sigy($sigy) Function: Sets/gets the sigy Returns : Returns the sigy for this atom Args : reference to an Atom =cut sub sigy { my($self, $value) = @_; if (defined $value) { $self->{'sigy'} = $value; } return $self->{'sigy'}; } =head2 sigz() Title : sigz Usage : $sigz = $atom->sigz($sigz) Function: Sets/gets the sigz Returns : Returns the sigz for this atom Args : reference to an Atom =cut sub sigz { my($self, $value) = @_; if (defined $value) { $self->{'sigz'} = $value; } return $self->{'sigz'}; } =head2 sigocc() Title : sigocc Usage : $sigocc = $atom->sigocc($sigocc) Function: Sets/gets the sigocc Returns : Returns the sigocc for this atom Args : reference to an Atom =cut sub sigocc { my($self, $value) = @_; if (defined $value) { $self->{'sigocc'} = $value; } return $self->{'sigocc'}; } =head2 sigtemp() Title : sigtemp Usage : $sigtemp = $atom->sigtemp($sigtemp) Function: Sets/gets the sigtemp Returns : Returns the sigtemp for this atom Args : reference to an Atom =cut sub sigtemp { my($self, $value) = @_; if (defined $value) { $self->{'sigtemp'} = $value; } return $self->{'sigtemp'}; } =head2 aniso() Title : aniso Usage : $u12 = $atom->aniso("u12", $u12) Function: Sets/gets the anisotropic temperature factors Returns : Returns the requested factor for this atom Args : reference to an Atom, name of the factor, value for the factor =cut sub aniso { my($self, $name, $value) = @_; if ( !defined $name) { $self->throw("You need to supply a name of the anisotropic temp factor you want to get"); } if (defined $value) { $self->{$name} = $value; } return $self->{$name}; } # placeholders sub u11 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub u22 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub u33 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub u12 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub u13 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub u23 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub sigu11 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub sigu22 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub sigu33 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub sigu12 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub sigu13 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } sub sigu23 { my ($self, $name, $value) = @_; $self->aniso($name,$value); } =head2 id() Title : id Usage : $atom->id("CZ2") Function: Gets/sets the ID for this atom Returns : the ID Args : the ID =cut sub id { my ($self, $value) = @_;; if (defined $value) { $self->{'id'} = $value; } return $self->{'id'}; } sub DESTROY { my $self = shift; # dummy, nothing needs to be done here } # # from here on only private methods # =head2 _remove_residue() Title : _remove_residue Usage : Function: Removes the Residue this Atom is atttached to. Returns : Args : =cut sub _remove_residue { my ($self) = shift; $self->throw("no code here at the moment\n"); } =head2 _grandparent() Title : _grandparent Usage : Function: get/set a symbolic reference to our grandparent Returns : Args : =cut sub _grandparent { my($self,$symref) = @_; if (ref($symref)) { $self->throw("Thou shall only pass strings in here, no references $symref\n"); } if (defined $symref) { $self->{'grandparent'} = $symref; } return $self->{'grandparent'}; } 1; ���������������������������������������������������������BioPerl-1.6.923/Bio/Structure/Chain.pm��������������������������������������������������������������000444��000765��000024�� 11253�12254227331� 17550� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Structure::Chain # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright Kris Boulez # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::Chain - Bioperl structure Object, describes a chain =head1 SYNOPSIS #add synopsis here =head1 DESCRIPTION This object stores a Bio::Structure::Chain =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::Chain; use strict; use Bio::Structure::Entry; use Bio::Structure::Model; use base qw(Bio::Root::Root); =head2 new() Title : new() Usage : $struc = Bio::Structure::Chain->new( -id => 'human_id', -accession_number => 'AL000012', ); Function: Returns a new Bio::Structure::Chain object from basic constructors. Usually called from Bio::Structure::IO. Returns : a new Bio::Structure::Chain object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($id, $residue ) = $self->_rearrange([qw( ID RESIDUE )], @args); $id && $self->id($id); $self->{'residue'} = []; # the 'smallest' item that can be added to a chain is a residue. $residue && $self->throw("use a method based on an Entry object for now"); return $self; } =head2 residue() Title : residue Usage : Function: nothing useful until I get symbolic references to do what I want Returns : Args : =cut sub residue { my ($self,$value) = @_; $self->throw("use a method on an Entry object to do what you want"); } =head2 add_residue() Title : add_residue Usage : Function: nothing useful until I get symbolic references to do what I want Returns : Args : =cut sub add_residue { my($self,$value) = @_; $self->throw("you want entry->add_residue(chain, residue)\n"); } =head2 model() Title : model Usage : Function: nothing useful until I get symbolic references to do what I want Returns : Args : =cut sub model { my($self, $value) = @_; $self->throw("go via a Entry object please\n"); } =head2 id() Title : id Usage : $chain->id("chain B") Function: Gets/sets the ID for this chain Returns : the ID Args : the ID =cut sub id { my ($self, $value) = @_;; if (defined $value) { $self->{'id'} = $value; } return $self->{'id'}; } sub DESTROY { my $self = shift; # no specific destruction for now } # # from here on only private methods # =head2 _remove_residues() Title : _remove_residues Usage : Function: Returns : Args : =cut sub _remove_residues { my ($self) = shift; $self->throw("nothing usefull in here, go see Entry\n"); } =head2 _remove_model() Title : _remove_model Usage : Function: Removes the Model this Chain is atttached to. Returns : Args : =cut sub _remove_model { my ($self) = shift; $self->throw("go see an Entry object, nothing here\n"); } =head2 _grandparent() Title : _grandparent Usage : Function: get/set a symbolic reference to our grandparent Returns : Args : =cut sub _grandparent { my($self,$symref) = @_; if (ref($symref)) { $self->throw("Thou shall only pass strings in here, no references $symref\n"); } if (defined $symref) { $self->{'grandparent'} = $symref; } return $self->{'grandparent'}; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/Entry.pm��������������������������������������������������������������000444��000765��000024�� 63133�12254227317� 17637� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Structure::Entry # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright Kris Boulez # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::Entry - Bioperl structure Object, describes the whole entry =head1 SYNOPSIS #add synopsis here =head1 DESCRIPTION This object stores a whole Bio::Structure entry. It can consist of one or more models (L<Bio::Structure::Model>), which in turn consist of one or more chains (L<Bio::Structure::Chain>). A chain is composed of residues (L<Bio::Structure::Residue>) and a residue consists of atoms (L<Bio::Structure::Atom>). If no specific model or chain is chosen, the first one is chosen. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::Entry; use strict; use Bio::Structure::Model; use Bio::Structure::Chain; use Bio::Annotation::Collection; use Tie::RefHash; use base qw(Bio::Root::Root Bio::Structure::StructureI); =head2 new() Title : new() Usage : $struc = Bio::Structure::Entry->new( -id => 'structure_id', ); Function: Returns a new Bio::Structure::Entry object from basic constructors. Probably most called from Bio::Structure::IO. Returns : a new Bio::Structure::Model object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($id, $model, $chain, $residue ) = $self->_rearrange([qw( ID MODEL CHAIN RESIDUE )], @args); # where to store parent->child relations (1 -> 1..n) # value to this hash will be an array ref # by using Tie::RefHash we can store references in this hash $self->{'p_c'} = (); tie %{ $self->{'p_c'} } , "Tie::RefHash"; # where to store child->parent relations (1 -> 1) $self->{'c_p'} = (); tie %{ $self->{'c_p'} } , "Tie::RefHash"; $id && $self->id($id); $self->{'model'} = []; $model && $self->model($model); if($chain) { if ( ! defined($self->model) ) { # no model yet, create default one $self->_create_default_model; } for my $m ($self->model) { # add this chain on all models $m->chain($chain); } } $residue && $self->residue($residue); # taken from Bio::Seq (or should we just inherit Bio::Seq and override some methods) my $ann = Bio::Annotation::Collection->new; $self->annotation($ann); return $self; } =head2 model() Title : model Function: Connects a (or a list of) Model objects to a Bio::Structure::Entry. To add a Model (and keep the existing ones) use add_model() It returns a list of Model objects. Returns : List of Bio::Structure::Model objects Args : One Model or a reference to an array of Model objects =cut sub model { my ($self, $model) = @_; if( defined $model) { if( (ref($model) eq "ARRAY") || ($model->isa('Bio::Structure::Model')) ) { # remove existing ones, tell they've become orphan my @obj = $self->model; if (@obj) { for my $m (@obj) { $self->_remove_from_graph($m); $self->{'model'} = []; } } # add the new ones $self->add_model($self,$model); } else { $self->throw("Supplied a $model to model, we want a Bio::Structure::Model or a list of these\n"); } } # give back list of models via general get method $self->get_models($self); } =head2 add_model() Title : add_model Usage : $structure->add_model($model); Function: Adds a (or a list of) Model objects to a Bio::Structure::Entry. Returns : Args : One Model or a reference to an array of Model objects =cut sub add_model { my($self,$entry,$model) = @_; # if only one argument and it's a model, change evrything one place # this is for people calling $entry->add_model($model); if ( !defined $model && ref($entry) =~ /^Bio::Structure::Model/) { $model = $entry; $entry = $self; } # $self and $entry are the same here, but it's used for uniformicity if ( !defined($entry) || ref($entry) !~ /^Bio::Structure::Entry/) { $self->throw("first argument to add_model needs to be a Bio::Structure::Entry object\n"); } if (defined $model) { if (ref($model) eq "ARRAY") { # if the user passed in a reference to an array for my $m ( @{$model} ) { if( ! $m->isa('Bio::Structure::Model') ) { $self->throw("$m is not a Model\n"); } if ( $self->_parent($m) ) { $self->throw("$m already assigned to a parent\n"); } push @{$self->{'model'}}, $m; # create a stringified version of our ref # not used untill we get symbolic ref working #my $str_ref = "$self"; #$m->_grandparent($str_ref); } } elsif ( $model->isa('Bio::Structure::Model') ) { if ( $self->_parent($model) ) { # already assigned to a parent $self->throw("$model already assigned\n"); } push @{$self->{'model'}}, $model; # create a stringified version of our ref #my $str_ref = "$self"; #$model->_grandparent($str_ref); } else { $self->throw("Supplied a $model to add_model, we want a Model or list of Models\n"); } } my $array_ref = $self->{'model'}; return $array_ref ? @{$array_ref} : (); } =head2 get_models() Title : get_models Usage : $structure->get_models($structure); Function: general get method for models attached to an Entry Returns : a list of models attached to this entry Args : an Entry =cut sub get_models { my ($self, $entry) = @_; # self and entry can be the same if ( !defined $entry) { $entry = $self; } # pass through to add_model $self->add_model($entry); } =head2 id() Title : id Usage : $entry->id("identity"); Function: Gets/sets the ID Returns : The ID Args : =cut sub id { my ($self, $value) = @_; if (defined $value) { $self->{'id'} = $value; } return $self->{'id'}; } =head2 chain() Title : chain Usage : @chains = $structure->chain($chain); Function: Connects a Chain or a list of Chain objects to a Bio::Structure::Entry. Returns : List of Bio::Structure::Chain objects Args : A Chain or a reference to an array of Chain objects =cut sub chain { my ($self, $chain) = @_; if ( ! $self->model ) { $self->_create_default_model; } my @models = $self->model; my $first_model = $models[0]; if ( defined $chain) { if( (ref($chain) eq "ARRAY") || ($chain->isa('Bio::Structure::Chain')) ) { # remove existing ones, tell they've become orphan my @obj = $self->get_chains($first_model); if (@obj) { for my $c (@obj) { $self->_remove_from_graph($c); } } # add the new ones $self->add_chain($first_model,$chain); } else { $self->throw("Supplied a $chain to chain, we want a Bio::Structure::Chain or a list of these\n"); } } $self->get_chains($first_model); } =head2 add_chain() Title : add_chain Usage : @chains = $structure->add_chain($model,$chain); Function: Adds one or more Chain objects to a Bio::Structure::Entry. Returns : List of Chain objects associated with the Model Args : A Model object and a Chain object or a reference to an array of of Chain objects =cut sub add_chain { my($self, $model, $chain) = @_; if (ref($model) !~ /^Bio::Structure::Model/) { $self->throw("add_chain: first argument needs to be a Model object ($model)\n"); } if (defined $chain) { if (ref($chain) eq "ARRAY") { # if the user passed in a reference to an array for my $c ( @{$chain} ) { if( ! $c->isa('Bio::Structure::Chain') ) { $self->throw("$c is not a Chain\n"); } if ( $self->_parent($c) ) { $self->throw("$c already assigned to a parent\n"); } $self->_parent($c, $model); $self->_child($model, $c); # stringify $self ref #my $str_ref = "$self"; #$c->_grandparent($str_ref); } } elsif ( $chain->isa('Bio::Structure::Chain') ) { if ( $self->_parent($chain) ) { # already assigned to parent $self->throw("$chain already assigned to a parent\n"); } $self->_parent($chain,$model); $self->_child($model, $chain); # stringify $self ref #my $str_ref = "$self"; #$chain->_grandparent($str_ref); } else { $self->throw("Supplied a $chain to add_chain, we want a Chain or list of Chains\n"); } } my $array_ref = $self->_child($model); return $array_ref ? @{$array_ref} : (); } =head2 get_chains() Title : get_chains Usage : $entry->get_chains($model); Function: General get method for Chains attached to a Model Returns : A list of Chains attached to this model Args : A Model =cut sub get_chains { my ($self, $model) = @_; if (! defined $model) { $model = ($self->get_models)[0]; } # pass through to add_chain $self->add_chain($model); } =head2 residue() Title : residue Usage : @residues = $structure->residue($residue); Function: Connects a (or a list of) Residue objects to a Bio::Structure::Entry. Returns : List of Bio::Structure::Residue objects Args : One Residue or a reference to an array of Residue objects =cut sub residue { my ($self, $residue) = @_; if ( ! $self->model ) { my $m = $self->_create_default_model; $self->add_model($self,$m); } my @models = $self->model; my $first_model = $models[0]; if ( ! $self->get_chains($first_model) ) { my $c = $self->_create_default_chain; $self->add_chain($first_model, $c); } my @chains = $self->get_chains($first_model); my $first_chain = $chains[0]; if( defined $residue) { if( (ref($residue) eq "ARRAY") || ($residue->isa('Bio::Structure::Residue')) ) { # remove existing ones, tell they've become orphan my @obj = $self->get_residues($first_chain); if (@obj) { for my $r (@obj) { $self->_remove_from_graph($r); } } # add the new ones $self->add_residue($first_chain,$residue); } else { $self->throw("Supplied a $residue to residue, we want a Bio::Structure::Residue or a list of these\n"); } } $self->get_residues($first_chain); } =head2 add_residue() Title : add_residue Usage : @residues = $structure->add_residue($chain,$residue); Function: Adds one or more Residue objects to a Bio::Structure::Entry. Returns : List of Bio::Structure::Residue objects Args : A Chain object and a Residue object or a reference to an array of Residue objects =cut sub add_residue { my($self,$chain,$residue) = @_; if (ref($chain) !~ /^Bio::Structure::Chain/) { $self->throw("add_residue: first argument needs to be a Chain object\n"); } if (defined $residue) { if (ref($residue) eq "ARRAY") { # if the user passed in a reference to an array for my $r ( @{$residue} ) { if( ! $r->isa('Bio::Structure::Residue') ) { $self->throw("$r is not a Residue\n"); } if ( $self->_parent($r) ) { $self->throw("$r already belongs to a parent\n"); } $self->_parent($r, $chain); $self->_child($chain, $r); # stringify my $str_ref = "$self"; $r->_grandparent($str_ref); } } elsif ( $residue->isa('Bio::Structure::Residue') ) { if ( $self->_parent($residue) ) { $self->throw("$residue already belongs to a parent\n"); } $self->_parent($residue, $chain); $self->_child($chain, $residue); # stringify my $str_ref = "$self"; $residue->_grandparent($str_ref); } else { $self->throw("Supplied a $residue to add_residue, we want a Residue or list of Residues\n"); } } my $array_ref = $self->_child($chain); return $array_ref ? @{$array_ref} : (); } =head2 get_residues() Title : get_residues Usage : $structure->get_residues($chain); Function: General get method for Residues attached to a Chain Returns : A list of residues attached to this Chain Args : A Chain =cut sub get_residues { my ($self, $chain) = @_; if ( !defined $chain) { $self->throw("get_residues needs a Chain as argument"); } # pass through to add_residue $self->add_residue($chain); } =head2 add_atom() Title : add_atom Usage : @atoms = $structure->add_atom($residue,$atom); Function: Adds a (or a list of) Atom objects to a Bio::Structure::Residue. Returns : List of Bio::Structure::Atom objects Args : A Residue and an Atom =cut sub add_atom { my($self,$residue,$atom) = @_; if (ref($residue) !~ /^Bio::Structure::Residue/) { $self->throw("add_atom: first argument needs to be a Residue object\n"); } if (defined $atom) { if (ref($atom) eq "ARRAY") { # if the user passed in a reference to an array for my $a ( @{$atom} ) { if( ! $a->isa('Bio::Structure::Atom') ) { $self->throw("$a is not an Atom\n"); } if ( $self->_parent($a) ) { $self->throw("$a already belongs to a parent\n"); } $self->_parent($a, $residue); $self->_child($residue, $a); # stringify #my $str_ref = "$self"; #$r->_grandparent($str_ref); } } #elsif ( $atom->isa('Bio::Structure::Atom') ) { elsif ( ref($atom) =~ /^Bio::Structure::Atom/ ) { if ( $self->_parent($atom) ) { $self->throw("$atom already belongs to a parent\n"); } $self->_parent($atom, $residue); $self->_child($residue, $atom); # stringify #my $str_ref = "$self"; #$atom->_grandparent($str_ref); } } my $array_ref = $self->_child($residue); return $array_ref ? @{$array_ref} : (); } =head2 get_atoms() Title : get_atoms Usage : $structure->get_atoms($residue); Function: General get method for Atoms attached to a Residue Returns : A list of Atoms attached to this Residue Args : A Residue =cut sub get_atoms { my ($self, $residue) = @_; if ( !defined $residue) { $self->throw("get_atoms needs a Residue as argument"); } # pass through to add_atom $self->add_atom($residue); } =head2 parent() Title : parent Usage : $structure->parent($residue); Function: Returns the parent of the argument Returns : The parent of the argument Args : A Bio::Structure object =cut =head2 connect Title : connect Usage : Function: Alias to conect() Returns : Args : =cut sub connect { my $self = shift; return $self->conect(@_); } =head2 conect() Title : conect Usage : $structure->conect($source); Function: Get/set method for conect Returns : A list of serial numbers for Atoms connected to source (together with $entry->get_atom_by_serial($model, $serial), this should be OK for now) Args : The source, the serial number for the source Atom, and the type =cut sub conect { my ($self, $source, $serial, $type) = @_; if ( !defined $source ) { $self->throw("You need to supply at least a source to connect"); } if ( defined $serial && defined $type ) { if ( !exists(${$self->{'conect'}}{$source}) || ref(${$self->{'conect'}}{$source} !~ /^ARRAY/ ) ) { ${$self->{'conect'}}{$source} = []; } # we also need to store type, a conect object might be better my $c = $serial . "_" . $type; push @{ ${$self->{'conect'}}{$source} }, $c; } # Bug 1894 return () if ( !exists $self->{'conect'}{$source} || !defined $self->{'conect'}{$source} ); return @{ ${$self->{'conect'}}{$source} }; } =head2 get_all_connect_source Title : get_all_connect_source Usage : Function: Alias to get_all_conect_source() Returns : Args : =cut sub get_all_connect_source { my $self = shift; return get_all_conect_source(@_); } =head2 get_all_conect_source() Title : get_all_conect_source Usage : @sources = $structure->get_all_conect_source; Function: Get all the sources for the conect records Returns : A list of serial numbers for atoms connected to source (together with $entry->get_atom_by_serial($model, $serial), this should be OK for now) Args : Notes : This is a bit of a kludge, but it is the best for now. Conect info might need to go in a separate object =cut sub get_all_conect_source { my ($self) = shift; my (@sources); for my $source (sort {$a<=>$b} keys %{$self->{'conect'}}) { push @sources, $source; } return @sources; } =head2 master() Title : master Usage : $structure->master($source); Function: Get/set method for master Returns : The master line Args : The master line for this entry =cut sub master { my ($self, $value) = @_; if (defined $value) { $self->{'master'} = $value; } return $self->{'master'}; } =head2 seqres() Title : seqres Usage : $seqobj = $structure->seqres("A"); Function: Gets a sequence object containing the sequence from the SEQRES record. if a chain-ID is given, the sequence for this chain is given, if none is provided the first chain is chosen Returns : A Bio::PrimarySeq Args : The chain-ID of the chain you want the sequence from =cut sub seqres { my ($self, $chainid) = @_; my $s_u = "x3 A1 x7 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3 x1 A3"; my (%seq_ch); if ( !defined $chainid) { my $m = ($self->get_models($self))[0]; my $c = ($self->get_chains($m))[0]; $chainid = $c->id; } my $seqres = ($self->annotation->get_Annotations("seqres"))[0]; my $seqres_string = $seqres->as_text; $self->debug("seqres : $seqres_string\n"); $seqres_string =~ s/^Value: //; # split into lines of 62 long my @l = unpack("A62" x (length($seqres_string)/62), $seqres_string); for my $line (@l) { # get out chain_id and sequence # we use a1, as A1 strips all spaces :( my ($chid, $seq) = unpack("x3 a1 x7 A51", $line); if ($chid eq " ") { $chid = "default"; } $seq =~ s/(\w+)/\u\L$1/g; # ALA -> Ala (for SeqUtils) $seq =~ s/\s//g; # strip all spaces $seq_ch{$chid} .= $seq; $self->debug("seqres : $chid $seq_ch{$chid}\n"); } # do we have a seqres for this chainid if(! exists $seq_ch{$chainid} ) { $self->warn("There is no SEQRES known for chainid \"$chainid\""); return; } # this will break for non-protein structures (about 10% for now) XXX KB my $pseq = Bio::PrimarySeq->new(-alphabet => 'protein'); $pseq = Bio::SeqUtils->seq3in($pseq,$seq_ch{$chainid}); my $id = $self->id . "_" . $chainid; $pseq->id($id); return $pseq; } =head2 get_atom_by_serial() Title : get_atom_by_serial Usage : $structure->get_atom_by_serial($model,$serial); Function: Get the Atom by serial Returns : The Atom object with this serial number in the model Args : Model on which to work, serial number for atom (if only a number is supplied, the first model is chosen) =cut sub get_atom_by_serial { my ($self, $model, $serial) = @_; if ($model =~ /^\d+$/ && !defined $serial) { # only serial given $serial = $model; my @m = $self->get_models($self); $model = $m[0]; } if ( !defined $model || ref($model) !~ /^Bio::Structure::Model/ ) { $self->throw("Could not find (first) model\n"); } if ( !defined $serial || ($serial !~ /^\d+$/) ) { $self->throw("The serial number you provided looks fishy ($serial)\n"); } for my $chain ($self->get_chains($model) ) { for my $residue ($self->get_residues($chain) ) { for my $atom ($self->get_atoms($residue) ) { # this could get expensive, do we cache ??? next unless ($atom->serial == $serial); return $atom; } } } } sub parent { my ($self, $obj) = @_; if ( !defined $obj) { $self->throw("parent: you need to supply an argument to get the parent from\n"); } # for now we pass on to _parent, untill we get the symbolic ref thing working. $self->_parent($obj); } sub DESTROY { my $self = shift; %{ $self->{'p_c'} } = (); %{ $self->{'c_p'} } = (); } =head2 annotation Title : annotation Usage : $obj->annotation($seq_obj) Function: Example : Returns : value of annotation Args : newvalue (optional) =cut sub annotation { my ($obj,$value) = @_; if( defined $value) { $obj->{'annotation'} = $value; } return $obj->{'annotation'}; } # # from here on only private methods # =head2 _remove_models() Title : _remove_models Usage : Function: Removes the models attached to an Entry. Tells the models they do not belong to this Entry any more Returns : Args : =cut # sub _remove_models { my ($self) = shift; ; } =head2 _create_default_model() Title : _create_default_model Usage : Function: Creates a default Model for this Entry. Typical situation in an X-ray structure where there is only one model Returns : Args : =cut sub _create_default_model { my ($self) = shift; my $model = Bio::Structure::Model->new(-id => "default"); return $model; } =head2 _create_default_chain() Title : _create_default_chain Usage : Function: Creates a default Chain for this Model. Typical situation in an X-ray structure where there is only one chain Returns : Args : =cut sub _create_default_chain { my ($self) = shift; my $chain = Bio::Structure::Chain->new(-id => "default"); return $chain; } =head2 _parent() Title : _parent Usage : This is an internal function only. It is used to have one place that keeps track of which object has which other object as parent. Thus allowing the underlying modules (Atom, Residue,...) to have no knowledge about all this (and thus removing the possibility of reference cycles). This method hides the details of manipulating references to an anonymous hash. Function: To get/set an objects parent Returns : A reference to the parent if it exist, undef otherwise. In the current implementation each node should have a parent (except Entry). Args : =cut # manipulating the c_p hash sub _parent { no strict "refs"; my ($self, $key, $value) = @_; if ( (!defined $key) || (ref($key) !~ /^Bio::/) ) { $self->throw("First argument to _parent needs to be a reference to a Bio:: object ($key)\n"); } if ( (defined $value) && (ref($value) !~ /^Bio::/) ) { $self->throw("Second argument to _parent needs to be a reference to a Bio:: object\n"); } # no checking here for consistency of key and value, needs to happen in caller if (defined $value) { # is this value already in, shout if (defined ( $self->{'c_p'}->{$key}) && exists ( $self->{'c_p'}->{$key}) ) { $self->throw("_parent: $key already has a parent ${$self->{'c_p'}}{$key}\n"); } ${$self->{'c_p'}}{$key} = $value; } return ${$self->{'c_p'}}{$key}; } =head2 _child() Title : _child Usage : This is an internal function only. It is used to have one place that keeps track of which object has which other object as child. Thus allowing the underlying modules (Atom, Residue,...) to have no knowledge about all this (and thus removing the possibility to have no knowledge about all this (and thus removing the possibility of reference cycles). This method hides the details of manipulating references to an anonymous hash. Function: To get/set an the children of an object Returns : A reference to an array of child(ren) if they exist, undef otherwise. Args : =cut # manipulating the p_c hash sub _child { my ($self, $key, $value) = @_; if ( (!defined $key) || (ref($key) !~ /^Bio::/) ) { $self->throw("First argument to _child needs to be a reference to a Bio:: object\n"); } if ( (defined $value) && (ref($value) !~ /^Bio::/) ) { $self->throw("Second argument to _child needs to be a reference to a Bio:: object\n"); } # no checking here for consistency of key and value, needs to happen in caller if (defined $value) { if ( !exists(${$self->{'p_c'}}{$key}) || ref(${$self->{'p_c'}}{$key}) !~ /^ARRAY/ ) { ${$self->{'p_c'}}{$key} = []; } push @{ ${$self->{'p_c'}}{$key} }, $value; } return ${$self->{'p_c'}}{$key}; } =head2 _remove_from_graph() Title : _remove_from_graph Usage : This is an internal function only. It is used to remove from the parent/child graph. We only remove the links from object to his parent. Not the ones from object to its children. Function: To remove an object from the parent/child graph Returns : Args : The object to be orphaned =cut sub _remove_from_graph { my ($self, $object) = @_; if ( !defined($object) && ref($object) !~ /^Bio::/) { $self->throw("_remove_from_graph needs a Bio object as argument"); } if ( $self->_parent($object) ) { my $dad = $self->_parent($object); # if we have a parent, remove me as being a child for my $k (0 .. $#{$self->_child($dad)}) { if ($object eq ${$self->{'p_c'}{$dad}}[$k]) { splice(@{$self->{'p_c'}{$dad}}, $k,1); } } delete( $self->{'c_p'}{$object}); } } sub _print_stats_pc { # print stats about the parent/child hashes my ($self) =@_; my $pc = scalar keys %{$self->{'p_c'}}; my $cp = scalar keys %{$self->{'c_p'}}; my $now_time = Time::HiRes::time(); $self->debug("pc stats: P_C $pc C_P $cp $now_time\n"); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/IO.pm�����������������������������������������������������������������000444��000765��000024�� 34460�12254227336� 17047� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Structure::IO # # Copyright 2001, 2002 Kris Boulez # # You may distribute this module under the same terms as perl itself # # _history # October 18, 1999 Largely rewritten by Lincoln Stein # November 16, 2001 Copied Bio::SeqIO to Bio::Structure::IO and modified # where needed. Factoring out common methods # (to Bio::Root::IO) might be a good idea. # POD documentation - main docs before the code =head1 NAME Bio::Structure::IO - Handler for Structure Formats =head1 SYNOPSIS use Bio::Structure::IO; $in = Bio::Structure::IO->new(-file => "inputfilename", -format => 'pdb'); while ( my $struc = $in->next_structure() ) { print "Structure ", $struc->id, " number of models: ", scalar $struc->model,"\n"; } =head1 DESCRIPTION Bio::Structure::IO is a handler module for the formats in the Structure::IO set (e.g. L<Bio::Structure::IO::pdb>). It is the officially sanctioned way of getting at the format objects, which most people should use. The Bio::Structure::IO system can be thought of like biological file handles. They are attached to filehandles with smart formatting rules (e.g. PDB format) and can either read or write structure objects (Bio::Structure objects, or more correctly, Bio::Structure::StructureI implementing objects, of which Bio::Structure is one such object). If you want to know what to do with a Bio::Structure object, read L<Bio::Structure>. The idea is that you request a stream object for a particular format. All the stream objects have a notion of an internal file that is read from or written to. A particular Structure::IO object instance is configured for either input or output. A specific example of a stream object is the Bio::Structure::IO::pdb object. Each stream object has functions $stream->next_structure(); and $stream->write_structure($struc); also $stream->type() # returns 'INPUT' or 'OUTPUT' As an added bonus, you can recover a filehandle that is tied to the Structure::IOIO object, allowing you to use the standard E<lt>E<gt> and print operations to read and write structure::IOuence objects: use Bio::Structure::IO; $stream = Bio::Structure::IO->newFh(-format => 'pdb'); # read from standard input while ( $structure = <$stream> ) { # do something with $structure } and print $stream $structure; # when stream is in output mode =head1 CONSTRUCTORS =head2 Bio::Structure::IO-E<gt>new() $stream = Bio::Structure::IO->new(-file => 'filename', -format=>$format); $stream = Bio::Structure::IO->new(-fh => \*FILEHANDLE, -format=>$format); $stream = Bio::Structure::IO->new(-format => $format); The new() class method constructs a new Bio::Structure::IO object. The returned object can be used to retrieve or print Bio::Structure objects. new() accepts the following parameters: =over 4 =item -file A file path to be opened for reading or writing. The usual Perl conventions apply: 'file' # open file for reading '>file' # open file for writing '>>file' # open file for appending '+<file' # open file read/write 'command |' # open a pipe from the command '| command' # open a pipe to the command =item -fh You may provide new() with a previously-opened filehandle. For example, to read from STDIN: $strucIO = Bio::Structure::IO->new(-fh => \*STDIN); Note that you must pass filehandles as references to globs. If neither a filehandle nor a filename is specified, then the module will read from the @ARGV array or STDIN, using the familiar E<lt>E<gt> semantics. =item -format Specify the format of the file. Supported formats include: pdb Protein Data Bank format If no format is specified and a filename is given, then the module will attempt to deduce it from the filename. If this is unsuccessful, PDB format is assumed. The format name is case insensitive. 'PDB', 'Pdb' and 'pdb' are all supported. =back =head2 Bio::Structure::IO-E<gt>newFh() $fh = Bio::Structure::IO->newFh(-fh => \*FILEHANDLE, -format=>$format); $fh = Bio::Structure::IO->newFh(-format => $format); # etc. This constructor behaves like new(), but returns a tied filehandle rather than a Bio::Structure::IO object. You can read structures from this object using the familiar E<lt>E<gt> operator, and write to it using print(). The usual array and $_ semantics work. For example, you can read all structure objects into an array like this: @structures = <$fh>; Other operations, such as read(), sysread(), write(), close(), and printf() are not supported. =head1 OBJECT METHODS See below for more detailed summaries. The main methods are: =head2 $structure = $structIO-E<gt>next_structure() Fetch the next structure from the stream. =head2 $structIO-E<gt>write_structure($struc [,$another_struc,...]) Write the specified structure(s) to the stream. =head2 TIEHANDLE(), READLINE(), PRINT() These provide the tie interface. See L<perltie> for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Ewan Birney, Lincoln Stein, Kris Boulez Email birney@ebi.ac.uk, lstein@cshl.org, kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::IO; use strict; use Bio::PrimarySeq; use Symbol; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : $stream = Bio::Structure::IO->new(-file => $filename, -format => 'Format') Function: Returns a new structIOstream Returns : A Bio::Structure::IO handler initialised with the appropriate format Args : -file => $filename -format => format -fh => filehandle to attach to =cut my $entry = 0; sub new { my ($caller,@args) = @_; my $class = ref($caller) || $caller; # or do we want to call SUPER on an object if $caller is an # object? if( $class =~ /Bio::Structure::IO::(\S+)/ ) { my ($self) = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } else { my %param = @args; @param{ map { lc $_ } keys %param } = values %param; # lowercase keys my $format = $param{'-format'} || $class->_guess_format( $param{-file} || $ARGV[0] ) || 'pdb'; $format = "\L$format"; # normalize capitalization to lower case # normalize capitalization return unless( &_load_format_module($format) ); return "Bio::Structure::IO::$format"->new(@args); } } =head2 newFh Title : newFh Usage : $fh = Bio::Structure::IO->newFh(-file=>$filename,-format=>'Format') Function: does a new() followed by an fh() Example : $fh = Bio::Structure::IO->newFh(-file=>$filename,-format=>'Format') $structure = <$fh>; # read a structure object print $fh $structure; # write a structure object Returns : filehandle tied to the Bio::Structure::IO::Fh class Args : =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Example : $fh = $obj->fh; # make a tied filehandle $structure = <$fh>; # read a structure object print $fh $structure; # write a structure object Returns : filehandle tied to the Bio::Structure::IO::Fh class Args : =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } =head2 format Title : format Usage : $format = $obj->format() Function: Get the structure format Returns : structure format Args : none =cut # format() method inherited from Bio::Root::IO # _initialize is chained for all SeqIO classes sub _initialize { my($self, @args) = @_; # not really necessary unless we put more in RootI $self->SUPER::_initialize(@args); # initialize the IO part $self->_initialize_io(@args); } =head2 next_structure Title : next_structure Usage : $structure = stream->next_structure Function: Reads the next structure object from the stream and returns a Bio::Structure::Entry object. Certain driver modules may encounter entries in the stream that are either misformatted or that use syntax not yet understood by the driver. If such an incident is recoverable, e.g., by dismissing a feature of a feature table or some other non-mandatory part of an entry, the driver will issue a warning. In the case of a non-recoverable situation an exception will be thrown. Do not assume that you can resume parsing the same stream after catching the exception. Note that you can always turn recoverable errors into exceptions by calling $stream->verbose(2) (see Bio::RootI POD page). Returns : a Bio::Structure::Entry object Args : none =cut sub next_structure { my ($self, $struc) = @_; $self->throw("Sorry, you cannot read from a generic Bio::Structure::IO object."); } # Do we want people to read out the sequence directly from a $structIO stream # ##=head2 next_primary_seq ## ## Title : next_primary_seq ## Usage : $seq = $stream->next_primary_seq ## Function: Provides a primaryseq type of sequence object ## Returns : A Bio::PrimarySeqI object ## Args : none ## ## ##=cut ## ##sub next_primary_seq { ## my ($self) = @_; ## ## # in this case, we default to next_seq. This is because ## # Bio::Seq's are Bio::PrimarySeqI objects. However we ## # expect certain sub classes to override this method to provide ## # less parsing heavy methods to retrieving the objects ## ## return $self->next_seq(); ##} =head2 write_structure Title : write_structure Usage : $stream->write_structure($structure) Function: writes the $structure object into the stream Returns : 1 for success and 0 for error Args : Bio::Structure object =cut sub write_seq { my ($self, $struc) = @_; $self->throw("Sorry, you cannot write to a generic Bio::Structure::IO object."); } # De we need this here # ##=head2 alphabet ## ## Title : alphabet ## Usage : $self->alphabet($newval) ## Function: Set/get the molecule type for the Seq objects to be created. ## Example : $seqio->alphabet('protein') ## Returns : value of alphabet: 'dna', 'rna', or 'protein' ## Args : newvalue (optional) ## Throws : Exception if the argument is not one of 'dna', 'rna', or 'protein' ## ##=cut ## ##sub alphabet { ## my ($self, $value) = @_; ## ## if ( defined $value) { ## # instead of hard-coding the allowed values once more, we check by ## # creating a dummy sequence object ## eval { ## my $seq = Bio::PrimarySeq->new('-alphabet' => $value); ## }; ## if($@) { ## $self->throw("Invalid alphabet: $value\n. See Bio::PrimarySeq for allowed values."); ## } ## $self->{'alphabet'} = "\L$value"; ## } ## return $self->{'alphabet'}; ##} =head2 _load_format_module Title : _load_format_module Usage : *INTERNAL Structure::IO stuff* Function: Loads up (like use) a module at run time on demand Example : Returns : Args : =cut sub _load_format_module { my ($format) = @_; my ($module, $load, $m); $module = "_<Bio/Structure/IO/$format.pm"; $load = "Bio/Structure/IO/$format.pm"; return 1 if $main::{$module}; eval { require $load; }; if ( $@ ) { print STDERR <<END; $load: $format cannot be found Exception $@ For more information about the Structure::IO system please see the Bio::Structure::IO docs. This includes ways of checking for formats at compile time, not run time END ; return; } return 1; } =head2 _concatenate_lines Title : _concatenate_lines Usage : $s = _concatenate_lines($line, $continuation_line) Function: Private. Concatenates two strings assuming that the second stems from a continuation line of the first. Adds a space between both unless the first ends with a dash. Takes care of either arg being empty. Example : Returns : A string. Args : =cut sub _concatenate_lines { my ($self, $s1, $s2) = @_; $s1 .= " " if($s1 && ($s1 !~ /-$/) && $s2); return ($s1 ? $s1 : "") . ($s2 ? $s2 : ""); } =head2 _filehandle Title : _filehandle Usage : $obj->_filehandle($newval) Function: This method is deprecated. Call _fh() instead. Example : Returns : value of _filehandle Args : newvalue (optional) =cut sub _filehandle { my ($self,@args) = @_; return $self->_fh(@args); } =head2 _guess_format Title : _guess_format Usage : $obj->_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'fasta' if /\.(fasta|fast|seq|fa|fsa|nt|aa)$/i; return 'genbank' if /\.(gb|gbank|genbank)$/i; return 'scf' if /\.scf$/i; return 'pir' if /\.pir$/i; return 'embl' if /\.(embl|ebl|emb|dat)$/i; return 'raw' if /\.(txt)$/i; return 'gcg' if /\.gcg$/i; return 'ace' if /\.ace$/i; return 'bsml' if /\.(bsm|bsml)$/i; return 'pdb' if /\.(ent|pdb)$/i; } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my ($class,$val) = @_; return bless {'structio' => $val}, $class; } sub READLINE { my $self = shift; return $self->{'structio'}->next_seq() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'structio'}->next_seq(); return @list; } sub PRINT { my $self = shift; $self->{'structio'}->write_seq(@_); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/Model.pm��������������������������������������������������������������000444��000765��000024�� 13017�12254227340� 17566� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Structure::Model # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright Kris Boulez # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::Model - Bioperl structure Object, describes a Model =head1 SYNOPSIS #add synopsis here =head1 DESCRIPTION This object stores a Bio::Structure::Chain =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::Model; use strict; use Bio::Structure::Entry; use Bio::Structure::Chain; use base qw(Bio::Root::Root); =head2 new() Title : new() Usage : $struc = Bio::Structure::Model->new( -id => 'human_id', ); Function: Returns a new Bio::Structure::Model object from basic constructors. Probably most called from Bio::Structure::IO. Returns : a new Bio::Structure::Model object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($id, $chain, $residue ) = $self->_rearrange([qw( ID CHAIN RESIDUE )], @args); $id && $self->id($id); $chain && $self->throw("you have to add chain via an Entry object\n"); $residue && $self->throw("you have to add residues via an Entry object\n"); return $self; } =head2 chain() Title : chain Usage : Function: will eventually allow parent/child navigation not via an Entry object Returns : Args : =cut sub chain { my ($self,$value) = @_; $self->throw("go via an Entry object\n"); } =head2 add_chain() Title : add_chain Usage : Function: will eventually allow parent/child navigation not via an Entry object Returns : Args : =cut sub add_chain { my ($self,$value) = @_; $self->throw("go via an Entry object for now\n"); } =head2 entry() Title : entry Usage : Function: will eventually allow parent/child navigation not via an Entry object Returns : Args : =cut sub entry { my($self) = @_; $self->throw("Model::entry go via an Entry object please\n"); } =head2 id() Title : id Usage : $model->id("model 5") Function: Gets/sets the ID for this model Returns : the ID Args : the ID =cut sub id { my ($self, $value) = @_;; if (defined $value) { $self->{'id'} = $value; } return $self->{'id'}; } =head2 residue() Title : residue Usage : Function: will eventually allow parent/child navigation not via an Entry object Returns : Args : =cut sub residue { my ($self, @args) = @_; $self->throw("need to go via Entry object or learn symbolic refs\n"); } =head2 add_residue() Title : add_residue Usage : Function: will eventually allow parent/child navigation not via an Entry object Returns : Args : =cut sub add_residue { my ($self, @args) = @_; $self->throw("go via entry->add_residue(chain, residue)\n"); } sub DESTROY { my $self = shift; # no specific DESTROY for now } # # from here on only private methods # =head2 _remove_chains() Title : _remove_chains Usage : Function: Removes the chains attached to a Model. Tells the chains they don't belong to this Model any more Returns : Args : =cut sub _remove_chains { my ($self) = shift; $self->throw("use Entry methods pleae\n"); } =head2 _remove_entry() Title : _remove_entry Usage : Function: Removes the Entry this Model is atttached to. Returns : Args : =cut sub _remove_entry { my ($self) = shift; $self->throw("use a method based on an Entry object\n"); } =head2 _create_default_chain() Title : _create_default_chain Usage : Function: Creates a default Chain for this Model. Typical situation in an X-ray structure where there is only one chain Returns : Args : =cut sub _create_default_chain { my ($self) = shift; my $chain = Bio::Structure::Chain->new(-id => "default"); } =head2 _grandparent() Title : _grandparent Usage : Function: get/set a symbolic reference to our grandparent Returns : Args : =cut sub _grandparent { my($self,$symref) = @_; if (ref($symref)) { $self->throw("Thou shall only pass strings in here, no references $symref\n"); } if (defined $symref) { $self->{'grandparent'} = $symref; } return $self->{'grandparent'}; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/Residue.pm������������������������������������������������������������000444��000765��000024�� 11615�12254227322� 20130� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Structure::Residue # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright Kris Boulez # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::Residue - Bioperl structure Object, describes a Residue =head1 SYNOPSIS #add synopsis here =head1 DESCRIPTION This object stores a Bio::Structure::Residue =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::Residue; use strict; use Bio::Structure::Chain; use Bio::Structure::Atom; use base qw(Bio::Root::Root); =head2 new() Title : new() Usage : $residue = Bio::Structure::Residue->new( -id => 'human_id', ); Function: Returns a new Bio::Structure::Residue object from basic constructors. Probably most called from Bio::Structure::IO. Returns : a new Bio::Structure::Residue object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my($id, $atom ) = $self->_rearrange([qw( ID ATOM )], @args); $id && $self->id($id); $self->{'atom'} = []; # the 'smallest' (and only) item that can be added to a residue is an atom $atom && $self->throw("add atoms via an Entry object entry->add_atom(residue,atom)\n"); return $self; } =head2 atom() Title : atom Usage : Function: nothing useful untill I get symbolic references to do what I want Returns : Args : =cut sub atom { my ($self,$value) = @_; $self->throw("no code down here, go see an Entry object nearby\n"); } =head2 add_atom() Title : add_atom Usage : Function: nothing useful untill I get symbolic references to do what I want Returns : Args : =cut sub add_atom { my($self,$value) = @_; $self->throw("nothing here, use a method on an Entry object\n"); } =head2 chain() Title : chain Usage : $chain = $residue->chain($chain) Function: Sets the Chain this Residue belongs to Returns : Returns the Chain this Residue belongs to Args : reference to a Chain =cut sub chain { my($self, $value) = @_; $self->throw("use an Entry based method please\n"); } =head2 id() Title : id Usage : $residue->id("TRP-35") Function: Gets/sets the ID for this residue Returns : the ID Args : the ID =cut sub id { my ($self, $value) = @_;; if (defined $value) { $self->{'id'} = $value; } return $self->{'id'}; } =head2 DESTROY() Title : DESTROY Usage : Function: destructor ( get rid of circular references ) Returns : Args : =cut sub DESTROY { my $self = shift; # no specific destruction for now } # # from here on only private methods # =head2 _remove_atoms() Title : _remove_atoms Usage : Function: Removes the atoms attached to a Residue. Tells the atoms they don't belong to this Residue any more Returns : Args : =cut sub _remove_atoms { my ($self) = shift; $self->throw("no code here\n"); } =head2 _remove_chain() Title : _remove_chain Usage : Function: Removes the Chain this Residue is atttached to. Returns : Args : =cut sub _remove_chain { my ($self) = shift; $self->{'chain'} = undef; } =head2 _grandparent() Title : _grandparent Usage : Function: get/set a symbolic reference to our grandparent Returns : Args : =cut sub _grandparent { my($self,$symref) = @_; if (ref($symref)) { $self->throw("Thou shall only pass strings in here, no references $symref\n"); } if (defined $symref) { $self->{'grandparent'} = $symref; } return $self->{'grandparent'}; } 1; �������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/StructureI.pm���������������������������������������������������������000444��000765��000024�� 3353�12254227322� 20621� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Structure::StructureI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright Kris Boulez # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::StructureI - Abstract Interface for a Structure objects =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the interface here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::StructureI; use strict; use base qw(Bio::Root::RootI); 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/IO��������������������������������������������������������������������000755��000765��000024�� 0�12254227331� 16320� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/IO/pdb.pm�������������������������������������������������������������000444��000765��000024�� 131277�12254227331� 17633� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Structure::IO::pdb # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Kris Boulez <kris.boulez@algonomics.com> # # Copyright 2001, 2002 Kris Boulez # # Framework is a copy of Bio::SeqIO::embl.pm # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Structure::IO::pdb - PDB input/output stream =head1 SYNOPSIS It is probably best not to use this object directly, but rather go through the Bio::Structure::IO handler system. Go: $stream = Bio::Structure::IO->new(-file => $filename, -format => 'PDB'); while (my $structure = $stream->next_structure) { # do something with $structure } =head1 DESCRIPTION This object can transform Bio::Structure objects to and from PDB flat file databases. The working is similar to that of the Bio::SeqIO handlers. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Kris Boulez Email kris.boulez@algonomics.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Structure::IO::pdb; use strict; use Bio::Structure::Entry; #use Bio::Structure::Model; #use Bio::Structure::Chain; #use Bio::Structure::Residue; use Bio::Structure::Atom; use Bio::SeqFeature::Generic; use Bio::Annotation::Reference; use base qw(Bio::Structure::IO); sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($noheader, $noatom) = $self->_rearrange([qw( NOHEADER NOATOM )], @args); $noheader && $self->_noheader($noheader); $noatom && $self->_noatom($noatom); } =head2 next_structure; Title : next_structure Usage : $struc = $stream->next_structure() Function: returns the next structure in the stream Returns : Bio::Structure object Args : =cut sub next_structure { my ($self,@args) = @_; my ($line); my ($obslte, $title, $caveat, $compnd, $source, $keywds, $expdta, $author, %revdat, $revdat, $sprsde, $jrnl, %remark, $dbref, $turn, $ssbond, $link, $hydbnd, $sltbrg, $cispep, $site, $cryst1, $tvect,); my $struc = Bio::Structure::Entry->new(-id => 'created from pdb.pm'); my $all_headers = ( !$self->_noheader ); # we'll parse all headers and store as annotation my %header; # stores all header RECORDs an is stored as annotations when ATOM is reached $line = $self->_readline; # This needs to be before the first eof() test if( !defined $line ) { return; # no throws - end of file } if( $line =~ /^\s+$/ ) { while( defined ($line = $self->_readline) ) { $line =~/\S/ && last; } } if( !defined $line ) { return; # end of file } $line =~ /^HEADER\s+\S+/ || $self->throw("PDB stream with no HEADER. Not pdb in my book"); my($header_line) = unpack "x10 a56", $line; $header{'header'} = $header_line; my($class, $depdate, $idcode) = unpack "x10 a40 a9 x3 a4", $line; $idcode =~ s/^\s*(\S+)\s*$/$1/; $struc->id($idcode); $self->debug("PBD c $class d $depdate id $idcode\n"); # XXX KB my $buffer = $line; BEFORE_COORDINATES : until( !defined $buffer ) { $_ = $buffer; # Exit at start of coordinate section last if /^(MODEL|ATOM|HETATM)/; # OBSLTE line(s) if (/^OBSLTE / && $all_headers) { $obslte = $self->_read_PDB_singlecontline("OBSLTE","12-70",\$buffer); $header{'obslte'} = $obslte; } # TITLE line(s) if (/^TITLE / && $all_headers) { $title = $self->_read_PDB_singlecontline("TITLE","11-70",\$buffer); $header{'title'} = $title; } # CAVEAT line(s) if (/^CAVEAT / && $all_headers) { $caveat = $self->_read_PDB_singlecontline("CAVEAT","12-70",\$buffer); $header{'caveat'} = $caveat; } # COMPND line(s) if (/^COMPND / && $all_headers) { $compnd = $self->_read_PDB_singlecontline("COMPND","11-70",\$buffer); $header{'compnd'} = $compnd; $self->debug("get COMPND $compnd\n"); } # SOURCE line(s) if (/^SOURCE / && $all_headers) { $source = $self->_read_PDB_singlecontline("SOURCE","11-70",\$buffer); $header{'source'} = $source; } # KEYWDS line(s) if (/^KEYWDS / && $all_headers) { $keywds = $self->_read_PDB_singlecontline("KEYWDS","11-70",\$buffer); $header{'keywds'} = $keywds; } # EXPDTA line(s) if (/^EXPDTA / && $all_headers) { $expdta = $self->_read_PDB_singlecontline("EXPDTA","11-70",\$buffer); $header{'expdta'} = $expdta; } # AUTHOR line(s) if (/^AUTHOR / && $all_headers) { $author = $self->_read_PDB_singlecontline("AUTHOR","11-70",\$buffer); $header{'author'} = $author; } # REVDAT line(s) # a bit more elaborate as we also store the modification number if (/^REVDAT / && $all_headers) { ##my($modnum,$rol) = unpack "x7 A3 x3 A53", $_; ##$modnum =~ s/\s+//; # remove spaces ##$revdat{$modnum} .= $rol; my ($rol) = unpack "x7 a59", $_; $revdat .= $rol; $header{'revdat'} = $revdat; } # SPRSDE line(s) if (/^SPRSDE / && $all_headers) { $sprsde = $self->_read_PDB_singlecontline("SPRSDE","12-70",\$buffer); $header{'sprsde'} = $sprsde; } # jRNL line(s) if (/^JRNL / && $all_headers) { $jrnl = $self->_read_PDB_jrnl(\$buffer); $struc->annotation->add_Annotation('reference',$jrnl); $header{'jrnl'} = 1; # when writing out, we need a way to check there was a JRNL record (not mandatory) } # REMARK line(s) # we only parse the "REMARK 1" lines (additional references) # thre rest is stored in %remark (indexed on remarkNum) (pack does space-padding) if (/^REMARK\s+(\d+)\s*/ && $all_headers) { my $remark_num = $1; if ($remark_num == 1) { my @refs = $self->_read_PDB_remark_1(\$buffer); # How can we find the primary reference when writing (JRNL record) XXX KB foreach my $ref (@refs) { $struc->annotation->add_Annotation('reference', $ref); } # $_ still holds the REMARK_1 line, $buffer now contains the first non # REMARK_1 line. We need to parse it in this pass (so no else block) $_ = $buffer; } # for the moment I don't see a better solution (other then using goto) if (/^REMARK\s+(\d+)\s*/) { my $r_num = $1; if ($r_num != 1) { # other remarks, we store literlly at the moment my ($rol) = unpack "x11 a59", $_; $remark{$r_num} .= $rol; } } } # REMARK # DBREF line(s) # references to sequences in other databases # we store as 'dblink' annotations and whole line as simple annotation (round-trip) if (/^DBREF / && $all_headers) { my ($rol) = unpack "x7 a61", $_; $dbref .= $rol; $header{'dbref'} = $dbref; my ($db, $acc) = unpack "x26 a6 x1 a8", $_; $db =~ s/\s*$//; $acc =~ s/\s*$//; my $link = Bio::Annotation::DBLink->new; $link->database($db); $link->primary_id($acc); $struc->annotation->add_Annotation('dblink', $link); } # DBREF # SEQADV line(s) if (/^SEQADV / && $all_headers) { my ($rol) = unpack "x7 a63", $_; $header{'seqadv'} .= $rol; } # SEQADV # SEQRES line(s) # this is (I think) the sequence of macromolecule that was analysed # this will be returned when doing $struc->seq if (/^SEQRES / && $all_headers) { my ($rol) = unpack "x8 a62", $_; $header{'seqres'} .= $rol; } # SEQRES # MODRES line(s) if (/^MODRES / && $all_headers) { my ($rol) = unpack "x7 a63", $_; $header{'modres'} .= $rol; } # MODRES # HET line(s) if (/^HET / && $all_headers) { my ($rol) = unpack "x7 a63", $_; $header{'het'} .= $rol; } # HET # HETNAM line(s) if (/^HETNAM / && $all_headers) { my ($rol) = unpack "x8 a62", $_; $header{'hetnam'} .= $rol; } # HETNAM # HETSYN line(s) if (/^HETSYN / && $all_headers) { my ($rol) = unpack "x8 a62", $_; $header{'hetsyn'} .= $rol; } # HETSYN # FORMUL line(s) if (/^FORMUL / && $all_headers) { my ($rol) = unpack "x8 a62", $_; $header{'formul'} .= $rol; } # FORMUL # HELIX line(s) # store as specific object ?? if (/^HELIX / && $all_headers) { my ($rol) = unpack "x7 a69", $_; $header{'helix'} .= $rol; } # HELIX # SHEET line(s) # store as specific object ?? if (/^SHEET / && $all_headers) { my ($rol) = unpack "x7 a63", $_; $header{'sheet'} .= $rol; } # SHEET # TURN line(s) # store as specific object ?? if (/^TURN / && $all_headers) { my ($rol) = unpack "x7 a63", $_; $turn .= $rol; $header{'turn'} = $turn; } # TURN # SSBOND line(s) # store in connection-like object (see parsing of CONECT record) if (/^SSBOND / && $all_headers) { my ($rol) = unpack "x7 a65", $_; $ssbond .= $rol; $header{'ssbond'} = $ssbond; } # SSBOND # LINK # store like SSBOND ? if (/^LINK / && $all_headers) { my ($rol) = unpack "x12 a60", $_; $link .= $rol; $header{'link'} = $link; } # LINK # HYDBND # store like SSBOND if (/^HYDBND / && $all_headers) { my ($rol) = unpack "x12 a60", $_; $hydbnd .= $rol; $header{'hydbnd'} = $hydbnd; } # HYDBND # SLTBRG # store like SSBOND ? if (/^SLTBRG / && $all_headers) { my ($rol) = unpack "x12 a60",$_; $sltbrg .= $rol; $header{'sltbrg'} = $sltbrg; } # SLTBRG # CISPEP # store like SSBOND ? if (/^CISPEP / && $all_headers) { my ($rol) = unpack "x7 a52", $_; $cispep .= $rol; $header{'cispep'} = $cispep; } # SITE line(s) if (/^SITE / && $all_headers) { my ($rol) = unpack "x7 a54", $_; $site .= $rol; $header{'site'} = $site; } # SITE # CRYST1 line # store in some crystallographic subobject ? if (/^CRYST1/ && $all_headers) { my ($rol) = unpack "x6 a64", $_; $cryst1 .= $rol; $header{'cryst1'} = $cryst1; } # CRYST1 # ORIGXn line(s) (n=1,2,3) if (/^(ORIGX\d) / && $all_headers) { my $origxn = lc($1); my ($rol) = unpack "x10 a45", $_; $header{$origxn} .= $rol; } # ORIGXn # SCALEn line(s) (n=1,2,3) if (/^(SCALE\d) / && $all_headers) { my $scalen = lc($1); my ($rol) = unpack "x10 a45", $_; $header{$scalen} .= $rol; } # SCALEn # MTRIXn line(s) (n=1,2,3) if (/^(MTRIX\d) / && $all_headers) { my $mtrixn = lc($1); my ($rol) = unpack "x7 a53", $_; $header{$mtrixn} .= $rol; } # MTRIXn # TVECT line(s) if (/^TVECT / && $all_headers) { my ($rol) = unpack "x7 a63", $_; $tvect .= $rol; $header{'tvect'} = $tvect; } # Get next line. $buffer = $self->_readline; } # store %header entries a annotations if (%header) { for my $record (keys %header) { my $sim = Bio::Annotation::SimpleValue->new(); $sim->value($header{$record}); $struc->annotation->add_Annotation($record, $sim); } } # store %remark entries as annotations if (%remark) { for my $remark_num (keys %remark) { my $sim = Bio::Annotation::SimpleValue->new(); $sim->value($remark{$remark_num}); $struc->annotation->add_Annotation("remark_$remark_num", $sim); } } # Coordinate section, the real meat # # $_ contains a line beginning with (ATOM|MODEL) $buffer = $_; if (defined($buffer) && $buffer =~ /^(ATOM |MODEL |HETATM)/ ) { # can you have an entry without ATOM ? while( defined ($buffer) ) { # (yes : 1a7z ) # read in one model at a time my $model = $self->_read_PDB_coordinate_section(\$buffer, $struc); # add this to $struc $struc->add_model($struc, $model); if ($buffer && $buffer !~ /^MODEL /) { # if we get here we have multiple MODELs last; } } } else { $self->throw("Could not find a coordinate section in this record\n"); } until( !defined $buffer ) { $_ = $buffer; # CONNECT records if (/^CONECT/) { # do not differentiate between different type of connect (column dependant) my $conect_unpack = "x6 a5 a5 a5 a5 a5 a5 a5 a5 a5 a5 a5"; my (@conect) = unpack $conect_unpack, $_; for my $k (0 .. $#conect) { $conect[$k] =~ s/\s//g; } my $source = shift @conect; my $type; for my $k (0 .. 9) { next unless ($conect[$k] =~ /^\d+$/); # 0..3 bond if( $k <= 3 ) { $type = "bond"; } # 4..5,7..8 hydrogen bonded elsif( ($k >= 4 && $k <= 5) || ($k >= 7 && $k <= 8) ) { $type = "hydrogen"; } # 6, 9 salt bridged elsif( $k == 6 || $k == 9 ) { $type = "saltbridged"; } else { $self->throw("k has impossible value ($k), check brain"); } $struc->conect($source, $conect[$k], $type); } } # MASTER record if (/^MASTER /) { # the numbers in here a checksums, we should use them :) my ($rol) = unpack "x10 a60", $_; $struc->master($rol); } if (/^END/) { # this it the end ... } $buffer = $self->_readline; } return $struc; } =head2 write_structure Title : write_structure Usage : $stream->write_structure($struc) Function: writes the $struc object (must be a Bio::Structure) to the stream Returns : 1 for success and 0 for error Args : Bio::Structure object =cut sub write_structure { my ($self, $struc) = @_; if( !defined $struc ) { $self->throw("Attempting to write with no structure!"); } if( ! ref $struc || ! $struc->isa('Bio::Structure::StructureI') ) { $self->throw(" $struc is not a StructureI compliant module."); } my ($ann, $string, $output_string, $key); # HEADER ($ann) = $struc->annotation->get_Annotations("header"); if (defined $ann) { $string = $ann->as_text; $string =~ s/^Value: //; $output_string = pack ("A10 A56", "HEADER", $string); } else { # not read in via read_structure, create HEADER line my $id = $struc->id; if (!$id) { $id = "UNK1"; } if (length($id) > 4) { $id = substr($id,0,4); } my $classification = "DEFAULT CLASSIFICATION"; my $dep_date = "24-JAN-70"; $output_string = pack ("A10 A40 A12 A4", "HEADER", $classification, $dep_date, $id); } $output_string .= " " x (80 - length($output_string) ); $self->_print("$output_string\n"); my (%header); for $key ($struc->annotation->get_all_annotation_keys) { $header{$key} = 1;; } exists $header{'obslte'} && $self->_write_PDB_simple_record(-name => "OBSLTE ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("obslte"), -rol => "11-70"); exists $header{'title'} && $self->_write_PDB_simple_record(-name => "TITLE ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("title"), -rol => "11-70"); exists $header{'caveat'} && $self->_write_PDB_simple_record(-name => "CAVEAT ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("caveat"), -rol => "12-70"); exists $header{'compnd'} && $self->_write_PDB_simple_record(-name => "COMPND ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("compnd"), -rol => "11-70"); exists $header{'source'} && $self->_write_PDB_simple_record(-name => "SOURCE ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("source"), -rol => "11-70"); exists $header{'keywds'} && $self->_write_PDB_simple_record(-name => "KEYWDS ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("keywds"), -rol => "11-70"); exists $header{'expdta'} && $self->_write_PDB_simple_record(-name => "EXPDTA ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("expdta"), -rol => "11-70"); exists $header{'author'} && $self->_write_PDB_simple_record(-name => "AUTHOR ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("author"), -rol => "11-70"); exists $header{'revdat'} && $self->_write_PDB_simple_record(-name => "REVDAT ", -annotation => $struc->annotation->get_Annotations("revdat"), -rol => "8-66"); exists $header{'sprsde'} && $self->_write_PDB_simple_record(-name => "SPRSDE ", -cont => "9-10", -annotation => $struc->annotation->get_Annotations("sprsde"), -rol => "12-70"); # JRNL en REMARK 1 my ($jrnl_done, $remark_1_counter); if ( !exists $header{'jrnl'} ) { $jrnl_done = 1; } foreach my $ref ($struc->annotation->get_Annotations('reference') ) { if( !$jrnl_done ) { # JRNL record $ref->authors && $self->_write_PDB_simple_record(-name => "JRNL AUTH", -cont => "17-18", -rol => "20-70", -string => $ref->authors ); $ref->title && $self->_write_PDB_simple_record(-name => "JRNL TITL", -cont => "17-18", -rol => "20-70", -string => $ref->title ); $ref->editors && $self->_write_PDB_simple_record(-name => "JRNL EDIT", -cont => "17-18", -rol => "20-70", -string => $ref->editors ); $ref->location && $self->_write_PDB_simple_record(-name => "JRNL REF ", -cont => "17-18", -rol => "20-70", -string => $ref->location ); $ref->editors && $self->_write_PDB_simple_record(-name => "JRNL EDIT", -cont => "17-18", -rol => "20-70", -string => $ref->editors ); $ref->encoded_ref && $self->_write_PDB_simple_record(-name => "JRNL REFN", -cont => "17-18", -rol => "20-70", -string => $ref->encoded_ref ); $jrnl_done = 1; } else { # REMARK 1 if (!$remark_1_counter) { # header line my $remark_1_header_line = "REMARK 1" . " " x 70; $self->_print("$remark_1_header_line\n"); $remark_1_counter = 1; } # per reference header my $rem_line = "REMARK 1 REFERENCE " . $remark_1_counter; $rem_line .= " " x (80 - length($rem_line) ); $self->_print($rem_line,"\n"); $ref->authors && $self->_write_PDB_simple_record(-name => "REMARK 1 AUTH", -cont => "17-18", -rol => "20-70", -string => $ref->authors ); $ref->title && $self->_write_PDB_simple_record(-name => "REMARK 1 TITL", -cont => "17-18", -rol => "20-70", -string => $ref->title ); $ref->editors && $self->_write_PDB_simple_record(-name => "REMARK 1 EDIT", -cont => "17-18", -rol => "20-70", -string => $ref->editors ); $ref->location && $self->_write_PDB_simple_record(-name => "REMARK 1 REF ", -cont => "17-18", -rol => "20-70", -string => $ref->location ); $ref->editors && $self->_write_PDB_simple_record(-name => "REMARK 1 EDIT", -cont => "17-18", -rol => "20-70", -string => $ref->editors ); $ref->encoded_ref && $self->_write_PDB_simple_record(-name => "REMARK 1 REFN", -cont => "17-18", -rol => "20-70", -string => $ref->encoded_ref ); $remark_1_counter++; } } if (! defined $remark_1_counter ) { # no remark 1 record written yet my $remark_1_header_line = "REMARK 1" . " " x 70; $self->_print("$remark_1_header_line\n"); # write dummy (we need this line) } # REMARK's (not 1 at the moment, references) my (%remarks, $remark_num); for $key (keys %header) { next unless ($key =~ /^remark_(\d+)$/); next if ($1 == 1); $remarks{$1} = 1; } for $remark_num (sort {$a <=> $b} keys %remarks) { $self->_write_PDB_remark_record($struc, $remark_num); } exists $header{'dbref'} && $self->_write_PDB_simple_record(-name => "DBREF ", -annotation => $struc->annotation->get_Annotations("dbref"), -rol => "8-68"); exists $header{'seqadv'} && $self->_write_PDB_simple_record(-name => "SEQADV ", -annotation => $struc->annotation->get_Annotations("seqadv"), -rol => "8-70"); exists $header{'seqres'} && $self->_write_PDB_simple_record(-name => "SEQRES ", -annotation => $struc->annotation->get_Annotations("seqres"), -rol => "9-70"); exists $header{'modres'} && $self->_write_PDB_simple_record(-name => "MODRES ", -annotation => $struc->annotation->get_Annotations("modres"), -rol => "8-70"); exists $header{'het'} && $self->_write_PDB_simple_record(-name => "HET ", -annotation => $struc->annotation->get_Annotations("het"), -rol => "8-70"); exists $header{'hetnam'} && $self->_write_PDB_simple_record(-name => "HETNAM ", -annotation => $struc->annotation->get_Annotations("hetnam"), -rol => "9-70"); exists $header{'hetsyn'} && $self->_write_PDB_simple_record(-name => "HETSYN ", -annotation => $struc->annotation->get_Annotations("hetsyn"), -rol => "9-70"); exists $header{'formul'} && $self->_write_PDB_simple_record(-name => "FORMUL ", -annotation => $struc->annotation->get_Annotations("formul"), -rol => "9-70"); exists $header{'helix'} && $self->_write_PDB_simple_record(-name => "HELIX ", -annotation => $struc->annotation->get_Annotations("helix"), -rol => "8-76"); exists $header{'sheet'} && $self->_write_PDB_simple_record(-name => "SHEET ", -annotation => $struc->annotation->get_Annotations("sheet"), -rol => "8-70"); exists $header{'turn'} && $self->_write_PDB_simple_record(-name => "TURN ", -annotation => $struc->annotation->get_Annotations("turn"), -rol => "8-70"); exists $header{'ssbond'} && $self->_write_PDB_simple_record(-name => "SSBOND ", -annotation => $struc->annotation->get_Annotations("ssbond"), -rol => "8-72"); exists $header{'link'} && $self->_write_PDB_simple_record(-name => "LINK ", -annotation => $struc->annotation->get_Annotations("link"), -rol => "13-72"); exists $header{'hydbnd'} && $self->_write_PDB_simple_record(-name => "HYDBND ", -annotation => $struc->annotation->get_Annotations("hydbnd"), -rol => "13-72"); exists $header{'sltbrg'} && $self->_write_PDB_simple_record(-name => "SLTBRG ", -annotation => $struc->annotation->get_Annotations("sltbrg"), -rol => "13-72"); exists $header{'cispep'} && $self->_write_PDB_simple_record(-name => "CISPEP ", -annotation => $struc->annotation->get_Annotations("cispep"), -rol => "8-59"); exists $header{'site'} && $self->_write_PDB_simple_record(-name => "SITE ", -annotation => $struc->annotation->get_Annotations("site"), -rol => "8-61"); exists $header{'cryst1'} && $self->_write_PDB_simple_record(-name => "CRYST1", -annotation => $struc->annotation->get_Annotations("cryst1"), -rol => "7-70"); for my $k (1..3) { my $origxn = "origx".$k; my $ORIGXN = uc($origxn)." "; exists $header{$origxn} && $self->_write_PDB_simple_record(-name => $ORIGXN, -annotation => $struc->annotation->get_Annotations($origxn), -rol => "11-55"); } for my $k (1..3) { my $scalen = "scale".$k; my $SCALEN = uc($scalen)." "; exists $header{$scalen} && $self->_write_PDB_simple_record(-name => $SCALEN, -annotation => $struc->annotation->get_Annotations($scalen), -rol => "11-55"); } for my $k (1..3) { my $mtrixn = "mtrix".$k; my $MTRIXN = uc($mtrixn)." "; exists $header{$mtrixn} && $self->_write_PDB_simple_record(-name => $MTRIXN, -annotation => $struc->annotation->get_Annotations($mtrixn), -rol => "8-60"); } exists $header{'tvect'} && $self->_write_PDB_simple_record(-name => "TVECT ", -annotation => $struc->annotation->get_Annotations("tvect"), -rol => "8-70"); # write out coordinate section # my %het_res; # hetero residues $het_res{'HOH'} = 1; # water is default if (exists $header{'het'}) { my ($het_line) = ($struc->annotation->get_Annotations("het"))[0]->as_text; $het_line =~ s/^Value: //; for ( my $k = 0; $k <= length $het_line ; $k += 63) { my $l = substr $het_line, $k, 63; $l =~ s/^\s*(\S+)\s+.*$/$1/; $het_res{$l} = 1; } } for my $model ($struc->get_models) { # more then one model ? if ($struc->get_models > 1) { my $model_line = sprintf("MODEL %4d", $model->id); $model_line .= " " x (80 - length($model_line) ); $self->_print($model_line, "\n"); } for my $chain ($struc->get_chains($model)) { my ($residue, $atom, $resname, $resnum, $atom_line, $atom_serial, $atom_icode, $chain_id); my ($prev_resname, $prev_resnum, $prev_atomicode); # need these for TER record my $last_record = ""; # Used to spot an ATOM -> HETATM change within a chain $chain_id = $chain->id; if ( $chain_id eq "default" ) { $chain_id = " "; } $self->debug("model_id: $model->id chain_id: $chain_id\n"); for $residue ($struc->get_residues($chain)) { ($resname, $resnum) = split /-/, $residue->id; for $atom ($struc->get_atoms($residue)) { if ($het_res{$resname}) { # HETATM if ( $resname ne "HOH" && $last_record eq "ATOM " ) { # going from ATOM -> HETATM, we have to write TER my $ter_line = "TER "; $ter_line .= sprintf("%5d", $atom_serial + 1); $ter_line .= " "; $ter_line .= sprintf("%3s ", $prev_resname); $ter_line .= $chain_id; $ter_line .= sprintf("%4d", $prev_resnum); $ter_line .= $atom_icode ? $prev_atomicode : " "; # 27 $ter_line .= " " x (80 - length $ter_line); # extend to 80 chars $self->_print($ter_line,"\n"); } $atom_line = "HETATM"; } else { $atom_line = "ATOM "; } $last_record = $atom_line; $atom_line .= sprintf("%5d ", $atom->serial); $atom_serial = $atom->serial; # we need it for TER record $atom_icode = $atom->icode; # remember some stuff if next iteration needs writing TER $prev_resname = $resname; $prev_resnum = $resnum; $prev_atomicode = $atom_icode; # getting the name of the atom correct is subtrivial my $atom_id = $atom->id; # is pdb_atomname set, then use this (most probably set when # reading in the PDB record) my $pdb_atomname = $atom->pdb_atomname; if( defined $pdb_atomname ) { $atom_line .= sprintf("%-4s", $pdb_atomname); } else { # start (educated) guessing my $element = $atom->element; if( defined $element && $element ne "H") { # element should be at first two positions (right justified) # ie. Calcium should be "CA " # C alpha should be " CA " if( length($element) == 2 ) { $atom_line .= sprintf("%-4s", $atom->id); } else { $atom_line .= sprintf(" %-3s", $atom->id); } } else { # old behaviour do a best guess if ($atom->id =~ /^\dH/) { # H: four positions, left justified $atom_line .= sprintf("%-4s", $atom->id); } elsif (length($atom_id) == 4) { if ($atom_id =~ /^(H\d\d)(\d)$/) { # turn H123 into 3H12 $atom_line .= $2.$1; } else { # no more guesses, no more alternatives $atom_line .= $atom_id; } } else { # if we get here and it is not correct let me know $atom_line .= sprintf(" %-3s", $atom->id); } } } # we don't do alternate location at this moment $atom_line .= " "; # 17 $atom_line .= sprintf("%3s",$resname); # 18-20 $atom_line .= " ".$chain_id; # 21, 22 $atom_line .= sprintf("%4d", $resnum); # 23-26 $atom_line .= $atom->icode ? $atom->icode : " "; # 27 $atom_line .= " "; # 28-30 $atom_line .= sprintf("%8.3f", $atom->x); # 31-38 $atom_line .= sprintf("%8.3f", $atom->y); # 39-46 $atom_line .= sprintf("%8.3f", $atom->z); # 47-54 $atom_line .= sprintf("%6.2f", $atom->occupancy); # 55-60 $atom_line .= sprintf("%6.2f", $atom->tempfactor); # 61-66 $atom_line .= " "; # 67-72 $atom_line .= $atom->segID ? # segID 73-76 sprintf("%-4s", $atom->segID) : " "; $atom_line .= $atom->element ? sprintf("%2s", $atom->element) : " "; $atom_line .= $atom->charge ? sprintf("%2s", $atom->charge) : " "; $self->_print($atom_line,"\n"); } } # write out TER record if ( $resname ne "HOH" ) { my $ter_line = "TER "; $ter_line .= sprintf("%5d", $atom_serial + 1); $ter_line .= " "; $ter_line .= sprintf("%3s ", $resname); $ter_line .= $chain_id; $ter_line .= sprintf("%4d", $resnum); $ter_line .= $atom_icode ? $atom_icode : " "; # 27 $ter_line .= " " x (80 - length $ter_line); # extend to 80 chars $self->_print($ter_line,"\n"); } } if ($struc->get_models > 1) { # we need ENDMDL my $endmdl_line = "ENDMDL" . " " x 74; $self->_print($endmdl_line, "\n"); } } # for my $model # CONECT my @sources = $struc->get_all_conect_source; my ($conect_line,@conect, @bond, @hydbond, @saltbridge, $to, $type); for my $source (@sources) { # get all conect's my @conect = $struc->conect($source); # classify for my $con (@conect) { ($to, $type) = split /_/, $con; if($type eq "bond") { push @bond, $to; } elsif($type eq "hydrogenbonded") { push @hydbond, $to; } elsif($type eq "saltbridged") { push @saltbridge, $to; } else { $self->throw("type $type is unknown for conect"); } } # and write out CONECT lines as long as there is something # in one of the arrays while ( @bond || @hydbond || @saltbridge) { my ($b, $hb, $sb); $conect_line = "CONECT". sprintf("%5d", $source); for my $k (0..3) { $b = shift @bond; $conect_line .= $b ? sprintf("%5d", $b) : " "; } for my $k (4..5) { $hb = shift @hydbond; $conect_line .= $hb ? sprintf("%5d", $hb) : " "; } $sb = shift @saltbridge; $conect_line .= $sb ? sprintf("%5d", $sb) : " "; for my $k (7..8) { $hb = shift @hydbond; $conect_line .= $hb ? sprintf("%5d", $hb) : " "; } $sb = shift @saltbridge; $conect_line .= $sb ? sprintf("%5d", $sb) : " "; $conect_line .= " " x (80 - length($conect_line) ); $self->_print($conect_line, "\n"); } } # MASTER line contains checksums, we should calculate them of course :) my $master_line = "MASTER " . $struc->master; $master_line .= " " x (80 - length($master_line) ); $self->_print($master_line, "\n"); my $end_line = "END" . " " x 77; $self->_print($end_line,"\n"); } =head2 _filehandle Title : _filehandle Usage : $obj->_filehandle($newval) Function: Example : Returns : value of _filehandle Args : newvalue (optional) =cut sub _filehandle{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_filehandle'} = $value; } return $obj->{'_filehandle'}; } =head2 _noatom Title : _noatom Usage : $obj->_noatom($newval) Function: Example : Returns : value of _noatom Args : newvalue (optional) =cut sub _noatom{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_noatom'} = $value; } return $obj->{'_noatom'}; } =head2 _noheader Title : _noheader Usage : $obj->_noheader($newval) Function: Example : Returns : value of _noheader Args : newvalue (optional) =cut sub _noheader{ my ($obj,$value) = @_; if( defined $value) { $obj->{'_noheader'} = $value; } return $obj->{'_noheader'}; } =head2 _read_PDB_singlecontline Title : _read_PDB_singlecontline Usage : $obj->_read_PDB_singlecontline($record, $fromto, $buffer)) Function: read single continued record from PDB Returns : concatenated record entry (between $fromto columns) Args : record, colunm delimiters, buffer =cut sub _read_PDB_singlecontline { my ($self, $record, $fromto, $buffer) = @_; my $concat_line; my ($begin, $end) = (split (/-/, $fromto)); my $unpack_string = "x8 a2 "; if($begin == 12) { # one additional space $unpack_string .= "x1 a59"; } else { $unpack_string .= "a60"; } $_ = $$buffer; while (defined( $_ ||= $self->_readline ) ) { if ( /^$record/ ) { my($cont, $rol) = unpack $unpack_string, $_; if($cont =~ /\d$/ && $begin == 11) { # continuation line # and text normally at pos 11 $rol =~ s/^\s//; # strip leading space } ## no space (store litteraly) $concat_line .= $rol . " "; $concat_line .= $rol; } else { last; } $_ = undef; } $concat_line =~ s/\s$//; # remove trailing space $$buffer = $_; return $concat_line; } =head2 _read_PDB_jrnl Title : _read_PDB_jrnl Usage : $obj->_read_PDB_jrnl($\buffer)) Function: read jrnl record from PDB Returns : Bio::Annotation::Reference object Args : =cut sub _read_PDB_jrnl { my ($self, $buffer) = @_; $_ = $$buffer; my ($auth, $titl,$edit,$ref,$publ,$refn, $pmid, $doi); while (defined( $_ ||= $self->_readline )) { if (/^JRNL /) { # this code belgons in a seperate method (shared with # remark 1 parsing) my ($rec, $subr, $cont, $rol) = unpack "A6 x6 A4 A2 x1 A51", $_; $auth = $self->_concatenate_lines($auth,$rol) if ($subr eq "AUTH"); $titl = $self->_concatenate_lines($titl,$rol) if ($subr eq "TITL"); $edit = $self->_concatenate_lines($edit,$rol) if ($subr eq "EDIT"); $ref = $self->_concatenate_lines($ref ,$rol) if ($subr eq "REF"); $publ = $self->_concatenate_lines($publ,$rol) if ($subr eq "PUBL"); $refn = $self->_concatenate_lines($refn,$rol) if ($subr eq "REFN"); $pmid = $self->_concatenate_lines($pmid,$rol) if ($subr eq "PMID"); $doi = $self->_concatenate_lines($doi,$rol) if ($subr eq "DOI"); } else { last; } $_ = undef; # trigger reading of next line } # while $$buffer = $_; my $jrnl_ref = Bio::Annotation::Reference->new; $jrnl_ref->authors($auth); $jrnl_ref->title($titl); $jrnl_ref->location($ref); $jrnl_ref->publisher($publ); $jrnl_ref->editors($edit); $jrnl_ref->encoded_ref($refn); $jrnl_ref->pubmed($pmid); $jrnl_ref->doi($doi); return $jrnl_ref; } # sub _read_PDB_jrnl =head2 _read_PDB_remark_1 Title : _read_PDB_remark_1 Usage : $obj->_read_PDB_remark_1($\buffer)) Function: read "remark 1" record from PDB Returns : array of Bio::Annotation::Reference objects Args : =cut sub _read_PDB_remark_1 { my ($self, $buffer) = @_; $_ = $$buffer; my ($auth, $titl,$edit,$ref,$publ,$refn,$refnum,$pmid, $doi); my @refs; while (defined( $_ ||= $self->_readline )) { if (/^REMARK 1 /) { if (/^REMARK 1\s+REFERENCE\s+(\d+)\s*/) { $refnum = $1; if ($refnum != 1) { # this is first line of a reference my $rref = Bio::Annotation::Reference->new; $rref->authors($auth); $rref->title($titl); $rref->location($ref); $rref->publisher($publ); $rref->editors($edit); $rref->encoded_ref($refn); $rref->pubmed($pmid); $rref->doi($doi); $auth = $titl = $edit = $ref = $publ = $refn = undef; push @refs, $rref; } } else { # this code belgons in a seperate method (shared with # remark 1 parsing) my ($rec, $subr, $cont, $rol) = unpack "A6 x6 A4 A2 x1 A51", $_; $auth = $self->_concatenate_lines($auth,$rol) if ($subr eq "AUTH"); $titl = $self->_concatenate_lines($titl,$rol) if ($subr eq "TITL"); $edit = $self->_concatenate_lines($edit,$rol) if ($subr eq "EDIT"); $ref = $self->_concatenate_lines($ref ,$rol) if ($subr eq "REF"); $publ = $self->_concatenate_lines($publ,$rol) if ($subr eq "PUBL"); $refn = $self->_concatenate_lines($refn,$rol) if ($subr eq "REFN"); $pmid = $self->_concatenate_lines($pmid,$rol) if ($subr eq "PMID"); $doi = $self->_concatenate_lines($doi,$rol) if ($subr eq "DOI"); } } else { # have we seen any reference at all (could be single REMARK 1 line if ( ! defined ($refnum) ) { last; # get out of while() } # create last reference my $rref = Bio::Annotation::Reference->new; $rref->authors($auth); $rref->title($titl); $rref->location($ref); $rref->publisher($publ); $rref->editors($edit); $rref->encoded_ref($refn); $rref->pubmed($pmid); $rref->doi($doi); push @refs, $rref; last; } $_ = undef; # trigger reading of next line } # while $$buffer = $_; return @refs; } # sub _read_PDB_jrnl =head2 _read_PDB_coordinate_section Title : _read_PDB_coordinate_section Usage : $obj->_read_PDB_coordinate_section($\buffer)) Function: read one model from a PDB Returns : Bio::Structure::Model object Args : =cut sub _read_PDB_coordinate_section { my ($self, $buffer, $struc) = @_; my ($model_num, $chain_name, $residue_name, $atom_name); # to keep track of state $model_num = ""; $chain_name = ""; $residue_name = ""; $atom_name = ""; my $atom_unpack = "x6 a5 x1 a4 a1 a3 x1 a1 a4 a1 x3 a8 a8 a8 a6 a6 x6 a4 a2 a2"; my $anisou_unpack = "x6 a5 x1 a4 a1 a3 x1 a1 a4 a1 x1 a7 a7 a7 a7 a7 a7 a4 a2 a2"; my $model = Bio::Structure::Model->new; $model->id('default'); my $noatom = $self->_noatom; my ($chain, $residue, $atom, $old); my (%_ch_in_model); # which chains are already in this model $_ = $$buffer; while (defined( $_ ||= $self->_readline )) { # start of a new model if (/^MODEL\s+(\d+)/) { $model_num = $1; $self->debug("_read_PDB_coor: parsing model $model_num\n"); $model->id($model_num); if (/^MODEL\s+\d+\s+\S+/) { # old format (pre 2.1) $old = 1; } } # old hier ook setten XXX # ATOM lines, if first set chain if (/^(ATOM |HETATM|SIGATM)/) { my @line_elements = unpack $atom_unpack, $_; my $pdb_atomname = $line_elements[1]; # need to get this before removing spaces for my $k (0 .. $#line_elements) { $line_elements[$k] =~ s/^\s+//; # remove leading space $line_elements[$k] =~ s/\s+$//; # remove trailing space $line_elements[$k] = undef if ($line_elements[$k] =~ /^\s*$/); } my ($serial, $atomname, $altloc, $resname, $chainID, $resseq, $icode, $x, $y, $z, $occupancy, $tempfactor, $segID, $element, $charge) = @line_elements; $chainID = 'default' if ( !defined $chainID ); if ($chainID ne $chain_name) { # possibly a new chain # fix for bug #1187 # we can have ATOM/HETATM of an already defined chain (A B A B) # e.g. 1abm if (exists $_ch_in_model{$chainID} ) { # we have already seen this chain in this model $chain = $_ch_in_model{$chainID}; } else { # we create a new chain $chain = Bio::Structure::Chain->new; $struc->add_chain($model,$chain); $chain->id($chainID); $_ch_in_model{$chainID} = $chain; } $chain_name = $chain->id; } #my $res_name_num = $resname."-".$resseq; my $res_name_num = $resname."-".$resseq; $res_name_num .= '.'.$icode if $icode; if ($res_name_num ne $residue_name) { # new residue $residue = Bio::Structure::Residue->new; $struc->add_residue($chain,$residue); $residue->id($res_name_num); $residue_name = $res_name_num; $atom_name = ""; # only needed inside a residue } # get out of here if we don't want the atom objects if ($noatom) { $_ = undef; next; } # alternative location: only take first one if ( $altloc && ($altloc =~ /\S+/) && ($atomname eq $atom_name) ) { $_ = undef; # trigger reading next line next; } if (/^(ATOM |HETATM)/) { # ATOM / HETATM $atom_name = $atomname; $atom = Bio::Structure::Atom->new; $struc->add_atom($residue,$atom); $atom->id($atomname); $atom->pdb_atomname($pdb_atomname); # store away PDB atomname for writing out $atom->serial($serial); $atom->icode($icode); $atom->x($x); $atom->y($y); $atom->z($z); $atom->occupancy($occupancy); $atom->tempfactor($tempfactor); $atom->segID($segID); # deprecated but used by people if (! $old ) { $atom->element($element); $atom->charge($charge); } } else { # SIGATM my $sigx = $x; my $sigy = $y; my $sigz = $z; my $sigocc = $occupancy; my $sigtemp = $tempfactor; if ($atom_name ne $atomname) { # something wrong with PDB file $self->throw("A SIGATM record should have the same $atomname as the previous record $atom_name\n"); } $atom->sigx($sigx); $atom->sigy($sigy); $atom->sigz($sigz); $atom->sigocc($sigocc); $atom->sigtemp($sigtemp); } } # ATOM|HETARM|SIGATM # ANISOU | SIGUIJ lines if (/^(ANISOU|SIGUIJ)/) { if ($noatom) { $_ = undef; next; } my @line_elements = unpack $anisou_unpack, $_; for my $k (0 .. $#line_elements) { $line_elements[$k] =~ s/^\s+//; # remove leading space $line_elements[$k] =~ s/\s+$//; # remove trailing space $line_elements[$k] = undef if ($line_elements[$k] =~ /^\s*$/); } my ($serial, $atomname, $altloc, $resname, $chainID, $resseq, $icode, $u11,$u22, $u33, $u12, $u13, $u23, $segID, $element, $charge) = @line_elements; $self->debug("read_PDB_coor: parsing ANISOU record: $serial $atomname\n"); if ( $altloc && ($altloc =~ /\S+/) && ($atomname eq $atom_name) ) { $_ = undef; next; } if (/^ANISOU/) { if ($atom_name ne $atomname) { # something wrong with PDB file $self->throw("A ANISOU record should have the same $atomname as the previous record $atom_name\n"); } $atom->aniso("u11",$u11); $atom->aniso("u22",$u22); $atom->aniso("u33",$u33); $atom->aniso("u12",$u12); $atom->aniso("u13",$u13); $atom->aniso("u23",$u23); } else { # SIGUIJ if ($atom_name ne $atomname) { # something wrong with PDB file $self->throw("A SIGUIJ record should have the same $atomname as the previous record $atom_name\n"); } # could use different variable names, but hey ... $atom->aniso("sigu11",$u11); $atom->aniso("sigu22",$u22); $atom->aniso("sigu33",$u33); $atom->aniso("sigu12",$u12); $atom->aniso("sigu13",$u13); $atom->aniso("sigu23",$u23); } } # ANISOU | SIGUIJ if (/^TER /) { $_ = undef; next; } if (/^ENDMDL/) { $_ = $self->_readline; last; } if (/^(CONECT|MASTER)/) { # get out of here # current line is OK last; } $_ = undef; } # while $$buffer = $_; return $model; } # _read_PDB_coordinate_section sub _write_PDB_simple_record { my ($self, @args) = @_; my ($name, $cont , $annotation, $rol, $string) = $self->_rearrange([qw( NAME CONT ANNOTATION ROL STRING )], @args); if (defined $string && defined $annotation) { $self->throw("you can only supply one of -annoation or -string"); } my ($output_string, $ann_string, $t_string); my ($rol_begin, $rol_end) = $rol =~ /^(\d+)-(\d+)$/; my $rol_length = $rol_end - $rol_begin +1; if ($string) { if (length $string > $rol_length) { # we might need to split $string in multiple lines while (length $string > $rol_length) { # other option might be to go for a bunch of substr's my @c = split//,$string; my $t = $rol_length; # index into @c while ($c[$t] ne " ") { # find first space, going backwards $self->debug("c[t]: $c[$t] $t\n"); $t--; if ($t == 0) { $self->throw("Found no space for $string\n"); } } $self->debug("t: $t rol_length: $rol_length\n"); $ann_string .= substr($string, 0, $t); $self->debug("ann_string: $ann_string\n"); $ann_string .= " " x ($rol_length - $t ); $string = substr($string, $t+1); $string =~ s/^\s+//; $self->debug("ann_string: $ann_string~~\nstring: $string~~\n"); } $ann_string .= $string; } else { $ann_string = $string; } } else { $ann_string = $annotation->as_text; $ann_string =~ s/^Value: //; } # ann_string contains the thing to write out, writing out happens below my $ann_length = length $ann_string; $self->debug("ann_string: $ann_string\n"); if ($cont) { my ($c_begin, $c_end) = $cont =~ /^(\d+)-(\d+)$/; if ( $ann_length > $rol_length ) { # we need to continuation lines my $first_line = 1; my $cont_number = 2; my $out_line; my $num_pos = $rol_length; my $i = 0; while( $i < $ann_length ) { $t_string = substr($ann_string, $i, $num_pos); $self->debug("t_string: $t_string~~$i $num_pos\n"); if ($first_line) { $out_line = $name . " " x ($rol_begin - $c_begin) . $t_string; $out_line .= " " x (80 - length($out_line) ) . "\n"; $first_line = 0; $output_string = $out_line; $i += $num_pos; # first do counter if ($rol_begin - $c_end == 1) { # next line one character less $num_pos--; } } else { $out_line = $name . sprintf("%2d",$cont_number); # a space after continuation number if ($rol_begin - $c_end == 1) { # one space after cont number $out_line .= " "; $out_line .= $t_string; } else { $out_line .= " " x ($rol_begin - $c_end - 1) . $t_string; } $out_line .= " " x (80 -length($out_line) ) . "\n"; $cont_number++; $output_string .= $out_line; $i += $num_pos; } } } else { # no continuation my $spaces = $rol_begin - $c_begin; # number of spaces need to insert $output_string = $name . " " x $spaces . $ann_string; $output_string .= " " x (80 - length($output_string) ); } } else { # no contintuation lines if ($ann_length < $rol_length) { $output_string = $name . $ann_string; $output_string .= " " x (80 - length($output_string) ); } else { for (my $i = 0; $i < $ann_length; $i += $rol_length) { my $out_line; $t_string = substr($ann_string, $i, $rol_length); $out_line = $name . $t_string; $out_line .= " " x (80 -length($out_line) ) . "\n"; $output_string .= $out_line; } } } $output_string =~ s/\n$//; # remove trailing newline $self->_print("$output_string\n"); } sub _write_PDB_remark_record { my ($self, $struc, $remark_num) = @_; my ($ann) = $struc->annotation->get_Annotations("remark_$remark_num"); my $name = sprintf("REMARK %3d ",$remark_num); $self->_write_PDB_simple_record(-name => $name, -annotation => $ann, -rol => "12-70"); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/SecStr����������������������������������������������������������������000755��000765��000024�� 0�12254227321� 17213� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/SecStr/DSSP�����������������������������������������������������������000755��000765��000024�� 0�12254227321� 17764� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/SecStr/DSSP/Res.pm����������������������������������������������������000444��000765��000024�� 106373�12254227321� 21262� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Header$ # # bioperl module for Bio::Structure::SecStr::DSSP::Res.pm # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ed Green <ed@compbio.berkeley.edu> # # Copyright Univ. of California # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Structure::SecStr::DSSP::Res - Module for parsing/accessing dssp output =head1 SYNOPSIS my $dssp_obj = Bio::Structure::SecStr::DSSP::Res->new('-file'=>'filename.dssp'); # or my $dssp_obj = Bio::Structure::SecStr::DSSP::Res->new('-fh'=>\*STDOUT); # get DSSP defined Secondary Structure for residue 20 $sec_str = $dssp_obj->resSecStr( 20 ); # get dssp defined sec. structure summary for PDB residue # 10 of chain A $sec_str = $dssp_obj->resSecStrSum( '10:A' ); =head1 DESCRIPTION DSSP::Res is a module for objectifying DSSP output. Methods are then available for extracting all the information within the output file and convenient subsets of it. The principal purpose of DSSP is to determine secondary structural elements of a given structure. ( Dictionary of protein secondary structure: pattern recognition of hydrogen-bonded and geometrical features. Biopolymers. 1983 Dec;22(12):2577-637. ) The DSSP program is available from: http://www.cmbi.kun.nl/swift/dssp This information is available on a per residue basis ( see resSecStr and resSecStrSum methods ) or on a per chain basis ( see secBounds method ). resSecStr() & secBounds() return one of the following: 'H' = alpha helix 'B' = residue in isolated beta-bridge 'E' = extended strand, participates in beta ladder 'G' = 3-helix (3/10 helix) 'I' = 5 helix (pi helix) 'T' = hydrogen bonded turn 'S' = bend '' = no assignment A more general classification is returned using the resSecStrSum() method. The purpose of this is to have a method for DSSP and STRIDE derived output whose range is the same. Its output is one of the following: 'H' = helix ( => 'H', 'G', or 'I' from above ) 'B' = beta ( => 'B' or 'E' from above ) 'T' = turn ( => 'T' or 'S' from above ) ' ' = no assignment ( => ' ' from above ) The methods are roughly divided into 3 sections: 1. Global features of this structure (PDB ID, total surface area, etc.). These methods do not require an argument. 2. Residue specific features ( amino acid, secondary structure, solvent exposed surface area, etc. ). These methods do require an argument. The argument is supposed to uniquely identify a residue described within the structure. It can be of any of the following forms: ('#A:B') or ( #, 'A', 'B' ) || | || - Chain ID (blank for single chain) |--- Insertion code for this residue. Blank for most residues. |--- Numeric portion of residue ID. (#) | --- Numeric portion of residue ID. If there is only one chain and it has no ID AND there is no residue with an insertion code at this number, then this can uniquely specify a residue. ('#:C') or ( #, 'C' ) | | | -Chain ID ---Numeric portion of residue ID. If a residue is incompletely specified then the first residue that fits the arguments is returned. For example, if 19 is the argument and there are three chains, A, B, and C with a residue whose number is 19, then 19:A will be returned (assuming its listed first). Since neither DSSP nor STRIDE correctly handle alt-loc codes, they are not supported by these modules. 3. Value-added methods. Return values are not verbatem strings parsed from DSSP or STRIDE output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ed Green Email ed@compbio.berkeley.edu =head1 APPENDIX The rest of the documentation details each method. Internal methods are preceded with a _ =cut package Bio::Structure::SecStr::DSSP::Res; use strict; use Bio::Root::IO; use Bio::PrimarySeq; use base qw(Bio::Root::Root); # Would be a class variable if Perl had them #attribute begin col # columns our %lookUp = ( 'pdb_resnum' => [ 5, 5 ], 'insertionco' => [ 10, 1 ], 'pdb_chain' => [ 11, 1 ], 'amino_acid' => [ 13, 1 ], 'term_sig' => [ 14, 1 ], 'ss_summary' => [ 16, 1 ], '3tph' => [ 18, 1 ], '4tph' => [ 19, 1 ], '5tph' => [ 20, 1 ], 'geo_bend' => [ 21, 1 ], 'chirality' => [ 22, 1 ], 'beta_br1la' => [ 23, 1 ], 'beta_br2la' => [ 24, 1 ], 'bb_part1nu' => [ 25, 4 ], 'bb_part2nu' => [ 29, 4 ], 'betash_lab' => [ 33, 1 ], 'solv_acces' => [ 34, 4 ], 'hb1_nh_o_p' => [ 39, 6 ], 'hb1_nh_o_e' => [ 46, 4 ], 'hb1_o_hn_p' => [ 50, 6 ], 'hb1_o_hn_e' => [ 57, 4 ], 'hb2_nh_o_p' => [ 61, 6 ], 'hb2_nh_o_e' => [ 68, 4 ], 'hb2_o_hn_p' => [ 72, 6 ], 'hb2_o_hn_e' => [ 79, 4 ], 'tco' => [ 85, 6 ], 'kappa' => [ 91, 6 ], 'alpha' => [ 97, 6 ], 'phi' => [ 103, 6 ], 'psi' => [ 109, 6 ], 'x_ca' => [ 115, 7 ], 'y_ca' => [ 122, 7 ], 'z_ca' => [ 129, 7 ] ); =head1 CONSTRUCTOR =cut =head2 new Title : new Usage : makes new object of this class Function : Constructor Example : $dssp_obj = Bio::DSSP:Res->new( filename or FILEHANDLE ) Returns : object (ref) Args : filename ( must be proper DSSP output file ) =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my $io = Bio::Root::IO->new( @args ); $self->_parse( $io->_fh() ); $io->close(); return $self; } =head1 ACCESSORS =cut # GLOBAL FEATURES / INFO / STATS =head2 totSurfArea Title : totSurfArea Usage : returns total accessible surface area in square And. Function : Example : $surArea = $dssp_obj->totSurfArea(); Returns : scalar Args : none =cut sub totSurfArea { my $self = shift; return $self->{ 'Head' }->{ 'ProAccSurf' }; } =head2 numResidues Title : numResidues Usage : returns the total number of residues in all chains or just the specified chain if a chain is specified Function : Example : $num_res = $dssp_obj->numResidues(); Returns : scalar int Args : none =cut sub numResidues { my $self = shift; my $chain = shift; if ( !( $chain ) ) { return $self->{'Head'}->{'TotNumRes'}; } else { my ( $num_res, $cont_seg ); my $cont_seg_pnt = $self->_contSegs(); foreach $cont_seg ( @{ $cont_seg_pnt } ) { if ( $chain eq $cont_seg->[ 2 ] ) { # this segment is part of the chain we want $num_res += ( $self->_toDsspKey( $cont_seg->[ 1 ] ) - $self->_toDsspKey( $cont_seg->[ 0 ] ) + 1 ); # this works because we know the # the region between the start # and end of a dssp key is # continuous } } return $num_res; } } # STRAIGHT FROM PDB ENTRY =head2 pdbID Title : pdbID Usage : returns pdb identifier ( 1FJM, e.g.) Function : Example : $pdb_id = $dssp_obj->pdbID(); Returns : scalar string Args : none =cut sub pdbID { my $self = shift; return $self->{'Head'}->{'PDB'}; } =head2 pdbAuthor Title : pdbAuthor Usage : returns author field Function : Example : $auth = $dssp_obj->pdbAuthor() Returns : scalar string Args : none =cut sub pdbAuthor { my $self = shift; return $self->{'Head'}->{'AUTHOR'}; } =head2 pdbCompound Title : pdbCompound Usage : returns pdbCompound given in PDB file Function : Example : $cmpd = $dssp_obj->pdbCompound(); Returns : scalar string Args : none =cut sub pdbCompound { my $self = shift; return $self->{'Head'}->{'COMPND'}; } =head2 pdbDate Title : pdbDate Usage : returns date given in PDB file Function : Example : $pdb_date = $dssp_obj->pdbDate(); Returns : scalar Args : none =cut sub pdbDate { my $self = shift; return $self->{'Head'}->{'DATE'}; } =head2 pdbHeader Title : pdbHeader Usage : returns header info from PDB file Function : Example : $header = $dssp_obj->pdbHeader(); Returns : scalar Args : none =cut sub pdbHeader { my $self = shift; return $self->{'Head'}->{'HEADER'}; } =head2 pdbSource Title : pdbSource Usage : returns pdbSource information from PDBSOURCE line Function : Example : $pdbSource = $dssp_obj->pdbSource(); Returns : scalar Args : none =cut sub pdbSource { my $self = shift; return $self->{'Head'}->{'SOURCE'}; } # RESIDUE SPECIFIC ACCESSORS =head2 resAA Title : resAA Usage : fetches the 1 char amino acid code, given an id Function : Example : $aa = $dssp_obj->resAA( '20:A' ); # pdb id as arg Returns : 1 character scalar string Args : RESIDUE_ID =cut sub resAA { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'amino_acid' }; } =head2 resPhi Title : resPhi Usage : returns phi angle of a single residue Function : accessor Example : $phi = $dssp_obj->resPhi( RESIDUE_ID ) Returns : scalar Args : RESIDUE_ID =cut sub resPhi { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'phi' }; } =head2 resPsi Title : resPsi Usage : returns psi angle of a single residue Function : accessor Example : $psi = $dssp_obj->resPsi( RESIDUE_ID ) Returns : scalar Args : RESIDUE_ID =cut sub resPsi { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'psi' }; } =head2 resSolvAcc Title : resSolvAcc Usage : returns solvent exposed area of this residue in square Andstroms Function : Example : $solv_acc = $dssp_obj->resSolvAcc( RESIDUE_ID ); Returns : scalar Args : RESIDUE_ID =cut sub resSolvAcc { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'solv_acces' }; } =head2 resSurfArea Title : resSurfArea Usage : returns solvent exposed area of this residue in square Andstroms Function : Example : $solv_acc = $dssp_obj->resSurfArea( RESIDUE_ID ); Returns : scalar Args : RESIDUE_ID =cut sub resSurfArea { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'solv_acces' }; } =head2 resSecStr Title : resSecStr Usage : $ss = $dssp_obj->resSecStr( RESIDUE_ID ); Function : returns the DSSP secondary structural designation of this residue Example : Returns : a character ( 'B', 'E', 'G', 'H', 'I', 'S', 'T', or ' ' ) Args : RESIDUE_ID NOTE : The range of this method differs from that of the resSecStr method in the STRIDE SecStr parser. That is because of the slightly different format for STRIDE and DSSP output. The resSecStrSum method exists to map these different ranges onto an identical range. =cut sub resSecStr { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); my $ss_char = $self->{ 'Res' }->[ $dssp_key ]->{ 'ss_summary' }; return $ss_char if $ss_char; return ' '; } =head2 resSecStrSum Title : resSecStrSum Usage : $ss = $dssp_obj->resSecStrSum( $id ); Function : returns what secondary structure group this residue belongs to. One of: 'H': helix ( H, G, or I ) 'B': beta ( B or E ) 'T': turn ( T or S ) ' ': none ( ' ' ) This method is similar to resSecStr, but the information it returns is less specific. Example : Returns : a character ( 'H', 'B', 'T', or ' ' ) Args : dssp residue number of pdb residue identifier =cut sub resSecStrSum { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); my $ss_char = $self->{ 'Res' }->[ $dssp_key ]->{ 'ss_summary' }; if ( $ss_char eq 'H' || $ss_char eq 'G' || $ss_char eq 'I' ) { return 'H'; } if ( $ss_char eq ' ' || !( $ss_char ) ) { return ' '; } if ( $ss_char eq 'B' || $ss_char eq 'E' ) { return 'B'; } else { return 'T'; } } # DSSP SPECIFIC =head2 hBonds Title : hBonds Usage : returns number of 14 different types of H Bonds Function : Example : $hb = $dssp_obj->hBonds Returns : pointer to 14 element array of ints Args : none NOTE : The different type of H-Bonds reported are, in order: TYPE O(I)-->H-N(J) IN PARALLEL BRIDGES IN ANTIPARALLEL BRIDGES TYPE O(I)-->H-N(I-5) TYPE O(I)-->H-N(I-4) TYPE O(I)-->H-N(I-3) TYPE O(I)-->H-N(I-2) TYPE O(I)-->H-N(I-1) TYPE O(I)-->H-N(I+0) TYPE O(I)-->H-N(I+1) TYPE O(I)-->H-N(I+2) TYPE O(I)-->H-N(I+3) TYPE O(I)-->H-N(I+4) TYPE O(I)-->H-N(I+5) =cut sub hBonds { my $self = shift; return $self->{ 'HBond'}; } =head2 numSSBr Title : numSSBr Usage : returns info about number of SS-bridges Function : Example : @SS_br = $dssp_obj->numSSbr(); Returns : 3 element scalar int array Args : none =cut sub numSSBr { my $self = shift; return ( $self->{'Head'}->{'TotSSBr'}, $self->{'Head'}->{'TotIaSSBr'}, $self->{'Head'}->{'TotIeSSBr'} ); } =head2 resHB_O_HN Title : resHB_O_HN Usage : returns pointer to a 4 element array consisting of: relative position of binding partner #1, energy of that bond (kcal/mol), relative positionof binding partner #2, energy of that bond (kcal/mol). If the bond is not bifurcated, the second bond is reported as 0, 0.0 Function : accessor Example : $oBonds_ptr = $dssp_obj->resHB_O_HN( RESIDUE_ID ) Returns : pointer to 4 element array Args : RESIDUE_ID =cut sub resHB_O_HN { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return ( $self->{ 'Res' }->[ $dssp_key ]->{ 'hb1_o_hn_p' }, $self->{ 'Res' }->[ $dssp_key ]->{ 'hb1_o_hn_e' }, $self->{ 'Res' }->[ $dssp_key ]->{ 'hb2_o_hn_p' }, $self->{ 'Res' }->[ $dssp_key ]->{ 'hb2_o_hn_e' } ); } =head2 resHB_NH_O Title : resHB_NH_O Usage : returns pointer to a 4 element array consisting of: relative position of binding partner #1, energy of that bond (kcal/mol), relative positionof binding partner #2, energy of that bond (kcal/mol). If the bond is not bifurcated, the second bond is reported as 0, 0.0 Function : accessor Example : $nhBonds_ptr = $dssp_obj->resHB_NH_O( RESIDUE_ID ) Returns : pointer to 4 element array Args : RESIDUE_ID =cut sub resHB_NH_O { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return ( $self->{ 'Res' }->[ $dssp_key ]->{ 'hb1_nh_o_p' }, $self->{ 'Res' }->[ $dssp_key ]->{ 'hb1_nh_o_e' }, $self->{ 'Res' }->[ $dssp_key ]->{ 'hb2_nh_o_p' }, $self->{ 'Res' }->[ $dssp_key ]->{ 'hb2_nh_o_e' } ); } =head2 resTco Title : resTco Usage : returns tco angle around this residue Function : accessor Example : resTco = $dssp_obj->resTco( RESIDUE_ID ) Returns : scalar Args : RESIDUE_ID =cut sub resTco { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'tco' }; } =head2 resKappa Title : resKappa Usage : returns kappa angle around this residue Function : accessor Example : $kappa = $dssp_obj->resKappa( RESIDUE_ID ) Returns : scalar Args : RESIDUE_ID ( dssp or PDB ) =cut sub resKappa { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'kappa' }; } =head2 resAlpha Title : resAlpha Usage : returns alpha angle around this residue Function : accessor Example : $alpha = $dssp_obj->resAlpha( RESIDUE_ID ) Returns : scalar Args : RESIDUE_ID ( dssp or PDB ) =cut sub resAlpha { my $self = shift; my @args = @_; my $dssp_key = $self->_toDsspKey( @args ); return $self->{ 'Res' }->[ $dssp_key ]->{ 'alpha' }; } # VALUE ADDED METHODS (NOT JUST PARSE/REPORT) =head2 secBounds Title : secBounds Usage : gets residue ids of boundary residues in each contiguous secondary structural element of specified chain Function : returns pointer to array of 3 element arrays. First two elements are the PDB IDs of the start and end points, respectively and inclusively. The last element is the DSSP secondary structural assignment code, i.e. one of : ('B', 'E', 'G', 'H', 'I', 'S', 'T', or ' ') Example : $ss_elements_pts = $dssp_obj->secBounds( 'A' ); Returns : pointer to array of arrays Args : chain id ( 'A', for example ). No arg => no chain id =cut sub secBounds { my $self = shift; my $chain = shift; my %sec_bounds; $chain = '-' if ( !( $chain ) || $chain eq ' ' || $chain eq '-' ); # if we've memoized this chain, use that if ( $self->{ 'SecBounds' } ) { # check to make sure chain is valid if ( !( $self->{ 'SecBounds' }->{ $chain } ) ) { $self->throw( "No such chain: $chain\n" ); } return $self->{ 'SecBounds' }->{ $chain }; } my ( $cur_element, $i, $cur_chain, $beg, ); #initialize $cur_element = $self->{ 'Res' }->[ 1 ]->{ 'ss_summary' }; $beg = 1; for ( $i = 2; $i <= $self->_numResLines() - 1; $i++ ) { if ( $self->{ 'Res' }->[ $i ]->{ 'amino_acid' } eq '!' ) { # element is terminated by a chain discontinuity push( @{ $sec_bounds{ $self->_pdbChain( $beg ) } }, [ $self->_toPdbId( $beg ), $self->_toPdbId( $i - 1 ), $cur_element ] ); $i++; $beg = $i; $cur_element = $self->{ 'Res' }->[ $i ]->{ 'ss_summary' }; } elsif ( $self->{ 'Res' }->[ $i ]->{ 'ss_summary' } ne $cur_element ) { # element is terminated by beginning of a new element push( @{ $sec_bounds{ $self->_pdbChain( $beg ) } }, [ $self->_toPdbId( $beg ), $self->_toPdbId( $i - 1 ), $cur_element ] ); $beg = $i; $cur_element = $self->{ 'Res' }->[ $i ]->{ 'ss_summary' }; } } #last residue if ( $self->{ 'Res' }->[ $i ]->{ 'ss_summary' } eq $cur_element ) { push( @{ $sec_bounds{ $self->_pdbChain( $beg ) } }, [ $self->_toPdbId( $beg ), $self->_toPdbId( $i ), $cur_element ] ); } else { push( @{ $sec_bounds{ $self->_pdbChain( $beg ) } }, [ $self->_toPdbId( $beg ), $self->_toPdbId( $i - 1 ), $cur_element ] ); push( @{ $sec_bounds{ $self->_pdbChain( $i ) } }, [ $self->_toPdbId( $i ), $self->_toPdbId( $i ), $self->{ 'Res' }->[ $i ]->{ 'ss_summary' } ] ); } $self->{ 'SecBounds' } = \%sec_bounds; # check to make sure chain is valid if ( !( $self->{ 'SecBounds' }->{ $chain } ) ) { $self->throw( "No such chain: $chain\n" ); } return $self->{ 'SecBounds' }->{ $chain }; } =head2 chains Title : chains Usage : returns pointer to array of chain I.D.s (characters) Function : Example : $chains_pnt = $dssp_obj->chains(); Returns : array of characters, one of which may be ' ' Args : none =cut sub chains { my $self = shift; my $cont_segs = $self->_contSegs(); my %chains; my $seg; foreach $seg ( @{ $cont_segs } ) { $chains{ $seg->[ 2 ] } = 1; } my @chains = keys( %chains ); return \@chains; } =head2 residues Title : residues Usage : returns array of residue identifiers for all residues in the output file, or in a specific chain Function : Example : @residues_ids = $dssp_obj->residues() Returns : array of residue identifiers Args : if none => returns residue ids of all residues of all chains (in order); if chain id is given, returns just the residue ids of residues in that chain =cut # Can't use the standard interface for getting the amino acid, # pdb_resnum, etc. in this method because we don't *know* the residue # indentifiers - we are building a list of them. sub residues { my $self = shift; my $chain = shift; my @residues; my $num_res = $self->_numResLines(); my $aa; for ( my $i = 1; $i <= $num_res; $i++ ) { # find what character was in the slot for tha amino acid code, # if it's a '!' we know this is not a *real* amino acid, it's # a chain discontinuity marker $aa = $self->{ 'Res' }->[ $i ]->{ 'amino_acid' }; if ( $aa ne '!' ) { if ( !$chain || $chain eq $self->{ 'Res' }->[ $i ]->{ 'pdb_chain' } ) { push( @residues, $self->{ 'Res' }->[ $i ]->{ 'pdb_resnum' }. $self->{ 'Res' }->[ $i ]->{ 'insertionco' }. ":". $self->{ 'Res' }->[ $i ]->{ 'pdb_chain' } ); } } } return @residues; } =head2 getSeq Title : getSeq Usage : returns a Bio::PrimarySeq object which represents a good guess at the sequence of the given chain Function : For most chains of most entries, the sequence returned by this method will be very good. However, it is inherently unsafe to rely on DSSP to extract sequence information about a PDB entry. More reliable information can be obtained from the PDB entry itself. Example : $pso = $dssp_obj->getSeq( 'A' ); Returns : (pointer to) a PrimarySeq object Args : Chain identifier. If none given, ' ' is assumed. If no ' ' chain, the first chain is used. =cut sub getSeq { my $self = shift; my $chain = shift; my ( $pot_chain, $seq, $frag_num, $frag, $curPdbNum, $lastPdbNum, $gap_len, $i, $id, ); my @frags; if ( !( $chain ) ) { $chain = ' '; } if ( $self->{ 'Seq' }->{ $chain } ) { return $self->{ 'Seq' }->{ $chain }; } my $contSegs_pnt = $self->_contSegs(); # load up specified chain foreach $pot_chain ( @{ $contSegs_pnt } ) { if ( $pot_chain->[ 2 ] eq $chain ) { push( @frags, $pot_chain ); } } # if that didn't work, just get the first one if ( !( @frags ) ) { $chain = $contSegs_pnt->[ 0 ]->[ 2 ]; foreach $pot_chain ( @{ $contSegs_pnt } ) { if ( $pot_chain->[ 2 ] eq $chain ) { push( @frags, $pot_chain ); } } } # now build the sequence string $seq = ""; $frag_num = 0; foreach $frag ( @frags ) { $frag_num++; if ( $frag_num > 1 ) { # we need to put in some gap seq $curPdbNum = $self->_pdbNum( $frag->[ 0 ] ); $gap_len = $curPdbNum - $lastPdbNum - 1; if ( $gap_len > 0 ) { $seq .= 'u' x $gap_len; } else { $seq .= 'u'; } } for ( $i = $frag->[ 0 ]; $i <= $frag->[ 1 ]; $i++ ) { $seq .= $self->_resAA( $i ); } $lastPdbNum = $self->_pdbNum( $i - 1 ); } $id = $self->pdbID(); $id .= ":$chain"; $self->{ 'Seq' }->{ $chain } = Bio::PrimarySeq->new ( -seq => $seq, -id => $id, -moltype => 'protein' ); return $self->{ 'Seq' }->{ $chain }; } =head1 INTERNAL METHODS =cut =head2 _pdbChain Title : _pdbChain Usage : returns the pdb chain id of given residue Function : Example : $chain_id = $dssp_obj->pdbChain( DSSP_KEY ); Returns : scalar Args : DSSP_KEY ( dssp or pdb ) =cut sub _pdbChain { my $self = shift; my $dssp_key = shift; return $self->{ 'Res' }->[ $dssp_key ]->{ 'pdb_chain' }; } =head2 _resAA Title : _resAA Usage : fetches the 1 char amino acid code, given a dssp id Function : Example : $aa = $dssp_obj->_resAA( dssp_id ); Returns : 1 character scalar string Args : dssp_id =cut sub _resAA { my $self = shift; my $dssp_key = shift; return $self->{ 'Res' }->[ $dssp_key ]->{ 'amino_acid' }; } =head2 _pdbNum Title : _pdbNum Usage : fetches the numeric portion of the identifier for a given residue as reported by the pdb entry. Note, this DOES NOT uniquely specify a residue. There may be an insertion code and/or chain identifier differences. Function : Example : $pdbNum = $self->_pdbNum( DSSP_ID ); Returns : a scalar Args : DSSP_ID =cut sub _pdbNum { my $self = shift; my $dssp_key = shift; return $self->{ 'Res' }->[ $dssp_key ]->{ 'pdb_resnum' }; } =head2 _pdbInsCo Title : _pdbInsCo Usage : fetches the Insertion Code for this residue, if it has one. Function : Example : $pdbNum = $self->_pdbInsCo( DSSP_ID ); Returns : a scalar Args : DSSP_ID =cut sub _pdbInsCo { my $self = shift; my $dssp_key = shift; return $self->{ 'Res' }->[ $dssp_key ]->{ 'insertionco' }; } =head2 _toPdbId Title : _toPdbId Usage : Takes a dssp key and builds the corresponding PDB identifier string Function : Example : $pdbId = $self->_toPdbId( DSSP_ID ); Returns : scalar Args : DSSP_ID =cut sub _toPdbId { my $self = shift; my $dssp_key = shift; my $pdbId = ( $self->_pdbNum( $dssp_key ). $self->_pdbInsCo( $dssp_key ) ); my $chain = $self->_pdbChain( $dssp_key ); $pdbId = "$pdbId:$chain" if $chain; return $pdbId; } =head2 _contSegs Title : _contSegs Usage : find the endpoints of continuous regions of this structure Function : returns pointer to array of 3 element array. Elements are the dssp keys of the start and end points of each continuous element and its PDB chain id (may be blank). Note that it is common to have several continuous elements with the same chain id. This occurs when an internal region is disordered and no structural information is available. Example : $cont_seg_ptr = $dssp_obj->_contSegs(); Returns : pointer to array of arrays Args : none =cut sub _contSegs { my $self = shift; if ( $self->{ 'contSegs' } ) { return $self->{ 'contSegs' }; } else { # first time, so make contSegs my ( $cur_chain, $i, $beg ); my @contSegs; #initialize $cur_chain = $self->_pdbChain( 1 ); $beg = 1; #internal residues for ( $i = 2; $i <= $self->_numResLines() - 1; $i++ ) { if ( $self->{ 'Res' }->[ $i ]->{ 'amino_acid' } eq '!' ) { push( @contSegs, [ $beg, $i - 1, $cur_chain ] ); $beg = $i + 1; $cur_chain = $self->_pdbChain( $i + 1 ); } } # last residue must be the end of a chain push( @contSegs, [ $beg, $i, $cur_chain ] ); $self->{ 'contSegs' } = \@contSegs; return $self->{ 'contSegs' }; } } =head2 _numResLines Title : _numResLines Usage : returns the total number of residue lines in this dssp file. This number is DIFFERENT than the number of residues in the pdb file because dssp has chain termination and chain discontinuity 'residues'. Function : Example : $num_res = $dssp_obj->_numResLines(); Returns : scalar int Args : none =cut sub _numResLines { my $self = shift; return ( $#{$self->{ 'Res' }} ); } =head2 _toDsspKey Title : _toDsspKey Usage : returns the unique dssp integer key given a pdb residue id. All accessor methods require (internally) the dssp key. This method is very useful in converting pdb keys to dssp keys so the accessors can accept pdb keys as argument. PDB Residue IDs are inherently problematic since they have multiple parts of overlapping function and ill-defined or observed convention in form. Input can be in any of the formats described in the DESCRIPTION section above. Function : Example : $dssp_id = $dssp_obj->_pdbKeyToDsspKey( '10B:A' ) Returns : scalar int Args : pdb residue identifier: num[insertion code]:[chain] =cut sub _toDsspKey { # Consider adding lookup table for 'common' name (like 20:A) for # fast access. Could be built during parse of input. my $self = shift; my ( $key_num, $chain_id, $ins_code ) = @_; if ( ! $chain_id) { # parse the lone argument ( $key_num, $chain_id, $ins_code ) = $key_num =~ m/([0-9]+) ([a-zA-z]?) (?::([a-zA-Z]))?/xms ? ( $1, $2, $3 ) : $self->throw("Could not derive PDB key $key_num"); } # Now find the residue which fits this description. Linear search is # probably not the best way to do this, but oh well... for ( my $i = 1; $i <= $self->_numResLines(); $i++ ) { unless ( ($self->{'Res'}->[$i]->{'term_sig'} eq '*') || ($self->{'Res'}->[$i]->{'amino_acid'} eq '!') ) { # chain break 'residue', doesn't match anything if ( $key_num == $self->{'Res'}->[$i]->{'pdb_resnum'} ) { if ( $chain_id ) { # if a chain was specified if ( $chain_id eq $self->{'Res'}->[$i]->{'pdb_chain'} ) { # and it's the right one if ( $ins_code ) { # if insertion code was specified if ( $ins_code eq $self->{'Res'}->[$i]->{'insertionco'} ) { # and it's the right one return $i; } } elsif ( $self->{'Res'}->[$i]->{'insertionco'} eq '' ) { # no isertion code specified, but need to check that the located residue doesn't have an insertion code E.g. pdb1aye fails on this return $i; } } } else { # no chain was specified return $i; } } } } $self->throw( "PDB key not found." ); } =head2 _parse Title : _parse Usage : parses dssp output Function : Example : used by the constructor Returns : Args : input source ( handled by Bio::Root:IO ) =cut sub _parse { my $self = shift; my $file = shift; my $cur; my $current_chain; my ( @elements, @hbond ); my ( %head, %his, ); my $element; my $res_num; $cur = <$file>; unless ( $cur =~ /^==== Secondary Structure Definition/ ) { $self->throw( "Not dssp output" ); return; } # REFERENCE line (always there) $cur = <$file>; ( $element ) = ( $cur =~ /^REFERENCE\s+(.+?)\s+\./ ); $head{ 'REFERENCE' } = $element; $cur = <$file>; # Check for HEADER line (not always there) if ( $cur =~ /^HEADER\s/ ) { @elements = split( /\s+/, $cur ); pop( @elements ); # take off that annoying period $head{ 'PDB' } = pop( @elements ); $head{ 'DATE' } = pop( @elements ); # now, everything else is "header" except for the word # HEADER shift( @elements ); $element = shift( @elements ); while ( @elements ) { $element = $element." ".shift( @elements ); } $head{ 'HEADER' } = $element; $cur = <$file>; } # Check for COMPND line (not always there) if ( $cur =~ /^COMPND\s/ ) { ($element) = ( $cur =~ /^COMPND\s+(.+?)\s+\./ ); $head{ 'COMPND' } = $element; $cur = <$file>; } # Check for SOURCE or PDBSOURCE line (not always there) if ( $cur =~ /^PDBSOURCE\s/ ) { ($element) = ( $cur =~ /^PDBSOURCE\s+(.+?)\s+\./ ); $head{ 'SOURCE' } = $element; $cur = <$file>; } elsif ( $cur =~ /^SOURCE\s/ ) { ($element) = ( $cur =~ /^SOURCE\s+(.+?)\s+\./ ); $head{ 'SOURCE' } = $element; $cur = <$file>; } # Check for AUTHOR line (not always there) if ( $cur =~ /^AUTHOR/ ) { ($element) = ( $cur =~ /^AUTHOR\s+(.+?)\s+/ ); $head{ 'AUTHOR' } = $element; $cur = <$file>; } # A B C D E TOTAL NUMBER OF RESIDUES, NUMBER ... line @elements = split( /\s+/, $cur ); shift( @elements ); $head{ 'TotNumRes' } = shift( @elements ); $head{ 'NumChain' } = shift( @elements ); $head{ 'TotSSBr' } = shift( @elements ); $head{ 'TotIaSSBr' } = shift( @elements ); $head{ 'TotIeSSBr' } = shift( @elements ); $cur = <$file>; ( $element ) = ( $cur =~ /\s*(\d+\.\d*)\s+ACCESSIBLE SURFACE OF PROTEIN/ ); $head{ 'ProAccSurf' } = $element; $self->{ 'Head' } = \%head; for ( my $i = 1; $i <= 14; $i++ ) { $cur = <$file>; ( $element ) = $cur =~ /\s*(\d+)\s+\d+\.\d+\s+TOTAL NUMBER OF HYDROGEN/; push( @hbond, $element ); # $hbond{ $hBondType } = $element; } $self->{ 'HBond' } = \@hbond; my $histogram_finished = 0; while ( !($histogram_finished) && chomp( $cur = <$file> ) ) { if ( $cur =~ /RESIDUE AA STRUCTURE/ ) { $histogram_finished = 1; } } while ( $cur = <$file> ) { if ( $cur =~ m/^\s*$/ ) { next; } $res_num = substr( $cur, 0, 5 ); $res_num =~ s/\s//g; $self->{ 'Res' }->[ $res_num ] = &_parseResLine( $cur ); } } =head2 _parseResLine Title : _parseResLine Usage : parses a single residue line Function : Example : used internally Returns : Args : residue line ( string ) =cut sub _parseResLine() { my $cur = shift; my ( $feat, $value ); my %elements; foreach $feat ( keys %lookUp ) { $value = substr( $cur, $lookUp{ $feat }->[0], $lookUp{ $feat }->[1] ); $value =~ s/\s//g; $elements{$feat} = $value ; } # if no chain id, make it '-' (like STRIDE...very convenient) if ( !( $elements{ 'pdb_chain' } ) || $elements{ 'pdb_chain'} eq ' ' ) { $elements{ 'pdb_chain' } = '-'; } return \%elements; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/SecStr/STRIDE���������������������������������������������������������000755��000765��000024�� 0�12254227315� 20210� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Structure/SecStr/STRIDE/Res.pm��������������������������������������������������000444��000765��000024�� 67724�12254227315� 21474� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $id $ # # bioperl module for Bio::Structure::SecStr::STRIDE::Res.pm # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ed Green <ed@compbio.berkeley.edu> # # Copyright Univ. of California # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Structure::SecStr::STRIDE::Res - Module for parsing/accessing stride output =head1 SYNOPSIS my $stride_obj = Bio::Structure::SecStr::STRIDE::Res->new( '-file' => 'filename.stride' ); # or my $stride_obj = Bio::Structure::SecStr::STRIDE::Res->new( '-fh' => \*STDOUT ); # Get secondary structure assignment for PDB residue 20 of chain A $sec_str = $stride_obj->resSecStr( '20:A' ); # same $sec_str = $stride_obj->resSecStr( 20, 'A' ) =head1 DESCRIPTION STRIDE::Res is a module for objectifying STRIDE output. STRIDE is a program (similar to DSSP) for assigning secondary structure to individual residues of a pdb structure file. ( Knowledge-Based Protein Secondary Structure Assignment, PROTEINS: Structure, Function, and Genetics 23:566-579 (1995) ) STRIDE is available here: http://webclu.bio.wzw.tum.de/stride/ Methods are then available for extracting all of the infomation present within the output or convenient subsets of it. Although they are very similar in function, DSSP and STRIDE differ somewhat in output format. Thes differences are reflected in the return value of some methods of these modules. For example, both the STRIDE and DSSP parsers have resSecStr() methods for returning the secondary structure of a given residue. However, the range of return values for DSSP is ( H, B, E, G, I, T, and S ) whereas the range of values for STRIDE is ( H, G, I, E, B, b, T, and C ). See individual methods for details. The methods are roughly divided into 3 sections: 1. Global features of this structure (PDB ID, total surface area, etc.). These methods do not require an argument. 2. Residue specific features ( amino acid, secondary structure, solvent exposed surface area, etc. ). These methods do require an argument. The argument is supposed to uniquely identify a residue described within the structure. It can be of any of the following forms: ('#A:B') or ( #, 'A', 'B' ) || | || - Chain ID (blank for single chain) |--- Insertion code for this residue. Blank for most residues. |--- Numeric portion of residue ID. (#) | --- Numeric portion of residue ID. If there is only one chain and it has no ID AND there is no residue with an insertion code at this number, then this can uniquely specify a residue. ('#:C') or ( #, 'C' ) | | | -Chain ID ---Numeric portion of residue ID. If a residue is incompletely specified then the first residue that fits the arguments is returned. For example, if 19 is the argument and there are three chains, A, B, and C with a residue whose number is 19, then 19:A will be returned (assuming its listed first). Since neither DSSP nor STRIDE correctly handle alt-loc codes, they are not supported by these modules. 3. Value-added methods. Return values are not verbatem strings parsed from DSSP or STRIDE output. =head1 FEEDBACK =head2 MailingLists UsUser feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ed Green Email ed@compbio.berkeley.edu =head1 APPENDIX The Rest of the documentation details each method. Internal methods are preceded with a _. =cut package Bio::Structure::SecStr::STRIDE::Res; use strict; use Bio::Root::IO; use Bio::PrimarySeq; use base qw(Bio::Root::Root); our %ASGTable = ( 'aa' => 0, 'resNum' => 1, 'ssAbbr' => 2, 'ssName' => 3, 'phi' => 4, 'psi' => 5, 'surfArea' => 6 ); our %AATable = ( 'ALA' => 'A', 'ARG' => 'R', 'ASN' => 'N', 'ASP' => 'D', 'CYS' => 'C', 'GLN' => 'Q', 'GLU' => 'E', 'GLY' => 'G', 'HIS' => 'H', 'ILE' => 'I', 'LEU' => 'L', 'LYS' => 'K', 'MET' => 'M', 'PHE' => 'F', 'PRO' => 'P', 'SER' => 'S', 'THR' => 'T', 'TRP' => 'W', 'TYR' => 'Y', 'VAL' => 'V' ); =head2 new Title : new Usage : makes new object of this class Function : Constructor Example : $stride_obj = Bio::Structure::SecStr::STRIDE:Res->new( '-file' => filename # or '-fh' => FILEHANDLE ) Returns : object (ref) Args : filename or filehandle( must be proper STRIDE output ) =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my $io = Bio::Root::IO->new( @args ); $self->_parse( $io ); # not passing filehandle ! $io->close(); return $self; } # GLOBAL FEATURES / INFO / STATS =head2 totSurfArea Title : totSurfArea Usage : returns sum of surface areas of all residues of all chains considered. Result is memoized. Function : Example : $tot_SA = $stride_obj->totSurfArea(); Returns : scalar Args : none =cut sub totSurfArea { my $self = shift; my $total = 0; my ( $chain, $res ); if ( $self->{ 'SurfArea' } ) { return $self->{ 'SurfArea' }; } else { foreach $chain ( keys %{$self->{ 'ASG' }} ) { for ( my $i = 1; $i <= $#{$self->{'ASG'}->{$chain}}; $i++ ) { $total += $self->{'ASG'}->{$chain}->[$i]->[$ASGTable{'surfArea'}]; } } } $self->{ 'SurfArea' } = $total; return $self->{ 'SurfArea' }; } =head2 numResidues Title : numResidues Usage : returns total number of residues in all chains or just the specified chain Function : Example : $tot_res = $stride_obj->numResidues(); Returns : scalar int Args : none or chain id =cut sub numResidues { my $self = shift; my $chain = shift; my $total = 0; my $key; foreach $key ( keys %{$self->{ 'ASG' }} ) { if ( $chain ) { if ( $key eq $chain ) { $total += $#{$self->{ 'ASG' }{ $key }}; } } else { $total += $#{$self->{ 'ASG' }{ $key }}; } } return $total; } # STRAIGHT FROM THE PDB ENTRY =head2 pdbID Title : pdbID Usage : returns pdb identifier ( 1FJM, e.g. ) Function : Example : $pdb_id = $stride_obj->pdbID(); Returns : scalar string Args : none =cut sub pdbID { my $self = shift; return $self->{ 'PDB' }; } =head2 pdbAuthor Title : pdbAuthor Usage : returns author of this PDB entry Function : Example : $auth = $stride_obj->pdbAuthor() Returns : scalar string Args : none =cut sub pdbAuthor { my $self = shift; return join( ' ', @{ $self->{ 'HEAD' }->{ 'AUT' } } ); } =head2 pdbCompound Title : pdbCompound Usage : returns string of what was found on the CMP lines Function : Example : $cmp = $stride_obj->pdbCompound(); Returns : string Args : none =cut sub pdbCompound { my $self = shift; return join( ' ', @{ $self->{ 'HEAD' }->{ 'CMP' } } ); } =head2 pdbDate Title : pdbDate Usage : returns date given in PDB file Function : Example : $pdb_date = $stride_obj->pdbDate(); Returns : scalar Args : none =cut sub pdbDate { my $self = shift; return $self->{ 'DATE' }; } =head2 pdbHeader Title : pdbHeader Usage : returns string of characters found on the PDB header line Function : Example : $head = $stride_obj->pdbHeader(); Returns : scalar Args : none =cut sub pdbHeader { my $self = shift; return $self->{ 'HEAD' }->{ 'HEADER' }; } =head2 pdbSource Title : pdbSource Usage : returns string of what was found on SRC lines Function : Example : $src = $stride_obj->pdbSource(); Returns : scalar Args : none =cut sub pdbSource { my $self = shift; return join( ' ', @{ $self->{ 'HEAD' }->{ 'SRC' } } ); } # RESIDUE SPECIFIC ACCESSORS =head2 resAA Title : resAA Usage : returns 1 letter abbr. of the amino acid specified by the arguments Function : Examples : $aa = $stride_obj->resAA( RESIDUE_ID ); Returns : scalar character Args : RESIDUE_ID =cut sub resAA { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return ( $AATable{$self->{'ASG'}->{$chain}->[$ord]->[$ASGTable{'aa'}]} ); } =head2 resPhi Title : resPhi Usage : returns phi angle of specified residue Function : Example : $phi = $stride_obj->resPhi( RESIDUE_ID ); Returns : scaler Args : RESIDUE_ID =cut sub resPhi { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'phi' } ]; } =head2 resPsi Title : resPsi Usage : returns psi angle of specified residue Function : Example : $psi = $stride_obj->resPsi( RESIDUE_ID ); Returns : scalar Args : RESIDUE_ID =cut sub resPsi { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'psi' } ]; } =head2 resSolvAcc Title : resSolvAcc Usage : returns stride calculated surface area of specified residue Function : Example : $sa = $stride_obj->resSolvAcc( RESIDUE_ID ); Returns : scalar Args : RESIDUE_ID =cut sub resSolvAcc { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'surfArea' } ]; } =head2 resSurfArea Title : resSurfArea Usage : returns stride calculated surface area of specified residue Function : Example : $sa = $stride_obj->resSurfArea( RESIDUE_ID ); Returns : scalar Args : RESIDUE_ID =cut sub resSurfArea { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'surfArea' } ]; } =head2 resSecStr Title : resSecStr Usage : gives one letter abbr. of stride determined secondary structure of specified residue Function : Example : $ss = $stride_obj->resSecStr( RESIDUE_ID ); Returns : one of: 'H' => Alpha Helix 'G' => 3-10 helix 'I' => PI-helix 'E' => Extended conformation 'B' or 'b' => Isolated bridge 'T' => Turn 'C' => Coil ' ' => None # NOTE: This range is slightly DIFFERENT from the # DSSP method of the same name Args : RESIDUE_ID =cut sub resSecStr { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'ssAbbr' } ]; } =head2 resSecStrSum Title : resSecStrSum Usage : gives one letter summary of secondary structure of specified residue. More general than secStruc() Function : Example : $ss_sum = $stride_obj->resSecStrSum( RESIDUE_ID ); Returns : one of: 'H' (helix), 'B' (beta), 'T' (turn), or 'C' (coil) Args : residue identifier(s) ( SEE INTRO NOTE ) =cut sub resSecStrSum { my $self = shift; my @args = @_; my $ss_char = $self->resSecStr( @args ); if ( $ss_char eq 'H' || $ss_char eq 'G' || $ss_char eq 'I' ) { return 'H'; } if ( $ss_char eq 'E' || $ss_char eq 'B' || $ss_char eq 'b' ) { return 'B'; } if ( $ss_char eq 'T' ) { return 'T'; } else { return 'C'; } } # STRIDE SPECIFIC =head2 resSecStrName Title : resSecStrName Usage : gives full name of the secondary structural element classification of the specified residue Function : Example : $ss_name = $stride_obj->resSecStrName( RESIDUE_ID ); Returns : scalar string Args : RESIDUE_ID =cut sub resSecStrName { my $self = shift; my @args = @_; my ( $ord, $chain ) = $self->_toOrdChain( @args ); return $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'ssName' } ]; } =head2 strideLocs Title : strideLocs Usage : returns stride determined contiguous secondary structural elements as specified on the LOC lines Function : Example : $loc_pnt = $stride_obj->strideLocs(); Returns : pointer to array of 5 element arrays. 0 => stride name of structural element 1 => first residue pdb key (including insertion code, if app.) 2 => first residue chain id 3 => last residue pdb key (including insertion code, if app.) 4 => last residue chain id NOTE the differences between this range and the range of SecBounds() Args : none =cut sub strideLocs { my $self = shift; return $self->{ 'LOC' }; } # VALUE ADDED METHODS (NOT JUST PARSE/REPORT) =head2 secBounds Title : secBounds Usage : gets residue ids of boundary residues in each contiguous secondary structural element of specified chain Function : Example : $ss_bound_pnt = $stride_obj->secBounds( 'A' ); Returns : pointer to array of 3 element arrays. First two elements are the PDB IDs of the start and end points, respectively and inclusively. The last element is the STRIDE secondary structural element code (same range as resSecStr). Args : chain identifier ( one character ). If none, '-' is assumed =cut sub secBounds { # Requires a chain name. If left blank, we assume ' ' which equals '-' my $self = shift; my $chain = shift; my @SecBounds; $chain = '-' if ( !( $chain ) || $chain eq ' ' || $chain eq '-' ); # if we've memoized this one, use that if ( $self->{ 'SecBounds' }->{ $chain } ) { return $self->{ 'SecBounds' }->{ $chain }; } #check to make sure chain is valid if ( !( $self->{ 'ASG' }->{ $chain } ) ) { $self->throw( "No such chain: $chain\n" ); } my $cur_element = $self->{ 'ASG' }->{ $chain }->[ 1 ]-> [ $ASGTable{ 'ssAbbr' } ]; my $beg = 1; my $i; for ( $i = 2; $i <= $#{$self->{'ASG'}->{$chain}}; $i++ ) { if ( $self->{ 'ASG' }->{ $chain }->[ $i ]->[ $ASGTable{ 'ssAbbr' } ] ne $cur_element ) { push( @SecBounds, [ $beg, $i -1 , $cur_element ] ); $beg = $i; $cur_element = $self->{ 'ASG' }->{ $chain }->[ $i ]-> [ $ASGTable{ 'ssAbbr' } ]; } } if ( $self->{ 'ASG' }->{ $chain }->[ $i ]->[ $ASGTable{ 'ssAbbr' } ] eq $cur_element ) { push( @SecBounds, [ $beg, $i, $cur_element ] ); } else { push( @SecBounds, [ $beg, $i - 1, $cur_element ], [ $i, $i, $self->{ 'ASG' }->{ $chain }->[ $i ]-> [ $ASGTable{ 'ssAbbr' } ] ] ); } $self->{ 'SecBounds' }->{ $chain } = \@SecBounds; return $self->{ 'SecBounds' }->{ $chain }; } =head2 chains Title : chains Usage : gives array chain I.D.s (characters) Function : Example : @chains = $stride_obj->chains(); Returns : array of characters Args : none =cut sub chains { my $self = shift; my @chains = keys ( %{ $self->{ 'ASG' } } ); return \@chains; } =head2 getSeq Title : getSeq Usage : returns a Bio::PrimarySeq object which represents an approximation at the sequence of the specified chain. Function : For most chain of most entries, the sequence returned by this method will be very good. However, it it inherently unsafe to rely on STRIDE to extract sequence information about a PDB entry. More reliable information can be obtained from the PDB entry itself. If a second option is given (and evaluates to true), the sequence generated will have 'X' in spaces where the pdb residue numbers are discontinuous. In some cases this results in a better sequence object (when the discontinuity is due to regions which were present, but could not be resolved). In other cases, it will result in a WORSE sequence object (when the discontinuity is due to historical sequence numbering and all sequence is actually resolved). Example : $pso = $dssp_obj->getSeq( 'A' ); Returns : (pointer to) a PrimarySeq object Args : Chain identifier. If none given, '-' is assumed. =cut sub getSeq { my $self = shift; my $chain = shift; my $fill_in = shift; if ( !( $chain ) ) { $chain = '-'; } if ( $self->{ 'Seq' }->{ $chain } ) { return $self->{ 'Seq' }->{ $chain }; } my ( $seq, $num_res, $last_res_num, $cur_res_num, $i, $step, $id ); $seq = ""; $num_res = $self->numResidues( $chain ); $last_res_num = $self->_pdbNum( 1, $chain ); for ( $i = 1; $i <= $num_res; $i++ ) { if ( $fill_in ) { $cur_res_num = $self->_pdbNum( $i, $chain ); $step = $cur_res_num - $last_res_num; if ( $step > 1 ) { $seq .= 'X' x ( $step - 1 ); } } $seq .= $self->_resAA( $i, $chain ); $last_res_num = $cur_res_num; } $id = $self->pdbID(); $id .= "$chain"; $self->{ 'Seq' }->{ $chain } = Bio::PrimarySeq->new( -seq => $seq, -id => $id, -moltype => 'protein' ); return $self->{ 'Seq' }->{ $chain }; } =head1 INTERNAL METHODS =head2 _pdbNum Title : _pdbNum Usage : fetches the numeric portion of the identifier for a given residue as reported by the pdb entry. Note, this DOES NOT uniquely specify a residue. There may be an insertion code and/or chain identifier differences. Function : Example : $pdbNum = $self->pdbNum( 3, 'A' ); Returns : a scalar Args : valid ordinal num / chain combination =cut sub _pdbNum { my $self = shift; my $ord = shift; my $chain = shift; if ( !( $self->{ 'ASG' }->{ $chain }->[ $ord ] ) ) { $self->throw( "No such ordinal $ord in chain $chain.\n" ); } my $pdb_junk = $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'resNum' } ]; my $num_part; ( $num_part ) = ( $pdb_junk =~ /(-*\d+).*/ ); return $num_part; } =head2 _resAA Title : _resAA Usage : returns 1 letter abbr. of the amino acid specified by the arguments Function : Examples : $aa = $stride_obj->_resAA( 3, '-' ); Returns : scalar character Args : ( ord. num, chain ) =cut sub _resAA { my $self = shift; my $ord = shift; my $chain = shift; if ( !( $self->{ 'ASG' }->{ $chain }->[ $ord ] ) ) { $self->throw( "No such ordinal $ord in chain $chain.\n" ); } return ( $AATable{$self->{'ASG'}->{$chain}->[$ord]->[$ASGTable{'aa'}]} ); } =head2 _pdbInsCo Title : _pdbInsCo Usage : fetches the Insertion code for this residue. Function : Example : $pdb_ins_co = $self->_pdb_ins_co( 15, 'B' ); Returns : a scalar Args : ordinal number and chain =cut sub _pdbInsCo { my $self = shift; my $ord = shift; my $chain = shift; if ( !( $self->{ 'ASG' }->{ $chain }->[ $ord ] ) ) { $self->throw( "No such ordinal $ord in chain $chain.\n" ); } my $pdb_junk = $self->{ 'ASG' }->{ $chain }->[ $ord ]->[ $ASGTable{ 'resNum' } ]; my $letter_part; ( $letter_part ) = ( $pdb_junk =~ /\d+(\D+)/ ); # insertion code can be any # non-word character(s) return $letter_part; } =head2 _toOrdChain Title : _toOrdChain Usage : takes any set of residue identifying parameters and wrestles them into a two element array: the chain and the ordinal number of this residue. This two element array can then be efficiently used as keys in many of the above accessor methods ('#A:B') or ( #, 'A', 'B' ) || | || - Chain ID (blank for single chain) |--- Insertion code for this residue. Blank for most residues. |--- Numeric portion of residue ID. (#) | --- Numeric portion of residue ID. If there is only one chain and it has no ID AND there is no residue with an insertion code at this number, then this can uniquely specify a residue. # ('#:C) or ( #, 'C' ) | | | -Chain ID ---Numeric portion of residue ID. If a residue is incompletely specified then the first residue that fits the arguments is returned. For example, if 19 is the argument and there are three chains, A, B, and C with a residue whose number is 19, then 19:A will be returned (assuming its listed first). Function : Example : my ( $ord, $chain ) = $self->_toOrdChain( @args ); Returns : two element array Args : valid set of residue identifier(s) ( SEE NOTE ABOVE ) =cut sub _toOrdChain { my $self = shift; my $arg_str; my ( $key_num, $chain_id, $ins_code, $key, $i ); # check to see how many args are given if ( $#_ >= 1 ) { # multiple args $key_num = shift; if ( $#_ >= 1 ) { # still multiple args => ins. code, too $ins_code = shift; $chain_id = shift; } else { # just one more arg. => chain_id $chain_id = shift; } } else { # only single arg. Might be number or string $arg_str = shift; if ( $arg_str =~ /:/ ) { # a chain is specified ( $chain_id ) = ( $arg_str =~ /:(.)/); $arg_str =~ s/:.//; } if ( $arg_str =~ /[A-Z]|[a-z]/ ) { # an insertion code is specified ( $ins_code ) = ( $arg_str =~ /([A-Z]|[a-z])/ ); $arg_str =~ s/[A-Z]|[a-z]//g; } #now, get the number bit-> everything still around $key_num = $arg_str; } $key = "$key_num$ins_code"; if ( !( $chain_id ) || $chain_id eq ' ' ) { $chain_id = '-'; } if ( !( $self->{ 'ASG' }->{ $chain_id } ) ) { $self->throw( "No such chain: $chain_id" ); } for ( $i = 1; $i <= $#{$self->{ 'ASG' }->{ $chain_id }}; $i++ ) { if ( $self->{ 'ASG' }->{ $chain_id }->[ $i ]->[ $ASGTable{ 'resNum' } ] eq $key ) { return ( $i, $chain_id ); } } $self->throw( "No such key: $key" ); } =head2 _parse Title : _parse Usage : as name suggests, parses stride output, creating object Function : Example : $self->_parse( $io ); Returns : Args : valid Bio::Root::IO object =cut sub _parse { my $self = shift; my $io = shift; my $file = $io->_fh(); # Parse top lines if ( $self->_parseTop( $io ) ) { $self->throw( "Not stride output" ); } # Parse the HDR, CMP, SCR, and AUT lines $self->_parseHead( $io ); # Parse the CHN, SEQ, STR, and LOC lines $self->_parseSummary( $io ); # we're ignoring this # Parse the ASG lines $self->_parseASG( $io ); } =head2 _parseTop Title : _parseTop Usage : makes sure this looks like stride output Function : Example : Returns : Args : =cut sub _parseTop { my $self = shift; my $io = shift; my $file = $io->_fh(); my $cur = <$file>; if ( $cur =~ /^REM ---/ ) { return 0; } return 1; } =head2 _parseHead Title : _parseHead Usage : parses Function : HDR, CMP, SRC, and AUT lines Example : Returns : Args : =cut sub _parseHead { my $self = shift; my $io = shift; my $file = $io->_fh(); my $cur; my $element; my ( @elements, @cmp, @src, @aut ); my %head = {}; my $still_head = 1; $cur = <$file>; while ( $cur =~ /^REM / ) { $cur = <$file>; } if ( $cur =~ /^HDR / ) { @elements = split( /\s+/, $cur ); shift( @elements ); pop( @elements ); $self->{ 'PDB' } = pop( @elements ); $self->{ 'DATE' } = pop( @elements ); # now, everything else is "header" except for the word # HDR $element = join( ' ', @elements ); $head{ 'HEADER' } = $element; } $cur = <$file>; while ( $cur =~ /^CMP / ) { ( $cur ) = ( $cur =~ /^CMP\s+(.+?)\s*\w{4}$/ ); push( @cmp, $cur ); $cur = <$file>; } while ( $cur =~ /^SRC / ) { ( $cur ) = ( $cur =~ /^SRC\s+(.+?)\s*\w{4}$/ ); push( @src, $cur ); $cur = <$file>; } while ( $cur =~ /^AUT / ) { ( $cur ) = ( $cur =~ /^AUT\s+(.+?)\s*\w{4}$/ ); push( @aut, $cur ); $cur = <$file>; } $head{ 'CMP' } = \@cmp; $head{ 'SRC' } = \@src; $head{ 'AUT' } = \@aut; $self->{ 'HEAD' } = \%head; } =head2 _parseSummary Title : _parseSummary Usage : parses LOC lines Function : Example : Returns : Args : =cut sub _parseSummary { my $self = shift; my $io = shift; my $file = $io->_fh(); my $cur = <$file>; my $bound_set; my $element; my ( @elements, @cur ); my @LOC_lookup = ( [ 5, 12 ], # Element name # reduntdant [ 18, 3 ], # First residue name [ 22, 5 ], # First residue PDB number [ 28, 1 ], # First residue Chain ID # redundant [ 35, 3 ], # Last residue name [ 40, 5 ], # Last residue PDB number [ 46, 1 ] ); # Last residue Chain ID #ignore these lines while ( $cur =~ /^REM |^STR |^SEQ |^CHN / ) { $cur = <$file>; } while ( $cur =~ /^LOC / ) { foreach $bound_set ( @LOC_lookup ) { $element = substr( $cur, $bound_set->[ 0 ], $bound_set->[ 1 ] ); $element =~ s/\s//g; push( @cur, $element ); } push( @elements, [ @cur ] ); $cur = <$file>; @cur = (); } $self->{ 'LOC' } = \@elements; } =head2 _parseASG Title : _parseASG Usage : parses ASG lines Function : Example : Returns : Args : =cut sub _parseASG { my $self = shift; my $io = shift; my $file = $io->_fh(); my $cur = <$file>; my $bound_set; my $ord_num; my ( $chain, $last_chain ); my $element; my %ASG; my ( @cur, @elements ); my @ASG_lookup = ( [ 5, 3 ], # Residue name # [ 9, 1 ], # Chain ID [ 10, 5 ], # PDB residue number (w/ins.code) # [ 16, 4 ], # ordinal stride number [ 24, 1 ], # one letter sec. stru. abbr. [ 26, 13], # full sec. stru. name [ 42, 7 ], # phi angle [ 52, 7 ], # psi angle [ 64, 5 ] );# residue solv. acc. while ( $cur =~ /^REM / ) { $cur = <$file>; } while ( $cur =~ /^ASG / ) { # get ordinal number for array key $ord_num = substr( $cur, 16, 4 ); $ord_num =~ s/\s//g; # get the chain id $chain = substr( $cur, 9, 1 ); if ( $last_chain && ( $chain ne $last_chain ) ) { $ASG{ $last_chain } = [ @elements ]; @elements = (); } # now get the rest of the info on this line foreach $bound_set ( @ASG_lookup ) { $element = substr( $cur, $bound_set->[ 0 ], $bound_set->[ 1 ] ); $element =~ s/\s//g; push( @cur, $element ); } $elements[ $ord_num ] = [ @cur ]; $cur = <$file>; @cur = (); $last_chain = $chain; } $ASG{ $chain } = [ @elements ]; $self->{ 'ASG' } = \%ASG; } 1; ��������������������������������������������BioPerl-1.6.923/Bio/Symbol��������������������������������������������������������������������������000755��000765��000024�� 0�12254227336� 15263� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Symbol/Alphabet.pm��������������������������������������������������������������000444��000765��000024�� 11561�12254227336� 17522� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Symbol::Alphabet # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Symbol::Alphabet - BSANE/BioCORBA compliant symbol list alphabet =head1 SYNOPSIS { my $alphabet = Bio::Symbols::Alphabet->new(-symbols => [ @s ], -subalphabets => [ @alphas ] ); my @symbols = $alphabet->symbols; my @subalphas = $alphabet->alphabets; if( $alphabet->contains($symbol) ) { # do something } } =head1 DESCRIPTION Alphabet contains set of symbols, which can be concatenated to form symbol lists. Sequence string, for example, is stringified representation of the symbol list (tokens of symbols). This module was implemented for the purposes of meeting the BSANE/BioCORBA spec 0.3 only. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Symbol::Alphabet; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::Symbol::AlphabetI); =head2 new Title : new Usage : my $obj = Bio::Symbol::Alphabet->new(); Function: Builds a new Bio::Symbol::Alphabet object Returns : Bio::Symbol::Alphabet Args : -symbols => Array ref of Bio::Symbol::SymbolI objects -subalphas=> Array ref of Bio::Symbol::AlphabetI objects representing sub alphabets =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_symbols'} = []; $self->{'_alphabets'} = []; my ($symbols, $subalphas) = $self->_rearrange([qw(SYMBOLS SUBALPHAS)], @args); defined $symbols && ref($symbols) =~ /array/i && $self->symbols(@$symbols); defined $subalphas && ref($subalphas) =~ /array/i && $self->alphabets(@$subalphas); return $self; } =head2 AlphabetI Interface methods =cut =head2 symbols Title : symbols Usage : my @symbols = $alphabet->symbols(); Function: Get/Set Symbol list for an alphabet List of symbols, which make up this alphabet. Returns : Array of Bio::Symbol::SymbolI objects Args : (optionalalphabets) Array of Bio::Symbol::SymbolI objects =cut sub symbols { my ($self,@args) = @_; if( @args ) { $self->{'_symbols'} = []; foreach my $symbol ( @args ) { if( ! defined $symbol || ! ref($symbol) || ! $symbol->isa('Bio::Symbol::SymbolI') ) { $self->warn("Did not provide a proper Bio::Symbol::SymbolI to method 'symbols' (got $symbol)"); } else { push @{$self->{'_symbols'}}, $symbol; } } } return @{$self->{'_symbols'}}; } =head2 alphabets Title : alphabets Usage : my @alphabets = $alphabet->alphabets(); Function: Get/Set Sub Alphabet list for an alphabet Sub-alphabets. E.g. codons made from DNAxDNAxDNA alphabets Returns : Array of Bio::Symbol::AlphabetI objects Args : (optional) Array of Bio::Symbol::AlphabetI objects =cut sub alphabets { my ($self,@args) = @_; if( @args ) { $self->{'_alphabets'} = []; foreach my $alpha ( @args ) { if( ! $alpha->isa('Bio::Symbol::AlphabetI') ) { $self->warn("Did not provide a proper Bio::Symbol::AlphabetI to method 'alphabets' (got $alpha)"); } else { push @{$self->{'_alphabets'}}, $alpha; } } } return @{$self->{'_alphabets'}}; } =head2 contains Title : contains Usage : if($alphabet->contains($symbol)) { } Function: Tests of Symbol is contained in this alphabet Returns : Boolean Args : Bio::Symbol::SymbolI =cut sub contains{ my ($self,$testsymbol) = @_; foreach my $symbol ( $self->symbols ) { return 1 if( $symbol->equals($testsymbol) ); } return 0; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Symbol/AlphabetI.pm�������������������������������������������������������������000444��000765��000024�� 10636�12254227323� 17631� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Symbol::AlphabetI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Symbol::AlphabetI - A Symbol Alphabet =head1 SYNOPSIS # get a Bio::Symbol::AlphabetI object somehow my @symbols = $alphabet->symbols; my @subalphas = $alphabet->alphabets; if( $alphabet->contains($symbol) ) { # do something } =head1 DESCRIPTION Alphabet contains set of symbols, which can be concatenated to form symbol lists. Sequence string, for example, is stringified representation of the symbol list (tokens of symbols). This module was implemented for the purposes of meeting the BSANE/BioCORBA spec 0.3 only. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Symbol::AlphabetI; use strict; use Bio::Root::RootI; =head2 AlphabetI Interface methods =cut =head2 symbols Title : symbols Usage : my @symbols = $alphabet->symbols(); Function: Get/Set Symbol list for an alphabet List of symbols, which make up this alphabet. Returns : Array of L<Bio::Symbol::SymbolI> objects Args : (optional) Array of L<Bio::Symbol::SymbolI> objects =cut sub symbols{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 alphabets Title : alphabets Usage : my @alphabets = $alphabet->alphabets(); Function: Get/Set Sub Alphabet list for an alphabet Sub-alphabets. E.g. codons made from DNAxDNAxDNA alphabets Returns : Array of L<Bio::Symbol::AlphabetI> objects Args : (optional) Array of L<Bio::Symbol::AlphabetI> objects =cut sub alphabets{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 contains Title : contains Usage : if($alphabet->contains($symbol)) { } Function: Tests of Symbol is contained in this alphabet Returns : Boolean Args : L<Bio::Symbol::SymbolI> =cut sub contains{ my ($self,@args) = @_; $self->throw_not_implemented(); } # Other methods from BSANE - not sure if we will implement here or only in # BioCORBA implementation # Resolve symbols from the token string. # SymbolList to_symbol(in string tokens) raises ( IllegalSymbolException) ; # Convinience method, which returns gap symbol that do not # match with any other symbols in the alphabet. # Symbol get_gap_symbol() raises ( DoesNotExist) ; # Returns a ambiguity symbol, which represent list of # symbols. All symbols in a list must be members of # this alphabet otherwise IllegalSymbolException is # thrown. # Symbol get_ambiguity( in SymbolList symbols) raises( IllegalSymbolException); # Returns a Symbol, which represents ordered list of symbols # given as a parameter. Each symbol in the list must be member of # different sub-alphabet in the order defined by the alphabets # attribute. For example, codons can be represented by a compound # Alphabet of three DNA Alphabets, in which case the get_symbol( # SymbolList[ a,g,t]) method of the Alphabet returns Symbol for # the codon agt.<p> # IllegalSymbolException is raised if members of symbols # are not Symbols over the alphabet defined by # get_alphabets()-method # Symbol get_symbol(in SymbolList symbols) raises(IllegalSymbolException) ; 1; ��������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Symbol/DNAAlphabet.pm�����������������������������������������������������������000444��000765��000024�� 5674�12254227316� 20033� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Symbol::DNAAlphabet # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Symbol::DNAAlphabet - A ready made DNA alphabet =head1 SYNOPSIS use Bio::Symbol::DNAAlphabet; my $alpha = Bio::Symbol::DNAAlphabet->new(); foreach my $symbol ( $alpha->symbols ) { print "symbol is $symbol\n"; } =head1 DESCRIPTION This object builds an Alphabet with DNA symbols. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Symbol::DNAAlphabet; use strict; use Bio::Symbol::Symbol; use Bio::Tools::IUPAC; use base qw(Bio::Symbol::Alphabet); =head2 new Title : new Usage : my $obj = Bio::Symbol::DNAAlphabet->new(); Function: Builds a new Bio::Symbol::DNAAlphabet object Returns : Bio::Symbol::DNAAlphabet Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my %alphabet = Bio::Tools::IUPAC::iupac_iub(); my %symbols; foreach my $let ( keys %alphabet ) { next unless @{$alphabet{$let}} == 1 || $let eq 'U'; $symbols{$let} = Bio::Symbol::Symbol->new(-name => $let, -token => $let); } foreach my $let ( keys %alphabet ) { next if( $symbols{$let} || $let eq 'U'); my @subsymbols; foreach my $sublet ( @{$alphabet{$let}} ) { push @subsymbols, $symbols{$sublet}; } my $alpha = Bio::Symbol::Alphabet->new(-symbols => \@subsymbols); $symbols{$let} = Bio::Symbol::Symbol->new(-name => $let, -token => $let, -matches => $alpha, -symbols => \@subsymbols); } $self->symbols(values %symbols); return $self; } 1; ��������������������������������������������������������������������BioPerl-1.6.923/Bio/Symbol/ProteinAlphabet.pm�������������������������������������������������������000444��000765��000024�� 5720�12254227330� 21035� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Symbol::ProteinAlphabet # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Symbol::ProteinAlphabet - A ready made Protein alphabet =head1 SYNOPSIS use Bio::Symbol::ProteinAlphabet; my $alpha = Bio::Symbol::ProteinAlphabet->new(); foreach my $symbol ( $alpha->symbols ) { print "symbol is $symbol\n"; } =head1 DESCRIPTION This object builds an Alphabet with Protein symbols. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Symbol::ProteinAlphabet; use strict; use Bio::Symbol::Symbol; use Bio::Tools::IUPAC; use Bio::SeqUtils; use base qw(Bio::Symbol::Alphabet); =head2 new Title : new Usage : my $obj = Bio::Symbol::ProteinAlphabet->new(); Function: Builds a new Bio::Symbol::ProteinAlphabet object Returns : Bio::Symbol::ProteinAlphabet Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my %aa = Bio::SeqUtils->valid_aa(2); my %codes = Bio::Tools::IUPAC->iupac_iup(); my %symbols; my @left; foreach my $let ( keys %codes ) { if( scalar @{$codes{$let}} != 1) { push @left, $let; next; } $symbols{$let} = Bio::Symbol::Symbol->new(-name => $aa{$let}, -token => $let); } foreach my $l ( @left ) { my @subsym; foreach my $sym ( @{$codes{$l}} ) { push @subsym, $symbols{$sym}; } my $alpha = Bio::Symbol::Alphabet->new(-symbols => \@subsym); $symbols{$l} = Bio::Symbol::Symbol->new(-name => $aa{$l}, -token => $l, -matches => $alpha, -symbols => \@subsym); } $self->symbols(values %symbols); return $self; } 1; ������������������������������������������������BioPerl-1.6.923/Bio/Symbol/README.Symbol������������������������������������������������������������000444��000765��000024�� 430�12254227320� 17512� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������This is unused code written simply for the benefit of impelementing the BioCORBA / OMG BSANE spec. We've pretty much given up on this in 2002 as anything useful. So unless someone finds a need for this code we'll probably remove it in future releases. -Jason Stajich August 2003 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Symbol/Symbol.pm����������������������������������������������������������������000444��000765��000024�� 13257�12254227317� 17252� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Symbol::Symbol # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Symbol::Symbol - A biological symbol =head1 SYNOPSIS use Bio::Symbol::Symbol; my $thymine = Bio::Symbol::Symbol->new(-name => 'Thy', -token=> 'T'); my $a = Bio::Symbol::Symbol->new(-token => 'A' ); my $u = Bio::Symbol::Symbol->new(-token => 'U' ); my $g = Bio::Symbol::Symbol->new(-token => 'G' ); my $M = Bio::Symbol::Symbol->new(-name => 'Met', -token => 'M', -symbols => [ $a, $u, $g ]); my ($name,$token) = ($a->name, $a->token); my @symbols = $a->symbols; my $matches = $a->matches; =head1 DESCRIPTION Symbol represents a single token in the sequence. Symbol can have multiple synonyms or matches within the same Alphabet, which makes possible to represent ambiguity codes and gaps. Symbols can be also composed from ordered list other symbols. For example, codons can be represented by single Symbol using a compound Alphabet made from three DNA Alphabets. This module was implemented for the purposes of meeting the BSANE/BioCORBA spec 0.3 only. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Symbol::Symbol; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Symbol::Alphabet; use base qw(Bio::Root::Root Bio::Symbol::SymbolI); =head2 new Title : new Usage : my $obj = Bio::Symbol::Symbol->new(); Function: Builds a new Bio::Symbol::Symbol object Returns : Bio::Symbol::Symbol Args : -name => descriptive name (string) [e.g. Met] -token => Shorthand token (string) [e.g. M] -symbols => Symbols that make up this symbol (array) [e.g. AUG] -matches => Alphabet in the event symbol is an ambiguity code. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_symbols'} = []; my ($name, $token, $symbols, $matches) = $self->_rearrange([qw(NAME TOKEN SYMBOLS MATCHES)], @args); $token && $self->token($token); $name && $self->name($name); $symbols && ref($symbols) =~ /array/i && $self->symbols(@$symbols); $matches && $self->matches($matches); return $self; } =head2 name Title : name Usage : my $name = $symbol->name(); Function: Get/Set Descriptive name for Symbol Returns : string Args : (optional) string =cut sub name { my ($self,$value) = @_; if( $value ) { $self->{'_name'} = $value; } return $self->{'_name'} || ''; } =head2 token Title : token Usage : my $token = $self->token(); Function: Get/Set token for this symbol Example : Letter A,C,G,or T for a DNA alphabet Symbol Returns : string Args : (optional) string =cut sub token{ my ($self,$value) = @_; if( $value ) { $self->{'_token'} = $value; } return $self->{'_token'} || ''; } =head2 symbols Title : symbols Usage : my @symbols = $self->symbols(); Function: Get/Set Symbols this Symbol is composed from Example : Ambiguity symbols are made up > 1 base symbol Returns : Array of Bio::Symbol::SymbolI objects Args : (optional) Array of Bio::Symbol::SymbolI objects =cut sub symbols{ my ($self,@args) = @_; if( @args ) { $self->{'_symbols'} = [@args]; } return @{$self->{'_symbols'}}; } =head2 matches Title : matches Usage : my $matchalphabet = $symbol->matches(); Function: Get/Set (Sub) alphabet of symbols matched by this symbol including the symbol itself (i.e. if symbol is DNA ambiguity code W then the matches contains symbols for W and T) Returns : Bio::Symbol::AlphabetI Args : (optional) Bio::Symbol::AlphabetI =cut sub matches{ my ($self,$matches) = @_; if( $matches ) { if( ! $matches->isa('Bio::Symbol::AlphabetI') ) { $self->warn("Must pass in a Bio::Symbol::AlphabetI object to matches function"); # stick with previous value } else { $self->{'_matches'} = $matches; } } return $self->{'_matches'}; } =head2 equals Title : equals Usage : if( $symbol->equals($symbol2) ) { } Function: Tests if a symbol is equal to another Returns : Boolean Args : Bio::Symbol::SymbolI =cut sub equals{ my ($self,$symbol2) = @_; # Let's just test based on Tokens for now # Doesn't handle DNA vs PROTEIN accidential comparisons return $self->token eq $symbol2->token; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Symbol/SymbolI.pm���������������������������������������������������������������000444��000765��000024�� 7644�12254227326� 17346� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Symbol::SymbolI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Symbol::SymbolI - Interface for a Symbol =head1 SYNOPSIS # get a Bio::Symbol::SymbolI object somehow my ($name,$token) = ($symbol->name, $symbol->token); my @symbols = $symbol->symbols; my $matches = $symbol->matches; =head1 DESCRIPTION Symbol represents a single token in the sequence. Symbol can have multiple synonyms or matches within the same Alphabet, which makes possible to represent ambiguity codes and gaps. Symbols can be also composed from ordered list other symbols. For example, codons can be represented by single Symbol using a compound Alphabet made from three DNA Alphabets. This module was implemented for the purposes of meeting the BSANE/BioCORBA spec 0.3 only. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Symbol::SymbolI; use strict; use base qw(Bio::Root::RootI); =head2 Bio::Symbol::SymbolI interface methods =cut =head2 name Title : name Usage : my $name = $symbol->name(); Function: Get/Set Descriptive name for Symbol Returns : string Args : (optional) string =cut sub name{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 token Title : token Usage : my $token = $self->token(); Function: Get/Set token for this symbol Example : Letter A,C,G,or T for a DNA alphabet Symbol Returns : string Args : (optional) string =cut sub token{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 symbols Title : symbols Usage : my @symbols = $self->symbols(); Function: Get/Set Symbols this Symbol is composed from Example : A codon is composed of 3 DNA symbols Returns : Array of Bio::Symbol::SymbolI objects Args : (optional) Array of Bio::Symbol::SymbolI objects =cut sub symbols{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 matches Title : matches Usage : my $matchalphabet = $symbol->matches(); Function: Get/Set (Sub) alphabet of symbols matched by this symbol including the symbol itself (i.e. if symbol is DNA ambiguity code W then the matches contains symbols for W and T) Returns : Bio::Symbol::AlphabetI Args : (optional) Bio::Symbol::AlphabetI =cut sub matches{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 equals Title : equals Usage : if( $symbol->equals($symbol2) ) { } Function: Tests if a symbol is equal to another Returns : Boolean Args : Bio::Symbol::SymbolI =cut sub equals{ my ($self,@args) = @_; $self->throw_not_implemented(); } 1; ��������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Taxonomy������������������������������������������������������������������������000755��000765��000024�� 0�12254227330� 15626� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Taxonomy/FactoryI.pm������������������������������������������������������������000444��000765��000024�� 5370�12254227312� 20046� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # # BioPerl interface of Bio::Taxnomoy::FactoryI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Juguang Xiao # # You may distribute this module under the same terms as Perl itself # # POD documentation - main does before the code =head1 NAME Bio::Taxonomy::FactoryI - interface to define how to access NCBI Taxonoy =head1 DESCRIPTION NB: This module has been deprecated. $factory-E<gt>fetch is a general method to fetch Taxonomy by either NCBI taxid or any types of names. $factory-E<gt>fetch_parent($taxonomy), returns a Taxonomy that is one-step higher rank of the taxonomy specified as argument. $factory-E<gt>fetch_children($taxonomy), reports an array of Taxonomy those are one-step lower rank of the taxonomy specified as the argument. =head1 AUTHOR - Juguang Xiao juguang@tll.org.sg =head1 CONTRIBUTORS Additional contributors' names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Taxonomy::FactoryI; use strict; use base qw(Bio::Root::Root); =head2 fetch Title: fetch Usage: my $taxonomy = $factory->fetch(-taxon_id => 9605); my $taxonomy = $factory->fetch(-common_name => 'mammals'); Fuctnion: Fetch taxonomy by taxon_id, common name or scientific name. Returns: an instance of Bio::Taxonomy Args: -taxon_id => NCBI taxonomy ID -common_name => comon name, such as 'human', 'mammals' -scientifc_name => specitic name, such as 'sapiens', 'Mammalia' =cut sub fetch { shift->throw_not_implemented; } =head2 fuzzy_fetch Title: fuzzy_fetch Usage: my @taxonomy = $factory->fuzzy_fetch(-name => 'mouse'); Function: Fuzzy fetch by name, or any text information found in DB Returns: an array reference of Bio::Taxonomy objects Args: -name => any name, such as common name, variant, scientific name -description, or -desc => any text information =cut sub fuzzy_fetch { shift->throw_not_implemented; } =head2 fetch_parent Title: fetch_parent Usage: my $parent_taxonomy = $factory->fetch_parent($taxonomy); Function: Fetch the parent that is one-rank higher than the argument. Returns: an instance of Bio::Taxonomy, or undef if the arg is the top one. Args: a Bio::Taxonomy object. =cut sub fetch_parent { shift->throw_not_implemented; } =head2 fetch_children Title: fetch_children Usage: my @children_taxonomy = $factory->fetch_children($taxonomy); Function: Fetch all children those are one-rank lower than the argument. Returns: an array reference of Bio::Taxonomy objects Args: a Bio::Taxonomy object. =cut sub fetch_children { shift->throw_not_implemented; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Taxonomy/Node.pm����������������������������������������������������������������000444��000765��000024�� 4076�12254227326� 17222� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Taxonomy::Node # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Taxonomy::Node - A node in a represented taxonomy =head1 SYNOPSIS use Bio::Taxon; # This module has been renamed Bio::Taxon - use that instead =head1 DESCRIPTION This module has been renamed Bio::Taxon - use that instead. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Juguang Xiao, juguang@tll.org.sg Gabriel Valiente, valiente@lsi.upc.edu Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Taxonomy::Node; use strict; use base qw(Bio::Taxon); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->warn("This module has been renamed Bio::Taxon - use that instead"); return $self; } 1;������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Taxonomy/Taxon.pm���������������������������������������������������������������000444��000765��000024�� 36140�12254227314� 17440� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Taxonomy::Taxon # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Dan Kortschak but pilfered extensively from # the Bio::Tree::Node code of Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Taxonomy::Taxon - Generic Taxonomic Entity object =head1 SYNOPSIS # NB: This module is deprecated. Use Bio::Taxon instead. use Bio::Taxonomy::Taxon; my $taxonA = Bio::Taxonomy::Taxon->new(); my $taxonL = Bio::Taxonomy::Taxon->new(); my $taxonR = Bio::Taxonomy::Taxon->new(); my $taxon = Bio::Taxonomy::Taxon->new(); $taxon->add_Descendents($taxonL); $taxon->add_Descendents($taxonR); my $species = $taxon->species; =head1 DESCRIPTION Makes a taxonomic unit suitable for use in a taxonomic tree =head1 AUTHOR Dan Kortschak email B<kortschak@rsbs.anu.edu.au> =head1 CONTRIBUTORS Sendu Bala: bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # code begins... package Bio::Taxonomy::Taxon; use vars qw($CREATIONORDER); use strict; use Bio::Species; use base qw(Bio::Root::Root Bio::Tree::NodeI); BEGIN { $CREATIONORDER = 0; } =head2 new Title : new Usage : my $obj = Bio::Taxonomy::Taxon->new(); Function: Builds a new Bio::Taxonomy::Taxon object Returns : Bio::Taxonomy::Taxon Args : -descendents => array pointer to descendents (optional) -branch_length => branch length [integer] (optional) -taxon => taxon -id => unique taxon id for node (from NCBI's list preferably) -rank => the taxonomic level of the node (also from NCBI) =cut #' for emacs sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->warn("Bio::Taxonomy::Taxon is deprecated. Use Bio::Taxon instead."); my ($children,$branchlen,$id,$taxon,$rank,$desc) = $self->_rearrange([qw(DESCENDENTS BRANCH_LENGTH ID TAXON RANK DESC)], @args); $self->{'_desc'} = {}; defined $desc && $self->description($desc); defined $taxon && $self->taxon($taxon); defined $id && $self->id($id); defined $branchlen && $self->branch_length($branchlen); defined $rank && $self->rank($rank); if( defined $children ) { if( ref($children) !~ /ARRAY/i ) { $self->warn("Must specify a valid ARRAY reference to initialize a Taxon's Descendents"); } foreach my $c ( @$children ) { $self->add_Descendent($c); } } $self->_creation_id($CREATIONORDER++); return $self; } =head2 add_Descendent Title : add_Descendent Usage : $taxon->add_Descendent($taxon); Function: Adds a descendent to a taxon Returns : number of current descendents for this taxon Args : Bio::Taxonomy::Taxon boolean flag, true if you want to ignore the fact that you are adding a second node with the same unique id (typically memory location reference in this implementation). default is false and will throw an error if you try and overwrite an existing node. =cut sub add_Descendent{ my ($self,$node,$ignoreoverwrite) = @_; return -1 if( ! defined $node ) ; if( ! $node->isa('Bio::Taxonomy::Taxon') ) { $self->warn("Trying to add a Descendent who is not a Bio::Taxonomy::Taxon"); return -1; } # do we care about order? $node->{'_ancestor'} = $self; if( $self->{'_desc'}->{$node->internal_id} && ! $ignoreoverwrite ) { $self->throw("Going to overwrite a taxon which is $node that is already stored here, set the ignore overwrite flag (parameter 2) to true to ignore this in the future"); } $self->{'_desc'}->{$node->internal_id} = $node; # is this safely unique - we've tested before at any rate?? $self->invalidate_height(); return scalar keys %{$self->{'_desc'}}; } =head2 each_Descendent Title : each_Descendent($sortby) Usage : my @taxa = $taxon->each_Descendent; Function: all the descendents for this taxon (but not their descendents i.e. not a recursive fetchall) Returns : Array of Bio::Taxonomy::Taxon objects Args : $sortby [optional] "height", "creation" or coderef to be used to sort the order of children taxa. =cut sub each_Descendent{ my ($self, $sortby) = @_; # order can be based on branch length (and sub branchlength) $sortby ||= 'height'; if (ref $sortby eq 'CODE') { my @values = sort $sortby values %{$self->{'_desc'}}; return @values; } else { if ($sortby eq 'height') { return map { $_->[0] } sort { $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } map { [$_, $_->height, $_->internal_id ] } values %{$self->{'_desc'}}; } else { return map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, $_->height ] } values %{$self->{'_desc'}}; } } } =head2 remove_Descendent Title : remove_Descendent Usage : $taxon->remove_Descedent($taxon_foo); Function: Removes a specific taxon from being a Descendent of this taxon Returns : nothing Args : An array of Bio::taxonomy::Taxon objects which have be previously passed to the add_Descendent call of this object. =cut sub remove_Descendent{ my ($self,@nodes) = @_; foreach my $n ( @nodes ) { if( $self->{'_desc'}->{$n->internal_id} ) { $n->{'_ancestor'} = undef; $self->{'_desc'}->{$n->internal_id}->{'_ancestor'} = undef; delete $self->{'_desc'}->{$n->internal_id}; } else { $self->debug(sprintf("no taxon %s (%s) listed as a descendent in this taxon %s (%s)\n",$n->id, $n,$self->id,$self)); $self->debug("Descendents are " . join(',', keys %{$self->{'_desc'}})."\n"); } } 1; } =head2 remove_all_Descendents Title : remove_all_Descendents Usage : $taxon->remove_All_Descendents() Function: Cleanup the taxon's reference to descendents and reset their ancestor pointers to undef, if you don't have a reference to these objects after this call they will be cleanedup - so a get_nodes from the Tree object would be a safe thing to do first Returns : nothing Args : none =cut sub remove_all_Descendents{ my ($self) = @_; # this won't cleanup the taxa themselves if you also have # a copy/pointer of them (I think)... while( my ($node,$val) = each %{ $self->{'_desc'} } ) { $val->{'_ancestor'} = undef; } $self->{'_desc'} = {}; 1; } =head2 get_Descendents Title : get_Descendents Usage : my @taxa = $taxon->get_Descendents; Function: Recursively fetch all the taxa and their descendents *NOTE* This is different from each_Descendent Returns : Array or Bio::Taxonomy::Taxon objects Args : none =cut # implemented in the interface =head2 ancestor Title : ancestor Usage : $taxon->ancestor($newval) Function: Set the Ancestor Returns : value of ancestor Args : newvalue (optional) =cut sub ancestor { my ($self, $value) = @_; if (defined $value) { $self->{'_ancestor'} = $value; } return $self->{'_ancestor'}; } =head2 branch_length Title : branch_length Usage : $obj->branch_length($newval) Function: Example : Returns : value of branch_length Args : newvalue (optional) =cut sub branch_length { my ($self,$value) = @_; if( defined $value) { $self->{'branch_length'} = $value; } return $self->{'branch_length'}; } =head2 description Title : description Usage : $obj->description($newval) Function: Returns : value of description Args : newvalue (optional) =cut sub description { my ($self,$value) = @_; if( defined $value ) { $self->{'_description'} = $value; } return $self->{'_description'}; } =head2 rank Title : rank Usage : $obj->rank($newval) Function: Set the taxonomic rank Returns : taxonomic rank of taxon Args : newvalue (optional) =cut sub rank { my ($self,$value) = @_; if (defined $value) { $self->{'_rank'} = $value; } return $self->{'_rank'}; } =head2 taxon Title : taxon Usage : $obj->taxon($newtaxon) Function: Set the name of the taxon Example : Returns : name of taxon Args : newtaxon (optional) =cut # because internal taxa have names too... sub taxon { my ($self,$value) = @_; if( defined $value ) { $self->{'_taxon'} = $value; } return $self->{'_taxon'}; } =head2 id Title : id Usage : $obj->id($newval) Function: Example : Returns : value of id Args : newvalue (optional) =cut sub id { my ($self,$value) = @_; if( defined $value ) { $self->{'_id'} = $value; } return $self->{'_id'}; } sub DESTROY { my ($self) = @_; # try to insure that everything is cleaned up $self->SUPER::DESTROY(); if( defined $self->{'_desc'} && ref($self->{'_desc'}) =~ /ARRAY/i ) { while( my ($nodeid,$node) = each %{ $self->{'_desc'} } ) { $node->{'_ancestor'} = undef; # ensure no circular references $node->DESTROY(); $node = undef; } $self->{'_desc'} = {}; } } =head2 internal_id Title : internal_id Usage : my $internalid = $taxon->internal_id Function: Returns the internal unique id for this taxon (a monotonically increasing number for this in-memory implementation but could be a database determined unique id in other implementations) Returns : unique id Args : none =cut sub internal_id { return $_[0]->_creation_id; } =head2 _creation_id Title : _creation_id Usage : $obj->_creation_id($newval) Function: a private method signifying the internal creation order Returns : value of _creation_id Args : newvalue (optional) =cut sub _creation_id { my ($self,$value) = @_; if( defined $value) { $self->{'_creation_id'} = $value; } return $self->{'_creation_id'} || 0; } # The following methods are implemented by NodeI decorated interface =head2 is_Leaf Title : is_Leaf Usage : if( $node->is_Leaf ) Function: Get Leaf status Returns : boolean Args : none =cut sub is_Leaf { my ($self) = @_; my $rc = 0; $rc = 1 if( ! defined $self->{'_desc'} || keys %{$self->{'_desc'}} == 0); return $rc; } =head2 to_string Title : to_string Usage : my $str = $taxon->to_string() Function: For debugging, provide a taxon as a string Returns : string Args : none =cut =head2 height Title : height Usage : my $len = $taxon->height Function: Returns the height of the tree starting at this taxon. Height is the maximum branchlength. Returns : The longest length (weighting branches with branch_length) to a leaf Args : none =cut sub height { my ($self) = @_; return $self->{'_height'} if( defined $self->{'_height'} ); if( $self->is_Leaf ) { if( !defined $self->branch_length ) { $self->debug(sprintf("Trying to calculate height of a taxon when a taxon (%s) has an undefined branch_length",$self->id || '?' )); return 0; } return $self->branch_length; } my $max = 0; foreach my $subnode ( $self->each_Descendent ) { my $s = $subnode->height; if( $s > $max ) { $max = $s; } } return ($self->{'_height'} = $max + ($self->branch_length || 1)); } =head2 invalidate_height Title : invalidate_height Usage : private helper method Function: Invalidate our cached value of the taxon's height in the tree Returns : nothing Args : none =cut sub invalidate_height { my ($self) = @_; $self->{'_height'} = undef; if( $self->ancestor ) { $self->ancestor->invalidate_height; } } =head2 classify Title : classify Usage : @obj->classify() Function: a method to return the classification of a species Returns : name of taxon and ancestor's taxon recursively Args : boolean to specify whether we want all taxa not just ranked levels =cut sub classify { my ($self,$allnodes) = @_; my @classification=($self->taxon); my $node=$self; while (defined $node->ancestor) { push @classification, $node->ancestor->taxon if $allnodes==1; $node=$node->ancestor; } return (@classification); } =head2 has_rank Title : has_rank Usage : $obj->has_rank($rank) Function: a method to query ancestors' rank Returns : boolean Args : $rank =cut sub has_rank { my ($self,$rank) = @_; return $self if $self->rank eq $rank; while (defined $self->ancestor) { return $self if $self->ancestor->rank eq $rank; $self=$self->ancestor; } return; } =head2 has_taxon Title : has_taxon Usage : $obj->has_taxon($taxon) Function: a method to query ancestors' taxa Returns : boolean Args : Bio::Taxonomy::Taxon object =cut sub has_taxon { my ($self,$taxon) = @_; return $self if ((defined $self->id && $self->id == $taxon->id) || ($self->taxon eq $taxon->taxon && $self->rank eq $taxon->rank)); while (defined $self->ancestor) { return $self if ((defined $self->id && $self->id == $taxon->id) || ($self->taxon eq $taxon->taxon && $self->rank eq $taxon->rank) && ($self->taxon ne 'no rank')); $self=$self->ancestor; } return; } =head2 distance_to_root Title : distance_to_root Usage : $obj->distance_to_root Function: a method to query ancestors' taxa Returns : number of links to root Args : =cut sub distance_to_root { my ($self,$taxon) = @_; my $count=0; while (defined $self->ancestor) { $count++; $self=$self->ancestor; } return $count; } =head2 recent_common_ancestor Title : recent_common_ancestor Usage : $obj->recent_common_ancestor($taxon) Function: a method to query find common ancestors Returns : Bio::Taxonomy::Taxon of query or undef if no ancestor of rank Args : Bio::Taxonomy::Taxon =cut sub recent_common_ancestor { my ($self,$node) = @_; while (defined $node->ancestor) { my $common=$self->has_taxon($node); return $common if defined $common; $node=$node->ancestor; } return; } =head2 species Title : species Usage : $obj=$taxon->species; Function: Returns a Bio::Species object reflecting the taxon's tree position Returns : a Bio::Species object Args : none =cut sub species { my ($self) = @_; my $species; if ($self->has_rank('subspecies') && $self->ancestor->rank eq 'species') { $species = Bio::Species->new(-classification => $self->ancestor->classify); $species->genus($self->ancestor->ancestor->taxon); $species->species($self->ancestor->taxon); $species->sub_species($self->taxon); } elsif ($self->has_rank('species')) { $species = Bio::Species->new(-classification => $self->classify); $species->genus($self->ancestor->taxon); $species->species($self->taxon); } else { $self->throw("Trying to create a species from a taxonomic entity without species rank. Use classify instead of species.\n"); } return $species; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Taxonomy/Tree.pm����������������������������������������������������������������000444��000765��000024�� 26205�12254227330� 17245� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Taxonomy::Tree # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Dan Kortschak but pilfered extensively from Bio::Tree::Tree by Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Taxonomy::Tree - An Organism Level Implementation of TreeI interface. =head1 SYNOPSIS # NB: This module is deprecated. Use Bio::Taxon in combination with # Bio::Tree::Tree instead # like from a TreeIO my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 'treefile.dnd'); my $tree = $treeio->next_tree; my @nodes = $tree->get_nodes; my $root = $tree->get_root_node; my @leaves = $tree->get_leaves; =head1 DESCRIPTION This object holds handles to Taxonomic Nodes which make up a tree. =head1 EXAMPLES use Bio::Species; use Bio::Taxonomy::Tree; my $human=Bio::Species->new(); my $chimp=Bio::Species->new(); my $bonobo=Bio::Species->new(); $human->classification(qw( sapiens Homo Hominidae Catarrhini Primates Eutheria Mammalia Euteleostomi Vertebrata Craniata Chordata Metazoa Eukaryota )); $chimp->classification(qw( troglodytes Pan Hominidae Catarrhini Primates Eutheria Mammalia Euteleostomi Vertebrata Craniata Chordata Metazoa Eukaryota )); $bonobo->classification(qw( paniscus Pan Hominidae Catarrhini Primates Eutheria Mammalia Euteleostomi Vertebrata Craniata Chordata Metazoa Eukaryota )); # ranks passed to $taxonomy match ranks of species my @ranks = ('superkingdom','kingdom','phylum','subphylum', 'no rank 1','no rank 2','class','no rank 3','order', 'suborder','family','genus','species'); my $taxonomy=Bio::Taxonomy->new(-ranks => \@ranks, -method => 'trust', -order => -1); my $tree1=Bio::Taxonomy::Tree->new(); my $tree2=Bio::Taxonomy::Tree->new(); $tree1->make_species_branch($human,$taxonomy); $tree2->make_species_branch($chimp,$taxonomy); my ($homo_sapiens)=$tree1->get_leaves; $tree1->splice($tree2); $tree1->add_species($bonobo,$taxonomy); my @taxa; foreach my $leaf ($tree1->get_leaves) { push @taxa,$leaf->taxon; } print join(", ",@taxa)."\n"; @taxa=(); $tree1->remove_branch($homo_sapiens); foreach my $leaf ($tree1->get_leaves) { push @taxa,$leaf->taxon; } print join(", ",@taxa)."\n"; =head1 FEEDBACK See AUTHOR =head1 AUTHOR - Dan Kortschak Email kortschak@rsbs.anu.edu.au =head1 CONTRIBUTORS Mainly Jason Stajich =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Code begins... package Bio::Taxonomy::Tree; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Taxonomy::Taxon; # Import rank information from Bio::Taxonomy.pm use vars qw(@RANK %RANK); use base qw(Bio::Root::Root Bio::Tree::TreeI Bio::Tree::TreeFunctionsI); =head2 new Title : new Usage : my $obj = Bio::Taxonomy::Tree->new(); Function: Builds a new Bio::Taxonomy::Tree object Returns : Bio::Taxonomy::Tree Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->warn("Bio::Taxonomy::Tree is deprecated. Use Bio::Taxon in combination with Bio::Tree::Tree instead."); $self->{'_rootnode'} = undef; $self->{'_maxbranchlen'} = 0; my ($root)= $self->_rearrange([qw(ROOT)], @args); if( $root ) { $self->set_root_node($root); } return $self; } =head2 get_nodes Title : get_nodes Usage : my @nodes = $tree->get_nodes() Function: Return list of Bio::Taxonomy::Taxon objects Returns : array of Bio::Taxonomy::Taxon objects Args : (named values) hash with one value order => 'b|breadth' first order or 'd|depth' first order =cut sub get_nodes{ my ($self, @args) = @_; my ($order, $sortby) = $self->_rearrange([qw(ORDER SORTBY)],@args); $order ||= 'depth'; $sortby ||= 'height'; if ($order =~ m/^b|(breadth)$/oi) { my $node = $self->get_root_node; my @children = ($node); for (@children) { push @children, $_->each_Descendent($sortby); } return @children; } if ($order =~ m/^d|(depth)$/oi) { # this is depth-first search I believe my $node = $self->get_root_node; my @children = ($node,$node->get_Descendents($sortby)); return @children; } } =head2 get_root_node Title : get_root_node Usage : my $node = $tree->get_root_node(); Function: Get the Top Node in the tree, in this implementation Trees only have one top node. Returns : Bio::Taxonomy::Taxon object Args : none =cut sub get_root_node{ my ($self) = @_; return $self->{'_rootnode'}; } =head2 set_root_node Title : set_root_node Usage : $tree->set_root_node($node) Function: Set the Root Node for the Tree Returns : Bio::Taxonomy::Taxon Args : Bio::Taxonomy::Taxon =cut sub set_root_node{ my ($self,$value) = @_; if( defined $value ) { if( ! $value->isa('Bio::Taxonomy::Taxon') ) { $self->warn("Trying to set the root node to $value which is not a Bio::Taxonomy::Taxon"); return $self->get_root_node; } $self->{'_rootnode'} = $value; } return $self->get_root_node; } =head2 get_leaves Title : get_leaves Usage : my @nodes = $tree->get_leaves() Function: Return list of Bio::Taxonomy::Taxon objects Returns : array of Bio::Taxonomy::Taxon objects Args : =cut sub get_leaves{ my ($self) = @_; my $node = $self->get_root_node; my @leaves; my @children = ($node); for (@children) { push @children, $_->each_Descendent(); } for (@children) { push @leaves, $_ if $_->is_Leaf; } return @leaves; } =head2 make_species_branch Title : make_species_branch Usage : @nodes = $tree->make_species_branch($species,$taxonomy) Function: Return list of Bio::Taxonomy::Taxon objects based on a Bio::Species object Returns : array of Bio::Taxonomy::Taxon objects Args : Bio::Species and Bio::Taxonomy objects =cut # I'm not happy that make_species_branch and make_branch are seperate routines # should be able to just make_branch and have it sort things out sub make_species_branch{ my ($self,$species,$taxonomy) = @_; if (! $species->isa('Bio::Species') ) { $self->throw("Trying to classify $species which is not a Bio::Species object"); } if (! $taxonomy->isa('Bio::Taxonomy') ) { $self->throw("Trying to classify with $taxonomy which is not a Bio::Taxonomy object"); } # this is done to make sure we aren't duplicating a path (let God sort them out) if (defined $self->get_root_node) { $self->get_root_node->remove_all_Descendents; } my @nodes; # nb taxa in [i][0] and ranks in [i][1] my @taxa=$taxonomy->classify($species); for (my $i = 0; $i < @taxa; $i++) { $nodes[$i]=Bio::Taxonomy::Taxon->new(-taxon => $taxa[$i][0], -rank => $taxa[$i][1]); } for (my $i = 0; $i < @taxa-1; $i++) { $nodes[$i]->add_Descendent($nodes[$i+1]); } $self->set_root_node($nodes[0]); return @nodes; } =head2 make_branch Title : make_branch Usage : $tree->make_branch($node) Function: Make a linear Bio::Taxonomy::Tree object from a leafish node Returns : Args : Bio::Taxonomy::Taxon object =cut sub make_branch{ my ($self,$node) = @_; # this is done to make sure we aren't duplicating a path (let God sort them out) # note that if you are using a linked set of node which include node # already in the tree, this will break $self->get_root_node->remove_all_Descendents; while (defined $node->ancestor) { $self->set_root_node($node); $node=$node->ancestor; } } =head2 splice Title : splice Usage : @nodes = $tree->splice($tree) Function: Return a of Bio::Taxonomy::Tree object that is a fusion of two Returns : array of Bio::Taxonomy::Taxon added to tree Args : Bio::Taxonomy::Tree object =cut sub splice{ my ($self,$tree) = @_; my @nodes; my @newleaves = $tree->get_leaves; foreach my $leaf (@newleaves) { push @nodes,$self->add_branch($leaf); } return @nodes; } =head2 add_species Title : add_species Usage : @nodes = $tree->add_species($species,$taxonomy) Function: Return a of Bio::Taxonomy::Tree object with a new species added Returns : array of Bio::Taxonomy::Taxon added to tree Args : Bio::Species object =cut sub add_species{ my ($self,$species,$taxonomy) = @_; my $branch=Bio::Taxonomy::Tree->new; my @nodes=$branch->make_species_branch($species,$taxonomy); my ($newleaf)=$branch->get_leaves; return $self->add_branch($newleaf); } =head2 add_branch Title : add_branch Usage : $tree->add_branch($node,boolean) Function: Return a of Bio::Taxonomy::Tree object with a new branch added Returns : array of Bio::Taxonomy::Taxon objects of the resulting tree Args : Bio::Taxonomy::Taxon object boolean flag to force overwrite of descendent (see Bio::Node->add_Descendent) =cut sub add_branch { my ($self,$node,$force) = @_; my $best_node_level=0; my ($best_node,@nodes,$common); my @leaves=$self->get_leaves; foreach my $leaf (@leaves) { $common=$node->recent_common_ancestor($leaf); # the root of the part to add if (defined $common && ($common->distance_to_root > $best_node_level)) { $best_node_level = $common->distance_to_root; $best_node = $common; } } return unless defined $best_node; push @nodes,($self->get_root_node,$self->get_root_node->get_Descendents); foreach my $node (@nodes) { if ((defined $best_node->id && $best_node->id == $node->id) || ($best_node->rank eq $node->rank && $best_node->taxon eq $node->taxon) && ($best_node->rank ne 'no rank')) { foreach my $descendent ($common->each_Descendent) { $node->add_Descendent($descendent,$force); } } $self->set_root_node($node) if $node->distance_to_root==0; } return ($common->get_Descendents); } =head2 remove_branch Title : remove_branch Usage : $tree->remove_branch($node) Function: remove a branch up to the next multifurcation Returns : Args : Bio::Taxonomy::Taxon object =cut sub remove_branch{ my ($self,$node) = @_; # we can define a branch at any point along it while (defined $node->ancestor) { last if $node->ancestor->each_Descendent > 1; $node=$node->ancestor; } $node->remove_all_Descendents; # I'm not sure if this is necessary, # but I don't see that remove_Descendent # has the side effect of deleting # descendent nodes of the deletee $node->ancestor->remove_Descendent($node); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools���������������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 15111� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/AlignFactory.pm�����������������������������������������������������������000444��000765��000024�� 5201�12254227325� 20167� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::AlignFactory # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::AlignFactory - Base object for alignment factories =head1 SYNOPSIS You wont be using this as an object, but using a dervied class like Bio::Tools::pSW =head1 DESCRIPTION Holds common Alignment Factory attributes in place =head1 CONTACT http://bio.perl.org/ or birney@sanger.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::AlignFactory; use strict; use base qw(Bio::Root::Root); BEGIN { eval { require Bio::Ext::Align; }; if ( $@ ) { print STDERR ("\nThe C-compiled engine for Smith Waterman alignments (Bio::Ext::Align) has not been installed.\n Please install the bioperl-ext package\n\n"); exit(1); } } sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize(@args); # set up defaults $self->{'kbyte'} = 20000; $self->{'report'} = 0; return $self; } =head2 kbyte Title : kbyte() Usage : set/gets the amount of memory able to be used Function : : $factory->kbyte(200); : Returns : Argument : memory in kilobytes =cut sub kbyte { my ($self,$value) = @_; if( defined $value ) { $self->{'kbyte'} = $value; } return $self->{'kbyte'}; } =head2 report Title : report() Usage : set/gets the report boolean to issue reports or not Function : : $factory->report(1); # reporting goes on : Returns : n/a Argument : 1 or 0 =cut sub report { my ($self,$value) = @_; if( defined $value ) { if( $value != 1 && $value != 0 ) { $self->throw("Attempting to modify AlignFactory Report with no boolean value!"); } $self->{'report'} = $value; } return $self->{'report'}; } =head2 set_memory_and_report Title : set_memory_and_report Usage : Only used by subclasses. Function: Example : Returns : Args : =cut sub set_memory_and_report{ my ($self) = @_; if( $self->{'kbyte'} < 5 ) { $self->throw("You can suggest aligning things with less than 5kb"); } &Bio::Ext::Align::change_max_BaseMatrix_kbytes($self->{'kbyte'}); if( $self->{'report'} == 0 ) { &Bio::Ext::Align::error_off(16); } else { &Bio::Ext::Align::error_on(16); } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/AmpliconSearch.pm���������������������������������������������������������000444��000765��000024�� 37367�12254227320� 20532� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::AmpliconSearch # # Copyright Florent Angly # # You may distribute this module under the same terms as perl itself package Bio::Tools::AmpliconSearch; use strict; use warnings; use Bio::Tools::IUPAC; use Bio::SeqFeature::Amplicon; use Bio::Tools::SeqPattern; # we require Bio::SeqIO # and Bio::SeqFeature::Primer use base qw(Bio::Root::Root); my $template_str; =head1 NAME Bio::Tools::AmpliconSearch - Find amplicons in a template using degenerate PCR primers =head1 SYNOPSIS use Bio::PrimarySeq; use Bio::Tools::AmpliconSearch; my $template = Bio::PrimarySeq->new( -seq => 'aaaaaCCCCaaaaaaaaaaTTTTTTaaaaaCCACaaaaaTTTTTTaaaaaaaaaa', ); my $fwd_primer = Bio::PrimarySeq->new( -seq => 'CCNC', ); my $rev_primer = Bio::PrimarySeq->new( -seq => 'AAAAA', ); my $search = Bio::Tools::AmpliconSearch->new( -template => $template, -fwd_primer => $fwd_primer, -rev_primer => $rev_primer, ); while (my $amplicon = $search->next_amplicon) { print "Found amplicon at position ".$amplicon->start.'..'.$amplicon->end.":\n"; print $amplicon->seq->seq."\n\n"; } # Now change the template (but you could change the primers instead) and look # for amplicons again $template = Bio::PrimarySeq->new( -seq => 'aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa', ); $search->template($template); while (my $amplicon = $search->next_amplicon) { print "Found amplicon at position ".$amplicon->start.'..'.$amplicon->end.":\n"; print $amplicon->seq->seq."\n\n"; } =head1 DESCRIPTION Perform an in silico PCR reaction, i.e. search for amplicons in a given template sequence using the specified degenerate primer. The template sequence is a sequence object, e.g. L<Bio::Seq>, and the primers can be a sequence or a L<Bio::SeqFeature::Primer> object and contain ambiguous residues as defined in the IUPAC conventions. The primer sequences are converted into regular expressions using L<Bio::Tools::IUPAC> and the matching regions of the template sequence, i.e. the amplicons, are returned as L<Bio::Seq::PrimedSeq> objects. AmpliconSearch will look for amplicons on both strands (forward and reverse- complement) of the specified template sequence. If the reverse primer is not provided, an amplicon will be returned and span a match of the forward primer to the end of the template. Similarly, when no forward primer is given, match from the beginning of the template sequence. When several amplicons overlap, only the shortest one to more accurately represent the biases of PCR. Future improvements may include modelling the effects of the number of PCR cycles or temperature on the PCR products. =head1 TODO Future improvements may include: =over =item * Allowing a small number of primer mismatches =item * Reporting all amplicons, including overlapping ones =item * Putting a limit on the length of amplicons, in accordance with the processivity of the polymerase used =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Florent Angly <florent.angly@gmail.com> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =head2 new Title : new Usage : my $search = Bio::Tools::AmpliconSearch->new( ); Function : Initialize an amplicon search Args : -template Sequence object for the template sequence. This object will be converted to Bio::Seq if needed in since features (amplicons and primers) will be added to this object. -fwd_primer A sequence object representing the forward primer -rev_primer A sequence object representing the reverse primer -primer_file Read primers from a sequence file. It replaces -fwd_primer and -rev_primer (optional) -attach_primers Whether or not to attach primers to Amplicon objects. Default: 0 (off) Returns : A Bio::Tools::AmpliconSearch object =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($template, $primer_file, $fwd_primer, $rev_primer, $attach_primers) = $self->_rearrange([qw(TEMPLATE PRIMER_FILE FWD_PRIMER REV_PRIMER ATTACH_PRIMERS)], @args); # Get primers if (defined $primer_file) { $self->primer_file($primer_file); } else { $self->fwd_primer($fwd_primer || ''); $self->rev_primer($rev_primer || ''); } # Get template sequence $self->template($template) if defined $template; $self->attach_primers($attach_primers) if defined $attach_primers; return $self; } =head2 template Title : template Usage : my $template = $search->template; Function : Get/set the template sequence. Setting a new template resets any search in progress. Args : Optional Bio::Seq object Returns : A Bio::Seq object =cut sub template { my ($self, $template) = @_; if (defined $template) { if ( not(ref $template) || not $template->isa('Bio::PrimarySeqI') ) { # Not a Bio::Seq or Bio::PrimarySeq $self->throw("Expected a sequence object as input but got a '".ref($template)."'\n"); } if (not $template->isa('Bio::SeqI')) { # Convert sequence object to Bio::Seq Seq so that features can be added my $primary_seq = $template; $template = Bio::Seq->new(); $template->primary_seq($primary_seq); } $self->{template} = $template; # Reset search in progress $template_str = undef; } return $self->{template}; } =head2 fwd_primer Title : fwd_primer Usage : my $primer = $search->fwd_primer; Function : Get/set the forward primer. Setting a new forward primer resets any search in progress. Args : Optional sequence object or primer object or '' to match beginning of sequence. Returns : A sequence object or primer object or undef =cut sub fwd_primer { my ($self, $primer) = @_; if (defined $primer) { $self->_set_primer('fwd', $primer); } return $self->{fwd_primer}; } =head2 rev_primer Title : rev_primer Usage : my $primer = $search->rev_primer; Function : Get/set the reverse primer. Setting a new reverse primer resets any search in progress. Args : Optional sequence object or primer object or '' to match end of sequence. Returns : A sequence object or primer object or undef =cut sub rev_primer { my ($self, $primer) = @_; if (defined $primer) { $self->_set_primer('rev', $primer); } return $self->{rev_primer}; } sub _set_primer { # Save a primer (sequence object) and convert it to regexp. Type is 'fwd' for # the forward primer or 'rev' for the reverse primer. my ($self, $type, $primer) = @_; my $re; my $match_rna = 1; if ($primer eq '') { $re = $type eq 'fwd' ? '^' : '$'; } else { if ( not(ref $primer) || ( not($primer->isa('Bio::PrimarySeqI')) && not($primer->isa('Bio::SeqFeature::Primer')) ) ) { $self->throw('Expected a sequence or primer object as input but got a '.ref($primer)."\n"); } $self->{$type.'_primer'} = $primer; my $seq = $primer->isa('Bio::SeqFeature::Primer') ? $primer->seq : $primer; $re = Bio::Tools::IUPAC->new( -seq => $type eq 'fwd' ? $seq : $seq->revcom, )->regexp($match_rna); } $self->{$type.'_regexp'} = $re; # Reset search in progress $template_str = undef; $self->{regexp} = undef; return $self->{$type.'_primer'}; } =head2 primer_file Title : primer_file Usage : my ($fwd, $rev) = $search->primer_file; Function : Get/set a sequence file to read the primer from. The first sequence must be the forward primer, and the second is the optional reverse primer. After reading the file, the primers are set using fwd_primer() and rev_primer() and returned. Args : Sequence file Returns : Array containing forward and reverse primers as sequence objects. =cut sub primer_file { my ($self, $primer_file) = @_; # Read primer file and convert primers into regular expressions to catch # amplicons present in the database if (not defined $primer_file) { $self->throw("Need to provide an input file\n"); } # Mandatory first primer require Bio::SeqIO; my $in = Bio::SeqIO->new( -file => $primer_file ); my $fwd_primer = $in->next_seq; if (not defined $fwd_primer) { $self->throw("The file '$primer_file' contains no primers\n"); } $fwd_primer->alphabet('dna'); # Force the alphabet since degenerate primers can look like protein sequences # Optional reverse primers my $rev_primer = $in->next_seq; if (defined $rev_primer) { $rev_primer->alphabet('dna'); } else { $rev_primer = ''; } $in->close; $self->fwd_primer($fwd_primer); $self->rev_primer($rev_primer); return ($fwd_primer, $rev_primer); } =head2 attach_primers Title : attach_primers Usage : my $attached = $search->attach_primers; Function : Get/set whether or not to attach primer objects to the amplicon objects. Args : Optional integer (1 for yes, 0 for no) Returns : Integer (1 for yes, 0 for no) =cut sub attach_primers { my ($self, $attach) = @_; if (defined $attach) { $self->{attach_primers} = $attach; require Bio::SeqFeature::Primer; } return $self->{attach_primers} || 0; } =head2 next_amplicon Title : next_amplicon Usage : my $amplicon = $search->next_amplicon; Function : Get the next amplicon Args : None Returns : A Bio::SeqFeature::Amplicon object =cut sub next_amplicon { my ($self) = @_; # Initialize search if (not defined $template_str) { $self->_init; } my $re = $self->_regexp; my $amplicon; if ($template_str =~ m/$re/g) { my ($match, $rev_match) = ($1, $2); my $strand = $rev_match ? -1 : 1; $match = $match || $rev_match; my $end = pos($template_str); my $start = $end - length($match) + 1; $amplicon = $self->_attach_amplicon($start, $end, $strand); } # If no more matches. Make sure calls to next_amplicon() will return undef. if (not $amplicon) { $template_str = ''; } return $amplicon; } sub _init { my ($self) = @_; # Sanity checks if ( not $self->template ) { $self->throw('Need to provide a template sequence'); } if ( not($self->fwd_primer) && not($self->rev_primer) ) { $self->throw('Need to provide at least a primer'); } # Set the template sequence string $template_str = $self->template->seq; # Set the regular expression to match amplicons $self->_regexp; return 1; } sub _regexp { # Get the regexp to match amplicon. If the regexp is not set, initialize it. my ($self, $regexp) = @_; if ( not defined $self->{regexp} ) { # Build regexp that matches amplicons on both strands and reports shortest # amplicon when there are several overlapping amplicons my $fwd_regexp = $self->_fwd_regexp; my $rev_regexp = $self->_rev_regexp; my ($fwd_regexp_rc, $basic_fwd_match, $rev_regexp_rc, $basic_rev_match); if ($fwd_regexp eq '^') { $fwd_regexp_rc = ''; $basic_fwd_match = "(?:.*?$rev_regexp)"; } else { $fwd_regexp_rc = Bio::Tools::SeqPattern->new( -seq => $fwd_regexp, -type => 'dna', )->revcom->str; $basic_fwd_match = "(?:$fwd_regexp.*?$rev_regexp)"; } if ($rev_regexp eq '$') { $rev_regexp_rc = ''; $basic_rev_match = "(?:.*?$fwd_regexp_rc)"; } else { $rev_regexp_rc = Bio::Tools::SeqPattern->new( -seq => $rev_regexp, -type => 'dna', )->revcom->str; $basic_rev_match = "(?:$rev_regexp_rc.*?$fwd_regexp_rc)"; } my $fwd_exclude = "(?!$basic_rev_match". ($fwd_regexp eq '^' ? '' : "|$fwd_regexp"). ")"; my $rev_exclude = "(?!$basic_fwd_match". ($rev_regexp eq '$' ? '' : "|$rev_regexp_rc"). ')'; $self->{regexp} = qr/ ( $fwd_regexp (?:$fwd_exclude.)*? $rev_regexp ) | ( $rev_regexp_rc (?:$rev_exclude.)*? $fwd_regexp_rc ) /xi; } return $self->{regexp}; } =head2 annotate_template Title : annotate_template Usage : my $template = $search->annotate_template; Function : Search for all amplicons and attach them to the template. This is equivalent to running: while (my $amplicon = $self->next_amplicon) { # do something } my $annotated = $self->template; Args : None Returns : A Bio::Seq object with attached Bio::SeqFeature::Amplicons (and Bio::SeqFeature::Primers if you set -attach_primers to 1). =cut sub annotate_template { my ($self) = @_; # Search all amplicons and attach them to template 1 while $self->next_amplicon; # Return annotated template return $self->template; } sub _fwd_regexp { my ($self) = @_; return $self->{fwd_regexp}; } sub _rev_regexp { my ($self) = @_; return $self->{rev_regexp}; } sub _attach_amplicon { # Create an amplicon object and attach it to template my ($self, $start, $end, $strand) = @_; # Create Bio::SeqFeature::Amplicon feature and attach it to the template my $amplicon = Bio::SeqFeature::Amplicon->new( -start => $start, -end => $end, -strand => $strand, -template => $self->template, ); # Create Bio::SeqFeature::Primer feature and attach them to the amplicon if ($self->attach_primers) { for my $type ('fwd', 'rev') { my ($pstart, $pend, $pstrand, $primer_seq); # Coordinates relative to amplicon if ($type eq 'fwd') { # Forward primer $primer_seq = $self->fwd_primer; next if not defined $primer_seq; $pstart = 1; $pend = $primer_seq->length; $pstrand = $amplicon->strand; } else { # Optional reverse primer $primer_seq = $self->rev_primer; next if not defined $primer_seq; $pstart = $end - $primer_seq->length + 1; $pend = $end; $pstrand = -1 * $amplicon->strand; } # Absolute coordinates needed $pstart += $start - 1; $pend += $start - 1; my $primer = Bio::SeqFeature::Primer->new( -start => $pstart, -end => $pend, -strand => $pstrand, -template => $amplicon, ); # Attach primer to amplicon if ($type eq 'fwd') { $amplicon->fwd_primer($primer); } else { $amplicon->rev_primer($primer); } } } return $amplicon; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/AnalysisResult.pm���������������������������������������������������������000444��000765��000024�� 22556�12254227333� 20622� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::AnalysisResult # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp-at-gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::AnalysisResult - Base class for analysis result objects and parsers =head1 SYNOPSIS # obtain a AnalysisResult derived object somehow print "Method ", $result->analysis_method(), ", version ", $result->analysis_method_version(), ", performed on ", $result->analysis_date(), "\n"; # annotate a sequence utilizing SeqAnalysisParserI methods while($feat = $result->next_feature()) { $seq->add_SeqFeature($feat); } $result->close(); # query object, e.g. a Bio::SeqI implementing object $queryseq = $result->analysis_query(); # Subject of the analysis -- may be undefined. Refer to derived module # to find out what is returned. $subject = $result->analysis_subject(); =head1 DESCRIPTION The AnalysisResult module is supposed to be the base class for modules encapsulating parsers and interpreters for the result of a analysis that was carried out with a query sequence. The notion of an analysis represented by this base class is that of a unary or binary operator, taking either one query or a query and a subject and producing a result. The query is e.g. a sequence, and a subject is either a sequence, too, or a database of sequences. This module also implements the Bio::SeqAnalysisParserI interface, and thus can be used wherever such an object fits. See L<Bio::SeqAnalysisParserI>. Developers will find a ready-to-use B<parse()> method, but need to implement B<next_feature()> in an inheriting class. Support for initialization with input file names and reading from streams is also ready to use. Note that this module does not provide support for B<running> an analysis. Rather, it is positioned in the subsequent parsing step (concerned with turning raw results into BioPerl objects). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp-at-gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::AnalysisResult; use strict; use base qw(Bio::Root::Root Bio::SeqAnalysisParserI Bio::AnalysisResultI Bio::Root::IO); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize(@args); return $self; } sub _initialize { my($self,@args) = @_; my $make = $self->SUPER::_initialize(@args); $self->_initialize_state(@args); return $make; # success - we hope! } =head2 _initialize_state Title : _initialize_state Usage : n/a; usually called by _initialize() Function: This method is for BioPerl B<developers> only, as indicated by the leading underscore in its name. Performs initialization or reset of the state of this object. The difference to _initialize() is that it may be called at any time, and repeatedly within the lifetime of this object. B<Note>, however, that this is potentially dangerous in a multi-threading environment. In general, calling this method twice is discouraged for this reason. This method is supposed to reset the state such that any 'history' is lost. State information that does not change during object lifetime is not considered as history, e.g. parent, name, etc shall not be reset. An inheriting object should only be concerned with state information it introduces itself, and for everything else call SUPER::_initialize_state(@args). An example is parsing an input file: a state reset implies discarding any unread input, and the actual input itself, followed by setting the new input. The argument syntax is the same as for L<new()|new> and L<_initialize()|_initialize>, i.e., named parameters following the -name=>$value convention. The following parameters are dealt with by the implementation provided here: -INPUT, -FH, -FILE (tags are case-insensitive). Example : Returns : Args : =cut sub _initialize_state { my ($self,@args) = @_; $self->close(); $self->_initialize_io(@args); $self->{'_analysis_sbjct'} = undef; $self->{'_analysis_query'} = undef; $self->{'_analysis_prog'} = undef; $self->{'_analysis_progVersion'} = undef; $self->{'_analysis_date'} = undef; return 1; } # =head2 parse # # Title : parse # Usage : $obj->parse(-input=>$inputobj, [ -params=>[@params] ], # [ -method => $method ] ) # Function: Sets up parsing for feature retrieval from an analysis file, # or object. # # This method was originally required by SeqAnalysisParserI, but # is now discouraged due to potential problems in a multi- # threading environment (CORBA!). If called only once, it doesn't # add any functionality to calling new() with the same # parameters. # # The implementation provided here calls automatically # _initialize_state() and passes on -input=>$inputobj and # @params as final arguments. # Example : # Returns : void # Args : B<input> - object/file where analysis are coming from # B<params> - parameter to use when parsing/running analysis # B<method> - method of analysis # # =cut sub parse { my ($self, @args) = @_; my ($input, $params, $method) = $self->_rearrange([qw(INPUT PARAMS METHOD )], @args); # initialize with new input if($params) { $self->_initialize_state('-input' => $input, @$params); } else { $self->_initialize_state('-input' => $input); } $self->analysis_method($method) if $method; } =head2 analysis_query Usage : $query_obj = $result->analysis_query(); Purpose : Set/Get the name of the query used to generate the result, that is, the entity on which the analysis was performed. Will mostly be a sequence object (Bio::PrimarySeq compatible). Argument : Returns : The object set before. Mostly a Bio::PrimarySeq compatible object. =cut #-------- sub analysis_query { my ($self, $obj) = @_; if($obj) { $self->{'_analysis_query'} = $obj; } return $self->{'_analysis_query'}; } #-------- =head2 analysis_subject Usage : $result->analyis_subject(); Purpose : Set/Get the subject of the analysis against which it was performed. For similarity searches it will probably be a database, and for sequence feature predictions (exons, promoters, etc) it may be a collection of models or homologous sequences that were used, or undefined. Returns : The object that was set before, or undef. Argument : =cut #--------------- sub analysis_subject { #--------------- my ($self, $sbjct_obj) = @_; if($sbjct_obj) { $self->{'_analysis_sbjct'} = $sbjct_obj; } return $self->{'_analysis_sbjct'}; } =head2 analysis_date Usage : $result->analysis_date(); Purpose : Set/Get the date on which the analysis was performed. Returns : String Argument : Comments : =cut #---------- sub analysis_date { my ($self, $date) = @_; if($date) { $self->{'_analysis_date'} = $date; } return $self->{'_analysis_date'}; } #---------- =head2 analysis_method Usage : $result->analysis_method(); Purpose : Set/Get the name of the sequence analysis method that was used to produce this result (BLASTP, FASTA, etc.). May also be the actual name of a program. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method) { $self->{'_analysis_prog'} = $method; } return $self->{'_analysis_prog'}; } =head2 analysis_method_version Usage : $result->analysis_method_version(); Purpose : Set/Get the version string of the analysis program. : (e.g., 1.4.9MP, 2.0a19MP-WashU). Returns : String Argument : n/a =cut #--------------------- sub analysis_method_version { #--------------------- my ($self, $version) = @_; if($version) { $self->{'_analysis_progVersion'} = $version; } return $self->{'_analysis_progVersion'}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Blat.pm�������������������������������������������������������������������000555��000765��000024�� 15442�12254227314� 16520� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Blat # # Written by Balamurugan Kumarasamy # # You may distribute this module under the same terms as perl itself # =head1 NAME Bio::Tools::Blat - parser for Blat program =head1 SYNOPSIS use Bio::Tools::Blat; my $blat_parser = Bio::Tools::Blat->new(-fh =>$filehandle ); while( my $blat_feat = $blat_parser->next_result ) { push @blat_feat, $blat_feat; } =head1 DESCRIPTION Parser for Blat program =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Balamurugan Kumarasamy Email: bala@tll.org.sg =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Blat; use strict; use Bio::SeqFeature::Generic; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Blat->new(-fh=>$filehandle); Function: Builds a new Bio::Tools::Blat object Returns : Bio::Tools::Blat Args : -filename -fh (filehandle) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $blat_parser->next_result Function: Get the next result set from parser data Returns : L<Bio::SeqFeature::Generic> Args : none =cut sub next_result { my ($self) = @_; my $filehandle; my $line; my $id; while ($_=$self->_readline()){ # first split on spaces: $line = $_; chomp $line; my ($matches, $mismatches, $rep_matches, $n_count, $q_num_insert, $q_base_insert, $t_num_insert, $t_base_insert, $strand, $q_name, $q_length, $q_start, $q_end, $t_name, $t_length, $t_start, $t_end, $block_count, $block_sizes, $q_starts, $t_starts ) = split; my $superfeature = Bio::SeqFeature::Generic->new(); # ignore any preceeding text next unless ( $matches =~/^\d+$/ ); # create as many features as blocks there are in each output line my (%feat1, %feat2); $feat1{name} = $t_name; $feat2{name} = $q_name; $strand = $1 if ($strand =~/([+-])[+-]/); $feat2{strand} = 1; $feat1{strand} = $strand; my $percent_id = sprintf "%.2f", (100 * ($matches + $rep_matches)/( $matches + $mismatches + $rep_matches)); unless ( $q_length ){ $self->warn("length of query is zero, something is wrong!"); next; } my $score = sprintf "%.2f", (100 * ( $matches + $mismatches + $rep_matches ) / $q_length); # size of each block of alignment (inclusive) my @block_sizes = split ",",$block_sizes; # start position of each block (you must add 1 as psl output # is off by one in the start coordinate) my @q_start_positions = split ",",$q_starts; my @t_start_positions = split ",",$t_starts; $superfeature->seq_id($q_name); $superfeature->score( $score ); $superfeature->add_tag_value('percent_id',$percent_id); # each line of output represents one possible entire aligment # of the query (feat1) and the target(feat2) for (my $i=0; $i<$block_count; $i++ ){ my ($query_start,$query_end); if ( $strand eq '+' ){ $query_start = $q_start_positions[$i] + 1; $query_end = $query_start + $block_sizes[$i] - 1; }else{ $query_end = $q_length - $q_start_positions[$i]; $query_start = $query_end - $block_sizes[$i] + 1; } #$feat2 {start} = $q_start_positions[$i] + 1; #$feat2 {end} = $feat2{start} + $block_sizes[$i] - 1; $feat2 {start} = $query_start; $feat2 {end} = $query_end; if ( $query_end < $query_start ){ $self->warn("dodgy feature coordinates: end = $query_end, start = $query_start. Reversing..."); $feat2 {end} = $query_start; $feat2 {start} = $query_end; } $feat1 {start} = $t_start_positions[$i] + 1; $feat1 {end} = $feat1{start} + $block_sizes[$i] - 1; # we put all the features with the same score and percent_id $feat2 {score} = $score; $feat1 {score} = $feat2 {score}; $feat2 {percent} = $percent_id; $feat1 {percent} = $feat2 {percent}; # other stuff: $feat1 {db} = undef; $feat1 {db_version} = undef; $feat1 {program} = 'blat'; $feat1 {p_version} = '1'; $feat1 {source} = 'blat'; $feat1 {primary} = 'similarity'; $feat2 {source} = 'blat'; $feat2 {primary} = 'similarity'; my $feature_pair = $self->create_feature(\%feat1, \%feat2); $superfeature->add_sub_SeqFeature( $feature_pair,'EXPAND'); } return $superfeature; } } =head2 create_feature Title : create_feature Usage : my $feat=$blat_parser->create_feature($feature,$seqname) Function: creates a SeqFeature Generic object Returns : L<Bio::SeqFeature::Generic> Args : =cut sub create_feature { my ($self, $feat1,$feat2) = @_; my $feature1= Bio::SeqFeature::Generic->new( -seq_id =>$feat1->{name}, -start =>$feat1->{start}, -end =>$feat1->{end}, -strand =>$feat1->{strand}, -score =>$feat1->{score}, -source =>$feat1->{source}, -primary =>$feat1->{primary} ); my $feature2= Bio::SeqFeature::Generic->new( -seq_id =>$feat2->{name}, -start =>$feat2->{start}, -end =>$feat2->{end}, -strand =>$feat2->{strand}, -score =>$feat2->{score}, -source =>$feat2->{source}, -primary =>$feat2->{primary} ); my $featurepair = Bio::SeqFeature::FeaturePair->new; $featurepair->feature1 ($feature1); $featurepair->feature2 ($feature2); $featurepair->add_tag_value('evalue',$feat2->{p}); $featurepair->add_tag_value('percent_id',$feat2->{percent}); $featurepair->add_tag_value("hid",$feat2->{primary}); return $featurepair; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/CodonTable.pm�������������������������������������������������������������000444��000765��000024�� 64053�12254227316� 17651� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Tools::CodonTable # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::CodonTable - Codon table object =head1 SYNOPSIS # This is a read-only class for all known codon tables. The IDs are # the ones used by nucleotide sequence databases. All common IUPAC # ambiguity codes for DNA, RNA and amino acids are recognized. use Bio::Tools::CodonTable; # defaults to ID 1 "Standard" $myCodonTable = Bio::Tools::CodonTable->new(); $myCodonTable2 = Bio::Tools::CodonTable->new( -id => 3 ); # change codon table $myCodonTable->id(5); # examine codon table print join (' ', "The name of the codon table no.", $myCodonTable->id(4), "is:", $myCodonTable->name(), "\n"); # print possible codon tables $tables = Bio::Tools::CodonTable->tables; while ( ($id,$name) = each %{$tables} ) { print "$id = $name\n"; } # translate a codon $aa = $myCodonTable->translate('ACU'); $aa = $myCodonTable->translate('act'); $aa = $myCodonTable->translate('ytr'); # reverse translate an amino acid @codons = $myCodonTable->revtranslate('A'); @codons = $myCodonTable->revtranslate('Ser'); @codons = $myCodonTable->revtranslate('Glx'); @codons = $myCodonTable->revtranslate('cYS', 'rna'); # reverse translate an entire amino acid sequence into a IUPAC # nucleotide string my $seqobj = Bio::PrimarySeq->new(-seq => 'FHGERHEL'); my $iupac_str = $myCodonTable->reverse_translate_all($seqobj); # boolean tests print "Is a start\n" if $myCodonTable->is_start_codon('ATG'); print "Is a terminator\n" if $myCodonTable->is_ter_codon('tar'); print "Is a unknown\n" if $myCodonTable->is_unknown_codon('JTG'); =head1 DESCRIPTION Codon tables are also called translation tables or genetic codes since that is what they represent. A bit more complete picture of the full complexity of codon usage in various taxonomic groups is presented at the NCBI Genetic Codes Home page. CodonTable is a BioPerl class that knows all current translation tables that are used by primary nucleotide sequence databases (GenBank, EMBL and DDBJ). It provides methods to output information about tables and relationships between codons and amino acids. This class and its methods recognized all common IUPAC ambiguity codes for DNA, RNA and animo acids. The translation method follows the conventions in EMBL and TREMBL databases. It is a nuisance to separate RNA and cDNA representations of nucleic acid transcripts. The CodonTable object accepts codons of both type as input and allows the user to set the mode for output when reverse translating. Its default for output is DNA. Note: This class deals primarily with individual codons and amino acids. However in the interest of speed you can L<translate> longer sequence, too. The full complexity of protein translation is tackled by L<Bio::PrimarySeqI::translate>. The amino acid codes are IUPAC recommendations for common amino acids: A Ala Alanine R Arg Arginine N Asn Asparagine D Asp Aspartic acid C Cys Cysteine Q Gln Glutamine E Glu Glutamic acid G Gly Glycine H His Histidine I Ile Isoleucine L Leu Leucine K Lys Lysine M Met Methionine F Phe Phenylalanine P Pro Proline O Pyl Pyrrolysine (22nd amino acid) U Sec Selenocysteine (21st amino acid) S Ser Serine T Thr Threonine W Trp Tryptophan Y Tyr Tyrosine V Val Valine B Asx Aspartic acid or Asparagine Z Glx Glutamine or Glutamic acid J Xle Isoleucine or Valine (mass spec ambiguity) X Xaa Any or unknown amino acid It is worth noting that, "Bacterial" codon table no. 11 produces an polypeptide that is, confusingly, identical to the standard one. The only differences are in available initiator codons. NCBI Genetic Codes home page: http://www.ncbi.nlm.nih.gov/Taxonomy/Utils/wprintgc.cgi?mode=c EBI Translation Table Viewer: http://www.ebi.ac.uk/cgi-bin/mutations/trtables.cgi Amended ASN.1 version with ids 16 and 21 is at: ftp://ftp.ebi.ac.uk/pub/databases/geneticcode/ Thanks to Matteo diTomasso for the original Perl implementation of these tables. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::CodonTable; use vars qw(@NAMES @TABLES @STARTS $TRCOL $CODONS %IUPAC_DNA $CODONGAP $GAP %IUPAC_AA %THREELETTERSYMBOLS $VALID_PROTEIN $TERMINATOR); use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Tools::IUPAC; use Bio::SeqUtils; use base qw(Bio::Root::Root); # first set internal values for all translation tables BEGIN { use constant CODONSIZE => 3; $GAP = '-'; $CODONGAP = $GAP x CODONSIZE; @NAMES = #id ( 'Standard', #1 'Vertebrate Mitochondrial',#2 'Yeast Mitochondrial',# 3 'Mold, Protozoan, and CoelenterateMitochondrial and Mycoplasma/Spiroplasma',#4 'Invertebrate Mitochondrial',#5 'Ciliate, Dasycladacean and Hexamita Nuclear',# 6 '', '', 'Echinoderm Mitochondrial',#9 'Euplotid Nuclear',#10 '"Bacterial"',# 11 'Alternative Yeast Nuclear',# 12 'Ascidian Mitochondrial',# 13 'Flatworm Mitochondrial',# 14 'Blepharisma Nuclear',# 15 'Chlorophycean Mitochondrial',# 16 '', '', '', '', 'Trematode Mitochondrial',# 21 'Scenedesmus obliquus Mitochondrial', #22 'Thraustochytrium Mitochondrial', #23 'Strict', #24, option for only ATG start ); @TABLES = qw( FFLLSSSSYY**CC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CCWWLLLLPPPPHHQQRRRRIIMMTTTTNNKKSS**VVVVAAAADDEEGGGG FFLLSSSSYY**CCWWTTTTPPPPHHQQRRRRIIMMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CCWWLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CCWWLLLLPPPPHHQQRRRRIIMMTTTTNNKKSSSSVVVVAAAADDEEGGGG FFLLSSSSYYQQCC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG '' '' FFLLSSSSYY**CCWWLLLLPPPPHHQQRRRRIIIMTTTTNNNKSSSSVVVVAAAADDEEGGGG FFLLSSSSYY**CCCWLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CC*WLLLSPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CCWWLLLLPPPPHHQQRRRRIIMMTTTTNNKKSSGGVVVVAAAADDEEGGGG FFLLSSSSYYY*CCWWLLLLPPPPHHQQRRRRIIIMTTTTNNNKSSSSVVVVAAAADDEEGGGG FFLLSSSSYY*QCC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY*LCC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG '' '' '' '' FFLLSSSSYY**CCWWLLLLPPPPHHQQRRRRIIMMTTTTNNNKSSSSVVVVAAAADDEEGGGG FFLLSS*SYY*LCC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FF*LSSSSYY**CC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG FFLLSSSSYY**CC*WLLLLPPPPHHQQRRRRIIIMTTTTNNKKSSRRVVVVAAAADDEEGGGG ); # (bases used for these tables, for reference) # 1 TTTTTTTTTTTTTTTTCCCCCCCCCCCCCCCCAAAAAAAAAAAAAAAAGGGGGGGGGGGGGGGG # 2 TTTTCCCCAAAAGGGGTTTTCCCCAAAAGGGGTTTTCCCCAAAAGGGGTTTTCCCCAAAAGGGG # 3 TCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAGTCAG @STARTS = qw( ---M---------------M---------------M---------------------------- --------------------------------MMMM---------------M------------ ----------------------------------MM---------------------------- --MM---------------M------------MMMM---------------M------------ ---M----------------------------MMMM---------------M------------ -----------------------------------M---------------------------- '' '' -----------------------------------M---------------------------- -----------------------------------M---------------------------- ---M---------------M------------MMMM---------------M------------ -------------------M---------------M---------------------------- -----------------------------------M---------------------------- -----------------------------------M---------------------------- -----------------------------------M---------------------------- -----------------------------------M---------------------------- '' '' '' '' -----------------------------------M---------------M------------ -----------------------------------M---------------------------- --------------------------------M--M---------------M------------ -----------------------------------M---------------------------- ); my @nucs = qw(t c a g); my $x = 0; ($CODONS, $TRCOL) = ({}, {}); for my $i (@nucs) { for my $j (@nucs) { for my $k (@nucs) { my $codon = "$i$j$k"; $CODONS->{$codon} = $x; $TRCOL->{$x} = $codon; $x++; } } } %IUPAC_DNA = Bio::Tools::IUPAC->iupac_iub(); %IUPAC_AA = Bio::Tools::IUPAC->iupac_iup(); %THREELETTERSYMBOLS = Bio::SeqUtils->valid_aa(2); $VALID_PROTEIN = '['.join('',Bio::SeqUtils->valid_aa(0)).']'; $TERMINATOR = '*'; } sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($id) = $self->_rearrange([qw(ID )], @args); $id = 1 if ( ! $id ); $id && $self->id($id); return $self; # success - we hope! } =head2 id Title : id Usage : $obj->id(3); $id_integer = $obj->id(); Function: Sets or returns the id of the translation table. IDs are integers from 1 to 15, excluding 7 and 8 which have been removed as redundant. If an invalid ID is given the method returns 0, false. Example : Returns : value of id, a scalar, 0 if not a valid Args : newvalue (optional) =cut sub id{ my ($self,$value) = @_; if( defined $value) { if ( !(defined $TABLES[$value-1]) or $TABLES[$value-1] eq '') { $self->warn("Not a valid codon table ID [$value] "); $value = 0; } $self->{'id'} = $value; } return $self->{'id'}; } =head2 name Title : name Usage : $obj->name() Function: returns the descriptive name of the translation table Example : Returns : A string Args : None =cut sub name{ my ($self) = @_; my ($id) = $self->{'id'}; return $NAMES[$id-1]; } =head2 tables Title : tables Usage : $obj->tables() or Bio::Tools::CodonTable->tables() Function: returns a hash reference where each key is a valid codon table id() number, and each value is the corresponding codon table name() string Example : Returns : A hashref Args : None =cut sub tables{ my %tables; for my $id (1 .. @NAMES) { my $name = $NAMES[$id-1]; $tables{$id} = $name if $name; } return \%tables; } =head2 translate Title : translate Usage : $obj->translate('YTR') Function: Returns a string of one letter amino acid codes from nucleotide sequence input. The imput can be of any length. Returns 'X' for unknown codons and codons that code for more than one amino acid. Returns an empty string if input is not three characters long. Exceptions for these are: - IUPAC amino acid code B for Aspartic Acid and Asparagine, is used. - IUPAC amino acid code Z for Glutamic Acid, Glutamine is used. - if the codon is two nucleotides long and if by adding an a third character 'N', it codes for a single amino acid (with exceptions above), return that, otherwise return empty string. Returns empty string for other input strings that are not three characters long. Example : Returns : a string of one letter ambiguous IUPAC amino acid codes Args : ambiguous IUPAC nucleotide string =cut sub translate { my ($self, $seq, $complete_codon) = @_; $self->throw("Calling translate without a seq argument!") unless defined $seq; return '' unless $seq; my $id = $self->id; my ($partial) = 0; $partial = 2 if length($seq) % CODONSIZE == 2; $seq = lc $seq; $seq =~ tr/u/t/; my $protein = ""; if ($seq =~ /[^actg]/ ) { #ambiguous chars for (my $i = 0; $i < (length($seq) - (CODONSIZE-1)); $i+= CODONSIZE) { my $triplet = substr($seq, $i, CODONSIZE); if( $triplet eq $CODONGAP ) { $protein .= $GAP; } elsif (exists $CODONS->{$triplet}) { $protein .= substr($TABLES[$id-1], $CODONS->{$triplet},1); } else { $protein .= $self->_translate_ambiguous_codon($triplet); } } } else { # simple, strict translation for (my $i = 0; $i < (length($seq) - (CODONSIZE -1)); $i+=CODONSIZE) { my $triplet = substr($seq, $i, CODONSIZE); if( $triplet eq $CODONGAP ) { $protein .= $GAP; } if (exists $CODONS->{$triplet}) { $protein .= substr($TABLES[$id-1], $CODONS->{$triplet}, 1); } else { $protein .= 'X'; } } } if ($partial == 2 && $complete_codon) { # 2 overhanging nucleotides my $triplet = substr($seq, ($partial -4)). "n"; if( $triplet eq $CODONGAP ) { $protein .= $GAP; } elsif (exists $CODONS->{$triplet}) { my $aa = substr($TABLES[$id-1], $CODONS->{$triplet},1); $protein .= $aa; } else { $protein .= $self->_translate_ambiguous_codon($triplet, $partial); } } return $protein; } sub _translate_ambiguous_codon { my ($self, $triplet, $partial) = @_; $partial ||= 0; my $id = $self->id; my $aa; my @codons = $self->unambiguous_codons($triplet); my %aas =(); foreach my $codon (@codons) { $aas{substr($TABLES[$id-1],$CODONS->{$codon},1)} = 1; } my $count = scalar keys %aas; if ( $count == 1 ) { $aa = (keys %aas)[0]; } elsif ( $count == 2 ) { if ($aas{'D'} and $aas{'N'}) { $aa = 'B'; } elsif ($aas{'E'} and $aas{'Q'}) { $aa = 'Z'; } else { $partial ? ($aa = '') : ($aa = 'X'); } } else { $partial ? ($aa = '') : ($aa = 'X'); } return $aa; } =head2 translate_strict Title : translate_strict Usage : $obj->translate_strict('ACT') Function: returns one letter amino acid code for a codon input Fast and simple translation. User is responsible to resolve ambiguous nucleotide codes before calling this method. Returns 'X' for unknown codons and an empty string for input strings that are not three characters long. It is not recommended to use this method in a production environment. Use method translate, instead. Example : Returns : A string Args : a codon = a three nucleotide character string =cut sub translate_strict{ my ($self, $value) = @_; my $id = $self->{'id'}; $value = lc $value; $value =~ tr/u/t/; return '' unless length $value == 3; return 'X' unless defined $CODONS->{$value}; return substr( $TABLES[$id-1], $CODONS->{$value}, 1 ); } =head2 revtranslate Title : revtranslate Usage : $obj->revtranslate('G') Function: returns codons for an amino acid Returns an empty string for unknown amino acid codes. Ambiguous IUPAC codes Asx,B, (Asp,D; Asn,N) and Glx,Z (Glu,E; Gln,Q) are resolved. Both single and three letter amino acid codes are accepted. '*' and 'Ter' are used for terminator. By default, the output codons are shown in DNA. If the output is needed in RNA (tr/t/u/), add a second argument 'RNA'. Example : $obj->revtranslate('Gly', 'RNA') Returns : An array of three lower case letter strings i.e. codons Args : amino acid, 'RNA' =cut sub revtranslate { my ($self, $value, $coding) = @_; my @codons; if (length($value) == 3 ) { $value = lc $value; $value = ucfirst $value; $value = $THREELETTERSYMBOLS{$value}; } if ( defined $value and $value =~ /$VALID_PROTEIN/ and length($value) == 1 ) { my $id = $self->{'id'}; $value = uc $value; my @aas = @{$IUPAC_AA{$value}}; foreach my $aa (@aas) { #print $aa, " -2\n"; $aa = '\*' if $aa eq '*'; while ($TABLES[$id-1] =~ m/$aa/g) { my $p = pos $TABLES[$id-1]; push (@codons, $TRCOL->{--$p}); } } } if ($coding and uc ($coding) eq 'RNA') { for my $i (0..$#codons) { $codons[$i] =~ tr/t/u/; } } return @codons; } =head2 reverse_translate_all Title : reverse_translate_all Usage : my $iup_str = $cttable->reverse_translate_all($seq_object) my $iup_str = $cttable->reverse_translate_all($seq_object, $cutable, 15); Function: reverse translates a protein sequence into IUPAC nucleotide sequence. An 'X' in the protein sequence is converted to 'NNN' in the nucleotide sequence. Returns : a string Args : a Bio::PrimarySeqI compatible object (mandatory) a Bio::CodonUsage::Table object and a threshold if only codons with a relative frequency above the threshold are to be considered. =cut sub reverse_translate_all { my ($self, $obj, $cut, $threshold) = @_; ## check args are OK if (!$obj || !$obj->isa('Bio::PrimarySeqI')){ $self->throw(" I need a Bio::PrimarySeqI object, not a [". ref($obj) . "]"); } if($obj->alphabet ne 'protein') { $self->throw("Cannot reverse translate, need an amino acid sequence .". "This sequence is of type [" . $obj->alphabet ."]"); } my @data; my @seq = split '', $obj->seq; ## if we're not supplying a codon usage table... if( !$cut && !$threshold) { ## get lists of possible codons for each aa. for my $aa (@seq) { if ($aa =~ /x/i) { push @data, (['NNN']); }else { my @cods = $self->revtranslate($aa); push @data, \@cods; } } }else{ #else we are supplying a codon usage table, we just want common codons #check args first. if(!$cut->isa('Bio::CodonUsage::Table')) { $self->throw("I need a Bio::CodonUsage::Table object, not a [". ref($cut). "]."); } my $cod_ref = $cut->probable_codons($threshold); for my $aa (@seq) { if ($aa =~ /x/i) { push @data, (['NNN']); next; } push @data, $cod_ref->{$aa}; } } return $self->_make_iupac_string(\@data); } =head2 reverse_translate_best Title : reverse_translate_best Usage : my $str = $cttable->reverse_translate_best($seq_object,$cutable); Function: Reverse translates a protein sequence into plain nucleotide sequence (GATC), uses the most common codon for each amino acid Returns : A string Args : A Bio::PrimarySeqI compatible object and a Bio::CodonUsage::Table object =cut sub reverse_translate_best { my ($self, $obj, $cut) = @_; if (!$obj || !$obj->isa('Bio::PrimarySeqI')){ $self->throw(" I need a Bio::PrimarySeqI object, not a [". ref($obj) . "]"); } if ($obj->alphabet ne 'protein') { $self->throw("Cannot reverse translate, need an amino acid sequence .". "This sequence is of type [" . $obj->alphabet ."]"); } if ( !$cut | !$cut->isa('Bio::CodonUsage::Table')) { $self->throw("I need a Bio::CodonUsage::Table object, not a [". ref($cut). "]."); } my $str = ''; my @seq = split '', $obj->seq; my $cod_ref = $cut->most_common_codons(); for my $aa ( @seq ) { if ($aa =~ /x/i) { $str .= 'NNN'; next; } if ( defined $cod_ref->{$aa} ) { $str .= $cod_ref->{$aa}; } else { $self->throw("Input sequence contains invalid character: $aa"); } } $str; } =head2 is_start_codon Title : is_start_codon Usage : $obj->is_start_codon('ATG') Function: returns true (1) for all codons that can be used as a translation start, false (0) for others. Example : $myCodonTable->is_start_codon('ATG') Returns : boolean Args : codon =cut sub is_start_codon{ shift->_codon_is( shift, \@STARTS, 'M' ); } =head2 is_ter_codon Title : is_ter_codon Usage : $obj->is_ter_codon('GAA') Function: returns true (1) for all codons that can be used as a translation tarminator, false (0) for others. Example : $myCodonTable->is_ter_codon('ATG') Returns : boolean Args : codon =cut sub is_ter_codon{ shift->_codon_is( shift, \@TABLES, $TERMINATOR ); } # desc: compares the passed value with a single entry in the given # codon table # args: a value (typically a three-char string like 'atg'), # a reference to the appropriate set of codon tables, # a single-character value to check for at the position in the # given codon table # ret: boolean, true if the given codon table contains the $key at the # position corresponding to $value sub _codon_is { my ($self, $value, $table, $key ) = @_; return 0 unless length $value == 3; $value = lc $value; $value =~ tr/u/t/; my $id = $self->{'id'}; for my $c ( $self->unambiguous_codons($value) ) { my $m = substr( $table->[$id-1], $CODONS->{$c}, 1 ); return 0 unless $m eq $key; } return 1; } =head2 is_unknown_codon Title : is_unknown_codon Usage : $obj->is_unknown_codon('GAJ') Function: returns false (0) for all codons that are valid, true (1) for others. Example : $myCodonTable->is_unknown_codon('NTG') Returns : boolean Args : codon =cut sub is_unknown_codon{ my ($self, $value) = @_; $value = lc $value; $value =~ tr/u/t/; return 1 unless $self->unambiguous_codons($value); return 0; } =head2 unambiguous_codons Title : unambiguous_codons Usage : @codons = $self->unambiguous_codons('ACN') Returns : array of strings (one-letter unambiguous amino acid codes) Args : a codon = a three IUPAC nucleotide character string =cut sub unambiguous_codons{ my ($self,$value) = @_; my @nts = map { $IUPAC_DNA{uc $_} } split(//, $value); my @codons; for my $i ( @{$nts[0]} ) { for my $j ( @{$nts[1]} ) { for my $k ( @{$nts[2]} ) { push @codons, lc "$i$j$k"; }}} return @codons; } =head2 _unambiquous_codons deprecated, now an alias for unambiguous_codons =cut sub _unambiquous_codons { unambiguous_codons( undef, @_ ); } =head2 add_table Title : add_table Usage : $newid = $ct->add_table($name, $table, $starts) Function: Add a custom Codon Table into the object. Know what you are doing, only the length of the argument strings is checked! Returns : the id of the new codon table Args : name, a string, optional (can be empty) table, a string of 64 characters startcodons, a string of 64 characters, defaults to standard =cut sub add_table { my ($self, $name, $table, $starts) = @_; $name ||= 'Custom'. scalar @NAMES + 1; $starts ||= $STARTS[0]; $self->throw('Suspect input!') unless length($table) == 64 and length($starts) == 64; push @NAMES, $name; push @TABLES, $table; push @STARTS, $starts; return scalar @NAMES; } sub _make_iupac_string { my ($self, $cod_ref) = @_; if(ref($cod_ref) ne 'ARRAY') { $self->throw(" I need a reference to a list of references to codons, ". " not a [". ref($cod_ref) . "]."); } my %iupac_hash = Bio::Tools::IUPAC->iupac_rev_iub(); my $iupac_string = ''; ## the string to be returned for my $aa (@$cod_ref) { ## scan through codon positions, record the differing values, # then look up in the iub hash for my $index(0..2) { my %h; map { my $k = substr($_,$index,1); $h{$k} = undef;} @$aa; my $lookup_key = join '', sort{$a cmp $b}keys %h; ## extend string $iupac_string .= $iupac_hash{uc$lookup_key}; } } return $iupac_string; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Coil.pm�������������������������������������������������������������������000555��000765��000024�� 14347�12254227316� 16531� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parser module for Coil Bio::Tools::Coil # # Based on the EnsEMBL module Bio::EnsEMBL::Pipeline::Runnable::Protein::Coil # originally written by Marc Sohrmann (ms2@sanger.ac.uk) # Written in BioPipe by Balamurugan Kumarasamy <savikalpa@fugu-sg.org> # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by the Fugu Informatics team (fuguteam@fugu-sg.org) # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Tools::Coil - parser for Coil output =head1 SYNOPSIS use Bio::Tools::Coil my $parser = Bio::Tools::Coil->new(); while( my $sp_feat = $parser->next_result($file) ) { #do something #eg push @sp_feat, $sp_feat; } =head1 DESCRIPTION Parser for Coil output =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Based on the EnsEMBL module Bio::EnsEMBL::Pipeline::Runnable::Protein::Coil originally written by Marc Sohrmann (ms2@sanger.ac.uk) Written in BioPipe by Balamurugan Kumarasamy <savikalpa@fugu-sg.org> # Please direct questions and support issues to <bioperl-l@bioperl.org> # Cared for by the Fugu Informatics team (fuguteam@fugu-sg.org) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Coil; use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 parse_results Title : parse_results Usage : obj->parse_results Function: Parses the coil output. Automatically called by next_result() if not yet done. Example : Returns : =cut sub parse_results { my ($self,$resfile) = @_; my $filehandle = $resfile; my %result_hash =_read_fasta($filehandle);#bala no file handle my @ids = keys %result_hash; my @feats; foreach my $id (keys %result_hash){ my $pep = reverse ($result_hash{$id}); my $count = my $switch = 0; my ($start, $end); while (my $aa = chop $pep) { $count++; if (!$switch && $aa eq "x") { $start = $count; $switch = 1; } elsif ($switch && $aa ne "x") { $end = $count-1; my (%feature); $feature{name} = $id; $feature{start} = $start; $feature{end} = $end; $feature{source} = "Coils"; $feature{primary} = 'ncoils'; ($feature{program}) = 'ncoils'; $feature{logic_name} = 'Coils'; my $new_feat = $self->create_feature (\%feature); $self->_add_prediction($new_feat); $switch = 0; } } } $self->_predictions_parsed(1); } =head2 next_result Title : next_result Usage : while($feat = $coil->next_result($file)) { # do something } Function: Returns the next protein feature of the coil output file Returns : Args : =cut sub next_result { my ($self,$resfile) = @_; my $gene; $self->parse_results($resfile) unless $self->_predictions_parsed(); $gene = $self->_result(); return $gene; } =head2 _result Title : _result Usage : $feat = $obj->_result() Function: internal Example : Returns : =cut sub _result { my ($self) = @_; return unless(exists($self->{'_feats'}) && @{$self->{'_feats'}}); return shift(@{$self->{'_feats'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($feat) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_feats'})) { $self->{'_feats'} = []; } push(@{$self->{'_feats'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } =head2 create_feature Title : create_feature Usage : obj->create_feature(\%feature) Function: Internal(not to be used directly) Returns : Args : =cut sub create_feature { my ($self, $feat) = @_; # create feature object my $feature = Bio::SeqFeature::Generic->new (-seq_id => $feat->{name}, -start => $feat->{start}, -end => $feat->{end}, -score => $feat->{score}, -source => $feat->{source}, -primary => $feat->{primary}, -logic_name => $feat->{logic_name}, ); $feature->add_tag_value('evalue',0); $feature->add_tag_value('percent_id','NULL'); $feature->add_tag_value("hid",$feat->{primary}); return $feature; } =head2 _read_fasta Title : _read_fasta Usage : obj->_read_fasta($file) Function: Internal(not to be used directly) Returns : Args : =cut sub _read_fasta { local (*FILE) = @_; my( $id , $seq , %name2seq);#bala while (<FILE>) { chomp; #bala if (/^>(\S+)/) { my $new_id = $1; if ($id) { $name2seq{$id} = $seq; } $id = $new_id ; $seq = "" ; } elsif (eof) { if ($id) { $seq .= $_ ;#bala line instead of $_ $name2seq{$id} = $seq; } } else { $seq .= $_; } } return %name2seq; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/dpAlign.pm����������������������������������������������������������������000444��000765��000024�� 56640�12254227327� 17222� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # BioPerl module for Bio::Tools::dpAlign # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Yee Man Chan <ymc@yahoo.com> # # Copyright Yee Man Chan # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::dpAlign - Perl extension to do pairwise dynamic programming sequence alignment =head1 SYNOPSIS use Bio::Tools::dpAlign; use Bio::SeqIO; use Bio::SimpleAlign; use Bio::AlignIO; use Bio::Matrix::IO; $seq1 = Bio::SeqIO->new(-file => $ARGV[0], -format => 'fasta'); $seq2 = Bio::SeqIO->new(-file => $ARGV[1], -format => 'fasta'); # create a dpAlign object # to do global alignment, specify DPALIGN_GLOBAL_MILLER_MYERS # to do ends-free alignment, specify DPALIGN_ENDSFREE_MILLER_MYERS $factory = new dpAlign(-match => 3, -mismatch => -1, -gap => 3, -ext => 1, -alg => Bio::Tools::dpAlign::DPALIGN_LOCAL_MILLER_MYERS); # actually do the alignment $out = $factory->pairwise_alignment($seq1->next_seq, $seq2->next_seq); $alnout = Bio::AlignIO->new(-format => 'pfam', -fh => \*STDOUT); $alnout->write_aln($out); # To do protein alignment, set the sequence type to protein # By default all protein alignments are using BLOSUM62 matrix # the gap opening cost is 7 and gap extension is 1. These # values are from ssearch. To use your own custom substitution # matrix, you can create a Bio::Matrix::MatrixI object. $parser = Bio::Matrix::IO->new(-format => 'scoring', -file => 'blosum50.mat'); $matrix = $parser->next_matrix; $factory = Bio::Tools::dpAlign->new(-matrix => $matrix, -alg => Bio::Tools::dpAlign::DPALIGN_LOCAL_MILLERMYERS); $seq1->alphabet('protein'); $seq2->alphabet('protein'); $out = $factory->pairwise_alignment($seq1->next_seq, $seq2->next_seq); $alnout->write_aln($out); # use the factory to make some output $factory->align_and_show($seq1, $seq2, STDOUT); # use Phil Green's algorithm to calculate the optimal local # alignment score between two sequences quickly. It is very # useful when you are searching a query sequence in a database # of sequences. Since finding a alignment is more costly # than just calculating scores, you can save time if you only # align sequences that have a high alignment score. # To use this feature, first you call the sequence_profile function # to obtain the profile of the query sequence. $profile = $factory->sequence_profile($query); %scores = (); # Then use a loop to run a database of sequences against the # profile to obtain a table of alignment scores $dbseq = Bio::SeqIO(-file => 'dbseq.fa', -format => 'fasta'); while (defined($seq = $dbseq->next_seq)) { $scores{$seq->id} = $factory->pairwise_alignment_score($profile, $seq); } =head1 DESCRIPTION Dynamic Programming approach is considered to be the most sensitive way to align two biological sequences. There are currently three major types of dynamic programming algorithms: Global Alignment, Local Alignment and Ends-free Alignment. Global Alignment compares two sequences in their entirety. By inserting gaps in the two sequences, it aligns two sequences to minimize the edit distance as defined by the gap cost function and the substitution matrix. Global Alignment is generally applied to two sequences that are very similar in length and content. Local Alignment instead attempts to find out the subsequences that has the minimal edit distance among all possible subsequences. It is good for sequences that has a stretch of subsequences that are similar to each other. Ends-free Alignment is a special case of Global Alignment. There are no gap penalty imposed for the gaps that extended from the end points of two sequences. Therefore it will be a good application when you think one sequence is contained by the other or when you think two sequences overlap each other. Dynamic Programming was first introduced by Needleman-Wunsch (1970) to globally align two sequences. The idea of local alignment was later introduced by Smith-Waterman (1981). Gotoh (1982) improved both algorithms by introducing auxillary arrays that reduced the time complexity of the algorithms to O(m*n). Miller-Myers (1988) exploits the divide-and-conquer idea introduced by Hirschberg (1975) to solve the affine gap cost dynamic programming using only linear space. At the time of this writing, it is accepted that Miller-Myers is the fastest single CPU implementation and using the least memory that is truly equivalent to original algorithm introduced by Needleman-Wunsch. According to Aaron Mackey, Phil Green's SWAT implementation introduced a heuristic that does not consider paths through the matrix where the score would be less than the gap opening penalty, yielding a 1.5-2X speedup on most comparisons. to skip the calculation of some cells. However, his approach is only good for calculating the minimum edit distance and find out the corresponding subsequences (aka search phase). Bill Pearson's popular dynamic programming alignment program SSEARCH uses Phil Green's algorithm to find the subsequences and then Miller-Myers's algorithm to find the actual alignment. (aka alignment phase) The current implementation supports local alignment of either DNA sequences or protein sequences. It allows you to specify either the Miller-Myers Global Alignment (DPALIGN_GLOBAL_MILLER_MYERS) or Miller-Myers Local Alignment (DPALIGN_LOCAL_MILLER_MYERS). For DNA alignment, you can specify the scores for match, mismatch, gap opening cost and gap extension cost. For protein alignment, it is using BLOSUM62 by default. Currently the substitution matrix is not configurable. Note: If you supply LocatableSeq objects to pairwise_alignment, pairwise_alignment_score, align_and_show or sequence_profile and the sequence supplied contains gaps, these functions will treat these sequences as if they are without gaps. =head1 DEPENDENCIES This package comes with the main bioperl distribution. You also need to install the lastest bioperl-ext package which contains the XS code that implements the algorithms. This package won't work if you haven't compiled the bioperl-ext package. =head1 TO-DO =over 3 =item 1. Basic support for IUPAC code for DNA sequence is now implemented. X will mismatch any character. T will match U. For others, whenever there is a possibility for match, it is considered a full match, for example, W will match B. =item 2. Allow custom substitution matrix for DNA. Note that for proteins, you can now use your own subsitution matirx. =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR This implementation was written by Yee Man Chan (ymc@yahoo.com). Copyright (c) 2003 Yee Man Chan. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Special thanks to Aaron Mackey and WIlliam Pearson for the helpful discussions. [The portion of code inside pgreen subdirectory was borrowed from ssearch. It should be distributed in the same terms as ssearch.] =cut package Bio::Tools::dpAlign; use Bio::SimpleAlign; use base qw(Bio::Tools::AlignFactory); # Gotoh algorithm as defined in J. Mol. Biol. (1982) 162, 705-708 # use constant DSW_GOTOH => 1; # Hirschberg's algorithm as defined in Myers & Miller in # CABIOS, Vol 4, No. 1, 1988, p 11-17 # This algorithm is used in both the search phase and the # alignment phase. use constant DPALIGN_LOCAL_MILLER_MYERS => 1; use constant DPALIGN_GLOBAL_MILLER_MYERS => 2; use constant DPALIGN_ENDSFREE_MILLER_MYERS => 3; # my toy algorithm that tries to do SW as fast as possible # use constant DSW_FSW => 3; # Phil Green's approximation to Smith-Waterman. It avoid calculations # that might result in a score less than the opening gap penalty. # This is the algorithm used by ssearch. Phil Green's algorithm is # used in the search phase while Miller-Myers algorithm is used in # the alignment phase #use constant DPALIGN_LOCAL_GREEN => 2; BEGIN { eval { require Bio::Ext::Align; }; if ( $@ ) { die("\nThe C-compiled engine for Smith Waterman alignments (Align) has not been installed.\n Please read the install the bioperl-ext package\n\n"); exit(1); } } sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($match, $mismatch, $gap, $ext, $alg, $matrix) = $self->_rearrange([qw(MATCH MISMATCH GAP EXT ALG MATRIX )], @args); $self->match(3) unless defined $match; $self->mismatch(-1) unless defined $mismatch; $self->gap(3) unless defined $gap; $self->ext(1) unless defined $ext; $self->alg(DPALIGN_LOCAL_MILLER_MYERS) unless defined $alg; if (defined $match) { if ($match =~ /^\d+$/) { $self->match($match); } else { $self->throw("Match score must be a number, not [$match]"); } } if (defined $mismatch) { if ($match =~ /^\d+$/) { $self->mismatch($mismatch); } else { $self->throw("Mismatch penalty must be a number, not [$mismatch]"); } } if (defined $gap) { if ($gap =~ /^\d+$/) { $self->gap($gap); } else { $self->throw("Gap penalty must be a number, not [$gap]"); } } if (defined $ext) { if ($ext =~ /^\d+$/) { $self->ext($ext); } else { $self->throw("Extension penalty must be a number, not [$ext]"); } } if (defined $alg) { if ($alg == DPALIGN_LOCAL_MILLER_MYERS or $alg == DPALIGN_GLOBAL_MILLER_MYERS or $alg == DPALIGN_ENDSFREE_MILLER_MYERS) { $self->alg($alg); } else { $self->throw("Algorithm must be either 1, 2 or 3"); } } if (defined $matrix and $matrix->isa('Bio::Matrix::MatrixI')) { $self->{'matrix'} = Bio::Ext::Align::ScoringMatrix->new(join("", $matrix->row_names), $self->gap, $self->ext); foreach $rowname ($matrix->row_names) { foreach $colname ($matrix->column_names) { Bio::Ext::Align::ScoringMatrix->set_entry($self->{'matrix'}, $rowname, $colname, $matrix->entry($rowname, $colname)); } } } else { $self->{'matrix'} = 0; } return $self; } =head2 sequence_profile Title : sequence_profile Usage : $prof = $factory->sequence_profile($seq1) Function: Makes a dpAlign_SequenceProfile object from one sequence Returns : A dpAlign_SequenceProfile object Args : The lone argument is a Bio::PrimarySeqI that we want to build a profile for. Usually, this would be the Query sequence =cut sub sequence_profile { my ($self, $seq1) = @_; if( ! defined $seq1 || ! $seq1->isa('Bio::PrimarySeqI')) { $self->warn("Cannot call sequence_profilewithout specifing one sequence (Bio::PrimarySeqI object)"); return; } # fix Jitterbug #1044 if( $seq1->length() < 2) { $self->warn("cannot create sequence profile with length less than 2"); return; } if ($seq1->isa('Bio::LocatableSeq')) { my $seqstr = $seq1->seq; $seqstr =~ s/\-//g; $seq1 = Bio::Seq->new(-id => $seq1->id, -seq => $seqstr, -alphabet => $seq1->alphabet); } # create engine objects $seq1->display_id('seq1') unless ( defined $seq1->id() ); if ($seq1->alphabet eq 'dna') { return Bio::Ext::Align::SequenceProfile->dna_new($seq1->seq, $self->{'match'}, $self->{'mismatch'}, $self->{'gap'}, $self->{'ext'}); } elsif ($seq1->alphabet eq 'protein') { return Bio::Ext::Align::SequenceProfile->protein_new($seq1->seq, $self->{'matrix'}); } else { croak("There is currently no support for the types of sequences you want to align!\n"); return; } } =head2 pairwise_alignment_score Title : pairwise_alignment_score Usage : $score = $factory->pairwise_alignment_score($prof,$seq2) Function: Makes a SimpleAlign object from two sequences Returns : An integer that is the score of the optimal alignment. Args : The first argument is the sequence profile obtained from a call to the sequence_profile function. The second argument is a Bio::PrimarySeqI object to be aligned. The second argument is usually a sequence in the database sequence. Note that this function only uses Phil Green's algorithm and therefore theoretically may not always give you the optimal score. =cut sub pairwise_alignment_score { my ($self, $prof, $seq2) = @_; if( ! defined $prof || ! $prof->isa('Bio::Ext::Align::SequenceProfile') || ! defined $seq2 || ! $seq2->isa('Bio::PrimarySeqI') ) { $self->warn("Cannot call pairwise_alignment_score without specifing 2 sequences (Bio::PrimarySeqI objects)"); return; } # fix Jitterbug #1044 if( $seq2->length() < 2) { $self->warn("cannot align sequences with length less than 2"); return; } if ($seq2->isa('Bio::LocatableSeq')) { my $seqstr = $seq2->seq; $seqstr =~ s/\-//g; $seq2 = Bio::Seq->new(-id => $seq2->id, -seq => $seqstr, -alphabet => $seq2->alphabet); } $self->set_memory_and_report(); # create engine objects $seq2->display_id('seq2') unless ( defined $seq2->id() ); if ($prof->alphabet eq 'dna' and $seq2->alphabet eq 'dna') { return Bio::Ext::Align::Score_DNA_Sequences($prof, $seq2->seq); } elsif ($prof->alphabet eq 'protein' and $seq2->alphabet eq 'protein') { return Bio::Ext::Align::Score_Protein_Sequences($prof, $seq2->seq); } else { $self->throw("There is currently no support for the types of sequences you want to align!\n"); return; } } =head2 pairwise_alignment Title : pairwise_alignment Usage : $aln = $factory->pairwise_alignment($seq1,$seq2) Function: Makes a SimpleAlign object from two sequences Returns : A SimpleAlign object if there is an alignment with positive score. Otherwise, return undef. Args : The first and second arguments are both Bio::PrimarySeqI objects that are to be aligned. =cut sub pairwise_alignment { my ($self, $seq1, $seq2) = @_; my ($aln, $out); if( ! defined $seq1 || ! $seq1->isa('Bio::PrimarySeqI') || ! defined $seq2 || ! $seq2->isa('Bio::PrimarySeqI') ) { $self->warn("Cannot call pairwise_alignment without specifing 2 sequences (Bio::PrimarySeqI objects)"); return; } # fix Jitterbug #1044 if( $seq1->length() < 2 || $seq2->length() < 2 ) { $self->warn("cannot align sequences with length less than 2"); return; } if ($seq1->isa('Bio::LocatableSeq')) { my $seqstr = $seq1->seq; $seqstr =~ s/\-//g; $seq1 = Bio::Seq->new(-id => $seq1->id, -seq => $seqstr, -alphabet => $seq1->alphabet); } if ($seq2->isa('Bio::LocatableSeq')) { my $seqstr = $seq2->seq; $seqstr =~ s/\-//g; $seq2 = Bio::Seq->new(-id => $seq2->id, -seq => $seqstr, -alphabet => $seq2->alphabet); } $self->set_memory_and_report(); # create engine objects $seq1->display_id('seq1') unless ( defined $seq1->id() ); $seq2->display_id('seq2') unless ( defined $seq2->id() ); if ($seq1->alphabet eq 'dna' and $seq2->alphabet eq 'dna') { $aln = Bio::Ext::Align::Align_DNA_Sequences($seq1->seq, $seq2->seq, $self->{'match'}, $self->{'mismatch'}, $self->{'gap'}, $self->{'ext'}, $self->{'alg'}); } elsif ($seq1->alphabet eq 'protein' and $seq2->alphabet eq 'protein') { $aln = Bio::Ext::Align::Align_Protein_Sequences($seq1->seq, $seq2->seq, $self->{'matrix'}, $self->{'alg'}); } else { croak("There is currently no support for the types of sequences you want to align!\n"); return; } if (not defined $aln or $aln == 0) { return; } $out = Bio::SimpleAlign->new(); $out->add_seq(Bio::LocatableSeq->new(-seq => $aln->aln1, -start => $aln->start1, -end => $aln->end1, -id => $seq1->id)); $out->add_seq(Bio::LocatableSeq->new(-seq => $aln->aln2, -start => $aln->start2, -end => $aln->end2, -id => $seq2->id)); $out->score($aln->score); return $out; } =head2 align_and_show Title : align_and_show Usage : $factory->align_and_show($seq1,$seq2,STDOUT) =cut sub align_and_show { my ($self, $seq1, $seq2, $fh) = @_; my ($aln, $out); if (! defined $fh) { $fh = \*STDOUT; } if( ! defined $seq1 || ! $seq1->isa('Bio::PrimarySeqI') || ! defined $seq2 || ! $seq2->isa('Bio::PrimarySeqI') ) { $self->warn("Cannot call pairwise_alignment without specifing 2 sequences (Bio::PrimarySeqI objects)"); return; } # fix Jitterbug #1044 if( $seq1->length() < 2 || $seq2->length() < 2 ) { $self->warn("cannot align sequences with length less than 2"); return; } if ($seq1->isa('Bio::LocatableSeq')) { my $seqstr = $seq1->seq; $seqstr =~ s/\-//g; $seq1 = Bio::Seq->new(-id => $seq1->id, -seq => $seqstr, -alphabet => $seq1->alphabet); } if ($seq2->isa('Bio::LocatableSeq')) { my $seqstr = $seq2->seq; $seqstr =~ s/\-//g; $seq2 = Bio::Seq->new(-id => $seq2->id, -seq => $seqstr, -alphabet => $seq2->alphabet); } $self->set_memory_and_report(); # create engine objects $seq1->display_id('seq1') unless ( defined $seq1->id() ); $seq2->display_id('seq2') unless ( defined $seq2->id() ); if ($seq1->alphabet eq 'dna' and $seq2->alphabet eq 'dna') { $aln = Bio::Ext::Align::Align_DNA_Sequences($seq1->seq, $seq2->seq, $self->{'match'}, $self->{'mismatch'}, $self->{'gap'}, $self->{'ext'}, $self->{'alg'}); } elsif ($seq1->alphabet eq 'protein' and $seq2->alphabet eq 'protein') { $aln = Bio::Ext::Align::Align_Protein_Sequences($seq1->seq, $seq2->seq, $self->{'matrix'}, $self->{'alg'}); } else { croak("There is currently no support for the types of sequences you want to align!\n"); } $out = Bio::Ext::Align::AlnBlock->new(); my $s1 = Bio::Ext::Align::AlnSequence->new(); my $s2 = Bio::Ext::Align::AlnSequence->new(); my $a1 = $aln->aln1; my $a2 = $aln->aln2; my $first_col = undef; my $last_col = undef; my $col; my $alu1; my $alu2; my $g1 = 0; my $g2 = 0; # construct AlnBlock for (my $i = 0; $i < length($a1); ++$i) { $col = Bio::Ext::Align::AlnColumn->new(); $alu1 = Bio::Ext::Align::AlnUnit->new(); $alu2 = Bio::Ext::Align::AlnUnit->new(); $first_col = $col unless defined $first_col; Bio::Ext::Align::AlnColumn::set_next($last_col, $col) if defined $last_col; if (substr($a1, $i, 1) eq "-") { Bio::Ext::Align::AlnUnit::set_text_label($alu1, "INSERT"); Bio::Ext::Align::AlnUnit::set_text_label($alu2, "SEQUENCE"); ++$g1; } elsif (substr($a2, $i, 1) eq "-") { Bio::Ext::Align::AlnUnit::set_text_label($alu1, "SEQUENCE"); Bio::Ext::Align::AlnUnit::set_text_label($alu2, "INSERT"); ++$g2; } else { Bio::Ext::Align::AlnUnit::set_text_label($alu1, "SEQUENCE"); Bio::Ext::Align::AlnUnit::set_text_label($alu2, "SEQUENCE"); } Bio::Ext::Align::AlnUnit::set_start($alu1, $aln->start1+$i-$g1-2); Bio::Ext::Align::AlnUnit::set_end($alu1, $aln->start1+$i-$g1-2); Bio::Ext::Align::AlnUnit::set_start($alu2, $aln->start2+$i-$g2-2); Bio::Ext::Align::AlnUnit::set_end($alu2, $aln->start2+$i-$g2-2); Bio::Ext::Align::AlnColumn::add_alu($col, $alu1); Bio::Ext::Align::AlnColumn::add_alu($col, $alu2); $last_col = $col; } Bio::Ext::Align::AlnBlock::set_start($out, $first_col); $col = Bio::Ext::Align::AlnColumn->new(); $alu1 = Bio::Ext::Align::AlnUnit->new(); $alu2 = Bio::Ext::Align::AlnUnit->new(); Bio::Ext::Align::AlnUnit::set_start($alu1, $aln->end1); Bio::Ext::Align::AlnUnit::set_end($alu1, $aln->end1); Bio::Ext::Align::AlnUnit::set_text_label($alu1, "END"); Bio::Ext::Align::AlnUnit::set_start($alu2, $aln->end2); Bio::Ext::Align::AlnUnit::set_end($alu2, $aln->end2); Bio::Ext::Align::AlnUnit::set_text_label($alu2, "END"); Bio::Ext::Align::AlnColumn::add_alu($col, $alu1); Bio::Ext::Align::AlnColumn::add_alu($col, $alu2); Bio::Ext::Align::AlnColumn::set_next($last_col, $col); &Bio::Ext::Align::write_pretty_str_align($out,$seq1->id,$seq1->seq,$seq2->id,$seq2->seq,12,50,$fh); } =head2 match Title : match Usage : $match = $factory->match() #get : $factory->match($value) #set Function : the set get for the match score Example : Returns : match value Arguments : new value =cut sub match { my ($self,$val) = @_; if( defined $val ) { if( $val < 0 ) { # Fixed so that match==0 is allowed /AE $self->throw("Can't have a match score less than 0"); } $self->{'match'} = $val; } return $self->{'match'}; } =head2 mismatch Title : mismatch Usage : $mismatch = $factory->mismatch() #get : $factory->mismatch($value) #set Function : the set get for the mismatch penalty Example : Returns : mismatch value Arguments : new value =cut sub mismatch { my ($self,$val) = @_; if( defined $val ) { if( $val > 0 ) { # Fixed so that mismatch==0 is allowed /AE $self->throw("Can't have a mismatch penalty greater than 0"); } $self->{'mismatch'} = $val; } return $self->{'mismatch'}; } =head2 gap Title : gap Usage : $gap = $factory->gap() #get : $factory->gap($value) #set Function : the set get for the gap penalty Example : Returns : gap value Arguments : new value =cut sub gap { my ($self,$val) = @_; if( defined $val ) { if( $val < 0 ) { # Fixed so that gap==0 is allowed /AE $self->throw("Can't have a gap penalty less than 0"); } $self->{'gap'} = $val; } return $self->{'gap'}; } =head2 ext Title : ext Usage : $ext = $factory->ext() #get : $factory->ext($value) #set Function : the set get for the ext penalty Example : Returns : ext value Arguments : new value =cut sub ext { my ($self,$val) = @_; if( defined $val ) { if( $val < 0 ) { # Fixed so that ext==0 is allowed /AE $self->throw("Can't have a extension penalty less than 0"); } $self->{'ext'} = $val; } return $self->{'ext'}; } =head2 alg Title : alg Usage : $alg = $factory->alg() #get : $factory->alg($value) #set Function : the set get for the algorithm Example : Returns : alg value Arguments : new value =cut sub alg { my ($self,$val) = @_; if( defined $val ) { if( $val != DPALIGN_LOCAL_MILLER_MYERS and $val != DPALIGN_GLOBAL_MILLER_MYERS and $val != DPALIGN_ENDSFREE_MILLER_MYERS) { $self->throw("Can't have an algorithm that is not 1, 2 or 3"); } $self->{'alg'} = $val; } return $self->{'alg'}; } 1; ������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/ECnumber.pm���������������������������������������������������������������000444��000765��000024�� 33757�12254227324� 17345� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::ECnumber # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Christian M. Zmasek <czmasek-at-burnham.org> or <cmzmasek@yahoo.com> # # (c) Christian M. Zmasek, czmasek-at-burnham.org, 2002. # (c) GNF, Genomics Institute of the Novartis Research Foundation, 2002. # # You may distribute this module under the same terms as perl itself. # Refer to the Perl Artistic License (see the license accompanying this # software package, or see http://www.perl.com/language/misc/Artistic.html) # for the terms under which you may use, modify, and redistribute this module. # # THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED # WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF # MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. # # POD documentation - main docs before the code =head1 NAME Bio::Tools::ECnumber - representation of EC numbers (Enzyme Classification) =head1 SYNOPSIS use Bio::Tools::ECnumber; # Creation of ECnumber objects my $EC1 = Bio::Tools::ECnumber->new( -ec_string => "4.3.2.1" ); my $EC2 = Bio::Tools::ECnumber->new( -ec_string => "EC 1.1.1.1" ); my $EC3 = Bio::Tools::ECnumber->new(); # Copying my $EC4 = $EC1->copy(); # Modification/canonicalization of ECnumber objects print $EC3->EC_string( "1.01.01.001" ); # Prints "1.1.1.1". # Stringify print $EC3->EC_string(); # or print $EC3->to_string(); # Test for equality # -- Against ECnumber object: if ( $EC3->is_equal( $EC2 ) ) { # Prints "equal". print "equal"; } # -- Against string representation of EC number: if ( ! $EC3->is_equal( "1.1.1.-" ) ) { # Prints "not equal". print "not equal"; } # Test for membership my $EC5 = Bio::Tools::ECnumber->new( -ec_string => "4.3.2.-" ); # -- Against ECnumber object. if ( $EC1->is_member( $EC5 ) ) { # Prints "member". print "member"; } # -- Against string representation of EC number. if ( ! $EC1->is_member( "4.3.1.-" ) ) { # Prints "not member". print "not member"; } =head1 DESCRIPTION L<Bio::Tools::ECnumber> is a representation of EC numbers, the numerical heirarchy for Enzyme Classification. See L<http://www.chem.qmul.ac.uk/iubmb/enzyme/> for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Christian M. Zmasek Email: czmasek-at-burnham.org or cmzmasek@yahoo.com WWW: http://monochrome-effect.net/ Address: Genomics Institute of the Novartis Research Foundation 10675 John Jay Hopkins Drive San Diego, CA 92121 =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::ECnumber; use strict; use constant DEFAULT => "-"; use constant TRUE => 1; use constant FALSE => 0; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $EC1 = Bio::Tools::ECnumber->new( -ec_string => "4.3.2.1" ); or $EC2 = Bio::Tools::ECnumber->new( -ec_string => "4.3.2.2", -comment => "Is EC 4.3.2.2" ); or $EC3 = Bio::Tools::ECnumber->new(); # EC3 is now "-.-.-.-" Function: Creates a new ECnumber object. Parses a EC number from "x.x.x.x", "EC x.x.x.x", "ECx.x.x.x", or "EC:x.x.x.x"; x being either a positive integer or a "-". Returns : A new ECnumber object. Args : A string representing a EC number, e.g. "4.3.2.1" or "EC 4.3.2.1" or "1.-.-.-". =cut sub new { my( $class, @args ) = @_; my $self = $class->SUPER::new( @args ); my ( $EC_string, $comment ) = $self->_rearrange( [ qw( EC_STRING COMMENT ) ], @args ); $self->init(); $EC_string && $self->EC_string( $EC_string ); $comment && $self->comment( $comment ); return $self; } # new =head2 init Title : init() Usage : $EC1->init(); # EC1 is now "-.-.-.-" Function: Initializes this ECnumber to default values. Returns : Args : =cut sub init { my( $self ) = @_; $self->enzyme_class( DEFAULT ); $self->sub_class( DEFAULT ); $self->sub_sub_class( DEFAULT ); $self->serial_number( DEFAULT ); $self->comment( "" ); } # init =head2 copy Title : copy() Usage : $EC2 = $EC1->copy(); Function: Creates a new ECnumber object which is an exact copy of this ECnumber. Returns : A copy of this ECnumber. Args : =cut sub copy { my( $self ) = @_; my $new_ec = $self->new(); $new_ec->enzyme_class( $self->enzyme_class() ); $new_ec->sub_class( $self->sub_class() ); $new_ec->sub_sub_class( $self->sub_sub_class() ); $new_ec->serial_number( $self->serial_number() ); $new_ec->comment( $self->comment() ); return $new_ec; } # copy =head2 EC_string Title : EC_string Usage : $EC3->EC_string( "1.1.1.-" ); or print $EC3->EC_string(); Function: Set/get for string representations of EC numbers. Parses a EC number from "x.x.x.x", "EC x.x.x.x", "ECx.x.x.x", or "EC:x.x.x.x"; x being either a positive integer or a "-". Returns : A string representations of a EC number. Args : A string representations of a EC number. =cut sub EC_string { my ( $self, $value ) = @_; if ( defined $value) { $value =~ s/\s+//g; # Removes white space. $value =~ s/^EC//i; # Removes "EC". $value =~ s/^://; # Removes ":". if ( $value =~ /^([\d-]*)\.([\d-]*)\.([\d-]*)\.([\d-]*)$/ ) { $self->enzyme_class( $1 ); $self->sub_class( $2 ); $self->sub_sub_class( $3 ); $self->serial_number( $4 ); } else { $self->throw( "Illegal format error [$value]" ); } } return $self->to_string(); } # EC_string =head2 to_string Title : to_string() Usage : print $EC3->to_string(); Function: To string method for EC numbers (equals the "get" functionality of "EC_string"). Returns : A string representations of a EC number. Args : =cut sub to_string { my ( $self ) = @_; my $s = $self->enzyme_class() . "."; $s .= $self->sub_class() . "."; $s .= $self->sub_sub_class() . "."; $s .= $self->serial_number(); return $s; } # to_string =head2 is_equal Title : is_equal Usage : if ( $EC3->is_equal( $EC2 ) ) or if ( $EC3->is_equal( "1.1.1.-" ) ) Function: Checks whether this ECnumber is equal to the argument EC number (please note: "1.1.1.1" != "1.1.1.-"). Returns : True (1) or false (0). Args : A ECnumber object or a string representation of a EC number. =cut sub is_equal { my ( $self, $value ) = @_; if ( $self->_is_not_reference( $value ) ) { $value = $self->new( -ec_string => $value ); } else { $self->_is_ECnumber_object( $value ); } unless ( $self->enzyme_class() eq $value->enzyme_class() ) { return FALSE; } unless ( $self->sub_class() eq $value->sub_class() ) { return FALSE; } unless ( $self->sub_sub_class() eq $value->sub_sub_class() ) { return FALSE; } unless ( $self->serial_number() eq $value->serial_number() ) { return FALSE; } return TRUE; } # is_equal =head2 is_member Title : is_member Usage : if ( $EC1->is_member( $EC5 ) ) or if ( $EC1->is_member( "4.3.-.-" ) ) Function: Checks whether this ECnumber is a member of the (incomplete) argument EC number (e.g. "1.1.1.1" is a member of "1.1.1.-" but not of "1.1.1.2"). Returns : True (1) or false (0). Args : A ECnumber object or a string representation of a EC number. =cut sub is_member { my ( $self, $value ) = @_; if ( $self->_is_not_reference( $value ) ) { $value = $self->new( -ec_string => $value ); } else { $self->_is_ECnumber_object( $value ); } $self->_check_for_illegal_defaults(); $value->_check_for_illegal_defaults(); unless ( $value->enzyme_class() eq DEFAULT || $self->enzyme_class() eq $value->enzyme_class() ) { return FALSE; } unless ( $value->sub_class() eq DEFAULT || $self->sub_class() eq $value->sub_class() ) { return FALSE; } unless ( $value->sub_sub_class() eq DEFAULT || $self->sub_sub_class() eq $value->sub_sub_class() ) { return FALSE; } unless ( $value->serial_number() eq DEFAULT || $self->serial_number() eq $value->serial_number() ) { return FALSE; } return TRUE; } # is_member =head2 enzyme_class Title : enzyme_class Usage : $EC1->enzyme_class( 1 ); or print $EC1->enzyme_class(); Function: Set/get for the enzyme class number of ECnumbers. Returns : The enzyme class number of this ECnumber. Args : A positive integer or "-". =cut sub enzyme_class { my ( $self, $value ) = @_; if ( defined $value) { $self->{ "_enzyme_class" } = $self->_check_number( $value ); } return $self->{ "_enzyme_class" }; } # enzyme_class =head2 sub_class Title : sub_class Usage : $EC1->sub_class( 4 ); or print $EC1->sub_class(); Function: Set/get for the enzyme sub class number of ECnumbers. Returns : The enzyme sub class number of this ECnumber. Args : A positive integer or "-". =cut sub sub_class { my ( $self, $value ) = @_; if ( defined $value) { $self->{ "_sub_class" } = $self->_check_number( $value ); } return $self->{ "_sub_class" }; } # sub_class =head2 sub_sub_class Title : sub_sub_class Usage : $EC1->sub_sub_class( 12 ); or print $EC1->sub_sub_class(); Function: Set/get for the enzyme sub sub class number of ECnumbers. Returns : The enzyme sub sub class number of this ECnumber. Args : A positive integer or "-". =cut sub sub_sub_class { my ( $self, $value ) = @_; if ( defined $value) { $self->{ "_sub_sub_class" } = $self->_check_number( $value ); } return $self->{ "_sub_sub_class" }; } # sub_sub_class =head2 serial_number Title : serial_number Usage : $EC1->serial_number( 482 ); or print $EC1->serial_number(); Function: Set/get for the serial number of ECnumbers. Returns : The serial number of this ECnumber. Args : A positive integer or "-". =cut sub serial_number { my ( $self, $value ) = @_; if ( defined $value) { $self->{ "_serial_number" } = $self->_check_number( $value ); } return $self->{ "_serial_number" }; } # serial_number =head2 comment Title : comment Usage : $EC1->comment( "deprecated" ); or print $EC1->comment(); Function: Set/get for a arbitrary comment. Returns : A comment [scalar]. Args : A comment [scalar]. =cut sub comment { my ( $self, $value ) = @_; if ( defined $value) { $self->{ "_comment" } = $value; } return $self->{ "_comment" }; } # comment # Title : _check_number # Function: Checks and standardizes the individual numbers of a EC number # (removes leading zeros, removes white spaces). # Returns : A standardized number. # Args : A string representing a number in a EC number. sub _check_number { my ( $self, $value ) = @_; my $original_value = $value; $value =~ s/\s+//g; # Removes white space. if ( $value eq "" ) { $value = DEFAULT; } $value =~ s/^0+//; # Removes leading zeros. if ( $value eq "" ) { # If it was "0" (or "00"), it would be "" now. $value = "0"; } elsif ( $value ne DEFAULT && $value =~ /\D/ ) { $self->throw( "Illegal format error [$original_value]" ); } return $value; } # _check_number # Title : _check_for_illegal_defaults() # Function: Checks for situations like "1.-.1.1", which # are illegal in membership tests. # Returns : # Args : sub _check_for_illegal_defaults { my ( $self ) = @_; if ( ( $self->sub_sub_class() eq DEFAULT && $self->serial_number() ne DEFAULT ) || ( $self->sub_class() eq DEFAULT && $self->sub_sub_class() ne DEFAULT ) || ( $self->enzyme_class() eq DEFAULT && $self->sub_class() ne DEFAULT ) ) { $self->throw( "Illegal format error for comparison [" . $self->to_string() . "]" ); } } # _check_for_illegal_defaults # Title : _is_not_reference # Function: Checks whether the argument is not a reference. # Returns : True or false. # Args : A scalar. sub _is_not_reference { my ( $self, $value ) = @_; return ( ! ref( $value ) ); } # _is_not_reference # Title : _is_ECnumber_object # Function: Checks whether the arument is a ECnumber. # Returns : # Args : A reference. sub _is_ECnumber_object { my ( $self, $value ) = @_; unless( $value->isa( "Bio::Tools::ECnumber" ) ) { $self->throw( "Found [". ref( $value ) ."] where [Bio::Tools::ECnumber] expected" ); } } # _is_ECnumber_object 1; �����������������BioPerl-1.6.923/Bio/Tools/EPCR.pm�������������������������������������������������������������������000444��000765��000024�� 14373�12254227312� 16364� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::EPCR # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::EPCR - Parse ePCR output and make features =head1 SYNOPSIS # A simple annotation pipeline wrapper for ePCR data # assuming ePCR data is already generated in file seq1.epcr # and sequence data is in fasta format in file called seq1.fa use Bio::Tools::EPCR; use Bio::SeqIO; my $parser = Bio::Tools::EPCR->new(-file => 'seq1.epcr'); my $seqio = Bio::SeqIO->new(-format => 'fasta', -file => 'seq1.fa'); my $seq = $seqio->next_seq || die("cannot get a seq object from SeqIO"); while( my $feat = $parser->next_feature ) { # add EPCR annotation to a sequence $seq->add_SeqFeature($feat); } my $seqout = Bio::SeqIO->new(-format => 'embl'); $seqout->write_seq($seq); =head1 DESCRIPTION This object serves as a parser for ePCR data, creating a Bio::SeqFeatureI for each ePCR hit. These can be processed or added as annotation to an existing Bio::SeqI object for the purposes of automated annotation. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::EPCR; use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::SeqAnalysisParserI Bio::Root::IO); =head2 new Title : new Usage : my $epcr = Bio::Tools::EPCR->new(-file => $file, -primary => $fprimary, -source => $fsource, -groupclass => $fgroupclass); Function: Initializes a new EPCR parser Returns : Bio::Tools::EPCR Args : -fh => filehandle OR -file => filename -primary => a string to be used as the common value for each features '-primary' tag. Defaults to 'sts'. (This in turn maps to the GFF 'type' tag (aka 'method')). -source => a string to be used as the common value for each features '-source' tag. Defaults to 'e-PCR'. (This in turn maps to the GFF 'source' tag) -groupclass => a string to be used as the name of the tag which will hold the sts marker namefirst attribute. Defaults to 'name'. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($primary, $source, $groupclass) = $self->_rearrange([qw(PRIMARY SOURCE GROUPCLASS)],@args); $self->primary(defined $primary ? $primary : 'sts'); $self->source(defined $source ? $source : 'e-PCR'); $self->groupclass(defined $groupclass ? $groupclass : 'name'); $self->_initialize_io(@args); return $self; } =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut sub next_feature { my ($self) = @_; my $line = $self->_readline; return unless defined($line); chomp($line); my($seqname,$location,$mkrname, $rest) = split(/\s+/,$line,4); my ($start,$end) = ($location =~ /(\S+)\.\.(\S+)/); # `e-PCR -direct` results code match strand in $rest as (+) and (-). Decode it if present. my $strandsign; if ($rest =~ m/^\(([+-])\)(.*)$/) { ($strandsign,$rest) = ($1, $2); } else { $strandsign = "?"; } my $strand = $strandsign eq "+" ? 1 : $strandsign eq "-" ? -1 : 0; my $markerfeature = Bio::SeqFeature::Generic->new ( '-start' => $start, '-end' => $end, '-strand' => $strand, '-source' => $self->source, '-primary' => $self->primary, '-seq_id' => $seqname, '-tag' => { $self->groupclass => $mkrname, ($rest ? ('Note' => $rest ) : ()), }); #$markerfeature->add_tag_value('Note', $rest) if defined $rest; return $markerfeature; } =head2 source Title : source Usage : $obj->source($newval) Function: Example : Returns : value of source (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source{ my $self = shift; return $self->{'_source'} = shift if @_; return $self->{'_source'}; } =head2 primary Title : primary Usage : $obj->primary($newval) Function: Example : Returns : value of primary (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub primary{ my $self = shift; return $self->{'_primary'} = shift if @_; return $self->{'_primary'}; } =head2 groupclass Title : groupclass Usage : $obj->groupclass($newval) Function: Example : Returns : value of groupclass (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub groupclass{ my $self = shift; return $self->{'_groupclass'} = shift if @_; return $self->{'_groupclass'}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Eponine.pm����������������������������������������������������������������000444��000765��000024�� 17133�12254227322� 17226� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Eponine # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Tania Oh <gisoht@nus.edu.sg> # # Copyright Tania Oh # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Eponine - Results of one Eponine run =head1 SYNOPSIS use Bio::Tools::Eponine; use strict; my $seq = "/data/seq.fa"; my $threshold = "0.999"; my @params = ( -seq => $seq, -threshold => $threshold); my $factory = Bio::Tools::Run::Eponine->new(@params); # run eponine against fasta my $r = $factory->run_eponine($seq); my $parser = Bio::Tools::Eponine->new($r); while (my $feat = $parser->next_prediction){ #$feat contains array of SeqFeature foreach my $orf($feat) { print $orf->seq_id. "\n"; } } =head1 DESCRIPTION Parser for Eponine, a probabilistic transcription start site detector optimized for mammalian genomic sequence. This module inherits off Bio::Tools::AnalysisResult and therefore implements Bio::SeqAnalysisParserI (see L<Bio::Tools::AnalysisResult> and L<Bio::SeqAnalysisParserI>). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Tania Oh E<lt>gisoht-at-nus.edu.sgE<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Eponine; use strict; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my($self,@args) = @_; # first call the inherited method! my $make = $self->SUPER::_initialize_state(@args); # handle our own parameters # our private state variables $self->{'_preds_parsed'} = 0; #array of Bio::SeqFeatures $self->{'_flist'} =[]; } =head2 analysis_method Usage : $mzef->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /mzef/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /epo/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $mzef->next_feature()) { # do something } Function: Returns the next gene structure prediction of the MZEF result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Note that with the present version of MZEF there will only be one object returned, because MZEF does not predict individual genes but just potential internal exons. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $mzef->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the MZEF result file. Call this method repeatedly until FALSE is returned. Note that with the present version of MZEF there will only be one object returned, because MZEF does not predict individual genes but just potential internal exons. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my $gene; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions() unless $self->_predictions_parsed(); # return the next gene structure (transcript) return $self->_prediction(); } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; while(defined($_ = $self->_readline())) { if (! /^\#/){ #ignore introductory lines my @element = split; my (%feature); $feature {name} = $element[0]; $feature {score} = $element[5]; $feature {start} = $element[3]; $feature {end} = $element[4]; $feature {strand} = $element[6]; $feature {source}= 'Eponine'; $feature {primary}= 'TSS'; $feature {program} = 'eponine-scan'; $feature {program_version} = '2'; $self->create_feature(\%feature); next; } } $self->_predictions_parsed(1); } =head2 create_feature Title : create_feature Usage : obj->create_feature($feature) Function: Returns an array of features Returns : Returns an array of features Args : none =cut sub create_feature { my ($self, $feat) = @_; #create and fill Bio::EnsEMBL::Seqfeature object my $tss = Bio::SeqFeature::Generic->new ( -seq_id => $feat->{'name'}, -start => $feat->{'start'}, -end => $feat->{'end'}, -strand => $feat->{'strand'}, -score => $feat->{'score'}, -source_tag => $feat->{'source'}, -primary_tag => $feat->{'primary'}); if ($tss) { # add to _flist push(@{$self->{'_flist'}}, $tss); } #print $tss->gff_string; } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_flist'}) && @{$self->{'_flist'}}); return shift(@{$self->{'_flist'}}); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; # array of pre-parsed predictions if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/ERPIN.pm������������������������������������������������������������������000444��000765��000024�� 30113�12254227314� 16500� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::ERPIN # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Fields <cjfields-at-uiuc-dot-edu> # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::ERPIN - a parser for ERPIN output =head1 SYNOPSIS use Bio::Tools::ERPIN; my $parser = Bio::Tools::ERPIN->new( -file => $rna_output, -motiftag => 'protein_bind' -desctag => 'TRAP_binding'); #parse the results while( my $motif = $parser->next_prediction) { # do something here } =head1 DESCRIPTION Parses raw ERPIN output. This module is not currently complete. As is, it will parse raw ERPIN long format output and pack information into Bio::SeqFeature::Generic objects. Several values have also been added in the 'tag' hash. These can be accessed using the following syntax: my ($entry) = $feature->get_Annotations('SecStructure'); Added tags are : tset - training set used for the sequence tsetdesc - training set description line cutoff - cutoff value used database - name of database dbdesc - description of database dbratios - nucleotide ratios of database (used to calculate evalue) descline - entire description line (in case the regex used for sequence ID doesn't adequately catch the name accession - accession number of sequence (if present) logodds - logodds score value sequence - sequence from hit, separated based on training set See t/ERPIN.t for example usage. At some point a more complicated feature object may be used to support this data rather than forcing most of the information into tag/value pairs in a SeqFeature::Generic. This will hopefully allow for more flexible analysis of data (specifically RNA secondary structural data). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields-at-uiuc-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::ERPIN; use strict; use Bio::SeqFeature::Generic; use base qw(Bio::Tools::AnalysisResult); our($MotifTag,$SrcTag,$DescTag) = qw(misc_binding ERPIN erpin); =head2 new Title : new Usage : my $obj = Bio::Tools::ERPIN->new(); Function: Builds a new Bio::Tools::ERPIN object Returns : an instance of Bio::Tools::ERPIN Args : -fh/-file for input filename -motiftag => primary tag used in gene features (default 'misc_binding') -desctag => tag used for display_name name (default 'erpin') -srctag => source tag used in all features (default 'ERPIN') =cut sub _initialize { my($self,@args) = @_; $self->warn('Use of this module is deprecated. Use Bio::SearchIO::erpin instead'); $self->SUPER::_initialize(@args); my ($motiftag,$desctag,$srctag) = $self->SUPER::_rearrange([qw(MOTIFTAG DESCTAG SRCTAG )], @args); $self->motif_tag(defined $motiftag ? $motiftag : $MotifTag); $self->source_tag(defined $srctag ? $srctag : $SrcTag); $self->desc_tag(defined $desctag ? $desctag : $DescTag); foreach (qw(_tset _tset_desc _cutoff _db _db_desc _db_ratios _eval_cutoff _seqid _secacc _seqdesc )) { $self->{$_}=''; } } =head2 motif_tag Title : motiftag Usage : $obj->motiftag($newval) Function: Get/Set the value used for 'motif_tag', which is used for setting the primary_tag. Default is 'misc_binding' as set by the global $MotifTag. 'misc_binding' is used here because a conserved RNA motif is capable of binding proteins (regulatory proteins), antisense RNA (siRNA), small molecules (riboswitches), or nothing at all (tRNA, terminators, etc.). It is recommended that this be changed to other tags ('misc_RNA', 'protein_binding', 'tRNA', etc.) where appropriate. For more information, see: http://www.ncbi.nlm.nih.gov/collab/FT/index.html Returns : value of motif_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub motif_tag{ my $self = shift; return $self->{'motif_tag'} = shift if @_; return $self->{'motif_tag'}; } =head2 source_tag Title : source_tag Usage : $obj->source_tag($newval) Function: Get/Set the value used for the 'source_tag'. Default is 'ERPIN' as set by the global $SrcTag Returns : value of source_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source_tag{ my $self = shift; return $self->{'source_tag'} = shift if @_; return $self->{'source_tag'}; } =head2 desc_tag Title : desc_tag Usage : $obj->desc_tag($newval) Function: Get/Set the value used for the query motif. This will be placed in the tag '-display_name'. Default is 'erpin' as set by the global $DescTag. Use this to manually set the descriptor (motif searched for). Since there is no way for this module to tell what the motif is from the name of the descriptor file or the ERPIN output, this should be set every time an ERPIN object is instantiated for clarity Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub desc_tag{ my $self = shift; return $self->{'desc_tag'} = shift if @_; return $self->{'desc_tag'}; } =head2 analysis_method Usage : $obj->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /ERPIN/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /ERPIN/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $obj->next_feature()) { # do something } Function: Returns the next gene structure prediction of the ERPIN result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Returns : A Bio::Tools::Prediction::Gene object. Args : None (at present) =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $obj->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the ERPIN result file. Call this method repeatedly until FALSE is returned. Returns : A Bio::Tools::Prediction::Gene object. Args : None (at present) =cut sub next_prediction { my ($self) = @_; my ($motiftag,$srctag,$desctag) = ( $self->motif_tag, $self->source_tag, $self->desc_tag); # hit vars my ($strand, $start, $end, $sequence, $logodds, $score)=0; while($_ = $self->_readline) { #skip blank lines next if /^\s+$/; # parse header; there's probably a better way to do this, perhaps by # mapping, but this works for now... if(/^Training set:\s+\"(.*)\":$/) { $self->{'_tset'}=$1; } elsif(/\s+(\d+ sequences of length \d+)/){ $self->{'_tset_descr'}=$1; } elsif(/^Cutoff:\s+(\S+)\s+$/) { $self->{'_cutoff'}=$1; } elsif(/^Database:\s+\"(.*)\"$/) { $self->{'_db'}=$1; } elsif(/^\s+(\d+ nucleotides to be processed in \d+ sequence)$/) { $self->{'_db_desc'}=$1; } elsif(/^\s+ATGC ratios:\s(\d.\d+)\s+(\d.\d+)\s+(\d.\d+)\s+(\d.\d+)$/) { my $atgc=sprintf("A=%0.3f T=%0.3f G=%0.3f C=%0.3f", $1, $2, $3, $4); $self->{'_db_ratios'}=$atgc; } elsif(/^E-value at cutoff \S+ for \S+(?:G|M|k)?b double strand data: (\S+)/) { $self->{'_eval_cutoff'}=$1; } # catch hit, store in private hash keys elsif (/^>(.*)/) { $self->{_seq_desc} = $1; if($self->{_seq_desc} =~ /(?:P<db>gb|gi|emb|dbj|sp|pdb|bbs|ref|lcl)\|(\d+)((?:\:|\|)\w+\|(\S*.\d+)\|)?/) { $self->{_seqid} = $1; # pulls out gid $self->{_seq_acc} = $3; } else { $self->{_seqid} = $self->{_seq_desc}; $self->{_seq_acc} = ''; } } # parse next hit elsif (/^(FW|RC)\s+\d+\s+(\d+)..(\d+)\s+(\d+.\d+)\s+(.*)/) { ($strand, $start, $end, $logodds, $score)=($1, $2, $3, $4, $5); $score =~ s/^e/1e/i; chomp ($sequence = $self->_readline); # grab next line, which is the sequence hit my $gene = Bio::SeqFeature::Generic->new(-seq_id => $self->{_seqid}, -start => $start, -end => $end, -strand => $strand eq 'FW' ? 1 : -1, -score => $score, -primary_tag => $motiftag, -source_tag => $srctag, -display_name => $desctag, -tag => { 'tset' => $self->{_tset}, 'tsetdesc' => $self->{_tset_descr}, 'cutoff' => $self->{_cutoff}, 'database' => $self->{_db}, 'dbdesc' => $self->{_db_desc}, 'dbratios' => $self->{_db_ratios}, 'descline' => $self->{_seq_desc}, 'accession' => $self->{_seq_acc}, 'logodds' => $logodds, 'sequence' => $sequence} ); return $gene; } #else { # $self->debug("unrecognized line: $_"); #} } } 1;�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Est2Genome.pm�������������������������������������������������������������000444��000765��000024�� 27373�12254227323� 17611� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Est2Genome # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Est2Genome - Parse est2genome output, makes simple Bio::SeqFeature::Generic objects =head1 SYNOPSIS use Bio::Tools::Est2Genome; my $featureiter = Bio::Tools::Est2Genome->new(-file => 'output.est2genome'); # This is going to be fixed to use the SeqAnalysisI next_feature # Method eventually when we have the objects to put the data in # properly while( my $f = $featureiter->parse_next_gene ) { # process Bio::SeqFeature::Generic objects here } =head1 DESCRIPTION This module is a parser for C<est2genome> [EMBOSS] alignments of est/cdna sequence to genomic DNA. This is generally accepted as the best program for predicting splice sites based on est/dnas (as far as I know). This module currently does not try pull out the ungapped alignments (Segment) but may in the future. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Est2Genome; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::Intron; use Bio::SeqFeature::Gene::GeneStructure; use Bio::SeqFeature::SimilarityPair; use base qw(Bio::Tools::AnalysisResult); =head2 new Title : new Usage : my $obj = Bio::Tools::Est2Genome->new(); Function: Builds a new Bio::Tools::Est2Genome object Returns : an instance of Bio::Tools::Est2Genome Args : -file => 'output.est2genome' or -fh => \*EST2GENOMEOUTPUT -genomefirst => 1 # genome was the first input (not standard) =cut sub _initialize_state { my($self,@args) = @_; # call the inherited method first my $make = $self->SUPER::_initialize_state(@args); my ($genome_is_first) = $self->_rearrange([qw(GENOMEFIRST)], @args); delete($self->{'_genome_is_first'}); $self->{'_genome_is_first'} = $genome_is_first if(defined($genome_is_first)); $self->analysis_method("est2genome"); } =head2 analysis_method Usage : $sim4->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /est2genome/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /est2genome/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 parse_next_gene Title : parse_next_gene Usage : @gene = $est2genome_result->parse_next_gene; foreach $exon (@exons) { # do something } Function: Parses the next alignments of the est2genome result file and returns the found exons as an array of Bio::SeqFeature::SimilarityPair objects. Call this method repeatedly until an empty array is returned to get the results for all alignments. The $exon->seq_id() attribute will be set to the identifier of the respective sequence for both sequences. The length is accessible via the seqlength() attribute of $exon->query() and $exon->est_hit(). Returns : An array (or array reference) of Bio::SeqFeature::SimilarityPair and Bio::SeqFeature::Generic objects or Bio::SeqFeature::Gene::GeneStructure Args : flag(1/0) indicating to return Bio::SeqFeature::Gene::GeneStructure or Bio::SeqFeature::SimilarityPair defaults to 0 =cut sub parse_next_gene { my ($self,$return_gene) = @_; return $self->_parse_gene_struct if $return_gene; my $seensegment = 0; my @features; my ($qstrand,$hstrand) = (1,1); my $lasthseqname; while( defined($_ = $self->_readline) ) { if( /Note Best alignment is between (reversed|forward) est and (reversed|forward) genome, (but|and) splice\s+sites imply\s+(forward gene|REVERSED GENE)/) { if( $seensegment ) { $self->_pushback($_); return wantarray ? @features : \@features; } $hstrand = -1 if $1 eq 'reversed'; $qstrand = -1 if $4 eq 'REVERSED GENE'; #$self->debug( "1=$1, 2=$2, 4=$4\n"); } elsif( /^Exon/ ) { my ($name,$score,$perc_ident,$qstart,$qend,$qseqname, $hstart,$hend, $hseqname) = split; $lasthseqname = $hseqname; my $query = Bio::SeqFeature::Similarity->new(-primary => $name, -source => $self->analysis_method, -seq_id => $qseqname, # FIXME WHEN WE REDO THE GENERIC NAME CHANGE -start => $qstart, -end => $qend, -strand => $qstrand, -score => $score, -tag => { # 'Location' => "$hstart..$hend", 'Sequence' => "$hseqname", 'identity' => $perc_ident, } ); my $hit = Bio::SeqFeature::Similarity->new(-primary => 'exon_hit', -source => $self->analysis_method, -seq_id => $hseqname, -start => $hstart, -end => $hend, -strand => $hstrand, -score => $score, -tag => { # 'Location' => "$qstart..$qend", 'Sequence' => "$qseqname", 'identity' => $perc_ident, } ); push @features, Bio::SeqFeature::SimilarityPair->new (-query => $query, -hit => $hit, -source => $self->analysis_method); } elsif( /^([\-\+\?])(Intron)/) { my ($name,$score,$perc_ident,$qstart,$qend,$qseqname) = split; push @features, Bio::SeqFeature::Generic->new(-primary => $2, -source => $self->analysis_method, -start => $qstart, -end => $qend, -strand => $qstrand, -score => $score, -seq_id => $qseqname, -tag => { 'identity' => $perc_ident, 'Sequence' => $lasthseqname}); } elsif( /^Span/ ) { } elsif( /^Segment/ ) { $seensegment = 1; } elsif( /^\s+$/ ) { # do nothing } else { $self->warn( "unknown line $_\n"); } } return unless( @features ); return wantarray ? @features : \@features; } sub _parse_gene_struct { my ($self) = @_; my $seensegment = 0; my @features; my ($qstrand,$hstrand) = (1,1); my $lasthseqname; my $gene = Bio::SeqFeature::Gene::GeneStructure->new(-source => $self->analysis_method); my $transcript = Bio::SeqFeature::Gene::Transcript->new(-source => $self->analysis_method); my @suppf; my @exon; while( defined($_ = $self->_readline) ) { if( /Note Best alignment is between (reversed|forward) est and (reversed|forward) genome, (but|and) splice\s+sites imply\s+(forward gene|REVERSED GENE)/) { if( $seensegment ) { $self->_pushback($_); return $gene; } $hstrand = -1 if $1 eq 'reversed'; $qstrand = -1 if $4 eq 'REVERSED GENE'; } elsif( /^Exon/ ) { my ($name,$score,$perc_ident,$qstart,$qend,$qseqname,$hstart,$hend, $hseqname) = split; $lasthseqname = $hseqname; my $exon = Bio::SeqFeature::Gene::Exon->new(-primary => $name, -source => $self->analysis_method, -seq_id => $qseqname, # FIXME WHEN WE REDO THE GENERIC NAME CHANGE -start => $qstart, -end => $qend, -strand => $qstrand, -score => $score, -tag => { #'Location' => "$hstart..$hend", 'identity' => $perc_ident, 'Sequence' => "$hseqname", } ); $transcript->seq_id($qseqname) unless $transcript->seq_id; $exon->add_tag_value('phase',0); push @exon, $exon; } elsif( /^([\-\+\?])(Intron)/) { next; #intron auto matically built from exons..hope thats ok.. } elsif( /^Span/ ) { } elsif( /^Segment/ ) { my ($name,$score,$perc_ident,$qstart,$qend,$qseqname,$hstart,$hend, $hseqname) = split; my $query = Bio::SeqFeature::Similarity->new(-primary => $name, -source => $self->analysis_method, -seq_id => $qseqname, # FIXME WHEN WE REDO THE GENERIC NAME CHANGE -start => $qstart, -end => $qend, -strand => $qstrand, -score => $score, -tag => { # 'Location' => "$hstart..$hend", 'Sequence' => "$hseqname", 'identity' => $perc_ident, } ); my $hit = Bio::SeqFeature::Similarity->new(-primary => 'exon_hit', -source => $self->analysis_method, -seq_id => $hseqname, -start => $hstart, -end => $hend, -strand => $hstrand, -score => $score, -tag => { # 'Location' => "$qstart..$qend", 'Sequence' => "$qseqname", 'identity' => $perc_ident, } ); my $support = Bio::SeqFeature::SimilarityPair->new(-query => $query, -hit => $hit, -source => $self->analysis_method); push @suppf, $support; } elsif( /^\s+$/ ) { # do nothing } else { $self->warn( "unknown line $_\n"); } } return unless $#exon >=0; foreach my $e(@exon){ my @add; foreach my $sf(@suppf){ if($sf->overlaps($e)){ push @add,$sf; } } $e->add_tag_value('supporting_feature',@add); $transcript->add_exon($e); } $gene->add_transcript($transcript); $gene->seq_id($transcript->seq_id); return $gene; } =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut sub next_feature { my ($self) = shift; $self->throw("We haven't really done this right, yet, use parse_next_gene"); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/ESTScan.pm����������������������������������������������������������������000444��000765��000024�� 25626�12254227332� 17100� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::ESTScan # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::ESTScan - Results of one ESTScan run =head1 SYNOPSIS $estscan = Bio::Tools::ESTScan->new(-file => 'result.estscan'); # filehandle: $estscan = Bio::Tools::ESTScan->new( -fh => \*INPUT ); # parse the results # note: this class is-a Bio::Tools::AnalysisResult which implements # Bio::SeqAnalysisParserI, i.e., $genscan->next_feature() is the same while($gene = $estscan->next_prediction()) { # $gene is an instance of Bio::Tools::Prediction::Gene foreach my $orf ($gene->exons()) { # $orf is an instance of Bio::Tools::Prediction::Exon $cds_str = $orf->predicted_cds(); } } # essential if you gave a filename at initialization (otherwise the file # will stay open) $estscan->close(); =head1 DESCRIPTION The ESTScan module provides a parser for ESTScan coding region prediction output. This module inherits off L<Bio::Tools::AnalysisResult> and therefore implements the L<Bio::SeqAnalysisParserI> interface. See L<Bio::SeqAnalysisParserI>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net (or hilmar.lapp@pharma.novartis.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::ESTScan; use strict; use Symbol; use Bio::Root::Root; use Bio::Tools::Prediction::Exon; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my ($self,@args) = @_; # first call the inherited method! my $make = $self->SUPER::_initialize_state(@args); if(! $self->analysis_method()) { $self->analysis_method('ESTScan'); } } =head2 analysis_method Usage : $estscan->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /estscan/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /estscan/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($orf = $estscan->next_feature()) { # do something } Function: Returns the next gene structure prediction of the ESTScan result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $estscan->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the ESTScan result file. Call this method repeatedly until FALSE is returned. So far, this method DOES NOT work for reverse strand predictions, even though the code looks like. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my ($gene, $seq, $cds, $predobj); my $numins = 0; # predictions are in the format of FASTA sequences and can be parsed one # at a time $seq = $self->_fasta_stream()->next_seq(); return unless $seq; # there is a new prediction $gene = Bio::Tools::Prediction::Gene->new('-primary' => "ORFprediction", '-source' => "ESTScan"); # score starts the description $seq->desc() =~ /^([\d.]+)\s*(.*)/ or $self->throw("unexpected format of description: no score in " . $seq->desc()); $gene->score($1); $seq->desc($2); # strand may end the description if($seq->desc() =~ /(.*)minus strand$/) { my $desc = $1; $desc =~ s/;\s+$//; $seq->desc($desc); $gene->strand(-1); } else { $gene->strand(1); } # check for the format: default or 'all-in-one' (option -a) if($seq->desc() =~ /^(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s*(.*)/) { # default format $seq->desc($5); $predobj = Bio::Tools::Prediction::Exon->new('-source' => "ESTScan", '-start' => $3, '-end' => $4); $predobj->strand($gene->strand()); $predobj->score($gene->score()); # FIXME or $1, or $2 ? $predobj->primary_tag("InternalExon"); $predobj->seq_id($seq->display_id()); # add to gene structure object $gene->add_exon($predobj); # add predicted CDS $cds = $seq->seq(); $cds =~ s/[a-z]//g; # remove the deletions, but keep the insertions $cds = Bio::PrimarySeq->new('-seq' => $cds, '-display_id' => $seq->display_id(), '-desc' => $seq->desc(), '-alphabet' => "dna"); $gene->predicted_cds($cds); $predobj->predicted_cds($cds); if($gene->strand() == -1) { $self->warn("reverse strand ORF, but unable to reverse coordinates!"); } } else { # # All-in-one format (hopefully). This encodes the following information # into the sequence: # 1) untranslated regions: stretches of lower-case letters # 2) translated regions: stretches of upper-case letters # 3) insertions in the translated regions: capital X # 4) deletions in the translated regions: a single lower-case letter # # if reverse strand ORF, save a lot of hassle by reversing the sequence if($gene->strand() == -1) { $seq = $seq->revcom(); } my $seqstr = $seq->seq(); while($seqstr =~ /^([a-z]*)([A-Z].*)$/) { # leading 5'UTR my $utr5 = $1; # exon + 3'UTR my $exonseq = $2; # strip 3'UTR and following exons if($exonseq =~ s/([a-z]{2,}.*)$//) { $seqstr = $1; } else { $seqstr = ""; } # start: take care of yielding the absolute coordinate my $start = CORE::length($utr5) + 1; if($predobj) { $start += $predobj->end() + $numins; } # for the end coordinate, we need to subtract the insertions $cds = $exonseq; $cds =~ s/[X]//g; my $end = $start + CORE::length($cds) - 1; # construct next exon object $predobj = Bio::Tools::Prediction::Exon->new('-start' => $start, '-end' => $end); $predobj->source_tag("ESTScan"); $predobj->primary_tag("InternalExon"); $predobj->seq_id($seq->display_id()); $predobj->strand($gene->strand()); $predobj->score($gene->score()); # add the exon to the gene structure object $gene->add_exon($predobj); # add the predicted CDS $cds = $exonseq; $cds =~ s/[a-z]//g; # remove the deletions, but keep the insertions $cds = Bio::PrimarySeq->new('-seq' => $cds, '-display_id' => $seq->display_id(), '-desc' => $seq->desc(), '-alphabet' => "dna"); # only store the first one in the overall prediction $gene->predicted_cds($cds) unless $gene->predicted_cds(); $predobj->predicted_cds($cds); # add the predicted insertions and deletions as subfeatures # of the exon my $fea = undef; while($exonseq =~ /([a-zX])/g) { my $indel = $1; # start and end: start looking at the position after the # previous feature if($fea) { $start = $fea->start()+$numins; $start -= 1 if($fea->primary_tag() eq 'insertion'); } else { $start = $predobj->start()+$numins-1; } #print "# numins = $numins, indel = $indel, start = $start\n"; $start = index($seq->seq(), $indel, $start) + 1 - $numins; $fea = Bio::SeqFeature::Generic->new('-start' => $start, '-end' => $start); $fea->source_tag("ESTScan"); $fea->seq_id($seq->display_id()); $fea->strand($predobj->strand()); if($indel eq 'X') { # an insertion (depends on viewpoint: to get the 'real' # CDS, a base has to be inserted, i.e., the HMMER model # inserted a base; however, the sequencing process deleted # a base that was there). $fea->primary_tag("insertion"); # we need to count insertions because these are left out # of any coordinates saved in the objects (which is correct # because insertions change the original sequence, so # coordinates wouldn't match) $numins++; } else { # a deletion (depends on viewpoint: to get the 'real' # CDS, a base has to be deleted, i.e., the HMMER model # deleted a base; however, the sequencing process inserted # a base that wasn't there). $fea->primary_tag("deletion"); $fea->add_tag_value('base', $indel); } $predobj->add_sub_SeqFeature($fea); } } } return $gene; } =head2 close Title : close Usage : $result->close() Function: Closes the file handle associated with this result file. Inherited method, overridden. Example : Returns : Args : =cut sub close { my ($self, @args) = @_; delete($self->{'_fastastream'}); $self->SUPER::close(@args); } =head2 _fasta_stream Title : _fasta_stream Usage : $result->_fasta_stream() Function: Gets/Sets the FASTA sequence IO stream for reading the contents of the file associated with this MZEF result object. If called for the first time, creates the stream from the filehandle if necessary. Example : Returns : Args : =cut sub _fasta_stream { my ($self, $stream) = @_; if($stream || (! exists($self->{'_fastastream'}))) { if(! $stream) { $stream = Bio::SeqIO->new('-fh' => $self->_fh(), '-format' => "fasta"); } $self->{'_fastastream'} = $stream; } return $self->{'_fastastream'}; } 1; ����������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Fgenesh.pm����������������������������������������������������������������000555��000765��000024�� 36275�12254227324� 17225� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Fgenesh # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Christopher Dwan (chris@dwan.org) # # Copied, lock stock & barrel from Genscan.pm # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Fgenesh - parse results of one Fgenesh run =head1 SYNOPSIS use Bio::Tools::Fgenesh; $fgenesh = Bio::Tools::Fgenesh->new(-file => 'result.fgenesh'); # filehandle: $fgenesh = Bio::Tools::Fgenesh->new( -fh => \*INPUT ); # parse the results # note: this class is-a Bio::Tools::AnalysisResult which implements # Bio::SeqAnalysisParserI, i.e., $fgensh->next_feature() is the same while($gene = $fgenesh->next_prediction()) { # $gene is an instance of Bio::Tools::Prediction::Gene, which inherits # off Bio::SeqFeature::Gene::Transcript. # # $gene->exons() returns an array of # Bio::Tools::Prediction::Exon objects # all exons: @exon_arr = $gene->exons(); # initial exons only @init_exons = $gene->exons('Initial'); # internal exons only @intrl_exons = $gene->exons('Internal'); # terminal exons only @term_exons = $gene->exons('Terminal'); # singleton exons: ($single_exon) = $gene->exons(); } # essential if you gave a filename at initialization (otherwise the file # will stay open) $fgenesh->close(); =head1 DESCRIPTION The Fgenesh module provides a parser for Fgenesh (version 2) gene structure prediction output. It parses one gene prediction into a Bio::SeqFeature::Gene::Transcript- derived object. This module also implements the L<Bio::SeqAnalysisParserI> interface, and thus can be used wherever such an object fits. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Dwan Email chris-at-dwan.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Fgenesh; use strict; use Symbol; use Bio::Root::Root; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use base qw(Bio::Tools::AnalysisResult); my %ExonTags = ('CDSf' => 'Initial', 'CDSi' => 'Internal', 'CDSl' => 'Terminal', 'CDSo' => 'Singleton'); sub _initialize_state { my ($self,@args) = @_; # first call the inherited method! $self->SUPER::_initialize_state(@args); # our private state variables $self->{'_preds_parsed'} = 0; $self->{'_has_cds'} = 0; # array of pre-parsed predictions $self->{'_preds'} = []; # seq stack $self->{'_seqstack'} = []; } =head2 analysis_method Usage : $genscan->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /genscan/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /fgenesh/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $fgenesh->next_feature()) { # do something } Function: Returns the next gene structure prediction of the Fgenesh result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $fgenesh->next_prediction()) { ... } Function: Returns the next gene structure prediction of the Genscan result file. Call this method repeatedly until FALSE is returned. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my $gene; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions() unless $self->_predictions_parsed(); # get next gene structure $gene = $self->_prediction(); if($gene) { # fill in predicted protein, and if available the predicted CDS # # use the seq stack if there's a seq on it my $seqobj = pop(@{$self->{'_seqstack'}}); my ($id, $seq); unless ($seqobj) { ($id, $seq) = $self->_read_fasta_seq(); my $alphabet; if (($id =~ /mrna/) || ($id =~ /cds/)) { $alphabet = 'dna'; } else { $alphabet = 'protein'; } $seqobj = Bio::PrimarySeq->new('-seq' => $seq, '-display_id' => $id, '-alphabet' => $alphabet); } if ($seqobj) { # check that prediction number matches the prediction number # indicated in the sequence id (there may be incomplete gene # predictions that contain only signals with no associated protein # prediction. $gene->primary_tag() =~ /[^0-9]([0-9]+)$/; my $prednr = $1; if ($id !~ /_predicted_(\w+)_$prednr/) { # this is not our sequence, so push back for next prediction push(@{$self->{'_seqstack'}}, $seqobj); } else { if ($1 eq "protein") { $gene->predicted_protein($seqobj); } elsif (($1 eq "mrna") || ($1 eq "cds")) { $self->_has_cds(1); $gene->predicted_cds($seqobj); # Have to go back in and get the protein... ($id, $seq) = $self->_read_fasta_seq(); if ($id =~ /_cds_/) { ($id, $seq) = $self->_read_fasta_seq(); } $seqobj = Bio::PrimarySeq->new('-seq' => $seq, '-display_id' => $id, '-alphabet' => "protein"); $gene->predicted_protein($seqobj); } } } } return $gene; } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; my $gene; my $seqname; while(defined($_ = $self->_readline())) { if(/^\s*(\d+)\s+([+\-])/) { my $line = $_; # exon or signal my $prednr = $1; my $strand = ($2 eq '+') ? 1 : -1; if(! defined($gene)) { $gene = Bio::Tools::Prediction::Gene->new( '-primary' => "GenePrediction$prednr", '-source' => 'Fgenesh'); } # split into fields chomp(); my @flds = split(/\s+/, ' ' . $line); ## NB - the above adds leading whitespace before the gene ## number in case there was none (as quick patch to code ## below which expects it but it is not present after 999 ## predictions!) This allows >999 predictions to be parsed. # create the feature object depending on the type of signal my $predobj; my $is_exon = grep {$line =~ $_} keys(%ExonTags); my ($start, $end); if($is_exon) { $predobj = Bio::Tools::Prediction::Exon->new(); $predobj->score($flds[8]); $start = $flds[5]; $end = $flds[7]; } else { # PolyA site, or TSS $predobj = Bio::SeqFeature::Generic->new(); $predobj->score($flds[5]); $start = $flds[4]; $end = $flds[4]; } # set common fields $predobj->source_tag('Fgenesh'); $predobj->strand($strand); # Following tactical commenting-out made by # malcolm.cook@stowers-institute.org since coordinate reversal is # apparently vestigial copy/paste detritus from Genscan.pm origins of # this module and this is NOT needed for fgenesh (at least in v # 2.1.4). # if($predobj->strand() == 1) { $predobj->start($start); $predobj->end($end); # } else { # $predobj->end($start); # $predobj->start($end); # } # print STDERR "start $start end $end\n"; # add to gene structure (should be done only when start and end # are set, in order to allow for proper expansion of the range) if($is_exon) { # first, set fields unique to exons $predobj->primary_tag($ExonTags{$flds[4]} . 'Exon'); $predobj->is_coding(1); my $cod_offset; if($predobj->strand() == 1) { $cod_offset = ($flds[9] - $predobj->start()) % 3; # Possible values are -2, -1, 0, 1, 2. -1 and -2 correspond # to offsets 2 and 1, resp. Offset 3 is the same as 0. $cod_offset += 3 if($cod_offset < 1); } else { # On the reverse strand the Genscan frame also refers to # the first base of the first complete codon, but viewed # from forward, which is the third base viewed from # reverse. $cod_offset = ($flds[11] - $predobj->end()) % 3; # Possible values are -2, -1, 0, 1, 2. Due to the reverse # situation, {2,-1} and {1,-2} correspond to offsets # 1 and 2, resp. Offset 3 is the same as 0. $cod_offset -= 3 if($cod_offset >= 0); $cod_offset = -$cod_offset; } # Offsets 2 and 1 correspond to frame 1 and 2 (frame of exon # is the frame of the first base relative to the exon, or the # number of bases the first codon is missing). $predobj->frame(3 - $cod_offset); # print STDERR " frame is " . $predobj->frame() . "\n"; # then add to gene structure object $gene->add_exon($predobj, $ExonTags{$flds[1]}); } elsif($flds[3] eq 'PolA') { $predobj->primary_tag("PolyAsite"); $gene->poly_A_site($predobj); } elsif($flds[3] eq 'TSS') { $predobj->primary_tag("Promoter"); # (hey! a TSS is NOT a promoter... what's going on here?... $gene->add_promoter($predobj); #I'd like to do this (for now): #$predobj->primary_tag("TSS"); #this is not the right model, but, it IS a feature at least. #but the followg errs out #$gene->add_SeqFeature($predobj); #err: MSG: start is undefined when bounds at Bio::SeqFeature::Generic::add_SeqFeature 671 check since gene has no start yet } else { $self->throw("unrecognized prediction line: " . $line); } next; } if(/^\s*$/ && defined($gene)) { # current gene is completed $gene->seq_id($seqname); $self->_add_prediction($gene); $gene = undef; next; } if(/^(FGENESH)\s+([\d\.]+)/) { $self->analysis_method($1); $self->analysis_method_version($2); if (/\s(\S+)\sgenomic DNA/) { $self->analysis_subject($1); } next; } if(/^\s*Seq name:\s+(\S+)/) { $seqname = $1; next; } /^Predicted protein/ && do { # section of predicted sequences $self->_pushback($_); last; }; } $self->_predictions_parsed(1); } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_preds'}) && @{$self->{'_preds'}}); return shift(@{$self->{'_preds'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_preds'})) { $self->{'_preds'} = []; } push(@{$self->{'_preds'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } =head2 _has_cds Title : _has_cds() Usage : $obj->_has_cds() Function: Whether or not the result contains the predicted CDSs, too. Example : Returns : TRUE or FALSE =cut sub _has_cds { my ($self, $val) = @_; $self->{'_has_cds'} = $val if $val; if(! exists($self->{'_has_cds'})) { $self->{'_has_cds'} = 0; } return $self->{'_has_cds'}; } =head2 _read_fasta_seq Title : _read_fasta_seq() Usage : ($id,$seqstr) = $obj->_read_fasta_seq(); Function: Simple but specialised FASTA format sequence reader. Uses $self->_readline() to retrieve input, and is able to strip off the traling description lines. Example : Returns : An array of two elements: fasta_id & sequence =cut sub _read_fasta_seq { my ($self) = @_; my ($id, $seq); #local $/ = ">"; my $entry = $self->_readline(); # print " ^^ $entry\n"; return unless ($entry); $entry = $self->_readline() if ($entry =~ /^Predicted protein/); # print " ^^ $entry\n"; # Pick up the header / id. if ($entry =~ /^>FGENESH:/) { if ($entry =~ /^>FGENESH:\s+(\d+)/) { # print STDERR " this is a predicted gene\n"; $id = "_predicted_protein_" . $1; } elsif ($entry =~ /^>FGENESH:\[mRNA\]\s*(\d+)/) { # print STDERR " this is an mRNA\n"; $id = "_predicted_mrna_" . $1; } elsif ($entry =~ /^>FGENESH:\[exon\]\s+Gene:\s*(\d+)/) { $id = "_predicted_cds_" . $1; } $seq = ""; $entry = $self->_readline(); } my $done = 0; while (!$done) { # print "*** $entry\n"; if (($entry =~ /^>FGENESH:\[exon\]/) && ($id =~ /^_predicted_cds_/)) { # print STDERR " -- informed about an exon header...\n"; $entry = $self->_readline(); } else { $seq .= $entry; # print STDERR " Added $entry\n"; } last unless $entry = $self->_readline(); if (($entry =~ /^>/) && (!(($entry =~ /^>FGENESH:\[exon\]/) && ($id =~ /^_predicted_cds_/)))) { $self->_pushback($entry); last; } } # id and sequence $seq =~ s/\s//g; # Remove whitespace return ($id, $seq); } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/FootPrinter.pm������������������������������������������������������������000444��000765��000024�� 14712�12254227334� 20107� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::FootPrinter # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Shawn Hoon <shawnh@fugu-sg.org> # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::FootPrinter - write sequence features in FootPrinter format =head1 SYNOPSIS use Bio::Tools::FootPrinter; my $tool = Bio::Tools::FootPrinter->new(-file=>"footprinter.out"); while (my $result = $tool->next_feature){ foreach my $feat($result->sub_SeqFeature){ print $result->seq_id."\t".$feat->start."\t".$feat->end."\t".$feat->seq->seq."\n"; } } =head1 DESCRIPTION This module writes sequence features in FootPrinter format. See L<http://bio.cs.washington.edu/software.html> for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::FootPrinter; use strict; use Bio::SeqFeature::Generic; use Bio::PrimarySeq; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::FootPrinter->new(); Function: Builds a new Bio::Tools::FootPrinter object Returns : Bio::Tools::FootPrinter Args : -fh/-file => $val, # for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_feature Title : next_feature Usage : my $r = $footprint->next_feature Function: Get the next feature from parser data Returns : L<Bio::SeqFeature::Generic> Args : none =cut sub next_feature{ my ($self) = @_; $self->_parse_predictions() unless $self->_predictions_parsed(); return shift @{$self->{'_feature'}}; } =head2 _add_feature Title : _add_feature Usage : $footprint->_add_feature($feat) Function: Add feature to array Returns : none Args : none =cut sub _add_feature { my ($self,$feat) = @_; if($feat){ push @{$self->{'_feature'}},$feat; } } =head2 _parse_predictions Title : _parse_predictions Usage : my $r = $footprint->_parse_predictions Function: do the parsing Returns : none Args : none =cut sub _parse_predictions { my ($self) = @_; $/=""; my ($seq,$second,$third,$name); while ($_ = $self->_readline) { chomp; my @array = split("\n",$_); if ($#array == 5) { # get rid of header shift(@array); shift(@array); } if($#array == 3){ if($name){ $name=~s/>//; my $feat = $self->_parse($name,$seq,$second,$third); $self->_add_feature($feat); } $name = shift @array; $seq = $array[0]; $second = $array[1]; $third = $array[2]; next; } $seq .= $array[0]; $third .= $array[2]; } $seq || return; $name=~s/>//; my $feat = $self->_parse($name,$seq,$second,$third); $self->_add_feature($feat); $self->_predictions_parsed(1); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $footprint->_predictions_parsed(1) Function: Get/Set for whether predictions parsed Returns : 1/0 Args : none =cut sub _predictions_parsed { my ($self,$val) = @_; if($val){ $self->{'_predictions_parsed'} = $val; } return $self->{'_predictions_parsed'}; } =head2 _parse Title : _parse Usage : $footprint->_parse($name,$seq,$pattern) Function: do the actual parsing Returns : L<Bio::SeqFeature::Generic> Args : none =cut sub _parse { my ($self,$name,$seq,$score,$pattern) = @_; my @char = split('',$pattern); my @score = split('',$score); my ($prev,$word,@words,@word_scores,$word_score); my $i = 0; for my $c ( @char ) { if( ! $word) { $word .= $c; $prev = $c; defined $score[$i] && ($score[$i] =~ /\d/) && ($word_score += $score[$i]); } elsif ($c eq $prev){ $word .=$c; $prev = $c; defined $score[$i] && ($score[$i] =~ /\d/) && ($word_score += $score[$i]); } else { # remove words with only \s $word=~s/\s+//g; if ($word ne ''){ push @words, $word; push @word_scores, ($word_score/length($word)); } $word =$c; $prev = $c; $word_score = 0; defined $score[$i] && ($score[$i] =~ /\d/) && ($word_score += $score[$i]); } $i++; } $word =~s/\s+//g; if( length($word) ){ push @words, $word; } my $last; my $feat = Bio::SeqFeature::Generic->new(-seq_id=>$name); my $offset = $i = 0; my $count = 1; for my $w (@words){ if(length($w) ) { my $index = index($pattern,$w,$offset); $offset = $index + length($w); my $subfeat = Bio::SeqFeature::Generic->new ( -seq_id =>"$name-motif".$count++, -start => $index+1, -end => $index+length($w), -source =>"FootPrinter", -score => $word_scores[$i] ); # ugh - not sure the sub_SeqFeature situation will # be around forever- things should probably be # grouped by a 'group' tag instead ala GFF3 # perhaps when Lincoln's API changes are # made to SeqFeatures this will get changed $feat->add_sub_SeqFeature($subfeat,'EXPAND'); } $i++; } my $priseq = Bio::PrimarySeq->new(-id=>$name,-seq=>$seq); $feat->attach_seq($priseq); return $feat; } 1; ������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Gel.pm��������������������������������������������������������������������000444��000765��000024�� 13344�12254227315� 16342� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Gel # Copyright Allen Day <allenday@ucla.edu> # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Gel - Calculates relative electrophoretic migration distances =head1 SYNOPSIS use Bio::PrimarySeq; use Bio::Restriction::Analysis; use Bio::Tools::Gel; # get a sequence my $d = 'AAAAAAAAAGAATTCTTTTTTTTTTTTTTGAATTCGGGGGGGGGGGGGGGGGGGG'; my $seq1 = Bio::Seq->new(-id=>'groundhog day',-seq=>$d); # cut it with an enzyme my $ra=Bio::Restriction::Analysis->new(-seq=>$seq1); @cuts = $ra->fragments('EcoRI'), 3; # analyse the fragments in a gel my $gel = Bio::Tools::Gel->new(-seq=>\@cuts,-dilate=>10); my %bands = $gel->bands; foreach my $band (sort {$b <=> $a} keys %bands){ print $band,"\t", sprintf("%.1f", $bands{$band}),"\n"; } #prints: #20 27.0 #25 26.0 #10 30.0 =head1 DESCRIPTION This takes a set of sequences or Bio::Seq objects, and calculates their respective migration distances using: distance = dilation * (4 - log10(length(dna)); Source: Molecular Cloning, a Laboratory Manual. Sambrook, Fritsch, Maniatis. CSHL Press, 1989. Bio::Tools::Gel currently calculates migration distances based solely on the length of the nucleotide sequence. Secondary or tertiary structure, curvature, and other biophysical attributes of a sequence are currently not considered. Polypeptide migration is currently not supported. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Allen Day Email allenday@ucla.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Gel; use strict; use Bio::PrimarySeq; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $gel = Bio::Tools::Gel->new(-seq => $sequence,-dilate => 3); Function: Initializes a new Gel Returns : Bio::Tools::Gel Args : -seq => Bio::Seq(s), scalar(s) or list of either/both (default: none) -dilate => Expand band migration distances (default: 1) =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($seqs, $dilate) = $self->_rearrange([qw(SEQ DILATE)], @args); if( ! ref($seqs) ) { $self->add_band([$seqs]); } elsif( ref($seqs) =~ /array/i || $seqs->isa('Bio::PrimarySeqI') ) { $self->add_band($seqs); } $self->dilate($dilate || 1); return $self; } =head2 add_band Title : add_band Usage : $gel->add_band($seq); Function: Calls _add_band with a (possibly created) Bio::Seq object. Returns : Args : Bio::Seq, scalar sequence, or list of either/both. =cut sub add_band { my ($self, $args) = @_; foreach my $arg (@$args){ my $seq; if( ! ref $arg ) { if( $arg =~ /^\d+/ ) { # $arg is a number $seq = Bio::PrimarySeq->new(-seq=>'N'x$arg, -id => $arg); } else { # $arg is a sequence string $seq = Bio::PrimarySeq->new(-seq=>$arg, -id=>length $arg); } } elsif( $arg->isa('Bio::PrimarySeqI') ) { # $arg is a sequence object $seq = $arg; } $self->_add_band($seq); } return 1; } =head2 _add_band Title : _add_band Usage : $gel->_add_band($seq); Function: Adds a new band to the gel. Returns : Args : Bio::Seq object =cut sub _add_band { my ($self, $arg) = @_; if ( defined $arg) { push (@{$self->{'bands'}},$arg); } return 1; } =head2 dilate Title : dilate Usage : $gel->dilate(1); Function: Sets/retrieves the dilation factor. Returns : dilation factor Args : Float or none =cut sub dilate { my ($self, $arg) = @_; return $self->{dilate} unless $arg; $self->throw("-dilate should be numeric") if defined $arg and $arg =~ /[^e\d\.]/; $self->{dilate} = $arg; return $self->{dilate}; } sub migrate { my ($self, $arg) = @_; $arg = $self unless $arg; if ( $arg ) { return 4 - log10($arg); } else { return 0; } } =head2 bands Title : bands Usage : $gel->bands; Function: Calculates migration distances of sequences. Returns : hash of (seq_id => distance) Args : =cut sub bands { my $self = shift; $self->throw("bands() is read-only") if @_; my %bands = (); foreach my $band (@{$self->{bands}}){ my $distance = $self->dilate * migrate($band->length); $bands{$band->id} = $distance; } return %bands; } =head2 log10 Title : log10 Usage : log10($n); Function: returns base 10 log of $n. Returns : float Args : float =cut # from "Programming Perl" sub log10 { my $n = shift; return log($n)/log(10); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Geneid.pm�����������������������������������������������������������������000444��000765��000024�� 22231�12254227324� 17021� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Keith James # # Copyright Genome Research Ltd. # # You may distribute this module under the same terms as Perl itself # POD documentation - main docs before the code =encoding utf-8 =head1 NAME Bio::Tools::Geneid - Results of one geneid run =head1 SYNOPSIS use Bio::Tools::Geneid; my $gid = Bio::Tools::Geneid(-file => "geneid.out"); while (my $gene = $gid->next_prediction) { my @transcripts = $gene->transcripts; foreach my $t (@transcripts) { my @exons = $t->exons; foreach my $e (@exons) { printf("Exon %d..%d\n", $e->start, $e->end); } } } =head1 DESCRIPTION This is the parser for the output of geneid by Enrique Blanco and Roderic GuigE<243> (IMIM-UPF). See http://www1.imim.es/software/geneid. It relies on native geneid output format internally and will work with geneid versions 1.0 and 1.1. Currently this module supports only the default mode of operation which is to predict exons and assemble an optimal gene prediction. It takes either a file handle or a file name and returns a Bio::SeqFeature::Gene::GeneStructure object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Keith James Email: kdj@sanger.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Geneid; use vars qw($SOURCE_TAG); use strict; use Bio::Tools::AnalysisResult; use Bio::SeqFeature::Generic; use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::GeneStructure; use base qw(Bio::Root::Root Bio::Root::IO); $SOURCE_TAG = 'geneid'; =head2 new Title : new Usage : $obj->new(-file = "<geneid.out"); $obj->new(-fh => \*GI); Function: Constructor for geneid wrapper. Takes either a file : or filehandle Returns : L<Bio::Tools::Geneid> =cut sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_prediction Title : next_prediction Usage : while($gene = $geneid->next_prediction) { # do something } Function: Returns the gene structure prediction of the geneid result file. Call this method repeatedly until FALSE is returned. Returns : A Bio::SeqFeature::Gene::GeneStructure object Args : None =cut sub next_prediction { my ($self) = @_; my ($gene, $transcript, $current_gene_id); my $transcript_score = 0; my ($gene_id, $exon_type, $exon_start, $exon_end, $exon_score, $exon_strand, $start_phase, $end_phase, $start_sig_score, $end_sig_score, $coding_pot_score, $homol_score); while (defined($_ = $self->_readline)) { $self->debug($_); s/^\s+//; s/\s+$//; # We have a choice of geneid, gff or XML formats. The native # geneid format has more information than gff. However, we # then need to perform the hack of extracting the sequence ID # from the header of the embedded Fasta file which comes after # the exon data, as it is not stored elsewhere. Ack. # the new version of geneID includes the sequence ID in a slightly # different format and a new "or" statement was added below # also removed "unless defined $self->_target_id;" inorder to continue # generating new sequence IDs. if (/^>(\S+)\|GeneId/ or /^# Sequence (\S+)/) { my $target_id = $1; $self->_target_id($target_id); next; } next unless (/(Single|First|Internal|Terminal)/); my @fields = split(/\s+/, $_); # Grab gene_id from eol first as there are issues with # inconsistent whitespace in the AA coords field $gene_id = pop @fields; ($exon_type, $exon_start, $exon_end, $exon_score, $exon_strand, $start_phase, $end_phase, $start_sig_score, $end_sig_score, $coding_pot_score, $homol_score) = @fields[0..10]; if (! defined $current_gene_id) { # Starting the requested prediction $current_gene_id = $gene_id; $transcript_score = $exon_score; $gene = Bio::SeqFeature::Gene::GeneStructure->new(-source => $SOURCE_TAG); $transcript = Bio::SeqFeature::Gene::Transcript->new(-source => $SOURCE_TAG); $self->_add_exon($gene, $transcript, $exon_type, $exon_start, $exon_end, $exon_score, $exon_strand, $start_phase, $end_phase, $start_sig_score, $end_sig_score, $coding_pot_score, $homol_score); } elsif ($gene_id eq $current_gene_id) { # Still in requested prediction $transcript_score += $exon_score; $self->_add_exon($gene, $transcript, $exon_type, $exon_start, $exon_end, $exon_score, $exon_strand, $start_phase, $end_phase, $start_sig_score, $end_sig_score, $coding_pot_score, $homol_score); } else { # Found following prediction $self->_pushback($_); last; } } if (defined $gene) { $transcript->seq_id($self->_target_id); $transcript->score($transcript_score); $gene->add_transcript($transcript); $gene->seq_id($self->_target_id); foreach my $exon ($gene->exons) { $exon->seq_id($self->_target_id); } $self->_set_strand($gene); } return $gene; } =head2 _add_exon Title : _add_exon Usage : $obj->_add_exon($gene, $transcript, ... exon data ...) Function: Adds a new exon to both gene and transcript from the data : supplied as args Example : Returns : Nothing =cut sub _add_exon { my ($self, $gene, $transcript, $exon_type, $exon_start, $exon_end, $exon_score, $exon_strand, $start_phase, $end_phase, $start_sig_score, $end_sig_score, $coding_pot_score, $homol_score) = @_; $exon_type =~ s/First/Initial/; my $strand = $exon_strand eq '+' ? 1 : -1; my $exon = Bio::SeqFeature::Gene::Exon->new(-source => $SOURCE_TAG, -start => $exon_start, -end => $exon_end, -strand => $strand, -score => $exon_score); $exon->is_coding(1); $exon->add_tag_value("Type", $exon_type); $exon->add_tag_value('phase', $start_phase); $exon->add_tag_value('end_phase', $end_phase); $exon->add_tag_value('start_signal_score', $start_sig_score); $exon->add_tag_value('end_signal_score', $end_sig_score); $exon->add_tag_value('coding_potential_score', $coding_pot_score); $exon->add_tag_value('homology_score', $homol_score); $transcript->strand($strand) unless $transcript->strand != 0; $transcript->add_exon($exon, $exon_type); } =head2 _set_strand Title : _set_strand Usage : $obj->_set_strand($gene) Function: Sets the overall gene strand to the same strand as all : the exons if they are all on the same strand, or to strand 0 : if the exons are on different strands. Example : Returns : Nothing =cut sub _set_strand { my ($self, $gene) = @_; my $fwd = 0; my $rev = 0; my @exons = $gene->exons; foreach my $exon (@exons) { my $strand = $exon->strand; if ($strand == 1) { $fwd++; } elsif ($strand == -1) { $rev++; } } if ($#exons == $fwd) { $gene->strand(1); } elsif ($#exons == $rev) { $gene->strand(-1); } else { $gene->strand(0); } return $gene; } =head2 _target_id Title : _target_id Usage : $obj->_target_id Function: get/set for genomic sequence id Example : Returns : A target ID =cut sub _target_id { my ($self,$val) = @_; if ($val) { $self->{'_target_id'} = $val; } return $self->{'_target_id'}; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Genemark.pm���������������������������������������������������������������000444��000765��000024�� 35234�12254227321� 17363� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Genemark # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Mark Fiers <hlapp@gmx.net> # # Copyright Hilmar Lapp, Mark Fiers # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Genemark - Results of one Genemark run =head1 SYNOPSIS $Genemark = Bio::Tools::Genemark->new(-file => 'result.Genemark'); # filehandle: $Genemark = Bio::Tools::Genemark->new( -fh => \*INPUT ); # parse the results # note: this class is-a Bio::Tools::AnalysisResult which implements # Bio::SeqAnalysisParserI, i.e., $Genemark->next_feature() is the same while($gene = $Genemark->next_prediction()) { # $gene is an instance of Bio::Tools::Prediction::Gene, which inherits # off Bio::SeqFeature::Gene::Transcript. # # $gene->exons() returns an array of # Bio::Tools::Prediction::Exon objects # all exons: @exon_arr = $gene->exons(); # initial exons only @init_exons = $gene->exons('Initial'); # internal exons only @intrl_exons = $gene->exons('Internal'); # terminal exons only @term_exons = $gene->exons('Terminal'); # singleton exons: ($single_exon) = $gene->exons(); } # essential if you gave a filename at initialization (otherwise the file # will stay open) $Genemark->close(); =head1 DESCRIPTION The Genemark module provides a parser for Genemark gene structure prediction output. It parses one gene prediction into a Bio::SeqFeature::Gene::Transcript- derived object. This module has been developed around genemark.hmm for eukaryots v2.2a and will probably not work with other versions. This module also implements the Bio::SeqAnalysisParserI interface, and thus can be used wherever such an object fits. See L<Bio::SeqAnalysisParserI>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp, Mark Fiers Email hlapp@gmx.net m.w.e.j.fiers@plant.wag-ur.nl =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Genemark; use strict; use Symbol; use Bio::Root::Root; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use Bio::Seq; use Bio::Factory::FTLocationFactory; use base qw(Bio::Tools::AnalysisResult); =head2 new Title : new Usage : my $obj = Bio::Tools::Genemark->new(); Function: Builds a new Bio::Tools::Genemark object Returns : an instance of Bio::Tools::Genemark Args : seqname =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($seqname) = $self->_rearrange([qw(SEQNAME)], @args); # hardwire seq_id when creating gene and exon objects $self->_seqname($seqname) if defined($seqname); return $self; } sub _initialize_state { my ($self,@args) = @_; # first call the inherited method! $self->SUPER::_initialize_state(@args); # our private state variables $self->{'_preds_parsed'} = 0; $self->{'_has_cds'} = 0; # array of pre-parsed predictions $self->{'_preds'} = []; # seq stack $self->{'_seqstack'} = []; } =head2 analysis_method Usage : $Genemark->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /GeneMark.hmm/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /Genemark\.hmm/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $Genemark->next_feature()) { # do something } Function: Returns the next gene structure prediction of the Genemark result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $Genemark->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the Genemark result file. Call this method repeatedly until FALSE is returned. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my $gene; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions() unless $self->_predictions_parsed(); # get next gene structure $gene = $self->_prediction(); return $gene; } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; my %exontags = ('Initial' => 'Initial', 'Internal' => 'Internal', 'Terminal' => 'Terminal', 'Single' => '', '_na_' => ''); my $exontag; my $gene; my $exontype; my $current_gene_no = -1; # The prediction report does not contain a sequence identifier # (at least the prokaryotic version doesn't) my $seqname = $self->_seqname(); while(defined($_ = $self->_readline())) { if( (/^\s*(\d+)\s+(\d+)/) || (/^\s*(\d+)\s+[\+\-]/)) { # this is an exon, Genemark doesn't predict anything else # $prednr corresponds to geneno. my $prednr = $1; #exon no: my $signalnr = 0; if ($2) { my $signalnr = $2; } # used in tag: exon_no # split into fields chomp(); my @flds = split(' ', $_); # create the feature (an exon) object my $predobj = Bio::Tools::Prediction::Exon->new(); # define info depending on it being eu- or prokaryot my ($start, $end, $orientation, $prediction_source); if ($self->analysis_method() =~ /PROKARYOTIC/i) { $prediction_source = "Genemark.hmm.pro"; $orientation = ($flds[1] eq '+') ? 1 : -1; ($start, $end) = @flds[(2,3)]; $exontag = "_na_"; } else { $prediction_source = "Genemark.hmm.eu"; $orientation = ($flds[2] eq '+') ? 1 : -1; ($start, $end) = @flds[(4,5)]; $exontag = $flds[3]; } # instatiate a location object via # Bio::Factory::FTLocationFactory (to handle # inexact coordinates) my $location_string = join('..', $start, $end); my $location_factory = Bio::Factory::FTLocationFactory->new(); my $location_obj = $location_factory->from_string($location_string); $predobj->location($location_obj); #store the data in the exon object $predobj->source_tag($prediction_source); $predobj->strand($orientation); $predobj->primary_tag($exontags{$exontag} . "Exon"); $predobj->add_tag_value('exon_no',"$signalnr") if ($signalnr); $predobj->is_coding(1); $predobj->seq_id($seqname) if (defined($seqname) && ($seqname ne 'unknown')); # frame calculation as in the genscan module # is to be implemented... #If the $prednr is not equal to the current gene, we #need to make a new gene and close the old one if($prednr != $current_gene_no) { # a new gene, store the old one if it exists if (defined ($gene)) { $gene->seq_id($seqname); $gene = undef ; } #and make a new one $gene = Bio::Tools::Prediction::Gene->new ( '-primary' => "GenePrediction$prednr", '-source' => $prediction_source); $self->_add_prediction($gene); $current_gene_no = $prednr; $gene->seq_id($seqname) if (defined($seqname) && ($seqname ne 'unknown')); } # Add the exon to the gene $gene->add_exon($predobj, ($exontag eq "_na_" ? undef : $exontags{$exontag})); } if(/^(Genemark\.hmm\s*[PROKARYOTIC]*)\s+\(Version (.*)\)$/i) { $self->analysis_method($1); my $gm_version = $2; $self->analysis_method_version($gm_version); next; } #Matrix file for eukaryot version if (/^Matrices file:\s+(\S+)?/i) { $self->analysis_subject($1); # since the line after the matrix file is always the date # (in the output file's I have seen!) extract and store this # here if (defined(my $_date = $self->_readline())) { chomp ($_date); $self->analysis_date($_date); } } #Matrix file for prokaryot version if (/^Model file name:\s+(\S+)/) { $self->analysis_subject($1); # since the line after the matrix file is always the date # (in the output file's I have seen!) extract and store this # here my $_date = $self->_readline() ; if (defined($_date = $self->_readline())) { chomp ($_date); $self->analysis_date($_date); } } if(/^Sequence[ file]? name:\s+(.+)\s*$/i) { $seqname = $1; # $self->analysis_subject($seqname); next; } /^>/ && do { $self->_pushback($_); # section of predicted aa sequences on recognition # of a fasta start, read all sequences and find the # appropriate gene while (1) { my ($aa_id, $seq) = $self->_read_fasta_seq(); last unless ($aa_id); #now parse through the predictions to add the pred. protein FINDPRED: foreach my $gene (@{$self->{'_preds'}}) { $gene->primary_tag() =~ /[^0-9]([0-9]+)$/; my $geneno = $1; if ($aa_id =~ /\|gene.$geneno\|/) { #print "x SEQ : \n $seq \nXXXX\n"; my $seqobj = Bio::Seq->new('-seq' => $seq, '-display_id' => $aa_id, '-alphabet' => "protein"); $gene->predicted_protein($seqobj); last FINDPRED; } } } last; }; } # if the analysis query object contains a ref to a Seq of PrimarySeq # object, then extract the predicted sequences and add it to the gene # object. if (defined $self->analysis_query()) { my $orig_seq = $self->analysis_query(); FINDPREDSEQ: foreach my $gene (@{$self->{'_preds'}}) { my $predseq = ""; foreach my $exon ($gene->exons()) { #print $exon->start() . " " . $exon->end () . "\n"; $predseq .= $orig_seq->subseq($exon->start(), $exon->end()); } my $seqobj = Bio::PrimarySeq->new('-seq' => $predseq, '-display_id' => "transl"); $gene->predicted_cds($seqobj); } } $self->_predictions_parsed(1); } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_preds'}) && @{$self->{'_preds'}}); return shift(@{$self->{'_preds'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_preds'})) { $self->{'_preds'} = []; } push(@{$self->{'_preds'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } =head2 _has_cds Title : _has_cds() Usage : $obj->_has_cds() Function: Whether or not the result contains the predicted CDSs, too. Example : Returns : TRUE or FALSE =cut sub _has_cds { my ($self, $val) = @_; $self->{'_has_cds'} = $val if $val; if(! exists($self->{'_has_cds'})) { $self->{'_has_cds'} = 0; } return $self->{'_has_cds'}; } =head2 _read_fasta_seq Title : _read_fasta_seq() Usage : ($id,$seqstr) = $obj->_read_fasta_seq(); Function: Simple but specialised FASTA format sequence reader. Uses $self->_readline() to retrieve input, and is able to strip off the traling description lines. Example : Returns : An array of two elements. =cut sub _read_fasta_seq { my ($self) = @_; my ($id, $seq); local $/ = ">"; return 0 unless (my $entry = $self->_readline()); $entry =~ s/^>//; # complete the entry if the first line came from a pushback buffer while(! ($entry =~ />$/)) { last unless ($_ = $self->_readline()); $entry .= $_; } # delete everything onwards from an new fasta start (>) $entry =~ s/\n>.*$//s; # id and sequence if($entry =~ s/^(.+)\n//) { $id = $1; $id =~ s/ /_/g; $seq = $entry; $seq =~ s/\s//g; #print "\n@@ $id \n@@ $seq \n##\n"; } else { $self->throw("Can't parse Genemark predicted sequence entry"); } $seq =~ s/\s//g; # Remove whitespace return ($id, $seq); } =head2 _seqname Title : _seqname Usage : $obj->_seqname($seqname) Function: internal Example : Returns : String =cut sub _seqname { my ($self, $val) = @_; $self->{'_seqname'} = $val if $val; if(! exists($self->{'_seqname'})) { $self->{'_seqname'} = 'unknown'; } return $self->{'_seqname'}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Genewise.pm���������������������������������������������������������������000444��000765��000024�� 21366�12254227317� 17406� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Genewise # # Copyright Fugu Team # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Genewise - Results of one Genewise run =head1 SYNOPSIS use Bio::Tools::Genewise; my $gw = Bio::Tools::Genewise(-file=>"genewise.out"); while (my $gene = $gw->next_prediction){ my @transcripts = $gene->transcripts; foreach my $t(@transcripts){ my @exons = $t->exons; foreach my $e(@exons){ print $e->start." ".$e->end."\n"; } } } =head1 DESCRIPTION This is the parser for the output of Genewise. It takes either a file handle or a file name and returns a Bio::SeqFeature::Gene::GeneStructure object. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Fugu Team, Jason Stajich Email: fugui@worf.fugu-sg.org Email: jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Genewise; use vars qw($Srctag); use strict; use Symbol; use Bio::Tools::AnalysisResult; use Bio::SeqFeature::Generic; use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::GeneStructure; use base qw(Bio::Root::Root Bio::Root::IO); $Srctag = 'genewise'; =head2 new Title : new Usage : $obj->new(-file=>"genewise.out"); $obj->new(-fh=>\*GW); Function: Constructor for genewise wrapper. Takes either a file or filehandle Example : Returns : Bio::Tools::Genewise object See L<Bio::Tools::Genewise> =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 _get_strand Title : _get_strand Usage : $obj->_get_strand Function: takes start and end values, swap them if start>end and returns end Example : Returns :$start,$end,$strand =cut sub _get_strand { my ($self,$start,$end) = @_; defined($start) || $self->throw("Need a start"); defined($end) || $self->throw("Need an end"); my $strand; if ($start > $end) { my $tmp = $start; $start = $end; $end = $tmp; $strand = -1; } else { $strand = 1; } return ($start,$end,$strand); } =head2 _score Title : _score Usage : $obj->_score Function: get/set for score info Returns : a score value =cut sub _score { my $self = shift; return $self->{'_score'} = shift if @_; return $self->{'_score'}; } =head2 _prot_id Title : _prot_id Usage : $obj->_prot_id Function: get/set for protein id Returns :a protein id =cut sub _prot_id { my $self = shift; return $self->{'_prot_id'} = shift if @_; return $self->{'_prot_id'}; } =head2 _target_id Title : _target_id Usage : $obj->_target_id Function: get/set for genomic sequence id Example : Returns :a target id =cut sub _target_id { my $self = shift; return $self->{'_target_id'} = shift if @_; return $self->{'_target_id'}; } =head2 next_prediction Title : next_prediction Usage : while($gene = $genewise->next_prediction()) { # do something } Function: Returns the gene structure prediction of the Genewise result file. Call this method repeatedly until FALSE is returned. Example : Returns : a Bio::SeqFeature::Gene::GeneStructure object Args : See L<Bio::SeqFeature::Gene::GeneStructure> =cut sub next_prediction { my ($self) = @_; unless ( $self->parsed ){ $self->_parse_genes; $self->parsed(1); } return shift @{$self->{'_genes'}}; } sub parsed { my $self = shift; return $self->{'_parsed'} = 1 if @_ && $_[0]; return $self->{'_parsed'}; } sub _parse_genes { my ($self) = @_; my (@alignments,@genes); local ($/) = "//"; while ( defined($_ = $self->_readline) ) { $self->debug( $_ ); while( /Alignment\s+(\d+)\s+Score\s+(\S+)\s+\(Bits\)/g ) { $alignments[$1] = $2; } if( /Score\s+(\-?\d+(\.\d+)?)/ ) { $self->_score($1);# unless defined $self->_score; } if( /Query\s+(?:protein|model)\:\s+(\S+)/ ) { $self->_prot_id($1); #unless defined $self->_prot_id; } if( /Target Sequence\s+(\S+)/ ) { $self->_target_id($1);# unless defined $self->_target_id; } next unless /Gene\s+\d+\n/; my @genes_txt = split(/Gene\s+\d+\n/,$_); shift @genes_txt; #remove first empty entry my $gene_num = 1; foreach my $gene_txt (@genes_txt) { my $score = $alignments[$gene_num]; # If genewise has assigned a strand to the gene as a whole # overall gene start and end my ($g_start, $g_end, $type) = $gene_txt =~ m/Gene\s+ (\d+)[\s-]+ # start (1-based) (\d+)\s+ # end (?:\[(\w+)\])? # /x; my $g_strand; my $source_tag = $type ? "$Srctag". "_$type" : $Srctag; my $genes = Bio::SeqFeature::Gene::GeneStructure->new (-source => $source_tag, -score => $self->_score, ); $genes->add_tag_value('ID', $self->_prot_id.".gene"); my $transcript = Bio::SeqFeature::Gene::Transcript->new (-source => $source_tag, -score => $score); ($g_start, $g_end, $g_strand) = $self->_get_strand($g_start,$g_end); $genes->strand($g_strand); # grab exon + supporting feature info my @exons; unless ( @exons = $gene_txt =~ m/(Exon .+\s+Supporting .+)/g ) { @exons = $gene_txt =~ m/(Exon .+\s+)/g; } my $nbr = 1; # loop through each exon-supporting feature pair foreach my $e (@exons){ my ($e_start,$e_end,$phase) = $e =~ m/Exon\s+ (\d+)[\s-]+ # start (1 based) (\d+)\s+ # end phase\s+(\d+) # phase /x; my $e_strand; ($e_start,$e_end,$e_strand) = $self->_get_strand($e_start, $e_end); $transcript->strand($e_strand) unless $transcript->strand != 0; my $exon = Bio::SeqFeature::Gene::Exon->new (-seq_id =>$self->_target_id, -source => $source_tag, -start =>$e_start, -end =>$e_end, -score => $score, #-frame => $phase, -strand =>$e_strand); $exon->add_tag_value('phase',$phase); $exon->is_coding(1); if( $self->_prot_id ) { $exon->add_tag_value('Parent',$self->_prot_id); } $exon->add_tag_value("Exon",$nbr++); if( $e =~ m/Supporting\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/) { my ($geno_start,$geno_end, $prot_start, $prot_end) = ($1,$2,$3,$4); my $prot_strand; ($prot_start,$prot_end, $prot_strand) = $self->_get_strand($prot_start,$prot_end); my $pf = Bio::SeqFeature::Generic->new ( -start => $prot_start, -end => $prot_end, -seq_id => $self->_prot_id, -score => $score, -strand => $prot_strand, -source => $source_tag, -primary_tag => 'supporting_protein_feature',); my $geno_strand; ($geno_start,$geno_end, $geno_strand) = $self->_get_strand($geno_start,$geno_end); my $gf = Bio::SeqFeature::Generic->new ( -start => $geno_start, -end => $geno_end, -seq_id => $self->_target_id, -score => $score, -strand => $geno_strand, -source => $source_tag, -primary_tag => 'supporting_genomic_feature',); my $fp = Bio::SeqFeature::FeaturePair->new (-feature1 =>$gf, -feature2 =>$pf); $exon->add_tag_value( 'supporting_feature',$fp ); if( $self->_prot_id ) { $exon->add_tag_value('Target','Protein:'.$self->_prot_id); $exon->add_tag_value('Target',$prot_start); $exon->add_tag_value('Target',$prot_end); } } $transcript->add_exon($exon); } $transcript->seq_id($self->_target_id); $transcript->add_tag_value('ID', $self->_prot_id); $transcript->add_tag_value('Parent', $self->_prot_id.".gene"); $genes->add_transcript($transcript); $genes->seq_id($self->_target_id); push @genes, $genes; $gene_num++; } } $self->{'_genes'} = \@genes; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Genomewise.pm�������������������������������������������������������������000444��000765��000024�� 12343�12254227327� 17736� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Genomewise # # Copyright Jason Stajich <jason-at-bioperl.org> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Tools::Genomewise - Results of one Genomewise run =head1 SYNOPSIS use Bio::Tools::Genomewise; my $gw = Bio::Tools::Genomewise(-file=>"genomewise.out"); while (my $gene = $gw->next_prediction){ my @transcripts = $gene->transcripts; foreach my $t(@transcripts){ my @exons = $t->exons; foreach my $e(@exons){ print $e->start." ".$e->end."\n"; } } } =head1 DESCRIPTION This is the parser for the output of Genewise. It takes either a file handle or a file name and returns a Bio::SeqFeature::Gene::GeneStructure object. You will need to specify the proper target sequence id on the object with the $feature-E<gt>seq_id($seqid). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Fugu Team, Jason Stajich Email: fugui-at-worf.fugu-sg.org jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Genomewise; use vars qw($Srctag); use strict; use Bio::Tools::AnalysisResult; use Bio::SeqFeature::Generic; use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::GeneStructure; use base qw(Bio::Tools::Genewise); $Srctag = 'genomewise'; =head2 new Title : new Usage : $obj->new(-file=>"genewise.out"); $obj->new(-fh=>\*GW); Function: Constructor for genomewise wrapper. Takes either a file or filehandle Example : Returns : L<Bio::Tools::Genomewise> =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 _get_strand Title : _get_strand Usage : $obj->_get_strand Function: takes start and end values, swap them if start>end and returns end Example : Returns :$start,$end,$strand =cut =head2 score Title : score Usage : $obj->score Function: get/set for score info Example : Returns : a score value =cut =head2 _prot_id Title : _prot_id Usage : $obj->_prot_id Function: get/set for protein id Example : Returns :a protein id =cut =head2 _target_id Title : _target_id Usage : $obj->_target_id Function: get/set for genomic sequence id Example : Returns :a target id =cut =head2 next_prediction Title : next_prediction Usage : while($gene = $genewise->next_prediction()) { # do something } Function: Returns the gene structure prediction of the Genomewise result file. Call this method repeatedly until FALSE is returned. Example : Returns : a Bio::SeqFeature::Gene::GeneStructure object Args : =cut sub next_prediction { my ($self) = @_; my $genes; while ($_ = $self->_readline) { $self->debug( $_ ); last if m{^//}; if( /^Gene\s+\d+\s*$/ ) { $genes = Bio::SeqFeature::Gene::GeneStructure->new (-source => $Srctag, -seq_id => $self->_target_id, # if this had been specified ); $_ = $self->_readline; $self->debug( $_ ); unless ( /^Gene\s+(\d+)\s+(\d+)\s*$/ ) { $self->warn("Unparseable genomewise output"); last; } my $transcript = Bio::SeqFeature::Gene::Transcript->new (-source => $Srctag, -seq_id => $self->_target_id, # if this had been specified -start => $1, -end => $2, ); my $nbr = 1; while( $_ = $self->_readline ) { $self->debug( $_ ); unless( m/^\s+Exon\s+(\d+)\s+(\d+)\s+phase\s+(\d+)/ ){ $self->_pushback($_); last; } my ($e_start,$e_end,$phase,$e_strand) = ($1,$2,$3); ($e_start,$e_end,$e_strand) = $self->_get_strand($e_start, $e_end); $transcript->strand($e_strand) unless $transcript->strand != 0; my $exon = Bio::SeqFeature::Gene::Exon->new (-seq_id=>$self->_target_id, -source => $Srctag, -start=>$e_start, -end=>$e_end, -frame => $phase, -strand=>$e_strand); $exon->add_tag_value("Exon",$nbr++); $exon->add_tag_value('phase',$phase); $transcript->add_exon($exon); } $genes->add_transcript($transcript); last; # only process a single gene at a time } } return $genes; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Genscan.pm����������������������������������������������������������������000444��000765��000024�� 32354�12254227325� 17214� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Genscan # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Genscan - Results of one Genscan run =head1 SYNOPSIS use Bio::Tools::Genscan; $genscan = Bio::Tools::Genscan->new(-file => 'result.genscan'); # filehandle: $genscan = Bio::Tools::Genscan->new( -fh => \*INPUT ); # parse the results # note: this class is-a Bio::Tools::AnalysisResult which implements # Bio::SeqAnalysisParserI, i.e., $genscan->next_feature() is the same while($gene = $genscan->next_prediction()) { # $gene is an instance of Bio::Tools::Prediction::Gene, which inherits # off Bio::SeqFeature::Gene::Transcript. # # $gene->exons() returns an array of # Bio::Tools::Prediction::Exon objects # all exons: @exon_arr = $gene->exons(); # initial exons only @init_exons = $gene->exons('Initial'); # internal exons only @intrl_exons = $gene->exons('Internal'); # terminal exons only @term_exons = $gene->exons('Terminal'); # singleton exons: ($single_exon) = $gene->exons(); } # essential if you gave a filename at initialization (otherwise the file # will stay open) $genscan->close(); =head1 DESCRIPTION The Genscan module provides a parser for Genscan gene structure prediction output. It parses one gene prediction into a Bio::SeqFeature::Gene::Transcript- derived object. This module also implements the Bio::SeqAnalysisParserI interface, and thus can be used wherever such an object fits. See L<Bio::SeqAnalysisParserI>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp@gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Genscan; use strict; use Symbol; use Bio::Root::Root; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use base qw(Bio::Tools::AnalysisResult); my %ExonTags = ('Init' => 'Initial', 'Intr' => 'Internal', 'Term' => 'Terminal', 'Sngl' => ''); sub _initialize_state { my ($self,@args) = @_; # first call the inherited method! $self->SUPER::_initialize_state(@args); # our private state variables $self->{'_preds_parsed'} = 0; $self->{'_has_cds'} = 0; # array of pre-parsed predictions $self->{'_preds'} = []; # seq stack $self->{'_seqstack'} = []; } =head2 analysis_method Usage : $genscan->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /genscan/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /genscan/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $genscan->next_feature()) { # do something } Function: Returns the next gene structure prediction of the Genscan result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $genscan->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the Genscan result file. Call this method repeatedly until FALSE is returned. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my $gene; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions() unless $self->_predictions_parsed(); # get next gene structure $gene = $self->_prediction(); if($gene) { # fill in predicted protein, and if available the predicted CDS # my ($id, $seq); # use the seq stack if there's a seq on it my $seqobj = pop(@{$self->{'_seqstack'}}); if(! $seqobj) { # otherwise read from input stream ($id, $seq) = $self->_read_fasta_seq(); # there may be no sequence at all, or none any more if($id && $seq) { $seqobj = Bio::PrimarySeq->new('-seq' => $seq, '-display_id' => $id, '-alphabet' => "protein"); } } if($seqobj) { # check that prediction number matches the prediction number # indicated in the sequence id (there may be incomplete gene # predictions that contain only signals with no associated protein # and CDS, like promoters, poly-A sites etc) $gene->primary_tag() =~ /[^0-9]([0-9]+)$/; my $prednr = $1; if($seqobj->display_id() !~ /_predicted_\w+_$prednr\|/) { # this is not our sequence, so push back for next prediction push(@{$self->{'_seqstack'}}, $seqobj); } else { $gene->predicted_protein($seqobj); # CDS prediction, too? if($self->_has_cds()) { ($id, $seq) = $self->_read_fasta_seq(); $seqobj = Bio::PrimarySeq->new('-seq' => $seq, '-display_id' => $id, '-alphabet' => "dna"); $gene->predicted_cds($seqobj); } } } } return $gene; } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; my $gene; my $seqname; while(defined($_ = $self->_readline())) { if(/^\s*(\d+)\.(\d+)/) { # exon or signal my $prednr = $1; my $signalnr = $2; # not used presently if(! defined($gene)) { $gene = Bio::Tools::Prediction::Gene->new( '-primary' => "GenePrediction$prednr", '-source' => 'Genscan'); } # split into fields chomp(); my @flds = split(' ', $_); # create the feature object depending on the type of signal my $predobj; my $is_exon = grep {$_ eq $flds[1];} (keys(%ExonTags)); if($is_exon) { $predobj = Bio::Tools::Prediction::Exon->new(); } else { # PolyA site, or Promoter $predobj = Bio::SeqFeature::Generic->new(); } # set common fields $predobj->source_tag('Genscan'); $predobj->score($flds[$#flds]); $predobj->strand((($flds[2] eq '+') ? 1 : -1)); my ($start, $end) = @flds[(3,4)]; if($predobj->strand() == 1) { $predobj->start($start); $predobj->end($end); } else { $predobj->end($start); $predobj->start($end); } # add to gene structure (should be done only when start and end # are set, in order to allow for proper expansion of the range) if($is_exon) { # first, set fields unique to exons $predobj->start_signal_score($flds[8]); $predobj->end_signal_score($flds[9]); $predobj->coding_signal_score($flds[10]); $predobj->significance($flds[11]); $predobj->primary_tag($ExonTags{$flds[1]} . 'Exon'); $predobj->is_coding(1); # Figure out the frame of this exon. This is NOT the frame # given by Genscan, which is the absolute frame of the base # starting the first predicted complete codon. By comparing # to the absolute frame of the first base we can compute the # offset of the first complete codon to the first base of the # exon, which determines the frame of the exon. my $cod_offset; if($predobj->strand() == 1) { $cod_offset = $flds[6] - (($predobj->start()-1) % 3); # Possible values are -2, -1, 0, 1, 2. -1 and -2 correspond # to offsets 2 and 1, resp. Offset 3 is the same as 0. $cod_offset += 3 if($cod_offset < 1); } else { # On the reverse strand the Genscan frame also refers to # the first base of the first complete codon, but viewed # from forward, which is the third base viewed from # reverse. $cod_offset = $flds[6] - (($predobj->end()-3) % 3); # Possible values are -2, -1, 0, 1, 2. Due to the reverse # situation, {2,-1} and {1,-2} correspond to offsets # 1 and 2, resp. Offset 3 is the same as 0. $cod_offset -= 3 if($cod_offset >= 0); $cod_offset = -$cod_offset; } # Offsets 2 and 1 correspond to frame 1 and 2 (frame of exon # is the frame of the first base relative to the exon, or the # number of bases the first codon is missing). $predobj->frame(3 - $cod_offset); # then add to gene structure object $gene->add_exon($predobj, $ExonTags{$flds[1]}); } elsif($flds[1] eq 'PlyA') { $predobj->primary_tag("PolyAsite"); $gene->poly_A_site($predobj); } elsif($flds[1] eq 'Prom') { $predobj->primary_tag("Promoter"); $gene->add_promoter($predobj); } next; } if(/^\s*$/ && defined($gene)) { # current gene is completed $gene->seq_id($seqname); $self->_add_prediction($gene); $gene = undef; next; } if(/^(GENSCAN)\s+(\S+)/) { $self->analysis_method($1); $self->analysis_method_version($2); next; } if(/^Sequence\s+(\S+)\s*:/) { $seqname = $1; next; } if(/^Parameter matrix:\s+(\S+)/i) { $self->analysis_subject($1); next; } if(/^Predicted coding/) { $self->_has_cds(1); next; } /^>/ && do { # section of predicted sequences $self->_pushback($_); last; }; } $self->_predictions_parsed(1); } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_preds'}) && @{$self->{'_preds'}}); return shift(@{$self->{'_preds'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_preds'})) { $self->{'_preds'} = []; } push(@{$self->{'_preds'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } =head2 _has_cds Title : _has_cds() Usage : $obj->_has_cds() Function: Whether or not the result contains the predicted CDSs, too. Example : Returns : TRUE or FALSE =cut sub _has_cds { my ($self, $val) = @_; $self->{'_has_cds'} = $val if $val; if(! exists($self->{'_has_cds'})) { $self->{'_has_cds'} = 0; } return $self->{'_has_cds'}; } =head2 _read_fasta_seq Title : _read_fasta_seq() Usage : ($id,$seqstr) = $obj->_read_fasta_seq(); Function: Simple but specialised FASTA format sequence reader. Uses $self->_readline() to retrieve input, and is able to strip off the traling description lines. Example : Returns : An array of two elements. =cut sub _read_fasta_seq { my ($self) = @_; my ($id, $seq); local $/ = ">"; my $entry = $self->_readline(); if($entry) { $entry =~ s/^>//; # complete the entry if the first line came from a pushback buffer while($entry !~ />$/) { last unless $_ = $self->_readline(); $entry .= $_; } # delete everything onwards from an intervening empty line (at the # end there might be statistics stuff) $entry =~ s/\n\n.*$//s; # id and sequence if($entry =~ /^(\S+)\n([^>]+)/) { $id = $1; $seq = $2; } else { $self->throw("Can't parse Genscan predicted sequence entry"); } $seq =~ s/\s//g; # Remove whitespace } return ($id, $seq); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/GFF.pm��������������������������������������������������������������������000444��000765��000024�� 112235�12254227331� 16252� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::GFF # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by the Bioperl core team # # Copyright Matthew Pocock # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::GFF - A Bio::SeqAnalysisParserI compliant GFF format parser =head1 SYNOPSIS use Bio::Tools::GFF; # specify input via -fh or -file my $gffio = Bio::Tools::GFF->new(-fh => \*STDIN, -gff_version => 2); my $feature; # loop over the input stream while($feature = $gffio->next_feature()) { # do something with feature } $gffio->close(); # you can also obtain a GFF parser as a SeqAnalasisParserI in # HT analysis pipelines (see Bio::SeqAnalysisParserI and # Bio::Factory::SeqAnalysisParserFactory) my $factory = Bio::Factory::SeqAnalysisParserFactory->new(); my $parser = $factory->get_parser(-input => \*STDIN, -method => "gff"); while($feature = $parser->next_feature()) { # do something with feature } =head1 DESCRIPTION This class provides a simple GFF parser and writer. In the sense of a SeqAnalysisParser, it parses an input file or stream into SeqFeatureI objects, but is not in any way specific to a particular analysis program and the output that program produces. That is, if you can get your analysis program spit out GFF, here is your result parser. =head1 GFF3 AND SEQUENCE DATA GFF3 supports sequence data; see http://www.sequenceontology.org/gff3.shtml There are a number of ways to deal with this - If you call $gffio->ignore_sequence(1) prior to parsing the sequence data is ignored; this is useful if you just want the features. It avoids the memory overhead in building and caching sequences Alternatively, you can call either $gffio->get_seqs() Or $gffio->seq_id_by_h() At the B<end> of parsing to get either a list or hashref of Bio::Seq objects (see the documentation for each of these methods) Note that these objects will not have the features attached - you have to do this yourself, OR call $gffio->features_attached_to_seqs(1) PRIOR to parsing; this will ensure that the Seqs have the features attached; ie you will then be able to call $seq->get_SeqFeatures(); And use Bio::SeqIO methods Note that auto-attaching the features to seqs will incur a higher memory overhead as the features must be cached until the sequence data is found =head1 TODO Make a Bio::SeqIO class specifically for GFF3 with sequence data =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Matthew Pocock Email mrp-at-sanger.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason-at-biperl-dot-org Chris Mungall, cjm-at-fruitfly-dot-org Steffen Grossmann [SG], grossman at molgen.mpg.de Malcolm Cook, mec-at-stowers-institute.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::GFF; use vars qw($HAS_HTML_ENTITIES); use strict; use Bio::Seq::SeqFactory; use Bio::LocatableSeq; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::SeqAnalysisParserI Bio::Root::IO); my $i = 0; my %GFF3_ID_Tags = map { $_ => $i++ } qw(ID Parent Target); # for skipping data that may be represented elsewhere; currently, this is # only the score my %SKIPPED_TAGS = map { $_ => 1 } qw(score); =head2 new Title : new Usage : my $parser = Bio::Tools::GFF->new(-gff_version => 2, -file => "filename.gff"); or my $writer = Bio::Tools::GFF->new(-gff_version => 3, -file => ">filename.gff3"); Function: Creates a new instance. Recognized named parameters are -file, -fh, and -gff_version. Returns : a new object Args : named parameters -gff_version => [1,2,3] =cut { # make a class variable such that we can generate unique ID's over # a session, no matter how many instances of GFF.pm we make # since these have to be unique within the scope of a GFF file. my $gff3_featureID = 0; sub _incrementGFF3ID { my ($self) = @_; return ++ $gff3_featureID; } } sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); my ($gff_version, $noparse) = $self->_rearrange([qw(GFF_VERSION NOPARSE)],@args); # initialize IO $self->_initialize_io(@args); $self->_parse_header() unless $noparse; $gff_version ||= 2; if( ! $self->gff_version($gff_version) ) { $self->throw("Can't build a GFF object with the unknown version ". $gff_version); } $self->{'_first'} = 1; return $self; } =head2 _parse_header Title : _parse_header Usage : $gffio->_parse_header() Function: used to turn parse GFF header lines. currently produces Bio::LocatableSeq objects from ##sequence-region lines Returns : 1 on success Args : none =cut sub _parse_header{ my ($self) = @_; my @unhandled; local $^W = 0; # hide warnings when we try and parse from a file opened # for writing - there isn't really a better way to do # AFAIK - cannot detech if a FH is read or write. while(my $line = $self->_readline()){ my $handled = 0; next if /^\s+$/; if($line =~ /^\#\#sequence-region\s+(\S+)\s+(\S+)\s+(\S+)\s*/){ my($seqid,$start,$end) = ($1,$2,$3); push @{ $self->{'segments'} }, Bio::LocatableSeq->new( -id => unescape($seqid), -start => $start, -end => $end, -length => ($end - $start + 1), ## make the length explicit ); $handled = 1; } elsif($line =~ /^(\#\#feature-ontology)/) { #to be implemented $self->warn("$1 header tag parsing unimplemented"); } elsif($line =~ /^(\#\#attribute-ontology)/) { #to be implemented $self->warn("$1 header tag parsing unimplemented"); } elsif($line =~ /^(\#\#source-ontology)/) { #to be implemented $self->warn("$1 header tag parsing unimplemented"); } elsif($line =~ /^(\#\#\#)/) { #to be implemented $self->warn("$1 header tag parsing unimplemented"); } elsif($line =~ /^(\#\#FASTA)/) { # initial ##FASTA is optional - artemis does not use it $line = $self->_readline(); if ($line !~ /^\>(\S+)/) { $self->throw("##FASTA directive must be followed by fasta header, not: $line"); } } if ($line =~ /^\>(.*)/) { # seq data can be at header or footer my $seq = $self->_parse_sequence($line); if ($seq) { $self->_seq_by_id_h->{$seq->primary_id} = $seq; } } if(!$handled){ push @unhandled, $line; } #looks like the header is over! last unless $line =~ /^\#/; } foreach my $line (@unhandled){ $self->_pushback($line); } return 1; } sub _parse_sequence { my ($self, $line) = @_; if ($line =~ /^\>(.*)/) { my $seqid = $1; $seqid =~ s/\s+$//; my $desc = ''; if ($seqid =~ /(\S+)\s+(.*)/) { ($seqid, $desc) = ($1,$2); } my $res = ''; while (my $line = $self->_readline) { if ($line =~ /^\#/) { last; } if ($line =~ /^\>/) { $self->_pushback($line); last; } $line =~ s/\s//g; $res .= $line; } return if $self->ignore_sequence; my $seqfactory = Bio::Seq::SeqFactory->new('Bio::Seq'); my $seq = $seqfactory->create(-seq=>$res, -id=>$seqid, -desc=>$desc); $seq->accession_number($seqid); if ($self->features_attached_to_seqs) { my @feats = @{$self->_feature_idx_by_seq_id->{$seqid}}; $seq->add_SeqFeature($_) foreach @feats; @{$self->_feature_idx_by_seq_id->{$seqid}} = (); } return $seq; } else { $self->throw("expected fasta header, not: $line"); } } =head2 next_segment Title : next_segment Usage : my $seq = $gffio->next_segment; Function: Returns a Bio::LocatableSeq object corresponding to a GFF "##sequence-region" header line. Example : Returns : A Bio::LocatableSeq object, or undef if there are no more sequences. Args : none =cut sub next_segment{ my ($self,@args) = @_; return shift @{ $self->{'segments'} } if defined $self->{'segments'}; return; } =head2 next_feature Title : next_feature Usage : $seqfeature = $gffio->next_feature(); Function: Returns the next feature available in the input file or stream, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut sub next_feature { my ($self) = @_; my $gff_string; # be graceful about empty lines or comments, and make sure we return undef # if the input's consumed while(($gff_string = $self->_readline()) && defined($gff_string)) { if ($gff_string =~ /^\#\#\#/) { # all forward refs have been seen; TODO } next if($gff_string =~ /^\#/ || $gff_string =~ /^\s*$/ || $gff_string =~ m{^//}); while ($gff_string =~ /^\>(.+)/) { # fasta can be in header or footer my $seq = $self->_parse_sequence($gff_string); if ($seq) { $self->_seq_by_id_h->{$seq->primary_id} = $seq; $gff_string = $self->_readline; last unless $gff_string; } } last; } return unless $gff_string; my $feat = Bio::SeqFeature::Generic->new(); $self->from_gff_string($feat, $gff_string); if ($self->features_attached_to_seqs) { push(@{$self->_feature_idx_by_seq_id->{$feat->seq_id}}, $feat); } return $feat; } sub _feature_idx_by_seq_id { my $self = shift; $self->{__feature_idx_by_seq_id} = shift if @_; $self->{__feature_idx_by_seq_id} = {} unless $self->{__feature_idx_by_seq_id}; return $self->{__feature_idx_by_seq_id}; } =head2 from_gff_string Title : from_gff_string Usage : $gff->from_gff_string($feature, $gff_string); Function: Sets properties of a SeqFeatureI object from a GFF-formatted string. Interpretation of the string depends on the version that has been specified at initialization. This method is used by next_feature(). It actually dispatches to one of the version-specific (private) methods. Example : Returns : void Args : A Bio::SeqFeatureI implementing object to be initialized The GFF-formatted string to initialize it from =cut sub from_gff_string { my ($self, $feat, $gff_string) = @_; if($self->gff_version() == 1) { return $self->_from_gff1_string($feat, $gff_string); } elsif( $self->gff_version() == 3 ) { return $self->_from_gff3_string($feat, $gff_string); } else { return $self->_from_gff2_string($feat, $gff_string); } } =head2 _from_gff1_string Title : _from_gff1_string Usage : Function: Example : Returns : void Args : A Bio::SeqFeatureI implementing object to be initialized The GFF-formatted string to initialize it from =cut sub _from_gff1_string { my ($gff, $feat, $string) = @_; chomp $string; my ($seqname, $source, $primary, $start, $end, $score, $strand, $frame, @group) = split(/\t/, $string); if ( !defined $frame ) { $feat->throw("[$string] does not look like GFF to me"); } $frame = 0 unless( $frame =~ /^\d+$/); $feat->seq_id($seqname); $feat->source_tag($source); $feat->primary_tag($primary); $feat->start($start); $feat->end($end); $feat->frame($frame); if ( $score eq '.' ) { #$feat->score(undef); } else { $feat->score($score); } if ( $strand eq '-' ) { $feat->strand(-1); } if ( $strand eq '+' ) { $feat->strand(1); } if ( $strand eq '.' ) { $feat->strand(0); } foreach my $g ( @group ) { if ( $g =~ /(\S+)=(\S+)/ ) { my $tag = $1; my $value = $2; $feat->add_tag_value($1, $2); } else { $feat->add_tag_value('group', $g); } } } =head2 _from_gff2_string Title : _from_gff2_string Usage : Function: Example : Returns : void Args : A Bio::SeqFeatureI implementing object to be initialized The GFF2-formatted string to initialize it from =cut sub _from_gff2_string { my ($gff, $feat, $string) = @_; chomp($string); # according to the Sanger website, GFF2 should be single-tab # separated elements, and the free-text at the end should contain # text-translated tab symbols but no "real" tabs, so splitting on # \t is safe, and $attribs gets the entire attributes field to be # parsed later # sendu: but the tag value pair can (should?) be separated by a tab. The # 'no tabs' thing seems to apply only to the free text that is allowed for # the value my ($seqname, $source, $primary, $start, $end, $score, $strand, $frame, @attribs) = split(/\t+/, $string); my $attribs = join ' ', @attribs; if ( !defined $frame ) { $feat->throw("[$string] does not look like GFF2 to me"); } $feat->seq_id($seqname); $feat->source_tag($source); $feat->primary_tag($primary); $feat->start($start); $feat->end($end); $feat->frame($frame); if ( $score eq '.' ) { # $feat->score(undef); } else { $feat->score($score); } if ( $strand eq '-' ) { $feat->strand(-1); } if ( $strand eq '+' ) { $feat->strand(1); } if ( $strand eq '.' ) { $feat->strand(0); } # <Begin Inefficient Code from Mark Wilkinson> # this routine is necessay to allow the presence of semicolons in # quoted text Semicolons are the delimiting character for new # tag/value attributes. it is more or less a "state" machine, with # the "quoted" flag going up and down as we pass thorugh quotes to # distinguish free-text semicolon and hash symbols from GFF control # characters my $flag = 0; # this could be changed to a bit and just be twiddled my @parsed; # run through each character one at a time and check it # NOTE: changed to foreach loop which is more efficient in perl # --jasons for my $a ( split //, $attribs ) { # flag up on entering quoted text, down on leaving it if( $a eq '"') { $flag = ( $flag == 0 ) ? 1:0 } elsif( $a eq ';' && $flag ) { $a = "INSERT_SEMICOLON_HERE"} elsif( $a eq '#' && ! $flag ) { last } push @parsed, $a; } $attribs = join "", @parsed; # rejoin into a single string # <End Inefficient Code> # Please feel free to fix this and make it more "perlish" my @key_vals = split /;/, $attribs; # attributes are semicolon-delimited foreach my $pair ( @key_vals ) { # replace semicolons that were removed from free-text above. $pair =~ s/INSERT_SEMICOLON_HERE/;/g; # separate the key from the value my ($blank, $key, $values) = split /^\s*([\w\d]+)\s/, $pair; if( defined $values ) { my @values; # free text is quoted, so match each free-text block # and remove it from the $values string while ($values =~ s/"(.*?)"//){ # and push it on to the list of values (tags may have # more than one value... and the value may be undef) push @values, $1; } # and what is left over should be space-separated # non-free-text values my @othervals = split /\s+/, $values; foreach my $othervalue(@othervals){ # get rid of any empty strings which might # result from the split if (CORE::length($othervalue) > 0) {push @values, $othervalue} } foreach my $value(@values){ $feat->add_tag_value($key, $value); } } } } sub _from_gff3_string { my ($gff, $feat, $string) = @_; chomp($string); # according to the now nearly final GFF3 spec, columns should # be tab separated, allowing unescaped spaces to occur in # column 9 my ($seqname, $source, $primary, $start, $end, $score, $strand, $frame, $groups) = split(/\t/, $string); if ( ! defined $frame ) { $feat->throw("[$string] does not look like GFF3 to me"); } $feat->seq_id($seqname); $feat->source_tag($source); $feat->primary_tag($primary); $feat->start($start); $feat->end($end); $feat->frame($frame); if ( $score eq '.' ) { #$feat->score(undef); } else { $feat->score($score); } if ( $strand eq '-' ) { $feat->strand(-1); } if ( $strand eq '+' ) { $feat->strand(1); } if ( $strand eq '.' ) { $feat->strand(0); } my @groups = split(/\s*;\s*/, $groups); for my $group (@groups) { my ($tag,$value) = split /=/,$group; $tag = unescape($tag); my @values = map {unescape($_)} split /,/,$value; for my $v ( @values ) { $feat->add_tag_value($tag,$v); } } } # taken from Bio::DB::GFF sub unescape { my $v = shift; $v =~ tr/+/ /; $v =~ s/%([0-9a-fA-F]{2})/chr hex($1)/ge; return $v; } =head2 write_feature Title : write_feature Usage : $gffio->write_feature($feature); Function: Writes the specified SeqFeatureI object in GFF format to the stream associated with this instance. Returns : none Args : An array of Bio::SeqFeatureI implementing objects to be serialized =cut sub write_feature { my ($self, @features) = @_; return unless @features; if( $self->{'_first'} && $self->gff_version() == 3 ) { $self->_print("##gff-version 3\n"); } $self->{'_first'} = 0; foreach my $feature ( @features ) { $self->_print($self->gff_string($feature)."\n"); } } =head2 gff_string Title : gff_string Usage : $gffstr = $gffio->gff_string($feature); Function: Obtain the GFF-formatted representation of a SeqFeatureI object. The formatting depends on the version specified at initialization. This method is used by write_feature(). It actually dispatches to one of the version-specific (private) methods. Example : Returns : A GFF-formatted string representation of the SeqFeature Args : A Bio::SeqFeatureI implementing object to be GFF-stringified =cut sub gff_string{ my ($self, $feature) = @_; if($self->gff_version() == 1) { return $self->_gff1_string($feature); } elsif( $self->gff_version() == 3 ) { return $self->_gff3_string($feature); } elsif( $self->gff_version() == 2.5 ) { return $self->_gff25_string($feature); } else { return $self->_gff2_string($feature); } } =head2 _gff1_string Title : _gff1_string Usage : $gffstr = $gffio->_gff1_string Function: Example : Returns : A GFF1-formatted string representation of the SeqFeature Args : A Bio::SeqFeatureI implementing object to be GFF-stringified =cut sub _gff1_string{ my ($gff, $feat) = @_; my ($str,$score,$frame,$name,$strand); if( $feat->can('score') ) { $score = $feat->score(); } $score = '.' unless defined $score; if( $feat->can('frame') ) { $frame = $feat->frame(); } $frame = '.' unless defined $frame; $strand = $feat->strand(); if(! $strand) { $strand = "."; } elsif( $strand == 1 ) { $strand = '+'; } elsif ( $feat->strand == -1 ) { $strand = '-'; } if( $feat->can('seqname') ) { $name = $feat->seq_id(); $name ||= 'SEQ'; } else { $name = 'SEQ'; } $str = join("\t", $name, $feat->source_tag, $feat->primary_tag, $feat->start, $feat->end, $score, $strand, $frame); foreach my $tag ( $feat->get_all_tags ) { next if exists $SKIPPED_TAGS{$tag}; foreach my $value ( $feat->get_tag_values($tag) ) { $str .= " $tag=$value" if $value; } } return $str; } =head2 _gff2_string Title : _gff2_string Usage : $gffstr = $gffio->_gff2_string Function: Example : Returns : A GFF2-formatted string representation of the SeqFeature Args : A Bio::SeqFeatureI implementing object to be GFF2-stringified =cut sub _gff2_string{ my ($gff, $origfeat) = @_; my $feat; if ($origfeat->isa('Bio::SeqFeature::FeaturePair')){ $feat = $origfeat->feature2; } else { $feat = $origfeat; } my ($str1, $str2,$score,$frame,$name,$strand); if( $feat->can('score') ) { $score = $feat->score(); } $score = '.' unless defined $score; if( $feat->can('frame') ) { $frame = $feat->frame(); } $frame = '.' unless defined $frame; $strand = $feat->strand(); if(! $strand) { $strand = "."; } elsif( $strand == 1 ) { $strand = '+'; } elsif ( $feat->strand == -1 ) { $strand = '-'; } if( $feat->can('seqname') ) { $name = $feat->seq_id(); } $name ||= 'SEQ'; $str1 = join("\t", $name, $feat->source_tag(), $feat->primary_tag(), $feat->start(), $feat->end(), $score, $strand, $frame); # the routine below is the only modification I made to the original # ->gff_string routine (above) as on November 17th, 2000, the # Sanger webpage describing GFF2 format reads: "From version 2 # onwards, the attribute field must have a tag value structure # following the syntax used within objects in a .ace file, # flattened onto one line by semicolon separators. Tags must be # standard identifiers ([A-Za-z][A-Za-z0-9_]*). Free text values # must be quoted with double quotes". # MW my @group; foreach my $tag ( $feat->get_all_tags ) { next if exists $SKIPPED_TAGS{$tag}; my @v; foreach my $value ( $feat->get_tag_values($tag) ) { unless( defined $value && length($value) ) { # quote anything other than valid tag/value characters $value = '""'; } elsif ($value =~ /[^A-Za-z0-9_]/){ # substitute tab and newline chars by their UNIX equivalent $value =~ s/\t/\\t/g; $value =~ s/\n/\\n/g; $value = '"' . $value . '" '; } push @v, $value; # for this tag (allowed in GFF2 and .ace format) } push @group, "$tag ".join(" ", @v); } $str2 .= join(' ; ', @group); # Add Target information for Feature Pairs if( ! $feat->has_tag('Target') && # This is a bad hack IMHO ! $feat->has_tag('Group') && $origfeat->isa('Bio::SeqFeature::FeaturePair') ) { $str2 = sprintf("Target %s %d %d", $origfeat->feature1->seq_id, ( $origfeat->feature1->strand < 0 ? ( $origfeat->feature1->end, $origfeat->feature1->start) : ( $origfeat->feature1->start, $origfeat->feature1->end) )) . ($str2?" ; ".$str2:""); # need to put Target information before other tag/value pairs - mw } return $str1."\t".$str2; } =head2 _gff25_string Title : _gff25_string Usage : $gffstr = $gffio->_gff2_string Function: To get a format of GFF that is peculiar to Gbrowse/Bio::DB::GFF Example : Returns : A GFF2.5-formatted string representation of the SeqFeature Args : A Bio::SeqFeatureI implementing object to be GFF2.5-stringified =cut sub _gff25_string { my ($gff, $origfeat) = @_; my $feat; if ($origfeat->isa('Bio::SeqFeature::FeaturePair')){ $feat = $origfeat->feature2; } else { $feat = $origfeat; } my ($str1, $str2,$score,$frame,$name,$strand); if( $feat->can('score') ) { $score = $feat->score(); } $score = '.' unless defined $score; if( $feat->can('frame') ) { $frame = $feat->frame(); } $frame = '.' unless defined $frame; $strand = $feat->strand(); if(! $strand) { $strand = "."; } elsif( $strand == 1 ) { $strand = '+'; } elsif ( $feat->strand == -1 ) { $strand = '-'; } if( $feat->can('seqname') ) { $name = $feat->seq_id(); $name ||= 'SEQ'; } else { $name = 'SEQ'; } $str1 = join("\t", $name, $feat->source_tag(), $feat->primary_tag(), $feat->start(), $feat->end(), $score, $strand, $frame); my @all_tags = $feat->all_tags; my @group; my @firstgroup; if (@all_tags) { # only play this game if it is worth playing... foreach my $tag ( @all_tags ) { my @v; foreach my $value ( $feat->get_tag_values($tag) ) { next if exists $SKIPPED_TAGS{$tag}; unless( defined $value && length($value) ) { $value = '""'; } elsif ($value =~ /[^A-Za-z0-9_]/){ $value =~ s/\t/\\t/g; # substitute tab and newline # characters $value =~ s/\n/\\n/g; # to their UNIX equivalents $value = '"' . $value . '" '; } # if the value contains # anything other than valid # tag/value characters, then # quote it push @v, $value; # for this tag (allowed in GFF2 and .ace format) } if (($tag eq 'Group') || ($tag eq 'Target')){ # hopefully we wont get both... push @firstgroup, "$tag ".join(" ", @v); } else { push @group, "$tag ".join(" ", @v); } } } $str2 = join(' ; ', (@firstgroup, @group)); # Add Target information for Feature Pairs if( ! $feat->has_tag('Target') && # This is a bad hack IMHO ! $feat->has_tag('Group') && $origfeat->isa('Bio::SeqFeature::FeaturePair') ) { $str2 = sprintf("Target %s ; tstart %d ; tend %d", $origfeat->feature1->seq_id, ( $origfeat->feature1->strand < 0 ? ( $origfeat->feature1->end, $origfeat->feature1->start) : ( $origfeat->feature1->start, $origfeat->feature1->end) )) . ($str2?" ; ".$str2:""); # need to put the target info before other tag/value pairs - mw } return $str1 . "\t". $str2; } =head2 _gff3_string Title : _gff3_string Usage : $gffstr = $gffio->_gff3_string Function: Example : Returns : A GFF3-formatted string representation of the SeqFeature Args : A Bio::SeqFeatureI implementing object to be GFF3-stringified =cut sub _gff3_string { my ($gff, $origfeat) = @_; my $feat; if ($origfeat->isa('Bio::SeqFeature::FeaturePair')){ $feat = $origfeat->feature2; } else { $feat = $origfeat; } my $ID = $gff->_incrementGFF3ID(); my ($score,$frame,$name,$strand); if( $feat->can('score') ) { $score = $feat->score(); } $score = '.' unless defined $score; if( $feat->can('frame') ) { $frame = $feat->frame(); } $frame = '1' unless defined $frame; $strand = $feat->strand(); if(! $strand) { $strand = "."; } elsif( $strand == 1 ) { $strand = '+'; } elsif ( $feat->strand == -1 ) { $strand = '-'; } if( $feat->can('seqname') ) { $name = $feat->seq_id(); $name ||= 'SEQ'; } else { $name = 'SEQ'; } my @groups; # force leading ID and Parent tags my @all_tags = grep { ! exists $GFF3_ID_Tags{$_} } $feat->all_tags; for my $t ( sort { $GFF3_ID_Tags{$b} <=> $GFF3_ID_Tags{$a} } keys %GFF3_ID_Tags ) { unshift @all_tags, $t if $feat->has_tag($t); } for my $tag ( @all_tags ) { next if exists $SKIPPED_TAGS{$tag}; # next if $tag eq 'Target'; if ($tag eq 'Target' && ! $origfeat->isa('Bio::SeqFeature::FeaturePair')){ # simple Target,start,stop my($target_id, $b,$e,$strand) = $feat->get_tag_values($tag); next unless(defined($e) && defined($b) && $target_id); ($b,$e)= ($e,$b) if(defined $strand && $strand<0); $target_id =~ s/([\t\n\r%&\=;,])/sprintf("%%%X",ord($1))/ge; push @groups, sprintf("Target=%s %d %d", $target_id,$b,$e); next; } my $valuestr; # a string which will hold one or more values # for this tag, with quoted free text and # space-separated individual values. my @v; for my $value ( $feat->get_tag_values($tag) ) { if( defined $value && length($value) ) { #$value =~ tr/ /+/; #spaces are allowed now if ( ref $value eq 'Bio::Annotation::Comment') { $value = $value->text; } if ($value =~ /[^a-zA-Z0-9\,\;\=\.:\%\^\*\$\@\!\+\_\?\-]/) { $value =~ s/\t/\\t/g; # substitute tab and newline # characters $value =~ s/\n/\\n/g; # to their UNIX equivalents # Unescaped quotes are not allowed in GFF3 # $value = '"' . $value . '"'; } $value =~ s/([\t\n\r%&\=;,])/sprintf("%%%X",ord($1))/ge; } else { # if it is completely empty, then just make empty double quotes $value = '""'; } push @v, $value; } # can we figure out how to improve this? $tag = lcfirst($tag) unless ( $tag =~ /^(ID|Name|Alias|Parent|Gap|Target|Derives_from|Note|Dbxref|Ontology_term)$/); push @groups, "$tag=".join(",",@v); } # Add Target information for Feature Pairs if( $feat->has_tag('Target') && ! $feat->has_tag('Group') && $origfeat->isa('Bio::SeqFeature::FeaturePair') ) { my $target_id = $origfeat->feature1->seq_id; $target_id =~ s/([\t\n\r%&\=;,])/sprintf("%%%X",ord($1))/ge; push @groups, sprintf("Target=%s %d %d", $target_id, ( $origfeat->feature1->strand < 0 ? ( $origfeat->feature1->end, $origfeat->feature1->start) : ( $origfeat->feature1->start, $origfeat->feature1->end) )); } # unshift @groups, "ID=autogenerated$ID" unless ($feat->has_tag('ID')); if ( $feat->can('name') && defined($feat->name) ) { # such as might be for Bio::DB::SeqFeature unshift @groups, 'Name=' . $feat->name; } my $gff_string = ""; if ($feat->location->isa("Bio::Location::SplitLocationI")) { my @locs = $feat->location->each_Location; foreach my $loc (@locs) { $gff_string .= join("\t", $name, $feat->source_tag() || '.', $feat->primary_tag(), $loc->start(), $loc->end(), $score, $strand, $frame, join(';', @groups)) . "\n"; } chop $gff_string; return $gff_string; } else { $gff_string = join("\t", $name, $feat->source_tag() || '.', $feat->primary_tag(), $feat->start(), $feat->end(), $score, $strand, $frame, join(';', @groups)); } return $gff_string; } =head2 gff_version Title : _gff_version Usage : $gffversion = $gffio->gff_version Function: Example : Returns : The GFF version this parser will accept and emit. Args : none =cut sub gff_version { my ($self, $value) = @_; if(defined $value && grep {$value == $_ } ( 1, 2, 2.5, 3)) { $self->{'GFF_VERSION'} = $value; } return $self->{'GFF_VERSION'}; } # Make filehandles =head2 newFh Title : newFh Usage : $fh = Bio::Tools::GFF->newFh(-file=>$filename,-format=>'Format') Function: does a new() followed by an fh() Example : $fh = Bio::Tools::GFF->newFh(-file=>$filename,-format=>'Format') $feature = <$fh>; # read a feature object print $fh $feature; # write a feature object Returns : filehandle tied to the Bio::Tools::GFF class Args : =cut sub newFh { my $class = shift; return unless my $self = $class->new(@_); return $self->fh; } =head2 fh Title : fh Usage : $obj->fh Function: Example : $fh = $obj->fh; # make a tied filehandle $feature = <$fh>; # read a feature object print $fh $feature; # write a feature object Returns : filehandle tied to Bio::Tools::GFF class Args : none =cut sub fh { my $self = shift; my $class = ref($self) || $self; my $s = Symbol::gensym; tie $$s,$class,$self; return $s; } # This accessor is used for accessing the Bio::Seq objects from a GFF3 # file; if the file you are using has no sequence data you can ignore # this accessor # This accessor returns a hash reference containing Bio::Seq objects, # indexed by Bio::Seq->primary_id sub _seq_by_id_h { my $self = shift; return $self->{'_seq_by_id_h'} = shift if @_; $self->{'_seq_by_id_h'} = {} unless $self->{'_seq_by_id_h'}; return $self->{'_seq_by_id_h'}; } =head2 get_seqs Title : get_seqs Usage : Function: Returns all Bio::Seq objects populated by GFF3 file Example : Returns : Args : =cut sub get_seqs { my ($self,@args) = @_; return values %{$self->_seq_by_id_h}; } =head2 features_attached_to_seqs Title : features_attached_to_seqs Usage : $obj->features_attached_to_seqs(1); Function: For use with GFF3 containg sequence only Setting this B<before> parsing ensures that all Bio::Seq object created will have the appropriate features added to them defaults to false (off) Note that this mode will incur higher memory usage because features will have to be cached until the relevant feature comes along Example : Returns : value of features_attached_to_seqs (a boolean) Args : on set, new value (a boolean, optional) =cut sub features_attached_to_seqs{ my $self = shift; return $self->{'_features_attached_to_seqs'} = shift if @_; return $self->{'_features_attached_to_seqs'}; } =head2 ignore_sequence Title : ignore_sequence Usage : $obj->ignore_sequence(1); Function: For use with GFF3 containg sequence only Setting this B<before> parsing means that all sequence data will be ignored Example : Returns : value of ignore_sequence (a boolean) Args : on set, new value (a boolean, optional) =cut sub ignore_sequence{ my $self = shift; return $self->{'_ignore_sequence'} = shift if @_; return $self->{'_ignore_sequence'}; } sub DESTROY { my $self = shift; $self->close(); } sub TIEHANDLE { my ($class,$val) = @_; return bless {'gffio' => $val}, $class; } sub READLINE { my $self = shift; return $self->{'gffio'}->next_feature() unless wantarray; my (@list, $obj); push @list, $obj while $obj = $self->{'gffio'}->next_feature(); return @list; } sub PRINT { my $self = shift; $self->{'gffio'}->write_feature(@_); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Glimmer.pm����������������������������������������������������������������000444��000765��000024�� 45042�12254227320� 17223� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Glimmer # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Glimmer - parser for Glimmer 2.X/3.X prokaryotic and GlimmerM/GlimmerHMM eukaryotic gene predictions =head1 SYNOPSIS use Bio::Tools::Glimmer; # file my $parser = Bio::Tools::Glimmer->new(-file => $file); # filehandle: $parser = Bio::Tools::Glimmer->new( -fh => \*INPUT ); # provide a sequence identifier (Glimmer 2.X) my $parser = Bio::Tools::Glimmer->new(-file => $file, -seqname => seqname); # force format (override automatic detection) my $parser = Bio::Tools::Glimmer->new(-file => $file, -format => 'GlimmerM'); # parse the results # note: this class is-a Bio::Tools::AnalysisResult which implements # Bio::SeqAnalysisParserI, i.e., $glimmer->next_feature() is the same while(my $gene = $parser->next_prediction()) { # For eukaryotic input (GlimmerM/GlimmerHMM), $gene will be an instance # of Bio::Tools::Prediction::Gene, which inherits off # Bio::SeqFeature::Gene::Transcript, and $gene->exons() will return an # array of Bio::Tools::Prediction::Exon objects. # For prokaryotic input (Glimmer2.X/Glimmer3.X), $gene will be an # instance of Bio::SeqFeature::Generic # all exons (eukaryotic only): @exon_arr = $gene->exons(); # initial exons only @init_exons = $gene->exons('Initial'); # internal exons only @intrl_exons = $gene->exons('Internal'); # terminal exons only @term_exons = $gene->exons('Terminal'); } =head1 DESCRIPTION This is a module for parsing Glimmer, GlimmerM and GlimmerHMM predictions. It will create gene objects from the prediction report which can be attached to a sequence using Bioperl objects, or output as GFF suitable for loading into Bio::DB::GFF for use with Gbrowse. Glimmer is open source and available at L<http://www.cbcb.umd.edu/software/glimmer/>. GlimmerM is open source and available at L<http://www.tigr.org/software/glimmerm/>. GlimmerHMM is open source and available at L<http://www.cbcb.umd.edu/software/GlimmerHMM/>. Note that Glimmer 2.X will only process the first sequence in a fasta file, and the prediction report does not contain any sort of sequence identifier Note that Glimmer 3.X produces two output files. This module only parses the .predict file. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Torsten Seemann Mark Johnson =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Glimmer; use strict; use Bio::Factory::FTLocationFactory; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my($self,@args) = @_; # first call the inherited method! my $make = $self->SUPER::_initialize_state(@args); $self->{'_preds_parsed'} = 0; # array of pre-parsed predictions $self->{'_preds'} = []; } =head2 new Title : new Usage : my $obj = Bio::Tools::Glimmer->new(); Function: Builds a new Bio::Tools::Glimmer object Returns : an instance of Bio::Tools::Glimmer Args : format ('Glimmer', 'GlimmerM', 'GlimmerHMM'), seqname =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($format, $seqname, $seqlength, $detail) = $self->_rearrange([qw(FORMAT SEQNAME SEQLENGTH DETAIL)], @args); # override automagic format detection if (defined($format) && (($format eq 'Glimmer') || ($format eq 'GlimmerM') || ($format eq 'GlimmerHMM')) ) { $self->_format($format); } if (defined($detail)) { $self->_format('Glimmer'); $self->_detail_file($detail); } # hardwire seq_id when creating gene and exon objects (Glimmer 2.X) $self->_seqname($seqname) if defined($seqname); # store the length of the input sequence (Glimmer 2.X) $self->_seqlength($seqlength) if defined($seqlength); return $self; } =head2 analysis_method Usage : $glimmer->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /glimmer/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /glimmer/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $glimmer->next_feature()) { # do something } Function: Returns the next gene structure prediction of the Glimmer result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $glimmer->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the Glimmer result file. Call this method repeatedly until FALSE is returned. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my $gene; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions() unless $self->_predictions_parsed(); # get next gene structure $gene = $self->_prediction(); return $gene; } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; my %method = ( 'Glimmer' => '_parse_prokaryotic', 'GlimmerM' => '_parse_eukaryotic', 'GlimmerHMM' => '_parse_eukaryotic', '_DEFAULT_' => '_parse_eukaryotic', ); my $format = $self->_format(); if (!$format) { while (my $line = $self->_readline()) { if ( $line =~ /^Glimmer\S*\s+\(Version\s*\S+\)/ ) { $format = 'GlimmerM'; $self->_pushback($line); last; } elsif ( $line =~ /^Glimmer\S*$/ ) { $format = 'GlimmerHMM'; $self->_pushback($line); last; } elsif ($line =~ /^Putative Genes:$/) { $format = 'Glimmer'; $self->_pushback($line); last; } elsif ($line =~ /^>(\S+)/) { $format = 'Glimmer'; $self->_pushback($line); last; } } } my $method = (exists($method{$format})) ? $method{$format} : $method{'_DEFAULT_'}; return $self->$method(); } =head2 _parse_eukaryotic Title : _parse_eukaryotic() Usage : $obj->_parse_eukaryotic() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_eukaryotic { my ($self) = @_; my ($gene,$seqname,$seqlen,$source,$lastgenenum); while(defined($_ = $self->_readline())) { if( /^(Glimmer\S*)\s+\(Version\s*(\S+)\)/ ) { $source = "$1_$2"; next; } elsif( /^(GlimmerHMM\S*)$/ ) { # GlimmerHMM has no version $source = $1; next; } elsif(/^Sequence name:\s+(.+)$/ ) { $seqname = $1; next; } elsif( /^Sequence length:\s+(\S+)/ ) { $seqlen = $1; next; } elsif( m/^(Predicted genes)|(Gene)|\s+\#/ || /^\s+$/ ) { next; } elsif( # GlimmerM/HMM gene-exon prediction line /^\s+(\d+)\s+ # gene num (\d+)\s+ # exon num ([\+\-])\s+ # strand (\S+)\s+ # exon type (\d+)\s+(\d+) # exon start, end \s+(\d+) # exon length /ox ) { my ($genenum,$exonnum,$strand,$type,$start,$end,$len) = ( $1,$2,$3,$4,$5,$6,$7); if( ! $lastgenenum || $lastgenenum != $genenum) { $self->_add_prediction($gene) if ( $gene ); $gene = Bio::Tools::Prediction::Gene->new ( '-seq_id' => $seqname, '-primary_tag' => "gene", '-source_tag' => $source, '-tag' => { 'Group' => "GenePrediction$genenum"}, ); } my $exon = Bio::Tools::Prediction::Exon->new ('-seq_id' => $seqname, '-start' => $start, '-end' => $end, '-strand' => $strand eq '-' ? '-1' : '1', '-source_tag' => $source, '-primary_tag'=> 'exon', '-tag' => { 'Group' => "GenePrediction$genenum"}, ); $gene->add_exon($exon,lc($type)); $lastgenenum = $genenum; } } $self->_add_prediction($gene) if( $gene ); $self->_predictions_parsed(1); } =head2 _parse_prokaryotic Title : _parse_prokaryotic() Usage : $obj->_parse_prokaryotic() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_prokaryotic { my ($self) = @_; # default value, possibly overriden later my $source = 'Glimmer'; # Store the sequence length(s) here, either from the # seqlength arg to the constructor, or from the # Glimmer 3.X detail file my %seqlength = ( ); # Glimmer 2.X does not provide a sequence identifer # in the prediction report (will default to unknown # if not specified in the seqname arg to the # constructor # # Glimmer 2.X does not report the length of the # input sequence, either (will default to undef # if not specified in the seqlength arg to the # constructor my $seqname = $self->_seqname(); my $seqlength = $self->_seqlength(); if (defined($seqlength)) { $seqlength{$seqname} = $seqlength } # Parse the detail file, if we have one (Glimmer 3.X) my $detail_file = $self->_detail_file(); if (defined($detail_file)) { my $io = Bio::Root::IO->new(-file => $detail_file); my $seqname; while (defined($_ = $io->_readline())) { if ($_ =~ /^>(\S+)/) { $seqname = $1; next; } if (defined($seqname) && ($_ =~ /^Sequence length = (\d+)$/)) { $seqlength{$seqname} = $1; next; } } } my $location_factory = Bio::Factory::FTLocationFactory->new(); while(defined($_ = $self->_readline())) { # Glimmer 3.X does provide a sequence identifier - # beware whitespace at the end (comes through from # the fasta file) if ($_ =~ /^Putative Genes:$/) { $source = 'Glimmer_2.X'; next; } # Glimmer 3.X sequence identifier elsif ($_ =~ /^>(\S+)/) { $seqname = $1; $seqlength = $seqlength{$seqname}; $source = 'Glimmer_3.X'; next; } elsif ( # Glimmer 2.X prediction (/^\s+(\d+)\s+ # gene num (\d+)\s+(\d+)\s+ # start, end \[([\+\-])(\d{1})\s+ # strand, frame /ox ) || # Glimmer 3.X prediction (/^[^\d]+(\d+)\s+ # orf (numeric portion) (\d+)\s+(\d+)\s+ # start, end ([\+\-])(\d{1})\s+ # strand, frame ([\d\.]+) # score /ox)) { my ($genenum,$start,$end,$strand,$frame,$score) = ( $1,$2,$3,$4,$5,$6 ); my $circular_prediction = 0; # Check for a circular prediction before we # start fiddling with the coordinates if ($strand eq '+') { if ($start > $end) { $circular_prediction = 1; } } else { if ($start < $end) { $circular_prediction = 1; } } if ($circular_prediction) { unless (defined($seqlength)) { $self->throw("need to know the sequence length to handle wraparound genes"); } } # Glimmer 2.X predictions do not include # the stop codon - this might extend the # prediction off either end of the sequence. # This works fine even on circular/wraparound # predictions. if ($source eq 'Glimmer_2.X') { if ($strand eq '+') { $end += 3; } else { $end -= 3; } } # We might have extended a Glimmer 2.X prediction # beyond the boundaries of the input sequence. # Also, Glimmer 3.X (with -X) will output predictions # with coordinates less than 1 or greater than the # length of the sequence. my ($fst, $fend); foreach my $coord ($start, $end) { if ($coord < 1) { $coord = '<1'; $fst++; } elsif (defined($seqlength) && ($coord > $seqlength)) { $coord = ">$seqlength"; $fend++; } } my $location_string; if ($circular_prediction) { if ($strand eq '+') { $location_string = "join($start..$seqlength,1..$end)"; } else { $location_string = "join($start..1,$seqlength..$end)"; } } else { # start must always be less than end for gene locations if ($strand eq '-' && !$fst && !$fend && $start > $end) { ($start, $end) = ($end, $start); } $location_string = "$start..$end"; } my $location_object = $location_factory->from_string($location_string); # convert glimmer's frame range from 1-3 to SeqFeature's 0-2. $frame--; my $gene = Bio::SeqFeature::Generic->new ( '-seq_id' => $seqname, '-location' => $location_object, '-strand' => $strand eq '-' ? '-1' : '1', '-frame' => $frame, '-source_tag' => $source, '-display_name' => "orf$genenum", '-primary_tag'=> 'gene', '-tag' => { 'Group' => "GenePrediction_$genenum"}, '-score' => $score || undef ); $self->_add_prediction($gene) } } $self->_predictions_parsed(1); } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_preds'}) && @{$self->{'_preds'}}); return shift(@{$self->{'_preds'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_preds'})) { $self->{'_preds'} = []; } push(@{$self->{'_preds'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } =head2 _seqname Title : _seqname Usage : $obj->_seqname($seqname) Function: internal (for Glimmer 2.X) Example : Returns : String =cut sub _seqname { my ($self, $val) = @_; $self->{'_seqname'} = $val if $val; if(! exists($self->{'_seqname'})) { $self->{'_seqname'} = 'unknown'; } return $self->{'_seqname'}; } =head2 _seqlength Title : _seqlength Usage : $obj->_seqlength($seqlength) Function: internal (for Glimmer 2.X) Example : Returns : String =cut sub _seqlength { my ($self, $val) = @_; $self->{'_seqlength'} = $val if $val; return $self->{'_seqlength'}; } =head2 _format Title : _format Usage : $obj->_format($format) Function: internal Example : Returns : String =cut sub _format { my ($self, $val) = @_; $self->{'_format'} = $val if $val; return $self->{'_format'}; } =head2 _detail_file Title : _detail_file Usage : $obj->_detail_file($filename) Function: internal (for Glimmer 3.X) Example : Returns : String =cut sub _detail_file { my ($self, $val) = @_; $self->{'_detail_file'} = $val if $val; return $self->{'_detail_file'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Grail.pm������������������������������������������������������������������000444��000765��000024�� 14306�12254227317� 16672� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Grail # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Grail - Results of one Grail run =head1 SYNOPSIS $grail = Bio::Tools::Grail->new(-file => 'result.grail'); # filehandle: $grail = Bio::Tools::Grail->new( -fh => \*INPUT ); # parse the results while($gene = $grail->next_prediction()) { # $gene is an instance of Bio::Tools::Prediction::Gene # $gene->exons() returns an array of # Bio::Tools::Prediction::Exon objects # all exons: @exon_arr = $gene->exons(); # initial exons only @init_exons = $gene->exons('Initial'); # internal exons only @intrl_exons = $gene->exons('Internal'); # terminal exons only @term_exons = $gene->exons('Terminal'); # singleton exons only -- should be same as $gene->exons() because # there are no other exons supposed to exist in this structure @single_exons = $gene->exons('Single'); } # essential if you gave a filename at initialization (otherwise the file # will stay open) $genscan->close(); =head1 DESCRIPTION The Grail module provides a parser for Grail gene structure prediction output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Grail; use strict; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use Symbol; use base qw(Bio::Root::IO Bio::Root::Root); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_prediction Title : next_prediction Usage : while($gene = $grail->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the Grail result file. Call this method repeatedly until FALSE is returned. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; # get next gene structure my $gene = $self->_prediction(); if($gene) { # fill in predicted protein, and if available the predicted CDS # my ($id, $seq); # use the seq stack if there's a seq on it my $seqobj = pop(@{$self->{'_seqstack'}}); if(! $seqobj) { # otherwise read from input stream ($id, $seq) = $self->_read_fasta_seq(); $seqobj = Bio::PrimarySeq->new('-seq' => $seq, '-display_id' => $id, '-alphabet' => "protein"); } # check that prediction number matches the prediction number # indicated in the sequence id (there may be incomplete gene # predictions that contain only signals with no associated protein # and CDS, like promoters, poly-A sites etc) $gene->primary_tag() =~ /[^0-9]([0-9]+)$/; my $prednr = $1; if($seqobj->display_id() !~ /_predicted_\w+_$prednr\|/) { # this is not our sequence, so push back for the next prediction push(@{$self->{'_seqstack'}}, $seqobj); } else { $gene->predicted_protein($seqobj); # CDS prediction, too? if($self->_has_cds()) { ($id, $seq) = $self->_read_fasta_seq(); $seqobj = Bio::PrimarySeq->new('-seq' => $seq, '-display_id' => $id, '-alphabet' => "dna"); $gene->predicted_cds($seqobj); } } } return $gene; } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; # code needs to go here $self->_predictions_parsed(1); } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_preds'}) && @{$self->{'_preds'}}); return shift(@{$self->{'_preds'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_preds'})) { $self->{'_preds'} = []; } push(@{$self->{'_preds'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } =head2 _has_cds Title : _has_cds() Usage : $obj->_has_cds() Function: Whether or not the result contains the predicted CDSs, too. Example : Returns : TRUE or FALSE =cut sub _has_cds { my ($self, $val) = @_; $self->{'_has_cds'} = $val if $val; if(! exists($self->{'_has_cds'})) { $self->{'_has_cds'} = 0; } return $self->{'_has_cds'}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/GuessSeqFormat.pm���������������������������������������������������������000444��000765��000024�� 53544�12254227336� 20554� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#------------------------------------------------------------------ # # BioPerl module Bio::Tools::GuessSeqFormat # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Andreas Kähäri, andreas.kahari@ebi.ac.uk # # You may distribute this module under the same terms as perl itself #------------------------------------------------------------------ =encoding utf-8 =head1 NAME Bio::Tools::GuessSeqFormat - Module for determining the sequence format of the contents of a file, a string, or through a filehandle. =head1 SYNOPSIS # To guess the format of a flat file, given a filename: my $guesser = Bio::Tools::GuessSeqFormat->new( -file => $filename ); my $format = $guesser->guess; # To guess the format from an already open filehandle: my $guesser = Bio::Tools::GuessSeqFormat->new( -fh => $filehandle ); my $format = $guesser->guess; # If the filehandle is seekable (STDIN isn't), it will be # returned to its original position. # To guess the format of one or several lines of text (with # embedded newlines): my $guesser = Bio::Tools::GuessSeqFormat->new( -text => $linesoftext ); my $format = $guesser->guess; # To create a Bio::Tools::GuessSeqFormat object and set the # filename, filehandle, or line to parse afterwards: my $guesser = Bio::Tools::GuessSeqFormat->new(); $guesser->file($filename); $guesser->fh($filehandle); $guesser->text($linesoftext); # To guess in one go, given e.g. a filename: my $format = Bio::Tools::GuessSeqFormat->new( -file => $filename )->guess; =head1 DESCRIPTION Bio::Tools::GuessSeqFormat tries to guess the format ("swiss", "pir", "fasta" etc.) of the sequence or MSA in a file, in a scalar, or through a filehandle. The guess() method of a Bio::Tools::GuessSeqFormat object will examine the data, line by line, until it finds a line to which only one format can be assigned. If no conclusive guess can be made, undef is returned. If the Bio::Tools::GuessSeqFormat object is given a filehandle which is seekable, it will be restored to its original position on return from the guess() method. =head2 Formats Tests are currently implemented for the following formats: =over =item * ACeDB ("ace") =item * Blast ("blast") =item * ClustalW ("clustalw") =item * Codata ("codata") =item * EMBL ("embl") =item * FastA sequence ("fasta") =item * FastQ sequence ("fastq") =item * FastXY/FastA alignment ("fastxy") =item * Game XML ("game") =item * GCG ("gcg") =item * GCG Blast ("gcgblast") =item * GCG FastA ("gcgfasta") =item * GDE ("gde") =item * Genbank ("genbank") =item * Genscan ("genscan") =item * GFF ("gff") =item * HMMER ("hmmer") =item * PAUP/NEXUS ("nexus") =item * Phrap assembly file ("phrap") =item * NBRF/PIR ("pir") =item * Mase ("mase") =item * Mega ("mega") =item * GCG/MSF ("msf") =item * Pfam ("pfam") =item * Phylip ("phylip") =item * Prodom ("prodom") =item * Raw ("raw") =item * RSF ("rsf") =item * Selex ("selex") =item * Stockholm ("stockholm") =item * Swissprot ("swiss") =item * Tab ("tab") =item * Variant Call Format ("vcf") =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Andreas KE<228>hE<228>ri, andreas.kahari@ebi.ac.uk =head1 CONTRIBUTORS Heikki LehvE<228>slaiho, heikki-at-bioperl-dot-org Mark A. Jensen, maj-at-fortinbras-dot-us =cut package Bio::Tools::GuessSeqFormat; use strict; use warnings; use base qw(Bio::Root::Root); =head1 METHODS Methods available to Bio::Tools::GuessSeqFormat objects are described below. Methods with names beginning with an underscore are considered to be internal. =cut =head2 new Title : new Usage : $guesser = Bio::Tools::GuessSeqFormat->new( ... ); Function : Creates a new object. Example : See SYNOPSIS. Returns : A new object. Arguments : -file The filename of the file whose format is to be guessed, or -fh An already opened filehandle from which a text stream may be read, or -text A scalar containing one or several lines of text with embedded newlines. If more than one of the above arguments are given, they are tested in the order -text, -file, -fh, and the first available argument will be used. =cut sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args); my $attr; my $value; while (@args) { $attr = shift @args; $attr = lc $attr; $value = shift @args; $self->{$attr} = $value; } return $self; } =head2 file Title : file Usage : $guesser->file($filename); $filename = $guesser->file; Function : Gets or sets the current filename associated with an object. Returns : The new filename. Arguments : The filename of the file whose format is to be guessed. A call to this method will clear the current filehandle and the current lines of text associated with the object. =cut sub file { # Sets and/or returns the filename to use. my $self = shift; my $file = shift; if (defined $file) { # Set the active filename, and clear the filehandle and # text line, if present. $self->{-file} = $file; $self->{-fh} = $self->{-text} = undef; } return $self->{-file}; } =head2 fh Title : fh Usage : $guesser->fh($filehandle); $filehandle = $guesser->fh; Function : Gets or sets the current filehandle associated with an object. Returns : The new filehandle. Arguments : An already opened filehandle from which a text stream may be read. A call to this method will clear the current filename and the current lines of text associated with the object. =cut sub fh { # Sets and/or returns the filehandle to use. my $self = shift; my $fh = shift; if (defined $fh) { # Set the active filehandle, and clear the filename and # text line, if present. $self->{-fh} = $fh; $self->{-file} = $self->{-text} = undef; } return $self->{-fh}; } =head2 text Title : text Usage : $guesser->text($linesoftext); $linesofext = $guesser->text; Function : Gets or sets the current text associated with an object. Returns : The new lines of texts. Arguments : A scalar containing one or several lines of text, including embedded newlines. A call to this method will clear the current filename and the current filehandle associated with the object. =cut sub text { # Sets and/or returns the text lines to use. my $self = shift; my $text = shift; if (defined $text) { # Set the active text lines, and clear the filehandle # and filename, if present. $self->{-text} = $text; $self->{-fh} = $self->{-file} = undef; } return $self->{-text}; } =head2 guess Title : guess Usage : $format = $guesser->guess; @format = $guesser->guess; # if given a line of text Function : Guesses the format of the data accociated with the object. Returns : A format string such as "swiss" or "pir". If a format can not be found, undef is returned. Arguments : None. If the object is associated with a filehandle and if that filehandle is searchable, the position of the filehandle will be returned to its original position before the method returns. =cut our %formats = ( ace => { test => \&_possibly_ace }, blast => { test => \&_possibly_blast }, bowtie => { test => \&_possibly_bowtie }, clustalw => { test => \&_possibly_clustalw }, codata => { test => \&_possibly_codata }, embl => { test => \&_possibly_embl }, fasta => { test => \&_possibly_fasta }, fastq => { test => \&_possibly_fastq }, fastxy => { test => \&_possibly_fastxy }, game => { test => \&_possibly_game }, gcg => { test => \&_possibly_gcg }, gcgblast => { test => \&_possibly_gcgblast }, gcgfasta => { test => \&_possibly_gcgfasta }, gde => { test => \&_possibly_gde }, genbank => { test => \&_possibly_genbank }, genscan => { test => \&_possibly_genscan }, gff => { test => \&_possibly_gff }, hmmer => { test => \&_possibly_hmmer }, nexus => { test => \&_possibly_nexus }, mase => { test => \&_possibly_mase }, mega => { test => \&_possibly_mega }, msf => { test => \&_possibly_msf }, phrap => { test => \&_possibly_phrap }, pir => { test => \&_possibly_pir }, pfam => { test => \&_possibly_pfam }, phylip => { test => \&_possibly_phylip }, prodom => { test => \&_possibly_prodom }, raw => { test => \&_possibly_raw }, rsf => { test => \&_possibly_rsf }, selex => { test => \&_possibly_selex }, stockholm => { test => \&_possibly_stockholm }, swiss => { test => \&_possibly_swiss }, tab => { test => \&_possibly_tab }, vcf => { test => \&_possibly_vcf } ); sub guess { my $self = shift; foreach my $fmt_key (keys %formats) { $formats{$fmt_key}{fmt_string} = $fmt_key; } my $fh; my $start_pos; my @lines; if (defined $self->{-text}) { # Break the text into separate lines. @lines = split /\n/, $self->{-text}; } elsif (defined $self->{-file}) { # If given a filename, open the file. open($fh, $self->{-file}) or $self->throw("Can not open '$self->{-file}' for reading: $!"); } elsif (defined $self->{-fh}) { # If given a filehandle, figure out if it's a plain GLOB # or a IO::Handle which is seekable. In the case of a # GLOB, we'll assume it's seekable. Get the current # position in the stream. $fh = $self->{-fh}; if (ref $fh eq 'GLOB') { $start_pos = tell($fh); } elsif (UNIVERSAL::isa($fh, 'IO::Seekable')) { $start_pos = $fh->getpos(); } } my $done = 0; my $lineno = 0; my $fmt_string; while (!$done) { my $line; # The next line of the file. my $match = 0; # Number of possible formats of this line. if (defined $self->{-text}) { last if (scalar @lines == 0); $line = shift @lines; } else { last if (!defined($line = <$fh>)); } next if ($line =~ /^\s*$/); # Skip white and empty lines. chomp($line); $line =~ s/\r$//; # Fix for DOS files on Unix. ++$lineno; while (my ($fmt_key, $fmt) = each (%formats)) { if ($fmt->{test}($line, $lineno)) { ++$match; $fmt_string = $fmt->{fmt_string}; } } # We're done if there was only one match. $done = ($match == 1); } if (defined $self->{-file}) { # Close the file we opened. close($fh); } elsif (ref $fh eq 'GLOB') { # Try seeking to the start position. seek($fh, $start_pos, 0) || $self->throw("Failed resetting the ". "filehandle; IO error occurred");; } elsif (defined $fh && $fh->can('setpos')) { # Seek to the start position. $fh->setpos($start_pos); } return ($done ? $fmt_string : undef); } =head1 HELPER SUBROUTINES All helper subroutines will, given a line of text and the line number of the same line, return 1 if the line possibly is from a file of the type that they perform a test of. A zero return value does not mean that the line is not part of a certain type of file, just that the test did not find any characteristics of that type of file in the line. =head2 _possibly_ace From bioperl test data, and from "http://www.isrec.isb-sib.ch/DEA/module8/B_Stevenson/Practicals/transcriptome_recon/transcriptome_recon.html". =cut sub _possibly_ace { my ($line, $lineno) = (shift, shift); return ($line =~ /^(?:Sequence|Peptide|DNA|Protein) [":]/); } =head2 _possibly_blast From various blast results. =cut sub _possibly_blast { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^[[:upper:]]*BLAST[[:upper:]]*.*\[.*\]$/); } =head2 _possibly_bowtie Contributed by kortsch. =cut sub _possibly_bowtie { my ($line, $lineno) = (shift, shift); return ($line =~ /^[[:graph:]]+\t[-+]\t[[:graph:]]+\t\d+\t([[:alpha:]]+)\t([[:graph:]]+)\t\d+\t[[:graph:]]?/) && length($1)==length($2); } =head2 _possibly_clustalw From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_clustalw { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /CLUSTAL/); } =head2 _possibly_codata From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_codata { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^ENTRY/) || ($lineno == 2 && $line =~ /^SEQUENCE/) || $line =~ m{^(?:ENTRY|SEQUENCE|///)}); } =head2 _possibly_embl From "http://www.ebi.ac.uk/embl/Documentation/User_manual/usrman.html#3.3". =cut sub _possibly_embl { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^ID / && $line =~ /BP\.$/); } =head2 _possibly_fasta From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_fasta { my ($line, $lineno) = (shift, shift); return (($lineno != 1 && $line =~ /^[A-IK-NP-Z]+$/i) || $line =~ /^>\s*\w/); } =head2 _possibly_fastq From bioperl test data. =cut sub _possibly_fastq { my ($line, $lineno) = (shift, shift); return ( ($lineno == 1 && $line =~ /^@/) || ($lineno == 3 && $line =~ /^\+/) ); } =head2 _possibly_fastxy From bioperl test data. =cut sub _possibly_fastxy { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^ FAST(?:XY|A)/) || ($lineno == 2 && $line =~ /^ version \d/)); } =head2 _possibly_game From bioperl testdata. =cut sub _possibly_game { my ($line, $lineno) = (shift, shift); return ($line =~ /^<!DOCTYPE game/); } =head2 _possibly_gcg From bioperl, Bio::SeqIO::gcg. =cut sub _possibly_gcg { my ($line, $lineno) = (shift, shift); return ($line =~ /Length: .*Type: .*Check: .*\.\.$/); } =head2 _possibly_gcgblast From bioperl testdata. =cut sub _possibly_gcgblast { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^!!SEQUENCE_LIST/) || ($lineno == 2 && $line =~ /^[[:upper:]]*BLAST[[:upper:]]*.*\[.*\]$/)); } =head2 _possibly_gcgfasta From bioperl testdata. =cut sub _possibly_gcgfasta { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^!!SEQUENCE_LIST/) || ($lineno == 2 && $line =~ /FASTA/)); } =head2 _possibly_gde From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_gde { my ($line, $lineno) = (shift, shift); return ($line =~ /^[{}]$/ || $line =~ /^(?:name|longname|sequence-ID| creation-date|direction|strandedness| type|offset|group-ID|creator|descrip| comment|sequence)/x); } =head2 _possibly_genbank From "http://www.ebi.ac.uk/help/formats.html". Format of [apparantly optional] file header from "http://www.umdnj.edu/rcompweb/PA/Notes/GenbankFF.htm". (TODO: dead link) =cut sub _possibly_genbank { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /GENETIC SEQUENCE DATA BANK/) || ($lineno == 1 && $line =~ /^LOCUS /) || ($lineno == 2 && $line =~ /^DEFINITION /) || ($lineno == 3 && $line =~ /^ACCESSION /)); } =head2 _possibly_genscan From bioperl test data. =cut sub _possibly_genscan { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^GENSCAN.*Date.*Time/) || ($line =~ /^(?:Sequence\s+\w+|Parameter matrix|Predicted genes)/)); } =head2 _possibly_gff From bioperl test data. =cut sub _possibly_gff { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^##gff-version/) || ($lineno == 2 && $line =~ /^##date/)); } =head2 _possibly_hmmer From bioperl test data. =cut sub _possibly_hmmer { my ($line, $lineno) = (shift, shift); return (($lineno == 2 && $line =~ /^HMMER/) || ($lineno == 3 && $line =~ /Washington University School of Medicine/)); } =head2 _possibly_nexus From "http://paup.csit.fsu.edu/nfiles.html". =cut sub _possibly_nexus { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^#NEXUS/); } =head2 _possibly_mase From bioperl test data. More detail from "http://www.umdnj.edu/rcompweb/PA/Notes/GenbankFF.htm" (TODO: dead link) =cut sub _possibly_mase { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^;;/) || ($lineno > 1 && $line =~ /^;[^;]?/)); } =head2 _possibly_mega From the ensembl broswer (AlignView data export). =cut sub _possibly_mega { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^#mega$/); } =head2 _possibly_msf From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_msf { my ($line, $lineno) = (shift, shift); return ($line =~ m{^//} || $line =~ /MSF:.*Type:.*Check:|Name:.*Len:/); } =head2 _possibly_phrap From "http://biodata.ccgb.umn.edu/docs/contigimage.html". (TODO: dead link) From "http://genetics.gene.cwru.edu/gene508/Lec6.htm". (TODO: dead link) From bioperl test data ("*.ace.1" files). =cut sub _possibly_phrap { my ($line, $lineno) = (shift, shift); return ($line =~ /^(?:AS\ |CO\ Contig|BQ|AF\ |BS\ |RD\ | QA\ |DS\ |RT\{)/x); } =head2 _possibly_pir From "http://www.ebi.ac.uk/help/formats.html". The ".,()" spotted in bioperl test data. =cut sub _possibly_pir # "NBRF/PIR" (?) { my ($line, $lineno) = (shift, shift); return (($lineno != 1 && $line =~ /^[\sA-IK-NP-Z.,()]+\*?$/i) || $line =~ /^>(?:P1|F1|DL|DC|RL|RC|N3|N1);/); } =head2 _possibly_pfam From bioperl test data. =cut sub _possibly_pfam { my ($line, $lineno) = (shift, shift); return ($line =~ m{^\w+/\d+-\d+\s+[A-IK-NP-Z.]+}i); } =head2 _possibly_phylip From "http://www.ebi.ac.uk/help/formats.html". Initial space allowed on first line (spotted in ensembl AlignView exported data). =cut sub _possibly_phylip { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^\s*\d+\s\d+/) || ($lineno == 2 && $line =~ /^\w\s+[A-IK-NP-Z\s]+/) || ($lineno == 3 && $line =~ /(?:^\w\s+[A-IK-NP-Z\s]+|\s+[A-IK-NP-Z\s]+)/) ); } =head2 _possibly_prodom From "http://prodom.prabi.fr/prodom/current/documentation/data.php". =cut sub _possibly_prodom { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^ID / && $line =~ /\d+ seq\.$/); } =head2 _possibly_raw From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_raw { my ($line, $lineno) = (shift, shift); return ($line =~ /^[A-Za-z\s]+$/); } =head2 _possibly_rsf From "http://www.ebi.ac.uk/help/formats.html". =cut sub _possibly_rsf { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^!!RICH_SEQUENCE/) || $line =~ /^[{}]$/ || $line =~ /^(?:name|type|longname| checksum|creation-date|strand|sequence)/x); } =head2 _possibly_selex From "http://www.ebc.ee/WWW/hmmer2-html/node27.html". Assuming presence of Selex file header. Data exported by Bioperl on Pfam and Selex formats are identical, but Pfam file only holds one alignment. =cut sub _possibly_selex { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^#=ID /) || ($lineno == 2 && $line =~ /^#=AC /) || ($line =~ /^#=SQ /)); } =head2 _possibly_stockholm From bioperl test data. =cut sub _possibly_stockholm { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /^# STOCKHOLM/) || $line =~ /^#=(?:GF|GS) /); } =head2 _possibly_swiss From "http://ca.expasy.org/sprot/userman.html#entrystruc". =cut sub _possibly_swiss { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^ID / && $line =~ /AA\.$/); } =head2 _possibly_tab Contributed by Heikki. =cut sub _possibly_tab { my ($line, $lineno) = (shift, shift); return ($lineno == 1 && $line =~ /^[^\t]+\t[^\t]+/) ; } =head2 _possibly_vcf From "http://www.1000genomes.org/wiki/analysis/vcf4.0". Assumptions made about sanity - format and date lines are line 1 and 2 respectively. This is not specified in the format document. =cut sub _possibly_vcf { my ($line, $lineno) = (shift, shift); return (($lineno == 1 && $line =~ /##fileformat=VCFv/) || ($lineno == 2 && $line =~ /##fileDate=/)); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Hmmpfam.pm����������������������������������������������������������������000555��000765��000024�� 13147�12254227335� 17226� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Hmmpfam # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Balamurugan Kumarasamy # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # =head1 NAME Bio::Tools::Hmmpfam - Parser for Hmmpfam program =head1 SYNOPSIS use Bio::Tools::Hmmpfam; my @hmmpfam_feat; my $hmmpfam_parser = Bio::Tools::Hmmpfam->new(-fh =>$filehandle ); while( my $hmmpfam_feat = $hmmpfam_parser->next_result ) { push @hmmpfam_feat, $hmmpfam_feat; } =head1 DESCRIPTION Parser for Hmmpfam program. See also L<Bio::SearchIO::hmmer>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Balamurugan Kumarasamy Email: fugui@worf.fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Hmmpfam; use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Hmmpfam->new(-fh=>$filehandle); Function: Builds a new Bio::Tools::Hmmpfam object Returns : Bio::Tools::Hmmpfam Args : -filename -fh (filehandle) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $hmmpfam_parser->next_result Function: Get the next result set from parser data Returns : L<Bio::SeqFeature::Generic> Args : none =cut sub next_result { my ($self) = @_; my $filehandle; my $line; my $id; while ($_=$self->_readline()) { $line = $_; chomp $line; if ( $line=~m/^Alignments of top-scoring domains/ ) { while( my $rest = $self->_readline() ) { last if $rest =~ m!^//! } } next if ($line=~m/^Model/ || /^\-/ || /^$/); if ($line=~m/^Query sequence:\s+(\S+)/) { $id = $1; $self->seqname($id); } if (my ($hid, $start, $end, $hstart, $hend, $score, $evalue) = $line=~m/^(\S+)\s+\S+\s+(\d+)\s+(\d+)\s+\S+\s+(\d+)\s+(\d+)\s+\S+\s+(\S+)\s+(\S+)/) { my %feature; ($feature{name}) = $self->seqname; $feature{raw_score} = $score; $feature{p_value} = sprintf ("%.3e", $evalue); $feature{score} = $feature{p_value}; $feature{start} = $start; $feature{end} = $end; $feature{hname} = $hid; $feature{hstart} = $hstart; $feature{hend} = $hend; ($feature{source}) = 'pfam'; $feature{primary} = $hid; ($feature{program}) = 'pfam'; ($feature{db}) = 'db1'; ($feature{logic_name}) = 'hmmpfam'; my $new_feat = $self->create_feature (\%feature); return $new_feat } next; } return; } =head2 create_feature Title : create_feature Usage : my $feat=$hmmpfam_parser->create_feature($feature,$seqname) Function: creates a SeqFeature Generic object Returns : L<Bio::SeqFeature::Generic> Args : =cut sub create_feature { my ($self, $feat) = @_; my $feature1= Bio::SeqFeature::Generic->new( -seq_id =>$feat->{name}, -start =>$feat->{start}, -end =>$feat->{end}, -score =>$feat->{score}, -source =>$feat->{source}, -primary =>$feat->{primary}, ); my $feature2= Bio::SeqFeature::Generic->new( -start =>$feat->{hstart}, -end =>$feat->{hend}, ); my $featurepair = Bio::SeqFeature::FeaturePair->new; $featurepair->feature1 ($feature1); $featurepair->feature2 ($feature2); $featurepair->add_tag_value('evalue',$feat->{p_value}); $featurepair->add_tag_value('percent_id','NULL'); $featurepair->add_tag_value("hid",$feat->{primary}); return $featurepair; } =head2 seqname Title : seqname Usage : obj->seqname($seqname) Function: Internal(not to be used directly) Returns : Args : seqname =cut sub seqname{ my($self,$seqname)=@_; if(defined($seqname)) { $self->{'seqname'}=$seqname; } return $self->{'seqname'}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Infernal.pm���������������������������������������������������������������000444��000765��000024�� 41771�12254227337� 17402� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Infernal # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Fields <cjfields-at-uiuc-dot-edu> # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Infernal - A parser for Infernal output =head1 SYNOPSIS use Bio::Tools::Infernal; my $parser = Bio::Tools::Infernal->new(-file => $rna_output, -motiftag => 'misc_binding' -desctag => 'Lysine riboswitch', -cm => 'RF00168', -rfam => 'RF00168', -minscore => 20); #parse the results, get a Bio::SeqFeature::FeaturePair while( my $motif = $parser->next_prediction) { # do something here } =head1 DESCRIPTION This is a highly experimental parser for Infernal output from the cmsearch program. At some point it is anticipated that this will morph into a proper SearchIO parser, along with the related RNAMotif and ERPIN tools. The Infernal suite of programs are used for generating RNA CM (covariance models) and searching sequences using CMs to locate potentially similar structures. The program is under active development; it is anticiapted that this will support the latest version available. This parser has been tested and is capable of parsing Infernal 0.7 and 0.71 output. However, future Infernal versions may break parsing as the output is constantly evolving, so keep an eye on this space for additional notes. Currently data is parsed into a Bio::SeqFeature::FeaturePair object, consisting of a query (the covariance model) and the hit (sequence searched). Model data is accessible via the following: Data SeqFeature::FeaturePair Note -------------------------------------------------------------------------- primary tag $sf->primary_tag Rfam ID (if passed to new()) start $sf->start Based on CM length end $sf->end Based on CM length score $sf->score Bit score strand $sf->strand 0 (CM does not have a strand) seqid $sf->seq_id Rfam ID (if passed to new()) display name $sf->feature1->display_name CM name (if passed to new()) source $sf->feature1->source tag 'Infernal' followed by version Hit data is accessible via the following: Data SeqFeature::FeaturePair Note ------------------------------------------------------------------ start $sf->hstart end $sf->hend score(bits) $sf->hscore strand $sf->hstrand seqid $sf->hseqid Primary Tag $sf->hprimary_tag Source Tag $sf->hsource_tag Added FeaturePair tags are : secstructure - entire description line (in case the regex used for sequence ID doesn't adequately catch the name model - name of the descriptor file (may include path to file) midline - contains structural information from the descriptor used as a query hit - sequence of motif, separated by spaces according to matches to the structure in the descriptor (in SecStructure). seqname - raw sequence name (for downstream parsing if needed) An additional parameter ('minscore') is added due to the huge number of spurious hits generated by cmsearch. This screens data, only building and returning objects when a minimal bitscore is present. See t/rnamotif.t for example usage. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields-at-uiuc-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Infernal; use strict; use Bio::SeqFeature::Generic; use Bio::SeqFeature::FeaturePair; use Data::Dumper; use base qw(Bio::Tools::AnalysisResult); our($MotifTag,$SrcTag,$DescTag) = qw(misc_binding Infernal infernal); our $MINSCORE = 0; our $DEFAULT_VERSION = '0.71'; =head2 new Title : new Usage : my $obj = Bio::Tools::Infernal->new(); Function: Builds a new Bio::Tools::Infernal object Returns : an instance of Bio::Tools::Infernal Args : -fh/-file - for input filehandle/filename -motiftag - primary tag used in gene features (default 'misc_binding') -desctag - tag used for display_name name (default 'infernal') -srctag - source tag used in all features (default 'Infernal') -rfam - Rfam id number -cm - covariance model used in analysis (may be same as rfam #) -minscore - minimum score (simple screener, since Infernal generates a ton of spurious hits) -version - Infernal program version =cut # yes, this is actually _initialize, but the args are passed to # the constructor. # see Bio::Tools::AnalysisResult for further details sub _initialize { my($self,@args) = @_; $self->warn('Use of this module is deprecated. Use Bio::SearchIO::infernal instead'); $self->SUPER::_initialize(@args); my ($motiftag,$desctag,$srctag,$rfam,$cm,$ms,$ver) = $self->SUPER::_rearrange([qw(MOTIFTAG DESCTAG SRCTAG RFAM CM MINSCORE VERSION )],@args); $self->motif_tag(defined $motiftag ? $motiftag : $MotifTag); $self->source_tag(defined $srctag ? $srctag : $SrcTag); $self->desc_tag(defined $desctag ? $desctag : $DescTag); $cm && $self->covariance_model($cm); $rfam && $self->rfam($rfam); $self->program_version(defined $ver ? $ver : $DEFAULT_VERSION); $self->minscore(defined $ms ? $ms : $MINSCORE); } =head2 motif_tag Title : motif_tag Usage : $obj->motif_tag($newval) Function: Get/Set the value used for 'motif_tag', which is used for setting the primary_tag. Default is 'misc_binding' as set by the global $MotifTag. 'misc_binding' is used here because a conserved RNA motif is capable of binding proteins (regulatory proteins), antisense RNA (siRNA), small molecules (riboswitches), or nothing at all (tRNA, terminators, etc.). It is recommended that this be changed to other tags ('misc_RNA', 'protein_binding', 'tRNA', etc.) where appropriate. For more information, see: http://www.ncbi.nlm.nih.gov/collab/FT/index.html Returns : value of motif_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub motif_tag{ my $self = shift; return $self->{'motif_tag'} = shift if @_; return $self->{'motif_tag'}; } =head2 source_tag Title : source_tag Usage : $obj->source_tag($newval) Function: Get/Set the value used for the 'source_tag'. Default is 'Infernal' as set by the global $SrcTag Returns : value of source_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source_tag{ my $self = shift; return $self->{'source_tag'} = shift if @_; return $self->{'source_tag'}; } =head2 desc_tag Title : desc_tag Usage : $obj->desc_tag($newval) Function: Get/Set the value used for the query motif. This will be placed in the tag '-display_name'. Default is 'infernal' as set by the global $DescTag. Use this to manually set the descriptor (motif searched for). Since there is no way for this module to tell what the motif is from the name of the descriptor file or the Infernal output, this should be set every time an Infernal object is instantiated for clarity Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub desc_tag{ my $self = shift; return $self->{'desc_tag'} = shift if @_; return $self->{'desc_tag'}; } =head2 covariance_model Title : covariance_model Usage : $obj->covariance_model($newval) Function: Get/Set the value used for the covariance model used in the analysis. Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub covariance_model{ my $self = shift; return $self->{'_cmodel'} = shift if @_; return $self->{'_cmodel'}; } =head2 rfam Title : rfam Usage : $obj->rfam($newval) Function: Get/Set the Rfam accession number Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub rfam { my $self = shift; return $self->{'_rfam'} = shift if @_; return $self->{'_rfam'}; } =head2 minscore Title : minscore Usage : $obj->minscore($newval) Function: Get/Set the minimum score threshold for generating SeqFeatures Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub minscore { my $self = shift; return $self->{'_minscore'} = shift if @_; return $self->{'_minscore'}; } =head2 program_version Title : program_version Usage : $obj->program_version($newval) Function: Get/Set the Infernal program version Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) Note: this is set to $DEFAULT_VERSION by, um, default =cut sub program_version { my $self = shift; return $self->{'_program_version'} = shift if @_; return $self->{'_program_version'}; } =head2 analysis_method Usage : $obj->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /Infernal/i. Returns : String Argument : n/a =cut sub analysis_method { my ($self, $method) = @_; if($method && ($method !~ /Infernal/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $obj->next_feature()) { # do something } Function: Returns the next gene structure prediction of the RNAMotif result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Returns : A Bio::Tools::Prediction::Gene object. Args : None (at present) =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $obj->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the RNAMotif result file. Call this method repeatedly until FALSE is returned. Returns : A Bio::SeqFeature::Generic object Args : None (at present) =cut sub next_prediction { my ($self) = @_; my ($start, $end, $strand, $score); my %hsp_key = ('0' => 'structure', '1' => 'model', '2' => 'midline', '3' => 'hit'); my $line; PARSER: while($line = $self->_readline) { next if $line =~ m{^\s+$}; if ($line =~ m{^sequence:\s+(\S+)} ){ $self->_current_hit($1); next PARSER; } elsif ($line =~ m{^hit\s+\d+\s+:\s+(\d+)\s+(\d+)\s+(\d+\.\d+)\s+bits}xms) { $strand = 1; ($start, $end, $score) = ($1, $2, $3); if ($start > $end) { ($start, $end) = ($end, $start); $strand = -1; } #$self->debug(sprintf("Hit: %-30s\n\tStrand:%-4d Start:%-6d End:%-6d Score:%-10s\n", # $self->_current_hit, $strand, $start, $end, $score)); } elsif ($line =~ m{^(\s+)[<>\{\}\(\)\[\]:_,-\.]+}xms) { # start of HSP $self->_pushback($line); # set up for loop # what is length of the gap to the structure data? my $offset = length($1); my ($ct, $strln) = 0; my $hsp; HSP: while ($line = $self->_readline) { next if $line =~ m{^\s*$}; # toss empty lines chomp $line; # exit loop if at end of file or upon next hit/HSP if (!defined($line) || $line =~ m{^(sequence|hit)}) { $self->_pushback($line); last HSP; } # iterate to keep track of each line (4 lines per hsp block) my $iterator = $ct%4; # strlen set only with structure lines (proper length) $strln = length($line) if $iterator == 0; # only grab the data needed (hit start and stop in hit line above; # query start, end are from the actual query length (entire hit is # mapped to CM data, so all CM data is represented # yes this is kinda clumsy, but I'll probably morph this into # a proper SearchIO module soon. For now this works... my $data = substr($line, $offset, $strln-$offset); $hsp->{ $hsp_key{$iterator} } .= $data; $ct++; } if ($self->minscore < $score) { my ($name, $program, $rfam, $cm, $dt, $st, $mt) = ($self->_current_hit, $self->analysis_method, $self->rfam, $self->covariance_model, $self->desc_tag, $self->source_tag, $self->motif_tag); my $ver = $self->program_version || ''; my $qid = $name; if ($name =~ m{(?:gb|gi|emb|dbj|sp|pdb|bbs|ref|lcl)\|(\d+)((?:\:|\|)\w+\|(\S*.\d+)\|)?}xms) { $qid = $1; } my $fp = Bio::SeqFeature::FeaturePair->new(); my $strlen = $hsp->{'model'} =~ tr{A-Za-z}{A-Za-z}; # gaps don't count my $qf = Bio::SeqFeature::Generic->new( -primary_tag => $mt, -source_tag => "$st $ver", -display_name => $cm || '', -score => $score, -start => 1, -end => $strlen, -seq_id => $rfam || '', -strand => 0, # covariance model does not have a strand ); my $hf = Bio::SeqFeature::Generic->new( -primary_tag => $mt, -source_tag => "$st $ver", -display_name => $dt || '', -score => $score, -start => $start, -end => $end, -seq_id => $qid, -strand => $strand ); $fp->feature1($qf); $fp->feature2($hf); # should emphasis be on the hit? $fp->add_tag_value('secstructure', $hsp->{'structure'}); $fp->add_tag_value('model', $hsp->{'model'}); $fp->add_tag_value('midline', $hsp->{'midline'}); $fp->add_tag_value('hit', $hsp->{'hit'}); $fp->add_tag_value('seq_name', $name); $fp->display_name($dt); return $fp; } else { next PARSER; } } } return (defined($line)) ? 1 : 0; } sub _current_hit { my $self = shift; return $self->{'_currhit'} = shift if @_; return $self->{'_currhit'}; } 1; �������BioPerl-1.6.923/Bio/Tools/ipcress.pm����������������������������������������������������������������000444��000765��000024�� 16506�12254227313� 17304� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::ipcress # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # Copyright Sheldon McKay # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::ipcress - Parse ipcress output and make features =head1 SYNOPSIS # A simple annotation pipeline wrapper for ipcress data # assuming ipcress data is already generated in file seq1.ipcress # and sequence data is in fasta format in file called seq1.fa use Bio::Tools::ipcress; use Bio::SeqIO; my $parser = Bio::Tools::ipcress->new(-file => 'seq1.ipcress'); my $seqio = Bio::SeqIO->new(-format => 'fasta', -file => 'seq1.fa'); my $seq = $seqio->next_seq || die("cannot get a seq object from SeqIO"); while( my $feat = $parser->next_feature ) { # add ipcress annotation to a sequence $seq->add_SeqFeature($feat); } my $seqout = Bio::SeqIO->new(-format => 'embl'); $seqout->write_seq($seq); =head1 DESCRIPTION This object serves as a parser for ipcress data, creating a Bio::SeqFeatureI for each ipcress hit. These can be processed or added as annotation to an existing Bio::SeqI object for the purposes of automated annotation. This module is adapted from the Bio::Tools::EPCR module written by Jason Stajich (jason-at-bioperl.org). Ipcress is available through Guy Slater's Exonerate package http://www.ebi.ac.uk/~guy/exonerate/ =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::ipcress; use strict; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $ipcress = Bio::Tools::ipcress->new(-file => $file, -primary => $fprimary, -source => $fsource, -groupclass => $fgroupclass); Function: Initializes a new ipcress parser Returns : Bio::Tools::ipcress Args : -fh => filehandle OR -file => filename -primary => a string to be used as the common value for each features '-primary' tag. Defaults to the sequence ontology term 'PCR_product'. (This in turn maps to the GFF 'type' tag (aka 'method')). -source => a string to be used as the common value for each features '-source' tag. Defaults to 'ipcress'. (This in turn maps to the GFF 'source' tag) -groupclass => a string to be used as the name of the tag which will hold the sts marker namefirst attribute. Defaults to 'name'. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($primary, $source, $groupclass, $file, $fh) = $self->_rearrange([qw(PRIMARY SOURCE GROUPCLASS FILE FH)],@args); $self->primary(defined $primary ? $primary : 'PCR_product'); $self->source(defined $source ? $source : 'ipcress'); $self->groupclass(defined $groupclass ? $groupclass : 'name'); local $/ = 'Ipcress result'; my @result; if ($file) { open FH, $file; @result = (<FH>); close FH; } elsif ($fh) { @result = (<$fh>); } else { $self->throw("Bio::Tools::ipcress: no input file"); } shift @result; $self->{result} = \@result; return $self; } =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut sub next_feature { my ($self) = @_; my $result = shift @{$self->{result}}; return unless defined($result); chomp $result; my @lines = split "\n", $result; my ($ipcress) = grep /ipcress: /, @lines; my (undef,$seqname,$mkrname,$length,undef,$start,$mismatchL, undef,undef,$mismatchR,$desc) = split /\s+/, $ipcress; my $end = $start + $length; $start += 1; my $strand = $desc eq 'forward' ? '+' : $desc eq 'revcomp' ? '-' : 0; my ($left) = grep /\# forward/, @lines; $left =~ s/[^A-Z]+//g; my ($right) = grep /\# revcomp/, @lines; $right =~ s/[^A-Z]+//g; $right = reverse $right; # if there are multiple hits, increment the name for # the groupclass if (++$self->{seen}->{$mkrname} > 1) { $mkrname .= "\.$self->{seen}->{$mkrname}"; } my $markerfeature = Bio::SeqFeature::Generic->new ( '-start' => $start, '-end' => $end, '-strand' => $strand, '-source' => $self->source, '-primary' => $self->primary, '-seq_id' => $seqname, '-tag' => { $self->groupclass => $mkrname, }); if (!$strand) { $markerfeature->add_tag_value('Note' => "bad product: single primer amplification"); } $markerfeature->add_tag_value('left_primer' => $left); $markerfeature->add_tag_value('right_primer' => $right); $markerfeature->add_tag_value('left_mismatches' => $mismatchL) if $mismatchL; $markerfeature->add_tag_value('right_mismatches' => $mismatchR) if $mismatchR; return $markerfeature; } =head2 source Title : source Usage : $obj->source($newval) Function: Example : Returns : value of source (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source{ my $self = shift; return $self->{'_source'} = shift if @_; return $self->{'_source'}; } =head2 primary Title : primary Usage : $obj->primary($newval) Function: Example : Returns : value of primary (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub primary{ my $self = shift; return $self->{'_primary'} = shift if @_; return $self->{'_primary'}; } =head2 groupclass Title : groupclass Usage : $obj->groupclass($newval) Function: Example : Returns : value of groupclass (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub groupclass{ my $self = shift; return $self->{'_groupclass'} = shift if @_; return $self->{'_groupclass'}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/isPcr.pm������������������������������������������������������������������000555��000765��000024�� 15164�12254227336� 16723� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::isPcr # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sheldon McKay <mckays@cshl.edu> # # Copyright Sheldon McKay # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::isPcr - Parse isPcr output and make features =head1 SYNOPSIS # A simple annotation pipeline wrapper for isPcr data # assuming isPcr data is already generated in file seq1.isPcr # and sequence data is in fasta format in file called seq1.fa # Note: this parser is meant for the default fasta output from # isPcr. bed and psl output formats are not supported. use Bio::Tools::IsPcr; use Bio::SeqIO; my $parser = Bio::Tools::isPcr->new(-file => 'seq1.isPcr'); my $seqio = Bio::SeqIO->new(-format => 'fasta', -file => 'seq1.fa'); my $seq = $seqio->next_seq || die("cannot get a seq object from SeqIO"); while( my $feat = $parser->next_feature ) { # add isPcr annotation to a sequence $seq->add_SeqFeature($feat); } my $seqout = Bio::SeqIO->new(-format => 'embl'); $seqout->write_seq($seq); =head1 DESCRIPTION This object serves as a parser for isPcr data (in the default fasta format), creating a Bio::SeqFeatureI for each isPcr hit. These can be processed or added as annotation to an existing Bio::SeqI object for the purposes of automated annotation. This module is adapted from the Bio::Tools::EPCR module written by Jason Stajich (jason-at-bioperl.org). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sheldon McKay Email mckays@cshl.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::isPcr; use strict; use Bio::SeqIO; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $ispcr = Bio::Tools::isPcr->new( -file => $file, -primary => $fprimary, -source => $fsource, -groupclass => $fgroupclass); Function: Initializes a new isPcr parser Returns : Bio::Tools::isPcr Args : -fh => filehandle OR -file => filename -primary => a string to be used as the common value for each features '-primary' tag. Defaults to the sequence ontology term 'PCR_product'. (This in turn maps to the GFF 'type' tag (aka 'method')). -source => a string to be used as the common value for each features '-source' tag. Defaults to 'isPcr'. (This in turn maps to the GFF 'source' tag) -groupclass => a string to be used as the name of the tag which will hold the sts marker namefirst attribute. Defaults to 'name'. =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($primary,$source,$groupclass) = $self->_rearrange([qw/PRIMARY SOURCE GROUPCLASS/],@args); $self->primary(defined $primary ? $primary : 'PCR_product'); $self->source(defined $source ? $source : 'isPcr'); $self->groupclass(defined $groupclass ? $groupclass : 'name'); # default output for isPcr is fasta format $self->{io} = Bio::SeqIO->new(-format => 'fasta', @args); return $self; } =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none =cut sub next_feature { my ($self) = @_; my $result = $self->{io}->next_seq; return unless defined $result; my ($seqname,$location) = split ':', $result->primary_id; my ($pcrname,$left,$right) = split /\s+/, $result->desc; my ($start,$strand,$end) = $location =~ /^(\d+)([-+])(\d+)$/; my $amplicon = $result->seq; # if there are multiple hits, increment the name for # the groupclass if (++$self->{seen}->{$pcrname} > 1) { $pcrname .= "\.$self->{seen}->{$pcrname}"; } my $tags = { $self->groupclass => $pcrname, amplicon => $amplicon, left_primer => $left, right_primer => $right }; my $markerfeature = Bio::SeqFeature::Generic->new( '-start' => $start, '-end' => $end, '-strand' => $strand, '-source' => $self->source, '-primary' => $self->primary, '-seq_id' => $seqname, '-tag' => $tags ); return $markerfeature; } =head2 source Title : source Usage : $obj->source($newval) Function: Example : Returns : value of source (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source{ my $self = shift; return $self->{'_source'} = shift if @_; return $self->{'_source'}; } =head2 primary Title : primary Usage : $obj->primary($newval) Function: Example : Returns : value of primary (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub primary{ my $self = shift; return $self->{'_primary'} = shift if @_; return $self->{'_primary'}; } =head2 groupclass Title : groupclass Usage : $obj->groupclass($newval) Function: Example : Returns : value of groupclass (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub groupclass{ my $self = shift; return $self->{'_groupclass'} = shift if @_; return $self->{'_groupclass'}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/IUPAC.pm������������������������������������������������������������������000444��000765��000024�� 33665�12254227332� 16503� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for IUPAC # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::IUPAC - Generates unique sequence objects or regular expressions from an ambiguous IUPAC sequence =head1 SYNOPSIS use Bio::PrimarySeq; use Bio::Tools::IUPAC; # Get the IUPAC code for proteins my %iupac_prot = Bio::Tools::IUPAC->new->iupac_iup; # Create a sequence with degenerate residues my $ambiseq = Bio::PrimarySeq->new(-seq => 'ARTCGUTGN', -alphabet => 'dna'); # Create all possible non-degenerate sequences my $iupac = Bio::Tools::IUPAC->new(-seq => $ambiseq); while ($uniqueseq = $iupac->next_seq()) { # process the unique Bio::Seq object. } # Get a regular expression that matches all possible sequences my $regexp = $iupac->regexp(); =head1 DESCRIPTION Bio::Tools::IUPAC is a tool that manipulates sequences with ambiguous residues following the IUPAC conventions. Non-standard characters have the meaning described below: IUPAC-IUB SYMBOLS FOR NUCLEOTIDE (DNA OR RNA) NOMENCLATURE: Cornish-Bowden (1985) Nucl. Acids Res. 13: 3021-3030 --------------------------------------------------------------- Symbol Meaning Nucleic Acid --------------------------------------------------------------- A A Adenine C C Cytosine G G Guanine T T Thymine U U Uracil M A or C aMino R A or G puRine W A or T Weak S C or G Strong Y C or T pYrimidine K G or T Keto V A or C or G not T (closest unused char after T) H A or C or T not G (closest unused char after G) D A or G or T not C (closest unused char after C) B C or G or T not A (closest unused char after A) X G or A or T or C Unknown (very rarely used) N G or A or T or C Unknown (commonly used) IUPAC-IUP AMINO ACID SYMBOLS: Biochem J. 1984 Apr 15; 219(2): 345-373 Eur J Biochem. 1993 Apr 1; 213(1): 2 ------------------------------------------ Symbol Meaning ------------------------------------------ A Alanine B Aspartic Acid, Asparagine C Cysteine D Aspartic Acid E Glutamic Acid F Phenylalanine G Glycine H Histidine I Isoleucine J Isoleucine/Leucine K Lysine L Leucine M Methionine N Asparagine O Pyrrolysine P Proline Q Glutamine R Arginine S Serine T Threonine U Selenocysteine V Valine W Tryptophan X Unknown Y Tyrosine Z Glutamic Acid, Glutamine * Terminator There are a few things Bio::Tools::IUPAC can do for you: =over =item * report the IUPAC mapping between ambiguous and non-ambiguous residues =item * produce a stream of all possible corresponding unambiguous Bio::Seq objects given an ambiguous sequence object =item * convert an ambiguous sequence object to a corresponding regular expression =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey-at-virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::IUPAC; use strict; use base qw(Bio::Root::Root); use vars qw(%IUB %IUB_AMB %REV_IUB %IUP %IUP_AMB $AUTOLOAD); BEGIN { # Ambiguous nucleic residues are matched to unambiguous residues %IUB = ( A => [qw(A)], C => [qw(C)], G => [qw(G)], T => [qw(T)], U => [qw(U)], M => [qw(A C)], R => [qw(A G)], S => [qw(C G)], W => [qw(A T)], Y => [qw(C T)], K => [qw(G T)], V => [qw(A C G)], H => [qw(A C T)], D => [qw(A G T)], B => [qw(C G T)], N => [qw(A C G T)], X => [qw(A C G T)], ); # Same as %IUB but ambiguous residues are matched to ambiguous residues only %IUB_AMB = ( M => [qw(M)], R => [qw(R)], W => [qw(W)], S => [qw(S)], Y => [qw(Y)], K => [qw(K)], V => [qw(M R S V)], H => [qw(H M W Y)], D => [qw(D K R W)], B => [qw(B K S Y)], N => [qw(B D H K M N R S V W Y)], ); # The inverse of %IUB %REV_IUB = ( A => 'A', T => 'T', U => 'U', C => 'C', G => 'G', AC => 'M', AG => 'R', AT => 'W', CG => 'S', CT => 'Y', GT => 'K', ACG => 'V', ACT => 'H', AGT => 'D', CGT => 'B', ACGT => 'N', N => 'N' ); # Same thing with proteins now %IUP = ( A => [qw(A)], B => [qw(D N)], C => [qw(C)], D => [qw(D)], E => [qw(E)], F => [qw(F)], G => [qw(G)], H => [qw(H)], I => [qw(I)], J => [qw(I L)], K => [qw(K)], L => [qw(L)], M => [qw(M)], N => [qw(N)], O => [qw(O)], P => [qw(P)], Q => [qw(Q)], R => [qw(R)], S => [qw(S)], T => [qw(T)], U => [qw(U)], V => [qw(V)], W => [qw(W)], X => [qw(X)], Y => [qw(Y)], Z => [qw(E Q)], '*' => [qw(*)], ); %IUP_AMB = ( B => [qw(B)], J => [qw(J)], Z => [qw(Z)], ); } =head2 new Title : new Usage : Bio::Tools::IUPAC->new($seq); Function: Create a new IUPAC object, which acts as a sequence stream (akin to SeqIO) Args : an ambiguously coded sequence object that has a specified 'alphabet' Returns : a Bio::Tools::IUPAC object. =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($seq) = $self->_rearrange([qw(SEQ)],@args); if ( (not defined $seq) && @args && ref($args[0]) ) { # parameter not passed as named parameter? $seq = $args[0]; } if (defined $seq) { if (not $seq->isa('Bio::PrimarySeqI')) { $self->throw('Must supply a sequence object'); } if (length $seq->seq == 0) { $self->throw('Sequence had zero-length'); } $self->{'_seq'} = $seq; } return $self; } sub _initialize { my ($self) = @_; my %iupac = $self->iupac; $self->{'_alpha'} = [ map { $iupac{uc $_} } split('', $self->{'_seq'}->seq) ]; $self->{'_string'} = [(0) x length($self->{'_seq'}->seq())]; $self->{'_string'}->[0] = -1; } =head2 next_seq Title : next_seq Usage : $iupac->next_seq(); Function: returns the next unique sequence object Args : none. Returns : a Bio::Seq object =cut sub next_seq { my ($self) = @_; if (not exists $self->{'_string'}) { $self->_initialize(); } for my $i ( 0 .. $#{$self->{'_string'}} ) { next unless $self->{'_string'}->[$i] || @{$self->{'_alpha'}->[$i]} > 1; if ( $self->{'_string'}->[$i] == $#{$self->{'_alpha'}->[$i]} ) { # rollover if ( $i == $#{$self->{'_string'}} ) { # end of possibilities return; } else { $self->{'_string'}->[$i] = 0; next; } } else { $self->{'_string'}->[$i]++; my $j = -1; my $seqstr = join('', map { $j++; $self->{'_alpha'}->[$j]->[$_]; } @{$self->{'_string'}}); my $desc = $self->{'_seq'}->desc() || ''; $self->{'_num'}++; 1 while $self->{'_num'} =~ s/(\d)(\d\d\d)(?!\d)/$1,$2/; $desc =~ s/( \[Bio::Tools::IUPAC-generated\sunique sequence # [^\]]*\])|$/ \[Bio::Tools::IUPAC-generated unique sequence # $self->{'_num'}\]/; $self->{'_num'} =~ s/,//g; # Return a fresh sequence object return Bio::PrimarySeq->new(-seq => $seqstr, -desc => $desc); } } } =head2 iupac Title : iupac Usage : my %symbols = $iupac->iupac; Function: Returns a hash of symbols -> symbol components of the right type for the given sequence, i.e. it is the same as iupac_iup() if Bio::Tools::IUPAC was given a proteic sequence, or iupac_iub() if the sequence was nucleic. For example, the key 'M' has the value ['A', 'C']. Args : none Returns : Hash =cut sub iupac { my ($self) = @_; my $alphabet = lc( $self->{'_seq'}->alphabet() ); if ( ($alphabet eq 'dna') or ($alphabet eq 'rna') ) { return %IUB; # nucleic } elsif ( $alphabet eq 'protein' ) { return %IUP; # proteic } else { $self->throw("The input sequence had the unknown alphabet '$alphabet'\n"); } } =head2 iupac_amb Title : iupac_amb Usage : my %symbols = $iupac->iupac_amb; Function: Same as iupac() but only contains a mapping between ambiguous residues and the ambiguous residues they map to. For example, the key 'N' has the value ['R', 'Y', 'K', 'M', 'S', 'W', 'B', 'D', 'H', 'V', 'N'], i.e. it matches all other ambiguous residues. Args : none Returns : Hash =cut sub iupac_amb { my ($self) = @_; my $alphabet = lc( $self->{'_seq'}->alphabet() ); if ( ($alphabet eq 'dna') or ($alphabet eq 'rna') ) { return %IUB_AMB; # nucleic } elsif ( $alphabet eq 'protein' ) { return %IUP_AMB; # proteic } else { $self->throw("The input sequence had the unknown alphabet '$alphabet'\n"); } } =head2 iupac_iup Title : iupac_iup Usage : my %aasymbols = $iupac->iupac_iup; Function: Returns a hash of PROTEIN symbols -> non-ambiguous symbol components Args : none Returns : Hash =cut sub iupac_iup { return %IUP; } =head2 iupac_iup_amb Title : iupac_iup_amb Usage : my %aasymbols = $iupac->iupac_iup_amb; Function: Returns a hash of PROTEIN symbols -> ambiguous symbol components Args : none Returns : Hash =cut sub iupac_iup_amb { return %IUP_AMB; } =head2 iupac_iub Title : iupac_iub Usage : my %dnasymbols = $iupac->iupac_iub; Function: Returns a hash of DNA symbols -> non-ambiguous symbol components Args : none Returns : Hash =cut sub iupac_iub { return %IUB; } =head2 iupac_iub_amb Title : iupac_iub_amb Usage : my %dnasymbols = $iupac->iupac_iub; Function: Returns a hash of DNA symbols -> ambiguous symbol components Args : none Returns : Hash =cut sub iupac_iub_amb { return %IUB_AMB; } =head2 iupac_rev_iub Title : iupac_rev_iub Usage : my %dnasymbols = $iupac->iupac_rev_iub; Function: Returns a hash of nucleotide combinations -> IUPAC code (a reverse of the iupac_iub hash). Args : none Returns : Hash =cut sub iupac_rev_iub { return %REV_IUB; } =head2 count Title : count Usage : my $total = $iupac->count(); Function: Calculates the number of unique, unambiguous sequences that this ambiguous sequence could generate Args : none Return : int =cut sub count { my ($self) = @_; if (not exists $self->{'_string'}) { $self->_initialize(); } my $count = 1; $count *= scalar(@$_) for (@{$self->{'_alpha'}}); return $count; } =head2 regexp Title : regexp Usage : my $re = $iupac->regexp(); Function: Converts the ambiguous sequence into a regular expression that matches all of the corresponding ambiguous and non-ambiguous sequences. You can further manipulate the resulting regular expression with the Bio::Tools::SeqPattern module. After you are done building your regular expression, you might want to compile it and make it case- insensitive: $re = qr/$re/i; Args : 1 to match RNA: T and U characters will match interchangeably Return : regular expression =cut sub regexp { my ($self, $match_rna) = @_; my $re; my $seq = $self->{'_seq'}->seq; my %iupac = $self->iupac; my %iupac_amb = $self->iupac_amb; for my $pos (0 .. length($seq)-1) { my $res = substr $seq, $pos, 1; my $iupacs = $iupac{$res}; my $iupacs_amb = $iupac_amb{$res} || []; if (not defined $iupacs) { $self->throw("Primer sequence '$seq' is not a valid IUPAC sequence.". " Offending character was '$res'.\n"); } my $part = join '', (@$iupacs, @$iupacs_amb); if ($match_rna) { $part =~ s/T/TU/i || $part =~ s/U/TU/i; } if (length $part > 1) { $part = '['.$part.']'; } $re .= $part; } return $re; } sub AUTOLOAD { my $self = shift @_; my $method = $AUTOLOAD; $method =~ s/.*:://; return $self->{'_seq'}->$method(@_) unless $method eq 'DESTROY'; } 1; ���������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Lucy.pm�������������������������������������������������������������������000444��000765��000024�� 52120�12254227330� 16537� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Lucy # # Copyright Her Majesty the Queen of England # written by Andrew Walsh (paeruginosa@hotmail.com) during employment with # Agriculture and Agri-food Canada, Cereal Research Centre, Winnipeg, MB # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Lucy - Object for analyzing the output from Lucy, a vector and quality trimming program from TIGR =head1 SYNOPSIS # Create the Lucy object from an existing Lucy output file @params = ('seqfile' => 'lucy.seq', 'lucy_verbose' => 1); $lucyObj = Bio::Tools::Lucy->new(@params); # Get names of all sequences $names = $lucyObj->get_sequence_names(); # Print seq and qual values for sequences >400 bp in order to run CAP3 foreach $name (@$names) { next unless $lucyObj->length_clear($name) > 400; print SEQ ">$name\n", $lucyObj->sequence($name), "\n"; print QUAL ">$name\n", $lucyObj->quality($name), "\n"; } # Get an array of Bio::PrimarySeq objects @seqObjs = $lucyObj->get_Seq_Objs(); =head1 DESCRIPTION Bio::Tools::Lucy.pm provides methods for analyzing the sequence and quality values generated by Lucy program from TIGR. Lucy will identify vector, poly-A/T tails, and poor quality regions in a sequence. (www.genomics.purdue.edu/gcg/other/lucy.pdf) The input to Lucy can be the Phred sequence and quality files generated from running Phred on a set of chromatograms. Lucy can be obtained (free of charge to academic users) from www.tigr.org/softlab There are a few methods that will only be available if you make some minor changes to the source for Lucy and then recompile. The changes are in the 'lucy.c' file and there is a diff between the original and the modified file in the Appendix Please contact the author of this module if you have any problems making these modifications. You do not have to make these modifications to use this module. =head2 Creating a Lucy object @params = ('seqfile' => 'lucy.seq', 'adv_stderr' => 1, 'fwd_desig' => '_F', 'rev_desig' => '_R'); $lucyObj = Bio::Tools::Lucy->new(@params); =head2 Using a Lucy object You should get an array with the sequence names in order to use accessor methods. Note: The Lucy binary program will fail unless the sequence names provided as input are unique. $names_ref = $lucyObj->get_sequence_names(); This code snippet will produce a Fasta format file with sequence lengths and %GC in the description line. foreach $name (@$names) { print FILE ">$name\t", $lucyObj->length_clear($name), "\t", $lucyObj->per_GC($name), "\n", $lucyObj->sequence($name), "\n"; } Print seq and qual values for sequences >400 bp in order to assemble them with CAP3 (or other assembler). foreach $name (@$names) { next unless $lucyObj->length_clear($name) > 400; print SEQ ">$name\n", $lucyObj->sequence($name), "\n"; print QUAL ">$name\n", $lucyObj->quality($name), "\n"; } Get all the sequences as Bio::PrimarySeq objects (eg., for use with Bio::Tools::Run::StandaloneBlast to perform BLAST). @seqObjs = $lucyObj->get_Seq_Objs(); Or use only those sequences that are full length and have a Poly-A tail. foreach $name (@$names) { next unless ($lucyObj->full_length($name) and $lucy->polyA($name)); push @seqObjs, $lucyObj->get_Seq_Obj($name); } Get the names of those sequences that were rejected by Lucy. $rejects_ref = $lucyObj->get_rejects(); Print the names of the rejects and 1 letter code for reason they were rejected. foreach $key (sort keys %$rejects_ref) { print "$key: ", $rejects_ref->{$key}; } There is a lot of other information available about the sequences analyzed by Lucy (see APPENDIX). This module can be used with the DBI module to store this sequence information in a database. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Andrew G. Walsh paeruginosa@hotmail.com =head1 APPENDIX Methods available to Lucy objects are described below. Please note that any method beginning with an underscore is considered internal and should not be called directly. =cut package Bio::Tools::Lucy; use vars qw($AUTOLOAD @ATTR %OK_FIELD); use strict; use Bio::PrimarySeq; use base qw(Bio::Root::Root Bio::Root::IO); @ATTR = qw(seqfile qualfile stderrfile infofile lucy_verbose fwd_desig rev_desig adv_stderr); foreach my $attr (@ATTR) { $OK_FIELD{$attr}++ } sub AUTOLOAD { my $self = shift; my $attr = $AUTOLOAD; $attr =~ s/.*:://; $attr = lc $attr; $self->throw("Unallowed parameter: $attr !") unless $OK_FIELD{$attr}; $self->{$attr} = shift if @_; return $self->{$attr}; } =head2 new Title : new Usage : $lucyObj = Bio::Tools::Lucy->new(seqfile => lucy.seq, rev_desig => '_R', fwd_desig => '_F') Function: creates a Lucy object from Lucy analysis files Returns : reference to Bio::Tools::Lucy object Args : seqfile Fasta sequence file generated by Lucy qualfile Quality values file generated by Lucy infofile Info file created when Lucy is run with -debug 'infofile' option stderrfile Standard error captured from Lucy when Lucy is run with -info option and STDERR is directed to stderrfile (ie. lucy ... 2> stderrfile). Info in this file will include sequences dropped for low quality. If you've modified Lucy source (see adv_stderr below), it will also include info on which sequences were dropped because they were vector, too short, had no insert, and whether a poly-A tail was found (if Lucy was run with -cdna option). lucy_verbose verbosity level (0-1). fwd_desig The string used to determine whether sequence is a forward read. The parser will assume that this match will occus at the end of the sequence name string. rev_desig As above, for reverse reads. adv_stderr Can be set to a true value (1). Will only work if you have modified the Lucy source code as outlined in DESCRIPTION and capture the standard error from Lucy. If you don't provide filenames for qualfile, infofile or stderrfile, the module will assume that .qual, .info, and .stderr are the file extensions and search in the same directory as the .seq file for these files. For example, if you create a Lucy object with $lucyObj = Bio::Tools::Lucy-E<gt>new(seqfile =E<gt>lucy.seq), the module will find lucy.qual, lucy.info and lucy.stderr. You can omit any or all of the quality, info or stderr files, but you will not be able to use all of the object methods (see method documentation below). =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($attr, $value); while (@args) { $attr = shift @args; $attr = lc $attr; $value = shift @args; $self->{$attr} = $value; } &_parse($self); return $self; } =head2 _parse Title : _parse Usage : n/a (internal function) Function: called by new() to parse Lucy output files Returns : nothing Args : none =cut sub _parse { my $self = shift; $self->{seqfile} =~ /^(\S+)\.\S+$/; my $file = $1; $self->warn("Opening $self->{seqfile} for parsing...\n") if $self->{lucy_verbose}; open my $SEQ, $self->{seqfile} or $self->throw("Could not open sequence file: $self->{seqfile}"); my ($name, $line); my $seq = ""; my @lines = <$SEQ>; while ($line = pop @lines) { chomp $line; if ($line =~ /^>(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/) { $name = $1; if ($self->{fwd_desig}) { $self->{sequences}{$name}{direction} = "F" if $name =~ /^(\S+)($self->{fwd_desig})$/; } if ($self->{rev_desig}) { $self->{sequences}{$name}{direction} = "R" if $name =~ /^(\S+)($self->{rev_desig})$/; } $self->{sequences}{$name}{min_clone_len} = $2; # this is used for TIGR Assembler, as are $3 and $4 $self->{sequences}{$name}{max_clone_len} = $3; $self->{sequences}{$name}{med_clone_len} = $4; $self->{sequences}{$name}{beg_clear} = $5; $self->{sequences}{$name}{end_clear} = $6; $self->{sequences}{$name}{length_raw} = $seq =~ tr/[AGCTN]//; # from what I've seen, these are the bases Phred calls. Please let me know if I'm wrong. my $beg = $5-1; # substr function begins with index 0 $seq = $self->{sequences}{$name}{sequence} = substr ($seq, $beg, $6-$beg); my $count = $self->{sequences}{$name}{length_clear} = $seq =~ tr/[AGCTN]//; my $countGC = $seq =~ tr/[GC]//; $self->{sequences}{$name}{per_GC} = $countGC/$count * 100; $seq = ""; } else { $seq = $line.$seq; } } # now parse quality values (check for presence of quality file first) if ($self->{qualfile}) { open my $QUAL, "$self->{qualfile}" or $self->throw("Could not open quality file: $self->{qualfile}"); @lines = <$QUAL>; } elsif (-e "$file.qual") { $self->warn("You did not set qualfile, but I'm opening $file.qual\n") if $self->{lucy_verbose}; $self->qualfile("$file.qual"); open my $QUAL, "$file.qual" or $self->throw("Could not open quality file: $file.qual"); @lines = <$QUAL>; } else { $self->warn("I did not find a quality file. You will not be able to use all of the accessor methods.\n") if $self->{lucy_verbose}; @lines = (); } my (@vals, @slice, $num, $tot, $vals); my $qual = ""; while ($line = pop @lines) { chomp $line; if ($line =~ /^>(\S+)/) { $name = $1; @vals = split /\s/ , $qual; @slice = @vals[$self->{sequences}{$name}{beg_clear} - 1 .. $self->{sequences}{$name}{end_clear} - 1]; $vals = join "\t", @slice; $self->{sequences}{$name}{quality} = $vals; $qual = ""; foreach $num (@slice) { $tot += $num; } $num = @slice; $self->{sequences}{$name}{avg_quality} = $tot/$num; $tot = 0; } else { $qual = $line.$qual; } } # determine whether reads are full length if ($self->{infofile}) { open my $INFO, "$self->{infofile}" or $self->throw("Could not open info file: $self->{infofile}"); @lines = <$INFO>; } elsif (-e "$file.info") { $self->warn("You did not set infofile, but I'm opening $file.info\n") if $self->{lucy_verbose}; $self->infofile("$file.info"); open my $INFO, "$file.info" or $self->throw("Could not open info file: $file.info"); @lines = <$INFO>; } else { $self->warn("I did not find an info file. You will not be able to use all of the accessor methods.\n") if $self->{lucy_verbose}; @lines = (); } foreach (@lines) { /^(\S+).+CLV\s+(\d+)\s+(\d+)$/; if ($2>0 && $3>0) { $self->{sequences}{$1}{full_length} = 1 if $self->{sequences}{$1}; # will show cleavage info for rejected sequences too } } # parse rejects (and presence of poly-A if Lucy has been modified) if ($self->{stderrfile}) { open my $STDERR_LUCY, "$self->{stderrfile}" or $self->throw("Could not open quality file: $self->{stderrfile}"); @lines = <$STDERR_LUCY>; } elsif (-e "$file.stderr") { $self->warn("You did not set stderrfile, but I'm opening $file.stderr\n") if $self->{lucy_verbose}; $self->stderrfile("$file.stderr"); open my $STDERR_LUCY, "$file.stderr" or $self->throw("Could not open quality file: $file.stderr"); @lines = <$STDERR_LUCY>; } else { $self->warn("I did not find a standard error file. You will not be able to use all of the accessor methods.\n") if $self->{lucy_verbose}; @lines = (); } if ($self->{adv_stderr}) { foreach (@lines) { $self->{reject}{$1} = "Q" if /dropping\s+(\S+)/; $self->{reject}{$1} = "V" if /Vector: (\S+)/; $self->{reject}{$1} = "E" if /Empty: (\S+)/; $self->{reject}{$1} = "S" if m{Short/ no insert: (\S+)}; $self->{sequences}{$1}{polyA} = 1 if /(\S+) has PolyA/; if (/Dropped PolyA: (\S+)/) { $self->{reject}{$1} = "P"; delete $self->{sequences}{$1}; } } } else { foreach (@lines) { $self->{reject}{$1} = "R" if /dropping\s+(\S+)/; } } } =head2 get_Seq_Objs Title : get_Seq_Objs Usage : $lucyObj->get_Seq_Objs() Function: returns an array of references to Bio::PrimarySeq objects where -id = 'sequence name' and -seq = 'sequence' Returns : array of Bio::PrimarySeq objects Args : none =cut sub get_Seq_Objs { my $self = shift; my($seqobj, @seqobjs); foreach my $key (sort keys %{$self->{sequences}}) { $seqobj = Bio::PrimarySeq->new( -seq => "$self->{sequences}{$key}{sequence}", -id => "$key"); push @seqobjs, $seqobj; } return \@seqobjs; } =head2 get_Seq_Obj Title : get_Seq_Obj Usage : $lucyObj->get_Seq_Obj($seqname) Function: returns reference to a Bio::PrimarySeq object where -id = 'sequence name' and -seq = 'sequence' Returns : reference to Bio::PrimarySeq object Args : name of a sequence =cut sub get_Seq_Obj { my ($self, $key) = @_; my $seqobj = Bio::PrimarySeq->new( -seq => "$self->{sequences}{$key}{sequence}", -id => "$key"); return $seqobj; } =head2 get_sequence_names Title : get_sequence_names Usage : $lucyObj->get_sequence_names Function: returns reference to an array of names of the sequences analyzed by Lucy. These names are required for most of the accessor methods. Note: The Lucy binary will fail unless sequence names are unique. Returns : array reference Args : none =cut sub get_sequence_names { my $self = shift; my @keys = sort keys %{$self->{sequences}}; return \@keys; } =head2 sequence Title : sequence Usage : $lucyObj->sequence($seqname) Function: returns the DNA sequence of one of the sequences analyzed by Lucy. Returns : string Args : name of a sequence =cut sub sequence { my ($self, $key) = @_; return $self->{sequences}{$key}{sequence}; } =head2 quality Title : quality Usage : $lucyObj->quality($seqname) Function: returns the quality values of one of the sequences analyzed by Lucy. This method depends on the user having provided a quality file. Returns : string Args : name of a sequence =cut sub quality { my($self, $key) = @_; return $self->{sequences}{$key}{quality}; } =head2 avg_quality Title : avg_quality Usage : $lucyObj->avg_quality($seqname) Function: returns the average quality value for one of the sequences analyzed by Lucy. Returns : float Args : name of a sequence =cut sub avg_quality { my($self, $key) = @_; return $self->{sequences}{$key}{avg_quality}; } =head2 direction Title : direction Usage : $lucyObj->direction($seqname) Function: returns the direction for one of the sequences analyzed by Lucy providing that 'fwd_desig' or 'rev_desig' were set when the Lucy object was created. Strings returned are: 'F' for forward, 'R' for reverse. Returns : string Args : name of a sequence =cut sub direction { my($self, $key) = @_; return $self->{sequences}{$key}{direction} if $self->{sequences}{$key}{direction}; return ""; } =head2 length_raw Title : length_raw Usage : $lucyObj->length_raw($seqname) Function: returns the length of a DNA sequence prior to quality/ vector trimming by Lucy. Returns : integer Args : name of a sequence =cut sub length_raw { my($self, $key) = @_; return $self->{sequences}{$key}{length_raw}; } =head2 length_clear Title : length_clear Usage : $lucyObj->length_clear($seqname) Function: returns the length of a DNA sequence following quality/ vector trimming by Lucy. Returns : integer Args : name of a sequence =cut sub length_clear { my($self, $key) = @_; return $self->{sequences}{$key}{length_clear}; } =head2 start_clear Title : start_clear Usage : $lucyObj->start_clear($seqname) Function: returns the beginning position of good quality, vector free DNA sequence determined by Lucy. Returns : integer Args : name of a sequence =cut sub start_clear { my($self, $key) = @_; return $self->{sequences}{$key}{beg_clear}; } =head2 end_clear Title : end_clear Usage : $lucyObj->end_clear($seqname) Function: returns the ending position of good quality, vector free DNA sequence determined by Lucy. Returns : integer Args : name of a sequence =cut sub end_clear { my($self, $key) = @_; return $self->{sequences}{$key}{end_clear}; } =head2 per_GC Title : per_GC Usage : $lucyObj->per_GC($seqname) Function: returns the percente of the good quality, vector free DNA sequence determined by Lucy. Returns : float Args : name of a sequence =cut sub per_GC { my($self, $key) = @_; return $self->{sequences}{$key}{per_GC}; } =head2 full_length Title : full_length Usage : $lucyObj->full_length($seqname) Function: returns the truth value for whether or not the sequence read was full length (ie. vector present on both ends of read). This method depends on the user having provided the 'info' file (Lucy must be run with the -debug 'info_filename' option to get this file). Returns : boolean Args : name of a sequence =cut sub full_length { my($self, $key) = @_; return 1 if $self->{sequences}{$key}{full_length}; return 0; } =head2 polyA Title : polyA Usage : $lucyObj->polyA($seqname) Function: returns the truth value for whether or not a poly-A tail was detected and clipped by Lucy. This method depends on the user having modified the source for Lucy as outlined in DESCRIPTION and invoking Lucy with the -cdna option and saving the standard error. Note, the final sequence will not show the poly-A/T region. Returns : boolean Args : name of a sequence =cut sub polyA { my($self, $key) = @_; return 1 if $self->{sequences}{$key}{polyA}; return 0; } =head2 get_rejects Title : get_rejects Usage : $lucyObj->get_rejects() Function: returns a hash containing names of rejects and a 1 letter code for the reason Lucy rejected the sequence. Q- rejected because of low quality values S- sequence was short V- sequence was vector E- sequence was empty P- poly-A/T trimming caused sequence to be too short In order to get the rejects, you must provide a file with the standard error from Lucy. You will only get the quality category rejects unless you have modified the source and recompiled Lucy as outlined in DESCRIPTION. Returns : hash reference Args : none =cut sub get_rejects { my $self = shift; return $self->{reject}; } =head2 Diff for Lucy source code 352a353,354 > /* AGW added next line */ > fprintf(stderr, "Empty: %s\n", seqs[i].name); 639a642,643 > /* AGW added next line */ > fprintf(stderr, "Short/ no insert: %s\n", seqs[i].name); 678c682,686 < if (left) seqs[i].left+=left; --- > if (left) { > seqs[i].left+=left; > /* AGW added next line */ > fprintf(stderr, "%s has PolyA (left).\n", seqs[i].name); > } 681c689,693 < if (right) seqs[i].right-=right; --- > if (right) { > seqs[i].right-=right; > /* AGW added next line */ > fprintf(stderr, "%s has PolyA (right).\n", seqs[i].name); > } 682a695,696 > /* AGW added next line */ > fprintf(stderr, "Dropped PolyA: %s\n", seqs[i].name); 734a749,750 > /* AGW added next line */ > fprintf(stderr, "Vector: %s\n", seqs[i].name); =cut =head2 This patch is to be applied to lucy.c from the lucy-1.19p release 277a278,279 > /* AGW added next line */ > fprintf(stderr, "Short/ no insert: %s\n", seqs[i].name); 588c590,592 < if ((seqs[i].len=bases)<=0) --- > if ((seqs[i].len=bases)<=0) { > /* AGW added next line */ > fprintf(stderr, "Empty: %s\n", seqs[i].name); 589a594 > } 893c898,902 < if (left) seqs[i].left+=left; --- > if (left) { > seqs[i].left+=left; > /* AGW added next line */ > fprintf(stderr, "%s has PolyA (left).\n", seqs[i].name); > } 896c905,909 < if (right) seqs[i].right-=right; --- > if (right) { > seqs[i].right-=right; > /* AGW added next line */ > fprintf(stderr, "%s has PolyA (right).\n", seqs[i].name); > } 898a912,913 > /* AGW added next line */ > fprintf(stderr, "Dropped PolyA: %s\n", seqs[i].name); 949a965,966 > /* AGW added next line */ > fprintf(stderr, "Vector: %s\n", seqs[i].name); =cut 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Match.pm������������������������������������������������������������������000555��000765��000024�� 12666�12254227321� 16675� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: Match.pm,v 1.2 2007/06/14 18:01:52 nathan Exp $ # # BioPerl module for Bio::Tools::Match # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sendu Bala <bix@sendu.me.uk> # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Match - Parses output from Transfac's match(TM) =head1 SYNOPSIS use strict; use Bio::Tools::Match; my $parser = Bio::Tools::Match->new(-file => "match.out"); while (my $feat = $parser->next_result) { my $start = $feat->start; my $end = $feat->end; my $core_score = $feat->score; my $matrix_score = ($feat->annotation->get_Annotations('matrix_score'))[0]->value; my $matrix_id = ($feat->annotation->get_Annotations('matrix_id'))[0]->value; } =head1 DESCRIPTION This module is used to parse the output from Transfac's match(TM) program. It doesn't support the histogram output of match. Each result is a Bio::SeqFeature::Annotated representing a single matrix match. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Match; use strict; use Bio::SeqFeature::Generic; use Bio::Annotation::SimpleValue; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Match->new(); Function: Builds a new Bio::Tools::Match object Returns : Bio::Tools::Match Args : -file (or -fh) should contain the contents of a standard match output =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : $result = $obj->next_result(); Function: Returns the next result available from the input, or undef if there are no more results. Returns : Bio::SeqFeature::Annotated object. Features are annotated with tags for 'matrix_score', 'matrix_id' and a 'predicted' tag. Args : none =cut sub next_result { my ($self) = @_; my $line = $self->_readline || return; if (! $self->{found_seq_id} && $line =~ /^Inspecting sequence ID\s+(.+)/) { $self->{found_seq_id} = $1; } while ($line !~ /^\s\S+\s+\|\s+\d+/) { $line = $self->_readline || return; } # The first column gives the TRANSFAC(r) identifier of the matching matrix, # then comes the position and the strand where the respective match has been # found. The core similarity score is given in column three, the matrix # similarity score in column four. The last column gives the matching # sequence. # # #Search for sites by WeightMatrix library: /home/sendu/files/programs/transfac/cgi-bin/data/matrix.dat #Sequence file: sequence.fa #Site selection profile: mxprf Profile generated from /home/sendu/files/programs/transfac/cgi-bin/data/matrix.dat with default values. # # #Inspecting sequence ID Homo_sapiens # # V$MYOD_01 | 5 (+) | 0.751 | 0.784 | ttaGAGGTggcg # V$MYOD_01 | 5 (-) | 0.778 | 0.580 | ttagAGGTGgcg # V$MYOD_01 | 30 (+) | 0.751 | 0.581 | gctCAGGCaccc #[...] # V$RORA_Q4 | 53610 (+) | 0.775 | 0.668 | tgtgggGGCCA # V$RORA_Q4 | 53639 (+) | 0.775 | 0.636 | gtcgggGGACA # # Total sequences length=53654 # # Total number of found sites=1735559 # # Frequency of sites per nucleotide=32.347243 my ($matrix_id, $start, $strand, $core_score, $matrix_score, $seq) = $line =~ /^\s(\S+)\s+\|\s+(\d+)\s+\(([+-])\)\s+\|\s+(\S+)\s+\|\s+(\S+)\s+\|\s+(\S+)/; my $feat = Bio::SeqFeature::Generic->new( -seq_id => $self->{found_seq_id}, -start => $start, -end => $start + length($seq) - 1, -strand => 1, -score => $core_score, -source => 'transfac_match'); my $sv = Bio::Annotation::SimpleValue->new(-tagname => 'predicted', -value => 1); $feat->annotation->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'matrix_score', -value => $matrix_score); $feat->annotation->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'matrix_id', -value => $matrix_id); $feat->annotation->add_Annotation($sv); return $feat; } 1; ��������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/MZEF.pm�������������������������������������������������������������������000444��000765��000024�� 23044�12254227321� 16367� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::MZEF # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp-at-gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::MZEF - Results of one MZEF run =head1 SYNOPSIS $mzef = Bio::Tools::MZEF->new(-file => 'result.mzef'); # filehandle: $mzef = Bio::Tools::MZEF->new( -fh => \*INPUT ); # to indicate that the sequence was reversed prior to feeding it to MZEF # and that you want to have this reflected in the strand() attribute of # the exons, as well have the coordinates translated to the non-reversed # sequence $mzef = Bio::Tools::MZEF->new( -file => 'result.mzef', -strand => -1 ); # parse the results # note: this class is-a Bio::Tools::AnalysisResult which implements # Bio::SeqAnalysisParserI, i.e., $genscan->next_feature() is the same while($gene = $mzef->next_prediction()) { # $gene is an instance of Bio::Tools::Prediction::Gene # $gene->exons() returns an array of # Bio::Tools::Prediction::Exon objects # all exons: @exon_arr = $gene->exons(); # internal exons only @intrl_exons = $gene->exons('Internal'); # note that presently MZEF predicts only internal exons! } # essential if you gave a filename at initialization (otherwise the file # will stay open) $mzef->close(); =head1 DESCRIPTION The MZEF module provides a parser for MZEF gene structure prediction output. This module inherits off L<Bio::Tools::AnalysisResult> and therefore implements L<Bio::SeqAnalysisParserI>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp-at-gmx.net (or hilmar.lapp-at-pharma.novartis.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::MZEF; use strict; use Bio::Tools::Prediction::Gene; use Bio::Tools::Prediction::Exon; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my($self,@args) = @_; # first call the inherited method! my $make = $self->SUPER::_initialize_state(@args); # handle our own parameters my ($strand, $params) = $self->_rearrange([qw(STRAND )], @args); # our private state variables $strand = 1 unless defined($strand); $self->{'_strand'} = $strand; $self->{'_preds_parsed'} = 0; $self->{'_has_cds'} = 0; # array of pre-parsed predictions $self->{'_preds'} = []; } =head2 analysis_method Usage : $mzef->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /mzef/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /mzef/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $mzef->next_feature()) { # do something } Function: Returns the next gene structure prediction of the MZEF result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Note that with the present version of MZEF there will only be one object returned, because MZEF does not predict individual genes but just potential internal exons. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $mzef->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the MZEF result file. Call this method repeatedly until FALSE is returned. Note that with the present version of MZEF there will only be one object returned, because MZEF does not predict individual genes but just potential internal exons. Example : Returns : A Bio::Tools::Prediction::Gene object. Args : =cut sub next_prediction { my ($self) = @_; my $gene; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions() unless $self->_predictions_parsed(); # return the next gene structure (transcript) return $self->_prediction(); } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; my ($method); # set but not used presently my $exon_tag = "InternalExon"; my $gene; # my $seqname; # name given in output is poorly formatted my $seqlen; my $prednr = 1; while(defined($_ = $self->_readline())) { if(/^\s*(\d+)\s*-\s*(\d+)\s+/) { # exon or signal if(! defined($gene)) { $gene = Bio::Tools::Prediction::Gene->new( '-primary' => "GenePrediction$prednr", '-source' => 'MZEF'); } # we handle start-end first because may not be space delimited # for large numbers my ($start,$end) = ($1,$2); s/^\s*(\d+)\s*-\s*(\d+)\s+//; # split the rest into fields chomp(); # format: Coordinates P Fr1 Fr2 Fr3 Orf 3ss Cds 5ss # index: 0 1 2 3 4 5 6 7 my @flds = split(' ', $_); # create the feature object depending on the type of signal -- # which is always an (internal) exon for MZEF my $predobj = Bio::Tools::Prediction::Exon->new(); # set common fields $predobj->source_tag('MZEF'); $predobj->significance($flds[0]); $predobj->score($flds[0]); # what shall we set as overall score? $predobj->strand($self->{'_strand'}); # MZEF searches only one if($predobj->strand() == 1) { $predobj->start($start); $predobj->end($end); } else { $predobj->start($seqlen-$end+1); $predobj->end($seqlen-$start+1); } # set scores $predobj->start_signal_score($flds[5]); $predobj->end_signal_score($flds[7]); $predobj->coding_signal_score($flds[6]); # frame -- we simply extract the one with highest score from the # orf field, and store the individual scores for now my $frm = index($flds[4], "1"); $predobj->frame(($frm < 0) ? undef : $frm); $predobj->primary_tag($exon_tag); $predobj->is_coding(1); # add to gene structure (should be done only when start and end # are set, in order to allow for proper expansion of the range) $gene->add_exon($predobj); next; } if(/^\s*Internal .*(MZEF)/) { $self->analysis_method($1); next; } if(/^\s*File_Name:\s+(\S+)\s+Sequence_length:\s+(\d+)/) { # $seqname = $1; # this is too poor currently (file name truncated # to 10 chars) in order to be sensible enough $seqlen = $2; next; } } # $gene->seq_id($seqname); $self->_add_prediction($gene) if defined($gene); $self->_predictions_parsed(1); } =head2 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return unless(exists($self->{'_preds'}) && @{$self->{'_preds'}}); return shift(@{$self->{'_preds'}}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; if(! exists($self->{'_preds'})) { $self->{'_preds'} = []; } push(@{$self->{'_preds'}}, $gene); } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/OddCodes.pm���������������������������������������������������������������000444��000765��000024�� 26646�12254227323� 17327� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#$Id$ #----------------------------------------------------------------------------- # PACKAGE : OddCodes.pm # PURPOSE : To write amino acid sequences in alternative alphabets # AUTHOR : Derek Gatherer (D.Gatherer@organon.nhe.akzonobel.nl) # SOURCE : # CREATED : 8th July 2000 # MODIFIED : # DISCLAIMER : I am employed in the pharmaceutical industry but my # : employers do not endorse or sponsor this module # : in any way whatsoever. The above email address is # : given purely for the purpose of easy communication # : with the author, and does not imply any connection # : between my employers and anything written below. # LICENCE : You may distribute this module under the same terms # : as the rest of BioPerl. #---------------------------------------------------------------------------- =head1 NAME Bio::Tools::OddCodes - Object holding alternative alphabet coding for one protein sequence =head1 SYNOPSIS # Take a sequence object from eg, an inputstream, and creates an # object for the purposes of rewriting that sequence in another # alphabet. These are abbreviated amino acid sequence alphabets, # designed to simplify the statistical aspects of analysing protein # sequences, by reducing the combinatorial explosion of the # 20-letter alphabet. These abbreviated alphabets range in size # from 2 to 8. # Creating the OddCodes object, eg: my $inputstream = Bio::SeqIO->new( '-file' => "seqfile", '-format' => 'Fasta'); my $seqobj = $inputstream->next_seq(); my $oddcode_obj = Bio::Tools::Oddcodes->new(-seq => $seqobj); # or: my $seqobj = Bio::PrimarySeq->new (-seq=>'[cut and paste a sequence here]', -alphabet => 'protein', -id => 'test'); my $oddcode_obj = Bio::Tools::OddCodes->new(-seq => $seqobj); # do the alternative coding, returning the answer as a reference to # a string my $output = $oddcode_obj->structural(); my $output = $oddcode_obj->chemical(); my $output = $oddcode_obj->functional(); my $output = $oddcode_obj->charge(); my $output = $oddcode_obj->hydrophobic(); my $output = $oddcode_obj->Dayhoff(); my $output = $oddcode_obj->Sneath(); my $output = $oddcode_obj->Stanfel(); # display sequence in new form, eg: my $new_coding = $$output; print "\n$new_coding"; =head1 DESCRIPTION Bio::Tools::Oddcodes is a welterweight object for rewriting a protein sequence in an alternative alphabet. Eight of these are provided, ranging from the the 2-letter hydrophobic alphabet, to the 8-letter chemical alphabet. These are useful for the statistical analysis of protein sequences since they can partially avoid the combinatorial explosion produced by the full 20-letter alphabet (eg. 400 dimers, 8000 trimers etc.) The objects will print out a warning if the input sequence is not a protein. If you know what you are doing, you can silence the warning by setting verbose() to a negative value. See SYNOPSIS above for object creation code. =head1 REFERENCES Stanfel LE (1996) A new approach to clustering the amino acids. J. theor. Biol. 183, 195-205. Karlin S, Ost F and Blaisdell BE (1989) Patterns in DNA and amino acid sequences and their statistical significance. Chapter 6 of: Mathematical Methods for DNA Sequences. Waterman MS (ed.) CRC Press, Boca Raton , FL. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Derek Gatherer =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::OddCodes; use strict; use base qw(Bio::Root::Root); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($seqobj) = $self->_rearrange([qw(SEQ)],@args); if((! defined($seqobj)) && @args && ref($args[0])) { # parameter not passed as named parameter? $seqobj = $args[0]; } unless ($seqobj->isa("Bio::PrimarySeqI")) { $self->throw("Bio::Tools::OddCodes only works on PrimarySeqI objects"); } $self->{'_seqref'} = $seqobj; return $self; } =head2 structural Title : structural Usage : $output = $oddcode_obj->structural(); Function: turns amino acid sequence into 3-letter structural alphabet : A (ambivalent), E (external), I (internal) Example : a sequence ACDEFGH will become AAEEIAE Returns : Reference to the new sequence string Args : none =cut sub structural() { my $self = $_[0]; my $seqstring = &_pullseq($self); # see _pullseq() below # now the real business $seqstring =~ tr/[ACGPSTWY]/1/; $seqstring =~ tr/[RNDQEHK]/2/; $seqstring =~ tr/[ILMFV]/3/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/E/; $seqstring =~ tr/3/I/; return \$seqstring; # and that's that one } =head2 functional Title : functional Usage : $output = $oddcode_obj->functional(); Function: turns amino acid sequence into 4-letter functional alphabet : A (acidic), C (basic), H (hydrophobic), P (polar) Example : a sequence ACDEFGH will become HPAAHHC Returns : Reference to the new sequence string Args : none =cut sub functional() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[DE]/1/; $seqstring =~ tr/[HKR]/2/; $seqstring =~ tr/[AFILMPVW]/3/; $seqstring =~ tr/[CGNQSTY]/4/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/C/; $seqstring =~ tr/3/H/; $seqstring =~ tr/4/P/; return \$seqstring; # and that's that one } =head2 hydrophobic Title : hydrophobic Usage : $output = $oddcode_obj->hydrophobic(); Function: turns amino acid sequence into 2-letter hydrophobicity alphabet : O (hydrophobic), I (hydrophilic) Example : a sequence ACDEFGH will become OIIIOII Returns : Reference to the new sequence string Args : none =cut sub hydrophobic() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[AFILMPVW]/1/; $seqstring =~ tr/[CDEGHKNQRSTY]/2/; $seqstring =~ tr/1/I/; $seqstring =~ tr/2/O/; return \$seqstring; # and that's that one } =head2 Dayhoff Title : Dayhoff Usage : $output = $oddcode_obj->Dayhoff(); Function: turns amino acid sequence into 6-letter Dayhoff alphabet Example : a sequence ACDEFGH will become CADDGCE : A (=C), C (=AGPST), D (=DENQ), : E (=HKR), F (=ILMV), G (=FWY) Returns : Reference to the new sequence string Args : none =cut sub Dayhoff() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[C]/1/; $seqstring =~ tr/[AGPST]/2/; $seqstring =~ tr/[DENQ]/3/; $seqstring =~ tr/[HKR]/4/; $seqstring =~ tr/[ILMV]/5/; $seqstring =~ tr/[FWY]/6/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/C/; $seqstring =~ tr/3/D/; $seqstring =~ tr/4/E/; $seqstring =~ tr/5/F/; $seqstring =~ tr/6/G/; return \$seqstring; # and that's that one } =head2 Sneath Title : Sneath Usage : $output = $oddcode_obj->Sneath(); Function: turns amino acid sequence into 7-letter Sneath alphabet Example : a sequence ACDEFGH will become CEFFHCF : A (=ILV), C (=AGP), D (=MNQ), E (=CST), : F (=DE), G (=KR), H (=FHWY) Returns : Reference to the new sequence string Args : none =cut sub Sneath() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[ILV]/1/; $seqstring =~ tr/[AGP]/2/; $seqstring =~ tr/[MNQ]/3/; $seqstring =~ tr/[CST]/4/; $seqstring =~ tr/[DE]/5/; $seqstring =~ tr/[KR]/6/; $seqstring =~ tr/[FHWY]/7/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/C/; $seqstring =~ tr/3/D/; $seqstring =~ tr/4/E/; $seqstring =~ tr/5/F/; $seqstring =~ tr/6/G/; $seqstring =~ tr/7/H/; return \$seqstring; # and that's that one } =head2 Stanfel Title : Stanfel Usage : $output = $oddcode_obj->Stanfel(); Function: turns amino acid sequence into 4-letter Stanfel alphabet Example : a sequence ACDEFGH will become AACCDAE : A (=ACGILMPSTV), C (=DENQ), D (=FWY), E (=HKR) Returns : Reference to the new sequence string Args : none =cut sub Stanfel() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[ACGILMPSTV]/1/; $seqstring =~ tr/[DENQ]/2/; $seqstring =~ tr/[FWY]/3/; $seqstring =~ tr/[HKR]/4/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/C/; $seqstring =~ tr/3/D/; $seqstring =~ tr/4/E/; return \$seqstring; # and that's that one } =head2 chemical Title : chemical Usage : $output = $oddcode_obj->chemical(); Function: turns amino acid sequence into 8-letter chemical alphabet : A (acidic), L (aliphatic), M (amide), R (aromatic) : C (basic), H (hydroxyl), I (imino), S (sulphur) Example : a sequence ACDEFGH will become LSAARAC Returns : Reference to the new sequence string Args : none =cut sub chemical() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[DE]/1/; $seqstring =~ tr/[AGILV]/2/; $seqstring =~ tr/[NQ]/3/; $seqstring =~ tr/[FWY]/4/; $seqstring =~ tr/[RHK]/5/; $seqstring =~ tr/[ST]/6/; $seqstring =~ tr/P/7/; $seqstring =~ tr/[CM]/8/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/L/; $seqstring =~ tr/3/M/; $seqstring =~ tr/4/R/; $seqstring =~ tr/5/C/; $seqstring =~ tr/6/H/; $seqstring =~ tr/7/I/; $seqstring =~ tr/8/S/; return \$seqstring; # and that's that one } =head2 charge Title : charge Usage : $output = $oddcode_obj->charge(); Function: turns amino acid sequence into 3-letter charge alphabet Example : a sequence ACDEFGH will become NNAANNC : A (negative; NOT anode), C (positive; NOT cathode), N (neutral) Returns : Reference to the new sequence string Args : none =cut sub charge() { my $self = $_[0]; my $seqstring = &_pullseq($self); # now the real business $seqstring =~ tr/[DE]/1/; $seqstring =~ tr/[HKR]/2/; $seqstring =~ tr/[ACFGILMNPQSTVWY]/3/; $seqstring =~ tr/1/A/; $seqstring =~ tr/2/C/; $seqstring =~ tr/3/N/; return \$seqstring; # and that's that one } # _pullseq is called within each of the subroutines # it just checks a few things and returns the sequence sub _pullseq { my $self = $_[0]; my $seqobj = $self->{'_seqref'}; unless ($seqobj->isa("Bio::PrimarySeqI")) { $self->throw("die, OddCodes works only on PrimarySeqI objects\n"); } $self->warn("\tAll OddCode alphabets need a protein sequence,\n". "\tbut BioPerl thinks this is not: [". $seqobj->id. "]") unless $seqobj->alphabet eq 'protein' or $self->verbose < 0;; my $seqstring = uc $seqobj->seq(); if(length($seqstring)<1) { $self->throw("$seqstring: die, sequence has zero length\n"); } return $seqstring; } 1; ������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/pICalculator.pm�����������������������������������������������������������000555��000765��000024�� 24260�12254227317� 20221� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::pICalculator # # Copyright (c) 2002, Merck & Co. Inc. All Rights Reserved. # # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::pICalculator - calculate the isoelectric point of a protein =head1 DESCRIPTION Calculates the isoelectric point of a protein, the pH at which there is no overall charge on the protein. Calculates the charge on a protein at a given pH. Can use built-in sets of pK values or custom pK sets. =head1 SYNOPSIS use Bio::Tools::pICalculator; use Bio::SeqIO; my $in = Bio::SeqIO->new( -fh => \*STDIN , -format => 'Fasta' ); my $calc = Bio::Tools::pICalculator->new(-places => 2, -pKset => 'EMBOSS'); while ( my $seq = $in->next_seq ) { $calc->seq($seq); my $iep = $calc->iep; print sprintf( "%s\t%s\t%.2f\n", $seq->id, $iep, $calc->charge_at_pH($iep) ); for( my $i = 0; $i <= 14; $i += 0.5 ){ print sprintf( "pH = %.2f\tCharge = %.2f\n", $i, $calc->charge_at_pH($i) ); } } =head1 SEE ALSO http://fields.scripps.edu/DTASelect/20010710-pI-Algorithm.pdf http://emboss.sourceforge.net/apps/cvs/emboss/apps/iep.html http://us.expasy.org/tools/pi_tool.html =head1 LIMITATIONS There are various sources for the pK values of the amino acids. The set of pK values chosen will affect the pI reported. The charge state of each residue is assumed to be independent of the others. Protein modifications (such as a phosphate group) that have a charge are ignored. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Mark Southern (mark_southern@merck.com). From an algorithm by David Tabb found at http://fields.scripps.edu/DTASelect/20010710-pI-Algorithm.pdf. Modification for Bioperl, additional documentation by Brian Osborne. =head1 COPYRIGHT Copyright (c) 2002, Merck & Co. Inc. All Rights Reserved. This module is free software. 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) =head1 APPENDIX The rest of the documentation details each of the object methods. Private methods are usually preceded by a _. =cut # Let the code begin... package Bio::Tools::pICalculator; use strict; use base qw(Bio::Root::Root); # pK values from the DTASelect program from Scripps # http://fields.scripps.edu/DTASelect my $DTASelect_pK = { N_term => 8.0, K => 10.0, # Lys R => 12.0, # Arg H => 6.5, # His D => 4.4, # Asp E => 4.4, # Glu C => 8.5, # Cys Y => 10.0, # Tyr C_term => 3.1 }; # pK values from the iep program from EMBOSS # http://emboss.sourceforge.net/apps/cvs/emboss/apps/iep.html my $Emboss_pK = { N_term => 8.6, K => 10.8, # Lys R => 12.5, # Arg H => 6.5, # His D => 3.9, # Asp E => 4.1, # Glu C => 8.5, # Cys Y => 10.1, # Tyr C_term => 3.6 }; =head2 desc Title : new Usage : Bio::Tools::pICalculator->new Function: Instantiates the Bio::Tools::pICalculator object Example : $calc = Bio::Tools::pICalculator->new( -pKset => \%pKvalues, # a Bio::Seq object -seq => $seq, -places => 2 ); or: $calc = Bio::Tools::pICalculator->new( -pKset => 'string', # a Bio::Seq object -seq => $seq, -places => 1 ); Constructs a new pICalculator. Arguments are a flattened hash. Valid, optional keys are: pKset - A reference to a hash with key value pairs for the pK values of the charged amino acids. Required keys are: N_term C_term K R H D E C Y pKset - A string ( 'DTASelect' or 'EMBOSS' ) that will specify an internal set of pK values to be used. The default is 'EMBOSS' seq - A Bio::Seq sequence object to analyze places - The number of decimal places to use in the isoelectric point calculation. The default is 2. Returns : The description Args : The description or none =cut sub new { my( $class, %opts ) = @_; my $self = $class->SUPER::new(%opts); $self = bless {}, ref $self || $self; $self->seq( $opts{-seq} ) if exists $opts{-seq}; $self->pKset( $opts{-pKset} || 'EMBOSS' ); exists $opts{-places} ? $self->places( $opts{-places} ) : $self->places(2); return $self; } =head2 seq Title : seq Usage : $calc->seq($seqobj) Function: Sets or returns the Bio::Seq used in the calculation Example : $seqobj = Bio::Seq->new(-seq=>"gghhhmmm",-id=>"GHM"); $calc = Bio::Tools::pICalculator->new; $calc->seq($seqobj); Returns : Bio::Seq object Args : Bio::Seq object or none =cut sub seq { my( $this, $seq ) = @_; unless( defined $seq && UNIVERSAL::isa($seq,'Bio::Seq') ){ $this->throw("$seq is not a valid Bio::Seq object"); } $this->{-seq} = $seq; $this->{-count} = count_charged_residues( $seq ); return $this->{-seq}; } =head2 pKset Title : pKset Usage : $pkSet = $calc->pKSet(\%pKSet) Function: Sets or returns the hash of pK values used in the calculation Example : $calc->pKset('emboss') Returns : reference to pKset hash Args : The reference to a pKset hash, a string, or none. Examples: pKset - A reference to a hash with key value pairs for the pK values of the charged amino acids. Required keys are: N_term C_term K R H D E C Y pKset - A valid string ( 'DTASelect' or 'EMBOSS' ) that will specify an internal set of pK values to be used. The default is 'EMBOSS' =cut sub pKset { my ( $this, $pKset ) = @_; if( ref $pKset eq 'HASH' ){ # user defined pK values $this->{-pKset} = $pKset; }elsif( $pKset =~ /^emboss$/i ){ # from EMBOSS's iep program $this->{-pKset} = $Emboss_pK; }elsif( $pKset =~ /^dtaselect$/i ){ # from DTASelect (scripps) $this->{-pKset} = $DTASelect_pK; }else{ # default to EMBOSS $this->{-pKset} = $Emboss_pK; } return $this->{-pKset}; } sub places { my $this = shift; $this->{-places} = shift if @_; return $this->{-places}; } =head2 iep Title : iep Usage : $calc->iep Function: Returns the isoelectric point Example : $calc = Bio::Tools::pICalculator->new(-places => 2); $calc->seq($seqobj); $iep = $calc->iep; Returns : The isoelectric point of the sequence in the Bio::Seq object Args : None =cut sub iep { my $this = shift; return _calculate_iep($this->{-pKset}, $this->{-places}, $this->{-seq}, $this->{-count} ); } =head2 charge_at_pH Title : charge_at_pH Usage : $charge = $calc->charge_at_pH($pH) Function: Sets or gets the description of the sequence Example : $calc = Bio::Tools::pICalculator->new(-places => 2); $calc->seq($seqobj); $charge = $calc->charge_at_ph("7"); Returns : The predicted charge at the given pH Args : pH =cut sub charge_at_pH { my $this = shift; return _calculate_charge_at_pH( shift, $this->{-pKset}, $this->{-count} ); } sub count_charged_residues { my $seq = shift; my $sequence = $seq->seq; my $count; for ( qw( K R H D E C Y ) ){ # charged AA's $count->{$_}++ while $sequence =~ /$_/ig; } return $count; } sub _calculate_iep { my( $pK, $places, $seq, $count ) = @_; my $pH = 7.0; my $step = 3.5; my $last_charge = 0.0; my $format = "%.${places}f"; unless( defined $count ){ $count = count_charged_residues($seq); } while(1){ my $charge = _calculate_charge_at_pH( $pH, $pK, $count ); last if sprintf($format,$charge) == sprintf($format,$last_charge); $charge > 0 ? ( $pH += $step ) : ( $pH -= $step ); $step /= 2.0; $last_charge = $charge; } return sprintf( $format, $pH ); } # it's the sum of all the partial charges for the # termini and all of the charged aa's! sub _calculate_charge_at_pH { no warnings; # don't complain if a given key doesn't exist my( $pH, $pK, $count ) = @_; my $charge = _partial_charge( $pK->{N_term}, $pH ) + $count->{K} * _partial_charge( $pK->{K}, $pH ) + $count->{R} * _partial_charge( $pK->{R}, $pH ) + $count->{H} * _partial_charge( $pK->{H}, $pH ) - $count->{D} * _partial_charge( $pH, $pK->{D} ) - $count->{E} * _partial_charge( $pH, $pK->{E} ) - $count->{C} * _partial_charge( $pH, $pK->{C} ) - $count->{Y} * _partial_charge( $pH, $pK->{Y} ) - _partial_charge( $pH, $pK->{C_term} ); return $charge; } # Concentration Ratio is 10**(pK - pH) for positive groups # and 10**(pH - pK) for negative groups sub _partial_charge { my $cr = 10 ** ( $_[0] - $_[1] ); return $cr / ( $cr + 1 ); } 1; __END__ ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer3.pm����������������������������������������������������������������000555��000765��000024�� 30517�12254227323� 17157� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Primer3 # # Copyright (c) 2003 bioperl, Rob Edwards. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Copyright Rob Edwards # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Primer3 - Create input for and work with the output from the program primer3 =head1 SYNOPSIS # parse primer3 output to get some data # this is also called from Bio::Tools::Run::Primer3 use Bio::Tools::Primer3; # read a primer3 output file my $p3 = Bio::Tools::Primer3->new(-file=>"data/primer3_output.txt"); # how many results were there? my $num = $p3->number_of_results; print "There were $num results\n"; # get all the results my $all_results = $p3->all_results; print "ALL the results\n"; foreach my $key (keys %{$all_results}) { print "$key\t${$all_results}{$key}\n"; } # get specific results my $result1 = $p3->primer_results(1); print "The first primer is\n"; foreach my $key (keys %{$result1}) { print "$key\t${$result1}{$key}\n"; } # get the results as a Bio::Seq::PrimedSeq stream my $primer = $p3->next_primer; print "The left primer in the stream is ", $primer->get_primer('-left_primer')->seq->seq, "\n"; =head1 DESCRIPTION Bio::Tools::Primer3 creates the input files needed to design primers using primer3 and provides mechanisms to access data in the primer3 output files. This module provides a bioperl interface to the program primer3. See http://www-genome.wi.mit.edu/genome_software/other/primer3.html for details and to download the software. This module is based on one written by Chad Matsalla (bioinformatics1@dieselwurks.com) I have ripped some of his code, and added a lot of my own. I hope he is not mad at me! This is probably best run in one of the two following ways: i. To parse the output from Bio::Tools::Run::Primer3. You will most likely just use next_primer to get the results from Bio::Tools::Run::Primer3. ii. To parse the output of primer3 handed to it as a file name. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Rob Edwards redwards@utmem.edu Based heavily on work of Chad Matsalla bioinformatics1@dieselwurks.com =head1 CONTRIBUTORS Brian Osborne bosborne at alum.mit.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Primer3; use strict; use Bio::Seq; use Bio::Seq::PrimedSeq; use Bio::SeqFeature::Primer; use vars qw($AUTOLOAD @PRIMER3_PARAMS %OK_FIELD $ID); BEGIN { @PRIMER3_PARAMS = qw(results seqobject); foreach my $attr (@PRIMER3_PARAMS) {$OK_FIELD{$attr}++} } use base qw(Bio::Root::Root Bio::Root::IO); sub AUTOLOAD { my $self = shift; my $attr = $AUTOLOAD; $attr =~ s/.*:://; $self->throw("Unallowed parameter: $attr !") unless $OK_FIELD{$attr}; $self->{$attr} = shift if @_; return $self->{$attr}; } =head2 new Title : new() Usage : my $primer3 = Bio::Tools::Primer3->new(-file=>$file); Function: Parse primer3 output Returns : Does not return anything. If called with a filename will allow you to retrieve the results Args : -file (optional) file of primer3 results to parse -verbose (optional) set verbose output Notes : =cut sub new { my($class,%args) = @_; my $self = $class->SUPER::new(%args); if ($args{'-file'}) { $self->_readfile($args{'-file'}); } if ($args{'-verbose'}) { $self->{'verbose'} = 1; } return $self; } =head2 number_of_results Title : number_of_results() Usage : my $count = $primer3->number_of_results(); Function: Retrieve the number of primers returned from Primer3. Returns : A scalar Args : None Notes : This returns the count of the primers returned by Primer3 (aka how many of them there are). This is one more than the maximum offset into the zero based list of primers that is accessed by primer_results(). =cut sub number_of_results { my $self = shift; return $self->{'maximum_primers_returned'} + 1; } =head2 all_results Title : all_results() Usage : my $results = $primer3->all_results(); or my $results = $primer3->all_results('primer3 result name', 'other results'); Function: Retrieve the results returned from Primer3. Returns : A reference to a hash Args : Optional array of specific results to retrieve =cut sub all_results { my ($self, @results) = @_; my %hash; if (@results) { # we only want a few things foreach my $result (@results) { $hash{$result} = $self->{'results'}->$result; } } else { foreach my $result (keys %{$self->{'results'}}) { $hash{$result}=$self->{'results'}->{$result}; } } return \%hash; } =head2 primer_results Title : primer_results() Usage : my $results = $primer3->primer_results(2); # results for third primer Function: Retrieve the results returned from Primer3 for specific primer pairs. Returns : A reference to a hash Args : A number between 0 and the maximum number of primers to retrieve =cut sub primer_results { my ($self, $toget) = @_; if ($toget > $self->{'maximum_primers_returned'}) { $self->warn("Didn't get any results for $toget"); return 0; } else { return \%{$self->{'results_by_number'}->{$toget}}; } } =head2 _readfile Title : _readfile() Usage : $self->_readfile(); Function: An internal function that reads a file and sets up the results Returns : Nothing. Args : None Notes : =cut sub _readfile { my ($self, $file) = @_; $self->_initialize_io(-file=>$file); my $line; my $id='primer 3 parsed results'; # hopefully we'll get this, but we can set a temp id in case not. while (defined($line = $self->_readline()) ) { chomp $line; next unless ($line); my ($return, $value) = split /=/, $line; if (uc($return) eq "SEQUENCE") { $self->{seqobject} = Bio::Seq->new(-seq=>$value, $id=>$id); next; } if (uc($return) eq "PRIMER_SEQUENCE_ID") { if ($self->{seqobject}) {$self->{seqobject}->id($value)} else {$id=$value} } $self->{'results'}->{$return} = $value; } # convert the results to individual results $self->_separate(); } =head2 next_primer Title : next_primer() Usage : while (my $primed_seq = $primer3->next_primer()) { Function: Retrieve the primed sequence and a primer pair, one at a time Returns : Returns a Bio::Seq::PrimedSeq object, one at a time Args : None Notes : Use $primed_seq->annotated_seq to get an annotated sequence object you can write out. =cut sub next_primer { my $self = shift; # here we are going to convert the primers to Bio::SeqFeature::Primer objects # and the primer/sequence to Bio::Seq::PrimedSeq objects # the problem at the moment is that PrimedSeq can only take one sequence/primer pair, and # yet for each sequence we can have lots of primer pairs. We need a way to overcome this. # at the moment we can do this as a stream, I guess. $self->warn("No primers were found for: ".$self->{'seqobject'}->{'primary_id'}) if (! $self->number_of_results); $self->{'next_to_return'} = 0 unless ($self->{'next_to_return'}); return if ($self->{'next_to_return'} >= $self->number_of_results); my $results = $self->primer_results($self->{'next_to_return'}); $self->throw("No left primer sequence") unless (${$results}{'PRIMER_LEFT_SEQUENCE'}); $self->throw("No right primer sequence") unless (${$results}{'PRIMER_RIGHT_SEQUENCE'}); $self->throw("No target sequence") unless ($self->{'seqobject'}); my $left_seq = Bio::SeqFeature::Primer->new( -id => 'left_primer', -seq => ${$results}{'PRIMER_LEFT_SEQUENCE'}, -display_id => ($self->{'next_to_return'} + 1), ); my $right_seq = Bio::SeqFeature::Primer->new( -id => "right_primer", -seq => ${$results}{'PRIMER_RIGHT_SEQUENCE'}, -display_id => ($self->{'next_to_return'} + 1) ); # add data to the Primer objects for my $key (%$results) { # skip the primer sequence data, already added above next if ($key =~ /PRIMER_(LEFT|RIGHT)_SEQUENCE/i ); if ($key =~ /PRIMER_LEFT/i) { $left_seq->add_tag_value($key, $$results{$key}); } elsif ($key =~ /PRIMER_RIGHT/i) { $right_seq->add_tag_value($key, $$results{$key}); } } my $primed_seq = Bio::Seq::PrimedSeq->new( -target_sequence => $self->{'seqobject'}->clone, -left_primer => $left_seq, -right_primer => $right_seq, ); # add data to the the PrimedSeq object that's not specific to the Primers for my $key (%$results) { next if ($key =~ /PRIMER_(LEFT|RIGHT)/i ); $primed_seq->add_tag_value($key, $$results{$key}); } $self->{'next_to_return'}++; return $primed_seq; } =head2 primer_stream Title : primer_stream() Usage : while (my $primed_seq = $primer3->primer_stream()) { Function: Retrieve the primer/sequences one at a time Returns : Returns a Bio::Seq::PrimedSeq object, one at a time Args : None Notes : Deprecated, just a link to next_primer =cut sub primer_stream { my $self = shift; my $primedseq = $self->next_primer; return $primedseq; } =head2 _separate Title : _separate() Usage : $self->_separate(); Function: An internal function that groups the results by number (e.g. primer pair 1, etc) Returns : Nothing. Args : None Notes : =cut sub _separate { my $self = shift; my %results; # the results that we find my $maxlocation = -1; # the maximum number of primers returned foreach my $key (keys %{$self->{'results'}}) { next if (${$self->{'input_options'}}{$key}); # don't process it if it is an input key my $location; # the number of the primer pair # names will have values like # PRIMER_RIGHT_SEQUENCE, PRIMER_RIGHT_2_SEQUENCE, PRIMER_PRODUCT_SIZE, and # PRIMER_PRODUCT_SIZE_3 hence we need to find and remove the number my $tempkey = $key; if ($tempkey =~ s/_(\d+)//) { $location = $1; if ($location > $maxlocation) {$maxlocation = $location} } elsif ( $tempkey =~ /PRIMER_(RIGHT|LEFT)_SEQUENCE/ ) { # first primers reported without a number, therefore set $location to 0 $location = 0; if ($location > $maxlocation) {$maxlocation = $location} } else { $location = 0; } # we will hash the results by number, and then by name ${$results{$location}}{$tempkey}=${$self->{'results'}}{$key}; } $self->{'results_by_number'} = \%results; $self->{'maximum_primers_returned'} = $maxlocation; } =head2 _set_variable Title : _set_variable() Usage : $self->_set_variable('variable name', 'value'); Function: An internal function that sets a variable Returns : Nothing. Args : None Notes : Used to set $self->{results} and $self->seqobject =cut sub _set_variable { my ($self, $name, $value) = @_; next unless ($name); $self->{$name} = $value; } 1; __END__ ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Prints.pm�����������������������������������������������������������������000555��000765��000024�� 13650�12254227323� 17114� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Prints # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Balamurugan Kumarasamy # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code # =head1 NAME Bio::Tools::Prints - Parser for FingerPRINTScanII program =head1 SYNOPSIS use Bio::Tools::Prints; my $prints_parser = Bio::Tools::Prints->new(-fh =>$filehandle ); while( my $prints_feat = $prints_parser->next_result ) { push @prints_feat, $prints_feat; } =head1 DESCRIPTION PRINTScan II is a PRINTS fingerprint identification algorithm. Copyright (C) 1998,1999 Phil Scordis =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Balamurugan Kumarasamy bala@tll.org.sg juguang@tll.org.sg =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Prints; use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Prints->new(-fh=>$filehandle); Function: Builds a new Bio::Tools::Prints object Returns : Bio::Tools::Prints Args : -filename -fh (filehandle) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $prints_parser->next_result Function: Get the next result set from parser data Returns : L<Bio::SeqFeature::Generic> Args : none =cut sub next_result { my ($self) = @_; my %printsac; my @features; my $line; my $sequenceId; while ($_=$self->_readline()) { $line = $_; chomp $line; if ($line =~ s/^Sn;//) { # We have identified a Sn; line so there should be the following: ($sequenceId) = $line =~ /^\s*(\w+)/; $self->seqname($sequenceId); next; } if ($line =~ s/^1TBH//) { my ($id) = $line =~ /^\s*(\w+)/; my ($ac) = $line =~ /(PR\w+)\s*$/; $printsac{$id} = $ac; $self->print_sac(\%printsac); next; } if ($line =~ s/^3TB//) { if ($line =~ s/^[HN]//) { my($num)=""; $line =~ s/^\s+//; my @elements = split /\s+/, $line; my ($fingerprintName,$motifNumber,$temp,$tot,$percentageIdentity,$profileScore,$pvalue,$subsequence,$motifLength,$lowestMotifPosition,$matchPosition,$highestMotifPosition) = @elements; my $start = $matchPosition; my $end = $matchPosition + $motifLength - 1; my $print_sac = $self->print_sac; my %printsac = %{$print_sac}; my $print = $printsac{$fingerprintName}; my $seqname=$self->seqname; my $feat = "$print,$start,$end,$percentageIdentity,$profileScore,$pvalue"; my $new_feat = $self->create_feature($feat,$seqname); return $new_feat; } if ($line =~ s/^F//) { return; } next; } next; } } =head2 create_feature Title : create_feature Usage : my $feat=$prints_parser->create_feature($feature,$seqname) Function: creates a SeqFeature Generic object Returns : L<Bio::SeqFeature::FeaturePair> Args : =cut sub create_feature { my ($self, $feat,$sequenceId) = @_; my @f = split (/,/,$feat); # create feature object my $feature= Bio::SeqFeature::Generic->new( -seq_id =>$sequenceId, -start=>$f[1], -end => $f[2], -score => $f[4], -source => "PRINTS", -primary =>$f[0], -logic_name => "PRINTS", ); $feature->add_tag_value('evalue',$f[5]); $feature->add_tag_value('percent_id',$f[3]); my $feature2 = Bio::SeqFeature::Generic->new( -seq_id => $f[0], -start => 0, -end => 0, ); my $fp = Bio::SeqFeature::FeaturePair->new( -feature1 => $feature, -feature2 => $feature2 ); return $fp; } =head2 print_sac Title : print_sac Usage : $prints_parser->print_sac($print_sac) Function: get/set for print_sac Returns : Args : =cut sub print_sac { my $self = shift; return $self->{'print_sac'} = shift if @_; return $self->{'print_sac'}; } =head2 seqname Title : seqname Usage : $prints_parser->seqname($seqname) Function: get/set for seqname Returns : Args : =cut sub seqname { my($self,$seqname)=@_; return $self->{'seqname'}=$seqname if(defined($seqname)); return $self->{'seqname'}; } 1; ����������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Profile.pm����������������������������������������������������������������000444��000765��000024�� 10727�12254227327� 17240� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Profile # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Balamurugan Kumarasamy # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Profile - parse Profile output =head1 SYNOPSIS use Bio::Tools::Profile; my $profile_parser = Bio::Tools::Profile->new(-fh =>$filehandle ); while( my $profile_feat = $profile_parser->next_result ) { push @profile_feat, $profile_feat; } =head1 DESCRIPTION Parser for Profile output =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Balamurugan Kumarasamy Email: fugui@worf.fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Profile; use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Profile->new(); Function: Builds a new Bio::Tools::Profile object Returns : Bio::Tools::Profile Args : -filename -fh ($filehandle) =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $profile_parser->next_result Function: Get the next result set from parser data Returns : L<Bio::SeqFeature::FeaturePair> Args : none =cut sub next_result { my ($self) = @_; my %printsac; my $line; my @features; while ($_=$self->_readline()) { $line = $_; chomp $line; my ($nscore,$rawscore,$from,$to,$hfrom,$hto,$ac) = $line =~ /(\S+)\s+(\d+)\s*pos.\s+(\d*)\s*-\s+(\d*)\s*\[\s+(\d*),\s+(\S*)\]\s*(\w+)/; #for example in this output line #38.435 2559 pos. 19958 - 20212 [ 1, -1] PS50011|PROTEIN_KINASE_DOM Protein kinase domain profile. #$nscore = 38.435 #$rawscore = 2559 #$from = 19958 #$end = 20212 #$hfrom = 1 #$hto =-1 #$ac = PS50011 my $feat = "$ac,$from,$to,$hfrom,$hto,$nscore"; my $new_feat= $self->create_feature($feat); return $new_feat } } =head2 create_feature Title : create_feature Usage : my $feat= $profile_parser->create_feature($feature) Function: creates a Bio::SeqFeature::FeaturePair object Returns : L<Bio::SeqFeature::FeaturePair> Args : =cut sub create_feature { my ($self, $feat) = @_; my @f = split (/,/,$feat); my $hto = $f[4]; if ($f[4] =~ /-1/) { $hto = $f[2] - $f[1] + 1; } my $feat1 = Bio::SeqFeature::Generic->new( -start => $f[1], -end => $f[2], -score => $f[5], -source=>'pfscan', -primary=>$f[0]); my $feat2 = Bio::SeqFeature::Generic->new(-start => $f[3], -end => $hto, ); my $feature = Bio::SeqFeature::FeaturePair->new(-feature1 => $feat1, -feature2 => $feat2); return $feature; } 1; �����������������������������������������BioPerl-1.6.923/Bio/Tools/Promoterwise.pm�����������������������������������������������������������000444��000765��000024�� 16103�12254227340� 20324� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Promoterwise # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Shawn Hoon <shawnh@fugu-sg.org> # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Promoterwise - parser for Promoterwise tab format output =head1 SYNOPSIS use Bio::Tools::Promoterwise; my $pw = Bio::Tools::Promoterwise->new(-file=>"out", -query1_seq=>$seq1, -query2_seq=>$seq2); while (my $fp = $pw->next_result){ print "Hit Length: ".$fp->feature1->length."\n"; print "Hit Start: ".$fp->feature1->start."\n"; print "Hit End: ".$fp->feature1->end."\n"; print "Hsps: \n"; my @first_hsp = $fp->feature1->sub_SeqFeature; my @second_hsp = $fp->feature2->sub_SeqFeature; foreach my $i (0..$#first_hsp){ print $first_hsp[$i]->start. " ".$first_hsp[$i]->end." ". $second_hsp[$i]->start. " ".$second_hsp[$i]->end."\n"; } } =head1 DESCRIPTION Promoteriwise is an alignment algorithm that relaxes the constraint that local alignments have to be co-linear. Otherwise it provides a similar model to DBA, which is designed for promoter sequence alignments. Promoterwise is written by Ewan Birney. It is part of the wise2 package available at L<ftp://ftp.ebi.ac.uk/pub/software/unix/wise2/> This module is the parser for the Promoterwise output in tab format. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Promoterwise; use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Promoterwise->new(); Function: Builds a new Bio::Tools::Promoterwise object Returns : L<Bio::Tools::Promoterwise> Args : -fh/-file => $val, # for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); my ($query1,$query2) = $self->_rearrange([qw(QUERY1_SEQ QUERY2_SEQ)],@args); $self->query1_seq($query1) if ($query1); $self->query2_seq($query2) if ($query2); return $self; } =head2 next_result Title : next_result Usage : my $r = $rpt_masker->next_result Function: Get the next result set from parser data Returns : an L<Bio::SeqFeature::FeaturePair> Args : none =cut sub next_result { my ($self) = @_; $self->_parse unless $self->_parsed; return $self->_next_result; } sub _parse{ my ($self) = @_; my (%hash,@fp); while (defined($_ = $self->_readline()) ) { chomp; my @array = split; push @{$hash{$array[-1]}}, \@array; } foreach my $key(keys %hash){ my $sf1 = Bio::SeqFeature::Generic->new(-primary=>"conserved_element", -source_tag=>"promoterwise"); $sf1->attach_seq($self->query1_seq) if $self->query1_seq; my $sf2 = Bio::SeqFeature::Generic->new(-primary=>"conserved_element", -source_tag=>"promoterwise"); $sf2->attach_seq($self->query2_seq) if $self->query2_seq; foreach my $info(@{$hash{$key}}){ my ($score,$id1,$start_1,$end_1, $strand_1,$s1_len, $id2,$start_2,$end_2,$strand_2,$s2_len, $group); if( @{$info} == 12 ) { ($score,$id1,$start_1,$end_1, $strand_1,$s1_len, $id2,$start_2,$end_2,$strand_2,$s2_len, $group) = @{$info}; } elsif( @{$info} == 10 ) { ($score,$id1,$start_1,$end_1, $strand_1, $id2,$start_2,$end_2,$s2_len, $group) = @{$info}; } else { $self->throw("unknown promoterwise output, ", scalar @{$info}, " columns, expected 10 or 12\n"); } if(!$sf1->strand && !$sf2->strand){ $sf1->strand($strand_1); $sf2->strand($strand_2); $sf1->seq_id($id1); $sf2->seq_id($id2); $sf1->score($score); $sf2->score($score); } my $sub1 = Bio::SeqFeature::Generic->new(-start=>$start_1, -seq_id=>$id1, -end =>$end_1, -strand=>$strand_1, -primary=>"conserved_element", -source_tag=>"promoterwise", -score=>$score); $sub1->attach_seq($self->query1_seq) if $self->query1_seq; my $sub2 = Bio::SeqFeature::Generic->new(-start=>$start_2, -seq_id=>$id2, -end =>$end_2, -strand=>$strand_2, -primary=>"conserved_element", -source_tag=>"promoterwise", -score=>$score); $sub2->attach_seq($self->query2_seq) if $self->query2_seq; $sf1->add_SeqFeature($sub1,'EXPAND'); $sf2->add_SeqFeature($sub2,'EXPAND'); } my $fp = Bio::SeqFeature::FeaturePair->new(-feature1=>$sf1, -feature2=>$sf2); push @fp, $fp; } $self->_feature_pairs(\@fp); $self->_parsed(1); return; } sub _feature_pairs { my ($self,$fp) = @_; if($fp){ $self->{'_feature_pairs'} = $fp; } return $self->{'_feature_pairs'}; } sub _next_result { my ($self) = @_; return unless (exists($self->{'_feature_pairs'}) && @{$self->{'_feature_pairs'}}); return shift(@{$self->{'_feature_pairs'}}); } sub _parsed { my ($self,$flag) = @_; if($flag){ $self->{'_flag'} = 1; } return $self->{'_flag'}; } sub query1_seq { my ($self,$val) = @_; if($val){ $self->{'query1_seq'} = $val; } return $self->{'query1_seq'}; } sub query2_seq { my ($self,$val) = @_; if($val){ $self->{'query2_seq'} = $val; } return $self->{'query2_seq'}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/PrositeScan.pm������������������������������������������������������������000444��000765��000024�� 7521�12254227314� 20044� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� =head1 NAME Bio::Tools::PrositeScan - Parser for ps_scan result =head1 SYNOPSIS use Bio::Tools::PrositeScan; my $factory = Bio::Tools::PrositeScan->new( -file => 'out.PrositeScan' ); while(my $match = $factory->next_prediction){ # $match is of Bio::SeqFeature::FeaturePair my $q_id = $fatch->feature1->seq_id; my $h_id = $fatch->feature2->seq_id; } =head1 DESCRIPTION This is the parser of the output of ps_scan program. It takes either a file handler or a file name, and returns a Bio::SeqFeature::FeaturePair object. =head1 AUTHOR Juguang Xiao, juguang@tll.org.sg =cut # Let the code begin... package Bio::Tools::PrositeScan; use vars qw(@FORMATS); use strict; use Bio::Seq; use Bio::SeqFeature::Generic; use Bio::SeqFeature::FeaturePair; use base qw(Bio::Root::Root Bio::Root::IO); @FORMATS = qw(SCAN FASTA PSA MSA PFF MATCHLIST); =head2 new Title : new Usage : Bio::Tools::PrositeScan->new(-file => 'out.PrositeScan'); Bio::Tools::PrositeScan->new(-fh => \*FH); Returns : L<Bio::Tools::PrositeScan> =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); my ($format) = $self->_rearrange([qw(FORMAT)], @args); $format || $self->throw("format needed"); if(grep /^$format$/i, @FORMATS){ $self->format($format); }else{ $self->throw("Invalid format, [$format]"); } return $self; } sub format { my $self = shift; return $self->{_format} = shift if(@_); return $self->{_format}; } =head2 next_prediction Title : new Usage : while($result = $factory->next_prediction){ ; } Returns : a Bio::SeqFeature::FeaturePair object =cut sub next_prediction { my ($self) = @_; unless($self->_parsed){ $self->_parse; $self->_parsed(1); } return shift @{$self->{_matches}}; } sub next_result { return shift->next_prediction; } sub _parsed { my $self = shift; return $self->{_parsed} = 1 if @_ && $_[0]; return $self->{_parsed}; } sub _parse { my $self = shift; my $format = $self->format; if($self->format =~ /^fasta$/){ $self->_parse_fasta; }else{ $self->throw("the [$format] parser has not been written"); } } sub _parse_fasta { my ($self) = @_; my @matches; my $fp; my $seq; while(defined($_ = $self->_readline)){ chop; if(/^\>([^>]+)/){ my $fasta_head = $1; if($fasta_head =~ /([^\/]+)\/(\d+)\-(\d+)(\s+)\:(\s+)(\S+)/){ my $q_id = $1; my $q_start = $2; my $q_end = $3; my $h_id = $6; if(defined $fp){ $self->_attach_seq($seq, $fp); push @matches, $fp; } $fp = Bio::SeqFeature::FeaturePair->new( -feature1 => Bio::SeqFeature::Generic->new( -seq_id => $q_id, -start => $q_start, -end => $q_end ), -feature2 => Bio::SeqFeature::Generic->new( -seq_id => $h_id, -start => 0, -end => 0 ) ); $seq = ''; }else{ $self->throw("ERR:\t\[$_\]"); } }else{ # sequence lines, ignored $seq .= $_; } } if(defined $fp){ $self->_attach_seq($seq, $fp); push @matches, $fp; } push @{$self->{_matches}}, @matches; } sub _attach_seq { my ($self, $seq, $fp) = @_; if(defined $fp){ my $whole_seq = 'X' x ($fp->start-1); $whole_seq .= $seq; $fp->feature1->attach_seq( Bio::Seq->new(-seq => $whole_seq) ); } } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Protparam.pm��������������������������������������������������������������000444��000765��000024�� 25354�12254227317� 17606� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Protparam # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Richard Dobson, r.j.dobson at qmul dot ac dot uk # # Copyright Richard Dobson # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Protparam - submit to and parse output from protparam ; =head1 SYNOPSIS use Bio::DB::GenBank; use Bio::Tools::Protparam; my $gb = new Bio::DB::GenBank(-retrievaltype => 'tempfile' , -format => 'Fasta'); my @ids=qw(O14521 O43709 O43826); my $seqio = $gb->get_Stream_by_acc(\@ids ); while( my $seq = $seqio->next_seq ) { my $pp = Bio::Tools::Protparam->new(seq=>$seq->seq); print "ID : ", $seq->display_id,"\n", "Amino acid number : ",$pp->amino_acid_number(),"\n", "Number of negative amino acids : ",$pp->num_neg(),"\n", "Number of positive amino acids : ",$pp->num_pos(),"\n", "Molecular weight : ",$pp->molecular_weight(),"\n", "Theoretical pI : ",$pp->theoretical_pI(),"\n", "Total number of atoms : ", $pp->total_atoms(),"\n", "Number of carbon atoms : ",$pp->num_carbon(),"\n", "Number of hydrogen atoms : ",$pp->num_hydrogen(),"\n", "Number of nitrogen atoms : ",$pp->num_nitro(),"\n", "Number of oxygen atoms : ",$pp->num_oxygen(),"\n", "Number of sulphur atoms : ",$pp->num_sulphur(),"\n", "Half life : ", $pp->half_life(),"\n", "Instability Index : ", $pp->instability_index(),"\n", "Stability class : ", $pp->stability(),"\n", "Aliphatic_index : ",$pp->aliphatic_index(),"\n", "Gravy : ", $pp->gravy(),"\n", "Composition of A : ", $pp->AA_comp('A'),"\n", "Composition of R : ", $pp->AA_comp('R'),"\n", "Composition of N : ", $pp->AA_comp('N'),"\n", "Composition of D : ", $pp->AA_comp('D'),"\n", "Composition of C : ", $pp->AA_comp('C'),"\n", "Composition of Q : ", $pp->AA_comp('Q'),"\n", "Composition of E : ", $pp->AA_comp('E'),"\n", "Composition of G : ", $pp->AA_comp('G'),"\n", "Composition of H : ", $pp->AA_comp('H'),"\n", "Composition of I : ", $pp->AA_comp('I'),"\n", "Composition of L : ", $pp->AA_comp('L'),"\n", "Composition of K : ", $pp->AA_comp('K'),"\n", "Composition of M : ", $pp->AA_comp('M'),"\n", "Composition of F : ", $pp->AA_comp('F'),"\n", "Composition of P : ", $pp->AA_comp('P'),"\n", "Composition of S : ", $pp->AA_comp('S'),"\n", "Composition of T : ", $pp->AA_comp('T'),"\n", "Composition of W : ", $pp->AA_comp('W'),"\n", "Composition of Y : ", $pp->AA_comp('Y'),"\n", "Composition of V : ", $pp->AA_comp('V'),"\n", "Composition of B : ", $pp->AA_comp('B'),"\n", "Composition of Z : ", $pp->AA_comp('Z'),"\n", "Composition of X : ", $pp->AA_comp('X'),"\n"; } =head1 DESCRIPTION This module takes an amino acid sequence and submits it to the Protparam program at www.expasy.org/cgi-bin/protparam. Many properties of the submitted sequence are returned. =head1 AUTHOR Richard Dobson, r.j.dobson at qmul dot ac dot uk =cut # Let the code begin... package Bio::Tools::Protparam; use strict; use base qw(Bio::Root::Root); use LWP 5.64; =head2 new Title : new Usage : $pp = Protparam->new(seq=>$seq->seq); Function : Creates a new Protparam object Returns : A Protparam object Args : A sequence =cut sub new { my ($class,@args) = @_; @args=('-url'=>'http://web.expasy.org/cgi-bin/protparam/protparam','-form'=>'sequence',@args); my $self=$class->SUPER::new(@args); my ($url,$seq,$form)=$self->_rearrange([qw(URL SEQ FORM)],@args); my $browser = LWP::UserAgent->new; my $response; #send request to PROTPARAM @ Expasy $response = $browser->post($url, [ $form => $seq ], 'User-Agent' => 'Mozilla/4.76 [en] (Win2000; U)', ); #Check if successful $self->throw("$url error: ".$response->status_line) unless $response->is_success; $self->throw("Bad content type at $url ".$response->content_type) unless $response->content_type eq 'text/html'; my $protParamOutput=$response->decoded_content; $self->{'output'}=$protParamOutput; return bless $self,$class; } =head2 num_neg Title : num_neg Usage : $pp->num_neg() Function : Retrieves the number of negative amino acids in a sequence Returns : Returns the number of negative amino acids in a sequence Args : none =cut sub num_neg{ my $self=shift; ($self->{'negAA'})=$self->{'output'}=~/<B>Total number of negatively charged residues.*?<\/B>\s*(\d*)/; return $self->{'negAA'}; } =head2 num_pos Title : num_pos Usage : $pp->num_pos() Function : Retrieves the number of positive amino acids in a sequence Returns : Returns the number of positive amino acids in a sequence Args : none =cut sub num_pos{ my $self=shift; ($self->{'posAA'})=$self->{'output'}=~/<B>Total number of positively charged residues.*?<\/B>\s*(\d*)/; return $self->{'posAA'}; } =head2 amino_acid_number Title : amino_acid_number Usage : $pp->amino_acid_number() Function : Retrieves the number of amino acids within a sequence Returns : Returns the number of amino acids within a sequence Args : none =cut sub amino_acid_number{ my $self=shift; ($self->{'numAA'})=$self->{'output'}=~/<B>Number of amino acids:<\/B> (\d+)/; return $self->{'numAA'}; } =head2 total_atoms Title : total_atoms Usage : $pp->total_atoms() Function : Retrieves the total number of atoms within a sequence Returns : Returns the total number of atoms within a sequence Args : none =cut sub total_atoms{ my $self=shift; $self->{'total_atoms'}=$self->{'output'}=~/<B>Total number of atoms:<\/B>\s*(\d*)/; return $self->{'total_atoms'}; } =head2 molecular_weight Title : molecular_weight Usage : $pp->molecular_weight() Function : Retrieves the molecular weight of a sequence Returns : Returns the molecular weight of a sequence Args : none =cut sub molecular_weight{ my $self=shift; ($self->{'MolWt'})=$self->{'output'}=~/<B>Molecular weight:<\/B> (\d*\.{0,1}\d*)/; return $self->{'MolWt'}; } =head2 theoretical_pI Title : theoretical_pI Usage : $pp->theoretical_pI() Function : Retrieve the theoretical pI for a sequence Returns : Return the theoretical pI for a sequence Args : none =cut sub theoretical_pI{ my $self=shift; ($self->{'TpI'})=$self->{'output'}=~/<B>Theoretical pI:<\/B> (-{0,1}\d*\.{0,1}\d*)/; return $self->{'TpI'}; } =head2 num_carbon Title : num_carbon Usage : $pp->num_carbon() Function : Retrieves the number of carbon atoms in a sequence Returns : Returns the number of carbon atoms in a sequence Args : none =cut sub num_carbon{ my $self=shift; ($self->{'car'}) = $self->{'output'}=~/Carbon\s+C\s+(\d+)/; return $self->{'car'}; } =head2 num_hydrogen Title : num_hydrogen Usage : $pp->num_hydrogen Function : Retrieves the number of hydrogen atoms in a sequence Returns : Returns the number of hydrogen atoms in a sequence Args : none =cut sub num_hydrogen{ my $self=shift; ($self->{'hyd'}) = $self->{'output'}=~/Hydrogen\s+H\s+(\d+)/; return $self->{'hyd'} } =head2 num_nitro Title : num_nitro Usage : $pp->num_nitro Function : Retrieves the number of nitrogen atoms in a sequence Returns : Returns the number of nitrogen atoms in a sequence Args : none =cut sub num_nitro{ my $self=shift; ($self->{'nitro'}) = $self->{'output'}=~/Nitrogen\s+N\s+(\d+)/; return $self->{'nitro'}; } =head2 num_oxygen Title : num_oxygen Usage : $pp->num_oxygen() Function : Retrieves the number of oxygen atoms in a sequence Returns : Returns the number of oxygen atoms in a sequence Args : none =cut sub num_oxygen{ my $self=shift; ($self->{'oxy'}) = $self->{'output'}=~/Oxygen\s+O\s+(\d+)/; return $self->{'oxy'}; } =head2 num_sulphur Title : num_sulphur Usage : $pp->num_sulphur() Function : Retrieves the number of sulphur atoms in a sequence Returns : Returns the number of sulphur atoms in a sequence Args : none =cut sub num_sulphur{ my $self=shift; ($self->{'sul'}) = $self->{'output'}=~/Sulfur\s+S\s+(\d+)/; return $self->{'sul'}; } =head2 half_life Title : half_life Usage : $pp->half_life() Function : Retrieves the half life of a sequence Returns : Returns the half life of a sequence Args : none =cut sub half_life{ my $self=shift; ($self->{'half_life'}) = $self->{'output'}=~/The estimated half-life is.*?(-{0,1}\d*\.{0,1}\d*)\s*hours \(mammalian reticulocytes, in vitro\)/; return $self->{'half_life'}; } =head2 instability_index Title : instability_index Usage : $pp->instability_index() Function : Retrieves the instability index of a sequence Returns : Returns the instability index of a sequence Args : none =cut sub instability_index{ my $self=shift; ($self->{'InstabilityIndex'})=$self->{'output'}=~/The instability index \(II\) is computed to be (-{0,1}\d*\.{0,1}\d*)/; return $self->{'InstabilityIndex'}; } =head2 stability Title : stability Usage : $pp->stability() Function : Calculates whether the sequence is stable or unstable Returns : 'stable' or 'unstable' Args : none =cut sub stability{ my $self=shift; ($self->{'Stability'})=$self->{'output'}=~/This classifies the protein as\s(\w+)\./; return $self->{'Stability'}; } =head2 aliphatic_index Title : aliphatic_index Usage : $pp->aliphatic_index() Function : Retrieves the aliphatic index of the sequence Returns : Returns the aliphatic index of the sequence Args : none =cut sub aliphatic_index{ my $self=shift; ($self->{'AliphaticIndex'})=$self->{'output'}=~/<B>Aliphatic index:<\/B>\s*(-{0,1}\d*\.{0,1}\d*)/; return $self->{'AliphaticIndex'}; } =head2 gravy Title : gravy Usage : $pp->gravy() Function : Retrieves the grand average of hydropathicity (GRAVY) of a sequence Returns : Returns the grand average of hydropathicity (GRAVY) of a sequence Args : none =cut sub gravy{ my $self=shift; ($self->{'GRAVY'})=$self->{'output'}=~/<B>Grand average of hydropathicity \(GRAVY\):<\/B>\s*(-{0,1}\d*\.{0,1}\d*)/; return $self->{'GRAVY'}; } =head2 AA_comp Title : AA_comp Usage : $pp->AA_comp('P') Function : Retrieves the percentage composition of a given amino acid for a sequence Returns : Returns the percentage composition of a given amino acid for a sequence Args : A single letter amino acid code eg A, R, G, P etc =cut sub AA_comp{ my $self=shift; my $aa=shift; $aa=uc($aa); my $AA={qw(A Ala R Arg N Asn D Asp C Cys Q Gln E Glu G Gly H His I Ile L Leu K Lys M Met F Phe P Pro S Ser T Thr W Trp Y Tyr V Val B Asx Z Glx X Xaa)}; ($self->{$aa})= $self->{'output'}=~/$AA->{$aa} \($aa\)\s+\d+\s+(\d+\.\d+)%/; return $self->{$aa}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Pseudowise.pm�������������������������������������������������������������000444��000765��000024�� 14510�12254227330� 17753� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Pseudowise # # # Copyright Jason Stajich, Fugu Team # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Pseudowise - Results of one Pseudowise run =head1 SYNOPSIS use Bio::Tools::Pseudowise; my $parser = Bio::Tools::Pseudowise->new(-file=>"pw.out"); while(my $feat = $parser->next_result){ push @feat, $feat; } =head1 DESCRIPTION Pseudowise is a pseudogene prediction program written by Ewan Birney as part of the Wise Package. This module is the parser for the output of the program. http://www.sanger.ac.uk/software/wise2 =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Previous committed by the Fugu Team Re-written by Jason Stajich jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Pseudowise; use strict; use Symbol; use Bio::Root::Root; use Bio::SeqFeature::Generic; use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::GeneStructure; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my ($self,@args) = @_; # first call the inherited method! $self->SUPER::_initialize_state(@args); # our private state variables $self->{'_preds_parsed'} = 0; $self->{'_has_cds'} = 0; # array of pre-parsed predictions $self->{'_preds'} = []; # seq stack $self->{'_seqstack'} = []; } =head2 analysis_method Usage : $pseudowise->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /pseudowise/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /pseudowise/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : $seqfeature = $obj->next_feature(); Function: Returns the next feature available in the analysis result, or undef if there are no more features. Example : Returns : A Bio::SeqFeatureI implementing object, or undef if there are no more features. Args : none See Also L<Bio::SeqFeatureI> =cut sub next_feature { return shift->next_prediction(@_); } =head2 next_prediction Title : next_prediction Usage : while($gene = $pseudowise->next_prediction()) { # do something } Function: Returns the gene of the Pseudowise result file. Call this method repeatedly until FALSE is returned. Example : Returns : a Bio::SeqFeature::Generic Args : none See Also L<Bio::SeqFeature::Generic> =cut sub next_prediction { my ($self) = @_; # if the prediction section hasn't been parsed yet, we do this now $self->_parse_predictions unless $self->_predictions_parsed; # get next gene structure return $self->_prediction(); } =head2 _parse_predictions Title : _parse_predictions() Usage : $obj->_parse_predictions() Function: Parses the prediction section. Automatically called by next_prediction() if not yet done. Example : Returns : =cut sub _parse_predictions { my ($self) = @_; my $gene; my @genes; local $/= "\n"; local($_); my %tags; while (defined( $_ = $self->_readline)){ if( /^(Total codons|\S+)\s+:\s+(\S+)/ ) { $tags{$1} = $2; } elsif(m!^//! ) { if( $gene ) { $gene = undef; %tags = (); } } elsif (/Gene\s+(\d+)\s*$/i) { $gene = Bio::SeqFeature::Generic->new ( -primary => 'pseudogene', -source => 'pseudowise', -tag => \%tags); push @genes, $gene; } elsif( /Gene\s+(\d+)\s+(\d+)/i ) { if( $1 < $2 ) { $gene->start($1); $gene->end($2); $gene->strand(1); } else { $gene->start($2); $gene->end($1); $gene->strand(-1); } } elsif (/Exon\s+(\d+)\s+(\d+)\s+phase\s+(\S+)/i) { my ($s,$e,$st) = ($1,$2,1); if( $s > $e) { ($s,$e,$st)=($e,$s,-1); } my $exon = Bio::SeqFeature::Generic->new ( -start => $s, -end => $e, -strand => $st, -primary => 'exon', -source => 'pseudowise', -tag => {'frame' => $3}); $gene->add_sub_SeqFeature($exon); } } $self->_add_prediction(\@genes); $self->_predictions_parsed(1); } =head1 _prediction Title : _prediction() Usage : $gene = $obj->_prediction() Function: internal Example : Returns : =cut sub _prediction { my ($self) = @_; return shift(@{$self->{'_preds'} || []}); } =head2 _add_prediction Title : _add_prediction() Usage : $obj->_add_prediction($gene) Function: internal Example : Returns : =cut sub _add_prediction { my ($self, $gene) = @_; $self->{'_preds'} ||= []; if( ref($gene) =~ /ARRAY/ ) { push(@{$self->{'_preds'}}, @$gene); } else { push(@{$self->{'_preds'}}, $gene); } } =head2 _predictions_parsed Title : _predictions_parsed Usage : $obj->_predictions_parsed Function: internal Example : Returns : TRUE or FALSE =cut sub _predictions_parsed { my ($self, $val) = @_; $self->{'_preds_parsed'} = $val if $val; if(! exists($self->{'_preds_parsed'})) { $self->{'_preds_parsed'} = 0; } return $self->{'_preds_parsed'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/pSW.pm��������������������������������������������������������������������000444��000765��000024�� 25442�12254227325� 16347� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� # # BioPerl module for Bio::Tools::pSW # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::pSW - pairwise Smith Waterman object =head1 SYNOPSIS use Bio::Tools::pSW; use Bio::AlignIO; my $factory = Bio::Tools::pSW->new( '-matrix' => 'blosum62.bla', '-gap' => 12, '-ext' => 2, ); #use the factory to make some output $factory->align_and_show($seq1,$seq2,STDOUT); # make a Bio::SimpleAlign and do something with it my $aln = $factory->pairwise_alignment($seq1,$seq2); my $alnout = Bio::AlignIO->new(-format => 'msf', -fh => \*STDOUT); $alnout->write_aln($aln); =head1 INSTALLATION This module is included with the central Bioperl distribution: http://bio.perl.org/Core/Latest ftp://bio.perl.org/pub/DIST Follow the installation instructions included in the INSTALL file. =head1 DESCRIPTION pSW is an Alignment Factory for protein sequences. It builds pairwise alignments using the Smith-Waterman algorithm. The alignment algorithm is implemented in C and added in using an XS extension. The XS extension basically comes from the Wise2 package, but has been slimmed down to only be the alignment part of that (this is a good thing!). The XS extension comes from the bioperl-ext package which is distributed along with bioperl. I<Warning:> This package will not work if you have not compiled the bioperl-ext package. The mixture of C and Perl is ideal for this sort of problem. Here are some plus points for this strategy: =over 2 =item Speed and Memory The algorithm is actually implemented in C, which means it is faster than a pure perl implementation (I have never done one, so I have no idea how faster) and will use considerably less memory, as it efficiently assigns memory for the calculation. =item Algorithm efficiency The algorithm was written using Dynamite, and so contains an automatic switch to the linear space divide-and-conquer method. This means you could effectively align very large sequences without killing your machine (it could take a while though!). =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Ewan Birney, birney-at-sanger.ac.uk or birney-at-ebi.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with an underscore "_". =cut # Let the code begin... package Bio::Tools::pSW; use strict; no strict ( 'refs'); BEGIN { eval { require Bio::Ext::Align; }; if ( $@ ) { die("\nThe C-compiled engine for Smith Waterman alignments (Bio::Ext::Align) has not been installed.\n Please read the install the bioperl-ext package\n\n"); exit(1); } } use Bio::SimpleAlign; use base qw(Bio::Tools::AlignFactory); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($matrix,$gap,$ext) = $self->_rearrange([qw(MATRIX GAP EXT )],@args); #default values - we have to load matrix into memory, so # we need to check it out now if( ! defined $matrix || !($matrix =~ /\w/) ) { $matrix = 'blosum62.bla'; } $self->matrix($matrix); # will throw exception if it can't load it $self->gap(12) unless defined $gap; $self->ext(2) unless defined $ext; # I'm pretty sure I am not doing this right... ho hum... # This was not roght ($gap and $ext could not be 0) It is fixed now /AE if( defined $gap ) { if( $gap =~ /^\d+$/ ) { $self->gap($gap); } else { $self->throw("Gap penalty must be a number, not [$gap]"); } } if( defined $ext ) { if( $ext =~ /^\d+$/ ) { $self->ext($ext); } else { $self->throw("Extension penalty must be a number, not [$ext]"); } } return $self; } =head2 pairwise_alignment Title : pairwise_alignment Usage : $aln = $factory->pairwise_alignment($seq1,$seq2) Function: Makes a SimpleAlign object from two sequences Returns : A SimpleAlign object Args : =cut sub pairwise_alignment{ my ($self,$seq1,$seq2) = @_; my($t1,$t2,$aln,$out,@str1,@str2,@ostr1,@ostr2,$alc,$tstr,$tid,$start1,$end1,$start2,$end2,$alctemp); if( ! defined $seq1 || ! $seq1->isa('Bio::PrimarySeqI') || ! defined $seq2 || ! $seq2->isa('Bio::PrimarySeqI') ) { $self->warn("Cannot call pairwise_alignment without specifing 2 sequences (Bio::PrimarySeqI objects)"); return; } # fix Jitterbug #1044 if( $seq1->length() < 2 || $seq2->length() < 2 ) { $self->warn("cannot align sequences with length less than 2"); return; } $self->set_memory_and_report(); # create engine objects $seq1->display_id('seq1') unless ( defined $seq1->id() ); $seq2->display_id('seq2') unless ( defined $seq2->id() ); $t1 = &Bio::Ext::Align::new_Sequence_from_strings($seq1->id(), $seq1->seq()); $t2 = &Bio::Ext::Align::new_Sequence_from_strings($seq2->id(), $seq2->seq()); $aln = &Bio::Ext::Align::Align_Sequences_ProteinSmithWaterman($t1,$t2,$self->{'matrix'},-$self->gap,-$self->ext); if( ! defined $aln || $aln == 0 ) { $self->throw("Unable to build an alignment"); } # free sequence engine objects $t1 = $t2 = 0; # now we have to get into the AlnBlock structure and # figure out what is aligned to what... # we are going to need the sequences as arrays for convience @str1 = split(//, $seq1->seq()); @str2 = split(//, $seq2->seq()); # get out start points # The alignment is in alignment coordinates - ie the first # residues starts at -1 and ends at 0. (weird I know). # bio-coordinates are +2 from this... $start1 = $aln->start()->alu(0)->start +2; $start2 = $aln->start()->alu(1)->start +2; # step along the linked list of alc units... for($alc = $aln->start();$alc->at_end() != 1;$alc = $alc->next()) { if( $alc->alu(0)->text_label eq 'SEQUENCE' ) { push(@ostr1,$str1[$alc->alu(0)->start+1]); } else { # assumme it is in insert! push(@ostr1,'-'); } if( $alc->alu(1)->text_label eq 'SEQUENCE' ) { push(@ostr2,$str2[$alc->alu(1)->start+1]); } else { # assumme it is in insert! push(@ostr2,'-'); } $alctemp = $alc; } # # get out end points # # end points = real residue end in 'C' coordinates = residue # end in biocoordinates. Oh... the wonder of coordinate systems! $end1 = $alctemp->alu(0)->end+1; $end2 = $alctemp->alu(1)->end+1; # get rid of the alnblock $alc = 0; $aln = 0; # new SimpleAlignment $out = Bio::SimpleAlign->new(); # new SimpleAlignment $tstr = join('',@ostr1); $tid = $seq1->id(); $out->add_seq(Bio::LocatableSeq->new( -seq=> $tstr, -start => $start1, -end => $end1, -id=>$tid )); $tstr = join('',@ostr2); $tid = $seq2->id(); $out->add_seq(Bio::LocatableSeq->new( -seq=> $tstr, -start => $start2, -end => $end2, -id=> $tid )); # give'm back the alignment return $out; } =head2 align_and_show Title : align_and_show Usage : $factory->align_and_show($seq1,$seq2,STDOUT) =cut sub align_and_show { my($self,$seq1,$seq2,$fh) = @_; my($t1,$t2,$aln,$id,$str); if( ! defined $seq1 || ! $seq1->isa('Bio::PrimarySeqI') || ! defined $seq2 || ! $seq2->isa('Bio::PrimarySeqI') ) { $self->warn("Cannot call align_and_show without specifing 2 sequences (Bio::PrimarySeqI objects)"); return; } # fix Jitterbug #1044 if( $seq1->length() < 2 || $seq2->length() < 2 ) { $self->warn("cannot align sequences with length less than 2"); return; } if( ! defined $fh ) { $fh = \*STDOUT; } $self->set_memory_and_report(); $seq1->display_id('seq1') unless ( defined $seq1->id() ); $seq2->display_id('seq2') unless ( defined $seq2->id() ); $t1 = &Bio::Ext::Align::new_Sequence_from_strings($seq1->id(),$seq1->seq()); $t2 = &Bio::Ext::Align::new_Sequence_from_strings($seq2->id(),$seq2->seq()); $aln = &Bio::Ext::Align::Align_Sequences_ProteinSmithWaterman($t1,$t2,$self->{'matrix'},-$self->gap,-$self->ext); if( ! defined $aln || $aln == 0 ) { $self->throw("Unable to build an alignment"); } &Bio::Ext::Align::write_pretty_seq_align($aln,$t1,$t2,12,50,$fh); } =head2 matrix Title : matrix() Usage : $factory->matrix('blosum62.bla'); Function : Reads in comparison matrix based on name : Returns : Argument : comparison matrix =cut sub matrix { my($self,$comp) = @_; my $temp; if( !defined $comp ) { $self->throw("You must have a comparison matrix to set!"); } # talking to the engine here... $temp = &Bio::Ext::Align::CompMat::read_Blast_file_CompMat($comp); if( !(defined $temp) || $temp == 0 ) { $self->throw("$comp cannot be read as a BLAST comparison matrix file"); } $self->{'matrix'} = $temp; } =head2 gap Title : gap Usage : $gap = $factory->gap() #get : $factory->gap($value) #set Function : the set get for the gap penalty Example : Returns : gap value Arguments : new value =cut sub gap { my ($self,$val) = @_; if( defined $val ) { if( $val < 0 ) { # Fixed so that gap==0 is allowed /AE $self->throw("Can't have a gap penalty less than 0"); } $self->{'gap'} = $val; } return $self->{'gap'}; } =head2 ext Title : ext Usage : $ext = $factory->ext() #get : $factory->ext($value) #set Function : the set get for the ext penalty Example : Returns : ext value Arguments : new value =cut sub ext { my ($self,$val) = @_; if( defined $val ) { if( $val < 0 ) { # Fixed so that gap==0 is allowed /AE $self->throw("Can't have a gap penalty less than 0"); } $self->{'ext'} = $val; } return $self->{'ext'}; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/QRNA.pm�������������������������������������������������������������������000444��000765��000024�� 27355�12254227313� 16401� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::QRNA # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::QRNA - A Parser for qrna output =head1 SYNOPSIS use Bio::Tools::QRNA; my $parser = Bio::Tools::QRNA->new(-file => $qrnaoutput); while( my $feature = $parser->next_feature ) { # do something here } =head1 DESCRIPTION Parses QRNA output (E.Rivas: http://selab.janelia.org/software.html ftp://selab.janelia.org/pub/software/qrna/). This module is not complete, but currently it packs information from each QRNA alignment into a single Bio::SeqFeature::Generic object. Not all options for QRNA output have been tested or tried. It has been tested on sliding window output (-w -x) and shuffled output (-b or -B). See t/QRNA.t for example usage. At some point we may have more complicated feature object which will support this data rather than forcing most of the information into tag/value pairs in a SeqFeature::Generic. Running with -verbose =E<gt> 1 will store extra data in the feature. The entire unparsed entry for a particular feature will be stored as a string in the tag 'entry' it is accessible via: my ($entry) = $f->each_tag_value('entry'); The winning model for any given alignment test will be the name stored in the primary_tag field of feature. The bit score will stored in the score field. The logoddpost is available via the a tag/value pair. This example code will show how to print out the score and log odds post for each model. # assuming you got a feature already print "model score logoddspost\n"; foreach my $model ( qw(OTH COD RNA) ) { my ($score) = $f->get_tag_values("$model\_score"); my ($logoddspost) = $f->get_tag_values("$model\_logoddspost"); print "$model $score $logoddspost\n"; } The start and end of the alignment for both the query and hit sequence are available through the L<Bio::SeqFeature::FeaturePair> interface, specifically L<Bio::SeqFeature::FeaturePair::feature1> and L<Bio::SeqFeature::FeaturePair::feature2>. Additionally if you have run QRNA with an input file which has the location of the alignment stored in the FASTA filename as in (ID/START-END) which is the default output format from L<Bio::AlignIO::fasta> produced alignment output, this module will re-number start/end for the two sequences so they are in the actual coordinates of the sequence rather than the relative coordinates of the alignment. You may find the bioperl utillity script search2alnblocks useful in creating your input files for QRNA. Some other words of warning, QRNA uses a 0 based numbering system for sequence locations, Bioperl uses a 1 based system. You'll notice that locations will be +1 they are reported in the raw QRNA output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::QRNA; use vars qw(@Models); use strict; use Bio::SeqFeature::Generic; use Bio::SeqFeature::FeaturePair; use base qw(Bio::Root::IO Bio::SeqAnalysisParserI); @Models = qw(OTH COD RNA); =head2 new Title : new Usage : my $obj = Bio::Tools::QRNA->new(); Function: Builds a new Bio::Tools::QRNA object Returns : an instance of Bio::Tools::QRNA Args : -fh/-file filehandle/filename standard input for Bio::Root:IO objects =cut =head2 next_feature Title : next_feature Usage : my $feature = $parser->next_feature Function: Get the next QRNA feature Returns : Args : =cut sub next_feature { my ($self) = @_; my $f = shift @{$self->{'_parsed_features'} || []}; if( ! defined $f && $self->_parse_pair ) { $f = shift @{$self->{'_parsed_features'} || []}; } return $f; } sub _parse_pair { my ($self,@args) = @_; my (@features,%data); my $seenstart = 0; while( defined( $_ = $self->_readline) ) { next if( /^\#\-\-/o ); if( /^\#\s+(qrna)\s+(\S+)\s+\(([^\)]+)\)/o ) { $self->program_name($1); $self->program_version($2); $self->program_date($3); } elsif( /^\#\s+(PAM model)\s+\=\s+(.+)\s+$/o ) { $self->PAM_model($2); } elsif( /^\#\s+(RNA model)\s+\=\s+(\S+)/o ) { $self->RNA_model($2); } elsif( /^\#\s+(seq file)\s+\=\s+(.+)\s+$/o ) { $self->seq_file($2); } elsif( /^\#\s+(\d+)\s+\[([\-+])\s+strand\]/o ) { if( $seenstart ) { if( $data{'alignment_len'} ) { push @features, $self->_make_feature(\%data); } $self->_pushback($_); last; } $seenstart = 1; } elsif( /^\#/ ) { next; } elsif( />(\S+)\s+\((\d+)\)/ ) { if( @{$data{'seqs'} || []} == 2 ) { $self->warn( "already seen seqs ".join(' ', ,map { $_->[0] } @{$data{'seqs'}}). "\n"); } else { push @{$data{'seqs'}}, [$1,$2]; } } elsif( /^length alignment:\s+(\d+)\s+\(id\=(\d+(\.\d+)?)\)/o ) { if( $data{'alignment_len'} ) { push @features, $self->_make_feature(\%data); # reset all the data but the 'seqs' field %data = ( 'seqs' => $data{'seqs'} ); } if( /\(((sre_)?shuffled)\)/ ) { $data{'shuffled'} = $1; } $data{'alignment_len'} = $1; $data{'alignment_pid'} = $2; } elsif ( /^pos([XY]):\s+(\d+)\-(\d+)\s+\[(\d+)\-(\d+)\]\((\d+)\)\s+ \-\-\s+\((\S+\s+\S+\s+\S+\s+\S+)\)/ox ) { $data{"seq\_$1"}->{'aln'} = [ $2,$3, $4,$5, $6]; @{$data{"seq\_$1"}->{'base_comp'}} = split(/\s+/,$7); } elsif( /^winner\s+\=\s+(\S{3})/ ) { $data{'winning_model'} = $1; } elsif( /^(\S{3})\s+ends\s+\=\s+(\-?\d+)\s+(\-?\d+)/ ) { # QRNA is 0-based # Bioperl is 1 based $data{'model_location'}->{$1} = [ $2,$3 ]; } elsif( /^\s+(logoddspost)?OTH\s+\=\s+/ox ) { while( /(\S+)\s+\=\s+(\-?\d+(\.\d+))/g ) { my ($model,$score)= ($1,$2); if( $model =~ s/^logoddspost// ) { $data{'model_scores'}->{'logoddspost'}->{$model} = $score; } else { $data{'model_scores'}->{'bits'}->{$model} = $score; } } } $data{'entry'} .= $_; } if( @features ) { push @{$self->{'_parsed_features'}}, @features; return scalar @features; } return 0; } =head2 PAM_model Title : PAM_model Usage : $obj->PAM_model($newval) Function: Example : Returns : value of PAM_model (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub PAM_model{ my $self = shift; return $self->{'PAM_model'} = shift if @_; return $self->{'PAM_model'}; } =head2 RNA_model Title : RNA_model Usage : $obj->RNA_model($newval) Function: Example : Returns : value of RNA_model (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub RNA_model{ my $self = shift; return $self->{'RNA_model'} = shift if @_; return $self->{'RNA_model'}; } =head2 seq_file Title : seq_file Usage : $obj->seq_file($newval) Function: Example : Returns : value of seq_file (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub seq_file{ my $self = shift; return $self->{'seq_file'} = shift if @_; return $self->{'seq_file'}; } =head2 program_name Title : program_name Usage : $obj->program_name($newval) Function: Example : Returns : value of program_name (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub program_name{ my $self = shift; return $self->{'program_name'} = shift if @_; return $self->{'program_name'} || 'qrna'; } =head2 program_version Title : program_version Usage : $obj->program_version($newval) Function: Example : Returns : value of program_version (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub program_version{ my $self = shift; return $self->{'program_version'} = shift if @_; return $self->{'program_version'}; } =head2 program_date Title : program_date Usage : $obj->program_date($newval) Function: Example : Returns : value of program_date (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub program_date{ my $self = shift; return $self->{'program_date'} = shift if @_; return $self->{'program_date'}; } sub _make_feature { my ($self,$data) = @_; my ($qoffset,$hoffset) = (1,1); # when you run qrna and have produced ID/START-END # formatted input strings we can remap the location # to the original # name is stored as the first entry in the seq array ref my ($qid,$hid) = ( $data->{'seqs'}->[0]->[0], $data->{'seqs'}->[1]->[0]); if( $qid =~ /(\S+)\/(\d+)\-(\d+)/ ) { ($qid,$qoffset) = ($1,$2); } if( $hid =~ /(\S+)\/(\d+)\-(\d+)/ ) { ($hid,$hoffset) = ($1,$2); } my $f = Bio::SeqFeature::FeaturePair->new(); my ($s,$e) = @{$data->{'model_location'}->{$data->{'winning_model'}}}; my $qf = Bio::SeqFeature::Generic->new ( -primary_tag => $data->{'winning_model'}, -source_tag => $self->program_name, -score => $data->{'model_scores'}->{'bits'}->{$data->{'winning_model'}}, -start => $s+$qoffset, -end => $e+$qoffset, -seq_id => $qid, -strand => ($s < $e ) ? 1 : -1, ); my $hf = Bio::SeqFeature::Generic->new ( -primary_tag => $qf->primary_tag, -source_tag => $qf->source_tag, -score => $qf->score, -seq_id => $hid, -start => $s + $hoffset, -end => $e + $hoffset, -strand => $qf->strand, ); $f->feature1($qf); $f->feature2($hf); $f->add_tag_value('alignment_len', $data->{'alignment_len'}); $f->add_tag_value('alignment_pid', $data->{'alignment_pid'}); # store the other model scores and data foreach my $model ( @Models ) { $f->add_tag_value("$model\_score", $data->{'model_scores'}->{'bits'}->{$model}); $f->add_tag_value("$model\_logoddspost", $data->{'model_scores'}->{'logoddspost'}->{$model}); if( ! $data->{'model_location'}->{$model} ) { if( $self->verbose > 0 ) { $self->debug( $data->{'entry'} ); } $self->throw("no location parsed for $model in ", (map { @$_ } @{$data->{'seqs'}}), " ", $f->start, " ", $f->end); } else { $f->add_tag_value("$model\_positions", join("..",@{$data->{'model_location'}->{$model} })); } } # probably a better way to store this - as # a seq object perhaps $f->add_tag_value('seq1', @{$data->{'seqs'}->[0]}); $f->add_tag_value('seq2', @{$data->{'seqs'}->[1]}); $f->add_tag_value('entry', $data->{'entry'}) if $self->verbose > 0; if( $data->{'shuffled'} ) { $f->add_tag_value('shuffled', $data->{'shuffled'}); } return $f; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/RandomDistFunctions.pm����������������������������������������������������000444��000765��000024�� 13261�12254227335� 21570� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::RandomDistFunctions # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::RandomDistFunctions - A set of routines useful for generating random data in different distributions =head1 SYNOPSIS use Bio::Tools::RandomDistFunctions; my $dist = Bio::Tools::RandomDistFunctions->new(); for my $v ( 1..1000 ) { my $birth_dist = $dist->rand_birth_distribution($lambda); # ... do something with the variable } =head1 DESCRIPTION Most of the code is based on the C implementation of these routines in Mike Sanderson's r8s's package. See http://loco.biosci.arizona.edu/r8s/ for information on his software. =for comment This code tries to be fast and use available faster BigInt and GMP library methods when those modules are available. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Thanks to Mike Sanderson for assistance in the getting this implementation together. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::RandomDistFunctions; require Exporter; use vars qw(%LOADED @EXPORT_OK); use strict; #use Math::BigFloat lib => 'GMP,Bit::Vector'; #use Math::BigInt lib => 'GMP,Bit::Vector'; use POSIX; use base qw(Bio::Root::Root); =head2 birth_distribution Title : rand_birth_distribution Usage : my $randvar = $dist-> rand_birth_distribution($lambda); Function: Returns a random number from a birth process waiting time with a fixed interval 1.0. Times are measured from 0=present,1=root; Returns : floating point number Args : $lambda ( > 0 ) References : This is based on code by Mike Sanders in r8s. Ross, Stochastic Processes, p. 145 for the density =cut sub rand_birth_distribution{ my ($self,$lambda) = @_; if( ! ref($self) && $self !~ /RandomDistFunctions/ ) { $lambda = $self; } unless( $lambda ) { $self->throw("Cannot call birth_distribution without a valid lambda value (>0)"); } return 1 - (log(rand(1) * (exp($lambda) - 1)+1)/ $lambda); } =head2 rand_geometric_distribution Title : rand_geometric_distribution Usage : my $randvar = $dist->rand_geometric_distribution($param); Function: Returns a random geometric variate distributed with parameter $param, according to c.d.f. 1 - ( 1- param) ^ n Returns : integer Args : $param ( 0 > $param < 1 ) =cut sub rand_geometric_distribution{ my ($self,$param) = @_; if( ! ref($self) && $self !~ /RandomDistFunctions/ ) { $param = $self; } unless( $param ) { $self->throw("Cannot call rand_geometric_distribution without a valid param value (>0)"); } my $den; if( $param < 1e-8) { $den = (-1 * $param) - ( $param * $param ) / 2; } else { $den = log(1 - $param); } my $z = log(1 - rand(1)) / $den; return POSIX::floor($z) + 1; # MSanderson comments from r8s code # Is this the right truncation of the real-valued expression above? # YES # Checked by reference to the expected mean of the distribution in # 100,000 replicates # EX = 1/param Var = (1-param)/param^2 See Olkin, Gleser, and # Derman, p. 193ff. Probability Models and Applications, 1980. } =head2 rand_exponentional_distribution Title : rand_exponentional_distribution Usage : my $var = $dist->rand_exponentional_distribution($param); Function: Returns a random exponential variate distributed with parameter $param, according to c.d.f 1 - e^(-param * x) Returns : floating point number Args : $param ( > 0 ) =cut sub rand_exponentional_distribution { my ($self,$param) = @_; if( ! ref($self) && $self !~ /RandomDistFunctions/ ) { $param = $self; } unless( $param ) { $self->throw("Cannot call rand_exponentional_distribution without a valid param value (>0)"); } return log( 1- rand(1)) / $param; } =head2 rand_normal_distribution Title : rand_normal_distribution Usage : my $var = $dist->rand_normal_distribution() Function: Returns a random normal (gaussian) variate distributed Returns : floating point number Args : none =cut sub rand_normal_distribution{ my $gset; my ($rsq,$v1,$v2) = ( 0,0,0); do { $v1 = 2 * rand(1) - 1; $v2 = 2 * rand(1) - 1; $rsq= $v1**2 + $v2 ** 2; } while( $rsq >= 1 || $rsq == 0); my $fac = sqrt(-2.0 * log($rsq) / $rsq ); $gset = $v1 * $fac; return $v2 * $fac; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/RepeatMasker.pm�����������������������������������������������������������000444��000765��000024�� 10121�12254227340� 20202� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::RepeatMasker # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Shawn Hoon <shawnh@fugu-sg.org> # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::RepeatMasker - a parser for RepeatMasker output =head1 SYNOPSIS use Bio::Tools::RepeatMasker; my $parser = Bio::Tools::RepeatMasker->new(-file => 'seq.fa.out'); while( my $result = $parser->next_result ) { # get some value } =head1 DESCRIPTION A parser for RepeatMasker output =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::RepeatMasker; use strict; use Bio::SeqFeature::FeaturePair; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::RepeatMasker->new(); Function: Builds a new Bio::Tools::RepeatMasker object Returns : Bio::Tools::RepeatMasker Args : -fh/-file => $val, for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $r = $rpt_masker->next_result Function: Get the next result set from parser data Returns : Bio::SeqFeature::FeaturePair Feature1 is the Query coordinates and Feature2 is the Hit Args : none =cut sub next_result { my ($self) = @_; local $_; while (defined($_=$self->_readline()) ) { if (/no repetitive sequences detected/) { $self->warn( "RepeatMasker didn't find any repetitive sequences\n"); return ; } #ignore introductory lines if (/\d+/) { my @element = split; # ignore features with negatives next if ($element[11-13] =~ /-/); my (%feat1, %feat2); my @line = split; my ($score, $query_name, $query_start, $query_end, $strand, $repeat_name, $repeat_class ) = @line[0, 4, 5, 6, 8, 9, 10]; my ($hit_start,$hit_end); if ($strand eq '+') { ($hit_start, $hit_end) = @line[11, 12]; $strand = 1; } elsif ($strand eq 'C') { ($hit_end, $hit_start) = @line[12, 13]; $strand = -1; } my $rf = Bio::SeqFeature::Generic->new (-seq_id => $query_name, -score => $score, -start => $query_start, -end => $query_end, -strand => $strand, -source_tag => 'RepeatMasker', -primary_tag => $repeat_class, -tag => { 'Target'=> [$repeat_name, $hit_start, $hit_end]}, ); my $rf2 = Bio::SeqFeature::Generic->new (-seq_id => $repeat_name, -score => $score, -start => $hit_start, -end => $hit_end, -strand => $strand, -source_tag => "RepeatMasker", -primary_tag => $repeat_class, -tag => { 'Target'=> [$query_name,$query_start,$query_end] }, ); my $fp = Bio::SeqFeature::FeaturePair->new(-feature1 => $rf, -feature2 => $rf2); return $fp; } } } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/RNAMotif.pm���������������������������������������������������������������000444��000765��000024�� 35532�12254227326� 17257� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::RNAMotif # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chris Fields <cjfields-at-uiuc-dot-edu> # # Copyright Chris Fields # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::RNAMotif - A parser for RNAMotif output =head1 SYNOPSIS use Bio::Tools::RNAMotif; my $parser = Bio::Tools::RNAMotif->new(-file => $rna_output, -motiftag => 'protein_bind' -desctag => 'TRAP_binding'); #parse the results while( my $motif = $parser->next_prediction) { # do something here } =head1 DESCRIPTION Parses raw RNAMotif output. RNAMotif uses a RNA profile, consisting of sequence and structural elements stored in a descriptor file, to search for potential motifs in a DNA sequence file. For more information, see: Macke TJ, Ecker DJ, Gutell RR, Gautheret D, Case DA, Sampath R. RNAMotif, an RNA secondary structure definition and search algorithm. Nucleic Acids Res. 2001 Nov 15;29(22):4724-35. http://www.scripps.edu/mb/case/casegr-sh-3.5.html. This module is not currently complete. As is, it will parse raw RNAMotif output (i.e. information not passed through the secondary programs rmfmt or rm2ct) and pack information into Bio::SeqFeature::Generic objects. Currently, parsing extra output utilized by the sprintf() function in an RNAMotif descriptor is not implemented; this information is instead packed into the score tag, which can be accessed by using the following: my ($score) = $feature->score; If the score contains anything besides a digit, it will throw a warning that sprintf() may have been used. Several values have also been added in the 'tag' hash. These can be accessed using the following syntax: my ($entry) = $feature->get_Annotations('secstructure'); Added tags are : descline - entire description line (in case the regex used for sequence ID doesn't adequately catch the name descfile - name of the descriptor file (may include path to file) secstrucure - contains structural information from the descriptor used as a query sequence - sequence of motif, separated by spaces according to matches to the structure in the descriptor (in SecStructure). See t/RNAMotif.t for example usage. The clean_features method can also be used to return a list of seqfeatures (in a Bio::SeqFeature::Collection object) that are within a particular region. RNAMotif is prone with some descriptors to returning redundant hits; an attempt to rectify this problem is attempted with RNAMotif's companion program rmprune, which returns the structure with the longest helices (and theoretically the best scoring structure). However, this doesn't take into account alternative foldings which may score better. This method adds a bit more flexibility, giving the user the ability to screen folds based on where the feature is found and the score. Passing a positive integer x screens SeqFeatures based on the highest score within x bp, while a negative integer screens based on the lowest score. So, to return the highest scoring values within 20 bp (likely using an arbitrary scroing system in the SCORE section of a descriptor file), one could use: $list = $obj->clean_features(20); ... and returning the lowest scoring structures within the same region (when the score is based on calculated free energies from efn2) can be accomplished by the following: $list = $obj->clean_features(-20); If you wanted the best feature in a sequence, you could set this to a large number, preferrably on that exceeds the bases in a sequence $list = $obj->clean_features(10000000); Each seqfeature in the collection can then be acted upon: @sf = $list->get_all_features; for my $f (@sf) { # do crazy things here } At some point a more complicated feature object may be used to support this data rather than forcing most of the information into tag/value pairs in a SeqFeature::Generic. This will hopefully allow for more flexible analysis of data (specifically RNA secondary structural data). It works for now... =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chris Fields Email cjfields-at-uiuc-dot-edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::RNAMotif; use strict; use Bio::SeqFeature::Generic; use Bio::SeqFeature::Collection; use base qw(Bio::Tools::AnalysisResult); our($MotifTag,$SrcTag,$DescTag) = qw(misc_binding RNAMotif rnamotif); =head2 new Title : new Usage : my $obj = Bio::Tools::RNAMotif->new(); Function: Builds a new Bio::Tools::RNAMotif object Returns : an instance of Bio::Tools::RNAMotif Args : -fh/-file for input filename -motiftag => primary tag used in gene features (default 'misc_binding') -desctag => tag used for display_name name (default 'rnamotif') -srctag => source tag used in all features (default 'RNAMotif') =cut sub _initialize { my($self,@args) = @_; $self->warn('Use of this module is deprecated. Use Bio::SearchIO::rnamotif instead'); $self->SUPER::_initialize(@args); my ($motiftag,$desctag,$srctag) = $self->SUPER::_rearrange([qw(MOTIFTAG DESCTAG SRCTAG )], @args); $self->motif_tag(defined $motiftag ? $motiftag : $MotifTag); $self->source_tag(defined $srctag ? $srctag : $SrcTag); $self->desc_tag(defined $desctag ? $desctag : $DescTag); $self->{'_sec_structure' => '', '_dfile' => ''}; } =head2 motif_tag Title : motif_tag Usage : $obj->motif_tag($newval) Function: Get/Set the value used for 'motif_tag', which is used for setting the primary_tag. Default is 'misc_binding' as set by the global $MotifTag. 'misc_binding' is used here because a conserved RNA motif is capable of binding proteins (regulatory proteins), antisense RNA (siRNA), small molecules (riboswitches), or nothing at all (tRNA, terminators, etc.). It is recommended that this be changed to other tags ('misc_RNA', 'protein_binding', 'tRNA', etc.) where appropriate. For more information, see: http://www.ncbi.nlm.nih.gov/collab/FT/index.html Returns : value of motif_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub motif_tag{ my $self = shift; return $self->{'motif_tag'} = shift if @_; return $self->{'motif_tag'}; } =head2 source_tag Title : source_tag Usage : $obj->source_tag($newval) Function: Get/Set the value used for the 'source_tag'. Default is 'RNAMotif' as set by the global $SrcTag Returns : value of source_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source_tag{ my $self = shift; return $self->{'source_tag'} = shift if @_; return $self->{'source_tag'}; } =head2 desc_tag Title : desc_tag Usage : $obj->desc_tag($newval) Function: Get/Set the value used for the query motif. This will be placed in the tag '-display_name'. Default is 'rnamotif' as set by the global $DescTag. Use this to manually set the descriptor (motif searched for). Since there is no way for this module to tell what the motif is from the name of the descriptor file or the RNAMotif output, this should be set every time an RNAMotif object is instantiated for clarity Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub desc_tag{ my $self = shift; return $self->{'desc_tag'} = shift if @_; return $self->{'desc_tag'}; } =head2 analysis_method Usage : $obj->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /RNAMotif/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /RNAMotif/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $obj->next_feature()) { # do something } Function: Returns the next gene structure prediction of the RNAMotif result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Returns : A Bio::Tools::Prediction::Gene object. Args : None (at present) =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $obj->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the RNAMotif result file. Call this method repeatedly until FALSE is returned. Returns : A Bio::SeqFeature::Generic object Args : None (at present) =cut sub next_prediction { my ($self) = @_; my ($motiftag,$srctag,$desctag) = ( $self->motif_tag, $self->source_tag, $self->desc_tag); my ($score, $strand, $start, $length, $sequence, $end, $seqid, $description)=0; while($_ = $self->_readline) { while($_ =~ /^#RM/) { # header line if(/^#RM\sdescr\s(.*)$/) { # contains sec structure $self->{'_sec_structure'}=$1; } if(/^#RM\sdfile\s(.*)$/) { # contains dfile $self->{'_dfile'}=$1; } $_ = $self->_readline; } if(m/^>((\S*)\s.*)$/) { $seqid = $2; $description = $1; # contains entire description line if needed if($seqid =~ /(gb|emb|dbj|sp|pdb|bbs|ref|lcl)\|(.*)\|/) { $seqid = $2; # pulls out gid } } # start pulling out hit information... # regex is m/^\S+\s+(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s(.*)$/ # m/^\S+\s+ # seqID, not needed # (.+)\s+ # score, or extra info using sprintf() # (\d+)\s+ # strand # (\d+)\s+ # start # (\d+)\s # length # (.*)$/ # sequence, divided according to descriptor if(m/^\S+\s+(.+)\s+(\d+)\s+(\d+)\s+(\d+)\s(.*)$/) { ($score, $strand, $start, $length, $sequence, $end)= ($1, $2, $3, $4, $5, 0); if( $strand==0 ) { $end = $start + $length -1; $strand = 1; } else { $end = $start - $length + 1; ($start, $end, $strand) = ($end, $start, -1); } my $gene = Bio::SeqFeature::Generic->new(-seq_id => $seqid, -start => $start, -end => $end, -strand => $strand, -score => $score, -primary_tag => $motiftag, -source_tag => $srctag, -display_name => $desctag, -tag => { 'descline' => $description, 'descfile' => $self->{'_dfile'}, 'secstructure' => $self->{'_sec_structure'}, 'sequence' => $sequence}); return $gene; } } } =head2 clean_features Title : next_prediction Usage : @list = $obj->clean_features(-10); Function: Cleans (reduces redundant hits) based on score, position Returns : a Bio::SeqFeature::Collection object Args : Pos./Neg. integer (for highest/lowest scoring seqfeature within x bp). Throws : Error unless digit is entered. =cut sub clean_features { my $self = shift; my $bp = shift; $self->throw("No arg, need pos. or neg. integer") if !$bp; $self->throw("Need pos. or neg. integer") if ($bp !~ /\-?\d/ || $bp =~ /\./); my ($b, $sf2); my @list = (); my @features = (); while (my $pred = $self->next_prediction) { push @features, $pred; } while (@features) { $b = shift @features if !defined($b); $sf2 = shift @features; # from same sequence? if ($sf2) { # if there is no feature, then... if ($b->seq_id == $sf2->seq_id) { # close starts (probable redundant hit)? if(abs(($b->start)-($sf2->start)) <= abs($bp)) { # which score is better? if( (($bp < 0) && ($b->score > $sf2->score)) || # lowest score (($bp > 0) && ($b->score < $sf2->score)) ){ # highest score $b = $sf2; next; } else { next; } } push @list, $b; $b = $sf2; } } } push @list, $b if $b; my $col = Bio::SeqFeature::Collection->new; $col->add_features(\@list); return $col; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Seg.pm��������������������������������������������������������������������000555��000765��000024�� 6660�12254227321� 16334� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Seg # # Copyright Balamurugan Kumarasamy # Totally re-written, added docs and tests -- Torsten Seemann, Sep 2006 # # Copyright # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Tools::Seg - parse C<seg> output =head1 SYNOPSIS use Bio::Tools::Seg; my $parser = Bio::Tools::Seg->(-file => 'seg.fasta'); while ( my $f = $parser->next_result ) { if ($f->score < 1.5) { print $f->location->to_FTstring, " is low complexity\n"; } } =head1 DESCRIPTION C<seg> identifies low-complexity regions on a protein sequence. It is usually part of the C<WU-BLAST> and C<InterProScan> packages. The L<Bio::Tools::Seg> module will only parse the "fasta" output modes of C<seg>, i.e. C<seg -l> (low complexity regions only), C<seg -h> (high complexity regions only), or C<seg -a> (both low and high). It creates a L<Bio::SeqFeature::Generic> for each FASTA-like entry found in the input file. It is up to the user to appropriately filter these using the feature's score. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Torsten Seemann Email - torsten.seemann AT infotech.monash.edu.au =head1 CONTRIBUTOR - Bala Email - savikalpa@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Seg; use strict; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Seg->new(); Function: Builds a new Bio::Tools::Seg object Returns : Bio::Tools::Seg Args : -fh/-file => $val, # for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $seg->next_result Function: Get the next result set from parser data Returns : Bio::SeqFeature::Generic Args : none =cut sub next_result { my ($self) = @_; # For example in this line # test_prot(214-226) complexity=2.26 (12/2.20/2.50) # $1 is test_prot # $2 is 214 # $3 is 226 # $4 is 2.26 while (my $line = $self->_readline) { if ($line =~ /^\>\s*?(\S+)?\s*?\((\d+)\-(\d+)\)\s*complexity=(\S+)/) { return Bio::SeqFeature::Generic->new( -seq_id => $1, -start => $2, -end => $3, -score => $4, -source_tag => 'Seg', -primary => 'low_complexity' ); } } } 1; ��������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SeqPattern.pm�������������������������������������������������������������000444��000765��000024�� 62777�12254227335� 17741� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # bioperl module for Bio::Tools::SeqPattern # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Steve Chervitz (sac-at-bioperl.org) # # Copyright Steve Chervitz # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::SeqPattern - represent a sequence pattern or motif =head1 SYNOPSIS use Bio::Tools::SeqPattern; my $pat1 = 'T[GA]AA...TAAT'; my $pattern1 = Bio::Tools::SeqPattern->new(-SEQ =>$pat1, -TYPE =>'Dna'); my $pat2 = '[VILM]R(GXX){3,2}...[^PG]'; my $pattern2 = Bio::Tools::SeqPattern->new(-SEQ =>$pat2, -TYPE =>'Amino'); =head1 DESCRIPTION L<Bio::Tools::SeqPattern> module encapsulates generic data and methods for manipulating regular expressions describing nucleic or amino acid sequence patterns (a.k.a, "motifs"), such as the ones produced by L<Bio::Tools::IUPAC>. L<Bio::Tools::SeqPattern> is a concrete class that inherits from L<Bio::Seq>. This class grew out of a need to have a standard module for doing routine tasks with sequence patterns such as: -- Forming a reverse-complement version of a nucleotide sequence pattern -- Expanding patterns containing ambiguity codes -- Checking for invalid regexp characters -- Untainting yet preserving special characters in the pattern Other features to look for in the future: -- Full pattern syntax checking -- Conversion between expanded and condensed forms of the pattern =head1 MOTIVATIONS A key motivation for L<Bio::Tools::SeqPattern> is to have a way to generate a reverse complement of a nucleotide sequence pattern. This makes possible simultaneous pattern matching on both sense and anti-sense strands of a query sequence. In principle, one could do such a search more inefficiently by testing against both sense and anti-sense versions of a sequence. It is entirely equivalent to test a regexp containing both sense and anti-sense versions of the *pattern* against one copy of the sequence. The latter approach is much more efficient since: 1) You need only one copy of the sequence. 2) Only one regexp is executed. 3) Regexp patterns are typically much smaller than sequences. Patterns can be quite complex and it is often difficult to generate the reverse complement pattern. The Bioperl SeqPattern.pm addresses this problem, providing a convenient set of tools for working with biological sequence regular expressions. Not all patterns have been tested. If you discover a pattern that is not handled properly by Bio::Tools::SeqPattern.pm, please send me some email (sac@bioperl.org). Thanks. =head1 OTHER FEATURES =head2 Extended Alphabet Support This module supports the same set of ambiguity codes for nucleotide sequences as supported by L<Bio::Seq>. These ambiguity codes define the behavior or the L<expand> method. ------------------------------------------ Symbol Meaning Nucleic Acid ------------------------------------------ A A (A)denine C C (C)ytosine G G (G)uanine T T (T)hymine U U (U)racil M A or C a(M)ino group R A or G pu(R)ine W A or T (W)eak bond S C or G (S)trong bond Y C or T p(Y)rimidine K G or T (K)eto group V A or C or G H A or C or T D A or G or T B C or G or T X G or A or T or C N G or A or T or C . G or A or T or C ------------------------------------------ Symbol Meaning ------------------------------------------ A Alanine C Cysteine D Aspartic Acid E Glutamic Acid F Phenylalanine G Glycine H Histidine I Isoleucine K Lysine L Leucine M Methionine N Asparagine P Proline Q Glutamine R Arginine S Serine T Threonine V Valine W Tryptophan Y Tyrosine B Aspartic Acid, Asparagine Z Glutamic Acid, Glutamine X Any amino acid . Any amino acid =head2 Multiple Format Support Ultimately, this module should be able to build SeqPattern.pm objects using a variety of pattern formats such as ProSite, Blocks, Prints, GCG, etc. Currently, this module only supports patterns using a grep-like syntax. =head1 USAGE A simple demo script called seq_pattern.pl is included in the examples/ directory of the central Bioperl distribution. =head1 SEE ALSO L<Bio::Seq> - Lightweight sequence object. L<Bio::Tools::IUPAC> - The IUPAC code for degenerate residues and their conversion to a regular expression. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Steve Chervitz, sac-at-bioperl.org =head1 COPYRIGHT Copyright (c) 1997-8 Steve Chervitz. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # ## ### #### END of main POD documentation. ### ## #' # CREATED : 28 Aug 1997 package Bio::Tools::SeqPattern; use base qw(Bio::Root::Root); use strict; use vars qw ($ID); $ID = 'Bio::Tools::SeqPattern'; ## These constants may be more appropriate in a Bio::Dictionary.pm ## type of class. my $PURINES = 'AG'; my $PYRIMIDINES = 'CT'; my $BEE = 'DN'; my $ZED = 'EQ'; my $Regexp_chars = '\w,.\*()\[\]<>\{\}^\$'; # quoted for use in regexps ## Package variables used in reverse complementing. my (%Processed_braces, %Processed_asterics); ##################################################################################### ## CONSTRUCTOR ## ##################################################################################### =head1 new Title : new Usage : my $seqpat = Bio::Tools::SeqPattern->new(); Purpose : Verifies that the type is correct for superclass (Bio::Seq.pm) : and calls superclass constructor last. Returns : n/a Argument : Parameters passed to new() Throws : Exception if the pattern string (seq) is empty. Comments : The process of creating a new SeqPattern.pm object : ensures that the pattern string is untained. See Also : L<Bio::Root::Root::new>, L<Bio::Seq::_initialize> =cut #---------------- sub new { #---------------- my($class, %param) = @_; my $self = $class->SUPER::new(%param); my ($seq,$type) = $self->_rearrange([qw(SEQ TYPE)], %param); $seq || $self->throw("Empty pattern."); my $t; # Get the type ready for Bio::Seq.pm if ($type =~ /nuc|[dr]na/i) { $t = 'Dna'; } elsif ($type =~ /amino|pep|prot/i) { $t = 'Amino'; } $seq =~ tr/a-z/A-Z/; #ps 8/8/00 Canonicalize to upper case $self->str($seq); $self->type($t); return $self; } =head1 alphabet_ok Title : alphabet_ok Usage : $mypat->alphabet_ok; Purpose : Checks for invalid regexp characters. : Overrides Bio::Seq::alphabet_ok() to allow : additional regexp characters ,.*()[]<>{}^$ : in addition to the standard genetic alphabet. : Also untaints the pattern and sets the sequence : object's sequence to the untained string. Returns : Boolean (1 | 0) Argument : n/a Throws : Exception if the pattern contains invalid characters. Comments : Does not call the superclass method. : Actually permits any alphanumeric, not just the : standard genetic alphabet. =cut #----------------' sub alphabet_ok { #---------------- my( $self) = @_; return 1 if $self->{'_alphabet_checked'}; $self->{'_alphabet_checked'} = 1; my $pat = $self->seq(); if($pat =~ /[^$Regexp_chars]/io) { $self->throw("Pattern contains invalid characters: $pat", 'Legal characters: a-z,A-Z,0-9,,.*()[]<>{}^$ '); } # Untaint pattern (makes code taint-safe). $pat =~ /([$Regexp_chars]+)/io; $self->setseq(uc($1)); # print STDERR "\npattern ok: $pat\n"; 1; } =head1 expand Title : expand Usage : $seqpat_object->expand(); Purpose : Expands the sequence pattern using special ambiguity codes. Example : $pat = $seq_pat->expand(); Returns : String containing fully expanded sequence pattern Argument : n/a Throws : Exception if sequence type is not recognized : (i.e., is not one of [DR]NA, Amino) See Also : L<Extended Alphabet Support>, L<_expand_pep>(), L<_expand_nuc>() =cut #---------- sub expand { #---------- my $self = shift; if($self->type =~ /[DR]na/i) { $self->_expand_nuc(); } elsif($self->type =~ /Amino/i) { $self->_expand_pep(); } else{ $self->throw("Don't know how to expand ${\$self->type} patterns.\n"); } } =head1 _expand_pep Title : _expand_pep Usage : n/a; automatically called by expand() Purpose : Expands peptide patterns Returns : String (the expanded pattern) Argument : String (the unexpanded pattern) Throws : n/a See Also : L<expand>(), L<_expand_nuc>() =cut #---------------- sub _expand_pep { #---------------- my ($self,$pat) = @_; $pat ||= $self->str; $pat =~ s/X/./g; $pat =~ s/^</\^/; $pat =~ s/>$/\$/; ## Avoid nested situations: [bmnq] --/--> [[$ZED]mnq] ## Yet correctly deal with: fze[bmnq] ---> f[$BEE]e[$ZEDmnq] if($pat =~ /\[\w*[BZ]\w*\]/) { $pat =~ s/\[(\w*)B(\w*)\]/\[$1$ZED$2\]/g; $pat =~ s/\[(\w*)Z(\w*)\]/\[$1$BEE$2\]/g; $pat =~ s/B/\[$ZED\]/g; $pat =~ s/Z/\[$BEE\]/g; } else { $pat =~ s/B/\[$ZED\]/g; $pat =~ s/Z/\[$BEE\]/g; } $pat =~ s/\((.)\)/$1/g; ## Doing these last since: $pat =~ s/\[(.)\]/$1/g; ## Pattern could contain [B] (for example) return $pat; } =head1 _expand_nuc Title : _expand_nuc Purpose : Expands nucleotide patterns Returns : String (the expanded pattern) Argument : String (the unexpanded pattern) Throws : n/a See Also : L<expand>(), L<_expand_pep>() =cut #--------------- sub _expand_nuc { #--------------- my ($self,$pat) = @_; $pat ||= $self->str; $pat =~ s/N|X/./g; $pat =~ s/pu/R/ig; $pat =~ s/py/Y/ig; $pat =~ s/U/T/g; $pat =~ s/^</\^/; $pat =~ s/>$/\$/; ## Avoid nested situations: [ya] --/--> [[ct]a] ## Yet correctly deal with: sg[ya] ---> [gc]g[cta] if($pat =~ /\[\w*[RYSWMK]\w*\]/) { $pat =~ s/\[(\w*)R(\w*)\]/\[$1$PURINES$2\]/g; $pat =~ s/\[(\w*)Y(\w*)\]/\[$1$PYRIMIDINES$2\]/g; $pat =~ s/\[(\w*)S(\w*)\]/\[$1GC$2\]/g; $pat =~ s/\[(\w*)W(\w*)\]/\[$1AT$2\]/g; $pat =~ s/\[(\w*)M(\w*)\]/\[$1AC$2\]/g; $pat =~ s/\[(\w*)K(\w*)\]/\[$1GT$2\]/g; $pat =~ s/\[(\w*)V(\w*)\]/\[$1ACG$2\]/g; $pat =~ s/\[(\w*)H(\w*)\]/\[$1ACT$2\]/g; $pat =~ s/\[(\w*)D(\w*)\]/\[$1AGT$2\]/g; $pat =~ s/\[(\w*)B(\w*)\]/\[$1CGT$2\]/g; $pat =~ s/R/\[$PURINES\]/g; $pat =~ s/Y/\[$PYRIMIDINES\]/g; $pat =~ s/S/\[GC\]/g; $pat =~ s/W/\[AT\]/g; $pat =~ s/M/\[AC\]/g; $pat =~ s/K/\[GT\]/g; $pat =~ s/V/\[ACG\]/g; $pat =~ s/H/\[ACT\]/g; $pat =~ s/D/\[AGT\]/g; $pat =~ s/B/\[CGT\]/g; } else { $pat =~ s/R/\[$PURINES\]/g; $pat =~ s/Y/\[$PYRIMIDINES\]/g; $pat =~ s/S/\[GC\]/g; $pat =~ s/W/\[AT\]/g; $pat =~ s/M/\[AC\]/g; $pat =~ s/K/\[GT\]/g; $pat =~ s/V/\[ACG\]/g; $pat =~ s/H/\[ACT\]/g; $pat =~ s/D/\[AGT\]/g; $pat =~ s/B/\[CGT\]/g; } $pat =~ s/\((.)\)/$1/g; ## Doing thses last since: $pat =~ s/\[(.)\]/$1/g; ## Pattern could contain [y] (for example) return $pat; } =head1 revcom Title : revcom Usage : revcom([1]); Purpose : Forms a pattern capable of recognizing the reverse complement : version of a nucleotide sequence pattern. Example : $pattern_object->revcom(); : $pattern_object->revcom(1); ## returns expanded rev complement pattern. Returns : Object reference for a new Bio::Tools::SeqPattern containing : the revcom of the current pattern as its sequence. Argument : (1) boolean (optional) (default= false) : true : expand the pattern before rev-complementing. : false: don't expand pattern before or after rev-complementing. Throws : Exception if called for amino acid sequence pattern. Comments : This method permits the simultaneous searching of both : sense and anti-sense versions of a nucleotide pattern : by means of a grep-type of functionality in which any : number of patterns may be or-ed into the recognition : pattern. : Overrides Bio::Seq::revcom() and calls it first thing. : The order of _fixpat() calls is critical. See Also : L<Bio::Seq::revcom>, L</_fixpat_1>, L</_fixpat_2>, L</_fixpat_3>, L</_fixpat_4>, L</_fixpat_5> =cut #-----------' sub revcom { #----------- my($self,$expand) = @_; if ($self->type !~ /Dna|Rna/i) { $self->throw("Can't get revcom for ${\$self->type} sequence types.\n"); } # return $self->{'_rev'} if defined $self->{'_rev'}; $expand ||= 0; my $str = $self->str; $str =~ tr/acgtrymkswhbvdnxACGTRYMKSWHBVDNX/tgcayrkmswdvbhnxTGCAYRKMSWDVBHNX/; my $rev = CORE::reverse $str; $rev =~ tr/[](){}<>/][)(}{></; if($expand) { $rev = $self->_expand_nuc($rev); # print "\nExpanded: $rev\n"; } %Processed_braces = (); %Processed_asterics = (); my $fixrev = _fixpat_1($rev); # print "FIX 1: $fixrev";<STDIN>; $fixrev = _fixpat_2($fixrev); # print "FIX 2: $fixrev";<STDIN>; $fixrev = _fixpat_3($fixrev); # print "FIX 3: $fixrev";<STDIN>; $fixrev = _fixpat_4($fixrev); # print "FIX 4: $fixrev";<STDIN>; $fixrev = _fixpat_5($fixrev); # print "FIX 5: $fixrev";<STDIN>; ##### Added by ps 8/7/00 to allow non-greedy matching $fixrev = _fixpat_6($fixrev); # print "FIX 6: $fixrev";<STDIN>; # $self->{'_rev'} = $fixrev; return Bio::Tools::SeqPattern->new(-seq =>$fixrev, -type =>$self->type); } =head1 backtranslate Title : backtranslate Usage : backtranslate(); Purpose : Produce a degenerate oligonucleotide whose translation would produce : the original protein motif. Example : $pattern_object->backtranslate(); Returns : Object reference for a new Bio::Tools::SeqPattern containing : the reverse translation of the current pattern as its sequence. Throws : Exception if called for nucleotide sequence pattern. =cut sub backtranslate { my $self = shift; # _load_module loads dynamically, caches call if successful $self->_load_module('Bio::Tools::SeqPattern::Backtranslate'); Bio::Tools::SeqPattern::Backtranslate->import("_reverse_translate_motif"); if ($self->type ne 'Amino') { $self->throw( "Can't get backtranslate for ${\$self->type} sequence types.\n" ); } return __PACKAGE__->new( -SEQ => _reverse_translate_motif($self->str), -TYPE => 'Dna', ); } =head1 _fixpat_1 Title : _fixpat_1 Usage : n/a; called automatically by revcom() Purpose : Utility method for revcom() : Converts all {7,5} --> {5,7} (Part I) : and [T^] --> [^T] (Part II) : and *N --> N* (Part III) Returns : String (the new, partially reversed pattern) Argument : String (the expanded pattern) Throws : n/a See Also : L<revcom>() =cut #-------------- sub _fixpat_1 { #-------------- my $pat = shift; ## Part I: my (@done,@parts); while(1) { $pat =~ /(.*)\{(\S+?)\}(.*)/ or do{ push @done, $pat; last; }; $pat = $1.'#{'.reverse($2).'}'.$3; # print "1: $1\n2: $2\n3: $3\n"; # print "modified pat: $pat";<STDIN>; @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } $pat = join('', reverse @done); ## Part II: @done = (); while(1) { $pat =~ /(.*)\[(\S+?)\](.*)/ or do{ push @done, $pat; last; }; $pat = $1.'#['.reverse($2).']'.$3; # print "1: $1\n2: $2\n3: $3\n"; # print "modified pat: $pat";<STDIN>; @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } $pat = join('', reverse @done); ## Part III: @done = (); while(1) { $pat =~ /(.*)\*([\w.])(.*)/ or do{ push @done, $pat; last; }; $pat = $1.'#'.$2.'*'.$3; $Processed_asterics{$2}++; # print "1: $1\n2: $2\n3: $3\n"; # print "modified pat: $pat";<STDIN>; @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } return join('', reverse @done); } =head1 _fixpat_2 Title : _fixpat_2 Usage : n/a; called automatically by revcom() Purpose : Utility method for revcom() : Converts all {5,7}Y ---> Y{5,7} : and {10,}. ---> .{10,} Returns : String (the new, partially reversed pattern) Argument : String (the expanded, partially reversed pattern) Throws : n/a See Also : L<revcom>() =cut #-------------- sub _fixpat_2 { #-------------- my $pat = shift; local($^W) = 0; my (@done,@parts,$braces); while(1) { # $pat =~ s/(.*)([^])])(\{\S+?\})([\w.])(.*)/$1$2#$4$3$5/ or do{ push @done, $pat; last; }; $pat =~ s/(.*)(\{\S+?\})([\w.])(.*)/$1#$3$2$4/ or do{ push @done, $pat; last; }; $braces = $2; $braces =~ s/[{}]//g; $Processed_braces{"$3$braces"}++; # print "modified pat: $pat";<STDIN>; @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } return join('', reverse @done); } =head1 _fixpat_3 Title : _fixpat_3 Usage : n/a; called automatically by revcom() Purpose : Utility method for revcom() : Converts all {5,7}(XXX) ---> (XXX){5,7} Returns : String (the new, partially reversed pattern) Argument : String (the expanded, partially reversed pattern) Throws : n/a See Also : L<revcom>() =cut #------------- sub _fixpat_3 { #------------- my $pat = shift; my (@done,@parts,$braces,$newpat,$oldpat); while(1) { # $pat =~ s/(.+)(\{\S+\})(\(\w+\))(.*)/$1#$3$2$4/ or do{ push @done, $pat; last; }; if( $pat =~ /(.*)(.)(\{\S+\})(\(\w+\))(.*)/) { $newpat = "$1#$2$4$3$5"; ##ps $oldpat = "$1#$2$3$4$5"; # print "1: $1\n2: $2\n3: $3\n4: $4\n5: $5\n"; ##ps $braces = $3; ##ps $braces =~ s/[{}]//g; ##ps if( exists $Processed_braces{"$2$braces"} || exists $Processed_asterics{$2}) { ##ps $pat = $oldpat; # Don't change it. Already processed. # print "saved pat: $pat";<STDIN>; ##ps } else { # print "new pat: $newpat";<STDIN>; $pat = $newpat; # Change it. ##ps } } elsif( $pat =~ /^(\{\S+\})(\(\w+\))(.*)/) { $pat = "#$2$1$3"; } else { push @done, $pat; last; } @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } return join('', reverse @done); } =head1 _fixpat_4 Title : _fixpat_4 Usage : n/a; called automatically by revcom() Purpose : Utility method for revcom() : Converts all {5,7}[XXX] ---> [XXX]{5,7} Returns : String (the new, partially reversed pattern) Argument : String (the expanded, partially reversed pattern) Throws : n/a See Also : L<revcom>() =cut #--------------- sub _fixpat_4 { #--------------- my $pat = shift; my (@done,@parts,$braces,$newpat,$oldpat); while(1) { # $pat =~ s/(.*)(\{\S+\})(\[\w+\])(.*)/$1#$3$2$4/ or do{ push @done, $pat; last; }; # $pat =~ s/(.*)([^\w.])(\{\S+\})(\[\w+\])(.*)/$1$2#$4$3$5/ or do{ push @done, $pat; last; }; if( $pat =~ /(.*)(.)(\{\S+\})(\[\w+\])(.*)/) { $newpat = "$1#$2$4$3$5"; $oldpat = "$1#$2$3$4$5"; # print "1: $1\n2: $2\n3: $3\n4: $4\n5: $5\n"; $braces = $3; $braces =~ s/[{}]//g; if( (defined $braces and defined $2) and exists $Processed_braces{"$2$braces"} || exists $Processed_asterics{$2}) { $pat = $oldpat; # Don't change it. Already processed. # print "saved pat: $pat";<STDIN>; } else { $pat = $newpat; # Change it. # print "new pat: $pat";<STDIN>; } } elsif( $pat =~ /^(\{\S+\})(\[\w+\])(.*)/) { $pat = "#$2$1$3"; } else { push @done, $pat; last; } @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } return join('', reverse @done); } =head1 _fixpat_5 Title : _fixpat_5 Usage : n/a; called automatically by revcom() Purpose : Utility method for revcom() : Converts all *[XXX] ---> [XXX]* : and *(XXX) ---> (XXX)* Returns : String (the new, partially reversed pattern) Argument : String (the expanded, partially reversed pattern) Throws : n/a See Also : L<revcom>() =cut #-------------- sub _fixpat_5 { #-------------- my $pat = shift; my (@done,@parts,$newpat,$oldpat); while(1) { # $pat =~ s/(.*)(\{\S+\})(\[\w+\])(.*)/$1#$3$2$4/ or do{ push @done, $pat; last; }; # $pat =~ s/(.*)([^\w.])(\{\S+\})(\[\w+\])(.*)/$1$2#$4$3$5/ or do{ push @done, $pat; last; }; if( $pat =~ /(.*)(.)\*(\[\w+\]|\(\w+\))(.*)/) { $newpat = "$1#$2$3*$4"; $oldpat = "$1#$2*$3$4"; # print "1: $1\n2: $2\n3: $3\n4: $4\n"; if( exists $Processed_asterics{$2}) { $pat = $oldpat; # Don't change it. Already processed. # print "saved pat: $pat";<STDIN>; } else { $pat = $newpat; # Change it. # print "new pat: $pat";<STDIN>; } } elsif( $pat =~ /^\*(\[\w+\]|\(\w+\))(.*)/) { $pat = "#$1*$3"; } else { push @done, $pat; last; } @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } return join('', reverse @done); } ############################ # # PS: Added 8/7/00 to allow non-greedy matching patterns # ###################################### =head1 _fixpat_6 Title : _fixpat_6 Usage : n/a; called automatically by revcom() Purpose : Utility method for revcom() : Converts all ?Y{5,7} ---> Y{5,7}? : and ?(XXX){5,7} ---> (XXX){5,7}? : and ?[XYZ]{5,7} ---> [XYZ]{5,7}? Returns : String (the new, partially reversed pattern) Argument : String (the expanded, partially reversed pattern) Throws : n/a See Also : L<revcom>() =cut #-------------- sub _fixpat_6 { #-------------- my $pat = shift; my (@done,@parts); @done = (); while(1) { $pat =~ /(.*)\?(\[\w+\]|\(\w+\)|\w)(\{\S+?\})?(.*)/ or do{ push @done, $pat; last; }; my $quantifier = $3 ? $3 : ""; # Shut up warning if no explicit quantifier $pat = $1.'#'.$2.$quantifier.'?'.$4; # $pat = $1.'#'.$2.$3.'?'.$4; # print "1: $1\n2: $2\n3: $3\n"; # print "modified pat: $pat";<STDIN>; @parts = split '#', $pat; push @done, $parts[1]; $pat = $parts[0]; # print "done: $parts[1]<---\nnew pat: $pat<---";<STDIN>; last if not $pat; } return join('', reverse @done); } =head2 str Title : str Usage : $obj->str($newval) Function: Returns : value of str Args : newvalue (optional) =cut sub str{ my $obj = shift; if( @_ ) { my $value = shift; $obj->{'str'} = $value; } return $obj->{'str'}; } =head2 type Title : type Usage : $obj->type($newval) Function: Returns : value of type Args : newvalue (optional) =cut sub type{ my $obj = shift; if( @_ ) { my $value = shift; $obj->{'type'} = $value; } return $obj->{'type'}; } 1; __END__ ######################################################################### # End of class ######################################################################### =head1 FOR DEVELOPERS ONLY =head2 Data Members Information about the various data members of this module is provided for those wishing to modify or understand the code. Two things to bear in mind: =over 2 =item 1 Do NOT rely on these in any code outside of this module. All data members are prefixed with an underscore to signify that they are private. Always use accessor methods. If the accessor doesn't exist or is inadequate, create or modify an accessor (and let me know, too!). =item 2 This documentation may be incomplete and out of date. It is easy for this documentation to become obsolete as this module is still evolving. Always double check this info and search for members not described here. =back An instance of Bio::Tools::RestrictionEnzyme.pm is a blessed reference to a hash containing all or some of the following fields: FIELD VALUE ------------------------------------------------------------------------ _rev : The corrected reverse complement of the fully expanded pattern. INHERITED DATA MEMBERS: _seq : (From Bio::Seq.pm) The original, unexpanded input sequence after untainting. _type : (From Bio::Seq.pm) 'Dna' or 'Amino' =cut �BioPerl-1.6.923/Bio/Tools/SeqStats.pm���������������������������������������������������������������000444��000765��000024�� 67136�12254227316� 17413� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::SeqStats # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::SeqStats - Object holding statistics for one particular sequence =head1 SYNOPSIS # build a primary nucleic acid or protein sequence object somehow # then build a statistics object from the sequence object $seqobj = Bio::PrimarySeq->new(-seq => 'ACTGTGGCGTCAACTG', -alphabet => 'dna', -id => 'test'); $seq_stats = Bio::Tools::SeqStats->new(-seq => $seqobj); # obtain a hash of counts of each type of monomer # (i.e. amino or nucleic acid) print "\nMonomer counts using statistics object\n"; $seq_stats = Bio::Tools::SeqStats->new(-seq=>$seqobj); $hash_ref = $seq_stats->count_monomers(); # e.g. for DNA sequence foreach $base (sort keys %$hash_ref) { print "Number of bases of type ", $base, "= ", %$hash_ref->{$base},"\n"; } # obtain the count directly without creating a new statistics object print "\nMonomer counts without statistics object\n"; $hash_ref = Bio::Tools::SeqStats->count_monomers($seqobj); foreach $base (sort keys %$hash_ref) { print "Number of bases of type ", $base, "= ", %$hash_ref->{$base},"\n"; } # obtain hash of counts of each type of codon in a nucleic acid sequence print "\nCodon counts using statistics object\n"; $hash_ref = $seq_stats-> count_codons(); # for nucleic acid sequence foreach $base (sort keys %$hash_ref) { print "Number of codons of type ", $base, "= ", %$hash_ref->{$base},"\n"; } # or print "\nCodon counts without statistics object\n"; $hash_ref = Bio::Tools::SeqStats->count_codons($seqobj); foreach $base (sort keys %$hash_ref) { print "Number of codons of type ", $base, "= ", %$hash_ref->{$base},"\n"; } # Obtain the molecular weight of a sequence. Since the sequence # may contain ambiguous monomers, the molecular weight is returned # as a (reference to) a two element array containing greatest lower # bound (GLB) and least upper bound (LUB) of the molecular weight $weight = $seq_stats->get_mol_wt(); print "\nMolecular weight (using statistics object) of sequence ", $seqobj->id(), " is between ", $$weight[0], " and " , $$weight[1], "\n"; # or $weight = Bio::Tools::SeqStats->get_mol_wt($seqobj); print "\nMolecular weight (without statistics object) of sequence ", $seqobj->id(), " is between ", $$weight[0], " and " , $$weight[1], "\n"; # Calculate mean Kyte-Doolittle hydropathicity (aka "gravy" score) my $prot = Bio::PrimarySeq->new(-seq=>'MSFVLVAPDMLATAAADVVQIGSAVSAGS', -alphabet=>'protein'); my $gravy = Bio::Tools::SeqStats->hydropathicity($seqobj); print "might be hydropathic" if $gravy > 1; =head1 DESCRIPTION Bio::Tools::SeqStats is a lightweight object for the calculation of simple statistical and numerical properties of a sequence. By "lightweight" I mean that only "primary" sequences are handled by the object. The calling script needs to create the appropriate primary sequence to be passed to SeqStats if statistics on a sequence feature are required. Similarly if a codon count is desired for a frame-shifted sequence and/or a negative strand sequence, the calling script needs to create that sequence and pass it to the SeqStats object. Nota that nucleotide sequences in bioperl do not strictly separate RNA and DNA sequences. By convention, sequences from RNA molecules are shown as is they were DNA. Objects are supposed to make the distinction when needed. This class is one of the few where this distinctions needs to be made. Internally, it changes all Ts into Us before weight and monomer count. SeqStats can be called in two distinct manners. If only a single computation is required on a given sequence object, the method can be called easily using the SeqStats object directly: $weight = Bio::Tools::SeqStats->get_mol_wt($seqobj); Alternately, if several computations will be required on a given sequence object, an "instance" statistics object can be constructed and used for the method calls: $seq_stats = Bio::Tools::SeqStats->new($seqobj); $monomers = $seq_stats->count_monomers(); $codons = $seq_stats->count_codons(); $weight = $seq_stats->get_mol_wt(); $gravy = $seq_stats->hydropathicity(); As currently implemented the object can return the following values from a sequence: =over =item * The molecular weight of the sequence: get_mol_wt() =item * The number of each type of monomer present: count_monomers() =item * The number of each codon present in a nucleic acid sequence: count_codons() =item * The mean hydropathicity ("gravy" score) of a protein: hydropathicity() =back For DNA and RNA sequences single-stranded weights are returned. The molecular weights are calculated for neutral, or not ionized, nucleic acids. The returned weight is the sum of the base-sugar-phosphate residues of the chain plus one weight of water to to account for the additional OH on the phosphate of the 5' residue and the additional H on the sugar ring of the 3' residue. Note that this leads to a difference of 18 in calculated molecular weights compared to some other available programs (e.g. Informax VectorNTI). Note that since sequences may contain ambiguous monomers (e.g. "M", meaning "A" or "C" in a nucleic acid sequence), the method get_mol_wt returns a two-element array containing the greatest lower bound and least upper bound of the molecule. For a sequence with no ambiguous monomers, the two elements of the returned array will be equal. The method count_codons() handles ambiguous bases by simply counting all ambiguous codons together and issuing a warning to that effect. =head1 DEVELOPERS NOTES Ewan moved it from Bio::SeqStats to Bio::Tools::SeqStats Heikki made tiny adjustments (+/- 0.01 daltons) to amino acid molecular weights to have the output match values in SWISS-PROT. Torsten added hydropathicity calculation. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Schattner Email schattner AT alum.mit.edu =head1 CONTRIBUTOR - Torsten Seemann Email torsten.seemann AT infotech.monash.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::SeqStats; use strict; use vars qw(%Alphabets %Alphabets_strict $amino_weights $rna_weights $dna_weights %Weights $amino_hydropathicity); use Bio::Seq; use base qw(Bio::Root::Root); BEGIN { %Alphabets = ( 'dna' => [ qw(A C G T R Y M K S W H B V D X N) ], 'rna' => [ qw(A C G U R Y M K S W H B V D X N) ], 'protein' => [ qw(A R N D C Q E G H I L K M F U P S T W X Y V B Z J O *) ], # sac: added B, Z ); # SAC: new strict alphabet: doesn't allow any ambiguity characters. %Alphabets_strict = ( 'dna' => [ qw( A C G T ) ], 'rna' => [ qw( A C G U ) ], 'protein' => [ qw(A R N D C Q E G H I L K M F U P S T W Y V O) ], ); # IUPAC-IUB SYMBOLS FOR NUCLEOTIDE NOMENCLATURE: # Cornish-Bowden (1985) Nucl. Acids Res. 13: 3021-3030. # Amino Acid alphabet # ------------------------------------------ # Symbol Meaning # ------------------------------------------ my $amino_A_wt = 89.09; my $amino_C_wt = 121.15; my $amino_D_wt = 133.1; my $amino_E_wt = 147.13; my $amino_F_wt = 165.19; my $amino_G_wt = 75.07; my $amino_H_wt = 155.16; my $amino_I_wt = 131.17; my $amino_K_wt = 146.19; my $amino_L_wt = 131.17; my $amino_M_wt = 149.21; my $amino_N_wt = 132.12; my $amino_O_wt = 255.31; my $amino_P_wt = 115.13; my $amino_Q_wt = 146.15; my $amino_R_wt = 174.20; my $amino_S_wt = 105.09; my $amino_T_wt = 119.12; my $amino_U_wt = 168.06; my $amino_V_wt = 117.15; my $amino_W_wt = 204.23; my $amino_Y_wt = 181.19; $amino_weights = { 'A' => [$amino_A_wt, $amino_A_wt], # Alanine 'B' => [$amino_N_wt, $amino_D_wt], # Aspartic Acid, Asparagine 'C' => [$amino_C_wt, $amino_C_wt], # Cysteine 'D' => [$amino_D_wt, $amino_D_wt], # Aspartic Acid 'E' => [$amino_E_wt, $amino_E_wt], # Glutamic Acid 'F' => [$amino_F_wt, $amino_F_wt], # Phenylalanine 'G' => [$amino_G_wt, $amino_G_wt], # Glycine 'H' => [$amino_H_wt, $amino_H_wt], # Histidine 'I' => [$amino_I_wt, $amino_I_wt], # Isoleucine 'J' => [$amino_L_wt, $amino_I_wt], # Leucine, Isoleucine 'K' => [$amino_K_wt, $amino_K_wt], # Lysine 'L' => [$amino_L_wt, $amino_L_wt], # Leucine 'M' => [$amino_M_wt, $amino_M_wt], # Methionine 'N' => [$amino_N_wt, $amino_N_wt], # Asparagine 'O' => [$amino_O_wt, $amino_O_wt], # Pyrrolysine 'P' => [$amino_P_wt, $amino_P_wt], # Proline 'Q' => [$amino_Q_wt, $amino_Q_wt], # Glutamine 'R' => [$amino_R_wt, $amino_R_wt], # Arginine 'S' => [$amino_S_wt, $amino_S_wt], # Serine 'T' => [$amino_T_wt, $amino_T_wt], # Threonine 'U' => [$amino_U_wt, $amino_U_wt], # SelenoCysteine 'V' => [$amino_V_wt, $amino_V_wt], # Valine 'W' => [$amino_W_wt, $amino_W_wt], # Tryptophan 'X' => [$amino_G_wt, $amino_W_wt], # Unknown 'Y' => [$amino_Y_wt, $amino_Y_wt], # Tyrosine 'Z' => [$amino_Q_wt, $amino_E_wt], # Glutamic Acid, Glutamine }; # Extended Dna / Rna alphabet use vars ( qw($C $O $N $H $P $water) ); use vars ( qw($adenine $guanine $cytosine $thymine $uracil)); use vars ( qw($ribose_phosphate $deoxyribose_phosphate $ppi)); use vars ( qw($dna_A_wt $dna_C_wt $dna_G_wt $dna_T_wt $rna_A_wt $rna_C_wt $rna_G_wt $rna_U_wt)); use vars ( qw($dna_weights $rna_weights %Weights)); $C = 12.01; $O = 16.00; $N = 14.01; $H = 1.01; $P = 30.97; $water = 18.015; $adenine = 5 * $C + 5 * $N + 5 * $H; $guanine = 5 * $C + 5 * $N + 1 * $O + 5 * $H; $cytosine = 4 * $C + 3 * $N + 1 * $O + 5 * $H; $thymine = 5 * $C + 2 * $N + 2 * $O + 6 * $H; $uracil = 4 * $C + 2 * $N + 2 * $O + 4 * $H; $ribose_phosphate = 5 * $C + 7 * $O + 9 * $H + 1 * $P; # neutral (unionized) form $deoxyribose_phosphate = 5 * $C + 6 * $O + 9 * $H + 1 * $P; # the following are single strand molecular weights / base $dna_A_wt = $adenine + $deoxyribose_phosphate - $water; $dna_C_wt = $cytosine + $deoxyribose_phosphate - $water; $dna_G_wt = $guanine + $deoxyribose_phosphate - $water; $dna_T_wt = $thymine + $deoxyribose_phosphate - $water; $rna_A_wt = $adenine + $ribose_phosphate - $water; $rna_C_wt = $cytosine + $ribose_phosphate - $water; $rna_G_wt = $guanine + $ribose_phosphate - $water; $rna_U_wt = $uracil + $ribose_phosphate - $water; $dna_weights = { 'A' => [$dna_A_wt,$dna_A_wt], # Adenine 'C' => [$dna_C_wt,$dna_C_wt], # Cytosine 'G' => [$dna_G_wt,$dna_G_wt], # Guanine 'T' => [$dna_T_wt,$dna_T_wt], # Thymine 'M' => [$dna_C_wt,$dna_A_wt], # A or C 'R' => [$dna_A_wt,$dna_G_wt], # A or G 'W' => [$dna_T_wt,$dna_A_wt], # A or T 'S' => [$dna_C_wt,$dna_G_wt], # C or G 'Y' => [$dna_C_wt,$dna_T_wt], # C or T 'K' => [$dna_T_wt,$dna_G_wt], # G or T 'V' => [$dna_C_wt,$dna_G_wt], # A or C or G 'H' => [$dna_C_wt,$dna_A_wt], # A or C or T 'D' => [$dna_T_wt,$dna_G_wt], # A or G or T 'B' => [$dna_C_wt,$dna_G_wt], # C or G or T 'X' => [$dna_C_wt,$dna_G_wt], # G or A or T or C 'N' => [$dna_C_wt,$dna_G_wt], # G or A or T or C }; $rna_weights = { 'A' => [$rna_A_wt,$rna_A_wt], # Adenine 'C' => [$rna_C_wt,$rna_C_wt], # Cytosine 'G' => [$rna_G_wt,$rna_G_wt], # Guanine 'U' => [$rna_U_wt,$rna_U_wt], # Uracil 'M' => [$rna_C_wt,$rna_A_wt], # A or C 'R' => [$rna_A_wt,$rna_G_wt], # A or G 'W' => [$rna_U_wt,$rna_A_wt], # A or U 'S' => [$rna_C_wt,$rna_G_wt], # C or G 'Y' => [$rna_C_wt,$rna_U_wt], # C or U 'K' => [$rna_U_wt,$rna_G_wt], # G or U 'V' => [$rna_C_wt,$rna_G_wt], # A or C or G 'H' => [$rna_C_wt,$rna_A_wt], # A or C or U 'D' => [$rna_U_wt,$rna_G_wt], # A or G or U 'B' => [$rna_C_wt,$rna_G_wt], # C or G or U 'X' => [$rna_C_wt,$rna_G_wt], # G or A or U or C 'N' => [$rna_C_wt,$rna_G_wt], # G or A or U or C }; %Weights = ( 'dna' => $dna_weights, 'rna' => $rna_weights, 'protein' => $amino_weights, ); # Amino acid scale: Hydropathicity. # Ref: Kyte J., Doolittle R.F. J. Mol. Biol. 157:105-132(1982). # http://au.expasy.org/tools/pscale/Hphob.Doolittle.html $amino_hydropathicity = { A => 1.800, R => -4.500, N => -3.500, D => -3.500, C => 2.500, Q => -3.500, E => -3.500, G => -0.400, H => -3.200, I => 4.500, L => 3.800, K => -3.900, M => 1.900, F => 2.800, P => -1.600, S => -0.800, T => -0.700, W => -0.900, Y => -1.300, V => 4.200, }; } sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($seqobj) = $self->_rearrange([qw(SEQ)],@args); unless ($seqobj->isa("Bio::PrimarySeqI")) { $self->throw("SeqStats works only on PrimarySeqI objects"); } if ( !defined $seqobj->alphabet || !defined $Alphabets{$seqobj->alphabet}) { $self->throw("Must have a valid alphabet defined for seq (". join(",",keys %Alphabets)); } $self->{'_seqref'} = $seqobj; # check the letters in the sequence $self->{'_is_strict'} = _is_alphabet_strict($seqobj); return $self; } =head2 count_monomers Title : count_monomers Usage : $rcount = $seq_stats->count_monomers(); or $rcount = $seq_stats->Bio::Tools::SeqStats->($seqobj); Function: Counts the number of each type of monomer (amino acid or base) in the sequence. Ts are counted as Us in RNA sequences. Example : Returns : Reference to a hash in which keys are letters of the genetic alphabet used and values are number of occurrences of the letter in the sequence. Args : None or reference to sequence object Throws : Throws an exception if type of sequence is unknown (ie amino or nucleic)or if unknown letter in alphabet. Ambiguous elements are allowed. =cut sub count_monomers{ my %count = (); my $seqobj; my $_is_strict; my $element = ''; my $_is_instance = 1 ; my $self = shift @_; my $object_argument = shift @_; # First we need to determine if the present object is an instance # object or if the sequence object has been passed as an argument if (defined $object_argument) { $_is_instance = 0; } # If we are using an instance object... if ($_is_instance) { if ($self->{'_monomer_count'}) { return $self->{'_monomer_count'}; # return count if previously calculated } $_is_strict = $self->{'_is_strict'}; # retrieve "strictness" $seqobj = $self->{'_seqref'}; } else { # otherwise... $seqobj = $object_argument; # Following two lines lead to error in "throw" routine $seqobj->isa("Bio::PrimarySeqI") || $self->throw("SeqStats works only on PrimarySeqI objects"); # is alphabet OK? Is it strict? $_is_strict = _is_alphabet_strict($seqobj); } my $alphabet = $_is_strict ? $Alphabets_strict{$seqobj->alphabet} : $Alphabets{$seqobj->alphabet} ; # get array of allowed letters # convert everything to upper case to be safe my $seqstring = uc $seqobj->seq(); # Since T is used in RichSeq RNA sequences, do conversion locally $seqstring =~ s/T/U/g if $seqobj->alphabet eq 'rna'; # For each letter, count the number of times it appears in # the sequence LETTER: foreach $element (@$alphabet) { # skip terminator symbol which may confuse regex next LETTER if $element eq '*'; $count{$element} = ( $seqstring =~ s/$element/$element/g); } if ($_is_instance) { $self->{'_monomer_count'} = \%count; # Save in case called again later } return \%count; } =head2 get_mol_wt Title : get_mol_wt Usage : $wt = $seqobj->get_mol_wt() or $wt = Bio::Tools::SeqStats ->get_mol_wt($seqobj); Function: Calculate molecular weight of sequence Ts are counted as Us in RNA sequences. Example : Returns : Reference to two element array containing lower and upper bounds of molecule molecular weight. For DNA and RNA sequences single-stranded weights are returned. If sequence contains no ambiguous elements, both entries in array are equal to molecular weight of molecule. Args : None or reference to sequence object Throws : Exception if type of sequence is unknown (ie not amino or nucleic) or if unknown letter in alphabet. Ambiguous elements are allowed. =cut sub get_mol_wt { my $seqobj; my $_is_strict; my $element = ''; my $_is_instance = 1 ; my $self = shift @_; my $object_argument = shift @_; my ($weight_array, $rcount); if (defined $object_argument) { $_is_instance = 0; } if ($_is_instance) { if ($weight_array = $self->{'_mol_wt'}) { # return mol. weight if previously calculated return $weight_array; } $seqobj = $self->{'_seqref'}; $rcount = $self->count_monomers(); } else { $seqobj = $object_argument; $seqobj->isa("Bio::PrimarySeqI") || $self->throw("Error: SeqStats works only on PrimarySeqI objects"); $_is_strict = _is_alphabet_strict($seqobj); # is alphabet OK? $rcount = $self->count_monomers($seqobj); } # We will also need to know what type of monomer we are dealing with my $moltype = $seqobj->alphabet(); # In general,the molecular weight is bounded below by the sum of the # weights of lower bounds of each alphabet symbol times the number of # occurrences of the symbol in the sequence. A similar upper bound on # the weight is also calculated. # Note that for "strict" (i.e. unambiguous) sequences there is an # inefficiency since the upper bound = the lower bound and there are # two calculations. However, this decrease in performance will be # minor and leads to significantly more readable code. my $weight_lower_bound = 0; my $weight_upper_bound = 0; my $weight_table = $Weights{$moltype}; my $total_res; # compute weight of all the residues foreach $element (keys %$rcount) { $weight_lower_bound += $$rcount{$element} * $$weight_table{$element}->[0]; $weight_upper_bound += $$rcount{$element} * $$weight_table{$element}->[1]; # this tracks only the residues used for counting MW $total_res += $$rcount{$element}; } if ($moltype =~ /protein/) { # remove H2O during peptide bond formation. $weight_lower_bound -= $water * ($total_res - 1); $weight_upper_bound -= $water * ($total_res - 1); } else { # Correction because phosphate of 5' residue has additional OH and # sugar ring of 3' residue has additional H $weight_lower_bound += $water; $weight_upper_bound += $water; } $weight_lower_bound = sprintf("%.1f", $weight_lower_bound); $weight_upper_bound = sprintf("%.1f", $weight_upper_bound); $weight_array = [$weight_lower_bound, $weight_upper_bound]; if ($_is_instance) { $self->{'_mol_wt'} = $weight_array; # Save in case called again later } return $weight_array; } =head2 count_codons Title : count_codons Usage : $rcount = $seqstats->count_codons() or $rcount = Bio::Tools::SeqStats->count_codons($seqobj) Function: Counts the number of each type of codons for a dna or rna sequence, starting at the 1st triple of the input sequence. Example : Returns : Reference to a hash in which keys are codons of the genetic alphabet used and values are number of occurrences of the codons in the sequence. All codons with "ambiguous" bases are counted together. Args : None or sequence object Throws : an exception if type of sequence is unknown or protein. =cut sub count_codons { my $rcount = {}; my $codon ; my $seqobj; my $_is_strict; my $element = ''; my $_is_instance = 1 ; my $self = shift @_; my $object_argument = shift @_; if (defined $object_argument) { $_is_instance = 0; } if ($_is_instance) { if ($rcount = $self->{'_codon_count'}) { return $rcount; # return count if previously calculated } $_is_strict = $self->{'_is_strict'}; # retrieve "strictness" $seqobj = $self->{'_seqref'}; } else { $seqobj = $object_argument; $seqobj->isa("Bio::PrimarySeqI") || $self->throw("Error: SeqStats works only on PrimarySeqI objects"); $_is_strict = _is_alphabet_strict($seqobj); } # Codon counts only make sense for nucleic acid sequences my $alphabet = $seqobj->alphabet(); unless ($alphabet =~ /[dr]na/i) { $seqobj->throw("Codon counts only meaningful for dna or rna, ". "not for $alphabet sequences."); } # If sequence contains ambiguous bases, warn that codons # containing them will all be lumped together in the count. if (!$_is_strict ) { $seqobj->warn("Sequence $seqobj contains ambiguous bases.". " All codons with ambiguous bases will be added together in count.") if $self->verbose >= 0 ; } my $seq = $seqobj->seq(); # Now step through the string by threes and count the codons CODON: while (length($seq) > 2) { $codon = uc substr($seq,0,3); $seq = substr($seq,3); if ($codon =~ /[^ACTGU]/i) { $$rcount{'ambiguous'}++; #lump together ambiguous codons next CODON; } if (!defined $$rcount{$codon}) { $$rcount{$codon}= 1 ; next CODON; } $$rcount{$codon}++; # default } if ($_is_instance) { $self->{'_codon_count'} = $rcount; # Save in case called again later } return $rcount; } =head2 hydropathicity Title : hydropathicity Usage : $gravy = $seqstats->hydropathicity(); or $gravy = Bio::Tools::SeqStats->hydropathicity($seqobj); Function: Calculates the mean Kyte-Doolittle hydropathicity for a protein sequence. Also known as the "gravy" score. Refer to Kyte J., Doolittle R.F., J. Mol. Biol. 157:105-132(1982). Example : Returns : float Args : None or reference to sequence object Throws : an exception if type of sequence is not protein. =cut sub hydropathicity { my $seqobj; my $_is_strict; my $element = ''; my $_is_instance = 1 ; my $self = shift @_; my $object_argument = shift @_; if (defined $object_argument) { $_is_instance = 0; } if ($_is_instance) { if (my $gravy = $self->{'_hydropathicity'}) { return $gravy; # return value if previously calculated } $_is_strict = $self->{'_is_strict'}; # retrieve "strictness" $seqobj = $self->{'_seqref'}; } else { $seqobj = $object_argument; $seqobj->isa("Bio::PrimarySeqI") || $self->throw("Error: SeqStats works only on PrimarySeqI objects"); $_is_strict = _is_alphabet_strict($seqobj); } # hydropathicity not menaingful for empty sequences unless ($seqobj->length() > 0) { $seqobj->throw("hydropathicity not defined for zero-length sequences"); } # hydropathicity only make sense for protein sequences my $alphabet = $seqobj->alphabet(); unless ($alphabet =~ /protein/i) { $seqobj->throw("hydropathicity only meaningful for protein, ". "not for $alphabet sequences."); } # If sequence contains ambiguous bases, warn that codons # containing them will all be lumped together in the count. unless ($_is_strict ) { $seqobj->throw("Sequence $seqobj contains ambiguous amino acids. ". "Hydropathicity can not be caculated.") } my $seq = $seqobj->seq(); # Now step through the string and add up the hydropathicity values my $gravy = 0; for my $i ( 0 .. length($seq) ) { my $codon = uc(substr($seq,$i,1)); $gravy += $amino_hydropathicity->{$codon}||0; # table look-up } $gravy /= length($seq); if ($_is_instance) { $self->{'_hydropathicity'} = $gravy; # Save in case called again later } return $gravy; } =head2 _is_alphabet_strict Title : _is_alphabet_strict Usage : Function: internal function to determine whether there are any ambiguous elements in the current sequence Example : Returns : 1 if strict alphabet is being used, 0 if ambiguous elements are present Args : Throws : an exception if type of sequence is unknown (ie amino or nucleic) or if unknown letter in alphabet. Ambiguous monomers are allowed. =cut sub _is_alphabet_strict { my ($seqobj) = @_; my $moltype = $seqobj->alphabet(); # convert everything to upper case to be safe my $seqstring = uc $seqobj->seq(); # Since T is used in RichSeq RNA sequences, do conversion locally $seqstring =~ s/T/U/g if $seqobj->alphabet eq 'rna'; # First we check if only the 'strict' letters are present in the # sequence string If not, we check whether the remaining letters # are ambiguous monomers or whether there are illegal letters in # the string # $alpha_array is a ref to an array of the 'strictly' allowed letters my $alpha_array = $Alphabets_strict{$moltype} ; # $alphabet contains the allowed letters in string form my $alphabet = join ('', @$alpha_array) ; unless ($seqstring =~ /[^$alphabet]/) { return 1 ; } # Next try to match with the alphabet's ambiguous letters $alpha_array = $Alphabets{$moltype} ; $alphabet = join ('', @$alpha_array) ; unless ($seqstring =~ /[^$alphabet]/) { return 0 ; } # If we got here there is an illegal letter in the sequence $seqobj->throw("Alphabet not OK for $seqobj"); } =head2 _print_data Title : _print_data Usage : $seqobj->_print_data() or Bio::Tools::SeqStats->_print_data(); Function: Displays dna / rna parameters (used for debugging) Returns : 1 Args : None Used for debugging. =cut sub _print_data { print "\n adenine = : $adenine \n"; print "\n guanine = : $guanine \n"; print "\n cytosine = : $cytosine \n"; print "\n thymine = : $thymine \n"; print "\n uracil = : $uracil \n"; print "\n dna_A_wt = : $dna_A_wt \n"; print "\n dna_C_wt = : $dna_C_wt \n"; print "\n dna_G_wt = : $dna_G_wt \n"; print "\n dna_T_wt = : $dna_T_wt \n"; print "\n rna_A_wt = : $rna_A_wt \n"; print "\n rna_C_wt = : $rna_C_wt \n"; print "\n rna_G_wt = : $rna_G_wt \n"; print "\n rna_U_wt = : $rna_U_wt \n"; return 1; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SeqWords.pm���������������������������������������������������������������000444��000765��000024�� 22401�12254227325� 17375� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#--------------------------------------------------------------------------- # PACKAGE : Bio::Tools::SeqWords # PURPOSE : To count n-mers in any sequence of characters # AUTHOR : Derek Gatherer (d.gatherer@vir.gla.ac.uk) # SOURCE : # CREATED : 21st March 2000 # MODIFIED : 11th November 2003 (DG - new method, count_overlap_words) # LICENCE : You may distribute this module under the same terms # : as the rest of BioPerl. #--------------------------------------------------------------------------- =head1 NAME Bio::Tools::SeqWords - Object holding n-mer statistics for a sequence =head1 SYNOPSIS # Create the SeqWords object, e.g.: my $inputstream = Bio::SeqIO->new(-file => "seqfile", -format => 'Fasta'); my $seqobj = $inputstream->next_seq(); my $seq_word = Bio::Tools::SeqWords->new(-seq => $seqobj); # Or: my $seqobj = Bio::PrimarySeq->new(-seq => "agggtttccc", -alphabet => 'dna', -id => 'test'); my $seq_word = Bio::Tools::SeqWords->new(-seq => $seqobj); # obtain a hash of word counts, eg: my $hash_ref = $seq_stats->count_words($word_length); # display hash table, eg: my %hash = %$hash_ref; foreach my $key(sort keys %hash) { print "\n$key\t$hash{$key}"; } # Or: my $hash_ref = Bio::Tools::SeqWords->count_words($seqobj,$word_length); =head1 DESCRIPTION L<Bio::Tools::SeqWords> is a featherweight object for the calculation of n-mer word occurrences in a single sequence. It is envisaged that the object will be useful for construction of scripts which use n-mer word tables as the raw material for statistical calculations; for instance, hexamer frequency for the calculation of coding protential, or the calculation of periodicity in repetitive DNA. Triplet frequency is already handled by L<Bio::Tools::SeqStats> (author: Peter Schattner). There are a few possible applications for protein, e.g. hypothesised amino acid 7-mers in heat shock proteins, or proteins with multiple simple motifs. Sometimes these protein periodicities are best seen when the amino acid alphabet is truncated, e.g. Shulman alphabet. Since there are quite a few of these shortened alphabets, this module does not specify any particular alphabet. See Synopsis above for object creation code. =head2 Rationale Take a sequence object and create an object for the purposes of holding n-mer word statistics about that sequence. The sequence can be nucleic acid or protein. In count_words() the words are counted in a non-overlapping manner, ie. in the style of a codon table, but with any word length. In count_overlap_words() the words are counted in an overlapping manner. For counts on opposite strand (DNA/RNA), a reverse complement method should be performed, and then the count repeated. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Derek Gatherer, in the loosest sense of the word 'author'. The general shape of the module is lifted directly from the SeqStat module of Peter Schattner. The central subroutine to count the words is adapted from original code provided by Dave Shivak, in response to a query on the bioperl mailing list. At least 2 other people provided alternative means (equally good but not used in the end) of performing the same calculation. Thanks to all for your assistance. =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::SeqWords; use strict; use base qw(Bio::Root::Root); sub new { my($class,@args) = @_; # our new standard way of instantiation my $self = $class->SUPER::new(@args); my ($seqobj) = $self->_rearrange([qw(SEQ)],@args); if((! defined($seqobj)) && @args && ref($args[0])) { # parameter not passed as named parameter? $seqobj = $args[0]; } if(! $seqobj->isa("Bio::PrimarySeqI")) { $self->throw(ref($self) . " works only on PrimarySeqI objects\n"); } $self->{'_seqref'} = $seqobj; return $self; } =head2 count_words Title : count_words Usage : $word_count = $seq_stats->count_words($word_length) or $word_count = $seq_stats->Bio::Tools::SeqWords->($seqobj,$word_length); Function: Counts non-overlapping words within a string, any alphabet is used Example : a sequence ACCGTCCGT, counted at word length 4, will give the hash {ACCG => 1, TCCG => 1} Returns : Reference to a hash in which keys are words (any length) of the alphabet used and values are number of occurrences of the word in the sequence. Args : Word length as scalar and, reference to sequence object if required Throws an exception word length is not a positive integer or if word length is longer than the sequence. =cut sub count_words { my ($self,$seqobj,$word_length) = @_; # check how we were called, and if necessary rearrange arguments if(ref($seqobj)) { # call as SeqWords->count_words($seq, $wordlen) if(! $seqobj->isa("Bio::PrimarySeqI")) { $self->throw("SeqWords works only on PrimarySeqI objects\n"); } } else { # call as $obj->count_words($wordlen) $word_length = $seqobj; $seqobj = undef; } if(! defined($seqobj)){ $seqobj = $self->{'_seqref'}; } if($word_length eq "" || $word_length =~ /[a-z]/i){ $self->throw("SeqWords cannot accept non-numeric characters". " or a null value in the \$word_length variable\n"); }elsif ($word_length <1 || ($word_length - int($word_length)) >0){ $self->throw("SeqWords requires the word length to be a ". "positive integer\n"); } my $seqstring = uc $seqobj->seq(); if($word_length > length($seqstring)){ $self->throw("die in _count, \$word_length is bigger ". "than sequence length\n"); } my $type = "non-overlap"; my $words = _count($seqobj, $word_length, $type); return $words; # ref. to a hash } =head2 count_overlap_words Title : count_overlap_words Usage : $word_count = $word_obj->count_overlap_words($word_length); Function: Counts overlapping words within a string, any alphabet is used Example : A sequence ACCAACCA, counted at word length 4, will give the hash {ACCA=>2, CCAA=>1, CAAC=>1, AACC=>1} Returns : Reference to a hash in which keys are words (any length) of the alphabet used and values are number of occurrences of the word in the sequence. Args : Word length as scalar Throws an exception if word length is not a positive integer or if word length is longer than the sequence. =cut sub count_overlap_words { my ($self,$seqobj,$word_length) = @_; # check how we were called, and if necessary rearrange arguments if(ref($seqobj)){ # call as SeqWords->count_words($seq, $wordlen) if(! $seqobj->isa("Bio::PrimarySeqI")){ $self->throw("SeqWords works only on PrimarySeqI objects\n"); } }else{ # call as $obj->count_words($wordlen) $word_length = $seqobj; $seqobj = undef; } if(! defined($seqobj)) { $seqobj = $self->{'_seqref'}; } my $seqstring = uc $seqobj->seq(); if($word_length > length($seqstring)){ $self->throw("die in _count, \$word_length is bigger ". "than sequence length\n"); } my $type = "overlap"; my $words = _count($seqobj, $word_length, $type); return $words; # ref. to a hash } # the actual counting routine # used by both count_words and count_overlap_words sub _count { my ($seqobj, $word_length, $type) = @_; my %codon = (); # now the real business # JS - remove DNA assumption my $seqstring = uc $seqobj->seq(); if($type eq "non-overlap") { while($seqstring =~ /((\w){$word_length})/gim){ $codon{uc($1)}++; } } elsif($type eq "overlap"){ my $seqlen = $seqobj->length(); # measure length for (my $frame = 1; $frame <= $word_length; $frame++) { # run through frames my $seqstring = uc($seqobj->subseq($frame,$seqlen)); # take the relevant substring while($seqstring =~ /((\w){$word_length})/gim){ $codon{uc($1)}++; # keep adding to hash } } } else { Bio::Root::Root->throw("\nSomething badly wrong here. \$type: $type can only be overlap or non-overlap"); } return \%codon; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Sigcleave.pm��������������������������������������������������������������000444��000765��000024�� 43671�12254227312� 17540� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#----------------------------------------------------------------------------- # PACKAGE : Bio::Tools::Sigcleave # AUTHOR : Chris Dagdigian, dag@sonsorol.org # CREATED : Jan 28 1999 # # Copyright (c) 1997-9 bioperl, Chris Dagdigian and others. All Rights Reserved. # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # _History_ # # Object framework ripped from Steve Chervits's SeqPattern.pm # # Core EGCG Sigcleave emulation from perl code developed by # Danh Nguyen & Kamalakar Gulukota which itself was based # loosely on Colgrove's signal.c program. # # The overall idea is to replicate the output of the sigcleave # program which was distributed with the EGCG extension to the GCG sequence # analysis package. There is also an accessor method for just getting at # the raw results. # #----------------------------------------------------------------------------- =head1 NAME Bio::Tools::Sigcleave - Bioperl object for sigcleave analysis =head1 SYNOPSIS =head2 Object Creation use Bio::Tools::Sigcleave (); # to keep the module backwar compatible, you can pass it a sequence string, but # there recommended say is to pass it a Seq object # this works $seq = "MVLLLILSVLLLKEDVRGSAQSSERRVVAHMPGDIIIGALFSVHHQPTVDKVHERKCGAVREQYGI"; $sig = Bio::Tools::Sigcleave->new(-seq => $seq, -type => 'protein', -threshold=>'3.5', ); # but you do: $seqobj = Bio::PrimarySeq->new(-seq => $seq); $sig = Bio::Tools::Sigcleave->new(-seq => $seqobj, -threshold=>'3.5', ); # now you can detect procaryotic signal sequences as well as eucaryotic $sig->matrix('eucaryotic'); # or 'procaryotic' =head2 Object Methods & Accessors # you can use this method to fine tune the threshod before printing out the results $sig->result_count: %raw_results = $sig->signals; $formatted_output = $sig->pretty_print; =head1 DESCRIPTION "Sigcleave" was a program distributed as part of the free EGCG add-on to earlier versions of the GCG Sequence Analysis package. A new implementation of the algorithm is now part of EMBOSS package. From the EGCG documentation: SigCleave uses the von Heijne method to locate signal sequences, and to identify the cleavage site. The method is 95% accurate in resolving signal sequences from non-signal sequences with a cutoff score of 3.5, and 75-80% accurate in identifying the cleavage site. The program reports all hits above a minimum value. The EGCG Sigcleave program was written by Peter Rice (E-mail: pmr@sanger.ac.uk Post: Informatics Division, The Sanger Centre, Wellcome Trust Genome Campus, Hinxton, Cambs, CB10 1SA, UK). Since EGCG is no longer distributed for the latest versions of GCG, this code was developed to emulate the output of the original program as much as possible for those who lost access to sigcleave when upgrading to newer versions of GCG. There are 2 accessor methods for this object. "signals" will return a perl associative array containing the sigcleave scores keyed by amino acid position. "pretty_print" returns a formatted string similar to the output of the original sigcleave utility. In both cases, the "threshold" setting controls the score reporting level. If no value for threshold is passed in by the user, the code defaults to a reporting value of 3.5. In this implemntation the accessor will never return any score/position pair which does not meet the threshold limit. This is the slightly different from the behaviour of the 8.1 EGCG sigcleave program which will report the highest of the under-threshold results if nothing else is found. Example of pretty_print output: SIGCLEAVE of sigtest from: 1 to 146 Report scores over 3.5 Maximum score 4.9 at residue 131 Sequence: FVILAAMSIQGSA-NLQTQWKSTASLALET | (signal) | (mature peptide) 118 131 Other entries above 3.5 Maximum score 3.7 at residue 112 Sequence: CSRQLFGWLFCKV-HPGAIVFVILAAMSIQGSANLQTQWKSTASLALET | (signal) | (mature peptide) 99 112 =head1 FEEDBACK When updating and maintaining a module, it helps to know that people are actually using it. Let us know if you find a bug, think this code is useful or have any improvements/features to suggest. =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Chris Dagdigian, dag-at-sonsorol.org & others =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 VERSION Bio::Tools::Sigcleave, $Id$ =head1 COPYRIGHT Copyright (c) 1999 Chris Dagdigian & others. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 REFERENCES / SEE ALSO von Heijne G. (1986) "A new method for predicting signal sequences cleavage sites." Nucleic Acids Res. 14, 4683-4690. von Heijne G. (1987) in "Sequence Analysis in Molecular Biology: Treasure Trove or Trivial Pursuit" (Acad. Press, (1987), 113-117). =head1 APPENDIX The following documentation describes the various functions contained in this module. Some functions are for internal use and are not meant to be called by the user; they are preceded by an underscore ("_"). =cut # ## ### #### END of main POD documentation. ### ## # package Bio::Tools::Sigcleave; use Bio::PrimarySeq; use base qw(Bio::Root::Root); use strict; use vars qw ($ID %WeightTable_euc %WeightTable_pro ); $ID = 'Bio::Tools::Sigcleave'; %WeightTable_euc = ( #Sample: 161 aligned sequences # R -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 +1 +2 Expect 'A' => [16, 13, 14, 15, 20, 18, 18, 17, 25, 15, 47, 6, 80, 18, 6, 14.5], 'C' => [ 3, 6, 9, 7, 9, 14, 6, 8, 5, 6, 19, 3, 9, 8, 3, 4.5], 'D' => [ 0, 0, 0, 0, 0, 0, 0, 0, 5, 3, 0, 5, 0, 10, 11, 8.9], 'E' => [ 0, 0, 0, 1, 0, 0, 0, 0, 3, 7, 0, 7, 0, 13, 14, 10.0], 'F' => [13, 9, 11, 11, 6, 7, 18, 13, 4, 5, 0, 13, 0, 6, 4, 5.6], 'G' => [ 4, 4, 3, 6, 3, 13, 3, 2, 19, 34, 5, 7, 39, 10, 7, 12.1], 'H' => [ 0, 0, 0, 0, 0, 1, 1, 0, 5, 0, 0, 6, 0, 4, 2, 3.4], 'I' => [15, 15, 8, 6, 11, 5, 4, 8, 5, 1, 10, 5, 0, 8, 7, 7.4], 'K' => [ 0, 0, 0, 1, 0, 0, 1, 0, 0, 4, 0, 2, 0, 11, 9, 11.3], 'L' => [71, 68, 72, 79, 78, 45, 64, 49, 10, 23, 8, 20, 1, 8, 4, 12.1], 'M' => [ 0, 3, 7, 4, 1, 6, 2, 2, 0, 0, 0, 1, 0, 1, 2, 2.7], 'N' => [ 0, 1, 0, 1, 1, 0, 0, 0, 3, 3, 0, 10, 0, 4, 7, 7.1], 'P' => [ 2, 0, 2, 0, 0, 4, 1, 8, 20, 14, 0, 1, 3, 0, 22, 7.4], 'Q' => [ 0, 0, 0, 1, 0, 6, 1, 0, 10, 8, 0, 18, 3, 19, 10, 6.3], 'R' => [ 2, 0, 0, 0, 0, 1, 0, 0, 7, 4, 0, 15, 0, 12, 9, 7.6], 'S' => [ 9, 3, 8, 6, 13, 10, 15, 16, 26, 11, 23, 17, 20, 15, 10, 11.4], 'T' => [ 2, 10, 5, 4, 5, 13, 7, 7, 12, 6, 17, 8, 6, 3, 10, 9.7], 'V' => [20, 25, 15, 18, 13, 15, 11, 27, 0, 12, 32, 3, 0, 8, 17, 11.1], 'W' => [ 4, 3, 3, 1, 1, 2, 6, 3, 1, 3, 0, 9, 0, 2, 0, 1.8], 'Y' => [ 0, 1, 4, 0, 0, 1, 3, 1, 1, 2, 0, 5, 0, 1, 7, 5.6] ); %WeightTable_pro = ( #Sample: 36 aligned sequences # R -13 -12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 +1 +2 Expect 'A' => [0, 8, 8, 9, 6, 7, 5, 6, 7, 7, 24, 2, 31, 18, 4, 3.2], 'C' => [1, 0, 0, 1, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1.0], 'D' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 8, 2.0], 'E' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 4, 8, 2.2], 'F' => [2, 4, 3, 4, 1, 1, 8, 0, 4, 1, 0, 7, 0, 1, 0, 1.3], 'G' => [4, 2, 2, 2, 3, 5, 2, 4, 2, 2, 0, 2, 2, 1, 0, 2.7], 'H' => [0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 7, 0, 1, 0, 0.8], 'I' => [3, 1, 5, 1, 5, 0, 1, 3, 0, 0, 0, 0, 0, 0, 2, 1.7], 'K' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 2, 0, 3, 0, 2.5], 'L' => [8, 11, 9, 8, 9, 13, 1, 0, 2, 2, 1, 2, 0, 0, 1, 2.7], 'M' => [0, 2, 1, 1, 3, 2, 3, 0, 1, 2, 0, 4, 0, 0, 1, 0.6], 'N' => [0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 3, 0, 1, 4, 1.6], 'P' => [0, 1, 1, 1, 1, 1, 2, 3, 5, 2, 0, 0, 0, 0, 5, 1.7], 'Q' => [0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 0, 3, 0, 0, 1, 1.4], 'R' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1.7], 'S' => [1, 0, 1, 4, 4, 1, 5, 15, 5, 8, 5, 2, 2, 0, 0, 2.6], 'T' => [2, 0, 4, 2, 2, 2, 2, 2, 5, 1, 3, 0, 1, 1, 2, 2.2], 'V' => [5, 7, 1, 3, 1, 4, 7, 0, 0, 4, 3, 0, 0, 2, 0, 2.5], 'W' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0.4], 'Y' => [0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 1, 0, 0, 0, 1.3] ); ## ## Now we calculate the _real_ values for the weight tables ## ## ## yeah yeah yeah there is lots of math here that gets repeated ## every single time a sigcleave object gets created. This is ## a quick hack to make sure that we get the scores as accurate as ## possible. Need all those significant digits.... ## ## suggestions for speedup aproaches welcome ## foreach my $i (keys %WeightTable_euc) { my $expected = $WeightTable_euc{$i}[15]; if ($expected > 0) { for (my $j=0; $j<16; $j++) { if ($WeightTable_euc{$i}[$j] == 0) { $WeightTable_euc{$i}[$j] = 1; if ($j == 10 || $j == 12) { $WeightTable_euc{$i}[$j] = 1.e-10; } } $WeightTable_euc{$i}[$j] = log($WeightTable_euc{$i}[$j]/$expected); } } } foreach my $i (keys %WeightTable_pro) { my $expected = $WeightTable_pro{$i}[15]; if ($expected > 0) { for (my $j=0; $j<16; $j++) { if ($WeightTable_pro{$i}[$j] == 0) { $WeightTable_pro{$i}[$j] = 1; if ($j == 10 || $j == 12) { $WeightTable_pro{$i}[$j] = 1.e-10; } } $WeightTable_pro{$i}[$j] = log($WeightTable_pro{$i}[$j]/$expected); } } } ##################################################################################### ## CONSTRUCTOR ## ##################################################################################### sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); #my $self = Bio::Seq->new(@args); my ($seq, $threshold, $matrix) = $self->_rearrange([qw(SEQ THRESHOLD MATRIX)],@args); defined $threshold && $self->threshold($threshold); $matrix && $self->matrix($matrix); $seq && $self->seq($seq); return $self; } =head1 threshold Title : threshold Usage : $value = $self->threshold Purpose : Read/write method sigcleave score reporting threshold. Returns : float. Argument : new value, float Throws : on non-number argument Comments : defaults to 3.5 See Also : n/a =cut #---------------- sub threshold { #---------------- my ($self, $value) = @_; if( defined $value) { $self->throw("I need a number, not [$value]") if $value !~ /^[+-]?[\d\.]+$/; $self->{'_threshold'} = $value; } return $self->{'_threshold'} || 3.5 ; } =head1 matrix Title : matrix Usage : $value = $self->matrix('procaryotic') Purpose : Read/write method sigcleave matrix. Returns : float. Argument : new value: 'eucaryotic' or 'procaryotic' Throws : on non-number argument Comments : defaults to 3.5 See Also : n/a =cut #---------------- sub matrix { #---------------- my ($self, $value) = @_; if( defined $value) { $self->throw("I need 'eucaryotic' or 'procaryotic', not [$value]") unless $value eq 'eucaryotic' or $value eq 'procaryotic'; $self->{'_matrix'} = $value; } return $self->{'_matrix'} || 'eucaryotic' ; } =head1 seq Title : seq Usage : $value = $self->seq($seq_object) Purpose : set the Seq object to be used Returns : Seq object Argument : protein sequence or Seq object See Also : n/a =cut #---------------- sub seq { #---------------- my ($self, $value) = @_; if( defined $value) { if ($value->isa('Bio::PrimarySeqI')) { $self->{'_seq'} = $value; } else { $self->{'_seq'} = Bio::PrimarySeq->new(-seq => $value, -alphabet => 'protein'); } } return $self->{'_seq'}; } =head1 _Analyze Title : _Analyze Usage : N/A This is an internal method. Not meant to be called from outside : the package : Purpose : calculates sigcleave score and amino acid position for the : given protein sequence. The score reporting threshold can : be adjusted by passing in the "threshold" parameter during : object construction. If no threshold is passed in, the code : defaults to reporting any scores equal to or above 3.5 : Returns : nothing. results are added to the object Argument : none. Throws : nothing. Comments : nothing. See Also : n/a =cut #---------------- sub _Analyze { #---------------- my($self) = @_; my %signals; my @hitWeight = (); my @hitsort = (); my @hitpos = (); my $maxSite = ""; my $seqPos = ""; my $istart = ""; my $iend = ""; my $icol = ""; my $i = ""; my $weight = ""; my $k = 0; my $c = 0; my $seqBegin = 0; my $pVal = -13; my $nVal = 2; my $nHits = 0; my $seqEnd = $self->seq->length; my $pep = $self->seq->seq; my $minWeight = $self->threshold; my $matrix = $self->matrix; ## The weight table is keyed by UPPERCASE letters so we uppercase ## the pep string because we don't want to alter the actual object ## sequence. $pep =~ tr/a-z/A-Z/; for ($seqPos = $seqBegin; $seqPos < $seqEnd; $seqPos++) { $istart = (0 > $seqPos + $pVal)? 0 : $seqPos + $pVal; $iend = ($seqPos + $nVal - 1 < $seqEnd)? $seqPos + $nVal - 1 : $seqEnd; $icol= $iend - $istart + 1; $weight = 0.00; for ($k=0; $k<$icol; $k++) { $c = substr($pep, $istart + $k, 1); ## CD: The if(defined) stuff was put in here because Sigcleave.pm ## CD: kept getting warnings about undefined vals during 'make test' ... if ($matrix eq 'eucaryotic') { $weight += $WeightTable_euc{$c}[$k] if defined $WeightTable_euc{$c}[$k]; } else { $weight += $WeightTable_pro{$c}[$k] if defined $WeightTable_pro{$c}[$k]; } } $signals{$seqPos+1} = sprintf ("%.1f", $weight) if $weight >= $minWeight; } $self->{"_signal_scores"} = { %signals }; } =head1 signals Title : signals Usage : %sigcleave_results = $sig->signals; : Purpose : Accessor method for sigcleave results : Returns : Associative array. The key value represents the amino acid position : and the value represents the score. Only scores that : are greater than or equal to the THRESHOLD value are reported. : Argument : none. Throws : none. Comments : none. See Also : THRESHOLD =cut #---------------- sub signals { #---------------- my $self = shift; my %results; my $position; # do the calculations $self->_Analyze; foreach $position ( sort keys %{ $self->{'_signal_scores'} } ) { $results{$position} = $self->{'_signal_scores'}{$position}; } return %results; } =head1 result_count Title : result_count Usage : $count = $sig->result_count; : Purpose : Accessor method for sigcleave results : Returns : Integer, number of results above the threshold : Argument : none. Throws : none. Comments : none. See Also : THRESHOLD =cut #---------------- sub result_count { #---------------- my $self = shift; $self->_Analyze; return keys %{ $self->{'_signal_scores'} }; } =head1 pretty_print Title : pretty_print Usage : $output = $sig->pretty_print; : print $sig->pretty_print; : Purpose : Emulates the output of the EGCG Sigcleave : utility. : Returns : A formatted string. Argument : none. Throws : none. Comments : none. See Also : n/a =cut #---------------- sub pretty_print { #---------------- my $self = shift; my $pos; my $output; my $cnt = 1; my %results = $self->signals; my @hits = keys %results; my $hitcount = $#hits; $hitcount++; my $thresh = $self->threshold; my $seqlen = $self->seq->length || 0; my $name = $self->seq->id || 'NONAME'; my $pep = $self->seq->seq; $pep =~ tr/a-z/A-Z/; $output = "SIGCLEAVE of $name from: 1 to $seqlen\n\n"; if ($hitcount > 0) { $output .= "Report scores over $thresh\n"; foreach $pos ((sort { $results{$b} cmp $results{$a} } keys %results)) { my $start = $pos - 15; $start = 1 if $start < 1; my $sig = substr($pep,$start -1,$pos-$start ); $output .= sprintf ("Maximum score %1.1f at residue %3d\n",$results{$pos},$pos); $output .= "\n"; $output .= " Sequence: "; $output .= $sig; $output .= "-" x (15- length($sig)); $output .= "-"; $output .= substr($pep,$pos-1,50); $output .= "\n"; $output .= " " x 12; $output .= "| \(signal\) | \(mature peptide\)\n"; $output .= sprintf(" %3d %3d\n\n",$start,$pos); if (($hitcount > 1) && ($cnt == 1)) { $output .= " Other entries above $thresh\n\n"; } $cnt++; } } $output; } 1; __END__ ######################################################################### # End of class ######################################################################### �����������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Signalp.pm����������������������������������������������������������������000555��000765��000024�� 17042�12254227314� 17231� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parser module for Signalp Bio::Tools::Signalp # # # Based on the EnsEMBL module # Bio::EnsEMBL::Pipeline::Runnable::Protein::Signalp originally # written by Marc Sohrmann (ms2@sanger.ac.uk) Written in BioPipe by # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Balamurugan Kumarasamy <savikalpa@fugu-sg.org> Cared for by the Fugu # Informatics team (fuguteam@fugu-sg.org) # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Tools::Signalp - parser for Signalp output =head1 SYNOPSIS use Bio::Tools::Signalp; my $parser = Bio::Tools::Signalp->new(-fh =>$filehandle ); while( my $sp_feat = $parser->next_result ) { if ($sp_feat->score > 0.9) { push @likely_sigpep, $sp_feat; } } =head1 DESCRIPTION C<SignalP> predicts the presence and location of signal peptide cleavage sites in amino acid sequences. L<Bio::Tools::Signalp> parses the output of C<SignalP> to provide a L<Bio::SeqFeature::Generic> object describing the signal peptide found, if any. It returns a variety of tags extracted from the NN and HMM analysis. Most importantly, the C<score()> attribute contains the NN probability of this being a true signal peptide. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted va the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR # Please direct questions and support issues to I<bioperl-l@bioperl.org> Based on the EnsEMBL module Bio::EnsEMBL::Pipeline::Runnable::Protein::Signalp originally written by Marc Sohrmann (ms2_AT_sanger.ac.uk). Written in BioPipe by Balamurugan Kumarasamy savikalpa_AT_fugu-sg.org. Cared for by the Fugu Informatics team (fuguteam_AT_fugu-sg.org) =head1 CONTRIBUTORS Torsten Seemann - torsten.seemann AT infotech.monash.edu.au =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Signalp; use strict; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Signalp->new(); Function: Builds a new Bio::Tools::Signalp object Returns : Bio::Tools::Signalp Args : -fh/-file => $val, # for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $signalp->next_result Function: Get the next result set from parser data Returns : Bio::SeqFeature::Generic Args : none =cut sub next_result { my ($self) = @_; while (my $line=$self->_readline()) { chomp $line; if ($line=~/^\>(\S+)/) { $self->_seqname($1); } elsif ($line=~/max\.\s+Y\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { $self->_fact1($2); } elsif ($line=~/mean\s+S\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { my $fact2 = $2; if ($fact2 eq 'YES' and $self->_fact1 eq 'YES') { my $line = $self->_readline(); ########################################### # modification to suit new SignalP output ########################################### chomp $line; #print STDERR "********** <$line>\n"; if ($line =~ /\s+D\s+.*/) { $line = $self->_readline(); } #print STDERR "********** <$line>\n"; my $end; ########################################### if ($line =~ /Most likely cleavage site between pos\.\s+(\d+)/) { my $end = $1; my (%feature); $feature{seq_id} = $self->_seqname; $feature{start} = 1; $feature{end} = $end; $feature{source_tag} = 'Signalp'; $feature{primary}= 'signal_peptide'; $self->_parse_hmm_result(\%feature); my $new_feat = $self->_create_feature (\%feature); return $new_feat; } else { $self->throw ("parsing problem in signalp"); } } } } } =head2 _parse_hmm_result Title : _parse_hmm_result Usage : $self->_parse_hmm_result(\%feature) Function: Internal (not to be used directly) Returns : hash of feature values Args : hash of more feature values =cut sub _parse_hmm_result { my ($self, $feature_hash) = @_; while(my $line = $self->_readline){ chomp $line; if($line =~ /Prediction: (.+)$/){ $feature_hash->{hmmProdiction} = $1; }elsif($line =~ /Signal peptide probability: ([0-9\.]+)/){ $feature_hash->{peptideProb} = $1; }elsif($line =~ /Signal anchor probability: ([0-9\.]+)/){ $feature_hash->{anchorProb} = $1; last; } } } =head2 _create_feature Title : _create_feature Usage : $self->create_feature(\%feature) Function: Internal (not to be used directly) Returns : hash of feature values Args : hash of more feature values =cut sub _create_feature { my ($self, $feat) = @_; # create feature object my $feature = Bio::SeqFeature::Generic->new( -seq_id => $feat->{name}, -start => $feat->{start}, -end => $feat->{end}, -score => $feat->{score}, -source => $feat->{source}, -primary => $feat->{primary}, -logic_name => $feat->{logic_name}, ); $feature->score($feat->{peptideProb}); $feature->add_tag_value('peptideProb', $feat->{peptideProb}); $feature->add_tag_value('anchorProb', $feat->{anchorProb}); $feature->add_tag_value('evalue',$feat->{anchorProb}); $feature->add_tag_value('percent_id','NULL'); $feature->add_tag_value("hid",$feat->{primary}); $feature->add_tag_value('SignalpPrediction', $feat->{hmmProdiction}); return $feature; } =head2 _seqname Title : _seqname Usage : $self->_seqname($name) Function: Internal (not to be used directly) Returns : Args : =cut sub _seqname{ my ($self,$seqname)=@_; if (defined$seqname){ $self->{'seqname'}=$seqname; } return $self->{'seqname'}; } =head2 _fact1 Title : _fact1 Usage : $self->fact1($fact1) Function: Internal (not to be used directly) Returns : Args : =cut sub _fact1{ my ($self, $fact1)=@_; if (defined $fact1){ $self->{'fact1'}=$fact1; } return $self->{'fact1'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SiRNA.pm������������������������������������������������������������������000444��000765��000024�� 37765�12254227324� 16564� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::SiRNA # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Bristol-Myers Squibb # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME SiRNA - Perl object for designing small inhibitory RNAs. =head1 SYNOPSIS use Bio::Tools::SiRNA; my $sirna_designer = Bio::Tools::SiRNA->new( -target => $bio_seq, -rules => 'saigo' ); my @pairs = $sirna_designer->design; foreach $pair (@pairs) { my $sense_oligo_sequence = $pair->sense->seq; my $antisense_oligo_sequence = $pair->antisense->seq; # print out results print join ("\t", $pair->start, $pair->end, $pair->rank, $sense_oligo_sequence, $antisense_oligo_sequence), "\n"; } =head1 DESCRIPTION Package for designing siRNA reagents. Input is a L<Bio::SeqI>-compliant object (the target). Output is a list of Bio::SeqFeature::SiRNA::Pair objects, which are added to the feature table of the target sequence. Each Bio::SeqFeature::SiRNA::Pair contains two subfeatures (Bio::SeqFeature::Oligo objects) which correspond to the individual oligos. These objects provide accessors for the information on the individual reagent pairs. This verion of Bio::Tools::SiRNA represents a major change in architecture. Specific 'rulesets' for siRNA selection as developed by various groups are implemented as Bio::Tools::SiRNA::Ruleset objects, which inherit from Bio::Tools::SiRNA. This will make it easier to add new rule sets or modify existing approaches. Currently the Tuschl and Ui-Tei (2004) rules are implemented. For consistency, the Tuschl rules are implemented by default. In addition, this module provides three 'extra' rules which can be added above and beyond any ruleset. =over 3 =item 1. SiRNAs that overlap known SNPs (identified as SeqFeatures with primary tag = variation) can be avoided. =item 2. Other regions (with primary tag = 'Excluded') can also be skipped. I use this with Bio::Tools::Run::Mdust to avoid low-complexity regions (must be run separately), but other programs could also be used. =item 3. SiRNAs may also be selected in the 3 prime UTR of a gene by setting $sirna_designer-E<gt>include_3pr() to true. =back =head2 EXPORT None. =head1 SEE ALSO L<Bio::Tools::Run::Mdust>, L<Bio::SeqFeature::SiRNA::Pair>, L<Bio::SeqFeature::SiRNA::Oligo>.. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Donald Jackson (donald.jackson@bms.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::SiRNA; use strict; use warnings; use vars qw($AUTOLOAD); use Bio::Seq::RichSeq; use Bio::SeqFeature::Generic; use Bio::SeqFeature::SiRNA::Oligo; use Bio::SeqFeature::SiRNA::Pair; use base qw(Bio::Root::Root); our %COMP = ( A => 'T', T => 'A', C => 'G', G => 'C', N => 'N', ); our @ARGNAMES = qw(RULES START_PAD END_PAD MIN_GC CUTOFF OLIGOS AVOID_SNPS GSTRING TMPDIR TARGET DEBUG); =head2 new Title : new Usage : my $sirna_designer = Bio::Tools::SiRNA->new(); Function : Constructor for designer object Returns : Bio::Tools::SiRNA object Args : target - the target sequence for the SiRNAs as a Bio::Seq::RichSeq start_pad - distance from the CDS start to skip (default 75) end_pad - distance from the CDS end to skip (default 50) include_3pr - set to true to include SiRNAs in the 3prime UTR (default false) rules - rules for selecting siRNAs, currently supporting saigo and tuschl min_gc - minimum GC fraction (NOT percent) (default 0.4) max_gc - maximum GC fraction (NOT percent) (default 0.6) cutoff - worst 'rank' accepted(default 3) avoid_snps - boolean - reject oligos that overlap a variation SeqFeature in the target (default true) gstring - maximum allowed consecutive Gs. Too many can cause problems in synthesis (default 4) Note : All arguments can also be changed/accessed using autoloaded methods such as: my $start_pad = $sirna_designer->start_pad(). =cut sub new { my ($proto, @args) = @_; my $pkg = ref($proto) || $proto; my $self = {}; bless ($self, $pkg); my %args; @args{@ARGNAMES} = $self->_rearrange(\@ARGNAMES, @args); if ($args{'RULES'}) { $self->rules($args{'RULES'}); } $self->{'start_pad'} = $args{'START_PAD'} || 75; # nt from start to mask $self->{'end_pad'} = $args{'END_PAD'} || 50; # nt from end to mask $self->{'include_3pr'} = $args{'INCLUDE_3PR'} || 0; # look for oligos in 3prime UTR $self->{'min_gc'} = $args{'MIN_GC'} || 0.40; $self->{'max_gc'} = $args{'MAX_GC'} || 0.60; $self->{'cutoff'} = $args{'CUTOFF'} || 3; # highest (worst) rank wanted $self->{'oligos'} = []; defined($args{'AVOID_SNPS'}) ? $self->{'avoid_snps'} = $args{'AVOID_SNPS'} : $self->{'avoid_snps'} = 1; # (t/f to avoid or include reagents that cover SNPs) $self->{'gstring'} = $args{'GSTRING'} || 4; # maximum allowed consecutive Gs - too many can cause problems in oligo synthesis $self->{'tmpdir'} = $args{'TMPDIR'} || $ENV{'TMPDIR'} || $ENV{'TMP'} || ''; $self->{'debug'} = $args{'DEBUG'} || 0; $self->target($args{'TARGET'}) if ($args{'TARGET'}); return $self; } =head2 target Title : target Usage : my $target_seq = $sirna_designer->target(); # get the current target OR $sirna_designer->target($new_target_seq); # set a new target Function : Set/get the target as a Bio::SeqI-compliant object Returns : a Bio::SeqI-compliant object Args : a Bio::SeqI-compliant object (optional) =cut sub target { my ($self, $target) = @_; if ($target) { unless ($target->isa('Bio::SeqI')) { $self->throw( -class => 'Bio::Root::BadParameter', -text => "Target must be passed as a Bio::Seq object" ); } if ($target->can('molecule')) { ( grep { uc($target->molecule) eq $_ } qw(DNA MRNA CDNA)) or $self->throw( -class => 'Bio::Root::BadParameter', -text => "Sequences of type ". $target->molecule. " are not supported" ); } else { ($target->alphabet eq 'dna') or $self->throw( -class => 'Bio::Root::BadParameter', -text => "Sequences of alphabet ". $target->alphabet. " are not supported" ); } $self->{'target'} = $target; return 1; } elsif ($self->{'target'}) { return $self->{'target'}; } else { $self->throw("Target sequence not defined"); } } =head2 rules Title : rules Usage : $sirna->rules('ruleset') Purpose : set/get ruleset to use for selecting SiRNA oligo pairs. Returns : not sure yet Args : a ruleset name (currently supported: Tuschl, Saigo) or a Bio::Tools::SiRNA::RulesetI compliant object =cut sub rules { my ($self, $rules) = @_; if ($rules) { $self->_load_ruleset($rules); } # default: use tuschl rules unless ($self->{_rules}) { $self->_load_ruleset('tuschl'); } return $self->{_rules}; } sub _load_ruleset { my ($self, $ruleset) = @_; my $rule_module = join('::', ref($self), 'Ruleset', lc($ruleset)); eval "require $rule_module"; if ($@) { #warn join("\n", '@INC contains:', @INC, undef); $self->throw("Unable to load $rule_module: $@"); return; } else { $self->{_rules} = $rule_module; bless($self, $rule_module); # recast as subclass } return 1; } =head2 design Title : design Usage : my @pairs = $sirna_designer->design(); Purpose : Design SiRNA oligo pairs. Returns : A list of SiRNA pairs as Bio::SeqFeature::SiRNA::Pair objects Args : none =cut sub design { my ($self) = @_; ($self->rules) or $self->throw('Unable to design siRNAs: no rule set specified'); # unless ( grep { $_->primary_tag eq 'Target' } $self->target->top_SeqFeatures ) { # $self->_define_target(); # } my @oligos = $self->_get_oligos(); return ( grep { $_->isa('Bio::SeqFeature::SiRNA::Pair') } $self->target->top_SeqFeatures ); } sub _define_target { my ($self) = @_; my ($feat, $cds, $left, $right); my $target = $self->target or $self->throw("Unable to design oligos - no target provided"); ($cds) = grep { $_->primary_tag eq 'CDS' } $target->top_SeqFeatures if ($target->can('top_SeqFeatures')); if ($cds) { $left = $cds->start + $self->start_pad; if (!$self->include_3pr) { $right = $cds->end - $self->end_pad; } else { $right = $target->length - $self->end_pad; } } else { $left = 0 + $self->start_pad; $right = $target->length - $self->end_pad; } # is there anything left? if (($right - $left) < 20) { $self->throw("There isn't enough sequence to design oligos. Please reduce start_pad and end_pad or supply more sequence"); } # define target region my $targregion = Bio::SeqFeature::Generic->new( -start => $left, -end => $right, -primary => 'Target' ); $self->target->add_SeqFeature($targregion); # locate excluded regions my @excluded = grep { $_->primary_tag eq 'Excluded' } $self->target->top_SeqFeatures; if ($self->avoid_snps) { my @snps = grep { $_->primary_tag eq 'variation' } $self->target->top_SeqFeatures; push(@excluded, @snps); } $self->excluded(\@excluded); return $targregion; } sub _get_targetregion { my ($self) = @_; my ($targregion) = grep { $_->primary_tag eq 'Target' } $self->target->top_SeqFeatures; $targregion ||= $self->_define_target; $self->throw("Target region for SiRNA design not defined") unless ($targregion); my $seq = $targregion->seq->seq; # but this way I loose start info my $targstart = $targregion->start; return ($seq, $targstart); } # MOVE to SiRNA::Ruleset::tuschl # sub _regex { # my ($self, $rank) = @_; # return $PATTERNS{$rank}; # } # sub _get_oligos { # # use regular expressions to pull out oligos # my ($self, $rank) = @_; # my $regex = $self->_regex($rank); # my @exclude; # my ($targregion) = grep { $_->primary_tag eq 'Target' } $self->target->top_SeqFeatures; # my $seq = $targregion->seq->seq; # # but this way I loose start info # my $targstart = $targregion->start; # # exclude masked region # push(@exclude, grep { $_->primary_tag eq 'Excluded' } $self->target->top_SeqFeatures); # # add SNP checking # if ($self->avoid_snps) { # my @snps = grep { $_->primary_tag eq 'variation' } $self->target->top_SeqFeatures; # push(@exclude, @snps); # } # while ( $seq =~ /$regex/gi ) { # my $target = $1; # # check for too many Gs (or Cs on the other strand) # next if ( $target =~ /G{ $self->gstring,}/io ); # next if ( $target =~ /C{ $self->gstring,}/io ); # # skip Ns (for filtering) # next if ( $target =~ /N/i); # my $start = length($`) + $targstart; # my $stop = $start + length($target) -1; # my @gc = ( $target =~ /G|C/gi); # my $fxGC = sprintf("%2.2f", (scalar(@gc) / length($target))); # next if ($fxGC < $self->min_gc); # next if ($fxGC > $self->max_gc); # my $sense = Bio::SeqFeature::SiRNA::Oligo->new( -start => $start, # -end => $stop, # -strand => 1, # -seq => _get_sense($target), # -source_tag => ref($self), # ); # my $asense = Bio::SeqFeature::SiRNA::Oligo->new( -start => $start, # -end => $stop, # -strand => -1, # -seq => _get_anti($target), # -source_tag => ref($self), # ); # my $sirna = Bio::SeqFeature::SiRNA::Pair->new( -rank => $rank, # -fxGC => $fxGC, # -sense => $sense, # -antisense => $asense, # -source_tag => ref($self), # ); # unless ($self->_has_overlap($sirna, \@exclude)) { # $self->target->add_SeqFeature($sirna); # } # } # } =head2 add_oligos Title : add_oligos Usage : $sirna_designer->add_oligos($sequence, $start, $rank); Purpose : Add SiRNA olgos to target Bio::Seq as Bio::SeqFeature::SiRNA::Pair objects Args : Oligo sequence and start position (required), rank/score (optional) =cut sub add_oligos { my ($self, $seq, $start, $rank) = @_; ($seq) or throw ('No sequence supplied for add_oligos'); (defined $start) or throw ('No start position specified for add_oligos'); my ($end) = $start + length($seq); my ($sseq) = $self->_get_sense($seq); my $sense = Bio::SeqFeature::SiRNA::Oligo->new( -start => $start, -end => ($start + length($sseq)), -strand => 1, -seq => $sseq, -source_tag => ref($self), ); my $aseq = $self->_get_anti($seq); my $asense = Bio::SeqFeature::SiRNA::Oligo->new( -start => $end, -end => ($end - length($aseq)), -strand => -1, -seq => $aseq, -source_tag => ref($self), ); my $sirna = Bio::SeqFeature::SiRNA::Pair->new( -rank => $rank, # -fxGC => $fxGC, -sense => $sense, -antisense => $asense, -source_tag => ref($self), ); unless ($self->_has_overlap($sirna, $self->excluded)) { $self->target->add_SeqFeature($sirna); } } sub _has_overlap { # flag any pairs that overlap an UNDESIRED feature (eg SNP) # return true if there is overlap, false if not my ($self, $test, $flist) = @_; print STDERR "Checking oligo at ", $test->start, " to ",$test->end, "\n" if ($self->debug); foreach my $feat (@$flist) { if (($test->start <= $feat->end) and ($test->end >= $feat->start)) { print STDERR "Overlaps ", $feat->primary_tag, " at ", $feat->start, " to ", $feat->end, "\n" if ($self->debug); return 1; } } return 0; # default - no overlap } # MOVE to SiRNA::Ruleset::tuschl # sub _get_sense { # my ($target) = @_; # # trim off 1st 2 nt to get overhang # $target =~ s/^..//; # # convert T's to U's (transcribe) # $target =~ s/T/U/gi; # # force last 2 nt to be T's # $target =~ s/..$/TT/; # return $target; # } # sub _get_anti { # my ($target) = @_; # my @target = split(//, $target); # my ($nt,@antitarget); # while ($nt = pop @target) { # push(@antitarget, $COMP{$nt}); # } # my $anti = join('', @antitarget); # # trim off 1st 2 nt to get overhang # $anti =~ s/^..//; # # convert T's to U's # $anti =~ s/T/U/gi; # # convert last 2 NT's to T # $anti =~ s/..$/TT/; # return $anti; # } sub AUTOLOAD { my ($self, $value) = @_; my $name = $AUTOLOAD; $name =~ s/.+:://; return if ($name eq 'DESTROY'); if (defined $value) { $self->{$name} = $value; } unless (exists $self->{$name}) { $self->throw("Attribute $name not defined for ". ref($self)); } return $self->{$name}; } sub _comp { my ($self, $char) = @_; return unless ($char); $char = uc($char); return $COMP{ $char }; } 1; �����������BioPerl-1.6.923/Bio/Tools/TandemRepeatsFinder.pm����������������������������������������������������000444��000765��000024�� 21775�12254227325� 21527� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� =head1 NAME Bio::Tools::TandemRepeatsFinder - a parser for Tandem Repeats Finder output =head1 SYNOPSIS use Bio::Tools::TandemRepeatsFinder; # create parser my $parser = Bio::Tools::Bio::Tools::TandemRepeatsFinder->new(-file => 'tandem_repeats.out'); # loop through results while( my $feature = $parser->next_result ) { # print the source sequence id, start, end, percent matches, and the consensus sequence my ($percent_matches) = $feat->get_tag_values('percent_matches'); my ($consensus_sequence) = $feat->get_tag_values('consensus_sequence'); print $feat->seq_id()."\t".$feat->start()."\t".$feat->end()."\t$percent_matches\t$consensus_sequence\n"; } =head1 DESCRIPTION A parser for Tandem Repeats Finder output. Written and tested for version 4.00 Location, seq_id, and score are stored in Bio::SeqFeature::Generic feature. All other data is stored in tags. The availabale tags are period_size copy_number consensus_size percent_matches percent_indels percent_a percent_c percent_g percent_t entropy consensus_sequence repeat_sequence run_parameters sequence_description The run_parameters are stored in a hashref with the following key: match_weight mismatch_weight indel_weight match_prob indel_prob min_score max_period_size =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Eric Just Email e-just@northwestern.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::TandemRepeatsFinder; use strict; use constant DEBUG => 0; use Bio::SeqFeature::Generic; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::TandemRepeatsFinder->new(); Function: Builds a new Bio::Tools::TandemRepeatsFinder object Returns : Bio::Tools::TandemRepeatsFinder Args : -fh/-file => $val, for initing input, see Bio::Root::IO =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 version Title : version Usage : $self->version( $version ) Function: get/set the version of Tandem Repeats finder that was used in analysis Returns : value of version of Args : new value (optional) =cut sub version { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'version'} = $value; } return $self->{'version'}; } =head2 _current_seq_id Title : _current_seq_id Usage : $self->_current_seq_id( $current_seq_id ) Function: get/set the _current_seq_id Returns : value of _current_seq_id Args : new value (optional) =cut sub _current_seq_id { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_current_seq_id'} = $value; } return $self->{'_current_seq_id'}; } =head2 _current_seq_description Title : _current_seq_description Usage : $self->_current_seq_description( $current_seq_id ) Function: get/set the _current_seq_description Returns : value of _current_seq_description Args : new value (optional) =cut sub _current_seq_description { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_current_seq_description'} = $value; } return $self->{'_current_seq_description'}; } =head2 _current_parameters Title : _current_parameters Usage : $self->_current_parameters( $parameters_hashref ) Function: get/set the _current_parameters Returns : hashref representing current parameters parsed from results file : keys are match_weight mismatch_weight indel_weight match_prob indel_prob min_score max_period_size Args : parameters hashref (optional) =cut sub _current_parameters { my ( $self, $value ) = @_; if ( defined $value ) { $self->{'_current_parameters'} = $value; } return $self->{'_current_parameters'}; } =head2 next_result Title : next_result Usage : my $r = $trf->next_result() Function: Get the next result set from parser data Returns : Bio::SeqFeature::Generic Args : none =cut sub next_result { my ($self) = @_; while ( defined( $_ = $self->_readline() ) ) { # Parse Version line if (/^Version (.+)/) { my $version = $1; $self->warn("parsed version: $version\n") if DEBUG; $self->warn( qq{ Bio::Tools::TandemRepeatsFinder was written and tested for Tandem Repeats Masker Version 4.00 output You appear to be using Verion $version. Use at your own risk.}) if ($version != 4); $self->version($version); } # Parse Sequence identifier # i.e. Sequence: DDB0215018 |Masked Chromosomal Sequence| Chr 2f elsif ( /^Sequence: ([^\s]+)\s(.+)?/ ) { my $seq_id = $1; my $seq_description = $2; $self->warn("parsed sequence_id: $seq_id\n") if DEBUG; $self->_current_seq_id($seq_id); $self->_current_seq_description($seq_description); } # Parse Parameters # i.e. Parameters: 2 7 7 80 10 50 12 elsif (/^Parameters: (.+)/) { my $params = $1; $self->warn("parsed parameters: $params\n") if DEBUG; my @param_array = split /\s/, $params; my $param_hash = { match_weight => $param_array[0], mismatch_weight => $param_array[1], indel_weight => $param_array[2], match_prob => $param_array[3], indel_prob => $param_array[4], min_score => $param_array[5], max_period_size => $param_array[6] }; $self->_current_parameters($param_hash); } # Parse Data # i.e. 13936 13960 12 2.1 12 100 0 50 16 8 52 24 1.70 T TTTTTTTTTT elsif (/^\d+\s\d+\s\d+/) { # call internal method to create Bio::SeqFeature::Generic # to represent tandem repeat return $self->_create_feature($_); } elsif (DEBUG) { $self->warn( "UNPARSED LINE:\n" . $_ ); } } return; } =head2 _create_feature Title : _create_feature Usage : internal method used by 'next_feature' Function: Takes a line from the results file and creates a bioperl object Returns : Bio::SeqFeature::Generic Args : none =cut sub _create_feature { my ( $self, $line ) = @_; # split the line and store into named variables my @element = split /\s/, $line; my ( $start, $end, $period_size, $copy_number, $consensus_size, $percent_matches, $percent_indels, $score, $percent_a, $percent_c, $percent_g, $percent_t, $entropy, $consensus_sequence, $repeat_sequence ) = @element; # create tag hash from data in line my $tags = { period_size => $period_size, copy_number => $copy_number, consensus_size => $consensus_size, percent_matches => $percent_matches, percent_indels => $percent_indels, percent_a => $percent_a, percent_c => $percent_c, percent_g => $percent_g, percent_t => $percent_t, entropy => $entropy, consensus_sequence => $consensus_sequence, repeat_sequence => $repeat_sequence, run_parameters => $self->_current_parameters(), sequence_description => $self->_current_seq_description() }; # create feature from start/end etc my $feat = Bio::SeqFeature::Generic->new( -seq_id => $self->_current_seq_id(), -score => $score, -start => $start, -end => $end, -source_tag => 'Tandem Repeats Finder', -primary_tag => 'tandem repeat', -tag => $tags ); return $feat; } 1; ���BioPerl-1.6.923/Bio/Tools/TargetP.pm����������������������������������������������������������������000444��000765��000024�� 27630�12254227322� 17202� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # Bioperl module for TargetP # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Emmanuel Quevillon <emmanuel.quevillon@versailles.inra.fr> # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Tools::TargetP - Results of one TargetP run =head1 SYNOPSIS use Bio::Tools::TargetP; #filename for TargetP result : $targetp = Bio::Tools::TargetP->new(-file => 'targetp.out'); # filehandle for TargetP : $targetp = Bio::Tools::TargetP->new( -fh => \*INPUT ); ### targetp v1.1 prediction results ################################## #Number of query sequences: 11 #Cleavage site predictions included. #Using NON-PLANT networks. # #Name Len mTP SP other Loc RC TPlen #---------------------------------------------------------------------- #swall|Q9LIP3|C72Y_AR 500 0.245 0.935 0.009 S 2 22 #swall|Q52813|AAPQ_RH 400 0.170 0.462 0.577 _ 5 - #swall|O86459|AAT_RHI 400 0.346 0.046 0.660 _ 4 - # parse the results while($feature = $targetp->next_prediction()) { #$feature is a Bio::SeqFeature::Generic object my $method = $targetp->analysis_method(); my $vesion = $targetp->analysis_method_version() || $feature->source(); my $seqid = $feature->seq_id(); # ... } # essential if you gave a filename at initialization (otherwise the file # will stay open) $targetp->close(); =head1 DESCRIPTION TargetP modules will provides parsed information about protein localization. It reads in a targetp output file. It parses the results, and returns a Bio::SeqFeature::Generic object for each seqeunces found to have a subcellular localization =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS - Emmanuel Quevillon Email emmanuel.quevillon@versailles.inra.fr Describe contact details here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::TargetP; use strict; use Bio::Tools::AnalysisResult; use Bio::SeqFeature::Generic; use Data::Dumper; use base qw(Bio::Tools::AnalysisResult); #Definition of 'Loc' field according to http://www.cbs.dtu.dk/services/TargetP/output.php my $MAPLOC = { 'S' => 'Secretory pathway', 'M' => 'Mitochondrion', 'C' => 'Chloroplast', '_' => 'Any other', '*' => 'Unknown', '?' => 'Unknown', }; =head1 analysis_method Usage : $self->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches Returns : String Argument : n/a =cut sub analysis_method { my ($self, $method) = @_; if($method && ($method !~ /TargetP/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head1 network Title : network Usage : $self->network($network) Function: This method Get/Set the network used for the analysis (PLANT or NON-PLANT) Example : Returns : string Arguments: On set, the network used =cut sub network { my($self, $net) = @_; if(defined($net)){ $self->{'_network'} = $net; } return $self->{'_network'}; } =head1 cleavage Title : cleavage Usage : $self->cleavage($cleavage) Function : This method Get/Set if SignalP program was used to run TargetP Example : Returns : 1 or 0 Arguments: On set, the cleavage used or not =cut sub cleavage { my($self, $cleavage) = @_; if(defined($cleavage)){ $self->{'_cleavage'} = $cleavage =~ /not included/ ? '0' : '1'; } return $self->{'_cleavage'}; } =head1 next_prediction Usage : $targetp->next_prediction() Purpose : Returns the next TargetP prediction Returns : A Bio::SeqFeature::Generic object Arguments: n/a =cut sub next_prediction { my($self) = @_; unless($self->_parsed()){ $self->_parse_results(); $self->_parsed(1); } return shift @{$self->{'_features'}} || undef; } =head1 create_feature Title : create_feature Usage : $self->create_feature(\%hash); Function : This method creates a new Bio::SeqFeature::Generic object Example : Returns : Bio::SeqFeature::Generic Arguments : hash reference =cut sub create_feature { my($self, $feat) = @_; $self->throw("Need a reference to hash table") unless($feat && ref($feat) eq 'HASH'); my $feature = Bio::SeqFeature::Generic->new( -seq_id => $feat->{seqid}, -source_tag => $self->analysis_method(), -primary_tag => 'signal_peptide', #Sequence Ontology compliant -strand => '+', ); if(defined($feat->{seqlen})){ $feature->start(1); $feature->end($feat->{seqlen}); } $feature->add_tag_value('location', $MAPLOC->{$feat->{loc}}) if(exists($MAPLOC->{$feat->{loc}})); $feature->add_tag_value('chloroplastCutOff', $feat->{cTP}) if(defined($feat->{cTP})); $feature->add_tag_value('mitochondrionCutOff', $feat->{mTP}) if(defined($feat->{mTP})); $feature->add_tag_value('signalPeptideCutOff', $feat->{SP}) if(defined($feat->{SP})); $feature->add_tag_value('otherCutOff', $feat->{other}) if(defined($feat->{other})); $feature->add_tag_value('reliabilityClass', $feat->{RC}) if(defined($feat->{RC})); $feature->add_tag_value('signalPeptideLength', $feat->{TPLen}) if(defined($feat->{TPLen})); $feature->add_tag_value('network', $self->network()); return $feature; } =head2 PRIVATE METHODS =cut =head2 _initialize_state Title : _initialize_state Usage : n/a; usually called by _initialize() itself called by new() Function: This method is supposed to reset the state such that any 'history' is lost. State information that does not change during object lifetime is not considered as history, e.g. parent, name, etc shall not be reset. An inheriting object should only be concerned with state information it introduces itself, and for everything else call SUPER::_initialize_state(@args). The argument syntax is the same as for new() and _initialize(), i.e., named parameters following the -name=>$value convention. The following parameters are dealt with by the implementation provided here: -INPUT, -FH, -FILE (tags are case-insensitive). Example : Returns : Args : =cut sub _initialize_state { my ($self,@args,) = @_; # first call the inherited method! $self->SUPER::_initialize_state(@args); # our private state variables $self->{'_features'} = [ ]; $self->{'_parameters'} = undef; $self->{'_format'} = undef; $self->{'_network'} = undef; $self->{'_cleavage'} = undef; $self->{'_parsed'} = 0; $self->analysis_method('TargetP'); return 1; } =head2 _predictions Usage : $targetp->_prediction() Purpose : Returns the number of TargetP predictions Returns : A scalar (number) Arguments: n/a =cut sub _predictions { my($self) = @_; return scalar(@{$self->{'_features'}}) || 0; } =head2 _parsed Title : _parsed Usage : $targetp->_parsed(1) Function : This method is used to know if the output result is parsed or not For internal use only Example : Returns : 1/0 Arguments : 1/0 for setting =cut sub _parsed { my($self, $value) = @_; if(defined($value)){ $self->{'_parsed'} = $value; } return $self->{'_parsed'}; } =head2 _parse_results Title : _parse_results Usage : $self->_parse_results() Function : This method parses a TargetP output For internal use only Example : Returns : n/a Arguments: none =cut sub _parse_results { my($self) = @_; ### targetp v1.1 prediction results ################################## #Number of query sequences: 11 #Cleavage site predictions included. #Using NON-PLANT networks. # #Name Len mTP SP other Loc RC TPlen #---------------------------------------------------------------------- #swall|Q9LIP3|C72Y_AR 500 0.245 0.935 0.009 S 2 22 #swall|Q52813|AAPQ_RH 400 0.170 0.462 0.577 _ 5 - #swall|O86459|AAT_RHI 400 0.346 0.046 0.660 _ 4 - while(defined(my $line = $self->_readline())){ if($line =~ /targetp (v[\d\.]+)/){ $self->analysis_method_version($1); }elsif($line =~ /Cleavage site predictions (.*)/){ $self->cleavage($1); }elsif($line =~ /Using (\S+) networks/){ $self->network($1); }elsif($line =~ /^Name/){ #We skip the next line which is '------------------' $self->_readline(); my $hash = { }; while(defined(my $line = $self->_readline())){ last if($line =~ /^----/); my $hash = $self->_parse_line($line); my $new_feature = $self->create_feature($hash); $self->_add_feature($new_feature); } } } return; } =head2 _parse_line Title : _parse_line Usage : $self->_parse_line($line) Function : This method parses the line result For internal use only Example : Returns : Hash reference Arguemnts: line to parse =cut sub _parse_line { my($self, $line) = @_; $self->throw("No line to parse given") unless($line); my $hash = { }; my ($seqid, $seqlen, $cTP, $mTP, $SP, $other, $loc, $RC, $TPlen); if($self->network() eq 'NON-PLANT'){ ($seqid, $seqlen, $mTP, $SP, $other, $loc, $RC, $TPlen) = split(/\s+/, $line); }else{ ($seqid, $seqlen, $cTP, $mTP, $SP, $other, $loc, $RC, $TPlen) = split(/\s+/, $line); } $hash->{seqid} = $seqid; $hash->{seqlen} = $seqlen; $hash->{cTP} = $cTP || undef; $hash->{mTP} = $mTP; $hash->{SP} = $SP; $hash->{other} = $other; $hash->{loc} = $loc; $hash->{RC} = $RC; $hash->{TPLen} = ($TPlen && $TPlen =~ /\d+/) ? $TPlen : undef; return $hash; } =head2 _add_feature Title : _add_feature Usage : $self->_add_feature($feature) Function : This method stores a feature object For internal use only Example : Returns : n/a Arguments: Bio::SeqFeature::Generic =cut sub _add_feature { my($self, $feature) = @_; $self->throw("Need a Bio::SeqFeature::Generic object") unless $feature->isa("Bio::SeqFeature::Generic"); push(@{$self->{'_features'}}, $feature); return; } =head2 _toString_location Title : _toString_location Usage : $self->_toString_location($key) Function : This method convert the 'one letter code' location to the corresponding definition For internal use only Example : Returns : Location or undef Arguments: String =cut sub _toString_location { my($self, $key) = @_; if($key && exists($MAPLOC->{$key})){ return $MAPLOC->{$key}; } return; } 1; ��������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Tmhmm.pm������������������������������������������������������������������000555��000765��000024�� 6615�12254227330� 16700� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Tmhmm # # Original copyright Balamurugan Kumarasamy # Re-written cleanly by Torsten Seemann, Sep 2006 # # Copyright: # You may distribute this module under the same terms as Perl itself =head1 NAME Bio::Tools::Tmhmm - parse TMHMM output (TransMembrane HMM) =head1 SYNOPSIS use Bio::Tools::Tmhmm; my $parser = Bio::Tools::Tmhmm->new(-fh => $filehandle ); while ( my $tmhmm_feat = $parser->next_result ) { # do something, e.g. push @tmhmm_feat, $tmhmm_feat; } =head1 DESCRIPTION TMHMM is software for the prediction of transmembrane helices in proteins. See L<http://www.cbs.dtu.dk/services/TMHMM/> for more details. This module parses the "long output" format of TMHMM 2.0 and creates a Bio:SeqFeature::Generic object for each C<TMHelix> feature found from lines like this: my_sequence_id TMHMM2.0 TMhelix 54 76 =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Torsten Seemann Email torsten.seemann AT infotech.monash.edu.au =head1 CONTRIBUTOR - Bala Email savikalpa@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Tmhmm; use strict; use Bio::Tools::AnalysisResult; use Bio::Root::Root; use Bio::Root::IO; use base qw(Bio::Root::Root Bio::Root::IO Bio::Tools::AnalysisResult); use Bio::SeqFeature::Generic; =head2 new Title : new Usage : my $obj = Bio::Tools::Tmhmm->new(); Function: Builds a new Bio::Tools::Tmhmm object Returns : Bio::Tools::Tmhmm Args : Either of the following as per L<Bio::Root::IO> interface -fh => $filehandle -file => $filename =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $feat = $Tmhmm->next_result Function: Get the next result set from parser data Returns : Bio::SeqFeature::Generic Args : none =cut sub next_result { my $self = shift; # # my_sequence_id Length: 178 # my_sequence_id TMHMM2.0 outside 1 53 # my_sequence_id TMHMM2.0 TMhelix 54 76 # my_sequence_id TMHMM2.0 inside 77 115 while (my $line = $self->_readline) { if ( $line =~ m/^(\S+)\s+(\S+)\s+(TMhelix)\s+(\d+)\s+(\d+)$/i ) { return Bio::SeqFeature::Generic->new( -primary => 'transmembrane', -seq_id => $1, -source => $2, -start => $4, -end => $5, ); } } } 1; �������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/tRNAscanSE.pm�������������������������������������������������������������000444��000765��000024�� 20251�12254227314� 17526� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::tRNAscanSE # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::tRNAscanSE - A parser for tRNAscan-SE output =head1 SYNOPSIS use Bio::Tools::tRNAscanSE; my $parser = Bio::Tools::tRNAscanSE->new(-file => 'result.tRNAscanSE'); # parse the results while( my $gene = $parser->next_prediction ) { @exon_arr = $gene->get_SeqFeatures(); } =head1 DESCRIPTION This script will parse tRNAscan-SE output. Just the tabular output of the tRNA locations in the genome for now. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::tRNAscanSE; use strict; use Bio::SeqFeature::Generic; use base qw(Bio::Tools::AnalysisResult); use vars qw($GeneTag $SrcTag $ExonTag); ($GeneTag,$SrcTag,$ExonTag) = qw(gene tRNAscan-SE exon); =head2 new Title : new Usage : my $obj = Bio::Tools::tRNAscanSE->new(); Function: Builds a new Bio::Tools::tRNAscanSE object Returns : an instance of Bio::Tools::tRNAscanSE Args : -fh/-file for input filename -genetag => primary tag used in gene features (default 'tRNA_gene') -exontag => primary tag used in exon features (default 'tRNA_exon') -srctag => source tag used in all features (default 'tRNAscan-SE') =cut sub _initialize { my($self,@args) = @_; $self->SUPER::_initialize(@args); my ($genetag,$exontag,$srctag) = $self->SUPER::_rearrange([qw(GENETAG SRCTAG EXONTAG)], @args); $self->gene_tag(defined $genetag ? $genetag : $GeneTag); $self->source_tag(defined $srctag ? $srctag : $SrcTag); $self->exon_tag(defined $exontag ? $exontag : $ExonTag); $self->{'_seen'} = {}; } =head2 gene_tag Title : gene_tag Usage : $obj->gene_tag($newval) Function: Get/Set the value used for the 'gene_tag' of genes Default is 'tRNA_gene' as set by the global $GeneTag Returns : value of gene_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub gene_tag{ my $self = shift; return $self->{'gene_tag'} = shift if @_; return $self->{'gene_tag'}; } =head2 source_tag Title : source_tag Usage : $obj->source_tag($newval) Function: Get/Set the value used for the 'source_tag' of exons and genes Default is 'tRNAscan-SE' as set by the global $SrcTag Returns : value of source_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source_tag{ my $self = shift; return $self->{'_source_tag'} = shift if @_; return $self->{'_source_tag'}; } =head2 exon_tag Title : exon_tag Usage : $obj->exon_tag($newval) Function: Get/Set the value used for the 'primary_tag' of exons Default is 'tRNA_exon' as set by the global $ExonTag Returns : value of exon_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub exon_tag{ my $self = shift; return $self->{'_exon_tag'} = shift if @_; return $self->{'_exon_tag'}; } =head2 analysis_method Usage : $genscan->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /tRNAscan-SE/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /tRNAscan-SE/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 next_feature Title : next_feature Usage : while($gene = $genscan->next_feature()) { # do something } Function: Returns the next gene structure prediction of the Genscan result file. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_prediction() at present. Example : Returns : A Bio::SeqFeature::Generic object. Args : See also : L<Bio::SeqFeature::Generic> =cut sub next_feature { my ($self,@args) = @_; # even though next_prediction doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_prediction(@args); } =head2 next_prediction Title : next_prediction Usage : while($gene = $genscan->next_prediction()) { # do something } Function: Returns the next gene structure prediction of the Genscan result file. Call this method repeatedly until FALSE is returned. Example : Returns : A Bio::SeqFeature::Generic object. Args : See also : L<Bio::SeqFeature::Generic> =cut sub next_prediction { my ($self) = @_; my ($genetag,$srctag,$exontag) = ( $self->gene_tag, $self->source_tag, $self->exon_tag); while( defined($_ = $self->_readline) ) { if( m/^(\S+)\s+ # sequence name (\d+)\s+ # tRNA # (\d+)\s+(\d+)\s+ # tRNA start,end (\w{3})\s+ # tRNA type ([CAGT]{3})\s+ # Codon (\d+)\s+(\d+)\s+ # Intron Begin End (\d+\.\d+)/ox # Cove Score ) { my ($seqid,$tRNAnum,$start,$end,$type, $codon,$intron_start,$intron_end, $score) = ($1,$2,$3,$4,$5,$6,$7,$8,$9); my $strand = 1; if( $start > $end ) { ($start,$end,$strand) = ($end,$start,-1); } if( $self->{'_seen'}->{$type}++ ) { $type .= "-".$self->{'_seen'}->{$type}; } my $gene = Bio::SeqFeature::Generic->new ( -seq_id => $seqid, -start => $start, -end => $end, -strand => $strand, -score => $score, -primary_tag => $genetag, -source_tag => $srctag, -tag => { 'ID' => "tRNA:$type", 'Name' => "tRNA:$type", 'AminoAcid' => $type, 'Codon' => $codon, }); if( $intron_start ) { if( $intron_start > $intron_end ) { ($intron_start,$intron_end) = ($intron_end,$intron_start); } $gene->add_SeqFeature(Bio::SeqFeature::Generic->new ( -seq_id=> $seqid, -start => $start, -end => $intron_start-1, -strand=> $strand, -primary_tag => $exontag, -source_tag => $srctag, -tag => { 'Parent' => "tRNA:$type", })); $gene->add_SeqFeature(Bio::SeqFeature::Generic->new ( -seq_id=> $seqid, -start => $intron_end+1, -end => $end, -strand=> $strand, -primary_tag => $exontag, -source_tag => $srctag, -tag => { 'Parent' => "tRNA:$type" })); } else { $gene->add_SeqFeature(Bio::SeqFeature::Generic->new ( -seq_id=> $seqid, -start => $start, -end => $end, -strand=> $strand, -primary_tag => $exontag, -source_tag => $srctag, -tag => { 'Parent' => "tRNA:$type" })); } return $gene; } } } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Alignment�����������������������������������������������������������������000755��000765��000024�� 0�12254227332� 17030� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Alignment/Consed.pm�������������������������������������������������������000444��000765��000024�� 176060�12254227312� 21006� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Bio::Tools::Alignment::Consed # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Alignment::Consed - A module to work with objects from consed .ace files =head1 SYNOPSIS # a report for sequencing stuff my $o_consed = Bio::Tools::Alignment::Consed->new( -acefile => "/path/to/an/acefile.ace.1", -verbose => 1); my $foo = $o_consed->set_reverse_designator("r"); my $bar = $o_consed->set_forward_designator("f"); # get the contig numbers my @keys = $o_consed->get_contigs(); # construct the doublets my $setter_doublets = $o_consed->choose_doublets(); # get the doublets my @doublets = $o_consed->get_doublets(); =head1 DESCRIPTION L<Bio::Tools::Alignment::Consed> provides methods and objects to deal with the output from the Consed software suite. Specifically, takes an C<.ace> file and provides objects for the results. A word about doublets: This module was written to accommodate a large EST sequencing operation. In this case, EST's were sequenced from the 3' and from the 5' end of the EST. The objective was to find a consensus sequence for these two reads. Thus, a contig of two is what we wanted, and this contig should consist of the forward and reverse reads of a getn clone. For example, for a forward designator of "F" and a reverse designator of "R", if the two reads chad1F and chad1R were in a single contig (for example Contig 5) it will be determined that the consensus sequence for Contig 5 will be the sequence for clone chad1. Doublets are good! This module parses C<.ace> and related files. A detailed list of methods can be found at the end of this document. I wrote a detailed rationale for design that may explain the reasons why some things were done the way they were done. That document is beyond the scope of this pod and can probably be found in the directory from which this module was 'made' or at L<http://www.dieselwurks.com/bioinformatics/consedpm_documentation.pdf>. Note that the POD in that document might be old but the original rationale still stands. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email chad-at-dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' package Bio::Tools::Alignment::Consed; use strict; use FileHandle; use Dumpvalue qw(dumpValue); use Bio::Tools::Alignment::Trim; use File::Spec; use base qw(Bio::Root::Root Bio::Root::IO); our %DEFAULTS = ( 'f_designator' => 'f', 'r_designator' => 'r'); =head2 new() Title : new(-acefile => $path_to_some_acefile, -verbose => "1") Usage : $o_consed = Bio::Tools::Alignment::Consed-> new(-acefile => $path_to_some_acefile, -verbose => "1"); Function: Construct the Bio::Tools::Alignment::Consed object. Sets verbosity for the following procedures, if necessary: 1. Construct a new Bio::Tools::Alignment::Trim object, to handle quality trimming 2. Read in the acefile and parse it Returns : A reference to a Bio::Tools::Alignment::Consed object. Args : A hash. (-acefile) is the filename of an acefile. If a full path is not specified "./" is prepended to the filename and used from instantiation until destruction. If you want Bio::Tools::Alignment::Consed to be noisy during parsing of the acefile, specify some value for (-verbose). =cut sub new { my ($class,%args) = @_; my $self = $class->SUPER::new(%args); $self->{'filename'} = $args{'-acefile'}; # this is special to UNIX and should probably use catfile : DONE! # if (!($self->{'filename'} =~ m{/})) { # $self->{'filename'} = "./".$self->{'filename'}; # } # $self->{'filename'} =~ s#\\#\/#g if $^O =~ m/mswin/i; # $self->{'filename'} =~ m/(.*\/)(.*)ace.*$/; # $self->{'path'} = $1; # this is more generic and should work on most systems (undef, $self->{'path'}, undef) = File::Spec->splitpath($self->{'filename'}); $self->_initialize_io('-file'=>$self->{'filename'}); $self->{'o_trim'} = Bio::Tools::Alignment::Trim->new(-verbose => $self->verbose()); $self->set_forward_designator($DEFAULTS{'f_designator'}); $self->set_reverse_designator($DEFAULTS{'r_designator'}); $self->_read_file(); return $self; } =head2 set_verbose() Title : set_verbose() Usage : $o_consed->set_verbose(1); Function: Set the verbosity level for debugging messages. On instantiation of the Bio::Tools::Alignment::Consed object the verbosity level is set to 0 (quiet). Returns : 1 or 0. Args : The verbosity levels are: 0 - quiet 1 - noisy 2 - noisier 3 - annoyingly noisy This method for setting verbosity has largely been superseded by a sub-by-sub way, where for every sub you can provide a (-verbose) switch. I am doing converting this bit-by-bit so do not be surprised if some subs do not honour this. =cut # from RootI # backwards compat sub set_verbose { (shift)->verbose(@_) } =head2 get_filename() Title : get_filename() Usage : $o_consed->get_filename(); Function: Returns the name of the acefile being used by the Bio::Tools::Alignment::Consed object. Returns : A scalar containing the name of a file. Args : None. =cut sub get_filename { my $self = shift; return $self->{'filename'}; } =head2 count_sequences_with_grep() Title : count_sequences_with_grep() Usage : $o_consed->count_sequences_with_grep(); Function: Use /bin/grep to scan through the files in the ace project dir and count sequences in those files. I used this method in the development of this module to verify that I was getting all of the sequences. It works, but it is (I think) unix-like platform dependent. Returns : A scalar containing the number of sequences in the ace project directory. Args : None. If you are on a non-UNIX platform, you really do not have to use this. It is more of a debugging routine designed to address very specific problems. This method was reimplemented to be platform independent with a pure perl implementation. The above note can be ignored. =cut sub count_sequences_with_grep { my $self = shift; my ($working_dir,$grep_cli,@total_grep_sequences); # this should be migrated to a pure perl implementation ala # Tom Christiansen's 'tcgrep' # http://www.cpan.org/modules/by-authors/id/TOMC/scripts/tcgrep.gz open(my $FILE, $self->{'filename'}) or do { $self->warn("cannot open file ".$self->{'filename'}. " for grepping"); return}; my $counter =0; while(<$FILE>) { $counter++ if(/^AF/); } close $FILE; opendir(my $SINGLETS,$self->{'path'}); foreach my $f ( readdir($SINGLETS) ) { next unless ($f =~ /\.singlets$/); open(my $FILE, File::Spec->catfile($self->{'path'},$f)) or do{ $self->warn("cannot open file ".File::Spec->catfile($self->{'path'},$f)); next }; while(<$FILE>) { $counter++ if(/^>/) } close $FILE; } return $counter; } =head2 get_path() Title : get_path() Usage : $o_consed->get_path(); Function: Returns the path to the acefile this object is working with. Returns : Scalar. The path to the working acefile. Args : None. =cut sub get_path { my $self = shift; return $self->{'path'}; } =head2 get_contigs() Title : get_contigs() Usage : $o_consed->get_contigs(); Function: Return the keys to the Bio::Tools::Alignment::Consed object. Returns : An array containing the keynames in the Bio::Tools::Alignment::Consed object. Args : None. This would normally be used to get the keynames for some sort of iterator. These keys are worthless in general day-to-day use because in the Consed acefile they are simply Contig1, Contig2, ... =cut sub get_contigs { my ($self,$contig) = @_; my @contigs = sort keys %{$self->{'contigs'}}; return @contigs; } =head2 get_class($contig_keyname) Title : get_class($contig_keyname) Usage : $o_consed->get_class($contig_keyname); Function: Return the class name for this contig Returns : A scalar representing the class of this contig. Args : None. Notes : =cut sub get_class { my ($self,$contig) = @_; return $self->{contigs}->{$contig}->{class}; } =head2 get_quality_array($contig_keyname) Title : get_quality_array($contig_keyname) Usage : $o_consed->get_quality_array($contig_keyname); Function: Returns the quality for the consensus sequence for the given contig as an array. See get_quality_scalar to get this as a scalar. Returns : An array containing the quality for the consensus sequence with the given keyname. Args : The keyname of a contig. Note: This is a keyname. The key would normally come from get_contigs. Returns an array, not a reference. Is this a bug? I<thinking> No. Well, maybe. Why was this developed like this? I was using FreezeThaw for object persistence, and when it froze out these arrays it took a long time to thaw it. Much better as a scalar. See L<get_quality_scalar()|get_quality_scalar> =cut sub get_quality_array { my ($self,$contig) = @_; return split ' ', $self->{contigs}->{$contig}->{quality}; } =head2 get_quality_scalar($contig_keyname) Title : get_quality_scalar($contig_keyname) Usage : $o_consed->get_quality_scalar($contig_keyname); Function: Returns the quality for the consensus sequence for the given contig as a scalar. See get_quality_array to get this as an array. Returns : An scalar containing the quality for the consensus sequence with the given keyname. Args : The keyname of a contig. Note this is a _keyname_. The key would normally come from get_contigs. Why was this developed like this? I was using FreezeThaw for object persistence, and when it froze out these arrays it took a coon's age to thaw it. Much better as a scalar. See L<get_quality_array()|get_quality_array> =cut #' sub get_quality_scalar { my ($self,$contig) = @_; return $self->{'contigs'}->{$contig}->{'quality'}; } =head2 freeze_hash() Title : freeze_hash() Usage : $o_consed->freeze_hash(); Function: Use Ilya's FreezeThaw module to create a persistent data object for this Bio::Tools::Alignment::Consed data structure. In the case of AAFC, we use Bio::Tools::Alignment::Consed to pre-process bunches of sequences, freeze the structures, and send in a harvesting robot later to do database stuff. Returns : 0 or 1; Args : None. This procedure was removed so Consed.pm won't require FreezeThaw. =cut #' sub freeze_hash { my $self = shift; $self->warn("This method (freeze_hash) was removed ". "from the bioperl consed.pm. Sorry.\n"); if (1==2) { $self->debug("Bio::Tools::Alignment::Consed::freeze_hash:". " \$self->{path} is $self->{path}\n"); my $filename = $self->{'path'}."frozen"; my %contigs = %{$self->{'contigs'}}; my $frozen = freeze(%contigs); umask 0001; open (my $FREEZE,">$filename") or do { $self->warn( "Bio::Tools::Alignment::Consed could not ". "freeze the contig hash because the file ". "($filename) could not be opened: $!\n"); return 1; }; print $FREEZE $frozen; return 0; } } =head2 get_members($contig_keyname) Title : get_members($contig_keyname) Usage : $o_consed->get_members($contig_keyname); Function: Return the _names_ of the reads in this contig. Returns : An array containing the names of the reads in this contig. Args : The keyname of a contig. Note this is a keyname. The keyname would normally come from get_contigs. See L<get_contigs()|get_contigs> =cut sub get_members { my ($self,$contig) = @_; if (!$contig) { $self->warn("You need to provide the name of a contig to ". "use Bio::Tools::Alignment::Consed::get_members!\n"); return; } return @{$self->{'contigs'}->{$contig}->{'member_array'}}; } =head2 get_members_by_name($some_arbitrary_name) Title : get_members_by_name($some_arbitrary_name) Usage : $o_consed->get_members_by_name($some_arbitrary_name); Function: Return the names of the reads in a contig. This is the name given to $contig{key} based on what is in the contig. This is different from the keys retrieved through get_contigs(). Returns : An array containing the names of the reads in the contig with this name. Args : The name of a contig. Not a key, but a name. Highly inefficient. use some other method if possible. See L<get_contigs()|get_contigs> =cut sub get_members_by_name { my ($self,$name) = @_; # build a list to try to screen for redundancy my @contigs_with_that_name; foreach my $currkey ( sort keys %{$self->{'contigs'}} ) { next if (!$self->{'contigs'}->{$currkey}->{'name'}); if ($self->{'contigs'}->{$currkey}->{'name'} eq "$name") { push @contigs_with_that_name,$currkey; } } my $count = @contigs_with_that_name; if ($count == 1) { my $contig_num = $contigs_with_that_name[0]; return @{$self->{'contigs'}->{$contig_num}->{'member_array'}}; } } =head2 get_contig_number_by_name($some_arbitrary_name) Title : get_contig_number_by_name($some_arbitrary_name) Usage : $o_consed->get_contig_number_by_name($some_arbitrary_name); Function: Return the names of the reads in a contig. This is the name given to $contig{key} based on what is in the contig. This is different from the keys retrieved through get_contigs(). Returns : An array containing the names of the reads in the contig with this name. Args : The name of a contig. Not a key, but a name. See L<get_contigs()|get_contigs> =cut sub get_contig_number_by_name { my ($self,$name) = @_; foreach my $currkey (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$currkey}->{'name'} && $self->{'contigs'}->{$currkey}->{'name'} eq "$name") { return $currkey; } } } =head2 get_sequence($contig_keyname) Title : get_sequence($contig_keyname) Usage : $o_consed->get_sequence($contig_keyname); Function: Returns the consensus sequence for a given contig. Returns : A scalar containing a sequence. Args : The keyname of a contig. Note this is a key. The key would normally come from get_contigs. See L<get_contigs()|get_contigs> =cut sub get_sequence { my ($self,$contig) = @_; return $self->{'contigs'}->{$contig}->{'consensus'}; } =head2 set_final_sequence($some_sequence) Title : set_final_sequence($name,$some_sequence) Usage : $o_consed->set_final_sequence($name,$some_sequence); Function: Provides a manual way to set the sequence for a given key in the contig hash. Rarely used. Returns : 0 or 1; Args : The name (not the keyname) of a contig and an arbitrary string. A method with a questionable and somewhat mysterious origin. May raise the dead or something like that. =cut sub set_final_sequence { my ($self,$name,$sequence) = @_; if (!$self->{'contigs'}->{$name}) { $self->warn("You cannot set the final sequence for ". "$name because it doesn't exist!\n"); return 1; } else { $self->{'contigs'}->{$name}->{'final_sequence'} = $sequence; } return 0; } =head2 _read_file() Title : _read_file(); Usage : _read_file(); Function: An internal subroutine used to read in an acefile and parse it into a Bio::Tools::Alignment::Consed object. Returns : 0 or 1. Args : Nothing. This routine creates and saves the filhandle for reading the files in {fh} =cut sub _read_file { my ($self) = @_; my ($line,$in_contig,$in_quality,$contig_number,$top); # make it easier to type $fhl while (defined($line=$self->_readline()) ) { chomp $line; # check if there is anything on this line # if not, you can stop gathering consensus sequence if (!$line) { # if the line is blank you are no longer to gather consensus # sequence or quality values $in_contig = 0; $in_quality = 0; } # you are currently gathering consensus sequence elsif ($in_contig) { if ($in_contig == 1) { $self->debug("Adding $line to consensus of contig number $contig_number.\n"); $self->{'contigs'}->{$contig_number}->{'consensus'} .= $line; } } elsif ($in_quality) { if (!$line) { $in_quality = undef; } else { # I wrote this in here because acefiles produced by # cap3 do not have a leading space like the acefiles # produced by phrap and there is the potential to have # concatenated quality values like this: 2020 rather # then 20 20 whre lines collide. Thanks Andrew for # noticing. if ($self->{'contigs'}->{$contig_number}->{'quality'} && !($self->{'contigs'}->{$contig_number}->{'quality'} =~ m/\ $/)) { $self->{'contigs'}->{$contig_number}->{'quality'} .= " "; } $self->{'contigs'}->{$contig_number}->{'quality'} .= $line; } } elsif ($line =~ /^BQ/) { $in_quality = 1; } # the line /^CO/ like this: # CO Contig1 796 1 1 U # can be broken down as follows: # CO - Contig! # Contig1 - the name of this contig # 796 - Number of bases in this contig # 1 - Number of reads in this contig # 1 - number of base segments in this contig # U - Uncomplemented elsif ($line =~ /^CO/) { $line =~ m/^CO\ Contig(\d+)\ \d+\ \d+\ \d+\ (\w)/; $contig_number = $1; if ($2 eq "C") { $self->debug("Contig $contig_number is complemented!\n"); } $self->{'contigs'}->{$contig_number}->{'member_array'} = []; $self->{'contigs'}->{$contig_number}->{'contig_direction'} = "$2"; $in_contig = 1; } # 000713 # this BS is deprecated, I think. # haha, I am really witty. <ew> elsif ($line =~ /^BSDEPRECATED/) { $line =~ m/^BS\s+\d+\s+\d+\s+(.+)/; my $member = $1; $self->{'contigs'}->{$contig_number}->{$member}++; } # the members of the contigs are determined by the AF line in the ace file elsif ($line =~ /^AF/) { $self->debug("I see an AF line here.\n"); $line =~ /^AF\ (\S+)\ (\w)\ (\S+)/; # push the name of the current read onto the member array for this contig push @{$self->{'contigs'}->{$contig_number}->{'member_array'}},$1; # the first read in the contig will be named the "top" read if (!$top) { $self->debug("\$top is not set.\n"); if ($self->{'contigs'}->{$contig_number}->{'contig_direction'} eq "C") { $self->debug("Reversing the order of the reads. The bottom will be $1\n"); # if the contig sequence is marked as the # complement, the top becomes the bottom and$ $self->{'contigs'}->{$contig_number}->{'bottom_name'} = $1; $self->{'contigs'}->{$contig_number}->{'bottom_complement'} = $2; $self->{'contigs'}->{$contig_number}->{'bottom_start'} = $3; } else { $self->debug("NOT reversing the order of the reads. ". "The top_name will be $1\n"); # if the contig sequence is marked as the # complement, the top becomes the bottom and$ $self->{'contigs'}->{$contig_number}->{'top_name'} = $1; $self->{'contigs'}->{$contig_number}->{'top_complement'} = $2; $self->{'contigs'}->{$contig_number}->{'top_start'} = $3; } $top = 1; } else { # if the contig sequence is marked as the complement, # the top becomes the bottom and the bottom becomes # the top if ($self->{'contigs'}->{$contig_number}->{'contig_direction'} eq "C") { $self->debug("Reversing the order of the reads. The top will be $1\n"); $self->{'contigs'}->{$contig_number}->{'top_name'} = $1; $self->{'contigs'}->{$contig_number}->{'top_complement'} = $2; $self->{'contigs'}->{$contig_number}->{'top_start'} = $3; } else { $self->debug("NOT reversing the order of the reads. The bottom will be $1\n"); $self->{'contigs'}->{$contig_number}->{'bottom_name'} = $1; $self->{'contigs'}->{$contig_number}->{'bottom_complement'} = $2; $self->{'contigs'}->{$contig_number}->{'bottom_start'} = $3; } $top = undef; } } } return 0; } =head2 set_reverse_designator($some_string) Title : set_reverse_designator($some_string) Usage : $o_consed->set_reverse_designator($some_string); Function: Set the designator for the reverse read of contigs in this Bio::Tools::Alignment::Consed object. Used to determine if contigs containing two reads can be named. Returns : The value of $o_consed->{reverse_designator} so you can check to see that it was set properly. Args : An arbitrary string. May be useful only to me. I<shrug> =cut sub set_reverse_designator { my ($self,$reverse_designator) = @_; $self->{'reverse_designator'} = $reverse_designator; $self->{'o_trim'}->set_reverse_designator($reverse_designator); return $self->{'reverse_designator'}; } # end set_reverse_designator =head2 set_forward_designator($some_string) Title : set_forward_designator($some_string) Usage : $o_consed->set_forward_designator($some_string); Function: Set the designator for the forward read of contigs in this Bio::Tools::Alignment::Consed object. Used to determine if contigs containing two reads can be named. Returns : The value of $o_consed->{forward_designator} so you can check to see that it was set properly. Args : An arbitrary string. May be useful only to me. I<shrug> =cut sub set_forward_designator { my ($self,$forward_designator) = @_; $self->{'forward_designator'} = $forward_designator; $self->{'o_trim'}->set_forward_designator($forward_designator); return $self->{'forward_designator'}; } # end set_forward_designator =head2 set_designator_ignore_case("yes") Title : set_designator_ignore_case("yes") Usage : $o_consed->set_designator_ignore_case("yes"); Function: Deprecated. Returns : Deprecated. Args : Deprecated. Deprecated. Really. Trust me. =cut sub set_designator_ignore_case { my ($self,$ignore_case) = @_; if ($ignore_case eq "yes") { $self->{'designator_ignore_case'} = 1; } return $self->{'designator_ignore_case'}; } # end set_designator_ignore_case =head2 set_trim_points_singlets_and_singletons() Title : set_trim_points_singlets_and_singletons() Usage : $o_consed->set_trim_points_singlets_and_singletons(); Function: Set the trim points for singlets and singletons based on quality. Uses the Bio::Tools::Alignment::Trim object. Use at your own risk because the Bio::Tools::Alignment::Trim object was designed specifically for me and is mysterious in its ways. Every time somebody other then me uses it a swarm of locusts decends on a small Central American village so do not say you weren't warned. Returns : Nothing. Args : None. Working on exceptions and warnings here. See L<Bio::Tools::Alignment::Trim> for more information =cut #' to make my emacs happy sub set_trim_points_singlets_and_singletons { my ($self) = @_; $self->debug("Consed.pm : \$self is $self\n"); my (@points,$trimmed_sequence); if (!$self->{'doublets_set'}) { $self->debug("You need to set the doublets before you use ". "set_trim_points_singlets_and_doublets. Doing that now."); $self->set_doublets(); } foreach (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$_}->{'class'} eq "singlet") { $self->debug("Singlet $_\n"); # this is what Warehouse wants # my ($self,$sequence,$quality,$name) = @_; # this is what Bio::Tools::Alignment::Trim::trim_singlet wants: # my ($self,$sequence,$quality,$name,$class) = @_; # the following several lines are to make the parameter passing legible. my ($sequence,$quality,$name,$class); $sequence = $self->{'contigs'}->{$_}->{'consensus'}; if (!$self->{'contigs'}->{$_}->{'quality'}) { $quality = "unset"; } else { $quality = $self->{'contigs'}->{$_}->{'quality'}; } $name = $self->{'contigs'}->{$_}->{'name'}; $class = $self->{'contigs'}->{$_}->{'class'}; @points = @{$self->{'o_trim'}->trim_singlet($sequence,$quality,$name,$class)}; $self->{'contigs'}->{$_}->{'start_point'} = $points[0]; $self->{'contigs'}->{$_}->{'end_point'} = $points[1]; $self->{'contigs'}->{$_}->{'sequence_trimmed'} = substr($self->{contigs}->{$_}->{'consensus'},$points[0],$points[1]-$points[0]); } } $self->debug("Bio::Tools::Alignment::Consed::set_trim_points_singlets". "_and_singletons: Done setting the quality trimpoints.\n"); return; } # end set_trim_points_singlet =head2 set_trim_points_doublets() Title : set_trim_points_doublets() Usage : $o_consed->set_trim_points_doublets(); Function: Set the trim points for doublets based on quality. Uses the Bio::Tools::Alignment::Trim object. Use at your own risk because the Bio::Tools::Alignment::Trim object was designed specifically for me and is mysterious in its ways. Every time somebody other then me uses it you risk a biblical plague being loosed on your city. Returns : Nothing. Args : None. Notes : Working on exceptions here. See L<Bio::Tools::Alignment::Trim> for more information =cut sub set_trim_points_doublets { my $self = shift; my @points; $self->debug("Bio::Tools::Alignment::Consed::set_trim_points_doublets:". " Restoring zeros for doublets.\n"); # &show_missing_sequence($self); $self->debug("Bio::Tools::Alignment::Consed::set_trim_points_doublets:". " Setting doublet trim points.\n"); foreach (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$_}->{'class'} eq "doublet") { # my ($self,$sequence,$quality,$name,$class) = @_; my @quals = split(' ',$self->{'contigs'}->{$_}->{'quality'}); @points = $self->{o_trim}->trim_doublet ($self->{'contigs'}->{$_}->{'consensus'}, $self->{'contigs'}->{$_}->{'quality'}, $self->{'contigs'}->{$_}->{name}, $self->{'contigs'}->{$_}->{'class'}); $self->{'contigs'}->{$_}->{'start_point'} = $points[0]; $self->{'contigs'}->{$_}->{'end_point'} = $points[1]; # now set this $self->{'contigs'}->{$_}->{'sequence_trimmed'} = substr($self->{contigs}->{$_}->{'consensus'}, $points[0],$points[1]-$points[0]); # 010102 the deprecated way to do things: } } $self->debug("Bio::Tools::Alignment::Consed::set_trim_points_doublets:". " Done setting doublet trim points.\n"); return; } # end set_trim_points_doublets =head2 get_trimmed_sequence_by_name($name) Title : get_trimmed_sequence_by_name($name) Usage : $o_consed->get_trimmed_sequence_by_name($name); Function: Returns the trimmed_sequence of a contig with {name} eq $name. Returns : A scalar- the trimmed sequence. Args : The {name} of a contig. Notes : =cut sub get_trimmed_sequence_by_name { my ($self,$name) = @_; my $trimmed_sequence; my $contigname = &get_contig_number_by_name($self,$name); my $class = $self->{'contigs'}->{$contigname}->{'class'}; # what is this business and who was smoking crack while writing this? # if ($class eq "singlet") { # send the sequence, the quality, and the name # $trimmed_sequence = $self->{o_trim}->trim_singlet # ($self->{'contigs'}->{$contigname}->{consensus}, # $self->{'contigs'}->{$contigname}->{'quality'},$name); # } return $self->{'contigs'}->{$contigname}->{'sequence_trimmed'}; } =head2 set_dash_present_in_sequence_name("yes") Title : set_dash_present_in_sequence_name("yes") Usage : $o_consed->set_dash_present_in_sequence_name("yes"); Function: Deprecated. Part of an uncompleted thought. ("Oooh! Shiny!") Returns : Nothing. Args : "yes" to set {dash_present_in_sequence_name} to 1 Notes : =cut sub set_dash_present_in_sequence_name { my ($self,$dash_present) = @_; if ($dash_present eq "yes") { $self->{'dash_present_in_sequence_name'} = 1; } else { $self->{'dash_present_in_sequence_name'} = 0; } return $self->{'dash_present_in_sequence_name'}; } # end set_dash_present_in_sequence_name =head2 set_doublets() Title : set_doublets() Usage : $o_consed->set_doublets(); Function: Find pairs that have similar names and mark them as doublets and set the {name}. Returns : 0 or 1. Args : None. A complicated subroutine that iterates over the Bio::Tools::Alignment::Consed looking for contigs of 2. If the forward and reverse designator are removed from each of the reads in {'member_array'} and the remaining reads are the same, {name} is set to that name and the contig's class is set as "doublet". If any of those cases fail the contig is marked as a "pair". =cut #' make my emacs happy sub set_doublets { my ($self) = @_; # set the designators in the Bio::Tools::Alignment::Trim object $self->{'o_trim'}->set_designators($self->{'reverse_designator'}, $self->{'forward_designator'}); foreach my $key_contig (sort keys %{$self->{'contigs'}}) { # if there is a member array (why would there not be? This should be a die()able offence # but for now I will leave it if ($self->{'contigs'}->{$key_contig}->{'member_array'}) { # if there are two reads in this contig # i am pretty sure that this is wrong but i am keeping it for reference # if (@{$self->{'contigs'}->{$key_contig}->{'member_array'}} == 2 || !$self->{'contigs'}->{$key_contig}->{'class'}) { # <seconds later> # <nod> WRONG. Was I on crack? if (@{$self->{'contigs'}->{$key_contig}->{'member_array'}} == 2) { $self->{'contigs'}->{$key_contig}->{'num_members'} = 2; $self->debug("\tThere are 2 members! Looking for the contig name...\n"); my $name = _get_contig_name($self,$self->{'contigs'}->{$key_contig}->{'member_array'}); $self->debug("The name is $name\n") if defined $name; if ($name) { $self->{'contigs'}->{$key_contig}->{'name'} = $name; $self->{'contigs'}->{$key_contig}->{'class'} = "doublet"; } else { $self->debug("$key_contig is a pair.\n"); $self->{'contigs'}->{$key_contig}->{'class'} = "pair"; } } # this is all fair and good but what about singlets? # they have one reads in the member_array but certainly are not singletons elsif (@{$self->{'contigs'}->{$key_contig}->{'member_array'}} == 1) { # set the name to be the name of the read $self->{'contigs'}->{$key_contig}->{name} = @{$self->{'contigs'}->{$key_contig}->{'member_array'}}[0]; # set the number of members to be one $self->{'contigs'}->{$key_contig}->{num_members} = 1; # if this was a singlet, it would already belong to the class "singlet" # so leave it alone # if it is not a singlet, it is a singleton! lablel it appropriately unless ($self->{'contigs'}->{$key_contig}->{'class'}) { $self->{'contigs'}->{$key_contig}->{'class'} = "singleton"; } } # set the multiplet characteristics elsif (@{$self->{'contigs'}->{$key_contig}->{'member_array'}} >= 3) { $self->{'contigs'}->{$key_contig}->{'num_members'} = @{$self->{'contigs'}->{$key_contig}->{'member_array'}}; $self->{'contigs'}->{$key_contig}->{'class'} = "multiplet"; } $self->{'contigs'}->{$key_contig}->{'num_members'} = @{$self->{'contigs'}->{$key_contig}->{'member_array'}}; } } $self->{'doublets_set'} = "done"; return 0; } # end set_doublets =head2 set_singlets Title : set_singlets Usage : $o_consed->set_singlets(); Function: Read in a singlets file and place them into the Bio::Tools::Alignment::Consed object. Returns : Nothing. Args : A scalar to turn on verbose parsing of the singlets file. Notes : =cut sub set_singlets { # parse out the contents of the singlets file my ($self) = @_; $self->debug("Bio::Tools::Alignment::Consed Adding singlets to the contig hash...\n"); my $full_filename = $self->{'filename'}; $self->debug("Bio::Tools::Alignment::Consed::set_singlets: \$full_filename is $full_filename\n"); $full_filename =~ s#\\#\/#g if $^O =~ m/mswin/i; $full_filename =~ m/(.*\/)(.*ace.*)$/; my ($base_path,$filename) = ($1,$2); $self->debug("Bio::Tools::Alignment::Consed::set_singlets: singlets filename is $filename and \$base_path is $base_path\n"); $filename =~ m/(.*)ace.*$/; my $singletsfile = $base_path.$1."singlets"; $self->debug("\$singletsfile is $singletsfile\n"); if (!-f $singletsfile) { # there is no singlets file. $self->{'singlets_set'} = "done"; return; } $self->debug("$singletsfile is indeed a file. Trying to open it...\n"); my $singlets_fh = Bio::Root::IO->new(-file => $singletsfile); my ($sequence,$name,$count); while ($_ = $singlets_fh->_readline()) { chomp $_; if (/\>/) { if ($name && $sequence) { $self->debug("Adding $name with sequence $sequence to hash...\n"); push @{$self->{'contigs'}->{$name}->{'member_array'}},$name; $self->{'contigs'}->{$name}->{'consensus'} = $sequence; $self->{'contigs'}->{$name}->{'name'} = $name; $self->{'contigs'}->{$name}->{"singlet"} = 1; $self->{'contigs'}->{$name}->{'class'} = "singlet"; } $sequence = $name = undef; $count++; m/^\>(.*)\s\sCHROMAT/; $name = $1; if (!$name) { m/\>(\S+)\s/; $name = $1; } } else { $sequence .= $_; } } if ($name && $sequence) { $self->debug("Pushing the last of the singlets ($name)\n"); @{$self->{'contigs'}->{$name}->{'member_array'}} = $name; $self->{'contigs'}->{$name}->{'consensus'} = $sequence; $self->{'contigs'}->{$name}->{'name'} = $name; $self->{'contigs'}->{$name}->{"singlet"} = 1; $self->{'contigs'}->{$name}->{'class'} = "singlet"; } $self->debug("Bio::Tools::Alignment::Consed::set_singlets: Done adding singlets to the singlets hash.\n"); $self->{'singlets_set'} = "done"; return 0; } # end sub set_singlets =head2 get_singlets() Title : get_singlets() Usage : $o_consed->get_singlets(); Function: Return the keynames of the singlets. Returns : An array containing the keynames of all Bio::Tools::Alignment::Consed sequences in the class "singlet". Args : None. Notes : =cut sub get_singlets { # returns an array of singlet names # singlets have "singlet"=1 in the hash my $self = shift; if (!$self->{singlets_set}) { $self->debug("You need to set the singlets before you get them. Doing that now."); $self->set_singlets(); } my (@singlets,@array); foreach my $key (sort keys %{$self->{'contigs'}}) { # @array = @{$Consed::contigs{$key}->{'member_array'}}; # somethimes a user will try to get a list of singlets before the classes for the rest of the # contigs has been set (see t/test.t for how I figured this out. <bah> # so either way, just return class=singlets if (!$self->{'contigs'}->{$key}->{'class'}) { # print("$key has no class. why?\n"); } elsif ($self->{'contigs'}->{$key}->{'class'} eq "singlet") { push @singlets,$key; } } return @singlets; } =head2 set_quality_by_name($name,$quality) Title : set_quality_by_name($name,$quality) Usage : $o_consed->set_quality_by_name($name,$quality); Function: Deprecated. Make the contig with {name} have {'quality'} $quality. Probably used for testing. Returns : Nothing. Args : The name of a contig and a scalar for its quality. Notes : Deprecated. =cut sub set_quality_by_name { # this is likely deprecated my ($self,$name,$quality) = shift; my $return; foreach (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'} eq "$name" || $self->{'contigs'}->{'name'} eq "$name") { $self->{'contigs'}->{'quality'} = $quality; $return=1; } } if ($return) { return "0"; } else { return "1"; } } # end set quality by name =head2 set_singlet_quality() Title : set_singlet_quality() Usage : $o_consed->set_singlet_quality(); Function: For each singlet, go to the appropriate file in phd_dir and read in the phred quality for that read and place it into {'quality'} Returns : 0 or 1. Args : None. Notes : This is the next subroutine that will receive substantial revision in the next little while. It really should eval the creation of Bio::Tools::Alignment::Phred objects and go from there. =cut sub set_singlet_quality { my $self = shift; my $full_filename = $self->{'filename'}; $full_filename =~ s#\\#\/#g if $^O =~ m/mswin/i; $full_filename =~ m/(.*\/)(.*)ace.*$/; my ($base_path,$filename) = ($1,"$2"."qual"); my $singletsfile = $base_path.$filename; if (-f $singletsfile) { # print("$singletsfile is indeed a file. Trying to open it...\n"); } else { $self->warn("$singletsfile is not a file. Sorry.\n"); return; } my $singlets_fh = Bio::Root::IO->new(-file => $singletsfile); my ($sequence,$name,$count); my ($identity,$line,$quality,@qline); while ($line = $singlets_fh->_readline()) { chomp $line; if ($line =~ /^\>/) { $quality = undef; $line =~ m/\>(\S*)\s/; $identity = $1; } else { if ($self->{'contigs'}->{$identity}) { $self->{'contigs'}->{$identity}->{'quality'} .= "$line "; } } } return 0; } =head2 set_contig_quality() Title : set_contig_quality() Usage : $o_consed->set_contig_quality(); Function: Deprecated. Returns : Deprecated. Args : Deprecated. Notes : Deprecated. Really. Trust me. =cut sub set_contig_quality { # note: contigs _include_ singletons but _not_ singlets my ($self) = shift; # the unexpected results I am referring to here are a doubling of quality values. # the profanity I uttered on discovering this reminded me of the simpsons: # Ned Flanders: "That is the loudest profanity I have ever heard!" $self->warn("set_contig_quality is deprecated and will likely produce unexpected results"); my $full_filename = $self->{'filename'}; # Run_SRC3700_2000-08-01_73+74.fasta.screen.contigs.qual # from Consed.pm $full_filename =~ s#\\#\/#g if $^O =~ m/mswin/i; $full_filename =~ m/(.*\/)(.*)ace.*$/; my ($base_path,$filename) = ($1,"$2"."contigs.qual"); my $singletsfile = $base_path.$filename; if (-f $singletsfile) { # print("$singletsfile is indeed a file. Trying to open it...\n"); } else { $self->warn("Bio::Tools::Alignment::Consed::set_contig_quality $singletsfile is not a file. Sorry.\n"); return; } my $contig_quality_fh = Bio::Root::IO->new(-file => $singletsfile); my ($sequence,$name,$count,$identity,$line,$quality); while ($line = $contig_quality_fh->_readline()) { chomp $line; if ($line =~ /^\>/) { $quality = undef; $line =~ m/\>.*Contig(\d+)\s/; $identity = $1; } else { if ($self->{'contigs'}->{$identity} ) { $self->{'contigs'}->{$identity}->{'quality'} .= " $line"; } } } } # end set_contig_quality =head2 get_multiplets() Title : get_multiplets() Usage : $o_consed->get_multiplets(); Function: Return the keynames of the multiplets. Returns : Returns an array containing the keynames of all Bio::Tools::Alignment::Consed sequences in the class "multiplet". Args : None. Notes : =cut sub get_multiplets { # returns an array of multiplet names # multiplets have # members > 2 my $self = shift; my (@multiplets,@array); foreach my $key (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$key}->{'class'}) { if ($self->{'contigs'}->{$key}->{'class'} eq "multiplet") { push @multiplets,$key; } } } return @multiplets; } =head2 get_all_members() Title : get_all_members() Usage : @all_members = $o_consed->get_all_members(); Function: Return a list of all of the read names in the Bio::Tools::Alignment::Consed object. Returns : An array containing all of the elements in all of the {'member_array'}s. Args : None. Notes : =cut sub get_all_members { my $self = shift; my @members; foreach my $key (sort keys %{$self->{'contigs'}}) { if ($key =~ /^singlet/) { push @members,$self->{'contigs'}->{$key}->{'member_array'}[0]; } elsif ($self->{'contigs'}->{$key}->{'member_array'}) { push @members,@{$self->{'contigs'}->{$key}->{'member_array'}}; } # else { # print("Bio::Tools::Alignment::Consed: $key is _not_ an array. Pushing $self->{'contigs'}->{$key}->{'member_array'} onto \@members\n"); # push @members,$self->{'contigs'}->{$key}->{'member_array'}; # } } return @members; } =head2 sum_lets($total_only) Title : sum_lets($total_only) Usage : $statistics = $o_consed->sum_lets($total_only); Function: Provide numbers for how many sequences were accounted for in the Bio::Tools::Alignment::Consed object. Returns : If a scalar is present, returns the total number of sequences accounted for in all classes. If no scalar passed then returns a string that looks like this: Singt/singn/doub/pair/mult/total : 2,0,1(2),0(0),0(0),4 This example means the following: There were 1 singlets. There were 0 singletons. There were 1 doublets for a total of 2 sequences in this class. There were 0 pairs for a total of 0 sequences in this class. There were 0 multiplets for a total of 0 sequences in this class. There were a total of 4 sequences accounted for in the Bio::Tools::Alignment::Consed object. Args : A scalar is optional to change the way the numbers are returned. Notes: =cut sub sum_lets { my ($self,$total_only) = @_; my ($count,$count_multiplets,$multiplet_count); my $singlets = &get_singlets($self); $count += $singlets; my $doublets = &get_doublets($self); $count += ($doublets * 2); my $pairs = &get_pairs($self); $count += ($pairs * 2); my $singletons = &get_singletons($self); $count += $singletons; my @multiplets = &get_multiplets($self); $count_multiplets = @multiplets; my $return_string; foreach (@multiplets) { my $number_members = $self->{'contigs'}->{$_}->{num_members}; $multiplet_count += $number_members; } if ($multiplet_count) { $count += $multiplet_count; } foreach (qw(multiplet_count singlets doublets pairs singletons multiplets count_multiplets)) { no strict 'refs'; # renege for the block if (!${$_}) { ${$_} = 0; } } if (!$multiplet_count) { $multiplet_count = 0; } if ($total_only) { return $count; } $return_string = "Singt/singn/doub/pair/mult/total : ". "$singlets,$singletons,$doublets(". ($doublets*2)."),$pairs(".($pairs*2). "),$count_multiplets($multiplet_count),$count"; return $return_string; } =head2 write_stats() Title : write_stats() Usage : $o_consed->write_stats(); Function: Write a file called "statistics" containing numbers similar to those provided in sum_lets(). Returns : Nothing. Write a file in $o_consed->{path} containing something like this: 0,0,50(100),0(0),0(0),100 Where the numbers provided are in the format described in the documentation for sum_lets(). Args : None. Notes : This might break platform independence, I do not know. See L<sum_lets()|sum_lets> =cut sub write_stats { # worry about platform dependence here? # oh shucksdarn. my $self = shift; my $stats_filename = $self->{'path'}."statistics"; my $statistics_raw = $self->sum_lets; my ($statsfilecontents) = $statistics_raw =~ s/.*\ \:\ //g; umask 0001; my $fh = Bio::Root::IO->new(-file=>"$stats_filename"); # open(STATSFILE,">$stats_filename") or print("Could not open the statsfile: $!\n"); $fh->_print("$statsfilecontents"); # close STATSFILE; $fh->close(); } =head2 get_singletons() Title : get_singletons() Usage : @singletons = $o_consed->get_singletons(); Function: Return the keynames of the singletons. Returns : Returns an array containing the keynames of all Bio::Tools::Alignment::Consed sequences in the class "singleton". Args : None. Notes : =cut sub get_singletons { # returns an array of singleton names # singletons are contigs with one member (see consed documentation) my $self = shift; my (@singletons,@array); foreach my $key (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$key}->{'class'}) { # print ("$key class: $self->{'contigs'}->{$key}->{'class'}\n"); } else { # print("$key belongs to no class. why?\n"); } if ($self->{'contigs'}->{$key}->{'member_array'}) { @array = @{$self->{'contigs'}->{$key}->{'member_array'}}; } my $num_array_elem = @array; if ($num_array_elem == 1 && $self->{'contigs'}->{$key}->{'class'} && $self->{'contigs'}->{$key}->{'class'} eq "singleton") { push @singletons,$key; } } return @singletons; } =head2 get_pairs() Title : get_pairs() Usage : @pairs = $o_consed->get_pairs(); Function: Return the keynames of the pairs. Returns : Returns an array containing the keynames of all Bio::Tools::Alignment::Consed sequences in the class "pair". Args : None. Notes : =cut sub get_pairs { # returns an array of pair contig names # a pair is a contig of two where the names do not match my $self = shift; my (@pairs,@array); foreach my $key (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$key}->{'member_array'}) { if (@{$self->{'contigs'}->{$key}->{'member_array'}} == 2 && $self->{'contigs'}->{$key}->{'class'} eq "pair") { push @pairs,$key; } } } return @pairs; } =head2 get_name($contig_keyname) Title : get_name($contig_keyname) Usage : $name = $o_consed->get_name($contig_keyname); Function: Return the {name} for $contig_keyname. Returns : A string. ({name}) Args : A contig keyname. Notes : =cut sub get_name { my ($self,$contig) = @_; return $self->{'contigs'}->{$contig}->{'name'}; } =head2 _get_contig_name(\@array_containing_reads) Title : _get_contig_name(\@array_containing_reads) Usage : $o_consed->_get_contig_name(\@array_containing_reads); Function: The logic for the set_doublets subroutine. Returns : The name for this contig. Args : A reference to an array containing read names. Notes : Depends on reverse_designator. Be sure this is set the way you intend. =cut sub _get_contig_name { my ($self,$r_array) = @_; my @contig_members = @$r_array; my @name_nodir; foreach (@contig_members) { # how can I distinguish the clone name from the direction label? # look for $Consed::reverse_designator and $Consed::forward_designator # what if you do not find _any_ of those? my $forward_designator = $self->{'forward_designator'} || "f"; my $reverse_designator = $self->{'reverse_designator'} || "r"; my $any_hits = /(.+)($forward_designator.*)/ || /(.+)($reverse_designator.*)/||/(.+)(_.+)/; my $name = $1; my $suffix = $2; if ($name) { # print("\t\$name is $name "); } if ($suffix) { # print("and \$suffix is $suffix.\n"); } # Jee, I hope we get a naming convention soon if ($suffix) { if ($suffix =~ /^$forward_designator/ || $suffix =~ /^$reverse_designator/) { push @name_nodir,$name; } # bugwatch here! should this be unnested? else { push @name_nodir,"$name$suffix"; } } } # print("\@name_nodir: @name_nodir\n"); my $mismatch = 0; for (my $counter=0; $counter<@name_nodir;$counter++) { next if ($name_nodir[0] eq $name_nodir[$counter]); $mismatch = 1; } if ($mismatch == 0) { # print("\tYou have a cohesive contig named $name_nodir[0].\n\n"); return $name_nodir[0]; } else { # print("\tYou have mixed names in this contig.\n\n"); } } # end _get_contig_name =head2 get_doublets() Title : get_doublets() Usage : @doublets = $o_consed->get_doublets(); Function: Return the keynames of the doublets. Returns : Returns an array containing the keynames of all Bio::Tools::Alignment::Consed sequences in the class "doublet". Args : None. Notes : =cut sub get_doublets { my $self = shift; if (!$self->{doublets_set}) { $self->warn("You need to set the doublets before you can get them. Doing that now."); $self->set_doublets(); } my @doublets; foreach (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$_}->{name} && $self->{'contigs'}->{$_}->{'class'} eq "doublet") { push @doublets,$_; } } return @doublets; } # end get_doublets =head2 dump_hash() Title : dump_hash() Usage : $o_consed->dump_hash(); Function: Use dumpvar.pl to dump out the Bio::Tools::Alignment::Consed object to STDOUT. Returns : Nothing. Args : None. Notes : I used this a lot in debugging. =cut sub dump_hash { my $self = shift; my $dumper = Dumpvalue->new(); $self->debug( "Bio::Tools::Alignment::Consed::dump_hash - ". "The following is the contents of the contig hash...\n"); $dumper->dumpValue($self->{'contigs'}); } =head2 dump_hash_compact() Title : dump_hash_compact() Usage : $o_consed->dump_hash_compact(); Function: Dump out the Bio::Tools::Alignment::Consed object in a compact way. Returns : Nothing. Args : Nothing. Notes : Cleaner then dumpValue(), dumpHash(). I used this a lot in debugging. =cut sub dump_hash_compact { no strict 'refs'; # renege for the block my ($self,$sequence) = @_; # get the classes my @singlets = $self->get_singlets(); my @singletons = $self->get_singletons(); my @doublets = $self->get_doublets(); my @pairs = $self->get_pairs(); my @multiplets = $self->get_multiplets(); print("Name\tClass\tMembers\tQuality?\n"); foreach (@singlets) { my @members = $self->get_members($_); print($self->get_name($_)."\tsinglets\t".(join',',@members)."\t"); if ($self->{'contigs'}->{$_}->{'quality'}) { print("qualities found here\n"); } else { print("no qualities found here\n"); } } foreach (@singletons) { my @members = $self->get_members($_); print($self->get_name($_)."\tsingletons\t".(join',',@members)."\t"); if ($self->{'contigs'}->{$_}->{'quality'}) { print("qualities found here\n"); } else { print("no qualities found here\n"); } } foreach my $pair (@pairs) { my @members = $self->get_members($pair); my $name; if (!$self->get_name($pair)) { $name = "BLANK"; } else { $name = $self->get_name($pair); } print("$name\tpairs\t".(join',',@members)."\n"); } foreach (@doublets) { my @members = $self->get_members_by_name($_); print("$_\tdoublets\t".(join',',@members)."\t"); my $contig_number = &get_contig_number_by_name($self,$_); if ($self->{'contigs'}->{$contig_number}->{'quality'}) { print("qualities found here\n"); } else { print("no qualities found here\n"); } # print($_."\tdoublets\t".(join',',@members)."\n"); } foreach (@multiplets) { my @members = $self->get_members($_); print("Contig $_"."\tmultiplets\t".(join',',@members)."\n"); } } # end dump_hash_compact =head2 get_phreds() Title : get_phreds() Usage : @phreds = $o_consed->get_phreds(); Function: For each doublet in the Bio::Tools::Alignment::Consed hash, go and get the phreds for the top and bottom reads. Place them into {top_phreds} and {bottom_phreds}. Returns : Nothing. Args : Nothing. Requires parse_phd() and reverse_and_complement(). I realize that it would be much more elegant to pull qualities as required but there were certain "features" in the acefile that required a bit more detailed work be done to get the qualities for certain parts of the consensus sequence. In order to make _sure_ that this was done properly I wrote things to do all steps and then I used dump_hash() and checked each one to ensure expected behavior. I have never changed this, so there you are. =cut sub get_phreds { # this subroutine is the target of a rewrite to use the Bio::Tools::Alignment::Phred object. my $self = shift; my $current_contig; foreach $current_contig (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$current_contig}->{'class'} eq "doublet") { $self->debug("$current_contig is a doublet. Going to parse_phd for top($self->{'contigs'}->{$current_contig}->{'top_name'}) and bottom($self->{'contigs'}->{$current_contig}->{'bottom_name'})\n"); my $r_phreds_top = &parse_phd($self,$self->{'contigs'}->{$current_contig}->{'top_name'}); my $r_phreds_bottom = &parse_phd($self,$self->{'contigs'}->{$current_contig}->{'bottom_name'}); if ($self->{'contigs'}->{$current_contig}->{'top_complement'} eq "C") { # print("Reversing and complementing...\n"); $r_phreds_top = &reverse_and_complement($r_phreds_top); } if ($self->{'contigs'}->{$current_contig}->{'bottom_complement'} eq "C") { $r_phreds_bottom = &reverse_and_complement($r_phreds_bottom); } $self->{'contigs'}->{$current_contig}->{'top_phreds'} = $r_phreds_top; $self->{'contigs'}->{$current_contig}->{'bottom_phreds'} = $r_phreds_bottom; } } } =head2 parse_phd($read_name) Title : parse_phd($read_name) Usage : $o_consed->parse_phd($read_name); Function: Suck in the contents of a .phd file. Returns : A reference to an array containing the quality values for the read. Args : The name of a read. Notes : This is a significantly weak subroutine because it was always intended that these functions, along with the functions provided by get_phreds() be put into the Bio::SeqIO:phd module. This is done now but the Bio::Tools::Alignment::Consed module has not be rewritten to reflect this change. See L<Bio::SeqIO::phd> for more information. =cut sub parse_phd { my ($self,$sequence_name) = @_; $self->debug("Parsing phd for $sequence_name\n"); my $in_dna = 0; my $base_number = 0; my (@bases,@current_line); # print("parse_phd: $sequence_name\n"); my $fh = Bio::Root::IO->new (-file=>"$self->{path}/../phd_dir/$sequence_name.phd.1"); while ($fh->_readline()) { # print("Reading a line from a phredfile!\n"); chomp; if (/^BEGIN_DNA/) { $in_dna = 1; next} if (/^END_DNA/) { last; } if (!$in_dna) { next; } push(@bases,$_); } return \@bases; } =head2 reverse_and_complement(\@source) Title : reverse_and_complement(\@source) Usage : $reference_to_array = $o_consed->reverse_and_complement(\@source); Function: A stub for the recursive routine reverse_recurse(). Returns : A reference to a reversed and complemented array of phred data. Args : A reference to an array of phred data. Notes : =cut sub reverse_and_complement { my $r_source = shift; my $r_destination; $r_destination = &reverse_recurse($r_source,$r_destination); return $r_destination; } =head2 reverse_recurse($r_source,$r_destination) Title : reverse_recurse(\@source,\@destination) Usage : $o_consed->reverse_recurse(\@source,\@destination); Function: A recursive routine to reverse and complement an array of phred data. Returns : A reference to an array containing reversed phred data. Args : A reference to a source array and a reverence to a destination array. Recursion is kewl, but this sub should likely be _reverse_recurse. =cut sub reverse_recurse($$) { my ($r_source,my $r_destination) = @_; if (!@$r_source) { return $r_destination; } $_=pop(@$r_source); s/c/g/ || s/g/c/ || s/a/t/ || s/t/a/; push(@$r_destination,$_); &reverse_recurse($r_source,$r_destination); } =head2 show_missing_sequence() Title : show_missing_sequence(); Usage : $o_consed->show_missing_sequence(); Function: Used by set_trim_points_doublets() to fill in quality values where consed (phrap?) set them to 0 at the beginning and/or end of the consensus sequences. Returns : Nothing. Args : None. Acts on doublets only. Really very somewhat quite ugly. A disgusting kludge. I<insert pride here> It was written stepwise with no real plan because it was not really evident why consed (phrap?) was doing this. =cut sub show_missing_sequence() { # decide which sequence should not have been clipped at consensus # position = 0 my $self = shift; &get_phreds($self); my ($current_contig,@qualities); foreach $current_contig (sort keys %{$self->{'contigs'}}) { if ($self->{'contigs'}->{$current_contig}->{'class'} eq "doublet") { my $number_leading_xs = 0; my $number_trailing_xs = 0; my $measurer = $self->{'contigs'}->{$current_contig}->{'quality'}; while ($measurer =~ s/^\ 0\ /\ /) { $number_leading_xs++; } while ($measurer =~ s/\ 0(\s*)$/$1/) { $number_trailing_xs++; } @qualities = split(' ',$self->{'contigs'}->{$current_contig}->{'quality'}); my $in_initial_zeros = 0; for (my $count=0;$count<scalar(@qualities); $count++) { if ($qualities[$count] == 0) { my ($quality,$top_phred_position,$bottom_phred_position,$top_phred_data,$bottom_phred_data); # print("The quality of the consensus at ".($count+1)." is zero. Retrieving the real quality value.\n"); # how do I know which strand to get these quality values from???? # boggle my $top_quality_here = $self->{'contigs'}->{$current_contig}->{'top_phreds'}->[0-$self->{'contigs'}->{$current_contig}->{'top_start'}+$count+1]; my $bottom_quality_here = $self->{'contigs'}->{$current_contig}->{'bottom_phreds'}->[1-$self->{'contigs'}->{$current_contig}->{'bottom_start'}+$count]; if (!$bottom_quality_here || (1-$self->{'contigs'}->{$current_contig}->{'bottom_start'}+$count)<0) { $bottom_quality_here = "not found"; } if (!$top_quality_here) { $top_quality_here = "not found"; } # print("Looking for quals at position $count of $current_contig: top position ".(0-$self->{'contigs'}->{$current_contig}->{top_start}+$count)." ($self->{'contigs'}->{$current_contig}->{top_name}) $top_quality_here , bottom position ".(1-$self->{'contigs'}->{$current_contig}->{bottom_start}+$count)." ($self->{'contigs'}->{$current_contig}->{bottom_name}) $bottom_quality_here\n"); if ($count<$number_leading_xs) { # print("$count is less then $number_leading_xs so I will get the quality from the top strand\n"); # print("retrieved quality is ".$self->{'contigs'}->{$current_contig}->{top_phreds}[0-$self->{'contigs'}->{$current_contig}->{top_start}+$count+1]."\n"); my $quality = $top_quality_here; $quality =~ /\S+\s(\d+)\s+/; $quality = $1; # print("retrieved quality for leading zero $count is $quality\n"); # t 9 9226 $qualities[$count] = $quality; } else { # this part is tricky # if the contig is like this # cccccccccccccccc # ffffffffffffffffff # rrrrrrrrrrrrrrrrr # then take the quality value for the trailing zeros in the cons. seq from the r # # but if the contig is like this # cccccccccccccccccc # ffffffffffffffffffffffffffffffff # rrrrrrrrrrrrrrrrrrrrrrrxxxxxxxxr # ^^^ # then any zeros that fall in the positions (^) must be decided whether the quality # is the qual from the f or r strand. I will use the greater number # does a similar situation exist for the leading zeros? i dunno # # print("$count is greater then $number_leading_xs so I will get the quality from the bottom strand\n"); # print("retrieved quality is ".$contigs->{$current_contig}->{top_phreds}[0-$contigs->{$current_contig}->{top_start}+$count+1]."\n"); # my ($quality,$top_phred_position,$bottom_phred_position,$top_phred_data,$bottom_phred_data); if ($bottom_quality_here eq "not found") { # $top_phred_position = 1-$contigs->{$current_contig}->{bottom_start}+$count; # print("Going to get quality from here: $top_phred_position of the top.\n"); # my $temp_quality - $contigs->{$current_contig}->{top_phreds} # $quality = $contigs->{$current_contig}->{top_phreds}[$top_phred_position]; $top_quality_here =~ /\w+\s(\d+)\s/; $quality = $1; } elsif ($top_quality_here eq "not found") { # $bottom_phred_position = 1+$contigs->{$current_contig}->{bottom_start}+$count; # print("Going to get quality from here: $bottom_phred_position of the bottom.\n"); # $quality = $contigs->{$current_contig}->{bottom_phreds}[$bottom_phred_position]; # print("Additional: no top quality but bottom is $quality\n"); $bottom_quality_here =~ /\w+\s(\d+)\s/; $quality = $1; } else { # print("Oh jeepers, there are 2 qualities to choose from at this position.\n"); # print("Going to compare these phred qualities: top: #$top_quality_here# bottom: #$bottom_quality_here#\n"); # now you have to compare them # my $top_quality_phred = $contigs->{$current_contig}->{top_phreds}[$top_phred_position]; # #t 40 875# # print("regexing #$top_quality_here#... "); $top_quality_here =~ /\w\ (\d+)\s/; my $top_quality = $1; # print("$top_quality\nregexing #$bottom_quality_here#... "); $bottom_quality_here =~ /\w\ (\d+)\s/; my $bottom_quality = $1; # print("$bottom_quality\n"); # print("top_quality: $top_quality bottom quality: $bottom_quality\n"); if ($bottom_quality > $top_quality) { # print("Chose to take the bottom quality: $bottom_quality\n"); $quality = $bottom_quality; } else { # print("Chose to take the top quality: $top_quality\n"); $quality = $top_quality; } } if (!$quality) { # print("Warning: no quality value for $current_contig, position $count!\n"); # print("Additional data: top quality phred: $top_quality_here\n"); # print("Additional data: bottom quality phred: $bottom_quality_here\n"); } else { $qualities[$count] = $quality; } } } } unless (!@qualities) { $self->{'contigs'}->{$current_contig}->{'quality'} = join(" ",@qualities); } $self->{'contigs'}->{$current_contig}->{'bottom_phreds'} = undef; $self->{'contigs'}->{$current_contig}->{'top_phreds'} = undef; my $count = 1; } # end foreach key } } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Alignment/Trim.pm���������������������������������������������������������000555��000765��000024�� 53375�12254227332� 20476� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Bio::Tools::Alignment::Trim.pm # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Alignment::Trim - A kludge to do specialized trimming of sequence based on quality. =head1 SYNOPSIS use Bio::Tools::Alignment::Trim; $o_trim = Bio::Tools::Alignment::Trim->new(); $o_trim->set_reverse_designator("R"); $o_trim->set_forward_designator("F"); =head1 DESCRIPTION This is a specialized module designed by Chad for Chad to trim sequences based on a highly specialized list of requirements. In other words, write something that will trim sequences 'just like the people in the lab would do manually'. I settled on a sliding-window-average style of search which is ugly and slow but does _exactly_ what I want it to do. Mental note: rewrite this. It is very important to keep in mind the context in which this module was written: strictly to support the projects for which Consed.pm was designed. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics-at-dieselwurks.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Alignment::Trim; use strict; use Dumpvalue; use vars qw(%DEFAULTS); use base qw(Bio::Root::Root); BEGIN { %DEFAULTS = ( 'f_designator' => 'f', 'r_designator' => 'r', 'windowsize' => '10', 'phreds' => '20'); } =head2 new() Title : new() Usage : $o_trim = Bio::Tools::Alignment::Trim->new(); Function: Construct the Bio::Tools::Alignment::Trim object. No parameters are required to create this object. It is strictly a bundle of functions, as far as I am concerned. Returns : A reference to a Bio::Tools::Alignment::Trim object. Args : (optional) -windowsize (default 10) -phreds (default 20) =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my($windowsize,$phreds) = $self->_rearrange([qw( WINDOWSIZE PHREDS )], @args); $self->{windowsize} = $windowsize || $DEFAULTS{'windowsize'}; $self->{phreds} = $phreds || $DEFAULTS{'phreds'}; # print("Constructor set phreds to ".$self->{phreds}."\n") if $self->verbose > 0; $self->set_designators($DEFAULTS{'f_designator'}, $DEFAULTS{'r_designator'}); return $self; } =head2 set_designators($forward_designator,$reverse_designator) Title : set_designators(<forward>,<reverse>) Usage : $o_trim->set_designators("F","R") Function: Set the string by which the system determines whether a given sequence represents a forward or a reverse read. Returns : Nothing. Args : two scalars: one representing the forward designator and one representing the reverse designator =cut sub set_designators { my $self = shift; ($self->{'f_designator'},$self->{'r_designator'}) = @_; } =head2 set_forward_designator($designator) Title : set_forward_designator($designator) Usage : $o_trim->set_forward_designator("F") Function: Set the string by which the system determines if a given sequence is a forward read. Returns : Nothing. Args : A string representing the forward designator of this project. =cut sub set_forward_designator { my ($self,$desig) = @_; $self->{'f_designator'} = $desig; } =head2 set_reverse_designator($reverse_designator) Title : set_reverse_designator($reverse_designator) Function: Set the string by which the system determines if a given sequence is a reverse read. Usage : $o_trim->set_reverse_designator("R") Returns : Nothing. Args : A string representing the forward designator of this project. =cut sub set_reverse_designator { my ($self,$desig) = @_; $self->{'r_designator'} = $desig; } =head2 get_designators() Title : get_designators() Usage : $o_trim->get_designators() Returns : A string describing the current designators. Args : None Notes : Really for informational purposes only. Duh. =cut sub get_designators { my $self = shift; return("forward: ".$self->{'f_designator'}." reverse: ".$self->{'r_designator'}); } =head2 trim_leading_polys() Title : trim_leading_polys() Usage : $o_trim->trim_leading_polys() Function: Not implemented. Does nothing. Returns : Nothing. Args : None. Notes : This function is not implemented. Part of something I wanted to do but never got around to doing. =cut sub trim_leading_polys { my ($self, $sequence) = @_; } =head2 dump_hash() Title : dump_hash() Usage : $o_trim->dump_hash() Function: Unimplemented. Returns : Nothing. Args : None. Notes : Does nothing. =cut sub dump_hash { my $self = shift; my %hash = %{$self->{'qualities'}}; } # end dump_hash =head2 trim_singlet($sequence,$quality,$name,$class) Title : trim_singlet($sequence,$quality,$name,$class) Usage : ($r_trim_points,$trimmed_sequence) = @{$o_trim->trim_singlet($sequence,$quality,$name,$class)}; Function: Trim a singlet based on its quality. Returns : a reference to an array containing the forward and reverse trim points and the trimmed sequence. Args : $sequence : A sequence (SCALAR, please) $quality : A _scalar_ of space-delimited quality values. $name : the name of the sequence $class : The class of the sequence. One of qw(singlet singleton doublet pair multiplet) Notes : At the time this was written the bioperl objects SeqWithQuality and PrimaryQual did not exist. This is what is with the clumsy passing of references and so on. I will rewrite this next time I have to work with it. I also wasn't sure whether this function should return just the trim points or the points and the sequence. I decided that I always wanted both so that's how I implemented it. - Note that the size of the sliding windows is set during construction of the Bio::Tools::Alignment::Trim object. =cut sub trim_singlet { my ($self,$sequence,$quality,$name,$class) = @_; # this split is done because I normally store quality values in a # space-delimited scalar rather then in an array. # I do this because serialization of the arrays is tough. my @qual = split(' ',$quality); my @points; my $sequence_length = length($sequence); my ($returnstring,$processed_sequence); # smooth out the qualities my $r_windows = &_sliding_window(\@qual,$self->{windowsize}); # find out the leading and trailing trimpoints my $start_base = $self->_get_start($r_windows,$self->{windowsize},$self->{phreds}); my (@new_points,$trimmed_sequence); # do you think that any sequence shorter then 100 should be # discarded? I don't think that this should be the decision of this # module. # removed, 020926 $points[0] = $start_base; # whew! now for the end base # required parameters: reference_to_windows,windowsize,$phredvalue,start_base my $end_base = &_get_end($r_windows,$self->{windowsize}, $self->{phreds},$start_base); $points[1] = $end_base; # now do the actual trimming # CHAD : I don't think that it is a good idea to call chop_sequence here # because chop_sequence also removes X's and N's and things # and that is not always what is wanted return \@points; } =head2 trim_doublet($sequence,$quality,$name,$class) Title : trim_doublet($sequence,$quality,$name,$class) Usage : ($r_trim_points,$trimmed_sequence) = @{$o_trim->trim_singlet($sequence,$quality,$name,$class)}; Function: Trim a singlet based on its quality. Returns : a reference to an array containing the forward and reverse Args : $sequence : A sequence $quality : A _scalar_ of space-delimited quality values. $name : the name of the sequence $class : The class of the sequence. One of qw(singlet singleton doublet pair multiplet) Notes : At the time this was written the bioperl objects SeqWithQuality and PrimaryQual did not exist. This is what is with the clumsy passing of references and so on. I will rewrite this next time I have to work with it. I also wasn't sure whether this function should return just the trim points or the points and the sequence. I decided that I always wanted both so that's how I implemented it. =cut #' sub trim_doublet { my ($self,$sequence,$quality,$name,$class) = @_; my @qual = split(' ',$quality); my @points; my $sequence_length = length($sequence); my ($returnstring,$processed_sequence); # smooth out the qualities my $r_windows = &_sliding_window(\@qual,$self->{windowsize}); # determine where the consensus sequence starts my $offset = 0; for (my $current = 0; $current<$sequence_length;$current++) { if ($qual[$current] != 0) { $offset = $current; last; } } # start_base required: r_quality,$windowsize,$phredvalue my $start_base = $self->_get_start($r_windows,$self->{windowsize},$self->{phreds},$offset); if ($start_base > ($sequence_length - 100)) { $points[0] = ("FAILED"); $points[1] = ("FAILED"); return @points; } $points[0] = $start_base; # # whew! now for the end base # # required parameters: reference_to_windows,windowsize,$phredvalue,start_base # | # 010420 NOTE: We will no longer get the end base to avoid the Q/--\___/-- syndrome my $end_base = $sequence_length; my $start_of_trailing_zeros = &count_doublet_trailing_zeros(\@qual); $points[1] = $end_base; # CHAD : I don't think that it is a good idea to call chop_sequence here # because chop_sequence also removes X's and N's and things # and that is not always what is wanted return @points; } # end trim_doublet =head2 chop_sequence($name,$class,$sequence,@points) Title : chop_sequence($name,$class,$sequence,@points) Usage : ($start_point,$end_point,$chopped_sequence) = $o_trim->chop_sequence($name,$class,$sequence,@points); Function: Chop a sequence based on its name, class, and sequence. Returns : an array containing three scalars: 1- the start trim point 2- the end trim point 3- the chopped sequence Args : $name : the name of the sequence $class : The class of the sequence. One of qw(singlet singleton doublet pair multiplet) $sequence : A sequence @points : An array containing two elements- the first contains the start trim point and the second conatines the end trim point. =cut sub chop_sequence { my ($self,$name,$class,$sequence,@points) = @_; print("Coming into chop_sequence, \@points are @points\n"); my $fdesig = $self->{'f_designator'}; my $rdesig = $self->{'r_designator'}; if (!$points[0] && !$points[1]) { $sequence = "junk"; return $sequence; } if ($class eq "singlet" && $name =~ /$fdesig$/) { $sequence = substr($sequence,$points[0],$points[1]-$points[0]); } elsif ($class eq "singlet" && $name =~ /$rdesig$/) { $sequence = substr($sequence,$points[0],$points[1]-$points[0]); } elsif ($class eq "singleton" && $name =~ /$fdesig$/) { $sequence = substr($sequence,$points[0],$points[1]-$points[0]); } elsif ($class eq "singleton" && $name =~ /$rdesig$/) { $sequence = substr($sequence,$points[0],$points[1]-$points[0]); } elsif ($class eq "doublet") { $sequence = substr($sequence,$points[0],$points[1]-$points[0]); } # this is a _terrible_ to do this! i couldn't seem to find a better way # i thought something like s/(^.*[Xx]{5,})//g; might work, but no go # no time to find a fix! my $length_before_trimming = length($sequence); my $subs_Xs = $sequence =~ s/^.*[Xx]{5,}//g; if ($subs_Xs) { my $length_after_trimming = length($sequence); my $number_Xs_trimmed = $length_before_trimming - $length_after_trimming; $points[0] += $number_Xs_trimmed; } $length_before_trimming = length($sequence); my $subs_Ns = $sequence =~ s/[Nn]{1,}$//g; if ($subs_Ns) { my $length_after_trimming = length($sequence); my $number_Ns_trimmed = $length_before_trimming - $length_after_trimming; $points[1] -= $number_Ns_trimmed; $points[1] -= 1; } push @points,$sequence; print("chop_sequence \@points are @points\n"); return @points; } =head2 _get_start($r_quals,$windowsize,$phreds,$offset) Title : _get_start($r_quals,$windowsize,$phreds,$offset) Usage : $start_base = $self->_get_start($r_windows,5,20); Function: Provide the start trim point for this sequence. Returns : a scalar representing the start of the sequence Args : $r_quals : A reference to an array containing quality values. In context, this array of values has been smoothed by then sliding window-look ahead algorithm. $windowsize : The size of the window used when the sliding window look-ahead average was calculated. $phreds : <fill in what this does here> $offset : <fill in what this does here> =cut sub _get_start { my ($self,$r_quals,$windowsize,$phreds,$offset) = @_; print("Using $phreds phreds\n") if $self->verbose > 0; # this is to help determine whether the sequence is good at all my @quals = @$r_quals; my ($count,$count2,$qualsum); if ($offset) { $count = $offset; } else { $count = 0; } # search along the length of the sequence for (; ($count+$windowsize) <= scalar(@quals); $count++) { # sum all of the quality values in this window. my $cumulative=0; for($count2 = $count; $count2 < $count+$windowsize; $count2++) { if (!$quals[$count2]) { # print("Quals don't exist here!\n"); } else { $qualsum += $quals[$count2]; # print("Incremented qualsum to ($qualsum)\n"); } $cumulative++; } # print("The sum of this window (starting at $count) is $qualsum. I counted $cumulative bases.\n"); # if the total of windowsize * phreds is if ($qualsum && $qualsum >= $windowsize*$phreds) { return $count; } $qualsum = 0; } # if ($count > scalar(@quals)-$windowsize) { return; } return $count; } =head2 _get_end($r_qual,$windowsize,$phreds,$count) Title : _get_end($r_qual,$windowsize,$phreds,$count) Usage : my $end_base = &_get_end($r_windows,20,20,$start_base); Function: Get the end trim point for this sequence. Returns : A scalar representing the end trim point for this sequence. Args : $r_qual : A reference to an array containing quality values. In context, this array of values has been smoothed by then sliding window-look ahead algorithm. $windowsize : The size of the window used when the sliding window look-ahead average was calculated. $phreds : <fill in what this does here> $count : Start looking for the end of the sequence here. =cut sub _get_end { my ($r_qual,$windowsize,$phreds,$count) = @_; my @quals = @$r_qual; my $total_bases = scalar(@quals); my ($count2,$qualsum,$end_of_quals,$bases_counted); if (!$count) { $count=0; } BASE: for (; $count < $total_bases; $count++) { $bases_counted = 0; $qualsum = 0; POSITION: for($count2 = $count; $count2 < $total_bases; $count2++) { $bases_counted++; if ($count2 == $total_bases-1) { $qualsum += $quals[$count2]; $bases_counted++; last BASE; } elsif ($bases_counted == $windowsize) { $qualsum += $quals[$count2]; if ($qualsum < $bases_counted*$phreds) { return $count+$bases_counted+$windowsize; } next BASE; } else { $qualsum += $quals[$count2]; } } if ($qualsum < $bases_counted*$phreds) { return $count+$bases_counted+$windowsize; } else { } $qualsum = 0; } # end for if ($end_of_quals) { my $bases_for_average = $total_bases-$count2; return $count2; } else { } if ($qualsum) { } # print ("$qualsum\n"); return $total_bases; } # end get_end =head2 count_doublet_trailing_zeros($r_qual) Title : count_doublet_trailing_zeros($r_qual) Usage : my $start_of_trailing_zeros = &count_doublet_trailing_zeros(\@qual); Function: Find out when the trailing zero qualities start. Returns : A scalar representing where the zeros start. Args : A reference to an array of quality values. Notes : Again, this should be rewritten to use PrimaryQual objects. A more detailed explanation of why phrap puts these zeros here should be written and placed here. Please email and hassle the author. =cut sub count_doublet_trailing_zeros { my ($r_qual) = shift; my $number_of_trailing_zeros = 0; my @qualities = @$r_qual; for (my $current=scalar(@qualities);$current>0;$current--) { if ($qualities[$current] && $qualities[$current] != 0) { $number_of_trailing_zeros = scalar(@qualities)-$current; return $current+1; } } return scalar(@qualities); } # end count_doublet_trailing_zeros =head2 _sliding_window($r_quals,$windowsize) Title : _sliding_window($r_quals,$windowsize) Usage : my $r_windows = &_sliding_window(\@qual,$windowsize); Function: Create a sliding window, look-forward-average on an array of quality values. Used to smooth out differences in qualities. Returns : A reference to an array containing the smoothed values. Args : $r_quals: A reference to an array containing quality values. $windowsize : The size of the sliding window. Notes : This was written before PrimaryQual objects existed. They should use that object but I haven't rewritten this yet. =cut #' sub _sliding_window { my ($r_quals,$windowsize) = @_; my (@window,@quals,$qualsum,$count,$count2,$average,@averages,$bases_counted); @quals = @$r_quals; my $size_of_quality = scalar(@quals); # do this loop for all of the qualities for ($count=0; $count <= $size_of_quality; $count++) { $bases_counted = 0; BASE: for($count2 = $count; $count2 < $size_of_quality; $count2++) { $bases_counted++; # if the search hits the end of the averages, stop # this is for the case near the end where bases remaining < windowsize if ($count2 == $size_of_quality) { $qualsum += $quals[$count2]; last BASE; } # if the search hits the size of the window elsif ($bases_counted == $windowsize) { $qualsum += $quals[$count2]; last BASE; } # otherwise add the quality value unless (!$quals[$count2]) { $qualsum += $quals[$count2]; } } unless (!$qualsum || !$windowsize) { $average = $qualsum / $bases_counted; if (!$average) { $average = "0"; } push @averages,$average; } $qualsum = 0; } # 02101 Yes, I repaired the mismatching numbers between averages and windows. # print("There are ".scalar(@$r_quals)." quality values. They are @$r_quals\n"); # print("There are ".scalar(@averages)." average values. They are @averages\n"); return \@averages; } =head2 _print_formatted_qualities Title : _print_formatted_qualities(\@quals) Usage : &_print_formatted_qualities(\@quals); Returns : Nothing. Prints. Args : A reference to an array containing quality values. Notes : An internal procedure used in debugging. Prints out an array nicely. =cut sub _print_formatted_qualities { my $rquals = shift; my @qual = @$rquals; for (my $count=0; $count<scalar(@qual) ; $count++) { if (($count%10)==0) { print("\n$count\t"); } if ($qual[$count]) { print ("$qual[$count]\t");} else { print("0\t"); } } print("\n"); } =head2 _get_end_old($r_qual,$windowsize,$phreds,$count) Title : _get_end_old($r_qual,$windowsize,$phreds,$count) Usage : Deprecated. Don't use this! Returns : Deprecated. Don't use this! Args : Deprecated. Don't use this! =cut #' sub _get_end_old { my ($r_qual,$windowsize,$phreds,$count) = @_; warn("Do Not Use this function (_get_end_old)"); my $target = $windowsize*$phreds; my @quals = @$r_qual; my $total_bases = scalar(@quals); my ($count2,$qualsum,$end_of_quals); if (!$count) { $count=0; } BASE: for (; $count < $total_bases; $count++) { for($count2 = $count; $count2 < $count+$windowsize; $count2++) { if ($count2 == scalar(@quals)-1) { $qualsum += $quals[$count2]; $end_of_quals = 1; last BASE; } $qualsum += $quals[$count2]; } if ($qualsum < $windowsize*$phreds) { return $count+$windowsize; } $qualsum = 0; } # end for } # end get_end_old # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis������������������������������������������������������������������000755��000765��000024�� 0�12254227330� 16673� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/SimpleAnalysisBase.pm��������������������������������������������000444��000765��000024�� 15434�12254227317� 23152� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Analysis::SimpleAnalysisBase # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::SimpleAnalysisBase - abstract superclass for SimpleAnalysis implementations =head1 SYNOPSIS # not to be run directly =head1 DESCRIPTION This class is a generic implementation of SimpleAnalysisI and should be used as a base class for specific implementations. Modules implementing SimpleAnalysisBase only need to provide specific _init(), _run() and result() methods, plus any get/set methods for parameters to the analysis program. =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Analysis::SimpleAnalysisBase; use strict; use Data::Dumper; my $FLOAT = '[+-]?\d*\.\d*'; my %STATUS = map { $_ => 1 } qw(CREATED COMPLETED TERMINATED_BY_ERROR); use base qw(Bio::WebAgent Bio::SimpleAnalysisI); =head2 new Usage : $job->new(...) Returns : a new analysis object, Args : none (but an implementation may choose to add arguments representing parameters for the analysis program. Each key value of must have a method implemented for it in a subclass. A seq () method is provided here as this will probably be needed by all sequence analysis programs =cut sub new { my $class = shift; my $self = $class->SUPER::new(); #WebAgent new $self->_init; #this line has to be before the attributes are filled in while ( @_ ) { my $key = lc shift; $key =~ s/^-//; $self->$key(shift); } return $self; } =head2 seq Usage : $job->seq() Returns : a Bio::PrimarySeqI implementing sequence object, or void Args : None, or a Bio::PrimarySeqI implementing object =cut sub seq { my ($self,$value) = @_; if ( defined $value) { $self->throw("I need a Bio::PrimarySeqI, not [". $value. "]") unless $value->isa('Bio::PrimarySeqI'); $self->throw(" I need a PrimarySeq object, not a BioSeq object ") if $value->isa('Bio::SeqI'); my $mol_type = $self->analysis_spec->{'type'}; $self->throw("I need a [" . $mol_type . "] seq, not a [". $value->alphabet. "]") unless $value->alphabet =~/$mol_type/i; $self->{'_seq'} = $value; return $self; } return $self->{'_seq'} ; } =head2 analysis_name Usage : $analysis->analysis_name(); Returns : The analysis name Arguments : none =cut sub analysis_name { my $self = shift; return $self->{'_ANALYSIS_NAME'}; } =head2 analysis_spec Usage : $analysis->analysis_spec(); Returns : a hash reference to a hash of analysis parameters. See Bio::SimpleAnalysisI for a list of recommended key values. Arguments: none =cut sub analysis_spec { my $self = shift; return $self->{'_ANALYSIS_SPEC'}; } =head2 clear Usage : $analysis->clear(); Returns : true value on success Arguments : none Purpose : to remove raw results from a previous analysis so that an analysis can be repeated with different parameters. =cut sub clear { my $self= shift; if (defined($self->{'_result'})) { delete $self->{'_result'}; } if (defined ($self->{'_parsed'})) { delete $self->{'_parsed'}; } return 1; } =head2 input_spec Usage : $analysis->input_spec(); Returns : a reference to an array of hashes of analysis parameters. See Bio::SimpleAnalysisI for a list of recommended key values. Arguments : none =cut sub input_spec { my $self = shift; return $self->{'_INPUT_SPEC'}; } =head2 result_spec Usage : $analysis->result_spec(); Returns : a reference to a hashes of resultformats. See Bio::SimpleAnalysisI for a list of recommended key values. The key values can be used as parameters to the result() method, the values provide descriptions. Arguments : none =cut sub result_spec { my $self = shift; return $self->{'_RESULT_SPEC'}; } sub run { my ($self, $args) = @_; $self->_process_arguments ($args) if $args; # check input $self->throw("Need a sequence object as an input") unless $self->seq; $self->debug(Data::Dumper->Dump([$self],[$self])); # internal run() $self->_run; return $self; } sub wait_for { my ($self, $args) = @_; $self->run($args); } sub status { my ($self,$value) = @_; if( defined $value) { no strict 'refs'; my $class = ref($self); $self->throw("Not a valid status value [$value]\n". "Valid values are ". join(", ", keys %STATUS )) unless defined $STATUS{$value}; $self->{'_status'} = $value; use strict; } return $self->{'_status'} || 'CREATED' ; } sub _process_arguments { my ($self, $args) = @_; my %spec; map {$spec{ $_->{'name'} } = $_ } @{$self->input_spec}; $self->debug(Data::Dumper->Dump([\%spec, $args],[\%spec, $args])); foreach my $key (keys %$args) { my $value = $args->{$key}; $self->throw("Unknown argument [$key]") unless $spec{$key}; $self->$key($value); } foreach my $key (keys %spec) { $self->throw("Mandatory argument [$key] is not set") if $spec{$key}{'mandatory'} eq 'true' and not defined $self->$key; } } sub _run { shift->throw_not_implemented();} 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/DNA��������������������������������������������������������������000755��000765��000024�� 0�12254227330� 17275� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/DNA/ESEfinder.pm�������������������������������������������������000444��000765��000024�� 23326�12254227330� 21622� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Analysis::DNA::ESEfinder # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::DNA::ESEfinder - a wrapper around ESEfinder server =head1 SYNOPSIS use Bio::Tools::Analysis::DNA::ESEfinder; use strict; my $seq; # a Bio::PrimarySeqI or Bio::SeqI object $seq = Bio::Seq->new( -primary_id => 'test', -seq=>'atgcatgctaggtgtgtgttttgtgggttgtactagctagtgat'. -alphabet=>'dna'); my $ese_finder = Bio::Tools::Analysis::DNA::ESEfinder-> new(-seq => $seq); # run ESEfinder prediction on a DNA sequence $ese_finder->run(); die "Could not get a result" unless $ese_finder->status =~ /^COMPLETED/; print $ese_finder->result; # print raw prediction to STDOUT foreach my $feat ( $ese_finder->result('Bio::SeqFeatureI') ) { # do something to SeqFeature # e.g. print as GFF print $feat->gff_string, "\n"; # or store within the sequence - if it is a Bio::SeqI $seq->add_SeqFeature($feat) } =head1 DESCRIPTION This class is a wrapper around the ESEfinder web server which uses experimentally defined scoring matrices to identify possible exonic splicing enhancers in human transcripts. The results can be retrieved in 4 ways. =over 4 =item 1. C<$ese_finder-E<gt>result('')> retrieves the raw text output of the program =item 2. C<$ese_finder-E<gt>result('all')> returns a Bio::Seq::Meta::Array object with prediction scores for all residues in the sequence =item 3. C<$ese_finder-E<gt>result('Bio::SeqFeatureI')> returns an array of Bio::SeqFeature objects for sequences with significant scores. Feature tags are score, motif, SR_protein and method =item 4. C<$ese_finder-E<gt>result('raw')> returns an array of significant matches with each element being a reference to [SR_protein, position, motif, score] =back See L<http://rulai.cshl.edu/tools/ESE2/> This the second implentation of Bio::SimpleAnalysisI which hopefully will make it easier to write wrappers on various services. This class uses a web resource and therefore inherits from L<Bio::WebAgent>. =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... #should have own package Bio::Tools::Analysis::DNA::ESEfinder; use Data::Dumper; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw (POST); use HTML::HeadParser; use Bio::SeqFeature::Generic; use Bio::Seq::Meta::Array; use Bio::WebAgent; use strict; #inherits directly from SimpleAnalysisBase use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); #global vars are now file-scoped lexicals my $URL = 'http://rulai.cshl.org/cgi-bin/tools/ESE/esefinder.cgi'; my $ANALYSIS_NAME = 'ESEfinder'; my $ANALYSIS_SPEC = { 'name' => 'ESEfinder', 'type' => 'DNA', #compulsory entry as is used for seq checking 'version' => '2.0', 'supplier' => 'Krainer lab, Cold Spring Harbor Laboratory, POBOX100, Bungtown Rd, COld Spring Harbor, NY, USA', 'description' => 'to identify exonic splicing elements in human transcripts', }; my $INPUT_SPEC = [{ 'mandatory' => 'true', 'type' => 'Bio::PrimarySeqI', 'name' => 'sequence', }]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', 'raw' => 'Array of [ SR_protein, position, motif, score]', 'all' => 'Bio::Seq::Meta::Array object' }; ### unique to this module ## sub _init { ## fills in fixed data for class ## my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} =$ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} =$INPUT_SPEC; $self->{'_RESULT_SPEC'} =$RESULT_SPEC; $self->{'_ANALYSIS_NAME'} =$ANALYSIS_NAME; return $self; } sub _run { my $self = shift; my $seq_fasta; my $stringfh = IO::String->new($seq_fasta); my $seqout = Bio::SeqIO->new(-fh => $stringfh, -format => 'fasta'); $seqout->write_seq($self->seq); $self->debug($seq_fasta); $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $request = POST $self->url, #Content_Type => 'x-www-form-urlencoded', Content => [ protein1 => 1, protein2 => 1, protein3 => 1, protein4 => 1, radio_sf2 => 0, radio_sc35 => 0, radio_srp40 => 0, radio_srp55 => 0, sequence =>$seq_fasta, ]; my $content = $self->request($request); if( $content->is_error ) { $self->throw(ref($self)." Request Error:\n".$content->as_string); } my $text = $content->content; #1st reponse my ($tmpfile) = $text =~ /value="(tmp\/.+txt)"/; # now get data for all residues # my $rq2 = POST 'http://rulai.cshl.org/cgi-bin/tools/ESE/resultfile.txt', #Content_Type => 'x-www-form-urlencoded', Content => [ fname => $tmpfile, ]; my $ua2 = Bio::WebAgent->new(); my $content2 = $ua2->request($rq2); if( $content2->is_error ) { $self->throw(ref($self)." Request Error:\n".$content2->as_string); } my $text2 = $content2->content; $self->{'_result'} = $text2; $self->status('COMPLETED') if $text2 ne ''; #print Dumper $response; } sub result { #make sec feat of above threshold scores # my ($self,$value) = @_; my @sig_pdctns; my @fts; if ($value ) { my $result = IO::String->new($self->{'_result'}); my $current_SR; my $all_st_flag = 0; my %all; while (my $line = <$result>) { #make array of all scores or threshold depending on $value last if $line =~ /^All scores/ && $value ne 'all' or $line =~ /2001,/; $all_st_flag++ if $line =~ /All scores/; next if $value eq 'all' && $all_st_flag == 0; #parse line if ($line =~ /^Protein/) { ($current_SR) = $line =~/:\s+(\S+)/; $current_SR =~ s{/}{_}; # remove unallowed charcters from hash } if ( $line =~/^\d+/ && $value ne 'all') { push @sig_pdctns, [$current_SR, split /\s+/, $line] ; } elsif ($line =~ /^\d+/) { push @{$all{$current_SR}}, [split /\s+/, $line]; } } if ($value eq 'Bio::SeqFeatureI') { foreach (@sig_pdctns) { #make new ese object for each row of results push @fts, Bio::SeqFeature::Generic->new ( -start => $_->[1], -end => $_->[1] + length($_->[2]) -1, -source => 'ESEfinder', -primary => 'ESE', -tag =>{ score =>$_->[3], motif=> $_->[2], SR_protein=> $_->[0], method=> 'ESEfinder', }, ); } return @fts; } ## convert parsed data into a meta array format elsif ($value eq 'all') { bless ($self->seq, "Bio::Seq::Meta::Array"); $self->seq->isa("Bio::Seq::MetaI") || $self->throw("$self is not a Bio::Seq::MetaI"); for my $prot (keys %all) { my @meta; my $len = scalar @{$all{$prot}} ; for (my $i = 0; $i < $len; $i++ ) { $meta[$i] = $all{$prot}[$i][2]; } # assign default name here so that the # Bio::Seq::Meta::Array can work for all classes # implementing it and we can avoid having to make # asubclass for each implementation $Bio::Seq::Meta::Array::DEFAULT_NAME = "ESEfinder_SRp55"; my $meta_name = $self->analysis_spec->{'name'} . "_" . "$prot"; $self->seq->named_meta($meta_name,\@meta ); } # return seq array object implementing meta sequence # return $self->seq; } #return ref to array of arrays return \@sig_pdctns; } return $self->{'_result'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein����������������������������������������������������������000755��000765��000024�� 0�12254227337� 20322� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/Domcut.pm������������������������������������������������000444��000765��000024�� 25165�12254227330� 22272� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: Domcut.pm,v 1.0 2003/07/ 11 # # BioPerl module for Bio::Tools::Analysis::Protein::Domcut # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::Domcut - a wrapper around Domcut server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::Domcut; #get a Bio::PrimarySeq use Bio::PrimarySeq; my $seq = Bio::PrimarySeq->new (-seq=>'IKLCVNLAILAKAHLIELALAL', -primary_id=>'test'); # a Bio::PrimarySeqI object my $domcut = Bio::Tools::Analysis::Protein::Domcut->new (-seq=>$seq); $domcut->run; print $domcut->result;# #raw text to standard out =head1 DESCRIPTION A module to remotely retrieve predictions of protein domain boundaries. Each residue in the protein receives a score, those better than the significance threshold and at a local minimum receive a rank - i.e., the best minimum is rank 1, the second best minimum is rank2 etc. These correspond to domain boundaries. e.g., my $analysis_object = Bio::Tools::Analysis::Protein::Domcut->new (-seq => $seq); creates a new object. The sequence supplied must be a Bio::PrimarySeq and not a Bio::Seq object. $analysis_object->run; submits the query to the server and obtains raw text output Given an amino acid sequence the results can be obtained in 4 formats, determined by the argument to the result method =over 4 =item 1 The raw text of the program output my $rawdata = $analysis_object->result; =item 2 A reference to an array of hashes of scores for each state and the assigned state. Each element in the array is a residue (indexed from 0). my $data_ref = $analysis_object->result('parsed'); print "score for helix at residue 2 is $data_ref->[1]{'helix'}\n"; print "predicted struc at residue 2 is $data_ref->[1]{'struc}\n"; =item 3 An array of Bio::SeqFeature::Generic objects where each feature is a predicted unit of secondary structure. Only stretches of helix/sheet predictions for longer than 4 residues are defined as helices. So, in order to add features to an existing Bio::Seq object; # get a Bio::Seq object my $seqobj; my $tool = Bio::Tools::Analysis::Protein::Domcut->new ( -seq => $seqobj->primary_seq); $tool->run; my @fts = $tool->result(Bio::SeqFeatureI); $seqobj->add_SeqFeature(@fts); # if you want meta sequences as well : my $meta = $tool->result('meta'); $seqobj->primary_seq($meta); # can access meta data in a Bio::Seq object via a # call to primary_seq: print $seq4->primary_seq->named_submeta_text('Domcut', 1,2), "\n"; =item 4 A Bio::Seq::Meta::Array implementing sequence. This is a Bio::Seq object that can also hold data about each residue in the sequence. In this case, the sequence can be associated with a single array of Domcut prediction scores. e.g., my $meta_sequence = $analysis_object->result('meta'); print "scores from residues 10 -20 are ", $meta_sequence->submeta_text(10,20), "\n"; Many methods common to all analyses are inherited from Bio::Tools::Analysis::SimpleAnalysisBase. =back =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::Tools::Analysis::SimpleAnalysisBase>, L<Bio::Seq::Meta::Array>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut use strict; package Bio::Tools::Analysis::Protein::Domcut; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw(GET); use Bio::SeqFeature::Generic; use Bio::Seq::Meta::Array; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); my $URL = 'http://www.Bork.EMBL-Heidelberg.DE/Docu/mikita/domplot.cgi?'; my $ANALYSIS_NAME = 'Domcut'; my $ANALYSIS_SPEC = { 'name' => 'Domcut', 'type' => 'protein', #compulsory entry as is used for seq checking 'version' => 'n/a', 'supplier' => 'Ohara lab, Laboratory of DNA technology, Kazusa DNA Research Institute, 1532-3 Yana, Kisarazu, Japan', 'description' => 'to predict domain boundaries in proteins', 'reference' => 'Bioinformatics 19, 673-674 (2003)', }; my $INPUT_SPEC = [ { 'mandatory' => 'true', 'type' => 'Bio::PrimarySeqI', 'name' => 'seq', }, ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', 'parsed' => "Array of {'score' =>, 'rank'=> ]", 'meta' => 'Bio::Seq::Meta::Array object' }; =head2 result Name : result Purpose : To retrieve results of analysis in one of several formats. Usage : $job->result (...) Returns : a result created by running an analysis Args : various - see keysin $RESULT_SPEC. The method returns a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data. This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags =item 'Bio::SeqFeatureI' The argument string defines the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. Tagnames are 'score' and 'rank'. =item 'parsed' Array of array references of [score, rank]. =item 'all' A Bio::Seq::Meta::Array object. Scores can be accessed using methods from this class. Meta sequence name is Domcut. =back =cut sub result { my ($self,$value) = @_; my @scores; my @fts; if ($value ) { # parse raw text if not already done so if (!exists($self->{'_parsed'})) { my $result = IO::String->new($self->{'_result'}); while (my $line = <$result>) { next if $line =~/#/; $line =~/(\-?\d\.\d+)\s+(\d+)?/; push @scores, {score => $1, rank => ($2)?$2:'' , }; } #hold parsed results in object, saves having to reparse each time $self->{'_parsed'} = \@scores; } #make aarray of Bio::SeqFeature::Generic objects if ($value eq 'Bio::SeqFeatureI') { my $i = 0; #array index (= aa num -1) my $in_trough = 0; my ($st, $end, $rank, $min_score, $min_locus) = (0,0,0,0,0); my $seqlen = $self->seq->length(); for my $score (@{$self->{'_parsed'}}) { ##start a potential trough if ($in_trough == 0 && $score->{'score'} < -0.09) { $in_trough = 1; $st = $i+1; } ## in a trough, is it ranked? elsif ( $in_trough == 1 && $score->{'score'} < -0.09 && $i +1 < $seqlen){ if ($score->{'rank'} ) { $rank = $score->{'rank'}; $min_score = $score->{'score'}; $min_locus = $i + 1; } } ## end of trough or end of sequence, make into feature ## if possible elsif ($in_trough == 1 && ($score->{'score'} > -0.09 || $i +1 == $seqlen) ){ if ($rank != 0) { push @fts, Bio::SeqFeature::Generic->new ( -start => $st, -end => $i +1, #current position -primary => 'Linker', -source => 'Domcut', -tag => { score => $min_score, rank => $rank, residue => $min_locus, }, ); } ##and reset parameters ## ($st, $in_trough, $min_locus, $min_score, $rank) = (0,0,0,0,0); } $i++; } return @fts; } ## convert parsed data into a meta array format elsif ($value eq 'meta') { ## only need to bless once if (! $self->seq->isa("Bio::Seq::MetaI")){ bless ($self->seq, "Bio::Seq::Meta::Array"); } $self->seq->isa("Bio::Seq::MetaI") || $self->throw("$self is not a Bio::Seq::MetaI"); my $meta_name = "Domcut"; #test that sequence does not have already a meta seq with same name if (grep{$_ eq $meta_name}$self->seq->meta_names ) { $self->warn ("$meta_name already exists , not overwriting!"); next; } ### or should be an instance variable?? ## $Bio::Seq::Meta::Array::DEFAULT_NAME = 'Domcut'; my @meta = map{$_->{'score'}} @{$self->{'_parsed'}}; $self->seq->named_meta($meta_name,\@meta ); # return seq array object implementing meta sequence # return $self->seq; } # return ref to array of predictions; elsif ($value eq 'parsed') { return $self->{'_parsed'}; } } #else if no arguments return raw text return $self->{'_result'}; } sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} = $ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} = $INPUT_SPEC; $self->{'_RESULT_SPEC'} = $RESULT_SPEC; $self->{'_ANALYSIS_NAME'} = $ANALYSIS_NAME; return $self; } sub _run { my $self = shift; my $seq_fasta = $self->seq->seq; $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $rqst = GET $self->url . "&seqnam=". "&sequence=". $seq_fasta. "&outform=dat"; my $content = $self->request($rqst); my $text = $content->content; #1st reponse $self->{'_result'} = $text; $self->status('COMPLETED') if $text ne ''; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/ELM.pm���������������������������������������������������000555��000765��000024�� 27225�12254227323� 21460� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Analysis::Protein::ELM # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Richard Adams <richard.adams@ed.ac.uk> # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::ELM - a wrapper around the ELM server which predicts short functional motifs on amino acid sequences =head1 SYNOPSIS # get a Bio::Seq object to start with, or a Bio::PrimaryI object. my $tool = Bio::Tools::Analysis::Protein::ELM-> new(seq => $seqobj->primary_seq() ); $tool->compartment(['ER', 'Golgi']); $tool->species(9606); $tool->run; my @fts = $tool->Result('Bio::SeqFeatureI'); $seqobj->addSeqFeature(@fts); =head1 DESCRIPTION This module is a wrapper around the ELM server L<http://elm.eu.org/> which predicts short functional motifs on amino acid sequences. False positives can be limited by providing values for the species and cellular compartment of the protein. To set the species attribute, use either a L<Bio::Species> object or an NCBI taxon ID number. To set the cell compartment attribute (any number of compartments can be chosen) use an array reference to a list of compartment names. Results can be obtained either as raw text output, parsed into a data structure, or as Bio::SeqFeature::Generic objects. =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut use strict; package Bio::Tools::Analysis::Protein::ELM; use vars qw(%cc); use HTML::HeadParser; use Bio::SeqFeature::Generic; use HTTP::Request::Common qw(POST); use IO::String; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); ## valid cell compartments ## %cc = ( all => 1, nucleus => 'GO:0005634', extracellular => 'GO:0005576', cytoplasm => 'GO:0005737', peroxisome => 'GO:0005777', glycosome => 'GO:0020015', glyoxisome => 'GO:0009514', golgi => 'GO:0005794', er => 'GO:0005783', lysosome => 'GO:0005764', endosome => 'GO:0005768', plasma_membrane=> 'GO:0005886', ); my $URL = 'http://elm.eu.org/cgimodel.py'; my $ANALYSIS_NAME = 'ELM'; my $INPUT_SPEC = [ { 'mandatory' => 'true', 'type' => 'Bio::PrimarySeqI', 'name' => 'seq', }, { 'mandatory' => 'false', 'type' => 'taxon_id or Bio::Species object', 'name' => 'species', 'default' => '9606', }, { 'mandatory' => 'false', 'type' => 'string', 'name' => 'compartment', 'default' => [1], }, ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', 'parsed' => '{motif1_name=>{locus=>[], peptide=>[], regexp=>[] }, }', }; my $ANALYSIS_SPEC= {name => 'ELM', type => 'Protein', version => 'n/a', supplier =>'BioComputing Unit, EMBL', description =>'Prediction of linear functional motifs in proteins', reference => 'NAR, 31:3625-3630'}; sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} = $ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} = $INPUT_SPEC; $self->{'_RESULT_SPEC'} = $RESULT_SPEC; $self->{'_ANALYSIS_NAME'} = $ANALYSIS_NAME; return $self; } =head2 compartment name : compartment usage : $elm->compartment(['golgi', 'er']); purpose : get/setter for cell compartment specifications arguments : None, single compartment string or ref to array of compartment names. returns : Array of compartment names (default if not previously set). =cut sub compartment { my ($self, $arg) = @_; if ($arg) { # convert to array ref if not one already if (ref ($arg) ne 'ARRAY') { $arg = [$arg]; } ## now add params if valid for my $param (@$arg) { if (exists($cc{lc($param)})) { push @{$self->{'_compartment'}} , $cc{$param}; } else { $self->warn("invalid argument ! Must be one of " . join "\n", keys %cc ); } } #end of for loop } #endif $arg return defined($self->{'_compartment'})? $self->{'_compartment'} : $self->input_spec()->[2]{'default'}; } =head1 species name : species usage : $tool->species('9606'); purpose : get/setter for species selction for ELM server arguments : none, taxon_id or Bio::Species object returns : a string of the ncbi taxon_id =cut sub species { my ($self, $arg) = @_; if ($arg) { if (ref($arg) && $arg->isa('Bio::Species')) { $self->{'_species'} = $arg->ncbi_taxid(); } elsif ($arg =~ /^\d+$/) { $self->{'_species'} = $arg; } else { $self->warn("Argument must be a Bio::Species object or ". " an integer NCBI taxon id. "); } } #end if $arg return defined($self->{'_species'})?$self->{'_species'} :$self->input_spec()->[1]{'default'}; } sub _run { my $self = shift; $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change #$self->sleep; $self->status('TERMINATED_BY_ERROR'); #### this deals with being able to submit multiple checkboxed #### slections #1st of all make param array my @cc_str; my @cmpts = @{$self->compartment()}; for (my $i = 0; $i <= $#cmpts ; $i++) { splice @cc_str, @cc_str, 0, 'userCC',$cmpts[$i]; } my %h = (swissprotId => "", sequence => $self->seq->seq, userSpecies => $self->species, typedUserSpecies => '', fun => "Submit"); splice (@cc_str, @cc_str,0, ( map{$_, $h{$_}} keys %h)); my $request = POST $self->url(), Content_Type => 'form-data', Content => \@cc_str; $self->debug( $request->as_string); my $r1 = $self->request($request); if ( $r1->is_error ) { $self->warn(ref($self)." Request Error:\n".$r1->as_string); return; } my $text = $r1->content; my ($url) = $text =~ /URL=\S+(fun=\S+r=\d)/s; #$url =~ s/amp;//g ; my ($resp2); $url = $URL . "?" .$url; while (1) { my $req2 = HTTP::Request->new(GET=>$url); my $r2 = $self->request ($req2); if ( $r2->is_error ) { $self->warn(ref($self)." Request Error:\n".$r2->as_string); return; } $resp2 = $r2->content(); if ($resp2 !~ /patient/s) { $self->status('COMPLETED'); $resp2=~ s/<[^>]+>/ /sg; $self->{'_result'} = $resp2; return; } else { print "." if $self->verbose > 0; $self->sleep(1); } } } =head1 result name : result usage : $tool->result('Bio::SeqFeatureI'); purpose : parse results into sequence features or basic data format arguments : 1. none (retrieves raw text without html) 2. a value (retrieves data structure) 3. 'Bio::SeqFeatureI' (returns array of sequence features) tag names are : {method => 'ELM', motif => motifname, peptide => seqeunce of match, concensus => regexp of match}. returns : see arguments. =cut sub result { my ($self, $val) = @_; if ($val) { if (!exists($self->{'_parsed'}) ) { $self->_parse_raw(); } if ($val eq 'Bio::SeqFeatureI') { my @fts; for my $motif (keys %{$self->{'_parsed'}}) { for (my $i = 0; $i< scalar @{$self->{'_parsed'}{$motif}{'locus'}};$i++) { my ($st, $end) = split /\-/, $self->{'_parsed'}{$motif}{'locus'}[$i]; push @fts, Bio::SeqFeature::Generic->new ( -start => $st, -end => $end, -primary_tag => 'Domain', -source => 'ELM', -tag => { method => 'ELM', motif => $motif, peptide => $self->{'_parsed'}{$motif}{'peptide'}[$i], concensus => $self->{'_parsed'}{$motif}{'regexp'}[0], }); } } return @fts; } #end if BioSeqFeature return $self->{'_parsed'}; } #endif ($val) return $self->{'_result'}; } ## internal sub to parse raw data into internal data structure which is cached. sub _parse_raw { my $self = shift; my $result = IO::String->new($self->{'_result'}); my $in_results = 0; my $name; my %results; my $last; while (my $l = <$result>) { next unless $in_results > 0 ||$l =~ /^\s+Elm\s+Name\s+Instances/; $in_results++; #will be set whnstart of results reached. last if $l =~ /List of excluded/; next unless $in_results >1; my @line_parts = split /\s+/, $l; shift @line_parts; ## if result has motif name on 1 line if (scalar @line_parts == 1 && $line_parts[0]=~ /^\s*(\w+_\w+)/) { $name = $1; next; } ## else if is line with loci /seq matches elsif (@line_parts > 1) { my $index = 0; ## array index my $read_loci = 0; ## flag to know that loci are being read while ($index <= $#line_parts) { my $word = $line_parts[$index++]; if ($read_loci ==0 && $word =~/_/) { $name = $word; } elsif ($read_loci == 0 && $word =~ /^\w+$/ ) { push @{$results{$name}{'peptide'}}, $word; } elsif ($word =~ /\d+\-\d+/) { $read_loci = 1; push @{$results{$name}{'locus'}}, $word; } else { ## only get here if there are elements last; } } #end of while push @{$results{$name}{'regexp'}}, $line_parts[$#line_parts]; } #end of elsif } #end of while $self->{'_parsed'} = \%results; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/GOR4.pm��������������������������������������������������000444��000765��000024�� 26535�12254227332� 21556� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: GOR4.pm,v 1.0 2003/07/ 11 # # BioPerl module for Bio::Tools::Analysis::Protein::GOR4 # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::GOR4 - a wrapper around GOR4 protein secondary structure prediction server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::GOR4; #get a Bio::Seq or Bio::PrimarySeq use Bio::PrimarySeq; $seq = Bio::PrimarySeq->new (-seq=>'IKLCVHHJHJHJHJHJHJHNLAILAKAHLIELALAL', -primary_id=>'test'); # a Bio::PrimarySeqI object my $gor4 = Bio::Tools::Analysis::Protein::GOR4->new (-seq=>$seq); $gor4->run; print $gor4->result;# #raw text to standard error =head1 DESCRIPTION A module to remotely retrieve predictions of protein secondary structure. Each residue in the protein receives a score representing the likelihood of existing in each of three different states (helix, coil or sheet), e.g., my $analysis_object = Bio::Tools::SimpleAnalysis::Protein::GOR4-> new(-seq => $seq); creates a new object $analysis_object->run; submits the query to the server and obtains raw text output Given an amino acid sequence the results can be obtained in 4 formats, determined by the argument to the result method =over 4 =item 1 The raw text of the program output my $rawdata = $analysis_object->result; =item 2 An reference to an array of hashes of scores for each state and the assigned state. my $data_ref = $analysis_object->result('parsed'); print "score for helix at residue 2 is $data_ref->[1]{'helix'}\n"; print "predicted struc at residue 2 is $data_ref->[1]{'struc}\n"; =item 3 An array of Bio::SeqFeature::Generic objects where each feature is a predicted unit of secondary structure. Only stretches of helix/sheet predictions for longer than 4 residues are defined as helices. See Bio::Tools::Analysis::Domcut.pm for examples of how to add sequence features. my @fts = $analysis_object->result(Bio::SeqFeatureI); for my $ft (@fts) { print " From ", $ft->start, " to ",$ft->end, " struc: " , ($ft->each_tag_value('type'))[0] ,"\n"; } =item 4 A Bio::Seq::Meta::Array implementing sequence. This is a Bio::Seq object that can also hold data about each residue in the sequence In this case, the sequence can be associated with a single array of GOR4 prediction scores. e.g., my $meta_sequence = $analysis_object->result('all'); print "helix scores from residues 10-20 are ", $meta_sequence->named_submeta_text("GOR4_helix",10,20), "\n"; Meta sequence names are : GOR4_helix, GOR4_sheet, GOR4_coil, GOR4_struc, representing the scores for each residue. Many methods common to all analyses are inherited from Bio::Tools::Analysis::SimpleAnalysisBase. =back =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::Tools::Analysis::SimpleAnalysisBase>, L<Bio::Seq::Meta::Array>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut use strict; package Bio::Tools::Analysis::Protein::GOR4; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw(POST); use Bio::SeqFeature::Generic; use Bio::Seq::Meta::Array; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); use constant MIN_STRUC_LEN => 3; my $URL = 'http://npsa-pbil.ibcp.fr/cgi-bin/secpred_gor4.pl'; my $ANALYSIS_NAME = 'GOR4'; my $ANALYSIS_SPEC = {name => 'Gor4', type => 'Protein'}; my $INPUT_SPEC = [ {mandatory =>'true', type => 'Bio::PrimarySeqI', 'name' => 'seq', }, ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', raw => '[ {struc =>, helix=> ,sheet=>, coil=>}]', meta => 'Bio::Seq::Meta::Array object', }; =head2 result Name : result Usage : $job->result (...) Returns : a result created by running an analysis Args : see keys of $RESULT_SPEC The method returns a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data. This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags =item 'Bio::SeqFeatureI' The argument string defines the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. Feature primary tag is "2ary". Feature tags are "type" (which can be helix, sheet or coil) "method" (GOR4). =item 'parsed' Array of hash references of { helix =E<gt>, sheet =E<gt> , coil =E<gt> , struc=E<gt>}. =item 'meta' A Bio::Seq::Meta::Array object. Scores can be accessed using methods from this class. Meta sequence names are GOR4_helix, GOR4_sheet, GOR4_coil, GOR4_struc. =back =cut sub result { my ($self,$value) = @_; my @scores; my @fts; if ($value ) { #parse into basic raw form, store this as well as '_result' if (!exists($self->{'_parsed'}) ) { my $result = IO::String->new($self->{'_result'}); while (my $line = <$result>) { next unless $line =~ /^\w\s/; # or for sopma/hnn /^[A-Z]\s/ $line =~/(\w)\s+(\d+)\s+(\d+)\s+(\d+)/; # or for so push @scores, { struc => $1, helix => $2, sheet => $3, coil => $4, }; } $self->{'_parsed'} = \@scores; } if ($value eq 'Bio::SeqFeatureI') { $self->_get_2ary_coords(); for my $type (keys %{$self->{'_parsed_coords'}} ) { next if $type =~ /\w{2,}/; #if not H,C,E or T for my $loc (@{$self->{'_parsed_coords'}{$type}} ) { push @fts, Bio::SeqFeature::Generic->new (-start => $loc->{'start'}, -end => $loc->{'end'}, -source => 'GOR4', -primary => 'Region', -tag => { type => $type, method => $self->analysis_name, }); } #end of array of strucs of type } # end of all 2nd struc elements delete $self->{'_parsed_coords'}; #remove temp data return @fts; } #endif BioSeqFeature elsif ($value eq 'meta') { #1st of all make 3 or 4 arrays of scores for each type from column data my %type_scores; for my $aa (@{$self->{'_parsed'}}) { push @{$type_scores{'struc'}}, $aa->{'struc'}; push @{$type_scores{'helix'}}, $aa->{'helix'}; push @{$type_scores{'sheet'}}, $aa->{'sheet'}; push @{$type_scores{'coil'}}, $aa->{'coil'}; } ## bless if necessary ## if (!$self->seq->isa("Bio::Seq::Meta::Array")){ bless ($self->seq, "Bio::Seq::Meta::Array"); } $self->seq->isa("Bio::Seq::MetaI") || $self->throw("$self is not a Bio::Seq::MetaI"); $Bio::Seq::Meta::Array::DEFAULT_NAME = 'GOR4_struc'; ## now make meta_Sequence for my $struc_type (keys %type_scores) { my $meta_name = "GOR4". "_" . "$struc_type"; my @meta = map{$_->{$struc_type}} @{$self->{'_parsed'}}; if (grep{$_ eq $meta_name}$self->seq->meta_names ) { $self->warn ("$meta_name already exists , not overwriting!"); next; } $self->seq->named_meta($meta_name,\@meta ); } # return seq array object implementing meta sequence # return $self->seq; } else { return $self->{'_parsed'}; } } #endif ($value) #return raw result if no return fomrt stated return $self->{'_result'}; } sub _get_2ary_coords { #helper sub for result; ##extracts runs of structure > MIN_STRUC_LENresidues or less if Turn: #i.e., helical prediction for 1 residue isn't very meaningful... ## and poulates array of hashes with start/end values. ##keys of $Result are 'H' 'T' 'C' 'E'. #could be put into a secondary base class if need be my ($self) = @_; my @prot = @{$self->{'_parsed'}}; my %Result; for (my $index = 0; $index <= $#prot; $index++) { my $type = $prot[$index]{'struc'}; next unless $type =~ /[HTCE]/; my $length = 1; for (my $j = $index + 1; $j <= $#prot; $j++) { my $test = $prot[$j]; if ($test->{'struc'} eq $type) { $length++; } elsif ( $length > MIN_STRUC_LEN || ($length <= MIN_STRUC_LEN && $type eq 'T') ) { push @{$Result{$type}}, {start => $index + 1 , end => $j}; $index += $length -1; last; } else { $index += $length - 1; last; } } } $self->{'_parsed_coords'} = \%Result; #temp assignment } sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} =$ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} =$INPUT_SPEC; $self->{'_RESULT_SPEC'} =$RESULT_SPEC; $self->{'_ANALYSIS_NAME'} =$ANALYSIS_NAME; return $self; } sub _run { my $self = shift; $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $request = POST $self->url, Content_Type => 'form-data', Content => [title => "", notice => $self->seq->seq, ali_width => 70, ]; my $content = $self->request($request); my $text = $content->content; return unless $text; my ($next) = $text =~ /Prediction.*?=(.*?)>/; return unless $next; my $out = 'http://npsa-pbil.ibcp.fr/'.$next; my $req2 = HTTP::Request->new(GET=>$out); my $resp2 = $self->request($req2); $self->status('COMPLETED') if $resp2 ne ''; $self->{'_result'} = $resp2->content; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/HNN.pm���������������������������������������������������000444��000765��000024�� 26575�12254227321� 21470� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: HNN.pm,v 1.0 2003/07/ 11 # # BioPerl module for Bio::Tools::Analysis::Protein::HNN # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::HNN - a wrapper around the HNN protein secondary structure prediction server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::HNN; #get a Bio::Seq or Bio::PrimarySeq use Bio::PrimarySeq; my $seq = Bio::PrimarySeq->new (-seq=>'IKLCVHHJHJHJHJHJHJHNLAILAKAHLIELALAL', -primary_id=>'test'); # a Bio::PrimarySeqI object my $hnn = Bio::Tools::Analysis::Protein::HNN->new (-seq=>$seq); $hnn->run; print $hnn->result;# #raw text to standard error =head1 DESCRIPTION A module to remotely retrieve predictions of protein secondary structure. Each residue in the protein receives a score representing the likelihood of existing in each of three different states (helix, coil or sheet), e.g.: my $analysis_object = Bio::Tools::SimpleAnalysis::Protein::HNN->new (-seq => $seq); creates a new object $analysis_object->run; submits the query to the server and obtains raw text output. Given an amino acid sequence the results can be obtained in 4 formats, determined by the argument to the result method: =over 4 =item 1 The raw text of the program output. my $rawdata = $analysis_object->result; =item 2 A reference to an array of hashes of scores for each state and the assigned state. my $data_ref = $analysis_object->result('parsed'); print "score for helix at residue 2 is $data_ref->[1]{'helix'}\n"; print "predicted struc at residue 2 is $data_ref->[1]{'struc}\n"; =item 3 An array of Bio::SeqFeature::Generic objects where each feature is a predicted unit of secondary structure. Only stretches of helix/sheet predictions for longer than 4 residues are defined as helices. my @fts = $analysis_object->result(Bio::SeqFeatureI); for my $ft (@fts) { print " From ", $ft->start, " to ",$ft->end, " struc: " , ($ft->each_tag_value('type'))[0] ,"\n"; } =item 4 A Bio::Seq::Meta::Array implementing sequence. This is a Bio::Seq object that can also hold data about each residue in the sequence In this case, the sequence can be associated with a single array of HNN prediction scores. e.g., my $meta_sequence = $analysis_object->result('meta'); print "helix scores from residues 10-20 are ", $meta_sequence->named_submeta_text("HNN_helix",10,20), "\n"; Meta sequence default names are : HNN_helix, HNN_sheet, HNN_coil, HNN_struc, representing the scores for each residue. Many methods common to all analyses are inherited from L<Bio::Tools::Analysis::SimpleAnalysisBase>. =back =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::Tools::Analysis::SimpleAnalysisBase>, L<Bio::Seq::Meta::Array>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut use strict; package Bio::Tools::Analysis::Protein::HNN; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw (POST); use Bio::SeqFeature::Generic; use Bio::Seq::Meta::Array; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); #extends array for 2struc. my $URL = 'http://npsa-pbil.ibcp.fr/cgi-bin/secpred_hnn.pl'; my $ANALYSIS_NAME= 'HNN'; my $ANALYSIS_SPEC= {name => 'HNN', type => 'Protein'}; my $INPUT_SPEC = [ { mandatory => 'true', type => 'Bio::PrimarySeqI', 'name' => 'seq', }, ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', raw => '[ {helix=>, sheet=>, struc=>, coil=>}]', meta => 'Bio::Seq::Meta::Array object', }; use constant MIN_STRUC_LEN => 3; sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} = $ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} = $INPUT_SPEC; $self->{'_RESULT_SPEC'} = $RESULT_SPEC; $self->{'_ANALYSIS_NAME'} = $ANALYSIS_NAME; return $self; } sub _run { my $self = shift; $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $request = POST 'http://npsa-pbil.ibcp.fr/cgi-bin/secpred_hnn.pl', Content_Type => 'form-data', Content => [title => "", notice => $self->seq->seq, ali_width => 70, ]; my $text = $self->request($request)->content; return unless $text; my ($next) = $text =~ /Prediction.*?=(.*?)>/; return unless $next; my $out = "http://npsa-pbil.ibcp.fr/".$next; my $req2 = HTTP::Request->new(GET=>$out); my $resp2 = $self->request ($req2); $self->status('COMPLETED') if $resp2 ne ''; $self->{'_result'} = $resp2->content; return $self; } =head2 result NAme : result Usage : $job->result (...) Returns : a result created by running an analysis Args : see keys of $INPUT_SPEC The method returns a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data. This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags. =item 'Bio::SeqFeatureI' The argument string defines the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. Feature primary tag is "2ary". Feature tags are "type" (which can be helix, sheet or coil) "method" (HNN). =item 'parsed' Array of hash references of scores/structure assignations { helix =E<gt>, sheet =E<gt> , coil =E<gt> , struc=E<gt>}. =item 'all' A Bio::Seq::Meta::Array object. Scores can be accessed using methods from this class. Meta sequence names are HNN_helix, HNN_sheet, HNN_coil, HNN_struc. =back =cut sub result { my ($self,$value) = @_; my @scores; my @fts; if ($value ) { #parse into basic raw form, store this as well as '_result' if (!exists($self->{'_parsed'}) ) { my $result = IO::String->new($self->{'_result'}); while (my $line = <$result>) { next unless $line =~ /^[HEC]\s/; # or for sopma/hnn /^[A-Z]\s/ $line =~/^([A-Z])\s+(\d+)\s+(\d+)\s+(\d+)/; # or for so push @scores, { struc => $1, helix => $2, sheet => $3, coil => $4, }; } $self->{'_parsed'} = \@scores; } if ($value eq 'Bio::SeqFeatureI') { $self->_get_2ary_coords(); for my $type (keys %{$self->{'_parsed_coords'}} ) { next if $type =~ /\w{2,}/; #if not H,C,E or T for my $loc (@{$self->{'_parsed_coords'}{$type}} ) { push @fts, Bio::SeqFeature::Generic->new (-start => $loc->{'start'}, -end => $loc->{'end'}, -source => 'HNN', -primary => 'Domain', -tag => { type => $type, method => $self->analysis_name, }); } #end of array of strucs of type } # end of all 2nd struc elements delete $self->{'_parsed_coords'}; #remove temp data return @fts; } #endif BioSeqFeature elsif ($value eq 'meta') { #1st of all make 3 or 4 arrays of scores for each type from column data my %type_scores; for my $aa (@{$self->{'_parsed'}}) { push @{$type_scores{'struc'}}, $aa->{'struc'}; push @{$type_scores{'helix'}}, $aa->{'helix'}; push @{$type_scores{'sheet'}}, $aa->{'sheet'}; push @{$type_scores{'coil'}}, $aa->{'coil'}; } ## bless as metasequence if necessary if (!$self->seq->isa("Bio::Seq::MetaI")) { bless ($self->seq, "Bio::Seq::Meta::Array"); } $self->seq->isa("Bio::Seq::MetaI") || $self->throw("$self is not a Bio::Seq::MetaI"); ## now make meta sequence $Bio::Seq::Meta::Array::DEFAULT_NAME = 'HNN_struc'; for my $struc_type (keys %type_scores) { my $meta_name = "HNN". "_" . "$struc_type"; my @meta = map{$_->{$struc_type}} @{$self->{'_parsed'}}; if (grep{$_ eq $meta_name}$self->seq->meta_names ) { $self->warn ("$meta_name already exists , not overwriting!"); next; } $self->seq->named_meta($meta_name,\@meta ); } # return seq array object implementing meta sequence # return $self->seq; } ## else for aa true value get data structure back ## else { return $self->{'_parsed'}; } } #endif ($value) #return raw result if no return fomrt stated return $self->{'_result'}; } sub _get_2ary_coords { #helper sub for result; ##extracts runs of structure > MIN_STRUC_LENresidues or less if Turn: #i.e., helical prediction for 1 residue isn't very meaningful... ## and poulates array of hashes with start/end values. #could be put into a secondary base class if need be my ($self) = @_; my @prot = @{$self->{'_parsed'}}; my %Result; for (my $index = 0; $index <= $#prot; $index++) { my $type = $prot[$index]{'struc'}; next unless $type =~ /[HTCE]/; my $length = 1; for (my $j = $index + 1; $j <= $#prot; $j++) { my $test = $prot[$j]; if ($test->{'struc'} eq $type) { $length++; } elsif ( $length > MIN_STRUC_LEN || ($length <= MIN_STRUC_LEN && $type eq 'T') ) { push @{$Result{$type}}, {start => $index + 1 , end => $j}; $index += $length -1; last; } else { $index += $length - 1; last; } } } $self->{'_parsed_coords'} = \%Result; #temp assignment } 1; �����������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/Mitoprot.pm����������������������������������������������000444��000765��000024�� 22350�12254227323� 22647� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: Mitoprot.pm, # # BioPerl module for Bio::Tools::Analysis::Protein::Mitoprot # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::Mitoprot - a wrapper around Mitoprot server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::Mitoprot; use Bio::PrimarySeq; my $seq = Bio::PrimarySeq->new (-seq=>'IKLCVHHJHJHJHJHJHJHNLAILAKAHLIELALAL', -primary_id=>'test'); # a Bio::PrimarySeqI object my $mitoprot = Bio::Tools::Analysis::Protein::Mitoprot->new ( -seq => $seq ); # sequence must be >!5aa long and start with an M. # run Mitoprot prediction on a DNA sequence my $mitoprot->run(); die "Could not get a result" unless $mitoprot->status =~ /^COMPLETED/; print $mitoprot->result; # print raw prediction to STDOUT foreach my $feat ( $mitoprot->result('Bio::SeqFeatureI') ) { # do something to SeqFeature # e.g. print as GFF print $feat->gff_string, "\n"; # or store within the sequence - if it is a Bio::RichSeqI $seq->add_SeqFeature($feat); } =head1 DESCRIPTION This class is a wrapper around the Mitoprot web server which calculates the probability of a sequence containing a mitochondrial targetting peptide. See http://mips.gsf.de/cgi-bin/proj/medgen/mitofilter for more details. The results can be obtained in 3 formats: =over 3 =item 1 The raw text of the program output my $rawdata = $analysis_object->result; =item 2 An reference to a hash of scores : my $data_ref = $analysis_object->result('parsed'); print "predicted export prob is $data_ref->{'export_prob'}\n"; # key values of returned hash are input_length, basic_aas, acidic_aas, export_prob, charge, cleavage_site. =item 3 A Bio::SeqFeature::Generic object my $ft = $analysis_object->result(Bio::SeqFeatureI); print "export prob is ", ($ft->each_tag_value('export_prob'))[0] ,"\n"; This the second implentation of Bio::SimpleAnalysisI which hopefully will make it easier to write wrappers on various services. This class uses a web resource and therefore inherits from Bio::WebAgent. =back =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::Tools::Analysis::SimpleAnalysisBase>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Analysis::Protein::Mitoprot; use vars qw($FLOAT); use strict; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw(GET); use Bio::SeqFeature::Generic; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); $FLOAT = '[+-]?\d*\.\d*'; my $URL = 'http://ihg.gsf.de/cgi-bin/paolo/mitofilter?'; my %STATUS = map { $_ => 1 } qw(CREATED COMPLETED TERMINATED_BY_ERROR); my $MIN_LEN = 60; #min len for protein analysis my $ANALYSIS_NAME = "Mitoprot"; my $ANALYSIS_SPEC = { 'name' => 'Mitoprot', 'type' => 'Protein', 'version' => '1.0a4', 'supplier' => 'Munich Information Center for ProteinSequences', 'description' => 'mitochondrial sig seq prediction', }; my $INPUT_SPEC = [ { 'mandatory' => 'true', 'type' => 'Bio::PrimarySeqI', 'name' => 'seq', #value must be name of method used to set value }, ]; my $RESULT_SPEC = { '' => 'raw text results', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', 'all' => 'hash of results', }; ### unique to this module ## =head2 result Usage : $job->result (...) Returns : a result created by running an analysis Args : various The method returns a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data. This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags =item 'Bio::SeqFeatureI' The argument string defines the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. Feature primary tag is "SigSeq". Feature tags are input_length , basic_aas, acidic_aas, export_prob, charge, cleavage_site, method. =item 'parsed' hash references of parsed results { input_length =E<gt>, basic_aas=E<gt>, acidic_aas=E<gt>, export_prob=E<gt>, charge=E<gt>, cleavage_site=E<gt>}. =back =cut sub result { my ($self,$value) = @_; #make sec feat of above threshold scores # my @sig_pdctns; my @fts; if ($value ) { my $result = IO::String->new($self->{'_result'}); my %results; while (my $line = <$result>) { #make array of all scores or threshold depending on $value next unless $line =~ /\d/ || $line =~ /^Cle/; if ($line =~ /^Net[^+\-\d]+ # Net, then anything except +,- or digit ((\+|-)?\d+)/x) #then get charge with optional + or - { $results{'charge'} = $1; } elsif ($line =~ /^Input[^\d]+(\d+)/ ) { $results{'input_length'} = $1; } elsif ($line =~ /basic[^\d]+(\d+)$/ ) { $results{'basic_aas'} = $1; } elsif ($line =~ /acidic[^\d]+(\d+)$/) { $results{'acidic_aas'} = $1; } elsif ($line =~ /^Cleavage[^\d]+(\d+)$/) { $results{'cleavage_site'} = $1; } elsif ($line =~ /^Cleavage/) { $results{'cleavage_site'} = 'not predictable'; } elsif ($line =~ /^of export[^\d]+((0|1)\.\d+)$/) { $results{'export_prob'} = $1; } } if ($value eq 'Bio::SeqFeatureI') { push @fts, Bio::SeqFeature::Generic->new ( -start => 1, -end => ($results{'cleavage_site'} =~ /^\d+$/)?$results{'cleavage_site'}:$self->seq->length, -source => 'Mitoprot', -primary => 'Region', -tag =>{ export_prob => $results{'export_prob'}, charge => $results{'charge'}, basic_aas => $results{'basic_aas'}, acid_aas => $results{'acidic_aas'}, region_name => 'Transit_peptide', method => 'MitoProt', cleavage_site => $results{'cleavage_site'}, }, ); return @fts; #return Bioseqfeature array } ## convert parsed data into a meta array format else { return \%results; # hash based results ref } } return $self->{'_result'}; } sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} =$ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} =$INPUT_SPEC; $self->{'_RESULT_SPEC'} =$RESULT_SPEC; $self->{'_ANALYSIS_NAME'} =$ANALYSIS_SPEC->{'name'}; return $self; } sub _process_arguments { #extra checking for sequence length #mitoprot specific argument testing my ($self, $args) = @_; #use base checking for existence of mandatory fields $self->SUPER::_process_arguments($args) ; #then check specifics $self->throw ("1st_aa must be M") if $self->seq->subseq(1,1) !~ /M/i; $self->throw ("sequence must be at least 15aa long") if $self->seq->length< 15; return; } sub _run { #request submitted by get not by post my $self = shift; $self->delay(1); $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $url = $self->url . "seq=".lc($self->seq->seq). "&seqnam="; my $request = GET $url; my $content = $self->request($request); my $text = $content->content; #1st reponse #remove html stuff $text =~ s/.*<PRE>(.*)<\/PRE>.*/$1/s; $text =~ s/<[^>]+>//sg; $self->status('COMPLETED') if $text ne '' && $self->seq->length > $MIN_LEN; $self->{'_result'} = $text; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/NetPhos.pm�����������������������������������������������000444��000765��000024�� 20235�12254227335� 22415� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Analysis::Protein::NetPhos # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::NetPhos - a wrapper around NetPhos server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::NetPhos; my $seq; # a Bio::PrimarySeqI object my $threshold = "0.90"; my $netphos = Bio::Tools::Analysis::Protein::NetPhos->new ( -seq => $seq, -threshold => $threshold ); # run NetPhos prediction on a sequence my $netphos->run(); # alternatively you can say $netphos->seq($seq)->threshold($threshold)->run; die "Could not get a result" unless $netphos->status =~ /^COMPLETED/; print $netphos->result; # print raw prediction to STDOUT foreach my $feat ( $netphos->result('Bio::SeqFeatureI') ) { # do something to SeqFeature # e.g. print as GFF print $feat->gff_string, "\n"; # or store within the sequence - if it is a Bio::RichSeqI $seq->add_SeqFeature($feat) } =head1 DESCRIPTION This class is wrapper around the NetPhos 2.0 server which produces neural network predictions for serine, threonine and tyrosine phosphorylation sites in eukaryotic proteins. See L<http://www.cbs.dtu.dk/services/NetPhos/>. This the first implentation of Bio::SimpleAnalysisI which hopefully will make it easier to write wrappers on various services. This class uses a web resource and therefore inherits from Bio::WebAgent. =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, Heikki Lehvaslaiho, heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Analysis::Protein::NetPhos; use vars qw($FLOAT); use strict; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw (POST); use Bio::SeqFeature::Generic; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); $FLOAT = '[+-]?\d*\.\d*'; my $URL = 'http://www.cbs.dtu.dk/cgi-bin/nph-webface'; my $ANALYSIS_SPEC = { 'name' => 'NetPhos', 'type' => 'Protein', 'version' => '2.0', 'supplier' => 'Center for Biological Sequence Analysis, Technical University of Denmark', 'description' => 'Prediction of serine, threonine and tyrosine phosphorylation sites in eukaryotic proteins', }; my $INPUT_SPEC = [ { 'mandatory' => 'true', 'type' => 'Bio::PrimarySeqI', 'name' => 'seq', }, { 'mandatory' => 'false', 'type' => 'float', 'name' => 'threshold', 'default' => 0.8, } ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeeature::Generic', 'raw' => 'Array of [ position, score, residue ]' }; =head2 result Name : result Usage : $job->result (...) Returns : a result created by running an analysis Args : none (but an implementation may choose to add arguments for instructions how to process the raw result) The method returns a scalar representing a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data (or both, depending on the implementation). This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags =item 'Bio::SeqFeatureI' The argument string defined the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. =item anything else Array of array references of [ position, score, residue]. =back =cut sub result { my ($self,$value) = @_; my @predictions; my @fts; if ($value ) { my $result = IO::String->new($self->{'_result'}); while (<$result>) { next if /^____/; /^\S+ +(\d+) +\w+ +(0\.\d+) +.([STY])/; next unless $3 and $2 > $self->threshold; push @predictions, [$1, $2, $3]; } if ($value eq 'Bio::SeqFeatureI') { foreach (@predictions) { push @fts, Bio::SeqFeature::Generic->new (-start => $_->[0], -end => $_->[0] , -source => 'NetPhos', -primary => 'Site', -tag => { score => $_->[1], residue => $_->[2] }); } return @fts; } return \@predictions; } return $self->{'_result'}; } =head2 threshold Usage : $job->threshold(...) Returns : The significance threshold of a prediction Args : None (retrieves value) or a value beween 0 and 1. Purpose : Get/setter of the threshold to be sumitted for analysis. =cut sub threshold { my ($self,$value) = @_; if( defined $value) { if ( $value !~ /$FLOAT/ or $value < 0 or $value > 1 ) { $self->throw("I need a value between 0 and 1 , not [". $value. "]") } $self->{'_threshold'} = $value; return $self; } return $self->{'_threshold'} || $self->input_spec->[1]{'default'} ; } sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} =$ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} =$INPUT_SPEC; $self->{'_RESULT_SPEC'} =$RESULT_SPEC; $self->{'_ANALYSIS_NAME'} =$ANALYSIS_SPEC->{name}; return $self; } sub _run { my $self = shift; # format the sequence into fasta my $seq_fasta; my $stringfh = IO::String->new($seq_fasta); my $seqout = Bio::SeqIO->new(-fh => $stringfh, -format => 'fasta'); $seqout->write_seq($self->seq); $self->debug($seq_fasta); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $request = POST $self->url, Content_Type => 'form-data', Content => [configfile => '/usr/opt/www/pub/CBS/services/NetPhos-2.0/NetPhos.cf', SEQPASTE => $seq_fasta]; my $content = $self->request($request); my $text = $content->content; my ($result_url) = $text =~ /follow <a href="(.*?)"/; return 0 unless $result_url; $self->debug("url is $result_url\n\n"); my $ua2 = $self->clone; my $content2 = $ua2->request(POST $result_url); my $ua3 = $self->clone; $result_url =~ s/&.*//; $self->debug("final result url is $result_url\n"); my $content3 = $ua3->request(POST $result_url); #print Dumper $content3; my $response = $content3->content; $response =~ s/.*<pre>(.*)<\/pre>.*/$1/s; $response =~ s/<.*?>//gs; $self->{'_result'} = $response; $self->status('COMPLETED') if $response ne ''; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/Scansite.pm����������������������������������������������000444��000765��000024�� 27134�12254227337� 22615� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Analysis::Protein::Scansite # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Richard Adams <richard.adams@ed.ac.uk> # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::Scansite - a wrapper around the Scansite server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::Scansite; my $seq; # a Bio::PrimarySeqI object my $tool = Bio::Tools::Analysis::Protein::Scansite->new ( -seq => $seq->primary_seq ); # run Scansite prediction on a sequence $tool->run(); # alternatively you can say $tool->seq($seq->primary_seq)->run; die "Could not get a result" unless $tool->status =~ /^COMPLETED/; print $tool->result; # print raw prediction to STDOUT foreach my $feat ( $tool->result('Bio::SeqFeatureI') ) { # do something to SeqFeature # e.g. print as GFF print $feat->gff_string, "\n"; # or store within the sequence - if it is a Bio::RichSeqI $seq->add_SeqFeature($feat); } =head1 DESCRIPTION This class is a wrapper around the Scansite 2.0 server which produces predictions for serine, threonine and tyrosine phosphorylation sites in eukaryotic proteins. At present this is a basic wrapper for the "Scan protein by input sequence" functionality, which takes a sequence and searches for motifs, with the option to select the search stringency. At present, searches for specific phosphorylation sites are not supported; all predicted sites are returned. =head2 Return formats The Scansite results can be obtained in several formats: =over 3 =item 1. By calling my $res = $tool->result(''); $res holds a string of the predicted sites in tabular format. =item 2. By calling my $data_ref = $tool->result('value') $data_ref is a reference to an array of hashes. Each element in the array represents a predicted phosphorylation site. The hash keys are the names of the data fields,i.e., 'motif' => 'Casn_Kin1' # name of kinase 'percentile' => 0.155 # see Scansite docs 'position' => 9 # position in protein 'protein' => 'A1' # protein id 'score' => 0.3696 # see Scansite docs 'sequence' => 'ASYFDTASYFSADAT' # sequence surrounding site 'site' => 'S9' # phosphorylated residue 'zscore' => '-3.110' # see Scansite docs =item 3. By calling my @fts = $tool->Result('Bio::SeqFeatureI'); which returns an array of L<Bio::SeqFeatureI> compliant objects with primary tag value 'Site' and tag names of 'motif', 'score', 'sequence', 'zscore' as above. =back See L<http://scansite.mit.edu/>. This inherits Bio::SimpleAnalysisI which hopefully makes it easier to write wrappers on various services. This class uses a web resource and therefore inherits from L<Bio::WebAgent>. =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Analysis::Protein::Scansite; use vars qw($FLOAT @STRINGENCY); use strict; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw(POST); use Bio::SeqFeature::Generic; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); $FLOAT = '[+-]?\d*\.\d*'; @STRINGENCY = qw(High Medium Low); my $URL = 'http://scansite.mit.edu/cgi-bin/motifscan_seq'; my $ANALYSIS_SPEC = { 'name' => 'Scansite', 'type' => 'Protein', 'version' => '2.0', 'supplier' => 'Massachusetts Institute of Technology', 'description' => 'Prediction of serine, threonine and tyrosine phosphorylation sites in eukaryotic proteins', }; my $INPUT_SPEC = [ { 'mandatory' => 'true', 'type' => 'Bio::PrimarySeqI', 'name' => 'seq', }, { 'mandatory' => 'false', 'type' => 'text', 'name' => 'protein_id', 'default' => 'unnamed', }, { 'mandatory' => 'false', 'type' => 'text', 'name' => 'stringency', 'default' => 'High', }, ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', 'raw' => 'Array of {motif=>, percentile=>, position=>, protein=>, score=>, site=>, zscore=> sequence=> }', }; =head2 result Name : result Usage : $job->result (...) Returns : a result created by running an analysis Args : none (but an implementation may choose to add arguments for instructions how to process the raw result) The method returns a scalar representing a result of an executed job. If the job was terminated by an error, the result may contain an error message instead of the real data. This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags =item 'Bio::SeqFeatureI' The argument string defined the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. =item 'parsed' Returns a reference to an array of hashes containing the data of one phosphorylation site prediction. Key values are: motif, percentile, position, protein, score, site, zscore, sequence. =back =cut sub result { my ($self,$value) = @_; if( !exists($self->{'_result'}) || $self->status ne 'COMPLETED'){ $self->throw("Cannot get results, analysis not run!"); } my @fts; if ($value ) { if ($value eq 'Bio::SeqFeatureI') { for my $hit (@{$self->{'_parsed'}}) { push @fts, Bio::SeqFeature::Generic->new( -start => $hit->{'position'}, -end => $hit->{'position'}, -primary_tag => 'Site', -source => 'Scansite', -tag => { score => $hit->{'score'}, zscore => $hit->{'zscore'}, motif => $hit->{'motif'}, site => $hit->{'site'}, sequence => $hit->{'sequence'}, }, ); } return @fts; } elsif ($value eq 'meta') { $self->throw("No meta sequences available in this analysis!"); } ## else get here return $self->{'_parsed'}; } return $self->{'_result'}; } =head2 stringency Usage : $job->stringency(...) Returns : The significance stringency of a prediction Args : None (retrieves value) or 'High', 'Medium' or 'Low'. Purpose : Get/setter of the stringency to be sumitted for analysis. =cut sub stringency { my ($self,$value) = @_; if( $value) { if (! grep{$_=~ /$value/i}@STRINGENCY ) { $self->throw("I need a stringency of [". join " ", @STRINGENCY . "], not [$value]"); } $self->{'_stringency'} = $value; return $self; } return $self->{'_stringency'} || $self->input_spec->[2]{'default'} ; } =head2 protein_id Usage : $job->protein_id(...) Returns : The sequence id of the protein or 'unnamed' if not set. Args : None Purpose : Getter of the seq_id. Returns the display_id of the sequence object. =cut sub protein_id { my $self = shift; return defined ($self->seq())? $self->seq->display_id() : $self->input_spec->[1]{'default'}; } sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} = $ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} = $INPUT_SPEC; $self->{'_RESULT_SPEC'} = $RESULT_SPEC; $self->{'_ANALYSIS_NAME'} = $ANALYSIS_SPEC->{'name'}; return $self; } sub _run { my $self = shift; # format the sequence into fasta $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $request = POST $self->url, Content => [sequence => $self->seq->seq(), protein_id => $self->protein_id(), motif_option => 'all', motifs => '', motif_groups => '', stringency => $self->stringency(), #domain_flag => '', submit => "Submit Request", ]; ## raw html report, my $content = $self->request($request); my $text = $content->content; ##access result data from tag in html my @parsed_Results = (); my @unwantedParams = qw(db source class); my @results = split /sitestats\.phtml\?/, $text; shift @results; ##this module generates 'parsed' output directly from html, ## avoids having toparse twice. for my $hit (@results) { ## get results string my ($res) = $hit =~ /^(.+?)"/; #get key value pairs my %params = $res =~/(\w+)=([^&]+)/g; ##remove unwanted data from hash map{delete $params{$_}} @unwantedParams; push @parsed_Results, \%params; } ## now generate text output in table format my $out_Str = ''; $out_Str .= $self->_make_header(\@parsed_Results); $out_Str .= $self->_add_data(\@parsed_Results); $self->{'_result'} = $out_Str; $self->{'_parsed'} = \@parsed_Results; ## is successsful if there are results or if there are no results and ## this beacuse there are no matches, not because of parsing errors etc. $self->status('COMPLETED') if $text ne '' && (scalar @results > 0 || (scalar @results == 0 && $text =~/No sites found/)); if ($text =~ /server\s+error/i) { $self->throw("Internal server error:\n\n $text"); return; } } sub _process_arguments { # extra checking for sequence length # mitoprot specific argument testing my ($self, $args) = @_; #use base checking for existence of mandatory fields $self->SUPER::_process_arguments($args); # specific requirements $self->throw("Sequence must be > 15 amino acids long!") if $self->seq->length < 15; $self->throw("Sequence must be protein") unless $self->seq->alphabet() eq 'protein'; } sub _make_header { my ($self, $res) = @_; my $header = ''; for my $k (sort keys %{$res->[0]} ){ next if $k eq 'sequence'; $header .= $k; $header .= ' 'x(12 -length($k)); } $header .= "sequence\n\n"; return $header; } sub _add_data { my ($self, $res) = @_; my $outstr = ''; for my $hit (@$res) { for my $k (sort keys %$hit ){ next if $k eq 'sequence'; $outstr .= $hit->{$k}; $outstr .= ' 'x(12 - length($hit->{$k})); } $outstr .= $hit->{'sequence'}. "\n" if $hit->{'sequence'}; } return $outstr; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Analysis/Protein/Sopma.pm�������������������������������������������������000444��000765��000024�� 36102�12254227326� 22114� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: Sopma.pm,v 1.0 2003/07/ 11 # # BioPerl module for Bio::Tools::Analysis::Protein::Sopma # # Copyright Richard Adams # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Analysis::Protein::Sopma - a wrapper around the Sopma protein secondary structure prediction server =head1 SYNOPSIS use Bio::Tools::Analysis::Protein::Sopma; #get a Bio::Seq or Bio::PrimarySeq my $seq; my $sopma = Bio::Tools::Analysis::Protein::Sopma->new (-seq=>$seq, states=>4); $sopma->run; print $sopma->result;# #raw text to standard error =head1 DESCRIPTION A module to remotely retrieve predictions of protein secondary structure. Each residue in the protein receives a score representing the likelihood of existing in each of four different states (helix, coil, turn or sheet), e.g., my $analysis_object = Bio::Tools::SimpleAnalysis::Protein::Sopma->new ( -seq => $seq, -states => 4, -window_width => 15, ); creates a new object. Compulsory argument -seq. Optional arguments -states, -window_width,-similarity_threshold. These arguments can also be set by direct methods , e.g., $analysis_object->states(4); $analysis_object->run; submits the query to the server and obtains raw text output. Given an amino acid sequence the results can be obtained in 4 formats, determined by the argument to the result method: =over 4 =item 1 The raw text of the program output. my $rawdata = $analysis_object->result; =item 2 A reference to an array of hashes of scores for each state and the assigned state. my $data_ref = $analysis_object->result('parsed'); print "score for helix at residue 2 is $data_ref->[1]{'helix'}\n"; print "predicted struc at residue 2 is $data_ref->[1]{'struc}\n"; Hash keys are 'helix', 'struc', 'sheet', 'coil', 'turn'. =item 3 An array of Bio::SeqFeature::Generic objects where each feature is a predicted unit of secondary structure. Only stretches of helix/sheet predictions for longer than 4 residues are defined as helices/sheets. my @fts = $analysis_object->result(Bio::SeqFeatureI); for my $ft (@fts) { print " From ", $ft->start, " to ",$ft->end, " struc: " , ($ft->each_tag_value('type'))[0] ,"\n"; } =item 4 A Bio::Seq::Meta::Array implementing sequence. This is a Bio::Seq object that can also hold data about each residue in the sequence. In this case, the sequence can be associated with a arrays of Sopma prediction scores. e.g., my $meta_sequence = $analysis_object->result('meta'); print "scores from residues 10 -20 are ", $meta_sequence->named_submeta_text("Sopma_helix",10,20), "\n"; Meta sequence names are : Sopma_helix, Sopma_sheet, Sopma_turn, Sopma_coil, Sopma_struc, representing the scores for each residue. Many methods common to all analyses are inherited from Bio::Tools::Analysis::SimpleAnalysisBase. =back =head1 SEE ALSO L<Bio::SimpleAnalysisI>, L<Bio::Tools::Analysis::SimpleAnalysisBase> L<Bio::Seq::Meta::Array>, L<Bio::WebAgent> =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHORS Richard Adams, Richard.Adams@ed.ac.uk, =head1 APPENDIX =cut use strict; package Bio::Tools::Analysis::Protein::Sopma; use IO::String; use Bio::SeqIO; use HTTP::Request::Common qw (POST); use Bio::SeqFeature::Generic; use Bio::Seq::Meta::Array; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); #extends array for 2struc. my $URL = 'http://npsa-pbil.ibcp.fr/cgi-bin/secpred_sopma.pl'; my $ANALYSIS_NAME= 'Sopma'; my $ANALYSIS_SPEC= {name => 'Sopma', type => 'Protein'}; my $INPUT_SPEC = [ {mandatory=>'true', type => 'Bio::PrimarySeqI', 'name' => 'seq', }, {mandatory =>'false', type => 'integer', name => 'similarity_threshold', default => 8, }, {mandatory =>'false', type => 'integer', name => 'window_width', default => 17, }, {mandatory =>'false', type => 'integer', name => 'states', default => 4, }, ]; my $RESULT_SPEC = { '' => 'bulk', # same as undef raw => '[{struc=>, helix=>, turn=>, coil=>, sheet=>}]', meta => 'Bio::Seq::Meta::Array object', 'Bio::SeqFeatureI' => 'ARRAY of Bio::SeqFeature::Generic', }; use constant MIN_STRUC_LEN => 3; =head2 similarity_threshold Useage : $job->similarity_threshold(...) Returns : The similarity threshold used in the analysis Args : None (retrieves value) or an integer (default = 8) that sets the similarity threshold . This method gets/sets the similarity threshold for the prediction. =cut sub similarity_threshold { my ($self, $value) = @_; if ($value) { $self->throw ("similarity_threshold must be integer") unless $value =~ /^\d+$/; $self->{'_similarity_threshold'} = $value; } $self->{'_similarity_threshold'} ||= $self->input_spec->[1]{'default'}; return $self->{'_similarity_threshold'}; } =head2 window_width Usage : $job->window_width(...) Returns : The window width used in the analysis Args : None (retrieves value) or an integer (default = 17) that sets the window width. This method gets/sets the window width for the prediction, . If attempted to set longer than the sequence, warns of error. =cut sub window_width { my ($self, $value) = @_; if ($value) { $self->throw ("window_width must be integer") unless $value =~ /^\d+$/; $self->{'_window_width'} = $value; } $self->{'_window_width'} ||= $self->input_spec->[2]{'default'}; $self->warn ("window width longer than sequence!") unless $self->{'_window_width'} < $self->seq->length; return $self->{'_window_width'}; } =head2 states Usage : $job->states(...) Returns : The number of secondary structure prediction states Args : None (retrieves value) or either '3' or '4' to set prior to running analysis. This method gets/sets the number of states for the prediction, either 3 or 4 (includes turns). =cut sub states { my ($self, $value) = @_; if ($value) { $self->throw ("number of states must be 3 or 4") unless $value == 3 or $value ==4; $self->{'_states'} = $value; } $self->{'_states'} ||= $self->input_spec->[3]{'default'}; return $self->{'_states'}; } =head2 result Usage : $job->result (...) Returns : a result created by running an analysis Args : various The method returns a result of an executed job. If the job was terminated by an error the result may contain an error message instead of the real data. This implementation returns differently processed data depending on argument: =over 3 =item undef Returns the raw ASCII data stream but without HTML tags =item 'Bio::SeqFeatureI' The argument string defines the type of bioperl objects returned in an array. The objects are L<Bio::SeqFeature::Generic>. Feature primary tag is "2ary". Feature tags are "type" (which can be helix, sheet coil, or turn if 4 state prediction requested) "method" (Sopma) =item 'parsed' Array of hash references of scores/structure assignations { helix =E<gt> , sheet =E<gt> , coil =E<gt> , struc=E<gt>}. =item 'all' A Bio::Seq::Meta::Array object. Scores can be accessed using methods from this class. Meta sequence names are Sopma_helix, Sopma_sheet, Sopma_coil, Sopma_turn (if defined), and Sopma_struc. =back =cut sub result { my ($self,$value, $run_id) = @_; my @score; my @fts; if ($value ) { if (!exists($self->{'_parsed'} )) { my $result = IO::String->new($self->{'_result'}); while (my $line = <$result>) { next unless $line =~ /^[HCET]\s/; # or for sopma/hnn /^[A-Z]\s/ $line =~/^([A-Z])\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/; # or for so push @score, { struc => $1, helix => $2, sheet => $3, coil => $5, }; #include turn if 4states are requested $score[$#score]{'turn'} = $4 if $self->states == 4; #can optimize by duplicating code here } $self->{'_parsed'} = \@score; } if ($value eq 'Bio::SeqFeatureI') { $self->_get_2ary_coords(); for my $type (keys %{$self->{'_parsed_coords'}} ) { next if $type =~ /\w{2,}/; #if not H,C,E or T ## these 2 are added to distinguish features on same ## sequence run with different params my $tag_hash = { type => $type, method => $self->analysis_name, }; $self->_add_params_to_result($tag_hash); ## now make feature object for my $loc (@{$self->{'_parsed_coords'}{$type}} ) { push @fts, Bio::SeqFeature::Generic->new (-start => $loc->{'start'}, -end => $loc->{'end'}, -source => 'Sopma', -primary => 'Domain', -tag => $tag_hash, ); } #end of array of strucs of type } # end of all 2nd struc elements delete $self->{'_parsed_coords'}; #remove temp data return @fts; } #endif BioSeqFeature elsif ($value eq 'meta') { #1st of all make 3 or 4 arrays of scores for each type from column data my %type_scores; for my $aa (@{$self->{'_parsed'}}) { for my $type (qw(struc helix sheet coil)) { push @{$type_scores{$type}}, $aa->{$type}; } push @{$type_scores{'turn'}}, $aa->{'turn'} if exists $aa->{'turn'}; } ## convert to meta sequence array ## if (!$self->seq->isa("Bio::Seq::Meta::Array")) { bless ($self->seq, "Bio::Seq::Meta::Array"); } $self->seq->isa("Bio::Seq::MetaI") || $self->throw("$self is not a Bio::Seq::MetaI"); $Bio::Seq::Meta::Array::DEFAULT_NAME = 'Sopma_struc'; for my $struc_type (keys %type_scores) { my $meta_name = "Sopma". "_" . "$struc_type"; if ($run_id) { $meta_name .= "|$run_id"; } my @meta = map{$_->{$struc_type}} @{$self->{'_parsed'}}; if (grep{$_ eq $meta_name}$self->seq->meta_names >0) { $self->warn ("$meta_name already exists , not overwriting!"); next; } $self->seq->named_meta($meta_name,\@meta ); } # return seq array object implementing meta sequence # return $self->seq; } ## else return parsed data if $value is defined else { return $self->{'_parsed'}; } } #endif ($value) #return raw result if no return format stated return $self->{'_result'}; } sub _init { my $self = shift; $self->url($URL); $self->{'_ANALYSIS_SPEC'} = $ANALYSIS_SPEC; $self->{'_INPUT_SPEC'} = $INPUT_SPEC; $self->{'_RESULT_SPEC'} = $RESULT_SPEC; $self->{'_ANALYSIS_NAME'} = $ANALYSIS_NAME; return $self; } sub _get_2ary_coords { #helper sub for result; ##extracts runs of structure > MIN_STRUC_LENresidues or less if Turn: #i.e., helical prediction for 1 residue isn't very meaningful... ## and poulates array of hashes with start/end values. ##keys of $Result are 'H' 'T' 'C' 'E'. my ($self) = @_; my @prot = @{$self->{'_parsed'}}; my %Result; for (my $index = 0; $index <= $#prot; $index++) { my $type = $prot[$index]{'struc'}; next unless $type && $type =~ /[HTCE]/; my $length = 1; for (my $j = $index + 1; $j <= $#prot; $j++) { my $test = $prot[$j]; if ($test->{'struc'} eq $type) { $length++; } elsif ( $length > MIN_STRUC_LEN || ($length <= MIN_STRUC_LEN && $type eq 'T') ) { push @{$Result{$type}}, {start => $index + 1 , end => $j}; $index += $length -1; last; } else { $index += $length - 1; last; } } } $self->{'_parsed_coords'} = \%Result; #temp assignment } sub _run { my $self = shift; $self->delay(1); # delay repeated calls by default by 3 sec, set delay() to change $self->sleep; $self->status('TERMINATED_BY_ERROR'); my $request = POST 'http://npsa-pbil.ibcp.fr/cgi-bin/secpred_sopma.pl', Content_Type => 'form-data', Content => [title => "", notice => $self->seq->seq, ali_width => 70, states => $self->states, threshold => $self->similarity_threshold , width => $self->window_width, ]; my $text = $self->request($request)->content; return $self unless $text; #### get text only version of results ## my ($next) = $text =~ /Prediction.*?=(.*?)>/; my $out = "http://npsa-pbil.ibcp.fr/". "$next"; my $req2 = HTTP::Request->new(GET=>$out); my $resp2 = $self->request ($req2); $self->{'_result'} = $resp2->content; $self->status('COMPLETED') if $resp2 ne ''; return $self; } sub _add_params_to_result{ ## called when making Seqfeature objects my ($self, $tag_hash) = @_; my $hash; ## adds input parameter values to SeqFeatureI results where multiple ## parameter values are possible. Only adds value if not default. map{$hash->{$_->{'name'}} = $_}@{$self->input_spec()}; for my $p (keys %$hash) { if (!ref($self->$p) && $self->$p ne $hash->{$p}{'default'}) { $tag_hash->{$p} = $self->$p; } } } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/EMBOSS��������������������������������������������������������������������000755��000765��000024�� 0�12254227333� 16103� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/EMBOSS/Palindrome.pm������������������������������������������������������000444��000765��000024�� 12606�12254227333� 20715� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::EMBOSS::Palindrome # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::EMBOSS::Palindrome - parse EMBOSS palindrome output =head1 SYNOPSIS # a simple script to turn palindrome output into GFF3 use Bio::Tools::EMBOSS::Palindrome; use Bio::Tools::GFF; my $parser = Bio::Tools::EMBOSS::Palindrome->new(-file => $filename); my $out = Bio::Tools::GFF->new(-gff_version => 3, -file => ">$filename.gff"); while( my $seq = $parser->next_seq ) { for my $feat ( $seq->get_SeqFeatures ) { $out->write_feature($feat); } } =head1 DESCRIPTION This is a parser for the EMBOSS tool 'palindrome'. It will produce a L<Bio::Seq> object for each sequence analyzed. The sequence will be empty (but will be of the correct length) and will have attached to it L<Bio::SeqFeature::FeaturePair> objects which wil =head2 FUTURE WORK It may be consolidated into another framework at a later time, but for the time being it will stay a separate modules. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::EMBOSS::Palindrome; use vars qw($DEFAULT_SOURCETAG); use strict; use Bio::SeqFeature::FeaturePair; use Bio::SeqFeature::Generic; use base qw(Bio::Root::IO); $DEFAULT_SOURCETAG = 'palindrome'; =head2 new Title : new Usage : my $obj = Bio::Tools::EMBOSS::Palindrome->new(); Function: Builds a new Bio::Tools::EMBOSS::Palindrome object Returns : an instance of Bio::Tools::EMBOSS::Palindrome Args : -file/-fh => a filename or filehandle for initializing the parser =cut =head2 next_seq Title : next_seq Usage : my $seq = $parser->next_seq; Function: Get the next feature set from the Returns : L<Bio::SeqI> object Args : none =cut sub next_seq { my ($self) = @_; my (%searching, $seq,$state); my $source = $self->source_tag; $state = 0; while(defined($_ = $self->_readline)) { if( /^\s+$/ ) { next; } elsif( /^Palindromes\s+of\s*:\s+(\S+)/o ) { $state = 0; if( $seq ) { $self->_pushback($_); return $seq; } $seq = Bio::Seq->new(-display_id => $1); # now get ready to store for the next record $searching{'-seq_id'} = $1; } elsif( /^Sequence\s+length\s+is\s*:\s+(\d+)/o ) { $seq->length($1); $searching{'-tag'}->{'seqlength'} = $1; } elsif( /^(Start|End)\s+at\s+position\s*:\s+(\d+)/ ) { $searching{'-tag'}->{lc($1)} = $2; } elsif( m/^(Maximum|Minimum)\s+length\s+of\s+Palindromes\s+ is\s*:\s+(\d+)/ox) { $searching{'-tag'}->{lc($1).'_length'} = $2; } elsif( /^(Maximum\s+gap)\s+between\s+elements\s+is\s*:\s+(\d+)/o ) { $searching{'-tag'}->{lc($1)} = $2; } elsif( m/^Number\s+of\s+mismatches\s+allowed\s+ in\s+Palindrome\s*:\s+(\d+)/ox ) { $searching{'-tag'}->{'allowed_mismatches'} = $1; } elsif( /^Palindromes:/o ) { $state = 1; } elsif( $state == 1 ) { my $feature = Bio::SeqFeature::FeaturePair->new (-primary_tag => 'similarity', -source_tag => $source); for(my $i = 0; $i < 3; $i++ ) { if ($i != 1) { if( /^(\d+)\s+(\S+)\s+(\d+)/o ) { my ($start,$match,$end) = ($1,$2,$3); my $type = $i == 0 ? 'feature1' : 'feature2'; ($start,$end) = sort { $a <=> $b } ($start,$end); $feature->$type( Bio::SeqFeature::Generic->new (%searching, -start => $start, -end => $end, -strand => $i == 0 ? 1 : -1, -primary_tag => 'similarity', -source_tag => $source) ); } else { chomp; warn("Out of sync, line did not match:'$_'\n"); } } $_ = $self->_readline; } $seq->add_SeqFeature($feature); } } return $seq; } =head2 source_tag Title : source_tag Usage : $obj->source_tag($newval) Function: Get/Set Source Tag ('palindrome') by default Returns : value of source_tag (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub source_tag{ my $self = shift; return $self->{'source_tag'} = shift if @_; return $self->{'source_tag'} || $DEFAULT_SOURCETAG; } 1; ��������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/HMMER���������������������������������������������������������������������000755��000765��000024�� 0�12254227335� 15765� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/HMMER/Domain.pm�����������������������������������������������������������000444��000765��000024�� 14435�12254227321� 17711� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::HMMER::Domain # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::HMMER::Domain - One particular domain hit from HMMER =head1 SYNOPSIS Read the Bio::Tools::HMMER::Results docs =head1 DESCRIPTION A particular domain score. We reuse the Homol SeqFeature system here, so this inherits off Homol SeqFeature. As this code originally came from a separate project, there are some backward compatibility stuff provided to keep this working with old code. Don't forget this inherits off Bio::SeqFeature, so all your usual nice start/end/score stuff is ready for use. =head1 CONTACT Ewan Birney, birney@ebi.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut #' package Bio::Tools::HMMER::Domain; use Bio::SeqFeature::Generic; use strict; use base qw(Bio::SeqFeature::FeaturePair); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'alignlines'} = []; my $hmmf1 = Bio::SeqFeature::Generic->new(@args); my $hmmf2 = Bio::SeqFeature::Generic->new(@args); $self->feature1($hmmf1); $self->feature2($hmmf2); return $self; } =head2 add_alignment_line Title : add_alignment_line Usage : $domain->add_alignment_line($line_from_hmmer_output); Function: add an alignment line to this Domain object Returns : Nothing Args : scalar Adds an alignment line, mainly for storing the HMMER alignments as flat text which can be reguritated. You're right. This is *not nice* and not the right way to do it. C'est la vie. =cut sub add_alignment_line { my $self = shift; my $line = shift; push(@{$self->{'alignlines'}},$line); } =head2 each_alignment_line Title : each_alignment_line Usage : foreach $line ( $domain->each_alignment_line ) Function: reguritates the alignment lines as they were fed in. only useful realistically for printing. Example : Returns : Args : None =cut sub each_alignment_line { my $self = shift; return @{$self->{'alignlines'}}; } =head2 get_nse Title : get_nse Usage : $domain->get_nse() Function: Provides a seqname/start-end format, useful for unique keys. nse stands for name-start-end It is used a lot in Pfam Example : Returns : A string Args : Optional separator 1 and separator 2 (default / and -) =cut sub get_nse { my $self = shift; my $sep1 = shift; my $sep2 = shift; if( !defined $sep2 ) { $sep2 = "-"; } if( !defined $sep1 ) { $sep1 = "/"; } return sprintf("%s%s%d%s%d",$self->seq_id,$sep1,$self->start,$sep2,$self->end); } # =head2 start_seq # Title : start_seq # Usage : Backward compatibility with old HMMER modules. # should use $domain->start # Function: # Example : # Returns : # Args : # =cut sub start_seq { my $self = shift; my $start = shift; $self->warn("Using old domain->start_seq. Should use domain->start"); return $self->start($start); } # =head2 end_seq # Title : end_seq # Usage : Backward compatibility with old HMMER modules. # should use $domain->end # Function: # Example : # Returns : # Args : # =cut sub end_seq { my $self = shift; my $end = shift; $self->warn("Using old domain->end_seq. Should use domain->end"); return $self->end($end); } # =head2 start_hmm # Title : start_hmm # Usage : Backward compatibility with old HMMER modules, and # for convience. Equivalent to $self->homol_SeqFeature->start # Function: # Example : # Returns : # Args : # =cut sub start_hmm { my $self = shift; my $start = shift; $self->warn("Using old domain->start_hmm. Should use domain->hstart"); return $self->hstart($start); } # =head2 end_hmm # Title : end_hmm # Usage : Backward compatibility with old HMMER modules, and # for convience. Equivalent to $self->homol_SeqFeature->start # Function: # Example : # Returns : # Args : # =cut sub end_hmm { my $self = shift; my $end = shift; $self->warn("Using old domain->end_hmm. Should use domain->hend"); return $self->hend($end); } =head2 hmmacc Title : hmmacc Usage : $domain->hmmacc($newacc) Function: set get for HMM accession number. This is placed in the homol feature of the HMM Example : Returns : Args : =cut sub hmmacc{ my ($self,$acc) = @_; if( defined $acc ) { $self->feature2->add_tag_value('accession',$acc); } my @vals = $self->feature2->each_tag_value('accession'); return shift @vals; } =head2 hmmname Title : hmmname Usage : $domain->hmmname($newname) Function: set get for HMM accession number. This is placed in the homol feature of the HMM Example : Returns : Args : =cut sub hmmname { return shift->hseq_id(@_); } =head2 bits Title : bits Usage : Function: backward compatibility. Same as score Example : Returns : Args : =cut sub bits{ return shift->score(@_); } =head2 evalue Title : evalue Usage : Function: $domain->evalue($value); Example : Returns : Args : =cut sub evalue{ return shift->_tag_value('evalue',@_); } =head2 seqbits Title : seqbits Usage : Function: $domain->seqbits($value); Example : Returns : Args : =cut sub seqbits { return shift->_tag_value('seqbits',@_); } =head2 seq_range Title : seq_range Usage : Function: Throws an exception to catch scripts which need to upgrade Example : Returns : Args : =cut sub seq_range{ my ($self,@args) = @_; $self->throw("You have accessed an old method. Please recode your script to the new bioperl HMMER module"); } =head2 hmm_range Title : hmm_range Usage : Function: Throws an exception to catch scripts which need to upgrade Example : Returns : Args : =cut sub hmm_range{ my ($self,@args) = @_; $self->throw("You have accessed an old method. Please recode your script to the new bioperl HMMER module"); } 1; # says use was ok __END__ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/HMMER/Results.pm����������������������������������������������������������000444��000765��000024�� 52003�12254227335� 20141� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # Perl Module for HMMResults # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # #Copyright Genome Research Limited (1997). =head1 NAME Bio::Tools::HMMER::Results - Object representing HMMER output results =head1 SYNOPSIS # parse a hmmsearch file (can also parse a hmmpfam file) $res = Bio::Tools::HMMER::Results->new( -file => 'output.hmm' , -type => 'hmmsearch'); # print out the results for each sequence foreach $seq ( $res->each_Set ) { print "Sequence bit score is",$seq->bits,"\n"; foreach $domain ( $seq->each_Domain ) { print " Domain start ",$domain->start," end ",$domain->end, " score ",$domain->bits,"\n"; } } # new result object on a sequence/domain cutoff of # 25 bits sequence, 15 bits domain $newresult = $res->filter_on_cutoff(25,15); # alternative way of getting out all domains directly foreach $domain ( $res->each_Domain ) { print "Domain on ",$domain->seq_id," with score ", $domain->bits," evalue ",$domain->evalue,"\n"; } =head1 DESCRIPTION This object represents HMMER output, either from hmmsearch or hmmpfam. For hmmsearch, a series of HMMER::Set objects are made, one for each sequence, which have the the bits score for the object. For hmmpfam searches, only one Set object is made. These objects come from the original HMMResults modules used internally in Pfam, written by Ewan Birney. Ewan then converted them to BioPerl objects in 1999. That conversion is meant to be backwardly compatible, but may not be (caveat emptor). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney@ebi.ac.uk =head1 CONTRIBUTORS Jason Stajich, jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::HMMER::Results; use strict; use Bio::Tools::HMMER::Domain; use Bio::Tools::HMMER::Set; use Symbol; use base qw(Bio::Root::Root Bio::Root::IO Bio::SeqAnalysisParserI); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'domain'} = []; # array of HMMUnits $self->{'seq'} = {}; my ($parsetype) = $self->_rearrange([qw(TYPE)],@args); $self->_initialize_io(@args); if( !defined $parsetype ) { $self->throw("No parse type provided. should be hmmsearch or hmmpfam"); } $self->parsetype($parsetype); if( defined $self->_fh() ) { if( $parsetype eq 'hmmsearch' ) { $self->_parse_hmmsearch($self->_fh()); } elsif ( $parsetype eq 'hmmpfam' ) { $self->_parse_hmmpfam($self->_fh()); } else { $self->throw("Did not recoginise type $parsetype"); } } return $self; # success - we hope! } =head2 next_feature Title : next_feature Usage : while( my $feat = $res->next_feature ) { # do something } Function: SeqAnalysisParserI implementing function Example : Returns : A Bio::SeqFeatureI compliant object, in this case, each DomainUnit object, ie, flattening the Sequence aspect of this. Args : None =cut sub next_feature{ my ($self) = @_; if( $self->{'_started_next_feature'} == 1 ) { return shift @{$self->{'_next_feature_array'}}; } else { $self->{'_started_next_feature'} = 1; my @array; foreach my $seq ( $self->each_Set() ) { foreach my $unit ( $seq->each_Domain() ) { push(@array,$unit); } } my $res = shift @array; $self->{'_next_feature_array'} = \@array; return $res; } $self->throw("Should not reach here! Error!"); } =head2 number Title : number Usage : print "There are ",$res->number," domains hit\n"; Function: provides the number of domains in the HMMER report =cut sub number { my $self = shift; my @val; my $ref; $ref = $self->{'domain'}; @val = @{$self->{'domain'}}; return scalar @val; } =head2 seqfile Title : seqfile Usage : $obj->seqfile($newval) Function: Example : Returns : value of seqfile Args : newvalue (optional) =cut sub seqfile{ my ($self,$value) = @_; if( defined $value) { $self->{'seqfile'} = $value; } return $self->{'seqfile'}; } =head2 hmmfile Title : hmmfile Usage : $obj->hmmfile($newval) Function: Example : Returns : value of hmmfile Args : newvalue (optional) =cut sub hmmfile{ my ($self,$value) = @_; if( defined $value) { $self->{'hmmfile'} = $value; } return $self->{'hmmfile'}; } =head2 add_Domain Title : add_Domain Usage : $res->add_Domain($unit) Function: adds a domain to the results array. Mainly used internally. Args : A Bio::Tools::HMMER::Domain =cut sub add_Domain { my $self = shift; my $unit = shift; my $name; $name = $unit->seq_id(); if( ! exists $self->{'seq'}->{$name} ) { $self->warn("Adding a domain of $name but with no HMMSequence. Will be kept in domain array but not added to a HMMSequence"); } else { $self->{'seq'}->{$name}->add_Domain($unit); } push(@{$self->{'domain'}},$unit); } =head2 each_Domain Title : each_Domain Usage : foreach $domain ( $res->each_Domain() ) Function: array of Domain units which are held in this report Returns : array Args : none =cut sub each_Domain { my $self = shift; my (@arr,$u); foreach $u ( @{$self->{'domain'}} ) { push(@arr,$u); } return @arr; } =head2 domain_bits_cutoff_from_evalue Title : domain_bits_cutoff_from_evalue Usage : $cutoff = domain_bits_cutoff_from_evalue(0.01); Function: return a bits cutoff from an evalue using the scores here. Somewhat interesting logic: Find the two bit score which straddle the evalue if( 25 is between these two points) return 25 else return the midpoint. This logic tries to ensure that with large signal to noise separation one still has sensible 25 bit cutoff Returns : Args : =cut sub domain_bits_cutoff_from_evalue { my $self = shift; my $eval = shift; my ($dom,$prev,@doms,$cutoff,$sep,$seen); @doms = $self->each_Domain; @doms = map { $_->[0] } sort { $b->[1] <=> $a->[1] } map { [ $_, $_->bits] } @doms; $seen = 0; foreach $_ ( @doms ) { if( $_->evalue > $eval ) { $seen = 1; $dom = $_; last; } $prev = $_; } if( ! defined $prev || $seen == 0) { $self->throw("Evalue is either above or below the list..."); return; } $sep = $prev->bits - $dom->bits ; if( $sep < 1 ) { return $prev->bits(); } if( $dom->bits < 25 && $prev->bits > 25 ) { return 25; } return int( $dom->bits + $sep/2 ) ; } sub dictate_hmm_acc { my $self = shift; my $acc = shift; my ($unit); foreach $unit ( $self->eachHMMUnit() ) { $unit->hmmacc($acc); } } =head2 write_FT_output Title : write_FT_output Usage : $res->write_FT_output(\*STDOUT,'DOMAIN') Function: writes feature table output ala swissprot Returns : Args : =cut sub write_FT_output { my $self = shift; my $file = shift; my $idt = shift; my ($seq,$unit); if( !defined $idt ) { $idt = "DOMAIN"; } foreach $seq ( $self->each_Set() ) { print $file sprintf("ID %s\n",$seq->name()); foreach $unit ( $seq->each_Domain() ) { print $file sprintf("FT %s %d %d %s\n",$idt, $unit->start,$unit->end,$unit->hmmname); } print $file "//\n"; } } =head2 filter_on_cutoff Title : filter_on_cutoff Usage : $newresults = $results->filter_on_cutoff(25,15); Function: Produces a new HMMER::Results module which has been trimmed at the cutoff. Returns : a Bio::Tools::HMMER::Results module Args : sequence cutoff and domain cutoff. in bits score if you want one cutoff, simply use same number both places =cut sub filter_on_cutoff { my $self = shift; my $seqthr = shift; my $domthr = shift; my ($new,$seq,$unit,@array,@narray); if( !defined $domthr ) { $self->throw("hmmresults filter on cutoff needs two arguments"); } $new = Bio::Tools::HMMER::Results->new(-type => $self->parsetype); foreach $seq ( $self->each_Set()) { next if( $seq->bits() < $seqthr ); $new->add_Set($seq); foreach $unit ( $seq->each_Domain() ) { next if( $unit->bits() < $domthr ); $new->add_Domain($unit); } } $new; } =head2 write_ascii_out Title : write_ascii_out Usage : $res->write_ascii_out(\*STDOUT) Function: writes as seq seq_start seq_end model-acc model_start model_end model_name Returns : Args : FIXME: Now that we have no modelacc, this is probably a bad thing. =cut # writes as seq sstart send modelacc hstart hend modelname sub write_ascii_out { my $self = shift; my $fh = shift; my ($unit,$seq); if( !defined $fh) { $fh = \*STDOUT; } foreach $seq ( $self->each_Set()) { foreach $unit ( $seq->each_Domain()) { print $fh sprintf("%s %4d %4d %s %4d %4d %4.2f %4.2g %s\n", $unit->seq_id(),$unit->start(),$unit->end(), $unit->hmmacc,$unit->hstart,$unit->hend, $unit->bits,$unit->evalue,$unit->hmmname); } } } =head2 write_GDF_bits Title : write_GDF_bits Usage : $res->write_GDF_bits(25,15,\*STDOUT) Function: writes GDF format with a sequence,domain threshold Returns : Args : =cut sub write_GDF_bits { my $self = shift; my $seqt = shift; my $domt = shift; my $file = shift; my $seq; my $unit; my (@array,@narray); if( !defined $file ) { $self->throw("Attempting to use write_GDF_bits without passing in correct arguments!"); return; } foreach $seq ( $self->each_Set()) { if( $seq->bits() < $seqt ) { next; } foreach $unit ( $seq->each_Domain() ) { if( $unit->bits() < $domt ) { next; } push(@array,$unit); } } @narray = sort { my ($aa,$bb,$st_a,$st_b); $aa = $a->seq_id(); $bb = $b->seq_id(); if ( $aa eq $bb) { $st_a = $a->start(); $st_b = $b->start(); return $st_a <=> $st_b; } else { return $aa cmp $bb; } } @array; foreach $unit ( @narray ) { print $file sprintf("%-24s\t%6d\t%6d\t%15s\t%.1f\t%g\n",$unit->get_nse(),$unit->start(),$unit->end(),$unit->seq_id(),$unit->bits(),$unit->evalue); } } sub write_scores_bits { my $self = shift; my $seqt = shift; my $domt = shift; my $file = shift; my $seq; my $unit; my (@array,@narray); if( !defined $file ) { $self->warn("Attempting to use write_scores_bits without passing in correct arguments!"); return; } foreach $seq ( $self->eachHMMSequence()) { if( $seq->bits() < $seqt ) { next; } foreach $unit ( $seq->eachHMMUnit() ) { if( $unit->bits() < $domt ) { next; } push(@array,$unit); } } @narray = sort { my ($aa,$bb,$st_a,$st_b); $aa = $a->bits(); $bb = $b->bits(); return $aa <=> $bb; } @array; foreach $unit ( @narray ) { print $file sprintf("%4.2f %s\n",$unit->bits(),$unit->get_nse()); } } sub write_GDF { my $self = shift; my $file = shift; my $unit; if( !defined $file ) { $file = \*STDOUT; } foreach $unit ( $self->eachHMMUnit() ) { print $file sprintf("%-24s\t%6d\t%6d\t%15s\t%.1f\t%g\n",$unit->get_nse(),$unit->start(),$unit->end(),$unit->seq_id(),$unit->bits(),$unit->evalue); } } sub highest_noise { my $self = shift; my $seqt = shift; my $domt = shift; my ($seq,$unit,$hseq,$hdom,$noiseseq,$noisedom); $hseq = $hdom = -100000; foreach $seq ( $self->eachHMMSequence()) { if( $seq->bits() < $seqt && $seq->bits() > $hseq ) { $hseq = $seq->bits(); $noiseseq = $seq; } foreach $unit ( $seq->eachHMMUnit() ) { if( (($seq->bits() < $seqt) || ($seq->bits() > $seqt && $unit->bits < $domt)) && $unit->bits() > $hdom ) { $hdom = $unit->bits(); $noisedom = $unit; } } } return ($noiseseq,$noisedom); } sub lowest_true { my $self = shift; my $seqt = shift; my $domt = shift; my ($seq,$unit,$lowseq,$lowdom,$trueseq,$truedom); if( ! defined $domt ) { $self->warn("lowest true needs at least a domain threshold cut-off"); return (0,0); } $lowseq = $lowdom = 100000; foreach $seq ( $self->eachHMMSequence()) { if( $seq->bits() >= $seqt && $seq->bits() < $lowseq ) { $lowseq = $seq->bits(); $trueseq = $seq; } if( $seq->bits() < $seqt ) { next; } foreach $unit ( $seq->eachHMMUnit() ) { if( $unit->bits() >= $domt && $unit->bits() < $lowdom ) { $lowdom = $unit->bits(); $truedom = $unit; } } } return ($trueseq,$truedom); } =head2 add_Set Title : add_Set Usage : Mainly internal function Function: Returns : Args : =cut sub add_Set { my $self = shift; my $seq = shift; my $name; $name = $seq->name(); if( exists $self->{'seq'}->{$name} ) { $self->throw("You alredy have $name in HMMResults!"); } $self->{'seq'}->{$name} = $seq; } =head2 each_Set Title : each_Set Usage : Function: Returns : Args : =cut sub each_Set { my $self = shift; my (@array,$name); foreach $name ( keys %{$self->{'seq'}} ) { push(@array,$self->{'seq'}->{$name}); } return @array; } =head2 get_Set Title : get_Set Usage : $set = $res->get_Set('sequence-name'); Function: returns the Set for a particular sequence Returns : a HMMER::Set object Args : name of the sequence =cut sub get_Set { my $self = shift; my $name = shift; return $self->{'seq'}->{$name}; } =head2 _parse_hmmpfam Title : _parse_hmmpfam Usage : $res->_parse_hmmpfam($filehandle) Function: Returns : Args : =cut sub _parse_hmmpfam { my $self = shift; my $file = shift; my ($id,$sqfrom,$sqto,$hmmf,$hmmt,$sc,$ev, $unit,$nd,$seq,$name,$seqname,$from, $to,%hash,%acc,$acc); my $count = 0; while(<$file>) { if( /^HMM file:\s+(\S+)/ ) { $self->hmmfile($1); next; } elsif( /^Sequence file:\s+(\S+)/ ) { $self->seqfile($1); next } elsif( /^Query(\s+sequence)?:\s+(\S+)/ ) { $seqname = $2; $seq = Bio::Tools::HMMER::Set->new(); $seq ->name($seqname); $self->add_Set($seq); %hash = (); while(<$file>){ if( /Accession:\s+(\S+)/ ) { $seq->accession($1); next } elsif( s/^Description:\s+// ) { chomp; $seq->desc($_); next } /^Parsed for domains/ && last; # This is to parse out the accession numbers in old Pfam format. # now not support due to changes in HMMER. if( (($id,$acc, $sc, $ev, $nd) = /^\s*(\S+)\s+(\S+).+?\s(\S+)\s+(\S+)\s+(\d+)\s*$/)) { $hash{$id} = $sc; # we need this for the sequence # core of the domains below! $acc {$id} = $acc; # this is the more common parsing routine } elsif ( (($id,$sc, $ev, $nd) = /^\s*(\S+).+?\s(\S+)\s+(\S+)\s+(\d+)\s*$/) ) { $hash{$id} = $sc; # we need this for the # sequence score of hte domains below! } } while(<$file>) { /^Align/ && last; m{^//} && last; # this is meant to match #Sequence Domain seq-f seq-t hmm-f hmm-t score E-value #-------- ------- ----- ----- ----- ----- ----- ------- #PF00621 1/1 198 372 .. 1 207 [] 281.6 1e-80 if( (($id, $sqfrom, $sqto, $hmmf,$hmmt,$sc, $ev) = /(\S+)\s+\S+\s+(\d+)\s+(\d+).+?(\d+)\s+(\d+)\s+\S+\s+(\S+)\s+(\S+)\s*$/)) { $unit = Bio::Tools::HMMER::Domain->new(); $unit->seq_id ($seqname); $unit->hmmname ($id); $unit->start ($sqfrom); $unit->end ($sqto); $unit->hstart($hmmf); $unit->hend ($hmmt); $unit->bits ($sc); $unit->evalue ($ev); if( !exists($hash{$id}) ) { $self->throw("HMMResults parsing error in hmmpfam for $id - can't find sequecne score"); } $unit->seqbits($hash{$id}); if( defined $acc{$id} ) { $unit->hmmacc($acc{$id}); } # this should find it's own sequence! $self->add_Domain($unit); } } if( m{^//} ) { next; } $_ = <$file>; # parses alignment lines. Icky as we have to break on the same line # that we need to read to place the alignment lines with the unit. while(1) { (!defined $_ || m{^//}) && last; # matches: # PF00621: domain 1 of 1, from 198 to 372 if( /^\s*(\S+):.*from\s+(\d+)\s+to\s+(\d+)/ ) { $name = $1; $from = $2; $to = $3; # find the HMMUnit which this alignment is from $unit = $self->get_unit_nse($seqname,$name,$from,$to); if( !defined $unit ) { $self->warn("Could not find $name $from $to unit even though I am reading it in. ugh!"); $_ = <$file>; next; } while(<$file>) { m{^//} && last; /^\s*\S+:.*from\s+\d+\s+to\s+\d+/ && last; $unit->add_alignment_line($_); } } else { $_ = <$file>; } } # back to main 'Query:' loop } } } # mainly internal function sub get_unit_nse { my $self = shift; my $seqname = shift; my $domname = shift; my $start = shift; my $end = shift; my($seq,$unit); $seq = $self->get_Set($seqname); if( !defined $seq ) { $self->throw("Could not get sequence name $seqname - so can't get its unit"); } foreach $unit ( $seq->each_Domain() ) { if( $unit->hmmname() eq $domname && $unit->start() == $start && $unit->end() == $end ) { return $unit; } } return; } =head2 _parse_hmmsearch Title : _parse_hmmsearch Usage : $res->_parse_hmmsearch($filehandle) Function: Returns : Args : =cut sub _parse_hmmsearch { my $self = shift; my $file = shift; my ($id,$sqfrom,$sqto,$sc,$ev,$unit,$nd,$seq,$hmmf,$hmmt, $hmmfname,$hmmacc, $hmmid, %seqh); my $count = 0; while(<$file>) { /^HMM file:\s+(\S+)/ and do { $self->hmmfile($1); $hmmfname = $1 }; /^Accession:\s+(\S+)/ and do { $hmmacc = $1 }; /^Query HMM:\s+(\S+)/ and do { $hmmid = $1 }; /^Sequence database:\s+(\S+)/ and do { $self->seqfile($1) }; /^Scores for complete sequences/ && last; } $hmmfname = "given" if not $hmmfname; while(<$file>) { /^Parsed for domains/ && last; if( (($id, $sc, $ev, $nd) = /(\S+).+?\s(\S+)\s+(\S+)\s+(\d+)\s*$/)) { $seq = Bio::Tools::HMMER::Set->new(); $seq->name($id); $seq->bits($sc); $seqh{$id} = $sc; $seq->evalue($ev); $self->add_Set($seq); $seq->accession($hmmacc); } } while(<$file>) { /^Alignments of top-scoring domains/ && last; if( (($id, $sqfrom, $sqto, $hmmf, $hmmt, $sc, $ev) = /(\S+)\s+\S+\s+(\d+)\s+(\d+).+?(\d+)\s+(\d+)\s+\S+\s+(\S+)\s+(\S+)\s*$/)) { $unit = Bio::Tools::HMMER::Domain->new(); $unit->seq_id($id); $unit->hmmname($hmmfname); $unit->start($sqfrom); $unit->end($sqto); $unit->bits($sc); $unit->hstart($hmmf); $unit->hend($hmmt); $unit->evalue($ev); $unit->seqbits($seqh{$id}); $self->add_Domain($unit); $count++; } } $_ = <$file>; ## Recognize and store domain alignments while(1) { if( !defined $_ ) { last; } /^Histogram of all scores/ && last; # matches: # PF00621: domain 1 of 1, from 198 to 372 if( /^\s*(\S+):.*from\s+(\d+)\s+to\s+(\d+)/ ) { my $name = $1; my $from = $2; my $to = $3; # find the HMMUnit which this alignment is from $unit = $self->get_unit_nse($name,$hmmfname,$from,$to); if( !defined $unit ) { $self->warn("Could not find $name $from $to unit even though I am reading it in. ugh!"); next; } while(<$file>) { /^Histogram of all scores/ && last; /^\s*\S+:.*from\s+\d+\s+to\s+\d+/ && last; $unit->add_alignment_line($_); } } else { $_ = <$file>; } } return $count; } =head2 parsetype Title : parsetype Usage : $obj->parsetype($newval) Function: Returns : value of parsetype Args : newvalue (optional) =cut sub parsetype{ my ($self,$value) = @_; if( defined $value) { $self->{'_parsetype'} = $value; } return $self->{'_parsetype'}; } 1; # says use was ok __END__ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/HMMER/Set.pm��������������������������������������������������������������000444��000765��000024�� 12255�12254227314� 17235� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::HMMER::Set # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@sanger.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::HMMER::Set - Set of identical domains from HMMER matches =head1 SYNOPSIS # get a Set object probably from the results object print "Bits score over set ",$set->bits," evalue ",$set->evalue,"\n"; foreach $domain ( $set->each_Domain ) { print "Domain start ",$domain->start," end ",$domain->end,"\n"; } =head1 DESCRIPTION Represents a set of HMMER domains hitting one sequence. HMMER reports two different scores, a per sequence total score (and evalue) and a per domain score and evalue. This object represents a collection of the same domain with the sequence bits score and evalue. (these attributes are also on the per domain scores, which you can get there). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution.Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney-at-ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::HMMER::Set; use strict; use Bio::Tools::HMMER::Domain; use base qw(Bio::Root::Root); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($name,$acc,$desc) = $self->_rearrange([qw(NAME ACCESSION DESC)], @args); $name && $self->name($name); $acc && $self->accession($acc); $desc && $self->desc($desc); $self->{'domains'} = []; $self->{'domainnames'} = {}; return $self; } =head2 add_Domain Title : add_Domain Usage : $set->add_Domain($domain) Function: adds the domain to the list Returns : nothing Args : A Bio::Tools::HMMER::Domain object =cut sub add_Domain{ my ($self,$domain) = @_; if( ! defined $domain || ! $domain->isa("Bio::Tools::HMMER::Domain") ) { $self->throw("[$domain] is not a Bio::Tools::HMMER::Domain. aborting"); } return if $self->{'domainnames'}->{$domain->get_nse}++; push(@{$self->{'domains'}},$domain); } =head2 each_Domain Title : each_Domain Usage : foreach $domain ( $set->each_Domain() ) Function: returns an array of domain objects in this set Returns : array Args : none =cut sub each_Domain{ my ($self,@args) = @_; return @{$self->{'domains'}}; } =head2 name Title : name Usage : $obj->name($newval) Function: Example : Returns : value of name Args : newvalue (optional) =cut sub name{ my ($obj,$value) = @_; if( defined $value) { $obj->{'name'} = $value; } return $obj->{'name'}; } =head2 desc Title : desc Usage : $obj->desc($newval) Function: Example : Returns : value of desc Args : newvalue (optional) =cut sub desc{ my ($self,$value) = @_; if( defined $value) { $self->{'desc'} = $value; } return $self->{'desc'}; } =head2 accession Title : accession Usage : $obj->accession($newval) Function: Example : Returns : value of accession Args : newvalue (optional) =cut sub accession{ my ($self,$value) = @_; if( defined $value) { $self->{'accession'} = $value; } return $self->{'accession'}; } =head2 bits Title : bits Usage : $obj->bits($newval) Function: Example : Returns : value of bits Args : newvalue (optional) =cut sub bits{ my ($obj,$value) = @_; if( defined $value) { $obj->{'bits'} = $value; } return $obj->{'bits'}; } =head2 evalue Title : evalue Usage : $obj->evalue($newval) Function: Example : Returns : value of evalue Args : newvalue (optional) =cut sub evalue{ my ($obj,$value) = @_; if( defined $value) { $obj->{'evalue'} = $value; } return $obj->{'evalue'}; } sub addHMMUnit { my $self = shift; my $unit = shift; $self->warn("Using old addHMMUnit call on Bio::Tools::HMMER::Set. Should replace with add_Domain"); return $self->add_Domain($unit); } sub eachHMMUnit { my $self = shift; $self->warn("Using old eachHMMUnit call on Bio::Tools::HMMER::Set. Should replace with each_Domain"); return $self->each_Domain(); } 1; # says use was ok __END__ ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo���������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 16204� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Gerp.pm�������������������������������������������������������������000555��000765��000024�� 10706�12254227315� 17625� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: Gumby.pm,v 1.2 2007/06/14 18:01:52 nathan Exp $ # # BioPerl module for Bio::Tools::Phylo::Gerp # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sendu Bala <bix@sendu.me.uk> # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::Gerp - Parses output from GERP =head1 SYNOPSIS use strict; use Bio::Tools::Phylo::Gerp; my $parser = Bio::Tools::Phylo::Gerp->new(-file => "alignment.rates.elems"); while (my $feat = $parser->next_result) { my $start = $feat->start; my $end = $feat->end; my $rs_score = $feat->score; my $p_value = ($feat->annotation->get_Annotations('p-value'))[0]->value; } =head1 DESCRIPTION This module is used to parse the output from 'GERP' (v2) by Eugene Davydov (originally Gregory M. Cooper et al.). You can get details here: http://mendel.stanford.edu/sidowlab/ It works on the .elems files produced by gerpelem. Each result is a Bio::SeqFeature::Annotated representing a single constrained element. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::Gerp; use strict; use Bio::SeqFeature::Generic; use Bio::Annotation::SimpleValue; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::Gerp->new(); Function: Builds a new Bio::Tools::Phylo::Gerp object Returns : Bio::Tools::Phylo::Gerp Args : -file (or -fh) should contain the contents of a gerpelem .elems file =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : $result = $obj->next_result(); Function: Returns the next result available from the input, or undef if there are no more results. Returns : Bio::SeqFeature::Annotated object. Features are annotated with a tag for 'pvalue', and a 'predicted' tag. They have no sequence id unless the input GERP file is non-standard, with the seq id as the 6th column. NB: feature coordinates are alignment columns of the alignment used to create the result file. Args : none =cut sub next_result { my ($self) = @_; my $line = $self->_readline || return; while ($line !~ /^\d+\s+\d+\s+\d+\s+\S+\s+\S+\s*(?:\S+\s*)?$/) { $line = $self->_readline || return; } #start end length RS-score p-value # code elsewhere adds seq_id on the end (not valid GERP), so we capture that # if present my ($start, $end, undef, $rs_score, $p_value, $seq_id) = split(/\s+/, $line); my $feat = Bio::SeqFeature::Generic->new( $seq_id ? (-seq_id => $seq_id) : (), -start => $start, -end => $end, -strand => 1, -score => $rs_score, #-type => 'conserved_region', ***causes 740x increase in SeqFeatureDB storage requirments! -source => 'GERP'); my $sv = Bio::Annotation::SimpleValue->new(-tagname => 'predicted', -value => 1); $feat->annotation->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'pvalue', -value => $p_value); $feat->annotation->add_Annotation($sv); return $feat; } 1; ����������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Gumby.pm������������������������������������������������������������000444��000765��000024�� 11232�12254227340� 20001� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::Gumby # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Sendu Bala <bix@sendu.me.uk> # # Copyright Sendu Bala # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::Gumby - Parses output from gumby =head1 SYNOPSIS #!/usr/bin/perl -Tw use strict; use Bio::Tools::Phylo::Gumby; my $parser = Bio::Tools::Phylo::Gumby->new(-file => "out.align"); my @features = $parser->next_result(); =head1 DESCRIPTION This module is used to parse the output from 'gumby' by Shyam Prabhakar. You can get details here: http://pga.lbl.gov/gumby/ It works on the .align files produced. The result is a list of feature objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Sendu Bala Email bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::Gumby; use strict; use Bio::SeqFeature::Annotated; use Bio::Annotation::SimpleValue; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::Gumby->new(); Function: Builds a new Bio::Tools::Phylo::Gumby object Returns : Bio::Tools::Phylo::Gumby Args : -file (or -fh) should contain the contents of a gumby .align output file =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : $result = $obj->next_result(); Function: Returns the next set of results available from the input, or undef if there are no more results. Returns : list of Bio::SeqFeature::Annotated (one per sequence). Features are annotated with tags for pvalue and 'kind' (holding 'all', 'exon', or 'nonexon'). NB: Gumby ignores sequence coordinates in input alignments, treating each sequence as if it started at position 1. If you're running this manually (ie. not via the Bio::Tools::Run::Phylo::Gumby) you will have to adjust the coordinates to match up with your input alignment and sequences. Args : none =cut sub next_result { my ($self) = @_; my $line = $self->_readline || return; while ($line !~ /^start/) { $line = $self->_readline || return; if ($line =~ /^(all|exon|nonexon):/) { $self->{_kind} = $1; } } my ($score, $pvalue) = $line =~ /score (\d+), pvalue (\S+)/; my @feats; while ($line = $self->_readline) { $line =~ /^$/ && last; $line || last; my ($seq_id, $start, $end) = split(/\s+/, $line); my $feature = Bio::SeqFeature::Annotated->new(-seq_id => $seq_id, -start => $start, -end => $end, -score => $score, -strand => 1, -source => 'gumby'); my $sv = Bio::Annotation::SimpleValue->new(-tagname => 'pvalue', -value => $pvalue); $feature->annotation->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'kind', -value => $self->{_kind}); $feature->annotation->add_Annotation($sv); $sv = Bio::Annotation::SimpleValue->new(-tagname => 'predicted', -value => 1); $feature->annotation->add_Annotation($sv); push(@feats, $feature); } return @feats; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Molphy.pm�����������������������������������������������������������000444��000765��000024�� 20350�12254227326� 20173� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::Molphy # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::Molphy - parser for Molphy output =head1 SYNOPSIS use Bio::Tools::Phylo::Molphy; my $parser = Bio::Tools::Phylo::Molphy->new(-file => 'output.protml'); while( my $r = $parser->next_result ) { # r is a Bio::Tools::Phylo::Molphy::Result object # print the model name print $r->model, "\n"; # get the substitution matrix # this is a hash of 3letter aa codes -> 3letter aa codes representing # substitution rate my $smat = $r->substitution_matrix; print "Arg -> Gln substitution rate is %d\n", $smat->{'Arg'}->{'Gln'}, "\n"; # get the transition probablity matrix # this is a hash of 3letter aa codes -> 3letter aa codes representing # transition probabilty my $tmat = $r->transition_probability_matrix; print "Arg -> Gln transition probablity is %.2f\n", $tmat->{'Arg'}->{'Gln'}, "\n"; # get the frequency for each of the residues my $rfreqs = $r->residue_frequencies; foreach my $residue ( keys %{$rfreqs} ) { printf "residue %s expected freq: %.2f observed freq: %.2f\n", $residue,$rfreqs->{$residue}->[0], $rfreqs->{$residue}->[1]; } my @trees; while( my $t = $r->next_tree ) { push @trees, $t; } print "search space is ", $r->search_space, "\n", "1st tree score is ", $trees[0]->score, "\n"; # writing to STDOUT, use -file => '>filename' to specify a file my $out = Bio::TreeIO->new(-format => "newick"); $out->write_tree($trees[0]); # writing only the 1st tree } =head1 DESCRIPTION A parser for Molphy output (protml,dnaml) =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::Molphy; use strict; use Bio::Tools::Phylo::Molphy::Result; use Bio::TreeIO; use IO::String; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::Molphy->new(); Function: Builds a new Bio::Tools::Phylo::Molphy object Returns : Bio::Tools::Phylo::Molphy Args : -fh/-file => $val, # for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); return $self; } =head2 next_result Title : next_result Usage : my $r = $molphy->next_result Function: Get the next result set from parser data Returns : Bio::Tools::Phylo::Molphy::Result object Args : none =cut sub next_result{ my ($self) = @_; # A little statemachine for the parser here my ($state,$transition_ct, @transition_matrix, %transition_mat, @resloc,) = ( 0,0); my ( %subst_matrix, @treelines, @treedata, %frequencies); my ( $treenum,$possible_trees, $model); my ($trans_type,$trans_amount); my $parsed = 0; while( defined ( $_ = $self->_readline()) ) { $parsed = 1; if( /^Relative Substitution Rate Matrix/ ) { if( %subst_matrix ) { $self->_pushback($_); last; } $state = 0; my ( @tempdata); @resloc = (); while( defined ($_ = $self->_readline) ) { last if (/^\s+$/); # remove leading/trailing spaces s/^\s+//; s/\s+$//; my @data = split; my $i = 0; for my $l ( @data ) { if( $l =~ /\D+/ ) { push @resloc, $l; } $i++; } push @tempdata, \@data; } my $i = 0; for my $row ( @tempdata ) { my $j = 0; for my $col ( @$row ) { if( $i == $j ) { # empty string for diagonals $subst_matrix{$resloc[$i]}->{$resloc[$j]} = ''; } else { $subst_matrix{$resloc[$i]}->{$resloc[$j]} = $col; } $j++; } $i++; } } elsif( /^Transition Probability Matrix/ ) { if( /(1\.0e(5|7))\)\s+(\S+)/ ) { $state = 1; my $newtrans_type = "$3-$1"; $trans_amount = $1; if( defined $trans_type ) { # finish processing the transition_matrix my $i =0; foreach my $row ( @transition_matrix ) { my $j = 0; foreach my $col ( @$row ) { $transition_mat{$trans_type}->{$resloc[$i]}->{$resloc[$j]} = $col; $j++; } $i++; } } $trans_type = $newtrans_type; $transition_ct = 0; @transition_matrix = (); } } elsif ( /Acid Frequencies/ ) { $state = 0; $self->_readline(); # skip the next line while( defined( $_ = $self->_readline) ) { unless( /^\s+/) { $self->_pushback($_); last; } s/^\s+//; s/\s+$//; my ($index,$res,$model,$data) = split; $frequencies{$res} = [ $model,$data]; } } elsif( /^(\d+)\s*\/\s*(\d+)\s+(.+)\s+model/ ) { my @save = ($1,$2,$3); # finish processing the transition_matrix my $i =0; foreach my $row ( @transition_matrix ) { my $j = 0; foreach my $col ( @$row ) { $transition_mat{$trans_type}->{$resloc[$i]}->{$resloc[$j]} = $col; $j++; } $i++; } if( defined $treenum ) { $self->_pushback($_); last; } $state = 2; ($treenum,$possible_trees, $model) = @save; $model =~ s/\s+/ /g; } elsif( $state == 1 ) { next if( /^\s+$/ || /^\s+Ala/); s/^\s+//; s/\s+$//; if( $trans_type eq '1PAM-1.0e7' ) { # because the matrix is split up into 2-10 column sets push @{$transition_matrix[$transition_ct++]}, split ; $transition_ct = 0 if $transition_ct % 20 == 0; } elsif( $trans_type eq '1PAM-1.0e5' ) { # because the matrix is split up into 2-10 column sets my ($res,@row) = split; next if $transition_ct >= 20; # skip last push @{$transition_matrix[$transition_ct++]}, @row; } } elsif( $state == 2 ) { if( s/^(\d+)\s+(\-?\d+(\.\d+)?)\s+// ) { push @treedata, [ $1,$2]; } # save this for the end so that we can # be efficient and only open one tree parser push @treelines, $_; } } # waiting till the end to do this, is it better my @trees; if( @treelines ) { my $strdat = IO::String->new(join('',@treelines)); my $treeio = Bio::TreeIO->new(-fh => $strdat, -format => 'newick'); while( my $tree = $treeio->next_tree ) { if( @treedata ) { my $dat = shift @treedata; # set the associated information $tree->id($dat->[0]); $tree->score($dat->[1]); } push @trees, $tree; } } return unless( $parsed ); my $result = Bio::Tools::Phylo::Molphy::Result->new (-trees => \@trees, -substitution_matrix => \%subst_matrix, -frequencies => \%frequencies, -model => $model, -search_space => $possible_trees, ); while( my ($type,$mat) = each %transition_mat ) { $result->transition_probability_matrix( $type,$mat); } $result; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/PAML.pm�������������������������������������������������������������000444��000765��000024�� 174130�12254227325� 17501� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::PAML # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich, Aaron J Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::PAML - Parses output from the PAML programs codeml, baseml, basemlg, codemlsites and yn00 =head1 SYNOPSIS #!/usr/bin/perl -Tw use strict; use Bio::Tools::Phylo::PAML; # need to specify the output file name (or a fh) (defaults to # -file => "codeml.mlc"); also, optionally, the directory in which # the other result files (rst, 2ML.dS, etc) may be found (defaults # to "./") my $parser = Bio::Tools::Phylo::PAML->new (-file => "./results/mlc", -dir => "./results/"); # get the first/next result; a Bio::Tools::Phylo::PAML::Result object, # which isa Bio::SeqAnalysisResultI object. my $result = $parser->next_result(); # get the sequences used in the analysis; returns Bio::PrimarySeq # objects (OTU = Operational Taxonomic Unit). my @otus = $result->get_seqs(); # codon summary: codon usage of each sequence [ arrayref of { # hashref of counts for each codon } for each sequence and the # overall sum ], and positional nucleotide distribution [ arrayref # of { hashref of frequencies for each nucleotide } for each # sequence and overall frequencies ]: my ($codonusage, $ntdist) = $result->get_codon_summary(); # example manipulations of $codonusage and $ntdist: printf "There were %d %s codons in the first seq (%s)\n", $codonusage->[0]->{AAA}, 'AAA', $otus[0]->id(); printf "There were %d %s codons used in all the sequences\n", $codonusage->[$#{$codonusage}]->{AAA}, 'AAA'; printf "Nucleotide %c was present %g of the time in seq %s\n", 'A', $ntdist->[1]->{A}, $otus[1]->id(); # get Nei & Gojobori dN/dS matrix: my $NGmatrix = $result->get_NGmatrix(); # get ML-estimated dN/dS matrix, if calculated; this corresponds to # the runmode = -2, pairwise comparison usage of codeml my $MLmatrix = $result->get_MLmatrix(); # These matrices are length(@otu) x length(@otu) "strict lower # triangle" 2D-matrices, which means that the diagonal and # everything above it is undefined. Each of the defined cells is a # hashref of estimates for "dN", "dS", "omega" (dN/dS ratio), "t", # "S" and "N". If a ML matrix, "lnL" and "kappa" will also be defined. printf "The omega ratio for sequences %s vs %s was: %g\n", $otus[0]->id, $otus[1]->id, $MLmatrix->[0]->[1]->{omega}; # with a little work, these matrices could also be passed to # Bio::Tools::Run::Phylip::Neighbor, or other similar tree-building # method that accepts a matrix of "distances" (using the LOWTRI # option): my $distmat = [ map { [ map { $$_{omega} } @$_ ] } @$MLmatrix ]; # for runmode's other than -2, get tree topology with estimated # branch lengths; returns a Bio::Tree::TreeI-based tree object with # added PAML parameters at each node my ($tree) = $result->get_trees(); for my $node ($tree->get_nodes()) { # inspect the tree: the "t" (time) parameter is available via # $node->branch_length(); all other branch-specific parameters # ("omega", "dN", etc.) are available via # ($omega) = $node->get_tag_values('omega'); } # if you are using model based Codeml then trees are stored in each # modelresult object for my $modelresult ( $result->get_NSSite_results ) { # model M0, M1, etc print "model is ", $modelresult->model_num, "\n"; my ($tree) = $modelresult->get_trees(); for my $node ($tree->get_nodes()) { # inspect the tree: the "t" (time) parameter is available via # $node->branch_length(); all other branch-specific parameters # ("omega", "dN", etc.) are available via # ($omega) = $node->get_tag_values('omega'); } } # get any general model parameters: kappa (the # transition/transversion ratio), NSsites model parameters ("p0", # "p1", "w0", "w1", etc.), etc. my $params = $result->get_model_params(); printf "M1 params: p0 = %g\tp1 = %g\n", $params->{p0}, $params->{p1}; # parse AAML result files my $aamat = $result->get_AADistMatrix(); my $aaMLmat = $result->get_AAMLDistMatrix(); =head1 DESCRIPTION This module is used to parse the output from the PAML programs codeml, baseml, basemlg, codemlsites and yn00. You can use the Bio::Tools::Run::Phylo::PAML::* modules to actually run some of the PAML programs, but this module is only useful to parse the output. This module has fledgling support for PAML version 4.3a (October 2009). Please report any problems to the mailing list (see FEEDBACK below). =head1 TO DO Implement get_posteriors(). For NSsites models, obtain arrayrefs of posterior probabilities for membership in each class for every position; probabilities correspond to classes w0, w1, ... etc. my @probs = $result->get_posteriors(); # find, say, positively selected sites! if ($params->{w2} > 1) { for (my $i = 0; $i < @probs ; $i++) { if ($probs[$i]->[2] > 0.5) { # assumes model M1: three w's, w0, w1 and w2 (positive selection) printf "position %d: (%g prob, %g omega, %g mean w)\n", $i, $probs[$i]->[2], $params->{w2}, $probs[$i]->[3]; } } } else { print "No positive selection found!\n"; } =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Aaron Mackey Email jason-at-bioperl.org Email amackey-at-virginia.edu =head1 CONTRIBUTORS Albert Vilella avilella-AT-gmail-DOT-com Sendu Bala bix@sendu.me.uk Dave Messina dmessina@cpan.org =head1 TODO RST parsing -- done, Avilella contributions bug#1506, added by jason 1.29 -- still need to parse in joint probability and non-syn changes at site table =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::PAML; use vars qw($RSTFILENAME); use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::Root::IO Bio::AnalysisParserI); BEGIN { $RSTFILENAME = 'rst'; # where to get the RST data from } # other objects used: use IO::String; use File::Spec; use Bio::TreeIO; use Bio::Tools::Phylo::PAML::Result; use Bio::LocatableSeq; use Bio::PrimarySeq; use Bio::Matrix::PhylipDist; use Bio::Tools::Phylo::PAML::ModelResult; =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::PAML->new(%args); Function: Builds a new Bio::Tools::Phylo::PAML object Returns : Bio::Tools::Phylo::PAML Args : Hash of options: -file, -fh, -dir -file (or -fh) should contain the contents of the PAML outfile; -dir is the (optional) name of the directory in which the PAML program was run (and includes other PAML-generated files from which we can try to gather data) =cut sub new { my ( $class, @args ) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); my ($dir) = $self->_rearrange( [qw(DIR)], @args ); $self->{_dir} = $dir if defined $dir; return $self; } =head2 Implement Bio::AnalysisParserI interface =cut =head2 next_result Title : next_result Usage : $result = $obj->next_result(); Function: Returns the next result available from the input, or undef if there are no more results. Example : Returns : a Bio::Tools::Phylo::PAML::Result object Args : none =cut sub next_result { my ($self) = @_; my %data; # parse the RST file, if it doesn't exist or if dir is not set # this will just skip the parsing $self->_parse_rst(); my $idlookup; # a hashreference to SEQID (number) ==> 'SEQUENCENAME' # get the various codon and other sequence summary data, if necessary: $self->_parse_summary unless ( $self->{'_summary'} && !$self->{'_summary'}->{'multidata'} ); # OK, depending on seqtype and runmode now, one of a few things can happen: my $seqtype = $self->{'_summary'}->{'seqtype'}; if ( $seqtype eq 'CODONML' || $seqtype eq 'AAML' ) { my $has_model_line = 0; while ( defined( $_ = $self->_readline ) ) { if ( $seqtype eq 'CODONML' && m/^pairwise comparison, codon frequencies:/ ) { # runmode = -2, CODONML $self->debug("pairwise Ka/Ks\n"); $self->_pushback($_); %data = $self->_parse_PairwiseCodon; last; } elsif ( $seqtype eq 'AAML' && m/^ML distances of aa seqs\.$/ ) { $self->_pushback($_); # get AA distances %data = ( '-AAMLdistmat' => $self->_parse_aa_dists() ); # $self->_pushback($_); # %data = $self->_parse_PairwiseAA; # last; } elsif ( m/^Model\s+(\d+)/ || ( ( !$has_model_line && m/^TREE/ ) && $seqtype eq 'CODONML' && ($self->{'_summary'}->{'version'} !~ /4/)) # last bit to keep PAML >= 4 from being caught here # bug 2482. Not sure this is the right fix, but tests # pass and the bug's test case passes. ) { $self->_pushback($_); my $model = $self->_parse_NSsitesBatch; push @{ $data{'-NSsitesresults'} }, $model; $has_model_line = 1; } elsif (m/for each branch/) { my %branch_dnds = $self->_parse_branch_dnds; if ( !defined $data{'-trees'} ) { $self->warn( "No trees have been loaded, can't do anything\n"); next; } my ($tree) = @{ $data{'-trees'} }; if ( !$tree || !ref($tree) || !$tree->isa('Bio::Tree::Tree') ) { $self->warn("no tree object already stored!\n"); next; } # These need to be added to the Node/branches while ( my ( $k, $v ) = each %branch_dnds ) { # we can probably do better by caching at some point my @nodes; for my $id ( split( /\.\./, $k ) ) { my @nodes_L = map { $tree->find_node( -id => $_ ) } @{ $idlookup->{$id} }; my $n = @nodes_L < 2 ? shift(@nodes_L) : $tree->get_lca(@nodes_L); if ( !$n ) { $self->warn("no node for $n\n"); } unless ( $n->is_Leaf && $n->id ) { $n->id($id); } push @nodes, $n; } my ( $parent, $child ) = @nodes; while ( my ( $kk, $vv ) = each %$v ) { $child->add_tag_value( $kk, $vv ); } } } elsif (m/^TREE/) { # runmode = 0 $self->_pushback($_); ( $data{'-trees'}, $idlookup ) = $self->_parse_Forestry; #last; } elsif (m/Heuristic tree search by stepwise addition$/) { # runmode = 3 $self->throw( -class => 'Bio::Root::NotImplemented', -text => "StepwiseAddition not yet implemented!" ); # $self->_pushback($_); # %data = $self->_parse_StepwiseAddition; # last; } elsif (m/Heuristic tree search by NNI perturbation$/) { # runmode = 4 $self->throw( -class => 'Bio::Root::NotImplemented', -text => "NNI Perturbation not yet implemented!" ); # $self->_pushback($_); # %data = $self->_parse_Perturbation; # last; } elsif (m/^stage 0:/) { # runmode = (1 or 2) $self->throw( -class => 'Bio::Root::NotImplemented', -text => "StarDecomposition not yet implemented!" ); $self->_pushback($_); %data = $self->_parse_StarDecomposition; last; } } } elsif ( $seqtype eq 'BASEML' ) { while ( defined( $_ = $self->_readline ) ) { if (/^Distances:/) { $self->_pushback($_); my ( $kappa, $alpha ) = $self->_parse_nt_dists(); %data = ( '-kappa_distmat' => $kappa, '-alpha_distmat' => $alpha ); } elsif (/^TREE/) { $self->_pushback($_); ( $data{'-trees'}, $idlookup ) = $self->_parse_Forestry; } } } elsif ( $seqtype eq 'YN00' ) { while ( $_ = $self->_readline ) { if ( m/^Estimation by the method|\(B\) Yang & Nielsen \(2000\) method/ ) { $self->_pushback($_); %data = $self->_parse_YN_Pairwise; last; } } } if (%data) { $data{'-version'} = $self->{'_summary'}->{'version'}; $data{'-seqs'} = $self->{'_summary'}->{'seqs'}; $data{'-patterns'} = $self->{'_summary'}->{'patterns'}; $data{'-ngmatrix'} = $self->{'_summary'}->{'ngmatrix'}; $data{'-codonpos'} = $self->{'_summary'}->{'codonposition'}; $data{'-codonfreq'} = $self->{'_summary'}->{'codonfreqs'}; $data{'-model'} = $self->{'_summary'}->{'model'}; $data{'-seqfile'} = $self->{'_summary'}->{'seqfile'}; $data{'-aadistmat'} = $self->{'_summary'}->{'aadistmat'}; $data{'-stats'} = $self->{'_summary'}->{'stats'}; $data{'-aafreq'} = $self->{'_summary'}->{'aafreqs'}; $data{'-ntfreq'} = $self->{'_summary'}->{'ntfreqs'}; $data{'-input_params'} = $self->{'_summary'}->{'inputparams'}; $data{'-rst'} = $self->{'_rst'}->{'rctrted_seqs'}; $data{'-rst_persite'} = $self->{'_rst'}->{'persite'}; $data{'-rst_trees'} = $self->{'_rst'}->{'trees'}; return Bio::Tools::Phylo::PAML::Result->new(%data); } else { return; } } sub _parse_summary { my ($self) = @_; # Depending on whether verbose > 0 or not, and whether the result # set comes from a multi-data run, the first few lines could be # various things; we're going to throw away any sequence data # here, since we'll get it later anyways # multidata ? : \n\nData set 1\n # verbose ? : cleandata ? : \nBefore deleting alignment gaps. \d sites\n # [ sequence printout ] # \nAfter deleting gaps. \d sites\n" # : [ sequence printout ] # CODONML (in paml 3.12 February 2002) <<-- what we want to see! my $SEQTYPES = qr( (?: (?: CODON | AA | BASE | CODON2AA ) ML ) | YN00 )x; my $line; $self->{'_already_parsed_seqs'} = $self->{'_already_parsed_seqs'} ? 1 : 0; my @lines; while ( $_ = $self->_readline ) { push @lines, $_; if (m/^($SEQTYPES) \s+ # seqtype: CODONML, AAML, BASEML, CODON2AAML, YN00, etc (?: \(in \s+ ([^\)]+?) \s* \) \s* )? # version: "paml 3.12 February 2002"; not present < 3.1 or YN00 (\S+) \s* # tree filename (?: (.+?) )? # model description (not there in YN00) \s* $ # trim any trailing space /ox ) { @{ $self->{'_summary'} }{qw(seqtype version seqfile model)} = ( $1, $2, $3, $4 ); # in 4.3, the model is on its own line if ( !defined $self->{'_summary'}->{'model'} ) { my $model_line = $self->_readline; chomp $model_line; if ($model_line =~ /^Model:/) { $self->{'_summary'}->{'model'} = $model_line; } } defined $self->{'_summary'}->{'model'} && $self->{'_summary'}->{'model'} =~ s/Model:\s+//; $self->_pushback($_) if $self->{'_summary'}->{'seqtype'} eq 'AAMODEL'; last; } elsif ((m/\s+?\d+?\s+?\d+?/) && ( $self->{'_already_parsed_seqs'} != 1 )) { $self->_parse_seqs; } elsif (m/^Data set \d$/) { $self->{'_summary'} = {}; $self->{'_summary'}->{'multidata'}++; } elsif (m/^Before\s+deleting\s+alignment\s+gaps/) { #Gap my ($phylip_header) = $self->_readline; $self->_parse_seqs; } elsif ( ( @lines >= 3 ) && ( $self->{'_already_parsed_seqs'} != 1 ) ) { #No gap # don't start parsing seqs yet if we're on a blank line # (gives another opportunity to match one of the other regexes) unless (/^\n$/) { $self->_parse_seqs; } } elsif ( (/Printing out site pattern counts/) && ( $self->{'_already_parsed_seqs'} != 1 ) ) { $self->_parse_patterns; } } unless ( defined $self->{'_summary'}->{'seqtype'} ) { $self->throw( -class => 'Bio::Root::NotImplemented', -text => 'Unknown format of PAML output did not see seqtype' ); } my $seqtype = $self->{'_summary'}->{'seqtype'}; if ( $seqtype eq "CODONML" ) { $self->_parse_inputparams(); # settings from the .ctl file # that get printed $self->_parse_patterns(); # codon patterns - not very interesting $self->_parse_seqs(); # the sequences data used for analysis $self->_parse_codoncts(); # counts and distributions of codon/nt # usage $self->_parse_codon_freqs(); # codon frequencies $self->_parse_distmat(); # NG distance matrices } elsif ( $seqtype eq "AAML" ) { $self->_parse_inputparams; $self->_parse_patterns(); $self->_parse_seqs(); # the sequences data used for analysis $self->_parse_aa_freqs(); # AA frequencies # get AA distances $self->{'_summary'}->{'aadistmat'} = $self->_parse_aa_dists(); } elsif ( $seqtype eq "CODON2AAML" ) { $self->throw( -class => 'Bio::Root::NotImplemented', -text => 'CODON2AAML parsing not yet implemented!' ); } elsif ( $seqtype eq "BASEML" ) { $self->_parse_patterns(); $self->_parse_seqs(); $self->_parse_nt_freqs(); } elsif ( $seqtype eq "YN00" ) { $self->_parse_codon_freqs(); $self->_parse_codoncts(); $self->_parse_distmat(); # NG distance matrices } else { $self->throw( -class => 'Bio::Root::NotImplemented', -text => 'Unknown seqtype, not yet implemented!', -value => $seqtype ); } } sub _parse_inputparams { my ($self) = @_; while ( defined( $_ = $self->_readline ) ) { if (/^((?:Codon frequencies)|(?:Site-class models))\s*:\s+(.+)/) { my ( $param, $val ) = ( $1, $2 ); $self->{'_summary'}->{'inputparams'}->{$param} = $val; } elsif (/^\s+$/) { next; } elsif ( /^ns\s+=\s+/ || /^Frequencies/ ) { $self->_pushback($_); last; } } } sub _parse_codon_freqs { my ($self) = @_; my ( $okay, $done ) = ( 0, 0 ); while ( defined( $_ = $self->_readline ) ) { if (/^Nei|\(A\) Nei/) { $self->_pushback($_); last } last if ($done); next if (/^\s+/); next unless ( $okay || /^Codon position x base \(3x4\) table\, overall/ ); $okay = 1; if (s/^position\s+(\d+):\s+//) { my $pos = $1; s/\s+$//; my @bases = split; foreach my $str (@bases) { my ( $base, $freq ) = split( /:/, $str, 2 ); $self->{'_summary'}->{'codonposition'}->[ $pos - 1 ]->{$base} = $freq; } $done = 1 if $pos == 3; } } $done = 0; while ( defined( $_ = $self->_readline ) ) { if (/^Nei\s\&\sGojobori|\(A\)\sNei-Gojobori/) { $self->_pushback($_); last; } last if ($done); if (/^Codon frequencies under model, for use in evolver/) { while ( defined( $_ = $self->_readline ) ) { last if (/^\s+$/); s/^\s+//; s/\s+$//; push @{ $self->{'_summary'}->{'codonfreqs'} }, [split]; } $done = 1; } } } sub _parse_aa_freqs { my ($self) = @_; my ( $okay, $done, $header ) = ( 0, 0, 0 ); my (@bases); my $numseqs = scalar @{ $self->{'_summary'}->{'seqs'} || [] }; while ( defined( $_ = $self->_readline ) ) { if ( /^TREE/ || /^AA distances/ ) { $self->_pushback($_); last; } last if ($done); next if ( /^\s+$/ || /^\(Ambiguity/ ); if (/^Frequencies\./) { $okay = 1; } elsif ( !$okay ) { # skip till we see 'Frequencies. next; } elsif ( !$header ) { s/^\s+//; # remove leading whitespace @bases = split; # get an array of the all the aa names $header = 1; $self->{'_summary'}->{'aafreqs'} = {}; # reset/clear values next; } elsif ( /^\#\s+constant\s+sites\:\s+ (\d+)\s+ # constant sites \(\s*([\d\.]+)\s*\%\s*\)/x ) { $self->{'_summary'}->{'stats'}->{'constant_sites'} = $1; $self->{'_summary'}->{'stats'}->{'constant_sites_percentage'} = $2; } elsif (/^ln\s+Lmax\s+\(unconstrained\)\s+\=\s+(\S+)/x) { $self->{'_summary'}->{'stats'}->{'loglikelihood'} = $1; $done = 1; # done for sure } else { my ( $seqname, @freqs ) = split; my $basect = 0; foreach my $f (@freqs) { # this will also store 'Average' $self->{'_summary'}->{'aafreqs'}->{$seqname} ->{ $bases[ $basect++ ] } = $f; } } } } # This is for parsing the automatic tree output sub _parse_StarDecomposition { my ($self) = @_; my %data; return %data; } sub _parse_aa_dists { my ($self) = @_; my ( $okay, $seen, $done ) = ( 0, 0, 0 ); my ( %matrix, @names, @values ); my $numseqs = scalar @{ $self->{'_summary'}->{'seqs'} || [] }; my $type = ''; while ( defined( $_ = $self->_readline ) ) { last if $done; if (/^TREE/) { $self->_pushback($_); last; } if (/^\s+$/) { last if ($seen); next; } if (/^(AA|ML) distances/) { $okay = 1; $type = $1; next; } s/\s+$//g; # remove trailing space if ($okay) { my ( $seqname, @vl ) = split; $seen = 1; my $i = 0; # hacky workaround to problem with 3.14 aaml if ( $type eq 'ML' && !@names && # first entry @vl ) { # not empty push @names, $self->{'_summary'}->{'seqs'}->[0]->display_id; } for my $s (@names) { last unless @vl; $matrix{$seqname}->{$s} = $matrix{$s}->{$seqname} = shift @vl; } push @names, $seqname; $matrix{$seqname}->{$seqname} = 0; } $done = 1 if ( scalar @names == $numseqs ); } my %dist; my $i = 0; @values = (); foreach my $lname (@names) { my @row; my $j = 0; foreach my $rname (@names) { my $v = $matrix{$lname}->{$rname}; $v = $matrix{$rname}->{$lname} unless defined $v; push @row, $v; $dist{$lname}{$rname} = [ $i, $j++ ]; } $i++; push @values, \@row; } return new Bio::Matrix::PhylipDist( -program => $self->{'_summary'}->{'seqtype'}, -matrix => \%dist, -names => \@names, -values => \@values ); } sub _parse_patterns { my ($self) = @_; my ( $patternct, @patterns, $ns, $ls ); return if exists $self->{'_summary'}->{'patterns'}; while ( defined( $_ = $self->_readline ) ) { if ( /^Codon\s+(usage|position)/ || /Model/ ) { $self->_pushback($_); last; } elsif ($patternct) { # last unless ( @patterns == $patternct ); last if (/^\s+$/); s/^\s+//; push @patterns, split; } elsif (/^ns\s+\=\s*(\d+)\s+ls\s+\=\s*(\d+)/) { ( $ns, $ls ) = ( $1, $2 ); } elsif (/^\# site patterns \=\s*(\d+)/) { $patternct = $1; } else { # $self->debug("Unknown line: $_"); } } $self->{'_summary'}->{'patterns'} = { -patterns => \@patterns, -ns => $ns, -ls => $ls }; } sub _parse_seqs { # this should in fact be packed into a Bio::SimpleAlign object instead of # an array but we'll stay with this for now my ($self) = @_; # Use this flag to deal with paml 4 vs 3 differences # In PAML 4 the sequences precede the CODONML|BASEML|AAML # while in PAML3 the files start off with this return 1 if $self->{'_already_parsed_seqs'}; my ( @firstseq, @seqs ); while ( defined( $_ = $self->_readline ) ) { if (/^(Printing|After|TREE|Codon)/) { $self->_pushback($_); last; } last if ( /^\s+$/ && @seqs > 0 ); next if (/^\s+$/); next if (/^\d+\s+$/); # we are reading PHYLIP format my ( $name, $seqstr ) = split( /\s+/, $_, 2 ); $seqstr =~ s/\s+//g; # remove whitespace unless (@firstseq) { @firstseq = split( //, $seqstr ); push @seqs, Bio::LocatableSeq->new( -display_id => $name, -seq => $seqstr ); } else { my $i = 0; my $v; while ( ( $v = index( $seqstr, '.', $i ) ) >= $i ) { # replace the '.' with the correct seq from the substr( $seqstr, $v, 1, $firstseq[$v] ); $i = $v; } push @seqs, Bio::LocatableSeq->new( -display_id => $name, -seq => $seqstr ); } } if ( @seqs > 0 ) { $self->{'_summary'}->{'seqs'} = \@seqs; $self->{'_already_parsed_seqs'} = 1; } 1; } sub _parse_codoncts { } sub _parse_distmat { my ($self) = @_; my @results; my $ver = 3.14; my $firstseq, my $secondseq; while ( defined( $_ = $self->_readline ) ) { next if /^\s+$/; # We need to get the names of the sequences if this is from YN00: if (/^\(A\)\sNei-Gojobori\s\(1986\)\smethod/) { $ver = 3.15; while ( defined( $_ = $self->_readline ) ) { if ($_ =~ m/.*\d+?\.\d+?\s*\(.*/) { $secondseq = $_; last; } $firstseq = $_; } } last; } #return unless (/^Nei\s*\&\s*Gojobori/); # skip the next 3 lines if ( $self->{'_summary'}->{'seqtype'} eq 'CODONML' ) { $self->_readline; $self->_readline; $self->_readline; } my $seqct = 0; my @seqs; if ( $self->{'_summary'}->{'seqtype'} eq 'YN00' ) { if ($firstseq) { $firstseq =~ s/(.+?)\s+.*/$1/; $secondseq =~ s/(.+?)\s+.*/$1/; chomp $firstseq; chomp $secondseq; push @seqs, Bio::PrimarySeq->new( -display_id => $firstseq ); push @seqs, Bio::PrimarySeq->new( -display_id => $secondseq ); } } while ( defined( $_ = $self->_readline ) ) { last if ( /^\s+$/ && exists $self->{'_summary'}->{'ngmatrix'} ); next if ( /^\s+$/ || /^NOTE:/i ); chomp; $_ =~ m/(.+?)\s*(-*\d+?\.\d+?.*)/; my $seq = $1; my $rest = $2; $rest = '' unless defined $rest; # get rid of empty messages my $j = 0; if ( $self->{'_summary'}->{'seqtype'} eq 'YN00' ) { push @seqs, Bio::PrimarySeq->new( -display_id => $seq ); } while ($rest && $rest =~ /(\-?\d+(\.\d+)?)\s*\(\-?(\d+(\.\d+)?)\s+(\-?\d+(\.\d+)?)\)/g ) { $self->{'_summary'}->{'ngmatrix'}->[ $j++ ]->[$seqct] = { 'omega' => $1, 'dN' => $3, 'dS' => $5 }; } $seqct++; } if ( $self->{'_summary'}->{'seqtype'} eq 'YN00' && @seqs ) { $self->{'_summary'}->{'seqs'} = \@seqs; } 1; } sub _parse_PairwiseCodon { my ($self) = @_; my @result; my ( $a, $b, $log, $model, $t, $kappa, $omega, $fixedkappa ); # check to see if we have a fixed kappa: if ( $self->{'_summary'}->{'model'} =~ /kappa = (\d+?\.\d+?) fixed/) { $fixedkappa = $1; } while ( defined( $_ = $self->_readline ) ) { if (/^pairwise comparison, codon frequencies\:\s*(\S+)\./) { $model = $1; } # 1st line of a pair block, e.g. # 2 (all_c7259) ... 1 (all_s57600) elsif (/^(\d+)\s+\((\S+)\)\s+\.\.\.\s+(\d+)\s+\((\S+)\)/) { ( $a, $b ) = ( $1, $3 ); } # 2nd line of a pair block, e.g. # lnL = -126.880601 elsif (/^lnL\s+\=\s*(\-?\d+(\.\d+)?)/) { $log = $1; if ( defined( $_ = $self->_readline ) ) { # 3rd line of a pair block, e.g. # 0.19045 2.92330 0.10941 s/^\s+//; ( $t, $kappa, $omega ) = split; # if there was a fixed kappa, there will only be two values here ($t, $omega) and $kappa = $fixedkappa. if ($omega eq "") { $omega = $kappa; $kappa = $fixedkappa; } } } # 5th line of a pair block, e.g. # t= 0.1904 S= 5.8 N= 135.2 dN/dS= 0.1094 dN= 0.0476 dS= 0.4353 # OR lines like (note last field; this includes a fix for bug #3040) # t= 0.0439 S= 0.0 N= 141.0 dN/dS= 0.1626 dN= 0.0146 dS= nan elsif (m/^t\=\s*(\d+(\.\d+)?)\s+/) { # Breaking out each piece individually so that you can see # what each regexp actually looks for my $parse_string = $_; $parse_string =~ m/.*t\s*\=\s*(\d+?\.\d+?)\s/; my $temp_t = $1; $parse_string =~ m/\sS\s*\=\s*(\d+?\.\d+?)\s/; my $temp_S = $1; $parse_string =~ m/\sN\s*\=\s*(\d+?\.\d+?)\s/; my $temp_N = $1; $parse_string =~ m/\sdN\/dS\s*\=\s*(\d+?\.\d+?)\s/; my $temp_omega = $1; $parse_string =~ m/\sdN\s*\=\s*(\d+?\.\d+?)\s/; my $temp_dN = $1; $parse_string =~ m/\sdS\s*\=\s*(.+)\s/; my $temp_dS = $1; $result[ $b - 1 ]->[ $a - 1 ] = { 'lnL' => $log, 't' => defined $t && length($t) ? $t : $temp_t, 'S' => $temp_S, 'N' => $temp_N, 'kappa' => $kappa, 'omega' => defined $omega && length($omega) ? $omega : $temp_omega, 'dN' => $temp_dN, 'dS' => $temp_dS }; } # 4th line of a pair block (which is blank) elsif (/^\s+$/) { next; } elsif (/^\s+(\d+\.\d+)\s+(\d+\.\d+)\s+(\d+\.\d+)/) { } else { $self->debug("unknown line: $_"); } } return ( -mlmatrix => \@result ); } sub _parse_YN_Pairwise { my ($self) = @_; my @result; while ( defined( $_ = $self->_readline ) ) { last if (/^seq\.\s+seq\./); } while ( defined( $_ = $self->_readline ) ) { if ( m/^\s+(\d+)\s+ # seq # (\d+)\s+ # seq # (\d+(\.\d+))\s+ # S (\d+(\.\d+))\s+ # N (\d+(\.\d+))\s+ # t (\d+(\.\d+))\s+ # kappa (\d+(\.\d+))\s+ # omega \-??(\d+(\.\d+))\s+ # dN \+\-\s+ \-??(\d+(\.\d+))\s+ # dN SE \-??(\d+(\.\d+))\s+ # dS \+\-\s+ \-??(\d+(\.\d+))\s+ # dS SE /ox ) { $result[ $2 - 1 ]->[ $1 - 1 ] = { 'S' => $3, 'N' => $5, 't' => $7, 'kappa' => $9, 'omega' => $11, 'dN' => $13, 'dN_SE' => $15, 'dS' => $17, 'dS_SE' => $19, }; } elsif (/^\s+$/) { next; } elsif (/^\(C\) LWL85, LPB93 & LWLm methods/) { $self->_pushback($_); last; } } return ( -mlmatrix => \@result ); } sub _parse_Forestry { my ($self) = @_; my ( $instancecount, $num_param, $loglikelihood, $score, $done, $treelength ) = ( 0, 0, 0, 0, 0, 0 ); my $okay = 0; my ( @ids, %match, @branches, @trees ); while ( defined( $_ = $self->_readline ) ) { last if $done; if (s/^TREE\s+\#\s*\d+:\s+//) { ($score) = (s/MP\s+score\:\s+(\S+)\s+$//); @ids = /(\d+)[\,\)]/g; } elsif (/^Node\s+\&/ || /^\s+N37/ || /^(CODONML|AAML|YN00|BASEML)/ || /^\*\*/ || /^Detailed output identifying parameters/ ) { $self->_pushback($_); $done = 1; last; } elsif (/^tree\s+length\s+\=\s+(\S+)/) { $treelength = $1; # not going to store this for now # as it is directly calculated from # $tree->total_branch_length; } elsif (/^\s*lnL\(.+np\:\s*(\d+)\)\:\s+(\S+)/) { # elsif( /^\s*lnL\(.+\)\:\s+(\S+)/ ) { ( $num_param, $loglikelihood ) = ( $1, $2 ); } elsif (/^\(/) { s/([\,:])\s+/$1/g; my $treestr = IO::String->new($_); my $treeio = Bio::TreeIO->new( -fh => $treestr, -format => 'newick' ); my $tree = $treeio->next_tree; if ($tree) { $tree->score($loglikelihood); $tree->id("num_param:$num_param"); if ( $okay > 0 ) { # we don't save the trees with the number labels if ( !%match && @ids ) { my $i = 0; for my $m (/([^():,]+):/g) { $match{ shift @ids } = [$m]; } my %grp; while ( my $br = shift @branches ) { my ( $parent, $child ) = @$br; if ( $match{$child} ) { push @{ $match{$parent} }, @{ $match{$child} }; } else { push @branches, $br; } } if ( $self->verbose > 1 ) { for my $k ( sort { $a <=> $b } keys %match ) { $self->debug( "$k -> ", join( ",", @{ $match{$k} } ), "\n" ); } } } # Associate SEs to nodes using tags if ( defined( $self->{_SEs} ) ) { my @SEs = split( " ", $self->{_SEs} ); my $i = 0; foreach my $parent_id ( map { /\d+\.\.(\d+)/ } split( " ", $self->{_branch_ids} ) ) { my @nodes; my @node_ids = @{ $match{$parent_id} }; my @nodes_L = map { $tree->find_node( -id => $_ ) } @node_ids; my $n = @nodes_L < 2 ? shift(@nodes_L) : $tree->get_lca(@nodes_L); if ( !$n ) { $self->warn( "no node could be found for node in SE assignation (no lca?)" ); } $n->add_tag_value( 'SE', $SEs[$i] ); $i++; } } push @trees, $tree; } } $okay++; } elsif (/^SEs for parameters/) { my $se_line = $self->_readline; $se_line =~ s/\n//; $self->{_SEs} = $se_line; } elsif (/^\s*\d+\.\.\d+/) { push @branches, map { [ split( /\.\./, $_ ) ] } split; my $ids = $_; $ids =~ s/\n//; $self->{_branch_ids} = $ids; } } return \@trees, \%match; } sub _parse_NSsitesBatch { my $self = shift; my ( %data, $idlookup ); my ( $okay, $done ) = ( 0, 0 ); while ( defined( $_ = $self->_readline ) ) { last if $done; next if /^\s+$/; next unless ( $okay || /^Model\s+\d+/ || /^TREE/ ); if (/^Model\s+(\d+)/) { if ($okay) { # this only happens if $okay was already 1 and # we hit a Model line $self->_pushback($_); $done = 1; } else { chomp; $data{'-model_num'} = $1; ( $data{'-model_description'} ) = (/\:\s+(.+)/); $okay = 1; } } elsif (/^Time used\:\s+(\S+)/) { $data{'-time_used'} = $1; $done = 1; } elsif (/^kappa\s+\(ts\/tv\)\s+\=\s+(\S+)/) { $data{'-kappa'} = $1; } elsif (/^TREE/) { $self->_pushback($_); ( $data{'-trees'}, $idlookup ) = $self->_parse_Forestry; if ( defined $data{'-trees'} && scalar @{ $data{'-trees'} } ) { $data{'-likelihood'} = $data{'-trees'}->[0]->score; } $okay = 1; } elsif (/^omega\s+\(dn\/ds\)\s+\=\s+(\S+)/i) { # for M0 (single ratio for the entire tree) # explicitly put '1.00000' rather than '1', because \d+\.\d{5} # is reported in all other cases. my @p = (q/1.00000/); # since there is only one class, my @w = $1; $data{'-dnds_site_classes'} = { 'p' => \@p, 'w' => \@w }; # since no K=X is provided, put 1 here $data{q/-num_site_classes/} = 1; } elsif ( /^(Naive Empirical Bayes)|(Bayes Empirical Bayes)|(Positively\sselected\ssites)/i ) { $self->_pushback($_); my ( $sites, $neb, $beb ) = $self->_parse_Pos_selected_sites; $data{'-pos_sites'} = $sites; $data{'-neb_sites'} = $neb; $data{'-beb_sites'} = $beb; } elsif (/^dN/i) { if (/K\=(\d+)/) { $data{'-num_site_classes'} = $1; while ( $_ = $self->_readline ) { unless ( $_ =~ /^\s+$/ ) { $self->_pushback($_); last; } } if (/^site class/) { $self->_readline; my $tmp = $self->_readline; my @p = $tmp =~ /(\d+\.\d{5})/g; $tmp = $self->_readline; my @b_w = $tmp =~ /(\d+\.\d{5})/g; $tmp = $self->_readline; my @f_w = $tmp =~ /(\d+\.\d{5})/g; my @w; foreach my $i ( 0 .. $#b_w ) { push @w, { q/background/ => $b_w[$i], q/foreground/ => $f_w[$i] }; } $data{'-dnds_site_classes'} = { q/p/ => \@p, q/w/ => \@w }; } else { my $tmp = $self->_readline; my @p = $tmp =~ /(\d+\.\d{5})/g; $tmp = $self->_readline; my @w = $tmp =~ /(\d+\.\d{5})/g; $data{'-dnds_site_classes'} = { 'p' => \@p, 'w' => \@w }; } } elsif (/for each branch/) { my %branch_dnds = $self->_parse_branch_dnds; if ( !defined $data{'-trees'} ) { $self->warn( "No trees have been loaded, can't do anything\n"); next; } my ($tree) = @{ $data{'-trees'} }; if ( !$tree || !ref($tree) || !$tree->isa('Bio::Tree::Tree') ) { $self->warn("no tree object already stored!\n"); next; } # These need to be added to the Node/branches while ( my ( $k, $v ) = each %branch_dnds ) { # we can probably do better by caching at some point my @nodes; for my $id ( split( /\.\./, $k ) ) { my @nodes_L = map { $tree->find_node( -id => $_ ) } @{ $idlookup->{$id} }; my $n = @nodes_L < 2 ? shift(@nodes_L) : $tree->get_lca(@nodes_L); if ( !$n ) { $self->warn( "no node could be found for $id (no lca?)"); } unless ( $n->is_Leaf && $n->id ) { $n->id($id); } push @nodes, $n; } my ( $parent, $child ) = @nodes; while ( my ( $kk, $vv ) = each %$v ) { $child->add_tag_value( $kk, $vv ); } } } } elsif (/^Parameters in beta:/) { $_ = $self->_readline; # need the next line if (/p\=\s+(\S+)\s+q\=\s+(\S+)/) { $data{'-shape_params'} = { 'shape' => 'beta', 'p' => $1, 'q' => $2 }; } else { $self->warn("unparseable beta parameters: $_"); } } elsif (/^Parameters in beta\&w\>1:/) { # Parameters in beta&w>1: # p0= 1.00000 p= 0.07642 q= 0.85550 # (p1= 0.00000) w= 1.00000 $_ = $self->_readline; # need the next line my ( $p0, $p, $q, $p1, $w ); if (/p0\=\s+(\S+)\s+p\=\s+(\S+)\s+q\=\s+(\S+)/) { $p0 = $1; $p = $2; $q = $3; } else { $self->warn("unparseable beta parameters: $_"); } $_ = $self->_readline; # need the next line if (/\(p1\=\s+(\S+)\)\s+w\=\s*(\S+)/) { $p1 = $1; $w = $2; $data{'-shape_params'} = { 'shape' => 'beta', 'p0' => $p0, 'p' => $p, 'q' => $q, 'p1' => $p1, 'w' => $w }; } else { $self->warn("unparseable beta parameters: $_"); } } elsif (/^alpha\s+\(gamma\)\s+\=\s+(\S+)/) { my $gamma = $1; $_ = $self->_readline; my ( @r, @f ); if (s/^r\s+\(\s*\d+\)\:\s+//) { @r = split; } $_ = $self->_readline; if (s/^f\s*\:\s+//) { @f = split; } $data{'-shape_params'} = { 'shape' => 'alpha', 'gamma' => $gamma, 'r' => \@r, 'f' => \@f }; } } return new Bio::Tools::Phylo::PAML::ModelResult(%data); } sub _parse_Pos_selected_sites { my $self = shift; my $okay = 0; my (%sites) = ( 'default' => [], 'neb' => [], 'beb' => [] ); my $type = 'default'; while ( defined( $_ = $self->_readline ) ) { next if ( /^\s+$/ || /^\s+Pr\(w\>1\)/ ); if ( /^Time used/ || /^TREE/ ) { $self->_pushback($_); last; } if (/^Naive Empirical Bayes/i) { $type = 'neb'; } elsif (/^Bayes Empirical Bayes/i) { $type = 'beb'; } elsif (/^Positively selected sites/) { $okay = 1; } elsif ( $okay && /^\s+(\d+)\s+(\S+)\s+(\-?\d+(?:\.\d+)?)(\**)\s+(\-?\d+(?:\.\d+)?)\s+\+\-\s+(\-?\d+(?:\.\d+)?)/ ) { my $signif = $4; $signif = '' unless defined $signif; push @{ $sites{$type} }, [ $1, $2, $3, $signif, $5, $6 ]; } elsif ( $okay && /^\s+(\d+)\s+(\S+)\s+(\-?\d*(?:.\d+))(\**)\s+(\-?\d+(?:\.\d+)?)/ ) { my $signif = $4; $signif = '' unless defined $signif; push @{ $sites{$type} }, [ $1, $2, $3, $signif, $5 ]; } elsif ( $okay && /^\s+(\d+)\s+(\S)\s+([\d\.\-\+]+)(\**)/ ) { my $signif = $4; $signif = '' unless defined $signif; push @{ $sites{$type} }, [ $1, $2, $3, $signif ]; } } return ( $sites{'default'}, $sites{'neb'}, $sites{'beb'} ); } sub _parse_branch_dnds { my $self = shift; my ($okay) = (0); my %branch_dnds; my @header; while ( defined( $_ = $self->_readline ) ) { next if (/^\s+$/); next unless ( $okay || /^\s+branch\s+t/ ); if (/^\s+branch\s+(.+)/) { s/^\s+//; @header = split( /\s+/, $_ ); $okay = 1; } elsif (/^\s*(\d+\.\.\d+)/) { my $branch = $1; s/^\s+//; my $i = 0; # fancyness just maps the header names like 't' or 'dN' # into the hash so we get at the end of the day # 't' => 0.067 # 'dN'=> 0.001 $branch_dnds{$branch} = { map { $header[ $i++ ] => $_ } split }; } else { $self->_pushback($_); last; } } return %branch_dnds; } #baseml stuff sub _parse_nt_freqs { my ($self) = @_; my ( $okay, $done, $header ) = ( 0, 0, 0 ); my (@bases); my $numseqs = scalar @{ $self->{'_summary'}->{'seqs'} || [] }; while ( defined( $_ = $self->_readline ) ) { if ( /^TREE/ || /^Distances/ ) { $self->_pushback($_); last } last if ($done); next if ( /^\s+$/ || /^\(Ambiguity/ ); if (/^Frequencies\./) { $okay = 1; } elsif ( !$okay ) { # skip till we see 'Frequencies. next; } elsif ( !$header ) { s/^\s+//; # remove leading whitespace @bases = split; # get an array of the all the aa names $header = 1; $self->{'_summary'}->{'ntfreqs'} = {}; # reset/clear values next; } elsif ( /^\#\s+constant\s+sites\:\s+ (\d+)\s+ # constant sites \(\s*([\d\.]+)\s*\%\s*\)/ox ) { $self->{'_summary'}->{'stats'}->{'constant_sites'} = $1; $self->{'_summary'}->{'stats'}->{'constant_sites_percentage'} = $2; } elsif (/^ln\s+Lmax\s+\(unconstrained\)\s+\=\s+(\S+)/ox) { $self->{'_summary'}->{'stats'}->{'loglikelihood'} = $1; $done = 1; # done for sure } else { my ( $seqname, @freqs ) = split; my $basect = 0; foreach my $f (@freqs) { # this will also store 'Average' $self->{'_summary'}->{'ntfreqs'}->{$seqname} ->{ $bases[ $basect++ ] } = $f; } } } } sub _parse_nt_dists { my ($self) = @_; my ( $okay, $seen, $done ) = ( 0, 0, 0 ); my ( %matrix, @names ); my $numseqs = scalar @{ $self->{'_summary'}->{'seqs'} || [] }; my $type = ''; while ( defined( $_ = $self->_readline ) ) { if (/^TREE/) { $self->_pushback($_); last; } last if $done; next if (/^This matrix is not used in later/); if (/^\s+$/) { last if ($seen); next; } if (/^Distances:(\S+)\s+\(([^\)]+)\)\s+\(alpha set at (\-?\d+\.\d+)\)/) { $okay = 1; $type = $1; next; } s/\s+$//g; # remove trailing space if ($okay) { my ( $seqname, $vl ) = split( /\s+/, $_, 2 ); $seen = 1; my $i = 0; if ( defined $vl ) { while ( $vl =~ /(\-?\d+\.\d+)\s*\(\s*(\-?\d+\.\d+)\s*\)\s*/g ) { my ( $kappa, $alpha ) = ( $1, $2 ); $matrix{$seqname}{ $names[$i] } = $matrix{ $names[$i] }{$seqname} = [ $kappa, $alpha ]; $i++; } unless ($i) { $self->warn("no matches for $vl\n"); } } push @names, $seqname; $matrix{$seqname}->{$seqname} = [ 0, 0 ]; } $done = 1 if ( scalar @names == $numseqs ); } my %dist; my $i = 0; my ( @kvalues, @avalues ); foreach my $lname (@names) { my ( @arow, @krow ); my $j = 0; foreach my $rname (@names) { my $v = $matrix{$lname}{$rname}; push @krow, $v->[0]; # kappa values push @arow, $v->[1]; # alpha $dist{$lname}{$rname} = [ $i, $j++ ]; } $i++; push @kvalues, \@krow; push @avalues, \@arow; } return ( Bio::Matrix::PhylipDist->new( -program => $self->{'_summary'}->{'seqtype'}, -matrix => \%dist, -names => \@names, -values => \@kvalues ), Bio::Matrix::PhylipDist->new( -program => $self->{'_summary'}->{'seqtype'}, -matrix => \%dist, -names => \@names, -values => \@avalues ) ); } # BASEML sub _parse_rate_parametes { my $self = shift; my (%rate_parameters); while ( defined( $_ = $self->_readline ) ) { if (/^Rate\s+parameters:\s+/) { s/\s+$//; $rate_parameters{'rate_parameters'} = [ split( /\s+/, $_ ) ]; } elsif (/^Base\s+frequencies:\s+/) { s/\s+$//; $rate_parameters{'base_frequencies'} = [ split( /\s+/, $_ ) ]; } elsif ( m/^Rate\s+matrix\s+Q,\s+Average\s+Ts\/Tv\s+(\([^\)+]+\))?\s*\=\s+ (\-?\d+\.\d+)/x ) { $rate_parameters{'average_TsTv'} = $1; while ( defined( $_ = $self->_readline ) ) { # short circuit last if (/^\s+$/); if (/^alpha/) { $self->_pushback($_); last; } s/^\s+//; s/\s+$//; push @{ $rate_parameters{'rate_matrix_Q'} }, [split]; } } elsif (/^alpha\s+\(gamma,\s+K=\s*(\d+)\s*\)\s*\=\s*(\-?\d+\.\d+)/) { $rate_parameters{'K'} = $1; $rate_parameters{'alpha'} = $2; } elsif (s/^(r|f):\s+//) { my ($p) = $1; s/\s+$//; $rate_parameters{$p} = [split]; } } } # RST parsing sub _parse_rst { my ($self) = @_; return unless $self->{'_dir'} && -d $self->{'_dir'} && -r $self->{'_dir'}; my $rstfile = File::Spec->catfile( $self->{'_dir'}, $RSTFILENAME ); return unless -e $rstfile && !-z $rstfile; my $rstio = Bio::Root::IO->new( -file => $rstfile ); # define whatever data structures you need to store the data # key points are to reuse existing bioperl objs (like Bio::Seq) # where appropriate my ( @firstseq, @seqs, @trees, @per_site_prob ); my $count; while ( defined( $_ = $rstio->_readline ) ) { # implement the parsing here if (/^TREE\s+\#\s+(\d+)/) { while ( defined( $_ = $rstio->_readline ) ) { if (/tree\s+with\s+node\s+labels\s+for/) { my $tree = Bio::TreeIO->new( -noclose => 1, -fh => $rstio->_fh, -format => 'newick' )->next_tree; # cleanup leading/trailing whitespace for my $n ( $tree->get_nodes ) { my $id = $n->id; $id =~ s/^\s+//; $id =~ s/\s+$//; $n->id($id); if ( defined( my $blen = $n->branch_length ) ) { $blen =~ s/^\s+//; $blen =~ s/\s+$//; $n->branch_length($blen); } } push @trees, $tree; last; } } } elsif (/^Prob\sof\sbest\scharacter\sat\seach\snode,\slisted\sby\ssite/) { $self->{'_rst'}->{'persite'} = []; while ( defined( $_ = $rstio->_readline ) ) { next if ( /^Site/i || /^\s+$/ ); if (s/^\s+(\d+)\s+(\d+)\s+([^:]+)\s*:\s*(.+)//) { my ( $sitenum, $freq, $extant, $ancestral ) = ( $1, $2, $3, $4 ); my ( @anc_site, @extant_site ); @extant_site = {}; while ( $extant =~ s/^([A-Z\-]{3})\s+\(([A-Z*])\)\s+//g ) { push @extant_site, { 'codon' => $1, 'aa' => $2 }; } while ( $ancestral =~ s/^([A-Z\-]{3})\s+([A-Z*])\s+ # codon AA (\S+)\s+ # Prob \(([A-Z*])\s+(\S+)\)\s*//xg # AA Prob ) { push @anc_site, { 'codon' => $1, 'aa' => $2, 'prob' => $3, 'Yang95_aa' => $4, 'Yang95_aa_prob' => $5 }; } # saving persite $self->{'_rst'}->{'persite'}->[$sitenum] = [ @extant_site, @anc_site ]; } elsif (/^Summary\sof\schanges\salong\sbranches\./) { last; } } } elsif (/^Check\sroot\sfor\sdirections\sof\schange\./ || /^Summary\sof\schanges\salong\sbranches\./ ) { my ( @branches, @branch2node, $branch, $node ); my $tree = $trees[-1]; if ( !$tree ) { $self->warn("No tree built before parsing Branch changes\n"); last; } my @nodes = ( map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [ $_, $_->id =~ /^(\d+)\_?/ ] } $tree->get_nodes ); unshift @nodes, undef; # fake first node so that index will match nodeid while ( defined( $_ = $rstio->_readline ) ) { next if /^\s+$/; if (m/^List\sof\sextant\sand\sreconstructed\ssequences/) { $rstio->_pushback($_); last; } elsif (/^Branch\s+(\d+):\s+(\d+)\.\.(\d+)\s+/) { my ( $left, $right ); ( $branch, $left, $right ) = ( $1, $2, $3 ); ($node) = $nodes[$right]; if ( !$node ) { $self->warn( "cannot find $right in $tree ($branch $left..$right)\n" ); last; } if (/\(n=\s*(\S+)\s+s=\s*(\S+)\)/) { $node->add_tag_value( 'n', $1 ); $node->add_tag_value( 's', $2 ); } $branch2node[$branch] = $right; } elsif ( /^\s+(\d+)\s+([A-Z*])\s+(\S+)\s+\-\>\s+([A-Z*])\s+(\S+)?/) { my ( $site, $anc, $aprob, $derived, $dprob ) = ( $1, $2, $3, $4, $5 ); if ( !$node ) { $self->warn("no branch line was previously parsed!"); next; } my %c = ( 'site' => $site, 'anc_aa' => $anc, 'anc_prob' => $aprob, 'derived_aa' => $derived, ); $c{'derived_prob'} = $dprob if defined $dprob; $node->add_tag_value( 'changes', \%c ); } } } elsif ( /^Overall\s+accuracy\s+of\s+the\s+(\d+)\s+ancestral\s+sequences:/) { my $line = $rstio->_readline; $line =~ s/^\s+//; $line =~ s/\s+$//; my @overall_site = split( /\s+/, $line ); # skip next 2 lines, want the third for ( 1 .. 3 ) { $line = $rstio->_readline; } $line =~ s/^\s+//; $line =~ s/\s+$//; my @overall_seq = split( /\s+/, $line ); if ( @overall_seq != @overall_site || @overall_seq != @seqs ) { $self->warn( "out of sync somehow seqs, site scores don't match\n"); $self->warn("@seqs @overall_seq @overall_site\n"); } for (@seqs) { $_->description( sprintf( "overall_accuracy_site=%s overall_accuracy_seq=%s", shift @overall_site, shift @overall_seq ) ); } } elsif (m/^List of extant and reconstructed sequences/o) { my $seqcount = 0; while ( defined( $_ = $rstio->_readline ) ) { last if (/^Overall accuracy of the/); if (/^\s+$/) { last if $seqcount && $seqcount == @seqs; next; } if (/^\s*(\d+)\s+(\d+)\s+$/) { $seqcount = $1; next } # runmode = (0) # this should in fact be packed into a Bio::SimpleAlign object # instead of an array but we'll stay with this for now if (/^node/) { my ( $name, $num, $seqstr ) = split( /\s+/, $_, 3 ); $name .= $num; $seqstr =~ s/\s+//g; # remove whitespace unless (@firstseq) { @firstseq = split( //, $seqstr ); push @seqs, Bio::LocatableSeq->new( -display_id => $name, -seq => $seqstr ); } else { my $i = 0; my $v; while ( ( $v = index( $seqstr, '.', $i ) ) >= $i ) { # replace the '.' with the correct seq from the substr( $seqstr, $v, 1, $firstseq[$v] ); $i = $v; } $self->debug("adding seq $seqstr\n"); push @seqs, Bio::LocatableSeq->new( -display_id => $name, -seq => $seqstr ); } } } $self->{'_rst'}->{'rctrted_seqs'} = \@seqs; } else { } } $self->{'_rst'}->{'trees'} = \@trees; return; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Molphy��������������������������������������������������������������000755��000765��000024�� 0�12254227333� 17456� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Molphy/Result.pm����������������������������������������������������000444��000765��000024�� 21135�12254227333� 21451� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::Molphy::Result # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::Molphy::Result - container for data parsed from a ProtML run =head1 SYNOPSIS # do not use this object directly, you will get it back as part of a # Molphy parser use Bio::Tools::Phylo::Molphy; my $parser = Bio::Tools::Phylo::Molphy->new(-file => 'output.protml'); while( my $r = $parser->next_result ) { # r is a Bio::Tools::Phylo::Molphy::Result object # print the model name print $r->model, "\n"; # get the substitution matrix # this is a hash of 3letter aa codes -> 3letter aa codes representing # substitution rate my $smat = $r->substitution_matrix; print "Arg -> Gln substitution rate is %d\n", $smat->{'Arg'}->{'Gln'}, "\n"; # get the transition probablity matrix # this is a hash of 3letter aa codes -> 3letter aa codes representing # transition probabilty my $tmat = $r->transition_probability_matrix; print "Arg -> Gln transition probablity is %.2f\n", $tmat->{'Arg'}->{'Gln'}, "\n"; # get the frequency for each of the residues my $rfreqs = $r->residue_frequencies; foreach my $residue ( keys %{$rfreqs} ) { printf "residue %s expected freq: %.2f observed freq: %.2f\n", $residue,$rfreqs->{$residue}->[0], $rfreqs->{$residue}->[1]; } my @trees; while( my $t = $r->next_tree ) { push @trees, $t; } print "search space is ", $r->search_space, "\n", "1st tree score is ", $trees[0]->score, "\n"; # writing to STDOUT, use -file => '>filename' to specify a file my $out = Bio::TreeIO->new(-format => "newick"); $out->write_tree($trees[0]); # writing only the 1st tree } =head1 DESCRIPTION A container for data parsed from a ProtML run. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::Molphy::Result; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::Molphy::Result->new(); Function: Builds a new Bio::Tools::Phylo::Molphy::Result object Returns : Bio::Tools::Phylo::Molphy::Result Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($trees,$smat,$freq, $model, $sspace, ) = $self->_rearrange([qw(TREES SUBSTITUTION_MATRIX FREQUENCIES MODEL SEARCH_SPACE)], @args); if( $trees ) { if(ref($trees) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize trees"); } else { foreach my $t ( @$trees ) { $self->add_tree($t); } } } # initialize things through object methods to be a good # little OO programmer if( ref($smat) =~ /HASH/i ) { $self->substitution_matrix($smat); } if( ref($freq) =~ /HASH/i ) { $self->residue_frequencies($freq); } $model && $self->model($model); $sspace && $self->search_space($sspace); $self->{'_treeiterator'} = 0; return $self; } =head2 model Title : model Usage : $obj->model($newval) Function: Returns : value of model Args : newvalue (optional) =cut sub model{ my ($self,$value) = @_; if( defined $value) { $self->{'model'} = $value; } return $self->{'model'}; } =head2 substitution_matrix Title : substitution_matrix Usage : my $smat = $result->subsitution_matrix; Function: Get the relative substitution matrix calculated in the ML procedure Returns : reference to hash of hashes where key is the aa/nt name and value is another hash ref which contains keys for all the aa/nt possibilities Args : none =cut sub substitution_matrix{ my ($self,$val) = @_; if(defined $val ) { if( ref($val) =~ /HASH/ ) { foreach my $v (values %{$val} ) { if( ref($v) !~ /HASH/i ) { $self->warn("Must be a valid hashref of hashrefs for substition_matrix"); return; } } $self->{'_substitution_matrix'} = $val; } else { $self->warn("Must be a valid hashref of hashrefs for substition_matrix"); return; } } return $self->{'_substitution_matrix'}; } =head2 transition_probability_matrix Title : transition_probability_matrix Usage : my $matrixref = $molphy->transition_probablity_matrix(); Function: Gets the observed transition probability matrix Returns : hash of hashes of aa/nt transition to each other aa/nt Args : Transition matrix type, typically '1PAM-1.0e05' or '1PAM-1.0e07' =cut sub transition_probability_matrix { my ($self,$type,$val) = @_; $type = '1PAM-1.0e7' unless defined $type; if(defined $val ) { if( ref($val) =~ /HASH/ ) { foreach my $v (values %{$val} ) { if( ref($v) !~ /HASH/i ) { $self->warn("Must be a valid hashref of hashrefs for transition_probability_matrix"); return; } } $self->{'_TPM'}->{$type} = $val; } else { $self->warn("Must be a valid hashref of hashrefs for transition_probablity_matrix"); return; } } # fix this for nucml where there are 2 values (one is just a transformation # of the either, but how to represent?) return $self->{'_TPM'}->{$type}; } =head2 residue_frequencies Title : residue_frequencies Usage : my %data = $molphy->residue_frequencies() Function: Get the modeled and expected frequencies for each of the residues in the sequence Returns : hash of either aa (protml) or nt (nucml) frequencies each key will point to an array reference where 1st slot is model's expected frequency 2nd slot is observed frequency in the data $hash{'A'}->[0] = Args : none =cut #' sub residue_frequencies { my ($self,$val) = @_; if(defined $val ) { if( ref($val) =~ /HASH/ ) { $self->{'_residue_frequencies'} = $val; } else { $self->warn("Must be a valid hashref of hashrefs for residue_frequencies"); } } return %{$self->{'_residue_frequencies'}}; } =head2 next_tree Title : next_tree Usage : my $tree = $factory->next_tree; Function: Get the next tree from the factory Returns : L<Bio::Tree::TreeI> Args : none =cut sub next_tree{ my ($self,@args) = @_; return $self->{'_trees'}->[$self->{'_treeiterator'}++] || undef; } =head2 rewind_tree Title : rewind_tree_iterator Usage : $result->rewind_tree() Function: Rewinds the tree iterator so that next_tree can be called again from the beginning Returns : none Args : none =cut sub rewind_tree_iterator { shift->{'_treeiterator'} = 0; } =head2 add_tree Title : add_tree Usage : $result->add_tree($tree); Function: Adds a tree Returns : integer which is the number of trees stored Args : L<Bio::Tree::TreeI> =cut sub add_tree{ my ($self,$tree) = @_; if( $tree && ref($tree) && $tree->isa('Bio::Tree::TreeI') ) { push @{$self->{'_trees'}},$tree; } return scalar @{$self->{'_trees'}}; } =head2 search_space Title : search_space Usage : $obj->search_space($newval) Function: Returns : value of search_space Args : newvalue (optional) =cut sub search_space{ my ($self,$value) = @_; if( defined $value) { $self->{'search_space'} = $value; } return $self->{'search_space'}; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/PAML����������������������������������������������������������������000755��000765��000024�� 0�12254227340� 16735� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/PAML/Codeml.pm������������������������������������������������������000444��000765��000024�� 16434�12254227340� 20663� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::PAML::Codeml # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich, Aaron J Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::PAML::Codeml - Parses output from the PAML program codeml. =head1 SYNOPSIS #!/usr/bin/perl -Tw use strict; use Bio::Tools::Phylo::PAML::Codeml; # need to specify the output file name (or a fh) (defaults to # -file => "codeml.mlc"); also, optionally, the directory in which # the other result files (rst, 2ML.dS, etc) may be found (defaults # to "./") my $parser = new Bio::Tools::Phylo::PAML::Codeml::Parser (-file => "./results/mlc", -dir => "./results/"); # get the first/next result; a Bio::[...]::Codeml::Result object my $result = $parser->next_result(); # get the sequences used in the analysis; returns Bio::PrimarySeq # objects (OTU = Operational Taxonomic Unit). my @otus = $result->get_seqs(); # codon summary: codon usage of each sequence [ arrayref of { # hashref of counts for each codon } for each sequence and the # overall sum ], and positional nucleotide distribution [ arrayref # of { hashref of frequencies for each nucleotide } for each # sequence and overall frequencies ]. my ($codonusage, $ntdist) = $result->get_codon_summary(); # example manipulations of $codonusage and $ntdist: printf "There were %d '%s' codons in the first seq (%s)\n", $codonusage->[0]->{AAA}, 'AAA', $otus[0]->id(); printf "There were %d '%s' codons used in all the sequences\n", $codonusage->[$#{$codonusage}]->{AAA}, 'AAA'; printf "Nucleotide '%c' was present %g of the time in seq %s\n", 'A', $ntdist->[1]->{A}, $otus[1]->id(); # get Nei & Gojobori dN/dS matrix: my $NGmatrix = $result->get_NGmatrix(); # get ML-estimated dN/dS matrix, if calculated; this corresponds to # the runmode = -2, pairwise comparison usage of codeml my $MLmatrix = $result->get_MLmatrix(); # These matrices are length(@otu) x length(@otu) "strict lower # triangle" 2D-matrices, which means that the diagonal and # everything above it is undefined. Each of the defined cells is a # hashref of estimates for "dN", "dS", "omega" (dN/dS ratio), "t", # "S" and "N". If a ML matrix, "lnL" will also be defined. Any # additional ML parameters estimated by the model will be in an # array ref under "params"; it's up to the user to know which # position corresponds to which parameter (since PAML doesn't label # them, and we can't guess very well yet (a TODO I guess). printf "The omega ratio for sequences %s vs %s was: %g\n", $otus[0]->id, $otus[1]->id, $MLmatrix->[0]->[1]->{omega}; # with a little work, these matrices could also be passed to # Bio::Tools::Run::Phylip::Neighbor, or other similar tree-building # method that accepts a matrix of "distances" (using the LOWTRI # option): my $distmat = [ map { [ map { $$_{omega} } @$_ ] } @$MLmatrix ]; # for runmode's other than -2, get tree topology with estimated # branch lengths; returns a Bio::Tree::TreeI-based tree object with # added PAML parameters at each node my $tree = $result->get_tree(); for my $node ($tree->get_nodes()) { # inspect the tree: the "t" (time) parameter is available via # $node->branch_length(); all other branch-specific parameters # ("omega", "dN", etc.) are available via $node->param('omega'); } # get any general model parameters: kappa (the # transition/transversion ratio), NSsites model parameters ("p0", # "p1", "w0", "w1", etc.), etc. my $params = $result->get_model_params(); printf "M1 params: p0 = %g\tp1 = %g\n", $params->{p0}, $params->{p1}; # for NSsites models, obtain posterior probabilities for membership # in each class for every position; probabilities correspond to # classes w0, w1, ... etc. my @probs = $result->get_posteriors(); # find, say, positively selected sites! if ($params->{w2} > 1) { for (my $i = 0; $i < @probs ; $i++) { if ($probs[$i]->[2] > 0.5) { # assumes model M1: three w's, w0, w1 and w2 (positive selection) printf "position %d: (%g prob, %g omega, %g mean w)\n", $i, $probs[$i]->[2], $params->{w2}, $probs[$i]->[3]; } } } else { print "No positive selection found!\n"; } =head1 DESCRIPTION This module is used to parse the output from the PAML program codeml. You can use the Bio::Tools::Run::Phylo::Phylo::PAML::Codeml module to actually run codeml; this module is only useful to parse the output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/MailList.shtml - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: bioperl-bugs@bioperl.org http://bioperl.org/bioperl-bugs/ =head1 AUTHOR - Jason Stajich, Aaron Mackey Email jason@bioperl.org Email amackey@virginia.edu =head1 TODO This module should also be able to handle "codemlsites" batch output... =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::PAML::Codeml; use vars qw(@ISA); use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Root::Root; use Bio::Root::IO; use Bio::TreeIO; use IO::String; @ISA = qw(Bio::Root::Root Bio::Root::IO ); =head2 new Title : new Usage : my $obj = new Bio::Tools::Phylo::PAML::Codeml(); Function: Builds a new Bio::Tools::Phylo::PAML::Codeml object Returns : Bio::Tools::Phylo::PAML::Codeml Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); $self->_parse_mlc(); return $self; } =head2 get_trees Title : get_trees Usage : my @trees = $codemlparser->get_trees(); Function: Returns a list of trees (if any) are in the output file Returns : List of L<Bio::Tree::TreeI> objects Args : none =cut sub get_trees{ my ($self) = @_; } =head2 get_statistics Title : get_statistics Usage : my $data = $codemlparser->get_statistics Function: Retrieves the set of pairwise comparisons Returns : Hash Reference keyed as 'seqname' -> 'seqname' -> 'datatype' Args : none =cut sub get_statistics { my ($self) = @_; } # parse the mlc file sub _parse_mlc { my ($self) = @_; my %data; while( defined( $_ = $self->_readline) ) { print; # Aaron this is where the parsing should begin # I'll do the Tree objects if you like - # I'd do it by building an IO::String for the # the tree data # or does it make more sense to parse this out of a collection of # files? if( /^TREE/ ) { # ... while( defined($_ = $self->_readline) ) { if( /^\(/) { my $treestr = IO::String->new($_); my $treeio = Bio::TreeIO->new(-fh => $treestr, -format => 'newick'); # this is very tenative here!! push @{$self->{'_trees'}}, $treeio->next_tree; } } } } } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/PAML/ModelResult.pm�������������������������������������������������000444��000765��000024�� 36541�12254227326� 21724� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::PAML::ModelResult # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@open-bio.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::PAML::ModelResult - A container for NSSite Model Result from PAML =head1 SYNOPSIS # get a ModelResult from a PAML::Result object use Bio::Tools::Phylo::PAML; my $paml = Bio::Tools::Phylo::PAML->new(-file => 'mlc'); my $result = $paml->next_result; foreach my $model ( $result->get_NSSite_results ) { print $model->model_num, " ", $model->model_description, "\n"; print $model->kappa, "\n"; print $model->run_time, "\n"; # if you are using PAML < 3.15 then only one place for POS sites for my $sites ( $model->get_pos_selected_sites ) { print join("\t",@$sites),"\n"; } # otherwise query NEB and BEB slots for my $sites ( $model->get_NEB_pos_selected_sites ) { print join("\t",@$sites),"\n"; } for my $sites ( $model->get_BEB_pos_selected_sites ) { print join("\t",@$sites),"\n"; } } =head1 DESCRIPTION Describe the object here =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@open-bio.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::PAML::ModelResult; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::PAML::ModelResult->new(); Function: Builds a new Bio::Tools::Phylo::PAML::ModelResult object Returns : an instance of Bio::Tools::Phylo::PAML::ModelResult Args : -model_num => model number -model_description => model description -kappa => value of kappa -time_used => amount of time -pos_sites => arrayref of sites under positive selection -neb_sites => arrayref of sites under positive selection (by NEB analysis) -beb_sites => arrayref of sites under positive selection (by BEB analysis) -trees => arrayref of tree(s) data for this model -shape_params => hashref of parameters ('shape' => 'alpha', 'gamma' => $g, 'r' => $r, 'f' => $f ) OR ( 'shape' => 'beta', 'p' => $p, 'q' => $q ) -likelihood => likelihood -num_site_classes => number of site classes -dnds_site_classes => hashref with two keys, 'p' and 'w' which each point to an array, each slot is for a different site class. 'w' is for dN/dS and 'p' is probability =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($modelnum,$modeldesc,$kappa, $timeused,$trees, $pos_sites,$neb_sites,$beb_sites, $num_site_classes, $shape_params, $dnds_classes, $likelihood) = $self->_rearrange([qw(MODEL_NUM MODEL_DESCRIPTION KAPPA TIME_USED TREES POS_SITES NEB_SITES BEB_SITES NUM_SITE_CLASSES SHAPE_PARAMS DNDS_SITE_CLASSES LIKELIHOOD)], @args); if( $trees ) { if(ref($trees) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize trees"); } else { foreach my $t ( @$trees ) { $self->add_tree($t); } } } $self->{'_treeiterator'} = 0; if( $pos_sites ) { if(ref($pos_sites) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize pos_sites"); } else { foreach my $s ( @$pos_sites ) { if( ref($s) !~ /ARRAY/i ) { $self->warn("Need an array reference for each entry in the pos_sites object"); next; } $self->add_pos_selected_site(@$s); } } } if( $beb_sites ) { if(ref($beb_sites) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize beb_sites"); } else { foreach my $s ( @$beb_sites ) { if( ref($s) !~ /ARRAY/i ) { $self->warn("need an array ref for each entry in the beb_sites object"); next; } $self->add_BEB_pos_selected_site(@$s); } } } if( $neb_sites ) { if(ref($neb_sites) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize neb_sites"); } else { foreach my $s ( @$neb_sites ) { if( ref($s) !~ /ARRAY/i ) { $self->warn("need an array ref for each entry in the neb_sites object"); next; } $self->add_NEB_pos_selected_site(@$s); } } } defined $modelnum && $self->model_num($modelnum); defined $modeldesc && $self->model_description($modeldesc); defined $kappa && $self->kappa($kappa); defined $timeused && $self->time_used($timeused); defined $likelihood && $self->likelihood($likelihood); $self->num_site_classes($num_site_classes || 0); if( defined $dnds_classes ) { if( ref($dnds_classes) !~ /HASH/i || ! defined $dnds_classes->{'p'} || ! defined $dnds_classes->{'w'} ) { $self->warn("-dnds_site_classes expects a hashref with keys p and w"); } else { $self->dnds_site_classes($dnds_classes); } } if( defined $shape_params ) { if( ref($shape_params) !~ /HASH/i ) { $self->warn("-shape_params expects a hashref not $shape_params\n"); } else { $self->shape_params($shape_params); } } return $self; } =head2 model_num Title : model_num Usage : $obj->model_num($newval) Function: Get/Set the Model number (0,1,2,3...) Returns : value of model_num (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub model_num { my $self = shift; return $self->{'_num'} = shift if @_; return $self->{'_num'}; } =head2 model_description Title : model_description Usage : $obj->model_description($newval) Function: Get/Set the model description This is something like 'one-ratio', 'neutral', 'selection' Returns : value of description (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub model_description{ my $self = shift; return $self->{'_model_description'} = shift if @_; return $self->{'_model_description'}; } =head2 time_used Title : time_used Usage : $obj->time_used($newval) Function: Get/Set the time it took to run this analysis Returns : value of time_used (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub time_used{ my $self = shift; return $self->{'_time_used'} = shift if @_; return $self->{'_time_used'}; } =head2 kappa Title : kappa Usage : $obj->kappa($newval) Function: Get/Set kappa (ts/tv) Returns : value of kappa (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub kappa{ my $self = shift; return $self->{'_kappa'} = shift if @_; return $self->{'_kappa'}; } =head2 num_site_classes Title : num_site_classes Usage : $obj->num_site_classes($newval) Function: Get/Set the number of site classes for this model Returns : value of num_site_classes (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub num_site_classes{ my $self = shift; return $self->{'_num_site_classes'} = shift if @_; return $self->{'_num_site_classes'}; } =head2 dnds_site_classes Title : dnds_site_classes Usage : $obj->dnds_site_classes($newval) Function: Get/Set dN/dS site classes, a hashref with 2 keys, 'p' and 'w' which point to arrays one slot for each site class. Returns : value of dnds_site_classes (a hashref) Args : on set, new value (a scalar or undef, optional) =cut sub dnds_site_classes{ my $self = shift; return $self->{'_dnds_site_classes'} = shift if @_; return $self->{'_dnds_site_classes'}; } =head2 get_pos_selected_sites Title : get_pos_selected_sites Usage : my @sites = $modelresult->get_pos_selected_sites(); Function: Get the sites which PAML has identified as under positive selection (w > 1). This returns an array with each slot being a site, 4 values, site location (in the original alignment) Amino acid (I *think* in the first sequence) P (P value) Significance (** indicated > 99%, * indicates >=95%) Returns : Array Args : none =cut sub get_pos_selected_sites{ return @{$_[0]->{'_posselsites'} || []}; } =head2 add_pos_selected_site Title : add_pos_selected_site Usage : $result->add_pos_selected_site($site,$aa,$pvalue,$signif); Function: Add a site to the list of positively selected sites Returns : count of the number of sites stored Args : $site - site number (in the alignment) $aa - amino acid under selection $pvalue - float from 0->1 represent probability site is under selection according to this model $signif - significance (coded as either empty, '*', or '**' =cut sub add_pos_selected_site{ my ($self,$site,$aa,$pvalue,$signif) = @_; push @{$self->{'_posselsites'}}, [ $site,$aa,$pvalue,$signif ]; return scalar @{$self->{'_posselsites'}}; } =head2 get_NEB_pos_selected_sites Title : get_NEB_pos_selected_sites Usage : my @sites = $modelresult->get_NEB_pos_selected_sites(); Function: Get the sites which PAML has identified as under positive selection (w > 1) using Naive Empirical Bayes. This returns an array with each slot being a site, 4 values, site location (in the original alignment) Amino acid (I *think* in the first sequence) P (P value) Significance (** indicated > 99%, * indicates > 95%) post mean for w Returns : Array Args : none =cut sub get_NEB_pos_selected_sites{ return @{$_[0]->{'_NEBposselsites'} || []}; } =head2 add_NEB_pos_selected_site Title : add_NEB_pos_selected_site Usage : $result->add_NEB_pos_selected_site($site,$aa,$pvalue,$signif); Function: Add a site to the list of positively selected sites Returns : count of the number of sites stored Args : $site - site number (in the alignment) $aa - amino acid under selection $pvalue - float from 0->1 represent probability site is under selection according to this model $signif - significance (coded as either empty, '*', or '**' $postmean - post mean for w =cut sub add_NEB_pos_selected_site{ my ($self,@args) = @_; push @{$self->{'_NEBposselsites'}}, [ @args ]; return scalar @{$self->{'_NEBposselsites'}}; } =head2 get_BEB_pos_selected_sites Title : get_BEB_pos_selected_sites Usage : my @sites = $modelresult->get_BEB_pos_selected_sites(); Function: Get the sites which PAML has identified as under positive selection (w > 1) using Bayes Empirical Bayes. This returns an array with each slot being a site, 6 values, site location (in the original alignment) Amino acid (I *think* in the first sequence) P (P value) Significance (** indicated > 99%, * indicates > 95%) post mean for w (mean) Standard Error for w (SE) Returns : Array Args : none =cut sub get_BEB_pos_selected_sites{ return @{$_[0]->{'_BEBposselsites'} || []}; } =head2 add_BEB_pos_selected_site Title : add_BEB_pos_selected_site Usage : $result->add_BEB_pos_selected_site($site,$aa,$pvalue,$signif); Function: Add a site to the list of positively selected sites Returns : count of the number of sites stored Args : $site - site number (in the alignment) $aa - amino acid under selection $pvalue - float from 0->1 represent probability site is under selection according to this model $signif - significance (coded as either empty, '*', or '**' $postmean - post mean for w $SE - Standard Error for w =cut sub add_BEB_pos_selected_site{ my ($self,@args) = @_; push @{$self->{'_BEBposselsites'}}, [ @args ]; return scalar @{$self->{'_BEBposselsites'}}; } =head2 next_tree Title : next_tree Usage : my $tree = $factory->next_tree; Function: Get the next tree from the factory Returns : L<Bio::Tree::TreeI> Args : none =cut sub next_tree{ my ($self,@args) = @_; return $self->{'_trees'}->[$self->{'_treeiterator'}++] || undef; } =head2 get_trees Title : get_trees Usage : my @trees = $result->get_trees; Function: Get all the parsed trees as an array Returns : Array of trees Args : none =cut sub get_trees{ my ($self) = @_; return @{$self->{'_trees'} || []}; } =head2 rewind_tree_iterator Title : rewind_tree_iterator Usage : $result->rewind_tree_iterator() Function: Rewinds the tree iterator so that next_tree can be called again from the beginning Returns : none Args : none =cut sub rewind_tree_iterator { shift->{'_treeiterator'} = 0; } =head2 add_tree Title : add_tree Usage : $result->add_tree($tree); Function: Adds a tree Returns : integer which is the number of trees stored Args : L<Bio::Tree::TreeI> =cut sub add_tree{ my ($self,$tree) = @_; if( $tree && ref($tree) && $tree->isa('Bio::Tree::TreeI') ) { push @{$self->{'_trees'}},$tree; } return scalar @{$self->{'_trees'}}; } =head2 shape_params Title : shape_params Usage : $obj->shape_params($newval) Function: Get/Set shape params for the distribution, 'alpha', 'beta' which is a hashref with 1 keys, 'p' and 'q' Returns : value of shape_params (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub shape_params{ my $self = shift; return $self->{'_shape_params'} = shift if @_; return $self->{'_shape_params'}; } =head2 likelihood Title : likelihood Usage : $obj->likelihood($newval) Function: log likelihood Returns : value of likelihood (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub likelihood{ my $self = shift; return $self->{'likelihood'} = shift if @_; return $self->{'likelihood'}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/PAML/Result.pm������������������������������������������������������000444��000765��000024�� 67176�12254227335� 20753� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Phylo::PAML::Result # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich, Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::PAML::Result - A PAML result set object =head1 SYNOPSIS # see Bio::Tools::Phylo::PAML for example usage use Bio::Tools::Phylo::PAML; my $parser = Bio::Tools::Phylo::PAML->new (-file => "./results/mlc", -dir => "./results/"); # get the first/next result; a Bio::Tools::Phylo::PAML::Result object, # which isa Bio::SeqAnalysisResultI object. my $result = $parser->next_result(); my @seqs = $result->get_seqs; my %input_params = $result->get_input_parameters; my @basfreq = $result->get_codon_pos_basefreq; my $MLmatrix = $result->get_MLmatrix; # get MaxLikelihood Matrix my $NGmatrix = $result->get_NGmatrix; # get Nei-Gojoburi Matrix # for AAML runs my $AAmatrix = $result->get_AADistMatrix; my $AAMLmatrix = $result->get_AAMLDistMatrix; # if -dir contains an rst file get list of # Bio::PrimarySeq ancestral state reconstructions of the sequences my @rsts = $result->get_rst_seqs; # if you want to print the changes on the tree # this will print out the # anc_aa => ANCESTRAL AMINO ACID # anc_prob => ANCESTRAL AA PROBABILITY # derived_aa => DERIVED AA # derived_prob => DERIVE AA PROBABILITY (where appropriate - NA for extant/tip taxas) # site => which codon site this in the alignment @trees = $result->get_rst_trees; for my $t ( @trees ) { for my $node ( $t->get_nodes ) { next unless $node->ancestor; # skip root node my @changes = $node->get_tag_values('changes'); my $chgstr = ''; for my $c ( @changes ) { for my $k ( sort keys %$c ) { $chgstr .= "$k => $c->{$k} "; } $chgstr .= "\n\t"; } printf "node:%s n=%s s=%s\n\t%s\n", $node->id, $node->get_tag_values('n'), $node->get_tag_values('s'), $chgstr; } } # Persite probabilities my $persite = $result->get_rst_persite; # let's score site 1 $site = $persite->[2]; # so site 2, node 2 (extant node, node 2) print $site->[2]->{'codon'}, ' ',$site->[2]->{'aa'},"\n"; # site 2, node 3 print $site->[3]->{'codon'}, ' ',$site->[3]->{'aa'}, "\n"; # ancestral node 9, codon, aa, marginal probabilities; Yang95 is listed as # (eqn. 4 in Yang et al. 1995 Genetics 141:1641-1650) in PAML rst file. print $site->[9]->{'codon'}, ' ',$site->[9]->{'aa'}, ' ', $site->[9]->{'prob'}, ' ', $site->[9]->{'Yang95_aa'},' ', $site->[9]->{'Yang95_aa_prob'},"\n"; =head1 DESCRIPTION This is a container object for PAML Results. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via email or the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Aaron Mackey Email jason-at-bioperl-dot-org Email amackey-at-virginia-dot-edu =head1 CONTRIBUTORS Albert Vilella avilella-AT-gmail-DOT-com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::PAML::Result; use strict; use base qw(Bio::Root::Root Bio::AnalysisResultI); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::PAML::Result->new(%data); Function: Builds a new Bio::Tools::Phylo::PAML::Result object Returns : Bio::Tools::Phylo::PAML::Result Args : -trees => array reference of Bio::Tree::TreeI objects -MLmatrix => ML matrix -seqs => array reference of Bio::PrimarySeqI objects -codonpos => array reference of codon positions -codonfreq => array reference of codon frequencies -version => version string -model => model string -patterns => hashref with the fields '-patterns', '-ns', '-ls' -stats => array ref of misc stats (optional) -aafreq => Hashref of AA frequencies (only for AAML) -aadistmat => Bio::Matrix::PhylipDist (only for AAML) -aamldistmat => Bio::Matrix::PhylipDist (only for pairwise AAML) -ntfreq => array ref of NT frequencies (only for BASEML) -seqfile => seqfile used -kappa_mat => Bio::Matrix::PhylipDist of kappa values (only for BASEML) -alpha_mat => Bio::Matrix::PhylipDist of alpha values (only for BASEML) -NSSitesresult => arrayref of PAML::ModelResult -input_params => input params from .ctl file -rst => array reference of Bio::PrimarySeqI objects of ancestral state reconstruction -rst_persite=> arrayref of persite data, this is a complicated set of AoH -rst_trees => rst trees with changes coded on the tree See Also: L<Bio::Tree::TreeI>, L<Bio::PrimarySeqI>, L<Bio::Matrix::PhylipDist>, L<Bio::Tools::Phylo::PAML> =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($trees,$mlmat,$seqs,$ngmatrix, $codonpos,$codonfreq,$version, $model,$patterns, $stats, $aafreq, $aadistmat, $aamldistmat, $ntfreqs, $seqfile, $kappa_mat, $alpha_mat, $NSSitesresults,$input_params,$rst,$rst_persite,$rst_trees ) = $self->_rearrange([qw (TREES MLMATRIX SEQS NGMATRIX CODONPOS CODONFREQ VERSION MODEL PATTERNS STATS AAFREQ AADISTMAT AAMLDISTMAT NTFREQ SEQFILE KAPPA_DISTMAT ALPHA_DISTMAT NSSITESRESULTS INPUT_PARAMS RST RST_PERSITE RST_TREES)], @args); $self->reset_seqs; if( $trees ) { if(ref($trees) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize trees"); } else { foreach my $t ( @$trees ) { $self->add_tree($t); } } } $self->{'_treeiterator'} = 0; if( $mlmat ) { if( ref($mlmat) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize MLmatrix"); } else { $self->set_MLmatrix($mlmat); } } if( $seqs ) { if( ref($seqs) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize seqs"); } else { foreach my $s ( @$seqs ) { $self->add_seq($s); } } } if( $ngmatrix ) { if( ref($ngmatrix) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize NGmatrix"); } else { $self->set_NGmatrix($ngmatrix); } } if( $codonfreq ) { if( ref($codonfreq) =~ /ARRAY/i ) { $self->set_CodonFreqs($codonfreq); } else { $self->warn("Must provide a valid array reference to initialize codonfreq"); } } if( $codonpos ) { if( ref($codonpos) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference to initialize codonpos"); } else { $self->set_codon_pos_basefreq(@$codonpos); } } $self->version($version) if defined $version; $self->seqfile($seqfile) if defined $seqfile; $self->model($model) if defined $model; if( defined $patterns ) { if( ref($patterns) =~ /HASH/i ) { $self->patterns($patterns); } else { $self->warn("Must provide a valid array reference to initialize patterns"); } } $self->{'_aafreqs'} = {}; if( $aafreq ) { if( ref($aafreq) =~ /HASH/i ) { $self->set_AAFreqs($aafreq); } else { $self->warn("Must provide a valid hash reference to initialize aafreq"); } } if( $stats ) { if( ref($stats) =~ /HASH/i ) { while( my ($stat,$val) = each %$stats) { $self->add_stat($stat,$val); } } else { $self->warn("Must provide a valid hash reference initialize stats"); } } $self->set_AADistMatrix($aadistmat) if defined $aadistmat; $self->set_AAMLDistMatrix($aamldistmat) if defined $aamldistmat; if( defined $NSSitesresults ) { if( ref($NSSitesresults) !~ /ARRAY/i ) { $self->warn("expected an arrayref for -NSSitesresults"); } else { foreach my $m ( @$NSSitesresults ) { $self->add_NSSite_result($m); } } } $self->{'_ntfreqs'} = {}; if( $ntfreqs ) { if( ref($ntfreqs) =~ /HASH/i ) { $self->set_NTFreqs($ntfreqs); } else { $self->warn("Must provide a valid hash reference to initialize ntfreq"); } } if( $kappa_mat ) { $self->set_KappaMatrix($kappa_mat); } if( $alpha_mat ) { $self->set_AlphaMatrix($alpha_mat); } if( $input_params ) { if( ref($input_params) !~ /HASH/i ) { $self->warn("Must provide a valid hash object for input_params\n"); } else { while( my ($p,$v) = each %$input_params ) { $self->set_input_parameter($p,$v); } } } $self->reset_rst_seqs; if( $rst ) { if( ref($rst) =~ /ARRAY/i ) { for ( @$rst ) { $self->add_rst_seq($_); } } else { $self->warn("Need a valid array ref for -rst option\n"); } } if( defined $rst_persite ) { $self->set_rst_persite($rst_persite); } $self->reset_rst_trees; if( $rst_trees ) { if( ref($rst_trees) =~ /ARRAY/i ) { for ( @$rst_trees ) { $self->add_rst_tree($_); } } else { $self->warn("Need a valid array ref for -rst_trees option\n"); } } return $self; } =head2 next_tree Title : next_tree Usage : my $tree = $factory->next_tree; Function: Get the next tree from the factory Returns : L<Bio::Tree::TreeI> Args : none =cut sub next_tree{ my ($self,@args) = @_; return $self->{'_trees'}->[$self->{'_treeiterator'}++] || undef; } =head2 get_trees Title : get_trees Usage : my @trees = $result->get_trees; Function: Get all the parsed trees as an array Returns : Array of trees Args : none =cut sub get_trees{ my ($self) = @_; return @{$self->{'_trees'} || []}; } =head2 rewind_tree_iterator Title : rewind_tree_iterator Usage : $result->rewind_tree_iterator() Function: Rewinds the tree iterator so that next_tree can be called again from the beginning Returns : none Args : none =cut sub rewind_tree_iterator { shift->{'_treeiterator'} = 0; } =head2 add_tree Title : add_tree Usage : $result->add_tree($tree); Function: Adds a tree Returns : integer which is the number of trees stored Args : L<Bio::Tree::TreeI> =cut sub add_tree{ my ($self,$tree) = @_; if( $tree && ref($tree) && $tree->isa('Bio::Tree::TreeI') ) { push @{$self->{'_trees'}},$tree; } return scalar @{$self->{'_trees'}}; } =head2 set_MLmatrix Title : set_MLmatrix Usage : $result->set_MLmatrix($mat) Function: Set the ML Matrix Returns : none Args : Arrayref to MLmatrix (must be arrayref to 2D matrix whic is lower triangle pairwise) =cut sub set_MLmatrix{ my ($self,$mat) = @_; return unless ( defined $mat ); if( ref($mat) !~ /ARRAY/i ) { $self->warn("Did not provide a valid 2D Array reference for set_MLmatrix"); return; } $self->{'_mlmatrix'} = $mat; } =head2 get_MLmatrix Title : get_MLmatrix Usage : my $mat = $result->get_MLmatrix() Function: Get the ML matrix Returns : 2D Array reference Args : none =cut sub get_MLmatrix{ my ($self,@args) = @_; return $self->{'_mlmatrix'}; } =head2 set_NGmatrix Title : set_NGmatrix Usage : $result->set_NGmatrix($mat) Function: Set the Nei & Gojobori Matrix Returns : none Args : Arrayref to NGmatrix (must be arrayref to 2D matrix whic is lower triangle pairwise) =cut sub set_NGmatrix{ my ($self,$mat) = @_; return unless ( defined $mat ); if( ref($mat) !~ /ARRAY/i ) { $self->warn("Did not provide a valid 2D Array reference for set_NGmatrix"); return; } $self->{'_ngmatrix'} = $mat; } =head2 get_NGmatrix Title : get_NGmatrix Usage : my $mat = $result->get_NGmatrix() Function: Get the Nei & Gojobori matrix Returns : 2D Array reference Args : none =cut sub get_NGmatrix{ my ($self,@args) = @_; return $self->{'_ngmatrix'}; } =head2 add_seq Title : add_seq Usage : $obj->add_seq($seq) Function: Add a Bio::PrimarySeq to the Result Returns : none Args : Bio::PrimarySeqI See also : L<Bio::PrimarySeqI> =cut sub add_seq{ my ($self,$seq) = @_; if( $seq ) { unless( $seq->isa("Bio::PrimarySeqI") ) { $self->warn("Must provide a valid Bio::PrimarySeqI to add_seq"); return; } push @{$self->{'_seqs'}},$seq; } } =head2 reset_seqs Title : reset_seqs Usage : $result->reset_seqs Function: Reset the OTU seqs stored Returns : none Args : none =cut sub reset_seqs{ my ($self) = @_; $self->{'_seqs'} = []; } =head2 get_seqs Title : get_seqs Usage : my @otus = $result->get_seqs Function: Get the seqs Bio::PrimarySeq (OTU = Operational Taxonomic Unit) Returns : Array of Bio::PrimarySeq Args : None See also : L<Bio::PrimarySeq> =cut sub get_seqs{ my ($self) = @_; return @{$self->{'_seqs'}}; } =head2 set_codon_pos_basefreq Title : set_codon_pos_basefreq Usage : $result->set_codon_pos_basefreq(@freqs) Function: Set the codon position base frequencies Returns : none Args : Array of length 3 where each slot has a hashref keyed on DNA base =cut sub set_codon_pos_basefreq { my ($self,@codonpos) = @_; if( scalar @codonpos != 3 ) { $self->warn("invalid array to set_codon_pos_basefreq, must be an array of length 3"); return; } foreach my $pos ( @codonpos ) { if( ref($pos) !~ /HASH/i || ! exists $pos->{'A'} ) { $self->warn("invalid array to set_codon_pos_basefreq, must be an array with hashreferences keyed on DNA bases, C,A,G,T"); } } $self->{'_codonposbasefreq'} = [@codonpos]; } =head2 get_codon_pos_basefreq Title : get_codon_pos_basefreq Usage : my @basepos = $result->get_codon_pos_basefreq; Function: Get the codon position base frequencies Returns : Array of length 3 (each codon position), each slot is a hashref keyed on DNA bases, the values are the frequency of the base at that position for all sequences Args : none Note : The array starts at 0 so position '1' is in position '0' of the array =cut sub get_codon_pos_basefreq{ my ($self) = @_; return @{$self->{'_codonposbasefreq'}}; } =head2 version Title : version Usage : $obj->version($newval) Function: Get/Set version Returns : value of version Args : newvalue (optional) =cut sub version{ my $self = shift; $self->{'_version'} = shift if @_; return $self->{'_version'}; } =head2 seqfile Title : seqfile Usage : $obj->seqfile($newval) Function: Get/Set seqfile Returns : value of seqfile Args : newvalue (optional) =cut sub seqfile{ my $self = shift; $self->{'_seqfile'} = shift if @_; return $self->{'_seqfile'}; } =head2 model Title : model Usage : $obj->model($newval) Function: Get/Set model Returns : value of model Args : on set, new value (a scalar or undef, optional) =cut sub model{ my $self = shift; return $self->{'_model'} = shift if @_; return $self->{'_model'}; } =head2 patterns Title : patterns Usage : $obj->patterns($newval) Function: Get/Set Patterns hash Returns : Hashref of pattern data Args : [optional] Hashref of patterns : The hashref is typically : { -patterns => \@arrayref : -ns => $ns : -ls => $ls : } =cut sub patterns{ my $self = shift; return $self->{'_patterns'} = shift if @_; return $self->{'_patterns'}; } =head2 set_AAFreqs Title : set_AAFreqs Usage : $result->set_AAFreqs(\%aafreqs); Function: Get/Set AA freqs Returns : none Args : Hashref, keys are the sequence names, each points to a hashref which in turn has keys which are the amino acids =cut sub set_AAFreqs{ my ($self,$aafreqs) = @_; if( $aafreqs && ref($aafreqs) =~ /HASH/i ) { foreach my $seqname ( keys %{$aafreqs} ) { $self->{'_aafreqs'}->{$seqname} = $aafreqs->{$seqname}; } } } =head2 get_AAFreqs Title : get_AAFreqs Usage : my %all_aa_freqs = $result->get_AAFreqs() OR my %seq_aa_freqs = $result->get_AAFreqs($seqname) Function: Get the AA freqs, either for every sequence or just for a specific sequence The average aa freqs for the entire set are also available for the sequence named 'Average' Returns : Hashref Args : (optional) sequence name to retrieve aa freqs for =cut sub get_AAFreqs{ my ($self,$seqname) = @_; if( $seqname ) { return $self->{'_aafreqs'}->{$seqname} || {}; } else { return $self->{'_aafreqs'}; } } =head2 set_NTFreqs Title : set_NTFreqs Usage : $result->set_NTFreqs(\%aafreqs); Function: Get/Set NT freqs Returns : none Args : Hashref, keys are the sequence names, each points to a hashref which in turn has keys which are the amino acids =cut sub set_NTFreqs{ my ($self,$freqs) = @_; if( $freqs && ref($freqs) =~ /HASH/i ) { foreach my $seqname ( keys %{$freqs} ) { $self->{'_ntfreqs'}->{$seqname} = $freqs->{$seqname}; } } } =head2 get_NTFreqs Title : get_NTFreqs Usage : my %all_nt_freqs = $result->get_NTFreqs() OR my %seq_nt_freqs = $result->get_NTFreqs($seqname) Function: Get the NT freqs, either for every sequence or just for a specific sequence The average nt freqs for the entire set are also available for the sequence named 'Average' Returns : Hashref Args : (optional) sequence name to retrieve nt freqs for =cut sub get_NTFreqs{ my ($self,$seqname) = @_; if( $seqname ) { return $self->{'_ntfreqs'}->{$seqname} || {}; } else { return $self->{'_ntfreqs'}; } } =head2 add_stat Title : add_stat Usage : $result->add_stat($stat,$value); Function: Add some misc stat valuess (key/value pairs) Returns : none Args : $stat stat name $value stat value =cut sub add_stat{ my ($self,$stat,$value) = @_; return if( ! defined $stat || !defined $value ); $self->{'_stats'}->{$stat} = $value; return; } =head2 get_stat Title : get_stat Usage : my $value = $result->get_stat($name); Function: Get the value for a stat of a given name Returns : scalar value Args : name of the stat =cut sub get_stat{ my ($self,$statname) = @_; return $self->{'_stats'}->{$statname}; } =head2 get_stat_names Title : get_stat_names Usage : my @names = $result->get_stat_names; Function: Get the stat names stored for the result Returns : array of names Args : none =cut sub get_stat_names{ my ($self) = @_; return keys %{$self->{'_stats'} || {}}; } =head2 get_AADistMatrix Title : get_AADistMatrix Usage : my $mat = $obj->get_AADistMatrix() Function: Get AADistance Matrix Returns : value of AADistMatrix (Bio::Matrix::PhylipDist) Args : none =cut sub get_AADistMatrix{ my $self = shift; return $self->{'_AADistMatix'}; } =head2 set_AADistMatrix Title : set_AADistMatrix Usage : $obj->set_AADistMatrix($mat); Function: Set the AADistrance Matrix (Bio::Matrix::PhylipDist) Returns : none Args : AADistrance Matrix (Bio::Matrix::PhylipDist) =cut sub set_AADistMatrix{ my ($self,$d) = @_; if( ! $d || ! ref($d) || ! $d->isa('Bio::Matrix::PhylipDist') ) { $self->warn("Must provide a valid Bio::Matrix::MatrixI for set_AADistMatrix"); } $self->{'_AADistMatix'} = $d; return; } =head2 get_AAMLDistMatrix Title : get_AAMLDistMatrix Usage : my $mat = $obj->get_AAMLDistMatrix() Function: Get AAMLDistance Matrix Returns : value of AAMLDistMatrix (Bio::Matrix::PhylipDist) Args : none =cut sub get_AAMLDistMatrix{ my $self = shift; return $self->{'_AAMLDistMatix'}; } =head2 set_AAMLDistMatrix Title : set_AAMLDistMatrix Usage : $obj->set_AAMLDistMatrix($mat); Function: Set the AA ML Distrance Matrix (Bio::Matrix::PhylipDist) Returns : none Args : AAMLDistrance Matrix (Bio::Matrix::PhylipDist) =cut sub set_AAMLDistMatrix{ my ($self,$d) = @_; if( ! $d || ! ref($d) || ! $d->isa('Bio::Matrix::PhylipDist') ) { $self->warn("Must provide a valid Bio::Matrix::MatrixI for set_AAMLDistMatrix"); } $self->{'_AAMLDistMatix'} = $d; return; } =head2 add_NSSite_result Title : add_NSSite_result Usage : $result->add_NSSite_result($model) Function: Add a NSsite result (PAML::ModelResult) Returns : none Args : Bio::Tools::Phylo::PAML::ModelResult =cut sub add_NSSite_result{ my ($self,$model) = @_; if( defined $model ) { push @{$self->{'_nssiteresult'}}, $model; } return scalar @{$self->{'_nssiteresult'}}; } =head2 get_NSSite_results Title : get_NSSite_results Usage : my @results = @{$self->get_NSSite_results}; Function: Get the reference to the array of NSSite_results Returns : Array of PAML::ModelResult results Args : none =cut sub get_NSSite_results{ my ($self) = @_; return @{$self->{'_nssiteresult'} || []}; } =head2 set_CodonFreqs Title : set_CodonFreqs Usage : $obj->set_CodonFreqs($newval) Function: Get/Set the Codon Frequence table Returns : value of set_CodonFreqs (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub set_CodonFreqs{ my $self = shift; return $self->{'_codonfreqs'} = shift if @_; return $self->{'_codonfreqs'}; } =head2 get_CodonFreqs Title : get_CodonFreqs Usage : my @codon_freqs = $result->get_CodonFreqs() Function: Get the Codon freqs Returns : Array Args : none =cut sub get_CodonFreqs{ my ($self) = @_; return @{$self->{'_codonfreqs'} || []}; } =head2 BASEML Relavent values =cut =head2 get_KappaMatrix Title : get_KappaMatrix Usage : my $mat = $obj->get_KappaMatrix() Function: Get KappaDistance Matrix Returns : value of KappaMatrix (Bio::Matrix::PhylipDist) Args : none =cut sub get_KappaMatrix{ my $self = shift; return $self->{'_KappaMatix'}; } =head2 set_KappaMatrix Title : set_KappaMatrix Usage : $obj->set_KappaMatrix($mat); Function: Set the KappaDistrance Matrix (Bio::Matrix::PhylipDist) Returns : none Args : KappaDistrance Matrix (Bio::Matrix::PhylipDist) =cut sub set_KappaMatrix{ my ($self,$d) = @_; if( ! $d || ! ref($d) || ! $d->isa('Bio::Matrix::PhylipDist') ) { $self->warn("Must provide a valid Bio::Matrix::MatrixI for set_NTDistMatrix"); } $self->{'_KappaMatix'} = $d; return; } =head2 get_AlphaMatrix Title : get_AlphaMatrix Usage : my $mat = $obj->get_AlphaMatrix() Function: Get AlphaDistance Matrix Returns : value of AlphaMatrix (Bio::Matrix::PhylipDist) Args : none =cut sub get_AlphaMatrix{ my $self = shift; return $self->{'_AlphaMatix'}; } =head2 set_AlphaMatrix Title : set_AlphaMatrix Usage : $obj->set_AlphaMatrix($mat); Function: Set the AlphaDistrance Matrix (Bio::Matrix::PhylipDist) Returns : none Args : AlphaDistrance Matrix (Bio::Matrix::PhylipDist) =cut sub set_AlphaMatrix{ my ($self,$d) = @_; if( ! $d || ! ref($d) || ! $d->isa('Bio::Matrix::PhylipDist') ) { $self->warn("Must provide a valid Bio::Matrix::MatrixI for set_NTDistMatrix"); } $self->{'_AlphaMatix'} = $d; return; } =head2 set_input_parameter Title : set_input_parameter Usage : $obj->set_input_parameter($p,$vl); Function: Set an Input Parameter Returns : none Args : $parameter and $value =cut sub set_input_parameter{ my ($self,$p,$v) = @_; return unless defined $p; $self->{'_input_parameters'}->{$p} = $v; } =head2 get_input_parameters Title : get_input_parameters Usage : $obj->get_input_parameters; Function: Get Input Parameters Returns : Hash of key/value pairs Args : none =cut sub get_input_parameters{ my ($self) = @_; return %{$self->{'_input_parameters'} || {}}; } =head2 reset_input_parameters Title : reset_input_parameters Usage : $obj->reset_input_parameters; Function: Reset the Input Parameters hash Returns : none Args : none =cut sub reset_input_parameters{ my ($self) = @_; $self->{'_input_parameters'} = {}; } =head1 Reconstructed Ancestral State relevant options =head2 add_rst_seq Title : add_rst_seq Usage : $obj->add_rst_seq($seq) Function: Add a Bio::PrimarySeq to the RST Result Returns : none Args : Bio::PrimarySeqI See also : L<Bio::PrimarySeqI> =cut sub add_rst_seq{ my ($self,$seq) = @_; if( $seq ) { unless( $seq->isa("Bio::PrimarySeqI") ) { $self->warn("Must provide a valid Bio::PrimarySeqI to add_rst_seq"); return; } push @{$self->{'_rstseqs'}},$seq; } } =head2 reset_rst_seqs Title : reset_rst_seqs Usage : $result->reset_rst_seqs Function: Reset the RST seqs stored Returns : none Args : none =cut sub reset_rst_seqs{ my ($self) = @_; $self->{'_rstseqs'} = []; } =head2 get_rst_seqs Title : get_rst_seqs Usage : my @otus = $result->get_rst_seqs Function: Get the seqs Bio::PrimarySeq Returns : Array of Bio::PrimarySeqI objects Args : None See also : L<Bio::PrimarySeq> =cut sub get_rst_seqs{ my ($self) = @_; return @{$self->{'_rstseqs'} || []}; } =head2 add_rst_tree Title : add_rst_tree Usage : $obj->add_rst_tree($tree) Function: Add a Bio::Tree::TreeI to the RST Result Returns : none Args : Bio::Tree::TreeI See also : L<Bio::Tree::TreeI> =cut sub add_rst_tree{ my ($self,$tree) = @_; if( $tree ) { unless( $tree->isa("Bio::Tree::TreeI") ) { $self->warn("Must provide a valid Bio::Tree::TreeI to add_rst_tree not $tree"); return; } push @{$self->{'_rsttrees'}},$tree; } } =head2 reset_rst_trees Title : reset_rst_trees Usage : $result->reset_rst_trees Function: Reset the RST trees stored Returns : none Args : none =cut sub reset_rst_trees{ my ($self) = @_; $self->{'_rsttrees'} = []; } =head2 get_rst_trees Title : get_rst_trees Usage : my @otus = $result->get_rst_trees Function: Get the trees Bio::Tree::TreeI Returns : Array of Bio::Tree::TreeI objects Args : None See also : L<Bio::Tree::TreeI> =cut sub get_rst_trees{ my ($self) = @_; return @{$self->{'_rsttrees'} || []}; } =head2 set_rst_persite Title : set_rst_persite Usage : $obj->set_rst_persite($newval) Function: Get/Set the per-site RST values Returns : value of set_rst_persite (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub set_rst_persite{ my $self = shift; return $self->{'_rstpersite'} = shift if @_; return $self->{'_rstpersite'}; } =head2 get_rst_persite Title : get_rst_persite Usage : my @rst_persite = @{$result->get_rst_persite()} Function: Get the per-site RST values Returns : Array Args : none =cut sub get_rst_persite{ my ($self) = @_; return $self->{'_rstpersite'} || []; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Phylip��������������������������������������������������������������000755��000765��000024�� 0�12254227340� 17451� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Phylo/Phylip/ProtDist.pm��������������������������������������������������000444��000765��000024�� 7444�12254227340� 21725� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Phylo::Phylip::ProtDist # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Shawn Hoon <shawnh@fugu-sg.org> # # Copyright Shawn Hoon # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Phylo::Phylip::ProtDist - parser for ProtDist output =head1 SYNOPSIS use Bio::Tools::Phylo::Phylip::ProtDist; my $parser = Bio::Tools::Phylo::Phylip::ProtDist->new(-file => 'outfile'); while( my $result = $parser->next_matrix) { # do something with it } =head1 DESCRIPTION A parser for ProtDist output into a L<Bio::Matrix::PhylipDist> object. See also L<Bio::Matrix::IO::phylip> this module may go away. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Shawn Hoon Email shawnh@fugu-sg.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Phylo::Phylip::ProtDist; use strict; use Bio::Matrix::PhylipDist; use base qw(Bio::Root::Root Bio::Root::IO); =head2 new Title : new Usage : my $obj = Bio::Tools::Phylo::Phylip::ProtDist->new(); Function: Builds a new Bio::Tools::Phylo::Phylip::ProtDist object Returns : Bio::Tools::ProtDist Args : -fh/-file => $val, # for initing input, see Bio::Root::IO -program => 'programname' # name of the program =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); my ($prog) = $self->_rearrange([qw(PROGRAM)], @args); $self->{'_program'} = $prog; return $self; } =head2 next_matrix Title : next_matrix Usage : my $matrix = $parser->next_matrix Function: Get the next result set from parser data Returns : L<Bio::Matrix::PhylipDist> Args : none =cut sub next_matrix{ my ($self) = @_; my @names; my @values; my $entry; my $size = 0; while ($entry=$self->_readline) { if($#names >=0 && $entry =~/^\s+\d+\n$/){ $self->_pushback($entry); last; } elsif($entry=~/^\s+(\d+)\n$/){ $size = $1; next; } elsif( $entry =~ s/^\s+(\-?\d+\.\d+)/$1/ ) { my (@line) = split( /\s+/,$entry); push @{$values[-1]}, @line; next; } my ($n,@line) = split( /\s+/,$entry); push @names, $n; push @values, [@line]; } if( scalar @names != $size ) { $self->warn("The number of entries ".(scalar @names). " is not the same $size"); } $#names>=0 || return; my %dist; my $i=0; for my $name (@names){ my $j=0; for my $n (@names) { $dist{$name}{$n} = [$i,$j]; $j++; } $i++; } return Bio::Matrix::PhylipDist->new(-program => $self->{'_program'}, -matrix => \%dist, -names => \@names, -values => \@values); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Prediction����������������������������������������������������������������000755��000765��000024�� 0�12254227334� 17214� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Prediction/Exon.pm��������������������������������������������������������000444��000765��000024�� 12673�12254227334� 20651� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Prediction::Exon # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Prediction::Exon - A predicted exon feature =head1 SYNOPSIS # See documentation of methods. =head1 DESCRIPTION A feature representing a predicted exon. This class actually inherits off Bio::SeqFeature::Gene::Exon and therefore has all that functionality (also implements Bio::SeqFeatureI), plus a few methods supporting predicted features, like various scores and a significance. Even though these were inspired by GenScan results, at least a subset should be generally useable for exon prediction results. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp-at-gmx.net =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Prediction::Exon; use strict; use base qw(Bio::SeqFeature::Gene::Exon); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 predicted_cds Title : predicted_cds Usage : $predicted_cds_dna = $exon->predicted_cds(); $exon->predicted_cds($predicted_cds_dna); Function: Get/Set the CDS (coding sequence) as predicted by a program. This method is independent of an attached_seq. There is no guarantee whatsoever that the returned CDS has anything to do (e.g., matches) with the sequence covered by the exons as annotated through this object. Example : Returns : A Bio::PrimarySeqI implementing object holding the DNA sequence defined as coding by a prediction of a program. Args : On set, a Bio::PrimarySeqI implementing object holding the DNA sequence defined as coding by a prediction of a program. =cut sub predicted_cds { my ($self, $cds) = @_; if(defined($cds)) { $self->{'_predicted_cds'} = $cds; } return $self->{'_predicted_cds'}; } =head2 predicted_protein Title : predicted_protein Usage : $predicted_protein_seq = $exon->predicted_protein(); $exon->predicted_protein($predicted_protein_seq); Function: Get/Set the protein translation as predicted by a program. This method is independent of an attached_seq. There is no guarantee whatsoever that the returned translation has anything to do with the sequence covered by the exons as annotated through this object, or the sequence returned by predicted_cds(), although it should usually be just the standard translation. Example : Returns : A Bio::PrimarySeqI implementing object holding the protein translation as predicted by a program. Args : On set, a Bio::PrimarySeqI implementing object holding the protein translation as predicted by a program. =cut sub predicted_protein { my ($self, $aa) = @_; if(defined($aa)) { $self->{'_predicted_aa'} = $aa; } return $self->{'_predicted_aa'}; } =head2 significance Title : significance Usage : $evalue = $obj->significance(); $obj->significance($evalue); Function: Returns : Args : =cut sub significance { return shift->_tag_value('signif', @_); } =head2 start_signal_score Title : start_signal_score Usage : $sc = $obj->start_signal_score(); $obj->start_signal_score($evalue); Function: Get/Set a score for the exon start signal (acceptor splice site or initiation signal). Returns : Args : =cut sub start_signal_score { return shift->_tag_value('AccScore', @_); } =head2 end_signal_score Title : end_signal_score Usage : $sc = $obj->end_signal_score(); $obj->end_signal_score($evalue); Function: Get/Set a score for the exon end signal (donor splice site or termination signal). Returns : Args : =cut sub end_signal_score { return shift->_tag_value('DonScore', @_); } =head2 coding_signal_score Title : coding_signal_score Usage : $sc = $obj->coding_signal_score(); $obj->coding_signal_score($evalue); Function: Get/Set a score for the exon coding signal (e.g., coding potential). Returns : Args : =cut sub coding_signal_score { return shift->_tag_value('CodScore', @_); } # # Everything else is just inherited from SeqFeature::Generic. # 1; ���������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Prediction/Gene.pm��������������������������������������������������������000444��000765��000024�� 11164�12254227325� 20610� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Prediction::Gene # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Hilmar Lapp <hlapp@gmx.net> # # Copyright Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Prediction::Gene - a predicted gene structure feature =head1 SYNOPSIS #See documentation of methods. =head1 DESCRIPTION A feature representing a predicted gene structure. This class actually inherits off Bio::SeqFeature::Gene::Transcript and therefore has all that functionality, plus a few methods supporting predicted sequence features, like a predicted CDS and a predicted translation. Exons held by an instance of this class will usually be instances of Bio::Tools::Prediction::Exon, although they do not have to be. Refer to the documentation of the class that produced the instance. Normally, you will not want to create an instance of this class yourself. Instead, classes representing the results of gene structure prediction programs will do that. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Hilmar Lapp Email hlapp-at-gmx.net or hilmar.lapp-at-pharma.novartis.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Prediction::Gene; use strict; use base qw(Bio::SeqFeature::Gene::Transcript); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($primary,$ptag) = $self->_rearrange([qw(PRIMARY PRIMARY_TAG)],@args); $self->primary_tag('predicted_gene') unless $primary || $ptag; return $self; } =head2 predicted_cds Title : predicted_cds Usage : $predicted_cds_dna = $gene->predicted_cds(); $gene->predicted_cds($predicted_cds_dna); Function: Get/Set the CDS (coding sequence) as predicted by a program. This method is independent of an attached_seq. There is no guarantee whatsoever that the returned CDS has anything to do (e.g., matches) with the sequence covered by the exons as annotated through this object. Example : Returns : A Bio::PrimarySeqI implementing object holding the DNA sequence defined as coding by a prediction of a program. Args : On set, a Bio::PrimarySeqI implementing object holding the DNA sequence defined as coding by a prediction of a program. =cut sub predicted_cds { my ($self, $cds) = @_; if(defined($cds)) { $self->{'_predicted_cds'} = $cds; } return $self->{'_predicted_cds'}; } =head2 predicted_protein Title : predicted_protein Usage : $predicted_protein_seq = $gene->predicted_protein(); $gene->predicted_protein($predicted_protein_seq); Function: Get/Set the protein translation as predicted by a program. This method is independent of an attached_seq. There is no guarantee whatsoever that the returned translation has anything to do with the sequence covered by the exons as annotated through this object, or the sequence returned by predicted_cds(), although it should usually be just the standard translation. Example : Returns : A Bio::PrimarySeqI implementing object holding the protein translation as predicted by a program. Args : On set, a Bio::PrimarySeqI implementing object holding the protein translation as predicted by a program. =cut sub predicted_protein { my ($self, $aa) = @_; if(defined($aa)) { $self->{'_predicted_aa'} = $aa; } return $self->{'_predicted_aa'}; } # # Everything else is just inherited from SeqFeature::GeneStructure. # 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer��������������������������������������������������������������������000755��000765��000024�� 0�12254227336� 16354� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer/AssessorI.pm�������������������������������������������������������000444��000765��000024�� 4024�12254227336� 20762� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Primer::AssessorI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Primer::AssessorI - interface for assessing primer pairs =head1 SYNOPSIS use Bio::Tools::Primer::AssessorI; if( $obj->isa('Bio::Tools::Primer::AssessorI') ) { my $score = $obj->assess($primer_pair); } =head1 DESCRIPTION The Primer Assessor interface provides a interface for scoring functions of primer pairs to comply to. It is mainly used by Bio::Tools::Primer::Design module =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney-at-ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Primer::AssessorI; use base qw(Bio::Root::RootI); sub assess { my ($self) = shift; $self->throw_not_implemented(); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer/Feature.pm���������������������������������������������������������000444��000765��000024�� 6344�12254227334� 20447� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Primer::Feature # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Primer::Feature - position of a single primer =head1 SYNOPSIS use Bio::Tools::Primer::Feature; my $pf = Bio::Tools::Primer::Feature->new( -start => $start, -end => $end, -strand => $strand); $pf->attach_seq($seq); # is a SeqFeatureI print "primer starts at ",$pf->start," with sequence ",$pf->seq->seq(),"\n"; # helper functions print "GC percentage ",$pf->gc(),"\n"; print "has inversion of size 4 at ",$pf->inversion(4),"\n"; =head1 DESCRIPTION Primer Features represents one primer in a primer pair. This object is mainly for designing primers, and probably principly used in the primer design system =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney-at-ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Primer::Feature; use base qw(Bio::SeqFeature::Generic); sub new { my ( $caller, @args) = @_; my ($self) = $caller->SUPER::new(@args); # done - we hope return $self; } sub gc_percent { my $self = shift; my $seq = $self->seq(); if( !defined $seq ) { $self->throw("Primer feature has no attached sequence, can't calculate GC"); } my $str = $seq->seq(); my $count = $str =~ tr/GCgc/GCgc/; return $count*100.0 / $seq->length; } sub inversion { my $self = shift; my $size = shift; if( !defined $size ) { $self->throw("Must have size paramter in inversion"); } my $seq = $self->seq(); if( !defined $seq ) { $self->throw("Primer feature has no attached sequence, can't calculate inversion"); } my $len = $seq->length - $size; my $str = $seq->seq(); foreach my $i ( 0 .. $len ) { my $revstr = substr($str,$i,$size); my $orig = $revstr; $revstr = reverse $revstr; $revstr = s/[^ATGCNatgcn]/N/g; $revstr =~ tr/ATGCNatgcn/TACGNtacgn/; if( $str =~ /$revstr/ ) { return $orig; } } return; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer/Pair.pm������������������������������������������������������������000444��000765��000024�� 6337�12254227332� 17747� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::Primer::Pair # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Primer::Pair - two primers on left and right side =head1 SYNOPSIS use Bio::Tools::Primer::Pair; my $pair = Bio::Tools::Primer::Pair->new( -left => $leftp , -right => $rightp); # helper functions print "GC percentage different",$pf->gc_difference(),"\n"; print "product length is ",$pf->product_length,"\n"; =head1 DESCRIPTION Primer Pairs represents one primer in a primer pair. This object is mainly for designing primers, and probably principly used in the primer design system =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney-at-ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Primer::Pair; use base qw(Bio::Root::Root); sub new { my ( $caller, @args) = @_; my ($self) = $caller->SUPER::new(@args); my ($left,$right) = $self->_rearrange([qw(LEFT RIGHT)],@args); if( !defined $left || !defined $right ) { $self->throw("Pair must be initialised with left and right primers"); } $self->left($left); $self->right($right); # done - we hope return $self; } sub left { my $self = shift; my $left = shift; if( defined $left ) { if( !ref $left || !$left->isa("Bio::Tools::Primer::Feature") ) { $self->throw("left primer must be a Bio::Tools::Primer::Feature, not $left"); } $self->{'left'} = $left; } return $self->{'left'}; } sub right { my $self = shift; my $right = shift; if( defined $right ) { if( !ref $right || !$right->isa("Bio::Tools::Primer::Feature") ) { $self->throw("right primer must be a Bio::Tools::Primer::Feature, not $right"); } $self->{'right'} = $right; } return $self->{'right'}; } sub gc_difference { my $self = shift; return abs ( $self->left->gc_percent - $self->right->gc_percent ); } sub product_length { my $self = shift; return $self->right->end - $self->left->start +1; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer/Assessor�����������������������������������������������������������000755��000765��000024�� 0�12254227325� 20154� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Primer/Assessor/Base.pm���������������������������������������������������000444��000765��000024�� 4345�12254227325� 21527� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Primer::Assessor::Base # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney@ebi.ac.uk> # # Copyright Ewan Birney # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Primer::Assessor::Base - base class for common assessor things =head1 SYNOPSIS use Bio::Tools::Primer::Assessor::Base $base->weight(10); =head1 DESCRIPTION Base class for assessors, probably only defining the weight function =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney Email birney-at-ebi.ac.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Primer::Assessor::Base; use base qw(Bio::Root::Root); sub new { my ( $caller, @args) = @_; my ($self) = $caller->SUPER::new(@args); my ($weight) = $self->_rearrange([qw(WEIGHT)],@args); if( !defined $weight ) { $weight = 10; } $self->weight($weight); # done - we hope return $self; } sub weight { my $self = shift; my $weight = shift; if( defined $weight ) { $self->{'weight'} = $weight; } return $self->{'weight'}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run�����������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 15655� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/GenericParameters.pm��������������������������������������������������000555��000765��000024�� 6352�12254227336� 21766� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for wrapping runtime parameters # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla (bioinformatics1 at dieselwurks dot com) # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::GenericParameters - An object for the parameters used to run programs =head1 SYNOPSIS my $void = $obj->set_parameter("parameter_name","parameter_value"); my $value = $obj->get_parameter("parameter_name"); =head1 DESCRIPTION This is a basic container to hold the parameters used to run a program. This module may get incorporated into the more generic Bio::Tools::Run framework in bioperl-run distribution. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1 at dieselwurks dot com =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Run::GenericParameters; use strict; use base qw(Bio::Root::Root Bio::Tools::Run::ParametersI); sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); return $self; } =head2 get_parameter Title : get_parameter Usage : $parameter_object->get_parameter($param_name); Function: Get the value of a parameter named $param_name Returns : A scalar that should be a string Args : A scalar that should be a string =cut sub get_parameter { my ($self,$arg) = @_; return $self->{params}->{$arg}; } =head2 set_parameter Title : set_parameter Usage : $parameter_object->set_parameter($param_name => $param_value); Function: Set the value of a parameter named $param_name to $param_value Returns : Void Args : A hash containing name=>value pairs =cut sub set_parameter { my ($self,$name,$value) = @_; $self->{params}->{$name} = $value; } =head2 available_parameters Title : available_parameters Usage : my @paramnames = $parameter_object->available_parameters Function: Returns the names of the available parameters Returns : list of available parameter names Args : none =cut sub available_parameters { my $self = shift; return keys %{$self->{params}}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/hmmer3.pm�������������������������������������������������������������000444��000765��000024�� 0�12254227320� 17447� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/ParametersI.pm��������������������������������������������������������000555��000765��000024�� 5372�12254227324� 20600� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for wrapping runtime parameters # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chad Matsalla (bioinformatics1 at dieselwurks dot com) # # Copyright Chad Matsalla # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::ParametersI - A Base object for the parameters used to run programs =head1 SYNOPSIS # do not use this object directly, it provides the following methods # for its subclasses my $void = $obj->set_parameter("parameter_name","parameter_value"); my $value = $obj->get_parameter("parameter_name"); =head1 DESCRIPTION This is a basic container to hold the parameters used to run a program. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chad Matsalla Email bioinformatics1 at dieselwurks dot com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Run::ParametersI; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::RootI); =head2 get_parameter Title : get_parameter Usage : $parameter_object->get_parameter($param_name); Function: Get the value of a parameter named $param_name Returns : A scalar that should be a string Args : A scalar that should be a string =cut sub get_parameter { my ($self,$arg) = @_; $self->throw_not_implemented; } =head2 set_parameter Title : set_parameter Usage : $parameter_object->set_parameter($param_name => $param_value); Function: Set the value of a parameter named $param_name to $param_value Returns : Void Args : A hash containing name=>value pairs =cut sub set_parameter { my ($self,$name,$value) = @_; $self->throw_not_implemented; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/README����������������������������������������������������������������000444��000765��000024�� 561�12254227340� 16654� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� This directory is now mainly in bioperl-run package which you should install alongside Bioperl to get over 50 different runnable options. We might decide to merge the two packages again, but the feeling is that bioperl "core" is getting a little too big. Bioperl-run follows the same release tagging schedule as Bioperl. Pick it up from www.bioperl.org and/or CPAN �����������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/RemoteBlast.pm��������������������������������������������������������000444��000765��000024�� 57421�12254227326� 20626� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Run::RemoteBlast # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # FORMERLY Cared for by Jason Stajich, Mat Wiepert # # Somewhat cared for by Roger Hall, Chris Fields (when they have time) # # Copyright Jason Stajich, Bioperl # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::RemoteBlast - Object for remote execution of the NCBI Blast via HTTP =head1 SYNOPSIS #Remote-blast "factory object" creation and blast-parameter initialization use Bio::Tools::Run::RemoteBlast; use strict; my $prog = 'blastp'; my $db = 'swissprot'; my $e_val= '1e-10'; my @params = ( '-prog' => $prog, '-data' => $db, '-expect' => $e_val, '-readmethod' => 'SearchIO' ); my $factory = Bio::Tools::Run::RemoteBlast->new(@params); #change a query parameter $Bio::Tools::Run::RemoteBlast::HEADER{'ENTREZ_QUERY'} = 'Homo sapiens [ORGN]'; #change a retrieval parameter $Bio::Tools::Run::RemoteBlast::RETRIEVALHEADER{'DESCRIPTIONS'} = 1000; #remove a parameter delete $Bio::Tools::Run::RemoteBlast::HEADER{'FILTER'}; #$v is just to turn on and off the messages my $v = 1; my $str = Bio::SeqIO->new(-file=>'amino.fa' , -format => 'fasta' ); while (my $input = $str->next_seq()){ #Blast a sequence against a database: #Alternatively, you could pass in a file with many #sequences rather than loop through sequence one at a time #Remove the loop starting 'while (my $input = $str->next_seq())' #and swap the two lines below for an example of that. my $r = $factory->submit_blast($input); #my $r = $factory->submit_blast('amino.fa'); print STDERR "waiting..." if( $v > 0 ); while ( my @rids = $factory->each_rid ) { foreach my $rid ( @rids ) { my $rc = $factory->retrieve_blast($rid); if( !ref($rc) ) { if( $rc < 0 ) { $factory->remove_rid($rid); } print STDERR "." if ( $v > 0 ); sleep 5; } else { my $result = $rc->next_result(); #save the output my $filename = $result->query_name()."\.out"; $factory->save_output($filename); $factory->remove_rid($rid); print "\nQuery Name: ", $result->query_name(), "\n"; while ( my $hit = $result->next_hit ) { next unless ( $v > 0); print "\thit name is ", $hit->name, "\n"; while( my $hsp = $hit->next_hsp ) { print "\t\tscore is ", $hsp->score, "\n"; } } } } } } # This example shows how to change a CGI parameter: $Bio::Tools::Run::RemoteBlast::HEADER{'MATRIX_NAME'} = 'BLOSUM45'; $Bio::Tools::Run::RemoteBlast::HEADER{'GAPCOSTS'} = '15 2'; # And this is how to delete a CGI parameter: delete $Bio::Tools::Run::RemoteBlast::HEADER{'FILTER'}; =head1 DESCRIPTION Class for remote execution of the NCBI Blast via HTTP. For a description of the many CGI parameters see: http://www.ncbi.nlm.nih.gov/BLAST/Doc/urlapi.html Various additional options and input formats are available. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Please do NOT contact Jason directly about this module. Please post to the bioperl mailing list (L<FEEDBACK>). If you would like to be the official maintainer of this module, please volunteer on the list and we will make it official in this POD. First written by Jason Stajich, many others have helped keep it running. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Run::RemoteBlast; use strict; use warnings; use Bio::SeqIO; use IO::String; use Bio::SearchIO; use LWP; use HTTP::Request::Common; use constant { NOT_FINISHED => 0, ERR_QBSTATUS => 1, ERR_NOCONTENT => 2, ERR_HTTPFAIL => 4, ERR_QBNONSPEC => 8 }; # Bio::Root::IO is-a Bio::Root::Roo use base qw(Bio::Root::IO Exporter); our @EXPORT = qw( NOT_FINISHED ERR_QBSTATUS ERR_NOCONTENT ERR_HTTPFAIL ERR_QBNONSPEC ); our $MODVERSION = $Bio::Root::Version::VERSION; our $URLBASE = 'http://www.ncbi.nlm.nih.gov/blast/Blast.cgi'; # In GET/PUTPARAMS the values are regexes which validate the input. our %PUTPARAMS = ( 'AUTO_FORMAT' => '(Off|(Semi|Full)auto)', # Off, Semiauto, Fullauto 'COMPOSITION_BASED_STATISTICS' => '(0|1)', # yes, no on NCBI's site, but actually binary 0/1 'DATABASE' => '.*', 'DB_GENETIC_CODE' => '([1-9]|1[1-6]|2(1|2))', # 1..16,21,22 'DISPLAY_SORT' => '\d', 'ENDPOINTS' => '(yes|no)', # yes,no 'ENTREZ_QUERY' => '.*', 'EXPECT' => '\d+(\.\d+)?([eE]-\d+)?', # Positive double 'FILTER' => '[LRm]', # L or R or m 'GAPCOSTS' => '-?\d+(\.\d+)\s+-?\d+(\.\d+)', # Two space separated float values 'GENETIC_CODE' => '([1-9]|1[1-6]|2(1|2))', # 1..16,21,22 'HITLIST_SIZE' => '\d+', # Positive integer 'I_THRESH' => '-?\d+(\.\d+)([eE]-\d+)?', # float 'LAYOUT' => '(One|Two)Windows?', # onewindow, twowindows 'LCASE_MASK' => '(yes|no)', # yes, no 'MATRIX_NAME' => '.*', 'NUCL_PENALTY' => '-\d+', # Negative integer 'NUCL_REWARD' => '-?\d+', # Integer 'OTHER_ADVANCED' => '.*', 'PERC_IDENT' => '\d\d+', # Integer, 0-99 inclusive 'PHI_PATTERN' => '.*', 'PROGRAM' => 't?blast[pnx]', # tblastp, tblastn, tblastx, blastp, blastn, blastx 'QUERY' => '.*', 'QUERY_FILE' => '.*', 'QUERY_BELIEVE_DEFLINE' => '(yes|no)', # yes, no 'QUERY_FROM' => '\d+', # Positive integer 'QUERY_TO' => '\d+', # Positive integer 'SEARCHSP_EFF' => '\d+', # Positive integer 'SERVICE' => '(plain|p[sh]i|(rps|mega)blast)', # plain,psi,phi,rpsblast,megablast 'SHORT_QUERY_ADJUST' => '(true|false)', 'THRESHOLD' => '-?\d+', # Integer 'UNGAPPED_ALIGNMENT' => '(yes|no)', # yes, no 'WORD_SIZE' => '\d+' # Positive integer ); our %GETPARAMS = ( 'ALIGNMENTS' => '\d+', # Positive integer 'ALIGNMENT_VIEW' => '(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 'EXPECT_HIGH' => '\d+(\.\d+)?([eE]-\d+)?', # Positive double 'FORMAT_ENTREZ_QUERY' => '', 'FORMAT_OBJECT' => '(Alignment|Neighbors|PSSM|SearchInfo|TaxBlast(Parent|MultiFrame)?)', # Alignment, Neighbors, PSSM, SearchInfo # TaxBlast, TaxblastParent, TaxBlastMultiFrame '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)', # plain,psi,phi,rpsblast,megablast 'SHOW_OVERVIEW' => '(yes|no)' # yes, no ); # Default values go in here for PUT our %HEADER = ( 'CMD' => 'Put', 'FORMAT_OBJECT' => 'Alignment', 'COMPOSITION_BASED_STATISTICS' => 'off', 'DATABASE' => 'nr', 'EXPECT' => '1e-3', 'FILTER' => 'L', 'PROGRAM' => 'blastp', 'SERVICE' => 'plain' ); # Default values go in here for GET our %RETRIEVALHEADER = ( 'CMD' => 'Get', 'ALIGNMENTS' => '50', 'ALIGNMENT_VIEW' => 'Pairwise', 'DESCRIPTIONS' => '100', 'FORMAT_TYPE' => 'Text', ); sub new { my ($caller, @args) = @_; # chained new my $self = $caller->SUPER::new(@args); # so that tempfiles are cleaned up $self->_initialize_io(); my ($prog, $data, $readmethod, $url_base) = $self->_rearrange([qw(PROG DATA READMETHOD URL_BASE)], @args); # Use these two parameters for backward-compatibility. # Overridden by PROGRAM and DATABASE if supplied. $self->submit_parameter('PROGRAM',$prog) if $prog; $self->submit_parameter('DATABASE',$data) if $data; $readmethod = 'SearchIO' unless defined $readmethod; $self->readmethod($readmethod); # Now read the rest of the parameters and set them all # PUT parameters first my @putValues = $self->_rearrange([keys %PUTPARAMS],@args); my %putNames; @putNames{keys %PUTPARAMS} = @putValues; foreach my $putName (keys %putNames) { $self->submit_parameter($putName,$putNames{$putName}); } # GET parameters second my @getValues = $self->_rearrange([keys %GETPARAMS],@args); my %getNames; @getNames{keys %GETPARAMS} = @getValues; foreach my $getName (keys %getNames) { $self->retrieve_parameter($getName,$getNames{$getName}); } # private variable to keep track of total rids $self->{'_total_rids'} = 0; $url_base ||= $URLBASE; # default to regular NCBI BLAST URL $self->set_url_base($url_base); return $self; } =head2 retrieve_parameter Title : retrieve_parameter Usage : my $db = $self->retrieve_parameter Function: Get/Set the named parameter for the retrieve_blast operation. Returns : string Args : $name : name of GET parameter $val : optional value to set the parameter to =cut sub retrieve_parameter { my ($self, $name, $val) = @_; $name = uc($name); $self->throw($name." is not a valid GET parameter.") unless exists $GETPARAMS{$name}; if (defined $val) { my $regex = $GETPARAMS{$name}; $val =~ m/^$regex$/i or $self->throw("Value ".$val." for GET parameter ".$name." does not match expression ".$regex.". Rejecting."); $RETRIEVALHEADER{$name} = $val; } return $RETRIEVALHEADER{$name}; } =head2 submit_parameter Title : submit_parameter Usage : my $db = $self->submit_parameter Function: Get/Set the named parameter for the submit_blast operation. Returns : string Args : $name : name of PUT parameter $val : optional value to set the parameter to =cut sub submit_parameter { my ($self, $name, $val) = @_; $name = uc($name); $self->throw($name." is not a valid PUT parameter.") unless exists $PUTPARAMS{$name}; if (defined $val) { my $regex = $PUTPARAMS{$name}; $val =~ m/^$regex$/i or $self->throw("Value ".$val." for PUT parameter ".$name." does not match expression ".$regex.". Rejecting."); $HEADER{$name} = $val; } return $HEADER{$name}; } =head2 header Title : header Usage : my $header = $self->header Function: Get HTTP header for blast query Returns : string Args : none =cut sub header { my ($self) = @_; return %HEADER; } =head2 readmethod Title : readmethod Usage : my $readmethod = $self->readmethod Function: Get/Set the method to read the blast report Returns : string Args : string [ blast, blasttable, xml ] =cut sub readmethod { my ($self, $val) = @_; if( defined $val ) { if ($val =~ /bplite/i) { $self->throw("Use of Bio::Tools::BPlite is deprecated; use Bio::SearchIO modules instead"); } $self->{'_readmethod'} = $val; } return $self->{'_readmethod'}; } =head2 program Title : program Usage : my $prog = $self->program Function: Get/Set the program to run. Retained for backwards-compatibility. Returns : string Args : string [ blastp, blastn, blastx, tblastn, tblastx ] =cut sub program { my ($self, $val) = @_; return $self->submit_parameter('PROGRAM',$val); } =head2 database Title : database Usage : my $db = $self->database Function: Get/Set the database to search. Retained for backwards-compatibility. Returns : string Args : string [ swissprot, nr, nt, etc... ] =cut sub database { my ($self, $val) = @_; return $self->submit_parameter('DATABASE',$val); } =head2 expect Title : expect Usage : my $expect = $self->expect Function: Get/Set the E value cutoff. Retained for backwards-compatibility. Returns : string Args : string [ '1e-4' ] =cut sub expect { my ($self, $val) = @_; return $self->submit_parameter('EXPECT',$val); } =head2 ua Title : ua Usage : my $ua = $self->ua or $self->ua($ua) Function: Get/Set a LWP::UserAgent for use Returns : reference to LWP::UserAgent Object Args : none Comments: Will create a UserAgent if none has been requested before. =cut sub ua { my ($self, $value) = @_; if( ! defined $self->{'_ua'} ) { $self->{'_ua'} = LWP::UserAgent->new(env_proxy => 1, parse_head => 0); my $nm = ref($self); $nm =~ s/::/_/g; $self->{'_ua'}->agent("bioperl-$nm/$MODVERSION"); } return $self->{'_ua'}; } =head2 proxy Title : proxy Usage : $httpproxy = $db->proxy('http') or $db->proxy(['http','ftp'], 'http://myproxy' ) Function: Get/Set a proxy for use of proxy Returns : a string indicating the proxy Args : $protocol : an array ref of the protocol(s) to set/get $proxyurl : url of the proxy to use for the specified protocol =cut sub proxy { my ($self,$protocol,$proxy) = @_; return if ( !defined $self->ua || !defined $protocol || !defined $proxy ); return $self->ua->proxy($protocol,$proxy); } sub add_rid { my ($self, @vals) = @_; foreach ( @vals ) { $self->{'_rids'}->{$_} = $self->{'_total_rids'}; $self->{'_total_rids'}++; } return scalar keys %{$self->{'_rids'}}; } sub remove_rid { my ($self, @vals) = @_; foreach ( @vals ) { delete $self->{'_rids'}->{$_}; } return scalar keys %{$self->{'_rids'}}; } sub each_rid { my ($self) = @_; # sort on key value, a little tricky... my @sort_rids = sort {$self->{'_rids'}->{$a} <=> $self->{'_rids'}->{$b}} keys %{$self->{'_rids'}}; return @sort_rids; } =head2 submit_blast Title : submit_blast Usage : $self->submit_blast([$seq1,$seq2]); Function: Submit blast jobs to ncbi blast queue on sequence(s) Returns : Blast report object as defined by $self->readmethod Args : input can be: * sequence object * array ref of sequence objects * filename of file containing fasta formatted sequences =cut sub submit_blast { my ($self, $input) = @_; my @seqs = $self->_load_input($input); my $url_base = $self->get_url_base; return 0 unless ( @seqs ); my $tcount = 0; my %header = $self->header; $header{$_} ||= $RETRIEVALHEADER{$_} foreach (keys %RETRIEVALHEADER); foreach my $seq ( @seqs ) { #If query has a fasta header, the output has the query line. $header{'QUERY'} = ">".(defined $seq->display_id() ? $seq->display_id() : ""). " ".(defined $seq->desc() ? $seq->desc() : "")."\n".$seq->seq(); my $request = POST $url_base, [%header]; $self->debug($request->as_string) if ( $self->verbose > 1); my $response = $self->ua->request( $request); if( $response->is_success ) { my @subdata = split(/\n/, $response->content ); my $count = 0; foreach ( @subdata ) { if( /^\s+RID\s+=\s+(\S+)/ ) { $count++; #$self->debug("RID: $1\n"); $self->add_rid($1); } elsif (/^\s+RTOE\s+=\s+(.*$)/) { $self->{rtoe} = $1; $count++; } last if $count >= 2; } if( $count == 0 ) { $self->warn("req was ". $request->as_string() . "\n"); $self->warn(join('', @subdata)); } $tcount += $count; } else { # should try and be a little more verbose here $self->warn("req was ". $request->as_string() . "\n" . $response->error_as_HTML); $tcount = -1; } } return $tcount; } =head2 retrieve_blast Title : retrieve_blast Usage : my $blastreport = $blastfactory->retrieve_blast($rid); Function: Attempts to retrieve a blast report from remote blast queue Returns : scalar int (constant) or Bio::SearchIO object Constants: NOT_FINISHED (= 0) : 'job not finished' code on error: ERR_QBSTATUS (= 1) : return line matches 'Status=ERROR' ERR_NOCONTENT (= 2): HTTP request successful, but no content returned ERR_HTTPFAIL (= 4) : HTTP request failed ERR_QBNONSPEC (= 8): return line matches 'ERROR' (not status line) Args : Remote Blast ID (RID) =cut sub retrieve_blast { my($self, $rid) = @_; my $url_base = $self->get_url_base; my %hdr = %RETRIEVALHEADER; $hdr{'RID'} = $rid; my $req = HTTP::Request->new( GET => $url_base."?CMD=Get&FORMAT_OBJECT=SearchInfo&RID=$rid", ); #$self->debug("SearchInfo request is " . $req->as_string()); my $response = $self->ua->request($req); if( $response->is_success ) { my $status; if($response->content =~ /Status=(WAITING|ERROR|FAILED|UNKNOWN|READY)/i ) { $status = $1; if( $status eq 'ERROR' ) { $self->warn("Server Error"); return ERR_QBSTATUS; } elsif( $status eq 'FAILED' ) { $self->warn("Request Failed"); return ERR_QBSTATUS; } } else { $self->warn("Error: No status reported\n"); } if ( $status ne 'READY' ) { return 0; } else { my ($fh,$tempfile) = $self->tempfile(); close $fh; my $req = POST $url_base, [%hdr]; $self->debug("retrieve request is " . $req->as_string()); my $response = $self->ua->request($req, $tempfile); my $blastobj; my $mthd = $self->readmethod; $mthd = ($mthd =~ /blasttable/i) ? 'blasttable' : ($mthd =~ /xml/i) ? 'blastxml' : ($mthd =~ /pull/i) ? 'blast_pull' : 'blast'; $blastobj = Bio::SearchIO->new( -file => $tempfile, -format => $mthd); ## store filename in object ## $self->file($tempfile); return $blastobj; } } else { $self->warn($response->error_as_HTML); return ERR_HTTPFAIL; } } =head2 save_output Title : saveoutput Usage : my $saveoutput = $self->save_output($filename) Function: Method to save the blast report Returns : 1 (throws error otherwise) Args : string [rid, filename] =cut sub save_output { my ($self, $filename) = @_; if( ! defined $filename ) { $self->throw("Can't save blast output. You must specify a filename to save to."); } my $blastfile = $self->file; #open temp file and output file, have to filter out some HTML open(my $TMP, $blastfile) or $self->throw("cannot open $blastfile"); open(my $SAVEOUT, ">", $filename) or $self->throw("cannot open $filename"); my $seentop = 0; while(<$TMP>) { next if (/<pre>/); if(/^(?:[T]?BLAST[NPX])\s*.+$/i || /^RPS-BLAST\s*.+$/i || /<\?xml\sversion=/ || /^#\s+(?:[T]?BLAST[NPX])\s*.+$/) { $seentop=1; } next if !$seentop; if( $seentop ) { print $SAVEOUT $_; } } return 1; } sub _load_input { my ($self, $input) = @_; if( ! defined $input ) { $self->throw("Calling remote blast with no input"); } my @seqs; if( ! ref $input ) { if( -e $input ) { my $seqio = Bio::SeqIO->new(-format => 'fasta', -file => $input); while( my $seq = $seqio->next_seq ) { push @seqs, $seq; } } else { $self->throw("Input $input was not a valid filename"); } } elsif( ref($input) =~ /ARRAY/i ) { foreach ( @$input ) { if( ref($_) && $_->isa('Bio::PrimarySeqI') ) { push @seqs, $_; } else { $self->warn("Trying to add a " . ref($_) . " but expected a Bio::PrimarySeqI"); } } if( ! @seqs) { $self->throw("Did not pass in valid input -- no sequence objects found"); } } elsif( $input->isa('Bio::PrimarySeqI') ) { push @seqs, $input; } return @seqs; } =head2 set_url_base Title : set_url_base Usage : $self->set_url_base($url) Function: Method to override the default NCBI BLAST database Returns : None Args : string (database url like NOTE : This is highly experimental; we cannot maintain support on databases other than the default NCBI database at this time =cut sub set_url_base { my $self = shift; $self->{'_urlbase'} = shift if @_; } =head2 get_url_base Title : get_url_base Usage : my $url = $self->set_url_base Function: Get the current URL for BLAST database searching Returns : string (URL used for remote blast searches) Args : None =cut sub get_url_base { my $self = shift; return $self->{'_urlbase'}; } =head2 get_rtoe Title : get_rtoe Usage : my $url = $self->rtoe Function: Retrieve the retrieval time (defined after submit_blast()) Returns : number Args : None =cut sub get_rtoe { my $self = shift; return $self->{rtoe}; } 1; __END__ �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/StandAloneBlast.pm����������������������������������������������������000444��000765��000024�� 53611�12254227335� 21420� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Run::StandAloneBlast # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::StandAloneBlast - Object for the local execution of the NCBI BLAST program suite (blastall, blastpgp, bl2seq). There is experimental support for WU-Blast and NCBI rpsblast. =head1 SYNOPSIS # Local-blast "factory object" creation and blast-parameter # initialization: @params = (-database => 'swissprot', -outfile => 'blast1.out'); $factory = Bio::Tools::Run::StandAloneBlast->new(@params); # Blast a sequence against a database: $str = Bio::SeqIO->new(-file=>'t/amino.fa', -format => 'Fasta'); $input = $str->next_seq(); $input2 = $str->next_seq(); $blast_report = $factory->blastall($input); # Run an iterated Blast (psiblast) of a sequence against a database: $factory->j(3); # 'j' is blast parameter for # of iterations $factory->outfile('psiblast1.out'); $factory = Bio::Tools::Run::StandAloneBlast->new(@params); $blast_report = $factory->blastpgp($input); # Use blast to align 2 sequences against each other: $factory = Bio::Tools::Run::StandAloneBlast->new(-outfile => 'bl2seq.out'); $factory->bl2seq($input, $input2); # Experimental support for WU-Blast 2.0 my $factory = Bio::Tools::Run::StandAloneBlast->new(-program =>"wublastp", -database =>"swissprot", -e => 1e-20); my $blast_report = $factory->wublast($seq); # Experimental support for NCBI rpsblast my $factory = Bio::Tools::Run::StandAloneBlast->new(-db => 'CDD/Cog', -expect => 0.001); $factory->F('T'); # turn on SEG filtering of query sequence my $blast_report = $factory->rpsblast($seq); # Use the experimental fast Blast parser, 'blast_pull' my $factory = Bio::Tools::Run::StandAloneBlast->new(-_READMETHOD =>'blast_pull', @other_params); # Various additional options and input formats are available, # see the DESCRIPTION section for details. =head1 DESCRIPTION This DESCRIPTION only documents Bio::Tools::Run::StandAloneBlast, a Bioperl object for running the NCBI standAlone BLAST package. Blast itself is a large & complex program - for more information regarding BLAST, please see the BLAST documentation which accompanies the BLAST distribution. BLAST is available from ftp://ncbi.nlm.nih.gov/blast/. A source of confusion in documenting a BLAST interface is that the term "program" is used in - at least - three different ways in the BLAST documentation. In this DESCRIPTION, "program" will refer to the BLAST routine set by the BLAST C<-p> parameter that can be set to blastn, blastp, tblastx etc. We will use the term Blast "executable" to refer to the various different executable files that may be called - ie. blastall, blastpgp or bl2seq. In addition, there are several BLAST capabilities, which are also referred to as "programs", and are implemented by using specific combinations of BLAST executables, programs and parameters. They will be referred by their specific names - eg PSIBLAST and PHIBLAST. Before running StandAloneBlast it is necessary: to install BLAST on your system, to edit set the environmental variable $BLASTDIR or your $PATH variable to point to the BLAST directory, and to ensure that users have execute privileges for the BLAST program. If the databases which will be searched by BLAST are located in the data subdirectory of the blast program directory (the default installation location), StandAloneBlast will find them; however, if the database files are located in any other location, environmental variable $BLASTDATADIR will need to be set to point to that directory. The use of the StandAloneBlast module is as follows: Initially, a local blast "factory object" is created. The constructor may be passed an optional array of (non-default) parameters to be used by the factory, eg: @params = (-program => 'blastn', -database => 'ecoli.nt'); $factory = Bio::Tools::Run::StandAloneBlast->new(@params); Any parameters not explicitly set will remain as the defaults of the BLAST executable. Note each BLAST executable has somewhat different parameters and options. See the BLAST Documentation for a description or run the BLAST executable from the command line followed solely with a "-" to see a list of options and default values for that executable; eg E<gt>blastall -. BLAST parameters can be changed and/or examined at any time after the factory has been created. The program checks that any parameter/switch being set/read is valid. Except where specifically noted, StandAloneBlast uses the same single-letter, case-sensitive parameter names as the actual blast program. Currently no checks are included to verify that parameters are of the proper type (e.g. string or numeric) or that their values are within the proper range. As an example, to change the value of the Blast parameter 'e' ('e' is the parameter for expectation-value cutoff) $expectvalue = 0.01; $factory->e($expectvalue); Note that for improved script readibility one can modify the name of the (ncbi) BLAST parameters as desired as long as the initial letter (and case) of the parameter are preserved, e.g.: $factory->expectvalue($expectvalue); Unfortunately, some of the BLAST parameters are not the single letter one might expect (eg "iteration round" in blastpgp is 'j'). Again one can check by using, for example: > blastpgp - Wublast parameters need to be complete (ie. don't truncate them to their first letter), but are case-insensitive. Once the factory has been created and the appropriate parameters set, one can call one of the supported blast executables. The input sequence(s) to these executables may be fasta file(s) as described in the BLAST documentation. $inputfilename = 't/testquery.fa'; $blast_report = $factory->blastall($inputfilename); In addition, sequence input may be in the form of either a Bio::Seq object or (a reference to) an array of Bio::Seq objects, e.g.: $input = Bio::Seq->new(-id => "test query", -seq => "ACTACCCTTTAAATCAGTGGGGG"); $blast_report = $factory->blastall($input); NOTE: Use of the BPlite method has been deprecated and is no longer supported. For blastall and non-psiblast blastpgp runs, report object is a L<Bio::SearchIO> object, selected by the user with the parameter _READMETHOD. The leading underscore is needed to distinguish this option from options which are passed to the BLAST executable. The default parser is Bio::SearchIO::blast. In any case, the "raw" blast report is also available. The filename is set by the 'outfile' parameter and has the default value of "blastreport.out". For psiblast execution in the BLAST "jumpstart" mode, the program must be passed (in addition to the query sequence itself) an alignment containing the query sequence (in the form of a SimpleAlign object) as well as a "mask" specifying at what residues position-specific scoring matrices (PSSMs) are to used and at what residues default scoring matrices (eg BLOSUM) are to be used. See psiblast documentation for more details. The mask itself is a string of 0's and 1's which is the same length as each sequence in the alignment and has a "1" at locations where (PSSMs) are to be used and a "0" at all other locations. So for example: $str = Bio::AlignIO->new(-file => "cysprot.msf", -format => 'msf'); $aln = $str->next_aln(); $len = $aln->length_aln(); $mask = '1' x $len; # simple case where PSSM's to be used at all residues $report = $factory->blastpgp("cysprot1.fa", $aln, $mask); For bl2seq execution, StandAloneBlast.pm can be combined with AlignIO.pm to directly produce a SimpleAlign object from the alignment of the two sequences produced by bl2seq as in: # Get 2 sequences $str = Bio::SeqIO->new(-file=>'t/amino.fa' , -format => 'Fasta'); my $seq3 = $str->next_seq(); my $seq4 = $str->next_seq(); # Run bl2seq on them $factory = Bio::Tools::Run::StandAloneBlast->new(-program => 'blastp', -outfile => 'bl2seq.out'); my $bl2seq_report = $factory->bl2seq($seq3, $seq4); # Use AlignIO.pm to create a SimpleAlign object from the bl2seq report $str = Bio::AlignIO->new(-file=> 'bl2seq.out',-format => 'bl2seq'); $aln = $str->next_aln(); For more examples of syntax and use of StandAloneBlast.pm, the user is encouraged to run the scripts standaloneblast.pl in the bioperl examples/tools directory and StandAloneBlast.t in the bioperl t/ directory. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Schattner Email schattner at alum.mit.edu =head1 MAINTAINER - Torsten Seemann Email torsten at infotech.monash.edu.au =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk (reimplementation) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Run::StandAloneBlast; use strict; use warnings; use Bio::Root::IO; use Bio::Seq; use Bio::SeqIO; use Bio::SearchIO; use File::Spec; use base qw(Bio::Tools::Run::WrapperBase Bio::Factory::ApplicationFactoryI); our $AUTOLOAD; our $DEFAULTBLASTTYPE = 'NCBI'; our $DEFAULTREADMETHOD = 'BLAST'; # If local BLAST databases are not stored in the standard # /data directory, the variable BLASTDATADIR will need to be # set explicitly our $DATADIR = $ENV{'BLASTDATADIR'} || $ENV{'BLASTDB'}; if (! defined $DATADIR && defined $ENV{'BLASTDIR'}) { my $dir = Bio::Root::IO->catfile($ENV{'BLASTDIR'}, 'data'); if (-d $dir) { $DATADIR = $dir; } elsif ($ENV{'BLASTDIR'} =~ /bin/) { $dir = $ENV{'BLASTDIR'}; $dir =~ s/bin/data/; $DATADIR = $dir if -d $dir; } } =head2 new Title : new Usage : my $obj = Bio::Tools::Run::StandAloneBlast->new(); Function: Builds a newBio::Tools::Run::StandAloneBlast object Returns : Bio::Tools::Run::StandAloneNCBIBlast or StandAloneWUBlast Args : -quiet => boolean # make program execution quiet -_READMETHOD => 'BLAST' (default, synonym 'SearchIO') || 'blast_pull' # the parsing method, case insensitive Essentially all BLAST parameters can be set via StandAloneBlast.pm. Some of the most commonly used parameters are listed below. All parameters have defaults and are optional except for -p in those programs that have it. For a complete listing of settable parameters, run the relevant executable BLAST program with the option "-" as in blastall - Note that the input parameters (-i, -j, -input) should not be set directly by you: this module sets them when you call one of the executable methods. Blastall -p Program Name [String] Input should be one of "blastp", "blastn", "blastx", "tblastn", or "tblastx". -d Database [String] default = nr The database specified must first be formatted with formatdb. Multiple database names (bracketed by quotations) will be accepted. An example would be -d "nr est" -e Expectation value (E) [Real] default = 10.0 -o BLAST report Output File [File Out] Optional, default = ./blastreport.out ; set by StandAloneBlast.pm -S Query strands to search against database (for blast[nx], and tblastx). 3 is both, 1 is top, 2 is bottom [Integer] default = 3 Blastpgp (including Psiblast) -j is the maximum number of rounds (default 1; i.e., regular BLAST) -h is the e-value threshold for including sequences in the score matrix model (default 0.001) -c is the "constant" used in the pseudocount formula specified in the paper (default 10) -B Multiple alignment file for PSI-BLAST "jump start mode" Optional -Q Output File for PSI-BLAST Matrix in ASCII [File Out] Optional rpsblast -d Database [String] default = (none - you must specify a database) The database specified must first be formatted with formatdb. Multiple database names (bracketed by quotations) will be accepted. An example would be -d "Cog Smart" -e Expectation value (E) [Real] default = 10.0 -o BLAST report Output File [File Out] Optional, default = ./blastreport.out ; set by StandAloneBlast.pm Bl2seq -p Program name: blastp, blastn, blastx. For blastx 1st argument should be nucleotide [String] default = blastp -o alignment output file [File Out] default = stdout -e Expectation value (E) [Real] default = 10.0 -S Query strands to search against database (blastn only). 3 is both, 1 is top, 2 is bottom [Integer] default = 3 WU-Blast -p Program Name [String] Input should be one of "wublastp", "wublastn", "wublastx", "wutblastn", or "wutblastx". -d Database [String] default = nr The database specified must first be formatted with xdformat. -E Expectation value (E) [Real] default = 10.0 -o BLAST report Output File [File Out] Optional, default = ./blastreport.out ; set by StandAloneBlast.pm =cut sub new { my ($caller, @args) = @_; my $class = ref($caller) || $caller; # Because of case-sensitivity issues, ncbi and wublast methods are # mutually exclusive. We can't load ncbi methods if we start with wublast # (and vice versa) since wublast e() and E() should be the same thing, # whilst they must be different things in ncbi blast. # # Solution: split StandAloneBlast out into two more modules for NCBI and WU if ($class =~ /NCBI|WU/) { return $class->SUPER::new(@args); } my %args = @args; my $blasttype = $DEFAULTBLASTTYPE; while (my ($attr, $value) = each %args) { if ($attr =~/^-?\s*program\s*$|^-?p$/) { if ($value =~ /^wu*/) { $blasttype = 'WU'; } } } my $module = "Bio::Tools::Run::StandAlone${blasttype}Blast"; Bio::Root::Root->_load_module($module); return $module->new(@args); } =head2 executable Title : executable Usage : my $exe = $blastfactory->executable('blastall'); Function: Finds the full path to the executable Returns : string representing the full path to the exe Args : [optional] name of executable to set path to [optional] boolean flag whether or not warn when exe is not found =cut sub executable { my ($self, $exename, $exe, $warn) = @_; $exename = 'blastall' unless (defined $exename || $self =~ /WUBlast/); $self->program_name($exename); if( defined $exe && -x $exe ) { $self->{'_pathtoexe'}->{$exename} = $exe; } unless( defined $self->{'_pathtoexe'}->{$exename} ) { my $f = $self->program_path($exename); $exe = $self->{'_pathtoexe'}->{$exename} = $f if(-e $f && -x $f ); # This is how I meant to split up these conditionals --jason # if exe is null we will execute this (handle the case where # PROGRAMDIR pointed to something invalid) unless( $exe ) { # we didn't find it in that last conditional if( ($exe = $self->io->exists_exe($exename)) && -x $exe ) { $self->{'_pathtoexe'}->{$exename} = $exe; } else { $self->warn("Cannot find executable for $exename") if $warn; $self->{'_pathtoexe'}->{$exename} = undef; } } } return $self->{'_pathtoexe'}->{$exename}; } =head2 program_dir Title : program_dir Usage : my $dir = $factory->program_dir(); Function: Abstract get method for dir of program. Returns : string representing program directory Args : none =cut sub program_dir { my $self = shift; $self =~ /NCBIBlast/? $ENV{'BLASTDIR'}: $ENV{'WUBLASTDIR'}; } sub program_name { my $self = shift; if (@_) { $self->{program_name} = shift } return $self->{program_name} || ''; } sub program { my $self = shift; if( wantarray ) { return ($self->executable, $self->p()); } else { return $self->executable(@_); } } =head2 _setinput Title : _setinput Usage : Internal function, not to be called directly Function: Create input file(s) for Blast executable Example : Returns : name of file containing Blast data input Args : Seq object reference or input file name =cut sub _setinput { my ($self, $executable, $input1, $input2) = @_; my ($seq, $temp, $infilename1, $infilename2,$fh ) ; # If $input1 is not a reference it better be the name of a file with # the sequence/ alignment data... $self->io->_io_cleanup(); SWITCH: { unless (ref $input1) { $infilename1 = (-e $input1) ? $input1 : 0 ; last SWITCH; } # $input may be an array of BioSeq objects... if (ref($input1) =~ /ARRAY/i ) { ($fh,$infilename1) = $self->io->tempfile(); $temp = Bio::SeqIO->new(-fh=> $fh, -format => 'fasta'); foreach $seq (@$input1) { unless ($seq->isa("Bio::PrimarySeqI")) {return 0;} $seq->display_id($seq->display_id); $temp->write_seq($seq); } close $fh; $fh = undef; last SWITCH; } # $input may be a single BioSeq object... elsif ($input1->isa("Bio::PrimarySeqI")) { ($fh,$infilename1) = $self->io->tempfile(); # just in case $input1 is taken from an alignment and has spaces (ie # deletions) indicated within it, we have to remove them - otherwise # the BLAST programs will be unhappy my $seq_string = $input1->seq(); $seq_string =~ s/\W+//g; # get rid of spaces in sequence $input1->seq($seq_string); $temp = Bio::SeqIO->new(-fh=> $fh, '-format' => 'fasta'); $temp->write_seq($input1); close $fh; undef $fh; last SWITCH; } $infilename1 = 0; # Set error flag if you get here } unless ($input2) { return $infilename1; } SWITCH2: { unless (ref $input2) { $infilename2 = (-e $input2) ? $input2 : 0 ; last SWITCH2; } if ($input2->isa("Bio::PrimarySeqI") && $executable eq 'bl2seq' ) { ($fh,$infilename2) = $self->io->tempfile(); $temp = Bio::SeqIO->new(-fh=> $fh, '-format' => 'Fasta'); $temp->write_seq($input2); close $fh; undef $fh; last SWITCH2; } # Option for using psiblast's pre-alignment "jumpstart" feature elsif ($input2->isa("Bio::SimpleAlign") && $executable eq 'blastpgp' ) { # a bit of a lie since it won't be a fasta file ($fh,$infilename2) = $self->io->tempfile(); # first we retrieve the "mask" that determines which residues should # by scored according to their position and which should be scored # using the non-position-specific matrices my @mask = split("", shift ); # get mask # then we have to convert all the residues in every sequence to upper # case at the positions that we want psiblast to use position specific # scoring foreach $seq ( $input2->each_seq() ) { my @seqstringlist = split("",$seq->seq()); for (my $i = 0; $i < scalar(@mask); $i++) { unless ( $seqstringlist[$i] =~ /[a-zA-Z]/ ) {next} $seqstringlist[$i] = $mask[$i] ? uc $seqstringlist[$i]: lc $seqstringlist[$i] ; } my $newseqstring = join("", @seqstringlist); $seq->seq($newseqstring); } # Now we need to write out the alignment to a file # in the "psi format" which psiblast is expecting $input2->map_chars('\.','-'); $temp = Bio::AlignIO->new(-fh=> $fh, '-format' => 'psi'); $temp->write_aln($input2); close $fh; undef $fh; last SWITCH2; } $infilename2 = 0; # Set error flag if you get here } return ($infilename1, $infilename2); } =head1 Bio::Tools::Run::WrapperBase methods =cut =head2 no_param_checks Title : no_param_checks Usage : $obj->no_param_checks($newval) Function: Boolean flag as to whether or not we should trust the sanity checks for parameter values Returns : value of no_param_checks Args : newvalue (optional) =cut =head2 save_tempfiles Title : save_tempfiles Usage : $obj->save_tempfiles($newval) Function: Returns : value of save_tempfiles Args : newvalue (optional) =cut =head2 outfile_name Title : outfile_name Usage : my $outfile = $tcoffee->outfile_name(); Function: Get/Set the name of the output file for this run (if you wanted to do something special) Returns : string Args : [optional] string to set value to =cut =head2 tempdir Title : tempdir Usage : my $tmpdir = $self->tempdir(); Function: Retrieve a temporary directory name (which is created) Returns : string which is the name of the temporary directory Args : none =cut =head2 cleanup Title : cleanup Usage : $tcoffee->cleanup(); Function: Will cleanup the tempdir directory after a PAML run Returns : none Args : none =cut =head2 io Title : io Usage : $obj->io($newval) Function: Gets a Bio::Root::IO object Returns : Bio::Root::IO Args : none =cut 1; �����������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/StandAloneNCBIBlast.pm������������������������������������������������000444��000765��000024�� 46523�12254227330� 22053� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Run::StandAloneBlast # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::StandAloneNCBIBlast - Object for the local execution of the NCBI BLAST program suite (blastall, blastpgp, bl2seq). With experimental support for NCBI rpsblast. =head1 SYNOPSIS # Do not use directly; see Bio::Tools::Run::StandAloneBlast =head1 DESCRIPTION See Bio::Tools::Run::StandAloneBlast =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Schattner Email schattner at alum.mit.edu =head1 MAINTAINER - Torsten Seemann Email torsten at infotech.monash.edu.au =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk (reimplementation) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Run::StandAloneNCBIBlast; use strict; use warnings; use base qw(Bio::Tools::Run::StandAloneBlast); our $AUTOLOAD; our $DEFAULTREADMETHOD = 'BLAST'; # If local BLAST databases are not stored in the standard # /data directory, the variable BLASTDATADIR will need to be # set explicitly our $DATADIR = $Bio::Tools::Run::StandAloneBlast::DATADIR; our %GENERAL_PARAMS = (i => 'input', o => 'outfile', p => 'program', d => 'database'); our @BLASTALL_PARAMS = qw(A B C D E F G K L M O P Q R S W X Y Z a b e f l m q r t v w y z n); our @BLASTALL_SWITCH = qw(I g J T U n V s); our @BLASTPGP_PARAMS = qw(A B C E F G H I J K L M N O P Q R S T U W X Y Z a b c e f h j k l m q s t u v y z); our @RPSBLAST_PARAMS = qw(F I J L N O P T U V X Y Z a b e l m v y z); our @BL2SEQ_PARAMS = qw(A D E F G I J M S T U V W X Y a e g j m q r t); our @OTHER_PARAMS = qw(_READMETHOD); =head2 new Title : new Usage : my $obj = Bio::Tools::Run::StandAloneBlast->new(); Function: Builds a newBio::Tools::Run::StandAloneBlast object Returns : Bio::Tools::Run::StandAloneBlast Args : -quiet => boolean # make program execution quiet -_READMETHOD => 'BLAST' (default, synonym 'SearchIO') || 'blast_pull' # the parsing method, case insensitive Essentially all BLAST parameters can be set via StandAloneBlast.pm. Some of the most commonly used parameters are listed below. All parameters have defaults and are optional except for -p in those programs that have it. For a complete listing of settable parameters, run the relevant executable BLAST program with the option "-" as in blastall - Note that the input parameters (-i, -j, -input) should not be set directly by you: this module sets them when you call one of the executable methods. Blastall -p Program Name [String] Input should be one of "blastp", "blastn", "blastx", "tblastn", or "tblastx". -d Database [String] default = nr The database specified must first be formatted with formatdb. Multiple database names (bracketed by quotations) will be accepted. An example would be -d "nr est" -e Expectation value (E) [Real] default = 10.0 -o BLAST report Output File [File Out] Optional, default = ./blastreport.out ; set by StandAloneBlast.pm -S Query strands to search against database (for blast[nx], and tblastx). 3 is both, 1 is top, 2 is bottom [Integer] default = 3 Blastpgp (including Psiblast) -j is the maximum number of rounds (default 1; i.e., regular BLAST) -h is the e-value threshold for including sequences in the score matrix model (default 0.001) -c is the "constant" used in the pseudocount formula specified in the paper (default 10) -B Multiple alignment file for PSI-BLAST "jump start mode" Optional -Q Output File for PSI-BLAST Matrix in ASCII [File Out] Optional rpsblast -d Database [String] default = (none - you must specify a database) The database specified must first be formatted with formatdb. Multiple database names (bracketed by quotations) will be accepted. An example would be -d "Cog Smart" -e Expectation value (E) [Real] default = 10.0 -o BLAST report Output File [File Out] Optional, default = ./blastreport.out ; set by StandAloneBlast.pm Bl2seq -p Program name: blastp, blastn, blastx. For blastx 1st argument should be nucleotide [String] default = blastp -o alignment output file [File Out] default = stdout -e Expectation value (E) [Real] default = 10.0 -S Query strands to search against database (blastn only). 3 is both, 1 is top, 2 is bottom [Integer] default = 3 =cut sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); # StandAloneBlast is special in that "one can modify the name of # the (ncbi) BLAST parameters as desired as long as the initial letter (and # case) of the parameter are preserved". We handle this by truncating input # args to their first char my %args = @args; @args = (); while (my ($attr, $value) = each %args) { $attr =~ s/^-//; $attr = substr($attr, 0, 1) unless $attr =~ /^_/; push(@args, $attr, $value); } $self->_set_from_args(\@args, -methods => {(map { $_ => $GENERAL_PARAMS{$_} } keys %GENERAL_PARAMS), (map { $_ => $_ } (@OTHER_PARAMS, @BLASTALL_PARAMS, @BLASTALL_SWITCH, @BLASTPGP_PARAMS, @RPSBLAST_PARAMS, @BL2SEQ_PARAMS))}, -code => { map { $_ => 'my $self = shift; if (@_) { my $value = shift; if ($value && $value ne \'F\') { $value = \'T\'; } else { $value = \'F\'; } $self->{\'_\'.$method} = $value; } return $self->{\'_\'.$method} || return;' } @BLASTALL_SWITCH }, # these methods can take boolean or 'T' and 'F' -create => 1, -force => 1, -case_sensitive => 1); my ($tfh, $tempfile) = $self->io->tempfile(); my $outfile = $self->o || $self->outfile || $tempfile; $self->o($outfile); close($tfh); $self->_READMETHOD($DEFAULTREADMETHOD) unless $self->_READMETHOD; return $self; } # StandAloneBlast is special in that "one can modify the name of # the (ncbi) BLAST parameters as desired as long as the initial letter (and # case) of the parameter are preserved". We handle this with AUTOLOAD # redirecting to the automatically created methods from _set_from_args() ! sub AUTOLOAD { my $self = shift; my $attr = $AUTOLOAD; $attr =~ s/.*:://; my $orig = $attr; $attr = substr($attr, 0, 1); $self->can($attr) || $self->throw("Unallowed parameter: $orig !"); return $self->$attr(@_); } =head2 blastall Title : blastall Usage : $blast_report = $factory->blastall('t/testquery.fa'); or $input = Bio::Seq->new(-id=>"test query", -seq=>"ACTACCCTTTAAATCAGTGGGGG"); $blast_report = $factory->blastall($input); or $seq_array_ref = \@seq_array; # where @seq_array is an array of Bio::Seq objects $blast_report = $factory->blastall($seq_array_ref); Returns : Reference to a Blast object containing the blast report. Args : Name of a file or Bio::Seq object or an array of Bio::Seq object containing the query sequence(s). Throws an exception if argument is not either a string (eg a filename) or a reference to a Bio::Seq object (or to an array of Seq objects). If argument is string, throws exception if file corresponding to string name can not be found. =cut sub blastall { my ($self, $input1) = @_; $self->io->_io_cleanup(); my $executable = 'blastall'; # Create input file pointer my $infilename1 = $self->_setinput($executable, $input1) || $self->throw("$input1 not Bio::Seq object or array of Bio::Seq objects or file name!"); $self->i($infilename1); my $blast_report = $self->_generic_local_blast($executable); } =head2 blastpgp Title : blastpgp Usage : $blast_report = $factory-> blastpgp('t/testquery.fa'); or $input = Bio::Seq->new(-id=>"test query", -seq=>"ACTADDEEQQPPTCADEEQQQVVGG"); $blast_report = $factory->blastpgp ($input); or $seq_array_ref = \@seq_array; # where @seq_array is an array of Bio::Seq objects $blast_report = $factory-> blastpgp(\@seq_array); Returns : Reference to a Bio::SearchIO object containing the blast report Args : Name of a file or Bio::Seq object. In psiblast jumpstart mode two additional arguments are required: a SimpleAlign object one of whose elements is the query and a "mask" to determine how BLAST should select scoring matrices see DESCRIPTION above for more details. Throws an exception if argument is not either a string (eg a filename) or a reference to a Bio::Seq object (or to an array of Seq objects). If argument is string, throws exception if file corresponding to string name can not be found. Returns : Reference to Bio::SearchIO object containing the blast report. =cut sub blastpgp { my $self = shift; my $executable = 'blastpgp'; my $input1 = shift; my $input2 = shift; # used by blastpgp's -B option to specify which # residues are position aligned my $mask = shift; my ($infilename1, $infilename2 ) = $self->_setinput($executable, $input1, $input2, $mask); if (!$infilename1) {$self->throw("$input1 not Bio::Seq object or array of Bio::Seq objects or file name!");} $self->i($infilename1); # set file name of sequence to be blasted to inputfilename1 (-i param of blastpgp) if ($input2) { unless ($infilename2) {$self->throw("$input2 not SimpleAlign Object in pre-aligned psiblast\n");} $self->B($infilename2); # set file name of partial alignment to inputfilename2 (-B param of blastpgp) } my $blast_report = $self->_generic_local_blast($executable); } =head2 rpsblast Title : rpsblast Usage : $blast_report = $factory->rpsblast('t/testquery.fa'); or $input = Bio::Seq->new(-id=>"test query", -seq=>"MVVLCRADDEEQQPPTCADEEQQQVVGG"); $blast_report = $factory->rpsblast($input); or $seq_array_ref = \@seq_array; # where @seq_array is an array of Bio::Seq objects $blast_report = $factory->rpsblast(\@seq_array); Args : Name of a file or Bio::Seq object or an array of Bio::Seq object containing the query sequence(s). Throws an exception if argument is not either a string (eg a filename) or a reference to a Bio::Seq object (or to an array of Seq objects). If argument is string, throws exception if file corresponding to string name can not be found. Returns : Reference to a Bio::SearchIO object containing the blast report =cut sub rpsblast { my ($self, $input1) = @_; $self->io->_io_cleanup(); my $executable = 'rpsblast'; # Create input file pointer my $infilename1 = $self->_setinput($executable, $input1) || $self->throw("$input1 not Bio::Seq object or array of Bio::Seq objects or file name!"); $self->i($infilename1); my $blast_report = $self->_generic_local_blast($executable); } =head2 bl2seq Title : bl2seq Usage : $factory-> bl2seq('t/seq1.fa', 't/seq2.fa'); or $input1 = Bio::Seq->new(-id=>"test query1", -seq=>"ACTADDEEQQPPTCADEEQQQVVGG"); $input2 = Bio::Seq->new(-id=>"test query2", -seq=>"ACTADDEMMMMMMMDEEQQQVVGG"); $blast_report = $factory->bl2seq ($input1, $input2); Returns : Reference to a BPbl2seq object containing the blast report. Args : Names of 2 files or 2 Bio::Seq objects containing the sequences to be aligned by bl2seq. Throws an exception if argument is not either a pair of strings (eg filenames) or references to Bio::Seq objects. If arguments are strings, throws exception if files corresponding to string names can not be found. =cut sub bl2seq { my $self = shift; my $executable = 'bl2seq'; my $input1 = shift; my $input2 = shift; # Create input file pointer my ($infilename1, $infilename2 ) = $self->_setinput($executable, $input1, $input2); if (!$infilename1){$self->throw(" $input1 not Seq Object or file name!");} if (!$infilename2){$self->throw("$input2 not Seq Object or file name!");} $self->i($infilename1); # set file name of first sequence to # be aligned to inputfilename1 # (-i param of bl2seq) $self->j($infilename2); # set file name of first sequence to # be aligned to inputfilename2 # (-j param of bl2seq) my $blast_report = $self->_generic_local_blast($executable); } =head2 _generic_local_blast Title : _generic_local_blast Usage : internal function not called directly Returns : Bio::SearchIO Args : Reference to calling object and name of BLAST executable =cut sub _generic_local_blast { my $self = shift; my $executable = shift; # Create parameter string to pass to Blast program my $param_string = $self->_setparams($executable); # run Blast my $blast_report = $self->_runblast($executable, $param_string); } =head2 _runblast Title : _runblast Usage : Internal function, not to be called directly Function: makes actual system call to Blast program Example : Returns : Report Bio::SearchIO object in the appropriate format Args : Reference to calling object, name of BLAST executable, and parameter string for executable =cut sub _runblast { my ($self, $executable, $param_string) = @_; my ($blast_obj, $exe); if (! ($exe = $self->executable($executable)) ) { $self->warn("cannot find path to $executable"); return; } my $commandstring = $exe.$param_string; $self->debug("$commandstring\n"); system($commandstring) && $self->throw("$executable call crashed: $? | $! | $commandstring\n"); # set significance cutoff to set expectation value or default value # (may want to make this value vary for different executables) my $signif = $self->e() || 1e-5; # get outputfilename my $outfile = $self->o(); # this should allow any blast SearchIO parser (not just 'blast_pull' or 'blast', # but 'blastxml' and 'blasttable'). Fall back to 'blast' if not stipulated. my $method = $self->_READMETHOD; if ($method =~ /^(?:blast|SearchIO)/i ) { $method = 'blast' if $method =~ m{SearchIO}i; $blast_obj = Bio::SearchIO->new(-file => $outfile, -format => $method); } # should these be here? They have been deprecated... elsif ($method =~ /BPlite/i ) { if ($executable =~ /bl2seq/i) { # Added program info so BPbl2seq can compute strand info $self->throw("Use of Bio::Tools::BPbl2seq is deprecated; use Bio::SearchIO modules instead"); } elsif ($executable =~ /blastpgp/i && defined $self->j() && $self->j() > 1) { $self->throw("Use of Bio::Tools::BPpsilite is deprecated; use Bio::SearchIO modules instead"); } elsif ($executable =~ /blastall|rpsblast/i) { $self->throw("Use of Bio::Tools::BPlite is deprecated; use Bio::SearchIO modules instead"); } else { $self->warn("Unrecognized executable $executable"); } } else { $self->warn("Unrecognized readmethod $method"); } return $blast_obj; } =head2 _setparams Title : _setparams Usage : Internal function, not to be called directly Function: Create parameter inputs for Blast program Example : Returns : parameter string to be passed to Blast Args : Reference to calling object and name of BLAST executable =cut sub _setparams { my ($self, $executable) = @_; my ($attr, $value, @execparams); if ($executable eq 'blastall') { @execparams = (@BLASTALL_PARAMS, @BLASTALL_SWITCH); } elsif ($executable eq 'blastpgp') { @execparams = @BLASTPGP_PARAMS; } elsif ($executable eq 'rpsblast') { @execparams = @RPSBLAST_PARAMS; } elsif ($executable eq 'bl2seq' ) { @execparams = @BL2SEQ_PARAMS; } # we also have all the general params push(@execparams, keys %GENERAL_PARAMS); my $database = $self->d; if ($database && $executable ne 'bl2seq') { # Need to prepend datadirectory to database name my @dbs = split(/ /, $database); for my $i (0..$#dbs) { # (works with multiple databases) if (! (-e $dbs[$i].".nin" || -e $dbs[$i].".pin") && ! (-e $dbs[$i].".nal" || -e $dbs[$i].".pal") ) { $dbs[$i] = File::Spec->catdir($DATADIR, $dbs[$i]); } } $self->d('"'.join(" ", @dbs).'"'); } # workaround for problems with shell metacharacters [bug 2707] # simply quoting does not always work! my $tmp = $self->o; $self->o(quotemeta($tmp)) if ($tmp && $^O !~ /^MSWin/); my $param_string = $self->SUPER::_setparams(-params => [@execparams], -dash => 1); $self->o($tmp) if ($tmp && $^O !~ /^MSWin/); $self->d($database) if $database; if ($self->quiet()) { $param_string .= ' 2> '.File::Spec->devnull; } return $param_string; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/StandAloneWUBlast.pm��������������������������������������������������000444��000765��000024�� 22000�12254227312� 21653� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Run::StandAloneBlast # # Copyright Peter Schattner # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::StandAloneWUBlast - Object for the local execution of WU-Blast. =head1 SYNOPSIS # Do not use directly; use Bio::Tools::Run::StandAloneBlast =head1 DESCRIPTION See Bio::Tools::Run::StandAloneBlast =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Peter Schattner Email schattner at alum.mit.edu =head1 MAINTAINER - Torsten Seemann Email torsten at infotech.monash.edu.au =head1 CONTRIBUTORS Sendu Bala bix@sendu.me.uk (reimplementation) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Run::StandAloneWUBlast; use strict; use base qw(Bio::Tools::Run::StandAloneBlast); our $AUTOLOAD; our $DEFAULTREADMETHOD = 'BLAST'; # If local BLAST databases are not stored in the standard # /data directory, the variable BLASTDATADIR will need to be # set explicitly our $DATADIR = $Bio::Tools::Run::StandAloneBlast::DATADIR; our %GENERAL_PARAMS = (i => 'input', o => 'outfile', p => 'program', d => 'database'); our @WUBLAST_PARAMS = qw(e s e2 s2 w t x m y z l k h v b q r matrix filter wordmask filter maskextra hitdist wink ctxfactor gape gaps gape2 gaps2 gapw gapx olf golf olmax golmax gapdecayrate topcombon topcomboe sumstatsmethod hspsepqmax hspsepsmax gapsepqmax gapsepsmax altscore hspmax gspmax qoffset nwstart nwlen qrecmin qrecmax dbrecmin dbrecmax vdbdescmax dbchunks sort_by_pvalue cpus putenv getenv progress); our @WUBLAST_SWITCH = qw(kap sump poissonp lcfilter lcmask echofilter stats nogap gapall pingpong nosegs postsw span2 span1 span prune consistency links ucdb gi noseqs qtype qres sort_by_pvalue sort_by_count sort_by_highscore sort_by_totalscore sort_by_subjectlength mmio nonnegok novalidctxok shortqueryok notes warnings errors endputenv getenv endgetenv abortonerror abortonfatal); our @OTHER_PARAMS = qw(_READMETHOD); =head2 new Title : new Usage : my $obj = Bio::Tools::Run::StandAloneBlast->new(); Function: Builds a newBio::Tools::Run::StandAloneBlast object Returns : Bio::Tools::Run::StandAloneBlast Args : -quiet => boolean # make program execution quiet -_READMETHOD => 'BLAST' (default, synonym 'SearchIO') || 'blast_pull' # the parsing method, case insensitive Essentially all BLAST parameters can be set via StandAloneBlast.pm. Some of the most commonly used parameters are listed below. All parameters have defaults and are optional except for -p. -p Program Name [String] Input should be one of "wublastp", "wublastn", "wublastx", "wutblastn", or "wutblastx". -d Database [String] default = nr The database specified must first be formatted with xdformat. -E Expectation value (E) [Real] default = 10.0 -o BLAST report Output File [File Out] Optional, default = ./blastreport.out ; set by StandAloneBlast.pm =cut sub new { my ($caller, @args) = @_; my $self = $caller->SUPER::new(@args); $self->_set_from_args(\@args, -methods => {(map { $_ => $GENERAL_PARAMS{$_} } keys %GENERAL_PARAMS), (map { $_ => $_ } (@OTHER_PARAMS, @WUBLAST_PARAMS, @WUBLAST_SWITCH))}, -create => 1, -force => 1); my ($tfh, $tempfile) = $self->io->tempfile(); my $outfile = $self->o || $self->outfile || $tempfile; $self->o($outfile); close($tfh); $self->_READMETHOD($DEFAULTREADMETHOD) unless $self->_READMETHOD; return $self; } # We let get/setter method names be case-insensitve sub AUTOLOAD { my $self = shift; my $attr = $AUTOLOAD; $attr =~ s/.*:://; my $orig = $attr; $attr = lc($attr); $self->can($attr) || $self->throw("Unallowed parameter: $orig !"); return $self->$attr(@_); } =head2 wublast Title : wublast Usage : $blast_report = $factory->wublast('t/testquery.fa'); or $input = Bio::Seq->new(-id=>"test query", -seq=>"ACTACCCTTTAAATCAGTGGGGG"); $blast_report = $factory->wublast($input); or $seq_array_ref = \@seq_array; # where @seq_array is an array of Bio::Seq objects $blast_report = $factory->wublast(\@seq_array); Returns : Reference to a Blast object Args : Name of a file or Bio::Seq object or an array of Bio::Seq object containing the query sequence(s). Throws an exception if argument is not either a string (eg a filename) or a reference to a Bio::Seq object (or to an array of Seq objects). If argument is string, throws exception if file corresponding to string name can not be found. =cut sub wublast { my ($self, $input1) = @_; $self->io->_io_cleanup(); my $executable = 'wublast'; # Create input file pointer my $infilename1 = $self->_setinput($executable, $input1) || $self->throw("$input1 not Bio::Seq object or array of Bio::Seq objects or file name!"); $self->i($infilename1); my $blast_report = $self->_generic_local_wublast($executable); } =head2 _generic_local_wublast Title : _generic_local_wublast Usage : internal function not called directly Returns : Blast object Args : Reference to calling object and name of BLAST executable =cut sub _generic_local_wublast { my $self = shift; my $executable = shift; # Create parameter string to pass to Blast program my $param_string = $self->_setparams($executable); $param_string = " ".$self->database." ".$self->input." ".$param_string; # run Blast my $blast_report = $self->_runwublast($executable, $param_string); } =head2 _runwublast Title : _runwublast Usage : Internal function, not to be called directly Function: makes actual system call to WU-Blast program Example : Returns : Report Blast object Args : Reference to calling object, name of BLAST executable, and parameter string for executable =cut sub _runwublast { my ($self, $executable, $param_string) = @_; my ($blast_obj, $exe); if (! ($exe = $self->executable($self->p))){ $self->warn("cannot find path to $executable"); return; } my $commandstring = $exe.$param_string; $self->debug("$commandstring\n"); system($commandstring) && $self->throw("$executable call crashed: $? | $! | $commandstring\n"); # get outputfilename my $outfile = $self->o(); $blast_obj = Bio::SearchIO->new(-file => $outfile, -format => 'blast'); return $blast_obj; } =head2 _setparams Title : _setparams Usage : Internal function, not to be called directly Function: Create parameter inputs for Blast program Example : Returns : parameter string to be passed to Blast Args : Reference to calling object and name of BLAST executable =cut sub _setparams { my ($self, $executable) = @_; my ($attr, $value, @execparams); @execparams = @WUBLAST_PARAMS; # of the general params, wublast only takes outfile at # this stage (we add in program, input and database manually elsewhere) push(@execparams, 'o'); # workaround for problems with shell metacharacters [bug 2707] # simply quoting does not always work! # Fixed so Windows files are not quotemeta'd my $tmp = $self->o; $self->o(quotemeta($tmp)) if ($tmp && $^O !~ /^MSWin/); my $param_string = $self->SUPER::_setparams(-params => [@execparams], -switches => \@WUBLAST_SWITCH, -dash => 1); $self->o($tmp) if ($tmp && $^O !~ /^MSWin/); if ($self->quiet()) { $param_string .= ' 2> '.File::Spec->devnull; } return $param_string; } 1; BioPerl-1.6.923/Bio/Tools/Run/WrapperBase.pm��������������������������������������������������������000444��000765��000024�� 33456�12254227323� 20617� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Run::WrapperBase # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::WrapperBase - A Base object for wrappers around executables =head1 SYNOPSIS # do not use this object directly, it provides the following methods # for its subclasses my $errstr = $obj->error_string(); my $exe = $obj->executable(); $obj->save_tempfiles($booleanflag) my $outfile= $obj->outfile_name(); my $tempdir= $obj->tempdir(); # get a temporary dir for executing my $io = $obj->io; # Bio::Root::IO object my $cleanup= $obj->cleanup(); # remove tempfiles $obj->run({-arg1 => $value}); =head1 DESCRIPTION This is a basic module from which to build executable wrapper modules. It has some basic methods to help when implementing new modules. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Run::WrapperBase; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root); use File::Spec; use File::Path qw(); # don't import anything =head2 run Title : run Usage : $wrapper->run({ARGS HERE}); Function: Support generic running with args passed in as a hashref Returns : Depends on the implementation, status OR data Args : hashref of named arguments =cut sub run { my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 error_string Title : error_string Usage : $obj->error_string($newval) Function: Where the output from the last analysis run is stored. Returns : value of error_string Args : newvalue (optional) =cut sub error_string{ my ($self,$value) = @_; if( defined $value) { $self->{'_error_string'} = $value; } return $self->{'_error_string'} || ''; } =head2 arguments Title : arguments Usage : $obj->arguments($newval) Function: Commandline parameters Returns : value of arguments Args : newvalue (optional) =cut sub arguments { my ($self,$value) = @_; if(defined $value) { $self->{'_arguments'} = $value; } return $self->{'_arguments'} || ''; } =head2 no_param_checks Title : no_param_checks Usage : $obj->no_param_checks($newval) Function: Boolean flag as to whether or not we should trust the sanity checks for parameter values Returns : value of no_param_checks Args : newvalue (optional) =cut sub no_param_checks{ my ($self,$value) = @_; if( defined $value || ! defined $self->{'no_param_checks'} ) { $value = 0 unless defined $value; $self->{'no_param_checks'} = $value; } return $self->{'no_param_checks'}; } =head2 save_tempfiles Title : save_tempfiles Usage : $obj->save_tempfiles($newval) Function: Get/set the choice of if tempfiles in the temp dir (see tempdir()) are kept or cleaned up. Default is '0', ie. delete temp files. NB: This must be set to the desired value PRIOR to first creating a temp dir with tempdir(). Any attempt to set this after tempdir creation will get a warning. Returns : boolean Args : none to get, boolean to set =cut sub save_tempfiles{ my $self = shift; my @args = @_; if (($args[0]) && (exists ($self->{'_tmpdir'}))) { $self->warn ("Tempdir already created; setting save_tempfiles will not affect cleanup behavior."); } return $self->io->save_tempfiles(@_); } =head2 outfile_name Title : outfile_name Usage : my $outfile = $wrapper->outfile_name(); Function: Get/Set the name of the output file for this run (if you wanted to do something special) Returns : string Args : [optional] string to set value to =cut sub outfile_name{ my ($self,$nm) = @_; if( defined $nm || ! defined $self->{'_outfilename'} ) { $nm = 'mlc' unless defined $nm; $self->{'_outfilename'} = $nm; } return $self->{'_outfilename'}; } =head2 tempdir Title : tempdir Usage : my $tmpdir = $self->tempdir(); Function: Retrieve a temporary directory name (which is created) Returns : string which is the name of the temporary directory Args : none =cut sub tempdir{ my ($self) = shift; $self->{'_tmpdir'} = shift if @_; unless( $self->{'_tmpdir'} ) { $self->{'_tmpdir'} = $self->io->tempdir(CLEANUP => ! $self->save_tempfiles ); } unless( -d $self->{'_tmpdir'} ) { mkdir($self->{'_tmpdir'},0777); } return $self->{'_tmpdir'}; } =head2 cleanup Title : cleanup Usage : $wrapper->cleanup(); Function: Will cleanup the tempdir directory Returns : none Args : none =cut sub cleanup{ my ($self) = @_; $self->io->_io_cleanup(); if( defined $self->{'_tmpdir'} && -d $self->{'_tmpdir'} ) { my $verbose = ($self->verbose >= 1) ? 1 : 0; File::Path::rmtree( $self->{'_tmpdir'}, $verbose); } } =head2 io Title : io Usage : $obj->io($newval) Function: Gets a Bio::Root::IO object Returns : Bio::Root::IO object Args : none =cut sub io{ my ($self) = @_; unless( defined $self->{'io'} ) { $self->{'io'} = Bio::Root::IO->new(-verbose => $self->verbose); } return $self->{'io'}; } =head2 version Title : version Usage : $version = $wrapper->version() Function: Returns the program version (if available) Returns : string representing version of the program Args : [Optional] value to (re)set version string =cut sub version{ my ($self,@args) = @_; return; } =head2 executable Title : executable Usage : my $exe = $factory->executable(); Function: Finds the full path to the executable Returns : string representing the full path to the exe Args : [optional] name of executable to set path to [optional] boolean flag whether or not warn when exe is not found =cut sub executable { my ($self, $exe, $warn) = @_; if (defined $exe) { $self->{'_pathtoexe'} = $exe; } unless( defined $self->{'_pathtoexe'} ) { my $prog_path = $self->program_path; if ($prog_path) { if (-f $prog_path && -x $prog_path) { $self->{'_pathtoexe'} = $prog_path; } elsif ($self->program_dir) { $self->warn("executable not found in $prog_path, trying system path...") if $warn; } } unless ($self->{'_pathtoexe'}) { my $exe; if ( $exe = $self->io->exists_exe($self->program_name) ) { $self->{'_pathtoexe'} = $exe; } else { $self->warn("Cannot find executable for ".$self->program_name) if $warn; $self->{'_pathtoexe'} = undef; } } } # bail if we never found the executable unless ( defined $self->{'_pathtoexe'}) { $self->throw("Cannot find executable for ".$self->program_name . ". path=\"".$self->program_path."\""); } return $self->{'_pathtoexe'}; } =head2 program_path Title : program_path Usage : my $path = $factory->program_path(); Function: Builds path for executable Returns : string representing the full path to the exe Args : none =cut sub program_path { my ($self) = @_; my @path; push @path, $self->program_dir if $self->program_dir; push @path, $self->program_name.($^O =~ /mswin/i ? '.exe' : '') if $self->program_name; return File::Spec->catfile(@path); } =head2 program_dir Title : program_dir Usage : my $dir = $factory->program_dir(); Function: Abstract get method for dir of program. To be implemented by wrapper. Returns : string representing program directory Args : none =cut sub program_dir { my ($self) = @_; $self->throw_not_implemented(); } =head2 program_name Title : program_name Usage : my $name = $factory->program_name(); Function: Abstract get method for name of program. To be implemented by wrapper. Returns : string representing program name Args : none =cut sub program_name { my ($self) = @_; $self->throw_not_implemented(); } =head2 quiet Title : quiet Usage : $factory->quiet(1); if ($factory->quiet()) { ... } Function: Get/set the quiet state. Can be used by wrappers to control if program output is printed to the console or not. Returns : boolean Args : none to get, boolean to set =cut sub quiet { my $self = shift; if (@_) { $self->{quiet} = shift } return $self->{quiet} || 0; } =head2 _setparams() Title : _setparams Usage : $params = $self->_setparams(-params => [qw(window evalue_cutoff)]) Function: For internal use by wrapper modules to build parameter strings suitable for sending to the program being wrapped. For each method name supplied, calls the method and adds the method name (as modified by optional things) along with its value (unless a switch) to the parameter string Example : $params = $self->_setparams(-params => [qw(window evalue_cutoff)], -switches => [qw(simple large all)], -double_dash => 1, -underscore_to_dash => 1); If window() and simple() had not been previously called, but evalue_cutoff(0.5), large(1) and all(0) had been called, $params would be ' --evalue-cutoff 0.5 --large' Returns : parameter string Args : -params => [] or {} # array ref of method names to call, or hash ref where keys are method names and values are how those names should be output in the params string -switches => [] or {}# as for -params, but no value is printed for these methods -join => string # define how parameters and their values are joined, default ' '. (eg. could be '=' for param=value) -lc => boolean # lc() method names prior to output in string -dash => boolean # prefix all method names with a single dash -double_dash => bool # prefix all method names with a double dash -mixed_dash => bool # prefix single-character method names with a # single dash, and multi-character method names # with a double-dash -underscore_to_dash => boolean # convert all underscores in method names to dashes =cut sub _setparams { my ($self, @args) = @_; my ($params, $switches, $join, $lc, $d, $dd, $md, $utd) = $self->_rearrange([qw(PARAMS SWITCHES JOIN LC DASH DOUBLE_DASH MIXED_DASH UNDERSCORE_TO_DASH)], @args); $self->throw('at least one of -params or -switches is required') unless ($params || $switches); $self->throw("-dash, -double_dash and -mixed_dash are mutually exclusive") if (defined($d) + defined($dd) + defined($md) > 1); $join ||= ' '; my %params = ref($params) eq 'HASH' ? %{$params} : map { $_ => $_ } @{$params}; my %switches = ref($switches) eq 'HASH' ? %{$switches} : map { $_ => $_ } @{$switches}; my $param_string = ''; for my $hash_ref (\%params, \%switches) { while (my ($method, $method_out) = each %{$hash_ref}) { my $value = $self->$method(); next unless (defined $value); next if (exists $switches{$method} && ! $value); $method_out = lc($method_out) if $lc; my $method_length = length($method_out) if $md; $method_out = '-'.$method_out if ($d || ($md && ($method_length == 1))); $method_out = '--'.$method_out if ($dd || ($md && ($method_length > 1))); $method_out =~ s/_/-/g if $utd; if ( exists $params{$method} ) { # if value are quoted with " or ', re-quote it if ( $value =~ m{^[\'\"]+(.+)[\'\"]+$} ) { $value = '"'. $1 . '"'; } # quote values that contain spaces elsif ( $value =~ m{\s+} ) { $value = '"'. $value . '"'; } } $param_string .= ' '.$method_out.(exists $switches{$method} ? '' : $join.$value); } } return $param_string; } sub DESTROY { my $self= shift; unless ( $self->save_tempfiles ) { $self->cleanup(); } $self->SUPER::DESTROY(); } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/WrapperBase�����������������������������������������������������������000755��000765��000024�� 0�12254227332� 20071� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Run/WrapperBase/CommandExts.pm��������������������������������������������000444��000765��000024�� 115161�12254227332� 23053� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Run::WrapperBase::CommandExts # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Mark A. Jensen <maj -at- fortinbras -dot- us> # # Copyright Mark A. Jensen # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Run::WrapperBase::CommandExts - Extensions to WrapperBase for handling programs with commands *ALPHA* =head1 SYNOPSIS Devs, see L</DEVELOPER INTERFACE>. Users, see L</USER INTERFACE>. =head1 DESCRIPTION This is a developer-focused experimental module. The main idea is to extend L<Bio::Tools::Run::WrapperBase> to make it relatively easy to create run wrappers around I<suites> of related programs, like C<samtools> or C<blast+>. Some definitions: =over =item * program The program is the command-line frontend application. C<samtools>, for example, is run from the command line as follows: $ samtools view -bS in.bam > out.sam $ samtools faidx =item * command The command is the specific component of a suite run by executing the program. In the example above, C<view> and C<faidx> are commands. =item * command prefix The command prefix is an abbreviation of the command name used internally by C<CommandExts> method, and sometimes by the user of the factory for specifying command line parameters to subcommands of composite commands. =item * composite command A composite command is a pipeline or script representing a series of separate executions of different commands. Composite commands can be specified by configuring C<CommandExts> appropriately; the composite command can be run by the user from a factory in the same way as ordinary commands. =item * options, parameters, switches and filespecs An option is any command-line option; i.e., a specification set off by a command-line by a specifier (like C<-v> or C<--outfile>). Parameters are command-line options that accept a value (C<-title mydb>); switches are boolean flags (C<--no-filter>). Filespecs are barewords at the end of the command line that usually indicate input or output files. In this module, this includes files that capture STDIN, STDOUT, or STDERR via redirection. =item * pseudo-program A "pseudo-program" is a way to refer to a collection of related applications that are run independently from the command line, rather than via a frontend program. The C<blast+> suite of programs is an example: C<blastn>, C<makeblastdb>, etc. C<CommandExts> can be configured to create a single factory for a suite of related, independent programs that treats each independent program as a "pseudo-program" command. =back This module essentially adds the non-assembler-specific wrapper machinery of fangly's L<Bio::Tools::Run::AssemblerBase> to the L<Bio::Tools::Run::WrapperBase> namespace, adding the general command-handling capability of L<Bio::Tools::Run::BWA>. It creates run factories that are automatically Bio::ParameterBaseI compliant, meaning that C<available_parameters()>, C<set_parameters()>, C<get_parameters>, C<reset_parameters()>, and C<parameters_changed()> are available. =head1 DEVELOPER INTERFACE C<CommandExts> is currently set up to read particular package globals which define the program, the commands available, command-line options for those commands, and human-readable aliases for those options. The easiest way to use C<CommandExts> is probably to create two modules: Bio::Tools::Run::YourRunPkg Bio::Tools::Run::YourRunPkg::Config The package globals should be defined in the C<Config> module, and the run package itself should begin with the following mantra: use YourRunPkg::Config; use Bio::Tools::Run::WrapperBase; use Bio::Tools::Run::WrapperBase::CommandExts; sub new { my $class = shift; my @args = @_; my $self = $class->SUPER::new(@args); ... return $self; } The following globals can/should be defined in the C<Config> module: $program_name $program_dir $use_dash $join @program_commands %command_prefixes @program_params @program_switches %param_translation %composite_commands %command_files See L</Config Globals> for detailed descriptions. The work of creating a run wrapper with C<CommandExts> lies mainly in setting up the globals. The key methods for the developer interface are: =over =item * program_dir($path_to_programs) Set this to point the factory to the executables. =item * _run(@file_args) Runs an instantiated factory with the given file args. Use in the C<run()> method override. =item * _create_factory_set() Returns a hash of instantiated factories for each true command from a composite command factory. The hash keys are the true command names, so you could do $cmds = $composite_fac->_create_factory_set; for (@true_commands) { $cmds->{$_}->_run(@file_args); } =item * executables($cmd,[$fullpath]) For pseudo-programs, this gets/sets the full path to the executable of the true program corresponding to the command C<$cmd>. =back =head2 Implementing Composite Commands =head2 Implementing Pseudo-programs To indicate that a package wraps disparate programs under a single pseudo program, use an asterisk before the program name: package Bio::Tools::Run::YourPkg::Config; ... our $program_name = '*blast+'; and C<_run> will know what to do. Specify the rest of the globals as if the desired programs were commands. Use the basename of the programs for the command names. If all the programs can be found in a single directory, just specify that directory in C<program_dir()>. If not, use C<executables()> to set the paths to each program explicitly: foreach (keys %cmdpaths) { $self->executables($_, $cmdpaths{$_}); } =head2 Config Globals Here is an example config file. Further details in prose are below. package Dummy::Config; use strict; use warnings; no warnings qw(qw); use Exporter; our (@ISA, @EXPORT, @EXPORT_OK); push @ISA, 'Exporter'; @EXPORT = qw( $program_name $program_dir $use_dash $join @program_commands %command_prefixes @program_params @program_switches %param_translation %command_files %composite_commands ); our $program_name = '*flurb'; our $program_dir = 'C:\cygwin\usr\local\bin'; our $use_dash = 'mixed'; our $join = ' '; our @program_commands = qw( rpsblast cat goob blorb multiglob ); our %command_prefixes = ( blastp => 'blp', tblastn => 'tbn', goob => 'g', blorb => 'b', multiglob => 'm' ); our @program_params = qw( command g|narf g|schlurb b|scroob b|frelb m|trud ); our @program_switches = qw( g|freen b|klep ); our %param_translation = ( 'g|narf' => 'n', 'g|schlurb' => 'schlurb', 'g|freen' => 'f', 'b|scroob' => 's', 'b|frelb' => 'frelb' ); our %command_files = ( 'goob' => [qw( fas faq )], ); our %composite_commands = ( 'multiglob' => [qw( blorb goob )] ); 1; C<$use_dash> can be one of C<single>, C<double>, or C<mixed>. See L<Bio::Tools::Run::WrapperBase>. There is a syntax for the C<%command_files> specification. The token matching C<[a-zA-Z0-9_]+> in each element of each arrayref becomes the named filespec parameter for the C<_run()> method in the wrapper class. Additional symbols surrounding this token indicate how this argument should be handled. Some examples: >out : stdout is redirected into the file specified by (..., -out => $file,... ) <in : stdin is accepted from the file specified by (..., -in => $file,... ) 2>log : stderr is redirected into the file specified by (..., -log => $file,... ) #opt : this filespec argument is optional (no throw if -opt => $option is missing) 2>#log: if -log is not specified in the arguments, the stderr() method will capture stderr *lst : this filespec can take multiple arguments, specify using an arrayref (..., -lst => [$file1, $file2], ...) *#lst : an optional list The tokens above are examples; they can be anything matching the above regexp. =head1 USER INTERFACE Using a wrapper created with C<Bio::Tools::Run::WrapperBase::CommandExts>: =over =item * Getting a list of available commands, parameters, and filespecs: To get a list of commands, simply: @commands = Bio::Tools::Run::ThePkg->available_commands; The wrapper will generally have human-readable aliases for each of the command-line options for the wrapped program and commands. To obtain a list of the parameters and switches available for a particular command, do $factory = Bio::Tools::Run::ThePkg->new( -command => 'glurb' ); @params = $factory->available_parameters('params'); @switches = $factory->available_parameters('switches'); @filespec = $factory->available_parameters('filespec'); @filespec = $factory->filespec; # alias =item * Create factories The factory is a handle on the program and command you wish to run. Create a factory using C<new> to set command-line parameters: $factory = Bio::Tools::Run::ThePkg->new( -command => 'glurb', -freen => 1, -furschlugginer => 'vreeble' ); A shorthand for this is: $factory = Bio::Tools::Run::ThePkg->new_glurb( -freen => 1, -furschlugginer => 'vreeble' ); =item * Running programs To run the program, use the C<run> method, providing filespecs as arguments $factory = Bio::Tools::Run::ThePkg->new_assemble( -min_qual => 63 ); $factory->run( -faq1 => 'read1.fq', -faq2 => 'read2.fq', -ref => 'refseq.fas', -out => 'new.sam' ); # do another $factory->run( -faq1 => 'read-old1.fq', -faq2 => 'read-old2.fq', -ref => 'refseq.fas', -out => 'old.sam' ); Messages on STDOUT and STDERR are dumped into their respective attributes: $stdout = $factory->stdout; $stderr = $factory->stderr; unless STDOUT and/or STDERR are part of the named files in the filespec. =item * Setting/getting/resetting/polling parameters. A C<CommandExts>-based factory is always L<Bio::ParameterBaseI> compliant. That means that you may set, get, and reset parameters using C<set_parameters()>, C<get_parameters()>, and C<reset_parameters>. You can ask whether parameters have changed since they were last accessed by using the predicate C<parameters_changed>. See L<Bio::ParameterBaseI> for more details. Once set, parameters become attributes of the factory. Thus, you can get their values as follows: if ($factory->freen) { $furs = $factory->furshlugginer; #... } =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: L<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mark A. Jensen Email maj -at- fortinbras -dot- us Describe contact details here =head1 CONTRIBUTORS Dan Kortschak ( dan -dot- kortschak -at- adelaide -dot- edu -dot- au ) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Run::WrapperBase; # need these methods in WrapperBase/maj use strict; use warnings; no warnings qw(redefine); use Bio::Root::Root; use File::Spec; use IPC::Run; use base qw(Bio::Root::Root Bio::ParameterBaseI); our $AUTOLOAD; =head2 new() Title : new Usage : Function: constructor for WrapperBase::CommandExts ; correctly binds configuration variables to the WrapperBase object Returns : Bio::Tools::Run::WrapperBase object with command extensions Args : Note : this method subsumes the old _register_program_commands and _set_program_options, leaving out the assembler-specific parms ($qual_param and out_type()) =cut sub new { my ($class, @args) = @_; my $self = bless ({}, $class); # pull in *copies* of the Config variables from the caller namespace: my ($pkg, @goob) = caller(); my ($commands, $prefixes, $params, $switches, $translation, $use_dash, $join, $name, $dir, $composite_commands, $files); for (qw( @program_commands %command_prefixes @program_params @program_switches %param_translation $use_dash $join $program_name $program_dir %composite_commands %command_files ) ) { my ($sigil, $var) = m/(.)(.*)/; my $qualvar = "${sigil}${pkg}::${var}"; for ($sigil) { /\@/ && do { $qualvar = "\[$qualvar\]" }; /\%/ && do { $qualvar = "\{$qualvar\}" }; } my $locvar = "\$${var}"; $locvar =~ s/program_|command_|param_//g; eval "$locvar = $qualvar"; } # set up the info registry hash my %registry; if ($composite_commands) { $self->_register_composite_commands($composite_commands, $params, $switches, $prefixes); } @registry{qw( _commands _prefixes _files _params _switches _translation _composite_commands )} = ($commands, $prefixes, $files, $params, $switches, $translation, $composite_commands); $self->{_options} = \%registry; if (not defined $use_dash) { $self->{'_options'}->{'_dash'} = 1; } else { $self->{'_options'}->{'_dash'} = $use_dash; } if (not defined $join) { $self->{'_options'}->{'_join'} = ' '; } else { $self->{'_options'}->{'_join'} = $join; } if ($name =~ /^\*/) { $self->is_pseudo(1); $name =~ s/^\*//; } $self->program_name($name) if not defined $self->program_name(); $self->program_dir($dir) if not defined $self->program_dir(); $self->set_parameters(@args); $self->parameters_changed(1); # set on instantiation, per Bio::ParameterBaseI return $self; } =head2 program_name Title : program_name Usage : $factory->program_name($name) Function: get/set the executable name Returns: string Args : string =cut sub program_name { my ($self, $val) = @_; $self->{'_program_name'} = $val if $val; return $self->{'_program_name'}; } =head2 program_dir Title : program_dir Usage : $factory->program_dir($dir) Function: get/set the program dir Returns: string Args : string =cut sub program_dir { my ($self, $val) = @_; $self->{'_program_dir'} = $val if $val; return $self->{'_program_dir'}; } =head2 _register_program_commands() Title : _register_program_commands Usage : $factory->_register_program_commands( \@commands, \%prefixes ) Function: Register the commands a program accepts (for programs that act as frontends for a set of commands, each command having its own set of params/switches) Returns : true on success Args : arrayref to a list of commands (scalar strings), hashref to a translation table of the form { $prefix1 => $command1, ... } [optional] Note : To implement a program with this kind of calling structure, include a parameter called 'command' in the @program_params global Note : The translation table is used to associate parameters and switches specified in _set_program_options with the correct program command. In the globals @program_params and @program_switches, specify elements as 'prefix1|param' and 'prefix1|switch', etc. =cut =head2 _set_program_options Title : _set_program_options Usage : $factory->_set_program_options( \@ args ); Function: Register the parameters and flags that an assembler takes. Returns : 1 for success Args : - arguments passed by the user - parameters that the program accepts, optional (default: none) - switches that the program accepts, optional (default: none) - parameter translation, optional (default: no translation occurs) - dash option for the program parameters, [1|single|double|mixed], optional (default: yes, use single dashes only) - join, optional (default: ' ') =cut =head2 _translate_params Title : _translate_params Usage : @options = $assembler->_translate_params( ); Function: Translate the Bioperl arguments into the arguments to pass to the program on the command line Returns : Arrayref of arguments Args : none =cut sub _translate_params { my ($self) = @_; # Get option string my ($params, $switches, $join, $dash, $translat) = @{$self->{_options}}{qw(_params _switches _join _dash _translation)}; # access the multiple dash choices of _setparams... my @dash_args; $dash ||= 1; # default as advertised for ($dash) { $_ eq '1' && do { @dash_args = ( -dash => 1 ); last; }; /^s/ && do { #single dash only @dash_args = ( -dash => 1); last; }; /^d/ && do { # double dash only @dash_args = ( -double_dash => 1); last; }; /^m/ && do { # mixed dash: one-letter opts get -, # long opts get -- @dash_args = ( -mixed_dash => 1); last; }; do { $self->warn( "Dash spec '$dash' not recognized; using 'single'" ); @dash_args = ( -dash => 1 ); }; } my $options = $self->_setparams( -params => $params, -switches => $switches, -join => $join, @dash_args ); # Translate options my @options = split(/(\s|$join)/, $options); for (my $i = 0; $i < scalar @options; $i++) { my ($prefix, $name) = ( $options[$i] =~ m/^(-{0,2})(.+)$/ ); if (defined $name) { if ($name =~ /command/i) { $name = $options[$i+2]; # get the command splice @options, $i, 4; $i--; # don't add the command if this is a pseudo-program unshift @options, $name unless ($self->is_pseudo); # put command first } elsif (defined $$translat{$name}) { $options[$i] = $prefix.$$translat{$name}; } } else { splice @options, $i, 1; $i--; } } $options = join('', @options); # this is a kludge for mixed options: the reason mixed doesn't # work right on the pass through _setparams is that the # *aliases* and not the actual params are passed to it. # here we just rejigger the dashes if ($dash =~ /^m/) { $options =~ s/--([a-z0-9](?:\s|$))/-$1/gi; } # Now arrayify the options @options = split(' ', $options); return \@options; } =head2 executable() Title : executable Usage : Function: find the full path to the main executable, or to the command executable for pseudo-programs Returns : full path, if found Args : [optional] explicit path to the executable (will set the appropriate command exec if applicable) [optional] boolean flag whether or not to warn when exe no found Note : overrides WrapperBase.pm =cut sub executable { my $self = shift; my ($exe, $warn) = @_; if ($self->is_pseudo) { return $self->{_pathtoexe} = $self->executables($self->command,$exe); } # otherwise # setter if (defined $exe) { $self->throw("binary '$exe' does not exist") unless -e $exe; $self->throw("'$exe' is not executable") unless -x $exe; return $self->{_pathtoexe} = $exe; } # getter return $self->{_pathtoexe} if defined $self->{_pathstoexe}; # finder return $self->{_pathtoexe} = $self->_find_executable($exe, $warn); } =head2 executables() Title : executables Usage : Function: find the full path to a command's executable Returns : full path (scalar string) Args : command (scalar string), [optional] explicit path to this command exe [optional] boolean flag whether or not to warn when exe no found =cut sub executables { my $self = shift; my ($cmd, $exe, $warn) = @_; # for now, barf if this is not a pseudo program $self->throw("This wrapper represents a single program with commands, not multiple programs; can't use executables()") unless $self->is_pseudo; $self->throw("Command name required at arg 1") unless defined $cmd; $self->throw("The desired executable '$cmd' is not registered as a command") unless grep /^$cmd$/, @{$self->{_options}->{_commands}}; # setter if (defined $exe) { $self->throw("binary '$exe' does not exist") unless -e $exe; $self->throw("'$exe' is not executable") unless -x $exe; $self->{_pathstoexe} = {} unless defined $self->{_pathstoexe}; return $self->{_pathstoexe}->{$cmd} = $exe; } # getter return $self->{_pathstoexe}->{$cmd} if defined $self->{_pathstoexe}->{$cmd}; $exe ||= $cmd; # finder return $self->{_pathstoexe}->{$cmd} = $self->_find_executable($exe, $warn); } =head2 _find_executable() Title : _find_executable Usage : my $exe_path = $fac->_find_executable($exe, $warn); Function: find the full path to a named executable, Returns : full path, if found Args : name of executable to find [optional] boolean flag whether or not to warn when exe no found Note : differs from executable and executables in not setting any object attributes =cut sub _find_executable { my $self = shift; my ($exe, $warn) = @_; if ($self->is_pseudo && !$exe) { if (!$self->command) { # this throw probably appropriate # the rest are now warns if $warn.../maj $self->throw( "The ".__PACKAGE__." wrapper represents several different programs;". "arg1 to _find_executable must be specified explicitly,". "or the command() attribute set"); } else { $exe = $self->command; } } $exe ||= $self->program_path; my $path; if ($self->program_dir) { $path = File::Spec->catfile($self->program_dir, $exe); } else { $path = $exe; $self->warn('Program directory not specified; use program_dir($path).') if $warn; } # use provided info - we are allowed to follow symlinks, but refuse directories map { return $path.$_ if ( -x $path.$_ && !(-d $path.$_) ) } ('', '.exe') if defined $path; # couldn't get path to executable from provided info, so use system path $path = $path ? " in $path" : undef; $self->warn("Executable $exe not found$path, trying system path...") if $warn; if ($path = $self->io->exists_exe($exe)) { return $path; } else { $self->warn("Cannot find executable for program '".($self->is_pseudo ? $self->command : $self->program_name)."'") if $warn; return; } } =head2 _register_composite_commands() Title : _register_composite_commands Usage : Function: adds subcomand params and switches for composite commands Returns : true on success Args : \%composite_commands, \@program_params, \@program_switches =cut sub _register_composite_commands { my $self = shift; my ($composite_commands, $program_params, $program_switches, $command_prefixes) = @_; my @sub_params; my @sub_switches; foreach my $cmd (keys %$composite_commands) { my $pfx = $command_prefixes->{$cmd} || $cmd; foreach my $subcmd ( @{$$composite_commands{$cmd}} ) { my $spfx = $command_prefixes->{$subcmd} || $subcmd; my @sub_program_params = grep /^$spfx\|/, @$program_params; my @sub_program_switches = grep /^$spfx\|/, @$program_switches; for (@sub_program_params) { m/^$spfx\|(.*)/; push @sub_params, "$pfx\|${spfx}_".$1; } for (@sub_program_switches) { m/^$spfx\|(.*)/; push @sub_switches, "$pfx\|${spfx}_".$1; } } } push @$program_params, @sub_params; push @$program_switches, @sub_switches; # translations for subcmd params/switches not necessary return 1; } =head2 _create_factory_set() Title : _create_factory_set Usage : @facs = $self->_create_factory_set Function: instantiate a set of individual command factories for a given composite command Factories will have the correct parameter fields set for their own subcommand Returns : hash of factories: ( $subcmd_prefix => $subcmd_factory, ... ) Args : none =cut sub _create_factory_set { my $self = shift; $self->throw('command not set') unless $self->command; my $cmd = $self->command; $self->throw('_create_factory_set only works on composite commands') unless grep /^$cmd$/, keys %{$self->{_options}->{_composite_commands}}; my %ret; my $class = ref $self; my $subargs_hash = $self->_collate_subcmd_args($cmd); for (keys %$subargs_hash) { $ret{$_} = $class->new( -command => $_, @{$$subargs_hash{$_}} ); } return %ret; } =head2 _collate_subcmd_args() Title : _collate_subcmd_args Usage : $args_hash = $self->_collate_subcmd_args Function: collate parameters and switches into command-specific arg lists for passing to new() Returns : hash of named argument lists Args : [optional] composite cmd prefix (scalar string) [default is 'run'] =cut sub _collate_subcmd_args { my $self = shift; my $cmd = shift; my %ret; # default command is 'run' $cmd ||= 'run'; return unless $self->{'_options'}->{'_composite_commands'}; return unless $self->{'_options'}->{'_composite_commands'}->{$cmd}; my @subcmds = @{$self->{'_options'}->{'_composite_commands'}->{$cmd}}; my $cur_options = $self->{'_options'}; # collate foreach my $subcmd (@subcmds) { # find the composite cmd form of the argument in # the current params and switches # e.g., map_max_mismatches my $pfx = $self->{_options}->{_prefixes}->{$subcmd} || $subcmd; my @params = grep /^${pfx}_/, @{$$cur_options{'_params'}}; my @switches = grep /^${pfx}_/, @{$$cur_options{'_switches'}}; $ret{$subcmd} = []; # create an argument list suitable for passing to new() of # the subcommand factory... foreach my $opt (@params, @switches) { my $subopt = $opt; $subopt =~ s/^${pfx}_//; push(@{$ret{$subcmd}}, '-'.$subopt => $self->$opt) if defined $self->$opt; } } return \%ret; } =head2 _run Title : _run Usage : $fac->_run( @file_args ) Function: Run a command as specified during object contruction Returns : true on success Args : a specification of the files to operate on according to the filespec =cut sub _run { my ($self, @args) = @_; # _translate_params will provide an array of command/parameters/switches # -- these are set at object construction # to set up the run, need to add the files to the call # -- provide these as arguments to this function my $cmd = $self->command if $self->can('command'); my $opts = $self->{_options}; my %args; $self->throw("No command specified for the object") unless $cmd; # setup files necessary for this command my $filespec = $opts->{'_files'}->{$cmd}; my @switches; my ($in, $out, $err); # some applications rely completely on switches if (defined $filespec && @$filespec) { # parse args based on filespec # require named args $self->throw("Named args are required") unless !(@args % 2); s/^-// for @args; %args = @args; # validate my @req = map { my $s = $_; $s =~ s/^-.*\|//; $s =~ s/^[012]?[<>]//; $s =~ s/[^a-zA-Z0-9_]//g; $s } grep !/[#]/, @$filespec; !defined($args{$_}) && $self->throw("Required filearg '$_' not specified") for @req; # set up redirects and file switches for (@$filespec) { m/^1?>#?(.*)/ && do { defined($args{$1}) && ( open($out,">", $args{$1}) or $self->throw("Open for write error : $!")); next; }; m/^2>#?(.*)/ && do { defined($args{$1}) && (open($err, ">", $args{$1}) or $self->throw("Open for write error : $!")); next; }; m/^<#?(.*)/ && do { defined($args{$1}) && (open($in, "<", $args{$1}) or $self->throw("Open for read error : $!")); next; }; if (m/^-(.*)\|/) { push @switches, $self->_dash_switch($1); } else { push @switches, undef; } } } my $dum; $in || ($in = \$dum); $out || ($out = \$self->{'stdout'}); $err || ($err = \$self->{'stderr'}); # Get program executable my $exe = $self->executable; $self->throw("Can't find executable for '".($self->is_pseudo ? $self->command : $self->program_name)."'; can't continue") unless $exe; # Get command-line options my $options = $self->_translate_params(); # Get file specs sans redirects in correct order my @specs = map { my $s = $_; $s =~ s/^-.*\|//; $s =~ s/[^a-zA-Z0-9_]//g; $s } grep !/[<>]/, @$filespec; my @files = @args{@specs}; # expand arrayrefs my $l = $#files; # Note: below code block may be brittle, see link on this: # http://lists.open-bio.org/pipermail/bioperl-l/2010-June/033439.html for (0..$l) { if (ref($files[$_]) eq 'ARRAY') { splice(@switches, $_, 1, ($switches[$_]) x @{$files[$_]}); splice(@files, $_, 1, @{$files[$_]}); } } @files = map { my $s = shift @switches; defined $_ ? ($s, $_): () } @files; @files = map { defined $_ ? $_ : () } @files; # squish undefs my @ipc_args = ( $exe, @$options, @files ); $self->{_last_execution} = join( $self->{'_options'}->{'_join'}, @ipc_args ); eval { IPC::Run::run(\@ipc_args, $in, $out, $err) or die ("There was a problem running $exe : ".$$err); }; if ($@) { $self->throw("$exe call crashed: $@") unless $self->no_throw_on_crash; return 0; } return 1; } =head2 no_throw_on_crash() Title : no_throw_on_crash Usage : Function: prevent throw on execution error Returns : Args : [optional] boolean =cut sub no_throw_on_crash { my $self = shift; return $self->{'_no_throw'} = shift if @_; return $self->{'_no_throw'}; } =head2 last_execution() Title : last_execution Usage : Function: return the last executed command with options Returns : string of command line sent to IPC::Run Args : =cut sub last_execution { my $self = shift; return $self->{'_last_execution'}; } =head2 _dash_switch() Title : _dash_switch Usage : $version = $fac->_dash_switch( $switch ) Function: Returns an appropriately dashed switch for the executable Args : A string containing a switch without dashes Returns : string containing an appropriately dashed switch for the current executable =cut sub _dash_switch { my ($self, $switch) = @_; my $dash = $self->{'_options'}->{'_dash'}; for ($dash) { $_ eq '1' && do { $switch = '-'.$switch; last; }; /^s/ && do { #single dash only $switch = '-'.$switch; last; }; /^d/ && do { # double dash only $switch = '--'.$switch; last; }; /^m/ && do { # mixed dash: one-letter opts get -, $switch = '-'.$switch; $switch =~ s/^(-[a-z0-9](?:\w+))$/-$1/i; last; }; do { $self->warn( "Dash spec '$dash' not recognized; using 'single'" ); $switch = '-'.$switch; }; } return $switch; } =head2 stdout() Title : stdout Usage : $fac->stdout() Function: store the output from STDOUT for the run, if no file specified in _run arguments Example : Returns : scalar string Args : on set, new value (a scalar or undef, optional) =cut sub stdout { my $self = shift; return $self->{'stdout'} = shift if @_; return $self->{'stdout'}; } =head2 stderr() Title : stderr Usage : $fac->stderr() Function: store the output from STDERR for the run, if no file is specified in _run arguments Example : Returns : scalar string Args : on set, new value (a scalar or undef, optional) =cut sub stderr { my $self = shift; return $self->{'stderr'} = shift if @_; return $self->{'stderr'}; } =head2 is_pseudo() Title : is_pseudo Usage : $obj->is_pseudo($newval) Function: returns true if this factory represents a pseudo-program Example : Returns : value of is_pseudo (boolean) Args : on set, new value (a scalar or undef, optional) =cut sub is_pseudo { my $self = shift; return $self->{'is_pseudo'} = shift if @_; return $self->{'is_pseudo'}; } =head2 AUTOLOAD AUTOLOAD permits $class->new_yourcommand(@args); as an alias for $class->new( -command => 'yourcommand', @args ); =cut sub AUTOLOAD { my $class = shift; my $tok = $AUTOLOAD; my @args = @_; $tok =~ s/.*:://; unless ($tok =~ /^new_/) { $class->throw("Can't locate object method '$tok' via package '".ref($class)?ref($class):$class); } my ($cmd) = $tok =~ m/new_(.*)/; return $class->new( -command => $cmd, @args ); } =head1 Bio:ParameterBaseI compliance =head2 set_parameters() Title : set_parameters Usage : $pobj->set_parameters(%params); Function: sets the parameters listed in the hash or array Returns : true on success Args : [optional] hash or array of parameter/values. =cut sub set_parameters { my ($self, @args) = @_; # currently stored stuff my $opts = $self->{'_options'}; my $params = $opts->{'_params'}; my $switches = $opts->{'_switches'}; my $translation = $opts->{'_translation'}; my $use_dash = $opts->{'_dash'}; my $join = $opts->{'_join'}; unless (($self->can('command') && $self->command) || (grep /command/, @args)) { push @args, '-command', 'run'; } my %args = @args; my $cmd = $args{'-command'} || $args{'command'} || ($self->can('command') && $self->command); if ($cmd) { my (@p,@s, %x); $self->warn('Command present, but no commands registered') unless $self->{'_options'}->{'_commands'}; $self->throw("Command '$cmd' not registered") unless grep /^$cmd$/, @{$self->{'_options'}->{'_commands'}}; $cmd = $self->{_options}->{_prefixes}->{$cmd} || $cmd; @p = (grep(!/^.*?\|/, @$params), grep(/^${cmd}\|/, @$params)); @s = (grep(!/^.*?\|/, @$switches), grep(/^${cmd}\|/, @$switches)); s/.*?\|// for @p; s/.*?\|// for @s; @x{@p, @s} = @{$translation}{ grep( !/^.*?\|/, @$params, @$switches), grep(/^${cmd}\|/, @$params, @$switches) }; $opts->{_translation} = $translation = \%x; $opts->{_params} = $params = \@p; $opts->{_switches} = $switches = \@s; } $self->_set_from_args( \@args, -methods => [ @$params, @$switches, 'program_name', 'program_dir', 'out_type' ], -create => 1, # when our parms are accessed, signal parameters are unchanged for # future reads (until set_parameters is called) -code => ' my $self = shift; $self->parameters_changed(0); return $self->{\'_\'.$method} = shift if @_; return $self->{\'_\'.$method};' ); # the question is, are previously-set parameters left alone when # not specified in @args? $self->parameters_changed(1); return 1; } =head2 reset_parameters() Title : reset_parameters Usage : resets values Function: resets parameters to either undef or value in passed hash Returns : none Args : [optional] hash of parameter-value pairs =cut sub reset_parameters { my ($self, @args) = @_; my @reset_args; # currently stored stuff my $opts = $self->{'_options'}; my $params = $opts->{'_params'}; my $switches = $opts->{'_switches'}; my $translation = $opts->{'_translation'}; my $qual_param = $opts->{'_qual_param'}; my $use_dash = $opts->{'_dash'}; my $join = $opts->{'_join'}; # handle command name my %args = @args; my $cmd = $args{'-command'} || $args{'command'} || $self->command; $args{'command'} = $cmd; delete $args{'-command'}; @args = %args; # don't like this, b/c _set_program_args will create a bunch of # accessors with undef values, but oh well for now /maj for my $p (@$params) { push(@reset_args, $p => undef) unless grep /^[-]?$p$/, @args; } for my $s (@$switches) { push(@reset_args, $s => undef) unless grep /^[-]?$s$/, @args; } push @args, @reset_args; $self->set_parameters(@args); $self->parameters_changed(1); } =head2 parameters_changed() Title : parameters_changed Usage : if ($pobj->parameters_changed) {...} Function: Returns boolean true (1) if parameters have changed Returns : Boolean (0 or 1) Args : [optional] Boolean =cut sub parameters_changed { my $self = shift; return $self->{'_parameters_changed'} = shift if @_; return $self->{'_parameters_changed'}; } =head2 available_parameters() Title : available_parameters Usage : @params = $pobj->available_parameters() Function: Returns a list of the available parameters Returns : Array of parameters Args : 'params' for settable program parameters 'switches' for boolean program switches default: all =cut sub available_parameters { my $self = shift; my $subset = shift; my $opts = $self->{'_options'}; my @ret; for ($subset) { (!defined || /^a/) && do { @ret = (@{$opts->{'_params'}}, @{$opts->{'_switches'}}); last; }; m/^p/i && do { @ret = @{$opts->{'_params'}}; last; }; m/^s/i && do { @ret = @{$opts->{'_switches'}}; last; }; m/^c/i && do { @ret = @{$opts->{'_commands'}}; last; }; m/^f/i && do { # get file spec return @{$opts->{'_files'}->{$self->command}}; }; do { #fail $self->throw("available_parameters: unrecognized subset"); }; } return @ret; } sub available_commands { shift->available_parameters('commands') } sub filespec { shift->available_parameters('filespec') } =head2 get_parameters() Title : get_parameters Usage : %params = $pobj->get_parameters; Function: Returns list of key-value pairs of parameter => value Returns : List of key-value pairs Args : [optional] A string is allowed if subsets are wanted or (if a parameter subset is default) 'all' to return all parameters =cut sub get_parameters { my $self = shift; my $subset = shift; $subset ||= 'all'; my @ret; my $opts = $self->{'_options'}; for ($subset) { m/^p/i && do { #params only for (@{$opts->{'_params'}}) { push(@ret, $_, $self->$_) if $self->can($_) && defined $self->$_; } last; }; m/^s/i && do { #switches only for (@{$opts->{'_switches'}}) { push(@ret, $_, $self->$_) if $self->can($_) && defined $self->$_; } last; }; m/^a/i && do { # all for ((@{$opts->{'_params'}},@{$opts->{'_switches'}})) { push(@ret, $_, $self->$_) if $self->can($_) && defined $self->$_; } last; }; do { $self->throw("get_parameters: unrecognized subset"); }; } return @ret; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SeqPattern����������������������������������������������������������������000755��000765��000024�� 0�12254227330� 17176� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SeqPattern/Backtranslate.pm�����������������������������������������������000444��000765��000024�� 53566�12254227330� 22506� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������package Bio::Tools::SeqPattern::Backtranslate; use strict; use warnings; use base qw(Bio::Root::Root); use base qw(Exporter); =head1 NAME Bio::Tools::SeqPattern::Backtranslate =head1 DESCRIPTION This module should not be used directly. It provides helper methods to Bio::Tools::SeqPattern to reverse translate protein patterns. =cut use Bio::Seq; use Bio::Tools::CodonTable; use List::MoreUtils qw(uniq); use Carp qw(croak); our @EXPORT_OK = qw(_reverse_translate_motif); our @EXPORT = @EXPORT_OK; sub _reverse_translate_motif { # Main subroutine. It takes a Profam-like motif and returns its # reverse translation using degenerate codons. # Steps: # 1. Tokenize, then parse tokens. # 2. Reverse translate each token type. # 3. Join tokens in original order. Return the resulting string. my $motif = shift; $motif =~ s/\./X/g; $motif = uc $motif; ### 1. Tokenize, parse the motif. my ( $ordered, $classified ) = _parse_motif($motif); ### 2. Reverse translate each token type. # Reverse translate the plain (unambiguous) tokens. my $ct = Bio::Tools::CodonTable->new; foreach my $seq ( @{ $classified->{plain} } ) { my $seqO = Bio::Seq->new( -seq => $$seq, -alphabet => 'protein' ); $$seq = $ct->reverse_translate_all($seqO); } # Reverse translate the ambiguous tokens. foreach my $token ( @{ $classified->{ambiguous} } ) { my ($aas) = $$token =~ m(([A-Za-z\.]+)); my @codons_to_contract; foreach my $residue ( split '', $aas ) { push @codons_to_contract, $ct->revtranslate($residue); } my $ambiguous_codon = _contract_codons(@codons_to_contract); $$token = $ambiguous_codon; } # Reverse translate the negated residues. foreach my $token ( @{ $classified->{negated} } ) { my ($aas) = $$token =~ m(([A-Za-z\.]+)); my $ambiguous_codon = _negated_aas_to_codon($aas); $$token = $ambiguous_codon; } ### 3. Join the profile back from its tokens. return join '', map {$$_} @{$ordered}; } sub _parse_motif { # Profam-like motif parser. It takes the pattern as a string, and # returns two data structures that contain the tokens, organized # by order of appearance in the pattern (first return value) and by # category (second return value). my $motif = shift; my $parser = _tokenize_motif($motif); my ( %tokens, @tokens ); while ( my $token = $parser->() ) { croak ("Unknown syntax token: <", $token->[1], ">") if ( $token->[0] eq 'UNKNOWN' ); push @{ $tokens{ $token->[0] } }, \$token->[1]; push @tokens, \$token->[1]; } return ( \@tokens, \%tokens ); } sub _tokenize_motif { # Return a tokenizer iterator that sequentially recognizes and # returns each token in the input pattern. # Examples of each token type: # ambiguous: a position with more than one possible residue. # eg. [ALEP] # negated: a position in which some residues are excluded. # eg. [^WY] # plain: a common sequence of residues. One position, one residue. # eg. MAAEIK # open_par, close_par: tags surrounding a motif that is repeated # a certain number of times. # eg. (...){3} my $target = shift; return sub { return [ 'ambiguous', $1 ] if $target =~ /\G (\[[A-Za-z\.]+\]) /gcx; return [ 'negated', $1 ] if $target =~ /\G (\[\^[A-Za-z\.]+\]) /gcx; return [ 'plain', $1 ] if $target =~ /\G ([A-Za-z\.]+) /gcx; return [ 'open_par', $1 ] if $target =~ /\G (\() /gcx; return [ 'close_par', $1 ] if $target =~ /\G (\)[\{\d+[,\d+]*\}]*) /gcx; return [ 'UNKNOWN', $1 ] if $target =~ /\G (.) /gcx; return; }; } sub _contract_codons { # Take a list of codons, return an ambiguous codon. my @codons = map { uc $_ } @_; my @by_letter = ( [], [], [], ); my $ambiguous_codon; foreach my $codon (@codons) { my @letters = split '', $codon; for my $i ( 0 .. 2 ) { push @{ $by_letter[$i] }, $letters[$i]; } } for my $i ( 0 .. 2 ) { $ambiguous_codon .= _convert( 'dna', _uniq_string( @{ $by_letter[$i] } ) ); } return $ambiguous_codon; } sub _expand_codon { # Given a degenerate codon, return a list with all its # constituents. Takes a three-letter string (codon) as # input, returns a list with three-letter scalars. my $codon = shift; die "Wrong codon length!\n" if length $codon != 3; my ( @codons, @return_bases ); my @orig_bases = split '', $codon; for my $i ( 0 .. 2 ) { # from each redundant base, create a list with all their # components (e.g., N -> (A, C, G, T) ); my @components = split '', _convert('dna', $orig_bases[$i] ); $orig_bases[$i] = [@components]; } # Combine all the bases of each of the three positions of the # codons, and build the return list. for my $i ( @{ $orig_bases[0] } ) { for my $j ( @{ $orig_bases[1] } ) { for my $k ( @{ $orig_bases[2] } ) { push @return_bases, $i . $j . $k; } } } return @return_bases; } { my %convert; sub _convert { # Interconvert between redundant and non-redundant protein and # dna alphabets. Takes an alphabet (protein or dna) and a string # with the letter, and returns its equivalent in # redundant/non-redundant alphabet. Example ACTG -> N. my ($alphabet, $letter) = @_; unless ( $alphabet and $alphabet =~ /^dna$|^protein$/i and $letter and length $letter <= 4 ) { croak "Wrong arguments!\n"; } unless (%convert) { %convert = ( 'dna' => { qw(N ACGT B CGT D AGT H ACT V ACG K GT M AC R AG S CG W AT Y CT A A C C T T G G) }, 'protein' => { '.' => 'ACDEFGHIJKLMNOPQRSTUVWY', X => 'ACDEFGHIJKLMNOPQRSTUVWY', Z => 'QE', B => 'ND', }, ); # Make %convert hash key/value agnostic. foreach my $alphabet ( keys %convert ) { map { $convert{$alphabet}->{ $convert{$alphabet}{$_} } = $_ } keys %{ $convert{$alphabet} }; } } return $convert{$alphabet}{$letter}; } } sub _uniq_string { # Takes a list of letters and returns an alphabetically sorted # list with unique elements. my @letters = @_; return join '', sort { $a cmp $b } uniq @letters; } { my ( @codon_library, $ct ); sub _negated_aas_to_codon { # Given a string of residues, returns a degenerate codon that will # not be translated into any of them, while maximizing degeneracy # (ie, it tries to also translate into as many residues as possible). # This functionality is required for reverse translating profiles # that contain negative patterns: [^X]. This means that the current # position should not contain aminoacid X, but can have any of the # others. The reverse translated nucleotide sequence should # reflect this. # Approach: construct a list of all possible codons, incluiding all # degenerate bases. This is an array of 15x15x15 = 3375 elements. # Order them by descendent "degeneracy". # Return the first one whose expansion in 4-lettered codons # doesn't contain a codon that translates into any of the # non-wanted residues. # * Since this takes some time, I presorted them and saved them. # Reading them from a file takes a fraction of the time that it taes # to re-sort them every time the application is launched. my $aas_to_avoid = shift; # Initialize reusable variables if it's the first time the sub # is called. unless (@codon_library) { while (<DATA>) { chomp; push @codon_library, split ' ', $_ } } unless ($ct) { $ct = Bio::Tools::CodonTable->new; } # Reverse translate the unwanted aminoacids to unwanted codons. my @unwanted_codons; foreach my $aa ( split '', $aas_to_avoid ) { push @unwanted_codons, $ct->revtranslate($aa); } foreach my $degenerate_codon (@codon_library) { my @codons = _expand_codon($degenerate_codon); my $success = 1; foreach my $unwanted (@unwanted_codons) { if ( grep { uc $unwanted eq $_ } @codons ) { $success = 0; } } if ($success) { return $degenerate_codon } } } } 1; =head1 COPYRIGHT & LICENSE Copyright 2009 Bruno Vecchi, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut __DATA__ NNN NNB NND NNH NNV NBN NDN NHN NVN BNN DNN HNN VNN NBB NBD NBH NBV NDB NDD NDH NDV NHB NHD NHH NHV NVB NVD NVH NVV BNB BND BNH BNV BBN BDN BHN BVN DNB DND DNH DNV DBN DDN DHN DVN HNB HND HNH HNV HBN HDN HHN HVN VNB VND VNH VNV VBN VDN VHN VVN NNK NNM NNR NNS NNW NNY NKN NMN NRN NSN NWN NYN KNN MNN RNN SNN WNN YNN BBB BBD BBH BBV BDB BDD BDH BDV BHB BHD BHH BHV BVB BVD BVH BVV DBB DBD DBH DBV DDB DDD DDH DDV DHB DHD DHH DHV DVB DVD DVH DVV HBB HBD HBH HBV HDB HDD HDH HDV HHB HHD HHH HHV HVB HVD HVH HVV VBB VBD VBH VBV VDB VDD VDH VDV VHB VHD VHH VHV VVB VVD VVH VVV NBK NBM NBR NBS NBW NBY NDK NDM NDR NDS NDW NDY NHK NHM NHR NHS NHW NHY NVK NVM NVR NVS NVW NVY NKB NKD NKH NKV NMB NMD NMH NMV NRB NRD NRH NRV NSB NSD NSH NSV NWB NWD NWH NWV NYB NYD NYH NYV BNK BNM BNR BNS BNW BNY BKN BMN BRN BSN BWN BYN DNK DNM DNR DNS DNW DNY DKN DMN DRN DSN DWN DYN HNK HNM HNR HNS HNW HNY HKN HMN HRN HSN HWN HYN VNK VNM VNR VNS VNW VNY VKN VMN VRN VSN VWN VYN KNB KND KNH KNV KBN KDN KHN KVN MNB MND MNH MNV MBN MDN MHN MVN RNB RND RNH RNV RBN RDN RHN RVN SNB SND SNH SNV SBN SDN SHN SVN WNB WND WNH WNV WBN WDN WHN WVN YNB YND YNH YNV YBN YDN YHN YVN BBK BBM BBR BBS BBW BBY BDK BDM BDR BDS BDW BDY BHK BHM BHR BHS BHW BHY BVK BVM BVR BVS BVW BVY BKB BKD BKH BKV BMB BMD BMH BMV BRB BRD BRH BRV BSB BSD BSH BSV BWB BWD BWH BWV BYB BYD BYH BYV DBK DBM DBR DBS DBW DBY DDK DDM DDR DDS DDW DDY DHK DHM DHR DHS DHW DHY DVK DVM DVR DVS DVW DVY DKB DKD DKH DKV DMB DMD DMH DMV DRB DRD DRH DRV DSB DSD DSH DSV DWB DWD DWH DWV DYB DYD DYH DYV HBK HBM HBR HBS HBW HBY HDK HDM HDR HDS HDW HDY HHK HHM HHR HHS HHW HHY HVK HVM HVR HVS HVW HVY HKB HKD HKH HKV HMB HMD HMH HMV HRB HRD HRH HRV HSB HSD HSH HSV HWB HWD HWH HWV HYB HYD HYH HYV VBK VBM VBR VBS VBW VBY VDK VDM VDR VDS VDW VDY VHK VHM VHR VHS VHW VHY VVK VVM VVR VVS VVW VVY VKB VKD VKH VKV VMB VMD VMH VMV VRB VRD VRH VRV VSB VSD VSH VSV VWB VWD VWH VWV VYB VYD VYH VYV KBB KBD KBH KBV KDB KDD KDH KDV KHB KHD KHH KHV KVB KVD KVH KVV MBB MBD MBH MBV MDB MDD MDH MDV MHB MHD MHH MHV MVB MVD MVH MVV RBB RBD RBH RBV RDB RDD RDH RDV RHB RHD RHH RHV RVB RVD RVH RVV SBB SBD SBH SBV SDB SDD SDH SDV SHB SHD SHH SHV SVB SVD SVH SVV WBB WBD WBH WBV WDB WDD WDH WDV WHB WHD WHH WHV WVB WVD WVH WVV YBB YBD YBH YBV YDB YDD YDH YDV YHB YHD YHH YHV YVB YVD YVH YVV NNA NNC NNT NNG NKK NKM NKR NKS NKW NKY NMK NMM NMR NMS NMW NMY NRK NRM NRR NRS NRW NRY NSK NSM NSR NSS NSW NSY NWK NWM NWR NWS NWW NWY NYK NYM NYR NYS NYW NYY NAN NCN NTN NGN KNK KNM KNR KNS KNW KNY KKN KMN KRN KSN KWN KYN MNK MNM MNR MNS MNW MNY MKN MMN MRN MSN MWN MYN RNK RNM RNR RNS RNW RNY RKN RMN RRN RSN RWN RYN SNK SNM SNR SNS SNW SNY SKN SMN SRN SSN SWN SYN WNK WNM WNR WNS WNW WNY WKN WMN WRN WSN WWN WYN YNK YNM YNR YNS YNW YNY YKN YMN YRN YSN YWN YYN ANN CNN TNN GNN NBA NBC NBT NBG NDA NDC NDT NDG NHA NHC NHT NHG NVA NVC NVT NVG NAB NAD NAH NAV NCB NCD NCH NCV NTB NTD NTH NTV NGB NGD NGH NGV BNA BNC BNT BNG BKK BKM BKR BKS BKW BKY BMK BMM BMR BMS BMW BMY BRK BRM BRR BRS BRW BRY BSK BSM BSR BSS BSW BSY BWK BWM BWR BWS BWW BWY BYK BYM BYR BYS BYW BYY BAN BCN BTN BGN DNA DNC DNT DNG DKK DKM DKR DKS DKW DKY DMK DMM DMR DMS DMW DMY DRK DRM DRR DRS DRW DRY DSK DSM DSR DSS DSW DSY DWK DWM DWR DWS DWW DWY DYK DYM DYR DYS DYW DYY DAN DCN DTN DGN HNA HNC HNT HNG HKK HKM HKR HKS HKW HKY HMK HMM HMR HMS HMW HMY HRK HRM HRR HRS HRW HRY HSK HSM HSR HSS HSW HSY HWK HWM HWR HWS HWW HWY HYK HYM HYR HYS HYW HYY HAN HCN HTN HGN VNA VNC VNT VNG VKK VKM VKR VKS VKW VKY VMK VMM VMR VMS VMW VMY VRK VRM VRR VRS VRW VRY VSK VSM VSR VSS VSW VSY VWK VWM VWR VWS VWW VWY VYK VYM VYR VYS VYW VYY VAN VCN VTN VGN KBK KBM KBR KBS KBW KBY KDK KDM KDR KDS KDW KDY KHK KHM KHR KHS KHW KHY KVK KVM KVR KVS KVW KVY KKB KKD KKH KKV KMB KMD KMH KMV KRB KRD KRH KRV KSB KSD KSH KSV KWB KWD KWH KWV KYB KYD KYH KYV MBK MBM MBR MBS MBW MBY MDK MDM MDR MDS MDW MDY MHK MHM MHR MHS MHW MHY MVK MVM MVR MVS MVW MVY MKB MKD MKH MKV MMB MMD MMH MMV MRB MRD MRH MRV MSB MSD MSH MSV MWB MWD MWH MWV MYB MYD MYH MYV RBK RBM RBR RBS RBW RBY RDK RDM RDR RDS RDW RDY RHK RHM RHR RHS RHW RHY RVK RVM RVR RVS RVW RVY RKB RKD RKH RKV RMB RMD RMH RMV RRB RRD RRH RRV RSB RSD RSH RSV RWB RWD RWH RWV RYB RYD RYH RYV SBK SBM SBR SBS SBW SBY SDK SDM SDR SDS SDW SDY SHK SHM SHR SHS SHW SHY SVK SVM SVR SVS SVW SVY SKB SKD SKH SKV SMB SMD SMH SMV SRB SRD SRH SRV SSB SSD SSH SSV SWB SWD SWH SWV SYB SYD SYH SYV WBK WBM WBR WBS WBW WBY WDK WDM WDR WDS WDW WDY WHK WHM WHR WHS WHW WHY WVK WVM WVR WVS WVW WVY WKB WKD WKH WKV WMB WMD WMH WMV WRB WRD WRH WRV WSB WSD WSH WSV WWB WWD WWH WWV WYB WYD WYH WYV YBK YBM YBR YBS YBW YBY YDK YDM YDR YDS YDW YDY YHK YHM YHR YHS YHW YHY YVK YVM YVR YVS YVW YVY YKB YKD YKH YKV YMB YMD YMH YMV YRB YRD YRH YRV YSB YSD YSH YSV YWB YWD YWH YWV YYB YYD YYH YYV ANB AND ANH ANV ABN ADN AHN AVN CNB CND CNH CNV CBN CDN CHN CVN TNB TND TNH TNV TBN TDN THN TVN GNB GND GNH GNV GBN GDN GHN GVN BBA BBC BBT BBG BDA BDC BDT BDG BHA BHC BHT BHG BVA BVC BVT BVG BAB BAD BAH BAV BCB BCD BCH BCV BTB BTD BTH BTV BGB BGD BGH BGV DBA DBC DBT DBG DDA DDC DDT DDG DHA DHC DHT DHG DVA DVC DVT DVG DAB DAD DAH DAV DCB DCD DCH DCV DTB DTD DTH DTV DGB DGD DGH DGV HBA HBC HBT HBG HDA HDC HDT HDG HHA HHC HHT HHG HVA HVC HVT HVG HAB HAD HAH HAV HCB HCD HCH HCV HTB HTD HTH HTV HGB HGD HGH HGV VBA VBC VBT VBG VDA VDC VDT VDG VHA VHC VHT VHG VVA VVC VVT VVG VAB VAD VAH VAV VCB VCD VCH VCV VTB VTD VTH VTV VGB VGD VGH VGV ABB ABD ABH ABV ADB ADD ADH ADV AHB AHD AHH AHV AVB AVD AVH AVV CBB CBD CBH CBV CDB CDD CDH CDV CHB CHD CHH CHV CVB CVD CVH CVV TBB TBD TBH TBV TDB TDD TDH TDV THB THD THH THV TVB TVD TVH TVV GBB GBD GBH GBV GDB GDD GDH GDV GHB GHD GHH GHV GVB GVD GVH GVV NKA NKC NKT NKG NMA NMC NMT NMG NRA NRC NRT NRG NSA NSC NST NSG NWA NWC NWT NWG NYA NYC NYT NYG NAK NAM NAR NAS NAW NAY NCK NCM NCR NCS NCW NCY NTK NTM NTR NTS NTW NTY NGK NGM NGR NGS NGW NGY KNA KNC KNT KNG KKK KKM KKR KKS KKW KKY KMK KMM KMR KMS KMW KMY KRK KRM KRR KRS KRW KRY KSK KSM KSR KSS KSW KSY KWK KWM KWR KWS KWW KWY KYK KYM KYR KYS KYW KYY KAN KCN KTN KGN MNA MNC MNT MNG MKK MKM MKR MKS MKW MKY MMK MMM MMR MMS MMW MMY MRK MRM MRR MRS MRW MRY MSK MSM MSR MSS MSW MSY MWK MWM MWR MWS MWW MWY MYK MYM MYR MYS MYW MYY MAN MCN MTN MGN RNA RNC RNT RNG RKK RKM RKR RKS RKW RKY RMK RMM RMR RMS RMW RMY RRK RRM RRR RRS RRW RRY RSK RSM RSR RSS RSW RSY RWK RWM RWR RWS RWW RWY RYK RYM RYR RYS RYW RYY RAN RCN RTN RGN SNA SNC SNT SNG SKK SKM SKR SKS SKW SKY SMK SMM SMR SMS SMW SMY SRK SRM SRR SRS SRW SRY SSK SSM SSR SSS SSW SSY SWK SWM SWR SWS SWW SWY SYK SYM SYR SYS SYW SYY SAN SCN STN SGN WNA WNC WNT WNG WKK WKM WKR WKS WKW WKY WMK WMM WMR WMS WMW WMY WRK WRM WRR WRS WRW WRY WSK WSM WSR WSS WSW WSY WWK WWM WWR WWS WWW WWY WYK WYM WYR WYS WYW WYY WAN WCN WTN WGN YNA YNC YNT YNG YKK YKM YKR YKS YKW YKY YMK YMM YMR YMS YMW YMY YRK YRM YRR YRS YRW YRY YSK YSM YSR YSS YSW YSY YWK YWM YWR YWS YWW YWY YYK YYM YYR YYS YYW YYY YAN YCN YTN YGN ANK ANM ANR ANS ANW ANY AKN AMN ARN ASN AWN AYN CNK CNM CNR CNS CNW CNY CKN CMN CRN CSN CWN CYN TNK TNM TNR TNS TNW TNY TKN TMN TRN TSN TWN TYN GNK GNM GNR GNS GNW GNY GKN GMN GRN GSN GWN GYN BKA BKC BKT BKG BMA BMC BMT BMG BRA BRC BRT BRG BSA BSC BST BSG BWA BWC BWT BWG BYA BYC BYT BYG BAK BAM BAR BAS BAW BAY BCK BCM BCR BCS BCW BCY BTK BTM BTR BTS BTW BTY BGK BGM BGR BGS BGW BGY DKA DKC DKT DKG DMA DMC DMT DMG DRA DRC DRT DRG DSA DSC DST DSG DWA DWC DWT DWG DYA DYC DYT DYG DAK DAM DAR DAS DAW DAY DCK DCM DCR DCS DCW DCY DTK DTM DTR DTS DTW DTY DGK DGM DGR DGS DGW DGY HKA HKC HKT HKG HMA HMC HMT HMG HRA HRC HRT HRG HSA HSC HST HSG HWA HWC HWT HWG HYA HYC HYT HYG HAK HAM HAR HAS HAW HAY HCK HCM HCR HCS HCW HCY HTK HTM HTR HTS HTW HTY HGK HGM HGR HGS HGW HGY VKA VKC VKT VKG VMA VMC VMT VMG VRA VRC VRT VRG VSA VSC VST VSG VWA VWC VWT VWG VYA VYC VYT VYG VAK VAM VAR VAS VAW VAY VCK VCM VCR VCS VCW VCY VTK VTM VTR VTS VTW VTY VGK VGM VGR VGS VGW VGY KBA KBC KBT KBG KDA KDC KDT KDG KHA KHC KHT KHG KVA KVC KVT KVG KAB KAD KAH KAV KCB KCD KCH KCV KTB KTD KTH KTV KGB KGD KGH KGV MBA MBC MBT MBG MDA MDC MDT MDG MHA MHC MHT MHG MVA MVC MVT MVG MAB MAD MAH MAV MCB MCD MCH MCV MTB MTD MTH MTV MGB MGD MGH MGV RBA RBC RBT RBG RDA RDC RDT RDG RHA RHC RHT RHG RVA RVC RVT RVG RAB RAD RAH RAV RCB RCD RCH RCV RTB RTD RTH RTV RGB RGD RGH RGV SBA SBC SBT SBG SDA SDC SDT SDG SHA SHC SHT SHG SVA SVC SVT SVG SAB SAD SAH SAV SCB SCD SCH SCV STB STD STH STV SGB SGD SGH SGV WBA WBC WBT WBG WDA WDC WDT WDG WHA WHC WHT WHG WVA WVC WVT WVG WAB WAD WAH WAV WCB WCD WCH WCV WTB WTD WTH WTV WGB WGD WGH WGV YBA YBC YBT YBG YDA YDC YDT YDG YHA YHC YHT YHG YVA YVC YVT YVG YAB YAD YAH YAV YCB YCD YCH YCV YTB YTD YTH YTV YGB YGD YGH YGV ABK ABM ABR ABS ABW ABY ADK ADM ADR ADS ADW ADY AHK AHM AHR AHS AHW AHY AVK AVM AVR AVS AVW AVY AKB AKD AKH AKV AMB AMD AMH AMV ARB ARD ARH ARV ASB ASD ASH ASV AWB AWD AWH AWV AYB AYD AYH AYV CBK CBM CBR CBS CBW CBY CDK CDM CDR CDS CDW CDY CHK CHM CHR CHS CHW CHY CVK CVM CVR CVS CVW CVY CKB CKD CKH CKV CMB CMD CMH CMV CRB CRD CRH CRV CSB CSD CSH CSV CWB CWD CWH CWV CYB CYD CYH CYV TBK TBM TBR TBS TBW TBY TDK TDM TDR TDS TDW TDY THK THM THR THS THW THY TVK TVM TVR TVS TVW TVY TKB TKD TKH TKV TMB TMD TMH TMV TRB TRD TRH TRV TSB TSD TSH TSV TWB TWD TWH TWV TYB TYD TYH TYV GBK GBM GBR GBS GBW GBY GDK GDM GDR GDS GDW GDY GHK GHM GHR GHS GHW GHY GVK GVM GVR GVS GVW GVY GKB GKD GKH GKV GMB GMD GMH GMV GRB GRD GRH GRV GSB GSD GSH GSV GWB GWD GWH GWV GYB GYD GYH GYV NAA NAC NAT NAG NCA NCC NCT NCG NTA NTC NTT NTG NGA NGC NGT NGG KKA KKC KKT KKG KMA KMC KMT KMG KRA KRC KRT KRG KSA KSC KST KSG KWA KWC KWT KWG KYA KYC KYT KYG KAK KAM KAR KAS KAW KAY KCK KCM KCR KCS KCW KCY KTK KTM KTR KTS KTW KTY KGK KGM KGR KGS KGW KGY MKA MKC MKT MKG MMA MMC MMT MMG MRA MRC MRT MRG MSA MSC MST MSG MWA MWC MWT MWG MYA MYC MYT MYG MAK MAM MAR MAS MAW MAY MCK MCM MCR MCS MCW MCY MTK MTM MTR MTS MTW MTY MGK MGM MGR MGS MGW MGY RKA RKC RKT RKG RMA RMC RMT RMG RRA RRC RRT RRG RSA RSC RST RSG RWA RWC RWT RWG RYA RYC RYT RYG RAK RAM RAR RAS RAW RAY RCK RCM RCR RCS RCW RCY RTK RTM RTR RTS RTW RTY RGK RGM RGR RGS RGW RGY SKA SKC SKT SKG SMA SMC SMT SMG SRA SRC SRT SRG SSA SSC SST SSG SWA SWC SWT SWG SYA SYC SYT SYG SAK SAM SAR SAS SAW SAY SCK SCM SCR SCS SCW SCY STK STM STR STS STW STY SGK SGM SGR SGS SGW SGY WKA WKC WKT WKG WMA WMC WMT WMG WRA WRC WRT WRG WSA WSC WST WSG WWA WWC WWT WWG WYA WYC WYT WYG WAK WAM WAR WAS WAW WAY WCK WCM WCR WCS WCW WCY WTK WTM WTR WTS WTW WTY WGK WGM WGR WGS WGW WGY YKA YKC YKT YKG YMA YMC YMT YMG YRA YRC YRT YRG YSA YSC YST YSG YWA YWC YWT YWG YYA YYC YYT YYG YAK YAM YAR YAS YAW YAY YCK YCM YCR YCS YCW YCY YTK YTM YTR YTS YTW YTY YGK YGM YGR YGS YGW YGY ANA ANC ANT ANG AKK AKM AKR AKS AKW AKY AMK AMM AMR AMS AMW AMY ARK ARM ARR ARS ARW ARY ASK ASM ASR ASS ASW ASY AWK AWM AWR AWS AWW AWY AYK AYM AYR AYS AYW AYY AAN ACN ATN AGN CNA CNC CNT CNG CKK CKM CKR CKS CKW CKY CMK CMM CMR CMS CMW CMY CRK CRM CRR CRS CRW CRY CSK CSM CSR CSS CSW CSY CWK CWM CWR CWS CWW CWY CYK CYM CYR CYS CYW CYY CAN CCN CTN CGN TNA TNC TNT TNG TKK TKM TKR TKS TKW TKY TMK TMM TMR TMS TMW TMY TRK TRM TRR TRS TRW TRY TSK TSM TSR TSS TSW TSY TWK TWM TWR TWS TWW TWY TYK TYM TYR TYS TYW TYY TAN TCN TTN TGN GNA GNC GNT GNG GKK GKM GKR GKS GKW GKY GMK GMM GMR GMS GMW GMY GRK GRM GRR GRS GRW GRY GSK GSM GSR GSS GSW GSY GWK GWM GWR GWS GWW GWY GYK GYM GYR GYS GYW GYY GAN GCN GTN GGN BAA BAC BAT BAG BCA BCC BCT BCG BTA BTC BTT BTG BGA BGC BGT BGG DAA DAC DAT DAG DCA DCC DCT DCG DTA DTC DTT DTG DGA DGC DGT DGG HAA HAC HAT HAG HCA HCC HCT HCG HTA HTC HTT HTG HGA HGC HGT HGG VAA VAC VAT VAG VCA VCC VCT VCG VTA VTC VTT VTG VGA VGC VGT VGG ABA ABC ABT ABG ADA ADC ADT ADG AHA AHC AHT AHG AVA AVC AVT AVG AAB AAD AAH AAV ACB ACD ACH ACV ATB ATD ATH ATV AGB AGD AGH AGV CBA CBC CBT CBG CDA CDC CDT CDG CHA CHC CHT CHG CVA CVC CVT CVG CAB CAD CAH CAV CCB CCD CCH CCV CTB CTD CTH CTV CGB CGD CGH CGV TBA TBC TBT TBG TDA TDC TDT TDG THA THC THT THG TVA TVC TVT TVG TAB TAD TAH TAV TCB TCD TCH TCV TTB TTD TTH TTV TGB TGD TGH TGV GBA GBC GBT GBG GDA GDC GDT GDG GHA GHC GHT GHG GVA GVC GVT GVG GAB GAD GAH GAV GCB GCD GCH GCV GTB GTD GTH GTV GGB GGD GGH GGV KAA KAC KAT KAG KCA KCC KCT KCG KTA KTC KTT KTG KGA KGC KGT KGG MAA MAC MAT MAG MCA MCC MCT MCG MTA MTC MTT MTG MGA MGC MGT MGG RAA RAC RAT RAG RCA RCC RCT RCG RTA RTC RTT RTG RGA RGC RGT RGG SAA SAC SAT SAG SCA SCC SCT SCG STA STC STT STG SGA SGC SGT SGG WAA WAC WAT WAG WCA WCC WCT WCG WTA WTC WTT WTG WGA WGC WGT WGG YAA YAC YAT YAG YCA YCC YCT YCG YTA YTC YTT YTG YGA YGC YGT YGG AKA AKC AKT AKG AMA AMC AMT AMG ARA ARC ART ARG ASA ASC AST ASG AWA AWC AWT AWG AYA AYC AYT AYG AAK AAM AAR AAS AAW AAY ACK ACM ACR ACS ACW ACY ATK ATM ATR ATS ATW ATY AGK AGM AGR AGS AGW AGY CKA CKC CKT CKG CMA CMC CMT CMG CRA CRC CRT CRG CSA CSC CST CSG CWA CWC CWT CWG CYA CYC CYT CYG CAK CAM CAR CAS CAW CAY CCK CCM CCR CCS CCW CCY CTK CTM CTR CTS CTW CTY CGK CGM CGR CGS CGW CGY TKA TKC TKT TKG TMA TMC TMT TMG TRA TRC TRT TRG TSA TSC TST TSG TWA TWC TWT TWG TYA TYC TYT TYG TAK TAM TAR TAS TAW TAY TCK TCM TCR TCS TCW TCY TTK TTM TTR TTS TTW TTY TGK TGM TGR TGS TGW TGY GKA GKC GKT GKG GMA GMC GMT GMG GRA GRC GRT GRG GSA GSC GST GSG GWA GWC GWT GWG GYA GYC GYT GYG GAK GAM GAR GAS GAW GAY GCK GCM GCR GCS GCW GCY GTK GTM GTR GTS GTW GTY GGK GGM GGR GGS GGW GGY AAA AAC AAT AAG ACA ACC ACT ACG ATA ATC ATT ATG AGA AGC AGT AGG CAA CAC CAT CAG CCA CCC CCT CCG CTA CTC CTT CTG CGA CGC CGT CGG TAA TAC TAT TAG TCA TCC TCT TCG TTA TTC TTT TTG TGA TGC TGT TGG GAA GAC GAT GAG GCA GCC GCT GCG GTA GTC GTT GTG GGA GGC GGT GGG ������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Signalp�������������������������������������������������������������������000755��000765��000024�� 0�12254227331� 16506� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Signalp/ExtendedSignalp.pm������������������������������������������������000444��000765��000024�� 41644�12254227331� 22310� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Signalp::ExtendedSignalp # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Emmanuel Quevillon <emmanuel.quevillon@versailles.inra.fr> # # Copyright Emmanuel Quevillon # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Tools::Signalp::ExtendedSignalp - enhanced parser for Signalp output =head1 SYNOPSIS use Bio::Tools::Signalp::ExtendedSignalp; my $params = [qw(maxC maxY maxS meanS D)]; my $parser = new Bio::Tools::Signalp::ExtendedSignalp( -fh => $filehandle -factors => $params ); $parser->factors($params); while( my $sp_feat = $parser->next_feature ) { #do something #eg push @sp_feat, $sp_feat; } =head1 DESCRIPTION # Please direct questions and support issues to I<bioperl-l@bioperl.org> Parser module for Signalp. Based on the EnsEMBL module Bio::EnsEMBL::Pipeline::Runnable::Protein::Signalp originally written by Marc Sohrmann (ms2 a sanger.ac.uk) Written in BioPipe by Balamurugan Kumarasamy (savikalpa a fugu-sg.org) Cared for by the Fugu Informatics team (fuguteam@fugu-sg.org) You may distribute this module under the same terms as perl itself Compared to the original SignalP, this method allow the user to filter results out based on maxC maxY maxS meanS and D factor cutoff for the Neural Network (NN) method only. The HMM method does not give any filters with 'YES' or 'NO' as result. The user must be aware that the filters can only by applied on NN method. Also, to ensure the compatibility with original Signalp parsing module, the user must know that by default, if filters are empty, max Y and mean S filters are automatically used to filter results. If the used gives a list, then the parser will only report protein having 'YES' for each factor. This module supports parsing for full, summary and short output form signalp. Actually, full and summary are equivalent in terms of filtering results. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Based on the Bio::Tools::Signalp module Emmanuel Quevillon <emmanuel.quevillon@versailles.inra.fr> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::Signalp::ExtendedSignalp; use strict; use Data::Dumper; use Bio::SeqFeature::Generic; # don't need Bio::Root::Root/IO (already in inheritance tree) use base qw(Bio::Tools::Signalp Bio::Tools::AnalysisResult); #Supported arguments my $FACTS = { 'maxC' => 1, 'maxS' => 1, 'maxY' => 1, 'meanS' => 1, 'D' => 1, }; =head2 new Title : new Usage : my $obj = new Bio::Tools::Signalp::ExtendedSignalp(); Function: Builds a new Bio::Tools::Signalp::ExtendedSignalp object Returns : Bio::Tools::Signalp::ExtendedSignalp Args : -fh/-file => $val, # for initing input, see Bio::Root::IO =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->_initialize_io(@args); my $factors = $self->_rearrange([qw(FACTORS)], @args); #To behave like the parent module (Bio::Tools::Signalp) we default factors to these two factors if($factors && scalar(@$factors)){ $factors = $factors; } else{ $factors = [qw(maxY meanS)]; } $factors && $self->factors($factors); return $self; } =head2 next_feature Title : next_feature Usage : my $feat = $signalp->next_feature Function: Get the next result feature from parser data Returns : Bio::SeqFeature::Generic Args : none =cut sub next_feature { my ($self) = @_; if(!$self->_parsed()){ $self->_parse(); } return shift @{$self->{_features}} || undef; } =head2 _filterok Title : _filterok Usage : my $feat = $signalp->_filterok Function: Check if the factors required by the user are all ok. Returns : 1/0 Args : hash reference =cut sub _filterok { my($self, $hash) = @_; #We hope everything will be fine ;) my $bool = 1; #If the user did not give any filter, we keep eveything return $bool unless keys %{$self->{_factors}}; #If only one of the factors parsed is equal to NO based on the user factors cutoff #Then the filter is not ok. foreach my $fact (keys %{$self->factors()}){ if(exists($hash->{$fact}) && $hash->{$fact} =~ /^N/){ $bool = 0; } } return $bool; } =head2 factors Title : factors Usage : my $feat = $signalp->factors Function: Get/Set the filters required from the user Returns : hash Args : array reference =cut sub factors { my($self, $array) = @_; if($array){ $self->{_factors} = { }; foreach my $f (@$array){ if(exists($FACTS->{$f})){ $self->{_factors}->{$f} = 1; } else{ $self->throw("[$f] incorrect factor. Supported:\n- ".join("\n- ", keys %$FACTS)."\n"); } } } return $self->{_factors}; } =head2 _parsed Title : _parsed Usage : obj->_parsed() Function: Get/Set if the result is parsed or not Returns : 1/0 scalar Args : On set 1 =cut sub _parsed { my($self, $parsed) = @_; if(defined($parsed)){ $self->{_parsed} = $parsed; } return $self->{_parsed}; } =head2 _parse Title : _parse Usage : obj->_parse Function: Parse the SignalP result Returns : Args : =cut sub _parse { my($self) = @_; #Let's read the file... while (my $line = $self->_readline()) { chomp $line; #We want to be sure to catch the first non empty line to be ablte to determine #which format we are working with... next unless ($line =~ /^>(\S+)|^# SignalP-[NHM]+ \S+ predictions/); if($line =~ /^>(\S+)/){ $self->_pushback($line); $self->_parse_summary_format(); last; } elsif($line =~ /^# SignalP-[NHM]+ \S+ predictions/){ $self->_pushback($line); $self->_parse_short_format(); last; } else{ $self->throw("Unable to determine the format type."); } } return; } =head2 _parse_summary_format Title : _parse_summary_format Usage : $self->_parse_summary_format Function: Method to parse summary/full format from signalp output It automatically fills filtered features. Returns : Args : =cut sub _parse_summary_format { my($self) = @_; my $feature = undef; my $ok = 0; while(my $line = $self->_readline()){ if($line =~ /^SignalP-NN result:/){ $self->_pushback($line); $feature = $self->_parse_nn_result($feature); } if($line =~ /^SignalP-HMM result:/){ $self->_pushback($line); $feature = $self->_parse_hmm_result($feature); } if($line =~ /^---------/ && $feature){ my $new_feature = $self->create_feature($feature); push @{$self->{_features}}, $new_feature if $new_feature; $feature = undef; } } return; } =head2 _parse_nn_result Title : _parse_nn_result Usage : obj->_parse_nn_result Function: Parses the Neuronal Network (NN) part of the result Returns : Hash reference Args : =cut sub _parse_nn_result { my($self, $feature) = @_; my $ok = 0; my %facts; #SignalP-NN result: #>MGG_11635.5 length = 100 ## Measure Position Value Cutoff signal peptide? # max. C 37 0.087 0.32 NO # max. Y 37 0.042 0.33 NO # max. S 3 0.062 0.87 NO # mean S 1-36 0.024 0.48 NO # D 1-36 0.033 0.43 NO while(my $line = $self->_readline()){ chomp $line; if($line =~ /^SignalP-NN result:/){ $ok = 1; next; } $self->throw("Wrong line for parsing NN results.") unless $ok; if ($line=~/^\>(\S+)\s+length/) { $self->seqname($1); %facts = (); next; } elsif($line =~ /max\.\s+C\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { $feature->{maxCprob} = $1; $facts{maxC} = $2; next; } elsif ($line =~ /max\.\s+Y\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { $feature->{maxYprob} = $1; $facts{maxY} = $2; next; } elsif($line =~ /max\.\s+S\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { $feature->{maxSprob} = $1; $facts{maxS} = $2; next; } elsif ($line=~/mean\s+S\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { $feature->{meanSprob} = $1; $facts{meanS} = $2; next; } elsif ($line=~/\s+D\s+(\S+)\s+\S+\s+\S+\s+(\S+)/) { $feature->{Dprob} = $1; $facts{D} = $2; next; } #If we don't have this line it means that all the factors cutoff are equal to 'NO' elsif ($line =~ /Most likely cleavage site between pos\.\s+(\d+)/) { #if($self->_filterok(\%facts)){ #$feature->{name} = $self->seqname(); #$feature->{start} = 1; $feature->{end} = $1 + 1; #To be consistent with end given in short format #} #return $feature; } elsif($line =~ /^\s*$/){ last; } } if($self->_filterok(\%facts)){ $feature->{name} = $self->seqname(); $feature->{start} = 1; $feature->{nnPrediction} = 'signal-peptide'; } return $feature; } =head2 _parse_hmm_result Title : _parse_hmm_result Usage : obj->_parse_hmm_result Function: Parses the Hiden Markov Model (HMM) part of the result Returns : Hash reference Args : =cut sub _parse_hmm_result { my ($self, $feature_hash) = @_; my $ok = 0; #SignalP-HMM result: #>MGG_11635.5 #Prediction: Non-secretory protein #Signal peptide probability: 0.000 #Signal anchor probability: 0.000 #Max cleavage site probability: 0.000 between pos. -1 and 0 while(my $line = $self->_readline()){ chomp $line; next if $line =~ /^\s*$/o; if($line =~ /^SignalP-HMM result:/){ $ok = 1; next; } $self->throw("Wrong line for parsing HMM result.") unless $ok; if($line =~ /^>(\S+)/){ #In case we already seen a name with NN results $feature_hash->{name} = $1 unless $self->seqname(); } elsif($line =~ /Prediction: (.+)$/){ $feature_hash->{hmmPrediction} = $1; } elsif($line =~ /Signal peptide probability: ([0-9\.]+)/){ $feature_hash->{peptideProb} = $1; } elsif($line =~ /Signal anchor probability: ([0-9\.]+)/){ $feature_hash->{anchorProb} = $1; } elsif($line =~ /Max cleavage site probability: (\S+) between pos. \S+ and (\S+)/){ $feature_hash->{cleavageSiteProb} = $1; #Strange case, if we don't have an end value in NN result (no nn method launched) #We try anyway to get an end value, unless this value is lower than 1 which is #the start $feature_hash->{end} = $2 if($2 > 1 && !$feature_hash->{end}); $feature_hash->{start} = 1 unless $feature_hash->{start}; last; } } return $feature_hash; } =head2 _parse_short_format Title : _parse_short_format Usage : $self->_parse_short_format Function: Method to parse short format from signalp output It automatically fills filtered features. Returns : Args : =cut sub _parse_short_format { my($self) = @_; my $ok = 0; my $method = undef; $self->{_oformat} = 'short'; #Output example # SignalP-NN euk predictions # SignalP-HMM euk predictions # name Cmax pos ? Ymax pos ? Smax pos ? Smean ? D ? # name ! Cmax pos ? Sprob ? #Q5A8M1_CANAL 0.085 27 N 0.190 35 N 0.936 27 Y 0.418 N 0.304 N Q5A8M1_CANAL Q 0.001 35 N 0.002 N #O74127_YARLI 0.121 21 N 0.284 21 N 0.953 11 Y 0.826 Y 0.555 Y O74127_YARLI S 0.485 23 N 0.668 Y #Q5VJ86_9PEZI 0.355 24 Y 0.375 24 Y 0.798 12 N 0.447 N 0.411 N Q5VJ86_9PEZI Q 0.180 23 N 0.339 N #Q5A8U5_CANAL 0.085 27 N 0.190 35 N 0.936 27 Y 0.418 N 0.304 N Q5A8U5_CANAL Q 0.001 35 N 0.002 N while(my $line = $self->_readline()){ chomp $line; next if $line =~ /^\s*$|^# name/; if($line =~ /^#/){ $method = $line =~ /SignalP-NN .+ SignalP-HMM/ ? 'both' : $line =~ /SignalP-NN/ ? 'nn' : 'hmm'; next; } #$self->throw("It looks like the format is not 'short' format.") unless($ok); my @data = split(/\s+/, $line); $self->seqname($data[0]); my $factors = { }; my $feature = { }; #NN results gives more fields than HMM if($method eq 'both' || $method eq 'nn'){ $feature->{maxCprob} = $data[1]; $factors->{maxC} = $data[3]; $feature->{maxYprob} = $data[4]; $factors->{maxY} = $data[6]; $feature->{maxSprob} = $data[7]; $factors->{maxS} = $data[9]; $feature->{meanSprob}= $data[10]; $factors->{meanS} = $data[11]; $feature->{Dprob} = $data[12]; $factors->{D} = $data[13]; #It looks like the max Y position is reported as the most likely cleavage position $feature->{end} = $data[5]; $feature->{nnPrediction} = 'signal-peptide'; if($method eq 'both'){ $feature->{hmmPrediction} = $data[15] eq 'Q' ? 'Non-secretory protein' : 'Signal peptide'; $feature->{cleavageSiteProb} = $data[16]; $feature->{peptideProb} = $data[19]; } } elsif($method eq 'hmm'){ #In short output anchor probability is not given $feature->{hmmPrediction} = $data[1] eq 'Q' ? 'Non-secretory protein' : 'Signal peptide'; $feature->{cleavageSiteProb} = $data[2]; $feature->{peptideProb} = $data[5]; #It looks like the max cleavage probability position is given by the Cmax proability $feature->{end} = $data[3]; } #Unfortunately, we cannot parse the filters for hmm method. if($self->_filterok($factors)){ $feature->{name} = $self->seqname(); $feature->{start} = 1; $feature->{source} = 'Signalp'; $feature->{primary} = 'signal_peptide'; $feature->{program} = 'Signalp'; $feature->{logic_name} = 'signal_peptide'; my $new_feat = $self->create_feature($feature); push @{$self->{_features}}, $new_feat if $new_feat; } } return; } =head2 create_feature Title : create_feature Usage : obj->create_feature(\%feature) Function: Internal(not to be used directly) Returns : Args : =cut sub create_feature { my ($self, $feat) = @_; #If we don't have neither start nor end, we return. unless($feat->{name} && $feat->{start} && $feat->{end}){ return; } # create feature object my $feature = Bio::SeqFeature::Generic->new( -seq_id => $feat->{name}, -start => $feat->{start}, -end => $feat->{end}, -score => defined($feat->{peptideProb}) ? $feat->{peptideProb} : '', -source => 'Signalp', -primary => 'signal_peptide', -logic_name => 'signal_peptide', ); $feature->add_tag_value('peptideProb', $feat->{peptideProb}); $feature->add_tag_value('anchorProb', $feat->{anchorProb}); $feature->add_tag_value('evalue',$feat->{anchorProb}); $feature->add_tag_value('percent_id','NULL'); $feature->add_tag_value("hid",$feat->{primary}); $feature->add_tag_value('signalpPrediction', $feat->{hmmPrediction}); $feature->add_tag_value('cleavageSiteProb', $feat->{cleavageSiteProb}) if($feat->{cleavageSiteProb}); $feature->add_tag_value('nnPrediction', $feat->{nnPrediction}) if($feat->{nnPrediction}); $feature->add_tag_value('maxCprob', $feat->{maxCprob}) if(defined($feat->{maxCprob})); $feature->add_tag_value('maxSprob', $feat->{maxSprob}) if(defined($feat->{maxSprob})); $feature->add_tag_value('maxYprob', $feat->{maxYprob}) if(defined($feat->{maxYprob})); $feature->add_tag_value('meanSprob', $feat->{meanSprob}) if(defined($feat->{meanSprob})); $feature->add_tag_value('Dprob', $feat->{Dprob}) if(defined($feat->{Dprob})); return $feature; } =head2 seqname Title : seqname Usage : obj->seqname($name) Function: Internal(not to be used directly) Returns : Args : =cut sub seqname{ my ($self,$seqname)=@_; if (defined($seqname)){ $self->{'seqname'} = $seqname; } return $self->{'seqname'}; } 1; ��������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Sim4����������������������������������������������������������������������000755��000765��000024�� 0�12254227336� 15732� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Sim4/Exon.pm��������������������������������������������������������������000444��000765��000024�� 12462�12254227336� 17363� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Sim4::Exon # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney-at-sanger.ac.uk> # and Hilmar Lapp <hlapp-at-gmx.net> # # Copyright Ewan Birney, Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Sim4::Exon - A single exon determined by an alignment =head1 SYNOPSIS # See Bio::Tools::Sim4::Results for a description of the context. # an instance of this class is-a Bio::SeqFeature::SimilarityPair # coordinates of the exon (recommended way): print "exon from ", $exon->start(), " to ", $exon->end(), "\n"; # the same (feature1() inherited from Bio::SeqFeature::FeaturePair) print "exon from ", $exon->feature1()->start(), " to ", $exon->feature1()->end(), "\n"; # also the same (query() inherited from Bio::SeqFeature::SimilarityPair): print "exon from ", $exon->query()->start(), " to ", $exon->query()->end(), "\n"; # coordinates on the matching EST (recommended way): print "matches on EST from ", $exon->est_hit()->start(), " to ", $exon->est_hit()->end(), "\n"; # the same (feature2() inherited from Bio::SeqFeature::FeaturePair) print "matches on EST from ", $exon->feature2()->start(), " to ", $exon->feature2()->end(), "\n"; # also the same (subject() inherited from Bio::SeqFeature::SimilarityPair): print "exon from ", $exon->subject()->start(), " to ", $exon->subject()->end(), "\n"; =head1 DESCRIPTION This class inherits from Bio::SeqFeature::SimilarityPair and represents an exon on a genomic sequence determined by similarity, that is, by aligning an EST sequence (using Sim4 in this case). Consequently, the notion of query and subject is always from the perspective of the genomic sequence: query refers to the genomic seq, subject to the aligned EST hit. Because of this, $exon-E<gt>start(), $exon-E<gt>end() etc will always return what you expect. To get the coordinates on the matching EST, refer to the properties of the feature returned by L<est_hit>(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney, Hilmar Lapp Ewan Birney E<lt>birney-at-sanger.ac.ukE<gt> Hilmar Lapp E<lt>hlapp-at-gmx.netE<gt> or E<lt>hilmar.lapp-at-pharma.novartis.comE<gt>. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Sim4::Exon; use strict; use base qw(Bio::SeqFeature::SimilarityPair); sub new { my ($class,@args) = @_; my %param = @args; my $self = $class->SUPER::new(@args); my ($prim, $prim_tag, $source, $source_tag) = $self->_rearrange([qw(PRIMARY PRIMARY_TAG SOURCE SOURCE_TAG)], @args); $self->primary_tag('exon') unless $prim || $prim_tag; $self->source_tag('Sim4') unless $source || $source_tag; $self->strand(0) unless defined($self->strand()); $self->query(); return $self; } =head2 percentage_id Title : percentage_id Usage : $obj->percentage_id($newval) Function: This is a synonym for 100 * $obj->est_hit()->frac_identical(). Returns : value of percentage_id Args : newvalue (optional) =cut sub percentage_id { my ($self, @args) = @_; my $frac; my $val; my $delegated = 0; if(@args) { $frac = $args[0]; $frac /= 100.0 if defined($frac); } if($self->query()->can('frac_identical')) { if(defined($frac)) { $self->query()->frac_identical($frac); } $val = 100.0 * $self->query()->frac_identical(); $delegated = 1; } if($self->est_hit()->can('frac_identical')) { if(defined($frac)) { $self->est_hit()->frac_identical($frac); } # this intentiously overwrites previous $val $val = 100.0 * $self->est_hit()->frac_identical(); $delegated = 1; } if(! $delegated) { if(@args) { $val = shift(@args); $self->{'percentage_id'} = $val; } else { $val = $self->{'percentage_id'}; } } return $val; } =head2 est_hit Title : est_hit Usage : $est_feature = $obj->est_hit(); Function: Returns the EST hit pointing to (i.e., aligned to by Sim4) this exon (i.e., genomic region). At present, merely a synonym for $obj->feature2(). Returns : An Bio::SeqFeatureI implementing object. Args : =cut sub est_hit { my $self = shift; return $self->feature2(@_); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Sim4/Results.pm�����������������������������������������������������������000444��000765��000024�� 35540�12254227326� 20114� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Sim4::Results # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ewan Birney <birney-at-sanger.ac.uk> # and Hilmar Lapp <hlapp-at-gmx.net> # # Copyright Ewan Birney and Hilmar Lapp # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Sim4::Results - Results of one Sim4 run =head1 SYNOPSIS # to preset the order of EST and genomic file as given on the sim4 # command line: my $sim4 = Bio::Tools::Sim4::Results->new(-file => 'result.sim4', -estfirst => 1); # to let the order be determined automatically (by length comparison): $sim4 = Bio::Tools::Sim4::Results->new( -file => 'sim4.results' ); # filehandle: $sim4 = Bio::Tools::Sim4::Results->new( -fh => \*INPUT ); # parse the results while(my $exonset = $sim4->next_exonset()) { # $exonset is-a Bio::SeqFeature::Generic with Bio::Tools::Sim4::Exons # as sub features print "Delimited on sequence ", $exonset->seq_id(), "from ", $exonset->start(), " to ", $exonset->end(), "\n"; foreach my $exon ( $exonset->sub_SeqFeature() ) { # $exon is-a Bio::SeqFeature::FeaturePair print "Exon from ", $exon->start, " to ", $exon->end, " on strand ", $exon->strand(), "\n"; # you can get out what it matched using the est_hit attribute my $homol = $exon->est_hit(); print "Matched to sequence ", $homol->seq_id, " at ", $homol->start," to ", $homol->end, "\n"; } } # essential if you gave a filename at initialization (otherwise the file # stays open) $sim4->close(); =head1 DESCRIPTION The sim4 module provides a parser and results object for sim4 output. The sim4 results are specialised types of SeqFeatures, meaning you can add them to AnnSeq objects fine, and manipulate them in the "normal" seqfeature manner. The sim4 Exon objects are Bio::SeqFeature::FeaturePair inherited objects. The $esthit = $exon-E<gt>est_hit() is the alignment as a feature on the matching object (normally, an EST), in which the start/end points are where the hit lies. To make this module work sensibly you need to run sim4 genomic.fasta est.database.fasta or sim4 est.fasta genomic.database.fasta To get the sequence identifiers recorded for the first sequence, too, use A=4 as output option for sim4. One fiddle here is that there are only two real possibilities to the matching criteria: either one sequence needs reversing or not. Because of this, it is impossible to tell whether the match is in the forward or reverse strand of the genomic DNA. We solve this here by assuming that the genomic DNA is always forward. As a consequence, the strand attribute of the matching EST is unknown, and the strand attribute of the genomic DNA (i.e., the Exon object) will reflect the direction of the hit. See the documentation of parse_next_alignment() for abilities of the parser to deal with the different output format options of sim4. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ewan Birney, Hilmar Lapp Ewan Birney E<lt>birney-at-sanger.ac.ukE<gt> Hilmar Lapp E<lt>hlapp-at-gmx.netE<gt> or E<lt>hilmar.lapp-at-pharma.novartis.comE<gt>. =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Sim4::Results; use strict; use File::Basename; use Bio::Root::Root; use Bio::Tools::Sim4::Exon; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my($self,@args) = @_; # call the inherited method first my $make = $self->SUPER::_initialize_state(@args); my ($est_is_first) = $self->_rearrange([qw(ESTFIRST)], @args); delete($self->{'_est_is_first'}); $self->{'_est_is_first'} = $est_is_first if(defined($est_is_first)); $self->analysis_method("Sim4"); } =head2 analysis_method Usage : $sim4->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /sim4/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /sim4/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 parse_next_alignment Title : parse_next_alignment Usage : @exons = $sim4_result->parse_next_alignment; foreach $exon (@exons) { # do something } Function: Parses the next alignment of the Sim4 result file and returns the found exons as an array of Bio::Tools::Sim4::Exon objects. Call this method repeatedly until an empty array is returned to get the results for all alignments. The $exon->seq_id() attribute will be set to the identifier of the respective sequence for both sequences if A=4 was used in the sim4 run, and otherwise for the second sequence only. If the output does not contain the identifier, the filename stripped of path and extension is used instead. In addition, the full filename will be recorded for both features ($exon inherits off Bio::SeqFeature::SimilarityPair) as tag 'filename'. The length is accessible via the seqlength() attribute of $exon->query() and $exon->est_hit(). Note that this method is capable of dealing with outputs generated with format 0,1,3, and 4 (via the A=n option to sim4). It automatically determines which of the two sequences has been reversed, and adjusts the coordinates for that sequence. It will also detect whether the EST sequence(s) were given as first or as second file to sim4, unless this has been specified at creation time of the object. Example : Returns : An array of Bio::Tools::Sim4::Exon objects Args : =cut sub parse_next_alignment { my ($self) = @_; my @exons = (); my %seq1props = (); my %seq2props = (); # we refer to the properties of each seq by reference my ($estseq, $genomseq, $to_reverse); my $started = 0; my $hit_direction = 1; my $output_fmt = 3; # same as 0 and 1 (we cannot deal with A=2 produced # output yet) while(defined($_ = $self->_readline())) { #chomp(); # # bascially, each sim4 'hit' starts with seq1... # /^seq1/ && do { if($started) { $self->_pushback($_); last; } $started = 1; # filename and length of seq 1 /^seq1\s+=\s+(\S+)\,\s+(\d+)/ || $self->throw("Sim4 parsing error on seq1 [$_] line. Sorry!"); $seq1props{'filename'} = $1; $seq1props{'length'} = $2; next; }; /^seq2/ && do { # the second hit has also the database name in the >name syntax # (in brackets). /^seq2\s+=\s+(\S+)\s+\(>?(\S+)\s*\)\,\s+(\d+)/|| $self->throw("Sim4 parsing error on seq2 [$_] line. Sorry!"); $seq2props{'filename'} = $1; $seq2props{'seqname'} = $2; $seq2props{'length'} = $3; next; }; if(/^>(\S+)\s*(.*)$/) { # output option was A=4, which not only gives the complete # description lines, but also causes the longer sequence to be # reversed if the second file contained one (genomic) sequence $seq1props{'seqname'} = $1; $seq1props{'description'} = $2 if $2; $output_fmt = 4; # we handle seq1 and seq2 both here if(defined($_ = $self->_readline()) && (/^>(\S+)\s*(.*)$/)) { $seq2props{'seqname'} = $1; # redundant, since already set above $seq2props{'description'} = $2 if $2; } next; } /^\(complement\)/ && do { $hit_direction = -1; next; }; # this matches # start-end (start-end) pctid% if(/(\d+)-(\d+)\s+\((\d+)-(\d+)\)\s+(\d+)%/) { $seq1props{'start'} = $1; $seq1props{'end'} = $2; $seq2props{'start'} = $3; $seq2props{'end'} = $4; my $pctid = $5; if(! defined($estseq)) { # for the first time here: need to set the references referring # to seq1 and seq2 if(! exists($self->{'_est_is_first'})) { # detect which one is the EST by looking at the lengths, # and assume that this holds throughout the entire result # file (i.e., when this method is called for the next # alignment, this will not be checked again) if($seq1props{'length'} > $seq2props{'length'}) { $self->{'_est_is_first'} = 0; } else { $self->{'_est_is_first'} = 1; } } if($self->{'_est_is_first'}) { $estseq = \%seq1props; $genomseq = \%seq2props; # if the EST is given first, A=4 selects the genomic # seq for being reversed (reversing the EST is default) $to_reverse = ($output_fmt == 4) ? $genomseq : $estseq; } else { $estseq = \%seq2props; $genomseq = \%seq1props; # if the EST is the second, A=4 does not change the # seq being reversed (always the EST is reversed) $to_reverse = $estseq; } } if($hit_direction == -1) { # we have to reverse the coordinates of one of both seqs my $tmp = $to_reverse->{'start'}; $to_reverse->{'start'} = $to_reverse->{'length'} - $to_reverse->{'end'} + 1; $to_reverse->{'end'} = $to_reverse->{'length'} - $tmp + 1; } # create and initialize the exon object my $exon = Bio::Tools::Sim4::Exon->new( '-start' => $genomseq->{'start'}, '-end' => $genomseq->{'end'}, '-strand' => $hit_direction); if(exists($genomseq->{'seqname'})) { $exon->seq_id($genomseq->{'seqname'}); } else { # take filename stripped of path as fall back my ($basename) = &File::Basename::fileparse($genomseq->{'filename'}, '\..*'); $exon->seq_id($basename); } $exon->feature1()->add_tag_value('filename', $genomseq->{'filename'}); # feature1 is supposed to be initialized to a Similarity object, # but we provide a safety net if($exon->feature1()->can('seqlength')) { $exon->feature1()->seqlength($genomseq->{'length'}); } else { $exon->feature1()->add_tag_value('SeqLength', $genomseq->{'length'}); } # create and initialize the feature wrapping the 'hit' (the EST) my $fea2 = Bio::SeqFeature::Similarity->new( '-start' => $estseq->{'start'}, '-end' => $estseq->{'end'}, '-strand' => 0, '-primary' => "aligning_EST"); if(exists($estseq->{'seqname'})) { $fea2->seq_id($estseq->{'seqname'}); } else { # take filename stripped of path as fall back my ($basename) = &File::Basename::fileparse($estseq->{'filename'}, '\..*'); $fea2->seq_id($basename); } $fea2->add_tag_value('filename', $estseq->{'filename'}); $fea2->seqlength($estseq->{'length'}); # store $exon->est_hit($fea2); # general properties $exon->source_tag($self->analysis_method()); $exon->percentage_id($pctid); $exon->score($exon->percentage_id()); # push onto array push(@exons, $exon); next; # back to while loop } } return @exons; } =head2 next_exonset Title : next_exonset Usage : $exonset = $sim4_result->parse_next_exonset; print "Exons start at ", $exonset->start(), "and end at ", $exonset->end(), "\n"; foreach $exon ($exonset->sub_SeqFeature()) { # do something } Function: Parses the next alignment of the Sim4 result file and returns the set of exons as a container of features. The container is itself a Bio::SeqFeature::Generic object, with the Bio::Tools::Sim4::Exon objects as sub features. Start, end, and strand of the container will represent the total region covered by the exons of this set. See the documentation of parse_next_alignment() for further reference about parsing and how the information is stored. Example : Returns : An Bio::SeqFeature::Generic object holding Bio::Tools::Sim4::Exon objects as sub features. Args : =cut sub next_exonset { my $self = shift; my $exonset; # get the next array of exons my @exons = $self->parse_next_alignment(); unless( @exons ) { return if eof($self->_fh); return $self->next_exonset; } # create the container of exons as a feature object itself, with the # data of the first exon for initialization $exonset = Bio::SeqFeature::Generic->new('-start' => $exons[0]->start(), '-end' => $exons[0]->end(), '-strand' => $exons[0]->strand(), '-primary' => "ExonSet"); $exonset->source_tag($exons[0]->source_tag()); $exonset->seq_id($exons[0]->seq_id()); # now add all exons as sub features, with enabling EXPANsion of the region # covered in total foreach my $exon (@exons) { $exonset->add_sub_SeqFeature($exon, 'EXPAND'); } return $exonset; } =head2 next_feature Title : next_feature Usage : while($exonset = $sim4->next_feature()) { # do something } Function: Does the same as L<next_exonset()>. See there for documentation of the functionality. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_exonset() at present. Example : Returns : A Bio::SeqFeature::Generic object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_exonset doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_exonset(@args); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SiRNA���������������������������������������������������������������������000755��000765��000024�� 0�12254227330� 16024� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SiRNA/Ruleset�������������������������������������������������������������000755��000765��000024�� 0�12254227334� 17453� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/SiRNA/Ruleset/saigo.pm����������������������������������������������������000444��000765��000024�� 12730�12254227334� 21273� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tools::SiRNA::Ruleset::saigo # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Bristol-Myers Squibb # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::SiRNA::Ruleset::saigo - Perl object implementing the Saigo group's rules for designing small inhibitory RNAs =head1 SYNOPSIS Do not use this module directly. Instead, use Bio::Tools::SiRNA and specify the saigo ruleset: use Bio::Tools::SiRNA; my $sirna_designer = Bio::Tools::SiRNA->new( -target => $bio_seq, -rules => 'saigo' ); my @pairs = $sirna_designer->design; foreach $pair (@pairs) { my $sense_oligo_sequence = $pair->sense->seq; my $antisense_oligo_sequence = $pair->antisense->seq; # print out results print join ("\t", $pair->start, $pair->end, $pair->rank, $sense_oligo_sequence, $antisense_oligo_sequence), "\n"; } =head1 DESCRIPTION This package implements the rules for designing siRNA reagents published by Ui-Tei et al (2004). The rules are: =over 5 =item 1. The first base in the sense strand of the duplex must be a G or C =item 2. The first base in the antisense strand of the duplex must be an A or U =item 3. The first 7 nucleotides in the antisense strand of the duplex must be A or U =item 4. There cannot be more than 9 consecutive G or C nucleotides =item 5. The first 12 nucleotides in the sense strand of the duplex should have 33-66% GC =back The module inherits from Bio::Tools::SiRNA. See the documentation for that module for information on how to specify the target and recover the SiRNA duplex information. =head2 EXPORT None. =head1 SEE ALSO L<Bio::Tools::SiRNA>, L<Bio::SeqFeature::SiRNA::Pair>, L<Bio::SeqFeature::SiRNA::Oligo>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Donald Jackson (donald.jackson@bms.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::SiRNA::Ruleset::saigo; use strict; use warnings; use base qw(Bio::Tools::SiRNA); =head2 new Title : new Usage : Do not call directly - use Bio::Tools::SiRNA->new instead. Returns : Bio::Tools::SiRNA::Ruleset::saigo object Args : none =cut sub new { my ($proto, %args) = @_; my $class = ref($proto) || $proto; $args{'RULES'} = 'saigo'; return $class->SUPER::new(%args); } sub _get_oligos { my ($self) = @_; my ($targseq, $targstart) = $self->_get_targetregion; foreach my $i (0 .. (length($targseq) - 23)) { my $testseq = substr($targseq, $i, 23); $self->add_oligos($testseq, $targstart + $i + 1) if ($self->_oligo_ok($testseq)); } } sub _get_sense { my ($self, $target) = @_; #trim off 1st 2 nt to get overhang $target =~ s/^..//; #convert T's to U's (transcribe) $target =~ s/T/U/gi; return $target; } sub _get_anti { my ($self, $target) = @_; my @target = split(//, $target); my ($nt,@antitarget); while ($nt = pop @target) { push(@antitarget, $self->_comp($nt)); } my $anti = join('', @antitarget); #trim off 1st 2 nt to get overhang $anti =~ s/^..//; #convert T's to U's $anti =~ s/T/U/gi; return $anti; } sub _oligo_ok { my ($self, $testseq) = @_; $self->debug("Testing $testseq...\n"); my @testseq = split(//, $testseq); # is 5p end of sense strand a G/C? unless ($testseq[2] =~ /[GC]/i) { $self->debug("No G/C at sense 5' end\n"); return 0; } # is 5p end of antisense strand an A/T? unless ($testseq[20] =~ /[AT]/i) { $self->debug("No A/T at antisense 5' end\n"); return 0; } # are 4 of the last 7 bases in the duplex A/T? my $atcount_3p = grep { /[AT]/i } @testseq[14 .. 20]; unless ($atcount_3p >= 4) { $self->debug("Found $atcount_3p A/T in last 7 bases of duplex\n"); return 0; } # what is gc fraction in rest of duplex? Target: 33 to 66 pct gc (4-8 of 12) my $gccount_5p = grep { /[GC]/i } @testseq[2 .. 13]; if ($gccount_5p < 4) { $self->debug("Found only $gccount_5p GCs in 5p end of duplex\n"); return 0; } if ($gccount_5p > 8) { $self->debug("Found only $gccount_5p GCs in 5p end of duplex\n"); return 0; } # no more than 9 consecutive GC if ($testseq =~ /[GC]{9,}?/i) { $self->debug("Found more than 9 consecutive GCs\n"); return 0; } $self->debug("Oligo passed \n"); return 1; } 1; ����������������������������������������BioPerl-1.6.923/Bio/Tools/SiRNA/Ruleset/tuschl.pm���������������������������������������������������000444��000765��000024�� 12637�12254227330� 21475� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # # BioPerl module for Bio::Tools::SiRNA::Ruleset::tuschl # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Donald Jackson, donald.jackson@bms.com # # Copyright Bristol-Myers Squibb # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::SiRNA::Ruleset::tuschl - Perl object implementing the tuschl group's rules for designing small inhibitory RNAs =head1 SYNOPSIS Do not use this module directly. Instead, use Bio::Tools::SiRNA and specify the tuschl ruleset: use Bio::Tools::SiRNA; my $sirna_designer = Bio::Tools::SiRNA->new( -target => $bio_seq, -rules => 'tuschl' ); my @pairs = $sirna_designer->design; foreach $pair (@pairs) { my $sense_oligo_sequence = $pair->sense->seq; my $antisense_oligo_sequence = $pair->antisense->seq; # print out results print join ("\t", $pair->start, $pair->end, $pair->rank, $sense_oligo_sequence, $antisense_oligo_sequence), "\n"; } =head1 DESCRIPTION This package implements the rules for designing siRNA reagents developed by Tuschl and colleagues (see http://www.rockefeller.edu/labheads/tuschl/sirna.html). It looks for oligos that match the following patterns in the target sequence: 1. AA(N19)TT (rank 1) 2. AA(N21) (rank 2) 3. NA(N21) (rank 3) The package also supports selection of siRNA seqences that can be transcribed by pol3: A[A,G]N17[C,T] =head1 SEE ALSO L<Bio::Tools::SiRNA>, L<Bio::SeqFeature::SiRNA::Pair>, L<Bio::SeqFeature::SiRNA::Oligo>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Donald Jackson (donald.jackson@bms.com) =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tools::SiRNA::Ruleset::tuschl; use strict; use warnings; use base qw(Bio::Tools::SiRNA); our %PATTERNS = ( 1 => '(AA.{19}TT)', 2 => '(AA.{19}[ACG][ACG])', 3 => '([CGT]A.{21})', Pol3 => '(.A[AG].{17}[CT]..)' ); our $DEFAULT_CUTOFF = 2; =head2 new Title : new Usage : Do not call directly - use Bio::Tools::SiRNA->new instead. Returns : Bio::Tools::SiRNA::Ruleset::saigo object Args : none =cut sub new { my ($proto, %args) = @_; my $class = ref($proto) || $proto; $args{'RULES'} = 'tuschl'; return $class->SUPER::new(%args); } sub _regex { my ($self, $rank) = @_; return $PATTERNS{$rank}; } sub cutoff { my ($self, $cutoff) = @_; if ($cutoff) { $self->{'cutoff'} = $cutoff; } elsif (!$self->{'cutoff'}) { $self->{'cutoff'} = $DEFAULT_CUTOFF; } return $self->{'cutoff'}; } sub _get_oligos { #use regular expressions to pull out oligos my ($self) = @_; my @ranks; if ($self->cutoff eq 'pol3') { @ranks = ('pol3'); } else { @ranks = (1 .. $self->cutoff); } foreach my $rank (@ranks) { my $regex = $self->_regex($rank); #my @exclude; # my ($targregion) = grep { $_->primary_tag eq 'Target' } $self->target->top_SeqFeatures; # my $seq = $targregion->seq->seq; # # but this way I loose start info # my $targstart = $targregion->start; my ($seq, $targstart) = $self->_get_targetregion(); while ( $seq =~ /(.*?)$regex/gi ) { my $target = $2; # check for too many Gs (or Cs on the other strand) next if ( $target =~ /G{ $self->gstring,}/io ); next if ( $target =~ /C{ $self->gstring,}/io ); # skip Ns (for filtering) next if ( $target =~ /N/i); my $start = length($1) + $targstart; my $stop = $start + length($target) -1; my @gc = ( $target =~ /G|C/gi); my $fxGC = sprintf("%2.2f", (scalar(@gc) / length($target))); next if ($fxGC < $self->min_gc); next if ($fxGC > $self->max_gc); $self->add_oligos($target, $start, $rank); } } } sub _get_sense { my ($self, $target) = @_; # trim off 1st 2 nt to get overhang $target =~ s/^..//; # convert T's to U's (transcribe) $target =~ s/T/U/gi; # force last 2 nt to be T's $target =~ s/..$/TT/; return $target; } sub _get_anti { my ($self, $target) = @_; my @target = split(//, $target); my ($nt,@antitarget); while ($nt = pop @target) { push(@antitarget, $self->_comp($nt)); } my $anti = join('', @antitarget); # trim off 1st 2 nt to get overhang $anti =~ s/^..//; # convert T's to U's $anti =~ s/T/U/gi; # convert last 2 NT's to T $anti =~ s/..$/TT/; return $anti; } 1; �������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Spidey��������������������������������������������������������������������000755��000765��000024�� 0�12254227334� 16351� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Spidey/Exon.pm������������������������������������������������������������000555��000765��000024�� 14226�12254227334� 20005� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Spidey::Exon # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ryan Golhar <golharam@umdnj.edu> # # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Spidey::Exon - A single exon determined by an alignment =head1 SYNOPSIS # See Bio::Tools::Spidey::Results for a description of the context. # an instance of this class is-a Bio::SeqFeature::SimilarityPair # coordinates of the exon (recommended way): print "exon from ", $exon->start(), " to ", $exon->end(), "\n"; # the same (feature1() inherited from Bio::SeqFeature::FeaturePair) print "exon from ", $exon->feature1()->start(), " to ", $exon->feature1()->end(), "\n"; # also the same (query() inherited from Bio::SeqFeature::SimilarityPair): print "exon from ", $exon->query()->start(), " to ", $exon->query()->end(), "\n"; # coordinates on the matching EST (recommended way): print "matches on EST from ", $exon->est_hit()->start(), " to ", $exon->est_hit()->end(), "\n"; # the same (feature2() inherited from Bio::SeqFeature::FeaturePair) print "matches on EST from ", $exon->feature2()->start(), " to ", $exon->feature2()->end(), "\n"; # also the same (subject() inherited from Bio::SeqFeature::SimilarityPair): print "exon from ", $exon->subject()->start(), " to ", $exon->subject()->end(), "\n"; =head1 DESCRIPTION This class inherits from Bio::SeqFeature::SimilarityPair and represents an exon on a genomic sequence determined by similarity, that is, by aligning an EST sequence (using Spidey in this case). Consequently, the notion of query and subject is always from the perspective of the genomic sequence: query refers to the genomic seq, subject to the aligned EST hit. Because of this, $exon-E<gt>start(), $exon-E<gt>end() etc will always return what you expect. To get the coordinates on the matching EST, refer to the properties of the feature returned by L<est_hit>(). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ryan Golhar Email golharam@umdnj.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Spidey::Exon; use strict; use base qw(Bio::SeqFeature::SimilarityPair); sub new { my ($class,@args) = @_; my %param = @args; my $self = $class->SUPER::new(@args); my ($prim, $prim_tag, $source, $source_tag) = $self->_rearrange([qw(PRIMARY PRIMARY_TAG SOURCE SOURCE_TAG)], @args); $self->primary_tag('exon') unless $prim || $prim_tag; $self->source_tag('Spidey') unless $source || $source_tag; $self->strand(0) unless defined($self->strand()); $self->query(); return $self; } =head2 percentage_id Title : percentage_id Usage : $obj->percentage_id Function: This is the percent id as reported by Spidey Returns : value of percentage_id Args : =cut sub percentage_id { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'percentage_id'} = $val; } else { $val = $self->{'percentage_id'}; } return $val; } =head2 est_hit Title : est_hit Usage : $est_feature = $obj->est_hit(); Function: Returns the EST hit pointing to (i.e., aligned to by Spidey) this exon (i.e., genomic region). At present, merely a synonym for $obj->feature2(). Returns : An Bio::SeqFeatureI implementing object. Args : =cut sub est_hit { my $self = shift; return $self->feature2(@_); } =head2 mismatches Title : mismatches Usage : $obj->mismatches; Function: Returns the mismatches of the cDNA to (i.e., aligned to by Spidey) this exon (i.e., genomic region). Returns : value of mismatches. Args : =cut sub mismatches { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'mismatches'} = $val; } else { $val = $self->{'mismatches'}; } return $val; } =head2 gaps Title : gaps Usage : $obj->gaps; Function: Returns the gaps of the cDNA to (i.e., aligned to by Spidey) this exon (i.e., genomic region). Returns : value of gaps. Args : =cut sub gaps { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'gaps'} = $val; } else { $val = $self->{'gaps'}; } return $val; } =head2 donor Title : donor Usage : $obj->donor; Function: Returns 0 if a splice donor site does not exist, or 1 if a splice donor site exists Returns : value of existence of donor splice site (0 or 1) Args : =cut sub donor { my ($self, @args) = @_; my $val; if (@args) { $val = shift @args; $self->{'donor'} = $val; } else { $val = $self->{'donor'}; } return $val; } =head2 acceptor Title : acceptor Usage : $obj->acceptor; Function: Returns 0 if a splice acceptor site does not exist, or 1 if a splice acceptor site exists Returns : value of existence of acceptor splice site (0 or 1) Args : =cut sub acceptor { my ($self, @args) = @_; my $val; if (@args) { $val = shift @args; $self->{'acceptor'} = $val; } else { $val = $self->{'acceptor'}; } return $val; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tools/Spidey/Results.pm���������������������������������������������������������000555��000765��000024�� 34377�12254227315� 20545� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tools::Spidey::Results # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Ryan Golhar <golharam@umdnj.edu> # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tools::Spidey::Results - Results of a Spidey run =head1 SYNOPSIS use Bio::Tools::Spidey::Results; my $spidey = Bio::Tools::Spidey::Results->new(-file => 'result.spidey' ); # or my $spidey = Bio::Tools::Spidey::Results->new( -fh => \*INPUT ); # get the exons before doing anything else my $exonset = $spidey->next_exonset(); # parse the results my @exons = $exonset->sub_SeqFeature(); print "Total no of Exons: ", scalar(@exons), "\n"; print "Genomic sequence length: ", $spidey->genomic_dna_length(), "\n"; # $exonset is-a Bio::SeqFeature::Generic with Bio::Tools::Spidey::Exons # as sub features print "Delimited on sequence ", $exonset->seq_id(), " from ", $exonset->start(), " to ", $exonset->end(), "\n"; foreach my $exon ( $exonset->sub_SeqFeature() ) { # $exon is-a Bio::SeqFeature::FeaturePair print "Exon from ", $exon->start, " to ", $exon->end, " on strand ", $exon->strand(), "\n"; # you can get out what it matched using the est_hit attribute my $homol = $exon->est_hit(); print "Matched to sequence ", $homol->seq_id, " at ", $homol->start," to ", $homol->end, "\n"; } # essential if you gave a filename at initialization (otherwise # the file stays open) $spidey->close(); =head1 DESCRIPTION The spidey module provides a parser and results object for spidey output. The spidey results are specialised types of SeqFeatures, meaning you can add them to AnnSeq objects fine, and manipulate them in the "normal" seqfeature manner. The spidey Exon objects are Bio::SeqFeature::FeaturePair inherited objects. The $esthit = $exon-E<gt>est_hit() is the alignment as a feature on the matching object (normally, a cDNA), in which the start/end points are where the hit lies. To make this module work sensibly you need to run spidey -i genomic.fasta -m cDNA.fasta =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Ryan Golhar Email golharam@umdnj.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tools::Spidey::Results; use strict; use File::Basename; use Bio::Root::Root; use Bio::Tools::Spidey::Exon; use base qw(Bio::Tools::AnalysisResult); sub _initialize_state { my($self,@args) = @_; # call the inherited method first my $make = $self->SUPER::_initialize_state(@args); # my ($est_is_first) = $self->_rearrange([qw(ESTFIRST)], @args); # delete($self->{'_est_is_first'}); # $self->{'_est_is_first'} = $est_is_first if(defined($est_is_first)); $self->analysis_method("Spidey"); } =head2 analysis_method Usage : $spidey->analysis_method(); Purpose : Inherited method. Overridden to ensure that the name matches /Spidey/i. Returns : String Argument : n/a =cut #------------- sub analysis_method { #------------- my ($self, $method) = @_; if($method && ($method !~ /Spidey/i)) { $self->throw("method $method not supported in " . ref($self)); } return $self->SUPER::analysis_method($method); } =head2 parse_next_alignment Title : parse_next_alignment Usage : @exons = $spidey_result->parse_next_alignment; foreach $exon (@exons) { # do something } Function: Parses the next alignment of the Spidey result file and returns the found exons as an array of Bio::Tools::Spidey::Exon objects. Call this method repeatedly until an empty array is returned to get the results for all alignments. Example : Returns : An array of Bio::Tools::Spidey::Exon objects Args : =cut sub parse_next_alignment { my ($self) = @_; # for strand 1 = plus, -1 = minus my ($started,$version,$strand, $exoncount) = (0,0,0,-1); my (%seq1props,%seq2props,@exons); # we refer to the properties of each seq by reference while(defined($_ = $self->_readline())) { chomp; # # bascially, parse a Spidey result... # # matches: --SPIDEY version 1.40-- if( /^--SPIDEY\s+version\s+(\d+\.\d+)--/) { if($started) { $self->_pushback($_); return \@exons; } $version = $1; if ($version != 1.40) { $self->throw("Spidey parser only designed to work with Spidey v1.40\n"); } $started = 1; } elsif (/^Genomic:\s+(\S+)\s.*,\s+(\d+)\sbp$/ ) { # matches: Genomic: lcl|some_name other information, 1234 bp # $seq1props{'filename'} = $1; $seq1props{'seqname'} = $1; $seq1props{'length'} = $2; $self->genomic_dna_length($seq1props{'length'}); } elsif( /^mRNA:\s+(\S+)\s.*,(?:\s+mRNA\s+sequence,)?\s(\d+)\sbp$/ ) { # matches: mRNA: # $seq2props{'filename'} = $1; $seq2props{'seqname'} = $1; $seq2props{'length'} = $2; } elsif( /^Strand:/ ) { if (/plus/) { $strand = 1; } else { $strand = -1; } } elsif( /^Number of exons: (\d+)/ ) { $exoncount = $1; my ($genomic_start, $genomic_stop, $cdna_start, $cdna_stop, $id, $mismatches, $gaps, $splice_donor, $splice_acceptor, $uncertain); # the next $exoncount lines contains information # about the matches of each exon. we should parse # this information here for (my $ec = 1; $ec <= $exoncount; $ec++) { if (defined($_ = $self->_readline())) { chomp; if (/^Exon\s$ec[\(\)-]*:\s(\d+)-(\d+)\s\(gen\)\s+(\d+)-(\d+)\s\(mRNA\)\s+id\s([\d\.inf-]+)%\s+mismatches\s(\d+)\s+gaps\s(\d+)\s+splice\ssite\s\(d\s+a\):\s(\d+)\s+(\d+)\s*(\w*)/) { $genomic_start = $1; $genomic_stop = $2; $cdna_start = $3; $cdna_stop = $4; $id = $5; $mismatches = $6; $gaps = $7; $splice_donor = $8; $splice_acceptor = $9; $uncertain = $10; } else { $self->throw( "Failed to match anything:\n$_\n"); } my $exon = Bio::Tools::Spidey::Exon->new (-start => $genomic_start, -end => $genomic_stop, -strand => $strand); $exon->seq_id($seq1props{'seqname'}); # feature1 is supposed to be initialized to a Similarity object, but we provide a safety net if ($exon->feature1->can('seqlength')) { $exon->feature1->seqlength($seq1props{'length'}); } else { $exon->feature1->add_tag_value('seqlength', $seq1props{'length'}); } # create and initialize the feature wrapping the 'hit' (the cDNA) my $fea2 = Bio::SeqFeature::Similarity->new (-start => $cdna_start, -end => $cdna_stop, -strand => $strand, -seq_id => $seq2props{'seqname'}, -primary => "aligning_cDNA"); $fea2->seqlength($seq2props{'length'}); # store $exon->est_hit($fea2); # general properties $exon->source_tag($self->analysis_method()); $exon->percentage_id($5); $exon->mismatches($6); $exon->gaps($7); $exon->donor($8); $exon->acceptor($9); # push onto array push(@exons, $exon); } else { $self->throw("Unexpected end of file reached\n"); } } } elsif( /^Number of splice sites:\s+(\d+)/ ) { $self->splicesites($1); } elsif( /^mRNA coverage:\s+(\d+)%/ ) { $self->est_coverage($1); } elsif(/^overall percent identity:\s+([\d\.]+)%/ ) { $self->overall_percentage_id($1); } elsif(/^Missing mRNA ends:\s+(\w+)/ ) { $self->missing_mrna_ends($1); } elsif( /^Exon (\d+): (\d+)-(\d+) \(gen\)\s+(\d+)-(\d+) \(mRNA\)/ ) { my ($exon_num, $gen_start, $gen_stop, $cdna_start, $cdna_stop); $exon_num = $1; $gen_start = $2; $gen_stop = $3; $cdna_start = $4; $cdna_stop = $5; } elsif( /No alignment found/ ) { return []; } else { #$self->debug("unmatched $_\n"); } } # Typical format: # Exon 1: 36375798-36375691 (gen) 1-108 (mRNA) # # # CCTCTTTTTCTTTGCAGGGTATATACCCAGTTACTTAGACAAGGATGAGCTATGTGTAGT # | |||||||||||||||||||||||||||||||||||||||||||||| # ATGTCAGGGTATATACCCAGTTACTTAGACAAGGATGAGCTATGTGTAGT # M S G Y I P S Y L D K D E L C V V # # # ATGTGGGGACAAAGCCACCGGATATCATTATCGCTGCATCACTTGTGAAGGTTGCAAGGT # |||||||||||||||||||||||||||||||||||||||||||||||||||||||||| # ATGTGGGGACAAAGCCACCGGATATCATTATCGCTGCATCACTTGTGAAGGTTGCAAG # C G D K A T G Y H Y R C I T C E G C K # # # AAATGGCA # @exons ? return \@exons : return ; } =head2 next_exonset Title : next_exonset Usage : $exonset = $spidey_result->parse_next_exonset; print "Exons start at ", $exonset->start(), "and end at ", $exonset->end(), "\n"; for $exon ($exonset->sub_SeqFeature()) { # do something } Function: Parses the next alignment of the Spidey result file and returns the set of exons as a container of features. The container is itself a Bio::SeqFeature::Generic object, with the Bio::Tools::Spidey::Exon objects as sub features. Start, end, and strand of the container will represent the total region covered by the exons of this set. See the documentation of parse_next_alignment() for further reference about parsing and how the information is stored. Example : Returns : An Bio::SeqFeature::Generic object holding Bio::Tools::Spidey::Exon objects as sub features. Args : =cut sub next_exonset { my $self = shift; my $exonset; # get the next array of exons my $exons = $self->parse_next_alignment(); if( ! defined $exons ) { $self->warn("No exons returned"); return; } if( @$exons == 0 ) { return Bio::SeqFeature::Generic->new(); } # create the container of exons as a feature object itself, with the # data of the first exon for initialization $exonset = Bio::SeqFeature::Generic->new('-start' => $exons->[0]->start(), '-end' => $exons->[-1]->end(), '-strand' => $exons->[0]->strand(), '-primary' => "ExonSet"); $exonset->source_tag($exons->[0]->source_tag()); $exonset->seq_id($exons->[0]->seq_id()); # now add all exons as sub features, with enabling EXPANsion of the region # covered in total foreach my $exon (@$exons) { $exonset->add_sub_SeqFeature($exon, 'EXPAND'); } return $exonset; } =head2 next_feature Title : next_feature Usage : while($exonset = $spidey->next_feature()) { # do something } Function: Does the same as L<next_exonset()>. See there for documentation of the functionality. Call this method repeatedly until FALSE is returned. The returned object is actually a SeqFeatureI implementing object. This method is required for classes implementing the SeqAnalysisParserI interface, and is merely an alias for next_exonset() at present. Example : Returns : A Bio::SeqFeature::Generic object. Args : =cut sub next_feature { my ($self,@args) = @_; # even though next_exonset doesn't expect any args (and this method # does neither), we pass on args in order to be prepared if this changes # ever return $self->next_exonset(@args); } =head2 genomic_dna_length Title : genomic_dna_length Usage : $spidey->genomic_dna_length(); Function: Returns the length of the genomic DNA used in this Spidey result Example : Returns : An integer value. Args : =cut sub genomic_dna_length { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'genomic_dna_length'} = $val; } else { $val = $self->{'genomic_dna_length'}; } return $val; } =head2 splicesites Title : splicesites Usage : $spidey->splicesites(); Function: Returns the number of splice sites found in this Spidey result Example : Returns : An integer value. Args : =cut sub splicesites { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'splicesites'} = $val; } else { $val = $self->{'splicesites'}; } return $val; } =head2 est_coverage Title : est_coverage Usage : $spidey->est_coverage(); Function: Returns the percent of est coverage in this Spidey result Example : Returns : An integer value. Args : =cut sub est_coverage { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'est_coverage'} = $val; } else { $val = $self->{'est_coverage'}; } return $val; } =head2 overall_percentage_id Title : overall_percentage_id Usage : $spidey->overall_percentage_id(); Function: Returns the overall percent id in this Spidey result Example : Returns : An float value. Args : =cut sub overall_percentage_id { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'overall_percentage_id'} = $val; } else { $val = $self->{'overall_percentage_id'}; } return $val; } =head2 missing_mrna_ends Title : missing_mrna_ends Usage : $spidey->missing_mrna_ends(); Function: Returns left/right/neither from Spidey Example : Returns : A string value. Args : =cut sub missing_mrna_ends { my ($self, @args) = @_; my $val; if(@args) { $val = shift(@args); $self->{'missing_mrna_ends'} = $val; } else { $val = $self->{'missing_mrna_ends'}; } return $val; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree����������������������������������������������������������������������������000755��000765��000024�� 0�12254227334� 14713� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/AlleleNode.pm��������������������������������������������������������������000444��000765��000024�� 30576�12254227325� 17445� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::AlleleNode # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::AlleleNode - A Node with Alleles attached =head1 SYNOPSIS use Bio::Tree::AlleleNode; =head1 DESCRIPTION AlleleNodes are basic L<Bio::Tree::Node>s with the added ability to add Genotypes alleles as defined by the L<Bio::PopGen::IndividualI> interface. Genotypes are defined by the L<Bio::PopGen::GenotypeI> interface, you will probably want to use the L<Bio::PopGen::Genotype> implementation. This is implemented via containment to avoid multiple inheritance problems. Their is a L<Bio::PopGen::Individual> object which handles the L<Bio::PopGen::IndividualI> interface, and is accessible via the L<Bio::Tree::AlleleNode::individual> method. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =head1 HISTORY This module was re-written to be a combination of L<Bio::PopGen::Individual> and L<Bio::Tree::Node> primarily for use in L<Bio::PopGen::Simulation::Coalescent> simulations. =cut # Let the code begin... package Bio::Tree::AlleleNode; use vars qw($UIDCOUNTER); use strict; BEGIN { $UIDCOUNTER = 1 } use Bio::PopGen::Individual; use Bio::PopGen::Genotype; use base qw(Bio::Tree::Node Bio::PopGen::IndividualI); =head2 new Title : new Usage : my $obj = Bio::Tree::AlleleNode->new(); Function: Builds a new Bio::Tree::AlleleNode() object Returns : an instance of Bio::Tree::AlleleNode Args : -unique_id => $id, -genotypes => \@genotypes -left => pointer to Left descendent (optional) -right => pointer to Right descenent (optional) -branch_length => branch length [integer] (optional) -bootstrap => value bootstrap value (string) -description => description of node -id => human readable (unique) id for node Should NOT contain the characters '();:' =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->individual( Bio::PopGen::Individual->new(@args)); return $self; } =head2 individual Title : individual Usage : $obj->individual($newval) Function: Get/Set Access to the underlying individual object Returns : L<Bio::PopGen::Individual> object Args : on set, new value (L<Bio::PopGen::Individual>) =cut sub individual { my ($self,$newval) = @_; if( defined $newval || ! defined $self->{'individual'} ) { $newval = Bio::PopGen::Individual->new() unless defined $newval; $self->{'individual'} = $newval; } return $self->{'individual'}; } =head2 Bio::PopGen::Individual methods Methods required by L<Bio::PopGen::IndividualI>. =head2 unique_id Title : unique_id Usage : my $id = $individual->unique_id Function: Unique Identifier Returns : string representing unique identifier Args : string =cut sub unique_id{ my $self = shift; $self->individual->unique_id(@_); } =head2 num_of_results Title : num_of_results Usage : my $count = $person->num_results; Function: returns the count of the number of Results for a person Returns : integer Args : none =cut sub num_of_results { my $self = shift; $self->individual->num_of_results(@_); } =head2 add_Genotype Title : add_Genotype Usage : $individual->add_Genotype Function: add a genotype value, only a single genotype may be associated Returns : count of the number of genotypes associated with this individual Args : @genotypes - Bio::PopGen::GenotypeI object(s) containing alleles plus a marker name =cut sub add_Genotype { my $self = shift; $self->individual->add_Genotype(@_); } =head2 reset_Genotypes Title : reset_Genotypes Usage : $individual->reset_Genotypes; Function: Reset the genotypes stored for this individual Returns : none Args : none =cut sub reset_Genotypes{ my $self = shift; $self->individual->reset_Genotypes(@_); } =head2 remove_Genotype Title : remove_Genotype Usage : $individual->remove_Genotype(@names) Function: Removes the genotypes for the requested markers Returns : none Args : Names of markers =cut sub remove_Genotype{ my $self = shift; $self->individual->remove_Genotype(@_); } =head2 get_Genotypes Title : get_Genotypes Usage : my @genotypes = $ind->get_Genotypes(-marker => $markername); Function: Get the genotypes for an individual, based on a criteria Returns : Array of genotypes Args : either none (return all genotypes) or -marker => name of marker to return (exact match, case matters) =cut sub get_Genotypes{ my $self = shift; $self->individual->get_Genotypes(@_); } =head2 has_Marker Title : has_Marker Usage : if( $ind->has_Marker($name) ) {} Function: Boolean test to see if an Individual has a genotype for a specific marker Returns : Boolean (true or false) Args : String representing a marker name =cut sub has_Marker{ my $self = shift; $self->individual->has_Marker(@_); } =head2 get_marker_names Title : get_marker_names Usage : my @names = $individual->get_marker_names; Function: Returns the list of known marker names Returns : List of strings Args : none =cut sub get_marker_names{ my $self = shift; $self->individual->get_marker_names(@_); } =head2 Bio::Tree::Node methods Methods inherited from L<Bio::Tree::Node>. =head2 add_Descendent Title : add_Descendent Usage : $node->add_Descendent($node); Function: Adds a descendent to a node Returns : number of current descendents for this node Args : Bio::Node::NodeI boolean flag, true if you want to ignore the fact that you are adding a second node with the same unique id (typically memory location reference in this implementation). default is false and will throw an error if you try and overwrite an existing node. =head2 each_Descendent Title : each_Descendent($sortby) Usage : my @nodes = $node->each_Descendent; Function: all the descendents for this Node (but not their descendents i.e. not a recursive fetchall) Returns : Array of Bio::Tree::NodeI objects Args : $sortby [optional] "height", "creation" or coderef to be used to sort the order of children nodes. =head2 remove_Descendent Title : remove_Descendent Usage : $node->remove_Descedent($node_foo); Function: Removes a specific node from being a Descendent of this node Returns : nothing Args : An array of Bio::Node::NodeI objects which have be previously passed to the add_Descendent call of this object. =head2 remove_all_Descendents Title : remove_all_Descendents Usage : $node->remove_All_Descendents() Function: Cleanup the node's reference to descendents and reset their ancestor pointers to undef, if you don't have a reference to these objects after this call they will be cleaned up - so a get_nodes from the Tree object would be a safe thing to do first Returns : nothing Args : none =head2 get_all_Descendents Title : get_all_Descendents Usage : my @nodes = $node->get_all_Descendents; Function: Recursively fetch all the nodes and their descendents *NOTE* This is different from each_Descendent Returns : Array or Bio::Tree::NodeI objects Args : none =cut # implemented in the interface =head2 ancestor Title : ancestor Usage : $obj->ancestor($newval) Function: Set the Ancestor Returns : value of ancestor Args : newvalue (optional) =head2 branch_length Title : branch_length Usage : $obj->branch_length() Function: Get/Set the branch length Returns : value of branch_length Args : newvalue (optional) =head2 bootstrap Title : bootstrap Usage : $obj->bootstrap($newval) Function: Get/Set the bootstrap value Returns : value of bootstrap Args : newvalue (optional) =head2 description Title : description Usage : $obj->description($newval) Function: Get/Set the description string Returns : value of description Args : newvalue (optional) =head2 id Title : id Usage : $obj->id($newval) Function: The human readable identifier for the node Returns : value of human readable id Args : newvalue (optional) Note : id cannot contain the chracters '();:' "A name can be any string of printable characters except blanks, colons, semicolons, parentheses, and square brackets. Because you may want to include a blank in a name, it is assumed that an underscore character ("_") stands for a blank; any of these in a name will be converted to a blank when it is read in." from L<http://evolution.genetics.washington.edu/phylip/newicktree.html> =cut =head2 internal_id Title : internal_id Usage : my $internalid = $node->internal_id Function: Returns the internal unique id for this Node (a monotonically increasing number for this in-memory implementation but could be a database determined unique id in other implementations) Returns : unique id Args : none =head2 Bio::Node::NodeI decorated interface implemented The following methods are implemented by L<Bio::Node::NodeI> decorated interface. =head2 is_Leaf Title : is_Leaf Usage : if( $node->is_Leaf ) Function: Get Leaf status Returns : boolean Args : none =cut =head2 to_string Title : to_string Usage : my $str = $node->to_string() Function: For debugging, provide a node as a string Returns : string Args : none =head2 height Title : height Usage : my $len = $node->height Function: Returns the height of the tree starting at this node. Height is the maximum branchlength. Returns : The longest length (weighting branches with branch_length) to a leaf Args : none =head2 invalidate_height Title : invalidate_height Usage : private helper method Function: Invalidate our cached value of the node's height in the tree Returns : nothing Args : none =cut #' =head2 add_tag_value Title : add_tag_value Usage : $node->add_tag_value($tag,$value) Function: Adds a tag value to a node Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =head2 remove_tag Title : remove_tag Usage : $node->remove_tag($tag) Function: Remove the tag and all values for this tag Returns : boolean representing success (0 if tag does not exist) Args : $tag - tagname to remove =head2 remove_all_tags Title : remove_all_tags Usage : $node->remove_all_tags() Function: Removes all tags Returns : None Args : None =head2 get_all_tags Title : get_all_tags Usage : my @tags = $node->get_all_tags() Function: Gets all the tag names for this Node Returns : Array of tagnames Args : None =head2 get_tag_values 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 Args : $tag - tag name =head2 has_tag Title : has_tag Usage : $node->has_tag($tag) Function: Boolean test if tag exists in the Node Returns : Boolean Args : $tag - tagname =cut 1; ����������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/AnnotatableNode.pm���������������������������������������������������������000444��000765��000024�� 20212�12254227327� 20463� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Tree::AnnotatableNode # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Mira Han <mirhan@indiana.edu> # # Copyright Mira Han # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::AnnotatableNode - A Tree Node with support for annotation =head1 SYNOPSIS use Bio::Tree::AnnotatableNode; my $nodeA = Bio::Tree::AnnotatableNode->new(); my $nodeL = Bio::Tree::AnnotatableNode->new(); my $nodeR = Bio::Tree::AnnotatableNode->new(); my $node = Bio::Tree::AnnotatableNode->new(); $node->add_Descendents($nodeL); $node->add_Descendents($nodeR); print "node is not a leaf \n" if( $node->is_leaf); # $node is-a Bio::AnnotatableI, hence: my $ann_coll = $node->annotation(); # $ann_coll is-a Bio::AnnotationCollectionI, hence: my @all_anns = $ann_coll->get_Annotations(); # do something with the annotation objects =head1 DESCRIPTION Makes a Tree Node with Annotations, suitable for building a Tree. See L<Bio::Tree::Node> for a full list of functionality. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mira Han Email mirhan@indiana.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::AnnotatableNode; use strict; use Bio::Annotation::Collection; use Bio::Seq; use base qw(Bio::Tree::Node Bio::AnnotatableI); =head2 new Title : new Usage : my $obj = Bio::Tree::AnnotatableNode->new(); Function: Builds a new Bio::Tree::AnnotatableNode object Returns : Bio::Tree::AnnotatableNode Args : -tostring => code reference to the tostring callback function (optional) =cut sub new { my ($class,@args) = @_; my $self = $class->SUPER::new(@args); my $to_string_cb = $self->_rearrange([qw(TOSTRING)], @args); if ($to_string_cb) { $self->to_string_callback($to_string_cb); } return $self; } sub DESTROY { my ($self) = @_; # try to insure that everything is cleaned up $self->SUPER::DESTROY(); } =head1 Methods for implementing Bio::AnnotatableI =cut =head2 annotation Title : annotation Usage : $ann = $node->annotation or $node->annotation($ann) Function: Gets or sets the annotation Returns : Bio::AnnotationCollectionI object Args : None or Bio::AnnotationCollectionI object See L<Bio::AnnotationCollectionI> and L<Bio::Annotation::Collection> for more information =cut sub annotation { my ($self,$value) = @_; if( defined $value ) { $self->throw("object of class ".ref($value)." does not implement ". "Bio::AnnotationCollectionI. Too bad.") unless $value->isa("Bio::AnnotationCollectionI"); $self->{'_annotation'} = $value; } elsif( ! defined $self->{'_annotation'}) { $self->{'_annotation'} = Bio::Annotation::Collection->new(); } return $self->{'_annotation'}; } =head1 Methods for implementing tag access through Annotation::SimpleValue =cut =head2 add_tag_value Title : add_tag_value Usage : $node->add_tag_value($tag,$value) Function: Adds a tag value to a node Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub add_tag_value { my ($self,$tag,$value) = @_; if( ! defined $tag || ! defined $value ) { $self->warn("cannot call add_tag_value with an undefined value"); } my $ac = $self->annotation(); my $sv = Bio::Annotation::SimpleValue->new(-value => $value); $ac->add_Annotation($tag, $sv); return scalar $ac->get_Annotations($tag); } =head2 remove_tag Title : remove_tag Usage : $node->remove_tag($tag) Function: Remove the tag and all values for this tag Returns : boolean representing success (0 if tag does not exist) Args : $tag - tagname to remove =cut sub remove_tag { my ($self,$tag) = @_; my $ac = $self->annotation(); if( @{$ac->get_Annotations($tag)} ) { $ac->remove_Annotations($tag); return 1; } return 0; } =head2 remove_all_tags Title : remove_all_tags Usage : $node->remove_all_tags() Function: Removes all tags Returns : None Args : None =cut sub remove_all_tags { my ($self) = @_; my $ac = $self->annotation(); $ac->remove_Annotations(); return; } =head2 get_all_tags Title : get_all_tags Usage : my @tags = $node->get_all_tags() Function: Gets all the tag names for this Node Returns : Array of tagnames Args : None =cut sub get_all_tags{ my ($self) = @_; my $ac = $self->annotation(); my @tags = sort $ac->get_all_annotation_keys(); # how to restrict it to SimpleValues? return @tags; } =head2 get_tag_values 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 Args : $tag - tag name =cut sub get_tag_values{ my ($self,$tag) = @_; my $ac = $self->annotation(); my @values = map {$_->value()} $ac->get_Annotations($tag); return @values; } =head2 has_tag Title : has_tag Usage : $node->has_tag($tag) Function: Boolean test if tag exists in the Node Returns : Boolean Args : $tag - tagname =cut sub has_tag { my ($self,$tag) = @_; my $ac = $self->annotation(); return ( scalar $ac->get_Annotations($tag) > 0); } =head1 Methods for implementing to_string =cut =head2 to_string_callback Title : to_string_callback Usage : $node->to_string_callback(\&func) Function: get/set callback for to_string Returns : code reference for the to_string callback function Args : \&func - code reference to be set as the callback function =cut sub to_string_callback { # get/set callback, using $DEFAULT_CB if nothing is set my ($self, $foo) = @_; if ($foo) { # $foo is callback code ref, self as first arg (so you have access to object data) $self->{'_to_string_cb'} = $foo; } else { if (! defined $self->{'_to_string_cb'}) { $self->{'_to_string_cb'} = \&Bio::Tree::NodeI::to_string; } } return $self->{'_to_string_cb'}; } sub to_string { my ($self) = @_; my $cb = $self->to_string_callback(); return $cb->($self); } =head1 Methods for accessing Bio::Seq =cut =head2 sequence Title : sequence Usage : $ann = $node->sequence or $node->sequence($seq) Function: Gets or sets the sequence Returns : array reference of Bio::SeqI objects Args : None or Bio::SeqI object See L<Bio::SeqI> and L<Bio::Seq> for more information =cut sub sequence { my ($self,$value) = @_; if( defined $value ) { $self->throw("object of class ".ref($value)." does not implement ". "Bio::SeqI. Too bad.") unless $value->isa("Bio::SeqI"); push (@{$self->{'_sequence'}}, $value); } #elsif( ! defined $self->{'_sequence'}) #{ # $self->{'_sequence'} = Bio::Seq->new(); #} return $self->{'_sequence'}; } =head2 has_sequence Title : has_sequence Usage : if( $node->has_sequence) { # do something } Function: tells if node has sequence attached Returns : Boolean for whether or not node has Bio::SeqI attached. Args : None =cut sub has_sequence { my ($self) = @_; return $self->{'_sequence'} && @{$self->{'_sequence'}}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/Compatible.pm��������������������������������������������������������������000444��000765��000024�� 31001�12254227334� 17500� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::Compatible # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Gabriel Valiente <valiente@lsi.upc.edu> # # Copyright Gabriel Valiente # # You may distribute this module under the same terms as Perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::Compatible - Testing compatibility of phylogenetic trees with nested taxa. =head1 SYNOPSIS use Bio::Tree::Compatible; use Bio::TreeIO; my $input = Bio::TreeIO->new('-format' => 'newick', '-file' => 'input.tre'); my $t1 = $input->next_tree; my $t2 = $input->next_tree; my ($incompat, $ilabels, $inodes) = Bio::Tree::Compatible::is_compatible($t1,$t2); if ($incompat) { my %cluster1 = %{ Bio::Tree::Compatible::cluster_representation($t1) }; my %cluster2 = %{ Bio::Tree::Compatible::cluster_representation($t2) }; print "incompatible trees\n"; if (scalar(@$ilabels)) { foreach my $label (@$ilabels) { my $node1 = $t1->find_node(-id => $label); my $node2 = $t2->find_node(-id => $label); my @c1 = sort @{ $cluster1{$node1} }; my @c2 = sort @{ $cluster2{$node2} }; print "label $label"; print " cluster"; map { print " ",$_ } @c1; print " cluster"; map { print " ",$_ } @c2; print "\n"; } } if (scalar(@$inodes)) { while (@$inodes) { my $node1 = shift @$inodes; my $node2 = shift @$inodes; my @c1 = sort @{ $cluster1{$node1} }; my @c2 = sort @{ $cluster2{$node2} }; print "cluster"; map { print " ",$_ } @c1; print " properly intersects cluster"; map { print " ",$_ } @c2; print "\n"; } } } else { print "compatible trees\n"; } =head1 DESCRIPTION NB: This module has exclusively class methods that work on Bio::Tree::TreeI objects. An instance of Bio::Tree::Compatible cannot itself represent a tree, and so typically there is no need to create one. Bio::Tree::Compatible is a Perl tool for testing compatibility of phylogenetic trees with nested taxa represented as Bio::Tree::Tree objects. It is based on a recent characterization of ancestral compatibility of semi-labeled trees in terms of their cluster representations. A semi-labeled tree is a phylogenetic tree with some of its internal nodes labeled, and it can represent a classification tree as well as a phylogenetic tree with nested taxa, with labeled internal nodes corresponding to taxa at a higher level of aggregation or nesting than that of their descendents. Two semi-labeled trees are compatible if their topological restrictions to the common labels are such that for each node label, the smallest clusters containing it in each of the trees coincide and, furthermore, no cluster in one of the trees properly intersects a cluster of the other tree. Future extensions of Bio::Tree::Compatible include a Bio::Tree::Supertree module for combining compatible phylogenetic trees with nested taxa into a common supertree. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 SEE ALSO =over =item * Philip Daniel and Charles Semple. Supertree Algorithms for Nested Taxa. In: Olaf R. P. Bininda-Emonds (ed.) Phylogenetic Supertrees: Combining Information to Reveal the Tree of Life, I<Computational Biology>, vol. 4, chap. 7, pp. 151-171. Kluwer (2004). =item * Charles Semple, Philip Daniel, Wim Hordijk, Roderic D. M. Page, and Mike Steel: Supertree Algorithms for Ancestral Divergence Dates and Nested Taxa. Bioinformatics B<20>(15), 2355-2360 (2004). =item * Merce Llabres, Jairo Rocha, Francesc Rossello, and Gabriel Valiente: On the Ancestral Compatibility of Two Phylogenetic Trees with Nested Taxa. J. Math. Biol. B<53>(3), 340-364 (2006). =back =head1 AUTHOR - Gabriel Valiente Email valiente@lsi.upc.edu =head1 APPENDIX The rest of the documentation details each of the object methods. =cut package Bio::Tree::Compatible; use strict; # Object preamble - inherits from Bio::Root::Root use Set::Scalar; use base qw(Bio::Root::Root); =head2 postorder_traversal Title : postorder_traversal Usage : my @nodes = @{ $tree->postorder_traversal } Function: Return list of nodes in postorder Returns : reference to array of Bio::Tree::Node Args : none For example, the postorder traversal of the tree C<(((A,B)C,D),(E,F,G));> is a reference to an array of nodes with internal_id 0 through 9, because the Newick standard representation for phylogenetic trees is based on a postorder traversal. +---A +---0 | | +---+---C +---4---2 | | | | | | | | +---B | | +---1 | | | | + +-------D 9 +-------3 | | | +-----E | +-----5 | | | | +-----+-----F +-----8-----6 | | +-----G +-----7 =cut sub postorder_traversal { my($self) = @_; my @stack; my @queue; push @stack, $self->get_root_node; while (@stack) { my $node = pop @stack; push @queue, $node; foreach my $child ($node->each_Descendent(-sortby => 'internal_id')) { push @stack, $child; } } my @postorder = reverse @queue; return \@postorder; } =head2 cluster_representation Title : cluster_representation Usage : my %cluster = %{ $tree->cluster_representation } Function: Compute the cluster representation of a tree Returns : reference to hash of array of string indexed by Bio::Tree::Node Args : none For example, the cluster representation of the tree C<(((A,B)C,D),(E,F,G));> is a reference to a hash associating an array of string (descendent labels) to each node, as follows: 0 --> [A] 1 --> [B] 2 --> [A,B,C] 3 --> [D] 4 --> [A,B,C,D] 5 --> [E] 6 --> [F] 7 --> [G] 8 --> [E,F,G] 9 --> [A,B,C,D,E,F,G] =cut sub cluster_representation { my ($tree) = @_; my %cluster; my @postorder = @{ postorder_traversal($tree) }; foreach my $node ( @postorder ) { my @labeled = map { $_->id } grep { $_->id } $node->get_Descendents; push @labeled, $node->id if $node->id; $cluster{$node} = \@labeled; } return \%cluster; } =head2 common_labels Title : common_labels Usage : my $labels = $tree1->common_labels($tree2); Function: Return set of common node labels Returns : Set::Scalar Args : Bio::Tree::Tree For example, the common labels of the tree C<(((A,B)C,D),(E,F,G));> and the tree C<((A,B)H,E,(J,(K)G)I);> are: C<[A,B,E,G]>. +---A +---A | | +---+---C +-------H | | | | | | | +---B | +---B | | | + +-------D +-----------E | | | +-----E | +-------J | | | | +-----+-----F +---I | | +-----G +---G---K =cut sub common_labels { my($self,$arg) = @_; my @labels1 = map { $_->id } grep { $_->id } $self->get_nodes; my $common = Set::Scalar->new( @labels1 ); my @labels2 = map { $_->id } grep { $_->id } $arg->get_nodes; my $temp = Set::Scalar->new( @labels2 ); return $common->intersection($temp); } =head2 topological_restriction Title : topological_restriction Usage : $tree->topological_restriction($labels) Function: Compute the topological restriction of a tree to a subset of node labels Returns : Bio::Tree::Tree Args : Set::Scalar For example, the topological restrictions of each of the trees C<(((A,B)C,D),(E,F,G));> and C<((A,B)H,E,(J,(K)G)I);> to the labels C<[A,B,E,G]> are as follows: +---A +---A | | +---+---+ +---+ | | | | | +---B | +---B + | | +---E +-------E | | | +-------+ +---+---G | +---G =cut sub topological_restriction { my ($tree, $labels) = @_; for my $node ( @{ postorder_traversal($tree) } ) { unless (ref($node)) { # skip $node if already removed my @cluster = map { $_->id } grep { $_->id } $node->get_Descendents; push @cluster, $node->id if $node->id; my $cluster = Set::Scalar->new(@cluster); if ($cluster->is_disjoint($labels)) { $tree->remove_Node($node); } else { if ($node->id and not $labels->has($node->id)) { $node->{'_id'} = undef; } } } } } =head2 is_compatible Title : is_compatible Usage : $tree1->is_compatible($tree2) Function: Test compatibility of two trees Returns : boolean Args : Bio::Tree::Tree For example, the topological restrictions of the trees C<(((A,B)C,D),(E,F,G));> and C<((A,B)H,E,(J,(K)G)I);> to their common labels, C<[A,B,E,G]>, are compatible. The respective cluster representations are as follows: [A] [A] [B] [B] [E] [E] [G] [G] [A,B] [A,B] [E,G] [A,B,E,G] [A,B,E,G] As a second example, the trees C<(A,B);> and C<((B)A);> are incompatible. Their respective cluster representations are as follows: [A] [B] [B] [A,B] [A,B] The reason is, the smallest cluster containing label C<A> is C<[A]> in the first tree but C<[A,B]> in the second tree. +---A A---B | + | +---B As a second example, the trees C<(((B,A),C),D);> and C<((A,(D,B)),C);> are also incompatible. Their respective cluster representations are as follows: [A] [A] [B] [B] [C] [C] [D] [D] [A,B] [B,D] [A,B,C] [A,B,D] [A,B,C,D] [A,B,C,D] The reason is, cluster C<[A,B]> properly intersects cluster C<[B,D]>. There are further incompatibilities between these trees: C<[A,B,C]> properly intersects both C<[B,D]> and C<[A,B,D]>. +---B +-------A | | +---+ +---+ +---D | | | | | +---+ +---A | +---+ | | + | + +-------C | +---B | | +-----------D +-----------C =cut sub is_compatible { my ($tree1, $tree2) = @_; my $common = $tree1->Bio::Tree::Compatible::common_labels($tree2); $tree1->Bio::Tree::Compatible::topological_restriction($common); $tree2->Bio::Tree::Compatible::topological_restriction($common); my @postorder1 = @{ postorder_traversal($tree1) }; my @postorder2 = @{ postorder_traversal($tree2) }; my %cluster1 = %{ cluster_representation($tree1) }; my %cluster2 = %{ cluster_representation($tree2) }; my $incompat = 0; # false my @labels; foreach my $label ( $common->elements ) { my $node1 = $tree1->find_node(-id => $label); my @labels1 = @{ $cluster1{$node1} }; my $cluster1 = Set::Scalar->new(@labels1); my $node2 = $tree2->find_node(-id => $label); my @labels2 = @{ $cluster2{$node2} }; my $cluster2 = Set::Scalar->new(@labels2); unless ( $cluster1->is_equal($cluster2) ) { $incompat = 1; # true push @labels, $label; } } my @nodes; foreach my $node1 ( @postorder1 ) { my @labels1 = @{ $cluster1{$node1} }; my $cluster1 = Set::Scalar->new(@labels1); foreach my $node2 ( @postorder2 ) { my @labels2 = @{$cluster2{$node2} }; my $cluster2 = Set::Scalar->new(@labels2); if ($cluster1->is_properly_intersecting($cluster2)) { $incompat = 1; # true push @nodes, $node1, $node2; } } } return ($incompat, \@labels, \@nodes); } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/DistanceFactory.pm���������������������������������������������������������000444��000765��000024�� 41233�12254227332� 20511� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::DistanceFactory # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::DistanceFactory - Construct a tree using distance based methods =head1 SYNOPSIS use Bio::Tree::DistanceFactory; use Bio::AlignIO; use Bio::Align::DNAStatistics; my $tfactory = Bio::Tree::DistanceFactory->new(-method => "NJ"); my $stats = Bio::Align::DNAStatistics->new(); my $alnin = Bio::AlignIO->new(-format => 'clustalw', -file => 'file.aln'); my $aln = $alnin->next_aln; # Of course matrix can come from a different place # like PHYLIP if you prefer, Bio::Matrix::IO should be able # to parse many things my $jcmatrix = $stats->distance(-align => $aln, -method => 'Jukes-Cantor'); my $tree = $tfactory->make_tree($jcmatrix); =head1 DESCRIPTION This is a factory which will construct a phylogenetic tree based on the pairwise sequence distances for a set of sequences. Currently UPGMA (Sokal and Michener 1958) and NJ (Saitou and Nei 1987) tree construction methods are implemented. =head1 REFERENCES Eddy SR, Durbin R, Krogh A, Mitchison G, (1998) "Biological Sequence Analysis", Cambridge Univ Press, Cambridge, UK. Howe K, Bateman A, Durbin R, (2002) "QuickTree: building huge Neighbour-Joining trees of protein sequences." Bioinformatics 18(11):1546-1547. Saitou N and Nei M, (1987) "The neighbor-joining method: a new method for reconstructing phylogenetic trees." Mol Biol Evol 4(4):406-25. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tree::DistanceFactory; use vars qw($DefaultMethod $Precision); use strict; # some defaults $DefaultMethod = 'UPGMA'; $Precision = 5; use Bio::Tree::Node; use Bio::Tree::Tree; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::Tree::DistanceFactory->new(); Function: Builds a new Bio::Tree::DistanceFactory object Returns : an instance of Bio::Tree::DistanceFactory Args : -method => 'NJ' or 'UPGMA' =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($method) = $self->_rearrange([qw(METHOD)], @args); $self->method($method || $DefaultMethod); return $self; } =head2 make_tree Title : make_tree Usage : my $tree = $disttreefact->make_tree($matrix); Function: Build a Tree based on a distance matrix Returns : L<Bio::Tree::TreeI> Args : L<Bio::Matrix::MatrixI> object =cut sub make_tree{ my ($self,$matrix) = @_; if( ! defined $matrix || !ref($matrix) || ! $matrix->isa('Bio::Matrix::MatrixI') ) { $self->warn("Need to provide a valid Bio::Matrix::MatrixI object to make_tree"); return; } my $method = uc ($self->method); if( $method =~ /NJ/i ) { return $self->_nj($matrix); } elsif( $method =~ /UPGMA/i ) { return $self->_upgma($matrix); } else { $self->warn("Unknown tree construction method '$method'. Cannot run."); return; } } =head2 _nj Title : _nj Usage : my $tree = $disttreefact->_nj($matrix); Function: Construct a tree based on distance matrix using the Neighbor Joining algorithm (Saitou and Nei, 1987) Implementation based on Kevin Howe's Quicktree implementation and uses his tricks (some based on Bill Bruno's work) to eliminate negative branch lengths Returns : L<Bio::Tree::TreeI> Args : L<Bio::Matrix::MatrixI> object =cut sub _nj { my ($self,$distmat) = @_; # we assume type checking of $aln has already been done # client shouldn't be calling this directly anyways, using the # make_tree method is preferred # so that we can trim the number of digits shown as the branch length my $precisionstr = "%.$Precision"."f"; my @names = $distmat->column_names; my $N = scalar @names; my ($i,$j,$m,@nodes,$mat,@r); my $L = $N; if( $N < 2 ) { $self->warn("Can only perform NJ treebuilding on sets of 2 or more species\n"); return; } elsif( $N == 2 ) { $i = 0; my $d = sprintf($precisionstr, $distmat->get_entry($names[0],$names[1]) / 2); my $root = Bio::Tree::Node->new(); for my $nm ( @names ) { $root->add_Descendents( Bio::Tree::Node->new(-id => $nm, -branch_length => $d)); } return Bio::Tree::Tree(-root => $root); } my $c = 0; for ( $i = 0; $i < $N; $i++ ) { push @nodes, Bio::Tree::Node->new(-id => $names[$i]); my $ri = 0; for( $j = 0; $j < $N; $j++ ) { $mat->[$i][$j] = $distmat->get_entry($names[$i],$names[$j]); $ri += $mat->[$i][$j]; } $r[$i] = $ri / ($L -2); } for( my $nodecount = 0; $nodecount < $N-3; $nodecount++) { my ($mini,$minj,$min); for($i = 0; $i < $N; $i++ ) { next unless defined $nodes[$i]; for( $j = 0; $j < $i; $j++ ) { next unless defined $nodes[$j]; my $dist = $mat->[$i][$j] - ($r[$i] + $r[$j]); if( ! defined $min || $dist <= $min) { ($mini,$minj,$min) = ($i,$j,$dist); } } } my $dij = $mat->[$mini][$minj]; my $dist_i = ($dij + $r[$mini] - $r[$minj]) / 2; my $dist_j = $dij - $dist_i; # deal with negative branch lengths # per code in K.Howe's quicktree if( $dist_i < 0 ) { $dist_i = 0; $dist_j = $dij; $dist_j = 0 if( $dist_j < 0 ); } elsif( $dist_j < 0 ) { $dist_j = 0; $dist_i = $dij; $dist_i = 0 if( $dist_i < 0 ); } $nodes[$mini]->branch_length(sprintf($precisionstr,$dist_i)); $nodes[$minj]->branch_length(sprintf($precisionstr,$dist_j)); my $newnode = Bio::Tree::Node->new(-descendents => [ $nodes[$mini], $nodes[$minj] ]); $nodes[$mini] = $newnode; delete $nodes[$minj]; # update the distance matrix $r[$mini] = 0; my ($dmi,$dmj); for( $m = 0; $m < $N; $m++ ) { next unless defined $nodes[$m]; if( $m != $mini ) { $dmj = $mat->[$m][$minj]; my ($row,$col); ($row,$col) = ($m,$mini); $dmi = $mat->[$row][$col]; # from K.Howe's notes in quicktree # we can actually adjust r[m] here, by using the form: # rm = ((rm * numseqs) - dmi - dmj + dmk) / (numseqs-1) # Note: in Bill Bruno's method for negative branch # elimination, then if either dist_i is positive and # dist_j is 0, or dist_i is zero and dist_j is positive # (after adjustment) then the matrix entry is formed # from the distance to the node in question (m) to the # node with the zero branch length (whichever it was). # I think my code already has the same effect; this is # certainly true if dij is equal to dist_i + dist_j, # which it should have been fixed to my $dmk = $mat->[$row][$col] = $mat->[$col][$row] = ($dmi + $dmj - $dij) / 2; # If we don't want to try and correct negative brlens # this is essentially what is in Edddy et al, BSA book. # $r[$m] = (($r[$m] * $L) - $dmi - $dmj + $dmk) / ($L-1); # $r[$m] = (($r[$m] * ($L - 2)) - $dmi - $dmj + $mat->[$row][$col]) / ( $L - 3); $r[$mini] += $dmk; } } $L--; $r[$mini] /= $L - 2; } # should be 3 nodes left my (@leftovernodes,@leftovers); for( my $k = 0; $k < $N; $k++ ) { if( defined $nodes[$k] ) { push @leftovers, $k; push @leftovernodes, $nodes[$k]; } } my ($l_0,$l_1,$l_2) = @leftovers; my $dist_i = ( $mat->[$l_1][$l_0] + $mat->[$l_2][$l_0] - $mat->[$l_2][$l_1] ) / 2; my $dist_j = ( $mat->[$l_1][$l_0] - $dist_i); my $dist_k = ( $mat->[$l_2][$l_0] - $dist_i); # This is Kev's code to get rid of negative branch lengths if( $dist_i < 0 ) { $dist_i = 0; $dist_j = $mat->[$l_1][$l_0]; $dist_k = $mat->[$l_2][$l_0]; if( $dist_j < 0 ) { $dist_j = 0; $dist_k = ( $mat->[$l_2][$l_0] + $mat->[$l_2][$l_1] ) / 2; $dist_k = 0 if( $dist_k < 0 ); } elsif( $dist_k < 0 ) { $dist_k = 0; $dist_j = ($mat->[$l_1][$l_0] + $mat->[$l_2][$l_1]) / 2; $dist_j = 0 if( $dist_j < 0 ); } } elsif( $dist_j < 0 ) { $dist_j = 0; $dist_i = $mat->[$l_1][$l_0]; $dist_k = $mat->[$l_2][$l_1]; if( $dist_i < 0 ) { $dist_i = 0; $dist_k = ( $mat->[$l_2][$l_0] + $mat->[$l_2][$l_1]) / 2; $dist_k = 0 if( $dist_k < 0 ); } elsif( $dist_k < 0 ) { $dist_k = 0; $dist_i = ( $mat->[$l_1][$l_0] + $mat->[$l_2][$l_0]) / 2; $dist_i = 0 if( $dist_i < 0 ); } } elsif( $dist_k < 0 ) { $dist_k = 0; $dist_i = $mat->[$l_2][$l_0]; $dist_j = $mat->[$l_2][$l_1]; if( $dist_i < 0 ) { $dist_i = 0; $dist_j = ( $mat->[$l_1][$l_0] + $mat->[$l_2][$l_1] ) / 2; $dist_j = 0 if $dist_j < 0; } elsif( $dist_j < 0 ) { $dist_j = 0; $dist_i = ($mat->[$l_1][$l_0] + $mat->[$l_2][$l_0]) / 2; $dist_i = 0 if $dist_i < 0; } } $leftovernodes[0]->branch_length(sprintf($precisionstr,$dist_i)); $leftovernodes[1]->branch_length(sprintf($precisionstr,$dist_j)); $leftovernodes[2]->branch_length(sprintf($precisionstr,$dist_k)); Bio::Tree::Tree->new(-root => Bio::Tree::Node->new (-descendents => \@leftovernodes)); } =head2 _upgma Title : _upgma Usage : my $tree = $disttreefact->_upgma($matrix); Function: Construct a tree based on alignment using UPGMA Returns : L<Bio::Tree::TreeI> Args : L<Bio::Matrix::MatrixI> object =cut sub _upgma{ my ($self,$distmat) = @_; # we assume type checking of $matrix has already been done # client shouldn't be calling this directly anyways, using the # make_tree method is preferred # algorithm, from Eddy, Durbin, Krogh, Mitchison, 1998 # originally by Sokal and Michener 1956 my $precisionstr = "%.$Precision"."f"; my ($i,$j,$x,$y,@dmat,@orig,@nodes); my @names = $distmat->column_names; my $c = 0; my @clusters = map { my $r = { 'id' => $c, 'height' => 0, 'contains' => [$c], }; $c++; $r; } @names; my $K = scalar @clusters; my (@mins,$min); for ( $i = 0; $i < $K; $i++ ) { for( $j = $i+1; $j < $K; $j++ ) { my $d = $distmat->get_entry($names[$i],$names[$j]); # get Min here on first time around, save 1 cycle $dmat[$j][$i] = $dmat[$i][$j] = $d; $orig[$i][$j] = $orig[$j][$i] = $d; if ( ! defined $min || $d <= $min ) { if( defined $min && $min == $d ) { push @mins, [$i,$j]; } else { @mins = [$i,$j]; $min = $d; } } } } # distance between each cluster is avg distance # between pairs of sequences from each cluster while( $K > 1 ) { # fencepost - we already have found the $min # so very first time loop is executed we can skip checking unless( defined $min ) { for($i = 0; $i < $K; $i++ ) { for( $j = $i+1; $j < $K; $j++ ) { my $dij = $dmat[$i][$j]; if( ! defined $min || $dij <= $min) { if( defined $min && $min == $dij ) { push @mins, [$i,$j]; } else { @mins = [ $i,$j ]; $min = $dij; } } } } } # randomly break ties ($x,$y) = @{ $mins[int(rand(scalar @mins))] }; # now we are going to join clusters x and y, make a new cluster my $node = Bio::Tree::Node->new(); my @subids; for my $cid ( $x,$y ) { my $nid = $clusters[$cid]->{'id'}; if( ! defined $nodes[$nid] ) { $nodes[$nid] = Bio::Tree::Node->new(-id => $names[$nid]); } $nodes[$nid]->branch_length (sprintf($precisionstr,$min/2 - $clusters[$cid]->{'height'})); $node->add_Descendent($nodes[$nid]); push @subids, @{ $clusters[$cid]->{'contains'} }; } my $cluster = { 'id' => $c++, 'height' => $min / 2, 'contains' => [@subids], }; $K--; # we are going to drop the last node so go ahead and decrement K $nodes[$cluster->{'id'}] = $node; if ( $y != $K ) { $clusters[$y] = $clusters[$K]; $dmat[$y] = $dmat[$K]; for ( $i = 0; $i < $K; $i++ ) { $dmat[$i][$y] = $dmat[$y][$i]; } } delete $clusters[$K]; $clusters[$x] = $cluster; # now recalculate @dmat for( $i = 0; $i < $K; $i++ ) { if( $i != $x) { $dmat[$i][$x] = $dmat[$x][$i] = &_upgma_distance($clusters[$i],$clusters[$x],\@orig); } else { $dmat[$i][$i] = 0; } } # reset so next loop iteration # we will find minimum distance @mins = (); $min = undef; } Bio::Tree::Tree->new(-root => $nodes[-1]); } # calculate avg distance between clusters - be they # single sequences or the combination of multiple seqences # $cluster_i and $cluster_j are the clusters to operate on # and $distances is a matrix (arrayref of arrayrefs) of pairwise # differences indexed on the sequence ids - # so $distances->[0][1] is the distance between sequences 0 and 1 sub _upgma_distance { my ($cluster_i, $cluster_j, $distances) = @_; my $ilen = scalar @{ $cluster_i->{'contains'} }; my $jlen = scalar @{ $cluster_j->{'contains'} }; my ($d,$count); for( my $i = 0; $i < $ilen; $i++ ) { my $i_id = $cluster_i->{'contains'}->[$i]; for( my $j = 0; $j < $jlen; $j++) { my $j_id = $cluster_j->{'contains'}->[$j]; if( ! defined $distances->[$i_id][$j_id] ) { warn("no value for $i_id $j_id\n"); } else { $d += $distances->[$i_id][$j_id]; } $count++; } } return $d / $count; } =head2 method Title : method Usage : $obj->method($newval) Function: Example : Returns : value of method (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub method{ my $self = shift; return $self->{'_method'} = shift if @_; return $self->{'_method'}; } =head2 check_additivity Title : check_additivity Usage : if( $distance->check_additivity($matrix) ) { } Function : See if matrix obeys additivity principal Returns : boolean Args : Bio::Matrix::MatrixI References: Based on a Java implementation by Peter Sestoft, sestoft@dina.kvl.dk 1999-12-07 version 0.3 http://www.dina.kvl.dk/~sestoft/bsa.html which in turn is based on algorithms described in R. Durbin, S. Eddy, A. Krogh, G. Mitchison. Biological Sequence Analysis CUP 1998, Chapter 7. =cut sub check_additivity{ my ($self,$matrix) = @_; my @names = $matrix->column_names; my $len = scalar @names; return unless $len >= 4; # look at all sets of 4 for( my $i = 0; $i < $len; $i++ ) { for( my $j = $i+1; $j< $len; $j++) { for( my $k = $j+1; $k < $len; $k ++ ) { for( my $m = $k +1; $m < $len; $m++ ) { my $DijDkm = $matrix->get_entry($names[$i],$names[$j]) + $matrix->get_entry($names[$k],$names[$m]); my $DikDjm = $matrix->get_entry($names[$i],$names[$k]) + $matrix->get_entry($names[$j],$names[$m]); my $DimDjk = $matrix->get_entry($names[$i],$names[$m]) + $matrix->get_entry($names[$j],$names[$k]); if( !( ( $DijDkm == $DikDjm && $DijDkm >= $DimDjk) || ( $DijDkm == $DimDjk && $DijDkm >= $DikDjm) || ( $DikDjm == $DimDjk && $DikDjm >= $DijDkm) )) { return 0; } } } } } return 1; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/Node.pm��������������������������������������������������������������������000444��000765��000024�� 52641�12254227313� 16320� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::Node # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::Node - A Simple Tree Node =head1 SYNOPSIS use Bio::Tree::Node; my $nodeA = Bio::Tree::Node->new(); my $nodeL = Bio::Tree::Node->new(); my $nodeR = Bio::Tree::Node->new(); my $node = Bio::Tree::Node->new(); $node->add_Descendent($nodeL); $node->add_Descendent($nodeR); print "node is not a leaf \n" if( $node->is_leaf); =head1 DESCRIPTION Makes a Tree Node suitable for building a Tree. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Aaron Mackey, amackey-at-virginia-dot-edu Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::Node; use vars qw($CREATIONORDER); use strict; use base qw(Bio::Root::Root Bio::Tree::NodeI); BEGIN { $CREATIONORDER = 1; } =head2 new Title : new Usage : my $obj = Bio::Tree::Node->new(); Function: Builds a new Bio::Tree::Node object Returns : Bio::Tree::Node Args : -descendents => arrayref of descendents (they will be updated s.t. their ancestor point is this node) -branch_length => branch length [integer] (optional) -bootstrap => value bootstrap value (string) -description => description of node -id => human readable id for node =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($children, $branchlen,$id, $bootstrap, $desc,$d) = $self->_rearrange([qw( DESCENDENTS BRANCH_LENGTH ID BOOTSTRAP DESC DESCRIPTION )], @args); $self->_register_for_cleanup(\&node_cleanup); $self->{'_desc'} = {}; # for descendents if( defined $d && defined $desc ) { $self->warn("can only accept -desc or -description, not both, accepting -description"); $desc = $d; } elsif( defined $d && ! defined $desc ) { $desc = $d; } defined $desc && $self->description($desc); defined $bootstrap && $self->bootstrap($bootstrap); defined $id && $self->id($id); defined $branchlen && $self->branch_length($branchlen); if( defined $children ) { if( ref($children) !~ /ARRAY/i ) { $self->throw("Must specify a valid ARRAY reference to initialize a Node's Descendents"); } foreach my $c ( @$children ) { $self->add_Descendent($c); } } $self->_creation_id($CREATIONORDER++); return $self; } =head2 create_node_on_branch Title : create_node_on_branch Usage : $node->create_node_on_branch($at_length) Function: Create a node on the ancestral branch of the calling object. Example : Returns : the created node Args : -POSITION=>$absolute_branch_length_from_caller (default) -FRACTION=>$fraction_of_branch_length_from_caller -ANNOT=>{ -id => "the id", -desc => "the description" } -FORCE, set to allow nodes with zero branch lengths =cut sub create_node_on_branch{ my ($self,@args) = @_; my ($pos, $frac, $annot, $force) = $self->_rearrange([qw(POSITION FRACTION ANNOT FORCE)], @args); my ($newpos); my $blen = $self->branch_length; # arg checks $force||=0; $annot||={}; unless ($self->ancestor) { $self->throw("Refusing to create nodes above the root--exiting"); } unless ($blen) { $self->throw("Calling node's branch length is zero") unless $force; } unless ((defined $pos && !defined $frac)||(defined $frac && !defined $pos)) { $self->throw("Either position or fraction must be specified, but not both"); } if (defined $frac) { $self->throw("FRACTION arg must be in the range [0,1]") unless ( (0 <= $frac) && ($frac <= 1) ); $newpos = $frac*$blen; } elsif (defined $pos) { $self->throw("POSITION arg must be in the range [0,$blen]") unless ( (0 <= $pos) && ($pos <= $blen) ); $newpos = $pos; } else { $self->throw("How did I get here?"); } $self->throw("Calling node's branch length will be zero (set -FORCE to force)--exiting") unless ($newpos > 0) || $force; $self->throw("Created nodes branch length would be zero (set -FORCE to force)--exiting") unless ($newpos < $blen) || $force; #guts $annot->{'-branch_length'} = $blen-$newpos; my $node = Bio::Tree::Node->new(%$annot); my $anc = $self->ancestor; # null anc check is above $node->add_Descendent($self); $anc->add_Descendent($node); $anc->remove_Descendent($self); $self->branch_length($newpos); return $node; } =head2 add_Descendent Title : add_Descendent Usage : $node->add_Descendent($node); Function: Adds a descendent to a node Returns : number of current descendents for this node Args : Bio::Node::NodeI boolean flag, true if you want to ignore the fact that you are adding a second node with the same unique id (typically memory location reference in this implementation). default is false and will throw an error if you try and overwrite an existing node. =cut sub add_Descendent{ my ($self,$node,$ignoreoverwrite) = @_; return -1 if( ! defined $node ); if( ! ref($node) || ref($node) =~ /HASH/ || ! $node->isa('Bio::Tree::NodeI') ) { $self->throw("Trying to add a Descendent who is not a Bio::Tree::NodeI"); return -1; } $self->{_adding_descendent} = 1; # avoid infinite recurse $node->ancestor($self) unless $node->{_setting_ancestor}; $self->{_adding_descendent} = 0; if( $self->{'_desc'}->{$node->internal_id} && ! $ignoreoverwrite ) { $self->throw("Going to overwrite a node which is $node that is already stored here, set the ignore overwrite flag (parameter 2) to true to ignore this in the future"); } $self->{'_desc'}->{$node->internal_id} = $node; # is this safely unique - we've tested before at any rate?? $self->invalidate_height(); return scalar keys %{$self->{'_desc'}}; } =head2 each_Descendent Title : each_Descendent($sortby) Usage : my @nodes = $node->each_Descendent; Function: all the descendents for this Node (but not their descendents i.e. not a recursive fetchall) Returns : Array of Bio::Tree::NodeI objects Args : $sortby [optional] "height", "creation", "alpha", "revalpha", or coderef to be used to sort the order of children nodes. =cut sub each_Descendent{ my ($self, $sortby) = @_; # order can be based on branch length (and sub branchlength) $sortby ||= 'none'; if (ref $sortby eq 'CODE') { my @values = sort { $sortby->($a,$b) } values %{$self->{'_desc'}}; return @values; } elsif ($sortby eq 'height') { return map { $_->[0] } sort { $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } map { [$_, $_->height, $_->internal_id ] } values %{$self->{'_desc'}}; } elsif( $sortby eq 'alpha' ) { my @set; for my $v ( values %{$self->{'_desc'}} ) { unless( $v->is_Leaf ) { my @lst = ( sort { $a cmp $b } map { $_->id } grep { $_->is_Leaf } $v->get_all_Descendents($sortby)); push @set, [$v, $lst[0], $v->internal_id]; } else { push @set, [$v, $v->id, $v->internal_id]; } } return map { $_->[0] } sort {$a->[1] cmp $b->[1] || $a->[2] <=> $b->[2] } @set; } elsif( $sortby eq 'revalpha' ) { my @set; for my $v ( values %{$self->{'_desc'}} ) { if( ! defined $v->id && ! $v->is_Leaf ) { my ($l) = ( sort { $b cmp $a } map { $_->id } grep { $_->is_Leaf } $v->get_all_Descendents($sortby)); push @set, [$v, $l, $v->internal_id]; } else { push @set, [$v, $v->id, $v->internal_id]; } } return map { $_->[0] } sort {$b->[1] cmp $a->[1] || $b->[2] <=> $a->[2] } @set; } else { # creation return map { $_->[0] } sort { $a->[1] <=> $b->[1] } map { [$_, $_->internal_id ] } grep {defined $_} values %{$self->{'_desc'}}; } } =head2 remove_Descendent Title : remove_Descendent Usage : $node->remove_Descendent($node_foo); Function: Removes a specific node from being a Descendent of this node Returns : nothing Args : An array of Bio::Node::NodeI objects which have been previously passed to the add_Descendent call of this object. =cut sub remove_Descendent{ my ($self,@nodes) = @_; my $c= 0; foreach my $n ( @nodes ) { if( $self->{'_desc'}->{$n->internal_id} ) { $self->{_removing_descendent} = 1; $n->ancestor(undef); $self->{_removing_descendent} = 0; # should be redundant $self->{'_desc'}->{$n->internal_id}->ancestor(undef); delete $self->{'_desc'}->{$n->internal_id}; $c++; } else { if( $self->verbose ) { $self->debug(sprintf("no node %s (%s) listed as a descendent in this node %s (%s)\n",$n->id, $n,$self->id,$self)); $self->debug("Descendents are " . join(',', keys %{$self->{'_desc'}})."\n"); } } } $c; } =head2 remove_all_Descendents Title : remove_all_Descendents Usage : $node->remove_All_Descendents() Function: Cleanup the node's reference to descendents and reset their ancestor pointers to undef, if you don't have a reference to these objects after this call they will be cleaned up - so a get_nodes from the Tree object would be a safe thing to do first Returns : nothing Args : none =cut sub remove_all_Descendents{ my ($self) = @_; # This won't cleanup the nodes themselves if you also have # a copy/pointer of them (I think)... # That's true. But that's not a bug; if we retain a reference to them it's # very possible we want to keep them. The only way to truly destroy them is # to call DESTROY on the instance. while( my ($node,$val) = each %{ $self->{'_desc'} } ) { delete $self->{'_desc'}->{$node} } $self->{'_desc'} = {}; 1; } =head2 get_all_Descendents Title : get_all_Descendents Usage : my @nodes = $node->get_all_Descendents; Function: Recursively fetch all the nodes and their descendents *NOTE* This is different from each_Descendent Returns : Array or Bio::Tree::NodeI objects Args : none =cut # get_all_Descendents implemented in the interface =head2 ancestor Title : ancestor Usage : $obj->ancestor($newval) Function: Set the Ancestor Returns : ancestral node Args : newvalue (optional) =cut sub ancestor { my $self = shift; if (@_) { my $new_ancestor = shift; # we can set ancestor to undef if ($new_ancestor) { $self->throw("This is [$new_ancestor], not a Bio::Tree::NodeI") unless $new_ancestor->isa('Bio::Tree::NodeI'); } my $old_ancestor = $self->{'_ancestor'} || ''; if (!$old_ancestor || ($old_ancestor && ( !$new_ancestor || $new_ancestor ne $old_ancestor)) ) { if( $old_ancestor && ! $old_ancestor->{_removing_descendent}) { $old_ancestor->remove_Descendent($self); } if ($new_ancestor && ! $new_ancestor->{_adding_descendent} ) { # avoid infinite recurse $self->{_setting_ancestor} = 1; $new_ancestor->add_Descendent($self, 1); $self->{_setting_ancestor} = 0; } } $self->{'_ancestor'} = $new_ancestor; } return $self->{'_ancestor'}; } =head2 branch_length Title : branch_length Usage : $obj->branch_length() Function: Get/Set the branch length Returns : value of branch_length Args : newvalue (optional) =cut sub branch_length{ my $self = shift; if( @_ ) { my $bl = shift; if( defined $bl && $bl =~ s/\[(\d+)\]// ) { $self->bootstrap($1); } $self->{'_branch_length'} = $bl; $self->invalidate_height(); } return $self->{'_branch_length'}; } =head2 bootstrap Title : bootstrap Usage : $obj->bootstrap($newval) Function: Get/Set the bootstrap value Returns : value of bootstrap Args : newvalue (optional) =cut sub bootstrap { my $self = shift; if( @_ ) { if( $self->has_tag('B') ) { $self->remove_tag('B'); } $self->add_tag_value('B',shift); } return ($self->get_tag_values('B'))[0]; } =head2 description Title : description Usage : $obj->description($newval) Function: Get/Set the description string Returns : value of description Args : newvalue (optional) =cut sub description { my $self = shift; $self->{'_description'} = shift @_ if @_; return $self->{'_description'}; } =head2 id Title : id Usage : $obj->id($newval) Function: The human readable identifier for the node Returns : value of human readable id Args : newvalue (optional) "A name can be any string of printable characters except blanks, colons, semicolons, parentheses, and square brackets. Because you may want to include a blank in a name, it is assumed that an underscore character ("_") stands for a blank; any of these in a name will be converted to a blank when it is read in." from L<http://evolution.genetics.washington.edu/phylip/newicktree.html> Also note that these objects now support spaces, ();: because we can automatically quote the strings if they contain these characters. The L<id_output> method does this for you so use the id() method to get the raw string while L<id_output> to get the pre-escaped string. =cut sub id { my ($self, $value) = @_; if (defined $value) { #$self->warn("Illegal characters ();: and space in the id [$value], converting to _ ") # if $value =~ /\(\);:/ and $self->verbose >= 0; #$value =~ s/[\(\);:\s]/_/g; $self->{'_id'} = $value; } return $self->{'_id'}; } =head2 Helper Functions =cut =head2 id_output Title : id_output Usage : my $id = $node->id_output; Function: Return an id suitable for output in format like newick so that if it contains spaces or ():; characters it is properly quoted Returns : $id string if $node->id has a value Args : none =cut # implemented in NodeI interface =head2 internal_id Title : internal_id Usage : my $internalid = $node->internal_id Function: Returns the internal unique id for this Node (a monotonically increasing number for this in-memory implementation but could be a database determined unique id in other implementations) Returns : unique id Args : none =cut sub internal_id { return $_[0]->_creation_id; } =head2 _creation_id Title : _creation_id Usage : $obj->_creation_id($newval) Function: a private method signifying the internal creation order Returns : value of _creation_id Args : newvalue (optional) =cut sub _creation_id { my $self = shift @_; $self->{'_creation_id'} = shift @_ if( @_); return $self->{'_creation_id'} || 0; } =head2 Bio::Node::NodeI decorated interface implemented The following methods are implemented by L<Bio::Node::NodeI> decorated interface. =head2 is_Leaf Title : is_Leaf Usage : if( $node->is_Leaf ) Function: Get Leaf status Returns : boolean Args : none =cut sub is_Leaf { my ($self) = @_; my $isleaf = ! (defined $self->{'_desc'} && (keys %{$self->{'_desc'}} > 0) ); return $isleaf; } =head2 height Title : height Usage : my $len = $node->height Function: Returns the height of the tree starting at this node. Height is the maximum branchlength to get to the tip. Returns : The longest length (weighting branches with branch_length) to a leaf Args : none =cut sub height { my ($self) = @_; return $self->{'_height'} if( defined $self->{'_height'} ); return 0 if( $self->is_Leaf ); my $max = 0; foreach my $subnode ( $self->each_Descendent ) { my $bl = $subnode->branch_length; $bl = 1 unless (defined $bl && $bl =~ /^\-?\d+(\.\d+)?$/); my $s = $subnode->height + $bl; if( $s > $max ) { $max = $s; } } return ($self->{'_height'} = $max); } =head2 invalidate_height Title : invalidate_height Usage : private helper method Function: Invalidate our cached value of the node height in the tree Returns : nothing Args : none =cut sub invalidate_height { my ($self) = @_; $self->{'_height'} = undef; if( defined $self->ancestor ) { $self->ancestor->invalidate_height; } } =head2 set_tag_value Title : set_tag_value Usage : $node->set_tag_value($tag,$value) $node->set_tag_value($tag,@values) Function: Sets a tag value(s) to a node. Replaces old values. Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub set_tag_value{ my ($self,$tag,@values) = @_; if( ! defined $tag || ! scalar @values ) { $self->warn("cannot call set_tag_value with an undefined value"); } $self->remove_tag ($tag); map { push @{$self->{'_tags'}->{$tag}}, $_ } @values; return scalar @{$self->{'_tags'}->{$tag}}; } =head2 add_tag_value Title : add_tag_value Usage : $node->add_tag_value($tag,$value) Function: Adds a tag value to a node Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub add_tag_value{ my ($self,$tag,$value) = @_; if( ! defined $tag || ! defined $value ) { $self->warn("cannot call add_tag_value with an undefined value".($tag ? " ($tag)" : '')); $self->warn($self->stack_trace_dump,"\n"); } push @{$self->{'_tags'}->{$tag}}, $value; return scalar @{$self->{'_tags'}->{$tag}}; } =head2 remove_tag Title : remove_tag Usage : $node->remove_tag($tag) Function: Remove the tag and all values for this tag Returns : boolean representing success (0 if tag does not exist) Args : $tag - tagname to remove =cut sub remove_tag { my ($self,$tag) = @_; if( exists $self->{'_tags'}->{$tag} ) { $self->{'_tags'}->{$tag} = undef; delete $self->{'_tags'}->{$tag}; return 1; } return 0; } =head2 remove_all_tags Title : remove_all_tags Usage : $node->remove_all_tags() Function: Removes all tags Returns : None Args : None =cut sub remove_all_tags{ my ($self) = @_; $self->{'_tags'} = {}; return; } =head2 get_all_tags Title : get_all_tags Usage : my @tags = $node->get_all_tags() Function: Gets all the tag names for this Node Returns : Array of tagnames Args : None =cut sub get_all_tags{ my ($self) = @_; my @tags = sort keys %{$self->{'_tags'} || {}}; return @tags; } =head2 get_tag_values Title : get_tag_values Usage : my @values = $node->get_tag_values($tag) Function: Gets the values for given tag ($tag) 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 sub get_tag_values{ my ($self,$tag) = @_; return wantarray ? @{$self->{'_tags'}->{$tag} || []} : (@{$self->{'_tags'}->{$tag} || []})[0]; } =head2 has_tag Title : has_tag Usage : $node->has_tag($tag) Function: Boolean test if tag exists in the Node Returns : Boolean Args : $tag - tagname =cut sub has_tag { my ($self,$tag) = @_; return exists $self->{'_tags'}->{$tag}; } sub node_cleanup { my $self = shift; return unless defined $self; #*** below is wrong, cleanup doesn't actually occur. Will replace with: # $self->remove_all_Descendents; once further fixes in place.. #if( defined $self->{'_desc'} && # ref($self->{'_desc'}) =~ /HASH/i ) { # while( my ($nodeid,$node) = each %{ $self->{'_desc'} } ) { # $node->ancestor(undef); # insure no circular references # $node = undef; # } #} $self->remove_all_Descendents; #$self->{'_desc'} = {}; 1; } =head2 reverse_edge Title : reverse_edge Usage : $node->reverse_edge(child); Function: makes child be a parent of node Requires: child must be a direct descendent of node Returns : 1 on success, 0 on failure Args : Bio::Tree::NodeI that is in the tree =cut sub reverse_edge { my ($self,$node) = @_; if( $self->delete_edge($node) ) { $node->add_Descendent($self); return 1; } return 0; } 1; �����������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/NodeI.pm�������������������������������������������������������������������000444��000765��000024�� 27072�12254227323� 16432� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::NodeI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::NodeI - Interface describing a Tree Node =head1 SYNOPSIS # get a Tree::NodeI somehow # like from a TreeIO use Bio::TreeIO; # read in a clustalw NJ in phylip/newick format my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 'file.dnd'); my $tree = $treeio->next_tree; # we'll assume it worked for demo purposes # you might want to test that it was defined my $rootnode = $tree->get_root_node; # process just the next generation foreach my $node ( $rootnode->each_Descendent() ) { print "branch len is ", $node->branch_length, "\n"; } # process all the children my $example_leaf_node; foreach my $node ( $rootnode->get_all_Descendents() ) { if( $node->is_Leaf ) { print "node is a leaf ... "; # for example use below $example_leaf_node = $node unless defined $example_leaf_node; } print "branch len is ", $node->branch_length, "\n"; } # The ancestor() method points to the parent of a node # A node can only have one parent my $parent = $example_leaf_node->ancestor; # parent won't likely have an description because it is an internal node # but child will because it is a leaf print "Parent id: ", $parent->id," child id: ", $example_leaf_node->id, "\n"; =head1 DESCRIPTION A NodeI is capable of the basic structure of building a tree and storing the branch length between nodes. The branch length is the length of the branch between the node and its ancestor, thus a root node in a Tree will not typically have a valid branch length. Various implementations of NodeI may extend the basic functions and allow storing of other information (like attatching a species object or full sequences used to build a tree or alternative sequences). If you don't know how to extend a Bioperl object please ask, happy to help, we would also greatly appreciate contributions with improvements or extensions of the objects back to the Bioperl code base so that others don't have to reinvent your ideas. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Aaron Mackey amackey@virginia.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::NodeI; use strict; no warnings 'recursion'; use base qw(Bio::Root::RootI); =head2 add_Descendent Title : add_Descendent Usage : $node->add_Descendent($node); Function: Adds a descendent to a node Returns : number of current descendents for this node Args : Bio::Node::NodeI =cut sub add_Descendent{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 each_Descendent Title : each_Descendent Usage : my @nodes = $node->each_Descendent; Function: all the descendents for this Node (but not their descendents i.e. not a recursive fetchall) Returns : Array of Bio::Tree::NodeI objects Args : none =cut sub each_Descendent{ my ($self) = @_; $self->throw_not_implemented(); } =head2 Decorated Interface methods =cut =head2 get_all_Descendents Title : get_all_Descendents($sortby) Usage : my @nodes = $node->get_all_Descendents; Function: Recursively fetch all the nodes and their descendents *NOTE* This is different from each_Descendent Returns : Array or Bio::Tree::NodeI objects Args : $sortby [optional] "height", "creation", "alpha", "revalpha", or a coderef to be used to sort the order of children nodes. =cut sub get_all_Descendents{ my ($self, $sortby) = @_; $sortby ||= 'none'; my @nodes; foreach my $node ( $self->each_Descendent($sortby) ) { push @nodes, ($node,$node->get_all_Descendents($sortby)); } return @nodes; } *get_Descendents = \&get_all_Descendents; =head2 is_Leaf Title : is_Leaf Usage : if( $node->is_Leaf ) Function: Get Leaf status Returns : boolean Args : none =cut sub is_Leaf{ my ($self) = @_; $self->throw_not_implemented(); } =head2 descendent_count Title : descendent_count Usage : my $count = $node->descendent_count; Function: Counts the number of descendents a node has (and all of their subnodes) Returns : integer Args : none =cut sub descendent_count{ my ($self) = @_; my $count = 0; foreach my $node ( $self->each_Descendent ) { $count += 1; $node->can('descendent_count') ? $count += $node->descendent_count : next; } return $count; } =head2 to_string Title : to_string Usage : my $str = $node->to_string() Function: For debugging, provide a node as a string Returns : string Args : none =cut sub to_string{ my ($self) = @_; return join('',defined $self->id_output ? $self->id_output : '', defined $self->branch_length ? ':' . $self->branch_length : ' ') } =head2 height Title : height Usage : my $len = $node->height Function: Returns the height of the tree starting at this node. Height is the maximum branchlength to get to the tip. Returns : The longest length (weighting branches with branch_length) to a leaf Args : none =cut sub height{ my ($self) = @_; return 0 if( $self->is_Leaf ); my $max = 0; foreach my $subnode ( $self->each_Descendent ) { my $s = $subnode->height + $subnode->branch_length;; if( $s > $max ) { $max = $s; } } return $max; } =head2 depth Title : depth Usage : my $len = $node->depth Function: Returns the depth of the tree starting at this node. Depth is the distance from this node to the root. Returns : The branch length to the root. Args : none =cut sub depth{ my ($self) = @_; my $depth = 0; my $node = $self; while( defined $node->ancestor ) { $depth += $node->branch_length; $node = $node->ancestor; } return $depth; } =head2 Get/Set methods =cut =head2 branch_length Title : branch_length Usage : $obj->branch_length() Function: Get/Set the branch length Returns : value of branch_length Args : newvalue (optional) =cut sub branch_length{ my ($self)= @_; $self->throw_not_implemented(); } =head2 id Title : id Usage : $obj->id($newval) Function: The human readable identifier for the node Returns : value of human readable id Args : newvalue (optional) =cut sub id{ my ($self)= @_; $self->throw_not_implemented(); } =head2 internal_id Title : internal_id Usage : my $internalid = $node->internal_id Function: Returns the internal unique id for this Node Returns : unique id Args : none =cut sub internal_id{ my ($self) = @_; $self->throw_not_implemented(); } =head2 description Title : description Usage : $obj->description($newval) Function: Get/Set the description string Returns : value of description Args : newvalue (optional) =cut sub description{ my ($self) = @_; $self->throw_not_implemented(); } =head2 bootstrap Title : bootstrap Usage : $obj->bootstrap($newval) Function: Get/Set the bootstrap value Returns : value of bootstrap Args : newvalue (optional) =cut sub bootstrap{ my ($self) = @_; $self->throw_not_implemented(); } =head2 ancestor Title : ancestor Usage : my $node = $node->ancestor; Function: Get/Set the ancestor node pointer for a Node Returns : Null if this is top level node Args : none =cut sub ancestor{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 invalidate_height Title : invalidate_height Usage : private helper method Function: Invalidate our cached value of the node height in the tree Returns : nothing Args : none =cut sub invalidate_height { shift->throw_not_implemented(); } =head2 Methods for associating Tag/Values with a Node These methods associate tag/value pairs with a Node =head2 set_tag_value Title : set_tag_value Usage : $node->set_tag_value($tag,$value) $node->set_tag_value($tag,@values) Function: Sets a tag value(s) to a node. Replaces old values. Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub set_tag_value{ shift->throw_not_implemented(); } =head2 add_tag_value Title : add_tag_value Usage : $node->add_tag_value($tag,$value) Function: Adds a tag value to a node Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub add_tag_value{ shift->throw_not_implemented(); } =head2 remove_tag Title : remove_tag Usage : $node->remove_tag($tag) Function: Remove the tag and all values for this tag Returns : boolean representing success (0 if tag does not exist) Args : $tag - tagname to remove =cut sub remove_tag { shift->throw_not_implemented(); } =head2 remove_all_tags Title : remove_all_tags Usage : $node->remove_all_tags() Function: Removes all tags Returns : None Args : None =cut sub remove_all_tags{ shift->throw_not_implemented(); } =head2 get_all_tags Title : get_all_tags Usage : my @tags = $node->get_all_tags() Function: Gets all the tag names for this Node Returns : Array of tagnames Args : None =cut sub get_all_tags { shift->throw_not_implemented(); } =head2 get_tag_values Title : get_tag_values Usage : my @values = $node->get_tag_values($tag) Function: Gets the values for given tag ($tag) Returns : Array of values or empty list if tag does not exist Args : $tag - tag name =cut sub get_tag_values{ shift->throw_not_implemented(); } =head2 has_tag Title : has_tag Usage : $node->has_tag($tag) Function: Boolean test if tag exists in the Node Returns : Boolean Args : $tag - tagname =cut sub has_tag{ shift->throw_not_implemented(); } =head2 Helper Functions =cut =head2 id_output Title : id_output Usage : my $id = $node->id_output; Function: Return an id suitable for output in format like newick so that if it contains spaces or ():; characters it is properly quoted Returns : $id string if $node->id has a value Args : none =cut sub id_output{ my $node = shift; my $id = $node->id; return unless( defined $id && length($id ) ); # single quotes must become double quotes # $id =~ s/'/''/g; if( $id =~ /[\(\);:,\s]/ ) { $id = '"'.$id.'"'; } return $id; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/NodeNHX.pm�����������������������������������������������������������������000444��000765��000024�� 11040�12254227327� 16667� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::NodeNHX # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::NodeNHX - A Simple Tree Node with support for NHX tags =head1 SYNOPSIS use Bio::Tree::NodeNHX; my $nodeA = Bio::Tree::NodeNHX->new(); my $nodeL = Bio::Tree::NodeNHX->new(); my $nodeR = Bio::Tree::NodeNHX->new(); my $node = Bio::Tree::NodeNHX->new(); $node->add_Descendents($nodeL); $node->add_Descendents($nodeR); print "node is not a leaf \n" if( $node->is_leaf); =head1 DESCRIPTION Makes a Tree Node with NHX tags, suitable for building a Tree. See L<Bio::Tree::Node> for a full list of functionality. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey@virginia.edu =head1 CONTRIBUTORS The NHX (New Hampshire eXtended) format was created by Chris Zmasek, and is described at: http://sourceforge.net/projects/forester-atv/ =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::NodeNHX; use strict; use base qw(Bio::Tree::Node); =head2 new Title : new Usage : my $obj = Bio::Tree::NodeNHX->new(); Function: Builds a new Bio::Tree::NodeNHX object Returns : Bio::Tree::NodeNHX Args : -left => pointer to Left descendent (optional) -right => pointer to Right descenent (optional) -branch_length => branch length [integer] (optional) -bootstrap => bootstrap value (string) -description => description of node -id => unique id for node -nhx => hashref of NHX tags and values =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($nhx) = $self->_rearrange([qw(NHX)], @args); $self->nhx_tag($nhx); return $self; } sub DESTROY { my ($self) = @_; # try to insure that everything is cleaned up $self->SUPER::DESTROY(); if( defined $self->{'_desc'} && ref($self->{'_desc'}) =~ /ARRAY/i ) { while( my ($nodeid,$node) = each %{ $self->{'_desc'} } ) { $node->{'_ancestor'} = undef; # insure no circular references $node->DESTROY(); $node = undef; } $self->{'_desc'} = {}; } } sub to_string{ my ($self) = @_; my @tags = $self->get_all_tags; my $tagstr = ''; if( scalar(@tags) > 0 ) { $tagstr = '[' . join(":", "&&NHX", map { "$_=" .join(',', $self->get_tag_values($_))} @tags ) . ']'; } return sprintf("%s%s%s", defined $self->id ? $self->id : '', defined $self->branch_length ? ':' . $self->branch_length : ' ', $tagstr); } =head2 nhx_tag Title : nhx_tag Usage : my $tag = $nodenhx->nhx_tag(%tags); Function: Set tag-value pairs for NHX nodes Returns : none Args : hashref to update the tags/value pairs OR with a scalar value update the bootstrap value by default =cut sub nhx_tag { my ($self, $tags) = @_; if (defined $tags && (ref($tags) =~ /HASH/i)) { while( my ($tag,$val) = each %$tags ) { if( ref($val) =~ /ARRAY/i ) { for my $v ( @$val ) { $self->add_tag_value($tag,$v); } } else { $self->add_tag_value($tag,$val); } } if (exists $tags->{'B'}) { $self->bootstrap($tags->{'B'}); } } elsif (defined $tags and ! ref ($tags)) { $self->debug( "here with $tags\n"); # bootstrap by default $self->bootstrap($tags); } } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/RandomFactory.pm�����������������������������������������������������������000444��000765��000024�� 33504�12254227315� 20202� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::RandomFactory # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::RandomFactory - TreeFactory for generating Random Trees =head1 SYNOPSIS use Bio::Tree::RandomFactory my @taxonnames; my $factory = Bio::Tree::RandomFactory->new( -taxa => \@taxonnames, -maxcount => 10); # or for anonymous samples my $factory = Bio::Tree::RandomFactory->new( -num_taxa => 6, -maxcount => 50); my $tree = $factory->next_tree; =head1 DESCRIPTION Builds a random tree every time next_tree is called or up to -maxcount times. This module was originally written for Coalescent simulations see L<Bio::PopGen::Simulation::Coalescent>. I've left the next_tree method intact although it is not generating random trees in the phylogenetic sense. I would be happy for someone to provide alternative implementations which can be used here. As written it will generate random topologies but the branch lengths are built from assumptions in the coalescent and are not appropriate for phylogenetic analyses. This algorithm is based on the make_tree algorithm from Richard Hudson 1990. Hudson, R. R. 1990. Gene genealogies and the coalescent process. Pp. 1-44 in D. Futuyma and J. Antonovics, eds. Oxford surveys in evolutionary biology. Vol. 7. Oxford University Press, New York Sanderson, M ... =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-AT-bioperl.org =head1 CONTRIBUTORS Matthew Hahn, E<lt>matthew.hahn@duke.eduE<gt> Mike Sanderson =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::RandomFactory; use vars qw($PRECISION_DIGITS $DefaultNodeType %Defaults); use strict; $PRECISION_DIGITS = 3; # Precision for the branchlength $DefaultNodeType = 'Bio::Tree::Node'; %Defaults = ('YuleRate' => 1.0, # as set by Sanderson in Rates 'Speciation' => 1.0, # 'DefaultTreeMethod' => 'yule', ); use Bio::Tools::RandomDistFunctions; use Bio::Tree::Tree; use base qw(Bio::Root::Root Bio::Factory::TreeFactoryI); =head2 new Title : new Usage : my $factory = Bio::Tree::RandomFactory->new(-samples => \@samples, -maxcount=> $N); Function: Initializes a Bio::Tree::RandomFactory object Returns : Bio::Tree::RandomFactory Args : -nodetype => Type of Nodes to create [default Bio::Tree::Node] -maxcount => [optional] Maximum num trees to create -randtype => Type of random trees so far support - yule/backward_yule/BY [default] - forward_yule/FY - birthdeath_forward/BDF - birthdeath_backwards/BDB ONE of the following must be specified -taxa => $arrayref of taxa names -num_taxa => integer indicating number of taxa in the tree =cut sub new{ my ($class,@args) = @_; my $self = $class->SUPER::new(@args); $self->{'_treecounter'} = 0; $self->{'_maxcount'} = 0; my ($nodetype,$randtype, $maxcount, $samps,$samplesize, $taxa, $num_taxa) = $self->_rearrange([qw(NODETYPE RANDTYPE MAXCOUNT SAMPLES SAMPLE_SIZE TAXA NUM_TAXA)], @args); my @taxa; $nodetype ||= $DefaultNodeType; $self->nodetype($nodetype); $taxa = $samps if defined $samps && ! defined $taxa; $num_taxa = $samplesize if $samplesize && ! $num_taxa; if( ! defined $taxa ) { if( ! defined $num_taxa || $num_taxa <= 0 ) { $self->throw("Must specify a valid num_taxa if parameter -TAXA is not specified"); } foreach ( 1..$num_taxa ) { push @taxa, "Taxon$_"; } } else { if( ref($taxa) !~ /ARRAY/i ) { $self->throw("Must specify a valid ARRAY reference to the parameter -TAXA, did you forget a leading '\\'? for $taxa"); } @taxa = @$taxa; } $self->taxa(\@taxa); defined $maxcount && $self->maxcount($maxcount); $self->{'_count'} = 0; return $self; } =head2 next_tree Title : next_tree Usage : my $tree = $factory->next_tree Function: Returns a random tree based on the initialized number of nodes NOTE: if maxcount is not specified on initialization or set to a valid integer, subsequent calls to next_tree will continue to return random trees and never return undef Returns : Bio::Tree::TreeI object Args : none =cut sub next_tree{ my ($self,%options) = @_; return if $self->maxcount && $self->{'_count'}++ >= $self->maxcount; my $rand_type = $options{'randtype'} || $self->random_tree_method; my $nodetype = $self->nodetype; my $treearray; if( $rand_type =~ /(birthdeath_forward|birth|BDF)/i ) { } elsif ( $rand_type =~ /(birthdeath_backward|BDB)/i ) { $treearray = $self->rand_birthdeath_backwards_tree; } elsif( $rand_type =~ /(BY|backwards_yule)/i || $rand_type =~ /^yule/i ) { my $speciation = $options{'speciation'}; # can be undef $treearray = $self->rand_yule_c_tree($speciation); } else { $self->warn("unrecognized random type $rand_type"); } my @nodes = (); foreach my $n ( @$treearray ) { for my $k ( qw(desc1 desc2) ) { next unless defined $n->{$k}; push @{$n->{'descendents'}}, $nodes[$n->{$k}]; } push @nodes, $nodetype->new(-id => $n->{'nodenum'}, -branch_length => $n->{'time'}, -descendents => $n->{'descendents'}, ); } my $T = Bio::Tree::Tree->new(-root => pop @nodes ); return $T; } =head2 maxcount Title : maxcount Usage : $obj->maxcount($newval) Function: Returns : Maxcount value Args : newvalue (optional) =cut sub maxcount{ my ($self,$value) = @_; if( defined $value) { if( $value =~ /^(\d+)/ ) { $self->{'_maxcount'} = $1; } else { $self->warn("Must specify a valid Positive integer to maxcount"); $self->{'_maxcount'} = 0; } } return $self->{'_maxcount'}; } =head2 reset_tree_count Title : reset_tree_count Usage : $factory->reset_tree_count; Function: Reset the tree counter Returns : none Args : none =cut sub reset_count{ shift->{'_count'} = 0; } =head2 taxa Title : taxa Usage : $obj->taxa($newval) Function: Set the leaf node names Returns : value of taxa Args : Arrayref of Taxon names =cut sub taxa { my ($self,$value) = @_; if( defined $value) { if( ref($value) !~ /ARRAY/i ) { $self->warn("Must specify a valid array ref to the method 'taxa'"); $value = []; } $self->{'_taxa'} = $value; $self->{'_num_taxa'} = scalar @$value; } return $self->{'_taxa'}; } =head2 num_taxa Title : num_taxa Usage : $obj->num_taxa($newval) Function: Get the number of Taxa Returns : value of num_taxa Args : none =cut sub num_taxa { my ($self) = @_; return $self->{'_num_taxa'}; } # alias old methods *num_samples = \&num_taxa; *samples = \&taxa; =head2 random Title : random Usage : my $rfloat = $node->random($size) Function: Generates a random number between 0 and $size This is abstracted so that someone can override and provide their own special RNG. This is expected to be a uniform RNG. Returns : Floating point random Args : $maximum size for random number (defaults to 1) =cut sub random{ my ($self,$max) = @_; return rand($max); } =head2 random_tree_method Title : random_tree_method Usage : $obj->random_tree_method($newval) Function: Example : Returns : value of random_tree_method (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub random_tree_method{ my $self = shift; return $self->{'random_tree_method'} = shift if @_; return $self->{'random_tree_method'} || $Defaults{'DefaultTreeMethod'}; } =head2 nodetype Title : nodetype Usage : $obj->nodetype($newval) Function: Example : Returns : value of nodetype (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub nodetype{ my ($self,$value) = @_; if( defined $value) { eval "require $value"; if( $@ ) { $self->throw("$@: Unrecognized Node type for ".ref($self). "'$value'");} my $a = bless {},$value; unless( $a->isa('Bio::Tree::NodeI') ) { $self->throw("Must provide a valid Bio::Tree::NodeI or child class to SeqFactory Not $value"); } $self->{'nodetype'} = $value; } return $self->{'nodetype'}; } # The assignment of times are based on Mike Sanderson's r8s code # The topology assignment code is based on Richard Hudson's # make_trees sub rand_yule_c_tree { my ($self,$speciation) = @_; $speciation ||= $Defaults{'Speciation'}; my $n_taxa = $self->num_taxa; my $taxa = $self->taxa || []; my $nodetype = $self->nodetype; my $randfuncs = Bio::Tools::RandomDistFunctions->new(); my $rate = $Defaults{'YuleRate'}; my (@tree,@list,@times,$i,$in); my $max = 2 * $n_taxa - 1; for($in=0;$in < $max; $in++ ) { push @tree, { 'nodenum' => "Node$in" }; } # setup leaf nodes for($in=0;$in < $n_taxa;$in++) { $tree[$in]->{'time'} = 0; $tree[$in]->{'desc1'} = undef; $tree[$in]->{'desc2'} = undef; if( my $r = $taxa->[$in] ) { $tree[$in]->{'nodenum'} = $r; } push @list, $in; } for( $i = 0; $i < $n_taxa - 1; $i++ ) { # draw random interval times push @times, $randfuncs->rand_birth_distribution($speciation); } # sort smallest to largest @times = sort {$a <=> $b} @times; # topology generation for ($in = $n_taxa; $in > 1; $in-- ) { my $time = shift @times; my $pick = int $self->random($in); my $nodeindex = $list[$pick]; $tree[$list[$pick]]->{'time'} = $time; my $swap = 2 * $n_taxa - $in; $tree[$swap]->{'desc1'} = $nodeindex; $list[$pick] = $list[$in-1]; $pick = int rand($in - 1); $nodeindex = $list[$pick]; $tree[$list[$pick]]->{'time'} = $time; $tree[$swap]->{'desc2'} = $nodeindex; $list[$pick] = $swap; } $tree[-1]->{'time'} = shift @times; return \@tree; } sub rand_birthdeath_backwards_tree { my ($self) = @_; my $n_taxa = $self->num_taxa; my $taxa = $self->taxa || []; my $randfuncs = Bio::Tools::RandomDistFunctions->new(); my $rate = $Defaults{'YuleRate'}; my (@tree,@list,@times,$i,$in); my $max = 2 * $n_taxa - 1; for($in=0;$in < $max; $in++ ) { push @tree, { 'nodenum' => "Node$in" }; } # setup leaf nodes for($in=0;$in < $n_taxa;$in++) { $tree[$in]->{'time'} = 0; $tree[$in]->{'desc1'} = undef; $tree[$in]->{'desc2'} = undef; if( my $r = $taxa->[$in] ) { # deal with pre-labeled nodes $tree[$in]->{'nodenum'} = $r; } push @list, $in; } my ($time) = (0); # topology generation for ($in = $n_taxa; $in > 1; $in-- ) { my $pick = int $self->random($in); my $nodeindex = $list[$pick]; my $swap = 2 * $n_taxa - $in; $time += $randfuncs->rand_geometric_distribution($n_taxa * $rate);; $tree[$list[$pick]]->{'time'} = $time; $tree[$swap]->{'desc1'} = $nodeindex; $list[$pick] = $list[$in-1]; $pick = int rand($in - 1); $nodeindex = $list[$pick]; $tree[$list[$pick]]->{'time'} = $time; $tree[$swap]->{'desc2'} = $nodeindex; $list[$pick] = $swap; } my $root = $tree[-1]; $time += $randfuncs->rand_geometric_distribution($n_taxa * $rate);; $root->{'time'} = $time; # Normalize times by the root node... for my $node ( @tree ) { $node->{'time'} /= $root->{'time'}; } return \@tree; } # The assignment of times are based on Mike Sanderson's r8s code # The topology assignment code is based on Richard Hudson's # make_trees sub rand_birth_death_tree { # Still need to finish # my ($self,$spec_rate,$extinct_rate,$char_rate) = @_; # my $n_taxa = $self->num_taxa; # my $dt = 0.1 / $n_taxa; # my @tree; # my $max = 3 * $n_taxa - 1; # # setup leaf nodes # for($in=0;$in < $size;$in++) { # push @tree, { 'nodenum' => $taxa->[$in] || "Node$in", # 'time' => 0, # 'desc1' => undef, # 'desc2' => undef, # }; # } # my $time = $dt; # my $idx = 0; # while( $n_taxa > 1 ) { # if ( event($dt * $spec_rate, $n_taxa) ) { # my $pick = int $self->random($n_taxa); # my $pick2 = int $self->random($n_taxa); # while( $pick2 == $pick ) { # $pick2 = int $self->random($n_taxa); # } # to finish.... # $tree[$swap]->{'desc1'} = $nodeindex; # } # } # $list[$pick] = $list[$in-1]; # $pick = int rand($in - 1); # $nodeindex = $list[$pick]; # $tree[$swap]->{'desc2'} = $nodeindex; # $list[$pick] = $swap; # $tree[$swap]->{'time'} = $times[$ix++]; # } } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/Statistics.pm��������������������������������������������������������������000444��000765��000024�� 57654�12254227331� 17576� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::Statistics # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::Statistics - Calculate certain statistics for a Tree =head1 SYNOPSIS use Bio::Tree::Statistics; =head1 DESCRIPTION This should be where Tree statistics are calculated. It was previously where statistics from a Coalescent simulation. It now contains several methods for calculating L<Tree-Trait statistics>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason AT bioperl.org =head1 CONTRIBUTORS Heikki Lehvaslaiho, heikki at bioperl dot org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::Statistics; use strict; use base qw(Bio::Root::Root); =head2 new Title : new Usage : my $obj = Bio::Tree::Statistics->new(); Function: Builds a new Bio::Tree::Statistics object Returns : Bio::Tree::Statistics Args : =head2 assess_bootstrap Title : assess_bootstrap Usage : my $tree_with_bs = $stats->assess_bootstrap(\@bs_trees); Function: Calculates the bootstrap for internal nodes based on Returns : L<Bio::Tree::TreeI> Args : Arrayref of L<Bio::Tree::TreeI>s =cut sub assess_bootstrap{ my ($self,$bs_trees,$guide_tree) = @_; my @consensus; # internal nodes are defined by their children my (%lookup,%internal); my $i = 0; for my $tree ( $guide_tree, @$bs_trees ) { # Do this as a top down approach, can probably be # improved by caching internal node states, but not going # to worry about it right now. my @allnodes = $tree->get_nodes; my @internalnodes = grep { ! $_->is_Leaf } @allnodes; for my $node ( @internalnodes ) { my @tips = sort map { $_->id } grep { $_->is_Leaf() } $node->get_all_Descendents; my $id = "(".join(",", @tips).")"; if( $i == 0 ) { $internal{$id} = $node->internal_id; } else { $lookup{$id}++; } } $i++; } my @save; for my $l ( keys %lookup ) { if( defined $internal{$l} ) {#&& $lookup{$l} > $min_seen ) { my $intnode = $guide_tree->find_node(-internal_id => $internal{$l}); $intnode->bootstrap(sprintf("%d",100 * $lookup{$l} / $i)); } } return $guide_tree; } =head2 cherries Example : cherries($tree, $node); Description: Count number of paired leaf nodes in a binary tree Returns : integer Exceptions : Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Commonly used statistics assume a binary tree, but this methods returns a value even for trees with polytomies. =cut sub cherries ($;$) { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; my $cherries = 0; my @descs = $node->each_Descendent; if ($descs[0]->is_Leaf and $descs[1]->is_Leaf) { if ($descs[3]) { #polytomy at leaf level $cherries = 0; } else { $cherries = 1; } } else { # recurse foreach my $desc (@descs) { $cherries += $self->cherries($tree, $desc); } } return $cherries; } =head2 Tree-Trait statistics The following methods produce descriptors of trait distribution among leaf nodes within the trees. They require that a trait has been set for each leaf node. The tag methods of Bio::Tree::Node are used to store them as key/value pairs. In this way, one tree can store more than one trait. Trees have method add_traits() to set trait values from a file. See the add_trait() method in L<Bio::Tree::TreeFunctionsI>. =head2 fitch Example : fitch($tree, $key, $node); Description: Calculates Parsimony Score (PS) and internal trait values using the Fitch 1971 parsimony algorithm for the subtree a defined by the (internal) node. Node defaults to the root. Returns : true on success Exceptions : leaf nodes have to have the trait defined Args : 1. Bio::Tree::TreeI object 2. trait name string 3. Bio::Tree::NodeI object within the tree, optional Runs first L<fitch_up> that calculates parsimony scores and then L<fitch_down> that should resolve most of the trait/character state ambiguities. Fitch, W.M., 1971. Toward defining the course of evolution: minimal change for a specific tree topology. Syst. Zool. 20, 406-416. You can access calculated parsimony values using: $score = $node->->get_tag_values('ps_score'); and the trait value with: $traitvalue = $node->->get_tag_values('ps_trait'); # only the first @traitvalues = $node->->get_tag_values('ps_trait'); Note that there can be more that one trait value, especially for the root node. =cut sub fitch { my $self = shift; my $tree = shift; my $key = shift || $self->throw("Trait name is needed"); my $node = shift || $tree->get_root_node; $self->fitch_up($tree, $key, $node); $self->fitch_down($tree, $node); } =head2 ps Example : ps($tree, $key, $node); Description: Calculates Parsimony Score (PS) from Fitch 1971 parsimony algorithm for the subtree as defined by the (internal) node. Node defaults to the root. Returns : integer, 1 < PS < n, where n is number of branches Exceptions : leaf nodes have to have the trait defined Args : 1. Bio::Tree::TreeI object 2. trait name string 3. Bio::Tree::NodeI object within the tree, optional This is the first half of the Fitch algorithm that is enough for calculating the resolved parsimony values. The trait/chararacter states are commonly left in ambiguous state. To resolve them, run L<fitch_down>. =cut sub ps { shift->fitch_up(@_) } =head2 fitch_up Example : fitch_up($tree, $key, $node); Description: Calculates Parsimony Score (PS) from the Fitch 1971 parsimony algorithm for the subtree as defined by the (internal) node. Node defaults to the root. Returns : integer, 1< PS < n, where n is number of branches Exceptions : leaf nodes have to have the trait defined Args : 1. Bio::Tree::TreeI object 2. trait name string 3. Bio::Tree::NodeI object within the tree, optional This is a more generic name for L<ps> and indicates that it performs the first bottom-up tree traversal that calculates the parsimony score but usually leaves trait/character states ambiguous. If you are interested in internal trait states, running L<fitch_down> should resolve most of the ambiguities. =cut sub fitch_up { my $self = shift; my $tree = shift; my $key = shift || $self->throw("Trait name is needed"); my $node = shift || $tree->get_root_node; if ($node->is_Leaf) { $self->throw ("ERROR: ". $node->internal_id. " needs a value for trait $key") unless $node->has_tag($key); $node->set_tag_value('ps_trait', $node->get_tag_values($key) ); $node->set_tag_value('ps_score', 0 ); return; # end of recursion } foreach my $child ($node->each_Descendent) { $self->fitch_up($tree, $key, $child); } my %intersection; my %union; my $score; foreach my $child ($node->each_Descendent) { foreach my $trait ($child->get_tag_values('ps_trait') ) { $intersection{$trait}++ if $union{$trait}; $union{$trait}++; } $score += $child->get_tag_values('ps_score'); } if (keys %intersection) { $node->set_tag_value('ps_trait', keys %intersection); $node->set_tag_value('ps_score', $score); } else { $node->set_tag_value('ps_trait', keys %union); $node->set_tag_value('ps_score', $score+1); } if ($self->verbose) { print "-- node --------------------------\n"; print "iID: ", $node->internal_id, " (", $node->id, ")\n"; print "Trait: ", join (', ', $node->get_tag_values('ps_trait') ), "\n"; print "length :", scalar($node->get_tag_values('ps_score')) , "\n"; } return scalar $node->get_tag_values('ps_score'); } =head2 fitch_down Example : fitch_down($tree, $node); Description: Runs the second pass from Fitch 1971 parsimony algorithm to resolve ambiguous trait states left by first pass. by the (internal) node. Node defaults to the root. Returns : true Exceptions : dies unless the trait is defined in all nodes Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Before running this method you should have ran L<fitch_up> (alias to L<ps> ). Note that it is not guaranteed that all states are completely resolved. =cut sub fitch_down { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; my $key = 'ps_trait'; $self->throw ("ERROR: ". $node->internal_id. " needs a value for $key") unless $node->has_tag($key); my $nodev; foreach my $trait ($node->get_tag_values($key) ) { $nodev->{$trait}++; } foreach my $child ($node->each_Descendent) { next if $child->is_Leaf; # end of recursion my $intersection; foreach my $trait ($child->get_tag_values($key) ) { $intersection->{$trait}++ if $nodev->{$trait}; } $self->fitch_down($tree, $child); $child->set_tag_value($key, keys %$intersection); } return 1; # success } =head2 persistence Example : persistence($tree, $node); Description: Calculates the persistence for node in the subtree defined by the (internal) node. Node defaults to the root. Returns : int, number of generations trait value has to remain same Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Persistence measures the stability that the trait value has in a tree. It expresses the number of generations the trait value remains the same. All the decendants of the root in the same generation have to share the same value. Depends on Fitch's parsimony score (PS). =cut sub _persistence { my $self = shift; my $tree = shift; my $node = shift; my $value = shift || $self->throw("Value is needed"); my $key = 'ps_trait'; $self->throw("Node is needed") unless $node->isa('Bio::Tree::NodeI'); return 0 unless $node->get_tag_values($key) eq $value; # wrong value return 1 if $node->is_Leaf; # end of recursion my $persistence = 10000000; # an arbitrarily large number foreach my $child ($node->each_Descendent) { my $pers = $self->_persistence($tree, $child, $value); $persistence = $pers if $pers < $persistence; } return $persistence + 1; } sub persistence { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; $self->throw("Node is needed") unless $node->isa('Bio::Tree::NodeI'); my $key = 'ps_trait'; my $value = $node->get_tag_values($key); #calculate my $persistence = $self->_persistence($tree, $node, $value); $node->set_tag_value('persistance', $persistence); return $persistence; } =head2 count_subclusters Example : count_clusters($tree, $node); Description: Calculates the number of sub-clusters in the subtree defined by the (internal) node. Node defaults to the root. Returns : int, count Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Depends on Fitch's parsimony score (PS). =cut sub _count_subclusters { my $self = shift; my $tree = shift; my $node = shift; my $value = shift || $self->throw("Value is needed"); my $key = 'ps_trait'; $self->throw ("ERROR: ". $node->internal_id. " needs a value for trait $key") unless $node->has_tag($key); if ($node->get_tag_values($key) eq $value) { if ($node->get_tag_values('ps_score') == 0) { return 0; } else { my $count = 0; foreach my $child ($node->each_Descendent) { $count += $self->_count_subclusters($tree, $child, $value); } return $count; } } return 1; } sub count_subclusters { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; $self->throw("Node is needed") unless $node->isa('Bio::Tree::NodeI'); my $key = 'ps_trait'; my $value = $node->get_tag_values($key); return $self->_count_subclusters($tree, $node, $value); } =head2 count_leaves Example : count_leaves($tree, $node); Description: Calculates the number of leaves with same trait value as root in the subtree defined by the (internal) node. Requires an unbroken line of identical trait values. Node defaults to the root. Returns : int, number of leaves with this trait value Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Depends on Fitch's parsimony score (PS). =cut sub _count_leaves { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; my $value = shift; my $key = 'ps_trait'; $self->throw ("ERROR: ". $node->internal_id. " needs a value for trait $key") unless $node->has_tag($key); if ($node->get_tag_values($key) eq $value) { #print $node->id, ": ", $node->get_tag_values($key), "\n"; return 1 if $node->is_Leaf; # end of recursion my $count = 0; foreach my $child ($node->each_Descendent) { $count += $self->_count_leaves($tree, $child, $value); } return $count; } return 0; } sub count_leaves { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; $self->throw("Node is needed") unless $node->isa('Bio::Tree::NodeI'); my $key = 'ps_trait'; my $value = $node->get_tag_values($key); return $self->_count_leaves($tree, $node, $value); } =head2 phylotype_length Example : phylotype_length($tree, $node); Description: Sums up the branch lengths within phylotype exluding the subclusters where the trait values are different Returns : float, length Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Depends on Fitch's parsimony score (PS). =cut sub _phylotype_length { my $self = shift; my $tree = shift; my $node = shift; my $value = shift; my $key = 'ps_trait'; $self->throw ("ERROR: ". $node->internal_id. " needs a value for trait $key") unless $node->has_tag($key); return 0 if $node->get_tag_values($key) ne $value; return $node->branch_length if $node->is_Leaf; # end of recursion my $length = 0; foreach my $child ($node->each_Descendent) { my $sub_len = $self->_phylotype_length($tree, $child, $value); $length += $sub_len; $length += $child->branch_length if not $child->is_Leaf and $sub_len; } return $length; } sub phylotype_length { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; my $key = 'ps_trait'; my $value = $node->get_tag_values($key); return $self->_phylotype_length($tree, $node, $value); } =head2 sum_of_leaf_distances Example : sum_of_leaf_distances($tree, $node); Description: Sums up the branch lengths from root to leaf exluding the subclusters where the trait values are different Returns : float, length Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Depends on Fitch's parsimony score (PS). =cut sub _sum_of_leaf_distances { my $self = shift; my $tree = shift; my $node = shift; my $value = shift; my $key = 'ps_trait'; $self->throw ("ERROR: ". $node->internal_id. " needs a value for trait $key") unless $node->has_tag($key); return 0 if $node->get_tag_values($key) ne $value; #return $node->branch_length if $node->is_Leaf; # end of recursion return 0 if $node->is_Leaf; # end of recursion my $length = 0; foreach my $child ($node->each_Descendent) { $length += $self->_count_leaves($tree, $child, $value) * $child->branch_length + $self->_sum_of_leaf_distances($tree, $child, $value); } return $length; } sub sum_of_leaf_distances { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; my $key = 'ps_trait'; my $value = $node->get_tag_values($key); return $self->_sum_of_leaf_distances($tree, $node, $value); } =head2 genetic_diversity Example : genetic_diversity($tree, $node); Description: Diversity is the sum of root to leaf distances within the phylotype normalised by number of leaf nodes Returns : float, value of genetic diversity Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Depends on Fitch's parsimony score (PS). =cut sub genetic_diversity { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; return $self->sum_of_leaf_distances($tree, $node) / $self->count_leaves($tree, $node); } =head2 statratio Example : statratio($tree, $node); Description: Ratio of the stem length and the genetic diversity of the phylotype L<genetic_diversity> Returns : float, separation score Exceptions : all the nodes need to have the trait defined Args : 1. Bio::Tree::TreeI object 2. Bio::Tree::NodeI object within the tree, optional Statratio gives a measure of separation and variability within the phylotype. Larger values identify more rapidly evolving and recent phylotypes. Depends on Fitch's parsimony score (PS). =cut sub statratio { my $self = shift; my $tree = shift; my $node = shift || $tree->get_root_node; my $div = $self->genetic_diversity($tree, $node); return 0 if $div == 0; return $node->branch_length / $div; } =head2 ai Example : ai($tree, $key, $node); Description: Calculates the Association Index (AI) of Whang et al. 2001 for the subtree defined by the (internal) node. Node defaults to the root. Returns : real Exceptions : leaf nodes have to have the trait defined Args : 1. Bio::Tree::TreeI object 2. trait name string 3. Bio::Tree::NodeI object within the tree, optional Association index (AI) gives a more fine grained results than PS since the result is a real number. ~0 E<lt>= AI. Wang, T.H., Donaldson, Y.K., Brettle, R.P., Bell, J.E., Simmonds, P., 2001. Identification of shared populations of human immunodeficiency Virus Type 1 infecting microglia and tissue macrophages outside the central nervous system. J. Virol. 75 (23), 11686-11699. =cut sub _node_ai { my $self = shift; my $node = shift; my $key = shift; my $traits; my $leaf_count = 0; for my $desc ( $node->get_all_Descendents ) { next unless $desc->is_Leaf; $leaf_count++; $self->throw ("Node ". $desc->id. " needs a value for trait [$key]") unless $desc->has_tag($key); my $trait = $desc->get_tag_values($key); $traits->{$trait}++; } my $most_common = 0; foreach ( keys %$traits) { $most_common = $traits->{$_} if $traits->{$_} > $most_common; } return sprintf "%1.6f", (1 - ($most_common/$leaf_count) ) / (2**($leaf_count-1) ); } sub ai { my $self = shift; my $tree = shift; my $key = shift || $self->throw("Trait name is needed"); my $start_node = shift || $tree->get_root_node; return unless $start_node; my $sum = 0; for my $node ( $start_node->get_all_Descendents ) { next if $node->is_Leaf; $sum += $self->_node_ai($node, $key); } return $sum; } =head2 mc Example : mc($tree, $key, $node); Description: Calculates the Monophyletic Clade (MC) size statistics for the subtree a defined by the (internal) node. Node defaults to the root; Returns : hashref with trait values as keys Exceptions : leaf nodes have to have the trait defined Args : 1. Bio::Tree::TreeI object 2. trait name string 3. Bio::Tree::NodeI object within the tree, optional Monophyletic Clade (MC) size statistics by Salemi at al 2005. It is calculated for each trait value. 1 E<lt>= MC E<lt>= nx, where nx is the number of tips with value x: pick the internal node with maximim value for number of of tips with only trait x MC was defined by Parker et al 2008. Salemi, M., Lamers, S.L., Yu, S., de Oliveira, T., Fitch, W.M., McGrath, M.S., 2005. Phylodynamic analysis of Human Immunodeficiency Virus Type 1 in distinct brain compartments provides a model for the neuropathogenesis of AIDS. J. Virol. 79 (17), 11343-11352. Parker, J., Rambaut A., Pybus O., 2008. Correlating viral phenotypes with phylogeny: Accounting for phylogenetic uncertainty Infection, Genetics and Evolution 8 (2008), 239-246. =cut sub _node_mc { my $self = shift; my $node = shift; my $key = shift; my $traits; my $leaf_count = 0; for my $node2 ( $node->get_all_Descendents ) { next unless $node2->is_Leaf; $leaf_count++; my $trait = $node2->get_tag_values($key); $traits->{$trait}++; } return $traits; } sub mc { my $self = shift; my $tree = shift; my $key = shift || die "Trait name is needed"; my $start_node = shift || $tree->get_root_node; return unless $start_node; my $sum; # hashref, keys are trait values my $keys; # hashref, keys are trait values foreach my $node ( $start_node->get_all_Descendents ) { next if $node->is_Leaf; my $traits = $self->_node_mc($node, $key); if (scalar keys %$traits == 1) { my ($value) = keys %$traits; no warnings; $sum->{$value} = $traits->{$value} if $sum->{$value} < $traits->{$value}; } else { map { $keys->{$_} = 1 } keys %$traits; } } # check for cases where there are no clusters foreach my $value (keys %$keys) { $sum->{$value} = 1 unless defined $sum->{$value}; } return $sum; } 1; ������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/Tree.pm��������������������������������������������������������������������000444��000765��000024�� 35246�12254227320� 16332� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::Tree # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::Tree - An implementation of the TreeI interface. =head1 SYNOPSIS use Bio::TreeIO; # like from a TreeIO my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 'treefile.dnd'); my $tree = $treeio->next_tree; my @nodes = $tree->get_nodes; my $root = $tree->get_root_node; =head1 DESCRIPTION This object holds handles to Nodes which make up a tree. =head1 IMPLEMENTATION NOTE This implementation of Bio::Tree::Tree contains Bio::Tree:::NodeI; mainly linked via the root node. As NodeI can potentially contain circular references (as nodes will need to refer to both parent and child nodes), Bio::Tree::Tree will remove those circular references when the object is garbage-collected. This has some side effects; primarily, one must keep the Tree in scope or have at least one reference to it if working with nodes. The fix is to count the references to the nodes and if it is greater than expected retain all of them, but it requires an additional prereq and thus may not be worth the effort. This only shows up in minor edge cases, though (see Bug #2869). Example of issue: # tree is not assigned to a variable, so passes from memory after # root node is passed my $root = Bio::TreeIO->new(-format => 'newick', -file => 'foo.txt')->next_tree ->get_root_node; # gets nothing, as all Node links are broken when Tree is garbage-collected above my @descendents = $root->get_all_Descendents; =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Aaron Mackey amackey@virginia.edu Sendu Bala bix@sendu.me.uk Mark A. Jensen maj@fortinbras.us =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::Tree; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::Root::Root Bio::Tree::TreeI Bio::Tree::TreeFunctionsI); =head2 new Title : new Usage : my $obj = Bio::Tree::Tree->new(); Function: Builds a new Bio::Tree::Tree object Returns : Bio::Tree::Tree Args : -root => L<Bio::Tree::NodeI> object which is the root OR -node => L<Bio::Tree::NodeI> object from which the root will be determined -nodelete => boolean, whether or not to try and cleanup all the nodes when this this tree goes out of scope. -id => optional tree ID -score => optional tree score value =cut sub new { my ($class, @args) = @_; my $self = $class->SUPER::new(@args); $self->{'_rootnode'} = undef; $self->{'_maxbranchlen'} = 0; $self->_register_for_cleanup(\&cleanup_tree); my ($root, $node, $nodel, $id, $score) = $self->_rearrange([qw(ROOT NODE NODELETE ID SCORE)], @args); if ($node && ! $root) { $self->throw("Must supply a Bio::Tree::NodeI") unless ref($node) && $node->isa('Bio::Tree::NodeI'); my @lineage = $self->get_lineage_nodes($node); $root = shift(@lineage) || $node; # to stop us pulling in entire database of a Bio::Taxon when we later do # get_nodes() or similar, specifically set ancestor() for each node if ($node->isa('Bio::Taxon')) { push(@lineage, $node) unless $node eq $root; my $ancestor = $root; foreach my $lineage_node (@lineage) { $lineage_node->ancestor($ancestor); } continue { $ancestor = $lineage_node; } } } if ($root) { $self->set_root_node($root); } $self->nodelete($nodel || 0); $self->id($id) if defined $id; $self->score($score) if defined $score; return $self; } =head2 nodelete Title : nodelete Usage : $obj->nodelete($newval) Function: Get/Set Boolean whether or not to delete the underlying nodes when it goes out of scope. By default this is false meaning trees are cleaned up. Returns : boolean Args : on set, new boolean value =cut sub nodelete { my $self = shift; return $self->{'nodelete'} = shift if @_; return $self->{'nodelete'}; } =head2 get_nodes Title : get_nodes Usage : my @nodes = $tree->get_nodes() Function: Return list of Bio::Tree::NodeI objects Returns : array of Bio::Tree::NodeI objects Args : (named values) hash with one value order => 'b|breadth' first order or 'd|depth' first order sortby => [optional] "height", "creation", "alpha", "revalpha", or coderef to be used to sort the order of children nodes. See L<Bio::Tree::Node> for details =cut sub get_nodes { my ($self, @args) = @_; my ($order, $sortby) = $self->_rearrange([qw(ORDER SORTBY)], @args); $order ||= 'depth'; $sortby ||= 'none'; my @children; my $node = $self->get_root_node; if ($node) { if ($order =~ m/^b/oi) { # breadth-first @children = ($node); my @to_process = ($node); while( @to_process ) { my $n = shift @to_process; my @c = $n->each_Descendent($sortby); push @children, @c; push @to_process, @c; } } elsif ($order =~ m/^d/oi) { # depth-first @children = ($node, $node->get_all_Descendents($sortby)); } else { $self->verbose(1); $self->warn("specified an order '$order' which I don't understan\n"); } } return @children; } =head2 get_root_node Title : get_root_node Usage : my $node = $tree->get_root_node(); Function: Get the Top Node in the tree, in this implementation Trees only have one top node. Returns : Bio::Tree::NodeI object Args : none =cut sub get_root_node { my ($self) = @_; return $self->{'_rootnode'}; } =head2 set_root_node Title : set_root_node Usage : $tree->set_root_node($node) Function: Set the Root Node for the Tree Returns : Bio::Tree::NodeI Args : Bio::Tree::NodeI =cut sub set_root_node { my $self = shift; if ( @_ ) { my $value = shift; if ( defined $value && ! $value->isa('Bio::Tree::NodeI') ) { $self->warn("Trying to set the root node to $value which is not a Bio::Tree::NodeI"); return $self->get_root_node; } $self->{'_rootnode'} = $value; } return $self->get_root_node; } =head2 total_branch_length Title : total_branch_length Usage : my $size = $tree->total_branch_length Function: Returns the sum of the length of all branches Returns : real Args : none =cut sub total_branch_length { shift->subtree_length } =head2 subtree_length Title : subtree_length Usage : my $subtree_size = $tree->subtree_length($internal_node) Function: Returns the sum of the length of all branches in a subtree under the node. Calculates the size of the whole tree without an argument (but only if root node is defined) Returns : real or undef Args : Bio::Tree::NodeI object, defaults to the root node =cut sub subtree_length { my $tree = shift; my $node = shift || $tree->get_root_node; return unless $node; my $sum = 0; for ( $node->get_all_Descendents ) { $sum += $_->branch_length || 0; } return $sum; } =head2 id Title : id Usage : my $id = $tree->id(); Function: An id value for the tree Returns : scalar Args : [optional] new value to set =cut sub id { my ($self, $val) = @_; if ( defined $val ) { $self->{'_treeid'} = $val; } return $self->{'_treeid'}; } =head2 score Title : score Usage : $obj->score($newval) Function: Sets the associated score with this tree This is a generic slot which is probably best used for log likelihood or other overall tree score Returns : value of score Args : newvalue (optional) =cut sub score { my ($self, $val) = @_; if ( defined $val ) { $self->{'_score'} = $val; } return $self->{'_score'}; } # decorated interface TreeI Implements this =head2 height Title : height Usage : my $height = $tree->height Function: Gets the height of tree - this LOG_2($number_nodes) WARNING: this is only true for strict binary trees. The TreeIO system is capable of building non-binary trees, for which this method will currently return an incorrect value!! Returns : integer Args : none =head2 number_nodes Title : number_nodes Usage : my $size = $tree->number_nodes Function: Returns the number of nodes in the tree Returns : integer Args : none =head2 as_text Title : as_text Usage : my $tree_as_string = $tree->as_text($format) Function: Returns the tree as a string representation in the desired format, e.g.: 'newick', 'nhx' or 'tabtree' (the default) Returns : scalar string Args : format type as specified by Bio::TreeIO Note : This method loads the Bio::TreeIO::$format module on the fly, and commandeers the _write_tree_Helper routine therein to create the tree string. =cut sub as_text { my $self = shift; my $format = shift || 'tabtree'; my $params_input = shift || {}; my $iomod = "Bio::TreeIO::$format"; $self->_load_module($iomod); my $string = ''; open my $fh, '>', \$string or die "Couldn't open $string as file: $!\n"; my $test = $iomod->new( -format => $format, -fh => $fh ); # Get the default params for the given IO module. $test->set_params($params_input); $test->write_tree($self); close $fh; return $string; } =head2 Methods for associating Tag/Values with a Tree These methods associate tag/value pairs with a Tree =head2 set_tag_value Title : set_tag_value Usage : $tree->set_tag_value($tag,$value) $tree->set_tag_value($tag,@values) Function: Sets a tag value(s) to a tree. Replaces old values. Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub set_tag_value { my ($self, $tag, @values) = @_; if ( ! defined $tag || ! scalar @values ) { $self->warn("cannot call set_tag_value with an undefined value"); } $self->remove_tag ($tag); map { push @{$self->{'_tags'}->{$tag}}, $_ } @values; return scalar @{$self->{'_tags'}->{$tag}}; } =head2 add_tag_value Title : add_tag_value Usage : $tree->add_tag_value($tag,$value) Function: Adds a tag value to a tree Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub add_tag_value { my ($self, $tag, $value) = @_; if ( ! defined $tag || ! defined $value ) { $self->warn("cannot call add_tag_value with an undefined value"); } push @{$self->{'_tags'}->{$tag}}, $value; return scalar @{$self->{'_tags'}->{$tag}}; } =head2 remove_tag Title : remove_tag Usage : $tree->remove_tag($tag) Function: Remove the tag and all values for this tag Returns : boolean representing success (0 if tag does not exist) Args : $tag - tagname to remove =cut sub remove_tag { my ($self, $tag) = @_; if ( exists $self->{'_tags'}->{$tag} ) { $self->{'_tags'}->{$tag} = undef; delete $self->{'_tags'}->{$tag}; return 1; } return 0; } =head2 remove_all_tags Title : remove_all_tags Usage : $tree->remove_all_tags() Function: Removes all tags Returns : None Args : None =cut sub remove_all_tags { my ($self) = @_; $self->{'_tags'} = {}; return; } =head2 get_all_tags Title : get_all_tags Usage : my @tags = $tree->get_all_tags() Function: Gets all the tag names for this Tree Returns : Array of tagnames Args : None =cut sub get_all_tags { my ($self) = @_; my @tags = sort keys %{$self->{'_tags'} || {}}; return @tags; } =head2 get_tag_values Title : get_tag_values Usage : my @values = $tree->get_tag_values($tag) Function: Gets the values for given tag ($tag) Returns : Array of values or empty list if tag does not exist Args : $tag - tag name =cut sub get_tag_values { my ($self, $tag) = @_; return wantarray ? @{$self->{'_tags'}->{$tag} || []} : (@{$self->{'_tags'}->{$tag} || []})[0]; } =head2 has_tag Title : has_tag Usage : $tree->has_tag($tag) Function: Boolean test if tag exists in the Tree Returns : Boolean Args : $tag - tagname =cut sub has_tag { my ($self, $tag) = @_; return exists $self->{'_tags'}->{$tag}; } # safe tree clone that doesn't seg fault =head2 clone Title : clone Alias : _clone Usage : $tree_copy = $tree->clone(); $subtree_copy = $tree->clone($internal_node); Function: Safe tree clone that doesn't segfault Returns : Bio::Tree::Tree object Args : [optional] $start_node, Bio::Tree::Node object =cut sub clone { my ($self, $parent, $parent_clone) = @_; $parent ||= $self->get_root_node; $parent_clone ||= $self->_clone_node($parent); foreach my $node ($parent->each_Descendent()) { my $child = $self->_clone_node($node); $child->ancestor($parent_clone); $self->_clone($node, $child); } $parent->ancestor && return; my $tree = $self->new(-root => $parent_clone); return $tree; } # -- private internal methods -- sub cleanup_tree { my $self = shift; unless( $self->nodelete ) { for my $node ($self->get_nodes(-order => 'b', -sortby => 'none')) { $node->node_cleanup; } } $self->{'_rootnode'} = undef; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/TreeFunctionsI.pm����������������������������������������������������������000444��000765��000024�� 104660�12254227316� 20356� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::TreeFunctionsI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::TreeFunctionsI - Decorated Interface implementing basic Tree exploration methods =head1 SYNOPSIS use Bio::TreeIO; my $in = Bio::TreeIO->new(-format => 'newick', -file => 'tree.tre'); my $tree = $in->next_tree; my @nodes = $tree->find_node('id1'); if( $tree->is_monophyletic(-nodes => \@nodes, -outgroup => $outnode) ){ #... } =head1 DESCRIPTION This interface provides a set of implementated Tree functions which only use the defined methods in the TreeI or NodeI interface. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich, Aaron Mackey, Justin Reese Email jason-at-bioperl-dot-org Email amackey-at-virginia.edu Email jtr4v-at-virginia.edu =head1 CONTRIBUTORS Sendu Bala, bix@sendu.me.uk Rerooting code was worked on by Daniel Barker d.barker-at-reading.ac.uk Ramiro Barrantes Ramiro.Barrantes-at-uvm.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::TreeFunctionsI; use strict; use base qw(Bio::Tree::TreeI); =head2 find_node Title : find_node Usage : my @nodes = $self->find_node(-id => 'node1'); Function: returns all nodes that match a specific field, by default this is id, but different branch_length, Returns : List of nodes which matched search Args : text string to search for OR -fieldname => $textstring =cut sub find_node { my ($self, $type, $field) = @_; if( ! defined $type ) { $self->warn("Must request a either a string or field and string when searching"); } # all this work for a '-' named field # is so that we could potentially # expand to other constraints in # different implementations # like 'find all nodes with boostrap < XX' if( ! defined $field ) { # only 1 argument, default to searching by id $field = $type; $type = 'id'; } else { $type =~ s/^-//; } # could actually do this by testing $rootnode->can($type) but # it is possible that a tree is implemeted with different node types # - although it is unlikely that the root node would be richer than the # leaf nodes. Can't handle NHX tags right now my @nodes = grep { $_->can($type) && defined $_->$type() && $_->$type() eq $field } $self->get_nodes(); if ( wantarray) { return @nodes; } else { if( @nodes > 1 ) { $self->warn("More than 1 node found but caller requested scalar, only returning first node"); } return shift @nodes; } } =head2 remove_Node Title : remove_Node Usage : $tree->remove_Node($node) Function: Removes a node from the tree Returns : boolean represent status of success Args : either Bio::Tree::NodeI or string of the node id =cut sub remove_Node { my ($self,$input) = @_; my $node = undef; unless( ref($input) ) { $node = $self->find_node($input); } elsif( ! $input->isa('Bio::Tree::NodeI') ) { $self->warn("Did not provide either a valid Bio::Tree::NodeI object or id to remove_node"); return 0; } else { $node = $input; } if( ! $node->ancestor && $self->get_root_node->internal_id != $node->internal_id) { $self->warn("Node (".$node->to_string . ") has no ancestor, can't remove!"); } else { $node->ancestor->remove_Descendent($node); } } =head2 get_lineage_nodes Title : get_lineage_nodes Usage : my @nodes = $tree->get_lineage_nodes($node); Function: Given a node or its ID, get its full lineage, i.e. all its ancestors, from the root to the most recent ancestor. Only use the node ID as input if the nodes have been added to the tree. Returns : list of nodes Args : either Bio::Tree::NodeI (or string of the node id) =cut sub get_lineage_nodes { my ($self, $input) = @_; my $node; # Sanity checks if (ref $input) { if (not $input->isa('Bio::Tree::NodeI')) { $self->throw("Did not provide a valid Bio::Tree::NodeI object or ID string to get_lineage_nodes"); } $node = $input; } else { $node = $self->find_node($input); } # When dealing with Bio::Taxon objects with databases, the root will always # be the database's root, ignoring this Tree's set root node; prefer the # Tree's idea of root. my $root = $self->get_root_node || ''; my @lineage; while ($node) { $node = $node->ancestor || last; unshift(@lineage, $node); $node eq $root && last; } return @lineage; } =head2 get_lineage_string Title : get_lineage_string Usage : my $lineage = $tree->get_lineage_string($node); Function: Get the string representation of the full lineage of a node, e.g. for the Enterobacteriales node, return Bacteria;Proteobacteria;Gammaproteobacteria;Enterobacteriales. This method uses get_lineage_nodes internally and therefore inherits of all of its caveats. Returns : string Args : * either Bio::Tree::NodeI (or string of the node id) * an optional separator (default: ';') =cut sub get_lineage_string { my ($self, $input, $sep) = @_; $sep ||= ';'; my $node; unless (ref $input) { $node = $self->find_node($input); } elsif (! $input->isa('Bio::Tree::NodeI')) { $self->warn("Did not provide either a valid Bio::Tree::NodeI object or id to get_lineage_nodes"); return; } else { $node = $input; } my @nodes = ($self->get_lineage_nodes($node), $node); for my $i (0 .. scalar @nodes - 1) { my $node_name = $nodes[$i]->node_name || ''; if ($node_name =~ m/$sep/) { $self->warn("Separator '$sep' is not safe to use because the node ". "called '$node_name' contains it. Consider using another separator". " or sanitizing the node name."); } $nodes[$i] = $node_name; } return join $sep, @nodes; } =head2 splice Title : splice Usage : $tree->splice(-remove_id => \@ids); Function: Remove all the nodes from a tree that correspond to the supplied args, making all the descendents of a removed node the descendents of the removed node's ancestor. You can ask to explicitly remove certain nodes by using -remove_*, remove them conditionally by using -remove_* in combination with -keep_*, or remove everything except certain nodes by using only -keep_*. Returns : n/a Args : just a list of Bio::Tree::NodeI objects to remove, OR -key => value pairs, where -key has the prefix 'remove' or 'keep', followed by an underscore, followed by a fieldname (like for the method find_node). Value should be a scalar or an array ref of scalars (again, like you might supply to find_node). So (-remove_id => [1, 2]) will remove all nodes from the tree that have an id() of '1' or '2', while (-remove_id => [1, 2], -keep_id => [2]) will remove all nodes with an id() of '1'. (-keep_id => [2]) will remove all nodes unless they have an id() of '2' (note, no -remove_*). -preserve_lengths => 1 : setting this argument will splice out intermediate nodes, preserving the original total length between the ancestor and the descendants of the spliced node. Undef by default. =cut sub splice { my ($self, @args) = @_; $self->throw("Must supply some arguments") unless @args > 0; my $preserve_lengths = 0; my @nodes_to_remove; if (ref($args[0])) { $self->throw("When supplying just a list of Nodes, they must be Bio::Tree::NodeI objects") unless $args[0]->isa('Bio::Tree::NodeI'); @nodes_to_remove = @args; } else { $self->throw("When supplying -key => value pairs, must be an even number of args") unless @args % 2 == 0; my %args = @args; my @keep_nodes; my @remove_nodes; my $remove_all = 1; while (my ($key, $value) = each %args) { my @values = ref($value) ? @{$value} : ($value); if ($key =~ s/remove_//) { $remove_all = 0; foreach my $value (@values) { push(@remove_nodes, $self->find_node($key => $value)); } } elsif ($key =~ s/keep_//) { foreach my $value (@values) { push(@keep_nodes, $self->find_node($key => $value)); } } elsif ($key =~ /preserve/) { $preserve_lengths = $value; } } if ($remove_all) { if (@keep_nodes == 0) { $self->warn("Requested to remove everything except certain nodes, but those nodes were not found; doing nothing instead"); return; } @remove_nodes = $self->get_nodes; } if (@keep_nodes > 0) { my %keep_iids = map { $_->internal_id => 1 } @keep_nodes; foreach my $node (@remove_nodes) { push(@nodes_to_remove, $node) unless exists $keep_iids{$node->internal_id}; } } else { @nodes_to_remove = @remove_nodes; } } # do the splicing #*** the algorithm here hasn't really been thought through and tested much, # will probably need revising my %root_descs; my $reroot = 0; foreach my $node (@nodes_to_remove) { my @descs = $node->each_Descendent; my $ancestor = $node->ancestor; if (! $ancestor && ! $reroot) { # we're going to remove the tree root, so will have to re-root the # tree later $reroot = 1; %root_descs = map { $_->internal_id => $_ } @descs; $node->remove_all_Descendents; next; } if (exists $root_descs{$node->internal_id}) { # well, this one can't be the future root anymore delete $root_descs{$node->internal_id}; # but maybe one of this one's descs will become the root foreach my $desc (@descs) { $root_descs{$desc->internal_id} = $desc; } } # make the ancestor of our descendents our own ancestor, and give us # no ancestor of our own to remove us from the tree foreach my $desc (@descs) { $desc->ancestor($ancestor); $desc->branch_length($desc->branch_length + $node->branch_length) if $preserve_lengths; } $node->ancestor(undef); } if ($reroot) { my @candidates = values %root_descs; $self->throw("After splicing, there was no tree root!") unless @candidates > 0; $self->throw("After splicing, the original root was removed but there are multiple candidates for the new root!") unless @candidates == 1; $self->set_root_node($candidates[0]); # not sure its valid to use the reroot() method } } =head2 get_lca Title : get_lca Usage : get_lca(-nodes => \@nodes ); OR get_lca(@nodes); Function: given two or more nodes, returns the lowest common ancestor (aka most recent common ancestor) Returns : node object or undef if there is no common ancestor Args : -nodes => arrayref of nodes to test, OR just a list of nodes =cut sub get_lca { my ($self, @args) = @_; my ($nodes) = $self->_rearrange([qw(NODES)],@args); my @nodes; if (ref($nodes) eq 'ARRAY') { @nodes = @{$nodes}; } else { @nodes = @args; } @nodes >= 2 or $self->throw("At least 2 nodes are required"); # We must go root->leaf to get the correct answer to lca (in a world where # internal_id might not be uniquely assigned), but leaf->root is more # forgiving (eg. lineages may not all have the same root, or they may have # different numbers of 'minor' taxa inbeteen 'major' ones). # # I use root->leaf so that we can easily do multiple nodes at once - no # matter what taxa are below the lca, the lca and all its ancestors ought to # be identical. my @paths; foreach my $node (@nodes) { unless(ref($node) && $node->isa('Bio::Tree::NodeI')) { $self->throw("Cannot process get_lca() with a non-NodeI object ($node)\n"); } my @path = ($self->get_lineage_nodes($node), $node); push(@paths, \@path); } return unless @paths >= 2; my $lca; LEVEL: while ($paths[0] > 0) { my %node_ids; my $node; foreach my $path (@paths) { $node = shift(@{$path}) || last LEVEL; my $node_id = $node->internal_id; unless (defined $node_id) { $self->warn("One of the lineages had a node with no internal_id, can't calculate the common ancestor"); return; } $node_ids{$node_id}++; } if (keys %node_ids == 1) { $lca = $node; } else { # at this point in the lineage the nodes are different; the previous # loop had the lca last LEVEL; } } # If the tree that we are contains the lca (get_lca could have been called # on an empty tree, since it works with plain Nodes), prefer to return the # node object that belongs to us if ($lca && $self->number_nodes > 0) { my $own_lca = $self->find_node(-internal_id => $lca->internal_id); $lca = $own_lca if $own_lca; } return $lca; } =head2 merge_lineage Title : merge_lineage Usage : merge_lineage($node) Function: Merge a lineage of nodes with this tree. Returns : true for success, false (and a warning) otherwise Args : Bio::Tree::TreeI with only one leaf, OR Bio::Tree::NodeI which has an ancestor For example, if we are the tree $tree: +---B | A | +---C and we want to merge the lineage $other_tree: A---C---D After calling $tree->merge_lineage($other_tree), $tree looks like: +---B | A | +---C---D =cut sub merge_lineage { my ($self, $thing) = @_; $self->throw("Must supply an object reference") unless ref($thing); my $lineage_leaf; if ($thing->isa('Bio::Tree::TreeI')) { my @leaves = $thing->get_leaf_nodes; $self->throw("The supplied Tree can only have one leaf") unless @leaves == 1; $lineage_leaf = shift(@leaves); } elsif ($thing->isa('Bio::Tree::NodeI')) { $self->throw("The supplied Node must have an ancestor") unless $thing->ancestor; $lineage_leaf = $thing; } # Find the lowest node in the supplied lineage that is in the tree # That will be our lca and we can merge at the node below my @lineage = ($lineage_leaf, reverse($self->get_lineage_nodes($lineage_leaf))); my $merged = 0; my $node; my $i = 0; while ($i <= $#lineage) { $node = $self->find_node(-internal_id => $lineage[$i]->internal_id); if (defined $node) { $merged = 1; last; } $i++; } if (not $merged) { $self->warn("Could not merge the lineage of ".$lineage_leaf->id." with the rest of the tree"); } # Merge descendents, recursively while ($i > 0) { $node->add_Descendent($lineage[$i-1]); $node = $self->find_node(-internal_id => $lineage[$i-1]->internal_id); $i--; } return $merged; } =head2 contract_linear_paths Title : contract_linear_paths Usage : contract_linear_paths() Function: Splices out all nodes in the tree that have an ancestor and only one descendent. Returns : n/a Args : none for normal behaviour, true to dis-regard the ancestor requirment and re-root the tree as necessary For example, if we are the tree $tree: +---E | A---B---C---D | +---F After calling $tree->contract_linear_paths(), $tree looks like: +---E | A---D | +---F Instead, $tree->contract_linear_paths(1) would have given: +---E | D | +---F =cut sub contract_linear_paths { my $self = shift; my $reroot = shift; my @remove; foreach my $node ($self->get_nodes) { if ($node->ancestor && $node->each_Descendent == 1) { push(@remove, $node); } } $self->splice(@remove) if @remove; if ($reroot) { my $root = $self->get_root_node; my @descs = $root->each_Descendent; if (@descs == 1) { my $new_root = shift(@descs); $self->set_root_node($new_root); $new_root->ancestor(undef); } } } =head2 is_binary Example : is_binary(); is_binary($node); Description: Finds if the tree or subtree defined by the internal node is a true binary tree without polytomies Returns : boolean Exceptions : Args : Internal node Bio::Tree::NodeI, optional =cut sub is_binary { my $self = shift; my $node = shift || $self->get_root_node; my $binary = 1; my @descs = $node->each_Descendent; $binary = 0 unless @descs == 2 or @descs == 0; #print "$binary, ", scalar @descs, "\n"; # recurse foreach my $desc (@descs) { $binary += $self->is_binary($desc) -1; } $binary = 0 if $binary < 0; return $binary; } =head2 force_binary Title : force_binary Usage : force_binary() Function: Forces the tree into a binary tree, splitting branches arbitrarily and creating extra nodes as necessary, such that all nodes have exactly two or zero descendants. Returns : n/a Args : none For example, if we are the tree $tree: +---G | +---F | +---E | A | +---D | +---C | +---B (A has 6 descendants B-G) After calling $tree->force_binary(), $tree looks like: +---X | +---X | | | +---X | +---X | | | | +---G | | | | +---X | | | +---F A | +---E | | | +---X | | | | | +---D | | +---X | | +---C | | +---X | +---B (Where X are artificially created nodes with ids 'artificial_n', where n is an integer making the id unique within the tree) =cut sub force_binary { my $self = shift; my $node = shift || $self->get_root_node; my @descs = $node->each_Descendent; if (@descs > 2) { # Removed overly verbose warning - cjfields 3-12-11 # Many nodes have no identifying names, a simple warning is probably # enough. $self->warn("Node has more than two descendants\nWill do an arbitrary balanced split"); my @working = @descs; # create an even set of artifical nodes on which to later hang the descs my $half = @working / 2; $half++ if $half > int($half); $half = int($half); my @artificials; while ($half > 1) { my @this_level; foreach my $top_node (@artificials || $node) { for (1..2) { my $art = $top_node->new(-id => "artificial_".++$self->{_art_num}); $top_node->add_Descendent($art); push(@this_level, $art); } } @artificials = @this_level; $half--; } # attach two descs to each artifical leaf foreach my $art (@artificials) { for (1..2) { my $desc = shift(@working) || $node->new(-id => "artificial_".++$self->{_art_num}); $desc->ancestor($art); } } } elsif (@descs == 1) { # ensure that all nodes have 2 descs $node->add_Descendent($node->new(-id => "artificial_".++$self->{_art_num})); } # recurse foreach my $desc (@descs) { $self->force_binary($desc); } } =head2 simplify_to_leaves_string Title : simplify_to_leaves_string Usage : my $leaves_string = $tree->simplify_to_leaves_string() Function: Creates a simple textual representation of the relationship between leaves in self. It forces the tree to be binary, so the result may not strictly correspond to the tree (if the tree wasn't binary), but will be as close as possible. The tree object is not altered. Only leaf node ids are output, in a newick-like format. Returns : string Args : none =cut sub simplify_to_leaves_string { my $self = shift; # Before contracting and forcing binary we need to clone self, but Clone.pm # clone() seg faults and fails to make the clone, whilst Storable dclone # needs $self->{_root_cleanup_methods} deleted (code ref) and seg faults at # end of script. Let's make our own clone... my $tree = $self->_clone; $tree->contract_linear_paths(1); $tree->force_binary; foreach my $node ($tree->get_nodes) { my $id = $node->id; $id = ($node->is_Leaf && $id !~ /^artificial/) ? $id : ''; $node->id($id); } my %paired; my @data = $self->_simplify_helper($tree->get_root_node, \%paired); return join(',', @data); } # alias sub _clone { shift->clone(@_) } # safe node clone that doesn't seg fault, but deliberately loses ancestors and # descendents sub _clone_node { my ($self, $node) = @_; my $clone = $node->new; while (my ($key, $val) = each %{$node}) { if ($key eq '_desc' || $key eq '_ancestor') { next; } ${$clone}{$key} = $val; } return $clone; } # tree string generator for simplify_to_leaves_string, based on # Bio::TreeIO::newick::_write_tree_Helper sub _simplify_helper { my ($self, $node, $paired) = @_; return () if (!defined $node); my @data = (); foreach my $node ($node->each_Descendent()) { push(@data, $self->_simplify_helper($node, $paired)); } my $id = $node->id_output || ''; if (@data) { unless (exists ${$paired}{"@data"} || @data == 1) { $data[0] = "(" . $data[0]; $data[-1] .= ")"; ${$paired}{"@data"} = 1; } } elsif ($id) { push(@data, $id); } return @data; } =head2 distance Title : distance Usage : distance(-nodes => \@nodes ) Function: returns the distance between two given nodes Returns : numerical distance Args : -nodes => arrayref of nodes to test or ($node1, $node2) =cut sub distance { my ($self,@args) = @_; my ($nodes) = $self->_rearrange([qw(NODES)],@args); if( ! defined $nodes ) { $self->warn("Must supply two nodes or -nodes parameter to distance() method"); return; } elsif (ref($nodes) eq 'ARRAY') { 1; } elsif ( @args == 2) { # assume these are nodes... $nodes = \@args; } else { $self->warn("Must supply two nodes or -nodes parameter to distance() method"); return; } $self->throw("Must provide 2 nodes") unless @{$nodes} == 2; my $lca = $self->get_lca(@{$nodes}); unless($lca) { $self->warn("could not find the lca of supplied nodes; can't find distance either"); return; } my $cumul_dist = 0; my $warned = 0; foreach my $current_node (@{$nodes}) { while (1) { last if $current_node eq $lca; if ($current_node->branch_length) { $cumul_dist += $current_node->branch_length; } elsif (! $warned) { $self->warn("At least some nodes do not have a branch length, the distance returned could be wrong"); $warned = 1; } $current_node = $current_node->ancestor || last; } } return $cumul_dist; } =head2 is_monophyletic Title : is_monophyletic Usage : if( $tree->is_monophyletic(-nodes => \@nodes, -outgroup => $outgroup) Function: Will do a test of monophyly for the nodes specified in comparison to a chosen outgroup Returns : boolean Args : -nodes => arrayref of nodes to test -outgroup => outgroup to serve as a reference =cut sub is_monophyletic{ my ($self,@args) = @_; my ($nodes,$outgroup) = $self->_rearrange([qw(NODES OUTGROUP)],@args); if( ! defined $nodes || ! defined $outgroup ) { $self->warn("Must supply -nodes and -outgroup parameters to the method is_monophyletic"); return; } if( ref($nodes) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference for -nodes"); } my $clade_root = $self->get_lca(@{$nodes}); unless( defined $clade_root ) { $self->warn("could not find clade root via lca"); return; } my $og_ancestor = $outgroup->ancestor; while( defined ($og_ancestor ) ) { if( $og_ancestor->internal_id == $clade_root->internal_id ) { # monophyly is violated return 0; } $og_ancestor = $og_ancestor->ancestor; } return 1; } =head2 is_paraphyletic Title : is_paraphyletic Usage : if( $tree->is_paraphyletic(-nodes =>\@nodes, -outgroup => $node) ){ } Function: Tests whether or not a given set of nodes are paraphyletic (representing the full clade) given an outgroup Returns : [-1,0,1] , -1 if the group is not monophyletic 0 if the group is not paraphyletic 1 if the group is paraphyletic Args : -nodes => Array of Bio::Tree::NodeI objects which are in the tree -outgroup => a Bio::Tree::NodeI to compare the nodes to =cut sub is_paraphyletic{ my ($self,@args) = @_; my ($nodes,$outgroup) = $self->_rearrange([qw(NODES OUTGROUP)],@args); if( ! defined $nodes || ! defined $outgroup ) { $self->warn("Must suply -nodes and -outgroup parameters to the method is_paraphyletic"); return; } if( ref($nodes) !~ /ARRAY/i ) { $self->warn("Must provide a valid array reference for -nodes"); return; } # Algorithm # Find the lca # Find all the nodes beneath the lca # Test to see that none are missing from the nodes list my %nodehash; foreach my $n ( @$nodes ) { $nodehash{$n->internal_id} = $n; } my $clade_root = $self->get_lca(-nodes => $nodes ); unless( defined $clade_root ) { $self->warn("could not find clade root via lca"); return; } my $og_ancestor = $outgroup->ancestor; # Is this necessary/correct for paraphyly test? while( defined ($og_ancestor ) ) { if( $og_ancestor->internal_id == $clade_root->internal_id ) { # monophyly is violated, could be paraphyletic return -1; } $og_ancestor = $og_ancestor->ancestor; } my $tree = Bio::Tree::Tree->new(-root => $clade_root, -nodelete => 1); foreach my $n ( $tree->get_nodes() ) { next unless $n->is_Leaf(); # if any leaf node is not in the list # then it is part of the clade and so the list # must be paraphyletic return 1 unless ( $nodehash{$n->internal_id} ); } return 0; } =head2 reroot Title : reroot Usage : $tree->reroot($node); Function: Reroots a tree making a new node the root Returns : 1 on success, 0 on failure Args : Bio::Tree::NodeI that is in the tree, but is not the current root =cut sub reroot { my ($self,$new_root) = @_; unless (defined $new_root && $new_root->isa("Bio::Tree::NodeI")) { $self->warn("Must provide a valid Bio::Tree::NodeI when rerooting"); return 0; } my $old_root = $self->get_root_node; if( $new_root == $old_root ) { $self->warn("Node requested for reroot is already the root node!"); return 0; } my $anc = $new_root->ancestor; unless( $anc ) { # this is already the root $self->warn("Node requested for reroot is already the root node!"); return 0; } my $tmp_node = $new_root->create_node_on_branch(-position=>0,-force=>1); # reverse the ancestor & children pointers my $former_anc = $tmp_node->ancestor; my @path_from_oldroot = ($self->get_lineage_nodes($tmp_node), $tmp_node); for (my $i = 0; $i < $#path_from_oldroot; $i++) { my $current = $path_from_oldroot[$i]; my $next = $path_from_oldroot[$i + 1]; $current->remove_Descendent($next); $current->branch_length($next->branch_length); $current->bootstrap($next->bootstrap) if defined $next->bootstrap; $next->remove_tag('B'); $next->add_Descendent($current); } $new_root->add_Descendent($former_anc); $tmp_node->remove_Descendent($former_anc); $tmp_node = undef; $new_root->branch_length(undef); $old_root = undef; $self->set_root_node($new_root); return 1; } =head2 reroot_at_midpoint Title : reroot_at_midpoint Usage : $tree->reroot_at_midpoint($node, $new_root_id); Function: Reroots a tree on a new node created halfway between the argument and its ancestor Returns : the new midpoint Bio::Tree::NodeIon success, 0 on failure Args : non-root Bio::Tree::NodeI currently in $tree scalar string, id for new node (optional) =cut sub reroot_at_midpoint { my $self = shift; my $node = shift; my $id = shift; unless (defined $node && $node->isa("Bio::Tree::NodeI")) { $self->warn("Must provide a valid Bio::Tree::NodeI when rerooting"); return 0; } my $midpt = $node->create_node_on_branch(-FRACTION=>0.5); if (defined $id) { $self->warn("ID argument is not a scalar") if (ref $id); $midpt->id($id) if defined($id) && !ref($id); } $self->reroot($midpt); return $midpt; } =head2 findnode_by_id Title : findnode_by_id Usage : my $node = $tree->findnode_by_id($id); Function: Get a node by its id (which should be unique for the tree) Returns : L<Bio::Tree::NodeI> Args : node id =cut sub findnode_by_id { my $tree = shift; $tree->deprecated("use of findnode_by_id() is deprecated; ". "use find_node() instead"); my $id = shift; my $rootnode = $tree->get_root_node; if ( ($rootnode->id) and ($rootnode->id eq $id) ) { return $rootnode; } # process all the children foreach my $node ( $rootnode->get_Descendents ) { if ( ($node->id) and ($node->id eq $id ) ) { return $node; } } } =head2 move_id_to_bootstrap Title : move_id_to_bootstrap Usage : $tree->move_id_to_bootstrap Function: Move internal IDs to bootstrap slot Returns : undef Args : undef =cut sub move_id_to_bootstrap{ my ($tree) = shift; for my $node ( grep { ! $_->is_Leaf } $tree->get_nodes ) { $node->bootstrap(defined $node->id ? $node->id : ''); $node->id(''); } } =head2 add_trait Title : add_trait Usage : my $key = $tree->add_trait($trait_file, 3); Function: Add traits to the leaf nodes of a Bio::Tree:Tree from a file. The trait file is a tab-delimited text file and needs to have a header line giving names to traits. The first column contains the leaf node ids. Subsequent columns contain different trait value sets. Single or double quotes are removed from the trait values. Traits are added to leaf nodes as a tag named $key using the add_tag_value() method. This means that you can retrieve the trait values using the get_tag_values() method (see the documentation for Bio::Tree::Node). Returns : Trait name (a scalar) on success, undef on failure (for example, if the column index requested was too large). Args : * Name of trait file (scalar string). * Index of trait file column (scalar int). Note that numbering starts at 0. Default: 1 (second column). * Ignore missing values. Typically, if a leaf node has no value in the trait file, an exception is thrown. If you set this option to 1, then no trait will be given to the node (no exception thrown). =cut sub _read_trait_file { my ($self, $file, $column) = @_; $column ||= 1; my $trait_name; my $trait_values; open my $TRAIT, '<', $file or $self->throw("Could not open file $file: $!\n"); my $first_line = 1; while (<$TRAIT>) { chomp; s/['"]//g; my @line = split /\t/; if ($first_line) { $first_line = 0; $trait_name = $line[$column]; next; } my $id = $line[0]; last if (not defined $id) or ($id eq ''); # Skip empty trait values my $value = $line[$column]; next if (not defined $value) or ($value eq ''); $trait_values->{$id} = $value; } close $TRAIT; return $trait_name, $trait_values; } sub add_trait { my ($self, $file, $column, $ignore) = @_; $ignore = 0 if not defined $ignore; my ($trait_name, $trait_values) = $self->_read_trait_file($file, $column); if (defined $trait_name) { for my $node ($self->get_leaf_nodes) { # strip quotes from the node id $node->id($1) if $node->id =~ /^['"]+(.*)['"]+$/; if ( not exists $trait_values->{$node->id} ) { if ($ignore) { next; } else { $self->throw("No trait for node [".$node->id."/".$node->internal_id."]"); } } $node->add_tag_value($trait_name, $trait_values->{ $node->id } ); } } return $trait_name; } 1; ��������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/TreeI.pm�������������������������������������������������������������������000444��000765��000024�� 15673�12254227316� 16452� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Tree::TreeI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::TreeI - A Tree object suitable for lots of things, designed originally for Phylogenetic Trees. =head1 SYNOPSIS # get a Bio::Tree::TreeI somehow # like from a TreeIO my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 'treefile.dnd'); my $tree = $treeio->next_tree; my @nodes = $tree->get_nodes; my @leaves = $tree->get_leaf_nodes; my $root = $tree->get_root_node; =head1 DESCRIPTION This object holds a pointer to the Root of a Tree which is a Bio::Tree::NodeI. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 CONTRIBUTORS Aaron Mackey, amackey@virginia.edu Elia Stupka, elia@fugu-sg.org Sendu Bala, bix@sendu.me.uk =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Tree::TreeI; use strict; use base qw(Bio::Root::RootI); =head2 get_nodes Title : get_nodes Usage : my @nodes = $tree->get_nodes() Function: Return list of Tree::NodeI objects Returns : array of Tree::NodeI objects Args : (named values) hash with one value order => 'b|breadth' first order or 'd|depth' first order =cut sub get_nodes{ my ($self) = @_; $self->throw_not_implemented(); } =head2 get_root_node Title : get_root_node Usage : my $node = $tree->get_root_node(); Function: Get the Top Node in the tree, in this implementation Trees only have one top node. Returns : Bio::Tree::NodeI object Args : none =cut sub get_root_node{ my ($self) = @_; $self->throw_not_implemented(); } =head2 number_nodes Title : number_nodes Usage : my $size = $tree->number_nodes Function: Find the number of nodes in the tree. Returns : int Args : none =cut sub number_nodes{ my ($self) = @_; my $root = $self->get_root_node; if( defined $root && $root->isa('Bio::Tree::NodeI')) { return ($root->descendent_count + 1); } return 0; } =head2 total_branch_length Title : total_branch_length Usage : my $size = $tree->total_branch_length Function: Returns the sum of the length of all branches Returns : integer Args : none =cut sub total_branch_length { my ($self) = @_; $self->throw_not_implemented(); } =head2 height Title : height Usage : my $height = $tree->height Function: Gets the height of tree - this LOG_2($number_nodes) WARNING: this is only true for strict binary trees. The TreeIO system is capable of building non-binary trees, for which this method will currently return an incorrect value!! Returns : integer Args : none =cut sub height{ my ($self) = @_; my $nodect = $self->number_nodes; return 0 if( ! $nodect ); return log($nodect) / log(2); } =head2 id Title : id Usage : my $id = $tree->id(); Function: An id value for the tree Returns : scalar Args : =cut sub id{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 score Title : score Usage : $obj->score($newval) Function: Sets the associated score with this tree This is a generic slot which is probably best used for log likelihood or other overall tree score Returns : value of score Args : newvalue (optional) =cut sub score{ my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 get_leaf_nodes Title : get_leaf_nodes Usage : my @leaves = $tree->get_leaf_nodes() Function: Returns the leaves (tips) of the tree Returns : Array of Bio::Tree::NodeI objects Args : none =cut sub get_leaf_nodes{ my ($self) = @_; return grep { $_->is_Leaf() } $self->get_nodes(-sortby => 'none'); } =head2 Methods for associating Tag/Values with a Tree These methods associate tag/value pairs with a Tree =head2 set_tag_value Title : set_tag_value Usage : $tree->set_tag_value($tag,$value) $tree->set_tag_value($tag,@values) Function: Sets a tag value(s) to a tree. Replaces old values. Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub set_tag_value{ shift->throw_not_implemented(); } =head2 add_tag_value Title : add_tag_value Usage : $tree->add_tag_value($tag,$value) Function: Adds a tag value to a tree Returns : number of values stored for this tag Args : $tag - tag name $value - value to store for the tag =cut sub add_tag_value{ shift->throw_not_implemented(); } =head2 remove_tag Title : remove_tag Usage : $tree->remove_tag($tag) Function: Remove the tag and all values for this tag Returns : boolean representing success (0 if tag does not exist) Args : $tag - tagname to remove =cut sub remove_tag { shift->throw_not_implemented(); } =head2 remove_all_tags Title : remove_all_tags Usage : $tree->remove_all_tags() Function: Removes all tags Returns : None Args : None =cut sub remove_all_tags{ shift->throw_not_implemented(); } =head2 get_all_tags Title : get_all_tags Usage : my @tags = $tree->get_all_tags() Function: Gets all the tag names for this Tree Returns : Array of tagnames Args : None =cut sub get_all_tags { shift->throw_not_implemented(); } =head2 get_tag_values Title : get_tag_values Usage : my @values = $tree->get_tag_values($tag) Function: Gets the values for given tag ($tag) Returns : Array of values or empty list if tag does not exist Args : $tag - tag name =cut sub get_tag_values{ shift->throw_not_implemented(); } =head2 has_tag Title : has_tag Usage : $tree->has_tag($tag) Function: Boolean test if tag exists in the Tree Returns : Boolean Args : $tag - tagname =cut sub has_tag{ shift->throw_not_implemented(); } 1; ���������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/Draw�����������������������������������������������������������������������000755��000765��000024�� 0�12254227322� 15605� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Tree/Draw/Cladogram.pm����������������������������������������������������������000444��000765��000024�� 44106�12254227322� 20216� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Cladogram # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Gabriel Valiente <valiente@lsi.upc.edu> # # Copyright Gabriel Valiente # # You may distribute this module under the same terms as Perl itself # POD documentation - main docs before the code =head1 NAME Bio::Tree::Draw::Cladogram - Drawing phylogenetic trees in Encapsulated PostScript (EPS) format. =head1 SYNOPSIS use Bio::Tree::Draw::Cladogram; use Bio::TreeIO; my $treeio = Bio::TreeIO->new('-format' => 'newick', '-file' => 'input.nwk'); my $t1 = $treeio->next_tree; my $t2 = $treeio->next_tree; my $obj1 = Bio::Tree::Draw::Cladogram->new(-tree => $t1); $obj1->print(-file => 'cladogram.eps'); if ($t2) { my $obj2 = Bio::Tree::Draw::Cladogram->new(-tree => $t1, -second => $t2); $obj2->print(-file => 'tanglegram.eps'); } =head1 DESCRIPTION Bio::Tree::Draw::Cladogram is a Perl tool for drawing Bio::Tree::Tree objects in Encapsulated PostScript (EPS) format. It can be utilized both for displaying a single phylogenetic tree (a cladogram) and for the comparative display of two phylogenetic trees (a tanglegram) such as a gene tree and a species tree, a host tree and a parasite tree, two alternative trees for the same set of taxa, or two alternative trees for overlapping sets of taxa. Phylogenetic trees are drawn as rectangular cladograms, with horizontal orientation and ancestral nodes centered over their descendents. The font used for taxa is Courier at 10 pt. A single Bio::Tree::Tree object is drawn with ancestors to the left and taxa flushed to the right. Two Bio::Tree::Tree objects are drawn with the first tree oriented left-to-right and the second tree oriented right-to-left, and with corresponding taxa connected by straight lines in a shade of gray. Each correspondence between a $taxon1 of the first tree and a $taxon2 of the second tree is established by setting $taxon1-E<gt>add_tag_value('connection',$taxon2). Thus, a taxon of the first tree can be connected to more than one taxon of the second tree, and vice versa. The branch from the parent to a child $node, as well as the child label, can be colored by setting $node-E<gt>add_tag_value('Rcolor',$r), $node-E<gt>add_tag_value('Gcolor',$g), and $node-E<gt>add_tag_value('Bcolor',$b), where $r, $g, and $b are the desired values for red, green, and blue (zero for lowest, one for highest intensity). This is a preliminary release of Bio::Tree::Draw::Cladogram. Future improvements include an option to output phylograms instead of cladograms. Beware that cladograms are automatically scaled according to branch lengths, but the current release has only been tested with trees having unit branch lengths. The print method could be extended to output graphic formats other than EPS, although there are many graphics conversion programs around that accept EPS input. For instance, most Linux distributions include epstopdf, a Perl script that together with Ghostscript, converts EPS to PDF. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Gabriel Valiente Email valiente@lsi.upc.edu Code for coloring branches contributed by Georgii A Bazykin (gbazykin@princeton.edu). =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut package Bio::Tree::Draw::Cladogram; use strict; use PostScript::TextBlock; use base qw(Bio::Root::Root); # The following private package variables are set by the new method # and used by the print method. my %xx; # horizontal coordinate for each node my %yy; # vertical coordinate for each node my $t1; # first Bio::Tree::Tree object my $t2; # second Bio::Tree::Tree object my $font; # font name my $size; # font size my $width; # total drawing width my $height; # total drawing height my $xstep; # branch length in drawing my $tip; # extra space between tip and label my $tipwidth1; # width of longest label among $t1 taxa my $tipwidth2; # width of longest label among $t2 taxa my $compact; # whether or not to ignore branch lengths my $ratio; # horizontal to vertical ratio my $colors; # use colors to color edges my %Rcolor; # red color for each node my %Gcolor; # green color for each node my %Bcolor; # blue color for each node my $bootstrap; # Draw Bootstrap boolean =head2 new Title : new Usage : my $obj = Bio::Tree::Draw::Cladogram->new(); Function: Builds a new Bio::Tree::Draw::Cladogram object Returns : Bio::Tree::Draw::Cladogram Args : -tree => Bio::Tree::Tree object -second => Bio::Tree::Tree object (optional) -font => font name [string] (optional) -size => font size [integer] (optional) -top => top margin [integer] (optional) -bottom => bottom margin [integer] (optional) -left => left margin [integer] (optional) -right => right margin [integer] (optional) -tip => extra tip space [integer] (optional) -column => extra space between cladograms [integer] (optional) -compact => ignore branch lengths [boolean] (optional) -ratio => horizontal to vertical ratio [integer] (optional) -colors => use colors to color edges [boolean] (optional) -bootstrap => draw bootstrap or internal ids [boolean] =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); ($t1, $t2, $font, $size, my $top, my $bottom, my $left, my $right, $tip, my $column, $compact, $ratio, $colors,$bootstrap) = $self->_rearrange([qw(TREE SECOND FONT SIZE TOP BOTTOM LEFT RIGHT TIP COLUMN COMPACT RATIO COLORS BOOTSTRAP)], @args); $font ||= "Helvetica-Narrow"; $size ||= 12; $top ||= 10; $bottom ||= 10; $left ||= 10; $right ||= 10; $tip ||= 5; $column ||= 60; $compact ||= 0; $ratio ||= 1 / 1.6180339887; $colors ||= 0; $bootstrap ||= 0; # Roughly, a cladogram is set according to the following parameters. ################################# # # T # $top (T, top margin) # +---------+ XXX # # $bottom (B, bottom margin) # | # # $left (L, left margin) # | # # $right (R, right margin) # +----+ # # $tip (X, extra tip space) # | +----+ XXXX # # $width (total drawing width) # | | # # $height (total drawing height) # +----+ # Y # $xstep (S, stem length) # | # # $ystep (Y, space between taxa) # +----+ XX # # $tiplen (string length of longest name) # # B # $tipwidth (N, size of longest name) ################################# # L S X N R # ############################# # A tanglegram is roughly set as follows. The only additional # parameter is $column (C, length of connection lines between taxa # of the two trees), but $tip occurs four times, and $tiplen and # $tipwidth differ for the first and the second tree. ########################################################### # # # +---------+ XXX ----- XXXXXX +----+ # # | | # # | +----+ # # +----+ | | # # | +----+ XXXX ----- XXX +----+ | # # | | +----+ # # +----+ | # # | | # # +----+ XX ----- XXXX +---------+ # # # ########################################################### # L X X C X X R # ########################################################### # An alternative would be to let the user set $width and $height in # points and to scale down everything to fit the desired # dimensions. However, the final EPS can later be scaled down to any # desired size anyway. my @taxa1 = $t1->get_leaf_nodes; my $root1 = $t1->get_root_node; $tipwidth1 = 0; foreach my $taxon (@taxa1) { my $w = PostScript::Metrics::stringwidth($taxon->id,$font,$size); if ($w > $tipwidth1) { $tipwidth1 = $w; } } my @taxa2; my $root2; my $ystep = 20; if ($t2) { @taxa2 = $t2->get_leaf_nodes; $root2 = $t2->get_root_node; $tipwidth2 = 0; foreach my $taxon (@taxa2) { my $w = PostScript::Metrics::stringwidth($taxon->id,$font,$size); if ($w > $tipwidth2) { $tipwidth2 = $w; } } } my $stems = $root1->height + 1; if ($t2) { $stems += $root2->height + 1; } my $labels = $tipwidth1; if ($t2) { $labels += $tipwidth2; } $xstep = 20; $width = $left + $stems * $xstep + $tip + $labels + $right; if ($t2) { $width += $tip + $column + $tip + $tip; } $height = $bottom + $ystep * (@taxa1 - 1) + $top; if ($t2) { if ( scalar(@taxa2) > scalar(@taxa1) ) { $height = $bottom + $ystep * (@taxa2 - 1) + $top; } } my $ystep1 = $height / scalar(@taxa1); my $ystep2; if ($t2) { $ystep2 = $height / scalar(@taxa2); } my $x = $left + $xstep * ($root1->height + 1) + $tip; my $y = $bottom; for my $taxon (reverse @taxa1) { $xx{$taxon} = $x - $tip; $yy{$taxon} = $y; $y += $ystep1; } $x -= $xstep; my @stack; my @queue; # postorder traversal push @stack, $t1->get_root_node; while (@stack) { my $node = pop @stack; push @queue, $node; foreach my $child ($node->each_Descendent(-sortby => 'internal_id')) { push @stack, $child; } } @queue = reverse @queue; for my $node (@queue) { if (!$node->is_Leaf) { my @children = $node->each_Descendent; my $child = shift @children; my $xmin = $xx{$child}; my $ymin = my $ymax = $yy{$child}; foreach $child (@children) { $xmin = $xx{$child} if $xx{$child} < $xmin; $ymax = $yy{$child} if $yy{$child} > $ymax; $ymin = $yy{$child} if $yy{$child} < $ymin; } $xx{$node} = $xmin - $xstep; $yy{$node} = ($ymin + $ymax)/2; } } $xx{$t1->get_root_node} = $left + $xstep; my @preorder = $t1->get_nodes(-order => 'depth'); for my $node (@preorder) { #print "\n$node"; if ($colors) { if ($node->has_tag('Rcolor')) { $Rcolor{$node} = $node->get_tag_values('Rcolor') } else { $Rcolor{$node} = 0 } if ($node->has_tag('Gcolor')) { $Gcolor{$node} = $node->get_tag_values('Gcolor') } else { $Gcolor{$node} = 0 } if ($node->has_tag('Bcolor')) { $Bcolor{$node} = $node->get_tag_values('Bcolor') } else { $Bcolor{$node} = 0 } #print "\t$Rcolor{$node}\t$Gcolor{$node}\t$Bcolor{$node}"; } } if ($compact) { # ragged right, ignoring branch lengths $width = 0; shift @preorder; # skip root for my $node (@preorder) { $xx{$node} = $xx{$node->ancestor} + $xstep; $width = $xx{$node} if $xx{$node} > $width; } $width += $tip + $tipwidth1 + $right; } else { # set to aspect ratio and use branch lengths if available my $total_height = (scalar($t1->get_leaf_nodes) - 1) * $ystep; my $scale_factor = $total_height * $ratio / $t1->get_root_node->height; $width = $t1->get_root_node->height * $scale_factor; $width += $left + $xstep; $width += $tip + $tipwidth1 + $right; shift @preorder; # skip root for my $node (@preorder) { my $bl = $node->branch_length; $bl = 1 unless (defined $bl && $bl =~ /^\-?\d+(\.\d+)?$/); $xx{$node} = $xx{$node->ancestor} + $bl * $scale_factor; } } if ($t2) { $x = $left + $xstep * ($root1->height + 1) + $tip; $x += $tipwidth1 + $tip + $column + $tip; my $y = $bottom; for my $taxon (reverse @taxa2) { $xx{$taxon} = $x + $tipwidth2 + $tip; $yy{$taxon} = $y; $y += $ystep2; } $x += $xstep; my @stack; my @queue; # postorder traversal push @stack, $t2->get_root_node; while (@stack) { my $node = pop @stack; push @queue, $node; foreach my $child ($node->each_Descendent(-sortby => 'internal_id')) { push @stack, $child; } } @queue = reverse @queue; for my $node (@queue) { if (!$node->is_Leaf) { my @children = $node->each_Descendent; my $child = shift @children; my $xmax = $xx{$child}; my $ymin = my $ymax = $yy{$child}; foreach $child (@children) { $xmax = $xx{$child} if $xx{$child} > $xmax; $ymax = $yy{$child} if $yy{$child} > $ymax; $ymin = $yy{$child} if $yy{$child} < $ymin; } $xx{$node} = $xmax + $xstep; $yy{$node} = ($ymin + $ymax)/2; } } } return $self; } =head2 print Title : print Usage : $obj->print(); Function: Outputs $obj in Encapsulated PostScript (EPS) format Returns : Args : -file => filename (optional) =cut sub print { my($self,@args) = @_; my ($file) = $self->_rearrange([qw(FILE)], @args); $file ||= "output.eps"; # stdout open(my $INFO,">", $file); print $INFO "%!PS-Adobe-\n"; print $INFO "%%BoundingBox: 0 0 ", $width, " ", $height, "\n"; print $INFO "1 setlinewidth\n"; print $INFO "/$font findfont\n"; print $INFO "$size scalefont\n"; print $INFO "setfont\n"; # taxa labels are centered to 1/3 the font size for my $taxon (reverse $t1->get_leaf_nodes) { if ($colors) { print $INFO $Rcolor{$taxon}, " ", $Gcolor{$taxon}, " ", $Bcolor{$taxon}, " setrgbcolor\n"; } print $INFO $xx{$taxon} + $tip, " ", $yy{$taxon} - $size / 3, " moveto\n"; print $INFO "(", $taxon->id, ") show\n"; } my $root1 = $t1->get_root_node; for my $node ($t1->get_nodes) { if ($node->ancestor) { # print $xx{$node->ancestor}, " ", $yy{$node->ancestor}, " moveto\n"; # print $xx{$node}, " ", $yy{$node}, " lineto\n"; if ($colors) { print $INFO "stroke\n"; print $INFO $Rcolor{$node}, " ", $Gcolor{$node}, " ", $Bcolor{$node}, " setrgbcolor\n"; } print $INFO $xx{$node}, " ", $yy{$node}, " moveto\n"; print $INFO $xx{$node->ancestor}, " ", $yy{$node}, " lineto\n"; if( $bootstrap ) { print $INFO $xx{$node->ancestor}+ $size/10, " ", $yy{$node->ancestor} - ($size / 3), " moveto\n"; print $INFO "(", $node->ancestor->id, ") show\n"; print $INFO $xx{$node->ancestor}, " ", $yy{$node}, " moveto\n"; } print $INFO $xx{$node->ancestor}, " ", $yy{$node->ancestor}, " lineto\n"; } } my $ymin = $yy{$root1}; my $ymax = $yy{$root1}; foreach my $child ($root1->each_Descendent) { $ymax = $yy{$child} if $yy{$child} > $ymax; $ymin = $yy{$child} if $yy{$child} < $ymin; } my $zz = ($ymin + $ymax)/2; if ($colors) { print $INFO "stroke\n"; print $INFO $Rcolor{$root1}, " ", $Gcolor{$root1}, " ", $Bcolor{$root1}, " setrgbcolor\n"; } print $INFO $xx{$root1}, " ", $zz, " moveto\n"; print $INFO $xx{$root1} - $xstep, " ", $zz, " lineto\n"; if ($t2) { for my $taxon (reverse $t2->get_leaf_nodes) { my $tiplen2 = PostScript::Metrics::stringwidth($taxon->id,$font,$size); print $INFO $xx{$taxon} - $tiplen2 - $tip, " ", $yy{$taxon} - $size / 3, " moveto\n"; printf $INFO "(%s) show\n", $taxon->id; } for my $node ($t2->get_nodes) { if ($node->ancestor) { print $INFO $xx{$node}, " ", $yy{$node}, " moveto\n"; print $INFO $xx{$node->ancestor}, " ", $yy{$node}, " lineto\n"; print $INFO $xx{$node->ancestor}, " ", $yy{$node->ancestor}, " lineto\n"; } } my $root2 = $t2->get_root_node; my $ymin = $yy{$root2}; my $ymax = $yy{$root2}; foreach my $child2 ($root2->each_Descendent) { $ymax = $yy{$child2} if $yy{$child2} > $ymax; $ymin = $yy{$child2} if $yy{$child2} < $ymin; } my $zz = ($ymin + $ymax)/2; print $INFO $xx{$root2}, " ", $zz, " moveto\n"; print $INFO $xx{$root2} + $xstep, " ", $zz, " lineto\n"; my @taxa1 = $t1->get_leaf_nodes; my @taxa2 = $t2->get_leaf_nodes; # set default connection between $t1 and $t2 taxa, unless # overridden by the user (the latter not implemented yet) foreach my $taxon1 (@taxa1) { foreach my $taxon2 (@taxa2) { if ($taxon1->id eq $taxon2->id) { $taxon1->add_tag_value('connection',$taxon2); last; } } } # draw connection lines between $t1 and $t2 taxa print $INFO "stroke\n"; print $INFO "0.5 setgray\n"; foreach my $taxon1 (@taxa1) { my @match = $taxon1->get_tag_values('connection'); foreach my $taxon2 (@match) { my $x0 = $xx{$taxon1} + $tip + PostScript::Metrics::stringwidth($taxon1->id,$font,$size) + $tip; my $x1 = $xx{$taxon1} + $tip + $tipwidth1 + $tip; my $y1 = $yy{$taxon1}; my $x2 = $xx{$taxon2} - $tip - $tipwidth2 - $tip; my $x3 = $xx{$taxon2} - $tip - PostScript::Metrics::stringwidth($taxon2->id,$font,$size) - $tip; my $y2 = $yy{$taxon2}; print $INFO $x0, " ", $y1, " moveto\n"; print $INFO $x1, " ", $y1, " lineto\n"; print $INFO $x2, " ", $y2, " lineto\n"; print $INFO $x3, " ", $y2, " lineto\n"; } } } print $INFO "stroke\n"; print $INFO "showpage\n"; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO��������������������������������������������������������������������������000755��000765��000024�� 0�12254227337� 15146� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/cluster.pm���������������������������������������������������������������000444��000765��000024�� 12364�12254227337� 17350� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::cluster # # Contributed by Guillaume Rousse <Guillaume-dot-Rousse-at-inria-dot-fr> # # Copyright INRIA # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::cluster - A TreeIO driver module for parsing Algorithm::Cluster::treecluster() output =head1 SYNOPSIS # do not use this module directly use Bio::TreeIO; use Algorithm::Cluster; my ($result, $linkdist) = Algorithm::Cluster::treecluster( distances => $matrix ); my $treeio = Bio::TreeIO->new( -format => 'cluster', -result => $result, -linkdist => $linkdist, -labels => $labels ); my $tree = $treeio->next_tree; =head1 DESCRIPTION This is a driver module for parsing Algorithm::Cluster::treecluster() output. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Guillaume Rousse Email Guillaume-dot-Rousse-at-inria-dot-fr =head1 CONTRIBUTORS Jason Stajich - jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::cluster; use strict; use Bio::Event::EventGeneratorI; use IO::String; use base qw(Bio::TreeIO); =head2 new Title : new Usage : my $obj = Bio::TreeIO::cluster->new(); Function: Builds a new Bio::TreeIO::cluster object for reading Algorithm::Cluster::treecluster output Returns : Bio::TreeIO::cluster Args :-result => Algorithm::Cluster result -linkdist => distance between links -labels => node labels =cut sub _initialize { my $self = shift; ($self->{_result},$self->{_linkdist}, $self->{_labels}) = $self->_rearrange([qw (RESULT LINKDIST LABELS)], @_); $self->SUPER::_initialize(@_); } =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree Function: Gets the next tree in the stream Returns : Bio::Tree::TreeI Args : none =cut sub next_tree { my ($self) = @_; if( ! $self->{_result} ){ $self->warn("Must provide value 'result' and 'linkdist' and 'labels' when initializing a TreeIO::cluster object"); return; } $self->_eventHandler->start_document(); # build tree from the root $self->_eventHandler->start_element({Name => 'tree'}); $self->_recurse(-1, 0); $self->_recurse(-1, 1); $self->_eventHandler->end_element({Name => 'tree'}); return $self->_eventHandler->end_document; } sub _recurse { my ($self, $line, $column) = @_; my $id = $self->{_result}->[$line]->[$column]; if ($id >= 0) { # leaf $self->debug("leaf $id\n"); $self->debug("distance $self->{_linkdist}->[$line]\n"); $self->debug("label $self->{_labels}->[$id]\n"); $self->_eventHandler->start_element({Name => 'node'}); $self->_eventHandler->start_element({Name => 'branch_length'}); $self->_eventHandler->characters($self->{_linkdist}->[$line]); $self->_eventHandler->end_element({Name => 'branch_length'}); $self->_eventHandler->start_element({Name => 'id'}); $self->_eventHandler->characters($self->{_labels}->[$id]); $self->_eventHandler->end_element({Name => 'id'}); $self->_eventHandler->start_element({Name => 'leaf'}); $self->_eventHandler->characters(1); $self->_eventHandler->end_element({Name => 'leaf'}); $self->_eventHandler->end_element({Name => 'node'}); } else { # internal node $self->debug("internal node $id\n"); $self->debug("distance $self->{_linkdist}->[$line]\n"); $self->_eventHandler->start_element({Name => 'node'}); $self->_eventHandler->start_element({Name => 'branch_length'}); $self->_eventHandler->characters($self->{_linkdist}->[$line]); $self->_eventHandler->end_element({Name => 'branch_length'}); $self->_eventHandler->start_element({Name => 'leaf'}); $self->_eventHandler->characters(0); $self->_eventHandler->end_element({Name => 'leaf'}); $self->_eventHandler->start_element({Name => 'tree'}); my $child_id = - ($id + 1); $self->_recurse($child_id, 0); $self->_recurse($child_id, 1); $self->_eventHandler->end_element({Name => 'tree'}); $self->_eventHandler->end_element({Name => 'node'}); } } =head2 write_tree Title : write_tree Usage : Function: Sorry not possible with this format Returns : none Args : none =cut sub write_tree{ $_[0]->throw("Sorry the format 'cluster' can only be used as an input format"); } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/lintree.pm���������������������������������������������������������������000444��000765��000024�� 14602�12254227320� 17316� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::lintree # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::lintree - Parser for lintree output trees =head1 SYNOPSIS # do not use directly, use through Bio::TreeIO use Bio::TreeIO; my $treeio = Bio::TreeIO->new(-format => 'lintree', -file => 't/data/crab.nj'); my $tree = $treeio->next_tree; =head1 DESCRIPTION Parser for the lintree output which looks like this 13 sequences 1000 bootstraping 1 A-salina 2 C-vittat 3 C-sp. 4 L-aequit 5 P-camtsc 6 E-tenuim 7 L-splend 8 P-bernha 9 P-acadia 10 P-p(NE) 11 P-p(GU) 12 P-l(NE) 13 P-l(GU) 14 and 2 0.098857 1000 14 and 3 0.127932 1000 15 and 1 0.197471 1000 15 and 14 0.029273 874 16 and 10 0.011732 1000 16 and 11 0.004529 1000 17 and 12 0.002258 1000 17 and 13 0.000428 1000 18 and 16 0.017512 1000 18 and 17 0.010824 998 19 and 4 0.006534 1000 19 and 5 0.006992 1000 20 and 15 0.070461 1000 20 and 18 0.030579 998 21 and 8 0.003339 1000 21 and 9 0.002042 1000 22 and 6 0.011142 1000 22 and 21 0.010693 983 23 and 20 0.020714 996 23 and 19 0.020350 1000 24 and 23 0.008665 826 24 and 22 0.013457 972 24 and 7 0.025598 1000 See http://www.bio.psu.edu/People/Faculty/Nei/Lab/software.htm for access to the program and N Takezaki, A Rzhetsky, and M Nei, "Phylogenetic test of the molecular clock and linearized trees." Mol Biol Evol 12(5):823-33. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 CONTRIBUTORS Ideas and discussion from: Alan Christoffels Avril Coghlan =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::lintree; use vars qw(%Defaults); use strict; use base qw(Bio::TreeIO); $Defaults{'NodeType'} = "Bio::Tree::Node"; =head2 new Title : new Usage : my $obj = Bio::TreeIO::lintree->new(); Function: Builds a new Bio::TreeIO::lintree object Returns : an instance of Bio::TreeIO::lintree Args : -nodetype => Node type to create [default Bio::Tree::Node] =cut sub _initialize { my ($self,@args) = @_; $self->SUPER::_initialize(@args); my ($nodetype) = $self->_rearrange([qw(NODETYPE)],@args); $nodetype ||= $Defaults{'NodeType'}; $self->nodetype($nodetype); } =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree Function: Gets the next tree in the stream Returns : Bio::Tree::TreeI Args : none =cut sub next_tree { my ($self) = @_; my $seentop = 0; my ($tipcount,%data,@nodes) = (0); my $nodetype = $self->nodetype; while( defined( $_ = $self->_readline) ) { if( /^\s*(\d+)\s+sequences/ox ) { if( $seentop ) { $self->_pushback($_); last; } $tipcount = $1; $seentop = 1; } elsif( /^(\d+)\s+(\S+)\s*$/ox ) { # deal with setting an outgroup unless( defined $data{'outgroup'} ) { $data{'outgroup'} = [$1,$2]; } $nodes[$1 - 1] = { '-id' => $2 }; } elsif( m/^\s*(\d+)\s+and\s+(\d+)\s+(\-?\d+\.\d+)(?:\s+(\d+))?/ox ) { my ($node,$descend,$blength,$bootstrap) = ( $1, $2, $3, $4 ); # need to -- descend and node because # array is 0 based $node--;$descend--; $nodes[$descend]->{'-branch_length'} = $blength; $nodes[$descend]->{'-bootstrap'} = $bootstrap; #? here $nodes[$node]->{'-id'} = $node+1; push @{$nodes[$node]->{'-d'}}, $descend; } elsif( /\s+(\S+)\-distance was used\./ox ) { $data{'method'} = $1; } elsif( /\s*seed=(\d+)/ox ) { $data{'seed'} = $1; } elsif( m/^outgroup:\s+(\d+)\s+(\S+)/ox ) { $data{'outgroup'} = [$1,$2]; } } if( @nodes ) { my @treenodes; foreach my $n ( @nodes ) { push @treenodes, $nodetype->new(%{$n}); } foreach my $tn ( @treenodes ) { my $n = shift @nodes; for my $ptr ( @{ $n->{'-d'} || [] } ) { $tn->add_Descendent($treenodes[$ptr]); } } my $T = Bio::Tree::Tree->new(-root => (pop @treenodes) ); if( $data{'outgroup'} ) { my ($outgroup) = $treenodes[$data{'outgroup'}->[0]]; if( ! defined $outgroup) { $self->warn("cannot find '". $data{'outgroup'}->[1]. "'\n"); } else { $T->reroot($outgroup->ancestor); } } return $T; } return; # if there are no more trees, return undef } =head2 nodetype Title : nodetype Usage : $obj->nodetype($newval) Function: Example : Returns : value of nodetype (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub nodetype{ my ($self,$value) = @_; if( defined $value) { eval "require $value"; if( $@ ) { $self->throw("$@: Unrecognized Node type for ".ref($self). "'$value'");} my $a = bless {},$value; unless( $a->isa('Bio::Tree::NodeI') ) { $self->throw("Must provide a valid Bio::Tree::NodeI or child class to SeqFactory Not $value"); } $self->{'nodetype'} = $value; } return $self->{'nodetype'}; } 1; ������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/newick.pm����������������������������������������������������������������000444��000765��000024�� 21474�12254227320� 17141� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::newick # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::newick =head1 SYNOPSIS # do not use this module directly use Bio::TreeIO; my $treeio = Bio::TreeIO->new(-format => 'newick', -file => 't/data/LOAD_Ccd1.dnd'); my $tree = $treeio->next_tree; =head1 DESCRIPTION This module handles parsing and writing of Newick/PHYLIP/New Hampshire format. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::newick; use strict; use Bio::Event::EventGeneratorI; use base qw(Bio::TreeIO Bio::TreeIO::NewickParser); =head2 new Title : new Args : -print_count => boolean default is false -bootstrap_style => set the bootstrap style (one of nobranchlength, molphy, traditional) -order_by => set the order by sort method See L<Bio::Node::Node::each_Descendent()> =cut sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); my ( $print_count ) = $self->_rearrange( [ qw(PRINT_COUNT) ], @_ ); $self->print_tree_count( $print_count || 0 ); return; } =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree Function: Gets the next tree in the stream Returns : L<Bio::Tree::TreeI> Args : none =cut sub next_tree { my ($self) = @_; local $/ = ";\n"; return unless $_ = $self->_readline; s/[\r\n]//gs; my $score; my $despace = sub { my $dirty = shift; $dirty =~ s/\s+//gs; return $dirty }; my $dequote = sub { my $dirty = shift; $dirty =~ s/^"?\s*(.+?)\s*"?$/$1/; return $dirty; }; s/([^"]*)(".+?")([^"]*)/$despace->($1) . $dequote->($2) . $despace->($3)/egsx; if (s/^\s*\[([^\]]+)\]//) { my $match = $1; $match =~ s/\s//g; $match =~ s/lh\=//; if ( $match =~ /([-\d\.+]+)/ ) { $score = $1; } } $self->_eventHandler->start_document; # Call the parse_newick method as defined in NewickParser.pm $self->parse_newick($_); my $tree = $self->_eventHandler->end_document; # Add the tree score afterwards if it exists. if (defined $tree) { $tree->score($score); return $tree; } } # Returns the default set of parsing & writing parameters for the Newick format. sub get_default_params { my $self = shift; return { newline_each_node => 0, order_by => '', # ??? bootstrap_style => 'traditional', # Can be 'traditional', 'molphy', 'nobranchlength' internal_node_id => 'id', # Can be 'id' or 'bootstrap' no_branch_lengths => 0, no_bootstrap_values => 0, no_internal_node_labels => 0 }; } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Write a tree out to data stream in newick/phylip format Returns : none Args : L<Bio::Tree::TreeI> object =cut sub write_tree { my ( $self, @trees ) = @_; if ( $self->print_tree_count ) { $self->_print( sprintf( " %d\n", scalar @trees ) ); } my $params = $self->get_params; foreach my $tree (@trees) { if ( !defined $tree || ref($tree) =~ /ARRAY/i || !$tree->isa('Bio::Tree::TreeI') ) { $self->throw( "Calling write_tree with non Bio::Tree::TreeI object\n"); } my @data = $self->_write_tree_Helper( $tree->get_root_node, $params); $self->_print( join( ',', @data ).";" ); } $self->flush if $self->_flush_on_write && defined $self->_fh; return; } sub _write_tree_Helper { my $self = shift; my ( $node, $params ) = @_; my @data; foreach my $n ( $node->each_Descendent($params->{order_by}) ) { push @data, $self->_write_tree_Helper( $n, $params ); } my $label = $self->_node_as_string($node,$params); if ( scalar(@data) >= 1) { $data[0] = "(" . $data[0]; $data[-1] .= ")"; $data[-1] .= $label; } else { push @data, $label; } return @data; } sub _node_as_string { my $self = shift; my $node = shift; my $params = shift; my $label_stringbuffer = ''; if ($params->{no_bootstrap_values} != 1 && !$node->is_Leaf && defined $node->bootstrap && $params->{bootstrap_style} eq 'traditional' && $params->{internal_node_id} eq 'bootstrap') { # If we're an internal node and we're using 'traditional' bootstrap style, # we output the bootstrap instead of any label. my $bootstrap = $node->bootstrap; $label_stringbuffer .= $bootstrap if (defined $bootstrap); } elsif ($params->{no_internal_node_labels} != 1) { my $id = $node->id; $label_stringbuffer .= $id if( defined $id ); } if ($params->{no_branch_lengths} != 1) { my $blen = $node->branch_length; $label_stringbuffer .= ":". $blen if (defined $blen); } if ($params->{bootstrap_style} eq 'molphy') { my $bootstrap = $node->bootstrap; $label_stringbuffer .= "[$bootstrap]" if (defined $bootstrap); } if ($params->{newline_each_node} == 1) { $label_stringbuffer .= "\n"; } return $label_stringbuffer; } =head2 print_tree_count Title : print_tree_count Usage : $obj->print_tree_count($newval) Function: Get/Set flag for printing out the tree count (paml,protml way) Returns : value of print_tree_count (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub print_tree_count { my $self = shift; return $self->{'_print_tree_count'} = shift if @_; return $self->{'_print_tree_count'} || 0; } =head2 bootstrap_style Title : bootstrap_style Usage : $obj->bootstrap_style($newval) Function: A description of how bootstraps and branch lengths are written, as the ID part of the internal node or else in [] in the branch length (Molphy-like; I am sure there is a better name for this but am not sure where to go for some sort of format documentation) If no branch lengths are requested then no bootstraps are usually written (unless someone REALLY wants this functionality...) Can take on strings which contain the possible values of 'nobranchlength' --> don't draw any branch lengths - this is helpful if you don't want to have to go through and delete branch len on all nodes 'molphy' --> draw bootstraps (100) like (A:0.11,B:0.22):0.33[100]; 'traditional' --> draw bootstraps (100) like (A:0.11,B:0.22)100:0.33; Returns : value of bootstrap_style (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub bootstrap_style { my $self = shift; my $val = shift; if ( defined $val ) { if ( $val !~ /^nobranchlength|molphy|traditional/i ) { $self->warn( "requested an unknown bootstrap style $val, expect one of nobranchlength,molphy,traditional, not updating value.\n" ); } else { $self->{'_bootstrap_style'} = $val; } } return $self->{'_bootstrap_style'} || 'traditional'; } =head2 order_by Title : order_by Usage : $obj->order_by($newval) Function: Allow node order to be specified (typically "alpha") See L<Bio::Node::Node::each_Descendent()> Returns : value of order_by (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub order_by { my $self = shift; return $self->{'order_by'} = shift if @_; return $self->{'order_by'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/NewickParser.pm����������������������������������������������������������000444��000765��000024�� 16466�12254227323� 20266� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# POD documentation - main docs before the code =head1 NAME Module which implements a newick string parser as a finite state machine which enables it to parse the full Newick specification. Taken largely from the Ensembl Compara file with the same name (Bio::EnsEMBL::Compara::Graph::NewickParser), this module adapts the parser to work with BioPerl's event handler-based parsing scheme. This module is used by nhx.pm and newick.pm, and is NOT called directly. Instead, both of those parsing modules extend this module in order to gain access to the main parsing method. =head1 SYNOPSIS # From newick.pm use base qw(Bio::TreeIO Bio::TreeIO::NewickParser); # in the next_tree method... $self->parse_newick($_); =head1 DESCRIPTION This module correctly parses the Newick and NHX formats, sending calls to the BioPerl TreeEventHandler when appropriate in order to build and populate the node objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jessica Severin (EnsEMBL implementation), Greg Jordan (BioPerl adaptation) =cut package Bio::TreeIO::NewickParser; use strict; use base qw(Bio::Root::Root); sub parse_newick { my $self = shift; my $newick = shift; $newick = $newick . ";" unless ($newick =~ m/;/); my $count=1; my $debug = $self->verbose; my $token = next_token(\$newick, "(;"); my $state=1; my $bracket_level = 0; $self->_start('tree'); my $leaf_flag = 0; while(defined($token)) { # backwards-compat. with 5.8.1, no Switch (but we hate if-elsif-ad-infinitum if ($state == 1) { #new node $self->_start('node'); $self->debug(" -> [$token]\n"); if($token eq '(') { #create new set $self->debug(" create set\n") if($debug); $token = next_token(\$newick, "[(:,)"); $state = 1; $bracket_level++; } else { $state = 2; $leaf_flag = 1; } } elsif ($state == 2) { #naming a node if(!($token =~ /[\[\:\,\)\;]/)) { if (!$leaf_flag && $self->param('internal_node_id') eq 'bootstrap') { $self->_start('bootstrap'); $self->_chars($token); $self->_end('bootstrap'); $token = ''; } $self->_start('id'); $self->_chars($token); $self->_end('id'); $self->debug(" naming leaf\n") if ($debug); $token = next_token(\$newick, "[:,);"); } $state = 3; } elsif ($state == 3) { # optional : and distance if($token eq ':') { $token = next_token(\$newick, "[,);"); $self->_start('branch_length'); $self->_chars($token); $self->_end('branch_length'); $token = next_token(\$newick, ",);"); #move to , or ) } elsif ($token eq '[') { # NHX tag without previous blength $token .= next_token(\$newick, ",);"); } $state = 4; } elsif ($state == 4) { # optional NHX tags if($token =~ /\[\&\&NHX/) { # careful: this regexp gets rid of all NHX wrapping in one step $self->_start('nhx_tag'); $token =~ /\[\&\&NHX\:(\S+)\]/; if ($1) { # NHX may be empty, presumably at end of file, just before ";" my @attributes = split ':', $1; foreach my $attribute (@attributes) { $attribute =~ s/\s+//; my($key,$value) = split '=', $attribute; $self->_start('tag_name'); $self->_chars($key); $self->_end('tag_name'); $self->_start('tag_value'); $self->_chars($value); $self->_end('tag_value'); } } $self->_end('nhx_tag'); $token = next_token(\$newick, ",);"); #move to , or ) } $state = 5; } elsif ($state == 5) { # end node if($token eq ')') { $self->_end('node'); $token = next_token(\$newick, "[:,);"); if (defined $token && $token eq '[') { # It is possible to have anonymous internal nodes w/ no name # and no blength but with NHX tags # # We use leaf_flag=0 to let the parser know that it's labeling an internal # node. This affects how potential bootstrap values are handled in state 2. $leaf_flag = 0; $state = 2; } else { $leaf_flag = 0; $state = 2; } $bracket_level--; } elsif($token eq ',') { $self->_end('node'); $token = next_token(\$newick, "[(:,)"); #can be un_blengthed nhx nodes $state=1; } elsif($token eq ';') { #done with tree $self->throw("parse error: unbalanced ()\n") if($bracket_level ne 0); $self->_end('node'); $self->_end('tree'); $token = next_token(\$newick, "("); $state=13; } else { $self->debug("[$token]]\n"); $self->throw("parse error: expected ; or ) or ,\n"); } } elsif ($state == 13) { $self->throw("parse error: nothing expected after ;"); } } if ($self->_eventHandler->within_element('tree')) { $self->_end('node'); $self->_end('tree'); } } sub _chars { my $self = shift; my $chars = shift; $self->_eventHandler->characters($chars); } sub _start { my $self = shift; my $name = shift; $self->_eventHandler->start_element({Name=>$name}); } sub _end { my $self = shift; my $name = shift; $self->_eventHandler->end_element({Name=>$name}); } sub next_token { my $string = shift; my $delim = shift; $$string =~ s/^(\s)+//; return undef unless(length($$string)); #print("input =>$$string\n"); #print("delim =>$delim\n"); my $index=undef; my @delims = split(/ */, $delim); foreach my $dl (@delims) { my $pos = index($$string, $dl); if($pos>=0) { $index = $pos unless(defined($index)); $index = $pos if($pos<$index); } } unless(defined($index)) { # have to call as class here (this is not an instance method) Bio::Root::Root->throw("couldn't find delimiter $delim\n $$string"); } my $token =''; if($index==0) { $token = substr($$string,0,1); $$string = substr($$string, 1); } else { $token = substr($$string, 0, $index); $$string = substr($$string, $index); } #print(" token =>$token\n"); #print(" outstring =>$$string\n\n"); return $token; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/nexml.pm�����������������������������������������������������������������000444��000765��000024�� 7636�12254227336� 16777� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::nexml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Chase Miller <chmille4@gmail.com> # # Copyright Chase Miller # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::nexml - A TreeIO driver module for parsing NeXML tree files =head1 SYNOPSIS use Bio::TreeIO; my $in = Bio::TreeIO->new(-file => 'data.nexml' -format => 'Nexml'); while( my $tree = $in->next_tree ) { } =head1 DESCRIPTION This is a driver module for parsing tree data in a NeXML format. For more information on NeXML, visit L<http://www.nexml.org>. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Chase Miller Email chmille4@gmail.com =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::nexml; use strict; use lib '../..'; use Bio::Event::EventGeneratorI; use IO::String; use Bio::Nexml::Factory; use Bio::Phylo::IO qw (parse unparse); use base qw(Bio::TreeIO); sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); $self->{_doc} = undef; } =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree Function: Gets the next tree in the stream Returns : L<Bio::Tree::TreeI> Args : none =cut sub next_tree { my ($self) = @_; unless ( $self->{'_parsed'} ) { $self->_parse; } return $self->{'_trees'}->[ $self->{'_treeiter'}++ ]; } =head2 doc Title : doc Usage : $treeio->doc Function: Returns the biophylo nexml document object Returns : Bio::Phylo::Project Args : none or Bio::Phylo::Project object =cut sub doc { my ($obj,$value) = @_; if( defined $value) { $obj->{'_doc'} = $value; } return $obj->{'_doc'}; } =head2 rewind Title : rewind Usage : $treeio->rewind Function: Resets the stream Returns : none Args : none =cut sub rewind { my $self = shift; $self->{'_treeiter'} = 0; } sub _parse { my ($self) = @_; $self->{'_parsed'} = 1; $self->{'_treeiter'} = 0; my $fac = Bio::Nexml::Factory->new(); $self->doc(parse( '-file' => $self->{'_file'}, '-format' => 'nexml', '-as_project' => '1' )); $self->{'_trees'} = $fac->create_bperl_tree($self); } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Writes a tree onto the stream Returns : none Args : L<Bio::Tree::TreeI> =cut sub write_tree { my ($self, $bp_tree) = @_; my $fac = Bio::Nexml::Factory->new(); my $taxa = $fac->create_bphylo_taxa($bp_tree); my ($tree) = $fac->create_bphylo_tree($bp_tree, $taxa); my $forest = Bio::Phylo::Factory->create_forest(); $self->doc(Bio::Phylo::Factory->create_project()); $forest->set_taxa($taxa); $forest->insert($tree); $self->doc->insert($forest); my $ret = $self->_print($self->doc->to_xml()); $self->flush; return $ret; } 1; ��������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/nexus.pm�����������������������������������������������������������������000444��000765��000024�� 24676�12254227336� 17041� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::nexus # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-open-bio-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::nexus - A TreeIO driver module for parsing Nexus tree output from PAUP =head1 SYNOPSIS use Bio::TreeIO; my $in = Bio::TreeIO->new(-file => 't/data/cat_tre.tre'); while( my $tree = $in->next_tree ) { } =head1 DESCRIPTION This is a driver module for parsing PAUP Nexus tree format which basically is just a remapping of trees. =head2 Comments The nexus format allows node comments that are placed inside square brackets. Usually the comments (implemented as tags for nodes) are used to give a name for an internal node or record the bootstap value, but other uses are possible. The FigTree program by Andrew Rambaut adds various rendering parameters inside comments and flags these comments by starting them with '&!'. The parameters implemented here are 'label' and 'color'. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-open-bio-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::nexus; use strict; use Bio::Event::EventGeneratorI; use IO::String; use base qw(Bio::TreeIO); =head2 new Title : new Args : -header => boolean default is true print/do not print #NEXUS header -translate => boolean default is true print/do not print Node Id translation to a number =cut sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); my ( $hdr, $trans ) = $self->_rearrange( [ qw(HEADER TRANSLATE) ], @_ ); $self->header( defined $hdr ? $hdr : 1 ); $self->translate_node( defined $trans ? $trans : 1 ); } =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree Function: Gets the next tree in the stream Returns : Bio::Tree::TreeI Args : none =cut sub next_tree { my ($self) = @_; unless ( $self->{'_parsed'} ) { $self->_parse; } return $self->{'_trees'}->[ $self->{'_treeiter'}++ ]; } sub rewind { shift->{'_treeiter'} = 0; } sub _parse { my ($self) = @_; $self->{'_parsed'} = 1; $self->{'_treeiter'} = 0; while ( defined( $_ = $self->_readline ) ) { next if /^\s+$/; last; } return unless ( defined $_ ); unless (/^\#NEXUS/i) { $self->warn("File does not start with #NEXUS"); #' return; } my $line; while ( defined( $_ = $self->_readline ) ) { $line .= $_; } my @sections = split( /#NEXUS/i, $line ); for my $s (@sections) { my %translate; if ( $self->verbose > 0 ) { while ( $s =~ s/(\[[^\]]+\])// ) { $self->debug("removing comment $1\n"); } } else { $s =~ s/(\[[^\]]+\])//g; } if ( $s =~ /begin trees;(.+)(end;)?/si ) { my $trees = $1; if ( $trees =~ s/\s+translate\s+([^;]+);//i ) { my @trans; my $tr = $1; while ($tr =~ m{\s*([^,\s]+?\s+(?:'[^']+'|[^'\s]+)),?}gc) { push @trans, $1; } for my $n ( @trans ) { if ($n =~ /^\s*(\S+)\s+(.+)$/) { my ($id,$tag) = ($1,$2); $tag =~ s/[\s,]+$//; # remove the extra spaces of the last taxon $translate{$id} = $tag; } } } else { $self->debug("no translate in: $trees\n"); } while ($trees =~ /\s+tree\s+\*?\s*(\S+)\s*\= \s*(?:\[\S+\])?\s*([^\;]+;)/igx) { my ( $tree_name, $tree_str ) = ( $1, $2 ); # MrBayes does not print colons for node label # $tree_str =~ s/\)(\d*\.\d+)\)/:$1/g; my $buf = IO::String->new($tree_str); my $treeio = Bio::TreeIO->new( -format => 'newick', -fh => $buf ); my $tree = $treeio->next_tree; foreach my $node ( grep { $_->is_Leaf } $tree->get_nodes ) { my $id = $node->id; my $lookup = $translate{$id}; $node->id( $lookup || $id ); } $tree->id($tree_name) if defined $tree_name; push @{ $self->{'_trees'} }, $tree; } } else { $self->debug("begin_trees failed: $s\n"); } } if ( !@sections ) { $self->debug("warn no sections: $line\n"); } } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Writes a tree onto the stream Returns : none Args : Bio::Tree::TreeI =cut sub write_tree { my ( $self, @trees ) = @_; if ( $self->header ) { $self->_print("#NEXUS\n\n"); } my $translate = $self->translate_node; my $time = localtime(); $self->_print( sprintf( "Begin trees; [Treefile created %s]\n", $time ) ); my ( $first, $nodecter, %node2num ) = ( 0, 1 ); foreach my $tree (@trees) { if ( $first == 0 && $translate ) { $self->_print("\tTranslate\n"); $self->_print( join( ",\n", map { $node2num{ $_->id } = $nodecter; sprintf( "\t\t%d %s", $nodecter++, $_->id ) } grep { $_->is_Leaf } $tree->get_nodes ), "\n;\n" ); } my @data = _write_tree_Helper( $tree->get_root_node, \%node2num ); if ( $data[-1] !~ /\)$/ ) { $data[0] = "(" . $data[0]; $data[-1] .= ")"; } # by default all trees in bioperl are currently rooted # something we'll try and fix one day.... $self->_print( sprintf( "\t tree %s = [&%s] %s;\n", ( $tree->id || sprintf( "Bioperl_%d", $first + 1 ) ), ( $tree->get_root_node ) ? 'R' : 'U', join( ',', @data ) ) ); $first++; } $self->_print("End;\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return; } sub _write_tree_Helper { my ( $node, $node2num ) = @_; return () if ( !defined $node ); my @data; foreach my $n ( $node->each_Descendent() ) { push @data, _write_tree_Helper( $n, $node2num ); } if ( @data > 1 ) { # internal node $data[0] = "(" . $data[0]; $data[-1] .= ")"; # FigTree comments start my $comment_flag; $comment_flag = 0 if ( $node->has_tag('color') or $node->has_tag('label') ); $data[-1] .= '[&!' if defined $comment_flag; if ( $node->has_tag('color')) { my $color = $node->get_tag_values('color'); $data[-1] .= "color=$color"; $comment_flag++; } if ( $node->has_tag('label')) { my $label = $node->get_tag_values('label'); $data[-1] .= ',' if $comment_flag; $data[-1] .= 'label="'. $label. '"'; } $data[-1] .= ']' if defined $comment_flag; # FigTree comments end # let's explicitly write out the bootstrap if we've got it my $b; my $bl = $node->branch_length; if ( !defined $bl ) { } elsif ( $bl =~ /\#/ ) { $data[-1] .= $bl; } else { $data[-1] .= ":$bl"; } if ( defined( $b = $node->bootstrap ) ) { $data[-1] .= sprintf( "[%s]", $b ); } elsif ( defined( $b = $node->id ) ) { $b = $node2num->{$b} if ( $node2num->{$b} ); # translate node2num $data[-1] .= sprintf( "[%s]", $b ) if defined $b; } } else { # leaf node if ( defined $node->id || defined $node->branch_length ) { my $id = defined $node->id ? $node->id : ''; if ( length($id) && $node2num->{$id} ) { $id = $node2num->{$id}; } if ( $node->has_tag('color')) { my ($color) = $node->get_tag_values('color'); $id .= "[&!color=$color\]"; } push @data, sprintf( "%s%s", $id, defined $node->branch_length ? ":" . $node->branch_length : '' ); } } return @data; } =head2 header Title : header Usage : $obj->header($newval) Function: Example : Returns : value of header (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub header { my $self = shift; return $self->{'header'} = shift if @_; return $self->{'header'}; } =head2 translate_node Title : translate_node Usage : $obj->translate_node($newval) Function: Example : Returns : value of translate_node (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub translate_node { my $self = shift; return $self->{'translate_node'} = shift if @_; return $self->{'translate_node'}; } 1; ������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/nhx.pm�������������������������������������������������������������������000444��000765��000024�� 5240�12254227313� 16431� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::nhx # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Aaron Mackey <amackey@virginia.edu> # # Copyright Aaron Mackey # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::nhx - TreeIO implementation for parsing Newick/New Hampshire eXtendend (NHX) format. =head1 SYNOPSIS # do not use this module directly use Bio::TreeIO; my $treeio = Bio::TreeIO->new(-format => 'nhx', -file => 'tree.dnd'); my $tree = $treeio->next_tree; =head1 DESCRIPTION This module handles parsing and writing of Newick/New Hampshire eXtended (NHX) format. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted viax the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Aaron Mackey Email amackey-at-virginia.edu =head1 CONTRIBUTORS Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::nhx; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Tree::NodeNHX; use Bio::Event::EventGeneratorI; #use XML::Handler::Subs; use base qw(Bio::TreeIO::newick); sub _initialize { my($self, %args) = @_; $args{-nodetype} ||= 'Bio::Tree::NodeNHX'; $self->SUPER::_initialize(%args); } sub _node_as_string { my $self = shift; my $node = shift; my $params = shift; my $label_stringbuffer = $self->SUPER::_node_as_string($node,$params); my @tags = $node->get_all_tags; if( scalar(@tags) > 0 ) { @tags = sort @tags; $label_stringbuffer .= '[' . join(":", "&&NHX", map { "$_=" .join(',',$node->get_tag_values($_)) } @tags ) . ']'; } return $label_stringbuffer; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/pag.pm�������������������������������������������������������������������000444��000765��000024�� 15563�12254227316� 16437� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::pag # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason-at-bioperl-dot-org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::pag - Bio::TreeIO driver for Pagel format =head1 SYNOPSIS use Bio::TreeIO; my $in = Bio::TreeIO->new(-format => 'nexus', -file => 't/data/adh.mb_tree.nexus'); my $out = Bio::TreeIO->new(-format => 'pag'); while( my $tree = $in->next_tree ) { $out->write_tree($tree); } =head1 DESCRIPTION Convert a Bio::TreeIO to Pagel format. More information here http://www.evolution.reading.ac.uk/index.html =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::pag; use strict; our $TaxonNameLen = 10; use base qw(Bio::TreeIO); =head2 new Title : new Usage : my $obj = Bio::TreeIO::pag->new(); Function: Builds a new Bio::TreeIO::pag object Returns : an instance of Bio::TreeIO::pag Args : -file/-fh for filename or filehandles -name_length for minimum name length (default = 10) =cut sub _initialize { my $self = shift; $self->SUPER::_initialize(@_); my ( $name_length ) = $self->_rearrange( [ qw(NAME_LENGTH) ], @_ ); $self->name_length( defined $name_length ? $name_length : $TaxonNameLen ); } =head2 write_tree Title : write_tree Usage : Function: Write a tree out in Pagel format Some options are only appropriate for bayesianmultistate and the simpler output is only proper for discrete Returns : none Args : -no_outgroups => (number) -print_header => 0/1 (leave 0 for discrete, 1 for bayesianms) -special_node => special node - not sure what they wanted to do here -keep_outgroup => 0/1 (keep the outgroup node in the output) -outgroup_ancestor => Bio::Tree::Node (if we want to exclude or include the outgroup this is what we operate on) -tree_no => a tree number label - only useful for BayesianMultistate =cut sub write_tree { my ($self,$tree,@args) = @_; my ($keep_outgroup, $print_header, $no_outgroups, $special_node, $outgroup_ancestor, $tree_no) = (0,0,1); my $name_len = $self->name_length; if( @args ) { ($no_outgroups, $print_header, $special_node, $outgroup_ancestor, $tree_no, $keep_outgroup) = $self->_rearrange([qw( NO_OUTGROUPS PRINT_HEADER SPECIAL_NODE OUTGROUP_ANCESTOR TREE_NO KEEP_OUTGROUP NAME_LENGTH)],@args); } my $newname_base = 1; my $root = $tree->get_root_node; my $eps = 0.0001; my (%chars,%names); my @nodes = $tree->get_nodes; my $species_ct; my $traitct; for my $node ( @nodes ) { if ((defined $special_node) && ($node eq $special_node)) { my $no_of_tree_nodes = scalar(@nodes); my $node_name = sprintf("N%d",$no_of_tree_nodes+1); $names{$node->internal_id} = $node_name; } elsif ($node->is_Leaf) { $species_ct++; my $node_name = $node->id; if( length($node_name)> $name_len ) { $self->warn( "Found a taxon name longer than $name_len letters, \n", "name will be abbreviated.\n"); $node_name = substr($node_name, 0,$name_len); } else { # $node_name = sprintf("%-".$TaxonNameLen."s",$node_name); } $names{$node->internal_id} = $node_name; my @tags = sort $node->get_all_tags; my @charstates = map { ($node->get_tag_values($_))[0] } @tags; $traitct = scalar @charstates unless defined $traitct; $chars{$node->internal_id} = [@charstates]; } else { $names{$node->internal_id} = sprintf("N%d", $newname_base++); } } # generate PAG representation if( $print_header ) { if ($keep_outgroup) { $self->_print(sprintf("%d %d\n",$species_ct,$traitct)); } else { $self->_print( sprintf("%d %d\n",$species_ct-$no_outgroups,$traitct)); } } my @ancestors = (); if ($keep_outgroup) { push @ancestors, $root; } else { push @ancestors, ( $root, $outgroup_ancestor); } my @rest; foreach my $node (@nodes) { my $i = 0; foreach my $anc (@ancestors) { if ($anc && $node eq $anc) { $i = 1; last } } unless ($i > 0) { # root not given in PAG my $current_name = $names{$node->internal_id}; my $branch_length_to_output; if ($node->branch_length < $eps) { my $msg_nodename = $current_name; $msg_nodename =~ s/\s+$//; warn( "TREE $tree_no, node \"$msg_nodename\": branch too ", "short (", $node->branch_length, "): increasing length to ", "$eps\n"); $branch_length_to_output = $eps; } else { $branch_length_to_output = $node->branch_length; } my @line = ( $current_name, $names{$node->ancestor->internal_id}, $branch_length_to_output); if ($node->is_Leaf) { push @line, @{$chars{$node->internal_id}}; $self->_print(join(',', @line),"\n"); } else { push @rest, \@line; } } } for ( @rest ) { $self->_print(join(',', @$_),"\n"); } } =head2 next_tree Title : next_tree Usage : Function: Example : Returns : Args : =cut sub next_tree{ my ($self,@args) = @_; $self->throw_not_implemented(); } =head2 name_length Title : name_length Usage : $self->name_length(20); Function: set mininum taxon name length Returns : integer (length of name) Args : integer =cut sub name_length { my ($self, $val) = @_; return $self->{'name_len'} = $val if $val; return $self->{'name_len'}; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/phyloxml.pm��������������������������������������������������������������000444��000765��000024�� 123511�12254227327� 17557� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# $Id: phyloxml.pm 11507 2007-06-23 01:37:45Z jason $ # # BioPerl module for Bio::TreeIO::phyloxml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Mira Han <mirhan@indiana.edu> # # Copyright Mira Han # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::phyloxml - TreeIO implementation for parsing PhyloXML format. =head1 SYNOPSIS # do not use this module directly use Bio::TreeIO; my $treeio = Bio::TreeIO->new(-format => 'phyloxml', -file => 'tree.dnd'); my $tree = $treeio->next_tree; =head1 DESCRIPTION This module handles parsing and writing of phyloXML format. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted viax the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Mira Han Email mirhan@indiana.edu =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::phyloxml; use strict; # Object preamble - inherits from Bio::Root::Root use Bio::Tree::Tree; use Bio::Tree::AnnotatableNode; use Bio::Annotation::SimpleValue; use Bio::Annotation::Relation; use XML::LibXML; use XML::LibXML::Reader; use base qw(Bio::TreeIO); sub _initialize { my($self, %args) = @_; $args{-treetype} ||= 'Bio::Tree::Tree'; $args{-nodetype} ||= 'Bio::Tree::AnnotatableNode'; $self->SUPER::_initialize(%args); # phyloxml TreeIO does not use SAX, # therefore no need to attach EventHandler # instead we will define a reader that is a pull-parser of libXML if ($self->mode eq 'r') { if ($self->_fh) { $self->{'_reader'} = XML::LibXML::Reader->new( IO => $self->_fh, no_blanks => 1 ); } if (!$self->{'_reader'}) { $self->throw("XML::LibXML::Reader not initialized"); } } elsif ($self->mode eq 'w') { # print default lines $self->_print('<?xml version="1.0" encoding="UTF-8"?>',"\n"); $self->_print('<phyloxml xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns="http://www.phyloxml.org" xsi:schemaLocation="http://www.phyloxml.org http://www.phyloxml.org/1.10/phyloxml.xsd">'); } $self->treetype($args{-treetype}); $self->nodetype($args{-nodetype}); $self->{'_lastitem'} = {}; # holds open items and the attribute hash $self->_init_func(); } sub _init_func { my ($self) = @_; my %start_elements = ( 'phylogeny' => \&element_phylogeny, 'clade' => \&element_clade, 'sequence_relation' => \&element_relation, 'clade_relation' => \&element_relation, ); $self->{'_start_elements'} = \%start_elements; my %end_elements = ( 'phylogeny' => \&end_element_phylogeny, 'clade' => \&end_element_clade, 'sequence_relation' => \&end_element_relation, 'clade_relation' => \&end_element_relation, ); $self->{'_end_elements'} = \%end_elements; } sub DESTROY { my $self = shift; if ($self->mode eq 'w') { $self->_print('</phyloxml>'); $self->flush if $self->_flush_on_write && defined $self->_fh; } $self->SUPER::DESTROY; } =head2 next_tree Title : next_tree Usage : my $tree = $treeio->next_tree Function: Gets the next tree in the stream Returns : Bio::Tree::TreeI Args : none =cut sub next_tree { my ($self) = @_; my $reader = $self->{'_reader'}; my $tree; while ($reader->read) { if ($reader->nodeType == XML_READER_TYPE_END_ELEMENT) { if ($reader->name eq 'phylogeny') { $tree = $self->end_element_phylogeny(); last; } } $self->processXMLNode; } return $tree; } =head2 add_attribute Title : add_phyloXML_annotation Usage : my $node = $treeio->add_phyloXML_annotation(-obj=>$node, -attr=>"id_source = \"A\"") Function: add attributes to an object Returns : the node that we added annotations to Args : -obj => object that will have the Annotation. (Bio::Tree::AnnotatableNode) -attr => string in the form "A = B", where A is the attribute name and B is the attribute value =cut sub add_attribute { my ($self, @args) = @_; my ($obj, $attr) = $self->_rearrange([qw(OBJ ATTR)], @args); if ($attr) { $attr = '<dummy '.$attr.'/>'; } my $oldreader = $self->{'_reader'}; # save reader $self->{'_reader'} = XML::LibXML::Reader->new( string => $attr, no_blanks => 1 ); my $reader = $self->{'_reader'}; $self->{'_currentannotation'} = []; # holds annotationcollection $self->{'_currenttext'} = ''; #$self->{'_id_link'} = {}; # pretend we saw a <clade> element $self->{'_lastitem'}->{'dummy'}++; push @{$self->{'_lastitem'}->{'current'}}, { 'dummy'=>{}}; # current holds current element and empty hash for its attributes # push object to annotate push @{$self->{'_currentitems'}}, $obj; # read attributes of element while ($reader->read) { #$self->processXMLNode; $self->processAttribute($self->current_attr); } # if there is id_source add sequence to _id_link if (exists $self->current_attr->{'id_source'}) { my $idsrc = $self->current_attr->{'id_source'}; $self->{'_id_link'}->{$idsrc} = $obj; } # check idref my $idref = ''; if (exists $self->current_attr->{'id_ref'}) { $idref = $self->current_attr->{'id_ref'}; } my $srcbyidref = ''; $srcbyidref = $self->{'_id_link'}->{$idref}; # exception when id_ref is defined but id_src is not, or vice versa. if ($idref xor $srcbyidref) { $self->throw("id_ref and id_src incompatible: $idref, $srcbyidref"); } # if attribute exists then add Annotation::Collection with tag '_attr' my $newac = $obj->annotation; if ( scalar keys %{$self->current_attr} ) { my $newattr = Bio::Annotation::Collection->new(); foreach my $tag (keys %{$self->current_attr}) { my $sv = Bio::Annotation::SimpleValue->new( -value => $self->current_attr->{$tag} ); $newattr->add_Annotation($tag, $sv); } $newac->add_Annotation('_attr', $newattr); } # pop from temporary list pop @{$self->{'_currentitems'}}; $self->{'_lastitem'}->{ $reader->name }-- if $reader->name; pop @{$self->{'_lastitem'}->{'current'}}; $self->{'_reader'} = $oldreader; # restore reader return $obj; } =head2 add_phyloXML_annotation Title : add_phyloXML_annotation Usage : my $node = $treeio->add_phyloXML_annotation(-obj=>$node, -xml=>$xmlstring) my $tree = $treeio->add_phyloXML_annotation('-obj'=>$tree, '-xml'=>'<sequence_relation id_ref_0="A" id_ref_1="B" type="orthology"/>') Function: add annotations to a node in the phyloXML format string Returns : the node that we added annotations to Args : -obj => object that will have the Annotation. (Bio::Tree::AnnotatableNode) -xml => string in phyloXML format that describes the annotation for the node =cut sub add_phyloXML_annotation { my ($self, @args) = @_; my ($obj, $xml_string) = $self->_rearrange([qw(OBJ XML)], @args); $xml_string = '<phyloxml>'.$xml_string.'</phyloxml>'; $self->debug( $xml_string ); my $oldreader = $self->{'_reader'}; # save reader $self->{'_reader'} = XML::LibXML::Reader->new( string => $xml_string, no_blanks => 1 ); my $reader = $self->{'_reader'}; #$self->{'_currentannotation'} = []; # holds annotationcollection #$self->{'_currenttext'} = ''; #$self->{'_id_link'} = {}; # pretend we saw a <clade> element $self->{'_lastitem'}->{'clade'}++; push @{$self->{'_lastitem'}->{'current'}}, { 'clade'=>{}}; # current holds current element and empty hash for its attributes # our object to annotate (nodeI) # push into temporary list push @{$self->{'_currentitems'}}, $obj; $reader->read; #read away the first element 'phyloxml' while ($reader->read) { $self->processXMLNode; } # pop from temporary list pop @{$self->{'_currentitems'}}; $self->{'_lastitem'}->{ $reader->name }-- if $reader->name; pop @{$self->{'_lastitem'}->{'current'}}; $self->{'_reader'} = $oldreader; # restore reader return $obj; } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Write a tree out to data stream in phyloxml format Returns : none Args : Bio::Tree::TreeI object =cut sub write_tree { my ($self, @trees) = @_; foreach my $tree (@trees) { my $root = $tree->get_root_node; $self->_print("<phylogeny"); my @tags = $tree->get_all_tags(); my $attr_str = ''; foreach my $tag (@tags) { my @values = $tree->get_tag_values($tag); foreach (@values) { $attr_str .= " ".$tag."=\"".$_."\""; } } # check if rooted my ($b_rooted) = $tree->get_tag_values('rooted'); if ($b_rooted) { $attr_str .= " rooted=\"true\""; } else { if($tree->is_binary($tree->get_root_node)) { $attr_str .= " rooted=\"true\""; } else { $attr_str .= " rooted=\"false\""; } } $self->_print($attr_str); $self->_print(">"); 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'}})) { $self->_print($str); } # print sequence relations while (my $str = pop (@{$self->{'_tree_attr'}->{'sequence_relation'}})) { $self->_print($str); } $self->_print("</phylogeny>"); } $self->flush if $self->_flush_on_write && defined $self->_fh; return; } =head2 _write_tree_Helper_annotatableNode Title : _write_tree_Helper_annotatableNode Usage : internal method used by write_tree, not to be used directly Function: recursive helper function of write_tree for the annotatableNodes. translates annotations into xml elements. Returns : string describing the node Args : Bio::Node::AnnotatableNode object, string =cut sub _write_tree_Helper_annotatableNode { my ($self, $node, $str) = @_; # this self is a Bio::Tree::phyloxml my $ac = $node->annotation; # if clade_relation exists my @relations = $ac->get_Annotations('clade_relation'); foreach (@relations) { my $clade_rel = $self->_relation_to_string($node, $_, ''); # set as tree attr push (@{$self->{'_tree_attr'}->{'clade_relation'}}, $clade_rel); } # start <clade> $str .= '<clade'; my ($attr) = $ac->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."\""; } } $str .= ">"; # print all descendent nodes foreach my $child ( $node->each_Descendent() ) { $str = $self->_write_tree_Helper_annotatableNode($child, $str); } # print all annotations $str = print_annotation( $node, $str, $ac ); # print all sequences if ($node->has_sequence) { foreach my $seq (@{$node->sequence}) { # if sequence_relation exists my @relations = $seq->annotation->get_Annotations('sequence_relation'); foreach (@relations) { my $sequence_rel = $self->_relation_to_string($seq, $_, ''); # set as tree attr push (@{$self->{'_tree_attr'}->{'sequence_relation'}}, $sequence_rel); } $str = print_seq_annotation( $node, $str, $seq ); } } $str .= "</clade>"; return $str; } =head2 _write_tree_Helper_generic Title : _write_tree_Helper_generic Usage : internal method used by write_tree, not to be used directly Function: recursive helper function of write_tree for generic NodesI. all tags are translated into property elements. Returns : string describing the node Args : Bio::Node::NodeI object, string =cut sub _write_tree_Helper_generic { my ($self, $node, $str) = @_; # this self is a Bio::Tree::phyloxml # start <clade> $str .= '<clade>'; # 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 .= "<property datatype=\"xsd:string\" ref=\"tag:$tag\" applies_to=\"clade\">"; $str .=$val; $str .= "</property>"; } } # print NodeI features if ($node->id) { $str .= "<name>"; $str .= $node->id; $str .= "</name>"; } if ($node->branch_length) { $str .= "<branch_length>"; $str .= $node->branch_length; $str .= "</branch_length>"; } if ($node->bootstrap) { $str .= "<confidence type = \"bootstrap\">"; $str .= $node->bootstrap; $str .= "</confidence>"; } $str .= "</clade>"; return $str; } =head2 _relation_to_string Title : _relation_to_string Usage : internal method used by write_tree, not to be used directly Function: internal function used by write_tree to translate Annotation::Relation objects into xml elements. Returns : string describing the node Args : Bio::Node::AnnotatableNode (or Bio::SeqI) object that contains the Annotation::Relation, the Annotation::Relation object, the string =cut # It may be more appropriate to make Annotation::Relation have # a to_string callback function, # and have this subroutine set as the callback when we are in # phyloXML context. # I've put it here for now, since write_tree is the only place it is used. sub _relation_to_string { my ($self, $obj, $rel, $str) = @_; my @attr = $obj->annotation->get_Annotations('_attr'); # check id_source if (@attr) { my @id_source = $attr[0]->get_Annotations('id_source'); } my ($id_ref_0) = $obj->annotation->get_nested_Annotations( '-keys' => ['id_source'], '-recursive' => 1); my ($id_ref_1) = $rel->to->annotation->get_nested_Annotations( '-keys' => ['id_source'], '-recursive' => 1); my $confidence = $rel->confidence(); my $confidence_type = $rel->confidence_type(); $str .= "<"; $str .= $rel->tagname; $str .= " id_ref_0=\"".$id_ref_0->value."\""; $str .= " id_ref_1=\"".$id_ref_1->value."\""; $str .= " type=\"".$rel->type."\""; if ($confidence) { $str .= " ><confidence"; if ($confidence_type) { $str .= " type=\"".$confidence_type."\""; } $str .= ">"; $str .= $confidence; $str .= "</confidence>"; $str .= "</"; $str .= $rel->tagname; $str .= ">"; } else { $str .= "/>"; } return $str; } =head2 read_annotation Title : read_annotation Usage : $treeio->read_annotation(-obj=>$node, -path=>$path, -attr=>1); Function: read text value (or attribute value) of the annotations corresponding to the element path Returns : list of text values of the annotations matching the path Args : -obj => object that contains the Annotation. (Bio::Tree::AnnotatableNode or Bio::SeqI) -path => path of the nested elements -attr => Boolean value to indicate whether to get the attribute of the element or the text value. (default is 0, meaning text value is returned) =cut # It may be more appropriate to make a separate Annotation::phyloXML object # and have this subroutine within that object so it can handle the # reading and writing of the values and attributes. # but since tagTree is a temporary stub and I didn't want to make # a redundant object I've put it here for now. sub read_annotation { my ($self, @args) = @_; my ($obj, $path, $attr) = $self->_rearrange([qw(OBJ PATH ATTR)], @args); my $ac = $obj->annotation; if ($attr) { my @elements = split ('/', $path); my $final = pop @elements; push (@elements, '_attr'); push (@elements, $final); $path = join ('/', @elements); return $self->_read_annotation_attr_Helper( [$ac], $path); } else { return $self->_read_annotation_text_Helper( [$ac], $path); } } sub _read_annotation_text_Helper { my ($self, $acs, $path) = @_; my @elements = split ('/', $path); my $key = shift @elements; my @nextacs = (); foreach my $ac (@$acs) { foreach my $ann ($ac->get_Annotations($key)) { if ($ann->isa('Bio::AnnotationCollectionI')) {push (@nextacs, $ann)} } } if (@elements == 0) { my @values = (); my @texts = map {$_->get_Annotations('_text')} @nextacs; foreach (@texts) { $_ && push (@values, $_->value); } return @values; } else { $path = join ('/', @elements); return $self->_read_annotation_text_Helper( \@nextacs, $path); } } sub _read_annotation_attr_Helper { my ($self, $acs, $path) = @_; my @elements = split ('/', $path); my $key = shift @elements; my @nextacs = (); foreach my $ac (@$acs) { foreach my $ann ($ac->get_Annotations($key)) { if ($ann->isa('Bio::AnnotationCollectionI')) {push (@nextacs, $ann)} } } if (@elements == 1) { my $attrname = $elements[0]; my @sv = map {$_->get_Annotations($attrname)} @nextacs; return map {$_->value} @sv; } else { $path = join ('/', @elements); return $self->_read_annotation_attr_Helper( \@nextacs, $path); } } =head1 Methods for parsing the XML document =cut =head2 processXMLNode Title : processXMLNode Usage : $treeio->processXMLNode Function: read the XML node and process according to the node type Returns : none Args : none =cut sub processXMLNode { my ($self) = @_; my $reader = $self->{'_reader'}; my $nodetype = $reader->nodeType; if ( $nodetype == XML_READER_TYPE_ELEMENT) { $self->{'_lastitem'}->{$reader->name}++; push @{$self->{'_lastitem'}->{'current'}}, { $reader->name=>{}}; # current holds current element and empty hash for its attributes if (exists $self->{'_start_elements'}->{$reader->name}) { my $method = $self->{'_start_elements'}->{$reader->name}; $self->$method(); } else { $self->element_default(); } if ($reader->isEmptyElement) { # element is complete # set nodetype so it can jump and # do procedures for XML_READER_TYPE_END_ELEMENT $nodetype = XML_READER_TYPE_END_ELEMENT; } } if ($nodetype == XML_READER_TYPE_TEXT) { $self->{'_currenttext'} = $reader->value; } if ($nodetype == XML_READER_TYPE_END_ELEMENT) { if (exists $self->{'_end_elements'}->{$reader->name}) { my $method = $self->{'_end_elements'}->{$reader->name}; $self->$method(); } else { $self->end_element_default(); } $self->{'_lastitem'}->{ $reader->name }--; pop @{$self->{'_lastitem'}->{'current'}}; $self->{'_currenttext'} = ''; } } =head2 processAttribute Title : processAttribute Usage : $treeio->processAttribute(\%hash_for_attribute); Function: reads the attributes of the current element into a hash Returns : none Args : hash reference where the attributes will be stored. =cut sub processAttribute { my ($self, $data) = @_; my $reader = $self->{'_reader'}; # several ways of reading attributes: # read all attributes: if ($reader-> moveToFirstAttribute) { do { $data->{$reader->name()} = $reader->value; } while ($reader-> moveToNextAttribute); $reader-> moveToElement; } } =head2 element_phylogeny Title : element_phylogeny Usage : $treeio->element_phylogeny Function: initialize the parsing of a tree Returns : none Args : none =cut sub element_phylogeny { my ($self) = @_; $self->{'_currentitems'} = []; # holds nodes while parsing current level $self->{'_currentnodes'} = []; # holds nodes while constructing tree $self->{'_currentannotation'} = []; # holds annotationcollection $self->{'_currenttext'} = ''; $self->{'_levelcnt'} = []; $self->{'_id_link'} = {}; $self->{'_tree_attr'} = $self->current_attr; $self->processAttribute($self->current_attr); return; } =head2 end_element_phylogeny Title : end_element_phylogeny Usage : $treeio->end_element_phylogeny Function: ends the parsing of a tree building a Tree::TreeI object. Returns : Tree::TreeI Args : none =cut sub end_element_phylogeny { my ($self) = @_; my $root; # if there is more than one node in _currentnodes # aggregate the nodes into trees basically ad-hoc. if ( @{$self->{'_currentnodes'}} > 1) { $root = $self->nodetype->new( -id => '', tostring => \&node_to_string, ); while ( @{$self->{'_currentnodes'}} ) { my ($node) = ( shift @{$self->{'_currentnodes'}}); $root->add_Descendent($node); } } # if there is only one node in _currentnodes # that node is root. elsif ( @{$self->{'_currentnodes'}} == 1) { $root = shift @{$self->{'_currentnodes'}}; } my $tree = $self->treetype->new( -root => $root, -id => $self->current_attr->{'name'}, %{$self->current_attr} ); foreach my $tag ( keys %{$self->current_attr} ) { $tree->add_tag_value( $tag, $self->current_attr->{$tag} ); } return $tree; } =head2 element_clade Title : element_clade Usage : $treeio->element_clade Function: initialize the parsing of a node creates a new AnnotatableNode with annotations Returns : none Args : none =cut sub element_clade { my ($self) = @_; my $reader = $self->{'_reader'}; my %clade_attr = (); # doesn't use current attribute in order to save memory $self->processAttribute(\%clade_attr); # create a node (Annotatable Node) my $tnode = $self->nodetype->new( -id => '', tostring => \&node_to_string, %clade_attr, ); # add all attributes as annotation collection with tag '_attr' my $ac = $tnode->annotation; my $newattr = Bio::Annotation::Collection->new(); foreach my $tag (keys %clade_attr) { my $sv = Bio::Annotation::SimpleValue->new( -value => $clade_attr{$tag} ); $newattr->add_Annotation($tag, $sv); } $ac->add_Annotation('_attr', $newattr); # if there is id_source add clade to _id_link if (exists $clade_attr{'id_source'}) { $self->{'_id_link'}->{$clade_attr{'id_source'}} = $tnode; } # push into temporary list push @{$self->{'_currentitems'}}, $tnode; } =head2 end_element_clade Title : end_element_clade Usage : $treeio->end_element_clade Function: ends the parsing of a node Returns : none Args : none =cut sub end_element_clade { my ($self) = @_; my $reader = $self->{'_reader'}; my $curcount = scalar @{$self->{'_currentnodes'}}; my $level = $reader->depth() - 2; my $childcnt = $self->{'_levelcnt'}->[$level+1] || 0; # pop from temporary list my $tnode = pop @{$self->{'_currentitems'}}; if ( $childcnt > 0) { if( $childcnt > $curcount) { $self->throw("something wrong with event construction treelevel ". "$level is recorded as having $childcnt nodes ". "but current nodes at this level is $curcount\n"); } my @childnodes = splice( @{$self->{'_currentnodes'}}, - $childcnt); for ( @childnodes ) { $tnode->add_Descendent($_); } $self->{'_levelcnt'}->[$level+1] = 0; } push @{$self->{'_currentnodes'}}, $tnode; $self->{'_levelcnt'}->[$level]++; } =head2 element_relation Title : element_relation Usage : $treeio->element_relation Function: starts the parsing of clade relation & sequence relation Returns : none Args : none =cut sub element_relation { my ($self) = @_; $self->processAttribute($self->current_attr); my $relationtype = $self->current_attr->{'type'}; my $id_ref_0 = $self->current_attr->{'id_ref_0'}; my $id_ref_1 = $self->current_attr->{'id_ref_1'}; my @srcbyidref = (); $srcbyidref[0] = $self->{'_id_link'}->{$id_ref_0}; $srcbyidref[1] = $self->{'_id_link'}->{$id_ref_1}; # exception when id_ref is defined but id_src is not, or vice versa. if ( ($id_ref_0 xor $srcbyidref[0])||($id_ref_1 xor $srcbyidref[1]) ) { $self->throw("id_ref and id_src incompatible: $id_ref_0, $id_ref_1, ", $srcbyidref[0], $srcbyidref[1]); } # set id_ref_0 my $ac0 = $srcbyidref[0]->annotation; my $newann = Bio::Annotation::Relation->new( '-type' => $relationtype, '-to' => $srcbyidref[1], '-tagname' => $self->current_element ); $ac0->add_Annotation($self->current_element, $newann); # set id_ref_1 my $ac1 = $srcbyidref[1]->annotation; $newann = Bio::Annotation::Relation->new( '-type' => $relationtype, '-to' => $srcbyidref[0], '-tagname' => $self->current_element ); $ac1->add_Annotation($self->current_element, $newann); push (@{$self->{'_currentannotation'}}, $newann); } =head2 end_element_relation Title : end_element_relation Usage : $treeio->end_element_relation Function: ends the parsing of clade relation & sequence relation Returns : none Args : none =cut sub end_element_relation { my ($self) = @_; my $ac = pop (@{$self->{'_currentannotation'}}); } =head2 element_default Title : element_default Usage : $treeio->element_default Function: starts the parsing of all other elements Returns : none Args : none =cut sub element_default { my ($self) = @_; my $reader = $self->{'_reader'}; my $current = $self->current_element(); my $prev = $self->prev_element(); # read attributes of element $self->processAttribute($self->current_attr); # check idref my $idref = ''; if (exists $self->current_attr->{'id_ref'}) { $idref = $self->current_attr->{'id_ref'}; } my $srcbyidref = ''; $srcbyidref = $self->{'_id_link'}->{$idref}; # exception when id_ref is defined but id_src is not, or vice versa. if ($idref xor $srcbyidref) { $self->throw("id_ref and id_src incompatible: $idref, $srcbyidref"); } # we are annotating a Node # set _currentannotation if ( ($srcbyidref && $srcbyidref->isa($self->nodetype)) || ((!$srcbyidref) && $prev eq 'clade') ) { # find node to annotate my $tnode; if ($srcbyidref) { $tnode = $srcbyidref; } else { $tnode = $self->{'_currentitems'}->[-1]; } my $ac = $tnode->annotation(); # add the new anncollection with the current element as key my $newann = Bio::Annotation::Collection->new(); $ac->add_Annotation($current, $newann); # push to current annotation push (@{$self->{'_currentannotation'}}, $newann); } # we are within sequence_relation or clade_relation elsif ($prev eq 'clade_relation' || $prev eq 'sequence_relation') { # do nothing? } # we are already within an annotation else { my $ac = $self->{'_currentannotation'}->[-1]; if ($ac) { # add the new anncollection with the current element as key my $newann = Bio::Annotation::Collection->new(); $ac->add_Annotation($current, $newann); push (@{$self->{'_currentannotation'}}, $newann); } } } =head2 end_element_default Title : end_element_default Usage : $treeio->end_element_default Function: ends the parsing of all other elements Returns : none Args : none =cut sub end_element_default { my ($self) = @_; my $reader = $self->{'_reader'}; my $current = $self->current_element(); my $prev = $self->prev_element(); # check idsrc my $idsrc = $self->current_attr->{'id_source'}; # check idref my $idref = ''; if (exists $self->current_attr->{'id_ref'}) { $idref = $self->current_attr->{'id_ref'}; delete $self->current_attr->{'id_ref'}; } my $srcbyidref = ''; $srcbyidref = $self->{'_id_link'}->{$idref}; # exception when id_ref is defined but id_src is not, or vice versa. if ($idref xor $srcbyidref) { $self->throw("id_ref and id_src incompatible: $idref, $srcbyidref"); } # we are annotating a Tree if ((!$srcbyidref) && $prev eq 'phylogeny') { # annotate Tree via tree attribute $self->prev_attr->{$current} = $self->{'_currenttext'}; } # we are within sequence_relation or clade_relation elsif ($prev eq 'clade_relation' || $prev eq 'sequence_relation') { my $ann_relation = $self->{'_currentannotation'}->[-1]; # we are here only with <confidence> if ($current eq 'confidence') { if (exists $self->current_attr->{'type'}) { $ann_relation->confidence_type($self->current_attr->{'type'}); } $ann_relation->confidence($self->{'_currenttext'}); } else { $self->throw($current, " is not allowed within <*_relation>"); } } # we are annotating a Node elsif (( $srcbyidref && $srcbyidref->isa($self->nodetype)) || ((!$srcbyidref) && $prev eq 'clade')) { # pop from current annotation my $ac = pop (@{$self->{'_currentannotation'}}); $self->annotateNode( $current, $ac); # additional setups for compatibility with NodeI my $tnode; if ($srcbyidref) { $tnode = $srcbyidref; } else { $tnode = $self->{'_currentitems'}->[-1]; } if ($current eq 'name') { $tnode->id($self->{'_currenttext'}); } elsif ($current eq 'branch_length') { $tnode->branch_length($self->{'_currenttext'}); } elsif ($current eq 'confidence') { if ((exists $self->current_attr->{'type'}) && ($self->current_attr->{'type'} eq 'bootstrap')) { $tnode->bootstrap($self->{'_currenttext'}); # this needs to change (adds 'B' annotation) } } elsif ($current eq 'sequence') { # if annotation is <sequence> # transform the Bio::Annotation object into a Bio::Seq object my $str = ''; # retrieve the sequence if (my ($molseq) = $ac->get_Annotations('mol_seq')) { my ($strac) = $molseq->get_Annotations('_text'); $str = $strac->value(); } # create Seq object with sequence my $newseq = Bio::Seq->new( -seq => $str, -annotation=>$ac, -nowarnonempty=>1); $tnode->sequence($newseq); $ac->remove_Annotations('mol_seq'); $tnode->annotation->remove_Annotations($current); # if there is id_source add sequence to _id_link if ($idsrc) { $self->{'_id_link'}->{$idsrc} = $newseq; } } elsif ($idsrc && $current eq 'taxonomy') { # if there is id_source add sequence to _id_link $self->{'_id_link'}->{$idsrc} = $ac; } } # we are within a default Annotation else { my $ac = pop (@{$self->{'_currentannotation'}}); if ($ac) { $self->annotateNode( $current, $ac); } } } =head2 annotateNode Title : annotateNode Usage : $treeio->annotateNode($element, $ac) Function: adds text value and attributes to the AnnotationCollection that has element name as key. If there are nested elements, optional AnnotationCollections are added recursively, with the nested element name as key. The structure of each AnnotationCollection is 'element' => AnnotationCollection { '_text' => SimpleValue (text value) '_attr' => AnnotationCollection { attribute1 => SimpleValue (attribute value 1) attribute2 => SimpleValue (attribute value 2) ... } ['nested element' => AnnotationCollection ] } Returns : none Args : none =cut sub annotateNode { my ($self, $element, $newac) = @_; # if attribute exists then add Annotation::Collection with tag '_attr' if ( scalar keys %{$self->current_attr} ) { my $newattr = Bio::Annotation::Collection->new(); foreach my $tag (keys %{$self->current_attr}) { my $sv = Bio::Annotation::SimpleValue->new( -value => $self->current_attr->{$tag} ); $newattr->add_Annotation($tag, $sv); } $newac->add_Annotation('_attr', $newattr); } # if text exists add text as SimpleValue with tag '_text' if ( $self->{'_currenttext'} ) { my $newvalue = Bio::Annotation::SimpleValue->new( -value => $self->{'_currenttext'} ); $newac->add_Annotation('_text', $newvalue); } } =head1 Methods for exploring the document =cut =head2 current_attr Title : current_attr Usage : $attr_hash = $treeio->current_attr; Function: returns the attribute hash for current item Returns : reference of the attribute hash Args : none =cut sub current_attr { my ($self) = @_; return 0 if ! defined $self->{'_lastitem'} || ! defined $self->{'_lastitem'}->{'current'}->[-1]; my @keys = keys %{$self->{'_lastitem'}->{'current'}->[-1]}; (@keys == 1) || die "there should be only one key for each hash"; return $self->{'_lastitem'}->{'current'}->[-1]->{$keys[0]}; } =head2 prev_attr Title : prev_attr Usage : $hash_ref = $treeio->prev_attr Function: returns the attribute hash for previous item Returns : reference of the attribute hash Args : none =cut sub prev_attr { my ($self) = @_; return 0 if ! defined $self->{'_lastitem'} || ! defined $self->{'_lastitem'}->{'current'}->[-2]; my @keys = keys %{$self->{'_lastitem'}->{'current'}->[-2]}; (@keys == 1) || die "there should be only one key for each hash"; return $self->{'_lastitem'}->{'current'}->[-2]->{$keys[0]}; } =head2 current_element Title : current_element Usage : $element = $treeio->current_element Function: returns the name of the current element Returns : string (element name) Args : none =cut sub current_element { my ($self) = @_; return 0 if ! defined $self->{'_lastitem'} || ! defined $self->{'_lastitem'}->{'current'}->[-1]; my @keys = keys %{$self->{'_lastitem'}->{'current'}->[-1]}; (@keys == 1) || die "there should be only one key for each hash"; return $keys[0]; } =head2 prev_element Title : prev_element Usage : $element = $treeio->current_element Function: returns the name of the previous element Returns : string (element name) Args : none =cut sub prev_element { my ($self) = @_; return 0 if ! defined $self->{'_lastitem'} || ! defined $self->{'_lastitem'}->{'current'}->[-2]; my @keys = keys %{$self->{'_lastitem'}->{'current'}->[-2]}; (@keys == 1) || die "there should be only one key for each hash"; return $keys[0]; } =head2 treetype Title : treetype Usage : $obj->treetype($newval) Function: returns the tree type (default is Bio::Tree::Tree) Returns : value of treetype Args : newvalue (optional) =cut sub treetype{ my ($self,$value) = @_; if( defined $value) { $self->{'treetype'} = $value; } return $self->{'treetype'}; } =head2 nodetype Title : nodetype Usage : $obj->nodetype($newval) Function: returns the node type (default is Bio::Node::AnnotatableNode) Returns : value of nodetype Args : newvalue (optional) =cut sub nodetype{ my ($self,$value) = @_; if( defined $value) { $self->{'nodetype'} = $value; } return $self->{'nodetype'}; } =head1 Methods for implementing to_string callback for AnnotatableNode =cut =head2 node_to_string Title : node_to_string Usage : $annotatablenode->to_string_callback(\&node_to_string) Function: set as callback in AnnotatableNode, prints the node information in string Returns : string of node information Args : none =cut # this function is similar to _write_tree_Helper_annotatableNode, # but it is not recursive sub node_to_string { my ($self) = @_; # this self is a Bio::Tree::AnnotatableNode # not a Bio::TreeIO::phyloxml my $str = ''; my $ac = $self->annotation; # start <clade> $str .= '<clade'; my @attr = $ac->get_Annotations('_attr'); # check id_source if (@attr) { my @id_source = $attr[0]->get_Annotations('id_source'); if (@id_source) { $str .= " id_source=\"".$id_source[0]->value."\""; } } $str .= '>'; # print all annotations $str = print_annotation( $self, $str, $ac ); # print all sequences if ($self->has_sequence) { foreach my $seq (@{$self->sequence}) { $str = print_seq_annotation( $self, $str, $seq ); } } $str .= '</clade>'; return $str; } =head2 print_annotation Title : print_annotation Usage : $str = $annotatablenode->print_annotation($str, $annotationcollection) Function: prints the annotationCollection in a phyloXML format. Returns : string of annotation information Args : string to which the Annotation should be concatenated to, annotationCollection that holds the Annotations =cut # Again, it may be more appropriate to make a separate Annotation::phyloXML object # and have this subroutine within that object so it can handle the # reading and writing of the values and attributes. # especially since this function is used both by # Bio::TreeIO::phyloxml (through write_tree) and # Bio::Node::AnnotatableNode (through node_to_string). # but since tagTree is a temporary stub and I didn't want to make # a redundant object I've put it here for now. sub print_annotation { my ($self, $str, $ac) = @_; my @all_anns = $ac->get_Annotations(); foreach my $ann (@all_anns) { my $key = $ann->tagname; if ($key eq '_attr') { next; } # attributes are already printed in the previous level if ($ann->isa('Bio::Annotation::SimpleValue')) { if ($key eq '_text') { $str .= $ann->value; } else { $str .= "<$key>"; $str .= $ann->value; $str .= "</$key>"; } } elsif ($ann->isa('Bio::Annotation::Collection')) { my @attrs = $ann->get_Annotations('_attr'); if (@attrs) { # if there is a attribute collection $str .= "<$key"; $str = print_attr($self, $str, $attrs[0]); $str .= ">"; } else { $str .= "<$key>"; } $str = print_annotation($self, $str, $ann); $str .= "</$key>"; } } return $str; } =head2 print_attr Title : print_attr Usage : $str = $annotatablenode->print_attr($str, $annotationcollection) Function: prints the annotationCollection in a phyloXML format. Returns : string of attributes Args : string to which the Annotation should be concatenated to, AnnotationCollection that holds the attributes =cut # Again, it may be more appropriate to make a separate Annotation::phyloXML object # and have this subroutine within that object so it can handle the # reading and writing of the values and attributes. # especially since this function is used both by # Bio::TreeIO::phyloxml and Bio::Node::AnnotatableNode # (through print_annotation). # but since tagTree is a temporary stub and I didn't want to make # a redundant object I've put it here for now. sub print_attr { my ($self, $str, $ac) = @_; my @all_attrs = $ac->get_Annotations(); foreach my $attr (@all_attrs) { if (!$attr->isa('Bio::Annotation::SimpleValue')) { $self->throw("attribute should be a SimpleValue"); } $str .= ' '; $str .= $attr->tagname; $str .= '='; $str .= '"'.$attr->value.'"'; } return $str; } =head2 print_sequence_annotation Title : print_sequence_annotation Usage : $str = $node->print_seq_annotation( $str, $seq ); Function: prints the Bio::Seq object associated with the node in a phyloXML format. Returns : string that describes the sequence Args : string to which the Annotation should be concatenated to, Seq object to print in phyloXML =cut # Again, it may be more appropriate to make a separate Annotation::phyloXML object # and have this subroutine within that object so it can handle the # reading and writing of the values and attributes. # especially since this function is used both by # Bio::TreeIO::phyloxml (through write_tree) and # Bio::Node::AnnotatableNode (through node_to_string). # but since tagTree is a temporary stub and I didn't want to make # a redundant object I've put it here for now. sub print_seq_annotation { my ($self, $str, $seq) = @_; $str .= "<sequence"; my ($attr) = $seq->annotation->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."\""; } } $str .= ">"; my @all_anns = $seq->annotation->get_Annotations(); foreach my $ann (@all_anns) { my $key = $ann->tagname; if ($key eq '_attr') { next; } # attributes are already printed in the previous level if ($ann->isa('Bio::Annotation::SimpleValue')) { if ($key eq '_text') { $str .= $ann->value; } else { $str .= "<$key>"; $str .= $ann->value; $str .= "</$key>"; } } elsif ($ann->isa('Bio::Annotation::Collection')) { my @attrs = $ann->get_Annotations('_attr'); if (@attrs) { # if there is a attribute collection $str .= "<$key"; $str = print_attr($self, $str, $attrs[0]); $str .= ">"; } else { $str .= "<$key>"; } $str = print_annotation($self, $str, $ann); $str .= "</$key>"; } } # print mol_seq if ($seq->seq()) { $str .= "<mol_seq>"; $str .= $seq->seq(); $str .= "</mol_seq>"; } $str .= "</sequence>"; return $str; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/svggraph.pm��������������������������������������������������������������000444��000765��000024�� 12675�12254227334� 17512� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::svg-graph # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Allen Day <allenday@ucla.edu> # # Copyright Brian O'Connor # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::svggraph - A simple output format that converts a Tree object to an SVG output =head1 SYNOPSIS use Bio::TreeIO; my $in = Bio::TreeIO->new(-file => 'input', -format => 'newick'); my $out = Bio::TreeIO->new(-file => '>output', -format => 'svggraph'); while( my $tree = $in->next_tree ) { my $svg_xml = $out->write_tree($tree); } =head1 DESCRIPTION This outputs a tree as an SVG graphic using the SVG::Graph API =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Brian OConnor Email brian.oconnor-at-excite.com =head1 CONTRIBUTORS Allen Day Guillaume Rousse, Guillaume-dot-Rousse-at-inria-dot-fr =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::svggraph; use strict; # Object preamble - inherits from Bio::Root::Root use SVG::Graph; use SVG::Graph::Data; use SVG::Graph::Data::Tree; use SVG::Graph::Data::Node; use Bio::Tree::TreeI; use Bio::Tree::Node; use Tree::DAG_Node; use base qw(Bio::TreeIO); =head2 new Title : new Usage : my $obj = Bio::TreeIO::svggraph->new(); Function: Builds a new Bio::TreeIO::svggraph object Returns : Bio::TreeIO::svggraph Args :-width => image width (default 1600) -height => image height (default 1000) -margin => margin (default 30) -stroke => stroke color (default 'black') -stroke_width=> stroke width (default 2) -font_size=> font size (default '10px') -nomalize => undef or 'log' (default is undef) =cut sub _initialize { my $self = shift; my ($width,$height,$margin,$stroke, $stroke_width,$font_size, $normalize) = $self->_rearrange([qw (WIDTH HEIGHT MARGIN STROKE STROKE_WIDTH FONT_SIZE NORMALIZE)], @_); $self->{_width} = $width || 1600; $self->{_height} = $height || 1000; $self->{_margin} = defined $margin ? $margin : 30; $self->{_stroke} = $stroke || 'black'; $self->{_stroke_width} = $stroke_width || 2; $self->{_font_size} = $font_size || '10px'; $self->{_normalize} = $normalize || ''; $self->SUPER::_initialize(@_); } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Write a tree out to data stream in newick/phylip format Returns : none Args : Bio::Tree::TreeI object =cut sub write_tree{ my ($self,$tree) = @_; my $line = $self->_write_tree_Helper($tree->get_root_node); $self->_print($line. "\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return; } sub _write_tree_Helper { my ($self,$node) = @_; my $graph = SVG::Graph->new ('width' => $self->{'_width'}, 'height' => $self->{'_height'}, 'margin' => $self->{'_margin'}); my $group0 = $graph->add_frame; my $tree = SVG::Graph::Data::Tree->new; my $root = SVG::Graph::Data::Node->new; $root->name($node->id); $self->_decorateRoot($root, $node->each_Descendent()); $tree->root($root); $group0->add_data($tree); $group0->add_glyph('tree', 'stroke' =>$self->{'_stroke'}, 'stroke-width'=>$self->{'_stroke_width'}, 'font-size' =>$self->{'_font_size'}); return($graph->draw); } =head2 decorateRoot Title : _decorateRoot Usage : internal methods Function: Example : Returns : Args : =cut sub _decorateRoot { my ($self,$previousNode,@children) = @_; for my $child (@children) { my $currNode = SVG::Graph::Data::Node->new; # if no ID is set, the branch label is intentionally set blank (bug in SVG::Graph) my $id = $child->id || ''; $currNode->branch_label($id); my $length = $child->branch_length; if ($self->{_normalize} eq 'log') { $length = log($length + 1); } $currNode->branch_length($length); $previousNode->add_daughter($currNode); $self->_decorateRoot($currNode, $child->each_Descendent()); } } =head2 next_tree Title : next_tree Usage : Function: Sorry not possible with this format Returns : none Args : none =cut sub next_tree{ $_[0]->throw("Sorry the format 'svggraph' can only be used as an output format"); } 1; �������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/tabtree.pm���������������������������������������������������������������000444��000765��000024�� 7060�12254227317� 17270� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::tabtree # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::tabtree - A simple output format which displays a tree as an ASCII drawing =head1 SYNOPSIS use Bio::TreeIO; my $in = Bio::TreeIO->new(-file => 'input', -format => 'newick'); my $out = Bio::TreeIO->new(-file => '>output', -format => 'tabtree'); while( my $tree = $in->next_tree ) { $out->write_tree($tree); } =head1 DESCRIPTION This is a made up format just for outputting trees as an ASCII drawing. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason@bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::tabtree; use strict; # Object preamble - inherits from Bio::Root::Root use base qw(Bio::TreeIO); =head2 new Title : new Usage : my $obj = Bio::TreeIO::tabtree->new(); Function: Builds a new Bio::TreeIO::tabtree object Returns : Bio::TreeIO::tabtree Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); } =head2 write_tree Title : write_tree Usage : $treeio->write_tree($tree); Function: Write a tree out to data stream in newick/phylip format Returns : none Args : Bio::Tree::TreeI object =cut sub write_tree{ my ($self,$tree) = @_; my $line = _write_tree_Helper($tree->get_root_node,""); $self->_print($line. "\n"); $self->flush if $self->_flush_on_write && defined $self->_fh; return; } sub _write_tree_Helper { my ($node,$indent) = @_; return unless defined $node; my @d = $node->each_Descendent(); my $line = ""; my ($i,$lastchild) = (0,scalar @d - 1); for my $n ( @d ) { if( $n->is_Leaf ) { $line .= sprintf("%s| \n%s\\-%s\n", $indent,$indent,$n->id || ''); } else { $line .= sprintf("$indent| %s\n",( $n->id ? sprintf("(%s)",$n->id) : '')); } my $new_indent = $indent . (($i == $lastchild) ? "| " : " "); if( $n != $node ) { # avoid the unlikely case of cycles $line .= _write_tree_Helper($n,$new_indent); } } return $line; } =head2 next_tree Title : next_tree Usage : Function: Sorry not possible with this format Returns : none Args : none =cut sub next_tree{ $_[0]->throw("Sorry the format 'tabtree' can only be used as an output format at this time"); } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/TreeIO/TreeEventBuilder.pm������������������������������������������������������000444��000765��000024�� 20131�12254227330� 21057� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::TreeIO::TreeEventBuilder # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Jason Stajich <jason@bioperl.org> # # Copyright Jason Stajich # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::TreeIO::TreeEventBuilder - Build Bio::Tree::Tree's and Bio::Tree::Node's from Events =head1 SYNOPSIS # internal use only =head1 DESCRIPTION This object will take events and build a Bio::Tree::TreeI compliant object makde up of Bio::Tree::NodeI objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing list. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track of the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Jason Stajich Email jason-at-bioperl.org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::TreeIO::TreeEventBuilder; use strict; use Bio::Tree::Tree; use Bio::Tree::Node; use base qw(Bio::Root::Root Bio::Event::EventHandlerI); =head2 new Title : new Usage : my $obj = Bio::TreeIO::TreeEventBuilder->new(); Function: Builds a new Bio::TreeIO::TreeEventBuilder object Returns : Bio::TreeIO::TreeEventBuilder Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($treetype, $nodetype) = $self->_rearrange([qw(TREETYPE NODETYPE)], @args); $treetype ||= 'Bio::Tree::Tree'; $nodetype ||= 'Bio::Tree::Node'; eval { $self->_load_module($treetype); $self->_load_module($nodetype); }; if( $@ ) { $self->throw("Could not load module $treetype or $nodetype. \n$@\n") } $self->treetype($treetype); $self->nodetype($nodetype); $self->{'_treelevel'} = 0; return $self; } =head2 treetype Title : treetype Usage : $obj->treetype($newval) Function: Returns : value of treetype Args : newvalue (optional) =cut sub treetype{ my ($self,$value) = @_; if( defined $value) { $self->{'treetype'} = $value; } return $self->{'treetype'}; } =head2 nodetype Title : nodetype Usage : $obj->nodetype($newval) Function: Returns : value of nodetype Args : newvalue (optional) =cut sub nodetype{ my ($self,$value) = @_; if( defined $value) { $self->{'nodetype'} = $value; } return $self->{'nodetype'}; } =head2 SAX methods =cut =head2 start_document Title : start_document Usage : $handler->start_document Function: Begins a Tree event cycle Returns : none Args : none =cut sub start_document { my ($self) = @_; $self->{'_lastitem'} = {}; $self->{'_currentitems'} = []; $self->{'_currentnodes'} = []; return; } =head2 end_document Title : end_document Usage : my @trees = $parser->end_document Function: Finishes a Phylogeny cycle Returns : An array Bio::Tree::TreeI Args : none =cut sub end_document { my ($self,$label) = @_; my ($root) = @{$self->{'_currentnodes'}}; $self->debug("Root node is " . $root->to_string()."\n"); if( $self->verbose > 0 ) { foreach my $node ( $root->get_Descendents ) { $self->debug("node is ". $node->to_string(). "\n"); } } my $tree = $self->treetype->new(-verbose => $self->verbose, -root => $root); return $tree; } =head2 start_element Title : start_element Usage : Function: Example : Returns : Args : $data => hashref with key 'Name' =cut sub start_element{ my ($self,$data) =@_; $self->{'_lastitem'}->{$data->{'Name'}}++; $self->debug("starting element: $data->{Name}\n"); push @{$self->{'_lastitem'}->{'current'}},$data->{'Name'}; my %data; if( $data->{'Name'} eq 'node' ) { push @{$self->{'_currentitems'}}, \%data; $self->{'_treelevel'}++; } elsif ( $data->{Name} eq 'tree' ) { } } =head2 end_element Title : end_element Usage : Function: Returns : none Args : $data => hashref with key 'Name' =cut sub end_element{ my ($self,$data) = @_; $self->debug("end of element: $data->{Name}\n"); # this is the stack where we push/pop items from it my $curcount = scalar @{$self->{'_currentnodes'}}; my $level = $self->{'_treelevel'}; my $levelct = $self->{'_nodect'}->[$self->{'_treelevel'}+1] || 0; if( $data->{'Name'} eq 'node' ) { my $tnode; my $node = pop @{$self->{'_currentitems'}}; $tnode = $self->nodetype->new( -verbose => $self->verbose, %{$node}); $self->debug( "new node will be ".$tnode->to_string."\n"); if ( !$node->{'-leaf'} && $levelct > 0) { $self->debug(join(',', map { $_->to_string } @{$self->{'_currentnodes'}}). "\n"); $self->throw("something wrong with event construction treelevel ". "$level is recorded as having $levelct nodes ". "but current nodes at this level is $curcount\n") if( $levelct > $curcount); for ( splice( @{$self->{'_currentnodes'}}, - $levelct)) { $self->debug("adding desc: " . $_->to_string . "\n"); $tnode->add_Descendent($_); } $self->{'_nodect'}->[$self->{'_treelevel'}+1] = 0; } push @{$self->{'_currentnodes'}}, $tnode; $self->{'_nodect'}->[$self->{'_treelevel'}]++; $curcount = scalar @{$self->{'_currentnodes'}}; $self->debug ("added node: count is now $curcount, treelevel: $level, nodect: $levelct\n"); $self->{'_treelevel'}--; } elsif( $data->{'Name'} eq 'tree' ) { $self->debug("end of tree: nodes in stack is $curcount\n"); } $self->{'_lastitem'}->{ $data->{'Name'} }--; pop @{$self->{'_lastitem'}->{'current'}}; } =head2 in_element Title : in_element Usage : Function: Example : Returns : Args : =cut sub in_element{ my ($self,$e) = @_; return 0 if ! defined $self->{'_lastitem'} || ! defined $self->{'_lastitem'}->{'current'}->[-1]; return ($e eq $self->{'_lastitem'}->{'current'}->[-1]); } =head2 within_element Title : within_element Usage : Function: Example : Returns : Args : =cut sub within_element{ my ($self,$e) = @_; return $self->{'_lastitem'}->{$e}; } =head2 characters Title : characters Usage : $handler->characters($text); Function: Processes characters Returns : none Args : text string =cut sub characters{ my ($self,$ch) = @_; if( $self->within_element('node') ) { my $hash = pop @{$self->{'_currentitems'}}; if( $self->in_element('bootstrap') ) { # leading/trailing Whitespace-B-Gone $ch =~ s/^\s+//; $ch =~ s/\s+$//; $hash->{'-bootstrap'} = $ch; } elsif( $self->in_element('branch_length') ) { # leading/trailing Whitespace-B-Gone $ch =~ s/^\s+//; $ch =~ s/\s+$//; $hash->{'-branch_length'} = $ch; } elsif( $self->in_element('id') ) { $hash->{'-id'} = $ch; } elsif( $self->in_element('description') ) { $hash->{'-desc'} = $ch; } elsif ( $self->in_element('tag_name') ) { $hash->{'-NHXtagname'} = $ch; } elsif ( $self->in_element('tag_value') ) { $hash->{'-nhx'}->{$hash->{'-NHXtagname'}} = $ch; delete $hash->{'-NHXtagname'}; } elsif( $self->in_element('leaf') ) { $hash->{'-leaf'} = $ch; } push @{$self->{'_currentitems'}}, $hash; } $self->debug("chars: $ch\n"); } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation�����������������������������������������������������������������������000755��000765��000024�� 0�12254227337� 15753� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/AAChange.pm�����������������������������������������������������������000444��000765��000024�� 33030�12254227337� 20054� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::AAChange # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Variation::AAChange - Sequence change class for polypeptides =head1 SYNOPSIS $aamut = Bio::Variation::AAChange->new ('-start' => $start, '-end' => $end, '-length' => $len, '-proof' => $proof, '-isMutation' => 1, '-mut_number' => $mut_number ); my $a1 = Bio::Variation::Allele->new; $a1->seq($ori) if $ori; $aamut->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq($mut) if $mut; $aachange->add_Allele($a2); $aachange->allele_mut($a2); print "\n"; # add it to a SeqDiff container object $seqdiff->add_Variant($rnachange); # and create links to and from RNA level variant objects $aamut->RNAChange($rnachange); $rnachange->AAChange($rnachange); =head1 DESCRIPTION The instantiable class Bio::Variation::RNAChange describes basic sequence changes at polypeptide level. It uses methods defined in superclass Bio::Variation::VariantI, see L<Bio::Variation::VariantI> for details. If the variation described by a AAChange object has a known Bio::Variation::RNAAChange object, create the link with method AAChange(). See L<Bio::Variation::AAChange> for more information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::AAChange; use vars qw($MATRIX); use strict; # Object preamble - inheritance use base qw(Bio::Variation::VariantI); BEGIN { my $matrix = << "__MATRIX__"; # Matrix made by matblas from blosum62.iij # * column uses minimum score # BLOSUM Clustered Scoring Matrix in 1/2 Bit Units # Blocks Database = /data/blocks_5.0/blocks.dat # Cluster Percentage: >= 62 # Entropy = 0.6979, Expected = -0.5209 A R N D C Q E G H I L K M F P S T W Y V B Z X * A 4 -1 -2 -2 0 -1 -1 0 -2 -1 -1 -1 -1 -2 -1 1 0 -3 -2 0 -2 -1 0 -4 R -1 5 0 -2 -3 1 0 -2 0 -3 -2 2 -1 -3 -2 -1 -1 -3 -2 -3 -1 0 -1 -4 N -2 0 6 1 -3 0 0 0 1 -3 -3 0 -2 -3 -2 1 0 -4 -2 -3 3 0 -1 -4 D -2 -2 1 6 -3 0 2 -1 -1 -3 -4 -1 -3 -3 -1 0 -1 -4 -3 -3 4 1 -1 -4 C 0 -3 -3 -3 9 -3 -4 -3 -3 -1 -1 -3 -1 -2 -3 -1 -1 -2 -2 -1 -3 -3 -2 -4 Q -1 1 0 0 -3 5 2 -2 0 -3 -2 1 0 -3 -1 0 -1 -2 -1 -2 0 3 -1 -4 E -1 0 0 2 -4 2 5 -2 0 -3 -3 1 -2 -3 -1 0 -1 -3 -2 -2 1 4 -1 -4 G 0 -2 0 -1 -3 -2 -2 6 -2 -4 -4 -2 -3 -3 -2 0 -2 -2 -3 -3 -1 -2 -1 -4 H -2 0 1 -1 -3 0 0 -2 8 -3 -3 -1 -2 -1 -2 -1 -2 -2 2 -3 0 0 -1 -4 I -1 -3 -3 -3 -1 -3 -3 -4 -3 4 2 -3 1 0 -3 -2 -1 -3 -1 3 -3 -3 -1 -4 L -1 -2 -3 -4 -1 -2 -3 -4 -3 2 4 -2 2 0 -3 -2 -1 -2 -1 1 -4 -3 -1 -4 K -1 2 0 -1 -3 1 1 -2 -1 -3 -2 5 -1 -3 -1 0 -1 -3 -2 -2 0 1 -1 -4 M -1 -1 -2 -3 -1 0 -2 -3 -2 1 2 -1 5 0 -2 -1 -1 -1 -1 1 -3 -1 -1 -4 F -2 -3 -3 -3 -2 -3 -3 -3 -1 0 0 -3 0 6 -4 -2 -2 1 3 -1 -3 -3 -1 -4 P -1 -2 -2 -1 -3 -1 -1 -2 -2 -3 -3 -1 -2 -4 7 -1 -1 -4 -3 -2 -2 -1 -2 -4 S 1 -1 1 0 -1 0 0 0 -1 -2 -2 0 -1 -2 -1 4 1 -3 -2 -2 0 0 0 -4 T 0 -1 0 -1 -1 -1 -1 -2 -2 -1 -1 -1 -1 -2 -1 1 5 -2 -2 0 -1 -1 0 -4 W -3 -3 -4 -4 -2 -2 -3 -2 -2 -3 -2 -3 -1 1 -4 -3 -2 11 2 -3 -4 -3 -2 -4 Y -2 -2 -2 -3 -2 -1 -2 -3 2 -1 -1 -2 -1 3 -3 -2 -2 2 7 -1 -3 -2 -1 -4 V 0 -3 -3 -3 -1 -2 -2 -3 -3 3 1 -2 1 -1 -2 -2 0 -3 -1 4 -3 -2 -1 -4 B -2 -1 3 4 -3 0 1 -1 0 -3 -4 0 -3 -3 -2 0 -1 -4 -3 -3 4 1 -1 -4 Z -1 0 0 1 -3 3 4 -2 0 -3 -3 1 -1 -3 -1 0 -1 -3 -2 -2 1 4 -1 -4 X 0 -1 -1 -1 -2 -1 -1 -1 -1 -1 -1 -1 -1 -1 -2 0 0 -2 -1 -1 -1 -1 -1 -4 * -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 1 __MATRIX__ my %blosum = (); $matrix =~ /^ +(.+)$/m; my @aas = split / +/, $1; foreach my $aa (@aas) { my $tmp = $aa; $tmp = "\\$aa" if $aa eq '*'; $matrix =~ /^($tmp) +([-+]?\d.*)$/m; my @scores = split / +/, $2 if defined $2; my $count = 0; foreach my $ak (@aas) { $blosum{$aa}->{$aas[$count]} = $scores[$count]; $count++; } } sub _matrix; $MATRIX = \%blosum; } sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($start, $end, $length, $strand, $primary, $source, $frame, $score, $gff_string, $allele_ori, $allele_mut, $upstreamseq, $dnstreamseq, $label, $status, $proof, $re_changes, $region, $region_value, $region_dist, $numbering, $mut_number, $ismutation) = $self->_rearrange([qw(START END LENGTH STRAND PRIMARY SOURCE FRAME SCORE GFF_STRING ALLELE_ORI ALLELE_MUT UPSTREAMSEQ DNSTREAMSEQ LABEL STATUS PROOF RE_CHANGES REGION REGION_VALUE REGION_DIST NUMBERING MUT_NUMBER ISMUTATION )],@args); $self->primary_tag("Variation"); $self->{ 'alleles' } = []; $start && $self->start($start); $end && $self->end($end); $length && $self->length($length); $strand && $self->strand($strand); $primary && $self->primary_tag($primary); $source && $self->source_tag($source); $frame && $self->frame($frame); $score && $self->score($score); $gff_string && $self->_from_gff_string($gff_string); $allele_ori && $self->allele_ori($allele_ori); $allele_mut && $self->allele_mut($allele_mut); $upstreamseq && $self->upstreamseq($upstreamseq); $dnstreamseq && $self->dnstreamseq($dnstreamseq); $label && $self->label($label); $status && $self->status($status); $proof && $self->proof($proof); $region && $self->region($region); $region_value && $self->region_value($region_value); $region_dist && $self->region_dist($region_dist); $numbering && $self->numbering($numbering); $mut_number && $self->mut_number($mut_number); $ismutation && $self->isMutation($ismutation); return $self; # success - we hope! } =head2 RNAChange Title : RNAChange Usage : $mutobj = $self->RNAChange; : $mutobj = $self->RNAChange($objref); Function: Returns or sets the link-reference to a mutation/change object. If there is no link, it will return undef Returns : an obj_ref or undef =cut sub RNAChange { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::RNAChange') ) { $self->throw("Is not a Bio::Variation::RNAChange object but a [$self]"); return; } else { $self->{'RNAChange'} = $value; } } unless (exists $self->{'RNAChange'}) { return; } else { return $self->{'RNAChange'}; } } =head2 label Title : label Usage : $obj->label(); Function: Sets and returns mutation event label(s). If value is not set, or no argument is given returns false. Each instantiable subclass of L<Bio::Variation::VariantI> needs to implement this method. Valid values are listed in 'Mutation event controlled vocabulary' in http://www.ebi.ac.uk/mutations/recommendations/mutevent.html. Example : Returns : string Args : string =cut sub label { my ($self) = @_; my ($o, $m, $type); $o = $self->allele_ori->seq if $self->allele_ori and $self->allele_ori->seq; $m = $self->allele_mut->seq if $self->allele_mut and $self->allele_mut->seq; if ($self->start == 1 ) { if ($o and substr($o, 0, 1) ne substr($m, 0, 1)) { $type = 'no translation'; } elsif ($o and $m and $o eq $m ) { $type = 'silent'; } # more ... } elsif ($o and substr($o, 0, 1) eq '*' ) { if ($m and substr($o, 0, 1) ne substr($m, 0, 1)) { $type = 'post-elongation'; } elsif ($m and $o eq $m ) { $type = 'silent, conservative'; } } elsif ($o and $m and $o eq $m) { $type = 'silent, conservative'; } elsif ($m and $m eq '*') { $type = 'truncation'; } elsif ($o and $m and $o eq $m) { $type = 'silent, conservative'; } elsif (not $m or ($o and $m and length($o) > length($m) and substr($m, -1, 1) ne '*')) { $type = 'deletion'; if ($o and $m and $o !~ $m and $o !~ $m) { $type .= ', complex'; } } elsif (not $o or ($o and $m and length($o) < length($m) and substr($m, -1, 1) ne '*' ) ) { $type = 'insertion'; if ($o and $m and $o !~ $m and $o !~ $m) { $type .= ', complex'; } } elsif ($o and $m and $o ne $m and length $o == 1 and length $m == 1 ) { $type = 'substitution'; my $value = $self->similarity_score; if (defined $value) { my $cons = ($value < 0) ? 'nonconservative' : 'conservative'; $type .= ", ". $cons; } } else { $type = 'out-of-frame translation, truncation'; } $self->{'label'} = $type; return $self->{'label'}; } =head2 similarity_score Title : similarity_score Usage : $self->similarity_score Function: Measure for evolutionary conservativeness of single amino substitutions. Uses BLOSUM62. Negative numbers are noncoservative changes. Returns : integer, undef if not single amino acid change =cut sub similarity_score { my ($self) = @_; my ($o, $m, $type); $o = $self->allele_ori->seq if $self->allele_ori and $self->allele_ori->seq; $m = $self->allele_mut->seq if $self->allele_mut and $self->allele_mut->seq; return unless $o and $m and length $o == 1 and length $m == 1; return unless $o =~ /[ARNDCQEGHILKMFPSTWYVBZX*]/i and $m =~ /[ARNDCQEGHILKMFPSTWYVBZX*]/i; return $MATRIX->{"\U$o"}->{"\U$m"}; } =head2 trivname Title : trivname Usage : $self->trivname Function: Given a Bio::Variation::AAChange object with linked Bio::Variation::RNAChange and Bio::Variation::DNAMutation objects, this subroutine creates a string corresponding to the 'trivial name' of the mutation. Trivial name is specified in Antonorakis & MDI Nomenclature Working Group: Human Mutation 11:1-3, 1998. Returns : string =cut sub trivname { my ($self,$value) = @_; if( defined $value) { $self->{'trivname'} = $value; } else { my ( $aaori, $aamut,$aamutsymbol, $aatermnumber, $aamutterm) = ('', '', '', '', ''); my $o = $self->allele_ori->seq if $self->allele_ori and $self->allele_ori->seq; #my $m = $self->allele_mut->seq if $self->allele_mut and $self->allele_mut->seq; $aaori = substr ($o, 0, 1) if $o; $aaori =~ tr/\*/X/; my $sep; if ($self->isMutation) { $sep = '>'; } else { $sep = '|'; } my $trivname = $aaori. $self->start; $trivname .= $sep if $sep eq '|'; my @alleles = $self->each_Allele; foreach my $allele (@alleles) { my $m = $allele->seq if $allele->seq; $self->allele_mut($allele); #$trivname .= $sep. uc $m if $m; $aamutterm = substr ($m, -1, 1) if $m; if ($self->RNAChange->label =~ /initiation codon/ and ( $o and $m and $o ne $m)) { $aamut = 'X'; } elsif (CORE::length($o) == 1 and CORE::length($m) == 1 ) { $aamutsymbol = ''; $aamut = $aamutterm; } elsif ($self->RNAChange->label =~ /deletion/) { $aamutsymbol = 'del'; if ($aamutterm eq '*') { $aatermnumber = $self->start + length($m) -1; $aamut = 'X'. $aatermnumber; } if ($self->RNAChange && $self->RNAChange->label =~ /inframe/){ $aamut = '-'. length($self->RNAChange->allele_ori->seq)/3 ; } } elsif ($self->RNAChange->label =~ /insertion/) { $aamutsymbol = 'ins'; if (($aamutterm eq '*') && (length($m)-1 != 0)) { $aatermnumber = $self->start + length($m)-1; $aamut = $aatermnumber. 'X'; } if ($self->RNAChange->label =~ /inframe/){ $aamut = '+'. int length($self->RNAChange->allele_mut->seq)/3 ; } } elsif ($self->RNAChange->label =~ /complex/ ) { my $diff = length($m) - length($o); if ($diff >= 0 ) { $aamutsymbol = 'ins'; } else { $aamutsymbol = 'del' ; } if (($aamutterm eq '*') && (length($m)-1 != 0)) { $aatermnumber = $self->start + length($m)-1; $aamut = $aatermnumber. 'X'; } if ($self->RNAChange->label =~ /inframe/){ if ($diff >= 0 ) { $aamut = '+'. $diff ; } else { $aamut = $diff ; } } } elsif ($self->label =~ /truncation/) { $aamut = $m; } else { $aamutsymbol = ''; $aamut = $aamutterm; } $aamut =~ tr/\*/X/; $trivname .= $aamutsymbol. $aamut. $sep; } chop $trivname; $self->{'trivname'} = $trivname; } return $self->{'trivname'}; } 1; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/AAReverseMutate.pm����������������������������������������������������000444��000765��000024�� 16450�12254227322� 21463� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::AAReverseMutate # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Variation::AAReverseMutate - point mutation and codon information from single amino acid changes =head1 SYNOPSIS $aamut = Bio::Variation::AAReverseMutate->new (-aa_ori => 'F', -aa_mut => 'S', -codon_ori => 'ttc', # optional -codon_table => '3' # defaults to 1 ); @points = $aamut->each_Variant; if (scalar @points > 0 ) { foreach $rnachange ( @points ) { # $rnachange is a Bio::Variation::RNAChange object print " ", $rnachange->allele_ori->seq, ">", $rnachange->allele_mut->seq, " in ", $rnachange->codon_ori, ">", $rnachange->codon_mut, " at position ", $rnachange->codon_pos, "\n"; } } else { print "No point mutations possible\n", } =head1 DESCRIPTION Bio::Variation::AAReverseMutate objects take in reference and mutated amino acid information and deduces potential point mutations at RNA level leading to this change. The choice can be further limited by letting the object know what is the the codon in the reference sequence. The results are returned as L<Bio::Variation::RNAChange> objects. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::AAReverseMutate; use strict; # Object preamble - inheritance use Bio::Tools::CodonTable; use Bio::Variation::RNAChange; use Bio::Variation::Allele; use base qw(Bio::Root::Root); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($aa_ori, $aa_mut, $codon_ori, $codon_table) = $self->_rearrange([qw(AA_ORI AA_MUT CODON CODON_TABLE )],@args); $aa_ori && $self->aa_ori($aa_ori); $aa_mut && $self->aa_mut($aa_mut); $codon_ori && $self->codon_ori($codon_ori); $codon_table && $self->codon_table($codon_table); return $self; # success - we hope! } =head2 aa_ori Title : aa_ori Usage : $obj->aa_ori(); Function: Sets and returns original aa sequence. If value is not set, returns false. Amino acid sequences are stored in upper case characters, others in lower case. Example : Returns : string Args : single character amino acid code =cut sub aa_ori { my ($self,$value) = @_; if( defined $value) { if ( uc($value) !~ /^[ARNDCQEGHILKMFPSTWYVBZX*]$/ ) { $self->throw("'$value' is not a valid one letter amino acid symbol\n"); } else { $self->{'aa_ori'} = uc $value; } } return $self->{'aa_ori'}; } =head2 aa_mut Title : aa_mut Usage : $obj->aa_mut(); Function: Sets and returns the mutated allele sequence. If value is not set, returns false. Example : Returns : string Args : single character amino acid code =cut sub aa_mut { my ($self,$value) = @_; if( defined $value) { if ( uc($value) !~ /^[ARNDCQEGHILKMFPSTWYVBZX*]$/ ) { $self->throw("'$value' is not a valid one letter amino acid symbol\n"); } else { $self->{'aa_mut'} = uc $value; } } return $self->{'aa_mut'}; } =head2 codon_ori Title : codon_ori Usage : $obj->codon_ori(); Function: Sets and returns codon_ori triplet. If value is not set, returns false. The string has to be three characters long. The chracter content is not checked. Example : Returns : string Args : string =cut sub codon_ori { my ($self,$value) = @_; if( defined $value) { if (length $value != 3 or lc $value =~ /[^atgc]/) { $self->warn("Codon string \"$value\" is not valid unique codon"); } $self->{'codon_ori'} = lc $value; } return $self->{'codon_ori'}; } =head2 codon_table Title : codon_table Usage : $obj->codon_table(); Function: Sets and returns the codon table id of the RNA If value is not set, returns 1, 'universal' code, as the default. Example : Returns : integer Args : none if get, the new value if set =cut sub codon_table { my ($self,$value) = @_; if( defined $value) { if ( not $value =~ /^\d+$/ ) { $self->throw("'$value' is not a valid codon table ID\n". "Has to be a positive integer. Defaulting to 1\n"); } else { $self->{'codon_table'} = $value; } } if( ! exists $self->{'codon_table'} ) { return 1; } else { return $self->{'codon_table'}; } } =head2 each_Variant Title : each_Variant Usage : $obj->each_Variant(); Function: Returns a list of Variants. Example : Returns : list of Variants Args : none =cut sub each_Variant{ my ($self,@args) = @_; $self->throw("aa_ori is not defined\n") if not defined $self->aa_ori; $self->throw("aa_mut is not defined\n") if not defined $self->aa_mut; my (@points, $codon_pos, $allele_ori, $allele_mut); my $ct = Bio::Tools::CodonTable->new( '-id' => $self->codon_table ); foreach my $codon_ori ($ct->revtranslate($self->aa_ori)) { next if $self->codon_ori and $self->codon_ori ne $codon_ori; foreach my $codon_mut ($ct->revtranslate($self->aa_mut)) { my $k = 0; my $length = 0; $codon_pos = $allele_ori = $allele_mut = undef; while ($k<3) { my $nt_ori = substr ($codon_ori, $k, 1); my $nt_mut = substr ($codon_mut, $k, 1); if ($nt_ori ne $nt_mut) { $length++; $codon_pos = $k+1; $allele_ori = $nt_ori; $allele_mut = $nt_mut; } $k++; } if ($length == 1) { my $rna = Bio::Variation::RNAChange->new ('-length' => '1', '-codon_ori' => $codon_ori, '-codon_mut' => $codon_mut, '-codon_pos' => $codon_pos, '-isMutation' => 1 ); my $all_ori = Bio::Variation::Allele->new('-seq'=>$allele_ori); $rna->allele_ori($all_ori); my $all_mut = Bio::Variation::Allele->new('-seq'=>$allele_mut); $rna->allele_mut($all_mut); push @points, $rna; } } } return @points; } 1; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/Allele.pm�������������������������������������������������������������000444��000765��000024�� 14707�12254227330� 17666� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::Allele # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Variation::Allele - Sequence object with allele-specific attributes =head1 SYNOPSIS $allele1 = Bio::Variation::Allele->new ( -seq => 'A', -id => 'AC00001.1', -alphabet => 'dna', -is_reference => 1 ); =head1 DESCRIPTION List of alleles describe known sequence alternatives in a variable region. Alleles are contained in Bio::Variation::VariantI complying objects. See L<Bio::Variation::VariantI> for details. Bio::Varation::Alleles are PrimarySeqI complying objects which can contain database cross references as specified in Bio::DBLinkContainerI interface, too. A lot of the complexity with dealing with Allele objects are caused by null alleles; Allele objects that have zero length sequence string. In addition describing the allele by its sequence , it possible to give describe repeat structure within the sequence. This done using methods repeat_unit (e.g. 'ca') and repeat_count (e.g. 7). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::Allele; use strict; # Object preamble - inheritance use base qw(Bio::PrimarySeq Bio::DBLinkContainerI); sub new { my($class, @args) = @_; my $self = $class->SUPER::new(@args); my($is_reference, $repeat_unit, $repeat_count) = $self->_rearrange([qw(IS_REFERENCE REPEAT_UNIT REPEAT_COUNT )], @args); $is_reference && $self->is_reference($is_reference); $repeat_unit && $self->repeat_unit($repeat_unit); $repeat_count && $self->repeat_count($repeat_count); return $self; # success - we hope! } =head2 is_reference Title : is_reference Usage : $obj->is_reference() Function: sets and returns boolean values. Unset values return false. Example : $obj->is_reference() Returns : boolean Args : optional true of false value =cut sub is_reference { my ($self,$value) = @_; if( defined $value) { $value ? ($value = 1) : ($value = 0); $self->{'is_reference'} = $value; } if( ! exists $self->{'is_reference'} ) { return 0; } else { return $self->{'is_reference'}; } } =head2 add_DBLink Title : add_DBLink Usage : $self->add_DBLink($ref) Function: adds a link object Example : Returns : Args : =cut sub add_DBLink{ my ($self,$com) = @_; if( ! $com->isa('Bio::Annotation::DBLink') ) { $self->throw("Is not a link object but a [$com]"); } push(@{$self->{'link'}},$com); } =head2 each_DBLink Title : each_DBLink Usage : foreach $ref ( $self->each_DBlink() ) Function: gets an array of DBlink of objects Example : Returns : Args : =cut sub each_DBLink{ my ($self) = @_; return @{$self->{'link'}}; } =head2 repeat_unit Title : repeat_unit Usage : $obj->repeat_unit('ca'); Function: Sets and returns the sequence of the repeat_unit the allele is composed of. Example : Returns : string Args : string =cut sub repeat_unit { my ($self,$value) = @_; if( defined $value) { $self->{'repeat_unit'} = $value; } if ($self->{'seq'} && $self->{'repeat_unit'} && $self->{'repeat_count'} ) { $self->warn("Repeats do not add up!") if ( $self->{'repeat_unit'} x $self->{'repeat_count'}) ne $self->{'seq'}; } return $self->{'repeat_unit'}; } =head2 repeat_count Title : repeat_count Usage : $obj->repeat_count(); Function: Sets and returns the number of repeat units in the allele. Example : Returns : string Args : string =cut sub repeat_count { my ($self,$value) = @_; if( defined $value) { if ( not $value =~ /^\d+$/ ) { $self->throw("[$value] for repeat_count has to be a positive integer\n"); } else { $self->{'repeat_count'} = $value; } } if ($self->{'seq'} && $self->{'repeat_unit'} && $self->{'repeat_count'} ) { $self->warn("Repeats do not add up!") if ( $self->{'repeat_unit'} x $self->{'repeat_count'}) ne $self->{'seq'}; } return $self->{'repeat_count'}; } =head2 count Title : count Usage : $obj->count(); Function: Sets and returns the number of times this allele was observed. Example : Returns : string Args : string =cut sub count { my ($self,$value) = @_; if( defined $value) { if ( not $value =~ /^\d+$/ ) { $self->throw("[$value] for count has to be a positive integer\n"); } else { $self->{'count'} = $value; } } return $self->{'count'}; } =head2 frequency Title : frequency Usage : $obj->frequency(); Function: Sets and returns the frequency of the allele in the observed population. Example : Returns : string Args : string =cut sub frequency { my ($self,$value) = @_; if( defined $value) { if ( not $value =~ /^\d+$/ ) { $self->throw("[$value] for frequency has to be a positive integer\n"); } else { $self->{'frequency'} = $value; } } return $self->{'frequency'}; } 1; ���������������������������������������������������������BioPerl-1.6.923/Bio/Variation/DNAMutation.pm��������������������������������������������������������000444��000765��000024�� 23350�12254227314� 20607� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::DNAMutation # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Variation::DNAMutation - DNA level mutation class =head1 SYNOPSIS $dnamut = Bio::Variation::DNAMutation->new ('-start' => $start, '-end' => $end, '-length' => $len, '-upStreamSeq' => $upflank, '-dnStreamSeq' => $dnflank, '-proof' => $proof, '-isMutation' => 1, '-mut_number' => $mut_number ); $a1 = Bio::Variation::Allele->new; $a1->seq('a'); $dnamut->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq('t'); $dnamut->add_Allele($a2); print "Restriction changes are ", $dnamut->restriction_changes, "\n"; # add it to a SeqDiff container object $seqdiff->add_Variant($dnamut); =head1 DESCRIPTION The instantiable class Bio::Variation::DNAMutation describes basic sequence changes in genomic DNA level. It uses methods defined in superclass Bio::Variation::VariantI. See L<Bio::Variation::VariantI> for details. If the variation described by a DNAMutation object is transcibed, link the corresponding Bio::Variation::RNAChange object to it using method RNAChange(). See L<Bio::Variation::RNAChange> for more information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::DNAMutation; use strict; # Object preamble - inheritance use base qw(Bio::Variation::VariantI); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($start, $end, $length, $strand, $primary, $source, $frame, $score, $gff_string, $allele_ori, $allele_mut, $upstreamseq, $dnstreamseq, $label, $status, $proof, $region, $region_value, $region_dist, $numbering, $cpg, $mut_number, $ismutation) = $self->_rearrange([qw(START END LENGTH STRAND PRIMARY SOURCE FRAME SCORE GFF_STRING ALLELE_ORI ALLELE_MUT UPSTREAMSEQ DNSTREAMSEQ LABEL STATUS PROOF REGION REGION_VALUE REGION_DIST NUMBERING CPG MUT_NUMBER ISMUTATION )], @args); $self->primary_tag("Variation"); $self->{ 'alleles' } = []; $start && $self->start($start); $end && $self->end($end); $length && $self->length($length); $strand && $self->strand($strand); $primary && $self->primary_tag($primary); $source && $self->source_tag($source); $frame && $self->frame($frame); $score && $self->score($score); $gff_string && $self->_from_gff_string($gff_string); $allele_ori && $self->allele_ori($allele_ori); $allele_mut && $self->allele_mut($allele_mut); $upstreamseq && $self->upStreamSeq($upstreamseq); $dnstreamseq && $self->dnStreamSeq($dnstreamseq); $label && $self->label($label); $status && $self->status($status); $proof && $self->proof($proof); $region && $self->region($region); $region_value && $self->region_value($region_value); $region_dist && $self->region_dist($region_dist); $numbering && $self->numbering($numbering); $mut_number && $self->mut_number($mut_number); $ismutation && $self->isMutation($ismutation); $cpg && $self->CpG($cpg); return $self; # success - we hope! } =head2 CpG Title : CpG Usage : $obj->CpG() Function: sets and returns boolean values for variation hitting a CpG site. Unset value return -1. Example : $obj->CpG() Returns : boolean Args : optional true of false value =cut sub CpG { my ($obj,$value) = @_; if( defined $value) { $value ? ($value = 1) : ($value = 0); $obj->{'cpg'} = $value; } elsif (not defined $obj->{'label'}) { $obj->{'cpg'} = $obj->_CpG_value; } else { return $obj->{'cpg'}; } } sub _CpG_value { my ($self) = @_; if ($self->allele_ori eq $self->allele_mut and length ($self->allele_ori) == 1 ) { # valid only for point mutations # CpG methylation-mediated deamination: # CG -> TG | CG -> CA substitutions # implementation here is less strict: if CpG dinucleotide was hit if ( ( ($self->allele_ori eq 'c') && (substr($self->upStreamSeq, 0, 1) eq 'g') ) || ( ($self->allele_ori eq 'g') && (substr($self->dnStreamSeq, -1, 1) eq 'c') ) ) { return 1; } else { return 0; } } else { $self->warn('CpG makes sense only in the context of point mutation'); return; } } =head2 RNAChange Title : RNAChange Usage : $mutobj = $obj->RNAChange; : $mutobj = $obj->RNAChange($objref); Function: Returns or sets the link-reference to a mutation/change object. If there is no link, it will return undef Returns : an obj_ref or undef =cut sub RNAChange { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::RNAChange') ) { $self->throw("Is not a Bio::Variation::RNAChange object but a [$self]"); return; } else { $self->{'RNAChange'} = $value; } } unless (exists $self->{'RNAChange'}) { return; } else { return $self->{'RNAChange'}; } } =head2 label Title : label Usage : $obj->label(); Function: Sets and returns mutation event label(s). If value is not set, or no argument is given returns false. Each instantiable subclass of L<Bio::Variation::VariantI> needs to implement this method. Valid values are listed in 'Mutation event controlled vocabulary' in http://www.ebi.ac.uk/mutations/recommendations/mutevent.html. Example : Returns : string Args : string =cut sub label { my ($self, $value) = @_; my ($o, $m, $type); $o = $self->allele_ori->seq if $self->allele_ori and $self->allele_ori->seq; $m = $self->allele_mut->seq if $self->allele_mut and $self->allele_mut->seq; if (not $o and not $m ) { $self->warn("[DNAMutation, label] Both alleles should not be empty!\n"); $type = 'no change'; # is this enough? } elsif ($o && $m && length($o) == length($m) && length($o) == 1) { $type = 'point'; $type .= ", ". _point_type_label($o, $m); } elsif (not $o ) { $type = 'insertion'; } elsif (not $m ) { $type = 'deletion'; } else { $type = 'complex'; } $self->{'label'} = $type; return $self->{'label'}; } sub _point_type_label { my ($o, $m) = @_; my ($type); my %transition = ('a' => 'g', 'g' => 'a', 'c' => 't', 't' => 'c'); $o = lc $o; $m = lc $m; if ($o eq $m) { $type = 'no change'; } elsif ($transition{$o} eq $m ) { $type = 'transition'; } else { $type = 'transversion'; } } =head2 sysname Title : sysname Usage : $self->sysname Function: This subroutine creates a string corresponding to the 'systematic name' of the mutation. Systematic name is specified in Antonorakis & MDI Nomenclature Working Group: Human Mutation 11:1-3, 1998. Returns : string =cut sub sysname { my ($self,$value) = @_; if( defined $value) { $self->{'sysname'} = $value; } else { $self->warn('Mutation start position is not defined') if not defined $self->start; my $sysname = ''; # show the alphabet only if $self->SeqDiff->alphabet is set; my $mol = ''; if ($self->SeqDiff ) { if ($self->SeqDiff && $self->SeqDiff->alphabet && $self->SeqDiff->alphabet eq 'dna') { $mol = 'g.'; } elsif ($self->SeqDiff->alphabet && $self->SeqDiff->alphabet eq 'rna') { $mol = 'c.'; } } my $sep; if ($self->isMutation) { $sep = '>'; } else { $sep = '|'; } my $sign = '+'; $sign = '' if $self->start < 1; $sysname .= $mol ;#if $mol; $sysname .= $sign. $self->start; my @alleles = $self->each_Allele; $self->allele_mut($alleles[0]); $sysname .= 'del' if $self->label =~ /deletion/; $sysname .= 'ins' if $self->label =~ /insertion/; $sysname .= uc $self->allele_ori->seq if $self->allele_ori->seq; #push @alleles, $self->allele_mut if $self->allele_mut; foreach my $allele (@alleles) { $self->allele_mut($allele); $sysname .= $sep if $self->label =~ /point/ or $self->label =~ /complex/; $sysname .= uc $self->allele_mut->seq if $self->allele_mut->seq; } $self->{'sysname'} = $sysname; #$self->{'sysname'} = $sign. $self->start. # uc $self->allele_ori->seq. $sep. uc $self->allele_mut->seq; } return $self->{'sysname'}; } 1; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/IO.pm�����������������������������������������������������������������000444��000765��000024�� 22231�12254227334� 16772� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::IO # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Variation::IO - Handler for sequence variation IO Formats =head1 SYNOPSIS use Bio::Variation::IO; $in = Bio::Variation::IO->new(-file => "inputfilename" , -format => 'flat'); $out = Bio::Variation::IO->new(-file => ">outputfilename" , -format => 'xml'); while ( my $seq = $in->next() ) { $out->write($seq); } # or use Bio::Variation::IO; #input file format can be read from the file extension (dat|xml) $in = Bio::Variation::IO->newFh(-file => "inputfilename"); $out = Bio::Variation::IO->newFh(-format => 'xml'); # World's shortest flat<->xml format converter: print $out $_ while <$in>; =head1 DESCRIPTION Bio::Variation::IO is a handler module for the formats in the Variation IO set (eg, Bio::Variation::IO::flat). It is the officially sanctioned way of getting at the format objects, which most people should use. The structure, conventions and most of the code is inherited from L<Bio::SeqIO> module. The main difference is that instead of using methods next_seq and write_seq, you drop '_seq' from the method names. The idea is that you request a stream object for a particular format. All the stream objects have a notion of an internal file that is read from or written to. A particular SeqIO object instance is configured for either input or output. A specific example of a stream object is the Bio::Variation::IO::flat object. Each stream object has functions $stream->next(); and $stream->write($seqDiff); also $stream->type() # returns 'INPUT' or 'OUTPUT' As an added bonus, you can recover a filehandle that is tied to the SeqIO object, allowing you to use the standard E<lt>E<gt> and print operations to read and write sequence objects: use Bio::Variation::IO; $stream = Bio::Variation::IO->newFh(-format => 'flat'); # read from standard input while ( $seq = <$stream> ) { # do something with $seq } and print $stream $seq; # when stream is in output mode This makes the simplest ever reformatter #!/usr/local/bin/perl $format1 = shift; $format2 = shift; use Bio::Variation::IO; $in = Bio::Variation::IO->newFh(-format => $format1 ); $out = Bio::Variation::IO->newFh(-format => $format2 ); print $out $_ while <$in>; =head1 CONSTRUCTORS =head2 Bio::Variation::IO-E<gt>new() $seqIO = Bio::Variation::IO->new(-file => 'filename', -format=>$format); $seqIO = Bio::Variation::IO->new(-fh => \*FILEHANDLE, -format=>$format); $seqIO = Bio::Variation::IO->new(-format => $format); The new() class method constructs a new Bio::Variation::IO object. The returned object can be used to retrieve or print BioSeq objects. new() accepts the following parameters: =over 4 =item -file A file path to be opened for reading or writing. The usual Perl conventions apply: 'file' # open file for reading '>file' # open file for writing '>>file' # open file for appending '+<file' # open file read/write 'command |' # open a pipe from the command '| command' # open a pipe to the command =item -fh You may provide new() with a previously-opened filehandle. For example, to read from STDIN: $seqIO = Bio::Variation::IO->new(-fh => \*STDIN); Note that you must pass filehandles as references to globs. If neither a filehandle nor a filename is specified, then the module will read from the @ARGV array or STDIN, using the familiar E<lt>E<gt> semantics. =item -format Specify the format of the file. Supported formats include: flat pseudo EMBL format xml seqvar xml format If no format is specified and a filename is given, then the module will attempt to deduce it from the filename. If this is unsuccessful, Fasta format is assumed. The format name is case insensitive. 'FLAT', 'Flat' and 'flat' are all supported. =back =head2 Bio::Variation::IO-E<gt>newFh() $fh = Bio::Variation::IO->newFh(-fh => \*FILEHANDLE, -format=>$format); $fh = Bio::Variation::IO->newFh(-format => $format); # etc. #e.g. $out = Bio::Variation::IO->newFh( '-FORMAT' => 'flat'); print $out $seqDiff; This constructor behaves like new(), but returns a tied filehandle rather than a Bio::Variation::IO object. You can read sequences from this object using the familiar E<lt>E<gt> operator, and write to it using print(). The usual array and $_ semantics work. For example, you can read all sequence objects into an array like this: @mutations = <$fh>; Other operations, such as read(), sysread(), write(), close(), and printf() are not supported. =head1 OBJECT METHODS See below for more detailed summaries. The main methods are: =head2 $sequence = $seqIO-E<gt>next() Fetch the next sequence from the stream. =head2 $seqIO-E<gt>write($sequence [,$another_sequence,...]) Write the specified sequence(s) to the stream. =head2 TIEHANDLE(), READLINE(), PRINT() These provide the tie interface. See L<perltie> for more details. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::IO; use strict; use base qw(Bio::SeqIO Bio::Root::IO); =head2 new Title : new Usage : $stream = Bio::Variation::IO->new(-file => $filename, -format => 'Format') Function: Returns a new seqstream Returns : A Bio::Variation::IO::Handler initialised with the appropriate format Args : -file => $filename -format => format -fh => filehandle to attach to =cut sub new { my ($class, %param) = @_; my ($format); @param{ map { lc $_ } keys %param } = values %param; # lowercase keys $format = $param{'-format'} || $class->_guess_format( $param{-file} || $ARGV[0] ) || 'flat'; $format = "\L$format"; # normalize capitalization to lower case return unless $class->_load_format_module($format); return "Bio::Variation::IO::$format"->new(%param); } =head2 format Title : format Usage : $format = $stream->format() Function: Get the variation format Returns : variation format Args : none =cut # format() method inherited from Bio::Root::IO sub _load_format_module { my ($class, $format) = @_; my $module = "Bio::Variation::IO::" . $format; my $ok; eval { $ok = $class->_load_module($module); }; if ( $@ ) { print STDERR <<END; $class: $format cannot be found Exception $@ For more information about the IO system please see the IO docs. This includes ways of checking for formats at compile time, not run time END ; } return $ok; } =head2 next Title : next Usage : $seqDiff = $stream->next Function: reads the next $seqDiff object from the stream Returns : a Bio::Variation::SeqDiff object Args : =cut sub next { my ($self, $seq) = @_; $self->throw("Sorry, you cannot read from a generic Bio::Variation::IO object."); } sub next_seq { my ($self, $seq) = @_; $self->throw("These are not sequence objects. Use method 'next' instead of 'next_seq'."); $self->next($seq); } =head2 write Title : write Usage : $stream->write($seq) Function: writes the $seq object into the stream Returns : 1 for success and 0 for error Args : Bio::Variation::SeqDiff object =cut sub write { my ($self, $seq) = @_; $self->throw("Sorry, you cannot write to a generic Bio::Variation::IO object."); } sub write_seq { my ($self, $seq) = @_; $self->warn("These are not sequence objects. Use method 'write' instead of 'write_seq'."); $self->write($seq); } =head2 _guess_format Title : _guess_format Usage : $obj->_guess_format($filename) Function: Example : Returns : guessed format of filename (lower case) Args : =cut sub _guess_format { my $class = shift; return unless $_ = shift; return 'flat' if /\.dat$/i; return 'xml' if /\.xml$/i; } 1; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/README����������������������������������������������������������������000444��000765��000024�� 1736�12254227323� 16772� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� README for Bio::Variation classes These classes are part of "Computational Mutation Expression Toolkit" project at European Bioinformatics Institute <http://www.ebi.ac.uk/mutations/toolkit/>, but they are written to be as general as possinble. Bio::Variation name space contains modules to store sequence variation information as differences between the reference sequence and changes sequences. Also included are classes to write out and recrete objects from EMBL-like flat files and XML. Lastly, there are simple classes to calculate values for sequence change objects. See "Computational Mutation Expression Toolkit" web pages for more information: http://www.ebi.ac.uk/mutations/toolkit/ Send bug reports using the bioperl bug-tracking system at https://redmine.open-bio.org/projects/bioperl/. Send general comments, questions, and feature requests to the bioperl mailing list: bioperl-l@bioperl.org Heikki Lehväslaiho <heikki-at-bioperl-dot-org> ����������������������������������BioPerl-1.6.923/Bio/Variation/RNAChange.pm����������������������������������������������������������000444��000765��000024�� 37335�12254227337� 20227� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::RNAChange # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Variation::RNAChange - Sequence change class for RNA level =head1 SYNOPSIS $rnachange = Bio::Variation::RNAChange->new ('-start' => $start, '-end' => $end, '-length' => $len, '-codon_pos' => $cp, '-upStreamSeq' => $upflank, '-dnStreamSeq' => $dnflank, '-proof' => $proof, '-isMutation' => 1, '-mut_number' => $mut_number ); $a1 = Bio::Variation::Allele->new; $a1->seq('a'); $rnachange->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq('t'); $rnachange->add_Allele($a2); $rnachange->allele_mut($a2); print "The codon change is ", $rnachange->codon_ori, ">", $rnachange->codon_mut, "\n"; # add it to a SeqDiff container object $seqdiff->add_Variant($rnachange); # and create links to and from DNA level mutation objects $rnachange->DNAMutation($dnamut); $dnamut->RNAChange($rnachange); =head1 DESCRIPTION The instantiable class Bio::Variation::DNAMutation describes basic sequence changes at RNA molecule level. It uses methods defined in superclass Bio::Variation::VariantI. See L<Bio::Variation::VariantI> for details. You are normally expected to create a corresponding Bio::Variation::DNAMutation object even if mutation is defined at RNA level. The numbering follows then cDNA numbering. Link the DNAMutation object to the RNAChange object using the method DNAMutation(). If the variation described by a RNAChange object is translated, link the corresponding Bio::Variation::AAChange object to it using method AAChange(). See L<Bio::Variation::DNAMutation> and L<Bio::Variation::AAChange> for more information. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::RNAChange; use strict; # Object preamble - inheritance use Bio::Tools::CodonTable; use base qw(Bio::Variation::VariantI); sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my ($start, $end, $length, $strand, $primary, $source, $frame, $score, $gff_string, $allele_ori, $allele_mut, $upstreamseq, $dnstreamseq, $label, $status, $proof, $region, $region_value, $region_dist, $numbering, $mut_number, $isMutation, $codon_ori, $codon_mut, $codon_pos, $codon_table, $cds_end) = $self->_rearrange([qw(START END LENGTH STRAND PRIMARY SOURCE FRAME SCORE GFF_STRING ALLELE_ORI ALLELE_MUT UPSTREAMSEQ DNSTREAMSEQ LABEL STATUS PROOF REGION REGION_VALUE REGION_DIST NUMBERING MUT_NUMBER ISMUTATION CODON_ORI CODON_MUT CODON_POS TRANSLATION_TABLE CDS_END )],@args); $self->primary_tag("Variation"); $self->{ 'alleles' } = []; $start && $self->start($start); $end && $self->end($end); $length && $self->length($length); $strand && $self->strand($strand); $primary && $self->primary_tag($primary); $source && $self->source_tag($source); $frame && $self->frame($frame); $score && $self->score($score); $gff_string && $self->_from_gff_string($gff_string); $allele_ori && $self->allele_ori($allele_ori); $allele_mut && $self->allele_mut($allele_mut); $upstreamseq && $self->upStreamSeq($upstreamseq); $dnstreamseq && $self->dnStreamSeq($dnstreamseq); $label && $self->label($label); $status && $self->status($status); $proof && $self->proof($proof); $region && $self->region($region); $region_value && $self->region_value($region_value); $region_dist && $self->region_dist($region_dist); $numbering && $self->numbering($numbering); $mut_number && $self->mut_number($mut_number); $isMutation && $self->isMutation($isMutation); $codon_ori && $self->codon_ori($codon_ori); $codon_mut && $self->codon_mut($codon_mut); $codon_pos && $self->codon_pos($codon_pos); $codon_table && $self->codon_table($codon_table); $cds_end && $self->cds_end($cds_end); return $self; # success - we hope! } =head2 codon_ori Title : codon_ori Usage : $obj->codon_ori(); Function: Sets and returns codon_ori triplet. If value is not set, creates the codon triplet from the codon position and flanking sequences. The string has to be three characters long. The character content is not checked. Example : Returns : string Args : string =cut sub codon_ori { my ($self,$value) = @_; if (defined $value) { if (length $value != 3) { $self->warn("Codon string \"$value\" is not three characters long"); } $self->{'codon_ori'} = $value; } elsif (! $self->{'codon_ori'}) { my $codon_ori = ''; if ($self->region eq 'coding' && $self->start && $self->start >= 1) { $self->warn('Codon position is not defined') if not defined $self->codon_pos; $self->warn('Upstream flanking sequence is not defined') if not defined $self->upStreamSeq; $self->warn('Downstream flanking sequence is not defined') if not defined $self->dnStreamSeq; my $cpos = $self->codon_pos; $codon_ori = substr($self->upStreamSeq, -$cpos +1 , $cpos-1); $codon_ori .= substr($self->allele_ori->seq, 0, 4-$cpos) if $self->allele_ori and $self->allele_ori->seq; $codon_ori .= substr($self->dnStreamSeq, 0, 3-length($codon_ori)); } $self->{'codon_ori'} = lc $codon_ori; } return $self->{'codon_ori'}; } =head2 codon_mut Title : codon_mut Usage : $obj->codon_mut(); Function: Sets and returns codon_mut triplet. If value is not set, creates the codon triplet from the codon position and flanking sequences. Return undef for other than point mutations. Example : Returns : string Args : string =cut sub codon_mut { my ($self,$value) = @_; if (defined $value) { if (length $value != 3 ) { $self->warn("Codon string \"$value\" is not three characters long"); } $self->{'codon_mut'} = $value; } else { my $codon_mut = ''; if ($self->allele_ori->seq and $self->allele_mut->seq and CORE::length($self->allele_ori->seq) == 1 and CORE::length($self->allele_mut->seq) == 1 and $self->region eq 'coding' and $self->start >= 1) { $self->warn('Codon position is not defined') if not defined $self->codon_pos; $self->warn('Upstream flanking sequnce is not defined') if not defined $self->upStreamSeq; $self->warn('Downstream flanking sequnce is not defined') if not defined $self->dnStreamSeq; $self->throw('Mutated allele is not defined') if not defined $self->allele_mut; my $cpos = $self->codon_pos; $codon_mut = substr($self->upStreamSeq, -$cpos +1 , $cpos-1); $codon_mut .= substr($self->allele_mut->seq, 0, 4-$cpos) if $self->allele_mut and $self->allele_mut->seq; $codon_mut .= substr($self->dnStreamSeq, 0, 3-length($codon_mut)); $self->{'codon_mut'} = lc $codon_mut; } } return $self->{'codon_mut'}; } =head2 codon_pos Title : codon_pos Usage : $obj->codon_pos(); Function: Sets and returns the position of the mutation start in the codon. If value is not set, returns false. Example : Returns : 1,2,3 Args : none if get, the new value if set =cut sub codon_pos { my ($self,$value) = @_; if( defined $value) { if ( $value !~ /[123]/ ) { $self->throw("'$value' is not a valid codon position"); } $self->{'codon_pos'} = $value; } return $self->{'codon_pos'}; } =head2 codon_table Title : codon_table Usage : $obj->codon_table(); Function: Sets and returns the codon table id of the RNA If value is not set, returns 1, 'universal' code, as the default. Example : Returns : integer Args : none if get, the new value if set =cut sub codon_table { my ($self,$value) = @_; if( defined $value) { if ( not $value =~ /^\d$/ ) { $self->throw("'$value' is not a valid codon table ID\n". "Has to be a positive integer. Defaulting to 1\n"); } else { $self->{'codon_table'} = $value; } } if( ! exists $self->{'codon_table'} ) { return 1; } else { return $self->{'codon_table'}; } } =head2 DNAMutation Title : DNAMutation Usage : $mutobj = $obj->DNAMutation; : $mutobj = $obj->DNAMutation($objref); Function: Returns or sets the link-reference to a mutation/change object. If there is no link, it will return undef Returns : an obj_ref or undef =cut sub DNAMutation { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::DNAMutation') ) { $self->throw("Is not a Bio::Variation::DNAMutation object but a [$self]"); return; } else { $self->{'DNAMutation'} = $value; } } unless (exists $self->{'DNAMutation'}) { return; } else { return $self->{'DNAMutation'}; } } =head2 AAChange Title : AAChange Usage : $mutobj = $obj->AAChange; : $mutobj = $obj->AAChange($objref); Function: Returns or sets the link-reference to a mutation/change object. If there is no link, it will return undef Returns : an obj_ref or undef =cut sub AAChange { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::AAChange') ) { $self->throw("Is not a Bio::Variation::AAChange object but a [$self]"); return; } else { $self->{'AAChange'} = $value; } } unless (exists $self->{'AAChange'}) { return; } else { return $self->{'AAChange'}; } } =head2 exons_modified Title : exons_modified Usage : $modified = $obj->exons_modified; : $modified = $obj->exons_modified(1); Function: Returns or sets information (example: a simple boolean flag) about the modification of exons as a result of a mutation. =cut sub exons_modified { my ($self,$value)=@_; if (defined($value)) { $self->{'exons_modified'}=$value; } return ($self->{'exons_modified'}); } =head2 region Title : region Usage : $obj->region(); Function: Sets and returns the name of the sequence region type or protein domain at this location. If value is not set, returns false. Example : Returns : string Args : string =cut sub region { my ($self,$value) = @_; if( defined $value) { $self->{'region'} = $value; } elsif (not defined $self->{'region'}) { $self->warn('Mutation start position is not defined') if not defined $self->start and $self->verbose; $self->warn('Mutation end position is not defined') if not defined $self->end and $self->verbose; $self->warn('Length of the CDS is not defined, the mutation can be beyond coding region!') if not defined $self->cds_end and $self->verbose; $self->region('coding'); if ($self->end && $self->end < 0 ){ $self->region('5\'UTR'); } elsif ($self->start && $self->cds_end && $self->start > $self->cds_end ) { $self->region('3\'UTR'); } } return $self->{'region'}; } =head2 cds_end Title : cds_end Usage : $cds_end = $obj->get_cds_end(); Function: Sets or returns the cds_end from the beginning of the DNA sequence to the coordinate start used to describe variants. Should be the location of the last nucleotide of the terminator codon of the gene. Example : Returns : value of cds_end, a scalar Args : =cut sub cds_end { my ($self, $value) = @_; if (defined $value) { $self->warn("[$value] is not a good value for sequence position") if not $value =~ /^\d+$/ ; $self->{'cds_end'} = $value; } else { $self->{'cds_end'} = $self->SeqDiff->cds_end if $self->SeqDiff; } return $self->{'cds_end'}; } =head2 label Title : label Usage : $obj->label(); Function: Sets and returns mutation event label(s). If value is not set, or no argument is given returns false. Each instantiable subclass of L<Bio::Variation::VariantI> needs to implement this method. Valid values are listed in 'Mutation event controlled vocabulary' in http://www.ebi.ac.uk/mutations/recommendations/mutevent.html. Example : Returns : string Args : string =cut sub label { my ($self) = @_; my ($o, $m, $type); $o = $self->allele_ori->seq if $self->allele_ori and $self->allele_ori->seq; $m = $self->allele_mut->seq if $self->allele_mut and $self->allele_mut->seq; my $ct = Bio::Tools::CodonTable -> new ( -id => $self->codon_table ); if ($o and $m and CORE::length($o) == 1 and CORE::length($m) == 1) { if (defined $self->AAChange) { if ($self->start > 0 and $self->start < 4 ) { $type = 'initiation codon'; } elsif ($self->codon_ori && $ct->is_ter_codon($self->codon_ori) ) { #AAChange->allele_ori and $self->AAChange->allele_ori->seq eq '*' ) { $type = 'termination codon'; } elsif ($self->codon_mut && $ct->is_ter_codon($self->codon_mut) ) { #elsif ($self->AAChange->allele_mut and $self->AAChange->allele_mut->seq eq "*") { $type = 'nonsense'; } elsif ($o and $m and ($o eq $m or $self->AAChange->allele_ori->seq eq $self->AAChange->allele_mut->seq)) { $type = 'silent'; } else { $type = 'missense'; } } else { $type = 'unknown'; } } else { my $len = 0; $len = CORE::length($o) if $o; $len -= CORE::length($m) if $m; if ($len%3 == 0 ) { $type = 'inframe'; } else { $type = 'frameshift'; } if (not $m ) { $type .= ', '. 'deletion'; } elsif (not $o ) { $type .= ', '. 'insertion'; } else { $type .= ', '. 'complex'; } if ($self->codon_ori && $ct->is_ter_codon($self->codon_ori) ) { $type .= ', '. 'termination codon'; } } $self->{'label'} = $type; return $self->{'label'}; } =head2 _change_codon_pos Title : _change_codon_pos Usage : $newCodonPos = _change_codon_pos($myCodonPos, 5) Function: Keeps track of the codon position in a changeing sequence Returns : codon_pos = integer 1, 2 or 3 Args : valid codon position signed integer offset to a new location in sequence =cut sub _change_codon_pos ($$) { my ($cpos, $i) = @_; $cpos = ($cpos + $i%3)%3; if ($cpos > 3 ) { $cpos = $cpos - 3; } elsif ($cpos < 1 ) { $cpos = $cpos + 3; } return $cpos; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/SeqDiff.pm������������������������������������������������������������000444��000765��000024�� 60637�12254227337� 20023� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# bioperl module for Bio::Variation::SeqDiff # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code # cds_end definition? =head1 NAME Bio::Variation::SeqDiff - Container class for mutation/variant descriptions =head1 SYNOPSIS $seqDiff = Bio::Variation::SeqDiff->new ( -id => $M20132, -alphabet => 'rna', -gene_symbol => 'AR' -chromosome => 'X', -numbering => 'coding' ); # get a DNAMutation object somehow $seqDiff->add_Variant($dnamut); print $seqDiff->sys_name(), "\n"; =head1 DESCRIPTION SeqDiff stores Bio::Variation::VariantI object references and descriptive information common to all changes in a sequence. Mutations are understood to be any kind of sequence markers and are expected to occur in the same chromosome. See L<Bio::Variation::VariantI> for details. The methods of SeqDiff are geared towards describing mutations in human genes using gene-based coordinate system where 'A' of the initiator codon has number 1 and the one before it -1. This is according to conventions of human genetics. There will be class Bio::Variation::Genotype to describe markers in different chromosomes and diploid genototypes. Classes implementing Bio::Variation::VariantI interface are Bio::Variation::DNAMutation, Bio::Variation::RNAChange, and Bio::Variation::AAChange. See L<Bio::Variation::VariantI>, L<Bio::Variation::DNAMutation>, L<Bio::Variation::RNAChange>, and L<Bio::Variation::AAChange> for more information. Variant objects can be added using two ways: an array passed to the constructor or as individual Variant objects with add_Variant method. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 CONTRIBUTORS Eckhard Lehmann, ecky@e-lehmann.de =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::SeqDiff; use strict; use Bio::Tools::CodonTable; use Bio::PrimarySeq; use base qw(Bio::Root::Root); =head2 new Title : new Usage : $seqDiff = Bio::Variation::SeqDiff->new; Function: generates a new Bio::Variation::SeqDiff Returns : reference to a new object of class SeqDiff Args : =cut sub new { my($class,@args) = @_; my $self = $class->SUPER::new(@args); my($id, $sysname, $trivname, $chr, $gene_symbol, $desc, $alphabet, $numbering, $offset, $rna_offset, $rna_id, $cds_end, $dna_ori, $dna_mut, $rna_ori, $rna_mut, $aa_ori, $aa_mut #@variants, @genes ) = $self->_rearrange([qw(ID SYSNAME TRIVNAME CHR GENE_SYMBOL DESC ALPHABET NUMBERING OFFSET RNA_OFFSET RNA_ID CDS_END DNA_ORI DNA_MUT RNA_ORI AA_ORI AA_MUT )], @args); #my $make = $self->SUPER::_initialize(@args); $id && $self->id($id); $sysname && $self->sysname($sysname); $trivname && $self->trivname($trivname); $chr && $self->chromosome($chr); $gene_symbol && $self->gene_symbol($chr); $desc && $self->description($desc); $alphabet && $self->alphabet($alphabet); $numbering && $self->numbering($numbering); $offset && $self->offset($offset); $rna_offset && $self->rna_offset($rna_offset); $rna_id && $self->rna_id($rna_id); $cds_end && $self->cds_end($cds_end); $dna_ori && $self->dna_ori($dna_ori); $dna_mut && $self->dna_mut($dna_mut); $rna_ori && $self->rna_ori($rna_ori); $rna_mut && $self->rna_mut($rna_mut); $aa_ori && $self->aa_ori ($aa_ori); $aa_mut && $self->aa_mut ($aa_mut); $self->{ 'variants' } = []; #@variants && push(@{$self->{'variants'}},@variants); $self->{ 'genes' } = []; #@genes && push(@{$self->{'genes'}},@genes); return $self; # success - we hope! } =head2 id Title : id Usage : $obj->id(H0001); $id = $obj->id(); Function: Sets or returns the id of the seqDiff. Should be used to give the collection of variants a UID without semantic associations. Example : Returns : value of id, a scalar Args : newvalue (optional) =cut sub id { my ($self,$value) = @_; if (defined $value) { $self->{'id'} = $value; } else { return $self->{'id'}; } } =head2 sysname Title : sysname Usage : $obj->sysname('5C>G'); $sysname = $obj->sysname(); Function: Sets or returns the systematic name of the seqDiff. The name should follow the HUGO Mutation Database Initiative approved nomenclature. If called without first setting the value, will generate it from L<Bio::Variation::DNAMutation> objects attached. Example : Returns : value of sysname, a scalar Args : newvalue (optional) =cut sub sysname { my ($self,$value) = @_; if (defined $value) { $self->{'sysname'} = $value; } elsif (not defined $self->{'sysname'}) { my $sysname = ''; my $c = 0; foreach my $mut ($self->each_Variant) { if( $mut->isa('Bio::Variation::DNAMutation') ) { $c++; if ($c == 1 ) { $sysname = $mut->sysname ; } else { $sysname .= ";". $mut->sysname; } } } $sysname = "[". $sysname. "]" if $c > 1; $self->{'sysname'} = $sysname; } return $self->{'sysname'}; } =head2 trivname Title : trivname Usage : $obj->trivname('[A2G;T56G]'); $trivname = $obj->trivname(); Function: Sets or returns the trivial name of the seqDiff. The name should follow the HUGO Mutation Database Initiative approved nomenclature. If called without first setting the value, will generate it from L<Bio::Variation::AAChange> objects attached. Example : Returns : value of trivname, a scalar Args : newvalue (optional) =cut sub trivname { my ($self,$value) = @_; if (defined $value) { $self->{'trivname'} = $value; } elsif (not defined $self->{'trivname'}) { my $trivname = ''; my $c = 0; foreach my $mut ($self->each_Variant) { if( $mut->isa('Bio::Variation::AAChange') ) { $c++; if ($c == 1 ) { $trivname = $mut->trivname ; } else { $trivname .= ";". $mut->trivname; } } } $trivname = "[". $trivname. "]" if $c > 1; $self->{'trivname'} = $trivname; } else { return $self->{'trivname'}; } } =head2 chromosome Title : chromosome Usage : $obj->chromosome('X'); $chromosome = $obj->chromosome(); Function: Sets or returns the chromosome ("linkage group") of the seqDiff. Example : Returns : value of chromosome, a scalar Args : newvalue (optional) =cut sub chromosome { my ($self,$value) = @_; if (defined $value) { $self->{'chromosome'} = $value; } else { return $self->{'chromosome'}; } } =head2 gene_symbol Title : gene_symbol Usage : $obj->gene_symbol('FOS'); $gene_symbol = $obj->gene_symbol; Function: Sets or returns the gene symbol for the studied CDS. Example : Returns : value of gene_symbol, a scalar Args : newvalue (optional) =cut sub gene_symbol { my ($self,$value) = @_; if (defined $value) { $self->{'gene_symbol'} = $value; } else { return $self->{'gene_symbol'}; } } =head2 description Title : description Usage : $obj->description('short description'); $descr = $obj->description(); Function: Sets or returns the short description of the seqDiff. Example : Returns : value of description, a scalar Args : newvalue (optional) =cut sub description { my ($self,$value) = @_; if (defined $value) { $self->{'description'} = $value; } else { return $self->{'description'}; } } =head2 alphabet Title : alphabet Usage : if( $obj->alphabet eq 'dna' ) { /Do Something/ } Function: Returns the type of primary reference sequence being one of 'dna', 'rna' or 'protein'. This is case sensitive. Returns : a string either 'dna','rna','protein'. Args : none =cut sub alphabet { my ($self,$value) = @_; my %type = (dna => 1, rna => 1, protein => 1); if( defined $value ) { if ($type{$value}) { $self->{'alphabet'} = $value; } else { $self->throw("$value is not valid alphabet value!"); } } return $self->{'alphabet'}; } =head2 numbering Title : numbering Usage : $obj->numbering('coding'); $numbering = $obj->numbering(); Function: Sets or returns the string giving the numbering schema used to describe the variants. Example : Returns : value of numbering, a scalar Args : newvalue (optional) =cut sub numbering { my ($self,$value) = @_; if (defined $value) { $self->{'numbering'} = $value; } else { return $self->{'numbering'}; } } =head2 offset Title : offset Usage : $obj->offset(124); $offset = $obj->offset(); Function: Sets or returns the offset from the beginning of the DNA sequence to the coordinate start used to describe variants. Typically the beginning of the coding region of the gene. The cds_start should be 1 + offset. Example : Returns : value of offset, a scalar Args : newvalue (optional) =cut sub offset { my ($self,$value) = @_; if (defined $value) { $self->{'offset'} = $value; } elsif (not defined $self->{'offset'} ) { return $self->{'offset'} = 0; } else { return $self->{'offset'}; } } =head2 cds_start Title : cds_start Usage : $obj->cds_start(123); $cds_start = $obj->cds_start(); Function: Sets or returns the cds_start from the beginning of the DNA sequence to the coordinate start used to describe variants. Typically the beginning of the coding region of the gene. Needs to be and is implemented as 1 + offset. Example : Returns : value of cds_start, a scalar Args : newvalue (optional) =cut sub cds_start { my ($self,$value) = @_; if (defined $value) { $self->{'offset'} = $value - 1; } else { return $self->{'offset'} + 1; } } =head2 cds_end Title : cds_end Usage : $obj->cds_end(321); $cds_end = $obj->cds_end(); Function: Sets or returns the position of the last nucleotitide of the termination codon. The coordinate system starts from cds_start. Example : Returns : value of cds_end, a scalar Args : newvalue (optional) =cut sub cds_end { my ($self,$value) = @_; if (defined $value) { $self->{'cds_end'} = $value; } else { return $self->{'cds_end'}; #$self->{'cds_end'} = CORE::length($self->SeqDiff->rna_ori)/3; } } =head2 rna_offset Title : rna_offset Usage : $obj->rna_offset(124); $rna_offset = $obj->rna_offset(); Function: Sets or returns the rna_offset from the beginning of the RNA sequence to the coordinate start used to describe variants. Typically the beginning of the coding region of the gene. Example : Returns : value of rna_offset, a scalar Args : newvalue (optional) =cut sub rna_offset { my ($self,$value) = @_; if (defined $value) { $self->{'rna_offset'} = $value; } elsif (not defined $self->{'rna_offset'} ) { return $self->{'rna_offset'} = 0; } else { return $self->{'rna_offset'}; } } =head2 rna_id Title : rna_id Usage : $obj->rna_id('transcript#3'); $rna_id = $obj->rna_id(); Function: Sets or returns the ID for original RNA sequence of the seqDiff. Example : Returns : value of rna_id, a scalar Args : newvalue (optional) =cut sub rna_id { my ($self,$value) = @_; if (defined $value) { $self->{'rna_id'} = $value; } else { return $self->{'rna_id'}; } } =head2 add_Variant Title : add_Variant Usage : $obj->add_Variant($variant) Function: Pushes one Bio::Variation::Variant into the list of variants. At the same time, creates a link from the Variant to SeqDiff using its SeqDiff method. Example : Returns : 1 when succeeds, 0 for failure. Args : Variant object =cut sub add_Variant { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::VariantI') ) { $self->throw("Is not a VariantI complying object but a [$self]"); return 0; } else { push(@{$self->{'variants'}},$value); $value->SeqDiff($self); return 1; } } else { return 0; } } =head2 each_Variant Title : each_Variant Usage : $obj->each_Variant(); Function: Returns a list of Variants. Example : Returns : list of Variants Args : none =cut sub each_Variant{ my ($self,@args) = @_; return @{$self->{'variants'}}; } =head2 add_Gene Title : add_Gene Usage : $obj->add_Gene($gene) Function: Pushes one L<Bio::LiveSeq::Gene> into the list of genes. Example : Returns : 1 when succeeds, 0 for failure. Args : Bio::LiveSeq::Gene object See L<Bio::LiveSeq::Gene> for more information. =cut sub add_Gene { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::LiveSeq::Gene') ) { $value->throw("Is not a Bio::LiveSeq::Gene object but a [$value]"); return 0; } else { push(@{$self->{'genes'}},$value); return 1; } } else { return 0; } } =head2 each_Gene Title : each_Gene Usage : $obj->each_Gene(); Function: Returns a list of L<Bio::LiveSeq::Gene>s. Example : Returns : list of Genes Args : none =cut sub each_Gene{ my ($self,@args) = @_; return @{$self->{'genes'}}; } =head2 dna_ori Title : dna_ori Usage : $obj->dna_ori('atgctgctgctgct'); $dna_ori = $obj->dna_ori(); Function: Sets or returns the original DNA sequence string of the seqDiff. Example : Returns : value of dna_ori, a scalar Args : newvalue (optional) =cut sub dna_ori { my ($self,$value) = @_; if (defined $value) { $self->{'dna_ori'} = $value; } else { return $self->{'dna_ori'}; } } =head2 dna_mut Title : dna_mut Usage : $obj->dna_mut('atgctggtgctgct'); $dna_mut = $obj->dna_mut(); Function: Sets or returns the mutated DNA sequence of the seqDiff. If sequence has not been set generates it from the original sequence and DNA mutations. Example : Returns : value of dna_mut, a scalar Args : newvalue (optional) =cut sub dna_mut { my ($self,$value) = @_; if (defined $value) { $self->{'dna_mut'} = $value; } else { $self->_set_dnamut() unless $self->{'dna_mut'}; return $self->{'dna_mut'}; } } sub _set_dnamut { my $self = shift; return unless $self->{'dna_ori'} && $self->each_Variant; $self->{'dna_mut'} = $self->{'dna_ori'}; foreach ($self->each_Variant) { next unless $_->isa('Bio::Variation::DNAMutation'); next unless $_->isMutation; my ($s, $la, $le); #lies the mutation less than 25 bases after the start of sequence? if ($_->start < 25) { $s = 0; $la = $_->start - 1; } else { $s = $_->start - 25; $la = 25; } #is the mutation an insertion? $_->end($_->start) unless $_->allele_ori->seq; #does the mutation end greater than 25 bases before the end of #sequence? if (($_->end + 25) > length($self->{'dna_mut'})) { $le = length($self->{'dna_mut'}) - $_->end; } else { $le = 25; } $_->dnStreamSeq(substr($self->{'dna_mut'}, $s, $la)); $_->upStreamSeq(substr($self->{'dna_mut'}, $_->end, $le)); my $s_ori = $_->dnStreamSeq . $_->allele_ori->seq . $_->upStreamSeq; my $s_mut = $_->dnStreamSeq . $_->allele_mut->seq . $_->upStreamSeq; (my $str = $self->{'dna_mut'}) =~ s/$s_ori/$s_mut/; $self->{'dna_mut'} = $str; } } =head2 rna_ori Title : rna_ori Usage : $obj->rna_ori('atgctgctgctgct'); $rna_ori = $obj->rna_ori(); Function: Sets or returns the original RNA sequence of the seqDiff. Example : Returns : value of rna_ori, a scalar Args : newvalue (optional) =cut sub rna_ori { my ($self,$value) = @_; if (defined $value) { $self->{'rna_ori'} = $value; } else { return $self->{'rna_ori'}; } } =head2 rna_mut Title : rna_mut Usage : $obj->rna_mut('atgctggtgctgct'); $rna_mut = $obj->rna_mut(); Function: Sets or returns the mutated RNA sequence of the seqDiff. Example : Returns : value of rna_mut, a scalar Args : newvalue (optional) =cut sub rna_mut { my ($self,$value) = @_; if (defined $value) { $self->{'rna_mut'} = $value; } else { return $self->{'rna_mut'}; } } =head2 aa_ori Title : aa_ori Usage : $obj->aa_ori('MAGVLL*'); $aa_ori = $obj->aa_ori(); Function: Sets or returns the original protein sequence of the seqDiff. Example : Returns : value of aa_ori, a scalar Args : newvalue (optional) =cut sub aa_ori { my ($self,$value) = @_; if (defined $value) { $self->{'aa_ori'} = $value; } else { return $self->{'aa_ori'}; } } =head2 aa_mut Title : aa_mut Usage : $obj->aa_mut('MA*'); $aa_mut = $obj->aa_mut(); Function: Sets or returns the mutated protein sequence of the seqDiff. Example : Returns : value of aa_mut, a scalar Args : newvalue (optional) =cut sub aa_mut { my ($self,$value) = @_; if (defined $value) { $self->{'aa_mut'} = $value; } else { return $self->{'aa_mut'}; } } =head2 seqobj Title : seqobj Usage : $dnaobj = $obj->seqobj('dna_mut'); Function: Returns the any original or mutated sequences as a Bio::PrimarySeq object. Example : Returns : Bio::PrimarySeq object for the requested sequence Args : string, method name for the sequence requested See L<Bio::PrimarySeq> for more information. =cut sub seqobj { my ($self,$value) = @_; my $out; my %valid_obj = map {$_, 1} qw(dna_ori rna_ori aa_ori dna_mut rna_mut aa_mut); $valid_obj{$value} || $self->throw("Sequence type '$value' is not a valid type (". join(',', map "'$_'", sort keys %valid_obj) .") lowercase"); my ($alphabet) = $value =~ /([^_]+)/; my $id = $self->id; $id = $self->rna_id if $self->rna_id; $alphabet = 'protein' if $alphabet eq 'aa'; $out = Bio::PrimarySeq->new ( '-seq' => $self->{$value}, '-display_id' => $id, '-accession_number' => $self->id, '-alphabet' => $alphabet ) if $self->{$value} ; return $out; } =head2 alignment Title : alignment Usage : $obj->alignment Function: Returns a pretty RNA/AA sequence alignment from linked objects. Under construction: Only simple coding region point mutations work. Example : Returns : Args : none =cut sub alignment { my $self = shift; my (@entry, $text); my $maxflanklen = 12; foreach my $mut ($self->each_Variant) { if( $mut->isa('Bio::Variation::RNAChange') ) { my $upflank = $mut->upStreamSeq; my $dnflank = $mut->dnStreamSeq; my $cposd = $mut->codon_pos; my $rori = $mut->allele_ori->seq; my $rmut = $mut->allele_mut->seq; my $rseqoriu = ''; my $rseqmutu = ''; my $rseqorid = ''; my $rseqmutd = ''; my $aaseqmutu = ''; my (@rseqori, @rseqmut ); # point if ($mut->DNAMutation->label =~ /point/) { if ($cposd == 1 ) { my $nt2d = substr($dnflank, 0, 2); push @rseqori, $rori. $nt2d; push @rseqmut, uc ($rmut). $nt2d; $dnflank = substr($dnflank, 2); } elsif ($cposd == 2) { my $ntu = chop $upflank; my $ntd = substr($dnflank, 0, 1); push @rseqori, $ntu. $rori. $ntd; push @rseqmut, $ntu. uc ($rmut). $ntd; $dnflank = substr($dnflank, 1); } elsif ($cposd == 3) { my $ntu1 = chop $upflank; my $ntu2 = chop $upflank; push (@rseqori, $ntu2. $ntu1. $rori); push (@rseqmut, $ntu2. $ntu1. uc $rmut); } } #deletion elsif ($mut->DNAMutation->label =~ /deletion/) { if ($cposd == 2 ) { $rseqorid = chop $upflank; $rseqmutd = $rseqorid; } for (my $i=1; $i<=$mut->length; $i++) { my $ntd .= substr($mut->allele_ori, $i-1, 1); $rseqorid .= $ntd; if (length($rseqorid) == 3 ) { push (@rseqori, $rseqorid); push (@rseqmut, " "); $rseqorid = ''; } } if ($rseqorid) { $rseqorid .= substr($dnflank, 0, 3-$rseqorid); push (@rseqori, $rseqorid); push (@rseqmut, " "); $dnflank = substr($dnflank,3-$rseqorid); } } $upflank = reverse $upflank; # loop throught the flanks for (my $i=1; $i<=length($dnflank); $i++) { last if $i > $maxflanklen; my $ntd .= substr($dnflank, $i-1, 1); my $ntu .= substr($upflank, $i-1, 1); $rseqmutd .= $ntd; $rseqorid .= $ntd; $rseqmutu = $ntu. $rseqmutu; $rseqoriu = $ntu. $rseqoriu; if (length($rseqorid) == 3 and length($rseqorid) == 3) { push (@rseqori, $rseqorid); push (@rseqmut, $rseqmutd); $rseqorid = $rseqmutd =''; } if (length($rseqoriu) == 3 and length($rseqoriu) == 3) { unshift (@rseqori, $rseqoriu); unshift (@rseqmut, $rseqmutu); $rseqoriu = $rseqmutu =''; } #print "|i=$i, $cposd, $rseqmutd, $rseqorid\n"; #print "|i=$i, $cposu, $rseqmutu, $rseqoriu\n\n"; } push (@rseqori, $rseqorid); unshift (@rseqori, $rseqoriu); push (@rseqmut, $rseqmutd); unshift (@rseqmut, $rseqmutu); return unless $mut->AAChange; #translate my $tr = Bio::Tools::CodonTable->new('-id' => $mut->codon_table); my $apos = $mut->AAChange->start; my $aposmax = CORE::length($self->aa_ori); #terminator codon no my $rseqori; my $rseqmut; my $aaseqori; my $aaseqmut = ""; for (my $i = 0; $i <= $#rseqori; $i++) { my $a = ''; $a = $tr->translate($rseqori[$i]) if length($rseqori[$i]) == 3; if (length($a) != 1 or $apos - ( $maxflanklen/2 -1) + $i < 1 or $apos - ( $maxflanklen/2 -1) + $i > $aposmax ) { $aaseqori .= " "; } else { $aaseqori .= " ". $a. " "; } my $b = ''; if (length($rseqmut[$i]) == 3) { if ($rseqmut[$i] eq ' ') { $b = "_"; } else { $b = $tr->translate($rseqmut[$i]); } } if (( $b ne $a and length($b) == 1 and $apos - ( $maxflanklen/2 -1) + $i >= 1 ) or ( $apos - ( $maxflanklen/2 -1) + $i >= $aposmax and $mut->label =~ 'termination') ) { $aaseqmut .= " ". $b. " "; } else { $aaseqmut .= " "; } if ($i == 0 and length($rseqori[$i]) != 3) { my $l = 3 - length($rseqori[$i]); $rseqori[$i] = (" " x $l). $rseqori[$i]; $rseqmut[$i] = (" " x $l). $rseqmut[$i]; } $rseqori .= $rseqori[$i]. " " if $rseqori[$i] ne ''; $rseqmut .= $rseqmut[$i]. " " if $rseqmut[$i] ne ''; } # collect the results push (@entry, "\n" ); $text = " ". $aaseqmut; push (@entry, $text ); $text = "Variant : ". $rseqmut; push (@entry, $text ); $text = "Reference: ". $rseqori; push (@entry, $text ); $text = " ". $aaseqori; push (@entry, $text ); push (@entry, "\n" ); } } my $res; foreach my $line (@entry) { $res .= "$line\n"; } return $res; } 1; �������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/SNP.pm����������������������������������������������������������������000444��000765��000024�� 11417�12254227320� 17122� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# bioperl module for Bio::Variation::SNP # # Copyright Allen Day <allenday@ucla.edu>, Stan Nelson <snelson@ucla.edu> # Human Genetics, UCLA Medical School, University of California, Los Angeles =head1 NAME Bio::Variation::SNP - submitted SNP =head1 SYNOPSIS $SNP = Bio::Variation::SNP->new (); =head1 DESCRIPTION Inherits from Bio::Variation::SeqDiff and Bio::Variation::Allele, with additional methods that are (db)SNP specific (ie, refSNP/subSNP IDs, batch IDs, validation methods). =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR Allen Day E<lt>allenday@ucla.eduE<gt> =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::SNP; use strict; use vars qw($AUTOLOAD); use Bio::Root::Root; use base qw(Bio::Variation::SeqDiff Bio::Variation::Allele); =head2 get/set-able methods Usage : $is = $snp->method() Function: for getting/setting attributes Returns : a value. probably a scalar. Args : if you're trying to set an attribute, pass in the new value. Methods: -------- id type observed seq_5 seq_3 ncbi_build ncbi_chr_hits ncbi_ctg_hits ncbi_seq_loc ucsc_build ucsc_chr_hits ucsc_ctg_hits heterozygous heterozygous_SE validated genotype handle batch_id method locus_id symbol mrna protein functional_class =cut #' my %OK_AUTOLOAD = ( id => '', type => '', observed => [], seq_5 => '', seq_3 => '', ncbi_build => '', ncbi_chr_hits => '', ncbi_ctg_hits => '', ncbi_seq_loc => '', ucsc_build => '', ucsc_chr_hits => '', ucsc_ctg_hits => '', heterozygous => '', heterozygous_SE => '', validated => '', genotype => '', handle => '', batch_id => '', method => '', locus_id => '', symbol => '', mrna => '', protein => '', functional_class => '', ); sub AUTOLOAD { my $self = shift; my $param = $AUTOLOAD; $param =~ s/.*:://; $self->throw(__PACKAGE__." doesn't implement $param") unless defined $OK_AUTOLOAD{$param}; if( ref $OK_AUTOLOAD{$param} eq 'ARRAY' ) { push @{$self->{$param}}, shift if @_; return $self->{$param}->[scalar(@{$self->{$param}}) - 1]; } else { $self->{$param} = shift if @_; return $self->{$param}; } } #foreach my $slot (keys %RWSLOT){ # no strict "refs"; #add class methods to package # *$slot = sub { # shift; # $RWSLOT{$slot} = shift if @_; # return $RWSLOT{$slot}; # }; #} =head2 is_subsnp Title : is_subsnp Usage : $is = $snp->is_subsnp() Function: returns 1 if $snp is a subSNP Returns : 1 or undef Args : NONE =cut sub is_subsnp { return shift->{is_subsnp}; } =head2 subsnp Title : subsnp Usage : $subsnp = $snp->subsnp() Function: returns the currently active subSNP of $snp Returns : Bio::Variation::SNP Args : NONE =cut sub subsnp { my $self = shift; return $self->{subsnps}->[ scalar($self->each_subsnp) - 1 ]; } =head2 add_subsnp Title : add_subsnp Usage : $subsnp = $snp->add_subsnp() Function: pushes the previous value returned by subsnp() onto a stack, accessible with each_subsnp(). Sets return value of subsnp() to a new Bio::Variation::SNP object, and returns that object. Returns : Bio::Varitiation::SNP Args : NONE =cut sub add_subsnp { my $self = shift; $self->throw("add_subsnp(): cannot add subSNP to subSNP, only to refSNP") if $self->is_subsnp; my $subsnp = Bio::Variation::SNP->new; push @{$self->{subsnps}}, $subsnp; $self->subsnp->{is_subsnp} = 1; return $self->subsnp; } =head2 each_subsnp Title : each_subsnp Usage : @subsnps = $snp->each_subsnp() Function: returns a list of the subSNPs of a refSNP Returns : list Args : NONE =cut sub each_subsnp { my $self = shift; $self->throw("each_subsnp(): cannot be called on a subSNP") if $self->is_subsnp; return @{$self->{subsnps}}; } 1; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/VariantI.pm�����������������������������������������������������������000444��000765��000024�� 65343�12254227312� 20207� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# # BioPerl module for Bio::Variation::VariantI # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::Variation::VariantI - Sequence Change SeqFeature abstract class =head1 SYNOPSIS #get Bio::Variant::VariantI somehow print $var->restriction_changes, "\n"; foreach $allele ($var->each_Allele) { #work on Bio::Variation::Allele objects } =head1 DESCRIPTION This superclass defines common methods to basic sequence changes. The instantiable classes Bio::Variation::DNAMutation, Bio::Variation::RNAChange and Bio::Variation::AAChange use them. See L<Bio::Variation::DNAMutation>, L<Bio::Variation::RNAChange>, and L<Bio::Variation::AAChange> for more information. These classes store information, heavy computation to detemine allele sequences is done elsewhere. The database cross-references are implemented as Bio::Annotation::DBLink objects. The methods to access them are defined in Bio::DBLinkContainerI. See L<Bio::Annotation::DBLink> and L<Bio::DBLinkContainerI> for details. Bio::Variation::VariantI redifines and extends Bio::SeqFeature::Generic for sequence variations. This class describes specific sequence change events. These events are always from a specific reference sequence to something different. See L<Bio::SeqFeature::Generic> for more information. IMPORTANT: The notion of reference sequence permeates all Bio::Variation classes. This is especially important to remember when dealing with Alleles. In a polymorphic site, there can be a large number of alleles. One of then has to be selected to be the reference allele (allele_ori). ALL the rest has to be passed to the Variant using the method add_Allele, including the mutated allele in a canonical mutation. The IO modules and generated attributes depend on it. They ignore the allele linked to using allele_mut and circulate each Allele returned by each_Allele into allele_mut and calculate the changes between that and allele_ori. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::VariantI; use strict; # Object preamble - inheritance use base qw(Bio::Root::Root Bio::SeqFeature::Generic Bio::DBLinkContainerI); =head2 id Title : id Usage : $obj->id Function: Read only method. Returns the id of the variation object. The id is the id of the first DBLink object attached to this object. Example : Returns : scalar Args : none =cut sub id { my ($self) = @_; my @ids = $self->each_DBLink; my $id = $ids[0] if scalar @ids > 0; return $id->database. "::". $id->primary_id if $id; } =head2 add_Allele Title : add_Allele Usage : $self->add_Allele($allele) Function: Adds one Bio::Variation::Allele into the list of alleles. Note that the method forces the convention that nucleotide sequence is in lower case and amino acds are in upper case. Example : Returns : 1 when succeeds, 0 for failure. Args : Allele object =cut sub add_Allele { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::Allele') ) { my $com = ref $value; $self->throw("Is not a Allele object but a [$com]"); return 0; } else { if ( $self->isa('Bio::Variation::AAChange') ) { $value->seq( uc $value->seq) if $value->seq; } else { $value->seq( lc $value->seq) if $value->seq; } push(@{$self->{'alleles'}},$value); $self->allele_mut($value); #???? return 1; } } else { return 0; } } =head2 each_Allele Title : alleles Usage : $obj->each_Allele(); Function: Returns a list of Bio::Variation::Allele objects Example : Returns : list of Alleles Args : none =cut sub each_Allele{ my ($self,@args) = @_; return @{$self->{'alleles'}}; } =head2 isMutation Title : isMutation Usage : print join('/', $obj->each_Allele) if not $obj->isMutation; Function: Returns or sets the boolean value indicating that the variant descibed is a canonical mutation with two alleles assinged to be the original (wild type) allele and mutated allele, respectively. If this value is not set, it is assumed that the Variant descibes polymorphisms. Returns : a boolean =cut sub isMutation { my ($self,$value) = @_; if (defined $value) { if ($value ) { $self->{'isMutation'} = 1; } else { $self->{'isMutation'} = 0; } } return $self->{'isMutation'}; } =head2 allele_ori Title : allele_ori Usage : $obj->allele_ori(); Function: Links to and returns the Bio::Variation::Allele object. If value is not set, returns false. All other Alleles are compared to this. Amino acid sequences are stored in upper case characters, others in lower case. Example : Returns : string Args : string See L<Bio::Variation::Allele> for more. =cut sub allele_ori { my ($self,$value) = @_; if( defined $value) { if ( ! ref $value || ! $value->isa('Bio::Variation::Allele')) { $self->throw("Value is not Bio::Variation::Allele but [$value]"); } else { if ( $self->isa('Bio::Variation::AAChange') ) { $value->seq( uc $value->seq) if $value->seq; } else { $value->seq( lc $value->seq) if $value->seq; } $self->{'allele_ori'} = $value; } } return $self->{'allele_ori'}; } =head2 allele_mut Title : allele_mut Usage : $obj->allele_mut(); Function: Links to and returns the Bio::Variation::Allele object. Sets and returns the mutated allele sequence. If value is not set, returns false. Amino acid sequences are stored in upper case characters, others in lower case. Example : Returns : string Args : string See L<Bio::Variation::Allele> for more. =cut sub allele_mut { my ($self,$value) = @_; if( defined $value) { if ( ! ref $value || ! $value->isa('Bio::Variation::Allele')) { $self->throw("Value is not Bio::Variation::Allele but [$value]"); } else { if ( $self->isa('Bio::Variation::AAChange') ) { $value->seq( uc $value->seq) if $value->seq; } else { $value->seq( lc $value->seq) if $value->seq; } $self->{'allele_mut'} = $value; } } return $self->{'allele_mut'}; } =head2 length Title : length Usage : $obj->length(); Function: Sets and returns the length of the affected original allele sequence. If value is not set, returns false == 0. Value 0 means that the variant position is before the start=end sequence position. (Value 1 would denote a point mutation). This follows the convension to report an insertion (2insT) in equivalent way to a corresponding deletion (2delT) (Think about indel polymorpism ATC <=> AC where the origianal state is not known ). Example : Returns : string Args : string =cut sub length { my ($self,$value) = @_; if ( defined $value) { $self->{'length'} = $value; } if ( ! exists $self->{'length'} ) { return 0; } return $self->{'length'}; } =head2 upStreamSeq Title : upStreamSeq Usage : $obj->upStreamSeq(); Function: Sets and returns upstream flanking sequence string. If value is not set, returns false. The sequence should be >=25 characters long, if possible. Example : Returns : string or false Args : string =cut sub upStreamSeq { my ($self,$value) = @_; if( defined $value) { $self->{'upstreamseq'} = $value; } return $self->{'upstreamseq'}; } =head2 dnStreamSeq Title : dnStreamSeq Usage : $obj->dnStreamSeq(); Function: Sets and returns dnstream flanking sequence string. If value is not set, returns false. The sequence should be >=25 characters long, if possible. Example : Returns : string or false Args : string =cut sub dnStreamSeq { my ($self,$value) = @_; if( defined $value) { $self->{'dnstreamseq'} = $value; } return $self->{'dnstreamseq'}; } =head2 label Title : label Usage : $obj->label(); Function: Sets and returns mutation event label(s). If value is not set, or no argument is given returns false. Each instantiable class needs to implement this method. Valid values are listed in 'Mutation event controlled vocabulary' in http://www.ebi.ac.uk/mutations/recommendations/mutevent.html. Example : Returns : string Args : string =cut sub label { my ($self,$value) = @_; $self->throw_not_implemented(); } =head2 status Title : status Usage : $obj->status() Function: Returns the status of the sequence change object. Valid values are: 'suspected' and 'proven' Example : $obj->status('proven'); Returns : scalar Args : valid string (optional, for setting) =cut sub status { my ($self,$value) = @_; my %status = (suspected => 1, proven => 1 ); if( defined $value) { $value = lc $value; if ($status{$value}) { $self->{'status'} = $value; } else { $self->throw("$value is not valid status value!"); } } if( ! exists $self->{'status'} ) { return "$self"; } return $self->{'status'}; } =head2 proof Title : proof Usage : $obj->proof() Function: Returns the proof of the sequence change object. Valid values are: 'computed' and 'experimental'. Example : $obj->proof('computed'); Returns : scalar Args : valid string (optional, for setting) =cut sub proof { my ($self,$value) = @_; my %proof = (computed => 1, experimental => 1 ); if( defined $value) { $value = lc $value; if ($proof{$value}) { $self->{'proof'} = $value; } else { $self->throw("$value is not valid proof value!"); } } return $self->{'proof'}; } =head2 region Title : region Usage : $obj->region(); Function: Sets and returns the name of the sequence region type or protein domain at this location. If value is not set, returns false. Example : Returns : string Args : string =cut sub region { my ($self,$value) = @_; if( defined $value) { $self->{'region'} = $value; } return $self->{'region'}; } =head2 region_value Title : region_value Usage : $obj->region_value(); Function: Sets and returns the name of the sequence region_value or protein domain at this location. If value is not set, returns false. Example : Returns : string Args : string =cut sub region_value { my ($self,$value) = @_; if( defined $value) { $self->{'region_value'} = $value; } return $self->{'region_value'}; } =head2 region_dist Title : region_dist Usage : $obj->region_dist(); Function: Sets and returns the distance tot the closest region (i.e. intro/exon or domain) boundary. If distance is not set, returns false. Example : Returns : integer Args : integer =cut sub region_dist { my ($self,$value) = @_; if( defined $value) { if ( not $value =~ /^[+-]?\d+$/ ) { $self->throw("[$value] for region_dist has to be an integer\n"); } else { $self->{'region_dist'} = $value; } } return $self->{'region_dist'}; } =head2 numbering Title : numbering Usage : $obj->numbering() Function: Returns the numbering chema used locating sequnce features. Valid values are: 'entry' and 'coding' Example : $obj->numbering('coding'); Returns : scalar Args : valid string (optional, for setting) =cut sub numbering { my ($self,$value) = @_; my %numbering = (entry => 1, coding => 1 ); if( defined $value) { $value = lc $value; if ($numbering{$value}) { $self->{'numbering'} = $value; } else { $self->throw("'$value' is not a valid for numbering!"); } } if( ! exists $self->{'numbering'} ) { return "$self"; } return $self->{'numbering'}; } =head2 mut_number Title : mut_number Usage : $num = $obj->mut_number; : $num = $obj->mut_number($number); Function: Returns or sets the number identifying the order in which the mutation has been issued. Numbers shouldstart from 1. If the number has never been set, the method will return '' If you want the output from IO modules look nice and, for multivariant/allele variations, make sense you better set this attribute. Returns : an integer =cut sub mut_number { my ($self,$value) = @_; if (defined $value) { $self->{'mut_number'} = $value; } unless (exists $self->{'mut_number'}) { return (''); } else { return $self->{'mut_number'}; } } =head2 SeqDiff Title : SeqDiff Usage : $mutobj = $obj->SeqDiff; : $mutobj = $obj->SeqDiff($objref); Function: Returns or sets the link-reference to the umbrella Bio::Variation::SeqDiff object. If there is no link, it will return undef Note: Adding a variant into a SeqDiff object will automatically set this value. Returns : an obj_ref or undef See L<Bio::Variation::SeqDiff> for more information. =cut sub SeqDiff { my ($self,$value) = @_; if (defined $value) { if( ! $value->isa('Bio::Variation::SeqDiff') ) { $self->throw("Is not a Bio::Variation::SeqDiff object but a [$value]"); return; } else { $self->{'seqDiff'} = $value; } } unless (exists $self->{'seqDiff'}) { return; } else { return $self->{'seqDiff'}; } } =head2 add_DBLink Title : add_DBLink Usage : $self->add_DBLink($ref) Function: adds a link object Example : Returns : Args : =cut sub add_DBLink{ my ($self,$com) = @_; if( $com && ! $com->isa('Bio::Annotation::DBLink') ) { $self->throw("Is not a link object but a [$com]"); } $com && push(@{$self->{'link'}},$com); } =head2 each_DBLink Title : each_DBLink Usage : foreach $ref ( $self->each_DBlink() ) Function: gets an array of DBlink of objects Example : Returns : Args : =cut sub each_DBLink{ my ($self) = @_; return @{$self->{'link'}}; } =head2 restriction_changes Title : restriction_changes Usage : $obj->restriction_changes(); Function: Returns a string containing a list of restriction enzyme changes of form +EcoRI, separated by commas. Strings need to be valid restriction enzyme names as stored in REBASE. allele_ori and allele_mut need to be assigned. Example : Returns : string Args : string =cut sub restriction_changes { my ($self) = @_; if (not $self->{'re_changes'}) { my %re = &_enzymes; # complain if used on AA data if ($self->isa('Bio::Variation::AAChange')) { $self->throw('Restriction enzymes do not bite polypeptides!'); } #sanity checks $self->warn('Upstream sequence is empty!') if $self->upStreamSeq eq ''; $self->warn('Downstream sequence is empty!') if $self->dnStreamSeq eq ''; # $self->warn('Original allele sequence is empty!') # if $self->allele_ori eq ''; # $self->warn('Mutated allele sequence is empty!') # if $self->allele_mut eq ''; #reuse the non empty DNA level list at RNA level if the flanks are identical #Hint: Check DNAMutation object first if ($self->isa('Bio::Variation::RNAChange') and $self->DNAMutation and $self->upStreamSeq eq $self->DNAMutation->upStreamSeq and $self->dnStreamSeq eq $self->DNAMutation->dnStreamSeq and $self->DNAMutation->restriction_changes ne '' ) { $self->{'re_changes'} = $self->DNAMutation->restriction_changes; } else { #maximum length of a type II restriction site in the current REBASE my ($le_dn) = 15; my ($le_up) = $le_dn; #reduce the flank lengths if the desired length is not available $le_dn = CORE::length ($self->dnStreamSeq) if $le_dn > CORE::length ($self->dnStreamSeq); $le_up = CORE::length ($self->upStreamSeq) if $le_up > CORE::length ($self->upStreamSeq); #Build sequence strings to compare my ($oriseq, $mutseq); $oriseq = $mutseq = substr($self->upStreamSeq, -$le_up, $le_up); $oriseq .= $self->allele_ori->seq if $self->allele_ori->seq; $mutseq .= $self->allele_mut->seq if $self->allele_mut->seq; $oriseq .= substr($self->dnStreamSeq, 0, $le_dn); $mutseq .= substr($self->dnStreamSeq, 0, $le_dn); # ... and their reverse complements my $oriseq_rev = _revcompl ($oriseq); my $mutseq_rev = _revcompl ($mutseq); # collect results into a string my $rec = ''; foreach my $enz (sort keys (%re)) { my $site = $re{$enz}; my @ori = ($oriseq=~ /$site/g); my @mut = ($mutseq=~ /$site/g); my @ori_r = ($oriseq_rev =~ /$site/g); my @mut_r = ($mutseq_rev =~ /$site/g); $rec .= '+'. $enz. ", " if (scalar @ori < scalar @mut) or (scalar @ori_r < scalar @mut_r); $rec .= '-'. $enz. ", " if (scalar @ori > scalar @mut) or (scalar @ori_r > scalar @mut_r); } $rec = substr($rec, 0, CORE::length($rec) - 2) if $rec ne ''; $self->{'re_changes'} = $rec; } } return $self->{'re_changes'} } sub _revcompl { # side effect: lower case letters my ($seq) = shift; $seq = lc $seq; $seq =~ tr/acgtrymkswhbvdnx/tgcayrkmswdvbhnx/; return CORE::reverse $seq; } sub _enzymes { #REBASE version 005 type2.005 my %enzymes = ( 'AarI' => 'cacctgc', 'AatII' => 'gacgtc', 'AccI' => 'gt[ac][gt]ac', 'AceIII' => 'cagctc', 'AciI' => 'ccgc', 'AclI' => 'aacgtt', 'AcyI' => 'g[ag]cg[ct]c', 'AflII' => 'cttaag', 'AflIII' => 'ac[ag][ct]gt', 'AgeI' => 'accggt', 'AhaIII' => 'tttaaa', 'AloI' => 'gaac[acgt][acgt][acgt][acgt][acgt][acgt]tcc', 'AluI' => 'agct', 'AlwNI' => 'cag[acgt][acgt][acgt]ctg', 'ApaBI' => 'gca[acgt][acgt][acgt][acgt][acgt]tgc', 'ApaI' => 'gggccc', 'ApaLI' => 'gtgcac', 'ApoI' => '[ag]aatt[ct]', 'AscI' => 'ggcgcgcc', 'AsuI' => 'gg[acgt]cc', 'AsuII' => 'ttcgaa', 'AvaI' => 'c[ct]cg[ag]g', 'AvaII' => 'gg[at]cc', 'AvaIII' => 'atgcat', 'AvrII' => 'cctagg', 'BaeI' => 'ac[acgt][acgt][acgt][acgt]gta[ct]c', 'BalI' => 'tggcca', 'BamHI' => 'ggatcc', 'BbvCI' => 'cctcagc', 'BbvI' => 'gcagc', 'BbvII' => 'gaagac', 'BccI' => 'ccatc', 'Bce83I' => 'cttgag', 'BcefI' => 'acggc', 'BcgI' => 'cga[acgt][acgt][acgt][acgt][acgt][acgt]tgc', 'BciVI' => 'gtatcc', 'BclI' => 'tgatca', 'BetI' => '[at]ccgg[at]', 'BfiI' => 'actggg', 'BglI' => 'gcc[acgt][acgt][acgt][acgt][acgt]ggc', 'BglII' => 'agatct', 'BinI' => 'ggatc', 'BmgI' => 'g[gt]gccc', 'BplI' => 'gag[acgt][acgt][acgt][acgt][acgt]ctc', 'Bpu10I' => 'cct[acgt]agc', 'BsaAI' => '[ct]acgt[ag]', 'BsaBI' => 'gat[acgt][acgt][acgt][acgt]atc', 'BsaXI' => 'ac[acgt][acgt][acgt][acgt][acgt]ctcc', 'BsbI' => 'caacac', 'BscGI' => 'cccgt', 'BseMII' => 'ctcag', 'BsePI' => 'gcgcgc', 'BseRI' => 'gaggag', 'BseSI' => 'g[gt]gc[ac]c', 'BsgI' => 'gtgcag', 'BsiI' => 'cacgag', 'BsiYI' => 'cc[acgt][acgt][acgt][acgt][acgt][acgt][acgt]gg', 'BsmAI' => 'gtctc', 'BsmI' => 'gaatgc', 'Bsp1407I' => 'tgtaca', 'Bsp24I' => 'gac[acgt][acgt][acgt][acgt][acgt][acgt]tgg', 'BspGI' => 'ctggac', 'BspHI' => 'tcatga', 'BspLU11I' => 'acatgt', 'BspMI' => 'acctgc', 'BspMII' => 'tccgga', 'BsrBI' => 'ccgctc', 'BsrDI' => 'gcaatg', 'BsrI' => 'actgg', 'BstEII' => 'ggt[acgt]acc', 'BstXI' => 'cca[acgt][acgt][acgt][acgt][acgt][acgt]tgg', 'BtrI' => 'cacgtc', 'BtsI' => 'gcagtg', 'Cac8I' => 'gc[acgt][acgt]gc', 'CauII' => 'cc[cg]gg', 'Cfr10I' => '[ag]ccgg[ct]', 'CfrI' => '[ct]ggcc[ag]', 'CjeI' => 'cca[acgt][acgt][acgt][acgt][acgt][acgt]gt', 'CjePI' => 'cca[acgt][acgt][acgt][acgt][acgt][acgt][acgt]tc', 'ClaI' => 'atcgat', 'CviJI' => '[ag]gc[ct]', 'CviRI' => 'tgca', 'DdeI' => 'ct[acgt]ag', 'DpnI' => 'gatc', 'DraII' => '[ag]gg[acgt]cc[ct]', 'DraIII' => 'cac[acgt][acgt][acgt]gtg', 'DrdI' => 'gac[acgt][acgt][acgt][acgt][acgt][acgt]gtc', 'DrdII' => 'gaacca', 'DsaI' => 'cc[ag][ct]gg', 'Eam1105I' => 'gac[acgt][acgt][acgt][acgt][acgt]gtc', 'EciI' => 'ggcgga', 'Eco31I' => 'ggtctc', 'Eco47III' => 'agcgct', 'Eco57I' => 'ctgaag', 'EcoNI' => 'cct[acgt][acgt][acgt][acgt][acgt]agg', 'EcoRI' => 'gaattc', 'EcoRII' => 'cc[at]gg', 'EcoRV' => 'gatatc', 'Esp3I' => 'cgtctc', 'EspI' => 'gct[acgt]agc', 'FauI' => 'cccgc', 'FinI' => 'gggac', 'Fnu4HI' => 'gc[acgt]gc', 'FnuDII' => 'cgcg', 'FokI' => 'ggatg', 'FseI' => 'ggccggcc', 'GdiII' => 'cggcc[ag]', 'GsuI' => 'ctggag', 'HaeI' => '[at]ggcc[at]', 'HaeII' => '[ag]gcgc[ct]', 'HaeIII' => 'ggcc', 'HaeIV' => 'ga[ct][acgt][acgt][acgt][acgt][acgt][ag]tc', 'HgaI' => 'gacgc', 'HgiAI' => 'g[at]gc[at]c', 'HgiCI' => 'gg[ct][ag]cc', 'HgiEII' => 'acc[acgt][acgt][acgt][acgt][acgt][acgt]ggt', 'HgiJII' => 'g[ag]gc[ct]c', 'HhaI' => 'gcgc', 'Hin4I' => 'ga[cgt][acgt][acgt][acgt][acgt][acgt][acg]tc', 'HindII' => 'gt[ct][ag]ac', 'HindIII' => 'aagctt', 'HinfI' => 'ga[acgt]tc', 'HpaI' => 'gttaac', 'HpaII' => 'ccgg', 'HphI' => 'ggtga', 'Hpy178III' => 'tc[acgt][acgt]ga', 'Hpy188I' => 'tc[acgt]ga', 'Hpy99I' => 'cg[at]cg', 'KpnI' => 'ggtacc', 'Ksp632I' => 'ctcttc', 'MaeI' => 'ctag', 'MaeII' => 'acgt', 'MaeIII' => 'gt[acgt]ac', 'MboI' => 'gatc', 'MboII' => 'gaaga', 'McrI' => 'cg[ag][ct]cg', 'MfeI' => 'caattg', 'MjaIV' => 'gt[acgt][acgt]ac', 'MluI' => 'acgcgt', 'MmeI' => 'tcc[ag]ac', 'MnlI' => 'cctc', 'MseI' => 'ttaa', 'MslI' => 'ca[ct][acgt][acgt][acgt][acgt][ag]tg', 'MstI' => 'tgcgca', 'MwoI' => 'gc[acgt][acgt][acgt][acgt][acgt][acgt][acgt]gc', 'NaeI' => 'gccggc', 'NarI' => 'ggcgcc', 'NcoI' => 'ccatgg', 'NdeI' => 'catatg', 'NheI' => 'gctagc', 'NlaIII' => 'catg', 'NlaIV' => 'gg[acgt][acgt]cc', 'NotI' => 'gcggccgc', 'NruI' => 'tcgcga', 'NspBII' => 'c[ac]gc[gt]g', 'NspI' => '[ag]catg[ct]', 'PacI' => 'ttaattaa', 'Pfl1108I' => 'tcgtag', 'PflMI' => 'cca[acgt][acgt][acgt][acgt][acgt]tgg', 'PleI' => 'gagtc', 'PmaCI' => 'cacgtg', 'PmeI' => 'gtttaaac', 'PpiI' => 'gaac[acgt][acgt][acgt][acgt][acgt]ctc', 'PpuMI' => '[ag]gg[at]cc[ct]', 'PshAI' => 'gac[acgt][acgt][acgt][acgt]gtc', 'PsiI' => 'ttataa', 'PstI' => 'ctgcag', 'PvuI' => 'cgatcg', 'PvuII' => 'cagctg', 'RleAI' => 'cccaca', 'RsaI' => 'gtac', 'RsrII' => 'cgg[at]ccg', 'SacI' => 'gagctc', 'SacII' => 'ccgcgg', 'SalI' => 'gtcgac', 'SanDI' => 'ggg[at]ccc', 'SapI' => 'gctcttc', 'SauI' => 'cct[acgt]agg', 'ScaI' => 'agtact', 'ScrFI' => 'cc[acgt]gg', 'SduI' => 'g[agt]gc[act]c', 'SecI' => 'cc[acgt][acgt]gg', 'SexAI' => 'acc[at]ggt', 'SfaNI' => 'gcatc', 'SfeI' => 'ct[ag][ct]ag', 'SfiI' => 'ggcc[acgt][acgt][acgt][acgt][acgt]ggcc', 'SgfI' => 'gcgatcgc', 'SgrAI' => 'c[ag]ccgg[ct]g', 'SimI' => 'gggtc', 'SmaI' => 'cccggg', 'SmlI' => 'ct[ct][ag]ag', 'SnaBI' => 'tacgta', 'SnaI' => 'gtatac', 'SpeI' => 'actagt', 'SphI' => 'gcatgc', 'SplI' => 'cgtacg', 'SrfI' => 'gcccgggc', 'Sse232I' => 'cgccggcg', 'Sse8387I' => 'cctgcagg', 'Sse8647I' => 'agg[at]cct', 'SspI' => 'aatatt', 'Sth132I' => 'cccg', 'StuI' => 'aggcct', 'StyI' => 'cc[at][at]gg', 'SwaI' => 'atttaaat', 'TaqI' => 'tcga', 'TaqII' => 'gaccga', 'TatI' => '[at]gtac[at]', 'TauI' => 'gc[cg]gc', 'TfiI' => 'ga[at]tc', 'TseI' => 'gc[at]gc', 'Tsp45I' => 'gt[cg]ac', 'Tsp4CI' => 'ac[acgt]gt', 'TspEI' => 'aatt', 'TspRI' => 'ca[cg]tg[acgt][acgt]', 'Tth111I' => 'gac[acgt][acgt][acgt]gtc', 'Tth111II' => 'caa[ag]ca', 'UbaGI' => 'cac[acgt][acgt][acgt][acgt]gtg', 'UbaPI' => 'cgaacg', 'VspI' => 'attaat', 'XbaI' => 'tctaga', 'XcmI' => 'cca[acgt][acgt][acgt][acgt][acgt][acgt][acgt][acgt][acgt]tgg', 'XhoI' => 'ctcgag', 'XhoII' => '[ag]gatc[ct]', 'XmaIII' => 'cggccg', 'XmnI' => 'gaa[acgt][acgt][acgt][acgt]ttc' ); return %enzymes; } 1; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/IO��������������������������������������������������������������������000755��000765��000024�� 0�12254227327� 16261� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/Bio/Variation/IO/flat.pm������������������������������������������������������������000444��000765��000024�� 50757�12254227327� 17740� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Variation::IO::flat # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Variation::IO::flat - flat file sequence variation input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Variation::IO class. =head1 DESCRIPTION This object can transform Bio::Variation::SeqDiff objects to and from flat file databases. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::IO::flat; use strict; use Text::Wrap; use Bio::Variation::SeqDiff; use Bio::Variation::DNAMutation; use Bio::Variation::RNAChange; use Bio::Variation::AAChange; use Bio::Variation::Allele; use base qw(Bio::Variation::IO); sub new { my($class, @args) = @_; my $self = bless {}, $class; $self->_initialize(@args); return $self; } sub _initialize { my($self,@args) = @_; return unless $self->SUPER::_initialize(@args); } =head2 next Title : next Usage : $haplo = $stream->next() Function: returns the next seqDiff in the stream Returns : Bio::Variation::SeqDiff object Args : NONE =cut sub next { my( $self ) = @_; local $/ = '//'; return unless my $entry = $self->_readline; return if $entry =~ /^\s+$/; $entry =~ /\s*ID\s+\S+/ || $self->throw("We do need an ID!"); my ($id, $offset, $alphabet) = $entry =~ /\s*ID +([^:]+)..(\d+)[^\)]*.\[?([cg])?/ or $self->throw("Can't parse ID line"); # $self->throw("$1|$2|$3"); my $h =Bio::Variation::SeqDiff->new(-id => $id, -offset => $offset, ); if ($alphabet) { if ($alphabet eq 'g') { $alphabet = 'dna'; } elsif ($alphabet eq 'c') { $alphabet = 'rna'; } $h->alphabet($alphabet); } # # DNA # my @dna = split ( / DNA;/, $entry ); shift @dna; my $prevdnaobj; foreach my $dna (@dna) { $dna =~ s/Feature[ \t]+//g; ($dna) = split "RNA; ", $dna; #$self->warn("|$dna|") ; #exit; my ($mut_number, $proof, $location, $upflank, $change, $dnflank) = $dna =~ m|\W+([\d\.]+).+/proof: (\w+).+/location: ([^ \n]+).+/upflank: ([ \n\w]+).+/change: ([^ /]+).+/dnflank: ([ \n\w]+)|s; $change =~ s/[ \n]//g; my ($ori, $mut) = split /[>\|]/, $change; my ($variation_number, $change_number) = split /\./, $mut_number; #$self->warn("|$mut_number|>|$variation_number|$change_number|"); my $dnamut; if ($change_number and $change_number > 1 ) { my $a3 = Bio::Variation::Allele->new; $a3->seq($mut) if $mut; #$dnamut->add_Allele($a3); $prevdnaobj->add_Allele($a3); } else { $upflank =~ s/[ \n]//g; $dnflank =~ s/[ \n]//g; my ($region, $junk, $region_value, $junk2, $region_dist) = $dna =~ m|.+/region: ([\w\']+)(; )?(\w+)?( ?\(\+?)?(-?\d+)?|s; #my $s = join ("|", $mut_number, $proof, $location, $upflank, # $change, $dnflank, $region, $region_value, $region_dist, $1,$2,$3,$4,$5); #$self->warn($s); #exit; my ($start, $sep, $end) = $location =~ /(-?\d+)(.)?\D?(-?\d+)?/; $end = $start if not defined $end ; my ($len) = $end - $start +1; $len = 0, $start = $end if defined $sep and $sep eq '^'; my $ismut = 0; $ismut = 1 if $change =~ m/>/; $dnamut = Bio::Variation::DNAMutation->new ('-start' => $start, '-end' => $end, '-length' => $len, '-upStreamSeq' => $upflank, '-dnStreamSeq' => $dnflank, '-proof' => $proof, '-mut_number' => $mut_number ); $prevdnaobj = $dnamut; my $a1 = Bio::Variation::Allele->new; $a1->seq($ori) if $ori; $dnamut->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq($mut) if $mut; $dnamut->add_Allele($a2); if ($ismut) { $dnamut->isMutation(1); $dnamut->allele_mut($a2); } $dnamut->region($region) if defined $region; $dnamut->region_value($region_value) if defined $region_value; $dnamut->region_dist($region_dist) if defined $region_dist; $h->add_Variant($dnamut); $dnamut->SeqDiff($h); } } # # RNA # my @rna = split ( / RNA;/, $entry ); shift @rna; my $prevrnaobj; foreach my $rna (@rna) { $rna = substr ($rna, 0, index($rna, 'Feature AA')); $rna =~ s/Feature[ \t]+//g; ($rna) = split "DNA; ", $rna; #$self->warn("|$rna|") ; my ($mut_number, $proof, $location, $upflank, $change, $dnflank) = $rna =~ m|\W+([\d\.]+).+/proof: (\w+).+/location: ([^ \n]+).+/upflank: (\w+).+/change: ([^/]+).+/dnflank: (\w+)|s ;#' my ($region, $junk, $region_value, $junk2, $region_dist) = $rna =~ m|.+/region: ([\w\']+)(; )?(\w+)?( ?\(\+?)?(-?\d+)?|s; #my $s = join ("|", $mut_number, $proof, $location, $upflank, # $change, $dnflank, $region, $region_value, $region_dist, $1,$2,$3,$4,$5); #$self->warn($s); #exit; $change =~ s/[ \n]//g; my ($ori, $mut) = split /[>\|]/, $change; my $rnamut; my ($variation_number, $change_number) = split /\./, $mut_number; if ($change_number and $change_number > 1 ) { my $a3 = Bio::Variation::Allele->new; $a3->seq($mut) if $mut; #$rnamut->add_Allele($a3); $prevrnaobj->add_Allele($a3); } else { my ($start, $sep, $end) = $location =~ /(-?\d+)(.)?\D?(-?\d+)?/; $end = $start if not defined $end ; my ($len) = $end - $start + 1; $len = 0, $start = $end if defined $sep and $sep eq '^'; my $ismut; $ismut = 1 if $change =~ m/>/; my ($codon_table) = $rna =~ m|.+/codon_table: (\d+)|s; my ($codon_pos) = $rna =~ m|.+/codon:[^;]+; ([123])|s; $rnamut = Bio::Variation::RNAChange->new ('-start' => $start, '-end' => $end, '-length' => $len, '-upStreamSeq' => $upflank, '-dnStreamSeq' => $dnflank, '-proof' => $proof, '-mut_number' => $mut_number ); $prevrnaobj = $rnamut; my $a1 = Bio::Variation::Allele->new; $a1->seq($ori) if $ori; $rnamut->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq($mut) if $mut; $rnamut->add_Allele($a2); if ($ismut) { $rnamut->isMutation(1); $rnamut->allele_mut($a2); } $rnamut->region($region) if defined $region; $rnamut->region_value($region_value) if defined $region_value; $rnamut->region_dist($region_dist) if defined $region_dist; $rnamut->codon_table($codon_table) if $codon_table; $rnamut->codon_pos($codon_pos) if $codon_pos; $h->add_Variant($rnamut); foreach my $mut ($h->each_Variant) { if ($mut->isa('Bio::Variation::DNAMutation') ) { if ($mut->mut_number == $rnamut->mut_number) { $rnamut->DNAMutation($mut); $mut->RNAChange($rnamut); } } } } } # # AA # my @aa = split ( / AA;/, $entry ); shift @aa; my $prevaaobj; foreach my $aa (@aa) { $aa = substr ($aa, 0, index($aa, 'Feature AA')); $aa =~ s/Feature[ \t]+//g; ($aa) = split "DNA; ", $aa; #$self->warn("|$aa|") ; my ($mut_number, $proof, $location, $change) = $aa =~ m|\W+([\d\.]+).+/proof: (\w+).+/location: ([^ \n]+)./change: ([^/;]+)|s; $change =~ s/[ \n]//g; #my $s = join ("|", $mut_number, $proof, $location, $change); #$self->warn($s); #exit; $change =~ s/[ \n]//g; $change =~ s/DNA$//; my ($ori, $mut) = split /[>\|]/, $change; #print "------$location----$ori-$mut-------------\n"; my ($variation_number, $change_number) = split /\./, $mut_number; my $aamut; if ($change_number and $change_number > 1 ) { my $a3 = Bio::Variation::Allele->new; $a3->seq($mut) if $mut; $prevaaobj->add_Allele($a3); } else { my ($start, $sep, $end) = $location =~ /(-?\d+)(.)?\D?(-?\d+)?/; $end = $start if not defined $end ; my ($len) = $end - $start + 1; $len = 0, $start = $end if defined $sep and $sep eq '^'; my $ismut; $ismut = 1 if $change =~ m/>/; my ($region) = $aa =~ m|.+/region: (\w+)|s ; $aamut = Bio::Variation::AAChange->new ('-start' => $start, '-end' => $end, '-length' => $len, '-proof' => $proof, '-mut_number' => $mut_number ); $prevaaobj = $aamut; my $a1 = Bio::Variation::Allele->new; $a1->seq($ori) if $ori; $aamut->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq($mut) if $mut; $aamut->add_Allele($a2); if ($ismut) { $aamut->isMutation(1); $aamut->allele_mut($a2); } $region && $aamut->region($region); $h->add_Variant($aamut); foreach my $mut ($h->each_Variant) { if ($mut->isa('Bio::Variation::RNAChange') ) { if ($mut->mut_number == $aamut->mut_number) { $aamut->RNAChange($mut); $mut->AAChange($aamut); } } } } } return $h; } =head2 write Title : write Usage : $stream->write(@seqDiffs) Function: writes the $seqDiff object into the stream Returns : 1 for success and 0 for error Args : Bio::Variation::SeqDiff object =cut sub write { my ($self,@h) = @_; #$columns = 75; #default for Text::Wrap my %tag = ( 'ID' => 'ID ', 'Description' => 'Description ', 'FeatureKey' => 'Feature ', 'FeatureQual' => "Feature ", 'FeatureWrap' => "Feature ", 'ErrorComment' => 'Comment ' #'Comment' => 'Comment -!-', #'CommentLine' => 'Comment ', ); if( !defined $h[0] ) { $self->throw("Attempting to write with no information!"); } foreach my $h (@h) { my @entry =(); my ($text, $tmp, $tmp2, $sep); my ($count) = 0; $text = $tag{ID}; $text .= $h->id; $text .= ":(". $h->offset; $text .= "+1" if $h->sysname =~ /-/; $text .= ")". $h->sysname; $text .= "; ". $h->trivname if $h->trivname; push (@entry, $text); #Variants need to be ordered accoding to mutation_number attribute #put them into a hash of arrays holding the Variant objects #This is necessary for cases like several distict mutations present # in the same sequence. my @allvariants = $h->each_Variant; my %variants = (); foreach my $mut ($h->each_Variant) { push @{$variants{$mut->mut_number} }, $mut; } #my ($variation_number, $change_number) = split /\./, $mut_number; foreach my $var (sort keys %variants) { #print $var, ": ", join (" ", @{$variants{$var}}), "\n"; foreach my $mut (@{$variants{$var}}) { # # DNA # if ( $mut->isa('Bio::Variation::DNAMutation') ) { #collect all non-reference alleles $self->throw("allele_ori needs to be defined in [$mut]") if not $mut->allele_ori; if ($mut->isMutation) { $sep = '>'; } else { $sep = '|'; } my @alleles = $mut->each_Allele; #push @alleles, $mut->allele_mut if $mut->allele_mut; my $count = 0; # two alleles foreach my $allele (@alleles) { $count++; my ($variation_number, $change_number) = split /\./, $mut->mut_number; if ($change_number and $change_number != $count){ $mut->mut_number("$change_number.$count"); } $mut->allele_mut($allele); push (@entry, $tag{FeatureKey}. 'DNA'. "; ". $mut->mut_number ); #label $text=$tag{FeatureQual}. '/label: '. $mut->label; push (@entry, $text); #proof if ($mut->proof) { $text = $tag{FeatureQual}. '/proof: '. $mut->proof; push (@entry, $text) ; } #location $text = $tag{FeatureQual}. '/location: '; #$mut->id. '; '. $mut->start; if ($mut->length > 1 ) {# if ($mut->end - $mut->start ) { my $l = $mut->start + $mut->length -1; $text .= $mut->start. '..'. $l; } elsif ($mut->length == 0) { my $tmp_start = $mut->start - 1; $tmp_start-- if $tmp_start == 0; $text .= $tmp_start. '^'. $mut->end; } else { $text .= $mut->start; } if ($h->alphabet && $h->alphabet eq 'dna') { $tmp = $mut->start + $h->offset; $tmp-- if $tmp <= 0; $mut->start < 1 && $tmp++; #$text.= ' ('. $h->id. '::'. $tmp; $tmp2 = $mut->end + $h->offset; if ( $mut->length > 1 ) { $mut->end < 1 && $tmp2++; $text.= ' ('. $h->id. '::'. $tmp. "..". $tmp2; } elsif ($mut->length == 0) { $tmp--; $tmp-- if $tmp == 0; $text .= ' ('. $h->id. '::'. $tmp. '^'. $tmp2; } else { $text.= ' ('. $h->id. '::'. $tmp; } $text .= ')'; } push (@entry, $text); #sequence push (@entry, $tag{FeatureQual}. '/upflank: '. $mut->upStreamSeq ); $text = ''; $text = $mut->allele_ori->seq if $mut->allele_ori->seq; $text .= $sep; $text .= $mut->allele_mut->seq if $mut->allele_mut->seq; push (@entry, wrap($tag{FeatureQual}. '/change: ', $tag{FeatureWrap}, $text) ); push (@entry, $tag{FeatureQual}. '/dnflank: '. $mut->dnStreamSeq ); #restriction enzyme if ($mut->restriction_changes ne '') { $text = $mut->restriction_changes; $text = wrap($tag{FeatureQual}. '/re_site: ', $tag{FeatureWrap}, $text); push (@entry, $text ); } #region if ($mut->region ) { $text = $tag{FeatureQual}. '/region: '. $mut->region; $text .= ';' if $mut->region_value or $mut->region_dist; $text .= ' '. $mut->region_value if $mut->region_value; if ($mut->region_dist ) { $tmp = ''; $tmp = '+' if $mut->region_dist > 1; $text .= " (". $tmp. $mut->region_dist. ')'; } push (@entry, $text); } #CpG if ($mut->CpG) { push (@entry, $tag{FeatureQual}. "/CpG" ); } } } # # RNA # elsif ($mut->isa('Bio::Variation::RNAChange') ) { #collect all non-reference alleles $self->throw("allele_ori needs to be defined in [$mut]") if not $mut->allele_ori; my @alleles = $mut->each_Allele; #push @alleles, $mut->allele_mut if $mut->allele_mut; if ($mut->isMutation) { $sep = '>'; } else { $sep = '|'; } my $count = 0; # two alleles foreach my $allele (@alleles) { $count++; my ($variation_number, $change_number) = split /\./, $mut->mut_number; if ($change_number and $change_number != $count){ $mut->mut_number("$change_number.$count"); } $mut->allele_mut($allele); push (@entry, $tag{FeatureKey}. 'RNA'. "; ". $mut->mut_number ); #label $text=$tag{FeatureQual}. '/label: '. $mut->label; push (@entry, $text); #proof if ($mut->proof) { $text = $tag{FeatureQual}. '/proof: '. $mut->proof; push (@entry, $text) ; } #location $text = $tag{FeatureQual}. '/location: ' ; if ($mut->length > 1 ) { $text .= $mut->start. '..'. $mut->end; $tmp2 = $mut->end + $h->offset; } elsif ($mut->length == 0) { my $tmp_start = $mut->start; $tmp_start--; $tmp_start-- if $tmp_start == 0; $text .= $tmp_start. '^'. $mut->end; } else { $text .= $mut->start; } if ($h->alphabet && $h->alphabet eq 'rna') { $tmp = $mut->start + $h->offset; $tmp-- if $tmp <= 0; #$mut->start < 1 && $tmp++; #$text.= ' ('. $h->id. '::'. $tmp; $tmp2 = $mut->end + $h->offset; #$mut->end < 1 && $tmp2++; if ( $mut->length > 1 ) { $text.= ' ('. $h->id. '::'. $tmp. "..". $tmp2; } elsif ($mut->length == 0) { $tmp--; $text .= ' ('. $h->id. '::'. $tmp. '^'. $tmp2; } else { $text.= ' ('. $h->id. '::'. $tmp; } $text .= ')'; } push (@entry, $text); #sequence push (@entry, $tag{FeatureQual}. '/upflank: '. $mut->upStreamSeq ); $text = ''; $text = $mut->allele_ori->seq if $mut->allele_ori->seq; $text .= $sep; $text .= $mut->allele_mut->seq if $mut->allele_mut->seq; push (@entry, wrap($tag{FeatureQual}. '/change: ', $tag{FeatureWrap}, $text) ); push (@entry, $tag{FeatureQual}. '/dnflank: '. $mut->dnStreamSeq ); #restriction if ($mut->restriction_changes ne '') { $text = $mut->restriction_changes; $text = wrap($tag{FeatureQual}. '/re_site: ', $tag{FeatureWrap}, $text); push (@entry, $text ); } #coding if ($mut->region eq 'coding') { #codon table $text = $tag{FeatureQual}. '/codon_table: '; $text .= $mut->codon_table; push (@entry, $text); #codon $text = $tag{FeatureQual}. '/codon: '. $mut->codon_ori. $sep; if ($mut->DNAMutation->label =~ /.*point/) { $text .= $mut->codon_mut; } else { $text .= '-'; } $text .= "; ". $mut->codon_pos; push (@entry, $text); } #region if ($mut->region ) { $text = $tag{FeatureQual}. '/region: '. $mut->region; $text .= ';' if $mut->region_value or $mut->region_dist; $text .= ' '. $mut->region_value if $mut->region_value; if ($mut->region_dist ) { $tmp = ''; $tmp = '+' if $mut->region_dist > 1; $text .= " (". $tmp. $mut->region_dist. ')'; } push (@entry, $text); } } } # # AA # elsif ($mut->isa('Bio::Variation::AAChange')) { #collect all non-reference alleles $self->throw("allele_ori needs to be defined in [$mut]") if not $mut->allele_ori; if ($mut->isMutation) { $sep = '>'; } else { $sep = '|'; } my @alleles = $mut->each_Allele; #push @alleles, $mut->allele_mut if $mut->allele_mut; my $count = 0; # two alleles foreach my $allele (@alleles) { $count++; my ($variation_number, $change_number) = split /\./, $mut->mut_number; if ($change_number and $change_number != $count){ $mut->mut_number("$change_number.$count"); } $mut->allele_mut($allele); push (@entry, $tag{FeatureKey}. 'AA'. "; ". $mut->mut_number ); #label $text=$tag{FeatureQual}. '/label: '. $mut->label; push (@entry, $text) ; #proof if ($mut->proof) { $text = $tag{FeatureQual}. '/proof: '. $mut->proof; push (@entry, $text) ; } #location $text = $tag{FeatureQual}. '/location: '. #$mut->id. '; '. $mut->start; $mut->start; if ($mut->length > 1 ) { $tmp = $mut->start + $mut->length -1; $text .= '..'. $tmp; } push (@entry, $text); #sequence $text = ''; $text = $mut->allele_ori->seq if $mut->allele_ori->seq; $text .= $sep; $text .= $mut->allele_mut->seq if $mut->allele_mut->seq; push (@entry, wrap($tag{FeatureQual}. '/change: ', $tag{FeatureWrap}, $text) ); #region if ($mut->region ) { $text = $tag{FeatureQual}. '/region: '. $mut->region; $text .= ';' if $mut->region_value or $mut->region_dist; $text .= ' '. $mut->region_value if $mut->region_value; if ($mut->region_dist ) { $tmp = ''; $tmp = '+' if $mut->region_dist > 1; $text .= " (". $tmp. $mut->region_dist. ')'; } push (@entry, $text); } } } } } push (@entry, "//" ); my $str = join ("\n", @entry). "\n"; $str =~ s/\t/ /g; $self->_print($str); } return 1; } 1; �����������������BioPerl-1.6.923/Bio/Variation/IO/xml.pm�������������������������������������������������������������000444��000765��000024�� 34660�12254227317� 17604� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# BioPerl module for Bio::Variation::IO::xml # # Please direct questions and support issues to <bioperl-l@bioperl.org> # # Cared for by Heikki Lehvaslaiho <heikki-at-bioperl-dot-org> # # Copyright Heikki Lehvaslaiho # # You may distribute this module under the same terms as perl itself # # POD documentation - main docs before the code =head1 NAME Bio::Variation::IO::xml - XML sequence variation input/output stream =head1 SYNOPSIS Do not use this module directly. Use it via the Bio::Variation::IO class. =head1 DESCRIPTION This object can transform L<Bio::Variation::SeqDiff> objects to and from XML file databases. The XML format, although consistent, is still evolving. The current DTD for it is at L<http://www.ebi.ac.uk/mutations/DTDE/seqDiff.dtd>. =head1 REQUIREMENTS To use this code you need the module L<XML::Twig> which creates an interface to L<XML::Parser> to read XML and modules L<XML::Writer> and L<IO::String> to write XML out. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to the Bioperl mailing lists Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Support Please direct usage questions or support issues to the mailing list: I<bioperl-l@bioperl.org> rather than to the module maintainer directly. Many experienced and reponsive experts will be able look at the problem and quickly address it. Please include a thorough description of the problem with code and data examples if at all possible. =head2 Reporting Bugs report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::Variation::IO::xml; use vars qw($seqdiff $var $prevdnaobj $prevrnaobj $prevaaobj); use strict; use XML::Twig; use XML::Writer 0.4; use IO::String; use Bio::Variation::SeqDiff; use Bio::Variation::DNAMutation; use Bio::Variation::RNAChange; use Bio::Variation::AAChange; use Bio::Variation::Allele; use base qw(Bio::Variation::IO); # _initialize is where the heavy stuff will happen when new is called sub new { my ($class,@args) = @_; my $self = bless {}, $class; $self->_initialize(@args); return $self; } sub _initialize { my($self,@args) = @_; return unless $self->SUPER::_initialize(@args); } =head2 next Title : next Usage : $haplo = $stream->next() Function: returns the next seqDiff in the stream Returns : Bio::Variation::SeqDiff object Args : NONE =cut sub _seqDiff { my ($t, $term)= @_; $seqdiff->id( $term->att('id') ); $seqdiff->alphabet( $term->att('moltype') ); $seqdiff->offset( $term->att('offset') ); foreach my $child ($term->children) { _variant($t, $child); } } sub _variant { my ($t, $term)= @_; my $var; my $att = $term->atts(); my ($variation_number, $change_number) = split /\./, $att->{number}; # if more than two alleles if ($variation_number and $change_number and $change_number > 1 ) { my $a3 = Bio::Variation::Allele->new; $a3->seq( $term->first_child_text('allele_mut') ) if $term->first_child_text('allele_mut'); if ($term->gi eq 'DNA') { $prevdnaobj->add_Allele($a3); } elsif ($term->gi eq 'RNA') { $prevrnaobj->add_Allele($a3); } else { # AA $prevaaobj->add_Allele($a3); } } else { # create new variants if ($term->gi eq 'DNA') { $var = Bio::Variation::DNAMutation->new(); } elsif ($term->gi eq 'RNA') { $var = Bio::Variation::RNAChange->new(); } else { # AA $var = Bio::Variation::AAChange->new(); } # these are always present $var->start( $att->{start} ); $var->end( $att->{end}); $var->length($att->{len}); $var->mut_number( $att->{number}); $var->upStreamSeq($term->first_child_text('upFlank')); $var->dnStreamSeq($term->first_child_text('dnFlank')); $var->proof($term->first_child_text('proof')); # region my $region = $term->first_child('region'); if ($region) { $var->region($region->text); my $region_atts = $region->atts; $var->region_value( $region_atts->{value} ) if $region_atts->{value}; $var->region_dist( $region_atts->{dist} ) if $region_atts->{dist}; } # alleles my $a1 = Bio::Variation::Allele->new; $a1->seq($term->first_child_text('allele_ori') ) if $term->first_child_text('allele_ori'); $var->allele_ori($a1); my $a2 = Bio::Variation::Allele->new; $a2->seq($term->first_child_text('allele_mut') ) if $term->first_child_text('allele_mut'); $var->isMutation(1) if $term->att('isMutation'); $var->allele_mut($a2); $var->add_Allele($a2); $var->length( $term->att('length') ); $seqdiff->add_Variant($var); # variant specific code if ($term->gi eq 'DNA') { $prevdnaobj = $var; } elsif ($term->gi eq 'RNA') { my $codon = $term->first_child('codon'); if ($codon) { my $codon_atts = $codon->atts; $var->codon_table( $codon->att('codon_table') ) if $codon_atts->{codon_table} and $codon_atts->{codon_table} != 1; $var->codon_pos( $codon->att('codon_pos') ) if $codon_atts->{codon_pos}; } $prevdnaobj->RNAChange($var); $var->DNAMutation($prevdnaobj); $prevrnaobj = $var; } else { $prevrnaobj->AAChange($var); $var->RNAChange($prevrnaobj); $prevaaobj = $var; } } } sub next { my( $self ) = @_; local $/ = "</seqDiff>\n"; return unless my $entry = $self->_readline; # print STDERR "|$entry|"; return unless $entry =~ /^\W*<seqDiff/; $seqdiff = Bio::Variation::SeqDiff->new; # create new parser object my $twig_handlers = {'seqDiff' => \&_seqDiff }; my $t = XML::Twig->new ( TwigHandlers => $twig_handlers, KeepEncoding => 1 ); $t->parse($entry); return $seqdiff; } =head2 write Title : write Usage : $stream->write(@haplos) Function: writes the $seqDiff objects into the stream Returns : 1 for success and 0 for error Args : Bio::Variation::SeqDiff object =cut sub write { my ($self,@h) = @_; if( !defined $h[0] ) { $self->throw("Attempting to write with no information!"); } my $str; my $output = IO::String->new($str); my $w = XML::Writer->new(OUTPUT => $output, DATA_MODE => 1, DATA_INDENT => 4 ); foreach my $h (@h) { # # seqDiff # $h->alphabet || $self->throw("Moltype of the reference sequence is not set!"); my $hasAA = 0; foreach my $mut ($h->each_Variant) { $hasAA = 1 if $mut->isa('Bio::Variation::AAChange'); } if ($hasAA) { $w->startTag("seqDiff", "id" => $h->id, "moltype" => $h->alphabet, "offset" => $h->offset, "sysname" => $h->sysname, "trivname" => $h->trivname ); } else { $w->startTag("seqDiff", "id" => $h->id, "moltype" => $h->alphabet, "offset" => $h->offset, "sysname" => $h->sysname ); } my @allvariants = $h->each_Variant; #print "allvars:", scalar @allvariants, "\n"; my %variants = (); foreach my $mut ($h->each_Variant) { #print STDERR $mut->mut_number, "\t", $mut, "\t", #$mut->proof, "\t", scalar $mut->each_Allele, "\n"; push @{$variants{$mut->mut_number} }, $mut; } foreach my $var (sort keys %variants) { foreach my $mut (@{$variants{$var}}) { # # DNA # if( $mut->isa('Bio::Variation::DNAMutation') ) { $mut->isMutation(0) if not $mut->isMutation; my @alleles = $mut->each_Allele; my $count = 0; foreach my $allele (@alleles) { $count++; my ($variation_number, $change_number) = split /\./, $mut->mut_number; if ($change_number and $change_number != $count){ $mut->mut_number("$change_number.$count"); } $mut->allele_mut($allele); $w->startTag("DNA", "number" => $mut->mut_number, "start" => $mut->start, "end" => $mut->end, "length" => $mut->length, "isMutation" => $mut->isMutation ); if ($mut->label) { foreach my $label (split ', ', $mut->label) { $w->startTag("label"); $w->characters($label); $w->endTag; } } if ($mut->proof) { $w->startTag("proof"); $w->characters($mut->proof ); $w->endTag; } if ($mut->upStreamSeq) { $w->startTag("upFlank"); $w->characters($mut->upStreamSeq ); $w->endTag; } #if ( $mut->isMutation) { #if ($mut->allele_ori) { $w->startTag("allele_ori"); $w->characters($mut->allele_ori->seq) if $mut->allele_ori->seq ; $w->endTag; #} #if ($mut->allele_mut) { $w->startTag("allele_mut"); $w->characters($mut->allele_mut->seq) if $mut->allele_mut->seq; $w->endTag; #} #} if ($mut->dnStreamSeq) { $w->startTag("dnFlank"); $w->characters($mut->dnStreamSeq ); $w->endTag; } if ($mut->restriction_changes) { $w->startTag("restriction_changes"); $w->characters($mut->restriction_changes); $w->endTag; } if ($mut->region) { if($mut->region_value and $mut->region_dist) { $w->startTag("region", "value" => $mut->region_value, "dist" => $mut->region_dist ); } elsif($mut->region_value) { $w->startTag("region", "value" => $mut->region_value ); } elsif($mut->region_dist) { $w->startTag("region", "dist" => $mut->region_dist ); } else { $w->startTag("region"); } $w->characters($mut->region ); $w->endTag; } $w->endTag; #DNA } } # # RNA # elsif( $mut->isa('Bio::Variation::RNAChange') ) { $mut->isMutation(0) if not $mut->isMutation; my @alleles = $mut->each_Allele; my $count = 0; foreach my $allele (@alleles) { $count++; my ($variation_number, $change_number) = split /\./, $mut->mut_number; if ($change_number and $change_number != $count){ $mut->mut_number("$change_number.$count"); } $mut->allele_mut($allele); $w->startTag("RNA", "number" => $mut->mut_number, "start" => $mut->start, "end" => $mut->end, "length" => $mut->length, "isMutation" => $mut->isMutation ); if ($mut->label) { foreach my $label (split ', ', $mut->label) { $w->startTag("label"); $w->characters($label ); $w->endTag; } } if ($mut->proof) { $w->startTag("proof"); $w->characters($mut->proof ); $w->endTag; } if ($mut->upStreamSeq) { $w->startTag("upFlank"); $w->characters($mut->upStreamSeq ); $w->endTag; } #if ( $mut->isMutation) { if ($mut->allele_ori) { $w->startTag("allele_ori"); $w->characters($mut->allele_ori->seq) if $mut->allele_ori->seq ; $w->endTag; } if ($mut->allele_mut) { $w->startTag("allele_mut"); $w->characters($mut->allele_mut->seq) if $mut->allele_mut->seq ; $w->endTag; } #} if ($mut->dnStreamSeq) { $w->startTag("dnFlank"); $w->characters($mut->dnStreamSeq ); $w->endTag; } if ($mut->region eq 'coding') { if (! $mut->codon_mut) { $w->startTag("codon", "codon_ori" => $mut->codon_ori, "codon_pos" => $mut->codon_pos ); } else { $w->startTag("codon", "codon_ori" => $mut->codon_ori, "codon_mut" => $mut->codon_mut, "codon_pos" => $mut->codon_pos ); } $w->endTag; } if ($mut->codon_table != 1) { $w->startTag("codon_table"); $w->characters($mut->codon_table); $w->endTag; } if ($mut->restriction_changes) { $w->startTag("restriction_changes"); $w->characters($mut->restriction_changes); $w->endTag; } if ($mut->region) { if($mut->region_value and $mut->region_dist) { $w->startTag("region", "value" => $mut->region_value, "dist" => $mut->region_dist ); } elsif($mut->region_value) { $w->startTag("region", "value" => $mut->region_value ); } elsif($mut->region_dist) { $w->startTag("region", "dist" => $mut->region_dist ); } else { $w->startTag("region"); } $w->characters($mut->region ); $w->endTag; } $w->endTag; #RNA } } # # AA # elsif( $mut->isa('Bio::Variation::AAChange') ) { $mut->isMutation(0) if not $mut->isMutation; my @alleles = $mut->each_Allele; my $count = 0; foreach my $allele (@alleles) { $count++; my ($variation_number, $change_number) = split /\./, $mut->mut_number; if ($change_number and $change_number != $count){ $mut->mut_number("$change_number.$count"); } $mut->allele_mut($allele); $w->startTag("AA", "number" => $mut->mut_number, "start" => $mut->start, "end" => $mut->end, "length" => $mut->length, "isMutation" => $mut->isMutation ); if ($mut->label) { foreach my $label (split ', ', $mut->label) { $w->startTag("label"); $w->characters($label ); $w->endTag; } } if ($mut->proof) { $w->startTag("proof"); $w->characters($mut->proof ); $w->endTag; } #if ( $mut->isMutation) { if ($mut->allele_ori) { $w->startTag("allele_ori"); $w->characters($mut->allele_ori->seq) if $mut->allele_ori->seq; $w->endTag; } if ($mut->allele_mut) { $w->startTag("allele_mut"); $w->characters($mut->allele_mut->seq) if $mut->allele_mut->seq; $w->endTag; } #} if ($mut->region) { if($mut->region_value and $mut->region_dist) { $w->startTag("region", "value" => $mut->region_value, "dist" => $mut->region_dist ); } elsif($mut->region_value) { $w->startTag("region", "value" => $mut->region_value ); } elsif($mut->region_dist) { $w->startTag("region", "dist" => $mut->region_dist ); } else { $w->startTag("region"); } $w->characters($mut->region ); $w->endTag; } $w->endTag; #AA } } } } } $w->endTag; $w->end; $self->_print($str); $output = undef; return 1; } 1; ��������������������������������������������������������������������������������BioPerl-1.6.923/doc���������������������������������������������������������������������������������000755��000765��000024�� 0�12254227336� 14052� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/makedoc.PL����������������������������������������������������������������������000555��000765��000024�� 273�12254227336� 16034� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use lib "."; use strict; require Bio::Root::Version; foreach ( @ARGV ) { `perl -pi -e 's/\\\@\\\@VERSION\\\@\\\@/$Bio::Root::Version::VERSION/g;' "$_"`; } __END__ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/README��������������������������������������������������������������������������000444��000765��000024�� 144�12254227336� 15046� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������For HOWTOs, tutorials, and module documentation please see the BioPerl Wiki at http://bioperl.org. ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator��������������������������������������������������������������������000755��000765��000024�� 0�12254227340� 16465� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/Build.PL�����������������������������������������������������������000555��000765��000024�� 1123�12254227335� 20122� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Deobfuscator', license => 'perl', dist_author => 'Dave Messina <dave-pause@davemessina.net>', dist_version_from => 'lib/Deobfuscator.pm', script_files => ['bin/deob_index.pl',], requires => { 'Test::More' => 0, 'version' => 0, 'Class::Inspector' => 0, 'DB_File' => 0, 'CGI' => 0, }, add_to_cleanup => [ 'Deobfuscator-*' ], ); $builder->create_build_script(); ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/Changes������������������������������������������������������������000444��000765��000024�� 6751�12254227340� 20126� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Revision history for Deobfuscator 0.0.1 Fri Apr 7 14:34:50 2006 Initial release. 0.0.2 Mon Apr 24 13:27:52 CDT 2006 NEW: Laura's cool flowchart added, which shows how the Deobfuscator works. Updated README and deob_help.html to reflect that. FIX: Cryptic "Can't close MODS file" error message rewritten. NEW: Indulged my POD formatting obsession. Again. (Lots of minor updates to the POD) NEW: Added Feedback section to deob_help.html. NEW: Added DOCUMENTATION section to README. FIX: "About the mailing lists" URL changed throughout. 0.0.3 Mon Oct 2 20:01:45 CDT 2006 FIX: change default $deob_detail_path to be a relative URL instead of having localhost hardcoded. Thanks to Jason Stajich for pointing this out. FIX: Bio::Ontology modules are no longer missing their prefix in the class list, and their methods are now shown in the lower pane as expected. Thanks to Hilmar Lapp for reporting this bug. FIX: can now handle (and ignore) VERSION POD section. FIX: missing SYNOPSIS section now handled properly. In fact, the SYNOPSIS and DESCRIPTION sections can be in reverse order now, although for consistency this is not recommended. FIX: Bug #2114: "Obfuscator doesn't show "Bio:Matrix:Generic" has been fixed. This bug turned out to afflict multiple modules, which weren't getting parsed correctly by deob_index.pl. NEW: Table cells have been padded out to get rid of that "scrunched" look. Thanks to Sendu Bala for this great suggestion. NEW: If the 'Returns' subsection of a method's documentation contains a POD L<> link, the Deobfuscator assumes this to be a package name, and wraps it in an href for display. This feature is not robust, but seems to work well enough for now. NEW: the list of classes is now sorted alphabetically depth-first, so that subclasses appear just after their parent class. Thanks to Amir Karger for noticing the strange sorting behavior. NEW: HTML page title now 'BioPerl Deobfuscator' to distinguish it from other Deobfuscators out there. Thanks to Amir Karger for suggesting this. NEW: 'No match' search string now more prominent. Yep, kudos to Amir Karger again -- another great idea! NEW: Search box caption now explicitly states that only package names can be searched. Big ups to Amir Karger for this suggestion. The ability to search method names is planned for a future version. NEW: added -x option to deob_index.pl. This allows the use of an 'excluded modules' file. This feature was added to resolve an issue with four modules which rely on external modules to compile. Class::Inspector, used by the Deobfuscator needs to load a module to traverse its inheritance tree, and modules must compile before they can be loaded. CHANGE: using short name now when traversing with File::Find to help identify excluded modules (deob_index.pl). Added since 0.0.3: NEW: deob_index.pl can now accept relative paths for BioPerl lib dir and output dir NEW: -s <version_string> option now can be passed to deob_index.pl to store a version string in packages.db which deob_interface.cgi can read and show. �����������������������BioPerl-1.6.923/doc/Deobfuscator/excluded_modules.txt�����������������������������������������������000444��000765��000024�� 1175�12254227314� 22715� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Excluded Modules file for the BioPerl Deobfuscator # # Module to be excluded from indexing should be listed here as a path, # each on its own line. # # Blank lines and lines starting with '#' are ignored. # Module names are matched by a right-end-anchored regular expression # (i.e. /Module.pm$/ ), so the shortest unique path is probably best. # Example: Bio/Tools/pSW.pm # # $Id$ # # The modules below are excluded because they require external dependencies # to compile (e.g. bioperl-ext), and Class::Inspector can't load modules it # can't compile. Bio/SearchDist.pm Bio/Tools/AlignFactory.pm Bio/Tools/dpAlign.pm Bio/Tools/pSW.pm���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/LICENSE������������������������������������������������������������000444��000765��000024�� 50101�12254227314� 17645� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Terms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS --------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/Makefile.PL��������������������������������������������������������000555��000765��000024�� 1244�12254227315� 20602� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Deobfuscator', AUTHOR => 'Dave Messina <dave-pause@davemessina.net>', VERSION_FROM => 'lib/Deobfuscator.pm', ABSTRACT_FROM => 'lib/Deobfuscator.pm', EXE_FILES => ['bin/deob_index.pl',], PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, 'version' => 0, 'Class::Inspector' => 0, 'DB_File' => 0, 'CGI' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Deobfuscator-*' }, ); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/MANIFEST�����������������������������������������������������������000444��000765��000024�� 424�12254227336� 17740� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Build.PL Changes excluded_modules.txt LICENSE MANIFEST META.yml # Will be created by "make dist" Makefile.PL README bin/deob_index.pl cgi-bin/deob_detail.cgi cgi-bin/deob_flowchart.png cgi-bin/deob_interface.cgi cgi-bin/deob_help.html lib/Deobfuscator.pm t/00.load.t t/pod.t ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/META.yml�����������������������������������������������������������000444��000765��000024�� 757�12254227324� 20066� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Deobfuscator version: v0.0.3 version_from: lib/Deobfuscator.pm installdirs: site requires: CGI: 0 Class::Inspector: 0 DB_File: 0 Test::More: 0 version: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30 �����������������BioPerl-1.6.923/doc/Deobfuscator/README�������������������������������������������������������������000444��000765��000024�� 10526�12254227313� 17526� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Deobfuscator version 0.0.3 The Deobfuscator was written to make it easier to determine the methods that are available from a given BioPerl module. BioPerl is a highly object-oriented software package, with often multiple levels of inheritance. Although each individual module is usually well documented for the methods specific to it, identifying the inherited methods is less straightforward. The Deobfuscator indexes all of the BioPerl POD documentation, taking account of the inheritance tree, and then presents all of the methods available to each module through a searchable web interface. DOCUMENTATION All of the code in this distribution have POD documentation, which can be read using the perldoc command. For example, perldoc lib/Deobfuscator.pm will show the POD documentation for the Deobfuscator module. Also, there are two files in the cgi-bin directory which may be helpful: cgi-bin/deob_help.html cgi-bin/deob_flowchart.png INSTALLATION Installation of the Deobfuscator package requires a little bit more than a typical CPAN module because there are some cgi scripts, and these need to be placed in a directory accessible to a webserver. Follow these steps to install the Deobfuscator on your system: 1) Follow the standard CPAN installation procedure to install the Deobfuscator.pm module and the deob_index.pl program. Run the following commands: perl Makefile.PL make make test make install Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL ./Build ./Build test ./Build install 2) Copy the contents of the cgi-bin directory to your cgi-bin directory, or any directory from which the webserver allows scripts to be executed over the web. 3) Make sure deob_interface.cgi and deob_detail.cgi are world-executable. On a UNIX system, the command chmod o+x deob_interface.cgi deob_detail.cgi should do it. 4) Run deob_index.pl. For a default installation, run it from your webserver's cgi-bin directory. On UNIX systems, it should be something like: cd /Library/WebServer/CGI-Executables deob_index.pl /Library/Perl/5.8.6/Bio . When the command finishes, it should show you some stats on the indexing. On my system it looked like this for BioPerl 1.5.1: This indexing run found: 803 files 798 pkg_name 772 desc 788 synopsis 5660 methods If the number of files is much lower than this (like 0), then deob_index.pl may have been pointed to the wrong directory. There should also be some new files in the directory you ran it from: packages.db methods.db package_list.txt deob_index.log You can move or delete deob_index.log and the Deobfuscator should still work, but the other three files need to be in the same directory as deob_interface.cgi and deob_index.cgi unless you change the hardcoded variables in those scripts. See their documentation if you want to do that. 5) Test your installation by pointing your browser to the deob_interface.cgi script. On my system, the URL is: http://localhost/cgi-bin/deob_interface.cgi If you get an error, check the permissions on the cgi-scripts and the files that deob_index.pl created in the last step. Your webserver error log may also be helpful. If you moved any of the files outside of your webserver's cgi-bin directory, make sure that the hardcoded variables in deob_interface.cgi point to their new location. The BioPerl code itself (the modules) need to be in the @INC (PERL5LIB) of the user running the Deobfuscator itself. (Class::Inspector, used under the hood by the Deobfuscator, must be able to 'use' a module in order to find its methods.) You may need to add a 'use lib' directive at the beginning of deob_interface.cgi. 6) That should be it! As always, check the POD documentation in the individual files for more information. And if you have comments, suggesions, or problems, send an email to the BioPerl mailing list <bioperl-l@bioperl.org>. DEPENDENCIES - version Available from CPAN. - Class::Inspector Available from CPAN. - Test::Pod Available from CPAN. - BioPerl Tested with v1.5.1, but other versions should work too. Get the latest from http://www.bioperl.org. COPYRIGHT AND LICENSE Copyright (C) 2006, Dave Messina and Laura Kavanaugh This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/bin����������������������������������������������������������������000755��000765��000024�� 0�12254227340� 17235� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/bin/deob_index.pl��������������������������������������������������000555��000765��000024�� 57235�12254227340� 22066� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # deob_index.pl # part of the Deobfuscator package # by Laura Kavanaugh and Dave Messina # # cared for by Dave Messina <dave-pause@davemessina.net> # # POD documentation - main docs before the code =head1 NAME deob_index.pl - extracts BioPerl documentation and indexes it in a database for easy retrieval =head1 VERSION This document describes deob_index.pl version 0.0.3 =head1 SYNOPSIS deob_index.pl <path to BioPerl lib> <output path> =over =item <path to BioPerl lib> a directory path pointing to the root of the BioPerl lib tree. e.g. /export/share/lib/perl5/site_perl/5.8.7/Bio/ =item <output path> where you would like deob_index.pl to put its output files. =back =head1 DESCRIPTION deob_index.pl goes through the entire BioPerl library tree looking for .pm and .pl files. For each one it finds, it tries to extract module-level POD documentation (e.g. SYNOPSIS, DESCRIPTION) and store it in a BerkeleyDB. It also tries to extract documentation for each method in the module and store that in a separate BerkeleyDB. Specific parts of the documentation for a module or method may be retrieved individually using the functions available in Deobfuscator.pm. See that module for details. While going through and trying to parse each module, deob_index.pl also reports what pieces of the documentation it can't find. For example, if a method's documentation doesn't describe the data type it returns, this script logs that information to a file. This type of automated documentation- checking could be used to standardize and improve the documentation in BioPerl. deob_index.pl creates four files: =over =item C<< package_list.txt >> A plaintext file listing each package found in the BioPerl directory that was searched. Packages are listed by their module names, such as 'Bio::SeqIO'. This file is used by L<deob_interface.cgi>. =item C<< packages.db >> A Berkeley DB, which stores package-level documentation, such as the synopsis and the description. Each key is a package name, e.g. "Bio::SeqIO", and each value string is composed of the individual pieces of the documentation kept separate by unique string record separators. The individual pieces of documentation are pulled out of the string using the get_pkg_docs function in Deobfuscator.pm. See that package for details. =item C<< methods.db >> Like packages.db, methods.db is also a Berkeley DB, except it stores various pieces of information about individual methods available to a class. Each method might have documentation about its usage, its arguments, its return values, an example, and a description of its function. Each key is the fully-qualified method name, e.g. "Bio::SeqIO::next_seq". Each value is a string containing all of the pieces of documentation concatenated together and separated by unique strings serving as record separators. The extraction of the actual documentation in these strings is handled by the get_method_docs subroutine in the Deobfuscator.pm module. See that package for details. Not all methods will have all of these types of documentation, and some methods will not have the different pieces of information clearly labeled and separated. For the latter type, deob_index.pl will try to store whatever free-form documentation that does exist, and the get_method_docs function in Deobfuscator.pm, if called without arguments, will return that documentation. =item C<< deob_index.log >> This file contains detailed information about errors encountered while trying to extract documentation during the indexing process. Each line in deob_index.log is a key-value pair describing a single parsing error. =back =head1 DIAGNOSTICS These are the parsing error codes reported in 'deob_index.log'. =head2 Package errors =over =item C<< PKG_NAME >> couldn't find the name of the package =item C<< SYNOPSIS >> couldn't find the synopsis =item C<< DESC >> couldn't find the description =item C<< METHODS >> couldn't find any methods =item C<< PKG_DUP >> This package name occurs more than once =back =head2 Method errors =over =item C<< FUNCTION >> couldn't find the function description =item C<< EXAMPLE >> couldn't find the example =item C<< ARGS >> couldn't find the method's arguments =item C<< USAGE >> couldn't find the usage statement =item C<< RETURNS >> couldn't find the return values =item C<< FREEFORM >> This method's documentation doesn't conform to the BioPerl standard of having clearly-labeled fields for title, function, example, args, usage, and returns. =item C<< METH_DUP >> This method name occurs more than once =back =head1 CONFIGURATION AND ENVIRONMENT This software requires: =over =item A working installation of the Berkeley DB The Berkeley DB comes standard with most UNIX distributions, so you may already have it installed. See L<http://www.sleepycat.com> for more information. =item BioPerl deob_index.pl recursively navigates a directory of BioPerl modules. Note that the BioPerl module directory need not be "installed"; any old location will do. See L<http://www.bioperl.org> for the latest version. =back =head1 DEPENDENCIES L<version>, L<File::Find>, L<DB_File> =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. deob_index.pl currently expects the sections of POD in a BioPerl module to be in a particular order, namely: NAME, SYNOPSIS, DESCRIPTION, CONSTRUCTORS, ... , APPENDIX. Those sections are expected to be marked with =head1 POD tags, and the documentation for each method is expected to be in =head2 sections in the APPENDIX. The order of SYNOPSIS and DESCRIPTION can be flipped, but this behavior should not be taken as encouragement to do so. Most, but not all BioPerl modules conform to this standard. Those that do not will cause deob_index.pl to report them as errors. Although the consistency of this standard is desirable for end-users of the documentation, this code probably needs to be a little bit more flexible (patches welcome!). This software has only been tested in a UNIX environment. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl =head1 SEE ALSO L<Deobfuscator>, L<deob_interface.cgi>, L<deob_detail.cgi> =head1 AUTHOR Dave Messina C<< <dave-pause@davemessina.net> >> =head1 CONTRIBUTORS =over =item Laura Kavanaugh =item David Curiel =back =head1 ACKNOWLEDGMENTS This software was developed originally at the Cold Spring Harbor Laboratory's Advanced Bioinformatics Course between Oct 12-25, 2005. Many thanks to David Curiel, who provided much-needed guidance and assistance on this project. =head1 LICENSE AND COPYRIGHT Copyright (C) 2005-6 Laura Kavanaugh and Dave Messina. All Rights Reserved. This module is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =cut use version; $VERSION = qv('0.0.2'); use warnings; use strict; use File::Find; use DB_File; use IO::File; use Getopt::Std; use File::Spec; # GetOpt::Std-related settings $Getopt::Std::STANDARD_HELP_VERSION = 1; getopts('s:x:'); my $DEBUG = 0; my $usage = " deob_index.pl - extracts and parses BioPerl POD and stores the info in a database. USAGE: deob_index.pl [-s bioperl-version] [-x exclude_file] <BioPerl lib dir> <output dir> where <BioPerl lib dir> is the BioPerl distribution you'd like to index e.g. /export/share/lib/perl5/site_perl/5.8.7/Bio/ and <output dir> is where the output files should be placed OPTIONS: -s user-supplied string to declare BioPerl's version (which will be displayed by deob_interface.cgi) -x excluded modules file (a module paths to skip; see POD for details) "; unless ( @ARGV == 2 ) { die $usage; } my ( $source_dir, $dest_dir ) = @ARGV; # check source_dir for full path and repair if it's a relative path unless ( File::Spec->file_name_is_absolute( $source_dir ) ) { $source_dir = File::Spec->rel2abs( $source_dir ) ; } # check dest_dir for full path and repair if it's a relative path unless ( File::Spec->file_name_is_absolute( $dest_dir ) ) { $dest_dir = File::Spec->rel2abs( $dest_dir ) ; } # NOTE: we're allowing only one source directory, but File::Find supports # passing an array of dirs. # read in an optional list of modules to exclude from indexing # - this is aimed at modules with external dependencies that are often not # - present and thus will prevent deob_interface.cgi from loading them our ($opt_s, $opt_x); my %exclude; if (defined $opt_x) { my $exclude_fh = IO::File->new($opt_x, "r") or die "couldn't open $opt_x\n"; while (<$exclude_fh>) { chomp; next if ( /^\#/ || /^\s*$/ ); # ignore comments and blank lines $exclude{$_} = 1; } print STDERR "Found ", scalar keys %exclude, " modules to be excluded.\n"; } # save a list of the BioPerl modules to a file my $list; # filehandle my $list_file = $dest_dir . "/package_list.txt"; if ( -e $list_file) { unlink($list_file); } open $list, ">$list_file" or die "deob_index.pl: couldn't open $list_file:$!\n"; my @list_holder; # hold all package names so we can sort them before writing. # record misbehaving BioPerl docs to a file my $log; # filehandle my $logfile = $dest_dir . "/deob_index.log"; open $log, ">$logfile" or die "deob_index.pl: couldn't open $logfile:$!\n"; # create databases my $meth_file = $dest_dir . '/methods.db'; if ( -e $meth_file ) { unlink($meth_file); } # remove for production? my $meth_db = create_db($meth_file) or die "deob_index.pl: couldn't create $meth_file: $!\n"; my $pkg_file = $dest_dir . '/packages.db'; if ( -e $pkg_file ) { unlink($pkg_file); } # remove for production? my $pkg_db = create_db($pkg_file) or die "deob_index.pl: couldn't create $pkg_file: $!\n"; # used to make sure we're parsing in the right order my %FLAG; # store version string in packages.db $pkg_db->{'__BioPerl_Version'} = $opt_s ? $opt_s : 'unknown'; # keep stats on our indexing my %stats = ( 'files' => 0, 'pkg_name' => 0, 'desc' => 0, 'synopsis' => 0, 'methods' => 0, ); # wanted points to the subroutine which is run on each found file # ( in this program, that subroutine is &extract_pod ) # no_chdir prevents find from chdir'ing into each subsequent directory my %FIND_OPTIONS = ( wanted => \&extract_pod);#, no_chdir => 1 ); # This is the important line - Find::File actually doing the # traversal of the directory tree. find( \%FIND_OPTIONS, $source_dir ); # sort and write out package list foreach my $sorted_pkg (sort @list_holder) { print $list $sorted_pkg, "\n"; } # store user-supplied BioPerl version number # output stats print STDOUT "\nThis indexing run found:\n"; print $log "\nThis indexing run found:\n"; foreach my $stat ( 'files', 'pkg_name', 'desc', 'synopsis', 'methods' ) { printf STDOUT "%5d %s\n", $stats{$stat}, $stat; printf $log "%5d %s\n", $stats{$stat}, $stat; } # close files and DBs untie $meth_db or die "deob_index.pl: couldn't close $meth_file: $!\n"; untie $pkg_db or die "deob_index.pl: couldn't close $pkg_file: $!\n"; close $list or die "deob_index.pl: couldn't close $list: $!\n"; close $log or die "deob_index.pl: couldn't close $log: $!\n"; my $mode = 0666; chmod($mode, $pkg_file, $meth_file, $list_file); ### Parsing subroutines ### sub extract_pod { my ($file) = $_; my $long_file = $File::Find::name; # skip if it's on our exclude list foreach my $one (keys %exclude) { if ($File::Find::name =~ /$one$/) { print STDERR "Excluding $file\n"; print $log "Excluding $file\n"; return; } } # skip unless it's a perl file that exists return unless ( $file =~ /\.PLS$/ ) or ( $file =~ /\.p[ml]$/ ); return unless -e $file; $stats{'files'}++; open my $fh, $File::Find::name or die "deob_index.pl: couldn't open $file:$!\n"; # these have to be done in order my ( $pkg_name, $short_desc ) = get_pkg_name($fh); my ($synopsis, $desc); LOOP: while (my ($type, $section) = get_generic($fh) ) { if ($type eq 'synopsis') { $synopsis = $section; } elsif ($type eq 'description') { $desc = $section; } else { last LOOP; } } my $constructors = get_constructors($fh); my $methods = get_methods($fh); # record package name to our package list file if ($pkg_name) { push @list_holder, $pkg_name; } # store valid package data here my @pkg_data; # error reporting if ($pkg_name) { $stats{'pkg_name'}++; print $pkg_name, "\n" if $DEBUG == 1; } else { print $log " PKG_NAME: $long_file\n"; } if ($short_desc) { $stats{'short_desc'}++; push @pkg_data, $short_desc; print $short_desc, "\n" if $DEBUG == 1; } else { push @pkg_data, 'no short description available'; # store something print $log "SHORT_DESC: $long_file\n"; } if ($synopsis) { $stats{'synopsis'}++; print $synopsis, "\n" if $DEBUG == 1; push @pkg_data, $synopsis; } else { push @pkg_data, 'no synopsis available'; # store something print $log " SYNOPSIS: $long_file\n"; } if ($desc) { $stats{'desc'}++; print $desc, "\n" if $DEBUG == 1; push @pkg_data, $desc; } else { push @pkg_data, 'no description available'; # store something print $log " DESC: $long_file\n"; } if ($methods) { my $method_count = scalar keys %$methods; print "**** Found $method_count methods in $pkg_name\n" if $DEBUG == 2; foreach my $method ( keys %$methods ) { $stats{'methods'}++; print $method, "\n//\n" if $DEBUG == 2; } } else { print $log " METHODS: $long_file\n"; } # prepare data for databases my $pkg_record = pkg_prep(@pkg_data); my $meth_records = meth_prep( $pkg_name, $methods ); # load data in databases if ($pkg_name) { pkg_load( $pkg_db, $pkg_name, $pkg_record ); meth_load( $meth_db, $meth_records ); } } sub slurp_until_next { my ($fh) = @_; my @lines; my $prev_line = $_; LINE: while (<$fh>) { next LINE if $_ eq $prev_line; # if it's a POD directive if (/^\=/) { # reset our position to the beginning of the line # so it is seen as part of the next POD section seek $fh, -length($_), 1; last LINE; } else { push @lines, $_; } } return join q{}, @lines; } sub get_pkg_name { my ($fh) = @_; my $pkg_name; my $short_desc; LINE: while (<$fh>) { chomp; print "**", $_, "\n" if $DEBUG == 2; # grab package name # - "short desc" is the one-line description of the package if ( $_ =~ /^\=head1\s+NAME/ ) { <$fh>; my $next_line = <$fh>; ( $pkg_name, $short_desc ) = split /\s+/, $next_line, 2; $short_desc .= slurp_until_next($fh); # strip off leading dash $short_desc =~ s/^(\-)+\s+//; # strip off trailing spaces $short_desc =~ s/\s+$//; # strip any newlines $short_desc =~ s/\n/ /; print $pkg_name, "\n" if $DEBUG == 1; last LINE; } # we've hit a =head1, but it's the wrong one elsif ( $_ =~ /^\=head1\s+/ ) { last LINE; } } if ($pkg_name) { $FLAG{'pkg_name'} = 1; return $pkg_name, $short_desc; } } sub get_generic { my ($fh) = @_; my $section; LINE: while (<$fh>) { chomp; print "**", $_, "\n" if $DEBUG == 2; if ( $_ =~ /^\=head1\s+SYNOPSIS/ ) { $section = slurp_until_next($fh); if ($section) { $FLAG{'synopsis'} = 1; return ('synopsis', $section); } else { last LINE; } } elsif ( $_ =~ /^\=head1\s+DESCRIPTION/ ) { $section = slurp_until_next($fh); if ($section) { $FLAG{'description'} = 1; return ('description', $section); } else { last LINE; } } # if we hit the APPENDIX, time to stop elsif (/^\=head1\s+APPENDIX/) { # reset our position to the beginning of the line # so it is seen by the next parser seek $fh, -length($_)*2, 1; last LINE; } } } sub get_synopsis { my ($fh) = @_; my $synopsis; LINE: while (<$fh>) { chomp; print "**", $_, "\n" if $DEBUG == 2; if ( $_ =~ /^\=head1\s+SYNOPSIS/ ) { $synopsis = slurp_until_next($fh); last LINE; } # we've hit a =head1, but it's the wrong one elsif ( $_ =~ /^\=head1\s+/ ) { last LINE; } } if ($synopsis) { $FLAG{'synopsis'} = 1; return $synopsis; } } sub get_desc { my ($fh) = @_; my $desc; LINE: while (<$fh>) { chomp; print "**", $_, "\n" if $DEBUG == 2; if ($_ =~ /^=head1\s+VERSION/ ) { slurp_until_next($fh); } if ( $_ =~ /^\=head1\s+DESCRIPTION/ ) { $desc = slurp_until_next($fh); last LINE; } # we've hit a =head1, but it's the wrong one elsif ( $_ =~ /^\=head1\s+/ ) { last LINE; } } if ($desc) { $FLAG{'description'} = 1; return $desc; } } sub get_constructors { # not implemented # should return a hashref } sub get_methods { my ($fh) = @_; my %methods; # we shouldn't see any methods until after the APPENDIX my $seen_appendix = 0; # there's an '=cut' after we enter the APPENDIX # we know the method '=head2' tags will come after it my $seen_first_cut = 0; LINE: while (<$fh>) { if ( $_ =~ /^\=head1\s+APPENDIX/ ) { $seen_appendix = 1; } # this should be the first tag after the APPENDIX if ( $seen_appendix && $_ =~ /^\=cut/ ) { $seen_first_cut = 1; } # this should be a method if ( $seen_first_cut && $_ =~ /^\=head2\s+(\S+)/ ) { $methods{$1} = slurp_until_next($fh); } } # returns a hashref return \%methods; } ### Database subroutines ### sub create_db { my ($filename) = @_; my %hash; my $hashref = \%hash; tie %hash, "DB_File", $filename or die "ERROR: couldn't open $filename:$!\n"; return $hashref; } sub pkg_prep { # unique string on which to split our sub-records my $rec_sep = 'DaVe-ReC-sEp'; my $record = join $rec_sep, @_; return $record; } sub meth_prep { my ( $pkg_name, $methods ) = @_; my %records; foreach my $entry ( keys %$methods ) { my $key = $pkg_name . '::' . $entry; my $record; # what will be stored in the db my $rec_sep = 'DaVe-ReC-sEp'; # if the method conforms to the BioPerl doc spec, # we will split it into constituent pieces before storing # it in the db. If not, we store the whole thing as one lump. my $last; # for grabbing multi-line entries my %fields = ( 'title' => '', 'usage' => '', 'function' => '', 'example' => '', 'returns' => '', 'args' => '', ); my @lines = split "\n", $methods->{$entry}; foreach my $line (@lines) { if ( $line =~ /^\s+Title\s+:(.*)/ ) { next if $1 =~ /^\s+$/; $fields{'title'} = $1; $last = \$fields{'title'}; } elsif ( $line =~ /^\s+Usage\s+:(.*)/ ) { next if $1 =~ /^\s+$/; $fields{'usage'} = $1; $last = \$fields{'usage'}; } elsif ( $line =~ /^\s+Function\s?:(.*)/ ) { next if $1 =~ /^\s+$/; $fields{'function'} = $1; $last = \$fields{'function'}; } elsif ( $line =~ /^\s+Example\s+:(.*)/ ) { next if $1 =~ /^\s+$/; $fields{'example'} = $1; $last = \$fields{'example'}; } elsif ( $line =~ /^\s+Returns\s+:(.*)/ ) { next if $1 =~ /^\s+$/; $fields{'returns'} = $1; $last = \$fields{'returns'}; } elsif ( $line =~ /^\s+Args\s+:(.*)/ ) { next if $1 =~ /^\s+$/; $fields{'args'} = $1; $last = \$fields{'args'}; } # grab multi-line entries elsif ( $line =~ /^\s{8,}(\s.*)/ ) { $$last .= $1; } } # debugging if ( $DEBUG == 2 ) { print "** $entry **\n"; foreach my $field ( keys %fields ) { print STDOUT $field, "\t", $fields{$field}, "\n"; } print "\n"; } # if any of our fields have a value, store subrecords my $filled_fields = grep /\w+/, values %fields; print STDERR $key, "\t", $filled_fields, "\n" if $DEBUG == 3; if ( $filled_fields > 0 ) { if ( !$fields{'title'} ) { print $log ' TITLE: ', $key, "\n"; } if ( !$fields{'usage'} ) { print $log ' USAGE: ', $key, "\n"; } if ( !$fields{'function'} ) { print $log ' FUNCTION: ', $key, "\n"; } if ( !$fields{'example'} ) { print $log ' EXAMPLE: ', $key, "\n"; } if ( !$fields{'returns'} ) { print $log ' RETURNS: ', $key, "\n"; } if ( !$fields{'args'} ) { print $log ' ARGS: ', $key, "\n"; } # create the records to be stored in the db foreach my $field ( keys %fields ) { my $subrecord = $rec_sep . '-' . $field . '|' . $fields{$field}; $record .= $subrecord; } # store the records $records{$key} = $record; } # if no subfields, store whatever docs we do have for the method else { $record = $methods->{$entry}; print $log ' FREEFORM: ', $key, "\n"; } } return \%records; } sub pkg_load { my ( $pkg_db, $pkg_name, $record ) = @_; if ( exists $pkg_db->{$pkg_name} ) { print $log ' PKG_DUP: ', $pkg_name, "\n"; warn( "$pkg_name already exists in package db!\n", "existing record:\n$pkg_db->{$pkg_name}\n", "attempted to add:\n$record\n", ) if $DEBUG == 2; } else { $pkg_db->{$pkg_name} = $record; } } sub meth_load { my ( $meth_db, $records ) = @_; foreach my $method ( keys %$records ) { if ( exists( $meth_db->{$method} ) ) { print $log ' METH_DUP: ', $method, "\n"; warn( "$method already exists in method db!\n", "existing record:\n$meth_db->{$method}\n", "attempted to add:\n$records->{$method}\n", ) if $DEBUG == 2; } else { $meth_db->{$method} = $records->{$method}; } } } __END__ �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/bin/run-deobfuscator-update.pl�������������������������������������000444��000765��000024�� 1112�12254227315� 24466� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w use strict; my $base = '/home/websites/bioperl.org'; my $srcdir = "$base/src/git"; my $deob_index = "$base/src/Deobfuscator/bin/deob_index.pl"; my @modules = qw( bioperl-corba-client bioperl-corba-server bioperl-db bioperl-dev bioperl-ext bioperl-gui bioperl-live bioperl-microarray bioperl-network bioperl-pedigree bioperl-pipeline bioperl-pise bioperl-run ); chdir $srcdir; for my $module (@modules) { system("/usr/bin/perl $deob_index -s $module $srcdir/$module/Bio $srcdir/$module"); } exit(); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/cgi-bin������������������������������������������������������������000755��000765��000024�� 0�12254227336� 20002� 5����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/cgi-bin/deob_detail.cgi��������������������������������������������000444��000765��000024�� 12366�12254227336� 23106� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl -w # Deob_detail.cgi # part of the Deobfuscator package # by Laura Kavanaugh and Dave Messina # # cared for by Dave Messina <dave-pause@davemessina.net> # # POD documentation - main docs before the code =head1 NAME deob_detail.cgi - displays a web page of detailed information about a BioPerl method =head1 VERSION This document describes deob_detail.cgi version 0.0.3 =head1 SYNOPSIS This program is designed to be called by deob_interface.cgi. See L</"DESCRIPTION"> for details. To install deob_detail.cgi and the rest of the Deobfuscator package, see the README. =head1 DESCRIPTION Deob_detail.cgi is called by deob_interface.cgi when a user clicks on a method name. This program extracts the documentation about that method from the Deobfuscator Berkeley DBs and returns it in some simple HTML formatting. =head1 DIAGNOSTICS None. =head1 CONFIGURATION AND ENVIRONMENT This program expects to have the 'methods.db' and 'packages.db' files in the same directory as itself. These two files are automatically generated when L<deob_index.pl> is run. If your installation requires that they be in a different location, change the $BerkeleyDB_packages and $BerkeleyDB_methods variables below to be fully qualified paths to the db files. =head1 DEPENDENCIES L<version>, L<CGI>, L<Deobfuscator> =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: http://bugzilla.bioperl.org/ =head1 SEE ALSO L<Deobfuscator>, L<deob_interface.cgi>, L<deob_index.pl> =head1 AUTHOR Laura Kavanaugh =head1 CONTRIBUTORS =over =item Dave Messina C<< <dave-pause@davemessina.net> >> =item David Curiel =back =head1 ACKNOWLEDGMENTS This software was developed originally at the Cold Spring Harbor Laboratory's Advanced Bioinformatics Course between Oct 12-25, 2005. Many thanks to David Curiel, who provided much-needed guidance and assistance on this project. =head1 LICENSE AND COPYRIGHT Copyright (C) 2005-6 Laura Kavanaugh and Dave Messina. All Rights Reserved. This module is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =cut # Let the code begin... ## HARDCODED VALUES ## # Change these to fit your installation. use lib './lib'; my $BerkeleyDB_packages = './packages.db'; my $BerkeleyDB_methods = './methods.db'; ## You shouldn't need to change anything below here ## use version; $VERSION = qv('0.0.2'); use warnings; use strict; use CGI ':standard'; use Deobfuscator; # Open BerkeleyDBs my $packages_ref = Deobfuscator::open_db($BerkeleyDB_packages); my $methods_ref = Deobfuscator::open_db($BerkeleyDB_methods); # 'method' is the name of the method passed in from deob_interface.cgi my $class_method = param('method'); # Get all of the documentation fields out of the db my $title = Deobfuscator::get_method_docs( $methods_ref, $class_method, "title" ); if ( $title eq "0" ) { $title = "not documented"; } my $usage = Deobfuscator::get_method_docs( $methods_ref, $class_method, "usage" ); if ( $usage eq "0" ) { $usage = "not documented"; } my $function = Deobfuscator::get_method_docs( $methods_ref, $class_method, "function" ); if ( $function eq "0" ) { $function = "not documented"; } my $returns = Deobfuscator::get_method_docs( $methods_ref, $class_method, "returns" ); if ( $returns eq "0" ) { $returns = "not documented"; } my $args = Deobfuscator::get_method_docs( $methods_ref, $class_method, "args" ); if ( $args eq "0" ) { $args = "not documented"; } ### Make the output page # Start the page print header; print start_html($class_method); # Define some styles my $style1 = qq{style="border-collapse:collapse;border:solid black 1px;font-family:verdana;font-size:10px;background-color:lightgrey"}; my $style2 = qq{style="border-collapse:collapse;border:solid black 1px;font-family:verdana;font-size:10px"}; my $style3 = qq{style="border-collapse:collapse;border:solid black 1px;font-family:verdana;font-size:14px"}; # open the table print '<div style="border:solid black 1px; width:100%; height:200; overflow:auto">'; print '<table width="100%" $style3>'; print "<tr><td colspan=4><center>$class_method</center></td></tr>"; my @sections = ('Usage', 'Function', 'Returns', 'Args'); my $sec_ndx = 0; foreach my $section ($usage, $function, $returns, $args) { my $section_html = Deobfuscator::htmlify($section); print "<tr><td $style1>$sections[$sec_ndx++]</td><td $style2>$section_html</td></tr>\n"; } # close the table print "</table></div>"; # finish the page print end_html; # close BerkeleyDB Deobfuscator::close_db($BerkeleyDB_packages); Deobfuscator::close_db($BerkeleyDB_methods); __END__ ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/cgi-bin/deob_flowchart.png�����������������������������������������000444��000765��000024�� 400225�12254227322� 23665� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������‰PNG  ��� IHDR��0��È���=[ô��� pHYs����gŸÒR�� �IDATxœìÝw\Våãÿñë”) €8È=Q·B"àJÔ܆†–Z™£2s¤å*S+ÔÜ¥´p¥æLKCPAs š q³AÙpÿþ8¿Ïyœ/óð�ùzþu‹s®ûº§¼yß×ÐhµZ������¨E¯¼;������€— ������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UåÝ��^.™™™?~üøñ£G’’’RSSÓÒÒRSS322LMMÍÍÍ-,,,,,Z¶lÙ¼ysF£{Ë/^|Þþôë×ÏØØX—3µZíÙ³gýüüîÞ½kjjjkkkkkÛ¹sç¾}ûV¯^]÷×MMM½uëÖƒâââRRRž={öìÙ³¬¬,©Y{{û-ZèÒ·’½ñ!C†ä¹½ÊvÌÍÍ{õê¥{kñññRÙÁÁ¡iÓ¦EŸÿäÉ“[·nݾ}ûÖ­[ÉÉÉuêÔ±³³«S§N³fÍúöíkddô<ïæÿ÷ßßßÿêÕ«111qqq‰‰‰UªT©V­Z5š4iÒªU+—ZµjéÞà‘#Gž={&:;;ÛÚÚæ?-''gÿþýÏÛÛüŒŒŒ<<< ûiÙ>~BˆÜÜ܇FDD<xðàéÓ§©©©Ïž=KMM544¬V­š¹¹yÓ¦MÛ´iceeUêw��  ÑjµåÝ��^¿ýöÛ‡~¨ã?¾fffmÛ¶uqqñòòªY³f±çûúú~òÉ'ÏÛ¥K—.Õ­[·èsž>}úÝwßýöÛo111…£¯¯ïìì<{öìÎ;û¢þùç¸qãrss‹>ÍÐÐðµ×^7nœ³³s§•ì?~ü¸J•*…µcoo¨{k 8sæŒT^´hÑäÉ“ ;333sÓ¦M+W®LJJ*ì ‹¡C‡Î;×ÒҲؗ~òäÉúõë÷îÝ{÷îÝbOîرã¦M›ìììŠ=322²mÛ¶ÊguÚ´iŸ}öYþ3Ÿ={Ö Aƒb,–­­mXXXþú2ü„ýõׄ ²²²Š=³Y³f^^^£FÒåw��tÇ”=��Ô“™™©ûWA)))§NZºt©££ãĉ¯_¿þBûV˜Í›7wîÜyõêÕEÄBˆœœœ   þýû¿ÿþûEŸ)„HOO/6Bdddìß¿ðàÁ“'ONIIy¾~WHݺu[¸pai”"))i×®]Å’zöìÙ×_ݾ}û•+Wê’F !ÂÂÂjÔ¨¡Ë™Èó¬–É0¨çõ"?!DZZš.i”âæÍ›óçÏïÖ­Û‘#Gtí4��ÐSö��(O¶¶¶ÖÖÖ&&&ÆÆÆiii‰‰‰‰‰‰òä/IVVÖž={:´páÂwÞyGµ¾åææΘ1cóæÍÊJCCCGGG;;;›ØØØû÷ï_¹r%##C>a÷îÝgϞݵkW£Ftyƒ-ZÔ©SÇÄÄÄÀÀ >>>22òáÇÊj×®]ñññÛ·o×Ó«Äߥݾ}{ܸqÊ÷eddÔ¤I“¦M›êééEDDDDD$&&J?*vÖÞ;wÆŽ{ãÆ<õFFFM›6µ²²²²²JII‰ŒŒŒŠŠŠ•Ò¥=z˜˜˜èÒÛ}ûö婉ˆˆ¸té’£££.——ž:ŸÄÜܼaÆææ榦¦©©©ÒŒÚ´´4ù„¸¸8//¯ï¿ÿ~Ø°a¥k��@H�P^š4irôèQSSÓü?ŠŽŽ ܽ{·üWqFFÆœ9s‚ƒƒ7mÚ¤¯¯_lã[¶lÑ¥…-*”••5~üøÇ+ÏüàƒFŽ™gîRBBÂŽ;Ö¬Y+ÕÜ¿À€»wïnÙ²e±hÖ¬ÙñãÇóT¦§§ïÙ³gãÆW¯^•jüýýçλlÙ²¢[Óý癯÷¢¥¥¥)Ó(33³Ù³g¿ûî»y~•‰‰‰GŽùñÇ\Dk&LP³222=ztÿþý»tébhh˜çü§OŸþõ×_{÷î8p .½}ðàÁ¹sç¤rûöí/\¸ •÷îÝ›?2119zôhaMݼyS9ñï¿ÿ.,UTþFT{ü„-Z´8qâDþú'N¬Y³FùpΚ5«K—.ºLx��Å"� |T­ZµÀ4Jakk;xðàÁƒþùç?üðÃÚµkåéEüñÇ'Ÿ|òÝwßÛxãÆKÓ½/¾øBôíÛwõêÕÎöªQ£Æ¤I“† 6iÒ¤   ©266vüøñÇŽÓq<NR¼2lØ°¡C‡þóÏ?Rå?þ8f̘V­Zqaéßø òí·ßÊ“.ÍÌÌŽ;VàžêÕ«{zzzzz1µ3,,lìر©©©r͘1cfÏž]àŠã’jÕª9räÈ‘:ööÀryÑ¢EC† ÉÎΖê-Z”çdFÓ¶mÛšÊóFÚ´iSlœ*Ô}ü ȺwïÞ½{÷ßÿ}Ò¤IRMrròÔ©Só��%P‰Ç½�ðŸgee5wîÜýû÷×®][®ÜºuëªU«^èë=zô‡~¸eË–¢×ªY³æ®]»zöì)×ܾ}{Þ¼y¥é†¡¡áæÍ›-,,äš³gÏ–¦Ár¤ƒ3oÞ¼b'”¶ÁbBB‚2ªZµêêÕ«W¬XQDU{÷î• 5kÖìÚµkÇŽ¥Ã‡Êùà‹SA?ÉðáÃ?øàùðÔ©Sqqq¥o��H�PÑuêÔéСCÊ?Ƚ½½?~ü‚^.##ãã?–¶´iÓfýúõº\¨§§çããÓ¤I¹Æ××÷òåË¥éL5:tè VÒ@*##Cž{(„ÐqÞ\¦OŸþàÁùpÓ¦M£F*Uçò‰ˆˆk...B777ù§/z|P…zü$Ÿ|ò‰rUhhhéÛ��R��T¯¼òʦM›ä¿ŠÓÓÓ‹]M©ÄvìØ%Κ5«ØíÞdfff3gÎTÖlØ°¡”ýi×®\ο†w¥*Oº411±±±)Y;—/_>tè|øÁxxx”Aÿþ/ånz®®®âÿRüñ‡î;E–@E{ü„¦¦¦Êy W®\)}›��€@ �€ÊÁÅÅE9²&ÏßíeE«Õ*ÿ†oÒ¤Iß¾}Ÿ«…Aƒ)W}Þ¿dddiº¤Üì¬^½z¥iª¼T­ZU.K›¸•¬o¾ùF.×­[wîܹ¥íYA”c ¤@ÊÑÑQ ü"^WTÈÇOboo/—åÕÓ�@iH�Pi|øá‡r977÷رceþgÎœ¹}û¶|(/ç¬;}}ý‰'ʇÙÙÙÊÕ©K@ÞîM¡ã¾iMË–-•[ÈåßUP÷îÝûûï¿åÃ)S¦”ýî4·oß–g:88HKSi4åòLò Se®>~e†Ø´iÓÒ7��¤��¨4Ú´iÓ¬Y3ùðER'Ož”ËÖÖÖo¼ñF 3fŒ¹¹¹|RâþŸ?^*›˜˜Œ;¶ÄM•£*Uª´hÑB>œ?¾r()c,###//¯²éÜÿ¥ ›,—‡ "—:”““ó"^½¢=~’œœœ°°0ùPùß ��(1)��*'''¹|êÔ©2o_™tëÖÍÐа˜šš*W"/ñ ¯û÷ï¿óÎ;rö1uêÔ²ÝKNMÊÁ>ÉÉÉ z®üýýårÇŽˬs ʤ $—ÝÜܪW¯.•ãââ”›–¡ õøÉöìÙ#Ï­U«–rQ3��PbR��T&Ê¿´䥲ˊ<I”nÁ¦úõëËåèè褤¤çº<!!aÑ¢E¯¾úª¼^ÏÛo¿g½êÊeĈÊÈ=z4|øð>úH9C­hÊüñÕW_-ãþ !„¸~ýº¼l¼£££ò—h`` \ÂìÍÚ« ŸRxxø¬Y³äùsçê¾È:��(BÙ/=���^kkkåa|||­ZµòŸöèÑ#å‚S…yë­·” WRRRzzº|XšD AƒyúiaaQà™Ê®æää<zôèÎ;QQQòVnÓ§OŸ<y².¯›••Sìi5kÖÔ¥µ²µ|ùòððp9ñÑjµÛ¶mÛ¾}{¯^½&Ož\tÆôìÙ³äädùð-c¤\Î\9GO®ñõõ•Êþù§···ra¬Ò+—ǯZ­vçÎ_}õUJJŠTãìììééYâ^��%)��*KKKåalllTRRÒöíÛ‹mÍÕÕUHÅÇÇ+ZVCT„‰‰‰…YtW]\\~þùgå’@E»uëV«V­Š=-**J___Ç6ËŠµµµŸŸß¬Y³~ûí7¹R«ÕúùùùùùuìØñã?îÓ§O×ÆÅÅ)­¬¬^D•Ô믿žç§ÎÎ涶ÑÑÑBˆ'Ož?~¼°Þ–L¹<~Bˆôôtyw!Drrò;wîܹsôèÑk×®Éõ}ûöõññÑh4%î��P"� 2É3&%77· OHHPæù«þ¹¼òÊ+ÊçOŸ–¬   ¾}ûzyyMœ8ñEl*§2ccã5kÖôèÑcÙ²e÷îÝSþèܹso¾ùfëÖ­W¯^íààçÂ<”¼œS —Ê;v´³³Ës‚F£4hÐƥý{÷–m U^ß;w\]]‹8ÁÚÚzÊ”)“&MR?Ä�à?¬Ò°�à¥òäÉåaa#e 6lXlkÕªUSfgg—¦oJyƤ1ÄÉÆÆfüøñR9###22Ršµ÷øñc©òöíÛ .<xð Oݺu˪‡åhøðáC‡=xðàºuë.\¸ üQXXXÿþýW®\9lØ0e}žÅÂäùŒeH9<J¹œ¹Ò!Cä@êðáÃ%[w¼@åòøËÁÁaß¾}¥i��ˆ@ �€Ê$Ï(’©Æ>oã5jÔPFDD”x­¢<Ãò´¬dcc3cÆŒüõ>>>~~~Ò(°sçι»»8EQV§NyóæÛ½rꢧ§÷ú믿þúë§OŸ^·nÝ‘#GäŒ)--íý÷ßϳ XžµÃòä’eBÞ_O Uà9;v¬W¯Þýû÷…)))Gíß¿Yu \?‰<øN«ÕÊ»:JBCCûöí»~ýz6×� lH�P™Èㆄ¦¦¦ÆÆÆeØxž¿ÛïܹSâ¦îÞ½«<,ÁšG®®®®®®»wïž4i’Ö$$$LŸ>}Û¶mE\eii9|øðç}-‰ry ç‚¤<ÿ¹–êÚµk×®]ÃÃÃgÏž­Ì—-[Ö¯_?9‘Ésó,·Tz/^”C›v¦H !öîÝûâ)Õ?{{{劊º~ýºŸŸßO?ý$ Úº}ûöÈ‘#÷ïßooo_â.�€<¤��¨LBBBä²££cÙ6^£F yæTDDD‰›RQ133Ë37PwÆ {òäɧŸ~*úùù8p ÿzÛeÂÔÔT.ç‰V,åù%x³7Þµk—··÷7ß|#ÕdeeÍš5kïÞ½ÒaõêÕ•¿š°°°²½ Êùz111Ÿþ¹.Wùùù¥¦¦š˜˜”I*ÈãW«V­Zµj¹ººŽ3æÍ7ߔҷ'OžL™2ÅßߟEÍ�(+zåÝ�� +­V{æÌùÐÅÅ¥lÛ×ÓÓkÛ¶­|XšD@9D¥[·n¥éÕ„ j×®-?~¼4­A¹ƒaLLLFF†î×>|øP.—lÅqF3sæÌ#FÈ5'OžT6«\é<88¸/Qy¾ÞsIMM=räHYõ¡¢=~-Z´X»v­žÞÿÿ´¶{÷îw ��äA �@¥qìØ1åâAEo V2ÎÎÎrùôéÓy6wÓÑíÛ·¯^½*vïÞ½”½êÚµ«\ -ek…QRZ­V-666==]>,Íx‹/Vn&xóæM¹¬üu_¼x1**ªÄ¯’Ç?ÿüóèÑ#©\µjUûâ(o”<†«LT´Ç¯[·n£F’·lÙRâ¦��@R��T«W¯–Ë 4(ó){BˆW_}U.§¥¥mØ°¡¬Y³FZ‰<›%Ó¡C¹üï¿ÿ*/Cy¶ðÓ=ÊsfãÆK܇5j(·G,,ÊÌÌ\¸pa‰_%å|½þýûgÎœ9òùþþþ)))eÕ“ øø :T.‡„„”ùê]��¼´¤��¨Ž;¦\@jÚ´iòd¢2äââòÊ+¯È‡?ýôSrròsµ¹k×.ù°]»vʹf%)—5Í‹xãB[[[;;;ùðßÿÕñBåxœ ØÚÚ–¦õêÕ“Ëiiir¹sçÎÊ_ÍîÝ»•ÏC‰iµÚ?þøC>ÔeiªÊÛfddüù知>~NNNR977÷ÅÍ�àeC �@%ððáÃÉ“'ˇõêÕ{ã7^Ä éëëOœ8Q>LIIÙ´iÓsµ°~ýú¬¬,ùpÚ´i¥ï•rå¬Zµj•¾ÁÂtîÜY.oÚ´I^`»Z­výúõòa—.]JÙ‡[·nÉåÖ­[ËeƒéÓ§+Ïœ3gNé‹…„„ȳÿLMM{öìYì%666NNNòaÎÚ«€ŸrlZ™„€��@H�PñEFFŽ3FÞÇM£Ñ,[¶L¹ÒPÙòòò²¶¶–×®]{íÚ5¯½p᯿þ*¶lÙÒÃã”ýIJJºråŠ|Ø£GR6X„¾}ûÊåû÷ïïر£ØKöîÝ«Œ”«’—@ll¬´­›¤M›6ÊŸŽ5ªAƒòáÕ«W¿ýöÛÒ¼œø¿qR¯^½Œu¹jðàÁr900P¹´Y)U´ÇOÑ©S'¹|úôéÒ7����\pppÏž=ÃÂÂäšÙ³g÷îÝûŽ¢©©éªU«äÔ””7ÞxãÞ½{Å^xëÖ­Ñ£G˳̌ŒŒJ¶RjjêèÑ£333¥CFãééYÊ6‹ðúë¯+wôûî»ïŠ^ )%%ÅÛÛ[>lݺuay™V«Õ¥3fÌ˵k×Î3ûO__Íš5UªT‘k¼½½§OŸ®ËH®åææ<xP>8p Ž8PŽD³²²””R…zü$Ê@êæÍ›,#�@™ � ‚:þ¼——×àÁƒcccåÊaÆ}òÉ'/ú¥ûôéóÎ;ïȇQQQîîîEÏÌÚ¶m[Ÿ>}”«/]º´U«V¥éƃÆŒóÏ?ÿÈ5S¦LQ¦eÎÀÀ`Ê”)òáÝ»w{õêUØbRW®\qwwWR®ö­”о}û5kÖ±"RZZÚ‚ ”ë1}õÕWùOëÚµë×_­¬Ù¼y󫯾ºgÏžb3¯˜˜˜<ÉÎÉ“'åìŒu:«W¯îââ"*—E/½ òøÉÚ´icbb"ž:uªLš�à%÷¢Fû�€¢={öìòåËÖÖÖ†††úúú™™™‰‰‰Ož<yðàAHHHpppxx¸ò|ƒùóçOš4I—Æccc¿ùæ]δ²²š0aBþú/¿üòÉ“'¿ÿþ»t˜œœüÞ{ïýðÃ^^^îîîµk×Öh4999‘‘‘ÿý÷¶mÛ._¾¬¼|öìÙ^^^ºt ###::ÚÊÊÊÀÀ@«ÕÆÆÆFFF†‡‡ïܹóøñãÊ5’?ûì3]Ú,÷Þ{ïèÑ£Òaxxøk¯½6mÚ´.]º´iÓÆÌÌ,&&æêÕ«gÎœY»vmFF†|áäÉ“ûôéS`›GŽyøðá_|±bÅŠ!C†ØÛÛ7jÔ¨qãÆvvv±±±—.]Z¿~½¼–“ÂÓÓ³°ñJÒüÍ%K–È7'<<|âĉ_~ù¥»»»««kƒ ¬­­-,,£££cbbnß¾}øðá³gÏzyy-_¾\nJ$õìÙS»kðàÁþþþRY ¶”SíJIµÇO:u ”Ož<©ËÒï�� hR��”{÷îõêÕKÇ“ííí—/_Þ±cGÏÕqu¡¦M›HlØ°ÁÆÆF9ïéüùóçÏŸBT©R¥zõêñññ999y.444\½zõСCuìjxx¸´t·F£Ñh4…­ÒݱcGŸ·r–L£Ñ¬_¿~øðáòÒE©©©K–,‘~daaQàzIÆ ›?~am:tH*¤¤¤lÞ¼¹Ø>4oÞ|éÒ¥EœðÑG988¼ÿþû‰‰‰råÇ}}}}}}‹¸088X.ggg+§Ú=oÈÒ¿ÿ3fH³)srrþøãqãÆ=W EPíñÓ‘‹‹‹H±Ñ��e‚){��T\¦OŸ>{öì Ô=*C_|ñÅž={Z¶l™§>+++&&&àááqüøñ’ÅZ­¶À4ªfÍšŸþù¡C‡êÖ­[‚fKÀÆÆæÏ?ÿìß¿žz­V›?266^´hÑ÷߯¯¯_Xƒ–––F——633[°`ÁñãÇÍÌÌŠ>ÓÝÝýĉï¼óŽ‘‘‘.-Knß¾-Ï� ”ó,##£Â†wÆÜÜÜÍÍM>,ÛY{5¿¢)oÎÝ»w•ó4�@É0B ��õU©RE¹-}~­ZµêÔ©S§Nºuë¦\c»\tïÞ= `Ïž=û÷ïHOOÏN­Zµz÷î=zôhS³ªU«±·±±qóæÍ[·nݯ_¿ž={‘õ¼ ¦¦¦¿üòËéÓ§W­Z$¯ª®T»víaÆMž<ÙÆƦèÖÖ®];uêÔ]»výùçŸááá.ödnn>pàÀ¹sçÖ¬YSÇNÚÚÚ.]ºôã?öõõ=~üø… Š¸¥uëÖíÞ½û°aÃäÞ*#$wwwSSS_W6xðà#GŽHåÓ§OGEEÕªUëy)Ú‹xüJ E‹¡¡¡ÒáÎ;U˜= �À›FÇ=_��@YIJJŠ‹‹KNNÎÊÊÊÎÎÎÊÊ’æ‚YZZZZZš››ë8šF}©©©—.]ŠŠŠŠŽŽNII±²²ªY³fÆ K¶zt\\\|||zzzzzº´“©©©™™YµjÕjÕª¥§WQÆq§§§Ÿ={6"""11133ÓÒÒÒÊÊÊÑѱQ£F%h-33óÁƒ÷îÝKHH077¯Q£FóæÍJù{öìÙÅ‹cbbâããõõõÍÌÌÌÍÍ4hШQ£<öUFeûø�€òE ������UU”ï�����ð’ �����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤Ê|Z|�� �IDAT������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª"�����€ª¤������ *)������¨Š@ ������ª2(ïà¿ãüùógÎœ)ï^�EéرcçÎË»@ÙX¿~}yw(ŠF£™4iRy÷•CLLÌîݻ˻À˨f͚Æ +ï^à%¥ÑjµåÝüG,_¾|Ù²eåÝ  (3f̘={vy÷(¹¹¹¶¶¶åÝ  (úúúQQQåÝ T—.]êÝ»wy÷x9::úùù•w/ð’b„Ê#PP11‚ÿIŒ@A…Å>”@Íš5‡^Þ½�^111¿ÿþ{y÷/5)”1WWWF  Z¾|9þ{ôôô-ZTÞ½�òÊÍÍ%B Ô©S‡ÿ§ª¹téÊ‹š�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TE ������UH�����@UR������P������TePÞ�^¸””SSSFSÞ)FZZšT000¨R¥Jùv���JÙÙÙYYYRÙØظ”­ñÁ�¤P)={öìÑ£GÉÉÉiii999–––vvvùÿ9Ÿ3gŽ¯¯¯µµõÚµk»wï^.½ÕEzzz½zõ¤²——×Ê•+Ë·?���ŸV«ŠŠŠ‰‰IMMMKK322ª^½ºµµu™¿Ö’%KÖ¬Y#•¯\¹R»ví7¥ò?­V•šššžž®§§gbbR³fÍzõêö•­š7ÀK‹@ •¯¯ï'Ÿ|’¿ÞÒÒrРAÓ§O¯S§ŽTóðáÃüQ«Õ>~üxݺu9��ÀójÓ¦MTTTþúN:½ýöÛ#GŽT¿KPawÉÄÄdРA|ðAÓ¦Mu¼„   ±†*ŸœœœëŸ<yò믿öë×ïöíÛR………TnÒ¤‰Jý��€*²³³ ¬?{öì”)S,X r*¦ÂîRjjêöíÛ'Mš”››«Ë%ÜX�eˆR¨Ü&OžÜ¼yó7nøûû_¿~]ñøñãåË—oØ°Aahh¸sçÎÍ›77nÜØËË«¼; ��€¢I“&“&MJOO?}úôÑ£G¥šÖ¯_ÿöÛo7lØ°¼{WQØÚÚzxx˜˜˜Ü¿?,,,""B¡Õjÿýw›/¾ø"ÿ%ÜX�/*·!C†8:: !f̘áè蘜œ,„ ”Oh×®]»víÊ­���xñ6l8vìX!Ä{ï½÷í·ß~óÍ7R}`` ¹‰¬E‹òÑjµ[¶l™?~JJŠbÆ #FŒÈs 7À‹C …ÿˆjÕª5lØðòåËBy‘Ȭ¬,OOO©Ü«W¯I“&)/ öõõ½~ýúÝ»wíììZµjõÖ[o999É'¬[·Îßß_áááñöÛo¯Zµ*(((44´^½z={öœ9s¦¡¡ažnìÙ³çðáÃ.\ˆoÓ¦³³ó´iÓªV­*ý4))iüøñRù·ß~;wîÜÚµkO:õ×_ñ/:��@™hÛ¶­\–?J¢££×¯_áÂ…+W®ØÚÚ¶oß~ܸq]ºt‘Oظqã‘#G„ƒ5jÔÒ¥K8àèè¸iÓ¦ü/¤Õj?øàƒÈÈHépܸq ÊE&,B= Ÿ5k–tZƒ –/_.•³²²F-͹«S§Ž¼òzÑ4͘1c4ÍÇ,Õüøãù)¥"n,�”�þ ž={¶k×.)B :T*äääIeå¿š™™™3gÎܶm›\sãÆ7nìÝ»wܸqË–-“6¹sçŽt¹ÁáǤ“ÃÂÂÂÂÂüýýwïÞ]½zu¹ÍÙ³goÙ²En388888øøñã[¶l±²²’Ú‘û6vìØ'OžˆÂWÅ��Às¹uë–<ŠÇÆÆÆÅÅEþÑ™3g&L˜-FDDDDD8pÀÛÛ{ôèÑRå£G¤Ok5º}ûöúõë…-[¶,ðµ¾ÿþû;vHå×_½ÿþB·Ï„…)º‡7~ôèQxx¸âäÉ“sçΕZ;þ¼ü1uêÔ©ºß+!„——׺uë¤X¯^½š““£¯¯_à™EÜX�(5Gå6mÚ4ww÷ÆÏœ9Saddôõ×_¿÷Þ{E_µbÅ 9ª[·n¿~ýjÔ¨!„Ðjµ?ýô“ô#ù[,éŸy9~B„††.]ºT>\ºt©ôÉÃÒÒrÚ´iÓ§O—>"œ;wnÙ²eÒ9UªT‘ÏŸ0a‚”F�� ”Ξ=;`À�{{{'''éKÊ.]ºüý÷ßÿÿ ø¸¸8OOO)ëqss[¸païÞ½…YYY3gÎ|üø±tšüiíèÑ£Òš¤… _²d‰TîÖ­Û† ¤o4uùLX ]z(ÍžBäææþý÷ßRùÔ©Sr#Æ Óõ–ýƒƒƒTHOO¿qãFžŸ{c Ä¤P¹]½z544TaÔ¹sç}IxxøêÕ«¥rûöíOŸ>íëëdkk+U.Y²$!!A()!DýúõoÞ¼yøðaKKK©Ò××W¤)ÇX¿üòËgŸ}6gÎy¼ôöíÛãââ„Êoœ<x`mmíååõå—_Ê/ ��€xòäÉ™3gbcc¥Cƒ &ØÙÙÉ'x{{K‹%9;;ïܹsÊ”)Û¶m“VÍÌÌüþûï¥ÓäOk>ÔjµNNNsçÎ9rdž—ËÉÉ™:ujzzº¢Y³f›7o–>7êø™°@ºôÐÓÓS^2âðáÃRA¤š7oÞºuëç½uÊ…#¤=‚”Š½±�PbR¨Üììì”ÿ"uíÚuûöíE\ròäɬ¬,©<jÔ(###!„­­mß¾}¥Ê”””‹/Šÿ›-\¸ÐÞÞ^Ñ¡C‡AƒI•999¡¡¡BˆƒJŸH¬­­«V­zîܹsçÎëéé !222„Ò÷f’*UªìÛ·oåÊ•ï¿ÿ¾M©ï��ÀËËÔÔ´I“&¦¦¦Òavvö{ï½7räH9IÙ½{·TèСùÿiÒ¤‰TyîÜ9© ü´6lØ°ýû÷üñÇòÊP²Í›7K—ÔªUkÇŽR½ŽŸ ¤KkÔ¨!w&000###++Kîüðáßçžý111rÙÌÌ,ÏO‹½±�PbŒ´DåöóÏ?;::ÆÅÅ…„„Ìš5+...99yúôé:u’ÿýÎãÚµkr¹sçÎr¹S§N¾¾¾RùßÿíÙ³§ò*åV}=zôøõ×_¥ò­[·úôésóæMé0..ÎÃÃ#ÿ‹Þ¿_¡Õjåš>}ú4oÞüyÞ+��� æää´mÛ¶œœœ«W¯þøãÒâ ÇŸ?þ† bccå¥V¯^-–—IÕÄÿý´öá‡örk×®• &&&ÒÊ?æ§{ÇŽ+EWÏž=;qâ„™™YZZšô#yÕç"- %©]»vžŸ}cKðr� c„þ ¬­­8{ölé0;;[žTŸ_RR’\®V­š\611‘ËÊÏ"é{-‰<eO®ONN.º‡Ò·mÊf•ËQ�� ôôõõÛ´i³jÕªš5kJ5Ò¼6?ª ?­effJ…;wî,\¸P®×ý…òÐýB''§¦M›JåcÇŽKåÎ;—`织ÊûYYYµjÕªÀÓ »±�PŒÂ‡¹¹¹\V¦Ny(÷I yå•W¤òéÓ§åzyqGYbb¢ü•ÑñãÇåzi”“<ËÊÊJšá¯ý©œ¿A���¼ æææÒL´ôôôŒŒŒúõëW©REZ´aÒ¤IîîîÊÏiZ­VùŤ.œœœ233¥¹r?ÿüs¿~ýÜÜÜD)>>WÇŽ;oÞ<!D```ݺu¥Ê,g.„˜5k–<Àjøðáʯ` ”çÆÊ Z@ Há?"==ý矖;tèPØ™mÛ¶•Ë~~~Ò*•999òv¹zzzù׃\¹rå¦M›„)))ýõ—T©Ñh¤…¥äóãããcccGŒQàKçx�ÿ%¹¹¹RÙÐаØ?lJFþÛÉÀÀ@¹{ii$''+¿Õ(%uîCÉdggË )—og€äï¿ÿ–§¡µjÕJ Mš7o.­ß<cÆŒÂþ“×ñÓš··wjjjŸ>}rss…}ôщ',,,tüL˜ŸŽ=Bxzz~õÕWééé·nݺwïžÂÐÐpÈ!:¾–äúõëŸ~ú©¼ z³fÍ>ûì³¢/)ðÆ@‰H¡r[·n]:uÂÂÂÎ;—šš*U6iÒäÕW_-ìWW×îÝ»Ÿ8qB±oß>}}ý.]ºüñÇ·nÝ’N˜:uªµµuž«öíÛwíÚµN:8qBžÃÿæ›oÖªUKñÚk¯µoßþÂ… BˆÉ“'ûí·NNN5jÔ¸uëÖíÛ·'Mš$íÑK à¿ÍÏÏÏËËK*oÚ´iðàÁeþéééòœ//¯•+W–²ÁÐÐÐwß}÷îÝ» ÷Æ*%îC‰-Y²DÞðëÊ•+ù׋*©ÿýwÁ‚III!!!wîÜ‘ëß~ûm©0gÎœ7ß|Sqùòe‡:´oß>..îÖ­[ !!!Òi:~Z333kÚ´©———´iddäìÙ³¿ÿþ{?HÇ !,--¸k×.ñ¿Éƒº,qéÒ%OOÏÔÔÔððpåZæFFF›6m*0¤.öÆ@‰H¡rÛ·o_žšúõëoݺµèq׫W¯öððˆŒŒBìÞ½[ÞÓDѵk×9sæä¿D£ÑܼyS^¨RQ·nÝ È?]µjÕ°aäÚ#"""""ä3/^¼H �“Oxx¸bÿþý“'Onß¾}y÷@I<|øpýúõÊ}}ý©S§ÊépŸ>}ÆÿÓO? !RSSOœ8!}=)‰ŒŒ”òÙçú´öÙgŸ8p@ZŒ|÷îÝýúõ4h.Ÿ ¤c%o½õ–HIä·Y´¤¤¤cÇŽ)k4‡‡ÇŒ3¤Qÿù{c Ä*Ðr@Gù׃¬V­š³³ó?þøÏ?ÿ4jÔ¨èìììBBB&Nœ¨ ]»vmooïýû÷ÔúøøÈßÉW©ReäÈ‘ÊÕÍ[´h2aÂåèªZµj¹¹¹ö<� ÜÉ ¾T­Zµë(_ùçíêéé5hÐ`Ò¤IçÎûüóÏ•?úúë¯wîÜÙ¶m[ù*CCC‡#FÈ‹”?—5jÌ;W>œ9sfttti>êÞÃ.]ºÈß¿¶lÙÒÅÅ¥ˆf«V­ª<Ôh4µjÕêرãèÑ£~ùå—ü«U<×€’a„*Ÿ1cÆxzz&$$¤§§geeš™™8JÙÈÈ(66¶ÀFLMM/^¼xñâÇGFF6lØP¹eo~:u:þü£Gâãã[´h‘çßu‰¹¹ù²eË–-[–˜˜øàÁƒW^y%O¯ ëO]�¼8&L022 {ã7òÏ×PÁ]¹r%)))%%%==]£Ñ˜ššZZZ±¶‘›››››[NNÎÝ»wsss5j¤¯¯¯<aÞ¼yÒzáùÍŸ?þüùy*Ç7nܸ<•Å~&,âƒ_±=”lÙ²E^­bÚ´i…½_ÉåË—“““¥»d``P»víbà{Þ �%@ …J©J•*¶¶¶eÒT:uêÔ©£ãÉuëÖ•·2)BõêÕu™Æàå”››ûàÁƒúõë—wG „&&&ï¾ûny÷EIKKcýuÁÂÂÂÂÂâ¹.Ñ××oܸñ êR‰?ÑÃøøø7®ZµJ:lÛ¶­. Õ™››?ïÖ %¸±�ð\¤��PUfff‡Ž5jäæêææîöªó«fffåÝ©’ÈÊÊZµjÕ±cÇ®_¿^¿~ýž={:::vrttôúõë/\¸påÊ[[ÛöíÛ7®K—.yN öõõ½~ýúÝ»wíììZµjõÖ[o999Öì½{÷¾ùæ› .ÄÇÇ·k×nüøñ}ûö}®w±yófy9Â7ZYYÅÆƾÿþûR¯¯ïùóçW¬XqåÊ33³®]».Z´(ÏBàeu|||ä]\ÇŒ#ÿ…ùá‡>zôHahh¸~ýzålqÙºuëüýý…o¿ýöªU«‚‚‚BCCëի׳gÏ™3gVºq III'Ož  èÝ»÷W‹¿*ï“'OÚ´i#Oß366^½zu…ÚÊ�tG �@9¸sçÎ;w~üéGƒÎ;»»¹»¹¹µiÓ&ÿySLLÌèÑ£/_¾,^½zõêÕ«VVVž|æÌ™ &DGGK‡Ò*¿ðöö=z´T™™™9sæÌmÛ¶ÉWݸqãÆ{÷î7nܲeËòß™°°°¾}ûÆÇÇK‡þþþþþþŸ~úé'Ÿ|¢û‰ˆˆ ’û „ÈÍÍ•kÖ­[·råÊììl!ÄÓ§O÷îÝpòäÉš5k–ù}2dÈòåËãââ„ÿþûoÏž=«U«vèСíÛ·Kç/\¸°À4JqçΩχoQXX˜¿¿ÿîÝ»+þÐݬ¬¬³gÏ^¼x177WªgK@fiiigg'ívgff¶iÓ&Ö*Py‘¦…jРóÿ¸h�”^vvvppðâ¯÷ìÕ³EË'NܱcGTTTy÷« ,S===i:³œ )ÅÅÅyzzJ)Œ››ÛÂ… {÷î-„ÈÊÊš9sæãÇ¥ÓV¬X!§QuëÖíׯŸ´´ŸV«ý駟|||ò·|éÒ¥øøx+++å³o¾ùæÆ¥ykÊÿáûí·ÙÙÙÊ,,11ñ믿–Ëð>XYYy{{K'ÇÆÆ._¾\«Õ.Y²DªéÖ­ÛäÉ“‹í³¿¿¿”F)ã§ÐÐÐ¥K—>Ç-P׿ÿþ»aÃÏQž›4~}Ðë+V¬8þ¼œFÈÃÙÙY__À€ÁÁÁ½zõ*ïî�@ÉH…;vì¾ÿ)ìën�(Cñññ»÷ìž2uJk‡Ö.=\.\˜‘‘QÞýÊëòåË¿ÿþ»TnҤɥK—.]ºTàÿ*½½½SRR„ÎÎÎ;wîœ2eʶmÛÚµk'„ÈÌÌüþûï…ááá«W¯–Îoß¾ýéÓ§}}}ƒ‚‚äå—,Y’¿ñ/¿üòêÕ«áááò¢Â¹¹¹ß}÷]iÞ]žo –-[¾bÅ y àãÇ¿ ûпÿaÆIçûøø¬^½úæÍ›B33³uëÖ1zNÙçúõëÞ¼yóðáÃòˆ*__ßÈÈÈÜ$2*rÇŽ“&M²oeßÝ¥û¼ùóŽ=*¯Ð  ³gϾ}ûöÏ?ÿœgú0�T:LÙðyðàÁ¯¾¿–w/ð²“æëÚµk×®][»n­±±±“““4§¯Y³f/º{ºøçŸäò„ ¤?ŠZ¶lùÑGåß‚j÷îÝR¡C‡çΓÊMš4¹xñ¢Bª9yòdVV–ô£Q£F !lmmûöíëëë+„HII¹xñbÏž=•-·oß^^ìiÖ¬Y¿üò‹4·+44´4ïN¹¡•‹‹Ë„ „cƌٶm›ÔÛGeffV­ZµÌïƒbÙ²e§NŠŠŠÊÈÈX¼x±TùÕW_½òÊ+:öyáÂ…Òž: 4è×_Bää䄆†–OSžŸ –fäIA›Ž®ÿ{ÿuÿç=xð@+´òÿP„²ÚØ�Ê€—ȵ¯ý¶ã·òîð|ÒÒÒŽ;vìØ1!D«V­.XèææV¾]R¦ ®®®r¹aÆyÎŒ}òä‰T^½zµ< Jvÿþ}!ĵk×äšÎ;ËåN:I”øß²JÊk[¶l)—­­­[µj&„¸wïÞó¾£Â(c GGG)6ÊÍÍMLL´µµ-óû „°´´\¾|ù›o¾)ÿ¨wïÞòJ[ºF]Izôè!RBˆ[·nõéÓG÷vÊŠV«=pàÀÆMÏ;—““S‚‚N*óŽ¡’×ê�¼ ¤�¼DìììŠØý PGNNÎÖ­[u?_OO¯C‡n®nîîîíÚµSŽ…)/IIIr¹è}Ä“““‹nJš†¦l°ZµjrÙÄÄD.ç_Ù:Ï6i\•È7ç®4”/‘¿Ù2¿ùHîß¿Ÿ••%O,–r¿-å"èåµ—F£4hPç΃NÅÄÄ<W -[¶ìÔ©Ó ê*ˆ¸¸¸?ÿüS÷ç�ð@ à%ÒʾÕìٳ˻xÙ¥§§ëHÙÙÙ¹»»»¹º¹¸¸XXX¨Ð1Ý5nÜX.;vlÔ¨QRYÞ?NV¿~ý*UªHÓp&Mšäîî®Õj¥hI*H‘“r¬SHHˆ<.éôéÓr½ƒƒCžÆcccårRR’4÷MѼyóR½=•ù}B<{ölÚ´iÊkoܸ±jÕª3f(+Ÿ>}jbbR`:™˜˜(OÍ“—»*Þ–Õ®]{Ô¨QÒ-ºvíZ@@@`P`HHˆ.ëFuïÞ}ÉWK^|Qž.]ºôן±‡ �¼T¤��¨(LLLœÝÝÜ]Ý\›6iZÞÝ)”2?Ú¾}ûСC SRRòÏD300hÞ¼¹4“.88xÆŒŽ$jÛ¶­\öóó9r¤"''GÚ0N¡§§×ºuë<WùùùýóÏ?Ò¿ß~ûMžÖªU«Ò½?]•ù}B,X°àÁƒBˆ† ¶nÝú?þB¬\¹rðàÁMš4‘ÎY´h‘¥¥¥··wß¾}ó´°råÊM›6 !RRRþúë/©R£ÑTœ½áíííííí'Ožœ™™yöìÙ€À€€€€Ë—/³³��/)�e 99¹èé*�ŠÐºuk)„êÚ¥k¥ àááѸqãððp!DHHH—.]Z¶lòìÙ3ù9š3gŽ´"ÒåË—:tèо}û¸¸¸[·n%$$„„„!\]]»wï~âÄ !ľ}ûôõõ»téòÇܺuKjdêÔ©ÖÖÖÊf…¹¹¹trrÊÎΖÇRøá‡*ÜñîCPP¼äÓôéÓ;uêôçŸæäädff~üñÇR8½aÆœœœ¨¨¨+Vä¤öíÛwíÚµN:8qB^šêÍ7߬U«Ö‹½ϯjÕªÎÎÎÎÎΟÍý,))éĉåÝ5T™™™999†††å5)~�J€@ •Rjjê£Gž<y’žžž™™illlffÖ¨Q#33³òîÚK'44ôÝwß½{÷î€|||Ê»;@¥accãÚÃÕÍÝ͵‡kÍš5Ë»;ÏÇÀÀ`É’%cÆŒ‘V ~ôèÑ£G„®®®çÏŸúô©BÞ-«OŸ>ãÇÿ駟„©©©'Nœ‚'Idd¤4¿lõêÕ‘‘‘BˆÝ»wË{Ò !ºví:gΩ¬Ü„KÊ°Nž<©ìÛgŸ}Vô†te¨l¹¹<Y¯I“&#GŽÔÓÓ{óÍ7¥eÝOŸ>íëë;vìØôôty$QóÝ4ÍÍ›7• ®×­[wÁ‚/à”% ‹ 0@ñàÁƒ€€€€À€'N$$$”w×P¡9òÔ©Sëׯ1bDy÷¥�¿üò‹­­m¿~ýt¬¯¼*ø/@ÅD€ÊÇ××·~ýúNNNC‡õôô4hPÏž=6lؽ{÷­[·²g°š|||ÂÃÃsrröïßáÂ…òîP T­Zõ¸ÿñkW¯mØ°a䈑•.’¸»»<xP^–ÈØØxĈ[·n•÷#OKK“Oþúë¯wîÜÙ¶m[yÅbCCC‡#FÈ›jÙÙÙ…„„Lœ8Q9ܲvíÚÞÞÞû÷ï700ÈÓ¬F£ùí·ßÆŒ#·Y¿~ý;vLœ8ñE½ç‚”á}'ë !fÏž-2˜={¶ü]Ë¢E‹¢££ëׯÿÆoh433³Ç‚ùøøÔ«WO*W©ReäÈ‘ÊÕÍ+¾W^ye̘1?úüxãúcG 4¸¼{”ÄÅ‹gÎœ)T,¶�^6ŒBåSĦÑׯ_Ÿ6mÚ²eË~øá'''5{UñÅÄÄ?~ÜÞÞ~êÔ©Ï{ynnîùóçüýý÷ìÙcll,ÕËkšT­ZUþ@ôôôò¯Ï]µk×îäÉ“qqq‘˜C�� �IDAT?¶··—2#iêY~nnnnnn999wïÞÍÍÍmÔ¨Qþ¹MMM/^¼xñâÇGFF6lØ°FyΩ]»¶r-ó+V,]ºôúõëµjÕ’3 ç2þüùóç+kŒŒŒ”/![´hÑ¢E‹ò×—Õ}ðöööööÎs~Íš5óÏ_[³fͬY³jÔ¨ajjšÿ%:uêtþüùGÅÇÇ·hÑ"Ï$Ðüï·"Óh4ÊõÅ€R 733ËóÿŠôôô«W¯vèСÌ_nëÖ­U«VÍ?b¨°zT >E�J†@ •[ïÞ½›6mš’’~îܹŒŒ !DTTÔ¸qãüüüÈGd™™™­[·–vtš2eJ ZXºtéwß}'••›¯O˜0ÁÈÈ(,,ì7ÞVxðR±¶¶Öý¿}}}}åÎt…©S§N:utlÓÐаÀÌâòåËÅ^[†aÇ‹¸E(vZbݺuëÖ­[š—�þc&L˜pàÀmÛ¶õîÝ[®¼xñâàÁƒ›5kæççW¶/—––¶gÏž~ýúå Ö «G¥PàS Ä¤P¹M›6MÚ_IqïÞ½Ù³g;vL‘0f̘ÇËy^ròþâ%VØæG&&&ï¾ûniZ€¡W¯^ÅžSàH(�ÿIÑÑÑù+Ÿ>}ZàZl¥wðàÁ§OŸŽ=ZÇzT >E�JŒ@ ÿõë×ÿå—_zôèqçÎ!ĵk×BBBÜÝÝåž={¶nݺþùçÆ™™™ööö]»výàƒLLLò4¥Õj·lÙrâĉëׯGDD˜šš¶hÑbåÊ• 6Ü´iÓáÇ¥Ó|}}¥éqqqòª%C‡•öQZ·n¿¿¿ÂÓÓÓÅÅeñâÅÙÙÙ=zô˜2eŠƒƒC||üš5kNž<ѺuëyóæuìØ1OOöìÙsøðá .ÄÇÇ·iÓÆÙÙyÚ´iòü ù%<<<<==¿ù曃ÆÇÇ7iÒäí·ßöòò’NÛ¸q£¼ó·bÿþý¡¡¡BˆÕ«W×­[7;;ûÈ‘#¸sçÎýû÷sss›5kÖ±cÇ3fT«VM‘””4~üx圑ѣGëëë;;;OŸ>}óæÍûöí“_ÈÊÊJ>-88Ø××÷úõëwïÞµ³³kÕªÕ[o½¥œJûþûïË7óüùó+V¬¸r劙™Y×®]-Z$-u �%@ؼTž>}ºmÛ¶ãÇÇÄÄ899MŸ>]‚´gÏž   éóáÆ:$„=zô¶mÛ¤<x m)P§NY³f !–-[µdÉ’ôôô]»v…„„ܽ{×ÁÁaØ°a®®®Ê×ÍÎÎNJJR~þ‘lݺµnݺnnnEÔ=zôàÁƒmÛ¶7nœ|Brròüù󭬬æÍ›§¼ð‹/¾HHH˜>}úš5k²²²>ýôSåÖ™;vì ñòòR~˜<{öìÖ­[ííí5jô¼/ôÉ'Ÿä‰™’’²víÚØØX;;»×^{í­·ÞÊ?ÿZ–˜˜èããsþüùû÷ï;::º¸¸xzz>×9—/_þùçŸ]\\†äççwúôi ‹Î;Ož<YZb/::zéÒ¥BˆyóæåùElÚ´éêÕ«}úôñððj¢££·lÙrõêÕ›7oš™™5kÖìwÞiÓ¦âéÓ§Û·o¾wï^ÕªUFŽ)ó]àS4~üxéÚüŠx!É•+WvìØöôéÓV­ZõèÑcøðáʤ‡pÅŠáááûöí;~üxíÚµ8xð`!DddäÊ•+/\¸ Ñhúôéóá‡ö‹�*.-PF¼½½­­­—-[öÿػ︦®÷à'ì 2ÄLÙ„Á]G«U[m­uU­Z몣j­ T@ÜÔZµZ­v©Õ:Zç·ÚªU!7 [Q‘=’üþ8ööþ@¸ŒÏ»¯W_ᜓÜ'!’›çžóœÆ>о}ûÌÿY­÷رcloXXÛ~õêU///ó|||¤R)÷nݺ5xðàš#?~¬R©–,Y¶лddd°ÁÁÁ´qáÂ…´eÊ”)þþþ܇rss“H$=zôà6ZYYEEE±a”——/X° fC† ÉÍÍ­vˆ1cÆ 6¬Úȵk×Òa‹/®ù8æææÉÉÉ*•êäÉ“ÏíõööNKKS©T=zî€éÓ§«Tª5kÖ°-<`ƒŸ7o^Í»XXX,Y²D©TÒa>d»6lØ`eeÅìèè˜ýºo—5Ùû i( sssKKK¾fáÇñ/ö3‚GxÂË’Ëåæææƒ zÙ;Ž1ÂÜÜ|÷îÝ477·³³£gOž<¡cV¬XѾ}{öT¤}ûöíÛ·?räHûöí-,,h;m|ã7è] dnnÝ·o_úh:u¢w_·n{ôªª*±XleeuáÂnTwïÞµ°°¨yÖQ­=22ÒÜÜÜÓÓ“;æÈ‘#4¤ÌÌL¶‘ž29::VUU5ÊÜÜü—_~áÞK,›››ÏŸ?ŸÛHO¿ýöÛW;PµàŸ>}êëëknnîêêúþûﻹ¹qþ"Ž9¶DGG …B++«!C†Lœ8ÑÙÙÙÜÜ|Þ¼y …¢þcΟ?O[öïßoaaÑ¡Cooo¶ŸŸ=•U©T={ö477ÿî»ï¸———wíÚÕÜÜ\.—Ó–C‡ÙÛÛÓ¿NþþþnnnÇŽ£½&L°°°ð÷÷ÿðÃ{öìiaaaeeÅ>£ç¾‹Îœ9£zžº¤R©BCCéy¯ŸŸ_ÿþýéûðÃ?ÌËËcÇôïßßÜÜ<<<¼k×®VVVôÍÍÍøᇌŒ wwwsssúŠ™››9ò¹‘Ôí•ÿÝ4ì²­ ÷Ê[@$77wêÔ©t7nMM;}û²—îÝ»7uêÔââbúcIIɸqã¤R)ýQMMÍÎήcÇŽvvvíÚµ{©HØyL§NJIIlWvvöÛo¿œœÌm¬ªªZ»v-ûãºuë~ùåBˆ‰‰É‚ .\H¯ù0 ³~ýúj‡øûï¿### !ÜܱcÝ°I[[›[øVSSÓÀÀÀÀÀ€îׯŸ††F×®]ß{ï½Y³f½ùæ›´=###44”>¦»'!D__ßÀÀ Žë0aaa¤·mllØB *•jß¾}{÷î­?!dÓ¦MUUUÜøóóó7lØPÛ!��€5iÒ¤ßÿUs¦@«lggwíÚµÔÔÔ+W®téÒ%++‹Ý… $$$;;ÛÏÏràÀììììììÑ£Gggg=z”âííM/]ºDïBOrÆoll|îܹØØØÔÔÔ@°eË–Ë—/ÓaYYYwïÞ­ªª’ËåÜx:D7n\µ8«µûúúš™™=xð 55•sêÔ):E;½–¤2dˆººú!C!W®\a{ãããïÞ½khhxþüy§D½×ðáÃ_í@Õ‚ßµkWZZÚˆ#âãã;üøñZ~!¤´´ô£>ÊÏÏ?qâĹsç~úé'¹\Þ«W¯ƒ²§ˆõC.\Xºtéºuëår¹D"qwwOMM?>6qâDBÈáǹ1\¼x±°°ÐÅÅÅÛÛ›ò×_Í;·´´4$$$---""">>ža˜ÁƒÓñ .¼~ýzDDÄáǯ]»¶oß¾ªªªÀÀÀ²²2RË»ˆxÅõÂ<x0,,ÌÜÜüòåË7nܸxñbLLL·nÝ.^¼¸téRöqèsÿè£ÆŒ’’²eËBÈÊ•+?øà¡P(•J“’’Nž<ihh^ǯ ÙBB Z[[[öö­[·èU«VåççÓÛ{öì9vìعsç¾øâ Ú’™™Fo¯[·ŽÝ…wØ°aIII‘‘‘r¹œ®Œ{)ÜlËàÁƒccc:Ä-`Ù«W¯˜˜˜?þøƒ­;QYYIÉÊÊb³6?üðÊ+–-[öÍ7ßЖC‡åææV;„··÷µk×®_¿Þ§OÚRQQqíÚ5BHHHûRB>ýôÓ´´´´´4ZR×ÈÈèÏ?ÿŒŠŠúî»ï‚‚‚<øá‡Ò‘¿ÿþ{yy¹¹¹yZZÚ¬Y³ØGHLLLKKcã©&55uÛ¶mô¶Ï7~úé§+W®°Û‘„††>~ü¸Zü„õëק¦¦†……±É/ö¼��� 6vvvÛ·owrr"„¸¸¸Ìž=›òÏ?ÿ¼òÒtLIIÉ®]»èULMMÍ3fÐR!!!tXÇŽW¬X1jÔ(Z®R©T¿þúkŸ>}ªí®S³] ÐÚØl¨%%%—/_ž8q¢©©iÍ<Ñðáà !o½õ!äêÕ«lï™3g444æÌ™“““#‘Hhã­[·233½¼¼:vìøjª&%%…"‰Øˇulΰk×®‡Ž?Þßߟ¶èêêÒKªûöí«ÿú‹ÈÉÉ™>}ú´iÓŒ !¶¶¶GŽÑÕÕŠŠ:þ<!dìرÚÚÚ111·oßfc 5%h¹®’’zæ¿yóæ3f°Ef;wîÌ^µõñña7¦/‚——Wnnnm»¦>× TPP°jÕ*BÈž={ÜÜÜh¯µµõ¯¿þª¡¡qâĉ7nÐFšrqq ¥gÑ“&M²±±)+++..Þ¹s'}#õèÑãã?&„„‡‡×?N€f )hm¸ECØöBVûöí‡ FoOž<™ÉþgË!ÙØØìÚµ‹õÜ­µëƽ²bee5hÐ n)ÀÀ@kkëž={²WW”J%Ótúôiz5ÆÜÜ\KK‹a†atuuÕÔÔ!åååñññ5áäääàà0wî\¶‘.t!OOÏœœœ]»vÍ›7o̘14EQ©T4ž—NÓj„qãÆéèèB,--ÙëBEEEôB"7þ¾}ûN›6ÍÐÐpâĉì¾W™™™/����´)&Là^å¢+ïß¿ÿÊËiÎeæÌ™Õvü¤¹ÄÆÆÒó4BÈ‚ víÚÅvùòåÌÌLnŠªŽvzvÄæ‰þþûïÒÒÒöíÛ÷úõëOŸ>%„(ŠþùÇÀÀ€–¯êܹ³‹‹KNNNBB½×éÓ§E"Ñ»ï¾K9{ö,m¤SÙÔÒ+¨z¾ºk×®ëׯ¿ðd uq»uëfllG÷Å®Ïú‹ÐÕÕ]¶lw˜……-¥D—˜˜˜ÐgzäÈ: ¬¬ìÏ?ÿÔÔÔ=z4!D*•fddØÙÙÕ,bUSff¦D"9{ö,nF×XÔÓ $“Éž<yâææƦá(›š©FBȸq㸠úõëGéÝ»7­ŸEч¢C€– )hm¸‹iIì¼¼¼GÑ___¶×ÒÒ’-ÖH'åçç?|ø¶ôîÝ›fR{ îãíÛ·¯ÙH§±—wrss‡úöÛo¿ýöÛï½÷»Õ;«æ!è´d*//ï…±©Tª/¿üÒÓÓ3 àСC/^ÌÈȨÏKILLdo³• ÉÿñoÞ¼Yí^Ü™ìSP*•ìÔ6���€çªVW¡[·nššš*•Š=|5]»v­ÖÒ±cG•JÅ]ûVÍÁƒMLLØ+ u·÷ïß_KKëÚµkôïÌ™3ººº~~~ýúõ«¬¬ü믿! üõÖ[lÒf—誽ÔÔÔ¤¤¤7ÞxÃÑÑÑÚÚšÝ{‡Þ÷wÞyq 6¬G<1bÄèÑ£ëNÐ×gèС]þ?šù¢çÛõCµoß¾æD...„sæ?iÒ$BÈo¿ýF³HýõWQQÑàÁƒé*fš¼óòòâ&wª¡•%èíí=tèÐÉ“'ÇÆÆB^*­ùÂ%%%B\]]kv¹»»³XæææÜíìì!Ül!Ä‚`@h™°Ë´6§Nbo÷íÛ—RPPÀ¶Ð¥ò,îg›J¥â&_žûI\ ;¨þ44þûGÇ~PÕœ~E?‰ëPóCŽm©Oä\_|ñÅ?þHo;::zxx¨Tª'N¼ÔƒpÕö‚W{µ«Ý‹ûŒ^ö)����pÑIå¯é¹9mmí¢¢¢šg2T~~þ¹sç>úè£j¥6kk×××ïÕ«×¥K—âââÜÝÝÏŸ?ß«W/mmm:§þüùóï¿ÿ>ÖÄÍd <xëÖ­ááá³fÍ¢ îH0`ÀRSS;vìxãÆ gggvUÝ«ˆKCCãøñã¿üòËöíÛ/_¾Ü·oßÅ‹/\¸°æÈ’’’¢¢"@@—#ÐÒÅ„³›–©©i}ƼðA8§”={ötppHII ïÓ§ÏüA8Ó¯h²¦Ú.•J5wîÜÇÛÛÛoÚ´‰‰ |ÙSâˆ.標_#ÿž�WUU½ÔÉ¿ïöÚÞ“�ÍRЪH¥R6·¢¯¯O/ uíÚUWW·´´”Â]þøñcv"’«««@ °µµÕÖÖ¦3„%‰J¥ªùùÇM%&&Ò‚MEEE ûDØìfff»ví"œgzÛÃÃã¥ûD ÙÛ¥¥¥´¾&!dܸq´öÓùóçk~úV{„ç~ŽRô‚ÁN}b—ÄB^6~���€&FÏ ¹Š‹‹óòòÔÔԸņ¸Ž=Z^^^s½^mí„Áƒ_ºt)**ª¤¤¤°°®¼³±±ñòò¢¢ˆˆAƒ±w‰D´\ÔßÿÝ©S'¡PH:tè._¾ìêêZQQÁNzåU£¡¡ññÇO˜0aß¾}«W¯Þ¸qãG}ÄNùgéééYZZfggOŸ>;¾šúŒ¡jþ"!ééé„Z8Œš4iR``àÑ£G»wï~þüy+++š§#ÿžZs+LUsþüùÇ;88üý÷ßìYnøÔæ…¢§¥¥Õ좥6è<)€6Kö •¨ªªÚ¹sç|À.j[·n••!D °ÙÓÓÓ“““éíK—.±Wè¢9uuu6™’””D7å­v .]º°·Oœ8A'I}÷Ýwlcƒ\`ÎËËËÉÉyã7ú÷ï?`À€8pРAlðzÒÒÒb¯Õ0 ÃÎ튉‰a‹4±;²› rq·mb‹L=wâ… è …BÁVòRSSÃg-���4%ºe ÷²\m,vù‹ÎÄïÚµkm…<èééYóÂ[míäßõw‰äÒ¥KšššliÑaÆåææÊd2™LÖ¿îµ@Z¤<???&&&**Š¦–!ýúõ300¸té­¬Tm®Ó+è¹h}÷!C†( :©&zF]÷¦@õC=|øÝ;›R*•tjwíÛ˜1c´´´Î;÷÷ß—””Œ3†(GÏ<¥Rim©"Zë­·Þâ>ýš•+ê~ÃÔç@´yTTTµvÅÅÅ´@;N’¡MAB Z¶åË—7®wïÞ¶¶¶«V­bg*5Š»ÕîÊ•+Ù >£GÞ¾}û¦M›-ZD[ÚµkÇî»råJö^aaa={öœ9sæèÑ£Ù­ë¸?ÿüs÷îݽ½½úé'¶Q¡P¼þó2dˆ½={öìîÝ»/X° ((hâĉ=zôà®þØ«O‰‰‰B¡ðÝwß-..æ^ÔÚ¾}û?þðõ×_³l‚»SÌÌ™3‡J§nÕôÆo°/×ï¿ÿ>sæÌýû÷=šM~öÙgÕÖÃ���4*zR&“Õl¼sç·à�ëÏ?ÿäοwïÞÆ ! ,`¿ûî»%K–ÐícccãããkNƒª­êر£›››D"¹xñbÿþýéFräßzäÛ¶m+))©6׉ü›] «¨¨xï½÷h£¶¶ö Aƒ®]»võêU[[Ûj©—=PJJʬY³~ûí7úcµRôcw‘«æóÏ?'„¬Y³†îÃóÊc(•J5þ|n�›7oNKKsppàljj:|øðüüüàà`@ðÑG±]^^^ƒ ª¬¬œ={ös‹”Ó+ÊÜ·Ç?ÿüC/¬r×Ð=÷]Ä}¡^x Áƒ—••-_¾œ}d•JµzõêÜÜ\oooZÚ À’=hÙª]-!„XYYÍ;—»ƒ!¤gÏžŸþyXX!$33sÍš5l—––Ö¶mÛè§ !¤_¿~³gÏÞ¹s'ý1%%…­•˜ŸŸß®];‘HÔ¿ÿK—.ÑFZÿÛÒÒÒ‚~š¾Ba©šÁ×_=jÔ(ZŒ3--;³W.—ÓÂ/eüøñlº-;;;;;»¢¢ÂÎÎî7Þ s—ÒÒÒ/^LaW8ÎéXYYÑ“*•J"‘pgBU³mÛ¶¡C‡feeBŽ;vìØ1¶Ëßß¿Ú>)����­OŸ>Gݳgσlll.\Ø®]»Î;wéÒ%==½_¿~#GŽtqq3f {//¯3fìÝ»wðàÁüñÇãÇûõëÇn –žž¾bÅ BH§NæÎ{ðàAQ£FU;tmí¬Áƒ‡……edd°§ „GGGGGÇ3gÎhjj²[³úõ맭­}öìÙ®]»rOɆ öûï¿_¹reÎœ9¯y ¯¾úêèÑ£gÎœ1b„––Öøñãuuu{ô衯¯ñâÅ«W¯ZZZ2ä¹Ï¨gÏžÓ§Oß³gÏ Aƒ†îî¦öèÑ£7nÑmë3†j×®]aa¡»»ûðáÃ;vìxåÊ•ððp--­7Ò)K¬I“&?~<%%¥_¿~¶¶¶Ü® 6 6,&&¦OŸ>ƒvrrzòäIttô‚ ú÷ïÿî»ïîÚµëÆóæÍëѣǕ+Wþ÷¿ÿ9;;'%%qK»>÷]Tí…ªû@4’˜˜˜“'OfddŒ9RSSóôéÓ×®]322Úµkwj€V3¤ åÑÐШVÚI__ßÉÉiàÀëׯgæÓO?­¹ä{Ù²e¿ÿþ»‡‡;wWSSsÈ!áááÕ>J׬YsìØ1îç©©)½öEÙ±c÷ÓÚÓÓóĉ"‘ˆþÈnüšºuë1mÚ4îd"++«þýû?wcŽš:uêÔ©S¹5>éµ o¿ý–ûtÄb1Ýñ—þÈnO£««»gÏîv3u,NìرcDDÄŒ3ŒŒŒØFkkëÍ›7ÿñÇÜÊî����MàÃ?6l˜R©<uêÔ®]»èŽººúæÍ›MMM333wìØA×L±f̘’’’¼ÿþòòò%K–>|˜о}{333555ggçòòòcÇŽ 6ŒyDÕÖÎEÏÄ´µµß~ûmn;»Ô§Oî ¥¯¯ß»woBȈ#¸ío¾ù&= ®9©êeD—999ÑbÛfffýõW``à¢E‹Îœ9ãïïÿ믿Ö1ç=44tÿþý]»v=yòäÚµkƒƒƒwïÞ]QQÁ]LPŸ1„ccã³gÏ:998p 444<<ÜÛÛûÂ… ì”|V¯^½è–‹Ó¦M«ÖÕ¹sçðððñãÇ«Tª£G†††îܹ3))‰n¢'‹¿úê+ƒC‡Í›7/22róæÍt*7!õÜwQµªîBlll®^½:zôèÄÄÄÀÀÀeË–EEE}ðÁlz€6B€jüÐP¶lÙ²~ýúÅ‹ùå—}¬ªªªÇ—••UVVšššVÛë·n¥¥¥ÉÉɺºº]»v­;3RQQ‘’’RRRbnnÞ¥K—jY°¼¼¼´´4KKËb|}ùùù÷ïßïÔ©ÓK=Óç*..¦kÚ;wîÌ- õøñã»wïÚÙÙ™˜˜ÔýéééYYY¦¦¦öööõ¹†óàÁƒ¬¬¬®]»rwKizMùþhJ¥ÒÒÒR]]»16@3÷'¼¬èèè7ß|“fõ@ô´ÄÖÖ–{TVVvëÖ-===öäpäȑ׮]Û¹sçèÑ£ !©©©J¥ÒÁÁ¡æv7ÅÅÅùùù;v<}úôœ9s8@óD¬ÚÚ[„ÔÔT[[[ö|¯¤¤äÞ½{%%%]ºtá¾€u+..NMMÕ××·¶¶®­@Umc®_¿>bÄ[[[ZÁžÇÚÙÙÕ–Ý‹ŒŒ>|¸““SÝOïÞ½›››kccceeÅýVVVÞºuËÔÔ´C‡uÜ½æ»¨Ú õÂQ …"99Y¥R9::òr½¶ÉþÝÔó EÒÐШ¹£G=éêêzzzÖg¤––Vs‘ÌÌÌêÿIüšÚµk÷ú©(J__ŸîÃR©©i=F]ºtáVv¡:Ôý¡���Ð4ž{Z¢££SG!BHóVôõõéÌǧ󌪩­½E¨öÄõôôºuëö²¢¯¯ÿÂsïúŒ!µŸÇRÅÅÅ_|ñ!ä…Wmmm«-è£455ëSS¼æ»¨¶wHm¢ÔÕÕ_áõhM°d������Z°ôôô±cÇÞ¼ysРA춃�ÐÌ!!������-Õ¡C‡zöìyãÆ ggço¿ý–ïp� ¾°d�����à?„ ¾iëŒ{õêÅn‡]ªªªI“&­Y³†Ý™�š?$¤������þÌw@!nnn¿ÿþû ‡ <866ÖÒÒ² B€„„������´Tzzzµíß�ÍjH�������@“BB ��������šR��������Ц±¡ý�� �IDAT¤�������€&…„��������4)$¤�������� I!!��������M )��������hRHH�������@“BB ��������šR��������Ф��hÁJKKïÝ»Çw­ŸJ¥JIIÙ·ß´H·oßV©T|G���Í‹ß@ksúôé;wîð@uIII|‡�Ð`<x©T)•UÊN;™˜˜ 0ï Z³’Ò’È‘yóT*Õù?ÏóQsÇM?¥§§÷ìÕÓ@ßÀ·»¯òZYYñ4[ééé3fÌà; €¶"??Ÿï ­CB XRR¾ù�4¬¢¢"y´<&&†a˜ˆˆˆ¼¼<Bˆ@ „¨TªüüücÇŽÑ¡a©T*Q©T*@@_á .°·¡>²³³Û·oÿèÑ£K—.]ºt‰6šššúûù …BWWWäø€ÊÏÏ?~ü8ßQ��@`54”[·n%&&ò@]ºuëæââÂw�õr÷î]FÊ0 ÃH˜˜Øî絑‘‘¯¯¯¾ž¾½½½ŽŽq¶V—._:{ölII !ÄÝÝ]OWOÂHT*•¶–öðw†è?@KK‹ï0›5@0räHz;77722R&“Éår™\VTTÄÙ¡C¡·P(º¹¹ò/ðéÉ“'l¾�šR»víÞxã ¾£€6 )��€fáéÓ§±q±Œ„a&âFDAAÛ¥¡¡áìì,‰}}}{ôèÑ¥Kãlõ ÅáÇ×oXÿàÁBHï^½Wú}!É)Éýõ!ÄÆÆfÍê5#FŒÀl©Wpÿþý‘7är¹\.¿™x³¨øÿå§\\\|||èâ>ggg¤\��Z%$¤���ø¡T*Sï¤J)Ã0F’Àí533óûŠÅb‘Xä+öÅwò¦qöÜÙÛ·oB<<<V®X9p`õú\W®^ Œ'„øøø„‡tïÞ‡X[ •J• —ËåÑr¹\~ëÖ­ŠŠ ¶W]]ÝËËK(ú}„B¡½½½ºº:Ñ��@CAB �� é<~ü˜–‚b¤LäHîÄ---WW‘XäëëÛ³GÏ:ðg±&h Ã0„.]º,[¶lÔû£j›ý¤T*ùå— 7dggBÞÿýËW`æZƒ¨ªªŠŽŽ¦“§d2Ù´;J¥’íÕÑÑùˆ„ÿêܹ3¡��Àë@B �� )ŠÛ·oÓ9P ÃЩ7,+++±X,‹}ž>>>ššš|ÅÙ–%&&†¬ 9þ<!ÄÂÂbÑÂE“'O®Ï¸ø«­_íÞ½»´´TKKkÖ¬YóçÍ722jüÛ’’FÊÈÿ•™™Éí544ìÞ½;;Ê‚¯8��àe!!��ÐÀòóó% -I.‘HJKKÙ.]]]777___±HÜ£GöíÛó'Ü»woý†õ¿ýö›J¥2Ð7˜3gάY³ ^êA²²²Ö¬YsôØQBˆ™™Ù²eË>šð‘†62n‘‘‘òg3¨ätÇI–………ŸŸ<åîænjjÊWœ���ðBHH��¼®ŠŠŠ¤¤$ #‘2Òë×322¸½:u‹Å´$¹——*à4yyya_…íÛ·¯²²RSSóã?^¼h±™™Ù+?`tLt@@@DD!ÄÑÑqmÈÚ4\¼ð|>ŒŠŠ¢É©ø„ø'Ožp{ìØÅ}.../›j��€F…„��À«ÈÎÎf¤Œ”‘J‰T*å–a600ðôô‹Ä"±¨‡LÓhVŠ‹‹wíÚõÍ7ß ‚F}°lÙ²†*EtòäÉàà´´4BH¿~ý‚ƒ‚]]]ä‘¡>nß¾-—Ëer™\.OJJ*))a»››ݹO(:;;kiiñ*��� !��P/eee‰‰‰t-^Äõˆ‡Ù¹½vvvb‘Xì+‹Äîîîjjj|Å µ©¬¬üéçŸ6oÞœ““C4hP`@`ƒ'Œ*++w·û«¯¾*((“'M^²d Öf6=¥RÇ.î»}ûvUUÛ«¡¡ÁNžz íììðo�� ‰!!��P«ÌÌLº#žD"‰ŽŽæ~¡566öòò¢kñüýýQʺ9S©T'Nœ]z÷î]BˆX, ìÙ³gã1??ý†õ?þøcUU•¾¾þÂ… g|:CGG§ñŽu«¨¨`+£Ë£åiiiÜs`===±HÌf¨lllx �� @B ��à?ÅÅÅqqq´ù7rssÙ.555º#žX,vqqá1N¨¿K—.ÅÅÅBW®X9lØ°¦9tJJJàª@ºŸÍªÀUï½÷ž@ hš£CŠŠŠ¤R©L&£Kü>üMLLºwïN÷ …Â×).���µAB ��Úº»wïÒ9PRF«T*Ù.sss///ZÜ××W__ŸÇ8áeÉä²à à«áW !ÖÖÖ_.ùrܸqM_T>üZx@@�͈ …Âà??¿&ŽêöøñãȨHvUµâèVVVÏ6ï󺻻ó'��@k‚„��´9OŸ>‰‘2R†a"nD°]ÎÎÎt”H,rtpä1Nxe)))¡ëBOž<I111™?þôO¦ó¸bN©T<xpýúõ´ôØÈ‘#W®XikkËW<P·DFFÒÅ}ñññ………Ü^''':sÊGèÓ­[7===¾â��hÑ�€ÖO©T¦ÞIe$ -•Àí577‹Äbñ³’ä(ôÓ¢e=ÌÚ¼ió/~Q(ºººŸNÿtÞ¼yÍdJKIIÉÖ¯·~ûí·¥¥¥ššš³fÎZ°`ª5s*•êÖ­[tæ”L&Kº•TVVÆöª©©yxx°‹û555yŒ�� AB ��Z§ÇÇÄÄ0 #a$QQQEEEl—–––›«›H,‹Å={ôìСqBC)((ØöͶݻw—••©««?~É’%ÖVÖ|ÇU]Öìà à#¿!„˜šš.]ºtÒÄI|Çõ¢P(bbcØÅ}))) …‚íÕÒÒb'O …B[[[” ��¨ R��ÐJ(ŠÛ·oK$Z’üöíÛÜ^+++±XìëëK÷ÒÒÒÒâ+Nhpeee{¿ß»uëVZúgøðá+W¬tppà;®ºÄÆÆ\»~âèà<hÐ ¾ƒ‚—VVV&“ÉäÑÏòSéééÜ^}±ï›÷5Ãô(����€ìñãÇt#a$Œ¤´´”íÒÕÕuww‹Åb‘ØßßßÒÒ’Ç8¡‘(ŠÃ‡¯[¿.++‹Ò§wŸ€À�¡ßqÕ×éÓ§ƒ‚ƒîܹCéÛ·opP°››ßAÁ«+,,”H$ϲSÑòììln¯™™Ywßîl~ÊÄÄ„¯8��š$¤�� %©¬¬LLLd¤Œ”‘F܈¸ÿ>··S§Nb±˜–$÷òòjúýÔ )=w688899™âáá°2`À€|õÒ*++÷ìÙöUØ“'OÁĉ¿\ò%ò§­CNNNTT”L.“Ëåñññ?æöÚØØtïÞÖŸrww744ä+N���^ !��Í]vv6ÅH©TZQQÁvèxzyŠEb±¯ØßÏßÔÔ”Ç8¡É\¿~=(8ˆaBˆ­­í²¥ËÞÿý]¬çÉ“'6nØ¿UU•¾¾þç >Ÿ1c†®®.ßqACJMMe÷%&$q{]\\ØÉSÝœ»aw��hõ�€f§¬¬,!!®Å‹ˆˆxøð!·×ÎÎNL‰Äîîîjjj|Å M/1118$øÂ… „ ‹E Mž<¹ÕìkvçÎÀÀÀÿýù?BH‡G½?ªE'Ú 6*•*11‘]Ü—””ÄMµ«««{zzÒÊèB¡ÐÁÁó=� õAB ��š…ÌÌL¶ytttUUÛellìååE×âùùùñ'ðåÞ½{ë7¬ÿí·ßT*•¾Áœ9sfÏž­¯¯Ïw\ ïÚµk±±±„o/ïààà=zð4®ÊÊÊØØX™LF3T©wR•J%Û«££ãããC÷ …Â.]ºð*��@CAB ��øQ\\ÇH‰D™››Ëv©©©9::Ò9Pb±¸[·n˜$Ò–ååå…}¶oß¾ÊÊJMMÍ)S¦,Z¸ÈÌ̌︑J¥:tèPèºP:=ðÝwß XеkW¾ã‚&RRR"•IåÿÊÈÈàöùúú …Bš¢jß¾=_q��¼$¤�� éܽ{WÂH†‘2ÒظXî�333oooZ\,ð'4EEE»víÚ¾}{Qq‘@ ýÁè¥K—vîܙ︚HIIɶo¶íܹ³¤¤DSSsƧ3>ÿüsccc¾ã‚¦öäÉ“g›÷EËår97}Oiß¾ý³ü”PèáîRz��ÐR !��èéÓ§1±1RF*‘H"£"Ÿ<yÂv©««»¸¸Ð9Pb±ØÁÁÇ8¡¹©¬¬üñ§·lÙ’““C4hP`@ ««+ßqñ ëaVHHÈ‘#GT*U»ví¾üòË'¬¡¡Áw\À›¬‡YŒ„‘Ëå2™,.>®  €ÛkooÏ.îsssk•ËZ� u@B ��’R©LIM‘2R†a$Œ$11‘ÛknnNwÄ‹Å"6ƒšT*Õ‰'Ö†®MOO'„ˆÅâU«PD)... üZ8!ÄÁÞ!((è­·Þâ;(hn'ßf÷%&&–––²]ÀÕÕU(ÒúèÎÎÎZZZ<† ��À…„��¼®üüüèèhZ’<**ª¨è¿½Ìµ´´Ü\ÝDb‘¯Ø×ßßßÆƆÇ8¡ù»téRPpP\\!ÄÉÉiÅŠÆã;¨fäÌÙ3AAA©©©„>½û»»»ó4# …"!!®ì“Ëå·nÝân¡©©éåå%ü—½=v)��!!��/M¡Pܺu‹aZ’<99™ÛkeeåëK'A‰…B!.ÈC}Èä² 5AtP‡¾\òåرc±Õ}M•••ßÿý–°-ùùù`„ K¿\jeeÅw\Е——ÇÄÄ<ËNEËïܹÃ=ó××ק3§¨Ž;ò*��´AHH�@½<zôH.—3Ògÿ•””°]ºººîîîb±ØWìëççgiiÉcœÐ⤤¤¬ ]{êÔ)Bˆ‰‰Éüùó§2]GG‡ï¸šµ‚‚‚›6ÒõôôÌ_0sæL===¾ã‚f­°¨P&•Éår™\&—˳²²¸½íÚµ‹Å´þ”OëÞÈ��š$¤��àù*++)ÃHFʤ¥¥q{;wîLç@‰ÅbOOO”X†Wõ0kÓ¦MP(ºººŸNÿtþüùFFF|ÇÕb¤¥¥­Zµêì¹³„kk뀀€ÑŒ|Ç-C^^ž„‘°õ§òóó¹½ÖÖÖÜÍû°½#��48$¤��à?ÙÙÙ %ed2Yyy9Ûe oàéåé+ö‰E~Ýýpñ^GAAÁ¶o¶íÞ½»¬¬L]]}„ K¾X‚ug¯&""" :&šâååܳgO¾ƒ‚–'33S"‘ÐÅ}qqq………Ü^GGG¶8º««+¶¤��€×‡„�@›VVV–@wÄ‹ŒŒ¬¶‚ÃÞÞ^$ѵxnnn( ¯¯¬¬lï÷{·nÝúäÉBÈ;ï¼³bù ¾ãjÙT*ÕáÇ׆®¥ÿ„‡hggÇw\ÐR©TªÛ·oËd²g›÷ÝLä^ŸPSSsww§‹ûèæ}˜$ ��¯� )�€6'##ƒ­GÃ݃ÉØØØËËË××W,wïÞk4 )Š_ýuý†õ4iÒ§wŸ€À�¡ßqµ¥¥¥ß|óÍŽ;Š‹‹544>þéÂ… MLLøŽ Z¼ªªª¸ø8vq_rr²B¡`{µµµ½½½…B!MQuíÚëF� >�hýŠ‹‹ãââ$Œ„a˜¨¨¨œœ¶K 899Ñ9Pb±ØÙÙ_$ 1œ9{&$$„nÈèáá°2`À€|Õ:=|øpmèÚ_ýU¥R™˜˜|¹äË?þXSS“︠õ(--ŽŽ¦‹ûärùÝ»w¹½"‘ˆNžòúX[[ó&��4wHH�´NiiiŒôY=¨¸¸8¥RÉv™™™ …BZ\,ð'´zׯ_ b†bkk»lé²÷ßyÏÆxåêBˆ½½ýš5k† ÂwPÐ:=}úT*•Êår™L&–gggs{ÍÍÍÅ"1ÍOyzzš››ó'��47HH�´………òh¹”‘2 I ôPêêê...b‘Ø××W$¡^4„„„µ!.\ „XXX,Z´hò¤É˜ªÓ”Îýï\К ä”dBHï^½ƒ‚‚<==ù Z¹G±›÷ÅÅÅ=~ü˜ÛÛ¥K¶8º»‡»¡!_q��ï�h©T*UrJ²”‘Òµx7oÞäþI·°°‹Ä"±H,‹|DØ šÒ½{÷Ö¯_ÿÛÑßT*•Ágs>›5k–¾¾>ßqµEUUUûöíÛ´yS~~¾@ 7nܲeˬ­°Š šÈ;wØÅ}ñññÅÅÅÜÞnݺ ÿåê⪭­ÍWœ��Ðô�hIòóóår9[’œ»-·–––›«›ØW,‰ýüü:vìÈcœÐfåææ†}¶ÿþÊÊJMMÍ)S¦,Z¸ÈÌÌŒï¸Úº‚‚‚Í[6ïÝ»·²²ROOoÞÜy³gÏÖÓÓã;.h[”JeRRÒ³ÒèÑò›7oVTT°½îl~ÊÑÑQ]]Çh� ±!!�Ь)Š[·n1 C§AÑšÐ,kkkZÊWìëíí­¥¥ÅWœ�EEE»víÚ¾}{Qq‘@ ýÁèeË–uêÔ‰ï¸à?wïÞ]µzÕ™3g!VVV+>üðCÔó¾TTTÄÅÅÉår™\&—ËSSS¹åuuu½½½éÎ}>>>]ºtá1T��h HH�4;9992™Œ‘2Œ„‘ʤ%%%l—ŽŽŽ‡‡Ý¯{÷îVVV<Æ @UVVþøÓ›7oÎÍÍ%„¼ùæ›+\]]ùŽ žïÆòh9!ÄÓÓ38(¸W¯^|@Š‹‹éÊ>êþýûÜ^cccvó>¡·ÐÒÒ’¯8� ¡ !�À¿ÊÊÊÄÄD #‘2RFʤ¥¥q{;wîLç@‰Ä"OO ¾â¨F¥R?~<t]hzz:!D,¯ \Õ£G¾ã‚P©TG~;²víÚB†º*p•½½=ßqü'??ŸnÞG³T999Ü^KKK‘HD‹£{zz¶k׎¯8�à•!!�À‡J¥RºO.————³]ú^^^b±X$ùu÷Cýhž.^¼OqrrZ±bÅ°¡Ãø ^BiiéŽ;¾ÙþMqq±††Æ'Ÿ|²há"|±‡æ)++‹a:y*6.¶  €ÛkggG÷ …Bwwwl¡��Ð" !�ÐDÊÊÊâããi=òÈÈȬ¬,n¯½½½H$òõõ‹Ännnjjj|Å ðB2™,(((üZ8!¤C‡_.ùrìر(?ÜBegg‡® =xð J¥266^òÅ’©S§jjjò@]’S’ÙÅ} ¥¥¥l—@ puue÷uëÖ �š'$¤��QFF[<66¶²²’í222 …b±X,wïÞÝØؘÇ8ê)9%944ôÔ©S„“ |2í¾ã‚וpåÊBˆÝêÕ«‡¾=”ï �êE¡P$&&²‹û’’’ªªªØ^---ÿ6ïs°wÀ%�€f )�€†TRRÃH†a¢¢¢¸5/““%‹±¹´ Y³6mÚtàÀ…B¡««û駟Ο7ßÈȈ︠!ýù矫׬¦»yöìÙ38(ØËË‹ï �^Nyyyll¬\.—Édòhù;w¸ßwôõõÙÅ}B¡;�ð )�€×•––FwÄc¤L\\w×jSSS±Hìëëë#ò140ä1N€WSPP°mÛ¶Ýßí.++SWWŸ0aÂ’/–`‡ÇÖªªªê‡~ظiããÇ !cÇŽ]±|…µµ5ßq¼¢Â¢B™LƮüYôcš-ŽŽÍû��šR��/­°°P-—2R #‘H$ùùùl—ººº‹‹‹¯ØW,‹D"ãxMeee{öîÙºu+­üÎ;ï¬X¾ïê¶àéÓ§[¶lÙ³wOEE…®®îÜÏæΙ3…¢¡ÈÍÍ•J¥tq_LLLnn.··cÇŽìä)/O/L�hTHH�¼˜J¥JNI¦s †¹yó&÷§¥¥¥ÐGì+‹Ä>>>ººº<† Ð  ů¿þº~ÃzZ}¿Oï>>B¾ã‚&•žž¾zÍjZ2ÌÊÒjÅŠcÆŒAýhMîÝ»ÇNžŠ‰)**âö::8²ù)777|¾�4,$¤��ž/??_.—³%É Ù.MMMwwwZÜ××·sçÎ<Æ ÐàÎœ=B yxxöïߟ7‘‘‘+VÊårBˆ‡‡GPPPŸÞ}ø  á©TªÛ·oÓä”L.KLL,//g{ÕÕÕŸmÞç-ôññqvvÖÐÐà1Z�€V� )�€g ERRÅ0 ý6ⶶ‹Åt-ž———¶¶6_q4žëׯ¯ Z#•J !¶¶¶Ë—-ï½÷P}T*ÕÑcGCBB233 !oy{ÕªUX¼ ­[UUU|B<;êöíÛ …‚íÕÖÖöòòz6{Ê[hgg‡?•��/ )�hÓrrrd2™„‘H©L.+..f»ttt<==éŽxÝ»wG ghÝ‚C‚ÿúë/Bˆ……Å¢E‹&Oš¬©©Éw\ÐŒ”••íܹsÛ¶mEÅES§NýbñíÚµã;.€¦PZZ#—Ëiý©´´4n¯¡¡!ÍMÑúè:tà+N�€ )�h[*++†¡%ÉïÞ½Ëííܹó³zäb‘§‡'fãC[pïÞ½õë×ÿvô7•Je``ðÙœÏfÍš…òÕP›G­[¿îÀJ¥ÒØØxñ¢ÅÓ¦MÓÒÒâ;.€&UPPÀݼïaöCn¯……ÍL …Booo333¾â�h΀ÖïáÇR©T"‘0RF.—sKBèëë{{y‹Ÿ-Æó577ç1N€&–››öUØþýû+++µ´´¦L™²ðó…øâõ‘˜˜¸*ðòåË„®]»®^µzØ°a|À›ììl©Lú¬8zL wû]BH—.]ØÅ}ž††|Å �Ь !�­Pyyy\\­G.‘H<xÀíµ··S"±››vŒ‚6¨¨¨èÛo¿Ý±cGQq‘@ =zô²¥Ë:uêÄw\ÐÂ\¸paÕêU·oß&„ôèÑ#88ØÛË›ï �ø—––Æ.î‹‹‹ãNNNÿmÞçꆪ”�Ðf!!�­DFFÅ0Llllee%Ûedd$ }}}iA(ãàWeeå?þ¸yËæÜÜ\BÈ›o¾°2ÀÕՕ︠¥R(?üøÃÆóòò!~øáÊ+Q@€¥T*oݺ%—Ëe2™<Zž˜˜È=EÑÐÐpwsgóSNNNêêê<F �Д€–ª¤¤$&&†‘2‰„a˜G±]ÀÙÙ™ÎòõõurrÂÞ7�*•êøñã¡ëBÓÓÓ !¾¾¾=zôà;.h ÃÂÂv·»¢¢BWWwÎœ9s?›‹Jd�5UTTÄÇÇËäÏêO%''s¿Žéêêzyy±õ§lmmù‹� Ñ!!�-É;wé³ÿâãã¹0›ššúøøÐ’ä>"h�àºxñbPpP||<!ÄÉÉiåÊ•CßÊwPÐÚÜ»woMК?þøƒbii¹|ÙòqãÆaY4@Š‹‹£££éâ>¹\~ïÞ=n¯±±±[ þ@+ƒ„�4k…E…r¹œ‘0t&·J¨ººº««+]…'‹íííyŒ Ù’ÉdAAAá× !:tXúåÒ1cÆ`I4‰D²2`¥T*%„¸¹¹÷íÓ—ï �Z†Ç³;÷EÇDgggs{­,­Øü”——W»víøŠ� A !�Í‹J¥JNNf˜g¨¤¤$öíÛ‹EÏþ …zzz<† ÐÌ%§$¯]»öôéÓ„“ |2í¾ã‚6áرcÁ!Á„Áo ^½fµ£ƒcmƒ 1­ ºÌÌLn~êéÓ§ÜÞ®]»Ò™S>>>îîîX$ �-R�À¿'OžÈd2 #a†a˜ÂÂB¶KSSÓÝÝ],Óµx;wæ1N€æC¡PÔ1Ë)ëaÖÆ<¨P(tuu?ýôÓùóæ5e„�eee»víÚºukQq‘ººú”)S–|±ÄÔÔ´Ú0™\6mÚ´ÇO \@T*Ujj*»¸/>>¾´´”íUSSëÖ­»¸ÏÕÕUSS“Çh�ê )�àB¡HJJ¢s CÄÛÓ�� �IDAT¤Œ49%™ÛkmmÍîˆçåå…íªIHH˜?þéÓ§kNw*((ضmÛîïv—••©««4á£/¾øeG€G999ëׯÿù—Ÿ•J¥‘‘Ñ¢E‹¦2]KK‹0lø°ÈÈHkkëßOüŽÅ×�õ¤P(nÞ¼)—ËiŠêæÍ›UUUl¯–––»»»P(¤õÑPÍ �š!$¤� ‰äææ2RºO*“ËŠ‹‹Ù.OOO:Jì+¶¶²æ1N€fŽa˜1cǬZµjîgsÙö²²²={÷lݺµ  €òî»ï._¶ÜÁÁ¿Hþ“””péÒ%Bˆ­­íªÀUï¼ó!äÔ©SS¦N¡c,--Oœ8áäèÄg �-SYYY\\»¾/%5…Ûk oàåå%üæ›@3„�4–ÊÊʄĆahIò»wïr{»téò¬¹¯ØÝÍËêãŸ+ÿLœ8±¤¤„bbb"e¤ÆÆÆ …âСC6nÈÊÊ"„ôíÓ7 0@è-ä;X€êþþûïÀU·nÝ"„øùù­^µz欙éééì�ssóÇO¸¸¸ð#@kPXXÈ.î“Ëå™™™Ü^º11]Üçííݾ}ûW;JNNNØWaóçÍÇ<\�x5HH@uÙÙÙ_mýêÝwÞíÙ³çËÞ7ëa–ôßyPÑÑÑeeel—¾¾¾·—÷¿³ |ÍÍÍ4j€ÖïÌÙ3Ó§O¯¨¨`[æÏ›ïãã²6$99™âéé°2 ÿþüÅð …⧟Ú°aCnnîs˜šš?vÜÝݽ‰hÅrrrØÅ}r¹<//ÛkccÃNžòöò®ÁÁóçÏŸ0^[[ûã?ž7wž¥¥e#Ä�­R�ðŸÇóÍ7{¿ß[ZZºlé²E‹½ð.åååqqq‰„¦¡ª]‚s°w‰E4åââ‚æ^Ùá#‡çΫT*¹Á³Ïq[[ÛåË–¿÷Þ{€§�^Baaáú ëwïÞýÜ^“£Gz{y7qT�mÄýû÷år¹L&“Ëå1±1EEEÜ^{6?åî«[ÛãlظaÓ¦Mô¶ŽŽÎ”)Sæ~6÷•ç[@„„�BHaaá·ß~»óÛìIÉ›o¾yèà¡ç¾ÿ>%‘Hâââ*++Ù.CCC‘H$‹ér<“¦ˆ µÛ»wïÒeKŸÛ¥««»zõêI'aÝ+´,_.ýòû￯­×ÈÈè·#¿‰D¢¦   R©TÉÉÉr¹\&—Éåò„„„òòr¶W]]ÝÅÅÅÇÇGè- …ݺuÓÐÐ`{ÇŽû×_qMWWwÊÇSæÎkaaÑtÏ�Z,$¤�Úº’’’½ßïýæ›oòóó¹í¦¦¦·oÝfÇÄÄÄH Ã0 Ã<zôˆ&œé(±Xìää„ � +,,,t]hm½êêêׯ¡x9´,É)ɽ{÷V(uŒ1008üëa??¿&‹ �*++ÙÅ}IIIÜ™¹:::ÿ®î>¬Úê?JWWwÚÔiŸ}öê3�@Ýh»***~ú駰¯Â¸ &®5kÖ¤ßMg¤LBB÷kC»víØ9P>"Cæ  ÍYµjÕŽ;êóÎ;ïìß·¿iâhã'Œ?þü ‡éëë<p°W¯^M�ÔTRRòßæ}Ñò;wîÔÿ¾zzzŸLûdÎœ9fff!�´hHH´EUUU¿þúë¦Í›ª•|ªººº«««¯ØW$‰Eb{{ûÆŽ�”Jå¢Å‹~þùçú >þ¼Ð§±Ch à y{H=ëêêþòË/ýúökÔ� > Øû"nDT›\ÿ\úúúŸ|òÉœÙsLMM› B�hYh[”Jå‰'6lÜPŸk\]ºt™4i’¯Ø×ÛÛ[OO¯ Â�ª²²rÖìY¿ÿþ{=Ç÷éÝçĉ@zðàÁÕð«W¯^ ÏÈȨ{°¶¶öÏ?ý<`À€¦‰ �êcÍš5ßlÿ¦žƒ ô >™þÉœÙsÚµkרQ@Ë‚„@ræì™õë×ß¼y³žã===/þ}±QC€šJKK§LR­Rìsúúúúûùw÷ëÞ«g/Tpƒ–èîÝ»áááW¯^½víÚÃì‡Ï£¥¥õÃþÞzë­&Ž �j3räÈðká/uƒO?ýtö¬ÙØô�($¤�Ú„K—.…††Ê£å/u/uuõ´;i˜Д ÇOQÛ€:øùùùùùùûù»ººª©©5ex�*9%™N›ºvíZµbÉššš{÷î6t_±�K¥RuµëÊnÍüR fÎœ9kæ,ccã �Z$¤�Z¹ˆˆˆÐu¡u|¹­ÛÉ?NöìÙ³aC€Úäåå}8æؘn£@ èÖ­›¿Ÿ¿Ÿ¿Ÿ_w¿N:ñ@“Q©T7oÞ|–œº~íéÓ§„uuõïv7bľ£hën'ß®ãüP]]ÝÐÐÐÈÈÈÈÈÈÐÐÐÈЈþhhdȶw´éèïïß”1@3„„@kvûöí³çΖ””Óÿ—””qËËËk{„ÀÀÀysç5eÌ�mVVVÖû£ÞONN&„hkk …B: ª{÷ m™R©Œ‹¥Ëú$ÉÆ?õßA´iIII'Ož|–oú7ñdhdhh`hdd„Éõ�POHH�Q(ϲTÅÿe©èÿm:Úôé݇ï�Z¿´´´éÓ§[YYùùûùûù{yyiiiñ@³SUUëæ榭­Íw,���ðZ��à_^^ž©©)ª’���@¡Áw�ÐÔ²³³üñG¾£�hjK–,á;„fäÆW®\á; €&Õµk×Ñ£GóEC’ÉdõÙŠàuØØØL˜0ï(Z¿;w¾Zp€–kÔ¨Qööö|G<à ©6'&&fРA|GÐÔrrrø¡ÙºuëÚµkùŽ I 0àðáÃ|GÑöìÙ³|ùr¾£€V®{÷îgÎœá;ŠÖÏÃÃãáÇ|GФ8ðÖ[oñð 3¤Ú(++«É“'ó@SØ°aß!4S=zôèÛ·/ßQ�4º´´´#GŽðEc‰D¸Î!33ó—_~á;Š¶eÎœ9|GÐèŽ;–’’ÂwÐ, !ÕFYZZ.^¼˜ï(�šRµñ÷÷Çßh .]ºÔŠR>>>ø‡ !** ©&6kÖ,KKK¾£�htÑÑÑHH¥Æw���������ж !��������M )��������hRHH�������@“BB ��������šR��������Ф�������€&…„��������4) ¾���h�¥¥¥ô††††¦¦&¿Á4’òòr¥RIQSSÓÖÖ¦má‰���@ëƒRÐú•þ«²²’ïX^EUUû¸íEEE*•Š¯¨�š•²²²ÎÿZ²d ßá4–¡C‡ÒçØ¿ÚÒFž8��¼&¥RÉžOÒk ®¶SÖ×Ñ৻ååå4Âòòò|Ø:´ôo"� )håZÁ·µÐÐPö)deeÑÆeË–9;;{{{_½z•ßð���� ™»pá{>yòäÉÆ8ÄsOY_GcœîÖ¼´Ó¨ZÁ7€F…„@Ë“‘‘ñý÷ßWTT<xð`ÇŽ|‡��ÐDšl®A£N'yî L£�àÂé.@[€„@ËcaaallLo;88Ôó^J¥R"‘lÚ´éí·ß~áTê—ü\=úí·ßfÏž½}ûöW¸;��@5M9× Q§“`ù-À ½Úé.�´,(jÐòhkk9rä矶··ÿè£êy¯uëÖmݺ•Þ~ájü—\SEE…»»;½ãœ9s^öî����Ж½Úé.�´,HH´HB¡P(¾Ô]^jÅÁk.OP©T(¸Þ–åääÌœ9“Þþ駟’““wïÞ-“É D"ѼyóüüüØÁUUUþùçÉ“'ïܹsïÞ=¥Réää$‹/^lhhXí‘ïܹóý÷ß'&&Þºu«¸¸ØÚÚz̘1ŸþùsÃø矶mÛFo›››oݺUWW÷Þ½{dæþýûYYY:tprrš<yòÀ«Ý=!!á믿–Éd¥¥¥~~~óçÏ?~ü8!¤wïÞ܃fggïܹS&“ÅÆÆZZZúøøL™2…û !ÅÅÅ;wîüóÏ?ïܹ£¡¡Ñ©S§,Z´HGG§¶—1::zÛ¶m2™¬¢¢ÂÃã>“&ÒÓÓ7nÜ(“Éòòò„BáÔ©SüÂ{47J¥R*•^¾|ùâÅ‹Ç×ÕÕå;"�àÁ+œî@Ë‚„4)|M­ù5õTVVŽ;–Þ4hЬY³èíÚ¾ñ–——O:5--}„ñãÇ«««÷êÕkáÂ…Õ¼   ¶ÁFFFçΣ'N9r$½=oÞ¼ÌÌLBˆ¶¶öÎ;9Â#„üñÇqqq„mÛ¶ÙØؼæs‡A©T^¹r…ÞÞ½{÷Ö­[Ù…ŸçÏŸ¿xñ↠&MšD[Î;7uêTîÝ£¢¢¢¢¢Nž<yâÄ [[[¶}ëÖ­[¶l)++c[RSSsrržCaaá¼yó<x@ÑÓÓ;qâýN;a„¤¤$î#¤¦¦ž;wîóÏ?_¾|9Û~ðàÁ%K–°å]N:uùòe'''©TJéÔ©;222rÚ´iÙÙÙôÇ´´´´´´“'OnÞ¼yüøñ´±  à­·Þºsç{¯üüüôôtî«Ù¿ÿŠ+ØR2/^ ×ÒÒªm<!$>>~ðàÁyyyì].^¼¸téÒE‹Õq/€fè5gé@eeå×_ý÷ß'%%uéÒeàÀÞÞÞµ >~üøÿþ÷?z1ÃÓÓ³W¯^ ,¨ö‰S\\¼cÇŽ¨¨¨[·nUTT¸ººúûûÏ;WOO﹩R©¾ÿþûÓ§OÇÅÅY[[÷êÕkÅŠ5Oàë~ 5OwwìØqñâEBÈСCÇŽ»qãÆÓ§Oçåå988|üñÇ5'R½Ô¥:^‡½{÷ÖçØÄĤþO°þ/iý¿z�´8HHA“Â×Ôj_S_B¡`_ÆÎ;Óu|ã-,,dÇS×®]#„˜™™Õ|ðŠŠŠÚ¯[·nË–-¹¹¹„›7o8ÐÐÐðÌ™3‡¢#W¯^mbb’œœÎÞ=#####ƒÒ€{�C3Ç=‹]·n!D__¿ªªŠþ骪Z±bÅÀÿcïÍ©ÚÞÇÿeŒx7YÆÌTÆ*T†iШA¥’Ä­¸Jš4ntuU·4\u+IƒJ3ÅM!’P”))â*Ó1žßëÛúíÏ9Çq ‘Z¯¿öyγ×Z{³÷~žg=k-ss 411AñS))©üüü0Œââb??¿'N rBCC}}}q±C† /--ÕÕÕeÛ†;v ÛœïäÉ“XmÊ”)oß¾500PQQikk‹‰‰AjÁÁÁóæÍ5j�àíÛ·žžžMMMè•òòòššt›�øùÿßÛóÓ§O‹-ª­­�˜™™™˜˜$$$ÄÄÄ477{zzšššÊÈÈ��|}}ѽ) 0}út!!¡ÌÌLyyy¶ÏËËÛ¶m[KK ú8lØ°¦¦¦ÚÚZÜ$¶¤§§�ÄÄÄQ“��3fÌ@×E ô¾ÓžôÂ/Byyù’%K222ÐǬ¬¬¬¬¬ö¬>//¯óçÏcIbbbbbb\\Üùóçñ)Ož<Y·nŠ¼`É“'O.]ºD}ÃRÙ¸qãƒÐñ—/_Þ¼ywåʪ©Ì¶æîÛ·o‘P@@àÚµkÉÉÉHž‘‘ñûï¿¿ÿžj´s?´Óa?Ì™3‡˜ËKéRî]¡?B5'ô*LnjCCƒˆˆÈ€¹©øÑŒÜT%%¥9s游¸XZZ"ç ¹©¸ä¦âhÔ!CFŒ!**Ú7UPPÐØØxåÊ•È�çää cä¦âW‚ŠŠÊÿþ÷?n*ŠF™™™íÞ½ÛÒÒ�€ÜTÔ€ž…êñΞ={Ñ¢E†††<<<<<<¢¢¢XYDDDTT÷<Êbbb@ŠŠŠ?ÿü“Á`àßÂÐÐÐÕÕ�0`À�|º€€€¨¨¨¨¨h{¾7áçƒÉÚóôôÌÎÎ.((À¡X:„Ž tÿþý”””'NìÝ»÷Â… vvvè«ëׯ£Û­´´tß¾}Xÿܹsyyy‰‰‰ùùù3gÎdmÀƒ.\¸€Ž÷ïß?uêTü•³³sffæÕ«W8…þ™mmm—/_F:{÷îÅ¡ŸC‡=}úôõë×666¸|§8p�…~&NœxéÒ¥ß~ûíÂ… h~ASSSHHRCQ]�À¤I“Nž<yøðáGáoYÙ³gŽFíÝ»7''';;çBr`ß¾}YYY+W®D’¶¶6œiB tŸ¿ÿþ{Þ¼yóæÍ»|ù2F[¿~½¶¶¶ººúÚµkQ2leeåîÝ»-,,TTTlmmSSSY ¡Ñh»víš9s¦‚‚Âøñã×®]‹½Ê/_¾Ì›7ïÚµkXyÉ’%óæÍÃO *ÅÅÅ®®®cÇŽÕÒÒZ¹r%ÕµÃ$&&®]»ÖÔÔTQQqÒ¤IÎÎΉ‰‰¬jÍÍ͘6mš’’’©©é¾}ûÚ‹ÿ¦¤¤,[¶LOOONNNOOoÙ²eøoôôôU«Véèèhhh,\¸Û (**úí·ß GŽ¹páÂû÷ïwx €ÙµkŽFñòò¢áœ?KÅßßEa† âîîîáá‚P©©©üñÒùôéÓªU«Ðý% `ll¬¯¯¾zÿþýªU«êêêXK~ðବ,–¼}ûvï޽ݼ4l`<|ø=7¨æåßÿýáÃtŒ†vp4jØ°a¢¢¢ht‡µØûK˜K¸ïRî]¡¿Â üb¤§§CÍÍÍû¤öÚÚZHaÿþýuuut:}Æ Xèááõ322¨§ÿöÛoHG\\œN§3Œ?***"¡²²òÝ»w‘fKK RhhhÀ%»»»ÇÄÄàgÎœ¡^RRòéÓ'üñÝ»wâââHsß¾}Hèàà€O¿páƒÁ ÓéË—/ÇB///¤éåå…$¶¶¶¸LKKK$ôööæ¾ÓöìÙƒËÿøñ#ëE!5###$Y°`µÃññÞ½{ñYuuuœ+å ìììŒäÇÿ믿б¢¢âû÷ï±NǧïÚµ‹û‹ý fôm~4<!ôõõýNåSÿ¢&&&mmmH^VV†åLO¡òòòcÇŽ­_¿ÞÎÎNGG«ååå1Œ³gÏbÉ©S§8×èì쬫«‹Ž}||ض0>>~ûöí«V­š>}º¤¤$RvrrBߎ1I¬­­ñ)999¸Š-[¶ ¡ªª*’ìÝ»÷Ù7\\\pÚ´iHÍÌÌ I$%%7oÞœŸŸÏ¹q±£FÂB:®¦¦†ä†††¬>uêT¬\QQŸ`'Nä\ÝOOll,„ÐÎή¯ÒÃœ8qB¸uëÖÞ¬ÔÃÃý¯V®\i``�)hjj>{öÌÐÐ*”’’JII¡–ðôéSMMMø‘–– c0åååèödúÃkhhPuTUUËÊÊpETë#..¾yófü\b04ÍÜÜœImÔ¨QøøÚµkHóäÉ“¬;vŒC…††JKKSõedd°éÂö^¶°° ÖŽ8pà@ý†Ü’œœ !´±±éåzM´´´ „Ô?p—A¦>ÂÀÀ�™ŽÙÙÙ¬é?ÊÊÊ"É“'OÐéÑÑÑH2|øðŠŠ ƒáêêŠO¼uëRÛ¿?îÝ» ©&«‘‘ч Æ«W¯ðËK\\¼  €Ë akîîܹ“z§ääääååÍ™3 ÃÃѦ½½==z”Á`Ô××{{{c!¾û¸ìw607WÁ}—rïzô/Яsÿþý¾n¡ï!R„^…kjjzzz8pÀ€ÔôZ<¤�=ztEEEHHȆ .\ˆ! �yðàèضm›µµ5®ˆ5ý§¡¡ÁËË »»»;88P¿•‘‘{üøñŽ;ûí7^Þÿwƒ¼ÿàaU}}ýÅ‹� °}ûv\¥¹zõ*:ÐÓÓKýÞ³–íˆq7Á×ïååUPP�� f*õüñ‡””� ±±ÑÇÇ }}}IÎ0-cÆŒÁ÷…¤¤¤šš:ÎÏÏG ÃËËkôèÑÞÞÞááá±±±hŽ'¢ªª �%(Ù7oÞÄ÷,ëß2##COOoîܹÇŠŠJNNnmm¥ÖU^^^]]$zzzøD ¦¢***>þŒŽ:4í8Ó 7œ¶¶¶†††.]º”m6S±ÆÆÆX>`À�iii®®®Ž!„šššè¸¨¨ˆÃYB§Àé 7oÞÌÏϧæ&Ðh´iÓ¦åååQ…---Ôɶ¦sŸÒ›––V^^N­ëóçÏ8…�„3%‡>mÚ´aÆ� Fhhè©S§°&—é$eee;wîDÇ#GŽ\±bÅÔ©SEEE'NœØ^wu*G“žž^YY)&&&**Š…8_›@à@JJ >vttD/uuu777&Í[·n¡BAAAd¬ #¸±±ñÕ«W�€ÿþûéKHHLŸ>S­hêB ˜½{÷¢ô(MMM[[[$d0¨Ì.Cu%|||FŽ©ªªº~ýz,Ä‹Wà¼K111”b,,,¼}ûv!S™\öè9˜û.åÞõ ú)$ Eè3ˆ›Ú³tÊãíC† ùóÏ?©KKËn®ŠEø‰Á]^aßþžžž¡¡¡h†Úˆ#æÎ;gΦBÐ=ˆà¼°7�€:Ñf×®]ÔpL^^Þ¼yóÐ (**:yòd'''¦(OMM >¦.|Æ`YYùëׯœ[‚¯qþüùÿý7^ŒƒÁ`Ü¿êÔ©ÔëÂ|ùò4ˆsl«Càýû:ì1{¨'++«ÌÌÌððpèALœ81##ãÆx‹¤¤$‘ép–+„°°°:A5;;»°°ððáÃL-ááá ~ûöm@@�ž´‚V;�àÝKtuuŸ>}zöìÙøøxIII$ôóóC7`FFÆ•+WPUU5======>>žuÁääd|!ÁÁÁaaaYYYZZZíu™~Kè}rssñ±©©)>VRRjOóÓ§O666ÈX3g^Äíýû÷•••åååèã¸qãð¹’’’Ø–f*¥Ž‘˜˜˜àcê¶9Ý7€º^; %wjh‡›~@=bsߥܻBÿ…¤}qS{–Ny¼Ý„i£ú÷ïßc@`ÛR�€ÚÚZœˆ–ÙnhhÀ ‚.^¼811ñøñãóçÏg*„º&7ól^^Þß~û ׸nÝ:|“^¹r…{>|éççÇdØ)((àì ìÜ�ÊÊʘ*¢jº¸¸\¾|ùÒ¥K/^ ?~ü8V¶³³ËÈÈ ™’ååågϞŠ¸£ððDZƒÁho¯õÛ/_¾¼xñ“Í =Sz‚”””………™™îܹSZZÚÈÈ/»ÖÖÖ†WuéÁôassó%K–ˆŠŠ®\¹R[[ KJJÙðäÉübZ¼x1zmIJJZYY!amm-ºG¸O'¡fi¹»»_¾|¹¥¥eàÀÞéÜçhPÑÕÕ]»v-//ïæÍ›qùh•.3Üjpc¯RKcÚ#º«1L½/¨v#“ Ùp¬.@§†v:e·wßæ¾K¹w=„þ Hú â¦ö8œ=^êÛ”ú†CPÎÊuuuîîîTINNNpp0—§~5îß¿3###q²�šP–‘‘#ÅxEOÖ±· �صku7IVfÍšµ{÷n<÷éÓ§ÿý7:~öì:SVV�TVV¾{÷Žz:???Îw(..F© ÔiGX?‚uuuÍÌ̦L™2eÊsss ###ô-š 0`À€eË–ÅÆÆb‹yéoÞ¼™<y²ššš½½}[[›€€�¾…‹‹‹cbbÐñ©S§XŸ6Tbbb°k}ñâEœã‰çî= Ì3f âW'Uˆ†Fz6}MœA +�@kk+Ê &P?Só^¿~ :“NbnnŽoùœœ´žú™3gÚk!™~KèTTTð1uTïûŒÁï11±Ë—/c{õâÅ‹È^:uª’’Ú�””„Ï­ªªÂ÷Ž††kX–:F‚g¨Þ#éÔÐ7ý€¸±‹QÍ÷]ʽëA ô_H@ŠÐg7µgáìñ¢KÃÊÔ-˜œaÎÊ�€]»v¡2•””ðgÄs-�‚‚‚xÌ'55•äOýÊ´´´X[[;::.]ºÔÓÓ …„„Ö­[þoÚù‘#Gþý÷_oooªm‡þ“–––HRRRbll¼páµkך˜˜œ;wŽ©F´êŠÆô÷÷Gž'®®¬¬ÌÓÓóßÿµ³³Ãc•øÿO]ÁÅÅEWWW]]í.W[·nEÚÚÚsçÎõÆõŸ�� �IDATññqwwŸ>}º¡¡!V[¾|ùüùóÿúë¯ÈÈÈ€€€úúz$Gnç?ÿüóæÍ›¶¶¶èè踸8��ê|îìÙ³MLL¨kíá`>@íŸ9sæœ9sfÎœ¹cÇ$Þ°akË „„ºÍöKY1ü~éì9íå °ætpŸI! pãÆ ê®èIÂvÀN•Ì™~KèÔ€fxx8Ú ­¶¶ObÅ`³¶²²²¢¢ÂÔÔÙ«æææÈ^•””äááÁjEEEyyyè8..ëR£ÏôVýüùó;w———Ú¼ïG§†v¸é¤Ð¡ ÌÖ¨f‚û.åÞõ ú/dŸHBŸÜTKKËÆÆFüžhÏMe0ùùù'OžÄBª›úôéSðÍM8qâСC_¿~½zõêeË–QkÄnêÿý‡Â7þþþæææêêêLnª––ÖÙ³gÙº©8KËÅÅ­@Áv³Û­[·ÚÛÛƒonªžžž®®î§OŸòòòªªª¨ã!=ÅòåËÛÚÚ&Mš$//ÿòåK&� //•×®]{êÔ©Y³f­]»9Ã��ä ›››sPŽÿ÷ß‘ÜÃÃcܸqwîÜimmmjjúý÷ßoÞ¼‰Ï’““CÇììì±cÇ*++‡‡‡EÖ ?8<<< QQQTá–-[Pö²²²©©);-,,Ü´i�@XX§¦ã­Žƒƒƒmmm‘ÙØ؈‡ ©yTÖ­[‡V8njjruuŽŽ^±bEdd$2øp^®×ebbâîîŒ4‘õ9qâDœÅ3w¦NºjÕªÐÐP�@}}ýãÇ?~ŒÛPZZ*--ÝÒÒ’’’RWW÷èÑ#j UTT.\þo>ºs.\xñâET]KK :211Aq1ä¥F{'Ožüøñc¦Åe·oßN6 ü  Ñ~ô§uqq™2e Úa|ÛôG‹˜Òl©Q$.¡:½IIIø.@i1¥“ eƒ»t�€˜˜XXXØëׯ;våÊt-ýõ—››NǨ®®:t(ø–£¢Ædú-¡×°±±QQQA›Û$%%M˜0A]]=))‰j¯¢¿¥µµµ®®nZZ�ÀÕÕ500ÐÈÈhØ°ayyyùùù...Ë—/�ìرcöìÙèV]°`ÁêÕ«ð˜îСCñüVêɃF­¯¯ÿìÙ3¼d’ƒƒî|oÖ­[‡;_¾|ù„ ª««©6n-—ýÀ ÌÖ¨f…û.åÞõ ú)$CŠÐg`7õþýû8âÃä¦"!rSCBB¨cƒT7çí#7õêÕ«ÙÙÙœÝTtŒÜÔæææ+V`ó÷Ì™3›6mÊÌÌÄù´Ln*ÖüðáC]]u{&7#75888,,,%%%??¿´´´ =Æäñ>zôÈ×××ÙÙùÈ‘#HŽ=^�À”)SpG1ŒgÏž¡äVg¸=ej¢²ªªªŠŠ Š»�Ð’±¸(ê4-))‰º†á×aÁ‚+V¬À ²²²aaaxò,�àرcxU�€¾¾þ£GðÞRØŠUVVNJJrrr<x0Væáááçæ憽ÐW¯^;v ¯X7pàÀ½{÷âÍ7q]�€íÛ·GDD,X°`äÈ‘“&MÚ±cu¦-5b»ÿþK—.3çÕ0@[[{Á‚è?_[[kjjJ}|ñóó/^¼øêÕ«(qÃÑÑ躺º(…“‡‡çÊ•+ÎÎÎØWPP¸pá¼yóÐG|Ûâž‹/.[¶ 7CAA!""ÂÙÙ¹½þ!zîÓ‡9dér 5ezµ¶¶â©C¼¼¼(õ€ût’¶¶6ôÀQWW?tèÐï¿ÿŽä Ÿ>}dú-áÇ€ŸŸßÏÏ¿tJJJ<xPWWgjjŠ³Ñ?í €e ÃÂÂ>|ïÞ½üü| 522Âÿö’’’={ö ˜ˆ  à¡C‡°ÅˆßÈcÇŽ¥Ñh·oßÆïVœ½Û ,\¸›èhh';;[HH›¸µÜô—60[£šî»”{׃@è§ )BŸ±`Á‚ž?MÖ“••Ý¿?5þرcîîîxšŒ¾¾þÑ£G§L™‚6èarSýüü.]º„sš:tS#""PÖrS·oß~ìر-[¶ å¸eË–¶¶¶Ý»w7ÕÈÈèòå˦¦¦‹-Âù´Lnªµµµ¯¯ovv6jÌ€FŽ©¦¦Öã¡äñÆÄÄà’ùùù,Xàåå…aaá“'OnØ°ïo‚Ffÿûï?†áö”q¢2�ÀËË -Kïåå‰~”={öXYY!×zÕªUoß¾=sæ Ž6’%M}||Þ¼y#))I]ö!<þ|UUÕ»w•Q´ˆí.<¢¢¢~~~~~~4­¨¨HTTTFFé ±f ¡O*óæÍ›={v^^//¯ªª*úSd333êRÍÑÑÑø˜z§cÍÖÖÖwïÞµµµ)++S~2dÈ™3g?~üXQQ!”““£îj?vìØôôô¢¢"j¦??¿Ïž={^¿~-..Ž‡”™öv––¦^xPP¿¿ÿ›7o¤¤¤zmš@à.Ó‡ÛËÒå¾"SSS”3�¸~ý:ß„ nÞ¼‰gǬ[·­,Î}:ÉóçÏlmmÕÕÕyxxnß¾¾:t(ºÝX“#¸ÏÑ`~kddÔÒÒ‚SºÈô[÷L™2åÖ­[ëׯG›µ Ϙ1㯿þ211A+{⸉šš²¢oܸâª��)))uuu \àÖ­[½½½³²²]' `nn¾wï^êjk¸Xssó?þøcÕªUh»gAAÁyóæùùùáѦ^� íìÞ½ûܹs(6¤  pðàÁOŸ>!ç‚<ê°¸´ÙÕlá²KAg\¡_ üb¤§§CÍÍÍû¤ö††ø wwwƒA§ÓÓÓÓKKKÛ;¥²²òùóçÕÕÕÜ”_VV–œœœ••Å¥>---¯_¿ÎÉÉimmåþ¬û÷ïã‹Š‰‰a[l~~~nnnKKKZÅ=t:ýíÛ·ÉÉÉMMMí©½{÷.)))''·§¹¹9??ŸKåNQ[[›–––––öéÓ§.œÞ# Ÿ¦¯jÿ19xð „Ð××÷;•Ïz§÷;nݺ•€?¾yófܸqèŠh4Z¶ÐYbcc!„vvv}Ýæĉ­[·öf¥{öìÁw7~/ – Š‹‹‘ðæÍ›XøìÙ3\ÂæÍ›a;|üøéÔ××kiiQ¿Ú²e £ýgËÎ;±¼¬¬ ?|ø ­­Í¶¢3f477ãÓ>|(##ä3þ|%%%tÎøöäd%44•óÛo¿aaTTƒÁhkk³µµeÒ—••µ··GÇcÇŽEçVWWc…9sæ°ÖÒó?'G’““!„666½\ï¯ úÃãoOQQQ‘‘‘Aý·s ªª*##£ªªŠƒN}}}FFFnn.—e–””dffr0J{–––—/_rß·Üô8Õlél—2¸p=~|Ð3ðþýû}ÝBßC2¤}Ì€Ø.…ˆ6lØ°aø,MRR²;I|||jjjœunß¾=tèP<­ ''§‹ˆˆŒ=šm±ÔÄLFFF‡MâÜ9L 0@II‰uc &¨~~~¶-d«Ü)DDDðæGB?âÈ‘#©©©BBBŠŠŠÍÍÍ………8×ÏËË‹i NÀ=ܤ·—ÒÛ)dee“’’üýýÃÃÃñzêÒÒÒ7n\¶lJp@p™N"##£¤¤DÍßTVVÞ´iÓ‚ ÐGÖäîs4˜¦ßnÙ²åâÅ‹¨¦L™ÒÙ PÌ‚Kå¡C‡¢åÏ8 ,,ÌÖÖm&!FëpŸ¸ÌóåããÃùDÜÀM?p€ƒQÍ–»´ ®Ð )¡sô ›jaaÑ¡çuO Â÷ ®®.==�@§ÓÑÌ´iÓȪL„_™;wîܹ“IèäääääÄ$œ1cF{¯0γ\)))EEE¥¥¥Ã† CÛɹ�€={öìÙ³‡U.""âãããããóñãÇÒÒR%%¥ö†¸ÆŽûäÉ“OŸ>}üøQCC-{Ç´‰Òikk“——g*L¿%¸áìÙ³œu6oÞŒwæýÅ!#d„Ÿ":AϺ©$ØDøYáããÃ+nâ5}ûÁÁÁQQQ9994‡‡GVVvĈ®®®ãÇïëÖ? í¥Séf–.†mš+ܤ“pÖi/9¢³9€‹r¡ŸâééI‚M\BFÈ?=$ EèUˆ›J ü \¿~½¯[ÑuQ*D_7„@ ¯ q=?=$ EèUˆ›J @ B\ÂOoÇ*@ @ BÏAR@ @ „^…¤@ @ ½ H@ @ z"B¥©©©¡¡¡­­­¯B @ : H~,~L÷²¬¬,!!áÝ»w}ÛŒ³s„>ÄÎÎN^^þêÕ«}Ý@ „~ISSSfffJJJ]]]_·…ðËAR„ V÷²°°022’N§÷I{¾|ù²víZmmíÙ³g7îúõë}Ò ñ½ @ Ý„F£¥§§'$$ÄÇÇççç×××÷u‹úž–––[·neggw¿¨^v^ºÙò»wïêéé™››OŸ>ÝÒÒ²gÛF t_7€@àƒÁ°µµ---ݼy³§§gï7`çÎW¯^9räüùókjjtttz¿ @ �� ƒN§óòò0 ¯ÛB ôWœœœXGXÇïíím``Ð'Mú¸páÂÆEDD²³³ØårzßyéNËß¾}»zõêæææ¥K—ªªª ~§FíAR„ ‰ÒÒRiii.O¡ÓéYYYzzzݯýÍ›7ááá·nÝ:th÷ $ÀJaaá‹/lll„„„8¨%%%ÙÚÚ***>{ö¬×ÚF üd´´´��¬­­§M›6`À�0sæÌãÇÏ;·¯Èž´ðÙ"!!ÁÃÃ#&&Æù)Ô!]p^ºIwZîçç×ÔÔ´nݺ]»v}¶BR„{÷î}üøQ^^žå/^Ìž={äÈ‘111ݯ:##ƒÁ`hjj’h@ ߉>φ&~AÌÍÍ—,Y‚Ž]]]ƒƒƒ}||<==gÍšÅÏÿÃyˆ=ká³ÅÚÚ:--M\\œ—·»kÚtÊyé>Ýiù‹/��ÆÆÆß¡]W5¤?:üüüÜ?Ðkjjzp<ZÅ\[[»§ $Ü‘‘áîî �ˆ÷öö¶´´œ?~@@@mm-çsÜÝÝ===?þŒ…ÑÑÑ®®®¦¦¦kÖ¬ £Óé—.]rwwÏÍÍå¦%7nÜ��DDD,X°ÀÈÈháÂ…ÑÑÑLš555'NœX±b…™™™••Õ¦M›RRRX‹º}ûvkkë•+W\\\,--÷ïßÿáä‰Ê_ºt)2™¨®® \´h‘‘‘‘««ëÅ‹97ž@ø1¡ÓéÏŸ?§JPB�€)¡   €F£õjã„_•õë×8ðëׯoÞ¼é붰¡g-üö••í‘éÀr^z„®µ¼¥¥¥¤¤g‡Ð§üpño‰#GŽäçç/]ºT__Ijkk9’””TQQ!++kmmíààÐÔÔ´uëÖÒÒR�À‡ÜÝÝ�222›7on¯äÌÌ̈ˆˆW¯^ÕÔÔhjjš˜˜ÌŸ?}E£Ñüýý‘ÅœœœŒJ[±bëR§OŸ666ž;wn|||LLÌÓ§O<~üxWWWQQQ¬YSSž˜˜XTT$((¨­­mgg7~üxֆݾ};>>>;;»ªªjøðáÆÆÆ®®®l=._¾, °}ûö!C†p_ËçÏŸ=šššZ__oll<cÆ %%%oooeeå 6P5cbbîÞ½›––6hÐ ƒ… ª¨¨0µ!444//OXXXSSsÍš5jjjíõ9À åååaaa ãëׯ›7oHOOôèQddäùóçUUUÙž˜››»|ùòÚÚÚ“'O¢;¢µµuãÆaaa��EEÅ„„„k׮ݹsGTT422réÒ¥œ[RZZÆÇÇ—šš"**ÚÜÜœ——»k×®uëÖaM—èèhyyùâââ³gφ……:thÁ‚Ô¢DDDîܹséÒ¥¡C‡~ùò%===22266öСCAAAƒ ¢Óéyyy111‘‘‘'NÄågdd¬\¹²´´TGGGUU566öòåËIIIìþX.Ðk´—æÀšPàèèuá²È.Ð ðòòJJJÖÔÔPåœíÀ?þø£¬¬ÌÏÏN§£·Ò»wï´µµçÍ›gjjÊTEssóéÓ§Ÿ={–““#%%¥­­½råJYYYªN```III``à»wïΟ?wïÞ½mÛ¶qiá£ö\¿~=..NZZzæÌ™³gÏ�”––<x0--‡‡gêÔ©6l q >,&&æíí…¬\¶þ`q^³`fffkkqåÊ•’’999GGÇ©S§²^Ettôõë׳³³GŽibb2oÞ¼¨¨¨ÄÄDWWב#G²ê³¶õC@@@iiéßÿ<###<íãßÿMNNnmm�ìÙ³‡ORRrëÖ­è[^ÐÃ0¿éééBssó¾n{lmm!„—.]jOòõë×qãÆA544æΫ©©9zôhƒñùóg qqq!„PBBBBBÂÔÔ´½Šüüü¤¤¤ „&L033C'ÚÙÙUVV2ŒÜÜ\ ø TÚõë×YˉŽŽ†nØ°áôéÓâââ222:::è¬ &äååaM{{{qqq;;;###qqq)))ê•2Œ²²²Å‹£ÓGŒa`` ''7a¶]‘““£¬¬,!!qãÆNÕòôéS---¡¼¼¼±±±„„ÄðáÃÏ;!\°`VkiiÙ¾};„PKKkÅŠæææ#GŽLOOÇ:§NBý3mÚ´)S¦HKKŸ;w®½>ï+Pöu+~,<!ôõõí놰çÑ£GBuuuIIÉS§N}þü™Á`šššBmll°&õ¦¨¨¨ÐÕÕ…ž?+=zB¨££ƒfබ¶þ÷ß#FŒ@78õÏÌ–ØØX¡¢¢¢ŠŠJTTTcccSSS`` „PFF¦°°k>þœz¿ß¼yB¨¦¦ÖÐÐÀTÔèÑ£>|ØÖÖF£ÑÌÌÌ „&&&²²²QQQÍÍÍ kÖ¬àÒêëëµ´´“’’°]ûxÇý€ Î·³³ëë†ô0'Nœ€nݺµ¯Ò ÐÝmaaÑ¡æôéÓ!„ÑÑÑTaBB„P__ÿ»5ðÿ“œœÌôÈ%|?aVVVÖ u­X±BxúôiªF£IHHÈÈÈ w.ƒ;;нL!„ÚÚÚrrrBqqqjùÙÙÙ“'O†*((ØØبªªB•””®\¹BU³´´„ææ檫«#û­ªªŠ{ ½UŸ<y¢¤¤$%%¥¢¢‚Î:sæLqq1êäQ£F!áìÙ³©ç²>^8X¹íù#&‹ýîÝ»B;v K`øðᨠ‡¦¶¡¥¥ÅÍÍ }¥¯¯¯¡¡!\²d 2 ž={ÆöªY[Žú!!!• ¦¦†ÊÔÖÖÆ¿¯““îUqqq ‰‰'¢¯8{I=‚½½=„ðþýû=U ¡ÿBR¿ý= �!tttlkkC’üü|¬Ì¥¥†Þ¯¯^½B’?Nš4 Bèää„Õ¼½½!„ÞÞÞŠâÞsîÐ_mkk³¶¶†ZYYåää asssnn.kW°õ½¹©¥¶¶½½½½››› FYY™»»;òÏíííñ¹!!!ÂÕ«W755!ɽ{÷¤¤¤tttZ[[ N—••ÏÊÊB eee555œº¾/ )V~ð€Ô“'OЯ¶cǪ¼¼¼YºØ‚Á7N·²²‚;v ëWVV***B“““©å\¼x•ÿòåKÎ-AF„ÉbF†rxx8‡sÍÍÍ!„±±±LE=xð�ë g„ðèÑ£XX]]-++ !,--E’   á¶mÛ¨å¿~ýBhffÆù ú1¨¯¯wss³³³C¡›››››ÛþýûÑ·‡vssCîÖÕ«WÝÜÜÐ]6þ|¤‰bÊí¤¢££ÿýw“™3gúúúR B—!©Þ¤oR4 ½O}||°°C;ñ-p¬¡¡1sæLtÿ655…„„ «2..©Ñéô & 2>ÛÚÚŽ?!”’’ÊÎÎƕΘ1Bhiiinn÷îÝ;$çÒÂG†´¢¢â–-[Pgþûï¿BYYYƒeË–1ŒÄÄD%%%áÕ«Wñ¹LÎV.g„Éyá~p«k£h¬FÜÎÎΨayyy(‚æîîŽÕjjjBµÞ¹ô’º H0$ÏŸÐÏÈÏÏ�èééñðð Ó ²ùòå ÚHâäÉ“šššH(--}ñâE~~þk×®=}ú”ûÒPjnEE…“““££ãàÁƒ�ŠŠŠ—.]NIIÁkÍèêêRç͘1c̘1Ÿ>}JJJB’ÐÐÐÔÔT•›7oâŒ\~~þ#F0UÚØظtéÒ÷ïßïÛ·ÏÞÞžúU‡µ<x°¬¬ÌÄÄdïÞ½hÑJIIÉýû÷£nÄsjjj‚‚‚øùùýýýÐÊÊjÚ´iÅÅÅ袊‹‹étú!Cp %%%©³ „®înaaaœ:ŽGY÷ÉÉÉL§lØ°áùóçžžžk׮Ŵ´´ÚÚÚ1cÆ0ÍZµ³³ëÔÆƃž7oUbhh�`»ÐFIIɳgÏîܹÃ`0ÐGê·RRRæææø£‰‰ :˜6m2dÔ¨QàÛã�pûöm��^}¡¦¦6xðà—/_666r-B_ÑÔÔ�¨¬¬ ¿{÷.úöÁƒaaa………�€´´´ðððŠŠ �À£Gfqq1Ûb[[[wìرdÉ’˜˜%%¥úúúàà`›ŒŒŒÞº2¡_ééééáá1þüñãÇgff9rdûöíè[nì@ðÍ ®¯¯ AÓӜѻØÇÇ©:t¨  `òäɾ¾¾ÈøäááY³fÍòåËQnz;gee={ÖÔÔTAA¡S…¦à©««ûùùIJJ�–/_>|øp:^WWwôèQ4/ØÐÐpÅŠ�€'Ož´Wg+·SþjUmmíþýûgÎœ)((( °iÓ&qqñ¦¦&ìwTUU��Ž?>zôh��//¯‰‰É¾}ûÚÚÚÀ·Þæ¾dee:„¦ªªêââ�xôè‡{ÖK"¸¤ý �@HHHbbb×JHKKûüù³¦¦¦U>|øp4‘ûñãÇÜ—ÖϹ=õúõë�€7â{°õ½¹¬%>>�°fͪ²   ^é‘””TUU5uêT!UŽ:-55� ¢¢2jÔ¨êêê;w2­8@ t ‰2 ÕÕÕ%Rƒ8sæLdd$??ÿÌ™3©òœœ��kH—‡‡§S‘SÖ}6µ´´��åååXÂ`0BCCÍÍÍuttlll233�L‹°2ÝPÇGÆ7S{ÄÅÅ�x9ç‚‚�€Âÿåëׯ�€²²2@è+L£Ñ®\¹�ÐÑÑ¡Ñh4 ŧ˜ðññ¡Ñh&L��„……!MôögåÔ©SÇŸ={vZZÚéÓ§<xpöìÙ¯_¿®X±¹p-OŸ>={öì¹sç=zTWW7gÎ;;;ü-7v øf¯]»VFF†ªæää�ÈÌ̤Óé�€ØØX�ÀêÕ«™Ú°jÕ*Ô’––$A1—Å‹3Ø)/^ŒãDàÛØϤI“¨¯Zt!LæÎVnü‘·zj ³lÙ2ê‰FFF�€ââ⺺ºöNéY/‰@ನ9¡Ÿ1}útCCä¤$[[[SSSÿö–7nôÜ×ÐÐ`ýJKKëÎ;]Ø^„Ï™Á`œ>}:,, ¹©ì¯fgg�ÆŽ˹®3gΤ¤¤°úÞ\Ö‚¶cuÑ Dýˆà˜˜¦±)d1 ¥%�Û·owrr:uêÔåË—===W¯^Íýè Àª5‰Aƒ~(ÌŠIII133‹‹‹stt|ðà¾+++�¬÷f÷aúŸ3Œõë×GDD¨¨¨êëëCwîÜyíÚµ®•rÑeÖ×××ÖÖòðð888€o+?ÊÆ ëîõýI7oÞŒŽŽ¶¶¶îÛ?,°¦lÏ�� �IDAT+V¬hjjÊÎÎÞµk×Ù³g+++Ïœ9ƒ¾åÒD())1.+++**Z[[[PP ©©Ùží­¦¦ÆÇÇ×ÜÜ\PP€RƒÑ ®Cc˜3LA4eeeÐÑÀ[8X¹]ðGØnEEEáÁ-ΣhUUUœËï°ÆQ£F 477WTTˆˆˆ°=å{xIgH@ŠÐÏàççGÛl9rä¿ÿþ366Þ´i“‡‡÷% Y�l}T4Œ€Gi¸§CϹCµ¡¡%;üïÿã\W{¾7—µ Q‘]tô†ÖÑÑA ØØõEÇxÇÃiÓ¦ÅÆÆ]»vmÇŽááá¡¡¡èÅO t¶3ÑŠŠŠ��L»Ì¬[·ÎÛÛÛÖÖöéÓ§›7o>rä’£4u4 ˆJkkkÏæôEGGGDD¨ªª>|øß\=²u4�`àÀ’’’4ÍÉÉINN®GÊ$~P‡ kÇÍ›7SSSI@Š@àŒ   ŽŽÎùó猌nß¾ýêÕ+”Ì¥ˆhÏ ®­­e0 µµµ€ñÉÇÇ' ÐÚÚŠmoTEׂ:uà§=8X¹Ý÷G�ËàÖ÷EÃt¸-ï÷ð’΀¡ÿÁÏÏ¿bÅ {{ûÐÐÐÝ»w,]ºTBB‚ËÓ‘+Ëê£�Þ¾} ¾MÆézÎú«ÂÂÂ222?~ÌÍÍE“ÞÛ£=ß»Sµ2ÕR]]Mýˆ^·***{÷îå|í#GŽ qssÛ´iSJJÊñãÇ÷ïßÏùÊÊÊ222ÆŒƒ%mmmhŦ±; ^^Þ£GšššFDDLœ8qñâÅàÛkbbâ»wï±þ­[·š››{°©(cêÔ©T® ƒ™í¡®®N£ÑbccQ’@@t*‰ƒ@ ´Çÿþ÷¿9sæ;vìÌ™3�±;3¸®®®²²’——WUUUHHHNNîÇ………LæzII NÀãLœ#D½+·›þ+½6ŠÆïá%œ!kHú+hÑDkkëÖÖÖ7n`!�€óS-Ñ—’’”¦[WW‡Öhì£yÎT “çÌ¿Šê ã\ö½ Ž¿â¦]]]�À… ¨Âææf´j2Í7LHHàr½duuudÁ •°„îÃ`0ÜÜܨ‘£ªªª²¯*''�زe Ê{×ÐИ={vkk«““¾ßß¼yãééÉtî±cÇÜÝÝ9§îsn*� -- K=zzh,ñ÷ß�ìÙ³çÕ«WÝ/@øiÀIË—/_¶lÙÒ¥KW¬XáääDÝ@€@ pÝ/xÅëNÙ÷îÝc’ܼy� ¤¤$$$¾ÙÞHH¥ð£©dœ«àÆÂÿ~p°rÙú#]ƒ:ŠF•÷ø(¾‡—D p†¤ý ¦'ò—/_��ÂÂÂ裔”�àíÛ·HÎmmm+++:¾mÛ6j†ðîÝ»?}ú¤££ƒíëzÎÜø«¼¼¼W¯^ í°FVß›ËZ6oÞÌÇÇwéÒ¥ÿýIwïÞÍäèŽ7nÒ¤I>|غuk{oAƒÑÚÚŠ?¢>ï©iJÂСCkjj´´´6nÜxðàÁ9sæ ´g¹Î;wþüùõõõŽŽŽ �€}ûöijj¦§§ëëëÏœ9ÓÄÄdòäÉ‹/FÏ ´×OQQÑÎ;ÃÂÂΟ?ßµ¦Îš5‹‡‡çéÓ§6lwqqY±bZMÅí&FFFNNN555«W¯þ믿:´cÇ ‹.oï@ üP“8öîÝ»oß>______??¿¹sçöu „~ƒ¾¾>ß»wïPj!7v æþýûÔ5ß¿v‹swwG’7òòòþûï¿x5t�À›7o:�ðòòÂÂö2¤¸±ð{ÎV.g¤kp?Šöýø^À2eÐÏX²d‰°°°¡¡¡ˆˆHllìãÇ%%%ñ"òòò EEE&&&³gÏVWW_¸p!k!û÷ïÏÈȈŠŠ*..ž={¶€€À­[· Ò…e¹±ç<cÆ YYÙøøø'OžP=çY³f…„„ ÕÐÐ0>>þÞ½{£Fzóæ öWõôôÖ¯_ìååuñâECCÃAƒUUU±õ“çÎsåÊGGǘ˜aaanjQWWß³gÏ®]»6mÚ¬ªªúìÙ3QQQWW×£G"ÿ8kÖ¬sçÎ%$$XYYÉÈÈ|þüùíÛ·t:ýìÙ³�€äääµk×Ι3gÔ¨QyyyÈY¾|yg{@`ËàÁƒoݺµzõê°°0dêèè³]k˜’’’““ãååuèÐ!))©{÷î?yòäÇzzz...‹-B÷Z²MRRBXUU…w8î,úúúD L„‡‡ËÉÉ¡¡Ôµk×öH@ �àççgddäëë…Ç`ÕÕÕ©æ2ðãÃ}š7šÔ$2B tmmíôôôøøxd<whbÆŒãìì|êÔ)++«âââ7nTUU™˜˜,Z´)èè踹¹¡±¥eË–=úõë×çΫ©©qpp ®õÖ^@ŠK ¿álåröGºÌ¾}ûòòòÐ(šŽŽÎׯ_³³³]]]###ËÊʨVú÷£Ç½$3$ Eègˆ‰‰EEE¡Ùp��¼š)ßœKJJþþûïY³f±}] >üñãÇÛ¶m»yó&Ê'˜?þž={º6÷»CÏ™KuÇŽãÇßµkWzzú‹/��<<<h—V¶0ùÞ\Öâì쬭­}æÌ´·«ƒƒÃÊ•+Qº5uIuUUÕ'Ožlß¾ýÞ½{ÇŽCB¼÷vSS“   ^ÄJTTÔËËkãÆ]è@-’’’7oÞ¬««ËÍÍUVV<x0“kò¼¨¨èóçÏ©!!!///ê�leeåׯ_Ñý.$$”ššZ]]-++ËTš‘‘Zà“‰ 6lØ°*±···³³ËÉÉ6lÞ¬šºÁs{E•””° ÙNÝ1cÆŒ3êêê DDD¤¥¥¿ëÒ§Â÷€šæÀzG³j¦¥¥qHtBIOž<Ùºuëþýû;œõC 80cÆŒôôô[·n!ã¹C;ãìì\]]ý矦¤¤ Í›73­ð½mÛ6]]]ooï“'O"‰œœ\PPÐìÙ³©jí¤¸´ð{ÎV.g¤Ëp3Šö½éq/‰@è�á#==BhnnÞ× é:uuu¯_¿~þüù§OŸØ*444¤§§çææ677s.ª¥¥åõë×ÙÙÙj¶GBB„P__}¬­­EQ¶ÊMMM/_¾,))é°ØÚÚÚçÏŸ¿yómPÒ)¸¯…ÊæÍ›!„l¿-**ÊÈÈ ÑhmmmL_•––>{ö,??¿©©©³Mí „¾nÅÅÁƒ!„¾¾¾}Ýö0ÝV=ÎÙ³g!„³fÍúNå~4bcc!„vvv}Ýæĉ­[·öuC:AKK‹žž„p̘1»víºxñ"’ÛÚÚB/]º„5à„+W®Ü±cGUUƒÝÃ!//O]]B8~üxooïcÇŽùûû;99-[¶¬—/íç#99BhccÓ× ù%ÐÒÒ‚–••õuCØÓžÈtçæçççææ²ÚŠTªªªRSSËË˻Рî-üž‚ƒ•Û¡?ÒS|úô B(##ÓË–v÷½$ØÛÛCïß¿ßã%ú$CŠÐÿ8p šš!!!êÎ\àããã\TgAK²E@@€Ëµ�EDDÐêã]€ûZ0±±±�€ö²±äåååååÙ~%%%…Ʊ „ÊÊʤ¤¤éÓ§ãM©÷íÛÇÃósçξmð Â}šƒ]ttôíÛ·ÑBÈK—.:t(«÷I¡Ëp°© }â83tèP==½®5ƒ{ ¿§à`åvèôwîÜ�èëë÷rh{I[H@Š@ø刎ŽÖÔÔ>|8úXWW·eË–wïÞ™››Oœ8±oÛF ô,·oßÞ¸q£˜˜Øˆ#ÄÄÄŠŠŠ^½zÅÃÃãææÖeƒ˜@ tSSÓŒŒŒœœœ*))!!ëô[~~þ3gÎ|üø±´´TQQQLL ´3õuØ°a(õþýûÏŸ?KII‰‹‹ã4@ ôÈ(ᄤ„_ŽM›6•——«ªª*))Õ×׿|ù­žóÇôuÓ��<xðĉ{$óÎÊʪ¼¼üÞ½{¹¹¹µµµòòò¶¶¶îîîdßb¡á>ÍAFF/ÊÖ!\&q E#ü‚€Ð-zÐsî5‚‚‚Ο?Ÿ••;hÐ •Y³f9:: öuÓ��ÐÔÔdM—è’’’›6mÚ´iS”F £­­ �ïë†ü$Q4Â/ HÝ¢=ç^â¯[A @èÇìÛ·¯¯›ðSAFÑ¿ ¼}Ý�@ @ ¯ H@ @ z"@ @ ô*$ E @ @èUH@Š@ ý‰¦¦¦†††¶¶¶¾n'ÚÚÚûº!@  H?( ƒ8´+vvvòòòW¯^íë†pâÎ;h·æ¾nhii¹uëVvvö[ @ ~& F_7„@ ôH@ŠðcQXXI§Ó»_T}}}vvvRRR\\\FFFyy9ë«ñGö¬’’’äåå'MšÔ× !ý˜ .¬\¹ÒÆƦ¾¾þÇ,@ ½IÛl±´´”——‹‹ûNåÿ²üÈn ÐeøûºÂÿƒÁ°µµ---ݼy³§§gwŠÊÍÍ4iSJ^^ÞÝÝÝÞÞž—÷ÿ…b/\¸°qãF‘ìììv§FðóQPP ***))Ù× é:<<<bbbBBB]8N§geeéééõT@èCzÐØ&ô2Äm!ü” )„„�@ZZº›Eµ¶¶2 QQÑC‡…††nÙ²ÅÄĤ¢¢ÂÃÃcÛ¶mXxV¡= 233ûº!ÝÂÚÚ:---11â¹çÅ‹£FÚ²eKOH „¾¥mB‡ÐéôçÏŸwíÜ‚‚F•·…ðSB2¤?÷îÝûøñ£¼¼|”&,,¼xñbüñùóçÓ§Oÿ矜œœTTTÀ7ÏJ\\œxV &C°ÿ"++ÛµkjjØÎËër@èszÖØ&´Ç‹/fÏž=räȘ˜˜ÎžëèèuáÂKKK,$n ᧄ¤?üüüß逸§§©©™™™™‘‘R€xVÂImmí‘#G’’’***dee­­­øøø¨:555.\ˆ‹‹+//722òðð6lS9™™™¯^½ª©©ÑÔÔ411™?>UáåË—ÿüóÏ”)S¦OŸ~ùòåÈÈHKKK11±øøø·oß�Nœ8qûöm�ÀªU«FͶµŸ>} IMMmhh000˜;wn{×U]]}êÔ©çÏŸ¿ÿ^GGÇØØxÑ¢Eºpvþüù¬¬¬ÜÜ\QQÑ‘#G®^½zôèÑl/ÄÉÉ©  àðáÃbbbÞÞÞ¨„?þø£¬¬ÌÏÏN§_¾|9))éÝ»wÚÚÚóæÍ355E: [·n---�|øðÁÝÝ� ##³yófÖÍÍͧOŸ~öìYNNŽ”””¶¶öÊ•+©ØŒŒŒÓ§O›™™ÙÚÚFDD\¹r¥¤¤DNNÎÑÑqêÔ©íõ@ z–ïjl0í êpC{CbÄm!ü|€áÇâÈ‘#ùùùK—.Õ××Gä;”––þý÷ß(ñ9ŸC‡ílùMMM��mmmô±=ϪC'–ŽJLLÌÝ»wÓÒÒ d``°páB�–””¾{÷îüùóqqq=êì¥? 555æææ………jjjÙÙÙ999«V­¢êTWWÏ™3'##cРA_¿~}ùòeTTÔãÇŒuüýý:ÔÒÒ¢¢¢2pàÀˆˆˆ‹/^¾|ùرc8tE£Ñ„……srr��ºººEEEááámmm�€Gñðð��¦NÊ6 •””äääD£ÑTUUÏ;wúôé °jfdd¬\¹²´´TGGGUU566==<ˆF;;¼ð‹/îرãË—/|||JJJÅÅÅiii¦¦¦£Gf{!øñSîáÇééé+W®Ü°aCvv¶´´ôçÏŸ³²²"""<<<н¦¦¦ððp´ _eeexx8�@CCcóæͬ�^¿~íììüúõkMMÍ/^ÄÅÅ>}:00pÞ¼yH§´´4,,Œ/555$$DTT´¹¹9///66v×®]ëÖ­ëÜ¿„@ ]‚ÉØîæhÁ­[·îܹ“••¥ªªjddäààÀV­ÃA ÌíÛ·ããã³³³«ªª†nllìêêÊËË›™™*//ïááAÕ?þ|jjêŒ3,,,ðåXZZZ[[_»víáÇùùùK–,‘““�DFF†‡‡—””(++oܸqìرL à<tÄMwqÔ�ÔÔÔ„‡‡'&& jkkÛÙÙ?ÙÞX7Ý–žr¦„†AøÅHOO‡š››÷uCØckk !¼té–˜™™A444 „jjjB¡¶¶öçÏŸÛ+';;B¨®®NÞºu Bhff†% B}}}ªšŸŸŸ””„p„ fffâââB;;»ÊÊJ¬caa!LOO766F‘““ƒŠ‹‹ûûûSKkiiÙ¾};„PKKkÅŠæææ#GŽLOOÇ:–––ÂÜÜ\uuutu­­­lÛFè¨Kûº?„úúúöuCØ�!tttlkkC’üü|ü-zJÈÊÊ:99åää0Œììl===áï¿ÿŽÕÂÂÂÐ}÷êÕ+$ùøñã¤I“ „NNNX->>B8eÊ99¹?ÿüóÍ›7ÕÕÕè«éÓ§C£££94µ¶¶=š<<<Ð.×[·nEÿ:+++¬Y__¯¥¥¥¨¨˜””„%èZÎ;ÇÍ…ÇÄÄ@eddBBBêëë‘°¨¨¨¶¶–Ã…°>IÐuihhÌœ9óÙ³g £©©)$$DBBB‡5=z!´°° ^2kt:}„ ÂmÛ¶5773Œ¶¶¶ãÇC¥¤¤²³³‘Zll,„PQQQEE%**ª±±±©©)00]Taa!‡~î&¨j;;»ïWEŸpâÄ áÖ­[ûº!„Ÿ“ääd¡M_7ä—@KK BXVVÖ u1ÛwïÞEo±;v §ôðáÃÑ[ìðáÃÊijjZ¿~=ÒÔÒÒ?~¼¸¸ø’%KÆ!|øð!ÖÌÎΞ<y2„PAAÁÆÆFUUB¨¤¤tåÊjeee‹/FŽ1ÂÀÀ@NNn„ èÛÛ·oC---™šáââ! ¦^ζmÛ\]]Q9èí6~üøÚÚZ???¡²²²ŒŒ „PBBâÉ“'ÔÒÒÓÓÇŽ+%%emm½lÙ²Q£FA7lØ€V§å²»>þ,!!<T‹„„„©©)úÖÞÞ^\\ÜÀÀÀÎÎÎÈÈH\\\JJ ÿÛ·oG Fn:÷öíÛŒn¸-]s¦¾+öööÂû÷ï÷Ií„ úåèw)kkkô¸wvvF¾Y^^Þ¸qã „îîî핃RÊÊÊwïÞ½sçÎéӧ׬Y#!!±hÑ"†ÕXŸì\:±Ü{t!!!ÂÕ«W755!ɽ{÷¤¤¤tttð»mÆŒèknn÷îÝ;¶m#t båH­Y³BxôèQ¶ß¢§„±±qcc#þóÏ?B]]]ôñóçÏÈÞÅÑDqq1²Û°üéÓ§èâééÉT7)á¬Y³¨Âæææ‰'2¤‚‚‚‰LÕ|ýú5¤DÉ9\x]]ŽŽ„ðÂ… l[ÒÞ…°>IfÍš…ª%%%TÍ;w2½¸ H¡8Úœ9s˜šäááA•£!„L Ä£„¬ï Hý8ìß¿ßÍÍ-++‹*¬¨¨pssóðð  kjjüýýgÍšehh¸`Á‚þù§¥¥}õõë×ãÇ;88˜ššN:uãÆÉÉɬuUWWûúúΙ3ÇÊÊÊ××7##ãëׯnnnØqETUU,\¸ÐÐÐÐÅÅå»þû$ Õ›ôa@ªË£GŽAÆpJJ ’dffjjj¢G=Hq9hÑÖÖ†l~+++4ÚÄ`0š››sssÑ1—)|9£G~øða[[FCYYÙ¨¨¨ææ憆ôÎ500ÀEq3tÄ}w±}‡2ŒçÏŸçååá7oÞDA"4¬…`ktÙméš3õ]!)†¬ˆFøÑ0`��@VVöСChš›ªªª‹‹ � Ãym_¿~]¶lÙòåË===###‡ ¶uëV´·[¾|ù²k×.�ÀÉ“'555‘PZZúâÅ‹üüü×®]{úô)¢%]êëëCBBP³€€€³³óÚµk�>>>H­¦¦&((ˆŸŸßßß_@@� ­¬¬¦M›V\\$‚‚‚�€¬¬¬³gÏššš*((t¥§„Ÿ�@HHHbbb{:öööèÆA�>|ø€ÖkHKKûüù³¦¦¦õ¬áÇ£ŒúÇ# º—ùùùÿý÷.45..�àììLòóó¯Y³†IeÝ/Y²„*TSS<xðË—/Ç þüyqq±²²2ÓšSî/Í@\»v­ŒŒ Uîää�ÈÌ̤ÓéœK`"66�°zõj&9šløôéÓ––,<x0žÄ‡044�¼yó¦S•ú)wîÜ ûøñ#UX[[%555S¦LùóÏ?óóó¥¥¥³³³ƒƒƒñbj...;vìÈÉÉ‘¨­­={ö¬­­íåË—©e&''Ož<ùàÁƒÏŸ?ohh¶±±¹qãFXXØ“'O°ZFF†¹¹yPPЗ/_ÐDÚõë×»¹¹¡»¯�²´kkk÷ïß?sæLAAAM›6‰‹‹755aÓ—‰ªªª��Nœ81nÜ8$ÔÖÖÞ»w/“æ¡C‡ &OžìëëËÏÏ�àááY³fÍòåËÑ4¤šššª¢¢róæÍ‘#G"!??ÿˆ#ºv9AAAS¦LA» ¢7TVVÖ¶mÛfÎœÉÏÏ/$$´ÿ~!!¡üüü²²2tnHHHYYÙ’%K°ñ ,,üÇ æu§»¨èêꪪªâ3fÌ3f̧OŸ’’’:u¥Ü»-Ýq¦„ï HúË–-cu>‹‹‹ëêê8œ5xðà7n\¿~ýĉëÖ­c0ëׯonnf«Ï½Ë¥G—””TUU5uêT!U •ŸššŠ>"#{ñâÅL¥¿&Ó§O744üøñ£­­í‚ òóóYu˜V=PSS`0åååà[tCCCƒõD---@ 0 �€„„D×6À.((@µsnÖ´±±Qø¿|ýú�€¬až••�3f zø°ÒÙ QRRb’ÈÊÊŠŠŠ2 ÔTîi¯·ÕÔÔøøøš››©²ö úEÐG BBB mmm_½zuõêÕW¯^EFFâo=<<“’’"""BCC[ZZvî܉c©uuu«W¯.++sqq)((xôèQffæ‚ 6nܾ �–.]Z]]}íÚµ»wïž={öÅ‹'N¼páÂ… zÿª „>¤³£©©©µµµššš'N¤ÊçÎ+%%E•p9hqýúu�ÀÆñnw’’277ÇMLLÐÁ´iÓ°pÈ!£F�à·-7CGˆ\)))yöìÙ;w줤„ûsAgÜDל)á{C5'ô˜|˜Q£F 477WTTˆˆˆ´w–   zÚ�æÌ™óÛo¿Í˜1ãâÅ‹²²²^^^¬úœØ;wî0½fÚóèjkk 455‘Ôô„^½h±CðÍ“d]U‘@ø5áç猌<þü‘#GþûïÿcïÎjÎþÿ¿n-Z,•J–"M–”±4SÍÇR!dŸ¡,Cf¢)#BalÉäcˆB®d ‘¥(RJR mTƒT7K¸­*÷÷ÇùÎýÝÏmQYŠž¿ºçž{Þ¯÷åÖ}¿ÞçuÎU33³%K–ˆ-bZ“è.ÈÏž=#"99¹šÝØ·1áœöéýŠÖp¥¥¥ÅÅÅDÔ®];±§ÄÒF¬'‡Ãa«½²)Ê$²Œ#[d½žgîÔ<PcO¤ÖÄV›6mØŠT „ˆÊÊÊØ›PóÝ–”””––®®®!U“Øæ‰�ôïõ¡±±±ð?ªèN lÁ~!6¿ 99966ö?ÿùmݺµ  ÀÜÜ\8YCMMÍÓÓóæÍ›<þ®`³!ÄfC˜ššúùùÙÚÚ~â¹”Ý�� �IDAT³hAj½[R×Ýö!­y?†ˆ”••…sŽ¨a7-ôôôRSSéã}»¬©©)##óöí[ÑöN:‘È–vÂ[Gb£•••QAAðû|cß.QÀßߟË妤¤ˆ¶7vK¾Æ^¶4íb àSCB ¾T¢Ÿ Ô±cGGGG''§S§NÕšjøE,óÞ+:öÎÐЕõ />ÙÏÂ?ä’à«$%%5{öì3føùù­^½zóæͶ¶¶õÔÛŠa³ýsrrj>Åv®a³rèßO_ÓÈÉÉ©©©ñx¼ÜÜ\ö¥VHìk¥°§½½=Ûå§.u8›ÞŸ™™Y× {"¢wz™’’’/^HHHˆ–¼—¬¬l—.]ž<yÂ6}êéÓ§åååÒÒÒÂâ €=ztpp°Oÿþý…7–jzúôi^^Þ³gÏÄæDEE‘X嬌ŒÌ”)S6lØ lyïlVçÐ:Õ·€e^j½M"úõ¸7-ÊÊÊØ|ázî»0òW»&v5ÁÆlà­£º4ðæŠ@ ptt ÒÑÑñòò8p`ÇŽÝÝÝO:ÕØà{ÙRS.¦�>:$¤ uasšêšÛð‹Xæ½Wt=zô "šõ¢>îW€¯[š-..îܹsgÎœa%± ÁSˆçñxjjjÂö’’¶v›Øg¹®£ŸÏ¯§žžÇ;sæŒØMÝšß,õõõy<^DDD][b‹ZìÄYÀ·oßÎÌÌü(ù‹/ŠM�9{ö,uïÞ½mÛ¶Â0è}ï�<yòäìÙ³ƒmgo»ûáC«ÂÊWcccÇÿÃ?lܸQ4OúÞù,u[séEEEч Ÿ �bØWÜÜÜÜšO‰Þ’iàM iii ¼¼¼ÌÌLÑ¿Ú¢Ø,–·U×BÕð[G",,,((HWW÷Ê•+Â\RÓrß½lh™…ÖåÎ;TÇcúß‹XÑöº.b/^¼(6‚ؾ¾>ÅÄÄÔL]@]ľ\¾~ýšˆdee>Bß¾}---ËËËÝÜÜD«óV¯^ýüùsCCC¶¼Õ›f«`$&&Ös ¶&ènÞ¼)l<yòäåË—‰Ht]d¶Öøš5kîÝ»W×hõœxÿþýGŒQYY¹páÂZSêÍk_ºtI4köøñãÍ›7‘“““°‘½ÙÙÙ,’º¸¸¸HHH<xP¸.¥§§oß¾ˆjŽ ­Ü{ÿ»²òU//¯®]»²òUoooák]]]KJJ¼¼¼"##ïÞ½;aÂákËÊÊØ’(µN 1kÖ¬™3gÚÙÙÙÙÙÙÚÚΛ7oÞ¼yõφ�håØêK7nÜxñâ…hûíÛ·?~,Ú¾]³oÈ¢ÄnZ°ïØ\.·®#²X^^žèšGÕÕÕ,1ýQnî²ïílÑ«WëM¶i‰………è/¨—/_6äµb{ÙÐ2a†´"·nÝb‚Lž<¹Öì"öÒ¥Knnn{öìa[ÔzË°+:á÷àšWtß~ûí÷ß½|ùrOOϺ¦ `†€¨éÓ§ËÊÊ:T^^>""âúõëjjjVVVÄÓÓ3999$$$77×ÆÆFZZúܹs111ŠŠŠ>>>©õõ|úLMMOœ8áëë›——§©©éìì\s͈#FŒ7.$$dÒ¤IVVVìžgrròš5k<<<ª««…=MLLìíí}}}GŒammݧO ‰Â¸¸¸µkײ¢¤úOÜÓÓs̘1ÉÉɦ¦¦–––½zõzõêÕ;wœœœþóŸÿ4ö×HÿþýçÏŸ¿oß>KKËÜÜÜ3gμ|ùÒÜÜ\t?mmí®]»>zôÈÜÜÜÆÆF__Ú´i5‡244\¼xñÖ­['L˜`ggׯ_¿´´´€€�>Ÿ?kÖ¬ÆþÃÁ×­Ö9µNp¨«|õ½ó deeÙT‹œœ±©EEEŸ?Ïl€¯ÕàÁƒoß¾íêêú÷ß³¯¸ÎÎÎìï‘𖌋‹KXXØÁƒmll„«UÔ¼iáìì|ùòå“'O4ˆ­w.FKK«]»v|>ß¾}‹/fþù'› ôQæIýþûïW¯^]³f±±ñ‡gsDoê())±FöæˆÞëºvíZxx8ýo…ð–Øĉ뿱—-�-Rð5+..öðð——/**º{÷.›Â0yòd±=ÚE5ð"–iÈ——׸qãbbb,--544^½z•]^^~èÐ!Ö )�Q:t ¹pá{8dÈ7Š-Pú^ššš×¯_wss;{ö,ûæ'--=yòä5kÖˆV Ôóé›:ujXXXhh(»¯kkk[3!EDûöíÛ²eËîݻϜ9CDzzzýõ×äÉ“=<<Äv®Ù°aƒ‰‰ÉúõëCBBXg"Ò××æ­ê?qmmíèèhww÷'N°ÆöíÛ³âˆÆþ™?~QQÑ_ýODòòòK—.[9^RRrË–-óçÏúôé®]»ÆWkBŠˆÜÜÜŒŒŒV­ZåëëËZºtéâíímccÓ¨¨à«×£Gøøx±ÕÐØ'´ÖÿÃ5ËW2¿ÀÈÈ(//ïÈ‘#¢›OUVV²E£„UH �b6lØ0a„3gÎddd 6¬¨¨(44´[·n“&M:yò¤ðO[oZ;::nÛ¶ÍÕÕõèÑ£C‡UTT|ôèÑË—/>LDç?þpww_·nÝ­[·ºvízéÒ¥/^ØÙÙ¼}ûöÃϨ!·Ž®Ö›:ãÆóññ‰‹‹[´hÑСC£¢¢.^¼¨§§—žž.š©oÈ-1jäe @Ë„„|$$$8NYYÙîÝ»‰HZZZ]]ÝÒÒò÷ß766®ç… ¼ˆerE§««½bÅŠ‹/þý÷߬Q^^^tÑ $¤�Dùøøx{{?~ü¸´´´k×®:t}–í ]SÍ•,”••wïÞ½cÇŽ‚ž={²û‡¢LLLز 5III8p ///??¿[·nba±¯ÈK–,ÉÈÈPVVnw]ë°ÖÖÖÖÖÖ%%%YYYòòò;w½¨®ÿĉHIIiÛ¶mÛ¶mû矞?®©©©®®Î–­ëDê9A‡¬¬¬wïÞéêêÖºKÃ?üœœœ‘‘!''ÇÖà«k@+++++«¢¢¢ììlmmm±UÞëyá¢E‹-ZTk„ðõa1Gupp`ÿÃsssÝÝÝégTVVŠÎ)-_mÈü‚¥K—^¸páرcÆÆÆ,ÙTQQ±víZ±‚Ù; µ122 _¸parrrzzº‚‚‚©©©··÷®]»ˆHô–LoZ¬\¹rРAwîÜIJJ""‡#šrpp(((Ø»wï¥K—ˆHWW700°°°0 àc-ŽñÞ[G WëMnݺuåÊ•]ºtaÕ¿üò‹hBª·ÄuÙÐ2qp%ÜÚ$''1¢ÿþl‰“¯Xeeå«W¯ÊËËÛ´iÓ„_ÊÕÕÕõ\ÄÚØØÄÄÄìÞ½{Ê”)DTÿÐãÇ_½z¥®®Þ©S§ú{ÂGÄ.Œëº&oþûßÿ®_¿þ÷ßwsskîXàsûõÕDFFN:uØ°aAAAÍËÇäëëëææfoo/ºs\ WRR2dÈ‚‚---6¹822rìرׯ_/,,ÌÏÏgp§L™"Z¾ª¦¦võêÕŽ;&$$Œ=Z üôÓOÂùZZZééé...Ë–-cÚ³g+›íÒ¥‹®®î­[·&Nœ¸{÷î±cÇúùù±nnnn¾¾¾’’’>âë?f̘Aƒ‰Í,ƒO¡oß¾÷îÝ«kIï–ìÕ«W?þæ›oj~aSÏM Q%%%òòòZZZ¬ÎWÔëׯ³²²TTTºuëöé¾N×u먱ÊËË…7u„ïOeeeFFFûöí544êyí{o‰ ÕÙÒÙÚÚ^ºt‰Ë墮¾€ÿ¯�M#--]ÿ_»úIJJÖµöyM::: 馭­­­­Ýä���¾hòòòtttÌÌÌÜ¿¿´´ôŒ36mÚdnn^XXXQQÁ.¥ê)_màü‚ùóç÷íÛ÷À‰‰‰¯^½š5kÖœ9sØV$¢ûÊÄÙ�­–²²²²²rCzª¨¨Ô_©ÀÈËËÕõ¬’’R=Ï~,òòòýúõûðqÚ¶mÛ¿±Fiié†ÌÊÔÐШ?c%Ԩˀ )����øLŒŒŒ®_¿ž““óæÍEEE"ŠŽŽíSùêŒ3¦N*6¿`Ò¤Ib211›åÄ?ÖÒÒm¬¿���>$¤���Z‘¾}ûÒ¿¥¬�ÍBBBâ½3‹åääê¹áßÀù¢***ØnîµÖâ}¬Ù���ÐpHH4®è�à õçŸ6w�Ÿ\XX˜¦¦&{XRR²lÙ²þùgøðáß}÷]óÆ��� R�M+:��€kÉ’%………ºººÝ»w/--½{÷nQQ‘––Ö¦M›š;4���ø?HH���ÀWÅÛÛûðáÃ÷ï߈ˆPTTÔÑÑ7nÜܹseddš;4���ø?HH���ÀWeĈ#FŒhî(��� >Í���������´.HH�������Àg…„��������|VHH��|ZUUUçÎKMMmî@�����Z ,jÞJåää̘1£¹£��hŽ9âââ"//Ÿšš*''×Üá��@K´pá¶mÛ6w�Ÿ\RRRs‡�-R­Ô›7oš; �€VAUU•ÃátèÐW�LAAAVV–¦¦f·nÝš;€–"**ª¹C��ø¬juzôèqäÈ‘æŽâ«2}út"» �u±²²JLLìÔ©“„*塵{ýúµ««ëÉ“'ÙC___›æ ‰©ªªºxñb=¾ùæ›æŽZÝ»w———7w�ŸÕ€š;h~HHµ:íÚµ9rdsGñ» �õÐÒÒjî�Zww÷“'OöêÕkòäÉ|>ßÐа¹#ú?(­…fdjjÚÜ!��4$¤�� Å)..Þ¹sgllì³gÏ´´´¬¬¬fÍšõüùó7ѪU«:tè Úß××÷þýû£GÞ´iSAAÁæÍ›óóówíÚuûöm"211qvvVQQ;Pee¥¿¿ÿ­[·222ÔÕÕûöí;gÎÑäQrr²¿¿¿™™Ùĉ£¢¢ÂÃÃãââ””” ´páBÑÑbbbüüü<x ++k``àààлwo"ÊÊÊÚ±cG‡V­ZUÿ9JJJ~ì÷ IOO ”••=wî\ÍÏã甕•¥   ¦¦&lAi-��Àg†„��´,|>øðá999ªªª½{÷NMMÍÈÈøùçŸÕÔÔnݺ•™™i```oo/ìÿöíÛ7òùüÙ³gQXXØÝ»w§Njoo_XXرcÇçÏŸ§¤¤œ9sæúõëJJJ¦¥¥ÍŸ??--M^^ÞÀÀ )))22ÒßßßËËkÒ¤I¬Oaa!—ËoÞ¼Yºt©´´´ªªê;w®]»|øða]]]ÖsÿþýË–-“066®¨¨8zô¨‘‘KHñx<.—Û­[7aBª®sü,o0@³INNÍ›š;wnHHÈ‘#GDg7£´��à3Ã_\��hY|||rrrÆïÞ½“'OÞ»w/88˜=eggGDAAA¢ý#""ø|¾¾¾>«ýiÓ¦ ͘1ÃÔÔ4...---66¶{÷îùùù«W¯¾ª¢¢bÎœ9iii> ÍÌÌ\¿~=ŸÏÿí·ßÒÒÒX76Zxxø²eË6nܘššš””tëÖ­>}údee-^¼X8ÚêÕ«9Nddäùóç¯\¹’””TÏÊ8õœ#ÀWìŸþ!¢¾}û6o<¯Öv---ö‘��€Ï� )��hY>|HDÆÆƇµèèè°~üñÇ6mÚ$''gff ûŸ>}šþÝ^€þM!iiimß¾½PWWwÁ‚DtíÚ5᫶oßž••ejjº~ýz)))"âp83gάªªZ±bëÆjèž={foo?wî\6Áª[·nÇŽ“••g;–æææ–——+++÷ìÙ“½PMMM¬ ¯çðUâñxNNNçÎ#¢›7o:99999ݹs‡ˆ6oÞìä䔚š*ÚÿùóçNNN...–ääd''§3gÎQPPД)SLLL¦M›V×®Á¡¡¡®®®cÇŽýî»ï¦NºsçÎwïÞ;99eggÑÞ½{Y)))D”••åääô矊“’’²bÅŠñãÇ6ÌÑÑñĉb���0HH�@Ë2zôh"òññ¹qã†ØSÊÊÊÖÖÖDtìØ1ÖR^^~éÒ%iié)S¦ˆö´³³“‘‘>411!¢ÜÜÜ’’ÖADóæÍ;«›‹‹‹«ªª""–0’••]¾|¹h·N:± P7oÞ$"==½¢¢"www>Ÿÿ!çðUzóæM```zz:¥¦¦>zôˆˆÎŸ?ÏåróòòDûs¹\Ñéùùù\.7**jÕªU¿ýö[BBÂãÇ#""f̘±sçNÑ×òx¼éӧϞ=ÛÏÏ/##ãÝ»wqqq‡–HLL |öì]»v…‘››Kÿ–Ö†„„ˆµqãFKK˽{÷²IUAAA ,˜6mÚË—/›���ˆBB ��Z–1cÆ :4//oüøñS¦La“‰„fÎœIDÇDtùòåââbKKK±eÎÅV¨ÑÓÓ“––ìB”ˆØ…qÍýÝ{÷î-))YYY™••%lTUU­¹ë–¾¾>ý;׉ˆV¬XѦM›}ûö 0`Ïž=ÕÕÕM>G€¯OÏž=y<›«¸`ÁÇãñÆßðØäÇàààÀÀ@–iÊÉÉquu%¢7²b@"³gÏ766Ž‰‰ÉÌÌŒÍÎÎ ¢uëÖñx¼Áƒ—Ëea°qMGŽñööîرãÕ«Wãââ"""’““{÷î±lÙ²Æ���b�€–EJJ*88ØËË«k×®W¯^533óöö>kbb¢««›——MD¬LFX¯WÑ…ŠËÊÊŠ‹‹‰¨fšIRRRZZšˆØ )FXX'Š]…²¼5*""bÒ¤I|>åʕÇgeAM8G�¨‰}⊋‹===ÇŽ+###--½dÉ’N:½}û6..ŽuóóóKHHÐÑÑ9{öl¯^½X£”””°œ¶^¿~íááAD¾¾¾¬±sçÎG•’’:uê”ðˆ ���Ä !��-Ž””ÔìÙ³ccc×­['6oÞ\XX(|–M’:qâDEEEXX˜ººúðáÃ5¾¬¬l—.]ˆ(''G쩧OŸ–——KKK /e‰¨¢¢¢æ ¬ÚH´[¯^½|||®^½:hРû÷ïïÙ³§Éç�µRRRn‚É :”þóHÿ.*çââÂ2ËM–˜˜øêÕ+ƒ!C†ˆ¶kjjZXXÑõë×���ˆAB ��Z(iiéùóç[YYUWW³™PÌ´iÓddd.\¸påÊ•ÒÒÒiÓ¦5a›v6åáìÙ³bí§N¢Kü„ÉÉÉ¢ÝÞ½{w᪭èO__Ë–-ôï…qýê:G�¨•X5.õéÓ‡ˆ„ù\¶8ú€>ð@uUõ (–izo`���  )��hY*++E¾~ýšˆdee…-íÛ··¶¶.**úóÏ?9Ž­­mŽâââ"!!qðàÁ„„aczzúöíÛ‰ˆ­ÿ"$/^,Ø–-[rrrtuuÇŽË:ˆ.Åb®gÿø÷ž#@k#¬~m,¶&SVVöæÍ"j×®ÝÆÃÖ›«YÕKDlÃѪÞ÷���5I5w����ÿcúôé²²²C‡•——ˆˆ¸~ýºššš•••hŸ™3g?|øÐÜܼ[·nM8Š¡¡áâÅ‹·nÝ:aÂ;;»~ýú¥¥¥ðùüY³f‰NEE…Ïç÷éÓÇÚÚZKK+***::ZFFfóæÍl"ÕÍ›7ùå— &èéé=xð€M³b¥…M>G€VB^^žˆX"IH,iÛ@²²²yyy™™™jjj«Æ­YÕKDly86 ���š )��hY:tè âˆhÈ!7nìر£hŸï¾ûNEE¥¨¨hîܹM>›››‘‘ѪU«|}}YK—.]¼½½mllÄz*));wnÞ¼y\.—Í„244ܶm›°œçíÛ·222Â-Þ\]]]\\>äZ‰=zÄÇÇgffŠ6&&&R“¦MõéÓ'//ËåšššÖÕ‡å‘ù|~=ã°ªÞøøx'šÛ*)) #$¤���>R��вøøøx{{?~ü¸´´´k×®:t¨ÙçæÍ›EEE½zõ5j”ØSu­Ü”››[³ÑÊÊÊÊʪ¨¨(;;[[[»S§NuE¥¦¦vöìÙ’’’ÌÌÌ=z())‰>kff_PP››«¢¢¢­­-º•‰‰ +ÿiÔ9´úúúDtôèQöYÈÍÍuww§”ÅÕäìì|ùòå“'O4è矮µºº:%&&Nœ8±®qúöíkiiyéÒ%77·={öHII‘@ X½zõóçÏ ÙÒæ���ÐdHH�@‹#''×»wﺞ-))ùã?¨ÆJOM¦¢¢bllÜžòòòõ,–¬®®Î.t¢þsh=fÍšõ÷ßçåå1ÂÒÒ277722rìرׯ_/,,¬ªªbÉ 266vttܶm›««ëÑ£G‡ª¨¨øèÑ£—/_>|˜õ155=qℯ¯o^^ž¦¦¦³³sÍ%ɉÈÓÓ3999$$$77×ÆÆFZZúܹs111ŠŠŠ>>>X" ��à!!��_’GýöÛoiii#FŒ7n\s‡�J^^þàÁƒŽŽŽ™™™û÷ï—––ž1cƦM›ÌÍÍ +**•"¢•+W4ÈÃÃãÎ;IIIDÄápLLL„¦NÊöÙ´µµ­5!¥©©yýúu77·³gϲBiiéÉ“'¯Y³FUUõƒÎ����€/H``à’%KÞ¾}«§§÷÷ß7w8�Ð8k×®]»vmÍv##£ëׯçää¼yóFGGGQQ‘ˆ¢££EûÔ,}e-Z´hÑ"±F ‹’’’ŒŒ yyy---¶t:#%%uàÀ¼¼¼üüünݺ±:ÁZÇWVVÞ½{÷Ž;<x zöìY3;Ö¨À���@ )��øb´mÛ¶ªªjæÌ™kÖ¬QPPø GTRRúî»ï^ˆ�M#!!¡££óqÇ”——722ªëY †Œ#))‰[��€ )��øbXZZ¦¤¤|ànîb``P×*é�����ÐdHH�ÀCNNNNN®¹£�����€%ÑÜ��������@ë‚„��������|VHH�������Àg…„��������|VHH�À—áÝ»weeeÍ�����|($¤��àËpþüymmíñãÇ7w ”““\^^þ±¬ªª:wî\jjêÇ���� …CB �� ÁøñãçÏŸ¿cÇŽ5æ‘#GæÌ™3zôèÒÒÒ5&����@K†„��@#p8UUU"êܹsÓFÈÊÊâñx¢-ªªª§C‡mÛ¶ý!À§'PD ��ð!��hœ‹/Þ¾}ÛÖÖ¶ ¯;wî!CRRRD­¬¬oܸ!!¿Ë�_†ØØXmmíï¿ÿ¾¹��øRI5w����_)))mmí¦½Vln”––ÖD����ð…AB ��Z¢çÏŸûøø$$$”•• 2dâĉuõ ¿páBbb¢¢¢â!C¦M›¦££#Ú!&&ÆÏÏïÁƒ²²²½{÷í•ššúòåKMMM33³… JHHxyy=}úÔËËëŸþ9|øpddäµk×8ÎÎ;>|hkk;pà@"JNNö÷÷733›8qbTTTxxx\\œ’’Ò Aƒ.\¨  ÀŽ•MD{÷î %¢Ÿþ¹_¿~YYY;vìèСêU«DKII ºwïŸÏ700077Ÿ<y²h‡M›6lÞ¼9??×®]·oß&"ggg•yÿ����>)$¤�� Å‰µ··çñxÒÒÒºººþþþS¦LëV]]íáá±gÏuuõ>yòdÛ¶m<vìXÿþýYŸýû÷/[¶LBBÂØظ¢¢âèÑ£FFF„Çûý÷ßÃÃÉHEE¥C‡qqq?þí·ßˆ(<<<))é×_?~ü³gψH p8œË—/ÇÄÄ|÷Ýw,!UXXÈårÁ›7o–.]*--­ªªzçÎk×®>|XWW—ˆß½{GD,±EÖ²„b�� �IDATDýúõãñx\.·[·n¢ ©7nß¾½ªªJGGGNN.((èèÑ£Çÿûï¿Û·oÏú„……ݽ{wêÔ©ööö………;v|þüyJJÊ™3g®_¿®¤¤ô ÿ‘�����>�Öª��€–¥¤¤dÞ¼y<oæÌ™ÙÙÙQQQéé鶶¶‡ë¹oß¾={öØØØ$&&úûû_¾|ùСCoÞ¼™={6ËûTTT¬^½šÃáDFFž?þÊ•+III666ìå`öìÙáááÆÆÆ111™™™±±±ÙÙÙ¬C›6mˆè×_ÕÐÐ8~üxBBB­k<±náááË–-Û¸qcjjjRRÒ­[·úôé“••µxñbÖmݺu<oðàÁDÄåry<Ç=zt­o‘#G¼½½;vìxõêÕ¸¸¸ˆˆˆäääÞ½{GDD,[¶LìÐ3fÌ055‹‹KKK‹íÞ½{~~þêÕ«›üO�����ð©!!��-ËÿûßÂÂB“¿þú‹í:'##³víZ===Ñn|>ßÛÛ[JJjãÆÒÒÒ¬ÑÒÒrÔ¨Q¹¹¹aaaD”››[^^®¬¬Ü³gOÖAMMMXCççç— ££söìÙ^½z±F)))ag"ºÿþ¡C‡~øᇮ]»Ö°¤¤$={öÌÞÞ~îܹl^R·nÝŽ;&++Ï‚i¸×¯_{xx‘¯¯¯kìܹóÑ£G¥¤¤N:ÇYBJKKkûöí¬PQWWwÁ‚DtíÚµFà³ wvvþá‡Æ·aƬ¬,Ö.V¯^íää$ö¿7##ÃÉÉiéÒ¥åååDÄçó÷îÝ;{öìÿüç?–––K–,‰ퟜœìääZ]]}âĉ Œ9ÒÓÓóÉ“'¬Cppð”)SLLLlmm“’’j¾688˜ˆ¢¢¢V­Z5räÈÉ“'oÞ¼¹¸¸øCÎ���Ä !��-Kdd$ÍŸ?_´QJJÊÁÁA´%66öåË—;vm2d%$$‘ŽŽŽžž^QQ‘»»;ŸÏ;ÐéÓ§‰ÈÅÅE˜ÏÃ2M?ýô“††F=³â;YYÙåË—‹¶wêÔ‰Íƺyóf=/¯)11ñÕ«Wì\„455-,,ˆèúõë¢ívvv,wƘ˜˜QnnnIII£Ž ð©UWW¯\¹rúôéáááÝ»w/--ݶmÛèÑ£“““‰ˆÃáôïߟËå.\¸°¨¨ˆ½äÝ»wŽŽŽ\.WGG‡e¨,X°råÊŒŒ UUÕâââC‡?þøñã£äççs¹Ü7n,Z´hÁ‚W®\IIIÙ²eËäÉ“KJJ6nÜ8þüÄÄÄG]ºtÉÊÊ*&&FøZV{íÚµLž<ÙÏÏïùóç×®]óòò1bÄÇ›|v���  )��hYØ„±uljHl•nÖ-<<¼ëÿZ³f åçç³n+V¬hӦ;}û °gÏžêêjá©©©D4`À€º"õw¥ªª*'''Ö¨¯¯ODõ_ÄÖ”žžNDß|óMͧúôé#ì $öÎèééIKK ¶î@ËñÞ2Û &Lš4©°°PXšºgÏž¤¤$sssa’ÚÙÙùƱ±±AAAlË‚ªª*www6Šþ9xäÈ‘èèè   ŒŒŒ»wïöíÛ7;;{̘1»wïöóóËÈÈÈÊÊš8qâ»wï–,Y"Œ°¸M;;���…„��´ ¥¥¥¬.¦]»vbO±‰HB<ˆ gÍš5kÖ¬™3gÚÙÙÙÚÚΞ=ÛÞÞ~øðá¬Û¨Q£"""&MšÄçóW®\9|øp¶Ï]YYÙ›7oj=KH‰N>ª‡Xx »¸eã4K$ÕLo ƒ©ªªª„Z׺h^ )³%"OOÏÎ;_¾|ùÉ“'›6mRQQÙµk—p###¶Q�cmmÝ¿ÿçÏŸÇÆƲö¹+..ööö6l‡ÃQUU7oÝ¿ßÍÍmìرRRRmÛ¶õôôlÛ¶íÇ Øk›\ÛÀ³���!ì²��-ˆœœœššÇËÍÍíÔ©“èS¥¥¥¢{ôèAD:::k×®­Ì^½zùøø,^¼˜­5³gÏOOOYYY ¼¼¼ÌÌL55µZ_بDREEEÍÆG±�>Ž°NNNͧX6Í“ø²°2ÛÑ£G×,³={ölBB‚••)))íرcÊ”)®®®:::¥¥¥»víªõCúôéÓ¼¼¼gÏž±êÓ§OEŸUWW&¦‰ÈÜÜœý0jÔ(a£²²²žž^rròÇÕÕÕé}¸7oÞd•³M;;���BB ��Z===wæ̱Z¹S§N‰>dÕp111lBDýôõõ·lÙbffvúôiOOO"êÓ§O^^—Ë555ýð° ’““û÷ï/ly÷îÝ… è‹ïØÔ‰š Z‰b ™ÇÇÇóx<Ñëð’’6Ï )ø‰–ÙŠ¶³Â2["277Ÿ;wî¾}û?~<}útkkkÑþÀßߟË妤¤ˆ¶‹å¬ÅCššš222oß¾nkÀ°Ä7›q)Ô„ ܆Ÿ���0HH�@˲`Á‚¨¨¨Œ5jðàÁ¬ñäÉ“—/_&"áR,ß~ûí÷ß½|ùrOOÏZ&ïÞ½c58Dôúõkú·œ‡ˆœ/_¾|òäÉAƒýüóϵ¾¼áa ‚Å‹‡‡‡ #Ù²eKNNŽ®®îرc…ÝØ,ŒÄÄĉ'Ö5Tß¾}---/]ºäææ¶gÏ)))úw²çÏŸÖ:A …–Ù8ˆÿb?³F!UUUöƒðóËGGÇ   //¯vìØÑÝÝ],aÝp¬¾UìÃÞ„ ÜF���R��ÐÒŒ1bܸq!!!“&M²²²ÒÕÕ½råJrròš5k<<<DW%÷òò7n\@@@LLŒ¥¥¥††Æ«W¯²³³ËËË:DD7oÞüå—_&L˜ §§÷àÁvÉ:sæLörcccGGÇmÛ¶¹ºº=ztèСŠŠŠ=zùòåáÇ©‘ )>Ÿß§Okkk--­¨¨¨èèh™Í›7‹&ËLMMOœ8áëë›——§©©éìì,¶$9ãé陜œ’››kcc#--}îܹ˜˜EEE±Kt€/BÃËlSRR¼¼¼z÷îýúõ뀀�kkëaƱ§Â‚‚‚دá$¦†Ì‘l”&Tà6üì���€AB ��Zœ}ûömÙ²e÷îÝgÎœ!"==½¿þúkòäÉ%%%ÂnºººÑÑÑ+V¬¸xñâßÿÍåååGÍ~~ûö­ŒŒÌÎ;ÙCWWWá+W®4h‡‡Ç;w’’’ˆˆÃᘘ˜°g•RRR:wîܼyó¸\.ËšnÛ¶Ml³¼©S§†………††ž={–ˆlmmkMHijj^¿~ÝÍÍíìÙ³‰‰‰D$--=yòä5kÖgŽ�|YXf[QQ±`Á‚ÊÊJ//¯çÏŸÏ™3ÇÉÉ)::ZQQ‘ˆnܸAD¢%u/_¾ü¸¡6°WTc‹ˆ��� )��hq8Îü±dÉ’ŒŒ eeeVæFÿn?'ª}ûö,õøñãW¯^©««wêÔIXncff_PP››«¢¢¢­­]³²Ï¢¤¤$##C^^^KKK^^ž=uúôéZë«]MMíìÙ³%%%™™™=zô`ûs‰‘’’:pà@^^^~~~·nÝ:tè@D&&&5OMYYy÷îÝ;vìxðà@ èÙ³'«ÝkH$¹¹¹µ¶4£†”ÙÑÚµk333úé§!C†+_]¾|9Ûh¥‰Y––¹víZxx85`÷Ɇk`nÎ���„�€ŠÃáôîÝ»µµµµµµk}J]]]˜Òª‹¼¼¼‘‘Qãâ«{(±åØkÒÐÐÐÐÐhÈh’’’ �Z¸÷–ÙFEEùúúvêÔIXøæååuãÆcÇŽ;ÖÊÊjܸq>>>qqq‹-:thTTÔÅ‹õôôÒÓÓß¼yó±âl`ncÏ���D!!����ŸCýe¶¯_¿þí·ßÁ† ”••Ù³;w^½zµ‹‹‹‹‹ËàÁƒ¸uëÖ•+WvéÒeË–-DôË/¿|Ä„T+puv���  )����øLê)³URRJII©ù’™3g ÷" ¢3fL:5##£}ûö™†“&Mv¨µ–ˆž>}Z³‘ËåÖç{+pk=JýEÄ��� )��€¢¤¤ôÝwß½·*�DÕSfû^ÒÒÒ}úôù¸ñÔª!¸µú³��h%��ø u-.�����µ’hî��������� uÁ )�����"Tà��|FHH����¡��à3BÉ��������|VHH�������Àg…„���‘@ (++«¨¨øÔª¨¨(++Ÿú@�����-R���DD±±±ÚÚÚßÿý§>ÐÈ‘#µµµ###?õ�����Z,$¤��������à³BB ��Z£¬¬,×ÜQ�����´RHH�@«3wîÜ!C†¤¤¤4w �����­R��Ðê`n����@ó’jî����þGrr²¿¿ÿÈ‘#­¬¬N:uåÊ•‡Ž1búôé]ºt!¢àààÀÀÀ§OŸöèÑÃÅÅeÀ€b#íÛ·ïöíÛ?644433ûñÇÙSÁÁÁQQQÙÙÙD´wïÞÐÐP"úùçŸûõë':Â7BBBâââTUUçÎkii)vˆÊÊJÿ[·nedd¨««÷íÛwÎœ9ZZZ5OçܹsçÏŸ¿ÿ¾®®®‰‰É¬Y³jö)..Þ¹sgllì³gÏ´´´¬¬¬fÍš%))ÙÄwà+U^^~ÿþ}ccãæ���>$¤�� eÉÏÏçr¹òòòçÏŸ?v옊ŠÊëׯïܹ±}ûvoooEEÅòòò„‡‡÷Ýw—'''Ï™3'??ßÐÐPWW7""âøñã±±±[·n•HLL |÷î]»vÃá‘………hBêèÑ£‹/nÛ¶meeåýû÷###=<<~ûí7a‡´´´ùó秥¥ÉËË$%%EFFúûû{yyMš4IØ­²²ÒÅÅ%00ˆÔÕÕïÝ»wöìÙˆˆˆŠŠ ÑóåóùÇÏÉÉQUUíÝ»wjjjFFÆÏ?ÿüÉÞ`€/RRR’M¯^½ÂÃÛ;���øP²��-K›6mˆèÈ‘#ÑÑÑAAAwïÞíÛ·ovvö˜1cvïÞíçç—‘‘‘••5qâÄwïÞ-Y²DøÚ²²2[[Û¢¢¢S§N]¸páСCIIIß}÷Ý‘#GŽ9BDëÖ­ãñxƒ&".—Ëãñx<ÞèÑ£…#äåå­ZµÊÇÇ'===;;› ¾iÓ¦G±sæÌIKKsppxøðahhhffæúõëù|þo¿ý–––&jïÞ½ªªªçÏŸ¿{÷îÍ›7¯\¹’œœÌæg ùøøäääŒ?þÞ½{'Ož¼wï^ppð'|¾L|>¿´´´¹£���€ )��hYXBª¸¸ØÛÛ{Ø°aGUUuÞ¼yDtÿþ}77·±cÇJIIµmÛÖÓÓ³mÛ¶>,((`¯õññ)((˜>}ú!CX‹¬¬ì¦M›ˆÈÏϯ!Gûö­§§ç„ deeÛ¶mëêêÚ±cÇŠŠŠ¸¸8ÖaûöíYYY¦¦¦ëׯ—’’""‡ãàà0sæ̪ªª+V°n/_¾Ü²e íÝ»÷Ûo¿e}ûö]»v­Ø>|HDÆÆÆlºéèè4éhé¼¼¼œœœ*++<xàááaff&ØSEEE^^^?þø£‰‰ÉÂ… =*|UYY™““Ó®]»ˆèÉ“'NNNNNN›7o&¢””'''ooo±>|ØÉÉéòåËï=ô¦M›œœœÞ¾}ûèÑ£¥K—>|øðá«V­***3&&fîܹfff–––ÎÎÎéééŸà��hE�€–H]]}øðá‡æææì‡Q£F •••õôôèßœ±5¡¦OŸ.:TïÞ½•””îÞ½+V+W+%%¥‰'Š¶ :”ˆ„ŸDÄd¢X‘]\\\UU%$$ˆ–ÑĉÕÕÕE[Øü,Ÿ7n¼7<€/Zxx8—ËýçŸÆ¿{÷î´´4–JNN>|¸··÷ëׯY¥­££ãâÅ‹YuíÛ·o###‰èÅ‹.\ ¢ÜÜ\.—{ñâE±ݸqƒË妦¦¾÷Ðaaa\.7!!aôèÑþþþyyy)))>>>æææ¯_¿¾|ÿþý666çÎSPP¨ªª:zôhBB§Ã���¾fHH�@KÔ±cGчššš222D¤   ÚÞ©S'Ù5/++‹ˆFÝõ½y󆈄©ê¡¢¢"ÖÒ§OÑC°ÌÔ7ß|#Ö­wïÞ’’’•••,–#ëÝ»wÍC(++‹>3fÌСCóòòÆ?eÊar àëÃæ?þúë¯ÇOHHxo¥­’’Ç;qâ²J[–ŸúÀC Ûg̘ajj—––Û½{÷üüüÕ«W³×VTT¬^½šÃáDFFž?þÊ•+lA«ùÖ���´>XÔ��¾`ì’’Ít(---..æp8l';@ÀÚÿjß¾}Áêò˜²²²ââb"’““ë&)))--]]]ÍfHQ»víj(,ÍŽ|øðá;w^½zÕÌÌlÉ’%ÎÎÎM …ciåû÷ïߺuKCCƒ5²J[±J[SSS???[[ÛOwhú7!¥¥¥µ}ûvÖGWWwÁ‚K—.½víë“››[^^®¢¢Ò³gOÖ¢¦¦öQ¢��hÍ�€¯„œœœššdz··ïҥ˧8„¬¬l—.]ž<yÂ6Å}êéÓ§åååÒÒÒ½zõ"¢=zQnnnÍAj.Ì,%%5{öì3føùù­^½zóæͶ¶¶bã|$%%‰è§Ÿ~M ½·Ò–åŒ>Å¡…ìììX6Š111!¢ÜÜÜ’’yyy==½ŒŒ www77·ZÍ���ÐX(Ù�€¯‡¾¾>ý»ÌS=¤¥¥‰ˆÏç7áDtöìY±öS§N‘žžœ-nuãÆ/^ˆv»}ûöãÇëŠjþüùVVVÕÕÕgÎœiBl�-›´8`À�ÑƯ´mò¡…ÄjuÙY <{öŒµ¬X±¢M›6ûöí0`Àž={ª««?JT���­R��ðõøý÷߉hÍš5÷îÝ«§<11± ‡pqq‘8xð è’ÆéééÛ·o'"WWWÖ2xð`ccãÒÒRWW×ÊÊJÖXQQáììÌ.ŒÙjÍD$|–aë(ËÊÊ6!6€Žýç‹$Zi;kÖ¬™3gÚÙÙÙÙÙÙÚÚΛ7oÞ¼y ©´nÕרCו 5*""bÒ¤I|>åʕÇÏÎÎnàP���P+”ì�À×ÃÄÄÄÞÞÞ××wĈÖÖÖ}úô‘(,,Œ‹‹[»v-+Ã!"SSÓ'Nøúúæååijj:;;×\˼.†††‹/Þºuë„ ìììúõë—––ÀçógÍšeee%ì¹aÆ &œ9s&##cØ°aEEE¡¡¡Ýºu›4iÒÉ“'…3,¦OŸ.++;tèPyyùˆˆˆëׯ«©©‰ŽðÕ¨™9úÀJ[yyy"bs©D‰åyk=tcõêÕËÇÇgñâÅK–,‰ß³g§§çŽ ��К!!��_• 6˜˜˜¬_¿>$$DXø¦¯¯/Zb3uêÔ°°°ÐÐPVygkkÛð„¹¹¹­ZµÊ××—µtéÒÅÛÛ[l×-##£ððð… &''§§§+((˜ššz{{ïÚµ‹ˆJJJX·:„„„°=ì‰hÈ!7nÛdà+¦¯¯Ïãñ"""Øvu©µÒ–-Ö–——Ç{bÕÕÕ)))ô1’PµF»eË33³Ó§O#!��ð!�€–ÅÄÄD¸n‹¨§OŸÖlär¹5­­­­­­KJJ²²²äåå;wî,¶)ž””Ôòòòòóó»uëÖ¡C‡zŽ»hÑ¢E‹‰5ZYYYYYeggkkkwêÔ©ÖséÕ«×åË—_½zõøñão¾ù†mØçááááá!ìããããííýøñãÒÒÒ®]»²`�¾Jµfˆ~ÿý÷«W¯®Y³ÆØظOŸ>u½–UÚfgg¿~ýZII‰5jiiµk׎ÏçïÛ·oñâŬñÏ?ÿdõt¢ó¤>$9%Þ½{Ç–E§ëj?ÊRë���­R��ðu’——ïׯ_=444jÝo«áTTTŒßÛMYYYYY¹žrrr½{÷þH�¾µf…Xi«­­Ýµk×G™››ÛØØèëëO›6ÃáüñÇîîîëÖ­»uëV×®]/]ºôâÅ ;;»€€€·oßÖèºyóæ/¿ü2aÂ==½° fÎœÙä��€���€Ï£®¬PC*m%%%·lÙ2þü§OŸîÚµkܸqÓ¦M#"‡‚‚‚½{÷^ºt‰ˆtuu ***Þ{è†xûö­ŒŒÌÎ;ÙCWWW—&���„„����|§OŸ®ë©÷VÚÑ?üœœœ‘‘!''×½{wÖ())¹fÍgg第,•nݺq8"«À­ëÐuµçææ 633‹/((ÈÍÍUQQÑÖÖf Z��À‡@B ����Z„÷VÚ¶mÛ¶ÿþ5Û•””ŒŒŒ>Y\DDêêêl+���ø($š;���������h]�������€Ï )��������ø¬�������€Ï )��������ø¬�������€Ï )��������ø¬¤š;���hYYY—.]jî(�>¹”””æ����Ä!!�ÐJ…„„„„„4w�����Ð!!�ÐêèèèXYY5w�ŸU¿~ýš;����øÿ�huÆŽ;vìØæŽ�����Z/,j��������ŸR���P;>Ÿ•ï>©òòòÛ·o7w���Í� )���¨Eqq±ùæ³fϺ“|§¹cø:%%%ééé-[¶¬¹��hHH��@-F]UUõËü_JKK›;€¯ŸÏLJ ��Z-,j���µ[µrÕÕ«WÓÓÓW®Zéý—ws‡_<>ŸxãÆGÉÈÈôíÛwêÔ©ƒ v¸{÷îþýû‡ 6f̘ãÇ9ÒÞÞž=ûêÕ«Ý»w'$$”––š™™Y[[wïÞ}ÕªU=zôX´h¥¤¤øùùikk;;;‹÷ðáà ÖÖÖ#FŒ`-›6m*((ðööÎÊÊ:}útdddçÎÇŽkccCDùùù[·nMLLäp8‹-jӦع„‡‡_¸p!11QQQqÈ!Ó¦MÓÑÑ>ËÆß¼ys~~þ®]»XQž‰‰‰³³³ŠŠ •••-_¾<??Ÿˆž<yâääDDK—.e#ÄÄÄøùù=xð@VVÖÀÀÀÁÁ¡wïÞñß�� Ùa†���Ô®M›6{÷ì•‘‘9tèÐ…‹š;øâ-X°`åÊ•ªªªÅÅŇ?~üñãÇ…x<—ËõöövttŒŒŒ|ñâ{êæÍ›¦¦¦[·n½}ûvYYÙ¶mÛF}æÌ.—Íúäæær¹Ü‹/Š÷Æ\.755UØÆdiiéíí™™booðàÁ§OŸZXXøûûçææÞ¹sgóæÍ?þø£èhÕÕÕ+W®œ>}zxxx÷îÝKKKY0ÉÉÉbã'$$Œ=Úßß?///%%ÅÇÇÇÜÜüõë×DôöíÛÀÀÀÈÈH"zñâE`````à… ÿ÷)Û¿¿Í¹s窪ªŽ=šð±þ���Z$¤��� Nß|ó‡»999ñx¼æ¾lÎÎÎ7n܈ b3€ªªªÜÝÝËËËY6)>>~ÇŽË—/ŽŽþå—_ˆ¨¤¤dÞ¼y ,ÈÊʺvíZJJÊ”)S\\\ˆHFF¦±‘°ÙÚÚN›6íÎ;>ü믿ˆhåÊ•“'O0`ÀíÛ·ÓÓÓCBBÚµk,|í¾}ûöìÙccc“˜˜èïïùòåC‡½yóföìÙï޽ƌ¦¦¦qqqiii±±±Ý»wÏÏÏ_½z5)))ñx¼'N‘¡¡!Çãñx,?UQQ±zõj‡yþüù+W®$%%±©[���_$¤��� >?üðË/96w,ðe322ÒÕÕ>´¶¶îß¿ÿóçÏcccY K-¥¤¤üøãÎÎÎzzzÊÊÊD´uëÖ‚‚ssóµk×JII½ê�� �IDAT‘ššš§§'«’“hôZ–0Ò××ß°aƒššÍœ9SSS³¼¼¼¤¤d÷îÝÚÚÚD4tèÐÙ³g‘pŸÏ÷öö–’’Ú¸q£´´4k´´´5jTnnnXX˜èøZZZÛ·ogAêêê.X°€ˆ®]»Vl¹¹¹åååÊÊÊ={öd-jjj =G��€ )���¨‡ÃÙ¹c§ŠŠJDDÄÞ½{›;ø<}úôÖ­[çÏŸì!k—””$"))©ßÿ]´TT988ˆ6ÊÈÈL™2åCÂø駟8Žð¡¹¹9}ÿý÷¢ÙŸ!C†ÑÇÙÃØØØ—/_ZXXtìØQt(ÖM¬°ÎÎÎNtö–‰‰ åææ–””Ô•ŽŽŽžž^QQ‘»»;ŸÏoêÉ��´tXÔ���ÞC]]ý¿ÿýï¬Y³Ö¬]cff†Å•¡i¿¿?—ËMIImî4ÇòSªªª;wí™™IDÂCBŠŠŠXR©GD$6©S§ND$¬WÍÊÊ"¢ððð®]»Šv«ªª""¶H¹[¿\HOOOZZº²²òÙ³gòòòõ¶bÅ {{û}ûö?~ü?þ˜7oKÕ��|M‚/LEEÅ»wïÚ¶m+zK��>µ1£ÇÌœ9óСCóÂÃÂkn:P?@àè褣£ãåå5pàÀŽ;º»»Ÿ:uJ´ÕXª¬¬ŒM)’““kà>bجP8&ËL8µ3ìgÖøÞÑÞkÔ¨QÞÞÞ§NZ¹re`` ŸŸË—��|5j„’’’G½y󦬬LEEE[[»}ûöÍT«3räÈ´´´   aÆ5w,��­ËŸkÿŒŽŽNMMýsÝŸëþ\×ÜáÀ&,,,((HWW÷Ê•+ÂÔ’Xf³Ö\’¬¬¬††F^^^NN[ïI¨¨¨Hô!›vôæͱ*++?<~†e…tttÖ®]û±Æ¬U¯^½|||/^¼dÉ’øøø={öxzz~Ò#��|fXCª¡222ºuëfnn>vìØ©S§Ž9ROO¯oß¾lƒ˜æŽ��à““——÷ññ‘””ôññyïÂÌ�bnܸAD¢^¾|Ù×Ñ‘#GD+++CCCE[X¶(//Ot‘¦êêjV!øQfNéëëQLLLEEŇƖE¯g¡(}}ý-[¶ÑéÓ§?üp���- R Åöñ•““[»víöíÛׯ_?cÆŒ¢¢"WW×9sæ4wt-WyyùíÛ·›; ��ø8Œ-_¶œˆ~ýõW±É)�õcù ÄÄDa˵k×ÂÃÃéߘ¨îœÑÒ¥K%%%;vðàAÖRQQ±zõê{÷î‰vÓÒÒj×®]yyù¾}û„þùgvv6}¤yRß~ûí÷ßÿäÉ“åË—ø€êêêD”ýúõka£@ ¨®®>dO¡H��¾>(Ùkyyy¶e/ãèèhiiyñâÅ'NLž<¹k™’’’lllzõêžn�ÀW`Ñ¢E—¯\Ž‹‹súÝéàƒÍ|1Æçãã·hÑ¢¡C‡FEE]¼xQOO/==]XdWWBJ__Íš5K–,Ù¶m›®®î­[·.\¸{÷n)©ÿûBËápþøãww÷uëÖݺu«k×®—.]zñâ…]@@ÀÛ·o?ʉxyy7. &&ÆÒÒRCCãÕ«WÙÙÙååå‡jÔPÚÚÚ]»v}ô葹¹¹¾¾þ´iÓnÞ¼ùË/¿L˜0AOOïÁƒl­™3g~”à��ZÌú :::óæÍ£w#1|>_¸o��|$$$þÞýw»víBCCš;øb 8pëÖ­ ‹-ºyóæ–-[œœœHdÕ§zªêæÏŸ<a ‰W¯^Íš5ëܹsDÔ®];a7‡… JII]ºtiïÞ½ÒÒÒ?üð}”";"ÒÕÕŽŽž<yraaáßÿ½jÕª¿þú+,,Ll{¾†””ܲeKûöíŸ>}ºk×®°°0"zûö­ŒŒÌÎ;·oßÎæ㻸¸|”à��ZÌúP½zõ"¢œœ"º{÷îþýû‡ 6f̘ãÇ9ÒÞÞžõ,**Ú·oßíÛ·?~lhhhfföã?Ö0444***55õåË—šššfff .îÉ’’’tïÞ=>Ÿo```nn.63kÓ¦MÞÞÞYYY§OŸŽŒŒìܹóرcmllˆ(??ëÖ­‰‰‰ÇÂÂbÑ¢E¢3ÀÙk7lØP^^~üøñØØØþù§oß¾“&Mbßä„6oÞœ——çààðÍ7ߟ?¾nÝ:IIÉ¿þú«¬¬lùòålóã'Ož°¯›K—.ö¿páBbb¢¢¢â!C¦M›¦££#önœ;wîüùó÷ïß×ÕÕ511™5kVãþy��àèÒ¥ËæÍ›,XðÿØ»ó¸œÒÿà×Ý¢UhßÓ2©0QcP„J…™alc«,²K&a²ïK!£²Œ%Œl“DÚ³–H´I›6­Ú»»ïß×oÎ÷žPÒëùÇçqîë¾Î9ïs<>ó¨W×â¾ÚÝÜÜ›AM:uâĉ‰‰‰²²²4K"„Œ7Žé`ffVPPð±ÓÍÌÌÌÌÌ[è\<uuu¦EXXxýúõ...©©©ÝºuëÞ½;Ý–·Áe?¸$Ó’%K–,YÒ ÑØØøý’dee}||!%%%ÊÊÊ ‚ûÿ~lɧ¬¬¬-C‡‹‹KLL”””ÔÖÖ&„XXX<xð 777++‹î¢C—š��øÆ úZééé„MMMBH^^Þ©S§$$$wìØAþ]ƒ“7cÆŒœœœ>}úèééÓÄg÷îÝLØ”——·téR:»­[·nrrr÷îÝËÈÈX¸p!í°uëV///.—«««+))yöìÙ3gÎœ?ÞÇLJÙïïÖ­[Ïž=›0a‚½½}UU•””Ôǯ^½ZZZjmmmgg—››+''WXXøäÉ“¨¨(Á½–ïܹóäÉ“3f,^¼8!!AEE¥¤¤äùóçgÏžuqqY±bÓ“†D?ýô“` U^^~êÔ)111ÚÚÚÓ§OÓ¿sž>}šbddD©úúúµk×8p@YYù‡~ÈÌÌÜ»wïñãÇÏ;gllL¯VWW·lÙ2z¢²²r||üµkׂƒƒ›ëÏ›��ð5&ŒŸpçö /8Íu ø'€™3Ð8QQÑ^½z5Ë¥jjj‚ƒƒ ! R*BH—.]˜ŸÁZ”¦¦&ý!ðkˆ‹‹3?ÿ0”••é S���ß*LÙû*¥¥¥t¶‚¹¹9ùw½ÉìÛ·oåÊ•sçÎ%„TUUM›6­¸¸øòåË~~~±±±æææÿý7³_ ŸÏŸ>}zPP©©idddRRRttô«W¯˜Ùÿý·§§§¼¼|HHȽ{÷‚ƒƒãââ ‚ƒƒ£"ZôiÓ~ûí·'Ož¤¤¤xxxBÜÝÝÇß·oßÇ¿|ùòêÕ«;wŽˆˆ¸téRƒs§L™Ò¥K—€€€§OŸ¦¦¦nÚ´‰Ãáxxx„„„4ýÍtéÒ%//ïÂ… „>}úäåååååݽ{—~{øðáŒ3&&&æèÑ£·oßöóó+++›>}:]<žrðàÁÓ§O+**þóÏ?Ïž=»ÿþ;wâââèßB�€u;vìPWWݾ»ÑC‹»uëVvv6ó±¢¢â÷ßýúµ••ý1 ���ÚRŸ‡ËåfffVVVfdd\ºtiĈ™™™ýû÷Ÿ<y2!¤S§N„§OŸNš4ÉÅÅ¥G]»v%„øúúæææN™2eÀ€ô:Û¶m#„9r„¶9räÑ£Gººº×®]£Ó� !"""ß}÷!¤´´tíÚµ„C‡õìÙ“~«¢¢ræÌ‘Ë—/ß»w6ÒPÉÐÐpË–-JJJ„55µêêꊊ oooúw¼NŸ>Á<°°0!¤²²Ò××÷‡~ „ˆŠŠ:99ÑXmÓ¦MÍòß½{çéé)""²uëVfº­­íˆ#²²²èê EEEt“ãƒöë×öéÝ»÷† š¥��øz222>Þ>gïÞ½÷ïßg»øÆýþû簾¦ƒ ²··7n\ß¾}Ïœ9£®®N ��€vÔç)..611ÑÒÒ255urrJKK[´hÑùóçéª4ÐYºt©àY7nÜ „L™2E°ÑÀÀ K—.Ïž=£sÐèZË–-ûà2111%%%={öd"-JMMÍÆƆ.Ø>yòdÁ… † B4hàr›ôR)))L =eîܹ̲]ëéÓ§ÕÕÕŸ|EŸ]TTdcc#///ØNëyôèýßòòòž={6ø›çرc1|� í8p ³³3Ç›;oî»wïØ.¾ežžžvvvtš^BB‚®®î† îß¿ß½{w¶K��€/>¤¤äÔ©SKKKÕÔÔôõõMMMéò“]2IQQQEEEð¬ÔÔTBÈÈ‘#\­ªªŠ’››«¥¥•@éÛ·ïïûòåKBˆà‚MŒ^½zýóÏ?´£AÖC—›m°ù‹‚‚!$//¯ÁŸˆRWW—––.//OMMeÆg}1ú6‚‚‚´´´Û¹\.!„®ƒNc2ƒ÷OïÚµknnîWÖ���Íe¹ëò»ÁwŸÄ=quuõõõe»øfY[[[[[³]���4RŸGJJjË–-û–Rt⣲²²¼¼œÃáÐâø|>íÆÿ—¬¬lUUÝðXpßbAt{IIÉ÷¿¢·£iÎg¡‹©¿¿¿²àÐ*†˜˜XyyyƒÎìÍÜõéӇΠdÞ=¦ùùùä#oãƒå��[DEE}}}-­,/\¼`cc3vìX¶+���€v�Tsú`@#))©¤¤”——7{öl «ªªúæÍ›¤¤$ºðStU©´´´÷¿¢‹|7׆5„÷·±«¨¨(,,ÒÓÓ£-RRR„¢1êêêšr}:\‹Ž´o¼Ïû[#B*++›r��h5zzz›7m^ê²ôw×ßû÷ﯦ¦ÆvE����ÐÖa ©Ö`hhH¡; M”N:õÁoéD¹4˜aWQQAWoÆ@êæÍ› Z®]»FÑÖÖ§-40JJJìCþ›ÊÑõ°¬*BßFddäûÉ£G„¨¨¨ÂÂBÁöÇgdd|î�@K³··a7¢¬¬lÞüyÌ~©�����ƒ@ª9}l ]ã|ýúõñññ;×ÅÅEHHèâŋ̾{‚z÷îmkk[]]½jÕ*fvŸÏ_·nÝÛ·oûôéC—6o—/_f>fddìرƒâììÌ4ÒPéÌ™3L`”••µfÍòßɃtòW¯^•––2ýúõ4hPffæÊ•+?6¨ªÿþ¦¦¦•••nnnLŸššú’ñÛ�@[³gÏ%%¥¨¨(///¶k���€¶SöšÓÇ)33³Ù³g:tÈÚÚú§Ÿ~êÕ«—P~~þ½{÷6lØ`ffF155]´hÑÞ½{ÝÜÜÎœ93pà@™ôôô¢¢¢“'OB¶oßwõêÕ¬¬¬1cƈŠŠ^¿~=22RFFÆ××—nð×,Œœœ>lkk›••uåÊ•¢¢¢!C†Lš4‰éãèèèããóæÍkkkÚíîÝ»?ÿüsxxx~~>—Ë!„hjjjii¥§§2d̘1†††¿ýö!dçοüòˉ'"##mmmUUUKJJ^½zU]]íççGo±eË–_ýõÊ•+‰‰‰–––ÅÅÅ7nÜèÞ½û¸qã.^¼X__ß\Ï ��ÍBNNîÏ}N˜8aÛömC‡ íc܇íŠ���� íB ÕœYä{Ë–-fff›7o¾zõê•+Wh£¡¡¡`°âîîþã?®]»öÉ“'±±±„‡Cã*BˆššZxxøªU«®]»F'ljŠŠŽ?~ýúõŠŠŠÍøNNNÅÅÅ< „HII-_¾ÜÅÅE°””ÔñãÇ-Z”””ô×_‰ŠŠN:uÛ¶mC† ÉÏϯ©©¡”°°ð®]»œœœ²³³÷ïßÿË/¿Ð@JOO/""â?þ¸yó¦sMÁMLL‚‚‚æÏŸ÷òåKiiéÁƒ{zzîß¿ŸRQQÑŒ ��ÍbØ°aNNN˜ë4788øƒ{q�����B8_¶Q|±ŠŠŠÔÔT)))•ý¤^QQ‘˜˜(%%¥®®N—T__ŸœœÌçó¿ûî;šû4—1cÆDFFz{{O˜0’ššÊãñôôô>¶±ÇKKK+++ÓÕÕ•‘‘ùØe«««%%%µµµß/8##£¤¤DYYYAAáƒ7*))ÉÈÈ022jÞ‡mF äß�:¸šš+k«—/_:88xzx²]ηìСC«V­š={v#ûÿ|±Œ5êǼqãÛµ��À·©þ†ÿ “’’úþûï?ÙÇÄÄäcß 4w] ««Ûx!!¡Oö!„ˆ‹‹ì[MMMMMÍFNïÚµk×®]?y��h ÄÄÄ8h=ÜÚÏÏoøðá#ìF°]����´E¤��� 9­]³ö÷?œMBM”””Ø®è[˜žžÎvð *..f»��øÆ!��€f6gÎœ ÛA!!!‹/:wöÛå|Ë222222Ø®���à³!‚ÿÓ»woòïŠH���_ŒÃáü¹ïÏÁƒƒƒƒ<8gζ+úÙÙÙuïÞí*à×­[7¶K��€o5øZXÔ�àƒnüsÃÑÑQLLìÎí;­³ú!����´Bl����ߦQ#GÙÛÛ×ÔÔÌqšSSSÃv9����І ��€–²iã&„„„›6²] ´9¹96¶6qqql���lB ���-EJJÊ××WXXØ××744”ír€}555ŽŽŽ111Û¶oc»���`)���hA&}MV¸­ „,X°�ÉÃ﮿ÇÄÄhhhìÿs?Ûµ����›H��@ËZ²dÉ€rór—:³] °éàÁƒ§OŸ–8áwBVV–ír���€M¤��� e ùxûtîÜùÆ'Ožd»`GDdÄê5« !û¼öõêÕ‹ír���€e¤��� Åihhìرƒò‡û¯^½b»hm™™™3gά¯¯_²dɘ1cØ.���؇@ ���ZÄñÆWQQá4׉Ëå²]´žÊÊJ{û¢¢"kkë?VýÁv9���Ð& ��€V²sçNuuõØØØ;w°] ´žÅKÇÇÇëêê<pPH?|���!¤��� ÕÈÈÈøxûp8œ={öÜ¿Ÿír 5ìõÚëïï/--}âÄ ¶Ë��€¶���´ž.Y²„ÇãÍ7÷Ý»wl—-ëÎ;›6m"„øúúê§Ïv9���Іˆ°]@[§  Ð,×)((h–렞ơžÆ¡žÆ¡žÆ¡žÆ¡žÆ5¨‡C8Y™Y:::m¤ž/†z×Y¦3ŸÏ_¹b¥­][¨§­½ÔÓ8ÔÓ8ÔÓ8ÔÓ8ÔӸ檇R����Ð"ÊÊÊFåââÂv!���Ðæpø|>Û5�´o4†Gˆ�ðYüüü\–¹ÈÈÈ„‡…«©©±]4'>Ÿïààp3ÀÀÀàfÀMiii¶+��€6#¤���€#ìF”••Í›?Çã±]4§í;¶Ü èÚµë ¿H£���àƒH���;öìÙ£¤¤åµÏ‹íZ Ùܸqc×®]BBB‡ÖÖÖf»���h£H���;äääöyí#„lÛ¶íIܶËfðòåËù æBÖ®];tèP¶Ë��€¶ ���°ÆÒÒÒÉɉËåÎuš[YYÉv9ðUJJJ¦ÙO«¨¨?nü‚ù Ø.���Ú4R���À¦5«×¤¤¦¬^½šíZàËÕ××ÿoöÿ^¿~mll¼{÷n¶Ë��€¶���°ILLìàƒ:u:îw<àf�ÛåÀÚ°aCHHˆ¼¼¼ßq? ¶Ë��€¶���°ÌÈÈhÍê5„ggç¼¼<¶ËÏváâ…ýÞûEDDŽ9ª¦¦Æv9���Ð ���ö999 :´°°pÑâElן'..ÎÙÙ™²eË–²]���´¤���€}çÏ}vëÖ-88øСCl—Mõöí[G‡êêj{{û™3f²]���´¤��� MPVVÞ³g!dÝúu/_¾d»ø4.—;cæŒììì~ýúm߶ír��� =A ���mŨ‘£ìííkjjæ8Í©©©a»ø„U«VEGG+++;z¬S§Nl—���í )���hC6mܤ££“°ió&¶kÆœ<yòÈÑ#:uò;¤Äv9���ÐÎ j£jkk«ªªx<Û…���´*)))___aaaŸÐÐP¶Ë{øð¡ërWBˆ§‡§‰‰ Ûå���@ûÃáóùl×ÐnTWWgddWVVvéÒEMMMQQ‘Ãá´Ä½ÆŒéíí=aÂÁö/^4~¢°°°¾¾>—˽y󦎎Ž‘‘QK”‚!l�ðíؽ{÷æ-›••”ÃÃûuëÆv9ð9¹9ÖÖÖyyysæÌÙ²y Ûå���@»$ÂvíFRRÒ AƒäwÒÒÒóæÍ[°`””T+ÔPWWgaaÑxiié´´´¿ÿþ{Ù²eRRR ’’’­P��@3Z²dÉà;÷îÝs^ê|üØq¶ËÿSSSãè蘗—7È|ІõØ.���Ú+RMU__Ïçó%%%ÿøã99¹ÊÊÊäääÓ§OïܹóÆAAA­°–§°°°ƒƒó±²²òÂ… „ÁF111Bº%'''..ÞÒU��4;!!!o‹!7nÜ8yòä´iÓØ®þ¿ß]‰‰ÑÐÐ8r䈈~’��€/„){MõâÅ …„„¦±  `øðáÙÙÙëÖ­[°`A3ÞîcSöåååõêÕ‹’ŸŸÿþÌÁ¬¬,šOA‹Â”=�€ráâ…¹sçJIIÝ ¾«££Ãv9@:´rÕJ ‰€è!����_‹š…™3gBîß¿Ïv- ©««#�€vmü¸ñãÆŽ«¨¨pšëÄårÙ.§£‹ˆŒp_íNÙçµi���|% ´þZªªª„wïÞ 6ÄÄÄÈÈÈ 0à·ß~ÓÕÕìððáógϦ¤¤äççëé陚šÎ›7¯'ý¥¦¦îÛ·ONNnõêÕ´eÛ¶m¹¹¹žžž©©©þþþwïÞUQQùùçŸÇŒCÉÉÉÙ½{wLL ‡Ã±±±Y¼xñûaÖ' �� Ùíܹóþƒû±±±;vîXµrÛåt\™™™3gά¯¯_²x ýá���àk`„Ô×zøð!!ÄØؘ~¬¯¯wwwŸ2eJPP¶¶veeåÞ½{GŽÇœòôéÓ‘#Gúûû×ÖÖ***FEEmڴ駟~*//o®ªòòòN:uõêU¦åÖ­[§NŠŽŽ¶µµõôôLJJºzõêìÙ³?žmccsôèѬ¬¬'OžìرcÒ¤I‚WkÊC��´o‡³gÏž68¹ƒ¨¬¬´w°/**²¶¶þã?Ø.���¾¤¾Ê¥K—Ž?.++;oÞ<ÚrøðáŒ3&&&æèÑ£·oßöóó+++›>}:Ç£}¾ÿþû¼xñâŸþñ÷÷‹‹ûñÇcccOœ8Ñr¥ÒOÓ¦Mûí·ßž<y’’’âááAqww?~|ß¾}?~üòåË«W¯vîÜ9""âÒ¥K̹My(��€2pàÀ%K–ðx¼¹óæ6’ ­c‰ó’øøx]]݃ á§G���hø‘âó”——»ºººººÎ™3ÇÜÜÜÉÉiØ°aaaaJJJ„wïÞyzzŠˆˆlݺUTT”žbkk;bĈ¬¬¬[·n1×;v,ÓAJJjÉ’%„ÁMÍŽR†††[¶l¡Õ:88¨©©UWWWTTx{{kjjB8}útBHDD=±é��ÐBÜ–»õ1î“™™¹|ùr¶képözí½|ù²´´ô ¿222l—���ßRŸ§ªªÊÏÏïøñã—/_NJJ’‘‘Y»v-Íw!ÑÑÑEEE666òòò‚g 0€òèÑ£÷¯–úâÅ BHvvvK×?yòdÁýø† B4h´´tƒjSRRèÇÏ}(��€f'**êëë+))yþÂyÁ1¼Ð¼ž?^WW'ØrçÎM›6B|}}õõõYª ���¾AXÔüó((($$$Bòóó¯\¹²aÃÄuý�� �IDAT;;» .üðÄÔÔTBHPP–––àYtc œœ¦%11ÑÇÇçÊ•+‚ëFUVV¶tý B%º…¶`EQPP „äååÑM(��€–£§§·iã&—e.¿»þÞ¿555¶+úÍ_0¿sçÎG¥? ¤¦¦Îž3›Ïç¯p[agkÇvu���ðMA õ…gÏž]SS³~ýz///???òoˆÓ§OšOñÿEi#!$..nܸqeeevvvúúúÅÅÅÖÖÖì=Íе!hÙ¤É��ÐÒ‚‚‚nÌ›?Ïÿ²?³˜QRrÒÍ›7/ZÌnyí]XxØóçÏ !VÖV~~~ºººööeee£FZ¶lÛÕ��À·ÔW™6mÚæÍ›sss•••é€#]]Ý 64r–‹‹Kii©§§§½½=mœF×Ö4ñ¡���ZÁž={b†ÄDEEyíór^âL9zìèš5k8ÎÌ3Œù…ÏâëëKÞ¼y3jÔ(ƒ¤¤$ƒýîoË?¨���@;…5¤¾J×®]MLLx<^xx8!ÄÐÐYSSó±SÊÊÊâãã9Îرc™Æ¢¢¢V¨öË4å¡���Z‡œœÜ>¯}„mÛ¶…†…N™:ÅÕÕµªªª²²òúõëlW׎¥¤¤nTRSS'..~üØqÄ|���ÐH}­þýûB¢¢¢!ýúõ4hPffæÊ•+¬ Êàp8<ÏçÇÄÄÐ>Ÿ¿víZòïªLmMS �� ÕXZZΙ3‡ËåNœ8Q0C9sæ ‹Uµwx¿±ººz¹ÛòâââÖ¯���¾y˜²÷µ¸oß>:BŠ²sçÎ_~ùåĉ‘‘‘¶¶¶ªªª%%%¯^½ª®®¦ëLuîÜÙÊÊêÎ;®®®ŽŽŽÕÕÕW¯^­®®­¨¨¨¯¯fõ>à“��Ðjªªªêjë!õõõ‚í‘YYYêêê,ÕÕŽŸ9ûá8/44Ôz¸õÉ'éˆi���€æ‚R_kÈ!;wNOOöì!DOO/""büøñùùù>>>«W¯öðð¸uë–àp÷½{÷<855uÍš5žžžêêê„wïÞ±ö$×”‡��hÏž=³²¶:zìè¿=wî\+×óm8vìXUUÕǾMOO·aÜš%��À7Ãl¦Í.##£¤¤DYYYAAáýÕ@óòòrss ;uêÄJy_¦ñ‡ê˜èÞØl�ðóññÙ°qC#óÇuttÜК%}êêêúöí››—ÛHŸÑ£GïöÜ-##ÓjU��À7SöZ¦¦¦¦¦æǾURRRRRjÍzšEã��ÐrôôôÄÄÄ ¤^½zõðáÃ~ýúµfUíݥ˗I£$$$¶lÞÂì ���Ð\0e���Ú‡áÇÞ ìÞ½{#}Ξ=ÛZå|#|}}?ö•‘‘Ñ;wF��@K@ ���íF=nÞ273ÿX‡Ëþ—kjjZ³¤v-"2‚.‚ù¾Y³fÝ ÒÿN¿•K��€���´'²²².\pppøà·¥¥¥7oÞlå’Ú/_Ÿ êÖ­Û‰'¶oÛ.&&Öú%��@@ ���ÚQQQOÏ­[¶ }à'™³ç0k¯IRSSo6h433 a7‚•’��� ã@ ���íÒìÙ³Ï=÷þÖowîÜÁΧMqàÀÁÝ–…„„V¸­ð¿ì¯¢¢ÂbU���ÐA ��€öjèС·oéêê 6Ö××_¸p­’Ú‹’’’3gÏ0ÕÔÔ®]½öûï¿pÐ���@³ÃÏ���ÐŽéééÞ ´°°lŒZàƒŽ?VYYIú駰аþýû³[���t(¤��� }ëڵ빳çf͚Ŵ<þüùóç,–ÔÆÕÕÕ>|˜"..¾k×®cGuéÒ…í¢��� cA ���히ˆÈömÛwîÜ),,L[0HªþWüsss nÝžî8ír��� #â.f �_@AA‚t�Ú‚ðˆð3f”””(((Ä?‹gò)demeÒ×dãÆâââl×���)€¯…@ � MIKK›2uJrròé¿O>œírÚœ/^¼zõjÔ¨Ql���)€¯…@ �šEff¦——ÛU|#8Îó„çâââ:Ú:l×Måâ⢢¢Âv���ÐJH|-R�Ð,bccmllØ®âÛÁápúèÿ,¾¼¼œíZ IBBBzöìÉv���ÐJDØ.����þ¦¦æâÅ‹Ù®âÛñë˜_±ŒTÛçééùæͶ«€§¸¸8++‹í* ƒ’””ÔÕÕe» �–!��hCäååÙ® U;v ´¾k×®-[¶Œí* ƒ266¾}û6ÛU�° �����tP²²²jjjlWHUUUJJ ÛU�´ ¤����� ƒú駟<<<Ø®:¸¸8kkk¶«�h„Ø.���������:R��������ЪH�������@«B ��������­ ��������´*R��������ЪH�������@«B ��������­ ��������´*R��������ЪH�������@«B ��������­ ��������´*R��������ЪH�������@«a»������€o—Ë­««£Çì�À:R������ͦ°°011155UBBBQQÑÀÀ@QQ‘²eË–}ûöÑ>OŸ>UQQaµÌ†RRRh^&))©¥¥Åv9�ðíC �����ðµ¸\î¡C‡öíÛWPP ØÎápÜÝÝ/^ÌVaM4vìØœœBˆ™™Ù•+WØ.�¾}¤������¾JTTÔï¿ÿžœœüþW|>_[[»õK÷øñãàààK—.aš$@[ƒ@ �����à˽~ýzêÔ©åååô£¸¸xïÞ½õõõ¹\nfffLLÌàÁƒÙ­°cÚºuëž={è1ŸÏg·�x)�����€/Äãñæ͛ǤQvvvÛ¶mSSSc:TVVJJJ²T]‡ÆãñØ.�ƒ@ �����à =zôÑ£GôxÀ€'NœhСñ4*##ãï¿ÿ~ôèQfffNNŽªªª¾¾¾£££••Uƒž<Ø·o_BBB~~¾¢¢¢‘‘ÑܹsÍÍÍé·ÞÞÞ¯^½ÑÐа´´\¶l™¸¸xYYÙÞ½{ïÝ»7~üø3fÐþÁÁÁ>>>ÊÊÊÎÎκºº¬­  `îܹôØÏÏïñãÇžžžOŸ>•––0`Àúõë¬ËÞH…û÷ï&„Œ9rúôé{÷î {ö왦¦¦•••«««˜˜Xƒ»_ºtéæÍ›111………ßÿ½¹¹¹³³s§Nûðùü“'O†‡‡¿|ù2--MJJÊÀÀ`÷îݲ²²3gÎLKKczN™2EXXØÜÜÜÅÅ…ycû÷ïðàAbbbmm­‘‘Ñ€-Z$øïuðàÁÀÀ@BȘ1c&Ož¼uëÖ«W¯öéÓçСCü›@!�����øBÑÑṈ̃‡‡Ççž>uêÔ—/_2SSSSSS–.]ºjÕ*¦ýðáÃ+W®d>fddddd˜››Ó¸§´´ÔÆÆæÕ«WL‡âââôôtz???///Bȃ~üñÇž={ÖÖÖ:99•””BÊÊÊŽ?þÁÚx<^XX=Þ¿ÿîÝ»¹\.!äÝ»w—/_ ‰ˆˆ ~²ÂW¯^ÑK‰ˆˆÜ¼y3$$„v‹¾xñb·nÝhcmm­››ÛÉ“'™«EEEEEEݽ{÷äÉ“rrr´1))iñâÅ?fºUWWGFFvíÚµ¶¶–©œŠŒŒ$„0çFDD,\¸0;;›éqîܹC‡™˜˜ÐÆììlz””oooBˆ¡¡á_�|.!¶ ������h¯âãã霜œ¾¾þçžniiÙ©S' ‹3f8::ªªªÒö½{÷&&&ÒãÜÜÜ5kÖÐc}}ýéÓ§ÛØØHKK3ã6oÞLÓ(QQÑ1cÆLš4ÉÈÈhàÀ‡ËÜŽ§¥¥Ñ4ªÁ· GÚ¹s'—Ë¥¤Š‹‹·oßÞÄ ™KÓ4Š‰Ÿ!Ïž=Ûºu+óqëÖ­4êÚµ«³³³‹‹ ’=z´mÛ6Ú§²²ròäÉL%$$¤£££®®®££Ó­[7‡#---**Ê\SJJJZZšŽÃzûöíÌ™3i%**jaañÃ?Ðn3gά¨¨ ™+ܾ}ÛÇÇçc/ �¾ FH�����|‰ŠŠ f\R=¾à NNN‹/fF§÷ë×Ïçóx¼óçÏ»»»Bîß¿_WWG;ìÝ»—¦'•••Ì¶qtø!dРAÌl2&U;vìÕ«W !âââ#GŽ¤¥%$$Ðo?V[ƒùqÛ¶m›8q¢¿¿¿››­çîÝ»ô«OV(x)---???##£ÇOš4‰Fc~~~K—.UQQÉÉÉ9|ø0íyìØ1iýðÃS¦L!„œ>}ÚÍÍM^^~ëÖ­´Û¨Q£vïÞM.úÔòòòiii7n¤CÃ! Ì\¼µk×ÓãC‡5Š²cÇŽ;wB²³³===W¯^M¦Ý²²²!fffC‡ýî»ï>öÆ�à³`„�����À—¨¨¨`¶o£ÓÙ>—ªªªœœ\xx¸»»û¬Y³,X $ôÿGcÁõ•œÏŸ?Ïår%%%™ñJL‡°°077·ÔÔTBˆ””m5jTDDÄ®]»âââdeeic`` ···¿¿ÿºuë>VÇB,,,fÍšÕ¹sg{{{cccÚ˜][[Û” /µnÝ:###Bˆ©©éèÑ£ic}}ý³gÏ!ׯ_¯®®&„ÈËËwêÔéÑ£G=’ ¯¥¦¦†Ió÷÷§'ª©©ùúú2ã­˜§n3aPQQ‘¦Q„GGG¦CDD=6nܸ+W®,]ºô§Ÿ~úä-� )H�����| EEÅ®]»Ò㤤¤/¸B\\œ©©éرc8põêÕû÷ï×××Ó¯ŠŠŠè••3ü*11qþüù}ûö=vìs‘ùóçÓƒúúú#GŽ 8pÚ´i‚ $õèÑÃÑÑ‘I£!âââ&L`¦Ô}’††sܧOzÀãñèP£OV(¨oß¾Ìñ!C˜ãääd"ðß¾};räÈ#FŒ1â×_e¶ÌËÈÈ(..ÎÍÍ¥ $..Þħ „æççÓã~ýú1íJJJÌ32“%™´‘²xñâ¦ß�š�����À200 %%%ÌÈš&JNN7n %--=xðàÙ³g7غŽ"**zåʦ%77×ÕÕÕÓÓ“~?~üþýû™y|>?00ÐÆƆ‰´¾žàX¡SùšR¡ f!„‰ó˜ö²²²OV"ø\ïÓ¸ÒÒRæ¸sç΂_ î¯G£(Á@JpÑ+�h¤������¾……s¼|ùòÊÊʦŸ{ᚈŠŠÞ¹sçÒ¥K[¶laö­$''wêÔ©°°°É“'3+mïÙ³‡N5qâĸ¸8OOO===Ú’ŸŸïççÇ\¡ªªªÁ5é̸æòÉ ÌúMD`*òï"\LýrrrçÏŸ?þü¹sçΞ={æÌ™3gÎœ>}ÚÆƦ{÷îÌ$Á‡ ÆF‚C´wïÞÑmmmfe+Á‹ŠŠ˜ÁYFFF‚ç@ A �����ð….\¨©©I“““-,,îܹCWV¢èÚáôðáCz ''§££C),,|ýúuƒn<.nhhèååµtéRÚ^UUõöí[òo´$&&fooÌŒôÉÌÌ$„¤¤¤ØØØèêêÎ;—¹æŽ; üñÇÐÐЯxú¦V(h÷îÝô ¼¼< €s8º°T¯^½hKaaaAAÁСC‡ fiiieeeeeemm­¤¤$,,lhhH»½|ùrÛ¶m̤˜!cD`Ýw‡ÃÜ"==Î$„ܽ{—¹³HÖÇ¢.�hØe���ØÁü¹^DDDpsîÆeff¾~ýºk×®:::MY¼� EIHHlß¾}òäÉôczzú¤I“„……µµµ9Nnnî»wïRSSeddÞ?— E'¸õêÕËÏÏ™SƬšôøñcGGÇÑ£Gr8œ7nÐönݺ)))Bx<Þ Aƒ455Ÿ={ƌҢ©ÍáÇccc !/^´··777ÏÏÏ÷ôô¬¯¯///÷ôô\ÈéË|²BAþþþ ýúõ gnŸ:uª²²2!ÄÎÎÎÄÄ$&&†2þü;wš™™ÉÊÊ&''§¤¤Ì›7ÏÁÁâîî>~üxz®§§çÕ«W sssÃÃÃi;BæÎ{øðá_~ùeîܹîîîcÆŒ¡aÓ„ þ÷¿ÿUUUíß¿Ÿ©yÉ’%ô@‹B ��ÐAUVVfgg—””TWW×ÖÖJHHHKKëèèHKK·ÂÝ«««™_¦M›ÆüÁ¼qqqnnn?¦—-[¶bÅŠ,� i¬­­/\¸àââÂÄ+õõõ)))L‡çÏŸ8ðý§OŸ~éÒ%šz0K€KHHм¾¦¦†¶DFF>|¸Áé+W®$„p¹ÜTTT4뤫«ûÛo¿‘ÿ®ÊD+**˜™tŸ\³©)¯°‡“””$¸¼ššÚÚµk™o÷îÝ;nÜ8ºôxZZZZZÓ366–RC† ™?¾··7mOIIa^xqq1]ïÉÒÒRYY™.Îçó>|H‡>™™™-]º”®o•½~ýzæú:uòòò¢ÑA ÐÂ0e�� #òóóÓÒÒ2339räرc'Mš4zôh+++mmíÁƒŸ:uŠN¾h;òóóÇǤQ„Ö Î��šbÈ!áááK–,éÛ·oƒÁ›zzzË5 àããÃ,ì-))¹aÃ777ú‘Ù NUUU[[[ðDooï3fBÊˡ*¸¶·ˆˆÈäÉ“/^¼Híž5kŠejj:|øpBˆ¶¶ö„ 8Ž´´ôÂ… ¿þñ¯°Ã‡38qbhh¨àêæÑÑѳfÍ’——g•••‡ F§õQëׯ¿xñbïÞ½………™FYYYf’ „„Ä¡C‡ cþ!V®\éïïß»wof…uQQQ;;»ˆˆ;;»/z�ðÙ8}¾’‚‚!¤  €íB� }‹µ±±111 l…Û=ztùòåtPVV>pà€™™Y P]]Íl°Ý”R .<{ö,=VQQ±°°øå—_wtj#òóóCCCïÞ½kddÔ,¿æuÆ ‹ éÙ³'Ûµ@âçç·lÙ2f¿xfffNNŽ¬¬¬¢¢â'ë ª¯¯ONNÒÓÓÜ®·oß¾yó†ÇãijjÊÊÊ6ø¶¦¦æÍ›7òòò æAs¹Üôôt]]]ÁÆŒŒ 99¹fœûÜH…6lØ·o=~úô©ŠŠJvvvaa¡AãÛägffjhh4²É]mmmJJJee¥¼¼¼––Öû둧§§Ó]]]ÁôŠRUU•œœ,!!¡­­-"Òó‡ââ⬭­oß¾Ý ·hË0e�� £>|øwß}W^^žššúèÑ#:I$77wÆŒAAA‚kp°(,,Œèéé………5}Í©ÖT[[Û«W/ú×¾ °]η/---**jêÔ©lІ†“¹’°°°Á'»ÉËË Žj@LLL[[»Á0%†ˆˆHƒ4Šüw‰¥fÑx… ¨©©©©©}²[·n݉¢¨N: ŽœzŸ–––––Ö¿’øþûï?Y�´R���³³ó?þHÓÓÓÝÜÜîܹC)**²··¿yó&³C6[***rrrèñ!CÚfEáóù{ÞÒŠŠŠÂÃÃCBCBCC322ÄÅÅH��´G¤���àÿhii;vlÈ!¯^½"„$$$DGG[ZZ2òòò¼½½cbbž>}ª¤¤dbb2cÆŒþýû7¸NTT”ŸŸßË—/_¿~­®®Þ³gOGGÇF&�¦§§ïر#&&¦°°°oß¾3gδµµ¥_yxx„„„0=ƒ‚‚’““}||:tóæMÚîççG'ž¼}ûÖÉɉ6Ž;–I+***¼½½_½z%""¢¡¡aii¹lÙ2qqqæâ¯^½ú믿+**TTT~ûí7ºyFFÆßÿýèÑ#:GUUU__ßÑÑÑÊÊŠž{ðàAfÿrBÈ•+Wž={FñòòbF|òµ”––Îœ9“Ÿ9sæÑ£Gþùgddd@@�³Ç9UPPÀìàîçç—œœ|àÀ˜˜˜ÒÒRSSÓÅ‹3ÿ(LO!!¡óçÏ_¼xÑÇÇ'55U__ĈÎÎ΄7n\¼x1**ªK—.#FŒXµjUã“hZYuuõý÷ÃBÃBBCž>}ŠÔ��à€@ ���þC\\ÜÍÍÉtâââ˜@êþýû³fÍÊËË£éæGW¯^ݵk×”)Shcmm­««ëßÿÍ\011111ñòåË3fÌضmÛû«{ÄÇÇÛÚÚÒÁÁÁÁÁÁ+V¬X¶l!äÅ‹÷îÝc:gdddddЙ&)))ÌT>fǨšš¦±oß¾ô ´´ÔÆƆ¦lTqqqzzúªU«˜–={öxxxTWW3-©©©ÌS§N}ùò¥àW©©©K—.¥INNŽˆˆ`:deeeeeBènYM|-"""Lññññ%%%‚OÇàñxLÏìÙ³‡ÞˆrëÖ­àààíÛ·Ó½¨{nÞ¼yÏž=ô8&&&&&¦ªªªK—.ÌþV………û÷ïOJJ,•|>ÿÙ³g¡a¡!!!÷ïßüw€v§{÷îæææô¸MåÝ�À"R���Ðà‚qqqôàíÛ·“&M*//'„ 6lÈ!‘‘‘AAAuuu®®®C‡UUU%„xzz2Y†ššÚ÷ßÿþý¢¢">ŸäÈ==½Ù³g7¸Ý“'O!rrr555ôú„;vüôÓO=zô—’’ª¨¨ í¢¢¢bbb’’’ŸõD›7o¦i”¨¨è¨Q£ÄÅÅŸ>}ª©©É¤cGŽÙ¼y3Ó¿k×® 999&&&´ÅÒÒòÕ«W ÐÕÕåñxAAAoÞ¼!„ÐíÉ{ôè!&&ö~„z‹&¾ÁÙˆ³fÍ¢iÔ þF·uëVBˆ””—Ë¥K€q¹Ü?þøÃÊÊJMMM°'M£8œÿÛÖ†n|Þ 1(((**ªå–´oDVVVHHHhXhXX“Q@{çàà@#r��)���h¨{÷îÌqbb"=صkM‹ÌÍÍÏ;GY°`Mlllmm­¯¯ï† RSS½¼¼h“+W®ˆ‹‹çååYYYÑqU[¶l7nÜûûCmܸqöìÙgÅŠG%„ðx¼={öøøøüù矫W¯îÕ«í9gÎœuëÖ}îEFFÒƒAƒ:tˆ3áQNNÎÆ鱌ŒÌþýûé¶ßõõõ\.—¶;99-^¼XNNŽ~LOOïׯŸÏçñxçÏŸwwwß´iÓêÕ«ÕÕÕ߯³é¯Epû§ÌÌLyyy;;»=z())5x¢C \]].\(,,¼|ùrš|UWW{zzzxxö=|øp¿~ýÖ­[Gÿ !Ç××wØ°aÛ·oÿ믿hcXXX«Rbbb&&&¸wÿžà(¶¦¨©©¡ÛØ|®·oßòø<¶«��è¸H��@CÌ<5B³#øÅ‹é©©é£G豞ž^ll,!„¶DDDÔÕÕѯ&OžL—gRRR²µµõóó#„”——ÇÆÆ2ë.Q&&&ÌrHË—/?vìªC×`jt°!$,,ÌÍÍmÎœ9ºººÌ£Ý¾}›™µjÕ*šFB„……™„ˆŽÿ  ÌÉÉÉËË¢3é222¿{Ó_‹à|FQQQÿ=z|ðš‚ÑUÏž=]]]鹫V­b†bÑÑm‚=ÇŒ3räHBȲe˘@ÊÒÒrìر„777&zýúuãÕ\ÒÒÒ¤¥¥“Ç<þ‚Óù|~ì“Øf¯ :i8ƒ��Z )���h(%%…9VQQ!„0ÓǼ¼¼˜ñ> Ê$$$0-ÌÎ}„~ýúÑä…òâÅ‹”àrÝòòò={öŒ'„¤§§7ÇÓBÈüùóçÍ›G©¯¯?räÈÑ£Gmll¶oßN—,ûcÃmâââfÎœùÁ쩨¨¨ñ»7ýµ.×mccó±4ªccc&ÉRRR200 Ë] þ;RÌ>ô:::ÒÒÒ4†STT¤ÝºuÓÔÔ¤Ïøɇj.ÚÚÚ………¹9¹¦ß-Ê�� �IDATçΞKÏH ‰ˆˆ(--mâébbbׯ_oÑ á[uãÆ=»÷°]�@Ç…@ ���ºvíslaaA)++küˆæ;wfŽ—|z‹´Ëœ3ÛÞ}ַ̤?~<Ç[³f ]–ˆÏçÆÆƆ‡‡ËÊÊ †/¼irrò¸qãèÓIKK÷íÛ×ÀÀàúõë999M©­é¯EðåtëÖ­)'„ ~ìÚµ+=xýxA"""ïwcFµ>%%%KKËÓgðx¼'Ož„†††„„<xø ñY‡Ó·OßV+¾%Ïž>küÿ#��ТH��À<~üøøñãôXJJêçŸ&„hii‰ŠŠÒh`Þ¼y–––|>ŸÉPø|>ÍVÇ:EGG3ãq·ÉëÝ»wƒ; Î,--¥s� !Ÿ$˜ž$$$ <˜ÂL¾k`âĉ£G>w·7:”ŸŸïçççìì,x£û÷ï=ºÁ¹.\ ¡’¨¨è;wttt!<hH þrûîÝ;æøË^ËûŠ‹‹?˜R3ÇåååÌ„Ê&°jk„„„LLLLLL–.]ZYY*8Ð ���Ú;¡Ow��€ŽËåz{{ÓÁD´eëÖ­ÊÊÊ„&݈ŠŠ2116l˜¥¥¥¥¥¥•••µµ5]�ÛØؘ¹ZPP=¨¯¯ ¡ÇBBBÌòä‚=<x@Ïœ9Cf"„ôìÙ³ñ‚µ´´˜ãË—/Ó¼ìàÁƒL#3਺ºš"&&fooÌ MÊÌÌ$ÿ ƒÖ®]ûþºÚ>¤rrr4*,,|•¥N:1 =zÄ íiúkyøõòåËÁƒL:•ù×a2aÍ¥K—˜…Ø?ùÛ>III++«6†…†%<Oðõõ4iF ���íFH��tt«V­RPPÈÌÌ|ýúuMM Ó>nܸɓ'3W®\9uêTBH\\\ïÞ½MMMMLLÞ¾}›œœ\TTM:tèàÁƒÃÃà !þþþÂÂÂýû÷¿víZrr2½ÈÂ… ååå !LêDáñx?ÿü³™™—Ëe IHH,^¼¸ñʳ­'Nܽ{—Ïçggg3Ì]x<Þ Aƒ455Ÿ={VYYIÛéØ¥áÇ0€Þ:;;ÛÂÂÂÜܼ[·n/^¼øßÿþgooϬ²”››ëêêÚ«W/???f"ž`B¤¡¡A³¡„„„¾}ûêèèœ>}ºé¯åcÔ_ýE—…ºuëÖÝ»w,ÂÅåríìì†^SSÃ^âââ .lü¶/ŠŠŠãÇ?n<!$)9)4$444ôË–B`QvvvBB›7oTUU{÷îÍì<PQQ‘žž^VVVUUE×t{ORª¸¸877—¢§§'**úÁ»”••ÉÈÈЕòxûömAA¢¢"³s(�@ëC ��ÐÑѽØ)++/Z´ÈÑÑQ°ÑÆÆfæÌ™GŽ!„TVV†‡‡Ó„…ÊÉÉ¡ãV¼¼¼FŽIç²]¼x‘Ù›2`À€•+WÒcÁ…hX!x»?þøƒ™Úö1¦¦¦Ã† »{÷.ý˜••EQRRRPP Ë¢Ó»p¹ÜTTT„†† ž®««ûÛo¿Ñã½{÷Ž=šþ‚WSSLÛiº4}úôK—.Ñ´èرcô+ ‰ªª*ÚŸ¹æ”)SÜÝÝéq^^^^^^mm­””T_ËÇ)z#ŠIÓ§ªªêêÕ«‚+V¬ÐÖÖþØ«kïô¿Ó×ÿNöìÙ‚É&@[VQQ±qãFfþ/C^^>&&FBB"11qРA ÎRVV^ºt©ƒƒ³èåîîN7Ê<pà�Ý%³ww÷ëׯKKKGGGÓ®‚Ž=ºcÇŽ5kÖ,Z´¨ž �à‹`Ê��@G$""Ò`5_)))}}}++«mÛ¶=zôhÎœ9bbb ÎÚ¾}û¹s猙?È‹‰‰õîÝ{„ µµµ´E]]=::ÚÉÉIFF†9QEEe×®]W®\a~§b‡sæÌ{{{æšZZZgÏžurrjʃìß¿ßÖÖ–ùøý÷ß_¾|ÙÔÔ”~¤3õÊˡ*¸Z¹ˆˆÈäÉ“/^¼ÈÌ°ÓÑщŽŽž={v—.]˜n‡FZ ðñña —””Ü°aƒ››ý˜ŸŸÏœ2sæÌ™3g ®2N3¦&¾–™5k–’’!ÄÄÄÄÎήÁ·&L˜>}:suuõS§N-X° ñk~˜¡%�mÙ;wÌÍÍÿúë/qqñ‰'®]»öàÁƒ[·nµ··755• ÿŽµ¤ÿyñòòÚ¼yóÔ©S‹‹‹ÝÜÜf̘!xµššš€€�iiiBˆ¿¿#÷-//gþK�ÐÖp>ö‡8�h"òßy�¾@ll¬‰‰I```ëÜ‘ËåUWW×ÕÕÉÊÊ6}O7BH}}ýëׯy<žŽŽN#‰À›7orrr´µµ?6ëDPMMÍË—/•••iòòY ÓÒÒ”””TUSSóæÍ›‚‚yyy Nr¡òòòÒÓÓ¥¥¥UUU™ŠR__Ÿœœ,$$¤§§×`c»***’’’!šššïψù¬×Âàr¹éé麺ºôcuu5ó°Ó¦MÛ½{7}JJJï†hㆠò ,z툟Ÿß²eË<<<ZôFOŸ>µµµår¹ëÖ­ÜjSЋ/,,,×ïOMMµµµ---õññ?~<m pppX´h‘ŸŸ_uuõ‹/Þ¿æŒ3®_¿®¥¥•žžîçç7bÄÁowî܉Rl‰‹‹³¶¶666¾}û6Ûµ�° Sö���:(fi¤Ï%,,Ì$#PUUUUUmâ5ÅÄÄÿþ,rrrŸ\ ELLL[[»)³Ø”””>Š 4¥))©¾}û~ìÛÏz- ‘Æßù×¼@�h!õõõK—.år¹‹-Z³fÍçž®««û¿ÿýÏÃÃ#,,Œ ¤è¨(kkëׯ__»víŸþaf7°xñâeË–¹¹¹YXXnK �Ð`Ê�����@‹8zôèÓ§OÕÕÕ]]]¿ì úúú„´´4ú±ªª*00PZZº_¿~–––¤ÑY{FFF¶¶¶999›6mú²»�´R������-‚nþ0}útºPÔHOO'„hjjÒAAA¶¶¶¢¢¢#GŽ -))ùà¹ÕÕÕ«W¯9räHLLÌ—��ÐBH���´?ÂÂÂæÿÒÓÓc»�ø°/^Bzôèñe§—––ž8q‚bnnN[èx¨Ñ£GBdee‡ RWWwýúõž^__ߣG9sæðx<ìJ �m )���€öGTTÔÿ_dC=€v§²²òõëׄï¾û®‰§p¹ÜÌÌÌÊÊÊŒŒŒK—.1"33³ÿþ“'O&„TTTܾ}»sçÎVVV´ÿ¯¿þJ¹|ùò¯Fwî[¾|¹²²òóçϽ½½i;¶§€¶������@󫯯ÿÜ=Í‹‹‹MLL´´´LMMœœÒÒÒ-Ztþüy‡C ¬ªª1bD§NhÿQ£F‰‹‹GFF¾}ûöý«Ñ@JJJŠ®!µk×®¼¼<‚@ �Úì²�����Ðü:wªúæÍ›”””¦ìLJ‘””œ:ujii©ššš¾¾¾©©©àÞ t$Ô“'O·Õ©®®¾víÚŒ3\‰ÃF}öìÙ   ;vxxxˆˆà×@�`þK�����Ð" ß¼y“`kkÛ”þRRR[¶lùàWïÞ½»{÷.‡Ã).....fÚ…„„!—/_~?´}ûöÈÈÈS§N999‰‹‹ÎC��´LÙ�����h&&&„C‡½{÷î+/PSScnnžð_!!!„{÷îåææ6rº††ÆòåËëëë7lØ ##ó•Å��|=R������-bÁ‚jjjëׯÿÊKÑýõ~ùå—í¦¦¦|>ÿÊ•+_aîܹ={ö ŒÿÊb��¾)�����€!%%µk×.BÈñãÇÇŸÝ CyyyS®SRR"$$4jÔ¨÷¿3f ùø^{ aaaOOO!!¡#GŽ4©z�€–„@ ����� ¥X[[ïÛ·OVV644´_¿~C‡;wîºuë.\heeeiiÙ”‹Ü¸q£®®nÀ€ŠŠŠï;zôh‡óøñãÌÌÌƯcbb2}úôêêê/y�€f…@ ����� Mš4)::ÚÁÁAEE%!!áâÅ‹û÷ï?{ölrr²¡¡a]]Ý'¯ð±ùz”ŠŠÊ?þHùä¬=Bˆ»»»²²òg>�@óÃ.{������-KVVÖÃÃRYY™œœLQTTTPPùÿ¿‘|ìôóçÏ7~ýëׯ ~<zôèÇzvîÜùÙ³gM¯� … �����h%’’’ÆÆÆlW�À>LÙ�������€V…@ ��������Z)��������hU¤�������� U!�������€V…@ ��������Z)��������hU¤�������� U!�������€V…@ ��������Z)��������hU¤�������� U!�������€V…@ ��������Z)��������hU¤�������� U!�������€V%Âv������ìHNN>qâÛU@’Ív �m)�����è ¢£££££Ù®� #B �����Ž¾¾¾½½=ÛU@¥®®Îv �ìC ��ІÄÄÄ(**²]@«âóùl—ðÿØ»÷€œïÿÿ㯫£Ôœº:H‡”ä˜!§ŠBŒafdÛÇ|̆±Í—9}l̶ŒÙglN#dfc(QΔD*9+!t>\×õûãýù¼ק’¢®+]÷Û_ïëõ~½_×ó}]mòðz½Þ0DÞÞÞÞÞÞú®� ��5 9× SSÓ¢¢"}W��`(üÖ <#!DFF†¾ �<½=îiåÞªY³fú.��À 0C ��@DFF¦§§H��膑¾ ���пȈȈˆ}W��`(˜!�� ÝíÛ·“’“îdÜQ«ÕFFüs��@µãW.��`褹Q><{Vßµ���)��`èäÅz‘‘z-��ÀPH��Cw(êtI ��  R��À ?>##C:>~âxnn®~ë��0R��À iÏŠ*,,<zô¨‹��0R��À EDFüÏˈˆ²û�� êH��ÃUXX£Ýyˆm¤���ª��0\ÇOÏËËÓnÑÞR ���Õ„@ ��®2è1I �� ºH��Ã¥½£yù���¨BR��À@=xðàìÙ³¥Û ¤���ª��0P‡Öh4¥Ûoݺ•”œ¤ûz��� ��0Pen %‰Œ`’��@5"��ªœÍËYµ��P­¤��€!ºvíZjjêãÎFŽ*..Öe=���…@ ��¢rÖë !²³³Ïœ9£«Z��� ��0Då¬×“”ŸX��àY˜è»����=>|x¿~ýþóB#ÞýÇ» …båÊ•r'G'ýT��`�e>í@ÅÙØØ!222ô]�à)©T*;{;##£;éwô] ��€A`É������tŠ@ ������:E ������"�����€NH�����@§¤������ SR������Ð))������è������tŠ@ ������:E ������"�����€NH�����@§Lô]���€L›6mó–ÍÚ-jµÚÑÉQ~Ù³gÏM7é¼.���ƒÀ )��`ˆ¼»yçk‘µ[¼½½õ[!��@-F �� ‘O/Ÿò;øúúê¦���D �� ‘‡‡ÇãÎ6hР}»öº¬��À H��åçç÷¸S½zõ22â×$��€êÂoZ��À@ùú<vQ^9Y���ž��0Pݺu355-óT9Y���ž��0P–––;w.ÝîââÒ´iS—��`@¤��€áòóõ+ÝÈóõ���ª��0\efOe¦T���¨BR��ÀpuèС^½zÚ- …¢W¯^úª��À@H��Ãell\"~jß®}Æ õU��€ ��­Äª=_?6��¨vR��À •Ø1ŠÍ��t€@ ��´æÍ›;::JÇuêÔéÚ¥«~ë��0R��ÀÐùùùIÞÞÞæææz­��À H��CçëóŸezr2��€jE �� tPb?)���T)��`謭­Ûµkgmmíéé©ïZ��� ‚‰¾ ���B‘™™yàÀ}Wa¸Úx¶iܸqXX˜¾ 1\õë××w��@G¤��¨®\¹2iÒ$}Wa¸Ú¶mkaaÁW G$�ÀpH�Pƒ4jÔ¨wïÞú®Â@›;99é» C´ÿþè» �� SR��Ô M›6 Õw€NõîÝ›@ ��Cææ������Ð))������è������tŠ@ ������:E ������"�����€NH�����@§¤������ SR������Ð))������è������tŠ@ ������:E ������"�����€NH�����@§¤������ SR������Ð))������è������tŠ@ ������:E ������"�����€NH�����@§¤������ SR������Ð))������è������tŠ@ ������:E ������"�����€NH�����@§¤������ S&ú.���èZ­.((ŽÍÍÍŒªåߨòòò¤SSÓ*óÑ£GõêÕ«’¡ªCNNNrrrvv¶“““³³³¾Ë©JÙÙÙ––– …Bß…��€Ú€R��¢}ûö9ÿWxxxu¼E~~¾ü}ôѳxîÜ9ooo77· &<ûhU®°°pÉ’%­[·xå•W:uê¤R©ô]T•ùä“OÜÝÝ;tè¥ïZ��@m@ ��žkÖ¬IIIQ©T;wî<}ú´¾Ë)iÑ¢E‹/ÎÍÍ•^ZXXë·¤ªrãÆü±°°ðÖ­[ß~û­¾Ë��µKö��ÀóÁÕÕU:033{ŠÕpjµúÔ©S ³°°¨ÂÚRRR¾ÿþ{éX¡PôíÛ·Q£FU8¾~ÙØØÔ¯_ÿÁƒBë[���xR��T™½{÷z{{×䎞k!!!uêÔ‰õÕW•Jee/ÿòË/¿þúkéX£ÑTmm111EEEÒñÊ•+GŽYµãë—¹¹ù–-[Ö¯_ߢE‹1cÆ軜2\JºäÖÒMßU��€J � ÊŒ_XXèåååçççëãûâ‹/VÕNÞBÔ­[wâĉO}¹Z­®ÂbJHJJ’ªïô¥cÇŽ;vÔwÿ#---òPddDdä¡È‡Þ¸~Cß�€J žUFF†¾K�Pƒ¨Õê“'Ož<yréÒ¥–––=zôðõñõóósww×cUEEEË—/ß¿ÿÅ‹]\\üýý;tèð¸Îéééß}÷ÝéÓ§ãââììì¼¼¼Þ|óÍ®]»–è½nݺ‹/^¹rÅÑÑÑÓÓsܸqÝ»wÜ°W¯^]¼xñéÓ§ïÝ»×±cÇñãÇ÷ïß¿Rw±~ýú;vHÇ?üðƒµµuFFƤI“¤–uëÖ:ujÙ²eqqqVVVÞÞÞŸþyãÆ…>?~|jjª<ÔèÑ£{ôè1uêԊܵ4‚t¼iÓ¦“'O®\¹òÈ‘#{öì©W¯Þ{ï½wéÒ%yð &(Š)S¦øùù]»vmÆ 'Ož¼~ýúíÛ·ÜÜÜÆçïï_ú/_¾üã?&$$$&&æää4nÜøÕW_ýðÃ+Ra9ÊöüùóË—/?}út^^^×®]ßÿýøøø°°0!DÏž=¥nEEE£F’úLž<ùÉßVõÈÎÎŽŽŽŽ<‘˜˜(·×©SG_%�€§C �@uÉÉÉÙ»wïÞ½{…övö>¾>¾¾¾¾>¾öööº,ãÎ;£GŽ•^ž?þüùóÖÖÖev>vìXHHHzzºô2555555<<|éÒ¥£G– §OŸ¾aÃùªÄÄÄÄÄÄíÛ·¿ùæ› .T(%†ïß¿ÿ½{÷¤—8pàÀÇ<mÚ´ŠßHjjê¡C‡ä„jµZnùöÛo¿úê«ââb!DVVÖöíÛ#"">lkk[XX(w“9rD!O¼ky„øøøàà`iC%•J•““Sbpé9tÒª½×_ýâÅ‹ò©””””””={ö|øá‡3gÎÔ¾ê믿þ׿þ•ŸŸ¯ÝYþ7Š|/e*Ø 6|ôÑGÒË]»vEDD¸¹¹:uJáää$µ«T*ùŸb÷®g¤R©NŸ>qòäIé+��Ï;ž²�€.¤¥§mÙ²åÝwßmÓ¶MÏ^=gÍžµoß¾ììl¼õܹså4ÊÈȨI“&B9Òv÷îÝQ£FI©GïÞ½?ûì³¾}û !ŠŠŠ¦OŸ~ëÖ-©Û²eËä4ªI“& 6ðÖh4k×®]³fMé‘Ïž={ïÞ=kkk+++¹qñâÅÚ“\ž‚™™™|¼dÉ’ââbí,,33sÑ¢EB…Baee¥½|ÒÒÒÒÊÊÊÜܼ‚w­}mHHˆ”FIŒŒŒ¬¬¬LLLJ .]Ò§O333Ÿ7ß|sܸqRŸåË—kßûÚµkçÏŸ/ÇF 4hÙ²¥•••——W+,SùÃ^¾|yúôérÕ¢E‹^x!++KJ£„Ú7¥{ÉÉÉk~\ìÚÒuÀÀ -<zô(i��µ3¤€*0ûÓÙú.@ ok]¾‹/^¼xqÕªU&&&;w–ÖôUSI±±±[·n•Ž]]]ÃÂÂ7n|áÂ…¡C‡–Τ–.]*ed=zôزe‹âÝwßíׯߙ3g CCC¿øâ‹”””+VHý½¼¼vîÜY§Nôôt)1Y°`APPPégÌÍ›7oâĉ …âã?þ駟„jµú믿–N÷´)!ÄÂ… GŽ¹cÇŽ3fHßÅÁƒ…J¥255uÞ¼yrå uëÖ­ø]Ëïrýúu¥Rèîîngggcc“šš:mÚ´uëÖ•üí·ß~ï½÷ä©XW¯^íܹ³F£Q«Õ¿ýöÛìÙ³…·oßž7ožÔ¡^½zß~ûm`` B¥RIùKE*,ýá<qØ/¾øBšh&„X±bÅk¯½VPPðÖ[oýñÇR£î©»wïFFFJ+òÊ ÚJ+**âÏbÔpéééW¯\6l˜¼Ð� PBCCõ]€çRqqqLLLLLÌÊ•+ûôé#OŸ©BÇ—CBB¤=•<<<Þÿý9sæ”è¼mÛ6é S§N'Ož”Ž]]]Ïœ9#„Z>,çn¯½öš´w]ÿþý¥D&;;ûÌ™3%öHòòò’ÿöÑGýûßÿ–žswîܹg¹;íœÈÇÇ'$$D1vìXiÛ&!ÄÍ›7 KäVOq×Ú¯LMMwìØQÁMÁ¤ï4**꯿þº}ûvzzº‘‘‘J¥B\»vMêó÷ßËsåfÎœ)ÅFÒÝI7X‘ K{â°ÑÑÑRË‹/¾øÚk¯ !ÌÍÍgÍš%R¥—^V‡ÅKËo]Y*•Š?‹Qói4Ý/z€‹@ ¨󾘧ï�Ô_Ìû¢‚“¤„ÆÆÆ^^^¾¾¾~¾~/¾øâ¹sçúõëWåÛKio¶­=«Y³f%zfddÈ+ÑV¬X!O&’IJBB‚ÜÒ¥Kù¸sçÎò¡ .”¤<<<äc¥Rééé/„¸zõjeïèqä „:tbµZ™™igg÷¸«*x×R|&éׯ_Å·¨?~¼œ=i»ÿ¾t ý‘Jkñž¢ÂÒÊöÎ;™™™Òq§Näv[[ÛÇÜJõºuëÖ¯¿þºðË…‘‘‘‡¢Uê™!¦¦¦s>-°5J||üæÍ›õ]�Ô R@Ðãó†�Ô(óÌb åÚÂÕ×Ï×Ïϯgž/¼ðBu—ôðáCù¸^½zåô|ôèQùCIóe´Ô®_^¤&þ7¾Ñ¾V&?­ü¹K•¢ý¶‚w­}G 6¬ààIIIAAAÒ'feeÕ°iá�� �IDAT±cÇV­Zýþûï·oßÖî&'SeV^Á K+ج¬,ù8//O>.ýÝé’ƒƒÃèÑ£G­Ñh""#"##cbb´+,“±±1£† —–Ü�$R��T;¥R)=aÏÏϯ:Öå•£E‹òñþýû¥•YBùym2SSS)P›<yrŸ>}4OHRä¤=×)&&Fž—tôèQ¹½mÛ¶%מíòðáCi­™¢âSžvp“••%ÝNïúélݺUJ£LMM÷ïßß¼ys!ÄñãÇKRÚ±cdž ¢}¶RfffÊyYŇ=pà€Üž––öÔ÷[… …§§§§§ç»ï¼[XXxìø±ÈÈÈȈȳ±gõ™�€ªB �@µ°°°èÖ­›´"¯uëֺ܎G›v~´qãÆaÆ™››ggg—^ùebbâîî.­¤‹ŽŽþç?ÿY挪öíÛËÇûöí9r¤B¥REDDHFFFmÚ´)qÕ¾}ûŽ?.-ñÛ´i“´‰’ÂÓÓóÙî¯äÅ…GŽ6l˜¨ð]?]râÄ ù­¥4êÞ½{W®\)ÑM;¿›;wnÛ¶m¥Î’ Vxñâʼn'^ºt) `ýúõFFFO¶M›6R2xãÆ­[·><//oþüùOq§ÕÊÌ̬WÏ^½zöš=köƒ¢¢¢"###"#J’��à9B �@•166îØ¡£¯Ÿ¯¯¯o×.]«p=ÚS8p`‹-RRR„111]»võððˆ‰‰ÉÉÉ‘ûÈñÐ'Ÿ|òúë¯ !bccÛ¶mÛ©S'//¯»wï&%%Ý¿?&&Fáçç׫W¯¨¨(!ÄŽ;Œ»víºk×®¤¤$iüãJ¥R{X!„Z­<xp÷îÝ‹‹‹å¹Tï½÷ž>‰ö^“&MZ³fÍË/¿<iÒ¤ŠÜõÓRò~LiiiÓ§OoӦͺuëä5jµZ:èÛ·¯···ô±Ü¼yÓÇǧG 6¼pá„ ÆŽ[‘ üñÇ‹/ !öîÝ{ðàAÿ';kÖ¬áÇK5Lž<yÁ‚÷ïß×þÁ¨4h0xðàÁƒ !®]»õÄ5}�� ¦!� Êœ‹;Wþ>Mºgbb²`Á‚±cÇ !nÞ¼yóæM!„ŸŸß©S§¤„ä}¯úõë7~üøµk× !rss£¢¢¤àIrûömé!}+V¬8p ´îlÛ¶mò3à„ÞÞÞŸ|ò‰t¬½–”a>|X»¶Y³fiïD^Ýúôécoo/-IÓh4'Nœf{U䮟.zã7¤kÿýïKRzRPP ÷\¾|ù!C¤Ú ä5tÒÆä©P;‘ÉÍÍ­È°¾¾¾|ðÁòåË¥ ¯_¿.„èѣǑ#G¤næææOq×:ãìì¬V«ÏŸ?¯ïr��@åé»���jš–FIúôéóûï¿Ë; YXXŒ1â×_•Ÿ=§e,Z´hË–-íÛ·755•ZÌÍÍÛ¶m;bÄ)ÒB8::ÆÄļýöÛÚ÷Û¸qã¥K—îܹÓÄĤİ …bÓ¦McÇŽ•ÇtqqÙ¼yóÛo¿]]÷\ ‹Õ«Wk?^PŽ™*r×OÁÛÛûûï¿oРô²nݺ_|ñÅŒ3¤—wîÜ‘{6oÞ<&&fâĉõë×— …ê=±Âé õòò ¬à°³fÍÚ¼yóˆ#ÜÜÜzöì9{öìU«VÉ=Ÿ—çÓ—XŸ��ž 6†� &8sæL¿~ý¼¼¼þúë¯jz‹»wïÞºu«uëÖrfT•JuåʵZݼysccãÇu»uëÖíÛ·›5kÖ¨Q£'ŽYPPpñâE{{{9 Ó‹«W¯Þ¾}»Q£F-Z´(qk¼ëJQ©TIIIFFF®®®FFOþ·Àôôô«W¯ZYY988ÈaVE*,..¾zõªö6öV¶wï^iy bãÆO,øÙõîÝ;>>þàÁƒ¥wjððð!C†¬Y³Fßµ�@À’=�� …R©”vwªccãÇEÚ*þÜ@sssí=Ñe±±±O¼¶Ì ŸŽ‹‹‹‹‹K™§*xוbllܪU«Š÷·³³+'°+§B“rŠ/sØÝ»w7lØ°{÷îÒËÄÄÄÙ³gKÇ–––íÚµ«xÙ���•B ��ô¬"Óp222tP‰¡Y¹råÉ“'ëÔ©Ó´iÓ¢¢¢ÔÔTy«õ3fÈ›²��T9)�� g„Mz‘““söìY!D~~¾ô„>Ù€t¼Ã��04R���†ÈÔÔtùòåáá቉‰ééé …ÂÑѱeË–ï¼óN—.]ô]��¨å¤��� ‘™™ÙÈ‘#GŽ©ïB��€!zò£^������€*D ������"�����€NH�����@§¤������ SR������Ð)}�����¨´;wîÄÅÅݽ{×ÓÓÓÃÃÃÄ„¿Üxžðÿ,����xž|ûí·¡¡¡iiir‹¹¹¹··÷²eËœõX�TKö����àù––ôÙgŸi§QBˆ‚‚‚ÈÈÈÞ½{ïÚµK_µ@¥H���Às@­V=úСCÒK{{ûQ£FMš4ÉÃÃCjyôèQHHÈéÓ§õW#�TKö����à9°nݺsçÎIÇ]»vݸqã /¼ ½üôÓOCCC…föìÙüñ‡Þª€Š!���€š.''gÁ‚Ò±……źuëä4J1oÞ¼ãÇKs£Nœ8ñçŸfee½ñÆR‡Aƒ½ùæ›Òñwß}·ÿ~éxóæÍÚ»¡‡……ýù矧OŸ¾wï^»vízôèñÁ˜™™Ig>|8~üxéxÓ¦M'Ož\¹rå‘#GöìÙ³}ûöS§NI§>þøãÎ;KÇ6lضm›t<uêÔ=zTíÇàùE ����5ݹsç233¥ã#F4jÔ¨D‡·ÞzkÒ¤IÒññãÇ åõ}ò²>!Dbb¢Ü®V«¥ƒÂÂÂ3füòË/r·èèèèèèƒþòË/ÖÖÖBùÂøøøààà!T*•»»ûW_}%rss“©­[·FEE !ÌÌÌÚ´iSŸ€Z‚=¤���� ¦»té’|üâ‹/–îЩS§2;WЗ_~)¥Q 4øàƒ¦N*…P'Ož\¸p¡ÔÇÔÔTî"¥Q’ÁƒËÙ_ý%<yR:ö÷÷¯_¿~e«P‹H���@M—˜˜(;99•îФI…B!§¤¤TjðÛ·o¯Y³F:þ÷¿ÿ=kÖ¬O>ùä›o¾‘Z6nÜx÷î]!„±±±|ÉõëוJå˜1cæÍ›ggggff6jÔ(ùÔùóç…§NÊËË“‡^©’�Ôz,Ù���€š®¸¸¸ÌcYaa¡F£‘Ž---+5øï¿ÿžŸŸ/„P*•fffÒ´& ###µZ]PPïçç'^BSSÓ;v¸»»Ë-ÁÁÁß}÷tü×_yzz9rDzieeÕ¿ÿJ• Ö#���€š®U«Vòñõë×Kw¸yó¦|ìèèX©Áå%~wïÞ8p`é×®]BÈ—¢_¿~Úi”¢E‹=zôB¨?ÿüsêÔ©r 5hÐ ssóJ• ÖcÉ����ÔtÚ”´Mx ÚmÛ¶-q¶¨¨¨œÁ=zTþ»Ks£´©† –î6nÜ8éàìÙ³iiiòR¬×P3¤���� ¦óôô¬[·nnn®b×®]×®]svv–ϪTªÕ«WKÇFFFÒvNuëÖ•;$$$ÈÇÙÙÙ%wuu•¬­­CCC…šÿ’ŽK'\e4hR©¼{÷®F£Y±b…´”]¯^½*}Ã�j;fH���@MW¯^½þóŸÒqqqñˆ#®^½*½ÌÏÏ7nœ¼‘yPPP“&M„¶¶¶Rcll¬´-zrròäa¥È©M›6ÒË{÷îeddøùùõîÝ»OŸ>þþþþþþvvvâgH•ÉÔÔTÞÚü矖†ndÄ_<”Äÿ����à9ðÎ;ï´nÝZ:¾|ùr×®]ûöíäîîþ×_Ií-[¶\²d‰|‰œ4åååùøøôëׯW¯^Ú3¤T*•"00ÐËËK~—.]º|ðÁ_|ñÅرc»uë¶nÝ:éÔ)!Dpp°´¾¯°°Pj3fÌ3Ü4€Z‹@ ����žÆÆÆ›6mòññ‘^ªTª³gÏ:tHZÇ'„:tèü¡ýˆ=yR•B­VŸ9s¦¸¸Øßß_n”ö–R(Ë—/—§S¥¦¦þúë¯ß|óÍŸþ™œœ|æÌ©½"T³fÍ´èuíÚU^�Ú¤����àùиqãmÛ¶}ùå—íÛ·766.qöÌ™3Ÿ~úé/¿ü"/ßëܹshhhýúõ¥—uëÖ>}úŠ+äKòóó¥ƒV­ZÅÄÄ„„„(•Jù¬½½}ïÞ½åiYäçç'¿ýöÛ•º€á`Ss����xžL˜0a„ ÙÙÙ'Nœ8zôèÖ­[¯]»&„¸råÊ•+W6mÚäíí½k×.©sPPÐ+¯¼’œœ\PPТE iþTFFFéaëÕ«·páÂ… fff^¿~ÝÉÉ©Ä£ôÌÍÍ˼P[NNÎÆ¥ã–-[4èÙï@­Ä )����xþXYYõîÝû“O>9uêÔ¶mÛ‚‚‚äÅz#FŒÐîillìîîÞ®];íÕ|åhØ°a»víJ¤Qqøðá&%%I/çÌ™#í'�¥1C ����žo>>>>>>ùùùؽ{÷+¯¼¢ûæÎûÝwßÉ/ƒ‚‚u_€ç����ÔuêÔ8pàÀõòîíÚµ“ûöí«½S�”Æ’=����À³êÑ£‡ÂÞÞ~åÊ•6l033ÓwE�j4fH����ž•½½}LLŒ«««¾ ð|`†����  F¨8fH�Pƒ\ºtéå—_Öw€N¥¦¦ê»�� kR��Ô ÙÙÙ111ú®Âàh4Ð!ŒL��Ð)��j77·ððp}Wa T*Õ+C_Q(á;ù ô¦yóæú.��è��5‚¥¥e·nÝô]…R©TB…BÁW��� ÌK����üGaaa^^žZ­Öw!�j9)����087oÞÜ·oßÏ?ÿüÇœ={Vš+*„9r¤³³ó¶mÛô[€Z%{����`(rrræÍ›·uëÖ‡j·+•ÊÓ§O[XXè«0�††@ ���� Âþýû§M›vóæM;;»þýû{xx4iÒäÞ½{ wîÜ! KR����PûÅÅÅ3¦¸¸888ø³Ï>{á…ô]�ƒF ����µœJ¥úðË‹‹§L™2gÎ}—�R����PÛýôÓOqqqŽŽŽÓ§O¯ìµ'NœØ¼ysrrò;w\]];uê4yòd333í>ÙÙÙ+W®Œ‰‰ÉÈÈptt 7nœ±±±töÈ‘#k×®MJJ²°°ðôô|ë­·ZµjU57à¹E ����µ\TT”â7Þ¨ìFQqqq¬_¿¾›››­­mttôž={vïÞfee%õÉÊÊò÷÷OMMµµµmÕªUBBBbbâøñ㥳?þøãÇlddÔ©S§‚‚‚M›6yyyH ���€ZîÂ… Bww÷Ê^Ø®]»U«V <ØÔÔT‘““3räÈãǯ_¿~òäÉRŸÐÐÐÔÔÔ!C†¬^½Z¡P!RRR¤SŸ}ö™B¡8xð`ëÖ­…ééé–––Uu_�ž_Fú.�����Prss¯\¹"„hÙ²åS\>lØ0)BXZZ¾ÿþûBˆððp¹Crr²¢S§NR%„hÑ¢…tpãÆüüü Èomgg'O­`Ȥ���� 6S©TæÉËËKHHˆŒŒ”&[ݼyS>5pà@!Dhhhttt‰«Z´háîîž™™9gÎœ¬¬¬g¬@mB ����µÙ /¼ààà þ;•©²?øàƒÖ­[ûúú>üÿþïÿ„¹¹¹r‡—^z©[·n·nÝ2dȈ#J¼Ë¬Y³ÌÍÍ׬YÓ±cÇU«V©Tªg»�µ����ÔrBˆ„„„Ê^ûÒK/mØ°!((hãƧNúûï¿Kô111 [²d‰‹‹KDD„ϲeËä³ 8pà@PPPVVÖìÙ³ýýý/_¾üŒ·  ���€ZÎËËK±zõêÊ®››:uêÇÿõ¯-]º4 ÀÙÙ¹Q£F¥»™˜˜¼ñÆ111ÿ÷ÿ§Ñh/^|çÎù¬››[hhhDDD—.]Ο?¿jÕªg¼�µ�����Ôrï¾ûn“&M222>ÿüóŠ_õèÑ£øøx…B1lØ0¹ñþýûëojjúöÛoªTª;w–8ëáá±téR!ÄŽ;*Y>€Zˆ@ ����j9KKK) úù矇®½%¹$;;»ôU …B­Vk4šÓ§OK-fîܹBˆââb¹[QQ‘öU>BXXXHýµ7’N™››WÅ=x¾™è»�����@µ øæ›oæÎÙ¹sg77·V­ZÙÛÛß½{÷Â… YYYÇ/qÉ /¼àïï¿ÿþéÓ§7.???<<<??ßÔÔ4''G¥R !FmaaÑ­[7KKËDEEÙÙÙ !Ž;6iÒ¤¡C‡º»»'%%mß¾]¬ûÛPÓH���€A5jT¿~ýæÏŸ‘pþüy©Ý¢wïÞEEE¦¦¦%.Y¾|ùäÉ“£¢¢æÌ™S§N??¿o¾ù¦ÿþ—/_ÎÊÊjРÂÚÚ:<<|Ïž=Ò%ÞÞÞ_~ù¥R©Bš™™­\¹R:eee5cÆŒiÓ¦éè†Ô` F£ï���ôI¥RÙÙÛÝI¿óäÞ�Pyááá!!!C† Y³f¾kùÜÜܤ¤$!„­­­‰Iy“ÒÓÓÓÒÒ<<<ÌÌÌ7Úµk×rss]\\¬­­KœMKK»qãFÆ Kg^� 3¤����ÀàÔ­[·}ûöìlgggggWþh­ZµzÜY{{{{{ûÊÕ ¶cSs������è������tŠ@ ������:E ������"�����€NH�����@§¤������ SR������Ð))������è���� Úi4š¼¼¼‚‚}¢ :»Ù‚‚‚¼¼<FóŒãÔ·ƒ‚@ ����Píbbbœ{öì©ïBtAg7Û·o_gg烖yöܹs«V­ºsçÎÇ1¨o5�����µÐ‚ ¾þúëFé»  R����€g•’’’žž®ï*ô£fÞûíÛ·80räH}×”@ ����ðLBBB¼½½ãââô]ˆÔØ{ß¼y³Z­=z´¾ ÊF ����x&5p~ÎÔØ{ß°aC§NÜÝÝõ]P6fî���@í—½råʘ˜˜ŒŒ GGÇÀÀÀqãÆËâââ6oÞŸ••åéééëë;|øpí–,YróæÍ%K–\¹rå—_~9xð`ddäöíÛ:tùòe!Ä?ü°{÷n!ÄøñãÛµkWN1ÑÑÑþùç±cÇêÖ­Û¹sçwÞy§AƒBˆôôô/¿üRñ駟Z[[k_²zõêóçÏ÷ë×oàÀBˆââ⇖èSZllìO?ýÔ·oßÀÀÀíÛ·ïß¿?999 `ôèÑNNNBˆ°°°7Þ¼y³yóæÓ¦Mëرc‰233׬YsêÔ©k×®uèÐÁÇÇgÔ¨QÒ©°°°ŠÜ{tttxxøÑ£GmmmCBBú÷ï_â-ŠŠŠ~úé§'N$&&ÚÛÛ·mÛöÍ7ßttt,};¿ÿþûüqþüyWW×îÝ»7®œO855uÊ”)%ÚwïÞ}èС„„„û÷ï7iÒÄÇÇçwÞ12*cªJVVÖÆ£££¯^½jffÖ¶mÛ‘#GvéÒE»Où?TGŽY»vmRR’………§§ç[o½ÕªU«Ç C¤��0lÅÅÅÖJk[} ÖÚ¹s§R© ÑW=êܹ³R©lݺõ°aÃ<==Ûµk§ÝaÁ‚öööJ¥²k×®½{÷¶±±Q*•#GŽ¼wïžÜ§oß¾J¥òÒ¥KJ¥R©TªTªY³fÙÚÚJ/mlllmmmmmwïÞ]º†#GŽ(•Ê_|ñ·ß~³³³srr’JR*•^^^.\ºuïÞ]©TþðÃÚ×4kÖL©Tž9sF£Ñ¿øâ‹öööûöí+ÿÆ÷ìÙ£T*gÎœùÎ;ï(•Ê–-[JÕvéÒ%;;{Á‚J¥²yóæJ¥ÒÖÖöðáÃÚ—Ÿ={¶cÇŽöööcÇŽuwwW*•ï½÷žJ¥Òh4åÜ»|³7n´µµuvvnܸ±Ôó›o¾Ñ~‹„„„^½z)•J—ººº*•ÊfÍšmݺU»[aaá”)S¤Ú´iÓ¥K›Ñ£GwéÒE©Tîß¿¿Ä¿ûî»...ÙÙÙrKZZÚk¯½&вeKooo''§®]»–øväþ¯¿þº··÷È‘#»wïncccoo¿e˹Cù?TkÖ¬‘>ÒôéÓ§qãÆëׯ/ÿË‚¡!��†Ž@ @uÓ{ µxñb©�µZ-µ$''ËgýõW)戗ZnݺճgO¥R9qâD¹Û Aƒ”Jeß¾}ýýý<xåÊùÔK/½¤T*÷îÝ[N RäѤI‡õë×KYÉõë×ýýý•Je@@€Ôíûï¿W*•þþþÚ×J¹R¯^½¤—ׯ_—‚•Å‹—ãP*•M›6m×®ÝþýûÕjuzzzïÞ½•J¥¯¯¯££cxxxQQQ^^Þ[o½¥T*½½½åksssÛ´iÓ´iÓ˜˜¹eÈ!J¥R;[)óÞ¥›upppuu ËÍÍÍËË[¸p¡ô È]~~~×®]¥È¬¨¨H£Ñ¨ÕêU«V)•J{{û„„yÀ•+WJÑÏñãÇ¥–¸¸8OOOés(Heee9;;O™2EnQ«ÕJ¥²ÿþ‰‰‰RcQQÑ¥K—´ Ö¤N:•””$¿Üµk—R©lÕªU^^žÔRÎU~~¾£££Íùó祖´´´¬¬¬ò¿,ö���€Z.99YÑ©S'…B!µ´hÑB:xøðáܹs…«W¯öôô”7n¼iÓ&“íÛ·=zTj433Bœ?~ݺu~~~...OQIAAÁÛo¿=fÌKKK!„££ãæÍ›ëÖ­{öìÙ={ö!Fenn{éÒ%ùª;v!äý¹gÍšôú믗ÿvæææBˆìììeË–õéÓG¡PØÚÚN˜0Aº‘™3g<ØÄĤN:‹-ªS§NrrrZZštmhhhZZÚèÑ£½½½¥ ‹…  !Ö®][‘›-,,\´hÑСC-,,êÔ©3cÆ ¥RYPP ¤+V¬HIIéÕ«×üùó¥gá)Š·Þz+88¸¸¸xÖ¬YR·û÷ï/]ºTñÃ?tîÜYjlÛ¶í_|Qæûnß¾=77WûÃY»víÉ“'[´h±k×.777©ÑÄĤeË–+ÞËËËÕÕU~9hРöíÛß½{7&&Fj)ç‡êÆùùù 4Ç·³³³²²ªÈ‡ÃA ����µœ´ïRhhhttt‰S§OŸ~ð১§»Hš4iÒ¯_?!DTT”Ô"í ôÚk¯988<u%}ô‘v‹µµõ+¯¼"„8~ü¸¢Aƒƒ BlÙ²E꟟ÿ×_™ššŽ1B¾êƒ> ­`%öööþþþòK___é`À€rcƒ ¤ý¿¥œE!í Uâ)u­Zµª_¿þ¹sç žø¾õë×6l˜vK·nÝ„/^”^8p@!dÚÆ/„8zôhqq±âäÉ“ÙÙÙžžž=zôÐî6lØ0{{ûÒï»aÃWW×®]»Ê-R¢7mÚ4SSÓ'–]ÂÍ›7Oœ8ñÇh4é¥Ô^ÎU‹-ÜÝÝ333çÌ™“••UÙw„ ���€Z^êÖ­Û­[·† 2bÄ9sÿ GZ·n]úª6mÚ­ôDÊ#Joû])¶¶¶uêÔ)Ñ(íu’’"½ BüöÛoÒ;þý÷ßÙÙÙýû÷âæ£T*µ_6iÒDšíUbÎŽÐzjžTÏÀ]þ×£G„òDªr4lØ°D‹ô‘Êoñ¸¿U«VÆÆÆEEER Ò÷UæŽàÒfðÚ.]ºtòäÉ9ZBB‚¨äw§ÑhÖ®]ëïïß¡C‡Ž7...N‘››+u(ç‡J1kÖ,ssó5kÖtìØqÕªU*•ªâo A ����µœ‰‰IXXØ’%K\\\"""|||–-[&ÊÈÈBÔ­[·@0¶ �� �IDATôURj#MÒÿ ¤¤Æ§&/ïÒ&-¬“uïÞÝÕÕõÖ­[‡BìܹS”š©T¤‡ÍI·™›››­P(Æ7nܸààà±cÇŽ;v̘1&L˜0aB£Fžâ-¤uy’¼¼¼ììlQÖ‡oll,Me’>ü;wî!^xá…Ò–þ<7lØ`bbòꫯj¿‘¢•9B™4Í”)Sf̘‘““³dÉ’ƒž;wnèС%îåq?TBˆ8p (((++köìÙþþþÒã™É“»�����žs&&&o¼ñÆ믿¾víÚÏ>ûlñâÅcÆŒ±µµ•vJMM-}‰” H“zÄ“šgTTTTºñêÕ«BiÅœ$88xÎœ9[·níÒ¥ËÞ½{K¬¹ÓºuëÚÙÙ¥§§Oœ8ÑÉÉ©:ÞÂÂÂÂÉÉéúõë©©©¶¶¶Ú§nÞ¼™ŸŸojj*};Í›7Bܸq£ô ò|%Iqqñ–-[´´°°ppp¸uëÖ¥K—ììì*RÛÞ½{7oÞìêêºÿ~9/+‘ŠÇÿPIgÝÜÜBCCßÿýþóŸÇ_µjÕ¢E‹*òî0Ì����CajjúöÛoªT*iæ‘´‘ùñãÇåud’œœœ½{÷ ­@ªüa…Ù-èöíÛ±±±Ú-jµZÚÎ\{åÚ«¯¾jff¶gÏžýû÷çææ¾úê«Òô%]òððÿÝæ©¿÷Ҥ׮]%Ú·oß.„pww——¢ºèèè{÷îiw;uêÔµk×´[öíÛ—‘‘1f̘J_⯿þZÁ¤m¡úõë§={ëþýûev.ýC¥ÍÃÃCÚ‘]ÚÇ H���@-Wb^ÒÇ…Bˆ¶mÛöïß???æ̙ګó>ûì³»wïvèÐAÚÚ\”;CJÚZûôéÓåÔ ]®V«ß{ï=íÁ-Z”ššÚ²eËÁƒË54hPffæ¼yó Eé„å‡~øè£îÞ½ûä›Z~ø¡âóÏ?/§[Eîýq¦M›fddôóÏ?Ÿ<yRn¼xñâŠ+„3fÌZºvíÚ©S§ÜÜÜ3fÈ_eAAÁÔ©SåOUjüõ×_íììJ¼ÑÔ©SŒŒ¶mÛVÁçJÃjßTddä¾}û„ÖÎr~¨4ö¦QÒ©Ò¬`àX²����µÜèÑ£-,,ºuëfiiyàÀ¨¨(;;»ÀÀ@éì¢E‹bccÃÃÃoܸñÊ+¯˜ššþþûïGŽ©W¯^hh¨ôp=Qn Õ«W¯­[·®^½úÖ­[Mš4™:ujéý¼¥ ãå—_¾páBëÖ­_zé%GGǨ¨¨£Gš››/]ºT{%!DpppXXXrr²¯¯oÓ¦MµO]½zuÖ¬YB''§)S¦<ë§óÝ»wŸ8qâêÕ« Ô¦M##£;wî=zô‹/¾èÞ½{Åïýq:tèðþûïõÕWC‡;vl»ví.\¸°~ýú¬¬¬qãÆÉ_bÁ‚C‡ݹsgbbbŸ>}233wïÞÝ´iÓ   mÛ¶IéÏ;wöïß?yòdù+“uêÔiÊ”)Ë—/Ÿ1cƦM›ºuëV¯^½«W¯Þ¿ÿ—_~)]ØË/¿zôèÑ÷Þ{¯[·n‡úóÏ?ÝÝÝ/^¼(mG%Êý¡:vìؤI“†êîîž””$Mø’öªdR����PËY[[‡‡‡K+ã„ÞÞÞ_~ù¥üì¹&MšDEEÍœ9s×®]Ò¤SSÓáÇþùçÚ[•H9rïÞ½»wï–VŸ3¦t(“““#„pss[°`Áĉûí7)¢êرãŠ+J?B®G 6ÌÌÌ )qÊÖÖÖÚÚ:33S{Û©ê°`Á‚îݻϟ??<<\^Œæáá¡=ý§"÷^Ž™3gzyy}ú駫W¯–Zœœœ–-[öÊ+¯hwóòòÚ·oß;ï¼{ñâE++«^½z-[¶ìÛo¿ÿýl·lÙR\\üú믗ùF³gÏîÒ¥ËܹsÏž={æÌ!„B¡cµ^|ñů¾újöìÙ7nܸq£“““´ìnÒ¤Ir UÎUaa¡™™ÙÊ•+¥SVVV3f̘6mZÅ?E•ìK��ðüR©TvövFFFwÒïè»�µSxxxHHÈ!CÖ¬Y£¯rss¯]»–››ëââbmm]f•J•””¤ÑhZ¶lYb¾REܺuëöíÛM›6}Üø%ê¹téRÓ¦M4hPf‡cÇŽ 4ÈÍÍíÈ‘#¥Ïæäädff:::V¶È§““““’’biiÙ¸qã2ŸHX©{/SffæåË—mllÊéöàÁƒk×®µnݺôP¯^½°°°òß('''11ÑÒÒÒÑÑÑÒÒ²œžEEE‰‰‰5rpp(³Cù?Tiii7nÜhØ°¡³³³´ @ ��:)�Õ­&RÏ—œœœ\¸páÇ|ùå—õ]€ªÇ¦æ����€äêÕ«£FºpáB@@�iP[H����jŠ7vïÞýèÑ£îîîßÿ½¾ËP]ØÔ��¢iÓ¦mÞ²Y»E­V;:ýÿ½HzõêµqÃF×�†®N:ÅÅÅÁÁÁŸþ¹•••¾ËP]¤��€!òîæýóºŸK4æççËÇ]»tÕmE��!„èß¿\\œ¾ P½¤��€!òéåS~_?_ÝT�ÐV·nÝ2c –a)��`ˆììì<<<w¶AƒíÛµ×e=���…@ ��(??¿ÇêÕ«—‘¿&��T~Ó��Ê×籋òÊɪ���ðì¤��€êÖ­›©©i™§Êɪ���ðì¤��€²´´ìܹsév—¦M›ê¼���B �� —Ÿ¯_éF__¦G��T/)��`¸ÊÌžÊL©���P…¤��€áêСC½zõ´[ E¯^½ôU��€ ��†ËØظgÏžÚ-íÛµoØ°¡¾ê��0R��À ùùùi¿ôõc)��€jG �� Z‰£ØÑ��@¤��€AkÞ¼¹£££t\§N®]ºê·���C@ �� ¼jÏÛÛÛÜÜ\¯µ���)��`è|}þ³L¯Ä~R���¨&R��ÀÐùøøHr2��€jE �� µµuÛ¶m­­­Û´i£ïZ��� ‚‰¾ ���Ð??_¿›·n* }��`¤���„ŸŸß7ô]��€¡ � Š]ºtIß% Ò5jdbbÂw÷ÜQ(-[¶Ôw�� Ò¤��¨JjµºGú®0ÆÆÆiiiú®��T��ÕÂÝÝ]ß%�µ™F£aF��Ï/)��ªž±±ñáÇõ]P›©Õj;;;}W��ž’‘¾ ������€a!�����€NH�����@§¤������ SR������Ð))������è������tŠ@ ������:E ������"�����€N™è»���ð4nܸqüøñ¤¤¤”””»wïfggçååi4}×¥P(êÖ­kiiiccÓ¢E WWWooo}×��j(¿¹�P…Ôjµ±±qZZZuŒûÛo¿ýõ×_W®\©Žñ*Ô¼yóþýû9²M›6U>xuÿ·†'  Ñw¨222ô]€jÇ )��žfçÎË—/—Z4hЭ[7OOOWWW;;;+++ ý —›››“““–––œœ|þüù˜˜˜Ë—/ÿý÷ßÿ}ûöíßÿýAƒ) }— ��j)��jºC‡}üñÇIIIB›      öíÛów{ÔdæôéÓÛ¶m ‹?~¼‡‡ÇÂ… »wï®ïÒP•† ²fÍ}WÚÃÆÆFß%�Ð65� æÊÊÊš4iRPPPRRR³f;úê«ØØØyóæuèÐ4 5œB¡èÔ©Ó‚ âââ–.]êìì|áÂ…!C†üãÿÈÉÉÑwu��@Ϥ��¨¡bcc{÷î½mÛ6KKË9sæDGG3ÆÔÔTßu•cff6nܸ£GÎœ9ÓÂÂbóæÍ}úô‘Ÿ��ÃD �@M´wïÞÁƒ_½zµcÇŽ‡š2eŠ‰ íñ355ýðÃ###ÛµkwùòåAƒ8p@ßEOöàÁƒ ÿ•——WâlJJŠtŠM�@eH�PãlÛ¶-888///88x÷îÝÎÎÎú®Hw4M^^^AAAu¿QAAA^^Þóõ¸á¼¼<µZ]—<ÅàO¡Y³f{öìyíµ×rrrÆŒ^­o<»íÛ·ûü×¹sçJœ5j”tjÒ¤Iz)�ž_R��Ô,ÿý÷?þñ•JõÑGýë_ÿÒï½»wïJÿøŸŸŸÿ¸>©©©.\HNN®’wŒ‰‰qvvîÙ³g•ŒVŽ¾}û:;;<x°ºßè©ÿþûï rËÈ‘#·mÛVñA*~ÉS þtÌÌÌV¬XñþûïMž<922²ºß��Ô@R��Ô !!!ÅÅÅS§N>}º¾Ë¡¡¡Ò?þÿúë¯evÈÎÎöõõõññéß¿¿Žk«õ6lØðæ›o8077WßµT½Ù³g¿ûî»………o¼ñ†ôI��`P¤��¨)rrrBBBrss_{íµO>ùDßå!Dff¦B¡P<nâLxxx^^žB¡ÈÊÊzŠåoùùù§NzÖ*k)[[[…Bamm]§N}×R->ûì³   ìììr¦à�€Z‰@ �€šbîܹÉÉÉžžžK–,Ñw-ÿñðáC!„··÷‰'®]»VºÃ–-[6lèéé©Ñh²²²*5ø™3gÜÝÝ?þø㪩µÖ <}úttt´‘Q­ý…mÙ²ennn.\˜7ož¾kªLNNÎ’%Kš7oîæææïï?þ|íÔ5==}îܹƒvqqéҥˤI“Ž;¦=Â?ü´~ýúâââyóæuîÜyâĉ:¿�¨Fµö÷��ž/gÎœY¿~½™™ÙêÕ«ÍÍÍõ]ÎH3¤^~ùe!DéIRׯ_ŽŽ8p ¥¥¥øozUqYYYµr1Zrtt¬9? Õ¡nݺ?üðƒ‰‰É?þ¯ïr€*ððáÃ>}ú,^¼8666+++333..~’ÿ[>v옿¿ÿwß}wôèÑÜÜÜÔÔÔmÛ¶ :tÆ ò 7oÞ<tèСC‡âââæÍ›·bÅŠ+W®èài� K<@�€aÖ¬YjµúwÞiÙ²¥¾kùÿ<x „x饗fÏž½mÛ¶?üPûì–-[4ÍË/¿¼råJ!ÄÇœœ´;ìÛ·oÏž=§OŸ®W¯ž··÷«¯¾Ú¢E !D^^Þ'Ÿ|rûöm!Äõë×?øà!„ƒƒÃG}¤}ytttxxøÑ£GmmmCBBÊܦ*..nóæÍñññYYYžžž¾¾¾Ã‡/Ýí÷ßÿã?Ο?ïêêÚ½{÷qãÆ•y¿GŽY»vmRR’………§§ç[o½ÕªU«2{ž8qbóæÍÉÉÉwîÜquuíÔ©ÓäÉ“ÍÌÌ„aaa‡jß¾ý›o¾©}IqqñŒ3T*ÕŒ37nœ••µqãÆèèè«W¯š™™µmÛväÈ‘]ºt‘û§¤¤|óÍ7ÖÖÖŸ~úi™5”_F ÒÛ=z4%%¥M›6C† éׯß㆕eff®Y³æÔ©S×®]ëСƒÏ¨Q£žxU¥HŸówß}7{öì;vTíà€îÍŸ?ÿòåËBSSÓ—^z©N:qqqÎÎÎ …Bq÷îÝQ£Fegg !z÷îíëë{äÈ‘}ûöMŸ>ÝÏÏÏÁÁAºVíï¿ÿ¾yó¦þî�ª3¤��п¨¨¨'N(•Ê©S§ê»–ÿ‘™™©P(7nÜ©S§ÄÄÄóçÏkŸýí·ß4hàãã#mrôèÑ£ÿÇÞÇÕœþÿãžö:¡å¨”E¥Rve«)²'Û˜DÈ:ƸÙÆ:¶k&o{†adH˜P„R¤©ÈZ(M%ÒíËé|ÿ¸~s~çÓæ´pÎŒÇýÏíœëu½®ëù:M}Þç麞—ðŸÏ_¿~½««kHHHçÎKKK÷îÝ;jÔ¨ØØX"ª¬¬ôõõe'ܽ{÷Î×××××÷Úµk¢ƒŸ={ÖÅÅÅ××÷ï¿ÿ¾uë–››K{‰Ú¾}»““Ó¯¿þš““CD~~~ .üúë¯óóó…}ªªª¾ÿþûY³f?>??ÿÙ³gkÖ¬qww¯»Öà·ß~?~ü•+WTUU«««Ïž=ûàÁƒz?–¸¸¸Q£F]ºt©²²RKK+**êçŸ3f û’Ù¾}ûÓ§OoÛ¶­ªªJô®Û·oûøøDGGwèЈ.\¸~ýúÄÄD--­ââbggçóçÏ ûçääœ>}:  ¡ŸNãaˆzÿþý¤I“Ö­[—––vîܹiÓ¦mܸ±¡‘™ØØX//¯÷ï߇……-^¼xÉ’%555ßØT?üðƒššZddd­]K�ÿF‘‘‘ìÅ AƒŽ=ºÿþððpoooÖ¸{÷nö:pàÀsçÎ-Z´èÌ™3={ö$¢ÊÊJa7YYYö"==] ØÚÚ®]»vÊ”)Ÿûa��>%$¤���$oß¾}D´`ÁeeeIÇò°íxl5讽¤¤¤Œ5JNNŽõMH;vìÈ‘#ãÇôèщ'nÞ¼éããóáÇ™3gÖÔÔ´k×.''çÂ… Ddmm“““““ÃòSLffæ?þèííýâÅ‹—/_®X±‚ˆvìØñúõkaŸ3gÎxyyñx¼Û·oß½{7,,,66ÖÔÔ4,,L´.Õ¯¿þêëë«¥¥ôôéÓ{÷î…††ÆÆƲ% B›6mâp8·nÝ }üøñøñãëýXzôèqäÈ‘„„„   K—.ÅÆÆöë×mº$¢Áƒëë놆†ŠÞåïïODÓ¦Mco—-[íççÇVfUWWoØ°AüòÞ‡!jË–-ªªªaaa<HNNÞ±c‡¬¬ì¡C‡‚ƒƒ¼¬¬ÌÍÍ­  àâŋ׮]óññyüøñÀÏœ9#º±¨Up¹ÜyóæÑþýû[wd€ÏO¸5ïÎ;«V­JII!"öG’DþŠöîÝûÁ?ŒY£0 ΖS1'N¼|ùòÒ¥KÇŒóy�àó@B ��@²²²îܹ£¤¤4{ölIÇòðùüââbUUU"6lý“RaüüüèŸòR¬°†TQQ‘———œœÜöíÛ…OœœœFŽ™žžÞHD¨²²rçÎ...ÊÊÊJJJ«V­âñxwïÞeÞ¿Ïø=zÔÜÜœ5vèÐáìÙ³rrr/^d=óóówïÞMD¿þúkß¾}Y7KKË-[¶Ôš1==½¼¼\MMM¸eR[[›=W½&L˜ |4.—»dÉ"®fúæ›oèÿæïÊË˯]»&'''ÜòÖ«W/á·P"3fŒ••ÕÛ·o£££?úùˆ†¼¼ü¡C‡,--‰HVVÖÃÃcÁ‚D´}ûö†FöööÎÎÎvuu0`�kQVVÞ±c?~\üÅ4gÎ…›7oæååµúà�-Áãñ„¯ë–½+++«ÕíÛo¿e/ø|þñãÇmllÜÜÜض»¼¼<¶šˆöíÛ7òÂ¥‘³#D-ýþûï[÷‰��¤R���váÂ…ššš‘#G¶iÓFÒ±üì‹KÊtïÞ½S§NlÏ@  ÒÔÔ:t(ýóÿ„Tttt~~þðáÃE¿ÈKm4´NT»ví&L˜ ÚbccCD/^¼`o=zTXXhnn.L—0zzzl1WDD›«¸¸ØÜÜ|àÀ¢Ý&L˜ ££#ÚbdddbbRPP°aÃñ ,++‹OHH "a©—¯¿þšÃáܸq£¤¤„µ„„„6LKK«Ö ÷ïß b_A›Q/¦¡0„,X ­­-ÚÂŽëzþüyCuå¯^½JD®®®¢¦¦¦íÚµ{úôi«WVWWwttäóù¢IO�i``` |Í*ß ñù|a µK—.ìŤI“<¨©©ÉÞ ‚7n ><??_ti½„ £DRêêê-{��)…¢æ���Æ6v5´;L‚XBJ˜&?~üÞ½{ƒƒƒ­¬¬bbbrss=<<äää„}„ )¶E%$$¤S§N¢VWWSotõªûÌÂÂ"00ÕŠ¢2SÝ»w¯{¯……EPP뜜LDõ&WSSËÎÎmY·nÝܹs;vþüù•+WΙ3GXÆ¥®ÄÄÄÇ_¾|Y´`“0¹c``0pàÀ¿þúëÚµk¬È:˳LŸ>]ØY œ8qâôéÓqqq¢#7éäÁÆêõƒ "===UUÕâââ—/_ZXXÔ™ýGU«­ÉÎή;f ?žm–œ?~ëŽ Ð†††Âס¡¡lý#.,©Ö¹sgaû”)SœÏ;wèÐ!öW(77×ÇÇç»ï¾“——gÕå.\øÕW_ –{b/TTT>Ë3�H$¤���$©¼¼üÁƒ222ƒ ’t,µQ»víØ[–ºqãÆÊ•+ƒ‚‚ˆè믿f—Ø**á?þ³´‘µµuŸ>}èŸ/ZÂ/]¬±©XæKˆ­J¨÷Ë;cŽ%¿rssI$§&J´D 3räÈ°°0//¯‹/®_¿Þ××÷øñãÂU¢bcc'NœøáÇ3fŒ1¢[·nŽŽŽ¢}¦M›ö×_ýù矓&M*..¾y󦮮®ƒƒ»*/^ìççgddäééÙ§O·aÆ‹/Šý‘ˆFCKDŠŠŠuËŸ3¥¥¥ÅÅŇGXë;³@ ÐÐÐ?N1 2„ÃáÜ»w¯ªªJ¸@âÚµkgmmýäÉ"ºråÊ7؉Ÿyyy?ÿü3ë#//oggÇ^———+)))**NŸ>}Ò¤I¦¦¦,GüæÍ999“gÏžQTTÔŠ+Ú¶m[濫+¤��þ«��$¶û©G }-‘ Z ) cc㸸¸œœœ«W¯³“¡¨Î )–Ä122ª[ª©µtëÖˆRSSë^bÕÊÙªIzzzÝnõ.DêÖ­›··÷’%KV¬XsäÈ‘;wÖí¶lÙ²÷ïß{yy W<ÕÍøŒ=ºM›6áááEEE7nÜ(//wuu•‘ùÿª%ûùù‡†† ÓjÂZÈb' ¦ÖyDTRRòîÝ;aÍ,Q***ÚÚÚ999sçÎÕ××oRTͦ©©Ù­[·ÄÄÄøøx++«Ï3)€86mÚıòùü3fXXX¨©©=~üX¸½wÞ¼yÂR3f̨©©4hÁÓ§O…jÌÌ̈hÍš5ìdƒØØXKKËÞ½{÷êÕëíÛ·IIIùùùÂrHHÀ—�5¤���$‰íæ`éiöì RD4aÂ@àååõúõëÉ“' Ûk5gß»"##¯4ÄVÁˆ_°I+d#ÜÄÇ”””°¢é,!ebbBDQQQïÞ½íöðáCañàºÌÌÌX)ôK—.Õ½úáÇgÏžq8Ñ*Wùùùµº)++»¸¸TUU…„„p8ÑzLQQQD4|øpÑE^ui„˜a0×®]«ÕHD]ºti( Æ~ˆaaaâ‡Ôrls%Û- =èááÁ^×ÔÔÄÅÅݹsGø·kÀ€ì$P"ª®®Ž‰‰ ߺuëüùó8ÀÚŒŒØ’ÒáÇ ϯ(--ˆˆØ»wïéÓ§cbb’““…;š‘€/R���’Ė󈞶&=XBJté[#pâÄ ‡#šªµBªoß¾ƒ zóæÍš5kê®ÍbeÅ_¾|)¼Q|–––NNNåååk×®e»óˆH lÚ´éíÛ·ÖÖÖ¬´yÿþý{÷î]ZZºjÕ*a$Ë–-cß÷„õ_ŸÏŽÏBª7YÃápjjjÁ£G„÷²#ÿ„‘0¬Ö̹sçnݺegg'ºÔˆÍ.ˆÂÃÃCBBêÒ1Ã`]¿~]ôÈ¿ÔÔT¶òkÙ²e ¿téR"Ú¼y3Û^ôyR •vìØáëëkbb",-Çáp:uêäéé(<‘³¸¸ØÎÎŽmfäää¾ùæ›?ÿüS¸wxçÎçγ²²nMUTT´´´œ<yreeåg|&�� Ö=���IbÛâÚ·o/é@êQw…T×®]ÍÍÍŸ?ncc#š^a_´Dòôô7nÜ©S§"##œœtuu _¾|Y^^îããÃútêÔéõë×C‡?~¼™™™°(•8vîÜžž>~üxyyù+W®DFF¶mÛÖÛÛ[ø¥qÛ¶m...—/_NLLüꫯ ®^½jhh8qâÄ?ÿüS˜„ºwïÞ‚ \\\LLL’’’X-§3fÔ·M›6¡¡¡+W®tww///(//———/)u*�� �IDAT)áóù©ûôéÓµkWV´ÞÍÍMtqãÆy{{ß½{÷ûï¿·±±¹sçÎõë×MLL^¼xñÑs¸šKN-_¾|Á‚ÞÞÞNNNW®\),,tppÍ*Öbkk;wîÜ£G:::Ž3ÆÂÂBFF&77÷îÝ»[¶l±µµ'ȦbÇ2²ÿð�¤£££££ceeeJJ ŸÏ722RVV®ÕGMMí÷߯¨¨ÈÌÌÌËËãñxúúúuk¢ÙÛÛÛÛÛóùüW¯^ÕÔÔtéÒ¥Ö ?þøã?þøiŸ�@Ò��$VUZø¯ëR¥V )fêÔ©`5P„jmÙ#"ccã¿þúkݺuׯ_?|ø0kär¹¢§¶ÉÊÊîÞ½{þüù7n\“Rzzzk×® d«„äåå'Mš´yóf---a·^½z…„„|ûí·±±±/^¼PUU<x°——×Áƒ‰¨¤¤„u«¬¬TPPî¯QUU]µjÕòåËëzïÞ½ .ŒˆˆØ°aƒ’’’Ýþýûœœ^¾|YTT¤¦¦&ìéêêºyóf7räHÑúôé³gÏV:Ý××W__Ÿm\°`˜ )1Ã`øÃ?hhhìÝ»—-Œâr¹«W¯fk ±mÛ6[[Û­[·\¾|™5š™™‰.%k]ì?¤†J­H¶¡µŠŠŠ;w=w¯^²²²lU �À—‰ƒýÉ���­¨¦¦F[[[VV6;;[œþ³fͺråÊï¿ÿ>zôèO›¤¤¥¥êèè´oß¾nÕíòòòÄÄD•Î;×:JOL|>?))I tíÚµ‘ ÓÒÒºwïÞHŸìììôôtuuuƒô–“““mff&º=§Iªªª544tuu›7BSÃxõêUEEE·nÝ*^¯’’’””.—Û¡C‡Oz,½¿¿ÿüùó'NœèííýÑÎMý]ƒVàáááìì|ìØ1IÇÿlÉ0;J�þÛ°B ���>-ƒ†®*))µðH5YYYV »qjjj¢k—ꥣ£Ã*[‰C[[[[[[ÌÎõ’——gÅ×[¢Ia6c .—Û£GfÜØ<øçR��€/Šš�������Àg…„��������|VHH�������Àg…„��������|VHH�������Àg…„��������|VHH�������Àg…„��������|VHH�������Àg…„���H—ÊÊʲ²²ššI����Ÿ R��� !!!'Ož zòä ŸÏgíS¦L100øóÏ?%����|:r’����¾,%%%?ýôÓ… Þ¿/ÚÎãñ=z¤¬¬,©À����à³AB ���“’’¢ªªª­­Ý*£…††._¾<##C[[ÛÉÉÉÌÌLOOïÝ»wñññ¹¹¹ÈF���|!��€yxxœ9sfØ°a--..ÎÍÍ­ººzÆŒ›6mjÓ¦MËÇ�øOzûömHHȽ{÷âããß¼ySTTT]]Íår;tè`llÜ»wo‡îÝ»K:L�€æCB ���”““ÓZCñùü¥K—VWW/^¼xÆ ­5,�ÀÌ;w¼½½CCCëžíðáÇ>$&&^½zuË–-ݺu›={¶›››¢¢¢DB�h $¤��� þþþwîÜyùò%ýúë¯W¯^%¢Ù³g÷èуuˆ‹‹óóó{öìYQQ‘¹¹ùСC'MšÔÈ€'Nœˆ‹‹ëرãÊ•+›LQQ‘¯¯oTTÔëׯ,--§L™Ò¯_?Ñ>ÅÅňŽŽÎËËëرãˆ#ÜÝÝeeeÙÕÈÈÈãÇ'%%)++›››Ï›7ÏÔÔ´©a��|R™™™ßÿ}xx8)**ÚÙÙÙÙÙYYYuêÔIMMMNN®¸¸8###>>>**êÆÿý÷êÕ«÷íÛçåååàà éð�š )���¨Ç£G|}}ٿχ‡‡s8">|8KHmß¾}ß¾}ÕÕÕFFF***~~~gÏž=þüáÇ544ê0""‚ˆfΜٌBQ . 622200HOO÷ññ9}úô¾}û&OžÌ:988¤¦¦jii™ššÆÇÇ'&&Ξ=›]ýí·ßV¯^-##Ó»wŠ³gÏöêÕ )�*þþþ+W®üðჺºúìÙ³=<<Ú·o_«OÛ¶mÛ¶mkff6qâÄ;w^¼xñàÁƒÏŸ?Ÿ:uêìÙ³7oÞ¬¤¤$‘à�š )���¨ÇÏ?ÿüóÏ?3æÞ½{§OŸ­!uæÌ///³gÏš››QVVÖ”)SÂÂÂV¯^ý믿Ö;`BB™˜˜4#˜eË–mÚ´ÉØؘ½½råʬY³6lØ0vìXöíËÛÛ;55ÕÙÙùèÑ£,w–’’Â:WTTlÚ´‰Ãáܺu‹Õ[ÉÉÉár¹Í�¤Êõë×+++[2—Ë•’…E^^^Û·o'¢±cÇîÞ½»¡Ì¾(99¹É“'Oš4ÉÛÛ{Û¶mÇOHHðõõÅß7�ø·@B ���šàýû÷7n$¢£G²luèÐáìÙ³}úô¹xñâìÙ³ Pë®ÒÒÒW¯^Q×®]›1i¯^½Dߎ3ÆÊÊ*666::ÚÞÞžˆ’““‰¨wïÞ,EDFFFìEzzzyy¹ºººpêÖ:1�$ë»ï¾{ÿþ}KF044¼ÿ~kÅÓl¿ýöÛöíÛeeewíÚ5cÆŒ&ÝËáp.\hoo?uêÔèèhwww???áne��i†„���4Á£G ÍÍÍkeôôô†Q7!ÅçóAËgÏÈÈÈÌÌÌËËc£edd°öQ£Fùûû{{{[YYÙÚÚŠÞbdddbb’˜˜¸aƵk×âh?€ÿ˜‘#GÊËË7õ®ÒÒÒ›7o~ŠxšêÉ“'ëׯçp8û÷ïnCuéÒ%"?~|­¿oB¦¦¦£F ßµkך5k>mÐ��­ )���h‚/^Q½g[XX±µ´iÓFWW733399Y¸vI|àĉ§OŸŽ‹‹m/--e/Fmccíììlgg·}ûváþ>"Z·nÝܹs;vþüù•+WΙ3Ë�þ3öïßß®]»¦Þõúõë>}ú|ŠxšD ,_¾¼ººúÛo¿­7äîîÎ^ÿþûï'Ož9rd½CüöÛoÎÎÎûöí›4iRó–£�|N2’����þMòòòˆHEE¥î%"ª®®®÷F333"ŠoêŒ`ñâÅ«V­*))ñôô¼uëÖÓ§O]\\DûÈÉÉùûû{zzvêÔéöíÛC† ñòò^9rdXXØĉ‹ŠŠÖ¯_ïààÀN�¬k×®±ãGZÓtåÊ"êܹsçÎ{ÛþýûOŸ>½ººú—_~ù$á�´*$¤���  ºuëFD©©©u/±,……E½7²:PG-**jÒŒÁÁÁ~~~ÆÆÆaaa3gδ°°ÐÑÑQTT¬ÕMNNnæÌ™ÑÑÑ?ÿü³@ صkWnn®hØÞÞÞ·oßîׯßóçÏ9Ò¤��>…S§NÑ¢E‹:o̘1D”šššššÊápØÛF,]ºTVV6 àÇ­-�@ëBB ���Ä*³ˆ¦X!󘘘œœÑž%%%ÁÁÁÔpBjÑ¢Ezzzyyy›7onR QQQD4|øpÑeYùùù <þü#FðùüË—/׺jff¶{÷n"bY��$¨¢¢"""BFFf„ õ5jÔ¥K—fÎœ9sæÌK—.5´_OHWW×ÆƦªªêöíÛ­.�@kCB ���¤££CD=¶XZZ:99•——¯]»V¸;O lÚ´éíÛ·ÖÖÖǯw(.—Ë’A'Ožœ4i’°¹Pqqq½7²úå¢1„‡‡‡„„ÈöÀªª*Ñ[ØÁ[ÊÊÊìv>Ÿ_ëRÝV��ŸYbbbEEE·nÝ444é6pà@OOOOOφ*š×º=}ú´u¢�ødPÔ���4xðà .=z433SOOoÙ²eêêê;wîŒ HOO?~¼¼¼ü•+W"##Û¶mëííÝH½pGGÇýû÷oܸ1<<¼o߾ݺu355ÕÑÑyûömBBBQQQLLLÝ»Æçíí}÷îÝï¿ÿÞÆÆæÎ;ׯ_711yñâ…pOŠ«««²²² —Ë ‹ˆˆÐÖÖ1bÝ»woÁ‚...&&&III/^$¢¦¬�ÐêØ:SƒÖV___88�€4CB ���4eÊ”ààà«W¯‘›››ºººžž^DDÄÚµkÙÂ%yyùI“&mÞ¼YKK«ñ§N:|øð­[·Þ¾};>>þùóç¬]YYÙÞÞ¾ªªªîñí}úôÙ³gÏúõë}}}}}}õõõÙJ« Rššš×®]co °}ûvGD••• `—TUUW­Zµ|ùòVù|��š­ñ”“kåodì¯h­u£��R )���hœœÜï¿ÿž™™™••ehh¨©©ÉÚÕÔÔ:´ÿþ¤¤$@еkWñ¿Sihh° JKK“’’ˆHKK«}ûöÂêxš6mÚ”)S544tuuYãĉ…¼½½½¼¼ÒÒÒJKK;uê$Œ“ˆ† “žž®®®n``P7ç�ðù©©©Ñ?G—¶"vžƒººzë �Ðê��€ÐÕÕ¦DÉÊÊššš6{X+++1;ËËË7T.]8Z#Áèèè°zX��RÂÄÄ„ˆê]Z‹8}˜ØØX"jÉg�€ÏEÍ�����>7 ssóââ➈·bÅŠŸ~úIœ1+**BCC‰hРA-�à“BB �����@&MšDD{÷z÷î]½}’’’Nž<yêÔ©’’’èëë[XXسgÏ.]º´r¬��­ [ö������$`úôé{÷î½wïž³³3uèСGÝ»wïÖ­›žžžªªjnn.;ÆaòäÉ\.·ñÑòóówîÜIDßÿýg� …�����€víÚ­]»ö‡~““SPPÈÊÊÊÊʺqãF­n:::Ë–-k|(>Ÿ¿`Á‚·oß<x̘1Ÿ,d�€Vƒ„�����€dÌš5+,,ìúõ뺺º{öì)((xñâERRRFFFIIIÛ¶m8oÞ<ÑÃC몮®^¸pá­[·Ú·oðàÁÏ<�@K !����� 1GŽ™4iÒýû÷çÌ™ãéé¹jÕª&Ýž’’òí·ß>zô¨mÛ¶gÎœéСÃ'Š� u¡¨9�����€Ä¨¨¨\¸paÔ¨QsæÌ™={v||¼87þòË/ööö=êÔ©ÓåË—­­­?u´��­ )������IRQQ9yòäÿþ÷?UUÕÀÀÀ¡C‡Nž<ùüùó¹¹¹u;—••Ý¹sgåÊ•VVV;vì(++suu ·°°øü‘�4¶ì�����HÞ´iÓìííùå—sçÎݾ}ûöíÛDÔ¡CCCÃvíÚÉÊÊgdd¼zõªººšÝbkkûÃ? 8P’q�4 R������RAWW÷—_~Y¿~ý¥K—nܸqÿþ}vôžh999+++SSSI… �ÐBHH�����HuuõY³fÍš5‹ˆÞ¼yóêÕ«I“&ÑéÓ§õõõ %#�@K!!����� ¥ôõõ«ªªjjj %�@«AQs������é•ššJD;w–t ��­ +¤�����¾,>>>üþÐ!C»té"éXàã^½zED†††-¤¨¨¨M›6­�@«@B ����àËr÷ÞÝsçΑ¾¾¾ÝÐ!C¬©©)鸀޿ôôéÓÜÜܲ²²ŠŠŠÒÒÒ´´4jYBª°°°k×®zzzOž<iµX�Z )����€/Ô›7oN:uêÔ)"êÑ£‡ÝP»¡C‡öïß_IIIÒ¡}‰ÂÂÂæÎûáǺ—~þùçK—.íÞ½ÛÅÅeÉ’%MMN¥§§Q»víZ%N�€V„�����P\\\\\ܾýû 0tèP»¡v–––GÒ¡}²³³=<<Š‹‹ûöí;zôèŽ;r¹\%%%]]ÝŽ;¾|ùòÁƒüñ‡ŸŸßþýû'Nœ(þà,!Õ±cÇO>�@“!!�����ÿ¿ŠŠŠðððððð-´ECCcÈ!C‡ µ³³Ó××—thÿegÏž-..vttôõõ­·ÃÎ;.\øË/¿œ={vÑ¢E¡¡¡íÛ·WRRêÙ³çˆ#œ%¤ôôôZ?n�€æBB ����þõlÚJ:„“ììl1{æçç_ºtéÒ¥KDÔ¹sg»¡vvvvƒ Âæ¯V———GDvvvô144Ü¿¿±±ñ¶mÛΟ?/lwvv>|ø°¼¼|C7¾yó†ˆR�©‚„����üëýý÷ß’á¿ïõë×±q±êê<¯ÿþ’ç¿F]]ˆòóó?ÚsÉ’%£GŽŠŠ*))ùðáÃÑ£G/_¾¬¥¥µmÛ¶†nÉÈÈ ¬�)ƒ„����üëEþ)éþM~þùçkׯ‰Ù¹K—.¬ØùàÁƒÛ¶mûIûBTUU½~ý:==ýíÛ·¥¥¥²²²lóý³·î£ŒÙk{{ûÑ£GŸ9sfëÖ­ übÃb…�H$¤����à_ÏÄÄDÒ!ü›´iÛ¦ñšššÂÒQ¨„ÝrOž<‰}öìÙóçÏSSSù|~½=ë=b¯q=zô ¢òòr@ÐxB ?J�*HH�����)))õïßßÎÎnè¡ÿ¢ÃõÜÝÝåäšü¥¦¼¼üS#”ŸŸŸ÷øñãÇ¿zõJôª¬¬¬¡¡¡¾¾¾––—Ë­®®ÎÉÉyñâEFF†hÏêêêk×®©ªªÚÛÛ74WXXõèÑCFF¦ÞUUU¹¹¹rrrÚÚÚ­ðl��­ )����€/‡ÃéÑ£‡ÝP»!C‡ è?@QQQÒ5Yd¤äwkæää\¹r%88øáÇEEE***ÅÅÅ¢¸\®¥¥eÏž=-,,,,,Œj 2hÐ )j.Ξ=»k×®ôôôaÆ5’:xð }ýõ× uHOOººº e¬��$ )����€/‹žžÞôéÓí†Ú <XCCCÒá4“OUUUCW½¼¼¢¢¢–/_nccÓPeeå–P^^~õêU__߈ˆˆššÖÈápŠ‹‹UUUMMM---­­­{öìibbÒx2(:::11Q[[û«¯¾"¢û÷ï¯Y³&66–ˆLLLœœœº1<<<&&FSSÓÕÕµ¡>¬¢9 H€´AB ����à˲ní:I‡Ð lmm¹zêÔ)"277:thëÎ[YYuùò倀�VòIQQÑÑÑqìرƒ âñx¥¥¥mÚ|¤JW-Ç'¢iӦݾ}ûøñãÁÁÁD¤§§·aÆ &4rãáljhÑ¢E$×Þ¼yC8b�¤R������÷þý{WWקOŸ–••±–Þ½{»ººº¸¸ˆf ÄÌFeee%%%¥¦¦&''p8œƒzyy—ËýöÛo/^Üø®²²²;wîÈËË»»»7Ò Í@:!!�����_„€€�VðáÇ>\¾|ùo¿ý6nܸFz–””<þüùóçÏž=KHHxñâEQQQ­>•••–––ÎÎÎÓ§Og+å›7oªªªŒÛ¶mÛH7¶e )�6HH�����´²¬¬¬g"RSSh×µkWccã—/_FFFN:uûöíªªªâOÁ*£—––6ÞmÙCB �¤ R�����ðqvv>vìXKF¨©©)Ÿ3gÎåË—?|ø”””_PP z‹¢¢¢©©©………¹¹y÷îÝMMM555Ù¥¹s瑽½}“²QDd`` ¦¦–™™™ššÚ¹s熺¡¨9�H'$¤������ÄõàÁ77·É“'WUUeeeEEEÑÒ¥KkuÓÔÔìÞ½»¥¥¥……………E·nÝdeeë0''‡ˆ:tèÐÔHddd†~îÜ9??¿Õ«W7Ô%¤PÔ�¤ R�����ð¹ÿþœ9sš}{LLÌ»wï¼½½EUTTÌÌÌLLLLLLÌÌ̺wï®­­-怅……D¤¦¦ÖŒ`f̘qîܹS§N-_¾\^^¾n‡¼¼¼òòrMMÍÆë£�|~HH����€TKKKÛ²eK“n)((èÛ·¯ŸŸßåË—…™™™ìÿŠ6¶ sssoooƒfÜûþý{"j×®]3îíß¿¿……ųgÏ®]»VoUu±�R )�����^iiiË–- —t ¹ÿþîÝ»wíÚ¥¤¤ÔÔ{Y±saQª¦ruu]»víÕ«WIHa¿�H!$¤�����@z†‡‡wêÔiÆ ’Ž¥A‹/öõõý駟š‘b©¨šššæM=xð`"zòäI½WYB Í@ !!�����ÒNMM­Þ@Rbùò奥¥Í»—Õ~ª¬¬lÞí DTVVVïU¬�©ÕÌu¡������ÐrêêêDTPPмÛCBBˆÈ¢ޫX!�R )������‰ÑÔÔ$¢wïÞ5ãÞ7oÞüòË/Däîî^o5�©…-{���ÐR•••|>_QQ±ÙEyÿ]Ayy¹ŒŒŒ¢¢¢¤c�iôþý{__ßGËËË·mÛVEEEAAANNŽˆŸÏgµÌkjj222ˆÈËËëòåËÕÕÕ|>ŸÏç×ÔÔ@ ##Ó¯_¿… Ö%99ÙÍÍ­  `ĈNNNõF‚„�H-$¤���@\ñññ™™™íÛ·×ÕÕµ´´”••%¢)S¦DFF:thòäÉ’ŽñsˆŽŽvvv644¼ÿ¾¤c�©óàÁƒéÓ§¿}û¶IwÝ¿¿¡?),%*))ÉÇÇçĉ=zô8tèP½7–––æçç+))ñx¼&�ð !���QRRòÓO?]¸páýû÷¢í<ïÑ£GÊÊÊ’ �@Ú͘1ãíÛ·¶¶¶ZZZW¯^­ªªíÀápdee…'ë1<ïíÛ·ººº}úôÑÒÒRVV–‘‘ž»§¦¦öçŸ~øð!+++55õÑ£GiiiìÒäÉ“===¹\n½Á°µWX�Ò )���hLhhèòåË322´µµœœÌÌÌôôôÞ½{Ÿ››‹l�€(Ÿ¼¼<kkë3f,X°€ˆ¬¬¬¬¬¬ôôô444¸\n½[}srröíÛ—™™ Î,JJJ½zõ²··ïÒ¥KhhhCÝåää>|Ø»wïf?�À§€„���4(..ÎÍÍ­ººzÆŒ›6mjÓ¦¤#�j,£ôÝwß‘¹¹yllllllëÎR^^%NçøøøÇ;v¬uc��h!$¤��� ~|>éÒ¥ÕÕÕ‹/Þ°aƒ¤Ã�v¥¥¥±±±²²²ŽŽŽ~~~D¤ªªJD}ûöÕÕÕ•HH<ÈÔ��CB ���êwâĉ¸¸¸Ž;®\¹²©÷ùúúFEE½~ýZAAÁÒÒrÊ”)ýúõíS\\|àÀèèè¼¼¼Ž;Ž1ÂÝÝUI'¢ÈÈÈãÇ'%%)++›››Ï›7ÏÔÔTxoAAÁ±cÇ>|˜––fmm=dÈ©S§Š?8#~øᇪªªÕ«WëèèÛýüü¢££ÝÜÜúôé#l¼ÿþéÓ§»wï>oÞ<ÑA¢¢¢îÞ½«¥¥åááQïAW!!!×®]{ôèQÛ¶m ðõ×_ ¯zzzfddxzz¾zõê?þ¸uëVxx8‡Ãç1@ªüý÷ß|>ßÜÜœËå*))ŸÏ'¢ Œ7N"!xxxHdj�€Æ!!���õ‹ˆˆ ¢™3g6£PÔÂ… ƒƒƒŒŒ ÒÓÓ}||NŸ>½oß>á1|EEE©©©ZZZ¦¦¦ñññ‰‰‰³gÏfWûí·Õ«WËÈÈôîÝ»¢¢âìÙ³½zõ&¤bccgÍš•••emmmllvþüùèèè={ö°:Á.ÄápRSSÃÃÃûöí;mÚ4aûîÝ»_½zED¢ ©³gÏž>}ú§Ÿ~áìÙ³K–,QRRªªªzþüù­[·6nÜøÝwß ;ðùü79rDGG§OŸ>oÞ¼Ù»wïÉ“'Ï;geeÅú„„„<~üxÑ¢EÎÎÎyyyD$8ÎG�¤MRR™™™Qee%±<¸×(ay�H-$¤��� ~ DdbbÒŒ{—-[¶iÓ&cccööÊ•+³fÍÚôÓÍ��“IDAT°aÃرcÙªooïÔÔTggç£G²Õ@)))¬sEEŦM›8έ[·ºwïND999Â3¤ÊÊÊÜÜÜŠ‹‹/^¼8`À�ÖòÍ7ßœ9s¦oß¾nnn^ˈ#ÂÃÃïܹ#LH={öìÕ«WmÚ´ f‰!ÖÎÊ3Fxoffæ?þèíí=bć³wïÞÝ»wïرcìر:ub}Ž;väÈ‘ñãÇ:tH^^žˆnܸ1sæÌ™3g>|øå•X…ãE‹éêê:t¨sçÎ222â<&�H›×¯_[ùöí["b¿ø‡–l`��R )���¨Gii)[%Ôµk×fÜÞ«W/Ñ·cÆŒ±²²ŠŽŽ¶··'¢ääd"êÝ»·0ã#ÜÅ–žž^^^®®®.œZ[[[8”··wvvö¼yóXš†ˆ”••wìØ1xðàãdzLM#ƒ×2|øð5kÖ°µ`ÌÕ«Wåää-Z´cÇŽû÷ï³m†‰‰‰VVV¢§§WVVîß¿ßÅÅ…½]µjÕï¿ÿþöíÛ»wﲄTQQ‘———œœÜöíÛÙ—R"rrr9rd```ppðˆ#ˆHAAˆž?~ÿþ}a•q�¤MZZuîÜ™ˆ²²²ˆ¨ÿþšššëÿ®÷�HH��@=ø|¾@ hù8™™™yyyl´ŒŒ Ö>jÔ(ooo+++[[[Ñ[ŒŒŒLLL7lØ°víÚZGû]½z•ˆ\]]EMMMÛµk÷ôéÓŠŠ EEÅF¯ÅÀÀÀÌÌ,!!áùóçæææDtåÊ•Þ½{7nÇŽAAA,!Fÿwyµk×n„ ¢-666/^¼`o£££óóóGÅãñD» 0 00ðÁƒ,!Åvô|óÍ7¢5ÅyÌFž �$‚%¤ «ªª²³³eeeW®\Y«z��0(@����õhÓ¦ Ë°ÕFM%Ž?îàà`mm=jÔ(ww÷¸¸8"*--eFmcc“™™éìì<yòäZ³¬[·NQQñرc={ö<rä« Ì°Íw£Fêô}øðˆ²³³?:x-¬ ù;wØà/^¼°³³ëÚµk‡®_¿Îúܼy“ˆÆŽ+z£ººz­¡,,,ˆ(''G4ÔZ¡nÞ¼™þY=Á>+"êÙ³§èPâ<&�H›—/_Q×®]_½zUSSc``Ð*Ù(GGÇ’’’–� =°B ���êgff–™™_ïÉq‹/öóó322òôôìÓ§ÇÛ°aÃÅ‹…}äääüýýÿøãܾ}{È!+V¬X¶l»:räÈ°°0//¯‹/®_¿Þ××÷øñã]ºt)---..æp8îîîl"–ÍüCCC㣃×âääô¿ÿýﯿþZ¸páµk׈ÈÁÁˆ¾úê«Ó§O§¤¤tìØñîÝ»&&& íû}(Ñ·,3emmÍ6˃d¯…;hX ۸Ljù˜� mJKKuttÚ¶mû×_‘°Ž^ ={ö¬°°P45�ð€„���Ô¯W¯^¡¡¡G3gN­}s öóó366 UQQau·˜ÉÉÉÍœ9sÚ´iÇß´iÓ®]»ÜÜÜ´´´ØÕnݺy{{/Y²dÅŠ111GŽÙ¹s§ŠŠŠ¶¶vNNÎܹsõõõ‰¡ñÁEõîÝ»}ûö÷ïß'¢ÐÐP}}}¶XiÔ¨Q§OŸ¾}ûv÷îÝ+++k-G—.]ˆÈÈÈhË–-t«»5RüÇ�iÃÎýû￉¨[·n’�@zaË���ÔoÑ¢Ezzzyyyl‹™ø¢¢¢ˆhøðáÂlåçç×ÛY^^~þüù#FŒàóù—/_®uÕÌÌl÷îÝDtéÒ%a ýSÔ飜áp8Æ +((ˆ‰‰7nk:t¨ªªê­[·îÝ»GD£GgÆZÁQdddEEEóîó1@z°jt‰‰‰ÔÜSJ�¾HH��@ý¸\.K<yrÒ¤IÂzäBÅÅÅõÞÈ–ü<zôHØBDÕÕÕ¬¥ªªJô–÷ïß‘²²2»]tg »$\`µtéR"Ú¼yó³gÏŠ¼‘ÁëÅö$zyyUVV OÍSTTtttŒŒŒŒˆˆ044dõ¡š¤oß¾ƒ zóæÍš5kj…$ªÞâñâ<&�H!KKK©n.áh��¤¶ì��@ƒ÷ïß¿qãÆððð¾}ûvëÖÍÔÔTGGçíÛ· EEE111uï7nœ··÷Ý»w¿ÿþ{›;wî\¿~ÝÄÄäÅ‹¬&7¹ºº*++ÛØØp¹Ü°°°ˆˆmmmvêܽ{÷,Xàââbbb’””Ä*O͘1ƒÝhkk;wîÜ£G:::Ž3ÆÂÂBFF&77÷îÝ»[¶lagê52x½†ª¨¨Ô¹sg+++aûèÑ£/]ºtçÎE‹5ïôôô7nÜ©S§"##œœtuu _¾|Y^^îããÃúÔ›ç1@ ±„T^^éèèH:��é…„���4fêԩÇߺuëíÛ·ãããŸ?ÎÚ•••ííí«ªªäååkÝÒ§OŸ={ö°bä¾¾¾úúúl¥Õ‚ „ )MMÍ€€�VDœˆ °}ûvGD••• `—TUUW­Zµ|ùráøÛ¶m³µµÝºuk@@€p#ž™™™p]U#ƒ×‹Ëå4(44ÔÙÙY´}Ø°aŠŠŠÍ( Åÿõ×_ëÖ­»~ýúáÇ…Ó5Jاބ”8 �Òƒý"+++³BæìD<.—+á°��¤§¡ÿ ���ÍPSS£­­-++›-NÿY³f]¹rå÷ßoF‰¢Ï¯´´4))‰ˆ´´´Ú·o_ëP¹Zªªª544tuu---­´´´S§Nšššµ®fgg§§§«««ÔÍy1%%%)))\.·C‡¢õª>:¸D¤¥¥êèè´oßžÃáˆc#ùãïï?þü &9r䣛ú»­. ÀÃÃÃÙÙùرcŸt¢¸¸8++«›7o~Ò‰Z¢sçÎÅÅÅÖÖÖl{²¹¹ynnn|||ûöí[>x×®] SRRÚ¶mÛòѤûÄØ3�øoà )���—ŠŠŠèŽ¶ÆÉËË7^wIEE…GU/îvár¹=zôhÆàa`````ÐŒyL�lé"«hND,_ßHñ8��@Qs�����€a'6tïÞ½eK™„›”� .$¤������Z¤¦¦†DVH±}goß¾•dL��Ò )�����€æ«¬¬d[öºvíÊZ:vìHD(p�Ð$¤������šö@DŠŠŠìKH½~ýZb1�H=$¤������š/11±V KH¥¦¦J"�€$¤������š/99¹VK·n݈(!!Aá��ü; !�����Ð|/_¾¬ÕbffÆápYm)��¨ )�����€æKOO¯ÕÂår;uêTQQ‘’’"‘��¤R������ÍWïizjjjDôìÙ³–Œœœœ¼bÅŠòòrCCÃiÓ¦]ºt©ººº%�H9I����ð‚òòráyUŸHEEEMM’’‡Ãù¤} ÿêàþcòóókµ<}úôÉ“'mÚ´±´´lÞ˜ÞÞÞ!!!€Ãáèèèܽ{÷îÝ»ZZZÓ¦Msww×ÓÓkqà��’„R��� ]¢££  ô©'6l˜Á­[·>õDâKMMõ÷÷///ÿhO) àKSZZ´hÑ¢¢¢¢Z—ÂÃÉh„ ]»vmÒ˜UUU~~~vvv&LVRRrwwŽŽ>{öìîÝ»ÍÍÍsss÷ìÙÓ«W/77·ÐÐP@ÐjÏ�ðya…��€$ÉÉɶ`� gg第¬~øaåÊ•’GXùgöK U¦OŸ®®®®¯¯¯¨¨XTT”‘‘‘˜˜/üë-'''ú—œíÔëÙ³§øSäççÿþûïÇÏÉÉ!"Ù³gÏœ9S]]upwwwww‰‰9qâD``à7nܸѩS'wwwWWWMMÍV{Z�€Ïÿÿ��@’TUU‰¨¸¸XÒHLJJŠªªª¶¶¶¤‘<‡£¥¥•••Õ¡CIÇ"ìýR�H¸¸¸ëׯ×m—••íÕ«—££ã¸qãÆŒSXX(¼ôäÉ"²°°güäädooïsçΕ••‘¥¥å‚ \\\äååëvîׯ_¿~ý¶nÝzæÌ™“'O¾zõjË–-;wî;vì¬Y³úõë×̇�øì��¤6mÚч$ˆdxxxœ9sfØ°a’ŽE*\¿~=33ÓÀÀ@ÒHÆû÷ïéŸ_ �éÑ£GÐÐÐ'OždeeUVVr¹\ccc •ºý£¢¢RRR444>šŠˆˆ8|øðÍ›7Y¡(''§ ˆ³aYCCã»ï¾[´hQXX؉'BBB.\¸páÂ…îÝ»;v¬©û�$ )���IÒ××'¢ÔÔTI"lg ÉÉÉ}±Ù("zõê}ÉŸ�H­=zôèу½Žˆˆ8zô(KKèééÕÔÔу"""Nœ8AD3gΔ••mdÌŸ~úiß¾}D¤¢¢2eÊ” 5)*‡ãààààà‘‘áããóǤ§§£Ø9�ü[ !�� IÆÆÆD”””$é@ê{âĉaÆ1ââÅ‹¡¡¡ÉÉÉŽŽŽ®®®,æïïïë뛑‘Ñ¥K—åË—×­–RPPpìر‡¦¥¥Y[[2dêÔ©ì’¿¿ÿ;w^¾|ID¿þúëÕ«W‰höìÙ¯|LTTT@@�;XÊÃÃÃÉÉ©ÖUUU'Nœ¸ÿ~bb¢ŽŽŽ¥¥å¬Y³:vìX÷q®\¹ôüùsccc[[[ww÷º}Š‹‹8——×±cÇ#F¸»»×û•ÒÓÓ3##ÃÓÓóÕ«WüñÇ­[·ÂÃÃÙw<õGg9pà@rr²››[Ÿ>}š¼8SK9ö‹À~)�¤Ö‡®]»Vï%áoœ««ëŠ+gܸqçÎóðð˜9s¦ššZKBÒÓÓ[³fÍÊ•+ê]´� …��$sss"zòä ŸÏoüßÒ?¿¬¬¬Ó§Os¹Ü   sçΩ««¿ÿþÉ“'þþþaaaûöíóòòjÛ¶myyyRRRHHˆ¿¿ÿÀ…·ÇÆÆΚ5+++ËÚÚÚØØ8,,ìüùóÑÑÑ{öì‘‘‘yô葯¯/[S Lå >\4!uöìÙ%K–())UUU=þüÖ­[7nüî»ï„æÏŸŸÀårÍÍÍ?~|ëÖ­'NxzzNœ8QØ­ªªjùòå¾¾¾D¤££óìÙ³ÀÀÀ°°°ŠŠ Ñç-**rppHMMÕÒÒ255OLLœ={v½NHHÈãÇ-Zäì윗—GDlÇMãOýÑYnÞ¼9pà@aBJÌà?ú7íg/ •••qqq§{÷î’Ž 1ýû÷÷ññ)..ÎÊÊzýúuZZZVVVRRRMM‘‘Q¿~ý¦OŸÞ·oߎceeõäÉ“VüË/''giiÙZ£�|r���h=|>ŸÇãikk‹‹­­-Ç»ÿþ§‹ªyÂÂÂx<ž¡¡!«ŸRSS“““cooÏãñ†Ú±cÇ€€€ªªª²²²yóæñx¼ï---µ°°044ŒŽŽ¶8;;óx¼S§N »=šÇã‹ÎÉãñtuuýýýKKKËÊÊvìØÁãñôôô^½zź•——÷ïߟÇã­]»¶ªªJ ÔÔÔ9r„ÇãéèèÄÇÇ <pà�ÇëÞ½{LL k‰‹‹377çñx<›.víÚÅãñ<<<jjjXKrrrCΘ1cx<Þ°aÃnݺŢç©Ÿ…u>wî\Sƒó—fìçnoo/fÿfü®Aëº|ù2ûùSOËãñ>õD-allÌãñ %È¿ûã&é(�àsøüs��ÀÛСC‰(((HÒÔ¦¨¨HDÅÅÅ^^^_}õ;nÎœ9Dôüùóµk׎;VNNNIIiçÎJJJÉÉÉÙÙÙì^ooïììlWW×°eeå;vÑñãÇÅ™½²²rçÎ...ÊÊÊJJJ«V­âñxwïÞeöíÛ—’’2xðà­[·ÊÉɇÙ7oÞŒ3ª««×­[ǺåççïÞ½›ˆ~ýõWášKKË-[¶Ôš199™ˆz÷îÍ–kQ#õ\ØçàããcggשS'1ŸºI³ˆ|Ë?p‰c¿C† ‘t ���ð9 !�� a&L ¢ .IÇRá[–>#¢‘#G ÕÔÔLLLèŸl ±šP®®®¢C™šš¶k×îéÓ§u·›ÕÕ®];öÉÙØØÑ‹/ØÛ°°0"b 2QlûÛÝ»w«««‰èÁƒÅÅÅæææ¢Û ‰h„ :::¢-£F""oo﨨¨†ÇvÙ|óÍ7ºººÂFqžºI³ˆ|Ë?pÉâóùþþþDäââ"éX���às@ )��� ëÓ§O—.]^¾|yãÆ#FH:œÚx<žè[===…ÊÊJUUUÑööíÛ“È©y)))ôOòETYYegg³%EPWW¯Õbaa(œ‚e¦êÖ255•••­ªªJII111a92SSÓºS¨©© —tÑèÑ£mll¢££íìì¶oßÞHum–=¬UÇ]œ§nÒ,âßò\²óòòLLL¬¬¬$ H33³°5›RëäÉ“ÕÕÕµþ0�@#��¼yóæ­^½ÚËËK Rbbe³Yš¦´´´¸¸˜Ãá°ÃàX™�©\©¡¡ÑŒ)ؾ<¦¬¬¬¸¸˜ˆêž'%+++//ÏçóÙ ©ÜÜ\"jÓ¦MÝ…›æ„ãûûûÿñǸ}ûö!CV¬X±lÙ²zƒaOÄ6î1b>u“f3øOôN{÷î%¢ùóçK:FòòòRžQ%"[[[I‡��ð/ƒ„��€äM›6ÍËËëñãÇW¯^=z´¤Ãi)mm휜œ¹sçêëëŠ)”••õõõß¼yÃŽ«½”‘‘Q^^.//ß­[7"êÒ¥ ¥§§×¤´´´V‹œœÜÌ™3§M›vüøñM›6íÚµËÍÍ­ÖøLÝý•â?µø³ˆügøÀ?)ÿgÏžéêêN:UÒ±���Àg‚R���’§¤¤ôÃ?ѺuëêfIþÌÌÌèŸ2O——'¢¢¢¢fLannNDµÚ/^¼HD&&&lpVÜ***êÝ»w¢Ý>|˜––ÖPTóçÏ1bŸÏ¿|ù²ø!‰ùÔâÏ"~ðMšZªoܸ‘ˆV¯^Í~d���ð%@B ��@*̘1£gÏž?þø£¤ciK—.%¢Í›7?{ö¬‘n¬2÷£Gš1ÅòåËeddNž<ùàÁaã‹/öíÛGD«V­b-ýû÷ïÝ»wiiéªU«ªªªXcEEŲeËØ*§ššÖ(¼Ê¼ÿžˆ”••ë½Þ ôâ<u“f?x1?p)´zõêìììþýûóÍ7’Ž���>lÙ�� gïÞ½NNN>>>¬uÀÜ¿Ž­­íܹs=êèè8fÌ ™ÜÜÜ»wïnÙ²EXleðàÁ.\8zôhff¦žžÞ²eËêÖ2oˆµµõ’%KöìÙãââ2}úô=z$$$œ:uª¨¨ÈÝÝ]´׶mÛ\\\._¾œ˜˜øÕW_\½zÕÐÐpâĉþù'ŸÏgÝ\]]•••mll¸\nXXXDD„¶¶vCU½êMH‰óÔMšEüàÅüÀ¥¯¯¯ŸŸ—Ëýßÿþ'éX���à³BB ��@Z˜™™mݺuÙ²eK–,éСƒ¤#j‘mÛ¶ÙÚÚnݺ5 @¸%ÍÌÌL˜C!¢)S¦_½z•í¼sss?!EDk×®íÕ«×?þxôèQÖ¢¯¯ïåå5~üxÑn½zõ ùöÛoccc_¼x¡ªª:xð`//¯ƒQII 릩©píÚ5övÀ€Û·o¯uÈ P½ )qžºI³ˆ¼8SK›ˆˆˆ+VÑ®]»9j���þ“8 ýÏ)���h†ššmmmYYÙìììæ°zõêß~û­mÛ¶.\èÙ³gë†'%%%)))\.·C‡uÅ#¢ÌÌ̬¬,CCCMMÍæMQPPðòåKƒöíÛ7Ò­°°0--­{÷î¢ö‰*--MKK+--íÔ©S³ƒayêæÍòÑàÅ™ZzÄÄÄ|ýõ×ÅÅÅß~ûíæÍ››1BË× …<<<œ;&éX࿃ýÏËË“t �ðÉ!!��КZþ%Y Ì›7ïÒ¥K\.÷ĉööö­!€ÄÏ™3§¬¬lÊ”)l©W3 !%qHHÁ§€„À—EÍ��¤ ‡Ãñöövuu-))ùæ›oP[þK§§çôéÓËÊÊf̘qàÀIG���’„��€Ô‘••Ý»wïÊ•+kjj¶nÝêââ’’’"é �Zêï¿ÿvvvÞµk­]»ö—_~áü¿öîX¥Í6�ðIZŠ ¨C*ˆ .‚‹"JÉ èæàâं›x�‚£x¢ƒƒ»CP¤Z袂 N‚¤H´ƒðó¶Ï×êu.ï³}ùnâ›R©èQ�@1)�øK---mmm½ÿ¾^¯üøqeeÅ¿0𺺺Z^^®V«‡‡‡===;;;µZ­èQ�@‘)�ø{U«Õƒƒƒùùù»»»õõõÑÑÑÅÅÅ/_¾½ žêèè¨V«mll4›Í………ƒƒƒ©©©¢w�s©9�´Ò3]´üíÛ·µµµ½½½Çw___µZœœx÷î] Ï‚?ñãÇÓÓÓïß¿×ëõýýýóó󶶶r¹<==ýéÓ§áááVäRóÂ=^jþáÇñññ¢·ðrìîÔ^A �ZéY_’ONN677···/..þûc¹\îêêêèèhoooù‰ðt···Fãúúúÿ/{{{gggçææ[{œ U¸Ç Uô ^&A ^A �Z)ð’üðððõë×z½~ttt|||vvvww÷LgÁ¯zûömÿÐÐÐÄÄÄÔÔÔÈÈÈ3$HîâââóçÏE¯àeš™™)zðì)�h¥üKr³Ù¼¹¹i4···ë¥T*µ··wtttvv–ˉ[J)�ø§½)z��ðG*•JwwwwwwÑC��à©üÊ����Q‚����Q‚����Q‚����Q‚����Q‚����Q‚����Q‚����Q‚����QoŠ��/ÐýýýêêjÑ+à%{xx(z�ðûJžå�ÐB÷÷÷===E¯€×¢R©\^^½�øe¾!�­T.——––Š^¯E©T*z�ð;|C ���€(—š���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���%H���õ:sP,¤-> ����IEND®B`‚���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/cgi-bin/deob_help.html���������������������������������������������000444��000765��000024�� 4333�12254227314� 22745� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������<html> <head> <body style="font-family:verdana;font-size:14px"> <h2>What is the BioPerl Deobfuscator?</h2> <p>The Deobfuscator was written to make it easier to determine the methods that are available from a given BioPerl module.</p> <p>BioPerl is a highly object-oriented software package, with often multiple levels of inheritance. Although each individual module is usually well documented for the methods specific to it, identifying the inherited methods is less straightforward.</p> <p>The Deobfuscator indexes all of the BioPerl POD documentation, taking account of the inheritance tree, and then presents all of the methods available to each module through a searchable web interface.</p> <p>The following diagram lays out what each part of the Deobfuscator does, and how the pieces interact. For more details, see the POD documentation for Deobfuscator.pm, deob_interface.cgi, and deob_index.pl. <img src="deob_flowchart.png" ALT="a diagram showing how the Deobfuscator works" width=640 height=480 border=0> <h2>Feedback</h2> <p>Find a bug? Have a suggestion for improving the Deobfuscator or other BioPerl modules? Or better yet, have a patch you want to submit?</p> <h3>Mailing Lists</h3> <p>User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated.</p> <ul> <li><a href="mailto:bioperl-l@bioperl.org">General discussion</a> <li><a href="http://www.bioperl.org/wiki/Mailing_lists">About the mailing lists</a> </ul> <h3>Reporting Bugs</h3> <p>Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web:</p> <ul> <li><a href="https://redmine.open-bio.org/projects/bioperl/">Redmine issue tracker</a> </ul> <h2>Credits</h2> <p>This software was developed originally at the Cold Spring Harbor Laboratory's <a href="http://meetings.cshl.edu/courses/c-info05.shtml">Advanced Bioinformatics Course</a> between Oct 12-25, 2005. Many thanks to David Curiel, who provided much-needed guidance and assistance on this project.</p> <p>The BioPerl Deobfuscator was developed by Laura Kavanaugh and Dave Messina.</p> </body> </html> �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������BioPerl-1.6.923/doc/Deobfuscator/cgi-bin/deob_interface.cgi�����������������������������������������000555��000765��000024�� 42217�12254227315� 23602� 0����������������������������������������������������������������������������������������������������ustar�00cjfields������������������������staff���������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl # Deob_interface.cgi # part of the Deobfuscator package # by Laura Kavanaugh and Dave Messina # # cared for by Dave Messina <dave-pause@davemessina.net> # # POD documentation - main docs before the code =head1 NAME deob_interface.cgi - a WWW user interface to the BioPerl Deobfuscator =head1 VERSION This document describes deob_interface.cgi version 0.0.3 =head1 SYNOPSIS This program is designed to be used through a web browser. To install deob_interface.cgi and the rest of the Deobfuscator package, see the README. =head1 DESCRIPTION Deob_interface.cgi provides a web-based front-end to the BioPerl Deobfuscator. It uses the Deobfuscator package to open the Berkeley databases storing the BioPerl documentation and then display a list of the available modules. A search box is also provided if the user wants to pare down the list. When a user clicks on the name of a class, deob_interface.cgi looks up the stored documentation on the methods in that class, and all of the classes that class inherits from, and displays a list of those methods. The list shows the class, return values, and usage statement for each method. A user can see more extensive documentation for a method by clicking on its name or its class's name. =head1 DIAGNOSTICS =over =item C<< Can't open list of Perl module names >> deob_interface.cgi can't locate the textfile F<package_list.txt> containing the full list of BioPerl packages. By default this file should be in the same directory as F<deob_interface.cgi>. See L</"CONFIGURATION AND ENVIRONMENT"> for more information. =item C<< Can't close list of Perl module names >> deob_interface.cgi was unsuccessful in closing the F<package_list.txt> file after reading it. This is most likely a transient filesystem error. =item C<< Unknown sort option selected in deob_interface.cgi >> In the event a sort parameter other than I<sort by class> or I<sort by method> was sent to the sorting subroutine, deob_interface.cgi will exit with a fatal error. =back =head1 CONFIGURATION AND ENVIRONMENT See the F<README> for installation instructions. There are four hardcoded variables you may need to set. Look in deob_interface.cgi for a section labeled 'SET HARDCODED VALUES HERE'. =over =item C<< $deob_detail_path >> The URL of the F<deob_detail.cgi> program. Set to L<< http://localhost/cgi-bin/deob_detail.cgi >> by default. F<deob_detail.cgi> needs to be in your webserver's F<cgi-bin> directory or some location where you are allowed to serve executable code to the web. If you are setting up the Deobfuscator package on your own machine, the default URL will probably work. Otherwise, you will need to change the URL, replacing the C<< localhost portion >> with the hostname of your webserver, and replacing C<< cgi-bin >> with the path to F<deob_detail.cgi> (starting at your webserver's root directory). =item C<< $PERLMODULES >> The textfile containing a list of the BioPerl modules. Set to F<package_list.txt> by default. F<package_list.txt> is automatically generated by the L<< deob_index.pl >> script and its name is a hardcoded value. If your copy of F<package_list.txt> has a different name or is not in the same directory as F<deob_detail.cgi>, set $PERLMODULES to the full path of F<package_list.txt>'s location. =item C<< $BerkeleyDB_packages >> The Berkeley DB file storing documentation on BioPerl packages. Set to F<packages.db> by default. F<packages.db> is automatically generated by the L<< deob_index.pl >> script and its name is a hardcoded value. If your copy of F<packages.db> has a different name or is not in the same directory as F<deob_detail.cgi>, set C<< $BerkeleyDB_packages >> to the full path of F<packages.db>'s location. =item C<< $BerkeleyDB_methods >> The Berkeley DB file storing documentation on BioPerl methods. Set to F<methods.db> by default. F<methods.db> is automatically generated by the F<deob_index.pl> script and its name is a hardcoded value. If your copy of F<methods.db> has a different name or is not in the same directory as F<deob_detail.cgi>, set C<< $BerkeleyDB_methods >> to the full path of F<methods.db>'s location. =back =head1 DEPENDENCIES L<version>, L<CGI>, L<Deobfuscator> =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS =over =item C<< Selecting a class name returns no methods >> Clicking on C<< Bio::Tools::dpAlign >> or C<< Bio::Tools::AlignFactory >> in the upper class selection pane produces an empty lower methods pane. There are undoubtedly other modules that will display this behavior. Reported by Laura Kavanaugh 2006-04-18. =back =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: https://redmine.open-bio.org/projects/bioperl/ =head1 SEE ALSO L<Deobfuscator>, L<deob_detail.cgi>, L<deob_index.pl> =head1 AUTHOR Laura Kavanaugh =head1 CONTRIBUTORS =over =item Dave Messina C<< <dave-pause@davemessina.net> >> =item David Curiel =back =head1 ACKNOWLEDGMENTS This software was developed originally at the Cold Spring Harbor Laboratory's Advanced Bioinformatics Course between Oct 12-25, 2005. Many thanks to David Curiel, who provided much-needed guidance and assistance on this project. Also, special thanks to Todd Wylie for his help with CGI. =head1 LICENSE AND COPYRIGHT Copyright (C) 2005-6 Laura Kavanaugh and Dave Messina. All Rights Reserved. You may use modify or redistribute this software under the same terms as Perl itself. =head1 DISCLAIMER This module is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =cut # Let the code begin... ## SET HARDCODED VALUES HERE ## use lib './lib'; my $PERLMODULES = 'package_list.txt'; my $BerkeleyDB_packages = 'packages.db'; my $BerkeleyDB_methods = 'methods.db'; my $help_path = 'deob_help.html'; my $deob_detail_path = 'deob_detail.cgi'; ## You shouldn't need to change anything below here ## use version; $VERSION = qv('0.0.2'); use warnings; use strict; use CGI ':standard'; use Deobfuscator; my @available_modules; my $sort_method; my $ref_Class_hash; my $filter; my $search; my $sort_order; my $pattern_found = 0; my @all_modules; my $ref_BerkeleyDB_packages; my $ref_BerkeleyDB_methods; my $ref_sorted_keys; # if user previously set the sort order, we can send it with the first form $sort_order = param('sort_order') ? param('sort_order') : 'by method'; # define some styles my $style1 = qq{style="border-collapse:collapse;border:solid black 1px;font-family:verdana;font-size:10px;background-color:lightgrey;padding:3"}; my $style2 = qq{style="border-collapse:collapse;border:solid black 1px;font-family:verdana;font-size:10px;padding:3"}; my $style3 = qq{style="border-collapse:collapse;border:solid black 1px;font-family:verdana;font-size:14px;padding:3"}; my $style4 = qq{style="border-collapse:collapse;border:0px;font-family:verdana;font-size:18px;font-weight:bold;padding:3"}; my $style5 = qq{style="font-family:verdana;font-size:14px;padding:3"}; # Open file containing all Bioperl package names open( MODS, $PERLMODULES ) or die "Can't open list of Perl module names $PERLMODULES: $!\n"; # Open BerkeleyDB by getting hash references $ref_BerkeleyDB_packages = Deobfuscator::open_db($BerkeleyDB_packages); $ref_BerkeleyDB_methods = Deobfuscator::open_db($BerkeleyDB_methods); # Grab input and remove whitespace my $pattern = param('search_string') ? param('search_string') : ' '; $pattern =~ s/\s//g; # Filter file names with user search string if one has been entered while (<MODS>) { if (/\S+/) { # capture list of all module names in case there are no # matches found to user input string push @all_modules, $_; } if ($pattern) { if (/$pattern/i) { push @available_modules, $_; $pattern_found = 1; } } else { if (/\S+/) { push @available_modules, $_; } } } if ( scalar @available_modules < 1 ) { @available_modules = @all_modules; } close MODS or die "Can't close list of Perl module names $PERLMODULES: $!"; # grab BioPerl version string my $version_string = '__BioPerl_Version'; # specified in deob_index.pl my $BioPerl_version = $ref_BerkeleyDB_packages->{$version_string}; print header; print <<CSHL; <html> <head> <title>BioPerl Deobfuscator

Welcome to the BioPerl Deobfuscator

[ $BioPerl_version ]

what is it?


Search class names by string or Perl regex (examples: Bio::SeqIO, seq, fasta\$)

OR select a class from the list:
CSHL print < CSHL2 foreach my $package (@available_modules) { chomp $package; my $packageDesc = Deobfuscator::get_pkg_docs( $ref_BerkeleyDB_packages, $package, 'short_desc' ); my $link = qq{$package}; print "\n"; } print <
EOP # keep track of all our form values my $input_module = param('module'); $filter = param('Filter') ? param('Filter') : ' '; $search = param('Search'); $sort_order = param('sort_order'); # set position of sort button based on current sort order my $is_method; my $is_class; if ($sort_order) { if ($sort_order eq 'by method') { $is_method = 'selected'; $is_class = ''; } elsif ($sort_order eq 'by class') { $is_method = ''; $is_class = 'selected'; } else { $is_method = 'selected'; $is_class = ''; } } # Process user input and return result if ( param() ) { #1 # show button allowing user to set sort order print < SORT_CODE # grab sort order from form or sort by method as a default $sort_method = param('sort_order') ? param('sort_order') : 'by method'; # filter not yet implemented, so this 'if' should never be true if ( ( $filter eq "" ) && ( $input_module eq "" ) ) { print "filter = $filter
search=$search
"; print "Please select a class from the menu or enter a search \n"; print "string and press \"Filter\" button\n"; } elsif ($search) { # Determine methods available to user's input class and the class # where the methods reside. Store results in a hash. $ref_Class_hash = get_methods($input_module); # Sort the method/class data according to user input and display $ref_sorted_keys = sorting( $input_module, $sort_method, $ref_Class_hash ); # Display results display( $input_module, $ref_sorted_keys, $ref_Class_hash, $ref_BerkeleyDB_methods, $deob_detail_path ); } # filter not yet implemented, so this 'if' should never be true elsif ($filter) { if ( !($pattern_found) ) { print qq{

No match to string found, please try again

}; h1('Welcome to the BioPerl Deobfuscator!'),; } } else { print "Not sure about that input. Please submit error report\n"; } } #1 # footer print "\n"; # Close BerkeleyDB Deobfuscator::close_db($BerkeleyDB_packages); Deobfuscator::close_db($BerkeleyDB_methods); ######################## SUBROUTINES ################################# sub get_methods { #1 # Get all available methods for user input class. Deobfuscator package # returns hash with key as user input class and value as ref to array. The # array contains references to an array for each Class, method pair. This # subroutine unpacks this data structure and, for each user input class # creates a hash where the keys are a concatinated class--method pair and the # values are the method (There is method to the maddness, its just obscure). my ($user_class) = shift; my $hashref = Deobfuscator::return_methods($user_class); # Put data from Deobfuscaotr into hash so it can be sorted later according # to user specification my %Package_hash = (); foreach my $array_ref ( @{ $hashref->{$user_class} } ) { #3 my $key = $array_ref->[1] . "::" . $array_ref->[0]; $Package_hash{$key} = $array_ref->[0]; } #3 return \%Package_hash; } #1 End sub get_methods sub sorting { #1 my ( $package, $sort, $ref_hash ) = @_; my @sorted_keys; # Sort by Class or method, depending on user request if ( $sort =~ 'by class' ) { #3 # Sort by Class name (use "lc" to ensure names containing capital # letters are not sorted separately from lower case names foreach my $first ( sort { lc $a cmp lc $b } keys %$ref_hash ) { #4 $first =~ /^(.+)::/; my $package_name = $1; push @sorted_keys, $first; } #4 } elsif ( $sort =~ 'by method' ) { #3 # Sort alphabetically by method name (use "lc" in sort because some # method names are capitalized and will appear first in # an alphabetized list unless lower cased.) foreach my $first ( sort { lc $ref_hash->{$a} cmp lc $ref_hash->{$b} } keys %$ref_hash ) { #5 $first =~ /^(.+)::/; my $package_name = $1; push @sorted_keys, $first; } #5 } else { #3 die "Unknown sort option >$sort< in deob_interface.cgi::sorting()\n"; } #3 return \@sorted_keys; } #1 End sorting subroutine sub display { #1 my ( $package, $ref_sorted_array, $ref_hash, $db_hashref, $detail_path ) = @_; my $search_word; print <
$link$packageDesc
methods for $package
CSHL foreach my $first (@$ref_sorted_array) { #4 $first =~ /^(.+)::/; my $package_name = Deobfuscator::urlify_pkg($1); # Get the return values part of the documentation my $return_methods_raw = Deobfuscator::get_method_docs( $db_hashref, $first, "returns" ); if ( $return_methods_raw eq "0" ) { $return_methods_raw = "not documented"; } # Get the usage part of the documentation my $return_usage_raw = Deobfuscator::get_method_docs( $db_hashref, $first, "usage" ); if ( $return_usage_raw eq "0" ) { $return_usage_raw = "not documented"; } # clean up formatting a little my $return_methods = Deobfuscator::htmlify($return_methods_raw); my $return_usage = Deobfuscator::htmlify($return_usage_raw); # Display output my $href = $detail_path . "?method=$first"; my $link = qq{$ref_hash->{$first}}; my @columns = ( $link, $package_name, $return_methods, $return_usage ); print "\n"; } #4 print < EOP } #1 End display subroutine __END__ BioPerl-1.6.923/doc/Deobfuscator/lib000755000765000024 012254227330 17232 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/doc/Deobfuscator/lib/Deobfuscator.pm000444000765000024 3430212254227330 22367 0ustar00cjfieldsstaff000000000000package Deobfuscator; # module for retrieving method-specific documentation from a # Berkeley database # # first version by Dave Messina (dmessina@watson.wustl.edu) at the # Cold Spring Harbor Laboratory Advanced Bioinformatics Course # Oct 12-25, 2005 # part of the Deobfuscator package # by Laura Kavanaugh and Dave Messina # # cared for by Dave Messina # # POD documentation - main docs before the code =head1 NAME Deobfuscator - get BioPerl method and package information from a Berkeley DB =head1 VERSION This document describes Deobfuscator version 0.0.3 =head1 SYNOPSIS use Deobfuscator; # get all the methods available to objects belonging to a class # (including those inherited from parent classes) my $hashref = Deobfuscator::return_methods('Bio::SeqIO', 'Bio::AlignIO'); # retrieve the return values for a method my $method_db_ref = Deobfuscator::open_db('methods.db'); my $ret_vals = Deobfuscator::get_method_docs( $method_db_ref, 'Bio::SeqIO::next_seq', 'returns' ); close_db($method_db_ref); # retrieve the synopsis documentation for a class my $pkg_db_ref = Deobfuscator::open_db('packages.db'); my $synopsis = Deobfuscator::get_pkg_docs( $pkg_db_ref, 'Bio::SeqIO', 'synopsis' ); close_db($pkg_db_ref); =head1 DESCRIPTION The Deobfuscator module contains functions which relate to retrieving specific types of documentation about BioPerl packages and methods. The deob_index.pl script reads through all of the BioPerl files, extracts the documentation, and stores it in two BerkeleyDB databases. This module is then used to query those databases for information about a given method or package. (see the deob_index.pl documentation for more info.) The types of information available for individual methods include: the usage statement, the return values, the arguments to give to the method, the description of the function, and an example of how to use the method. The Deobfuscator module can be used also to retrieve the synopsis and description documentation for a given class. =head1 DIAGNOSTICS =over =item C<< error: couldn't eval $module >> A package couldn't be loaded (eval'd), which would prevent us from determining what its methods are. =item C<< error: couldn't open $filename >> One of the Berkeley databases couldn't be opened. Possible causes are: deob_index.pl wasn't run and so the databases weren't created, or the database files aren't in the correct place. =item C<< error: couldn't close database >> One of the Berkeley databases couldn't be closed. This might just be a transient filesystem error. =back =item C<< error: couldn't load [module] >> The BioPerl modules aren't in the Perl lib (PERL5LIB) and so can't be searched (the Deobfuscator uses I for this. Check that the value of your PERL5LIB includes BioPerl's modules. If need be, you can set a use lub directive at the beginning of deob_interface.cgi. =back =head1 CONFIGURATION AND ENVIRONMENT This software requires: =over =item A working installation of the Berkeley DB The Berkeley DB comes standard with most UNIX distributions, so you may already have it installed. See L for more information. =item BioPerl Deobfuscator.pm recursively navigates a directory of BioPerl modules. Note that the BioPerl module directory need not be "installed"; any old location will do. See L for the latest version. =back =head1 DEPENDENCIES L, L, L =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS In the current implementation, Deobfuscator does not show internal or private methods (i.e. those whose name begins with an underscore). This is simply an option in the Class::Inspector->methods call, and so could be presented as an option to the user (patches welcome). No bugs have been reported. =head1 FEEDBACK =head2 Mailing Lists User feedback is an integral part of the evolution of this and other Bioperl modules. Send your comments and suggestions preferably to one of the Bioperl mailing lists. Your participation is much appreciated. bioperl-l@bioperl.org - General discussion http://www.bioperl.org/wiki/Mailing_lists - About the mailing lists =head2 Reporting Bugs Report bugs to the Bioperl bug tracking system to help us keep track the bugs and their resolution. Bug reports can be submitted via the web: http://bugzilla.bioperl.org/ =head1 SEE ALSO L =head1 AUTHOR Dave Messina C<< >> =head1 CONTRIBUTORS =over =item Laura Kavanaugh =item David Curiel =back =head1 ACKNOWLEDGMENTS This software was developed originally at the Cold Spring Harbor Laboratory's Advanced Bioinformatics Course between Oct 12-25, 2005. Many thanks to David Curiel, who provided much-needed guidance and assistance on this project. =head1 LICENSE AND COPYRIGHT Copyright (C) 2005-6 Laura Kavanaugh and Dave Messina. All Rights Reserved. This module is free software; you may redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER This software is provided "as is" without warranty of any kind. =head1 APPENDIX The rest of the documentation details each of the functions. Internal methods are preceded with a "_". =cut use version; $VERSION = qv('0.0.3'); use warnings; use strict; use Class::Inspector; use DB_File; use lib './lib'; =head2 return_methods Title : return_methods Usage : $methods_hashref = Deobfuscator::return_methods('Bio::AlignIO', 'Bio::SeqIO'); Function: traverses the inheritance tree for a given class to determine the methods available to objects belonging to that class Returns : a reference to a hash. The hash keys are fully-qualified class names, such as 'Bio::SeqIO'. The hash values are references to an array of hashes, where each array element is a reference to a hash containing two key-value pairs, 'method' and 'class'; Args : a list of fully-qualified class names =cut sub return_methods { my @input = @_; # key: full class name # value: a reference to an array of hashes # where each array element is a pointer to a hash # which contains two key: 'method' and 'class' my %methods_of; foreach my $class (@input) { # fancy eval so that we can loop through different modules my $retval = _load_module($class); if ($retval) { die "error: couldn't load $class: $retval\n"; } # methods returned from Class::Inspector as: # [ # [ 'Class::method1', 'Class', 'method1', \&Class::method1 ], # [ 'Another::method2', 'Another', 'method2', \&Another::method2 ], # [ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ], # ] my $methods_aryref3 = Class::Inspector->methods( $class, 'expanded', 'public' ); for ( my $i = 0; $i < scalar @{$methods_aryref3}; $i++ ) { foreach my $meth ( $methods_aryref3->[$i] ) { my $method_name = $meth->[2]; my $inherited_from = $meth->[1]; push @{$methods_of{$class}}, [$method_name, $inherited_from]; } } } return \%methods_of; } =head2 print_methods Title : print_methods Usage : print_methods('Bio::AlignIO','Bio::SeqIO'); Function: traverses the inheritance tree for a given class to determine the methods available to objects belonging to that class, then pretty-prints the resulting information. Returns : nothing. But it does print to the current filehandle (usually STDOUT). Args : a list of fully-qualified class names =cut sub print_methods { my @input = @_; foreach my $class (@input) { # fancy eval so that we can loop through different modules my $retval = _load_module($class); if ($retval) { die "error: couldn't load $class: $retval\n"; } # methods returned as # [ # [ 'Class::method1', 'Class', 'method1', \&Class::method1 ], # [ 'Another::method2', 'Another', 'method2', \&Another::method2 ], # [ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ], # ] my $methods_aryref3 = Class::Inspector->methods( $class, 'expanded', 'public' ); print "methods for $class\n"; print "=========================================\n"; for ( my $i = 0; $i < scalar @{$methods_aryref3}; $i++ ) { print "method $i\n"; foreach my $meth ( $methods_aryref3->[$i] ) { print "\t class: $meth->[1]\n"; print "\t method: $meth->[2]\n"; } print "--------------------------------------\n"; } } } =head2 _load_module Title : _load_module Usage : * INTERNAL USE ONLY * Function: attempts to load a module Returns : nothing. But it does die upon failure to load. Args : a module name =cut sub _load_module { my $module = shift; eval "require $module"; my $err = $@ || 'eval returned undef'; if ($@) { return $@ } else { return } } =head2 open_db Title : open_db Usage : open_db($filename) Function: opens a Berkeley DB Returns : a hashref tied to the DB Args : a filename as a scalar =cut sub open_db { my ($filename) = @_; my %hash; my $hashref = \%hash; tie %hash, "DB_File", $filename or die "error: couldn't open $filename: $!\n"; return $hashref; } =head2 close_db Title : close_db Usage : closes a Berkeley DB Function: closes a database Returns : nothing. Args : a hashref to a tied Berkeley DB =cut sub close_db { my ($hashref) = @_; untie $hashref or die "error: couldn't close database: $!\n"; } =head2 get_pkg_docs Title : get_pkg_docs Usage : get_pkg_docs($db_hashref, 'Class name', 'documentation type'); Function: returns a specified part of the documentation for a class Returns : a string containing the desired documentation or ' ' if the documentation doesn't exist Args : - $db_hashref is the ref to the hash tied to the DB - Class name is of the form 'Bio::SeqIO' - documentation type is the subfield of the method's POD. The possible values of documentation type are: short_desc, synopsis, desc =cut sub get_pkg_docs { my ($db_hashref, $pkg_name, $info_type) = @_; # hash to store our hash value, now split out into its constituent parts my %record; my $rec_sep = 'DaVe-ReC-sEp'; # if the method isn't in our db if ( ! exists($db_hashref->{$pkg_name}) ) { return 0; } # grab the constituent parts of the pkg record ( $record{'short_desc'}, $record{'synopsis'}, $record{'desc'} ) = ( split $rec_sep, $db_hashref->{$pkg_name} ); # return just the part that was asked for if ( exists($record{$info_type}) ) { return $record{$info_type}; } else { return ' '; } } =head2 get_method_docs Title : get_method_docs Usage : get_method_docs($db_hashref, 'Class+method name', 'documentation type'); Example : get_method_docs($db_hashref, 'Bio::SeqIO::next_aln', 'args'); Function: returns a specified part of the documentation for a class's method Returns : a string containing the desired documentation, or 0 if the desired documentation doesn't exist Args : - $db_hashref is the ref to the hash tied to the DB - Class+method name is of the form 'Bio::SeqIO::next_aln', where Bio::SeqIO is the class and next_aln is the method. - documentation type is the subfield of the method's POD. The possible values of documentation type are: title, usage, function, returns, args =cut sub get_method_docs { my ($db_hashref, $meth_name, $info_type) = @_; my %record; my $whole_record; my $rec_sep = 'DaVe-ReC-sEp'; # if the method isn't in our db if ( !exists( $db_hashref->{$meth_name} ) ) { return 0; } # separate the sub-records using the record separator and field tag my @parts = split $rec_sep, $db_hashref->{$meth_name}; # put individual info types into separate hash entries... foreach my $part (@parts) { if ($part =~ /^-(\w+)\|(.*)/) { $record{$1} = $2; } # ... and put the whole thing into one big string $whole_record .= "$part\n"; } # return a specific part if that was asked for if ($info_type) { # return just the part that was asked for if ( exists( $record{$info_type} ) ) { # if there's really nothing in there, say so. if ( ( $record{$info_type} =~ /^[\s\n]*$/) || ( $record{$info_type} eq '') ) { return 0; } else { return $record{$info_type}; } } # or return everything else { return $whole_record; } } # otherwise return whole record else { return $whole_record; } } =head2 htmlify Title : htmlify Usage : htmlify($string); Example : htmlify('this is a : doc); Function: does some crude reformatting of POD method documentation by swapping isolated colons (':') into HTML
tags Returns : a string Args : a string =cut sub htmlify { my ($string) = @_; # change isolated colons into
tags $string =~ s/\s:\s/
/g; # change L<> POD link into HTML link if ( $string =~ /L<(.+)>/ ) { $string = urlify_pkg($1); } return $string; } =head2 urlify_pkg Title : urlify_pkg Usage : urlify_pkg($string); Example : urlify('this is a : doc); Function: wraps a package name in an HTML href pointing to the bioperl.org pdoc docs for that package Returns : a string (an href in HTML) Args : a string =cut sub urlify_pkg { my ($pkg_name) = @_; my $bioperl_doc_url = q{http://doc.bioperl.org/bioperl-live/}; my $pkg_as_path = $pkg_name; # convert Bio::DB::RefSeq to Bio/DB/RefSeq $pkg_as_path =~ s/::/\//g; my $url = $bioperl_doc_url . $pkg_as_path . '.html'; my $href = qq{$pkg_name}; return $href; } 1; __END__ BioPerl-1.6.923/doc/Deobfuscator/t000755000765000024 012254227321 16727 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/doc/Deobfuscator/t/00.load.t000444000765000024 17012254227317 20371 0ustar00cjfieldsstaff000000000000use Test::More tests => 1; BEGIN { use_ok( 'Deobfuscator' ); } diag( "Testing Deobfuscator $Deobfuscator::VERSION" ); BioPerl-1.6.923/doc/Deobfuscator/t/pod.t000444000765000024 21412254227321 20010 0ustar00cjfieldsstaff000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); BioPerl-1.6.923/examples000755000765000024 012254227340 15116 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/bioperl.pl000555000765000024 4051712254227330 17275 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # bioperl.pl # cjm@fruitfly.org use strict; use lib '.'; no strict "vars"; use Data::Dumper; use Bio::Perl; use Bio::SeqIO; use Getopt::Long; my $h = {}; GetOptions($h, "file|f=s", ); my @cmds = get_default_cmds(); shell($h, \@cmds, @ARGV); # prepare for some seriously hacky code.... sub shell { my $h = shift; my @cmds = @{shift || []}; my @args = @_; my $prompt = $ENV{BIOPERL_PROMPT} || "BioPerl> "; my $quit = 0; my @lines = (); my $r; my $rv; my $seq; my @pseqs = (); my $seqio; my $wseqio; my $fastadb; my $options = {echo=>0, chatty=>10}; my $loadfn = $h->{'file'}; if ($loadfn) { @lines = ("load '$loadfn'"); } sub hr { print "\n===============================\n"; } sub nl { print "\n"; } sub demo { if (! -d 't/data') { print "To run the demo, you must be in the bioperl directory\n"; } @lines = split(/\n/, q[ %keep = %$options; +format '' +outformat '' +echo 1 # BioPerl shell utility - Demo # # We're now going to take a tour # through some of the features of # this tool. # # # This demo will go through some of # the major commands, feeding you # the commands as you go. all you have # to do is hit every time # you see the prompt $prompt # you will then see the output of # the command on your terminal window. # type 'q' to end the tour # at any time. # waitenter # PARSING GENBANK RECORDS # ----------------------- # to parse genbank files, use # the read_seq() method, or # simply use the '<' command. # # First of all we're going to # take a look at the file # 't/data/test.genbank' # Let's examine the file itself # using the unix command "cat" # (you can use any unix command # using the ! at the beginning # of a line) ^!cat t/data/test.genbank waitenter # Ok, you can see this is a # typical file of genbank records. # Let's get the first sequence # from the file ^seq() waitenter # # we can cycle through all the # sequences in the file using # the ',' command. ^, waitenter # this fetched the second sequence # and placed it in the $seq variable # # we can change the output format # by setting the 'outformat' parameter # like this: ^+outformat fasta ^, waitenter # now the sequences are output in # fasta format # to change to embl format: ^+outformat embl ^, waitenter # we can also fetch _all_ seqs from # a file; for this example we will # use t/data/swiss.dat, which is in # swiss format. usually bioperl can guess # the file format from the file extension # but this isn't possible here, so we # must help by setting the input format: ^+format swiss # now lets get all the sequences, like this: ^<*t/data/swiss.dat waitenter # typing <* is equivalent to # using the read_seqs() function, # like this: ^read_seqs('t/data/swiss.dat') waitenter # we now have all the sequences in # the array @seqs # we can write these all out as fasta ^+outformat fasta ^>* # we can also write these out to a file: ^>*myfile.tmp ^!cat myfile.tmp # # RANDOM ACCESS OF FASTA FILES # END +echo 0 %$options = %keep ]); @lines = map { s/^ *//; $_; } @lines; } sub error { if ($error) { print "Error:\n$error"; } else { print "No errors have been reported\n"; } } sub fmt { $options->{format} = shift if @_; print "format=$options->{format}\n"; } # should this move to Bio::Perl ? sub seqio { my $filename = shift; $options->{format} = shift if @_; if( !defined $filename ) { warn "read_sequence($filename) - usage incorrect"; } if( defined $options->{format} ) { $seqio = Bio::SeqIO->new( '-file' => $filename, '-format' => $options->{format}); } else { $seqio = Bio::SeqIO->new( '-file' => $filename); } $seqio; } sub wseqio { my $filename = shift; $options->{format} = shift if @_; my @args = (); if ($filename && $filename !~ /^\>/) { $filename = ">$filename"; } push(@args, -file => "$filename") if $filename; push(@args, -fh => \*STDOUT) unless $filename; push(@args, -format => $options->{outformat}) if $options->{outformat}; $wseqio = Bio::SeqIO->new( @args ); $wseqio; } sub show_seq { return unless $seq; if ($wseqio) { $wseqio->write_seq($seq); } else { printf "seq display id: %s\n", $seq->display_id; } } sub addseq { push(@pseqs, @_); while (scalar(@pseqs) > 50) { # todo - history variable shift @pseqs; } } sub next_seq { if ($seqio) { eval { $seq = $seqio->next_seq; }; if ($@) { $error = $@; print "There was an error getting the seq. Type 'error'\n"; print "for full details\n"; print "(Maybe you have to explicitly set the format?)"; } addseq($seq); } else { print STDERR "use read_seq first\n"; } show_seq; $seq; } sub next_seqs { @seqs = (); if ($seqio) { while ($seq = $seqio->next_seq) { printf "%s\n", $seq->display_id; push(@seqs, $seq); } } $seq = $seqs[$#seqs] if @seqs; @seqs } sub read_seq { seqio(@_); next_seq(); } sub read_seqs { seqio(@_); next_seqs(); } sub write_seq { wseqio(@_); $wseqio->write_seq($seq) if $seq; } sub write_seqs { wseqio(@_); map { $wseqio->write_seq($_) } @seqs; } sub pod { if (!-d "Bio") { print "You need to be in the bioperl directory!\n"; } else { my $mod = shift; unix("pod2text", "Bio/$mod.pm"); } } sub fastadb { require "Bio/DB/Fasta.pm"; my $f = shift; $fastadb = Bio::DB::Fasta->new($f); print "Set \$fastadb object\n"; $fastadb; } sub subseq { if (!$fastadb) { fastadb(shift); } $seq = $fastadb->get_Seq_by_id(shift); if (@_) { printf "%s\n", $seq->subseq(@_); } $seq; } sub load { open(F, shift); @lines = map {chomp;$_} ; close(F); } sub waitenter { print ""; ; } sub showintro { hr; print "This is a text-based commandline interface to BioPerl;\n"; print "\n"; } sub checkoptions { } sub showoptions { my $k = shift; my @k = defined $k ? ($k) : keys %$options; foreach my $ok ($k) { my $v = sprintf("%s", $options->{$k}); if ($v =~ /HASH/) { # hide perl internal details # from user; if they are experienced # perlhackers they can just # type "x $options" to see the # gory details $v = "undisplayable"; } printf("%20s:%s\n", $ok, $b); } } sub set { my ($k,$v) = @_; if (defined($v)) { $options->{$k} = $v; checkoptions; } else { showoptions($k); } # if ($k eq "format") { # seqio; # } if ($k eq "outformat") { wseqio; } } sub echo { my $e = shift; if (defined($e)) { set("echo", $e); } else { set("echo", !$options->{echo}); } } sub options { map {print "$_ = $options->{$_}\n"} keys%$options; } sub showcommands { hr; print "BioPerl Shell Commands:\n"; my $layout = "%5s : %-20s - %s\n"; printf $layout, "cmd", "function", "summary"; printf "%s\n", ("-" x 40); foreach my $c (@cmds) { my $sc = $c->{shortcut}; $sc =~ s/\\//g; printf($layout, $sc, $c->{'func'} . "()", $c->{'summary'} ); } } sub showexamples { print "\nExamples:\n-------\n"; } sub showvariables { hr; print "Shell variables:\n"; print q[ $seq : Bio::SeqI object $seqio : Bio::SeqIO object @pseqs : array of previous Bio::SeqI objects ]; nl; } sub welcome { print "Welcome to the BioPerl shell interface!\n\n"; print "\n\nType 'help' for instructions\n"; print "\n\nType 'demo' for demonstration\n"; print "\n\nThis is ALPHA software - commands may change\n"; print "-lots more commands need to be added to take full\n"; print "advantage of the bioperl functionality\n\n"; } sub help { my $topic = shift; my $c; if ($topic) { ($c) = grep {$_->{func} eq $topic} @cmds; } if ($c) { print "Function: $c->{func}\n"; print "Shortcut: $c->{shortcut}\n" if $c->{shortcut}; print "Summary: $c->{summary}\n" if $c->{summary}; print "=======\n"; print "$c->{docs}\n" if $c->{docs}; } elsif ($topic eq "advanced") { hr; nl; } else { hr; print "\nBioPerl Shell Help\n\n"; showintro; waitenter; showcommands; waitenter; showvariables; waitenter; showexamples; nl; nl; nl; print "Type \"demo\" for an interactive demo of commands\n\n"; print "Type \"help advanced\" for advanced options\n\n"; hr; nl; } } sub p { print shift; print "\n"; } sub x { print Dumper shift; print "\n"; } # trick to allow barewords as keywords... sub advanced {"advanced"} sub unix { my @cmds = @_; my $c = join(" ", @cmds); print `$c`; } welcome; require Term::ReadLine; require Shell; checkoptions; print "\n"; my $termline = shift || Term::ReadLine->new($prompt); my $rcfile = "$ENV{HOME}/.goshellrc"; if (-f $rcfile) { open(F, $rcfile); @lines = ; close(F); } my $end_signal = ""; while (!$quit) { if ($end_signal) { @lines = ($lines); while ($end_signal && ($line = $termline->readline("? "))) { if($line !~ /$end_signal/) { $lines[0].= "\n$line"; } else { $end_signal = ""; } } next; } my $line = @lines ? shift @lines : $termline->readline($prompt); if ($line =~ /^\^/) { $line =~ s/^\^//; print "$prompt$line"; my $e = ; if ($e =~ /^q/) { $line = ""; @lines = (); } } if ($options->{echo} && $line !~ /\+?wait/) { if ($line =~ /^\#/) { print "$line\n"; } else { print "$prompt$line\n"; } if ($options->{sleep}) { sleep $options->{sleep}; } if ($options->{wait}) { sleep $options->{wait}; } } my ($cmd, @w) = split(' ',$line); $_ = $cmd; if (/^\<\<(.*)/) { $end_signal = $1; } # check for shortcuts my $selected; foreach my $c (@cmds) { my $shortcut = $c->{'shortcut'}; next unless $shortcut; if ($line =~ /^$shortcut(.*)/) { if (!defined($selected) || length($shortcut) > length($selected->{shortcut} || "")) { # get the most specific match $selected = $c; } } } if ($selected) { my $shortcut = $selected->{'shortcut'}; if ($line =~ /^$shortcut(.*)/) { my @w = map {"'".$_."'" } split(' ', $1); $line = $selected->{'func'}." ".join(", ", @w); } } $rv = eval $line; # print "\n"; # print "RV=$rv;;;\n"; if ($@) { print STDERR $@; } if ($options->{sleep}) { sleep $options->{sleep}; } if ($options->{wait}) { sleep $options->{wait}; $options->{wait} = 0; } } } sub get_default_cmds { my @cmds = ( { func => 'read_seq', shortcut => '\<', summary => 'read a Seq from a file', }, { func => 'next_seq', shortcut => ',', summary => 'get the next Seq', }, { func => 'read_seqs', shortcut => '\<\*', summary => 'read all Seqs from a file', }, { func => 'write_seq', shortcut => '\>', summary => 'write a Seq to screen/file', }, { func => 'write_seqs', shortcut => '\>\*', summary => 'write a Seq to screen/file', }, { func => 'fastadb', shortcut => 'fa', summary => 'fast fasta access', }, { func => 'subseq', summary => 'get a subseq from a fastadb', }, { func => 'set', shortcut => '\+', summary => 'set a shell parameter', }, { func => 'unix', shortcut => '\!', summary => 'run a unix command', }, { func => 'x', summary => 'display variable (and internals) using dumper', }, ); return @cmds; } BioPerl-1.6.923/examples/generate_random_seq.pl000555000765000024 466412254227340 21627 0ustar00cjfieldsstaff000000000000#!/bin/perl use strict; use vars qw($USAGE); # random sequence generator # # -c=1 option will cause prot sequences to be built # using vertebrate aa frequencies, # with option -a putting a 1st methionine residues on. Frequencies are # calculated from the NCBI human RefSeq protein sequences # -c and -a only affect protein sequences # -a only works in conjunction with -c # -n number of random sequences, default = 1 use Bio::PrimarySeq; use Bio::SeqIO; use Getopt::Long; my ($length,$type,$filename,$comp,$met); $USAGE = 'usage: generate_random_seq.pl --length=1000 --type=dna --filename=/tmp/test.seq --number=50'; my %alphabets = ( 'dna' => [qw(C A G T)], 'rna' => [qw(C A G U)], 'prot'=> [qw( A C D E F G H I K L M N P Q R S T V W Y)], ); # make random num from 1-10000. numbers in this array reflect the frequency, # e.g., a random number from 1.744 = A, 745-991 = C etc; my @aa_frequencies = qw(744 991 1398 2017 2378 3104 3349 3726 4239 5273 5443 5749 6410 6848 7455 8263 8760 9340 9488 9713 10000); my $number = 1; &GetOptions ( 'l|length:s' => \$length, 't|type|m|alphabet:s' => \$type, 'f|file|filename:s' => \$filename, 'c|composition:s' => \$comp, 'a|methionine:s' => \$met, 'n|number:s' => \$number ); assert ( $type && defined ($alphabets{lc $type}), $USAGE); assert ( $length && $length =~ /^\d+$/, $USAGE ); foreach my $num (1..$number) { my $sequence = ""; my $alphabet = $alphabets{lc $type}; my $sspace = scalar @$alphabet; if (!$comp || $type ne 'prot') { foreach ( 1..$length ) { $sequence .= $alphabet->[ int rand($sspace) ]; } }elsif ($type eq 'prot') { $sequence = build_seq($length, \@aa_frequencies); } my $seq = Bio::PrimarySeq->new(-seq => $sequence, -display_id => 'randomseq'.$num); my %args = (-format => 'fasta'); if( $filename ) { $args{-file} = ">>$filename" } my $seqio = Bio::SeqIO->new(%args); $seqio->write_seq($seq); } sub assert { die $_[1] unless( $_[0] ); } sub build_seq { #takes seqlen and ref to frequency data as parameters my ($len, $pf) = @_; my $str = ($met)?'M':''; my $i = ($met)?1:0; for ($i..$len-1) { my $aa = int(rand (10000)) ; my $j = 0; while ($pf->[$j] < $aa && $j <19) { $j++; } $str .= $alphabets{'prot'}[$j]; } print "str is $str\n"; return $str; } BioPerl-1.6.923/examples/longorf.pl000555000765000024 1027112254227331 17302 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # longorf.pl v0208020920 # (c) Dan Kortschak 2002 use vars qw($USAGE); use strict; use Getopt::Long; use Bio::SeqIO; $USAGE = "longorf [--help] [--notstrict] [--verbose] [--graph] [--width printwidth] [--format seqformat] --input seqfile\n"; my ($sequencefile,$sequenceformat,$notstrict,$graph,$verb,$printwidth,$help) = (undef, 'fasta', undef, undef,undef,50, undef); &GetOptions('input|i=s' => \$sequencefile, 'format|f=s' => \$sequenceformat, 'notstrict|n' => \$notstrict, 'width|w=s' => \$printwidth, 'graph|g' => \$graph, 'verbose|v' => \$verb, 'help|h' => \$help, ); if ($help) { exec('perldoc', $0); die; } if (!defined $sequencefile) { die($USAGE . "\nPlease specify an input filename.\n"); } sub longestORF { my $best=0; my ($bests,$beste,$beststrand)=(-1,-1,0); my $bestorf=""; my $relaxed=$_[1]; my $dna=Bio::Seq->new(-seq => $_[0]); my %strand=('+'=>$dna->seq, '-'=>$dna->revcom->seq); foreach my $direction (keys %strand) { my @starts=(); my @ends=(); if ($relaxed) { for (my $frame=0;$frame<3;$frame++) { unless ($strand{$direction}=~m/^.{$frame}(taa|tga|tag)/i) { push @starts,$frame+1; } } } while ($strand{$direction}=~m/(atg)/gi) { push @starts,pos($strand{$direction})-2; } while ($strand{$direction}=~m/(taa|tga|tag)/gi) { push @ends,pos($strand{$direction})-2; } push @ends,($dna->length-2,$dna->length-1,$dna->length); for my $s (@starts) { for my $e (@ends) { if ($e%3==$s%3 and $e>$s) { if ($e-$s>$best) { $best=$e-$s; ($bests,$beste,$beststrand)=($s,$e,$direction); $bestorf=Bio::Seq->new(-seq=>$strand{$direction})->subseq($s,$e); } last } else { next } } } } return ($best,$bests,$beste,$beststrand,$bestorf); } my $seqio = new Bio::SeqIO('-format' => $sequenceformat, '-file' => $sequencefile ); my ($length,$start,$end,$direction,$sequence); my $count=0; my @lengths; my $totallength=0; while (my $dna = $seqio->next_seq) { $count++; ($length,$start,$end,$direction,$sequence)=longestORF($dna->seq,$notstrict); if ($verb) { print $dna->display_id," ",$dna->desc,": "; print "$length, $start, $end ($direction)\n$sequence\n\n",Bio::Seq->new(-seq=>$sequence)->translate->seq,"\n\n--\n\n"; } $totallength+=$length; $lengths[$length/3]++; } print "Average ORF length: ", $totallength/$count,"\n\n"; print "Length distribution is:\n"; if ($graph) { my $length; my $maxlength=0; for ($length=0;$length<@lengths;$length++) { $lengths[$length]=0 unless $lengths[$length]; $maxlength=$lengths[$length] if ($lengths[$length]>$maxlength); } for ($length=0;$length<@lengths;$length++) { print $length*3,"\t",$lengths[$length],"\t|"; print "#"x(($lengths[$length])*$printwidth/$maxlength); print "\n"; } } else { for ($length=0;$length<@lengths;$length++) { print $length*3,"\t",($lengths[$length]or"0"),"\n"; } } __END__ =head1 NAME longorf.pl - perl script to find the longest ORF of a sequence =head1 SYNOPSIS % longorf.pl [-h] [-n] [-v] [-g] [-w printwidth] [-f seqformat] -i seqfile =head1 DESCRIPTION This script will examine a set of nucleotide sequences and determine the longest ORF in each sequence. ORFs may start at the canonical ATG or at the beginning of the sequence if the notstrict option is chosen. The script will output a list of the longest ORF lengths, starts, ends and strands with the ORF and amino acid sequence if the verbose option is chosen. A histogram of the longest ORFs in the input set may be printed by choosing the graph option. =head1 FEEDBACK This script is not supported by anyone, but requests can be made to the author. =head1 AUTHOR - Dan Kortschak =cut BioPerl-1.6.923/examples/make_primers.pl000444000765000024 1221112254227312 20302 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # Author: cckim@stanford.edu # Description: This program designs primers for constructing knockouts # of genes by transformation of PCR products (ref: Datsenko & Wanner, # PNAS 2000). A tab-delimited file containing ORF START STOP is read, # and primers flanking the start & stop coordinates are designed based # on the user-designated sequence file. In addition, primers flanking # the knockout regions are chosen for PCR screening purposes once the # knockout is generated. The script uses Bioperl in order to # determine the primer sequences, which requires getting subsequences # and reverse complementing some of the objects. # make_primers.pl # Purpose: Design primers for the Wanner method of PCR product-based knockouts # Input: FASTA sequence file, tab-delimited coordinates file # Output: Primer output file # July 4, 2001 # Charles C. Kim ########### # MODULES # ########### use Bio::Seq; use Getopt::Std; ############# # VARIABLES # ############# $upgap = 0; # the number of nt upstream of the 5' end to include in the deletion $downgap = 0; # the number of nucleotides downstream of the 3' end to include # in the deletion $oligolength = 40; # the length of the homologous region on each primer $seqfile = ''; # don't specify these filenames unless you want to run $coordfile = ''; # the program on these filenames exclusively $outfile = ''; # %fiveprime_primers = ( "P1" => "GTGTAGGCTGGAGCTGCTTC", ); %threeprime_primers = ( "P2" => "CATATGAATATCCTCCTTAG", "P4" => "ATTCCGGGGATCCGTCGACC", ); ######### # FILES # ######### getopts('s:c:o:'); # sequence file, coordinates file, output file $seqfile = $opt_s if $opt_s; $coordfile = $opt_c if $opt_c; $outfile = $opt_o if $opt_o; &open_readfile(*SEQFILE, 'sequence', $seqfile); &open_readfile(*COORDFILE, 'coordinate', $coordfile); &open_writefile(*PRIMERFILE, 'output', $outfile); ######## # MAIN # ######## $seq = ''; $count = 0; while () { if (/>/) { $count++; if ($count > 1) { die "More than one sequence present in the input file\n"; } next; } chomp($_); $_ =~ tr/gatc/GATC/; $seq .= $_; } close SEQFILE; $seq = Bio::Seq-> new('-seq'=>$seq ); while () { chomp($_); next if !$_; (my $name, my $start, my $stop) = split(/\t/, $_); if ($start < $stop) { $upprimer = $seq->subseq($start-$oligolength-$upgap, $start-1-$upgap); $downprimer = $seq->subseq($stop+1+$downgap,$stop+$oligolength+$downgap); $downprimer = Bio::Seq->new('-seq'=>$downprimer); $downprimer = $downprimer->revcom(); $downprimer = $downprimer->seq(); $uppcr = $seq->subseq($start-$oligolength-$upgap-20,$start-1-$upgap-$oligolength); $downpcr = $seq->subseq($stop+1+$downgap+$oligolength,$stop+$oligolength+$downgap+20); $downpcr = Bio::Seq->new('-seq'=>$downpcr); $downpcr = $downpcr->revcom(); $downpcr = $downpcr->seq(); } elsif ($start > $stop) { $upprimer = $seq->subseq($start+$upgap+1,$start+$oligolength+$upgap); $downprimer = $seq->subseq($stop-$oligolength-$downgap, $stop-1-$downgap); $upprimer = Bio::Seq->new('-seq'=>$upprimer); $upprimer = $upprimer->revcom(); $upprimer = $upprimer->seq(); $uppcr = $seq->subseq($start+$oligolength+$upgap+1,$start+$oligolength+$upgap+20); $downpcr = $seq->subseq($stop-$oligolength-$downgap-20,$stop-1-$downgap-$oligolength); $uppcr = Bio::Seq->new('-seq'=>$uppcr); $uppcr = $uppcr->revcom(); $uppcr = $uppcr->seq(); } else { die "Problem with start and stop coordinates\n"; } print PRIMERFILE "$name\n"; print PRIMERFILE "5'pcr\t$uppcr\n"; print PRIMERFILE "3'pcr\t$downpcr\n"; print PRIMERFILE "\tExpected wildtype product size: ",abs($start-$stop)+121," bp\n"; foreach $entry (sort keys %fiveprime_primers) { print PRIMERFILE "5'+$entry\t$upprimer$fiveprime_primers{$entry}\n"; } foreach $entry (sort keys %threeprime_primers) { print PRIMERFILE "3'+$entry\t$downprimer$threeprime_primers{$entry}\n"; } print PRIMERFILE "\n"; $upprimer = ''; $downprimer = ''; $uppcr = ''; $downpcr = ''; } ############### # SUBROUTINES # ############### sub open_readfile { my $filehandle = $_[0]; my $filetype = $_[1] if $_[1]; my $filename = $_[2] if $_[2]; unless ($filename) { print "Enter $filetype filename: "; chomp ($filename=); } unless (-e $filename) { die "$filename not found\n"; } open($filehandle,$filename) or die "Couldn't open $filename\n"; $filehandle = ''; $filetype = ''; $filename = ''; } sub open_writefile { my $filehandle = $_[0]; my $filetype = $_[1] if $_[1]; my $filename = $_[2] if $_[2]; unless ($filename) { print "Enter $filetype filename: "; chomp ($filename=); } if (-e $filename) { print "$filename already exists! Overwrite (Y/N)? "; chomp ($_ = ); while (/[^yn]/i) { print 'Y or N, please: '; chomp ($_ = ); } if (/n/i) { die "$filename not overwritten.\n"; } else { open($filehandle, ">$filename") or die "Couldn't open $filename\n"; } } else { open($filehandle, ">$filename") or die "Couldn't open $filename\n"; } $filehandle = ''; $filetype = ''; $filename = ''; } BioPerl-1.6.923/examples/rev_and_trans.pl000555000765000024 221312254227316 20441 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # PROGRAM : rev_and_trans.pl # PURPOSE : Simple driver for Bio::Seq revcom and translate # AUTHOR : Ewan Birney birney@sanger.ac.uk # CREATED : Tue Oct 27 1998 # # INSTALLATION # If you have installed bioperl using the standard # makefile system everything should be fine and # dandy. # # if not edit the use lib "...." line to point the directory # containing your Bioperl modules. # use Bio::Seq; use Bio::SeqIO; # new sequence from raw memory... # it is *very* important to get the type right so it # is translated correctly. $seq = Bio::Seq->new ( -id => "myseq", -seq => "CGCCGAAGAAGCATCGTTAAAGTCTCTCTTCACCCTGCCGTCATGTCTAAGTCAGAGTCTCCT", -type => 'Dna'); $seqout = Bio::SeqIO->new('-format' => 'fasta', -fh => \*STDOUT); # make a reverse complement sequence $rev = $seq->revcom(); # the actual sequence is here $actual_bases = $rev->seq(); print "Reversed sequence as a string is [$actual_bases]\n"; # we could also write it as fasta formatted output $seqout->write_seq($rev); # make a translation $trans = $seq->translate(); print "Translated sequence!\n"; $seqout->write_seq($trans); BioPerl-1.6.923/examples/revcom_dir.pl000555000765000024 436612254227320 17753 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # ################################################################################ #11-17-2001 #Jianwen Fang (jwfang1999@yahoo.com) # #THis program returns reverse complement sequences of all sequences in the current directory #and save them in the same directory, using the same name with extension ".rev" ############################################################################### use strict; use Bio::Seq; use Bio::SeqIO; my @files = (); my $folder = '.'; my $inputFormat; my $outputFormat; my $numSeq; #Fasta FASTA format #EMBL EMBL format #GenBank GenBank format #GCG GCG format #raw Raw format (one sequence per line, no ID) my @format = ('Fasta', 'EMBL', 'GenBank', 'GCG', 'Raw'); print("\nWhat is the format of the original sequence files?\n"); print("type 0 for Fasta; 1 for EMBL; 2 for GenBank; 3 for GCG; 4 for Raw\n"); $inputFormat = ; chomp ($inputFormat); print("\nWhat is the format of the reverse complement sequence files you want?\n"); print("type 0 for Fasta; 1 for EMBL; 2 for GenBank; 3 for GCG; 4 for Raw\n"); $outputFormat = ; chomp ($outputFormat); unless(opendir(FOLDER, $folder)) { print "cannot open folder $folder!\n"; exit; } @files = grep(!/^\.\.?$/, readdir(FOLDER)); foreach my $file (@files) { if($file =~ /seq/i) { getRevcom($file); $numSeq++; } } print "$numSeq reverse complement sequences have been saved in current directory\n"; exit; ############################################################################ #subroutine getRevcom take an backward sequence file name(should with .seq extension) as parameter #return its revcom sequence using the same name with the extension replaced with rev ############################################################################ sub getRevcom { my $seqFile = $_[0]; my $in = Bio::SeqIO->new('-file'=>$seqFile, '-format'=>$format[$inputFormat]); my $seq = $in->next_seq(); my $revcomSeq = $seq->revcom(); my @outSeqFile = split (/\./, $seqFile); pop @outSeqFile; push(@outSeqFile, 'rev'); my $outSeqFile = join('.', @outSeqFile); print "$outSeqFile\n"; my $out = Bio::SeqIO->new('-file'=>">$outSeqFile", '-format'=>$format[$outputFormat]); $out->write_seq($revcomSeq); } BioPerl-1.6.923/examples/subsequence.cgi000444000765000024 1001212254227323 20274 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # see http://zfish.nichd.nih.gov/tools/subsequence.cgi # uncomment and modify the next two lines # if your perl is in a nonstandard directory #use lib '/disk3/local/lib/perl5/site_perl'; #use lib '/disk3/local/lib/perl5/'; use CGI qw/:standard :html3/; use Bio::DB::GenBank; use File::Temp; use FileHandle; print header, start_html(-title => 'find subsequence of large GenBank entries',-author => 'Jonathan_Epstein\@nih.gov'); print_form() unless param; print_results() if param; sub print_results { $gb = new Bio::DB::GenBank; $accession = param('accession'); eval { $seq = $gb->get_Seq_by_acc($accession); # Accession Number }; if ($@) { print "***ERROR: accession $accession not found***\n"; return; } $segment_start = param('start'); $segment_end = param('length_or_end_value'); $segment_end = $segment_start+$segment_end-1 if param('length_or_end_choice') eq 'Length'; if ($segment_end<$segment_start || $segment_start<0) { print "***ERROR: invalid segment start and end values:$segment_start,$segment_end***\n"; return; } $len = $seq->length(); if ($segment_end>$len) { print "***ERROR: maximum length $len exceeded***\n"; return; } $subseq = $seq->subseq ($segment_start,$segment_end); $name = "subsequence of $accession"; $strand = "+"; $strand = "-" if (param('reverse')); # For some reason, there seems to be a problem if you use the file # handle provided by File::Temp. Similarly, there's a problem if you # pass a filename to BioPerl below rather than a file handle. However, # constructing our own file handle and then passing it to BioPerl works # fine. (undef, $filename) = File::Temp::tempfile(); $fh = new FileHandle "> $filename"; $seqoutlong = Bio::SeqIO->new( '-format' => 'Fasta',-fh => $fh); $seqobj = Bio::PrimarySeq->new ( -seq => $subseq, -id => $name . "[length:$len]:" . $segment_start . "-" . $segment_end . "(" . $strand . "strand)", -moltype => 'dna' ); $seqobj = $seqobj->revcom if ($strand ne "+"); $seqoutlong->write_seq($seqobj); $fh->close; undef $fh; # Now we parse the FASTA file which was just generated, and perform # some simple conversions to HTML. open (TEMPORARY, "<$filename") or die "unable to open temporary file $filename\n"; print "\n"; while () { print $_; print "
\n"; } close TEMPORARY; print "\n"; unlink $filename; } sub print_form { print p("This web page permits you to extract a short subsequence of DNA from a large GenBank entry. This is especially useful in an era of huge \"contigs\" of genomic DNA, where you only want to extract a few hundred base pairs for subsequent analysis.\n"); print p,"This program also illustrates the power of ",a({-href => 'http://www.BioPerl.org/'}, "BioPerl"), ", a powerful set of tools for molecular biology analysis. The ", a({-href => 'subsequence.pl.txt'}, "source code"), " for this program is less than 90 lines long.\n"; print p,"You must specify the GenBank accession number along with a start position. You may specify either the length of the subsequence you wish to extract or, equivalently, the endpoint.\n"; print "The sequence may be reverse-complemented if you wish, e.g., the reverse complement of ATCGC is GCGAT.\n"; print p,"To test this web page, try accession NT_004002, start 50000, length 400.\n"; print start_form,table( Tr(td("Enter your GenBank accession"),td(textfield(-name => 'accession',-size => 20))), Tr(td("Start position"),td(textfield(-name => 'start',-size => 10))), Tr(td("Specify length or end position"), td(radio_group (-name => 'length_or_end_choice',-values => [Length, End], default => Length))), Tr(td("Length or end position"), td(textfield (-name => length_or_end_value,-size => 20))), Tr(td("Reverse complement?"), td(checkbox (-name => 'reverse')))), submit ("Find my subsequence"); print hr(),"Credits: Jonathan Epstein (Jonathan_Epstein\@nih.gov)"; } BioPerl-1.6.923/examples/align000755000765000024 012254227331 16210 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/align/align_on_codons.pl000555000765000024 1113412254227331 22060 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl use strict; use vars qw($USAGE %VALIDALIGN $CODONSIZE); use Bio::SeqIO; use Bio::AlignIO; use Bio::LocatableSeq; use Bio::SimpleAlign; use Getopt::Long; use Bio::Tools::CodonTable; use Carp; BEGIN { $CODONSIZE = 3; # parametrize everything like a good little programmer if( ! defined $ENV{'CLUSTALDIR'} ) { $ENV{'CLUSTALDIR'} = '/usr/local/bin'; } if( ! defined $ENV{'TCOFFEEDIR'} ) { $ENV{'TCOFFEEDIR'} = '/usr/local/bin'; } $USAGE = qq{align_on_codons.pl < file.fa -h/--help See this information -f/--frame Translation Frame (0,1,2) are valid (defaults to '0') -ct/--codontable Codon table to use (defaults to '1') see perldoc Bio::PrimarySeq for more information -i/--input Input Filename (defaults to STDIN) -o/--output Output Filename (defaults to STDOUT) -sf/--seqformat Input format (defaults to FASTA/Pearson) -af/--alignformat Alignment output format (clustal,fasta,nexus,phylip, msf,pfam,mase,meme,prodom,selex,stockholm) -ap/--alignprog ClustalW, TCoffee (currently only support local execution) -v/--verbose Run in verbose mode }; %VALIDALIGN = ('clustalw' => 'Bio::Tools::Run::Alignment::Clustalw', 'tcoffee' => 'Bio::Tools::Run::Alignment::TCoffee'); } my ($help, $input, $output); my ($alignprog, $sformat, $aformat, $frame, $codontable, $verbose) = ('clustalw', 'fasta', 'clustalw', 0, 1, 0); GetOptions( 'h|help' => \$help, 'i|input:s' => \$input, 'o|output:s' => \$output, 'sf|seqformat:s' => \$sformat, 'af|alignformat:s' => \$aformat, 'ap|alignprog:s' => \$alignprog, # for translate 'f|frame:s' => \$frame, 'ct|codontable:s' => \$codontable, 'v|verbose' => \$verbose, ); if( $help ) { die($USAGE); } if( ! $alignprog || !defined $VALIDALIGN{$alignprog} ) { die("Cannot use $alignprog as 'alignprog' parameter"); } else { my $modname = $VALIDALIGN{$alignprog} .".pm"; $modname =~ s/::/\//g; require $modname; } my $alignout; if( $output ) { $alignout = new Bio::AlignIO('-format' => $aformat, '-file' => ">$output"); } else { $alignout = new Bio::AlignIO('-format' => $aformat); } my (@nucseqs,@protseqs); my $seqio; if( $input ) { $seqio = new Bio::SeqIO('-format' => $sformat, '-file' => $input); } else { $seqio = new Bio::SeqIO('-format' => $sformat, '-fh' => \*STDIN); } my $table = new Bio::Tools::CodonTable(); while( my $seq = $seqio->next_seq ) { # if( $frame == 0 && $alignprog eq 'tcoffee' ) { # print "last codon is ",$seq->subseq($seq->length() -2, # $seq->length()), "\n"; # if( $table->is_ter_codon($seq->subseq($seq->length() -2, # $seq->length())) ) { # $seq->seq($seq->subseq(1,$seq->length() - 3)); # } # } push @nucseqs, $seq; push @protseqs, $seq->translate(-frame => $frame, -codontable_id => $codontable ); } if( @nucseqs <= 1 ) { die("Must specify > 1 sequence for alignment on codons"); } # allow these to be tweaked by cmdline parameters at some point my @params = ('ktuple' => 2, 'matrix' => 'BLOSUM'); my $alignengine = $VALIDALIGN{$alignprog}->new('-verbose' => $verbose, @params); my $aln = $alignengine->align(\@protseqs); my $dnaalign = new Bio::SimpleAlign; my $seqorder = 0; my $alnlen = $aln->length; foreach my $seq ( $aln->each_seq ) { my $newseq; foreach my $pos ( 1..$alnlen ) { my $loc = $seq->location_from_column($pos); my $dna = ''; if( !defined $loc || $loc->location_type ne 'EXACT' ) { $dna = '---'; } else { # to readjust to codon boundaries # end needs to be +1 so we can just multiply by CODONSIZE # to get this my ($start,$end) = ((($loc->start - 1)*$CODONSIZE) +1, ($loc->end)*$CODONSIZE); if( $start <=0 || $end > $nucseqs[$seqorder]->length() ) { print "start is ", $loc->start, " end is ", $loc->end, "\n"; warn("codons don't seem to be matching up for $start,$end"); $dna = '---'; } else { $dna = $nucseqs[$seqorder]->subseq($start,$end); } } $newseq .= $dna; } $seqorder++; # funky looking math is to readjust to codon boundaries and deal # with fact that sequence start with 1 my $newdna = new Bio::LocatableSeq(-display_id => $seq->id(), -start => (($seq->start - 1) * $CODONSIZE) + 1, -end => ($seq->end * $CODONSIZE), -strand => $seq->strand, -seq => $newseq); $dnaalign->add_seq($newdna); } $alignout->write_aln($dnaalign); BioPerl-1.6.923/examples/align/aligntutorial.pl000555000765000024 664112254227314 21573 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # An example of how to use the different alignment tools in bioperl # to align some sequences # All these methods except Bio::Tools::pSW will work for DNA sequence # (need to use a different matrix however) use Bio::Factory::EMBOSS; use Bio::SeqIO; use Bio::AlignIO; use Bio::Tools::pSW; use Bio::PrimarySeq; use Bio::Tools::Run::Alignment::Clustalw; use Bio::Tools::Run::Alignment::TCoffee; use Bio::Tools::Run::StandAloneBlast; use strict; # build the sequences since EMBOSS expects seqs to be in files my $seq = new Bio::PrimarySeq(-seq => 'MAVNPELAPFTLSRGIPSFDDQALSTIIQLQDCIQQAIQQLNYSTAEFLAELLYAECSILDKSSVYWSDAVYLYALSLFLNKSYHTAFQISKEFKEYHLGIAYIFGRCALQLSQGVNEAILTLLSIINVFSSNSSNTRINMVLNSNLVHIPDLATLNCLLGNLYMKLDHSKEGAFYHSEALAINPYLWESYEAICKMRATVDLKRVFFDIAGKKSNSHNNNAASSFPSTSLSHFEPRSQPSLYSKTNKNGNNNINNNVNTLFQSSNSPPSTSASSFSSIQHFSRSQQQQANTSIRTCQNKNTQTPKNPAINSKTSSALPNNISMNLVSPSSKQPTISSLAKVYNRNKLLTTPPSKLLNNDRNHQNNNNNNNNNNNNNNNNNNNNNNNNIINKTTFKTPRNLYSSTGRLTTSKKNPRSLIISNSILTSDYQITLPEIMYNFALILRSSSQYNSFKAIRLFESQIPSHIKDTMPWCLVQLGKLHFEIINYDMSLKYFNRLKDLQPARVKDMEIFSTLLWHLHDKVKSSNLANGLMDTMPNKPETWCCIGNLLSLQKDHDAAIKAFEKATQLDPNFAYAYTLQGHEHSSNDSSDSAKTCYRKALACDPQHYNAYYGLGTSAMKLGQYEEALLYFEKARSINPVNVVLICCCGGSLEKLGYKEKALQYYELACHLQPTSSLSKYKMGQLLYSMTRYNVALQTFEELVKLVPDDATAHYLLGQTYRIVGRKKDAIKELTVAMNLDPKGNQVIIDELQKCHMQE', -id => 'seq1' ); my $seq2 = new Bio::PrimarySeq( -seq => 'CLIFXRLLLIQMIHPQARRAFTFLQQQEPYRIQSMEQLSTLLWHLADLPALSHLSQSLISISRSSPQAWIAVGNCFSLQKDHDEAMRCFRRATQVDEGCAYAWTLCGYEAVEMEEYERAMAFYRTAIRTDARHYNAWYVLFFFFFFFFVPGDIDSXPKKGMEWGXFISKRIDRGMRSIILKEPSKSIQLIPFFYVALVWXVGVSSYPLETMTNIDFPKKKKALEKSNDVVQALHFYERASKYAPTSAMVQFKRIRALVALQRYDEAISALVPLTHSAPDEANVFFLLGKCLLKKERRQEATMAFTNARELEPK', -id => 'seq2'); my $out = new Bio::SeqIO(-format => 'fasta', -file => ">seq1.fa"); $out->write_seq($seq); $out->close(); $out = new Bio::SeqIO(-format => 'fasta', -file => ">seq2.fa"); $out->write_seq($seq2); $out->close(); my $embossfactory = Bio::Factory::EMBOSS->new(); my @alignprogs = qw(water needle stretcher matcher); my $alignout = new Bio::AlignIO(-format => 'msf'); foreach my $prog ( @alignprogs ) { my $alignfactory = $embossfactory->program('water'); $alignfactory->run({ '-sequencea' => 'seq1.fa', '-seqall' => 'seq2.fa', '-gapext' => 2.0, '-datafile' => 'EBLOSUM62', '-gapopen' => 14.0, '-outfile' => "seq1_vs_seq2.$prog"}); my $alnin = new Bio::AlignIO(-format => 'emboss', -file => "seq1_vs_seq2.$prog"); my $aln = $alnin->next_aln(); $alignout->write_aln($aln); } # this should produce the same alignment as 'water' my $factory = new Bio::Tools::pSW(-matrix=> 'blosum62.bla', -gap => 14, -ext => 2); my $aln = $factory->pairwise_alignment($seq,$seq2); $alignout->write_aln($aln); $factory = new Bio::Tools::Run::Alignment::Clustalw('ktuple' => 2, 'matrix' => 'BLOSUM'); $aln = $factory->align([$seq,$seq2]); $alignout->write_aln($aln); $factory = new Bio::Tools::Run::Alignment::TCoffee('ktuple' => 2, 'matrix' => 'BLOSUM'); $aln = $factory->align([$seq,$seq2]); $alignout->write_aln($aln); $factory = new Bio::Tools::Run::StandAloneBlast(); $aln = $factory->bl2seq($seq,$seq2); # this actually returns a Bio::Tools::BPbl2seq object # it can be transformed to a SimpleAlign object see # the code in Bio::AlignIO::bl2seq # A transformer object will be written at some point BioPerl-1.6.923/examples/align/clustalw.pl000555000765000024 2176412254227322 20575 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # PROGRAM : clustalw.pl # PURPOSE : Demonstrate possible uses of Bio::Tools::Run::Alignment::Clustalw.pm # AUTHOR : Peter Schattner schattner@alum.mit.edu # CREATED : Oct 06 2000 # # INSTALLATION # # You will need to have installed clustalw and to ensure that Clustalw.pm can find it. # This can be done in different ways (bash syntax): # export PATH=$PATH:/home/peter/clustalw1.8 # or # define an environmental variable CLUSTALDIR: # export CLUSTALDIR=/home/peter/clustalw1.8 # or # include a definition of an environmental variable CLUSTALDIR in every # script that will use Clustal.pm. # BEGIN {$ENV{CLUSTALDIR} = '/home/peter/clustalw1.8/'; } # # We are going to demonstrate 3 possible applications of Clustalw.pm: # 1. Test effect of varying clustalw alignment parameter(s) on resulting alignment # 2. Test effect of changing the order that sequences are added to the alignment # on the resulting alignment # 3. Test effect of incorporating an "anchor point" in the alignment process # # Before we can do any tests, we need to set up the environment, create the factory # and read in the unaligned sequences. # #BEGIN { # $ENV{CLUSTALDIR} = '/home/peter/clustalw1.8/'; #} use Getopt::Long; use Bio::Tools::Run::Alignment::Clustalw; use Bio::SimpleAlign; use Bio::AlignIO; use Bio::SeqIO; use strict; # set some default values my $infile = 't/data/cysprot1a.fa'; my @params = ('quiet' => 1 ); my $do_only = '123'; # string listing examples to be executed. Default is to # execute all tests (ie 1,2 and 3) my $param = 'ktuple'; # parameter to be varied in example 1 my $startvalue = 1; # initial value for parameter $param my $stopvalue = 3; # final value for parameter $param my $regex = 'W[AT]F'; # regular expression for 'anchoring' alignment in example 3 my $extension = 30; # distance regexp anchor should be extended in each direction # for local alignment in example 3 my $helpflag = 0; # Flag to show usage info. # get user options my @argv = @ARGV; # copy ARGV before GetOptions() massacres it. &GetOptions("h!" => \$helpflag, "help!" => \$helpflag, "in=s" => \$infile, "param=s" => \$param, "do=s" => \$do_only, "start=i" => \$startvalue, "stop=i" => \$stopvalue, "ext=i" => \$extension, "regex=s" => \$regex,) ; if ($helpflag) { &clustalw_usage(); exit 0;} # create factory & set user-specified global clustalw parameters foreach my $argv (@argv) { unless ($argv =~ /^(.*)=>(.*)$/) { next;} push (@params, $1 => $2); } my $factory = Bio::Tools::Run::Alignment::Clustalw->new(@params); # put unaligned sequences in a Bio::Seq array my $str = Bio::SeqIO->new(-file=> $infile, '-format' => 'Fasta'); my ($paramvalue, $aln, $subaln, @consensus, $seq_num, $string, $strout, $id); my @seq_array =(); while ( my $seq = $str->next_seq() ) { push (@seq_array, $seq) ;} # Do each example that has digit present in variable $do_only $_= $do_only; /1/ && &vary_params(); /2/ && &vary_align_order(); /3/ && &anchored_align(); ## End of "main" ################################################# # vary_params(): Example demonstrating varying of clustalw parameter # sub vary_params { print "Beginning parameter-varying example... \n"; # Now we'll create several alignments, 1 for each value of the selected # parameter. We also compute a simple consensus string for each alignment. # (In the default case, we vary the "ktuple" parameter, creating 3 # alignments using ktuple values from 1 to 3.) my $index =0; for ($paramvalue = $startvalue; $paramvalue < ($stopvalue + 1); $paramvalue++) { $factory->$param($paramvalue); # set parameter value print "Performing alignment with $param = $paramvalue \n"; $aln = $factory->align(\@seq_array); $string = $aln->consensus_string(); # Get consensus of alignment # convert '?' to 'X' at non-consensus positions $string =~ s/\?/X/g; $consensus[$index] = Bio::Seq->new(-id=>"$param=$paramvalue",-seq=>$string); $index++; } # Compare consensus strings for alignments with different $param values by # making an alignment of the different consensus strings # $factory->ktuple(1); # set ktuple parameter print "Performing alignment of $param consensus sequences \n"; $aln = $factory->align(\@consensus); $strout = Bio::AlignIO->newFh('-format' => 'msf'); print $strout $aln; return 1; } ################################################# # vary_align_order(): # # For our second example, we'll test the effect of changing the order # that sequences are added to the alignment sub vary_align_order { print "\nBeginning alignment-order-changing example... \n"; @consensus = (); # clear array for ($seq_num = 0; $seq_num < scalar(@seq_array); $seq_num++) { my $obj_out = shift @seq_array; # remove one Seq object from array and save $id = $obj_out->display_id; # align remaining sequences print "Performing alignment with sequence $id left out \n"; $subaln = $factory->align(\@seq_array); # add left-out sequence to subalignment $aln = $factory->profile_align($subaln,$obj_out); $string = $aln->consensus_string(); # Get consensus of alignment # convert '?' to 'X' for non-consensus positions $string =~ s/\?/X/g; $consensus[$seq_num] = Bio::Seq->new(-id=>"$id left out",-seq=>$string); push @seq_array, $obj_out; # return Seq object for next (sub) alignment } # Compare consensus strings for alignments created in different orders # $factory->ktuple(1); # set ktuple parameter print "\nPerforming alignment of consensus sequences for different reorderings \n"; print "Each consensus is labeled by the sequence which was omitted in the initial alignment\n"; $aln = $factory->align(\@consensus); $strout = Bio::AlignIO->newFh('-format' => 'msf'); print $strout $aln; return 1; } ################################################# # anchored_align() # # For our last example, we'll test a way to perform a local alignment by # "anchoring" the alignment to a regular expression. This is similar # to the approach taken in the recent dbclustal program. # In principle, we could write a script to search for a good regular expression # to use. Instead, here we'll simply choose one manually after looking at the # previous alignments. sub anchored_align { my @local_array = (); my @seqs_not_matched = (); print "\n Beginning anchored-alignment example... \n"; for ($seq_num = 0; $seq_num < scalar(@seq_array); $seq_num++) { my $seqobj = $seq_array[$seq_num]; my $seq = $seqobj->seq(); my $id = $seqobj->id(); # if $regex is not found in the sequence, save sequence id name and set # array value =0 for later unless ($seq =~/$regex/) { $local_array[$seq_num] = 0; push (@seqs_not_matched, $id) ; next; } # find positions of start and of subsequence to be aligned my $match_start_pos = length($`); my $match_stop_pos = length($`) + length($&); my $start = ($match_start_pos - $extension) > 1 ? ($match_start_pos - $extension) +1 : 1; my $stop = ($match_stop_pos + $extension) < length($seq) ? ($match_stop_pos + $extension) : length($seq); my $string = $seqobj->subseq($start, $stop); $local_array[$seq_num] = Bio::Seq->new(-id=>$id, -seq=>$string); } @local_array = grep $_ , @local_array; # remove array entries with no match # Perform alignment on the local segments of the sequences which match "anchor" $aln = $factory->align(\@local_array); my $consensus = $aln->consensus_string(); # Get consensus of local alignment if (scalar(@seqs_not_matched) ) { print " Sequences not matching $regex : @seqs_not_matched \n" } else { print " All sequences match $regex : @seqs_not_matched \n" } print "Consensus sequence of local alignment: $consensus \n"; return 1; } #---------------- sub clustalw_usage { #---------------- #----------------------- # Prints usage information for general parameters. print STDERR <<"QQ_PARAMS_QQ"; Command-line accessible script variables and commands: ------------------------------- -h : Display this usage info and exit. -in : File containing input sequences in fasta format (default = $infile) . -do : String listing examples to be executed. Default is to execute all tests (ie default = '123') -param : Parameter to be varied in example 1. Any clustalw parameter which takes inteer values can be varied (default = 'ktuple') -start : Initial value for varying parameter in example 1 (default = 1) -stop : Final value for varying parameter (default = 3) -regex : Regular expression for 'anchoring' alignment in example 3 (default = $regex) -ext : Distance regexp anchor should be extended in each direction for local alignment in example 3 (default = 30) In addition, any valid Clustalw parameter can be set using the syntax "parameter=>value" as in "ktuple=>3" So a typical command lines might be: > clustalw.pl -param=pairgap -start=2 -stop=3 -do=1 "ktuple=>3" or > clustalw.pl -ext=10 -regex='W[AST]F' -do=23 -in='t/cysprot1a.fa' QQ_PARAMS_QQ } BioPerl-1.6.923/examples/align/FastAlign.pl000444000765000024 1524612254227323 20603 0ustar00cjfieldsstaff000000000000#! /usr/bin/perl ##################################################### # Fasta # | # Align # # By # Antony Vincent # (a.vincent.0312@gmail.com) # # FastAlign is a perl script which uses the heuristic method # of tfasty36 for find similarity between a query sequence # in amino acids and a sequence in nucleotides. It provides # a more intuitive output to find exon-intron junctions. # The query string is in amino acids and the hit string is # in nucleotides. There are extra nucleotides at the end of # the hit string (option -diff and by default = 10), that # allow to verify if the intron start with common rules # (5'-GTGCGA-... for group II intron and after an exonic T # for group I intron). # # The FASTA version can be changed by the user by changing # the line with tfasty36 for tfastyXX. # # If you have Emboss, you can genarate a graphic with option # -graph 1. # # For complete help: type perl fastalign.pl -help # Last Update: 01/06/13 ####################################################### =head1 Copyright (C) 2013 Antony Vincent Licence: This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . =cut use strict; use Bio::SearchIO; use Bio::SeqIO; use Getopt::Long; use Bio::SeqUtils; ## Set the default variables my $identity = 75; my $length = 50; my $diff = 10; my $out = 'output'; my $graphic = 10; my $query; my $library; my $help; GetOptions( 'seq=s' => \$query, 'db=s' => \$library, 'graph=s' => \$graphic, 'i=i' => \$identity, 'l=i' => \$length, 'diff=s' => \$diff, 'out=s' => \$out, 'help!' => \$help, ) or die "Incorrect usage! Try perl fastalign.pl -help for an exhaustif help.\n"; ### if( $help ) { # if start print "\n"; print "Two options are required:\n"; print " -seq: Your sequence in amino acids\n"; print " -db: The sequence in nucleotides (Could be a whole genome or a partial sequence...)\n"; print "\n"; print "There are few miscellaneous options:\n"; print " -i: Minimum identity percentage (default = 75)\n"; print " -l: Minimum match length (default = 50)\n"; print " -diff: Difference between the hit string and the alignement (default = 10)\n"; print " -out: Name of the output file (default = output.txt)\n"; print " -graph: If this option = 1, a graph will be generated (default = no)\n"; } # if help else { # else start my $date = `date`; open (WRITE, ">>$out.txt"); ## Open the output file print WRITE " Fasta\n"; print WRITE " |\n"; print WRITE " Align\n\n"; print WRITE "Date:", $date, "\n"; print WRITE "PARAMETERS\n"; print WRITE "Minimum identity =", $identity, "\n"; print WRITE "Minimum length =", $length, "\n"; print WRITE "Diff =", $diff, "\n\n"; if ( $graphic == 1 ) { open (WRITE, ">>$out.txt"); ## Open the output file open (WRITE2, ">>lindna.lnp"); ## Open the lindna config file ## start the lindna header print WRITE2 "start"; print WRITE2 "\t"; print WRITE2 "1"; print WRITE2 "\n"; print WRITE2 "End"; print WRITE2 "\t"; my $seqio_obj = Bio::SeqIO->new(-file => "$library", -format => "fasta" ); my $seq_obj = $seqio_obj->next_seq; my $count_obj = $seq_obj->length; print WRITE2 "$count_obj"; print WRITE2 "\n\n"; print WRITE2 "group"; print WRITE2 "\n"; } else { print "No graphic generated \n"; } ## run tfasty36 my $fh; my $fasta = "tfasty36"; # <------ You can change this line for newest fasta algorithm my $command = "$fasta $query $library"; open $fh,"$command |" || die("cannot run fasta cmd of $command: $!\n"); my $searchio = Bio::SearchIO->new(-format => 'fasta', -fh => $fh); print WRITE "Fasta algorithm:", $fasta, "\n\n"; ## start the parsing part of the script while( my $result = $searchio->next_result ) { ## $result is a Bio::Search::Result::ResultI compliant object while( my $hit = $result->next_hit ) { ## $hit is a Bio::Search::Hit::HitI compliant object while( my $hsp = $hit->next_hsp ) { ## $hsp is a Bio::Search::HSP::HSPI compliant object if( $hsp->length('total') > $length ) { if ( $hsp->percent_identity >= $identity ) { ## Generals informations print WRITE "Rank=", $hsp->rank, "\n", "Query=", $result->query_name, "\n", "Hit=", $hit->name, "\n" , "Length=", $hsp->length('total'), "\n", "Percent_id=", $hsp->percent_identity, "\n", "Strand=", $hsp->strand('hit'), "\n"; print WRITE "\n"; ## Search for nucleotide sequences print WRITE "\n"; my $start_hit = $hsp->start('hit'), "\n"; my $end_hit = $hsp->end('hit') , "\n"; my $in = Bio::SeqIO->new(-file => "$library" , '-format' => 'fasta'); while ( my $seq = $in->next_seq() ) {#1 ## looking for query position my $start_query = $hsp->start('query'), "\n"; my $end_query = $hsp->end('query') , "\n"; ## aa_to_3aa my $seqobj = Bio::PrimarySeq->new ( -seq => $hsp->query_string); my $polypeptide_3char = Bio::SeqUtils->seq3($seqobj); ## modify the homology string my $homo = $hsp->homology_string; $homo =~ s/:/|||/g; $homo =~ s/\./***/g; $homo =~ s/ /XXX/g; ## HSP print WRITE "Query($start_query,$end_query)\n"; print WRITE "Hit($start_hit,$end_hit)\n\n"; print WRITE $polypeptide_3char, "\n"; print WRITE $homo, "\n"; print WRITE $seq->subseq($start_hit,$end_hit+$diff), "\n"; if ( $graphic == 1) { ## if start ## write in lindna file print WRITE2 "label", "\n", "Block", "\t", "$start_hit", "\t", "$end_hit", "\t", "3", "\t", "H", "\n"; print WRITE2 "Exon", $hsp->rank, "\n"; print WRITE2 "endlabel"; print WRITE2 "\n\n"; } ## if end else {print "No lindna file generated\n";} } #1 print WRITE "\n"; } } } } } if ( $graphic == 1) { ## if start print WRITE2 "endgroup"; system ("lindna -infile lindna.lnp -ruler y -blocktype filled -graphout svg"); system ("rm *.lnp"); } ## if end } # else end BioPerl-1.6.923/examples/align/simplealign.pl000555000765000024 3232612254227330 21236 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # PROGRAM : simplealign.pl # PURPOSE : Simple driver for Bio::SimpleAlign # AUTHOR : Ewan Birney birney@sanger.ac.uk # CREATED : Tue Oct 27 1998 # # INSTALLATION # If you have installed bioperl using the standard # makefile system everything should be fine and # dandy. # # if not edit the use lib "...." line to point the directory # containing your Bioperl modules. # #use lib "/nfs/disk21/birney/prog/bioperl/"; # Modified 3/5/01 to use AlignIO by Peter Schattner schattner@alum.mit.edu # # This uses the internal DATA stream (past the end of this # file, on the __END__ tag) to load in the data. We then # do some reformats, sort in a different way and a quick # getting into the alignment. All pretty simple ;) # # # The simplealign module does not do the following things # a) give you sensible ways of asking if residues are a # column of gaps or conservation # b) provide ways of editing the alignment # c) making alignments # # # a) and b) are probably best done by UnivAlign from Georg Fuellen # c) is done for pairwise alignments in Bio::Tools::pSW; and # also you can read in stuff from programs like clustal and hmmer # into this. # use strict; use Bio::SimpleAlign; use Bio::AlignIO; # read from a stream my $str = Bio::AlignIO->newFh('-fh'=> \*DATA, '-format' => 'pfam' ); my $al = <$str>; # write out a MSF file my $out = Bio::AlignIO->newFh('-fh'=> \*STDOUT, '-format' => 'msf'); my $status = print $out $al; # order by alphabetically then start end $al->sort_alphabetically(); # write in Pfam format now... my $out2=Bio::AlignIO->newFh( '-fh'=> \*STDOUT, '-format' => 'pfam'); $status = print $out2 $al; # now set the display name to be # name_# like roa1_human_1, roa1_human_2 etc # This **doesn't** change the underlying names of the # sequences you'll be glad to hear. $al->set_displayname_count(); # dump again... bored of this yet? $status = print $out2 $al; # get into the alignment and get things out # we just want to see how many unique names # there are in this alignment my ($seq, $id, %hash) ; # loop over the alignment foreach $seq ( $al->eachSeq() ) { # increment a hash on the name by one each time $hash{$seq->id()}++; } # disgorge the hash foreach $id ( keys %hash ) { print "$id has $hash{$id} subsequences in this alignment\n"; } __END__ GR10_BRANA/8-79 CFVGGL......AWATGDAELERTFS.....Q.FGEV..IDSKIIND.............RETGRSRGFGFVTFKDEKSMKDAIDEMNG.K...ELDGRTITV HUD_HUMAN/48-119 LIVNYL......PQNMTQEEFRSLFG.....S.IGEI..ESCKLVRD.............KITGQSLGYGFVNYIDPKDAEKAINTLNG.L...RLQTKTIKV IF32_SCHPO/41-124 VVIEGAP....VVEEAKQQDFFRFLSSKVLAK.IGKVKENGFYMPFE.........EKNGK..KMSLGLVFADFENVDGADLCVQELDGKQ...ILKNHTFVV IF32_YEAST/79-157 IVVNGAPVIPSAKVPVLKKALTSLFS.....K.AGKV..VNMEFPID.............EATGKTKGFLFVECGSMNDAKKIIKSFHGKR...LDLKHRLFL IF4B_HUMAN/98-168 AFLGNL......PYDVTEESIKEFFR.....G.LNIS...AVRLPR............EPSNPERLKGFGYAEFEDLDSLLSALS.LNE.E...SLGNRRIRV LA_DROME/151-225 AYAKGF......PLDSQISELLDFTA.....N.YDKV..VNLTMRNS.........YDKPTKSYKFKGSIFLTFETKDQAKAFLE.QEK.I...VYKERELLR LA_HUMAN/113-182 VYIKGF......PTDATLDDIKEWLE.....D.KGQV..LNIQMRR..............TLHKAFKGSIFVVFDSIESAKKFVE.TPG.Q...KYKETDLLI MEI2_SCHPO/197-265 LFVTNL......PRIVPYATLLELFS.....K.LGDV..KGIDTSSL.................STDGICIVAFFDIRQAIQAAKSLRSQR...FFNDRLLYF MODU_DROME/177-246 VFVTNL......PNEYLHKDLVALFA.....K.FGRL..SALQRFTN................LNGNKSVLIAFDTSTGAEAVLQAKPKAL...TLGDNVLSV MODU_DROME/260-326 VVVGLI......GPNITKDDLKTFFE.....K.VAPV..EAVTISSN.................RLMPRAFVRLASVDDIPKALK.LHS.T...ELFSRFITV MODU_DROME/342-410 LVVENVG....KHESYSSDALEKIFK.....K.FGDV..EEIDVVC..................SKAVLAFVTFKQSDAATKALAQLDG.K...TVNKFEWKL MODU_DROME/422-484 ILVTNL......TSDATEADLRKVFN.....D.SGEI..ESIIMLG.....................QKAVVKFKDDEGFCKSFL.ANE.S...IVNNAPIFI MSSP_HUMAN/31-102 LYIRGL......PPHTTDQDLVKLCQ.....P.YGKI..VSTKAILD.............KTTNKCKGYGFVDFDSPAAAQKAVSALKA.S...GVQAQKAKQ NAM8_YEAST/165-237 IFVGDL......APNVTESQLFELFI.....NRYAST..SHAKIVHD.............QVTGMSKGYGFVKFTNSDEQQLALSEMQG.V...FLNGRAIKV NONA_DROME/304-369 LYVGNL......TNDITDDELREMFK.....P.YGEI..SEIFSNLD...................KNFTFLKVDYHPNAEKAKRALDG.S...MRKGRQLRV NONA_DROME/378-448 LRVSNL......TPFVSNELLYKSFE.....I.FGPI..ERASITVD..............DRGKHMGEGIVEFAKKSSASACLRMCNE.K...CFFLTASLR NOP3_YEAST/127-190 LFVRPF......PLDVQESELNEIFG.....P.FGPM..KEVKILN.....................GFAFVEFEEAESAAKAIEEVHG.K...SFANQPLEV NOP3_YEAST/202-270 ITMKNL......PEGCSWQDLKDLAR.....E.NSLE..TTFSSVN................TRDFDGTGALEFPSEEILVEALERLNN.I...EFRGSVITV NOP4_YEAST/28-98 LFVRSI......PQDVTDEQLADFFS.....N.FAPI..KHAVVVKD..............TNKRSRGFGFVSFAVEDDTKEALAKARK.T...KFNGHILRV NOP4_YEAST/292-363 VFVRNV......PYDATEESLAPHFS.....K.FGSV..KYALPVID.............KSTGLAKGTAFVAFKDQYTYNECIKNAPA.A...GSTSLLIGD NSR1_YEAST/170-241 IFVGRL......SWSIDDEWLKKEFE.....H.IGGV..IGARVIYE.............RGTDRSRGYGYVDFENKSYAEKAIQEMQG.K...EIDGRPINC NSR1_YEAST/269-340 LFLGNL......SFNADRDAIFELFA.....K.HGEV..VSVRIPTH.............PETEQPKGFGYVQFSNMEDAKKALDALQG.E...YIDNRPVRL NUCL_CHICK/283-352 LFVKNL......TPTKDYEELRTAIK.....EFFGKK...NLQVSEV..............RIGSSKRFGYVDFLSAEDMDKALQ.LNG.K...KLMGLEIKL PABP_DROME/4-75 LYVGDL......PQDVNESGLFDKFS.....S.AGPV..LSIRVCRD.............VITRRSLGYAYVNFQQPADAERALDTMNF.D...LVRNKPIRI PABP_DROME/92-162 VFIKNL......DRAIDNKAIYDTFS.....A.FGNI..LSCKVATD..............EKGNSKGYGFVHFETEEAANTSIDKVNG.M...LLNGKKVYV PABP_DROME/183-254 VYVKNF......TEDFDDEKLKEFFE.....P.YGKI..TSYKVMS..............KEDGKSKGFGFVAFETTEAAEAAVQALNGKD...MGEGKSLYV PABP_SCHPO/249-319 VYIKNL......DTEITEQEFSDLFG.....Q.FGEI..TSLSLVKD..............QNDKPRGFGFVNYANHECAQKAVDELND.K...EYKGKKLYV PES4_YEAST/93-164 LFIGDL......HETVTEETLKGIFK.....K.YPSF..VSAKVCLD.............SVTKKSLGHGYLNFEDKEEAEKAMEELNY.T...KVNGKEIRI PES4_YEAST/305-374 IFIKNL......PTITTRDDILNFFS.....E.VGPI..KSIYLSN...............ATKVKYLWAFVTYKNSSDSEKAIKRYNN.F...YFRGKKLLV PR24_YEAST/43-111 VLVKNL......PKSYNQNKVYKYFK.....H.CGPI..IHVDVAD...............SLKKNFRFARIEFARYDGALAAIT.KTH.K...VVGQNEIIV PR24_YEAST/119-190 LWMTNF......PPSYTQRNIRDLLQ.....D.INVV.ALSIRLPSL..............RFNTSRRFAYIDVTSKEDARYCVEKLNG.L...KIEGYTLVT PR24_YEAST/212-284 IMIRNL.....STELLDENLLRESFE.....G.FGSI..EKINIPAG............QKEHSFNNCCAFMVFENKDSAERALQ.MNR.S...LLGNREISV PSF_HUMAN/373-443 LSVRNL......SPYVSNELLEEAFS.....Q.FGPI..ERAVVIVD..............DRGRSTGKGIVEFASKPAARKAFERCSE.G...VFLLTTTPR PTB_HUMAN/61-128 IHIRKL......PIDVTEGEVISLGL.....P.FGKV..TNLLMLKG...................KNQAFIEMNTEEAANTMVN.YYT.SVTPVLRGQPIYI PTB_HUMAN/186-253 IIVENL......FYPVTLDVLHQIFS.....K.FGTV....LKIIT...............FTKNNQFQALLQYADPVSAQHAKLSLDG.Q...NIYNACCTL PUB1_YEAST/76-146 LYVGNL......DKAITEDILKQYFQ.....V.GGPI..ANIKIMID..............KNNKNVNYAFVEYHQSHDANIALQTLNG.K...QIENNIVKI PUB1_YEAST/163-234 LFVGDL......NVNVDDETLRNAFK.....D.FPSY..LSGHVMWD.............MQTGSSRGYGFVSFTSQDDAQNAMDSMQG.Q...DLNGRPLRI PUB1_YEAST/342-407 AYIGNI......PHFATEADLIPLFQ.....N.FGFI..LDFKHYPE...................KGCCFIKYDTHEQAAVCIVALAN.F...PFQGRNLRT RB97_DROME/34-104 LFIGGL......APYTTEENLKLFYG.....Q.WGKV..VDVVVMRD.............AATKRSRGFGFITYTKSLMVDRAQE..NRPH...IIDGKTVEA RN12_YEAST/200-267 IVIKFQ......GPALTEEEIYSLFR.....R.YGTI....IDIFP...............PTAANNNVAKVRYRSFRGAISAKNCVSG.I...EIHNTVLHI RN15_YEAST/20-91 VYLGSI......PYDQTEEQILDLCS.....N.VGPV..INLKMMFD.............PQTGRSKGYAFIEFRDLESSASAVRNLNG.Y...QLGSRFLKC RNP1_YEAST/37-109 LYVGNL......PKNCRKQDLRDLFE.....PNYGKI..TINMLKKK.............PLKKPLKRFAFIEFQEGVNLKKVKEKMNG.K...IFMNEKIVI RO28_NICSY/99-170 LFVGNL......PYDIDSEGLAQLFQ.....Q.AGVV..EIAEVIYN.............RETDRSRGFGFVTMSTVEEADKAVELYSQ.Y...DLNGRLLTV RO33_NICSY/116-187 LYVGNL......PFSMTSSQLSEIFA.....E.AGTV..ANVEIVYD.............RVTDRSRGFAFVTMGSVEEAKEAIRLFDG.S...QVGGRTVKV RO33_NICSY/219-290 LYVANL......SWALTSQGLRDAFA.....D.QPGF..MSAKVIYD.............RSSGRSRGFGFITFSSAEAMNSALDTMNE.V...ELEGRPLRL ROA1_BOVIN/106-176 IFVGGI......KEDTEEHHLRDYFE.....Q.YGKI..EVIEIMTD.............RGSGKKRGFAFVTFDDHDSVDKIVI.QKY.H...TVNGHNCEV ROC_HUMAN/18-82 VFIGNL.....NTLVVKKSDVEAIFS.....K.YGKI..VGCSVHK.....................GFAFVQYVNERNARAAVAGEDG.R...MIAGQVLDI ROF_HUMAN/113-183 VRLRGL......PFGCTKEEIVQFFS.....G.LEIV.PNGITLPVD..............PEGKITGEAFVQFASQELAEKALG.KHK.E...RIGHRYIEV ROG_HUMAN/10-81 LFIGGL......NTETNEKALEAVFG.....K.YGRI..VEVLLMKD.............RETNKSRGFAFVTFESPADAKDAARDMNG.K...SLDGKAIKV RT19_ARATH/33-104 LYIGGL......SPGTDEHSLKDAFS.....S.FNGV..TEARVMTN.............KVTGRSRGYGFVNFISEDSANSAISAMNG.Q...ELNGFNISV RU17_DROME/104-175 LFIARI......NYDTSESKLRREFE.....F.YGPI..KKIVLIHD.............QESGKPKGYAFIEYEHERDMHAAYKHADG.K...KIDSKRVLV RU1A_HUMAN/12-84 IYINNLNE..KIKKDELKKSLYAIFS.....Q.FGQI..LDILVSR................SLKMRGQAFVIFKEVSSATNALRSMQG.F...PFYDKPMRI RU1A_HUMAN/210-276 LFLTNL......PEETNELMLSMLFN.....Q.FPGF..KEVRLVPG..................RHDIAFVEFDNEVQAGAARDALQG.F...KITQNNAMK RU1A_YEAST/229-293 LLIQNL......PSGTTEQLLSQILG.....N.EALV...EIRLVSV...................RNLAFVEYETVADATKIKNQLGS.T...YKLQNNDVT RU2B_HUMAN/9-81 IYINNMND..KIKKEELKRSLYALFS.....Q.FGHV..VDIVALK................TMKMRGQAFVIFKELGSSTNALRQLQG.F...PFYGKPMRI RU2B_HUMAN/153-220 LFLNNL......PEETNEMMLSMLFN.....Q.FPGF..KEVRLVPG..................RHDIAFVEFENDGQAGAARDALQGFK...ITPSHAMKI SC35_CHICK/16-87 LKVDNL......TYRTSPDTLRRVFE.....K.YGRV..GDVYIPRD.............RYTKESRGFAFVRFHDKRDAEDAMDAMDG.A...VLDGRELRV SP33_HUMAN/17-85 IYVGNL......PPDIRTKDIEDVFY.....K.YGAI..RDIDLKNR................RGGPPFAFVEFEDPRDAEDAVYGRDG.Y...DYDGYRLRV SP33_HUMAN/122-186 VVVSGL......PPSGSWQDLKDHMR.....E.AGDV..CYADVYRD....................GTGVVEFVRKEDMTYAVRKLDN.T...KFRSHEGET SQD_DROME/58-128 LFVGGL......SWETTEKELRDHFG.....K.YGEI..ESINVKTD.............PQTGRSRGFAFIVFTNTEAIDKVSA.ADE.H...IINSKKVDP SQD_DROME/138-208 IFVGGL......TTEISDEEIKTYFG.....Q.FGNI..VEVEMPLD.............KQKSQRKGFCFITFDSEQVVTDLLK.TPK.Q...KIAGKEVDV SR55_DROME/5-68 VYVGGL......PYGVRERDLERFFK.....G.YGRT..RDILIKN.....................GYGFVEFEDYRDADDAVYELNG.K...ELLGERVVV SSB1_YEAST/39-114 IFIGNV......AHECTEDDLKQLFV.....EEFGDE..VSVEIPIK..........EHTDGHIPASKHALVKFPTKIDFDNIKENYDT.K...VVKDREIHI SXLF_DROME/127-198 LIVNYL......PQDMTDRELYALFR.....A.IGPI..NTCRIMRD.............YKTGYSFGYAFVDFTSEMDSQRAIKVLNG.I...TVRNKRLKV SXLF_DROME/213-285 LYVTNL......PRTITDDQLDTIFG.....K.YGSI..VQKNILRD.............KLTGRPRGVAFVRYNKREEAQEAISALNNVI...PEGGSQPLS TIA1_HUMAN/9-78 LYVGNL......SRDVTEALILQLFS.....Q.IGPC..KNCKMIMD...............TAGNDPYCFVEFHEHRHAAAALAAMNG.R...KIMGKEVKV TIA1_HUMAN/97-168 VFVGDL......SPQITTEDIKAAFA.....P.FGRI..SDARVVKD.............MATGKSKGYGFVSFFNKWDAENAIQQMGG.Q...WLGGRQIRT TIA1_HUMAN/205-270 VYCGGV......TSGLTEQLMRQTFS.....P.FGQI..MEIRVFPD...................KGYSFVRFNSHESAAHAIVSVNG.T...TIEGHVVKC TRA2_DROME/99-170 IGVFGL......NTNTSQHKVRELFN.....K.YGPI..ERIQMVID.............AQTQRSRGFCFIYFEKLSDARAAKDSCSG.I...EVDGRRIRV U2AF_HUMAN/261-332 LFIGGL......PNYLNDDQVKELLT.....S.FGPL..KAFNLVKD.............SATGLSKGYAFCEYVDINVTDQAIAGLNG.M...QLGDKKLLV U2AF_SCHPO/312-383 IYISNL......PLNLGEDQVVELLK.....P.FGDL..LSFQLIKN.............IADGSSKGFCFCEFKNPSDAEVAISGLDG.K...DTYGNKLHA U2AG_HUMAN/67-142 CAVSDVEM..QEHYDEFFEEVFTEME.....EKYGEV..EEMNVCDN..............LGDHLVGNVYVKFRREEDAEKAVIDLNN.R...WFNGQPIHA WHI3_YEAST/540-614 LYVGNL......PSDATEQELRQLFS.....G.QEGF..RRLSFRNK..........NTTSNGHSHGPMCFVEFDDVSFATRALAELYG.R...QLPRSTVSS X16_HUMAN/12-78 VYVGNL......GNNGNKTELERAFG.....Y.YGPL..RSVWVARN..................PPGFAFVEFEDPRDAADAVRELDG.R...TLCGCRVRV YHC4_YEAST/348-415 IFVGQL......DKETTREELNRRFS.....T.HGKI..QDINLIFK.................PTNIFAFIKYETEEAAAAALESENH.A...IFLNKTMHV YHH5_YEAST/315-384 ILVKNL......PSDTTQEEVLDYFS.....T.IGPI..KSVFISEK...............QANTPHKAFVTYKNEEESKKAQKCLNK.T...IFKNHTIWV YIS1_YEAST/66-136 IFVGNI......TPDVTPEQIEDHFK.....D.CGQI..KRITLLYD.............RNTGTPKGYGYIEFESPAYREKALQ.LNG.G...ELKGKKIAV YIS5_YEAST/33-104 IYIGNL......NRELTEGDILTVFS.....E.YGVP..VDVILSRD.............ENTGESQGFAYLKYEDQRSTILAVDNLNG.F...KIGGRALKI ARP2_PLAFA/364-438 VEVTYLF....STYLVNGQTL..IYS.....N.ISVV....LVILY........HQKFKETVLGRNSGFGFVSYDNVISAQHAIQFMNG.Y...FVNNKYLKV CABA_MOUSE/77-147 MFVGGL......SWDTSKKDLKDYFT.....K.FGEV..VDCTIKMD.............PNTGRSRGFGFILFKDSSSVEKVLD.QKE.H...RLDGRVIDP CABA_MOUSE/161-231 IFVGGL......NPEATEEKIREYFG.....Q.FGEI..EAIELPID.............PKLNKRRGFVFITFKEEDPVKKVLE.KKF.H...TVSGSKCEI CPO_DROME/453-526 LFVSGL......PMDAKPRELYLLFR.....A.YEGY..EGSLLKV............TSKNGKTASPVGFVTFHTRAGAEAAKQDLQGVR...FDPDMPQTI CST2_HUMAN/18-89 VFVGNI......PYEATEEQLKDIFS.....E.VGPV..VSFRLVYD.............RETGKPKGYGFCEYQDQETALSAMRNLNG.R...EFSGRALRV D111_ARATH/281-360 LLLRNMVG.PGQVDDELEDEVGGECA.....K.YGTV..TRVLIFE..........ITEPNFPVHEAVRIFVQFSRPEETTKALVDLDG.R...YFGGRTVRA ELAV_DROME/250-322 LYVSGL......PKTMTQQELEAIFA.....P.FGAI..ITSRILQN............AGNDTQTKGVGFIRFDKREEATRAIIALNG.T...TPSSCTDPI ELAV_DROME/404-475 IFIYNL......APETEEAALWQLFG.....P.FGAV..QSVKIVKD.............PTTNQCKGYGFVSMTNYDEAAMAIRALNG.Y...TMGNRVLQV EWS_HUMAN/363-442 IYVQGL......NDSVTLDDLADFFK.....Q.CGVV..K.MNKRTG....QPMIHIYLDKETGKPKGDATVSYEDPPTAKAAVEWFDG.K...DFQGSKLKV GBP2_YEAST/124-193 IFVRNL......TFDCTPEDLKELFG.....T.VGEV..VEADIIT...............SKGHHRGMGTVEFTKNESVQDAISKFDG.A...LFMDRKLMV GBP2_YEAST/221-291 VFIINL......PYSMNWQSLKDMFK.....E.CGHV..LRADVELD..............FNGFSRGFGSVIYPTEDEMIRAIDTFNG.M...EVEGRVLEV GBP2_YEAST/351-421 IYCSNL......PFSTARSDLFDLFG.....P.IGKI..NNAELKP..............QENGQPTGVAVVEYENLVDADFCIQKLNN.Y...NYGGCSLQI BioPerl-1.6.923/examples/Bio-DB-GFF000755000765000024 012254227327 16517 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/Bio-DB-GFF/load_ucsc.pl000555000765000024 3566012254227327 21202 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl use strict; use enum qw(:u_ refmethod refsource refgroup refseq refstart refstop refscore refstrand refphase qrystart qrystop sizes starts); use enum qw(:v_ refmethod refsource refgroup refseq refstrand refscore refphase txstart txstop cdsstart cdsstop exonstarts exonstops); use enum qw(:all_bacends__ x matches misMatches repMatches nCount qNumInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:all_est__ bin matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:all_mrna__ bin matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:all_sts_primer__ matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:all_sts_seq__ matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:bacEndPairs__ bin chrom chromStart chromEnd name score strand pslTable lfCount lfStarts lfSizes lfNames); use enum qw(:blatFish__ bin matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:gap__ bin chrom chromStart chromEnd ix n size type bridge); use enum qw(:gl__ bin frag start end strand); use enum qw(:gold__ bin chrom chromStart chromEnd ix type frag fragStart fragEnd strand); use enum qw(:intronEst__ bin matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:mrna__ bin matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:rmsk__ bin swScore milliDiv milliDel milliIns genoName genoStart genoEnd genoLeft strand repName repClass repFamily repStart repEnd repLeft id); use enum qw(:clonePos__ name seqSize phase chrom chromStart chromEnd stage faFile); use enum qw(:ctgPos__ contig size chrom chromStart chromEnd); use enum qw(:cytoBand__ chrom chromStart chromEnd name gieStain); use enum qw(:fishClones__ chrom chromStart chromEnd name score placeCount bandStarts bandEnds labs placeType accCount accNames stsCount stsNames beCount beNames); use enum qw(:gcPercent__ chrom chromStart chromEnd name gcPpt); use enum qw(:genscan__ name chrom strand txStart txEnd cdsStart cdsEnd exonCount exonStarts exonEnds); use enum qw(:genscanSubopt__ bin chrom chromStart chromEnd name score strand); use enum qw(:jaxOrtholog__ humanSymbol humanBand mgiId mouseSymbol mouseChr mouseCm mouseBand); use enum qw(:refGene__ name chrom strand txStart txEnd cdsStart cdsEnd exonCount exonStarts exonEnds); use enum qw(:refLink__ name product mrnaAcc protAcc geneName prodName locusLinkID omimId); use enum qw(:refSeqAli__ bin matches misMatches repMatches nCount qNumInsert qBaseInsert tNumInsert tBaseInsert strand qName qSize qStart qEnd tName tSize tStart tEnd blockCount blockSizes qStarts tStarts); use enum qw(:simpleRepeat__ bin chrom chromStart chromEnd name period copyNum consensusSize perMatch perIndel score A C G T entropy sequence); use enum qw(:stsAlias__ alias identNo trueName); use enum qw(:stsInfo__ identNo name gbCount genbank gdbCount gdb nameCount otherNames dbSTSid otherDbstsCount otherDbSTS leftPrimer rightPrimer distance organism sequence otherUCSCcount otherUCSC mergeUCSCcount mergeUCSC genethonName genethonChr genethonPos genethonLOD marshfieldName marshfieldChr marshfieldPos marshfieldLOD wiyacName wiyacChr wiyacPos wiyacLOD wirhName wirhChr wirhPos wirhLOD gm99gb4Name gm99gb4Chr gm99gb4Pos gm99gb4LOD gm99g3Name gm99g3Chr gm99g3Pos gm99g3LOD tngName tngChr tngPos tngLOD); use enum qw(:stsMap__ chrom chromStart chromEnd name score identNo ctgAcc otherAcc genethonChrom genethonPos marshfieldChrom marshfieldPos gm99Gb4Chrom gm99Gb4Pos shgcTngChrom shgcTngPos shgcG3Chrom shgcG3Pos wiYacChrom wiYacPos wiRhChrom wiRhPos fishChrom beginBand endBand lab); use enum qw(:uniGene_2__ bin chrom chromStart chromEnd name score strand txStart txEnd reserved exonCount exonStarts exonEnds); ############################################### # end enum ############################################### my %parentpos; my %nolandmark = map {$_=>1} qw(gap cpgIsland recombRate_decode recombRate_marshfield recombRate_genethon humMusL zoom1_humMusL zoom50_humMusL zoom2500_humMusL genscanSubopt simpleRepeat snpNih snpTsc ); foreach my $filename (@ARGV){ my $newfilename = $filename; $newfilename =~ s/txt\.gz/gff/; open(my $fhi, "zcat $filename |"); open(my $fho, ">$newfilename"); while(my $line = <$fhi>){ #these three should work the same way as unigene, but the fields are different order # $filename =~ /affyRatio/ ? toGFF($line,$fho,['affyRatio', '', 3, 0, 1, 2, 4, 5,-1,-1,-1,10,11]) : # $filename =~ /nci60/ ? toGFF($line,$fho,['nci60', '', 3, 0, 1, 2, 4, 5,-1,-1,-1,10,11]) : # $filename =~ /rnaCluster/ ? toGFF($line,$fho,['rnaCluster', '', 4, 1, 2, 3, 5, 6,-1, 7, 8,11,12]) : #these two are not yet handled # $filename =~ /cpgIsland/ ? toGFF($line,$fho,['cpgIsland', '', 3, 0, 1, 2,-1,-1,-1]) : # $filename =~ /estOrientInfo/ ? toGFF($line,$fho,['estOrientInfo', '',]) : $filename =~ /uniGene_2/ ? toGFF($line,$fho,['uniGene_2', '', 4, 1, 2, 3, 5, 6,-1,-1,-1,11,12]) : $filename =~ /all_bacends/ ? toGFF($line,$fho,['bacends', '', 9,13,15,16,-1, 8,-1,11,12,18,20]) : $filename =~ /all_est/ ? toGFF($line,$fho,['est', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /all_mrna/ ? toGFF($line,$fho,['mrna', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /all_sts_primer/ ? toGFF($line,$fho,['sts_primer', '', 9,13,15,16,-1, 8,-1,11,12,18,20]) : $filename =~ /all_sts_seq/ ? toGFF($line,$fho,['sts_seq', '', 9,13,15,16,-1, 8,-1,11,12,18,20]) : $filename =~ /blastzBestMouse/ ? toGFF($line,$fho,['blastzBestMouse', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /blastzMm2/ ? toGFF($line,$fho,['blastzMm2', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /blastzTightMouse/ ? toGFF($line,$fho,['blastzTightMouse', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /blatFish/ ? toGFF($line,$fho,['blatFish', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /chimpBac/ ? toGFF($line,$fho,['chimpBac', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /chimpBlat/ ? toGFF($line,$fho,['chimpBlat', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /clonePos/ ? toGFF($line,$fho,['clonePos', '', 0, 3, 4, 5,-1,-1, 2]) : $filename =~ /ctgPos/ ? toGFF($line,$fho,['ctgPos', '', 0, 2, 3, 4,-1,-1,-1]) : $filename =~ /cytoBand/ ? toGFF($line,$fho,['cytoBand', '', 3, 0, 1, 2,-1,-1,-1]) : $filename =~ /est/ ? toGFF($line,$fho,['est', '',10,14,16,17,-1,9,-1,12,13,19,21]) : $filename =~ /fishClones/ ? toGFF($line,$fho,['fishClones', '', 3, 0, 1, 2, 4,-1,-1]) : $filename =~ /gap/ ? toGFF($line,$fho,['gap', '', 7, 1, 2, 3,-1,-1,-1]) : $filename =~ /gcPercent/ ? toGFF($line,$fho,['gcPercent', '', 3, 0, 1, 2, 4,-1,-1]) : $filename =~ /genMapDb/ ? toGFF($line,$fho,['genMapDb', '', 3, 0, 1, 2, 4, 5,-1]) : $filename =~ /genscanSubopt/ ? toGFF($line,$fho,['genscanSubopt', '', 4, 1, 2, 3, 5, 6,-1]) : $filename =~ /gold/ ? toGFF($line,$fho,['gold', '', 6, 1, 2, 3,-1, 9,-1, 7, 8]) : $filename =~ /intronEst/ ? toGFF($line,$fho,['intron_est', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /recombRate/ ? eval { toGFF($line,$fho,['recombRate_decode', '', 3, 0, 1, 2, 4,-1,-1]); toGFF($line,$fho,['recombRate_marshfield', '', 3, 0, 1, 2, 7,-1,-1]); toGFF($line,$fho,['recombRate_genethon', '', 3, 0, 1, 2,10,-1,-1]); } : $filename =~ /refSeqAli/ ? toGFF($line,$fho,['refSeqAli', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /rmsk/ ? toGFF($line,$fho,['rmsk', '',10, 5, 6, 7,-1, 9,-1,13,14]) : $filename =~ /simpleRepeat/ ? toGFF($line,$fho,['simpleRepeat', '', 4, 1, 2, 3,10,-1,-1]) : $filename =~ /snpNih/ ? toGFF($line,$fho,['snpNih', '', 4, 1, 2, 3]) : $filename =~ /snpTsc/ ? toGFF($line,$fho,['snpTsc', '', 4, 1, 2, 3]) : $filename =~ /stsMap/ ? toGFF($line,$fho,['stsMap', '', 3, 0, 1, 2, 4,-1,-1]) : $filename =~ /xenoEst/ ? toGFF($line,$fho,['xenoEst', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /xenoMrna/ ? toGFF($line,$fho,['xenoMrna', '',10,14,16,17,-1, 9,-1,12,13,19,21]) : $filename =~ /zoom1_humMusL/ ? toGFF($line,$fho,['zoom1_humMusL', '', 4, 1, 2, 3, 5, 6,-1]) : $filename =~ /zoom2500_humMusL/ ? toGFF($line,$fho,['zoom2500_humMusL', '', 4, 1, 2, 3, 5, 6,-1]) : $filename =~ /zoom50_humMusL/ ? toGFF($line,$fho,['zoom50_humMusL', '', 4, 1, 2, 3, 5, 6,-1]) : $filename =~ /humMusL/ ? toGFF($line,$fho,['humMusL', '', 4, 1, 2, 3, 5, 6,-1]) : $filename =~ /(refGene|genscan|acembly|ensGene|refFlat|sanger22pseudo|sanger22|softberryGene|twinscan)/ ? toGFF2($line,$fho, [$1, -1, 0, 2, 3, -1, -1, 4, 5, 6, 7, 9, 10]) : 0; } close($fhi); close($fho); } ############################################### # begin filetype-specific subroutines ############################################### sub toGFF2 { my($line,$fho, $maps) = @_; chomp $line; my @fields = split /\t/, $line; if(!$nolandmark{render($maps->[v_refmethod],\@fields)}){ print $fho join "\t", map {render($maps->[$_],\@fields)} (v_refseq, v_refsource, v_refmethod, v_txstart, v_txstop, v_refscore, v_refstrand, v_refphase,); print $fho "\t"; print $fho "Sequence " . render($maps->[v_refgroup],\@fields); print $fho "\n"; } if(!$nolandmark{render($maps->[v_refmethod],\@fields)}){ print $fho join "\t", map {render($maps->[$_],\@fields)} (v_refseq, v_refsource, v_refmethod, v_cdsstart, v_cdsstop, v_refscore, v_refstrand, v_refphase,); print $fho "\t"; print $fho "CDS " . render($maps->[v_refgroup],\@fields); print $fho "\n"; } if(defined($maps->[v_exonstarts]) and defined($maps->[v_exonstops])){ my @starts = split /,/, render($maps->[v_exonstarts],\@fields); my @stops = split /,/, render($maps->[v_exonstops],\@fields); while(my $start = shift @starts){ my $stop = shift @stops; print $fho join "\t", (render($maps->[v_refseq],\@fields), render($maps->[v_refsource],\@fields), render($maps->[v_refmethod],\@fields), $start, $stop, render($maps->[v_refscore],\@fields), render($maps->[v_refstrand],\@fields), render($maps->[v_refphase],\@fields), render($maps->[v_refmethod],\@fields) . " " . render($maps->[v_refgroup],\@fields) ), "\n"; } } } sub toGFF { my($line,$fho, $maps) = @_; chomp $line; my @fields = split /\t/, $line; if(!$maps->[u_qrystart] and !$nolandmark{render($maps->[u_refmethod],\@fields)}){ print $fho join "\t", map {render($maps->[$_],\@fields)} (u_refseq, u_refsource, u_refmethod, u_refstart, u_refstop, u_refscore, u_refstrand, u_refphase); print $fho "\t"; print $fho "Sequence " . render($maps->[u_refgroup],\@fields); print $fho "\n"; } print $fho join "\t", map {render($maps->[$_],\@fields)} (u_refseq, u_refsource, u_refmethod, u_refstart, u_refstop, u_refscore, u_refstrand, u_refphase); print $fho "\t"; if($maps->[u_qrystart] >= 0){ print $fho "Target:" . render($maps->[u_refmethod],\@fields) . " "; print $fho render($maps->[u_refgroup],\@fields) . " " . render($maps->[u_qrystart],\@fields) . " " . render($maps->[u_qrystop], \@fields); } else { print $fho "Sequence " . render($maps->[u_refgroup],\@fields) . " "; } print $fho "\n"; if(defined($maps->[u_starts]) and defined($maps->[u_sizes])){ my @starts = split /,/, render($maps->[u_starts],\@fields); my @sizes = split /,/, render($maps->[u_sizes],\@fields); my $start; while(defined($start = shift @starts)){ my $size = shift @sizes; if($maps->[u_qrystart] < 1 and $maps->[u_qrystop] < 1){ print $fho join "\t", (render($maps->[u_refseq],\@fields), render($maps->[u_refsource],\@fields), render($maps->[u_refmethod],\@fields), render($maps->[u_refstart],\@fields) + $start, render($maps->[u_refstart],\@fields) + $start + $size, render($maps->[u_refscore],\@fields), render($maps->[u_refstrand],\@fields), render($maps->[u_refphase],\@fields), render($maps->[u_refmethod],\@fields) . " " . render($maps->[u_refgroup],\@fields) ), "\n"; } else { print $fho join "\t", (render($maps->[u_refseq],\@fields), render($maps->[u_refsource],\@fields), render($maps->[u_refmethod],\@fields), $start, $start + $size, render($maps->[u_refscore],\@fields), render($maps->[u_refstrand],\@fields), render($maps->[u_refphase],\@fields), render($maps->[u_refmethod],\@fields) . " " . render($maps->[u_refgroup],\@fields) ), "\n"; } } } } sub render { my($index,$fields) = @_; return '.' if $index == -1; return $index unless $index =~ /^\d+$/; return $fields->[$index]; } BioPerl-1.6.923/examples/cluster000755000765000024 012254227332 16600 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/cluster/dbsnp.pl000555000765000024 105612254227332 20405 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # allenday@ucla.edu # parses a dbsnp xml file, prints some info for each refsnp and subsnp use strict; use Bio::ClusterIO; use Bio::Root::IO; use IO::File; my $file = shift @ARGV; my $io = Bio::ClusterIO->new ( -tempfile => 0, -format => 'dbsnp', -fh => IO::File->new("zcat $file |"), ); while(my $cluster = $io->next_cluster){ print $cluster->id,"\t", $cluster->observed, "\n"; foreach my $subsnp ($cluster->each_subsnp){ print "\t\t\t", $subsnp->id, "\t", $subsnp->handle, "\t", $subsnp->method, "\n"; } } BioPerl-1.6.923/examples/contributed000755000765000024 012254227335 17444 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/contributed/nmrpdb_parse.pl000555000765000024 1105212254227335 22634 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl use strict; # This program will read in an NMR derived PDB file containing # multiple conformers, and will allow the user to extract either # one or all of the models to separate files. # # Although the program will run interactively, the command line # usage is "nmrsplit [input.file] [number of model to extract]" # # # # Written 13/12/00 by Simon Andrews (simon.andrews@bbsrc.ac.uk) # Submitted to bioperl script project 2001/08/06 # Description: Script which reads an NMR-derived multiple structure # PDB file, and will either extract a single structure from it, or # will extract all of the structures into single files. This is # useful when you want to work with a single representative structure # from an NMR ensemble - especially in conjunction with the OLDERADO # database (http://neon.chem.le.ac.uk/olderado/) which finds the # most representative structure from an ensemble. my $Input = $ARGV[0]; # File to be read my $Pullout = $ARGV[1]; # Specific model to extract my @Pdbfile; # Array for whole PDB file my $Header = ""; # String to hold the PDB header my $Model = ""; # String to hold individual models my $Output; # Prefix for output files my $Modno = 1; # Number of the model being processed while () { if ($Input) { if (-r $Input) { last; }else{ print "\"$Input\" does not exist, or could not be read\n"; } } print "\nEnter name of multiple PDB file: "; $Input = ; chomp $Input; $Input =~ s/^\s*//; $Input =~ s/\s*$//; next; } while () { if ($Pullout) { if ($Pullout =~ /^\d+$/){ if ($Pullout == int $Pullout) { last; }else { print "\"$Pullout\" should be an integer\n"; } }else { print "\"$Pullout\" should be a number\n"; } } print "\nEnter number of specific model to extract (Return for none): "; $Pullout = ; chomp $Pullout; $Pullout =~ s/^\s*//; $Pullout =~ s/\s*$//; last unless ($Pullout); next; } ($Output = $Input) =~ s/\.\w*$//; # Take off everything after the last . to use as prefix open (PDB,$Input) || die "Can't open $Input because $!"; ########## Read the header information #################### while () { if (/^MODEL\b/){last;} $Header = $Header . $_; } ######### Read the separate models ####################### while () { model(); if ($Model) { # Check if we're past the last model if ($Pullout) { # Check if we're writing one or all last if ($Modno > $Pullout);# No point continuing if we've got the one we want readout(); }else { writeout(); } $Model = ""; ++$Modno; }else { last; } } --$Modno; # Correct last increment which didn't find a model if (($Pullout) & ($Modno < $Pullout)) { print "\nCannot find model $Pullout : Only $Modno models in this file\n"; } #################### subroutines start here ########################## sub model { while () { if (/^(MODEL\b|END\b|MASTER\b)/){next;} # Stops you getting MODEL... at the top of the output # and makes sure there isn't a file containing just END or MASTER if (/^ENDMDL\b/){last;} # Check for the end of the model $Model = $Model . $_; # Append the line to $Model } } sub writeout { # Used when all files are being written out if (-e "$Output\_$Modno.pdb"){ # Check whether we're overwriting anything print "\n$Output\_$Modno.pdb already exists. Overwrite (y/n)? "; my $Question = ; unless ($Question =~ /^y/i) { print "\nSkipping $Output\_$Modno.pdb"; return; } } open (OUT,">$Output\_$Modno.pdb") || die "Can't open $Output\_$Modno.pdb because $!"; print "\nWriting $Output\_$Modno.pdb ..."; print OUT $Header; print OUT $Model; print OUT "END\n"; # Adds and END statement to the PDB file close OUT || die "Couldn't close $Output\_$Modno.pdb because $!"; } sub readout { if ($Modno == $Pullout) { if (-e "$Output\_$Modno.pdb") { # Check whether we're overwriting anything print "\n$Output\_$Modno.pdb already exists. Overwrite (y/n)? "; my $Question = ; unless ($Question =~ /^y/i) { print "\nModel not extracted\n"; $Model = ""; return; } } open (OUT,">$Output\_$Modno.pdb") || die "Can't open $Output\_$Modno.pdb because $!"; print "\nWriting $Output\_$Modno.pdb ...\n"; print OUT $Header; print OUT $Model; print OUT "END\n"; # Adds and END statement to the PDB file close OUT || die "Couldn't close $Output\_$Modno.pdb because $!"; $Model = ""; # Stops the reading after this model }else { print "\nReading Model $Modno ..."; } } BioPerl-1.6.923/examples/contributed/prosite2perl.pl000555000765000024 120412254227325 22567 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # prosite2perl -- convert Prosite patterns to Perl regular expressions # # Jordan Dimov (jdimov@cis.clarion.edu) # # Submitted to bioperl scripts project 2001/08/03 # # Description: # Prosite patterns to Perl regular expressions. # The prositeRegEx($) sub accepts a string # containing a Prosite pattern and returns a # string containing a valid Perl regex. The code # is self-explanatory. sub prositeRegEx($); while (<>) { chomp ($_); print prositeRegEx ($_), "\n"; } sub prositeRegEx ($) { my $regex = shift; $regex =~ s/[\-\.]//g; $regex =~ s/\{/[^/g; $regex =~ tr/x()<>}/.{}^$]/; return ($regex); } BioPerl-1.6.923/examples/contributed/rebase2list.pl000555000765000024 100612254227334 22354 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl # Generate an enzyme list for RestrictionEnzyme.pm from rebase # From Ryan Brinkman my $strider = $ARGV[0]; #commercial_version_rebase_strider_format open (FILEIN,"$strider") or die "can't open $strider: $!\n"; while (){ chomp; if ( /^[A-Z]\S+,\S+/ ){ ($enzyme,$cutsite)=split(','); if ($cutsite =~ m#/#){ $match=$-[0]; } ($seqfixed=$cutsite) =~ s/\///g; $seqfixed=uc $seqfixed; print " \'$enzyme\'\t=> \'".$seqfixed." ".$match."\'\,\n"; } } BioPerl-1.6.923/examples/db000755000765000024 012254227335 15507 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/db/dbfetch000555000765000024 4437012254227313 17215 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl -- # -*-Perl-*- =head1 NAME dbfetch - generic CGI program to retrieve biological database entries in various formats and styles (using SRS) =head1 SYNOPSIS # URL examples: # prints the interactive page with the HTML form http://www.ebi.ac.uk/Tools/dbfetch/dbfetch # for backward compatibility, implements # single entry queries defaulting to EMBL sequence database http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?J00231 # retrieves one or more entries in default format # and default style (html) # returns nothing for IDs which are not valid http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?id=J00231.1,hsfos,bum # retrieve entries in fasta format without html tags http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?format=fasta&style=raw&id=J00231,hsfos,bum # retrieve a raw Ensembl entry http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?db=ensembl&style=raw&id=AL122059 =head1 DESCRIPTION This program generates a page allowing a web user to retrieve database entries from a local SRS in two styles: html and raw. Other database engines can be used to implement te same interfase. At this stage, on unique identifier queries are supported. Free text searches returning more than one entry per query term are not in these specs. In its default setup, type one or more EMBL accession numbers (e.g. J00231), entry name (e.g. BUM) or sequence version into the seach dialog to retieve hypertext linked enties. Note that for practical reasons only the first 50 identifiers submitted are processed. Additional input is needed to change the sequence format or suppress the HTML tags. The styles are html and raw. In future there might be additional styles (e.g. xml). Currently XML is a 'raw' format used by Medline. Each style is implemented as a separate subroutine. =head1 MAINTANENCE A new database can be added simply by adding a new entry in the global hash %IDS. Additionally, if the database defines new formats add an entry for each of them into the hash %IDMATCH. After modifying the hash, run this script from command line for some sanity checks with parameter debug set to true (e.g. dbfetch debug=1 ). Finally, the user interface needs to be updated in the L subroutine. =head1 VERSIONS Version 3 uses EBI SRS server 6.1.3. That server is able to merge release and update libraries automatically which makes this script simpler. The other significant change is the way sequence versions are indexed. They used to be indexed together with the string accession (e.g. 'J00231.1'). Now they are indexed as integers (e.g. '1'). Version 3.1 changes the command line interface. To get the debug information use attribute 'debug' set to true. Also, it uses File::Temp module to create temporary files securely. Version 3.2 fixes fasta format parsing to get the entry id. Version 3.3. Adds RefSeq to the database list. Version 3.4. Make this compliant to BioFetch specs. =head1 AUTHOR - Heikki Lehvaslaiho Email: heikki-at-bioperl-dot-org =cut # Let the code begin... $VERSION = '3.4'; $DATE = '28 Jan 2002'; use CGI "standard"; #use POSIX; use CGI::Carp qw/ fatalsToBrowser /; use File::Temp qw/ tempfile tempdir /; use strict; no strict "refs"; use constant MAXIDS => 50; use constant TMPDIR => '/usr/tmp'; use vars qw( $VERSION $DATE %DBS %STYLES $RWGETZ $RGETZ %IDMATCH %IDLIST $XEMBL $FH ); BEGIN { # paths to SRS binaries $RWGETZ = '/ebi/srs/srs/bin/osf_5/wgetz -e'; $RGETZ = '/ebi/srs/srs/bin/osf_5/getz -e'; $XEMBL = "cd /ebi/www/pages/cgi-bin/xembl/; ./XEMBL.pl"; #$EMBOSSDIR = '/ebi/services/pkgs/emboss/bin'; # RE matching the unique ID in the db entry # - key is the # - put the id string in parenthesis %IDMATCH = ( # 123 embl => 'ID (\w+)', fasta => '>\w+.(\w+)', medlinefull => '[\n><]MedlineID. ?(\w+)', swissprot => 'ID (\w+)', pdb => '.{62}(\w+)', bsml => 'DUMMY', agave => 'DUMMY', refseq => 'LOCUS ([\w_]+)' ); %DBS = ( embl => { fields => ['id', 'acc'], version => 'sv', # name of the SRS field format => { default => 'embl', embl => 1, fasta => 'FastaSeqs', bsml => 1, agave => 1 } }, medline => { fields => ['id'], format => { default => 'medlinefull', # medlineref => 'MedlineRef', medlinefull => 'MedlineFull' } }, ensembl => { fields => ['id'], format => { default => 'embl', embl => 1, fasta => 'FastaSeqs' } }, swall => { fields => ['id', 'acc'], format => { default => 'swissprot', swissprot => 1, fasta => 'FastaSeqs' } }, pdb => { fields => ['id'], format => { default => 'pdb', pdb => '1' } }, refseq => { fields => ['id', 'acc'], format => { default => 'refseq', refseq => 1, fasta => 'FastaSeqs' } } #add more databases here... ); %STYLES = ( html => 1, raw => 1 ); %IDLIST = (); #redundancy check list built during the execution } my $q = new CGI; # sanity checks if the script is running from command line # and debug parameter is set. my $debug = protect($q->param('debug')) if $q->param('debug'); &debugging if not $q->user_agent and $debug; if ( $q->param('id') or $q->param('keywords') ) { # pacify input strings my $value; $value = protect($q->param('id')) if $q->param('id'); $value = protect($q->param('keywords')) if $q->param('keywords'); my $db = lc protect($q->param('db')); # let's keep the case lower my $format = lc protect($q->param('format')); my $style = lc protect($q->param('style')); # check input and set defaults $style ||= 'html'; # default style input_error($q, $style, "2 Unknown style [$style].") unless $STYLES{$style}; $db ||= 'embl'; # default db input_error($q, $style, "1 Unknown database [$db].") unless $DBS{$db}; $format ||= $DBS{$db}{format}{default}; # default format input_error($q, $style, "3 Format [$format] not known for database [$db]") unless $DBS{$db}{format}{$format}; $format = $DBS{$db}{format}{default} if $format eq 'default'; # If people choose Bsml or AGAVE, DB can only be 'embl' input_error($q, $style, "1 Unknown database [$db].") if ($format eq 'bsml' or $format eq 'agave') and $db ne 'embl'; # If people choose Bsml or AGAVE, internal style has to be xml . Make it so. $style = ($format =~ /(bsml|agave)/i) ? 'xml' : $style; if ($style eq 'html') { print $q->header(-type => 'text/html', -charset => 'UTF-8'); } elsif ($style eq 'raw') { print "Content-Type: text/plain; charset=UTF-8\n\n"; } $FH = tempfile('dbfetchXXXXXX', DIR => TMPDIR, UNLINK => 1 ); #automatic unlinking # Check the number of IDs my @ids = split (/ /, $value); input_error($q, $style, "6 Too many IDs [". scalar @ids. "]. Max [". MAXIDS. "] allowed.") if scalar @ids > MAXIDS; # XEMBL cannot 'glue' single entries due to XML setup #- we need to send things in one go. if ($style eq 'xml') { &xml($format, @ids); } else { my $counter; foreach my $id (@ids) { &$style($db, $id, $format); } no_entries($q, $value) if $style eq 'html' and tell($FH) == 0; } seek $FH, 0, 0; print '
' if $style eq 'html';
    print $_ while <$FH>;
} else {
    print_prompt($q);
}


=head2 print_prompt

 Title   : print_prompt
 Usage   :
 Function: Prints the default page with the query form
           to STDOUT (Web page)
 Args    :
 Returns :

=cut

sub print_prompt {
    print $q->header(),
         $q->start_html(-title => 'DB Entry Retrieval',
                        -bgcolor => 'white',
			-author => 'heikki-at-bioperl-dot-org'
			),
	 '',
	  $q->h1('Generic DB Entry Retrieval'),
	  $q->p("This page allows you to retrieve up to ". MAXIDS .
		 " entries at the time from various up-to-date biological databases."),
	  $q->p("For EMBL, enter an  accession number (e.g. J00231) or entry name (e.g.
		 BUM) or a sequence version (e.g. J00231.1), or any combination of them
		 separated by a non-word character into your browser's search dialog.
		 SWALL examples are: fos_human, p53_human.
		 For short Ensembl entries, try : AL122059, AL031002, AL031030 .
		 'Random' Medline entry examples are: 20063307, 98276153.
		 PDB entry examples are: 100D, 1FOS. Try NM_006732 for RefSeq.
		 Only one copy of the latest version of the entry is returned."),
	  $q->hr,
	  $q->startform,
	  $q->popup_menu(-name => 'db',
			 -values => ['EMBL',
				     'SWALL',
				     'PDB',
				     'Medline',
				     'Ensembl',
				     'RefSeq'
				     ]),
	  $q->textfield(-name => 'id',
			 -size => 40,
			 -maxlength => 1000),
	  $q->popup_menu(-name => 'format',
			 -values => ['default','Fasta','bsml','agave']),
	  $q->popup_menu(-name => 'style',
			 -values => ['html','raw']),
	  $q->submit('Retrieve'),
	  $q->endform,
	  $q->hr,
	  $q->h2('Direct access'),
	  $q->p('For backward compatibility, the script defaults to EMBL:'),
	  $q->code('
		     http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?J00231'),
	  $q->p('but the preferred way of calling it is:'),
	  $q->code('
		     http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?id=J00231.1,hsfos,bum'),
	  $q->p('which can be extended to retrieve entries in alternative sequence formats
		      and other databases:'),
	  $q->code('
		     http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?db=swall&format=fasta&id=fos_human'),
	  $q->p('Set style to raw to retrieve plain text entries for computational purposes
                 and saving to disk:'),
	  $q->code('
                    http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?db=medline&style=raw&id=21131735'),
 	  $q->p('There is now the possibility to retrieve EMBL sequences formatterd into two XML standards:
                Bsml (Bioinformatic Sequence Markup Language - from 
                Labbook, Inc.) or as AGAVE (Architecture for Genomic Annotation, 
                Visualisation, and Exchange - from Labbook, Inc.). To do this, use the 
                formats \'bsml\' or \'agave\', as follows:'),
	  $q->code('
                   http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?format=bsml&id=J00231
'),
	  $q->code('
                   http://www.ebi.ac.uk/Tools/dbfetch/dbfetch?format=agave&id=J00231'),
          $q->p("Version numbers are not supported with the XML retrieval."),
	  $q->hr,
          $q->address("Version $VERSION, $DATE, support\@ebi.ac.uk"),
	  $q->end_html, "\n" ;
}

=head2 protect

 Title   : protect
 Usage   : $value = protect($q->param('id'));
 Function:

           Removes potentially dangerous characters from the input
	   string.  At the same time, converts word separators into a
	   single space character.

 Args    : scalar, string with one or more IDs or accession numbers
 Returns : scalar

=cut

sub protect {
    my ($s) = @_;
    $s =~ s![^\w\.\_]+! !g; # allow version numbers with '.' & RefSeq IDs with '_'
    $s =~ s|^\W+||;
    $s =~ s|\W+$||;
    return $s;
}

=head2 input_error

 Title   : input_error
 Usage   : input_error($q, 'html', "Error message");
 Function: Standard error message behaviour
 Args    : reference to the CGI object
           scalar, string to display on input error.
 Returns : scalar

=cut

sub input_error {
    my ($q, $style, $s) = @_;

    if ($style eq 'html' ) {
	print $q->header,
	$q->start_html(-title => 'DB Entry Retrieval: Input error', 
		       -bgcolor => 'white'
		       ),
	"
ERROR in input:
$s\n",
	$q->end_html, "\n";
    } else {
	print "Content-type: text/plain\n\n", "ERROR $s\n";
    }
    exit 0;
}

=head2 no_entries

 Title   : no_entries
 Usage   : no_entries($q, "Message");
 Function: Standard behaviour when no entries found
 Args    : reference to the CGI object
           scalar, string to display on input error.
 Returns : scalar

=cut

sub no_entries {
    my ($q, $value) = @_;

    print $q->start_html(-title => 'DB Entry Retrieval: Input warning',
			 -bgcolor => 'white'
			 ),
	  "
Sorry, your query retrieved no entries.
",
	  "Entries with [$value] where not found.",
	  "Please go back or press here to try again",
	   $q->end_html, "\n";
    exit 0;
}


=head2 raw

 Title   : raw
 Usage   :
 Function: Retrieves a single database entry in plain text
 Args    : scalar, an ID
           scaler, format
 Returns : scalar

=cut

sub raw {
    my ($db, $value, $format) = @_;
    my ($srsq, $qdb, $entry, $id);
    my ($seqformat) = '';
    $seqformat = '-view '. $DBS{$db}{format}{$format}
       if $format ne $DBS{$db}{format}{default};

    my $version = '';
    $value =~ /(.+)\.(.+)/;
    $version = $2 if $2;
    $value = $1 if $1;

    # main db
    $qdb = $db;
    $srsq = '';
    foreach my $field (@{$DBS{$db}{fields}}) {
	$srsq .= " [$qdb-$field:$value] |";
    }
    chop $srsq;

    # if database supports versions (EMBL, GenBank, RefSeq...)
    if ($version) {
	my $vfname = $DBS{$db}{version};
	$srsq = "[$qdb-$vfname:$version] & (". $srsq. ")"
    }

#    print "rsh srs $RGETZ $seqformat $srsq\n";
    $entry = `rsh srs "$RGETZ $seqformat '$srsq'"`;

    $entry =~ s|EMBL[^\n]+\n||;
    $entry =~ s|^\s+||g;
    $entry =~ s|\s+$|\n|g;

    my $idmatch = $IDMATCH{$format};
    ($id) = $entry =~ /$idmatch/;
    # die if ID not found
    input_error(' ', 'raw', "5 ID [$value] not found in database [$db].")
	     unless $id;

#    my $tmp = substr($entry, 0, 20);
#    print "Entry:$tmp\n";
#    print  "-----id=$id---\$1=$1----idmatch=$idmatch=format=$format=\n";
#
    print $FH $entry unless $IDLIST{$id};
    $IDLIST{$id} = 1;
}

=head2 html

 Title   : html
 Usage   :
 Function: Retrieves a single database entry with HTML
           hypertext links in place. Limits retieved enties to 
           ones with correct version if the string has '.' in it.
 Args    : scalar, a UID
           scalar, format
 Returns : scalar

=cut

sub html {
    my ($db, $value, $format) = @_;
    my ($srsq, $qdb, $entry, $id, $idmatch);
    my ($seqformat) = '';
    $seqformat = '-view '. $DBS{$db}{format}{$format}
       if $format ne $DBS{$db}{format}{default};

    my $version = '';
    $value =~ /(.+)\.(.+)/;
    $version = $2 if $2;
    $value = $1 if $1;

    # SWALL plain format at EBI
    $seqformat .= ' -vn 2 ' if $db eq 'swall' or $db eq 'refseq';
    
    $qdb = $db;
    $srsq = '';
    foreach my $field (@{$DBS{$db}{fields}}) {
	$srsq .= " [$qdb-$field:$value] |";
    }
    chop $srsq;

    # if database supports versions (EMBL...)
    if ($version) {
	my $vfname = $DBS{$db}{version};
	$srsq = "[$qdb-$vfname:$version] & (". $srsq. ")"
    }

#    print "rsh srs $RWGETZ $seqformat $srsq\n";
    ### '-id EBISRS' is (hopefully) a temporary addtion until SRS HTML output is fixed 
    $entry = `rsh srs "$RWGETZ $seqformat '$srsq'"`;
  
    return if $entry =~ /SRS error/;

    $entry =~ s|^Content-type:[^\n]+\n||;
    $entry =~ s|\n||g;
    $entry =~ s|||g;
    $entry =~ s|\n+|\n|g;
    $entry =~ s|^\n+||g;

    $idmatch = $IDMATCH{$format};
    ($id) = $entry =~ /$idmatch/;

#    my $tmp = substr($entry, 0, 20);
#    print "Entry:$tmp\n";
#    print  "-----id=$id---\$1=$1----idmatch=$idmatch=format=$format=\n";
    print $FH $entry unless $IDLIST{$id};
    $IDLIST{$id} = 1;
}

=head2 xml

 Title   : xml
 Usage   : 
 Function: Retrieves an entry formatted as XML
 Args    : array, UID
           scalar, format 
 Returns : scalar

=cut

sub xml {
    my ($format, @ids) = @_;
    my ($entry, $id, $content, $counter, $reg);

    $content = ($ENV{'HTTP_USER_AGENT'} =~ /MSIE/) ? "Content-type: text/xml\n\n" : 
      "Content-type: text/plain\n\n";

    $entry = "--format ".(($format eq "bsml") ? "Bsml" : "sciobj") .
	     " " . join (" ", @ids);

    $entry = `rsh mercury "$XEMBL $entry"`;

    $reg = (($format eq "bsml") ? 'tissue
my $VERBOSE = 0;# verbosity option
my $blastfile;  # blastfile to parse
my $pvalue;     # Max P-Value allowed when parsing blastfile
my $remote;     # flag for remote database 
my $db;         # generic database handle
my %accessions; # cache results
my $format = 'blast';

&GetOptions( 'd|dir:s'   => \$dir,
	     'i|index:s' => \$index,
	     'v|verbose' => \$VERBOSE,
	     'b|blast:s' => \$blastfile,
	     'f|format:s' => \$format,
	     'c|cache:s' => \$cache,
	     'p|pvalue:s'       => \$pvalue,
	     'r|remote:s'=> \$remote);

if( $cache && -w $cache ) {
    print "creating cache file\n";
    tie %accessions, "DB_File", $cache,  O_RDWR|O_CREAT,0660, $DB_HASH;
}

if( ! $remote ) {
    opendir(GBEST, $dir) or die("cannot open $dir");
    
    my $indexfile = new Bio::Index::GenBank(-filename   => $index,
					    -write_flag => 'WRITE');
    foreach my $file  ( readdir(GBEST) ) {
#	print "file is $file\n";
	    next unless ( $file =~ /(gbest\d+\.seq)(.gz)?$/ );
	    if( $2 ) {		
		`$GUNZIP $dir/$file`;
	    }
	    $indexfile->make_index("$dir/$1");
    }

    $indexfile = undef;
    $db = new Bio::Index::GenBank(-filename => $index);
    
} else { 
    if( $remote =~ /(ncbi)|(genbank)/i ) {

	$db = new Bio::DB::GenBank;
    } elsif( $remote =~ /embl/i ) {
	$db = new Bio::DB::EMBL;
    } else { 
	die("remote must be either 'NCBI' or 'EMBL'");
    }
    # would need to add code to set proxy info for those who need it
}

if(! $blastfile || ! -r $blastfile ) {
    die("Must specify a valid blastfile");
}

my $parser = new Bio::SearchIO(-format => $format,
			       -file => $blastfile);

my %tissues_seen = ();
my ($result,$hit,$hsp);
while( my $result = $parser->next_result )  {
  HIT: while( my $hit = $result->next_hit ) {
      if( defined $pvalue ) {
	  while( my $hsp = $hit->next_hsp ) {
	      if( $hsp->evalue > $pvalue ) {
		  print "skipping ", $hit->name, " because of low evalue \n";
		  # skip this Subject if it contains a pvalue of > $pvalue
		  next HIT;
	      }
	  }
      }
      my  ($id) = split(/\s+/, $hit->name);
      # get the last value
      my @ids = split(/\|/, $id);
      $id = pop @ids;
      my ($tissuetype) = get_tissue($id);
      if( defined $tissuetype ) {
	  push @{$tissues_seen{$tissuetype}}, $hit->name;
      } else { 
	  print STDERR "could not find tissue for $id\n" if( $VERBOSE);
      }
  }
  print "tissues seen for: ", $result->query_name, "\n";

  foreach my $tissue ( sort keys %tissues_seen ) {
      print "* $tissue\n-----------\n\t", 
      join("\n\t",@{$tissues_seen{$tissue}}), "\n\n";
  }
}

# cleanup -- avoid segfault here
$db = undef;

# subroutines

sub get_tissue {
    my ($id) = @_;
    my $tissue;
    if( $tissue = $accessions{$id} ) {
	return $tissue;
    }

    my $seq = $db->get_Seq_by_acc($id);
    return  unless(  $seq );

    foreach my $feature ( $seq->all_SeqFeatures ) {
	if( $feature->primary_tag eq 'source' ) {
	    foreach my $tag ( sort { $b cmp $a }
			      $feature->all_tags ) {
		if( $tag =~ /tissue/i  || 
		    ( ! $tissue && 
		      $tag =~ /clone_lib/i ) ){
		    ($tissue) = $feature->each_tag_value($tag);
		    $accessions{$seq->display_id} = $tissue;
		    return $tissue;
		}
	    }
	}
    }	    
    return;
}
BioPerl-1.6.923/examples/db/gb2features.pl000555000765000024      1231612254227317 20440 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# Author: Damien Mattei C.N.R.S / U.N.S.A - UMR 6549
# example: ./idfetch.pl AP001266

use Bio::DB::GenBank;

$gb = new Bio::DB::GenBank();

# this returns a Seq object :
$seq1 = $gb->get_Seq_by_acc($ARGV[0]);
print $seq1->display_id() . "\n" ;


foreach $feat ($seq1->all_SeqFeatures()) {

  #print $feat->primary_tag . " " . $feat->source_tag() . "\n" ;

  print "Feature from ", $feat->start, " to ",
   $feat->end, " Primary tag  ", $feat->primary_tag,
   ", produced by ", $feat->source_tag(), "\n";

  if( $feat->strand == 0 ) {
    print "Feature applicable to either strand\n";
  } else {
    print "Feature on strand ", $feat->strand,"\n"; # -1,1
  }

  foreach $tag ( $feat->all_tags() ) {
    print "Feature has tag ", $tag, " with values, ",
    join(' ',$feat->each_tag_value($tag)), "\n";
  }

  print "new feature\n" if $feat->has_tag('new');

}


exit;

__END__

It will display something like that:

[dmattei@pclgmch2 gmap]$ ./idfetch.pl AP001266
AP001266
Feature from 1 to 168978 Primary tag  source, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag chromosome with values, 11
Feature has tag map with values, 11q13
Feature has tag clone with values, RP11-770G2
Feature has tag organism with values, Homo sapiens
Feature has tag db_xref with values, taxon:9606
Feature from 1 to 31550 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 31651 to 48510 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 48611 to 64044 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 64145 to 78208 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 78309 to 89008 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 89109 to 99704 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 99805 to 107965 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 108066 to 116032 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 116133 to 124010 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 124111 to 130494 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 130595 to 136072 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 136173 to 139649 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 139750 to 144590 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 144691 to 148482 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 148583 to 152279 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 152380 to 153632 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment clone_end:T7 
vector_side:left
Feature from 153733 to 155746 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 155847 to 156405 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment clone_end:SP6 
vector_side:right
Feature from 156506 to 158398 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 158499 to 161333 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 161434 to 163304 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 163405 to 164604 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 164705 to 166693 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment
Feature from 166794 to 168978 Primary tag  misc_feature, produced by 
EMBL/GenBank/SwissProt
Feature on strand 1
Feature has tag note with values, assembly_fragment

BioPerl-1.6.923/examples/db/get_seqs.pl000555000765000024       322112254227314 20011 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl
use strict;
use vars qw($USAGE);
use Carp;
use Getopt::Long;
use Bio::SeqIO;

$USAGE = "get_seqs.pl\t[--db=DBNAME] [--format=FORMAT] \n\t\t[--output=FILENAME] [--proxy=PROXY] accession1, accession2, ...\n Defaults: db=GenBank format=fasta output=STDOUT proxy=none\n See LWP::UserAgent for more information on proxy syntax";
my %dbs = (
  'genbank'   => 'Bio::DB::GenBank',
  'embl'      => 'Bio::DB::EMBL',
  'swissprot' => 'Bio::DB::SwissProt', 
);

my ($db,$format,$file,$proxy,$help) = ( 'genbank', 'fasta' );

&GetOptions
    (
     'db:s'       => \$db,
     'f|format:s' => \$format,
     "file|out|output:s" => \$file,
     'proxy:s'           => \$proxy,
     "h|\?|help"  => \$help ,     
     );

if( $help ) { print $USAGE, "\n";exit; }

if( $db =~ /gb|gen|genbank/i ) {
    $db = 'genbank';
} elsif( $db =~ /embl|em|e/i ) {
    $db = 'embl';
} elsif( $db =~ /swiss|sp/i ) {
    $db = 'swissprot';
} else { 
    croak("Unknown db parameter '$db' valid parameters are (" . join(',', keys %dbs) . ")");
}

my %params = ( '-format' => $format );

if( defined $file ) {
    $params{'-file'} = ">$file";
} else { 
    $params{'-fh'} = \*STDOUT;
}

my $seqio = new Bio::SeqIO(%params);

my $remotedb;

eval {
    my $filename = "$dbs{$db}.pm";
    $filename =~ s!::!/!g;
    require $filename;
    $remotedb = "$dbs{$db}"->new();
};

die($@) unless ! $@;

if( defined $proxy ) { $remotedb->proxy($proxy); }

my $stream;

if( $remotedb->can('get_Stream_by_batch') ) {
    $stream = $remotedb->get_Stream_by_batch(@ARGV);
} else {
    $stream = $remotedb->get_Stream_by_acc(\@ARGV);
}

while( my $seq = $stream->next_seq ) {
    $seqio->write_seq($seq);
}
BioPerl-1.6.923/examples/db/getGenBank.pl000555000765000024       142712254227317 20215 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl
#
# How to retrieve GenBank entries over the Web
#
# by Jason Stajich
#
use Bio::DB::GenBank;
use Bio::SeqIO;
my $gb = new Bio::DB::GenBank;

# the output stream for your seqs, this can be a file
# instead or STDOUT, see the Bio::SeqIO module for info

my $seqout = new Bio::SeqIO(-fh => \*STDOUT, -format => 'fasta');

# if you want a single seq
my $seq = $gb->get_Seq_by_id('J00522');
$seqout->write_seq($seq);
# or by accession
$seq = $gb->get_Seq_by_acc('AF303112');

$seqout->write_seq($seq);

# feel free to pull multiple sequences...
# if you want to get a bunch of sequences use the get_Stream_by_id/acc methods
my $seqio = $gb->get_Stream_by_id([ qw(J00522 AF303112 2981014)]);

while( defined ($seq = $seqio->next_seq )) {
        $seqout->write_seq($seq);
}
BioPerl-1.6.923/examples/db/rfetch.pl000555000765000024       234712254227331 17461 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

#
# Fetch sequence data via OBDA registry system
#
# usage: rfetch -i  -a -v -d embl -s start -e end
#

use Bio::DB::Registry;
use Bio::SeqIO;
use Getopt::Long;
use strict;

my $database = 'embl_biosql';
my $start    = undef;
my $end      = undef;
my $format   = 'fasta';
my $file     = undef;
my $acc      = undef;
my $verbose  = undef;

&GetOptions(
	    'd|database:s' => \$database,
	    's|start:i' => \$start,
	    'e|end:i'   => \$end,
	    'f|format:s' => \$format,
	    'i|input:s' => \$file,
	    'a|acc'     => \$acc,
	    'v|verbose' => \$verbose,
	   );


my $registry = Bio::DB::Registry->new();

my $db = $registry->get_database($database);

my $seqout = Bio::SeqIO->new( '-format' => $format, '-fh' => \*STDOUT);

my @ids;

if( defined $file ) {
  open(F,$file) || die "cannot open $file $!";
  while(  ) {
    my ($id) = split;
    push(@ids,$id);
  }
} else {
  @ids = @ARGV;
}

foreach my $id ( @ids ) {
  my $seq;
  if( $verbose ){
    print STDERR "fetching $id\n";
  }

  if( $acc ) {
    $seq = $db->get_Seq_by_acc($id);
  } else {
    $seq = $db->get_Seq_by_id($id);
  }

  if( defined $start && defined $end ) {
    $seq = $seq->trunc($start,$end);
  }

  $seqout->write_seq($seq);
}
BioPerl-1.6.923/examples/db/use_registry.pl000555000765000024        47212254227335 20713 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
use strict;

use Bio::DB::Registry;
use Bio::SeqIO;
use strict;

my $registry = new Bio::DB::Registry();

print "services are ", join(',', $registry->services), "\n";
my $db = $registry->get_database("embl");
my $seq = $db->get_Seq_by_id("J02231");
my $out = new Bio::SeqIO;
$out->write_seq($seq);
BioPerl-1.6.923/examples/liveseq000755000765000024          012254227330 16565 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/liveseq/change_gene.pl000555000765000024       345412254227330 21513 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use Bio::LiveSeq::IO::BioPerl;
use Bio::LiveSeq::Mutator;
use Bio::LiveSeq::Mutation;
use Bio::Variation::IO;

if ($#ARGV < 1) { # one argument input
    print <load(-file => "$filename");

    my $gene_name=$ARGV[1];
    my $gene=$loader->gene2liveseq(-gene_name => $gene_name,
				   -getswissprotinfo => 0);

    print STDERR "Gene: ",$gene->name,"\n";
    print STDERR "    Moltype: ", $gene->get_DNA->alphabet,  "\n";
    print STDERR "    Features:\n";
    print STDERR $gene->printfeaturesnum();
    print STDERR "    Gene has boundaries ",$gene->upbound," - ",$gene->downbound,"\n";
    print STDERR "    Gene has maxtranscript with start ",$gene->maxtranscript->start,
          " end ",$gene->maxtranscript->end," strand ",$gene->maxtranscript->strand,"\n";
    print STDERR "    DNA  has boundaries ",$gene->get_DNA->start," - ",$gene->get_DNA->end,"\n";
    print STDERR "\n";

    print STDERR "Now issuing mutations to the gene....\n";

    my $mutation = new Bio::LiveSeq::Mutation (-seq =>'A',
				       -pos => 64
				       );
    my $mutate = Bio::LiveSeq::Mutator->new(-gene => $gene,
					 -numbering => "coding"
					 );
    $mutate->add_Mutation($mutation);
    my $results=$mutate->change_gene();
    print "\n";
    if ($results) {
	my $out = Bio::Variation::IO->new( '-format' => 'flat');
	$out->write($results);
    }
}
BioPerl-1.6.923/examples/popgen000755000765000024          012254227332 16407 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/popgen/parse_calc_stats.pl000555000765000024       632512254227332 22424 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# Author: Jason Stajich, jason@bioperl.org
# $Revision: 6576 $

use strict;

use Bio::PopGen::IO;
use Bio::PopGen::Statistics;
use Bio::PopGen::Population;

my $io = new Bio::PopGen::IO(-format => 'prettybase',
			     # the Bio::Root::IO->catfile is only
			     # to make file access platform independent
			     -file   => Bio::Root::IO->catfile
			     (qw( t data popstats.prettybase)));

# This is an example of how to read in data from Bio::PopGen::IO
# We're going to make 2 lists, @outgroup, @ingroup
# @outgroup is a single individual which is named 'out'
# @ingroup is the set of individuals we are testing
my (@ingroup,@outgroup);
while( my $ind = $io->next_individual ) {
    if($ind->unique_id =~ /out/) {
	push @outgroup, $ind;
    } else { 
	push @ingroup, $ind;	
    }
}

# We'll get the names of all the markers (or sites)
# that this individual has genotypes for
my @marker_names = $ingroup[0]->get_marker_names();

# the number of sites is the same as the number of markers
# we assume that all the individuals have the same number of sites
# or that this data is 'aligned' if these were derived from a 
# multiple sequence alignment
my $sitecount = scalar @marker_names;

foreach my $ind ( @ingroup ) {
    # here let's print out the individual name and all their alleles
    # for all the markers
    # like this
    # Name: INDIVIDUALNAME
    #      A1,A2 B1,B2,...
    print "Name: ", $ind->unique_id,"\n";
    print "\t";
    foreach my $marker ( @marker_names ) {
	for my $genotype ( $ind->get_Genotypes($marker) ) {
	    my @alleles = $genotype->get_Alleles();
	    # In this example these are actually single alleles anyways...
	    print join(",", @alleles), " ";
	}
    }
    print "\n";
    
    # There is a more compact way to write that
    print "Name: ", $ind->unique_id,
          "\n\t", join(" ", map { join(",",$_->get_Alleles) } 
		          map { $ind->get_Genotypes($_) } @marker_names),"\n";
    print "--\n";
}

# We can compute some statistics about these individuals
# (underlying assumption is that they are unrelated...)

print "Pi: ",Bio::PopGen::Statistics->pi(\@ingroup), "\n";
print "Theta: ",Bio::PopGen::Statistics->theta(\@ingroup), "\n";

# we can also treat them like a population
my $ingroup_pop = new Bio::PopGen::Population(-individuals => \@ingroup);

print "Pi: ",Bio::PopGen::Statistics->pi($ingroup_pop), "\n";
print "Theta: ",Bio::PopGen::Statistics->theta($ingroup_pop), "\n";





# You can also simulate individuals from a coalescent 
use Bio::PopGen::Simulation::Coalescent;

my $ssize = 5;
my $sim = new Bio::PopGen::Simulation::Coalescent(-sample_size => $ssize);
my $tree = $sim->next_tree;
my $mutcount = 100;
$sim->add_Mutations($tree, $mutcount);

# The leaves are the simulated individuals
my @leaves = $tree->get_leaf_nodes;

# We can use the Stats module either like Bio::PopGen::Statistics->XXX
# or like this:
my $stats = new Bio::PopGen::Statistics;
# $stats->verbose(1);
print "Coalescent pi: ", $stats->pi(\@leaves), "\n";
print "Coalescent theta: ", $stats->theta(\@leaves), "\n";
my $coalescent_pop = new Bio::PopGen::Population(-individuals => \@leaves);

print "Coalescent pi: ", $stats->pi($coalescent_pop), "\n";
print "Coalescent theta: ", $stats->theta($coalescent_pop), "\n";
BioPerl-1.6.923/examples/quality000755000765000024          012254227312 16605 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/quality/svgtrace.pl000555000765000024       305112254227312 21117 0ustar00cjfieldsstaff000000000000#! /usr/bin/perl

use warnings;
use strict;
use Bio::SeqIO;
use SVG;

my $USAGE = <

This simple example script reads the ABI data and uses the trace data to
generate a SVG-formatted chromatogram. Requires the CPAN SVG module and
Bio::SeqIO::staden::read (from bioperl-ext), which itself requires io_lib from
the Staden package.

END_USAGE

my $file = shift || die $USAGE;

my $img_width = 6000;
my $img_height = 200;

my $svg = SVG->new(width => $img_width, height => $img_height, xmlns => "http://www.w3.org/2000/svg");

my $seq_io = Bio::SeqIO->new( -file => $file, -format => 'abi', -get_trace_data => 1);

my $seq = $seq_io->next_seq;

my $points = scalar($seq->get_trace_graph( -trace => 'a' ));

my @xdata = map { $_ / $points * $img_width } (0..$points-1);

my %colours = ( 'a' => 'green', 'c' => 'blue', 'g' => 'black', 't' => 'red' );
foreach my $element ('a', 'c', 'g', 't')
{
	my @trace = $seq->get_trace_graph( -trace => $element, -scale => $img_height); 
	@trace = map { $img_height - $_ } @trace;
	my $points = $svg->get_path(-type => 'polyline', -closed => 0, x => \@xdata, y => \@trace);
	$svg->polyline(%$points, id=> $element, 'stroke-width' => 0.5, stroke => $colours{$element}, 'fill-opacity' => 0, 'fill' => 'white');
}

my $count = 0;
my $text_group = $svg->group( id => 'text_layer');
foreach my $base_loc (@{$seq->trace})
{
	$text_group->text(x => ($base_loc / $points * $img_width), y => 50, 'text-anchor' => 'middle', fill => 'black', 'font-size' => '5pt')->cdata(substr($seq->seq,$count,1));
	++$count;
}

print $svg->xmlify();
BioPerl-1.6.923/examples/root000755000765000024          012254227334 16104 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/root/exceptions1.pl000555000765000024      1076012254227320 21062 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl

# A simple tester script for demonstrating how to throw and catch
# Error.pm objects. It also shows how to define new types of
# Error.pm-based objects. 
#
# It relies on the tester modules TestObject.pm and TestInterface.pm
# which you should also look at.
#
# Note that Bio::Root::NotImplemented is a subclass of Error.pm 
# and is defined in Bio::Root::Exception.pm
#
# This code requires Graham Barr's Error.pm module available from CPAN.
#
# Author: Steve Chervitz 
#

use strict;
use lib qw(lib/ ../../);
use Error qw(:try);
use TestObject;
use Getopt::Long;

# Command-line options:
my $eg = 0;        # which example to run (a number 1-4)
my $help = 0;      # print usage info

# $Error::Debug is set to true by default in Bio::Root::Interface.
$Error::Debug = 1; # enables verbose stack trace 

GetOptions( "debug!" => \$Error::Debug,
	    "eg=s"   => \$eg,    
	    "h"      => \$help   
	  ); 

my $options = << "OPTS";
      -eg  1|2|3|4   Run a particular example
      -nodebug       Deactivate verbose stacktrace
      -h             Print this usage
OPTS

(!$eg || $help) and die "Usage: $0 -eg 1|2|3|4 [-nodebug] [-h]\nOptions:\n$options";

print $Error::Debug ? "Try a -nodebug option to supress stack trace." : "Verbose stacktrace off.";
print "\n\n";

# Set up a tester object.
my $test = TestObject->new();
$test->data('Eeny meeny miney moe.');

try {

    test_notimplemented( $test ) if $eg == 1;

    test_custom_error( $test ) if $eg == 2;

    test_simple_error() if $eg == 3;

    # This subroutine doesn't even exist. But because it occurs within a try block,
    # the Error module will create a Error::Simple to capture it. Handy eh?
    if(  $eg == 4 ) {
	print "Test #4: Calling an undefined subroutine.\n";
	test_foobar();
    }

    # We shouldn't see this stuff.
    print "----\n";
    print "----\n";
    print "Some other code within the try block after the last throw...\n";
    print "----\n";
    print "----\n";
}

# Multiple catch blocks to handle different types of errors:

catch Bio::Root::NotImplemented with {
    my $error = shift;
    print "\nCaught a Bio::Root::NotImplemented.\n",
      "  file  : ", $error->file, "\n",
      "  line  : ", $error->line, "\n",
      "  text  : ", $error->text, "\n",
      "  value : ", $error->value, "\n",
      "  object: ", ref($error->object), "\n";

    print "\nstacktrace:\n", $error->stacktrace, "\n";

    print "\nstringify:\n$error\n";
    # The above line is equivalent to this:
    #print "\nstringify:\n", $error->stringify, "\n";
}

catch Bio::TestException with {
    # Since we know what type of error we're getting,
    # we can extract more information about the offending object
    # which is retrievable from the error object.
    my $error = shift;
    print "\nCaught a Bio::TestException.\n",
      "  file  : ", $error->file, "\n",
      "  line  : ", $error->line, "\n",
      "  text  : ", $error->text, "\n",
      "  value : ", $error->value, "\n",
      "  object: ", ref($error->object), "\n",
      "  data  : ", $error->object->data, "\n";

    print "\nstacktrace:\n", $error->stacktrace, "\n";
    print "\nstringify:\n", $error->stringify, "\n";

}

otherwise {
    # This is a catch-all handler for any type of error not handled above.
    my $error = shift;
    print "\nCaught an other type of error: ", ref($error), "\n",
      "  file  : ", $error->file, "\n",
      "  line  : ", $error->line, "\n",
      "  text  : ", $error->text, "\n",
      "  value : ", $error->value, "\n",
      "  object: ", ref($error->object), "\n";

#    print "\nstack_trace_dump:\n", $error->stack_trace_dump(), "\n";

    print "\nstacktrace:\n", $error->stacktrace, "\n";

    print "\nstringify:\n$error\n";

};  # This semicolon is essential.

print "\nDone $0\n";

sub test_notimplemented {

    my $test = shift;
    # This demonstrates what will happen if a method defined in an interface 
    # that is not implemented in the implementating object.

    print "Test #1: Inducing a Bio::Root::NotImplemented exception from TestObject\n";

    $test->foo();
}


sub test_custom_error {

    my $test = shift;

    # TestObject::bar() deliberately throws a Bio::TestException, 
    # which is defined in TestObject.pm

    print "Test #2: Throwing a Bio::TestException exception from TestObject\n";

    $test->bar;

}


sub test_simple_error {

    # Error::Simple comes with Error.pm and can have only a string and a value.

    print "Test #3: Throwing a Error::Simple object\n";

    throw Error::Simple( "A simple error", 42 );
}


BioPerl-1.6.923/examples/root/exceptions2.pl000555000765000024      1066712254227317 21077 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl

# This shows how Error.pm-based objects can be thrown 
# by Bio::Root::Root::throw() when Error.pm is available.
# When Error.pm isn't available, Bio::Root::Root::throw() 
# works as usual.
#
# It also demonstrates what happens when you use an outer eval{}
# instead of a try{} to trap thrown Error.pm-based exceptions. 
# The behavior is the same as when Error.pm is not used.
# This is important for backward compatibility.
#
# Author: Steve Chervitz 
#

use strict;

use lib qw(lib/ ../../);

# Uncomment this line to force Bio::Root::Root::throw() to 
# not use Error.pm even if it's available.
# Some of the tests in this script will be skipped .
#BEGIN { $main::DONT_USE_ERROR = 1; }

use Bio::Root::Root;
#use Bio::Root::Exception;  # Not necessary since Bio::Root::Root uses it.
use Error qw(:try);

my $foo = Bio::Root::Root->new();

if (!$main::DONT_USE_ERROR) {
    try {
        # This is the new, fancier way to handle exceptions. 
        # You must have Error.pm to do this (tarball included in this dir).
        
        print "[1] Throwing Error within try block via call to Bio::Root::Root::throw()\n";
        $foo->throw( -class => 'Bio::Root::Exception',
                     -text  => "Oopsie!",
                     -value => "123" 
                   );
    }
    
    catch Bio::Root::Exception with {
        my $err = shift;
        print "[1] Caught Bio::Root::Exception:\n$err";

    }

    otherwise {
        my $err = shift;
        print "[1] Caught other Error: ", ref($err), "\n$err";
    };

    
    print "\n\n";
}

eval {

    # This example demonstrates the traditional method for throwing
    # an exception using Bio::Root::Root->throw('string').
    # Notice how an exception of type Bio::Root::Exception is created.

    print "[2] Calling Bio::Root::Root->throw('string') within an eval{}\n";
    $foo->throw("Error message string.");

};

if($@) {
    print "[2] Caught eval{}-based exception: ", ref($@), "\n$@";
}
else {
    print "[2] Nothing to catch.\n";
}



print "\n\n";

eval {

    # This example shows that calling Error::throw directly within
    # an eval{} doesn't lead to a true value in $@ if
    # the error lacks a value. 

    print "[3] Attempting to throw a valueless Error within an eval{} block\n    (this should fail to be caught by Error.pm v0.13 but is caught by v0.14 and greater).\n";

    if( $ENV{OSTYPE} =~ /cygwin/ ) {
        die "[3] This causes a segmentation fault with cygwin perl! Skipping.\n";
    }

    throw Error::Simple ("A simple error.");

};

if($@) {
    print "[3] Caught eval{}-based exception: ", ref($@), "\n$@\n";
}
else {
    print "[3] Nothing to catch.\n";
}


print "\n\n";

eval {

    # This example shows that calling Error::throw directly within
    # an eval{} *does* lead to a true value in $@ if the error 
    # contains a non-zero value. 

    print "[4] Attempting to throw a valued Error within an eval{} block.\n";

    throw Error::Simple ("A simple error.", 42);

};

if($@) {
    print "[4] Caught eval{}-based exception: ", ref($@), "\n$@\n";
}
else {
    print "[4] Nothing to catch.\n";
}

print "\n\n";

if (!$main::DONT_USE_ERROR) {
    eval {

        # This example shows what happens if we try to create a
        # Bio::Root::IOException (a subclass of Bio::Root::Exception)
        # with a zero value. Bio::Root::Exception::new() catches this
        # faux pas and substitutes a value that will register as true in if($@).

        print "[5] Attempting to throw a zero-valued Bio::Root::IOException\n    within an eval{} block.\n";

        throw Bio::Root::IOException ( -text =>"An error with zero value.",
                                   -value => 0);

    };

    if($@) {
        print "[5] Caught eval{}-based zero-valued exception: ", ref($@), "\n$@\n";
    }
    else {
        print "[5] Nothing to catch.\n";
    }
    print "\n\n";
}


eval {

    # If Error::throw is called *indirectly* within an eval{}
    # (i.e., by calling a method which then calls Error::throw),
    # $@ is defined and it consists of a reference to the Error.pm object.

    print "[6] Attempting to throw Error indirectly within an eval{} block \n    via Bio::Root::Root::throw()\n";

    $foo->throw( -class => 'Bio::Root::Exception',
                 -text  => "Oopsie!",
                 -value => "456"
                );

};

if($@) {
    print "[6] Caught eval{}-based exception: ", ref($@), "\n$@";
}
else {
    print "[6] Nothing to catch.\n";
}

print "Done.\n";


BioPerl-1.6.923/examples/root/exceptions3.pl000555000765000024       243212254227334 21046 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl

# This shows that Error objects can be subclassed into more specialized types.
# Bio::Root::FileOpenException is a subclass of  Bio::Root::IOException. 
#
# We can write a generic handler to trap any type of IOException
# or we could handle FileOpenExceptions explicitly.
#
# To demo, run this script without any arguments, then try it with an argument
# that doesn't correspond to any file on your system (e.g., foobar). 
# Then try running with a valid file name.
#
# This requires Graham Barr's Error.pm module available from CPAN.
#
# Author: Steve Chervitz 
#

use strict;
use lib qw(lib/ ../../);
use Error qw(:try);
use Bio::Root::Exception;

try {
   print "Starting try block.\n";
   my $file = shift @ARGV || throw Bio::Root::IOException(-text=>"No file supplied.");

   open ( IN, $file) || throw Bio::Root::FileOpenException(-text=>"Can't open file \"$file\"", -value=> $!); 

   print "Opened file $file\n";

}
catch Bio::Root::IOException with {
    # This handler deals with IOException or any of its subclasses.
    # We could also write a handler with a `catch Bio::Root::FileOpenException'.
    # Such a handler would appear before this one.
    my $e = shift;
    print "Caught IOException:\n\n$e";
}
finally {
     close IN;
};

print "\nDone.\n";
BioPerl-1.6.923/examples/root/exceptions4.pl000555000765000024       644712254227324 21060 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl

# This shows how the examples work when Error.pm isn't installed.
# It also shows how to supress using Error.pm if it is installed
# and you don't want to use it for some reason.
#
# Here we use the eval{} style exception handling that's currently
# in vogue trapping Bioperl exceptions.
#
# Author: Steve Chervitz 
#


# Setting this variable simulates not having Error.pm installed.
BEGIN { $DONT_USE_ERROR = 1; }

use strict;
use lib qw(lib/ ../../);
use TestObject;
use Getopt::Long;

# Command-line options:
my $eg = 0;        # which example to run (a number 1-4)
my $help = 0;      # print usage info
$Error::Debug = 1; # enables verbose stack trace 

GetOptions( "debug!" => \$Error::Debug,
	    "eg=s"   => \$eg,    
	    "h"      => \$help   
	  ); 

my $options = << "OPTS";
      -eg  1|2|3|4   Run a particular example
      -nodebug       Deactivate verbose stacktrace
      -h             Print this usage
OPTS

(!$eg || $help) and die "Usage: $0 -eg 1|2|3|4|5 [-nodebug] [-h]\nOptions:\n$options";

# Set up a tester object.
my $test = TestObject->new();
$test->data('Eeny meeny miney moe.');

eval {

    test_notimplemented( $test ) if $eg == 1;

    test_custom_error( $test ) if $eg == 2;

    test_simple_error() if $eg == 3;

    # This subroutine doesn't even exist. But because it occurs within a try block,
    # the Error module will create a Error::Simple to capture it. Handy eh?
    if(  $eg == 4 ) {
	print "Test #4: Calling an undefined subroutine.\n";
	test_foobar();
    }

    # Throwing an exception the traditional bioperl way.
    if(  $eg == 5 ) {
	print "Test #5: Creating a Bio::Root::Root object and calling throw('string').\n";
        my $obj = Bio::Root::Root->new();
        $obj->throw("Throwing string from Bio::Root::Root object.");
    }

    # We shouldn't see this stuff.
    print "----\n";
    print "----\n";
    print "Some other code within the try block after the last throw...\n";
    print "----\n";
    print "----\n";
};

if($@) {
    my $error = shift;
    print "\nAn exception occurred:\n$@\n";
}
else {
    print "\nNo exception occurred\n";
}

print "\nDone $0\n";

sub test_notimplemented {

    my $test = shift;
    # This demonstrates what will happen if a method defined in an interface 
    # that is not implemented in the implementation.

    print "Test #1: Inducing a Bio::Root::NotImplemented exception from TestObject\n";

    $test->foo();
}    


sub test_custom_error {

    my $test = shift;

    # TestObject::bar() deliberately throws a Bio::Root::TestError, 
    # which is defined in TestObject.pm

    print "Test #2: Throwing a Bio::TestException exception from TestObject\n";

    $test->bar;  

}


sub test_simple_error {

    # This example won't work without Error.pm installed.
    # It shows how setting $DONT_USE_ERROR = 1 
    # really does simulate the absence of Error.pm.
    # The exception should report something like:
    # "Can't locate object method "throw" via package "Error::Simple"

    # Error::Simple comes with Error.pm and can have only a string and a value.

    print "Test #3: Throwing a Error::Simple object\n\n";

    print "This should fail to find object method 'throw' via package 'Error::Simple'\n";
    print "because Error.pm is not available.\n\n";

    throw Error::Simple( "A simple error", 42 );
}


BioPerl-1.6.923/examples/root/README000555000765000024      1714312254227313 17147 0ustar00cjfieldsstaff000000000000README for Bioperl examples/root 

This directory contains some sample scripts and modules that
illustrate the use of the Bio::Root::* modules. Currently, these
example scripts focus on how exception handling. 

Here are some short descriptions of the examples/root scripts:

Script            Description
--------------    ----------------------------------------
exceptions1.pl    How to throw and catch Error.pm objects
exceptions2.pl    How to throw Error.pm objects via Bio::Root::Root
exceptions3.pl    Illustrates inheritance between Error.pm types
exceptions4.pl    Shows what happens when Error.pm isn't installed

These demo scripts should be executed within the
examples/root directory of the Bioperl distribution.


Using Error.pm for Exception Handling
--------------------------------------

The Bio::Root::Root module interfaces with Graham Barr's Error.pm.
Error.pm provides a handy way to create, throw, and catch exceptions
as objects. Error.pm is quite convenient and easy to use and adds a
level of control for managing errors within your Perl code using
familiar object-oriented, try-catch-finally semantics. You can define
subclasses of Error.pm representing particular types of exceptions,
and you can define catch blocks to handle these types of exceptions.

This has distinct advantages over simply catching any and all errors
with an eval{} block, as is currently done in Bioperl. Strongly typed
exception objects make it easy to write appropriate handlers. It also
makes you code easier to understand because it's clear what type of
things can/did go wrong.

Throwing exceptions that are Error.pm-compliant is a little more work
than throwing them the usual Bioperl way. Here's an example:

Using Error.pm-compliant syntax:

  if( !$feat->isa("Bio::SeqFeatureI") ) {
      $self->throw(-class => 'Bio::Root::BadParameter',
                   -text  =>"$feat is not a SeqFeatureI and that's what we expect.",
                   -value => $feat);
  }

Not using Error.pm-compliant syntax:

  if( !$feat->isa("Bio::SeqFeatureI") ) {
      $self->throw("$feat is not a SeqFeatureI and that's what we expect.");
  }

The advantage of using the Error.pm-compliant syntax is that, even if
Error.pm isn't installed, the exception message that gets thrown will
contain the name of the class of the exception. This provides a more
informative description of what went wrong.

In the Error.pm-compliant case above, the exception string starts with:

    ------------- EXCEPTION: Bio::Root::BadParameter -------------

Compare this to the non-Error.pm-compliant exception string:

    -------------------- EXCEPTION --------------------

There are a variety of exception classes that are declared in
Bio::Root::Exception for common types of error conditions:

    Bio::Root::Exception
    Bio::Root::NotImplemented
    Bio::Root::IOException
    Bio::Root::FileOpenException
    Bio::Root::SystemException
    Bio::Root::BadParameter
    Bio::Root::OutOfRange
    Bio::Root::NoSuchThing

Feel free to use these, or subclass from them to derive more specific
classes of exceptions. For more information about these types of
exceptions, see perldoc Bio::Root::Exception.

Error.pm is available through CPAN and I encourage Bioperl users and
developers to install it and experiment with it.


Bio::Root::Exception.pm
-----------------------

The Bio::Root::Exception.pm module contains a number of Error.pm
subclasses representing common types of errors. If you want to throw
an exception within your Bioperl module that doesn't correspond to any
of the ones defined in Bio::Root::Exception, feel free to define a new
one, but be sure it inherits from Bio::Root::Exception or one of its
subclasses. This will allow anyone to write a handler for any type of
Bioperl exception.

Defining a new type of exception can be done quite simply. All you
need to do is to specify the @ISA array for your new type, as in:

    @Bio::Root::Exception::MyBad::ISA = qw( Bio::Root::Exception );

If you want to override any of the available methods or add new ones,
you'll have to provide a package statement and the appropriate
method definitions.

Programming tip: Be careful not to use exceptions as your primary
means of flow control within your code. Throwing and handling
exceptions come with some execution overhead. Also, such excessive use
of exceptions can make your logic hard to follow.


Bio::Root::RootI.pm and Bio::Root::Root.pm 
-------------------------------------------

The modules in the lib directory also demonstrate the use of the Bioperl
modules Bio::Root::RootI and Bio::Root::Root. RootI.pm should be used
as the base class for any Bioperl module that specifies an
interface. It simplifies the process of writing virtual
methods. Root.pm implements RootI.pm should be used as a base class
for any Bioperl module that specifies a concrete object.

The module TestInterface.pm demonstrates how to use
Bio::Root::RootI.pm. The module TestObject.pm demonstrates how to use
Bio::Root::Root.pm.

Bio::Root::RootI defines a method called "throw_not_implemented()"
that will throw a Bio::Root::NotImplemented exception. This is useful
for ensuring that an implementing class has implemented all
methods. Any method within a Bio::Root::RootI subclass can call
throw_not_implemented() to indicate that a method has not been
implemented. Implementations of the interface must implement the
method or an exception will result when someone tries to use it.

Note that Bio::Root::Root can make use of Error.pm if available, but
Error.pm is not required. 


Bio::Root::Root::throw() with Error.pm
---------------------------------------

Bio::Root::Root can determine if Error.pm is available and if so, can
make use of it when Bio::Root::Root::throw() is called. For a demo,
see test2.pl.


Real-Life Examples
------------------

For additional examples of how to make use of the Error.pm-related capabilities
of Bio::Root::Root.pm, I created new versions of Bio::SeqI.pm,
Bio::Seq.pm, Bio::PrimarySeqI.pm, and Bio::PrimarySeq.pm within the
lib/Bio subdirectory. This conversion is pretty straightforward and could
be done on the other Bioperl modules without too much effort.

TODO: Update the lib/Bio modules based on the latest versions in bioperl-live.


Using Error.pm's try{} and catch{} within Bioperl Modules
----------------------------------------------------------

For developers, using Error.pm's try{} and catch{} blocks within
Bioperl modules themselves could come in handy. But doing so would add
an external dependency for Error.pm, which is not part of the standard
Perl distribution. So at this stage, it's best to stick with just
using Error.pm's throw() method (via Bio::Root::Root) and leave the
try{} and catch{} blocks for use only within your scripts.

If you really want to use try{} and catch{} within your module and
still want to be capable of running when Error.pm isn't available, you
can check $Bio::Root::Root::ERRORLOADED variable.

If we really want to incorporate it within Bioperl, a reasonable
solution would be to distribute Error.pm with Bioperl. 

So why use Error.pm instead of some other utility? Well, Perl 6 will
most likely include some form of structured exception handling akin to
that provided by Error.pm (see these RFC's:
http://dev.perl.org/rfc/63.pod and http://dev.perl.org/rfc/88.pod).
So it will probably be easy to convert Error.pm-based exception handling
to whatever is adopted for Perl 6.

(Side note for any CORBA folks out there: Error.pm is used in some
other CPAN modules, notably CORBA::MICO. Thus, using Error.pm within
Bioperl allows consistent exception handling methodology when working
with such modules and Bioperl together.)

--
Steve Chervitz 
21 April 2001
Updated 6 March 2003

BioPerl-1.6.923/examples/root/lib000755000765000024          012254227336 16654 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/root/lib/TestInterface.pm000444000765000024        75312254227336 22074 0ustar00cjfieldsstaff000000000000=head1 NAME

TestInterface - A simple subclass of Interface

=head1 DESCRIPTION

This module demonstrates how to use the generic Bio::Root::RootI
superclass.

=head1 AUTHOR

Steve Chervitz Esac@bioperl.orgE

=cut

package TestInterface;


use base qw(Bio::Root::RootI);

sub data {
    my $self = shift;
    $self->throw_not_implemented;
}

sub foo {
    my $self = shift;
    $self->throw_not_implemented;
}

sub bar {
    my $self = shift;
    $self->throw_not_implemented;
}


1;
BioPerl-1.6.923/examples/root/lib/TestObject.pm000444000765000024       334512254227330 21414 0ustar00cjfieldsstaff000000000000=head1 NAME

TestObject - An implementation of TestInterface

=head1 DESCRIPTION

This module attempts to provide an implementation of TestInterface and
is used for illustrating exception throwing using Graham Barr's
Error.pm object.

=head1 AUTHOR

Steve Chervitz Esac@bioperl.orgE

=cut

#'

package TestObject;

use strict;


# Define a special type of error "Bio::TestException" as a subclass of Error.
# Note two things:
#   1. The ISA declaration effectively defines our new Exception object.
#   2. This declaration doesn't have to be located in the Bio directory.
#   3. We don't have to use Bio::Root::Exception in this module.
#   4. If Error.pm isn't available this statement doesn't matter.
@Bio::TestException::ISA = qw( Bio::Root::Exception );

use base qw(Bio::Root::Root TestInterface);


# Note that we're not implementing foo(), so calling it
# will result in a Bio::Root::NotImplemented exception.

sub data {
    my ($self, $data) = @_;
    print "Setting test data ($data)\n" if $data && $self->verbose;
    $self->{'data'} = $data if $data;
 
   return $self->{'data'} 
}

sub bar {

    my $self = shift;

    print "\nExecuting method bar() in TestObject\n" if $self->verbose;
    print "Throwing a Bio::TestException\n" if $self->verbose;

    my $message = "A Test error";

    # Bio::Root::Root::throw() will make use of Error.pm if present.
    # The type of Error is specified with a -class parameter. 
    # If -class is not supplied, a Bio::Root::Exception is throw.
    # In this case, the argument can consist of a simple string.

    $self->throw( -class => 'Bio::TestException',
                  -text  => $message );

    print "Code within bar() below the throw that shouldn't be executed.\n" if $self->verbose;

}

1;
BioPerl-1.6.923/examples/searchio000755000765000024          012254227340 16713 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/searchio/blast_example.pl000555000765000024      1530112254227326 22254 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# Example that shows values returned by Bio::SearchIO::Blast.
# Note that some methods will return objects or arrays, not text.
# For example, $hsp->get_aln will return a Bio::SimpleAlign object,
# not the alignment in a printable form.
# This script was used to create the table in the SearchIO HOWTO,
# found at http://bioperl.open-bio.org/wiki/HOWTO:SearchIO
# Brian Osborne

use strict;
use Bio::SearchIO;
use Bio::SimpleAlign;
use Bio::AlignIO;

my $file = shift or die "Usage: $0 \n";
my $in = new Bio::SearchIO(-format => 'blast',
			   # comment out the next line to read STDIN
			   -file   => $file );

while ( my $result = $in->next_result ) {
   my @stats =  $result->available_statistics;
   my @params = $result->available_parameters;
   print "Result\tavailable_statistics\t@stats\n";
   print "Result\tavailable_parameters\t@params\n";
   print "Result\talgorithm\t" .         $result->algorithm . "\n";
   print "Result\talgorithm_version\t" . $result->algorithm_version . "\n";
   print "Result\tquery_name\t" .        $result->query_name . "\n";
   print "Result\tquery_accession\t" .   $result->query_accession . "\n";
   print "Result\tquery_length\t" .      $result->query_length . "\n";
   print "Result\tquery_description\t" . $result->query_description . "\n";
   print "Result\tdatabase_name\t" .     $result->database_name . "\n";
   print "Result\tdatabase_letters\t" .  $result->database_letters . "\n";
   print "Result\tdatabase_entries\t" .  $result->database_entries . "\n";
   print "Result\tnum_hits\t" .          $result->num_hits . "\n";
   print "Result\thits\t" .              $result->hits . "\n";
   while ( my $hit = $result->next_hit ) {
      my $id =         $hit->matches('id');
      my $cons =       $hit->matches('cons');
      my @accs =       $hit->each_accession_number;
      my @qidentical = $hit->seq_inds('query','identical');
      my @qconserved = $hit->seq_inds('query','conserved');
      my @hidentical = $hit->seq_inds('hit','identical');
      my @hconserved = $hit->seq_inds('hit','conserved');
      print "Hit\tseq_inds('query','identical')\t@qidentical\n";
      print "Hit\tseq_inds('query','conserved')\t@qconserved\n";
      print "Hit\tseq_inds('hit','identical')\t@hidentical\n";
      print "Hit\tseq_inds('hit','conserved')\t@hconserved\n";
      print "Hit\teach_accession_number\t@accs\n";
      print "Hit\tmatches('id')\t" . $id . "\n";
      print "Hit\tmatches('cons')\t" . $cons . "\n";
      print "Hit\tname\t" .                $hit->name . "\n";
      print "Hit\taccession\t" .           $hit->accession . "\n";
      print "Hit\tdescription\t" .         $hit->description . "\n";
      print "Hit\tlength\t" .              $hit->length . "\n";
      print "Hit\talgorithm\t" .           $hit->algorithm . "\n";
      print "Hit\traw_score\t" .           $hit->raw_score . "\n";
      print "Hit\tsignificance\t" .        $hit->significance . "\n";
      print "Hit\tbits\t" .                $hit->bits . "\n";
      print "Hit\thsps\t" .                $hit->hsps . "\n";
      print "Hit\tnum_hsps\t" .            $hit->num_hsps . "\n";
      print "Hit\tambiguous_aln\t" .       $hit->ambiguous_aln . "\n";
      print "Hit\toverlap\t" .             $hit->overlap . "\n";
      print "Hit\tn\t" .                   $hit->n . "\n"; 
      print "Hit\tlogical_length\t" .      $hit->logical_length . "\n";
      print "Hit\tlength_aln\t" .          $hit->length_aln . "\n";
      print "Hit\tgaps\t" .                $hit->gaps . "\n";
      print "Hit\tfrac_identical\t" .      $hit->frac_identical . "\n";
      print "Hit\tfrac_conserved\t" .      $hit->frac_conserved . "\n";
      print "Hit\tfrac_aligned_query\t" .  $hit->frac_aligned_query . "\n";
      print "Hit\tfrac_aligned_hit\t" .    $hit->frac_aligned_hit . "\n";
      print "Hit\tnum_unaligned_sbjct\t" . $hit->num_unaligned_sbjct . "\n";
      print "Hit\tnum_unaligned_hit\t" .   $hit->num_unaligned_hit . "\n";
      print "Hit\tnum_unaligned_query\t" . $hit->num_unaligned_query . "\n";
      print "Hit\tstrand\t" .              $hit->strand . "\n";
      print "Hit\tframe\t" .               $hit->frame . "\n";
      print "Hit\trank\t" .                $hit->rank . "\n";
      print "Hit\tlocus\t" .               $hit->locus . "\n";
      while ( my $hsp = $hit->next_hsp ) {
	 my ($qid,$qcons) = $hsp->matches('hit');
	 my ($id,$cons) = $hsp->matches('query');
	 @qidentical = $hsp->seq_inds('query','identical');
	 @qconserved = $hsp->seq_inds('query','conserved');
	 @hidentical = $hsp->seq_inds('hit','identical');
	 @hconserved = $hsp->seq_inds('hit','conserved');
	 my @hrange =  $hsp->range('hit');
	 my @qrange =  $hsp->range('query');
	 my $aln =     $hsp->get_aln;
	 my $alnIO = Bio::AlignIO->new(-format=>"clustalw");
	 print "HSP\trange('hit')\t@hrange\n";
	 print "HSP\trange('query')\t@qrange\n";
	 print "HSP\tseq_inds('hit','identical')\t@hidentical\n";
	 print "HSP\tseq_inds('query','conserved')\t@qconserved\n";
	 print "HSP\tseq_inds('query','identical')\t@qidentical\n";
	 print "HSP\tseq_inds('hit','conserved')\t@hconserved\n";
	 print "HSP\tmatches('hit')\t" .   $qid . " " . $qcons . "\n";
	 print "HSP\tmatches('query')\t" . $id . " " . $cons . "\n";
	 print "HSP\talgorithm\t" .        $hsp->algorithm . "\n";
	 print "HSP\tevalue\t" .           $hsp->evalue . "\n";
	 print "HSP\tfrac_identical\t" .   $hsp->frac_identical . "\n";
	 print "HSP\tfrac_conserved\t" .   $hsp->frac_conserved . "\n";
	 print "HSP\tgaps\t" .             $hsp->gaps     . "\n";
	 print "HSP\tquery_string\t" .     $hsp->query_string . "\n";
	 print "HSP\thit_string\t" .       $hsp->hit_string . "\n";
	 print "HSP\thomology_string\t" .  $hsp->homology_string . "\n";
	 print "HSP\tlength('total')\t" .  $hsp->length('total') . "\n";
	 print "HSP\tlength('hit')\t" .    $hsp->length('hit') . "\n";
	 print "HSP\tlength('query')\t" .  $hsp->length('query') . "\n";
	 print "HSP\thsp_length\t" .       $hsp->hsp_length . "\n";
	 print "HSP\tframe\t" .            $hsp->frame . "\n";
	 print "HSP\tnum_conserved\t" .    $hsp->num_conserved . "\n";
	 print "HSP\tnum_identical\t" .    $hsp->num_identical . "\n";
	 print "HSP\trank\t" .             $hsp->rank . "\n";
	 print "HSP\tscore\t" .            $hsp->score . "\n";
	 print "HSP\tbits\t" .             $hsp->bits . "\n";
	 print "HSP\tpercent_identity\t" . $hsp->percent_identity . "\n";
	 print "HSP\tstrand()\t" .         $hsp->strand() . "\n";
	 print "HSP\tstart('hit')\t" .     $hsp->start('hit') . "\n";
	 print "HSP\tstart('query')\t" .   $hsp->start('query') . "\n";
	 print "HSP\tend('hit')\t" .       $hsp->end('hit') . "\n";
	 print "HSP\tend('query')\t" .     $hsp->end('query') . "\n";
	 print "HSP\talignment\n";
	 print $alnIO->write_aln($aln),"\n\n";
      }
   }
}

__END__
BioPerl-1.6.923/examples/searchio/custom_writer.pl000555000765000024       621712254227313 22324 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl 

# Demonstrates the use of a SearchIO Blast parser and a SearchWriterI object
# for producing custom output of Blast hit data from a Blast report 
# input stream.
#
# Here we define a custom SearchWriterI object that ouputs just the data we want
# from each BLAST report.
# 
# NOTE: If you just want pick and choose which columns you want 
# in the output table, you don't need to create your own custom
# SearchWriterI implementation as we do here. HitTableWriter and HSPTableWriter
# are configurable as to what columns and order you want. 
# The hitwriter*.pl and hspwriter.pl examples in this directory
# illustrate this.
#
# For a complete list of columns, see the docs for these modules:
#   Bio::SearchIO::Writer::HitTableWriter
#   Bio::SearchIO::Writer::HSPTableWriter
#
# This example serves as an illustration of how to use the 
# SearchWriterI api and plug it in to a SearchIO parser,
# which you may want to do if you want to generate data column(s)
# not provided by the available writers.
#
# Usage:
#   STDIN:  stream containing one or more BLAST or PSI-BLAST reports.
#   STDOUT: none, but generates an output file "custom_writer.out"
#           containing tab-delimited data on a per-hit basis.
#   STDERR: Progress info.
#
# Author: Steve Chervitz 

package MyBlastWriter;

use strict;
use lib '../../';
use Bio::Root::Root;
use Bio::SearchIO::SearchWriterI;

use base qw( Bio::Root::Root Bio::SearchIO::SearchWriterI );

sub to_string {
    my ($self, $result, @args) = @_;
    my $str = '';

    my $hits_reported = 0;

    foreach my $hit($result->hits) {

      # If this is a PSI-BLAST report, only report novel hits
      if( $result->psiblast ) {
	# Note that we could have supplied this has a -HIT_FILTER function
	# when we defined our input SearchIO object. Then we wouldn't need 
	# to define a custom writer.
	next unless $hit->iteration > 1 and not $hit->found_again;
      }

      $hits_reported++;
      printf STDERR "$hit\n";

      $str .= sprintf "%s\t%d\t%s\t%d\t%.2f\t%d\t%.1e\t%d\t%d\t%d\t%d\t%s\n", 
	               $result->query_name, $result->query_length, $hit->name,
	               $hit->length, $hit->frac_identical('query'), $hit->length_aln,
	               $hit->expect, $hit->score, $hit->bits,
	               $hit->gaps('total'), $hit->num_hsps, $hit->iteration || '-';
    }

    printf STDERR "\n%d hits written\n", $hits_reported;

    $str;

}

package main;

#===================================================
# Start of script 
#===================================================

use strict;

use lib '../../../';
use Bio::SearchIO;

select STDOUT; $|=1; 

my $in     = Bio::SearchIO->new( -format => 'blast', 
				 -fh => \*ARGV,
                                 -signif => 0.1 );
my $writer = MyBlastWriter->new();
my $out    = Bio::SearchIO->new( -format => 'blast',
				 -writer => $writer,
				 -file   => ">custom_writer.out" );

while ( my $result = $in->next_result() ) {
    printf STDERR "Report %d: $result\n", $in->result_count;
    $out->write_result($result);
}

printf STDERR "\n%d Results processed.\n", $in->result_count;
printf STDERR "Output sent to file: %s\n",  $out->file if $out->file;

BioPerl-1.6.923/examples/searchio/hitwriter.pl000555000765000024       772612254227325 21450 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl 

# Demonstrates the use of a SearchIO Blast parser and a SearchWriterI object
# for producing tab-delimited output of hit data from a Blast report 
# input stream.
#
# Each row in the output represents data for a single hit.
# For hits containing multiple HSPs, the output information represents a
# summary across all HSPs.
#
# This parser represents a new and improved version of Bio::Tools::Blast.
#
# Usage:
#   STDIN:  stream containing one or more BLAST or PSI-BLAST reports.
#   STDOUT: none, but generates an output file "hitwriter.out"
#           containing tab-delimited data on a per-hit basis.
#   STDERR: Progress info and any errors.
# 
# In this example, we create a SearchIO parser that screens out hits 
# based on expect (or P) scores and a default HitTableWriter. This writer
# provides the same functionality as the original Bio::Tools::Blast::table()
# function (i.e., a tab-delimited summary of each hit per row).
# HitTableWriter, however, is customizable so you can specify just the columns
# you want to have in the output table.
#
# For more documentation about the writer, including
# a complete list of columns, execute:
#   perldoc Bio::SearchIO::Writer::HitTableWriter.
#
# For more documentation about working with Blast result objects,
# see docs for these modules:
#   Bio::Search::Result::BlastResult
#   Bio::Search::Iteration::IterationI
#   Bio::Search::Hit::BlastHit
#   Bio::Search::HSP::BlastHSP
#
# For more documentation about the Blast parser, see docs for
#   Bio::SearchIO
#
# Author: Steve Chervitz 

use strict;
use lib '../../';

use Bio::SearchIO;
use Bio::SearchIO::Writer::HitTableWriter;

# These are the columns that will be in the output table of BLAST results.
my @columns = qw(
		 query_name
		 query_length
                 hit_name
                 hit_length
		 num_hsps
                 expect
                 frac_aligned_query
                 frac_identical_query
                 length_aln_query
                 gaps_total
                 strand_query
                 strand_hit
		);

# The following columns require HSP alignment data:
# 		  num_hsps
#                 frac_identical_query
#                 length_aln_query
#                 gaps_total
#                 strand_query
#                 strand_hit

print STDERR "\nUsing SearchIO->new()\n";

# Note that all parameters for the $in, $out, and $writer objects are optional.
# Default in = STDIN; Default out = STDOUT; Default writer = all columns 
# In this example, we're reading from STDIN and  writing to a file 
# called "hitwriter.out"
# TODO: write hitless reports to STDERR and note if filtered.
my $in     = Bio::SearchIO->new( -format => 'blast', 
				 -fh => \*ARGV,
				 -signif => 0.1, 
				# -verbose=> 2
                               );
my $writer = Bio::SearchIO::Writer::HitTableWriter->new( -columns => \@columns
						       );
my $out    = Bio::SearchIO->new( -format => 'blast',
				 -writer => $writer,
				 -file   => ">hitwriter.out" );
# Need to keep a separate count of reports with hits
# to know when to include labels. The first report may be hitless, 
# so we can't use $in->result_count
my $hit_count = 0;
while ( my $blast = $in->next_result() ) {
  printf STDERR "\nReport %d: $blast\n", $in->result_count;
  
  printf STDERR "query=%s, length=%d\n", $blast->query_name, $blast->query_length;

  if( $blast->hits ) {
      print STDERR "# hits= ", $blast->num_hits, "\n";
      $hit_count++;
      my @hits= $blast->hits;
      print STDERR "frac_aligned_query= ", $hits[0]->frac_aligned_query, "\n";

      $out->write_result($blast, $hit_count==1 );
  }
  else {
    print STDERR "Hitless Blast Report ";
    print STDERR ($blast->no_hits_found ? "\n" : "(filtered)\n");
  }
  
  ## For a simple progress monitor, uncomment this line:
  #print STDERR "."; print STDERR "\n" if $in->result_count % 50 == 0;
}

printf STDERR "\n%d Blast report(s) processed.\n", $in->result_count;
printf STDERR "Output sent to file: %s\n",  $out->file if $out->file;

BioPerl-1.6.923/examples/searchio/hspwriter.pl000555000765000024       607512254227332 21450 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl 

# Demonstrates the use of a SearchIO Blast parser and a SearchWriterI object
# for producing tab-delimited output of HSP data from a Blast report 
# input stream.
#
# Each row in the output represents data for a single HSP.
#
# This parser represents a new and improved version of Bio::Tools::Blast.
#
# Usage:
#   STDIN:  stream containing one or more BLAST or PSI-BLAST reports.
#   STDOUT: none, but generates an output file "hspwriter.out"
#           containing tab-delimited data on a per-HSP basis.
#   STDERR: Progress info and any errors.
#
# In this example, we create a SearchIO parser that screens out hits 
# based on expect (or P) scores and a default HSPTableWriter. This writer
# provides the same functionality as the original Bio::Tools::Blast::table2()
# function (i.e., a tab-delimited summary of each hit per row).
# HSPTableWriter, however, is customizable so you can specify just the columns
# you want to have in the output table.
#
# For more documentation about the writer, including
# a complete list of columns, execute:
#   perldoc Bio::SearchIO::Writer::HSPTableWriter.
#
# For more documentation about working with Blast result objects,
# see docs for these modules:
#   Bio::Search::Result::BlastResult
#   Bio::Search::Iteration::IterationI
#   Bio::Search::Hit::BlastHit
#   Bio::Search::HSP::BlastHSP
#
# For more documentation about the Blast parser, see docs for
#   Bio::SearchIO
#
# Author: Steve Chervitz 

use strict;
use lib '../../';

use Bio::SearchIO;
use Bio::SearchIO::Writer::HSPTableWriter;

# These are the columns that will be in the output table of BLAST results.
my @columns = qw(
		 query_name
		 query_length
                 hit_name
                 hit_length
		 rank
                 expect
                 frac_identical_query
                 length_aln_query
                 gaps_total
                 strand_query
                 strand_hit
		);


print STDERR "\nUsing SearchIO->new()\n";

# Note that all parameters for the $in, $out, and $writer objects are optional.
# Default in = STDIN; Default out = STDOUT; Default writer = all columns 
# In this example, we're reading from STDIN and  writing to a STDOUT
my $in     = Bio::SearchIO->new( -format => 'blast',
				 -fh => \*ARGV
                               );
my $writer = Bio::SearchIO::Writer::HSPTableWriter->new( -columns => \@columns );
my $out    = Bio::SearchIO->new( -format => 'blast', 
				 -writer => $writer,
				 -file   => ">hspwriter.out" );

while ( my $result = $in->next_result() ) {
  printf STDERR "\nReport %d: $result\n", $in->result_count;
  
  if( $result->hits ) {
    $out->write_result($result, ($in->result_count - 1 ? 0 : 1) );
  }
  else {
    print STDERR "Hitless Blast Report: $result ";
    print STDERR ($result->no_hits_found ? "\n" : "(filtered)\n");
  }
  
  ## For a simple progress monitor, uncomment this line:
  #print STDERR "."; print STDERR "\n" if $in->result_count % 50 == 0;
}

printf STDERR "\n%d Blast report(s) processed.\n", $in->result_count;
printf STDERR "Output sent to file: %s\n",  $out->file if $out->file;

BioPerl-1.6.923/examples/searchio/htmlwriter.pl000555000765000024       365512254227316 21625 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl 

# Demonstrates the use of a SearchIO Blast parser and a SearchWriterI object
# for producing HTML Blast output from a Blast report input stream.
#
# Usage:
#   STDIN:  none; supply filename of BLAST report on command-line
#   STDOUT: none; generates an output file "searchio.html"
#           containing HTML-formatted Blast Report
#   STDERR: Any errors that occurred.
#
# For more documentation about the writer, including
# a complete list of columns, see the docs for 
#   Bio::SearchIO::Writer::HTMLResultWriter.
#
# For more documentation about working with Blast result objects,
# see docs for these modules:
#   Bio::Search::Result::BlastResult
#   Bio::Search::Iteration::IterationI
#   Bio::Search::Hit::BlastHit
#   Bio::Search::HSP::BlastHSP
#
# For more documentation about the Blast parser, see docs for
#   Bio::SearchIO
#
# Author: Steve Chervitz 


use strict;
use lib '../../';

use Bio::SearchIO;
use Bio::SearchIO::Writer::HTMLResultWriter;

my $outfile = "searchio.html";
my $file = shift or die "Usage: $0 \n       HTML output is saved to $outfile\n";

my $in = Bio::SearchIO->new( -format => 'blast', 
                             -file => $file,  #comment this out to read STDIN
                             #-fh => \*ARGV,  #uncomment this to read from STDIN
                             -verbose => 0 );

my $writer = new Bio::SearchIO::Writer::HTMLResultWriter();
my $out = new Bio::SearchIO(-writer => $writer,
                            -file   => ">$outfile");


while ( my $result = $in->next_result() ) {
    eval {
        # printf STDERR "Report %d: $result\n", $in->result_count;
        $out->write_result($result, 1);
    };
    if($@) {
        warn "Warning: Blast parsing or writing exception caught for $result:\n$@\n";
    }
}

printf STDERR "\n%d Blast report(s) processed.\n", $in->result_count;
printf STDERR "Output sent to file: %s\n",  $out->file if $out->file;
BioPerl-1.6.923/examples/searchio/psiblast_features.pl000555000765000024       316512254227325 23137 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl 

# Example usage of a SearchIO::psiblast parser of traditional format Blast 
# and PSI-Blast reports.
# Illustrates how to grab a set of SeqFeatures from a Blast report.
# This parser represents a new and improved version of Bio/Tools/Blast.pm.
#
# Usage:
#   STDIN:  stream containing one or more BLAST or PSI-BLAST reports.
#   STDOUT: feature start, end data
#   STDERR: Processing info, such as the number of reports processed
#           and the number of hitless reports.
# 
# For more documentation about working with Blast result objects,
# see to documentation for these modules:
#   Bio::Search::Result::BlastResult
#   Bio::Search::Hit::BlastHit
#   Bio::Search::HSP::BlastHSP
#
# For more documentation about the PSI-Blast parser, see docs for
#   Bio::SearchIO::psiblast
#
# Author: Steve Chervitz 

use strict;
use lib '../../';
use Bio::SearchIO;

my $in = Bio::SearchIO->new( -format => 'psiblast',
                             -fh => \*ARGV,
			     -signif => 0.1, 
			     -verbose => 0 );
my @hitless_reports = ();

while ( my $blast = $in->next_result() ) {

    if( $blast->hits ) {
      while( my $feature = $blast->next_feature() ) {
	print "Feature from ", $feature->start, " to ", $feature->end, "\n";
      }
    }
    else {
      push @hitless_reports, $blast;
    }
}

printf STDERR "\n%d Blast report(s) processed.\n", $in->result_count;
printf STDERR "\n%d reports had no hits:\n", scalar(@hitless_reports);

foreach my $blast (@hitless_reports) {
    print STDERR "No hits for query ", $blast->query_name;
    print STDERR ($blast->no_hits_found ? "\n" : "(filtered)\n")
;
}
  

BioPerl-1.6.923/examples/searchio/psiblast_iterations.pl000555000765000024       426712254227326 23507 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl 

# Demonstrates the use of a SearchIO parser for processing
# the iterations within a PSI-BLAST report.
#
# Usage:
#   STDIN:  none; supply filename of PSI-BLAST report on command-line
#   STDOUT: information parsed from the input data.
#   STDERR: errors.
#
# For more documentation about working with Iteration objects,
# see docs for:
#   Bio::Search::Iteration::IterationI
#
# Author: Steve Chervitz 

use strict;
use lib '../../';

use Bio::SearchIO;

my $file = shift or die "Usage: $0 \n";
my $in = new Bio::SearchIO(-format => 'blast',
                           -file => $file, #comment this out to read STDIN
                           #-fh => \*ARGV,  #uncomment this to read STDIN
                          );

# Iterate over all results in the input stream
while (my $result = $in->next_result) {

    printf "Result #%d: %s\n", $in->result_count, $result->to_string;
    printf "Total Iterations: %d\n", $result->num_iterations();

    # Iterate over all iterations and process old and new hits
    # separately.

    while( my $it = $result->next_iteration) { 
        printf "\nIteration %d\n", $it->number;
        printf "Converged: %d\n", $it->converged;

        # Print out the hits not found in previous iteration
        printf "New hits: %d\n", $it->num_hits_new;
        while( my $hit = $it->next_hit_new ) {
            printf "  %s, Expect=%g\n", $hit->name, $hit->expect; 
        }

        # Print out the hits found in previous iteration
        printf "Old hits: %d\n", $it->num_hits_old; 
        while( my $hit = $it->next_hit_old ) {
            printf "  %s, Expect=%g\n", $hit->name, $hit->expect; 
        }
    }
    printf "%s\n\n", '-' x 50;
}

printf "Total Reports processed: %d: %s\n", $in->result_count;

__END__

# NOTE: The following functionality is just proposed
# (does not yet exist but might, given sufficient hew and cry):

# Zero-in on the new hits found in last iteration.
# By default, iteration() returns the last one.

my $last_iteration = $result->iteration();
while( my $hit = $last_iteration->next_hit) {
    # Do something with new hit...
}

# Get the first iteration

my $first_iteration = $result->iteration(1);

BioPerl-1.6.923/examples/searchio/rawwriter.pl000555000765000024       365212254227335 21450 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl 

# Demonstrates the use of a SearchIO Blast parser for producing
# output of raw HSP data from a Blast report input stream.
#
# Shows how to print out raw BLAST alignment data for each HSP.
#
# Usage:
#   STDIN:  stream containing one or more BLAST or PSI-BLAST reports.
#   STDOUT: Raw alignment data for each HSP of each hit (BLAST format)
#   STDERR: Progress info and any errors.
#
# For more documentation about working with Blast result objects,
# see docs for these modules:
#   Bio::Search::Result::BlastResult
#   Bio::Search::Hit::BlastHit
#   Bio::Search::HSP::BlastHSP
#
# For more documentation about the PSI-Blast parser, see docs for
#   Bio::SearchIO::psiblast
#
# Author: Steve Chervitz 
#
# TODO: 
#   * Implement a Bio::SearchIO::Writer::HSPTextWriter object
#     that can do this. Then this example can fit into the standard
#     model used by the other writer examples in which a writer
#     object is created and hooked up with a SearchIO output object.

use strict;

use lib '../../';

use Bio::SearchIO;

# In this case, we only want raw alignments, and we only need to screen
# on significance info (E- or P-value) so we don't need
# to do a full parse of the alignments. Thus, we're using a -shalow_parse
# flag to indicate that we don't need to parse alignments. This should
# result in faster processing.
# TODO: Convert this to use -format='blast'. Shallow-parse option not supported there.
my $in = Bio::SearchIO->new(-format => 'psiblast', 
                            -fh => \*ARGV,
			    -signif => 0.1,
			    -shallow_parse => 1,
			    -hold_raw_data => 1 );

while ( my $result = $in->next_result() ) {
  print STDERR "\nBLAST Results for $result\n\n";
  my $count = 0;
  foreach( $result->hits ) {
    print "Alignment for hit #", ++$count, "\n\n";
    print $_->raw_hit_data();
  }
  print "=" x 50 , "\n";
}

printf STDERR "\n%d Blast report(s) processed.\n", $in->result_count;

BioPerl-1.6.923/examples/searchio/resultwriter.pl000555000765000024       735412254227340 22174 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl 

# Demonstrates the use of a SearchIO Blast parser and a SearchWriterI object
# for producing tab-delimited output of result data from a Blast report 
# input stream.
#
# This writer only outputs information at the level of the result object.
# This shows that you can work with a writer that only knows about 
# Bio::Search::Result objects and doesn't care about hit or HSP data. 
# Therefore, the output from this example doesn't contain any information 
# about hits or HSPs. 
# See the hitwriter.pl and hspwriter.pl examples for that.
#
# This parser represents a new and improved version of Bio::Tools::Blast.
#
# Usage:
#   STDIN:  stream containing one or more BLAST or PSI-BLAST reports.
#   STDOUT: none, but generates an output file "resultwriter.out"
#           containing tab-delimited data on a per-report basis.
#   STDERR: Any errors that occurred.
#
# For more documentation about the writer, including
# a complete list of columns, see the docs for 
#   Bio::SearchIO::Writer::ResultTableWriter.
#
# For more documentation about working with Blast result objects,
# see docs for these modules:
#   Bio::Search::Result::BlastResult
#   Bio::Search::Iteration::IterationI
#   Bio::Search::Hit::BlastHit
#   Bio::Search::HSP::BlastHSP
#
# For more documentation about the Blast parser, see docs for
#   Bio::SearchIO
#
# Author: Steve Chervitz 


use strict;
use lib '../../';

use Bio::SearchIO;
use Bio::SearchIO::Writer::ResultTableWriter;
use Bio::SearchIO::Writer::HTMLResultWriter;

print "\nUsing SearchIO->new()\n";


# Note that all parameters for the $in, $out, and $writer objects are optional.
# Default in = STDIN; Default out = STDOUT; Default writer = all columns
# In this example, we're reading from STDIN and  writing to STDOUT
# and using the default columns for the writer.
# We're also telling the script to timeout if input isn't received
# within 10 sec. (Note the clock is still ticking when you background the job.)
# Setting verbose to 1 is useful for debugging.
my $in = Bio::SearchIO->new( -format => 'blast', 
                             -fh => \*ARGV,
                             -signif => 0.1, 
                             -verbose => 0, 
                             -timeout_sec => 10 );
# not specifying any columns to get the default.
my $writer = Bio::SearchIO::Writer::ResultTableWriter->new();
my $out    = Bio::SearchIO->new( -format => 'blast', 
                                 -writer => $writer,
                                 -file => ">resultwriter.out");

my $writerhtml = new Bio::SearchIO::Writer::HTMLResultWriter();
my $outhtml = new Bio::SearchIO(-writer => $writerhtml,
                                -file   => ">searchio.html");


while ( my $result = $in->next_result() ) {
    eval {
        # printf STDERR "Report %d: $result\n", $in->result_count;
        $out->write_result($result, ($in->result_count - 1 ? 0 : 1) );
        
        $outhtml->write_result($result, 1);

        # To get at the statistical parameters:
        # Calling raw_statistics() returns a list containing the
        # unparsed lines of the parameters section of the report.
        # Here we're only interested in parameters beginning with "effective".
        #         print "Report Stats, effective data:\n";
        #         foreach( $result->raw_statistics) {
        #             print "$_" if /^effective/i;
        #         }
        
	## For a simple progress monitor, uncomment this line:
	#print STDERR "."; print STDERR "\n" if $in->result_count % 50 == 0;
    };
    if($@) {
        warn "Warning: Blast parsing or writing exception caught for $result:\n$@\n";
    }
}

printf STDERR "\n%d Blast report(s) processed.\n", $in->result_count;
printf STDERR "Output sent to file: %s\n",  $out->file if $out->file;
BioPerl-1.6.923/examples/searchio/waba2gff.pl000555000765000024       141312254227333 21070 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
use strict;
use Bio::SearchIO;
use Getopt::Long;
use Benchmark;

my ($infile,$outfile,$verbose);

GetOptions( 
	    'i|input:s'  => \$infile,
	    'o|output:s' => \$outfile,
	    'v|verbose'  => \$verbose,
	    );
$infile = shift unless $infile;

my $in = new Bio::SearchIO(-format => 'waba',
			   -file   => $infile, #comment out to read from STDIN
                           #-fh => \*ARGV,  # uncomment to read from STDIN
			   -verbose => $verbose);

my $out;
if( defined $outfile) {
    $out = new Bio::Tools::GFF(-file => ">$outfile");
} else {
    $out = new Bio::Tools::GFF(-verbose => $verbose);
}

while( my $r = $in->next_result ) {
    while( my $hit = $r->next_hit ) {
	while( my $hsp = $hit->next_hsp ) {
	    $out->write_feature($hsp);
	}
    }
}
BioPerl-1.6.923/examples/searchio/waba2gff3.pl000555000765000024      1066512254227334 21205 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=head1 NAME

waba2gff3.pl - convert waba output into GFF3 suitable for Gbrowse

=head1 DESCRIPTION

This script turns WABA output into GFF3 output for the query sequence.
If you need to get this where the Hit sequence is the reference
sequence you'll want to flip-flop the code to use hit instead of
query.  I didn't try and make it that general yet.

I don't (yet) know how the 'score' field is calculate by Wormbase
folks for WABA data in their GFF dumps.  I'm checking on that but it
shouldn't make a difference for Gbrowse.

=head1 AUTHOR

Jason Stajich, jason-at-bioperl-dot-org
Duke University, 

=head1 LICENSE

This script is available under the Perl Artistic License meaning you
can do with it what you wish.  

Please do tell me about bugs or improvements so I can roll those back
in for other people to use.


=cut

 

use strict;
use Bio::SearchIO;
use Bio::SeqFeature::Generic;
use Bio::Tools::GFF;
use Getopt::Long;

my %States = ('1' => 'coding',
	      '2' => 'coding',
	      '3' => 'coding',
	      'L'  => 'weak',
	      'H'  => 'strong',
	     );
my ($infile,$outfile,$verbose,$version);
$version = 3;
my $ptag = 'nucleotide_match';
GetOptions( 
    'i|input:s'  => \$infile,
    'o|output:s' => \$outfile,
    'v|verbose'  => \$verbose,
    'version'    => \$version,
    'p|primary|primary_tag:s' => \$ptag,
);
$infile = shift unless $infile;

my $in;

if( $infile ) {
    $in = new Bio::SearchIO(-verbose => $verbose,
			    -format  => 'waba',
			    -file    => $infile);
} else {
    $in = new Bio::SearchIO(-verbose => $verbose,
			    -format  => 'waba',
			    -fh      => \*ARGV);
}

my $out;
if( defined $outfile) {
    $out = new Bio::Tools::GFF(-gff_version => $version,
			       -file => ">$outfile",
			       -verbose => $verbose);
} else {
    $out = new Bio::Tools::GFF(-gff_version => $version,
			       -verbose     => $verbose);
}

while( my $r = $in->next_result ) {
    while( my $hit = $r->next_hit ) {
	while( my $hsp = $hit->next_hsp ) {
	    # now split this HSP up into pieces
	    my ($qs,$qe,$hs,$he)= ($hsp->query->start,
				   $hsp->query->end,
				   $hsp->hit->start,
				   $hsp->hit->end);
	    my $i = 0;
	    # grab the HMM states from Jim's WABA output
	    my $stateseq = $hsp->hmmstate_string;
	    my $state_len = length($stateseq);
	    my ($piece,$gap,@pieces);
	    $piece = {'length'   => 0,
		      'str'      => '',
		      'start'    => $i};
	    $gap = 0;
	    
	    # parse the state string, finding the gaps (Q and T states)
	    # runs of Non Q or T letters indicate a 'piece'
	    while($i <  $state_len ) {
		my $char = substr($stateseq,$i,1);
		if($char =~ /[QT]/ ) {
		    $gap++;
		} elsif( $gap ) {
		    # just finished a gap
		    $piece->{'length'} = length($piece->{'str'});
		    push @pieces, $piece;
		    $piece = {'length' => 0,
			      'str'    => '',
			      'start'  => $i };
		    $gap = 0;
		} else {
		    $piece->{'str'} .= $char;
		}
		$i++;
	    }
	    # for each piece, this could be made up of things either 
	    # as H,L, or 123 state. 
	    # In retrospect this could all probably be contained in a 
	    # single loop, but now I'm feeling lazy. I had just converted this
	    # from using 'split' in the first place if you want to know
	    # why it is structured this way....
	    for my $piece ( @pieces ) {
		
		my $len = $piece->{length};
		my $start = $piece->{start};
		my $end = $start + $len;
		my ($j) = 0;
		my $state = substr($piece->{str},$j++,1);
		warn("start is $start end is $end len is $len\n") if $verbose;
		my ($set,@sets) = ($state);
		while( $j < $len ) {
		    my $char = substr($piece->{str},$j++,1);
		    next unless( $char);
		    if( ($char =~ /\d/ && $state =~ /\d/) ||
			($char =~ /\w/ && $char eq $state) ) {
			$set .= $char;
		    } else {
			push @sets, $set;
			$set = $state = $char;
		    }		    
		}
		push @sets, $set;
		for my $set (@sets ) {
		    my $c = substr($set,0,1);
		    if( ! $c ) {
			warn("no char for '$set'\n") if $verbose;
			next;
		    }
		    my $type ='waba_'.$States{$c};
		    my $f = Bio::SeqFeature::Generic->new(
			-start => $qs + $start,
			-end   => $qs + $start + length($set),
			-strand=> $hsp->query->strand,
			-seq_id=> $hsp->query->seq_id,
			-score => $hsp->query->score,
			-primary_tag => $ptag,
			-source_tag  => $type,
			-tag    => {
			    'ID' => $hsp->hit->seq_id
			    });
		    $f->add_tag_value('ID',$hs+$start,$hs+$start+$f->length);
		    $out->write_feature($f);
		    $start += $f->length+1;
		}
	    }
	}
    }
}
BioPerl-1.6.923/examples/sirna000755000765000024          012254227335 16236 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/sirna/rnai_finder.cgi000555000765000024      3545412254227335 21375 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=pod

=head1 NAME

rnai_finder.cgi

=head1 DESCRIPTION

A CGI script using the Bio::Tools::SiRNA package to design RNAi reagents.  
Retrieves sequences from NCBI and generates output in graphic and tabular form.

=head1 INSTALLATION

To use this script, place it in an appropriate cgi-bin directory on a web server.  
The script needs to write its graphic maps to a temporary directory.  Please update
$TMPDIR and $TMPURL to suit your local configuation.

=head1 AUTHOR

Donald Jackson (donald.jackson@bms.com)

=head1 SEE ALSO

L, L, L, L

=cut

use Bio::Tools::SiRNA;

use Bio::Graphics::Panel;
use Bio::DB::NCBIHelper;
use Bio::Seq::RichSeq; # for hand-entry
use Bio::SeqFeature::Generic; 

use GD::Text::Align;
use Clone qw(clone);

use CGI;
use CGI::Carp qw (fatalsToBrowser carpout);

my $q = CGI->new;



# define a bunch of constants
my %COLORRANKS = ( 1 => 'red',
		   2 => 'orchid',
		   3 => 'blue' );
my $TMPDIR = '/var/www/htdocs/tmp/';
my $TMPURL = '/tmp/';
my $ATGPAD = 75; # how far from start do we wait?
my $NOLIGOS = 3;

my $log = $TMPDIR . 'RNAiFinder.log';
open (LOG, ">>$log") or die $!;
carpout(LOG);

print $q->header,
    $q->start_html;
    
print $q->h1('RNAi Finder');


if ($q->param('Design')) {
    if ($q->param('accession') and !$q->param('seq')) {
	$target = get_target();
    }
    else { 
	$target = make_target();
    }
    get_rnai($target);
}
else {
    get_settings();
}


sub get_settings {
    print <Oligos are designed as described on the Tuschl lab web page and are ranked as follows: 

    

  • New: Selecting 'Pol3-compatible targets' looks for oligos with the 
pattern NAR(N17)YNN which can be synthesized or expressed from a Pol3 promoter.

    This selection overrides the 'Cutoff' rank.

  • Oligos with Rank = 1 (best) match the AAN(19)TT rule.

  • Oligos with Rank = 2 match the AAN(21) rule 

  • Oligos with Rank = 3 match the NAN(21) rule.



If percent GC and specificity are similar, Rank 1 oligos are better. All 3 prime overhangs are converted to TT; the rest of the sequence is transcribed into RNA



Modifications to published rules:


    

  • 
Runs of 3 or more consecutive Gs on either strand are skipped - these can cause problems in synthesis. 

  • Users may choose to exclude oligos that overlap single nucleotide polymorphisms (ON by default).  SNP data comes from the NCBI dbSNP database.  

  • 'Low-complexity' regions (such as runs of a single nucleotide) are also excluded.



EOM1
    
    print $q->start_form;
    print $q->h2('Enter your sequence and other parameters:'), "\n";
    print $q->p('The values already here are DEFAULTS - you should change them to suit YOUR sequence');
    print $q->start_table();
    print $q->TR( $q->td({-align=> 'left'}, 
		       [
			$q->textfield(-name 	=> 'mingc', -default => '0.40'),
			$q->textfield(-name 	=> 'maxgc', -default => '0.60'),
			]
		       ),
		      $q->td({-align=> 'left'},
			     $q->popup_menu(-name	 => 'worstrank', 
				      -values 	=> [1,2,3], 
				      -default 	=> 2,
				      ),
			     $q->b('OR'),
			     $q->checkbox(-name 		=> 'pol3',
				    -label		=> 'Pol3 compatible',
				    -default	=> 0,
				    ),
			     ),
		      );	
    print    $q->TR( $q->th({-align=> 'left'}, 'Exclude oligos with SNPs?'),
		     $q->td($q->radio_group(-name => 'avoid_snps', 
					    -values => [1,0],
					    -default => 1,
					    -labels => {1 => 'Yes', 0 => 'No'}
					    )),
		     );

    print $q->TR( $q->th({-align=> 'left'}, 'Sequence Name:'),
		  $q->td({-align=> 'left'},$q->textfield('accession')),
		  $q->td({-align=> 'left'}, 
			 $q->em( q(Enter an accession and you won't have to enter the 
sequence or start/stop. Use accessions beginning with NM_ if possible.))),
		  );

    print $q->TR( $q->th({-align=> 'left'}, ['Position of initiator ATG:', 
					     'NT after start to exclude:',
					     'Position of Stop codon:' ]));
    print $q->TR( $q->td({-align=> 'left'}, 
					   [$q->textfield(-name => 'cdstart', -default => 1),
					    $q->textfield(-name => 'atgpad', -default => $ATGPAD),
					    $q->textfield('cdend'), ]));
    print $q->TR( $q->th({-align=> 'left'}, ['Minimum Fraction GC:', 
					     'Maximum Fraction GC:', 
					     'Rank cutoff',
					     ]));
    print $q->TR($q->th({-align=> 'left', -colspan=>2},'cDNA Sequence in plain text or FASTA format'),
		 $q->td( $q->a({-href =>'Fasta_format.html', -target => 'Fasta_desc'}, 'What is FASTA format?')),
		 );
    print $q->TR($q->td({-align => 'left', -colspan=>3},
		  $q->textarea( -name =>'seq',
				-rows => 4,
				-columns => 80, 
				-wrap => 'virtual',
				)));
    print $q->TR( $q->th({-align => 'left', -colspan=>3},
			 'Output options: '));
    print $q->TR( $q->td({-align=> 'left'},
		   [ $q->checkbox(-name => 'Graphic', -checked => 'checked'), 
		     $q->checkbox(-name =>  'Table',  -checked => 'checked'), 
						 ]));			       		   		
    print $q->TR($q->td({-align=> 'left', -colspan=>3}, $q->submit('Design')));
    print $q->end_table();		
    print $q->end_form;

}

sub get_rnai {
    # design and output RNAi reagents
    my ($gene) = @_;

    my $factory = Bio::Tools::SiRNA->new( -target 	=> $gene, 
					  -tmpdir	=> $TMPDIR,
					  -cutoff 	=> $q->param('worstrank') || 2,
					  -avoid_snps	=> $q->param('avoid_snps') || 1, 
					  -min_gc	=> $q->param('min_gc') || 0.40,
					  -max_gc	=> $q->param('max_gc') || 0.60,
					  -pol3		=> $q->param('pol3') || 0,
					  );

    print $q->p('Designing Pol3-compatible oligos') if ($q->param('pol3'));

    my @pairs = $factory->design;

    draw_gene($gene) if ($q->param('Graphic'));
    print_table($gene->accession, \@pairs) if ($q->param('Table'));
    print_text($gene->accession, \@pairs) if ($q->param('Text'));
}

sub get_target {
    my ($acc) = $q->param('accession');
    my $gb = Bio::DB::NCBIHelper->new();
    my $seq = $gb->get_Seq_by_acc($acc);

    if ($seq) { 
	return $seq;
    }
    else {
	print_error("Unable to retrieve sequence from GenBank using accession $acc");
	return;
    }

}

sub make_target {
      # sanity chex - do we have the necessary info?
      $q->param('seq') or print_error("Please supply a sequence", 1);
      my $seq = $q->param('seq');
      my $name;

      # is sequence in fasta format?
      if ($seq =~ /^>/) {
	  my ($head, $realseq) = split (/\n/, $seq, 2);
	  $head =~ /^>(.+?) /;
	  $name = $1;
	  $realseq =~ s/[\n|\r|\s]//g;
	  $seq = $realseq;
      }
      elsif ($q->param('accession')) {
  	$name = $q->param('accession');
	$seq =~ s/[\n|\r|\s]//g;
      }
      else {
  	print_error('Please supply a sequence name!');
  	return;
      }

      $cds_start = $q->param('cds_start') || 1;
      $cds_end = $q->param('cds_end') || length($seq);

      # create a new Bio::Seq::RichSeq object from parameters 
      my $seqobj = Bio::Seq::RichSeq->new( -seq 		=> $seq,
					   -accession_number	=> $name,
					   -molecule		=> 'DNA',
					   
  				     );
      my $cds = Bio::SeqFeature::Generic->new( -start 	=> $cds_start,
					       -end	=> $cds_end,
  					     );
      $cds->primary_tag('CDS');
      $seqobj->add_SeqFeature($cds);
      return $seqobj;
     
}
sub draw_gene {
# now draw a pretty picture
    my ($gene) = @_;

    my $panel = Bio::Graphics::Panel->new( -segment 	=> $gene,
					   -width 	=> 600,
					   -pad_top	=> 100,
					   -pad_bottom  => 20,
					   -pad_left	=> 50,
					   -pad_right	=> 50,
					   -fontcolor	=> 'black',
					   -fontcolor2  => 'black',
					   -key_color	=> 'white',
					   -grid	=> 1,
					   -key_style	=> 'between',
					   #-gridcolor	=> 'lightgray',
					   );

    my $genefeat = Bio::SeqFeature::Generic->new( -start	=> 1,
						  -end 	       	=> $gene->length);

    $panel->add_track( arrow	=> $genefeat,
		       -bump	=> 0,
		       -tick	=> 2,
		       -label 	=> 1,
		       );

    my %feature_classes;

    foreach $feat($gene->top_SeqFeatures) {
	$feature_classes{ $feat->primary_tag } ||= [];

	push(@{ $feature_classes{ $feat->primary_tag } }, $feat);
    }

# for some reason, Bio::Graphics insists on drawing subfeatures for SiRNA::Pair objects...
    $cleanpairs = cleanup_feature($feature_classes{'SiRNA::Pair'});

# draw
    $panel->add_track( transcript	=> $feature_classes{'gene'},
		       -bgcolor	=> 'green',
		       -fgcolor	=> 'black',
		       -fontcolor2  => 'black',
		       -key		=> 'Gene',
		       -bump	=> +1,
		       -height	=> 8,
		       -label	=> \&feature_label,
		       -description	=> 1,
		       );

    $panel->add_track( transcript2	=> $feature_classes{'CDS'},
		       -bgcolor		=> 'blue',
		       -fontcolor2  => 'black',
		       -fgcolor		=> 'black',
		       -key		=> 'CDS',
		       -bump		=> +1,
		       -height		=> 8,
		       -label		=> \&feature_label,
		       -description		=> \&feature_desc,
		       );

    $panel->add_track( $feature_classes{'variation'},
		       -bgcolor	=> 'black',
		       -fgcolor	=> 'black',
		       -fontcolor2  => 'black',
		       -key	=> 'SNPs',
		       -bump	=> +1,
		       -height	=> 8,
		       -label	=> \&snp_label,
		       #-glyph	=> 'triangle',
		       -glyph	=> 'diamond',
		       -description		=> \&feature_desc,
		       );

    $panel->add_track( generic	=> $feature_classes{'Excluded'},
		       -bgcolor	=> 'silver',
		       -fgcolor	=> 'black',
		       -fontcolor  => 'black',
		       -fontcolor2  => 'black',
		       -key	=> 'Excluded Regions',
		       -bump	=> +1,
		       -height	=> 6,
		       -label	=> \&feature_label,
		       -description		=> \&feature_desc,
		       );

    $panel->add_track( 
		       generic => $cleanpairs,
		       -bgcolor	=> \&feature_color,
		       -fgcolor	=> \&feature_color,
		       -fontcolor  => 'black',
		       -fontcolor2  => 'black',
		       -key	=> 'SiRNA Reagents',
		       -bump	=> +1,
		       -height	=> 8,
		       -label	=> \&feature_label,
		       -glyph	=> 'generic',
		       -description		=> \&feature_desc,
		       );

    my $gd = $panel->gd;
    my $black = $gd->colorAllocate(0,0,0);
    my $txt = GD::Text::Align->new($gd);    
    $txt->set( valign => 'center', align => 'center', color => $black);
    #$txt->set_font(['/usr/share/fonts/truetype/VERDANA.TTF',gdGiantFont ], 10);
    $txt->set_font(gdGiantFont);
    $txt->set_text("RNAi Reagents for ".$gene->accession );
    $txt->draw(200, 50, 0);

    my $pngfile = $TMPDIR . $gene->accession . '.png';
    my $pngurl = $TMPURL . $gene->accession . '.png';
    open (IMG, ">$pngfile") or die $!;
    binmode IMG;
    print IMG $gd->png;
    close IMG;

    # also get the imagemap boxes
    my @pairboxes = extract_pairs($panel->boxes);

    print $q->img({-src => $pngurl, -usemap=>"#MAP"});
    print $q->p('Oligos are color coded: rank 1 in ', 
		$q->font({-color => $COLORRANKS{1}}, $COLORRANKS{1}),
		', rank 2 in ',
		$q->font({-color => $COLORRANKS{2}}, $COLORRANKS{2}),
		' and rank 3 in ',
		$q->font({-color => $COLORRANKS{3}}, $COLORRANKS{3}),
		'. Click on an oligo to bring it up in the table below');

    print_imagemap(@pairboxes);

}

sub feature_label {
    my ($feature) = @_;
    my (@notes, @label);
    #$label = ucfirst($feature->primary_tag);
    foreach (qw(note name product gene)) {
	if ($feature->has_tag($_)) {
	    @notes = $feature->each_tag_value($_);
	    #$label .= ': ' . $notes[0];
	    push(@label, $notes[0]);
	    last;
	}
    }
    return join(': ', @label);
    #return $label;
}

sub feature_color {
    my ($feature) = @_;
    my ($rank) = $feature->each_tag_value('rank');
    #print STDERR "Feature rank: $rank COLOR $COLORRANKS{$rank}\n";
    return $COLORRANKS{$rank};
    #return 'red';
}


sub print_table {
    my ($accession, $pairs) = @_;

    print $q->h2("RNAi Reagents for $accession");
    print $q->start_table({-border => 1, -cellpadding => 2});
    print $q->TR( $q->th(['Reagent #', 'Start', 'Stop', 'Rank', 'Fxn GC', 'Sense Oligo', 'Antisense Oligo', 'Target' ]) ), "\n";


    my $i = 1;

    foreach $pair ( sort { $a->start <=> $b->start } @$pairs ) {
	my $sense = $pair->sense;
	my $anti = $pair->antisense;
	my $color = feature_color($pair);

#  	my $blasturl = "http://nunu.hpw.pri.bms.com/biocgi/versablast.pl?p=blastn&sequence=";
#  	$blasturl .= $pair->seq->seq;
#  	$blasturl .= "&action=Nucleotide Databases";

	print 
	    $q->TR( $q->td( [ $q->a({-name => 'RNAi' . $pair->start}) . $i,
			      $pair->start, 
			      $pair->end,
			      $q->font({-color => $color},$pair->rank), 
			      $pair->fxGC,
			      $q->tt($sense->seq), 	
			      $q->tt($anti->seq),
			      $q->tt($pair->seq->seq),
#  			      $q->a({-href=>$blasturl,
#  				     -target=>"blastn"},
#  				    "BLAST this target"),
			      ] ) ),
	"\n";
	$i++;
    }
    print $q->end_table;
}





sub print_text {
    my ($accession,  $pairs ) = @_;
    my ($pair);

    print "RNAi reagents for $accession \n";

    print join("\t", qw(Start Stop Rank Sense Antisense)), "\n";
    foreach $pair (@$pairs ) {
	my $sense = $pair->sense;
	my $anti = $pair->antisense;

	print join("\t", $pair->start, $pair->end, $pair->rank, $sense->seq, $anti->seq), "\n";


    }


}

sub cleanup_feature {
    my ($flist) = @_;

    my ($feat, @clean, $cfeat);

    foreach $feat(@$flist) {
	$cfeat = clone($feat);
#	$cfeat = $feat->clone;
	$cfeat->flush_sub_SeqFeature;
	push (@clean, $cfeat); # will they 
    }
    return \@clean;
}


sub extract_pairs {
    # get SiRNA::Pair features ONLY for imagemap
    return ( grep {ref($_->[0]) eq "Bio::SeqFeature::SiRNA::Pair"} @_ );
}

sub print_imagemap {
    my @items = @_;

    print q(), "\n";

    my $i = 1;
    
    foreach $item (@items) {
	my ($feature, $x1, $y1, $x2, $y2) = @$item;
	my $fstart = $feature->start; # should be unique
	my $text = 'RNAi #' . $i. ' Start=' . $feature->start . ' Rank='.$feature->rank;
	print qq(), "\n";
	warn "Mouseover text: $text\n";

	$i++;
    }
    print "\n";
}


sub print_error {
    # print error messages in big red type. Provide more graceful die/warn to end user
    my ($msg, $fatal) = @_;
    print $q->h3($q->font({-color=>'RED'}, $msg));
    
    if ($fatal) {
	print $q->end_html;
	die "$msg \n";
    }
    else {
	warn $msg;
    }
}

sub dump {
    print $q->start_ul;

    foreach ($q->param) {
	print $q->li($_),
	$q->ul($q->li([ $q->param($_) ]));
    }
}
    
sub snp_label {
    # special format for SNPs
    my ($feature) = @_;
    my $label;

    if ( $feature->has_tag('db_xref') ) {
	my @notes = $feature->each_tag_value('db_xref');
	$label .= $notes[0];
	$label .= ' ';
    }
    if ( $feature->has_tag('allele') ) {
	my ($nt1, $nt2) = $feature->each_tag_value('allele');
	$label .=  $nt1 . '->' . $nt2;
    }
    return $label;
}

sub feature_desc {
    my ($feature) = @_;
    my $desc = $feature->start;
    $desc .= '-' . $feature->end unless ($feature->start == $feature->end);
    return $desc;
}
BioPerl-1.6.923/examples/sirna/TAG000444000765000024        11112254227331 16676 0ustar00cjfieldsstaff000000000000These are scripts for designing SiRNA reagents using Bio::Tools::SiRNA.pmBioPerl-1.6.923/examples/structure000755000765000024          012254227326 17162 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/structure/structure-io.pl000555000765000024       126312254227326 22326 0ustar00cjfieldsstaff000000000000#!/bin/perl
# Getting  Entry, Chain, Residue, and Atom objects given a PDB file

use Bio::Structure::IO;
use strict;

my $file = shift or die "No PDB file\n";
my $structio = Bio::Structure::IO->new(-file => $file);
my $struc = $structio->next_structure;

for my $chain ($struc->get_chains) {
   my $chainid = $chain->id;
   # one-letter chaincode if present, 'default' otherwise
   for my $res ($struc->get_residues($chain)) {
      my $resid = $res->id;
      # format is 3-lettercode - dash - residue number, e.g. PHE-20
      my $atoms = $struc->get_atoms($res);
      # actually a list of atom objects, used here to get a count
      print join "\t", $chainid,$resid,$atoms,"\n";
   }
}
BioPerl-1.6.923/examples/tk000755000765000024          012254227327 15541 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/tk/gsequence.pl000555000765000024     14717412254227317 20272 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# gSequence - Protein Sequence Control Panel
# by Lorenz Pollsk
#
# this is work in progress! use this only for testing

use Gtk;
use strict;
use Bio::Seq;
use Bio::SeqIO;
use Bio::Tools::SeqStats;
use Bio::SeqFeature::Generic;
use Bio::Index::Abstract;
use Bio::DB::GenBank;
use Bio::DB::GenPept;

init Gtk;

# constant
my $false = 0;
my $true = 1;

# global widgets
my ($main_notebook,@main_label,@seq_edit);
my $about_dialog;
my ($import_dialog,$import_entry,@import_buttons,$import_from);
my ($description_window,$description_edit);
my ($comment_window,$comment_edit,$current_comment,$comment_frame);
my ($seqstats_window,$seqstats_edit);
my ($dblink_window,@dblink_entry,$current_dblink,$dblink_clist,$dblink_handler_id);
my ($ref_window,@ref_entry,$current_ref,$ref_clist,$ref_handler_id);
my ($feature_window,@feature_entry,$current_feature_item,@feature_spinner,
    $feature_handler_id,$feature_tree);
my ($pref_window,@pref_entry);

# global file data
my @seq;
my @filename;
my @modified;
my @locked; # locked sequence for editing ?
my $current;

# menu
my @menu_items = ( { path        => '/_File',
		     type        => '' },
		   { path        => '/File/_New',
		     accelerator => 'N',
		     callback    => \&new },
		   { path        => '/File/_Open SwissProt',
		     accelerator => 'O',
		     callback    => \&open_dialog },
		   { path        => '/File/_Save SwissProt',
		     accelerator => 'S',
		     callback    => \&save },
		   { path        => '/File/Save _As...',
		     callback    => \&saveas_dialog },
		   { path        => '/File/Close',
		     callback    => \&close },
		   { path        => '/File/sep1',
		     type        => '' },
		   { path        => '/File/_Import from...',
		     type        => '' },
                   { path        => '/File/Import from.../Remote DB',
		     type        => '' },
                   { path        => '/File/Import from.../Remote DB/AceDB',
		     callback    => sub { &seq_import("ace"); } },
                   { path        => '/File/Import from.../Remote DB/GenPept',
		     callback    => sub { &seq_import("genpept"); } },
                   { path        => '/File/Import from.../Flat File Index',
		     type        => '' },
                   { path        => '/File/Import from.../Flat File Index/Fasta',
		     callback    => sub { &seq_import("fasta"); } },
                   { path        => '/File/Import from.../Flat File Index/SwissProt',
		     callback    => sub { &seq_import("swissprot"); } },
                   { path        => '/File/Import from.../Flat File Index/SwissPfam',
		     callback    => sub { &seq_import("swisspfam"); } },
		   { path        => '/File/_Export to...' },
		   { path        => '/File/sep2',
		     type        => '' },
		   { path        => '/File/_Quit',
		     callback    => sub { Gtk->exit( 0 ); } },

		   { path        => '/_Edit',
		     type        => '' },
		   { path        => '/Edit/C_ut',
		     callback    => sub { $seq_edit[$current]->cut_clipboard(); },
		     accelerator => 'X' },
		   { path        => '/Edit/_Copy',
		     callback    => sub { $seq_edit[$current]->copy_clipboard(); },
		     accelerator => 'C' },
		   { path        => '/Edit/_Paste',
		     callback    => sub { $seq_edit[$current]->paste_clipboard(); },
		     accelerator => 'V' },
		   { path        => '/Edit/Select All',
		     callback    => sub { $seq_edit[$current]->select_region(0,-1); } },

		   { path        => '/_Specs',
		     type        => '' },
		   { path        => '/Specs/_Sequence Stats',
		     callback    => sub {&update_seqstats_window(1);} },
		   { path        => '/Specs/sep1',
		     type        => '' },
		   { path        => '/Specs/_Description',
		     callback    => sub {&update_description_window(1);} },
		   { path        => '/Specs/_Comments',
		     callback    => sub {&update_comment_window(1);} },
		   { path        => '/Specs/_DB Links',
		     callback    => sub {&update_dblink_window(1);} },
		   { path        => '/Specs/_References',
		     callback    => sub {&update_reference_window(1);} },
		   { path        => '/Specs/sep2',
		     type        => '' },
		   { path        => '/Specs/_Features',
		     callback    => sub {&update_feature_window(1);} },

		   { path        => '/_Tools',
		     type        => '' },
		   { path        => '/Tools/Code Table' },
		   { path        => '/Tools/sep1',
		     type        => '' },
		   { path        => '/Tools/local Blast' },
		   { path        => '/Tools/local HMMER' },
		   { path        => '/Tools/hmmpfam' },
		   { path        => '/Tools/web Blast' },

		   { path        => '/_Options',
		     type        => '' },
		   { path        => '/Options/_Preferences',
		     callback    => sub {&update_pref_window(1);} },

		   { path        => '/_Help',
		     type        => '' },
		   { path        => '/Help/Help' },
		   { path        => '/Help/_About...',
		     callback    => sub { $about_dialog->show_all();} } );

### main

$current = 0;
&init_windows();
main Gtk;
exit( 0 );


### Subroutines

sub init_windows
{
    &init_main_window();
    &init_about_dialog();
    &init_import_dialog();
    &init_seqstats_window();
    &init_description_window();
    &init_comment_window();
    &init_dblink_window();
    &init_reference_window();
    &init_feature_window();
    &init_pref_window();
}

sub init_main_window
{
    # toplevel window
    my $window;
    $window = new Gtk::Window( 'toplevel' );
    $window->signal_connect( 'destroy', sub { Gtk->exit( 0 ); } );
    $window->set_title( "gSequence" );
    $window->set_usize( 600, 400 );

    # vertical box containing menu and text editor widget
    my $main_vbox;
    $main_vbox = new Gtk::VBox( $false, 1 );
    $main_vbox->border_width( 1 );
    $window->add( $main_vbox );

    # handlebox for menubar
    my $handlebox;
    $handlebox = new Gtk::HandleBox();
    $main_vbox->pack_start( $handlebox, $false, $true, 0 );

    # menubar
    my $menubar;
    $menubar = get_menu( $window );
    $handlebox->add( $menubar );

    # text widget
    $seq_edit[$current] = new Gtk::Text( undef, undef );
    $seq_edit[$current]->set_editable( $true );

    # vertical scrollbar for text widget
    my $scrollbar;
    $scrollbar = new Gtk::VScrollbar( $seq_edit[$current]->vadj );

    # horizontal box containing text widget and scrollbar
    my $seq_edit_hbox;
    $seq_edit_hbox = new Gtk::HBox( $false, 1 );
    $seq_edit_hbox->border_width( 1 );
    $seq_edit_hbox->pack_start( $seq_edit[$current], $true, $true, 0);
    $seq_edit_hbox->pack_end( $scrollbar, $false, $true, 0);

    $main_notebook = new Gtk::Notebook();
    $main_notebook->set_tab_pos( 'top' );

    $main_vbox->pack_end( $main_notebook, $true, $true, 0);

    # show everything
    $window->show_all();

    $main_notebook->signal_connect_after("switch-page",
       sub{ #$seq[$current]->seq($seq_edit[$current]->get_chars(0,-1)) 
	    #   if (defined($seq[$current]));
	    $current = $main_notebook->get_current_page(); 
	    &update_seq_data(); } );
}

sub get_menu
{
    my ( $window ) = @_;
    
    my $menubar;
    my $item_factory;
    my $accel_group;

    $accel_group = new Gtk::AccelGroup();

    # This function initializes the item factory.
    # Param 1: The type of menu - can be 'Gtk::MenuBar', 'Gtk::Menu',
    #          or 'Gtk::OptionMenu'.
    # Param 2: The path of the menu.
    # Param 3: The accelerator group.  The item factory sets up
    #          the accelerator table while generating menus.
    $item_factory = new Gtk::ItemFactory( 'Gtk::MenuBar',
					  '
',
					  $accel_group );

    # This function generates the menu items. Pass the item factory,
    # the number of items in the array, the array itself, and any
    # callback data for the the menu items.
    $item_factory->create_items( @menu_items );

    # Attach the new accelerator group to the window.
    $window->add_accel_group( $accel_group );

    # Finally, return the actual menu bar created by the item factory.
    #*menubar = gtk_item_factory_get_widget (item_factory, "<main>");
    return ( $item_factory->get_widget( '
' ) );
}

sub new_seq_page
{
    my ($seq) = shift;
    my $curr;

    push @seq,$seq;
    $curr = @seq - 1;
    $main_label[$curr] = new Gtk::Label($seq[$curr]->id())
	if (defined($seq[$curr]));
    $main_label[$curr] = new Gtk::Label("")
	if (!defined($seq[$curr]));

    # text widget
    $seq_edit[$curr] = new Gtk::Text( undef, undef );
    $seq_edit[$curr]->set_editable( $true );

    # vertical scrollbar for text widget
    my $scrollbar;
    $scrollbar = new Gtk::VScrollbar( $seq_edit[$curr]->vadj );

    # horizontal box containing text widget and scrollbar
    my $seq_edit_hbox;
    $seq_edit_hbox = new Gtk::HBox( $false, 1 );
    $seq_edit_hbox->border_width( 1 );
    $seq_edit_hbox->pack_start( $seq_edit[$curr], $true, $true, 0);
    $seq_edit_hbox->pack_end( $scrollbar, $false, $true, 0);

    $main_notebook->append_page( $seq_edit_hbox, $main_label[$curr] );
    $main_notebook->show_all();
    $main_notebook->set_page(-1);
}

sub seq_fetch
{
    my ($server,$port,$dir,$db); # read from preferences
    my ($dbobj);

    return if (!defined($import_from) || !($import_from));

    $dbobj = Bio::DB::GenPept->new() if ($import_from eq "genpept");
    $dbobj = Bio::DB::Ace->new(-host=>$server,-port=>$port)
	if ($import_from eq "ace");
    $dbobj = Bio::Index::Abstract->new("$dir/$db") 
	if ($import_from eq "fasta") ||
	   ($import_from eq "swissprot") ||
	   ($import_from eq "swisspfam");

    if( $import_buttons[0]->get_active() ) {
	&new_seq_page($dbobj->get_Seq_by_id($import_entry->get_text()));
    } else {
	&new_seq_page($dbobj->get_Seq_by_acc($import_entry->get_text()));
    }
}

sub seq_import
{
    ($import_from) = @_;
    my %names = ( "ace" => "AceDB",
			 "genpept" => "GenPept DB",
			 "fasta" => "Fasta Flat File",
			 "swissprot" => "SwissProt Flat File",
			 "swisspfam" => "SwissPfam Flat File"
		     );
    $import_dialog->set_title("Import from ".$names{$import_from});
    $import_entry->set_text("");
    $import_dialog->show_all();
}

sub init_import_dialog
{
    $import_dialog = new Gtk::Dialog();
    $import_dialog->border_width(5);

    # create the first button and add it to a box
    my $button = new Gtk::RadioButton( "Fetch by ID" );
    $import_dialog->vbox->pack_start($button,$false,$false,2);
         
    # create the second button and add it to a box
    $button = new Gtk::RadioButton( "Fetch by ACCESSION", $button );
    $import_dialog->vbox->pack_start($button,$false,$false,2);
    @import_buttons = $button->group();

    $import_entry = new Gtk::Entry();
    my $frame = new Gtk::Frame("Enter here:");
    $frame->add($import_entry);
    $import_dialog->vbox->pack_start( $frame, $true, $true, 5);
    
    my $bbox = new Gtk::HButtonBox();
    $bbox->set_layout("end");
    
    $button = new Gtk::Button( "OK" );
    $bbox->add( $button );
    $button->signal_connect("clicked",
           # OK button handler
           sub{ $import_dialog->hide();
		&seq_fetch();
	      });

    $button = new Gtk::Button( "Cancel" );
    $bbox->add( $button );
    $button->signal_connect("clicked",
           # close button handler
           sub{ $import_dialog->hide();
	      });

    $import_dialog->action_area->pack_start( $bbox, $true, $true, 0 );

    $import_dialog->signal_connect_after( "delete_event",
           # window delete handler
           sub{ $import_dialog->hide();
                return &Gtk::true;
	      });
}

sub open_dialog
{
    # Create a new file selection widget
    my $open_dialog = new Gtk::FileSelection( "Open File..." );
    # Connect the ok_button to open_ok_sel function
    $open_dialog->ok_button->signal_connect( "clicked",
					     \&ok_open_dialog,
					     $open_dialog );
    # Connect the cancel_button to destroy the widget
    $open_dialog->cancel_button->signal_connect( "clicked",
						 sub { $open_dialog->destroy(); } );
    $open_dialog->show();
}

# Get the selected filename
sub ok_open_dialog
  {
    my ( $widget, $file_selection ) = @_;
    push @filename, $file_selection->get_filename();

    $widget->parent->parent->parent->destroy();

    my $in = Bio::SeqIO->new(-file => $filename[-1] , '-format' => 'swiss');

    &new_seq_page($in->next_seq());
}

sub update_seq_data
{    
    $main_label[$current]->set_text($seq[$current]->id) if (defined($seq[$current]));
    $main_label[$current]->set_text("") if (!defined($seq[$current]));

    $seq_edit[$current]->freeze();
    $seq_edit[$current]->delete_text(0,-1);
    $seq_edit[$current]->insert(undef,undef,undef,$seq[$current]->seq()) if (defined($seq[$current]));
    $seq_edit[$current]->thaw();

    &update_comment_window();
    &update_description_window();
    &update_seqstats_window();
    &update_dblink_window();
    &update_reference_window();
    &update_feature_window();
}

sub new
{
    &new_seq_page(undef);
}

sub close
{
}

sub save
{
    if (!defined($filename[$current])||!$filename[$current])
    {
	&saveas_dialog;
	return;
    }
    my $out = Bio::SeqIO->new(-file => ">$filename[$current]" , '-format' => 'swiss');
    $out->write_seq($seq[$current]);
}

sub saveas_dialog
{
    # Create a new file selection widget
    my $saveas_dialog = new Gtk::FileSelection( "Save As..." );
    # Connect the ok_button to saveas_ok_sel function
    $saveas_dialog->ok_button->signal_connect( "clicked",
					       \&ok_saveas_dialog,
					       $saveas_dialog );
    # Connect the cancel_button to destroy the widget
    $saveas_dialog->cancel_button->signal_connect( "clicked",
						   sub { $saveas_dialog->destroy(); } );
    $saveas_dialog->show();
}

# Get the selected filename and print it to the console
sub ok_saveas_dialog
  {
    my ( $widget, $file_selection ) = @_;
    my $filename = $file_selection->get_filename();
    $widget->parent->parent->parent->destroy();
    $filename[$current] = $filename;
    my $out = Bio::SeqIO->new(-file => ">$filename[$current]" , '-format' => 'swiss');
    $out->write_seq($seq[$current]);
  }

sub init_comment_window
{
    $current_comment = 0;
    
    $comment_window = new Gtk::Dialog();
    $comment_window->set_default_size(650,300);
    $comment_window->set_policy($false,$true,$false);
    $comment_window->set_title("Comments");
    $comment_window->border_width(5);
    
    # frame
    $comment_frame = new Gtk::Frame( "Comment[".$current_comment."]" );
    
    # text widget
    $comment_edit = new Gtk::Text( undef, undef );
    $comment_edit->set_editable( $true );
    $comment_edit->set_word_wrap( $true );
	
    # vertical scrollbar for text widget
    my $scrollbar;
    $scrollbar = new Gtk::VScrollbar( $comment_edit->vadj );
	
    # horizontal box containing text widget and scrollbar
    my $hbox;
    $hbox = new Gtk::HBox( $false, 1 );
    $hbox->border_width( 1 );
    $hbox->pack_start( $comment_edit, $true, $true, 0);
    $hbox->pack_end( $scrollbar, $false, $true, 0);
    $comment_frame->add($hbox);
    $comment_window->vbox->pack_start( $comment_frame, $true, $true, 5);

    my $bbox = new Gtk::HBox( $false, 5 );
    $bbox->border_width(10);
    my $arrow = new Gtk::Arrow('right','out');
    my $button = new Gtk::Button();
    $button->add($arrow);
    $bbox->pack_end( $button, $false, $false, 0);
    $button->signal_connect
	( "clicked", 
	  # next comment button handler
	  sub { return if !defined($seq[$current]);
		 &store_current_comment;
		$current_comment++ 
		    if ($current_comment <((scalar $seq[$current]->annotation->each_Comment)-1));
		&update_comment_window;
	    } );

    $arrow = new Gtk::Arrow('left','out');
    $button = new Gtk::Button();
    $button->add($arrow);
    $bbox->pack_end( $button, $false, $false, 0);
    $button->signal_connect( "clicked", 
           # prev comment button handler
	   sub { return if !defined($seq[$current]);
		 &store_current_comment;
		 $current_comment-- 
		     if ($current_comment > 0);
		 &update_comment_window;
	       } );

    $button = new Gtk::Button("Add");
    $bbox->pack_start( $button, $false, $false, 0);
    $button->signal_connect( "clicked",
           # add comment button handler 
           sub { return if !defined($seq[$current]);
		 &store_current_comment;
		 my $comment = new Bio::Annotation::Comment;
		 $comment->text("");
		 $seq[$current]->annotation->add_Comment( $comment );
		 $current_comment = $seq[$current]->annotation->each_Comment - 1;
		 &update_comment_window;
	       } );

     $button = new Gtk::Button("Delete");
     $bbox->pack_start( $button, $false, $false, 0);
     $button->signal_connect( "clicked", 
           # delete comment button handler
           sub { return if !defined($seq[$current]); 
		 $seq[$current]->annotation->remove_Comment( $current_comment );
		 $current_comment = $current_comment - 1 
		     if ($current_comment > 0);
		 &update_comment_window;		 
	       } );

     $comment_window->vbox->pack_end( $bbox, $false, $false, 0);

     $bbox = new Gtk::HButtonBox();
     $bbox->set_layout("end");
	
     $button = new Gtk::Button( "Close" );
     $bbox->add( $button );
     $button->signal_connect("clicked",
           # close button handler
           sub{ $comment_window->hide();
		&store_current_comment;
	      });

     $comment_window->action_area->pack_start( $bbox, $true, $true, 0 );
     $comment_window->signal_connect_after( "delete_event",
           # window delete handler
           sub{ $comment_window->hide();
		&store_current_comment;
                return &Gtk::true;
	      });
}

sub store_current_comment
{
    (($seq[$current]->annotation->each_Comment)[$current_comment])->
	text($comment_edit->get_chars(0,-1) )
	    if ((defined($seq[$current])) && ($seq[$current]->annotation->each_Comment));
}

sub update_comment_window
{
    my ($show_me) = @_;
    $comment_frame->set_label("Comment[".$current_comment."]");
    # insert comment text
    $comment_edit->freeze();
    $comment_edit->delete_text(0,-1);
    if (defined($seq[$current]))
    {
	my @comment = $seq[$current]->annotation->each_Comment;
	$comment_edit->insert(undef,undef,undef, $comment[$current_comment]->text)
	    if (@comment);
    }
    $comment_edit->thaw();
    
    $comment_window->show_all() if (defined($show_me));
}

sub init_description_window
{
    $description_window = new Gtk::Dialog();
    $description_window->set_default_size(620,250);
    $description_window->border_width(5);
    $description_window->set_title("Description");
    
    # frame
    my $description_frame = new Gtk::Frame( "Description" );
    
    # text widget
    $description_edit = new Gtk::Text( undef, undef );
    $description_edit->set_editable( $true );
    $description_edit->set_word_wrap( $true );	
    
    # vertical scrollbar for text widget
    my $scrollbar;
    $scrollbar = new Gtk::VScrollbar( $description_edit->vadj );
    
    # horizontal box containing text widget and scrollbar
    my $hbox;
    $hbox = new Gtk::HBox( $false, 1 );
    $hbox->border_width( 1 );
    $hbox->pack_start( $description_edit, $true, $true, 0);
    $hbox->pack_end( $scrollbar, $false, $true, 0);
    $description_frame->add($hbox);
    $description_window->vbox->pack_start( $description_frame, $true, $true, 5);
    
    my $bbox = new Gtk::HButtonBox();
    $bbox->set_layout("end");
    
    my $button = new Gtk::Button( "Close" );
    $bbox->add( $button );
    $button->signal_connect("clicked",
           # close button handler
           sub{ $description_window->hide();
		$seq[$current]->desc($description_edit->get_chars(0,-1))
		    if $description_edit->get_chars(0,-1);
	      });

    $description_window->action_area->pack_start( $bbox, $true, $true, 0 );
    $description_window->signal_connect_after( "delete_event",
           # window delete handler
           sub{ $description_window->hide();
		$seq[$current]->desc($description_edit->get_chars(0,-1))
		    if $description_edit->get_chars(0,-1);
                return &Gtk::true;
	      });
}

sub update_description_window
{
    my ($show_me) = @_;
    $description_edit->freeze();
    $description_edit->delete_text(0,-1);
    $description_edit->insert(undef,undef,undef,$seq[$current]->desc)
	if defined($seq[$current]) && defined($seq[$current]->desc);
    $description_edit->thaw();
    
    $description_window->show_all() if (defined($show_me));
}

sub init_seqstats_window
{
    $seqstats_window = new Gtk::Dialog();
    $seqstats_window->border_width(5);
    $seqstats_window->set_default_size(100,250);
    $seqstats_window->set_title("Sequence Statistics");

    # frame
    my $seqstats_frame = new Gtk::Frame( "Sequence Statistics" );
    
    # text widget
    $seqstats_edit = new Gtk::Text( undef, undef );
    $seqstats_edit->set_editable( $false );
    $seqstats_edit->set_word_wrap( $true );
    
    # vertical scrollbar for text widget
    my $scrollbar;
    $scrollbar = new Gtk::VScrollbar( $seqstats_edit->vadj );
    
    # horizontal box containing text widget and scrollbar
    my $hbox;
    $hbox = new Gtk::HBox( $false, 1 );
    $hbox->border_width( 1 );
    $hbox->pack_start( $seqstats_edit, $true, $true, 0);
    $hbox->pack_end( $scrollbar, $false, $true, 0);
    $seqstats_frame->add($hbox);
    $seqstats_window->vbox->pack_start( $seqstats_frame, $true, $true, 5);
    
    my $bbox = new Gtk::HButtonBox();
    $bbox->set_layout("end");
    
    my $button = new Gtk::Button( "Close" );
    $bbox->add( $button );
    $button->signal_connect("clicked",
       # close button handler
       sub{ $seqstats_window->hide();
	  });
    
    $seqstats_window->action_area->pack_start( $bbox, $true, $true, 0 );
    $seqstats_window->signal_connect_after( "delete_event",
       # window delete handler
       sub{ $seqstats_window->hide();
	    return &Gtk::true;
	  });
}

sub update_seqstats_window
{
    my ($show_me) = @_;
    my ($data,$weight,$count_hash,$percent);

    $seqstats_edit->freeze();
    $seqstats_edit->delete_text(0,-1);
    if (defined($seq[$current]))
    {
	$data = $seq[$current]->id."\n\n";
	$weight = Bio::Tools::SeqStats->get_mol_wt($seq[$current]->primary_seq);
	if ($$weight[0] == $$weight[1]) {
	    $data .= "Molecular weight of sequence equals to ".$$weight[0]."\n\n";
	} else {
	    $data .= "Molecular weight of sequence is greater than ";
	    $data .= $$weight[0]." and less than ".$$weight[1]."\n\n";
	}
	$count_hash = Bio::Tools::SeqStats->count_monomers($seq[$current]->primary_seq);
	$data .= "Amino Acids:\n";
	foreach (sort keys %$count_hash)
	{
	    $percent = sprintf "%.1f",
	    (($$count_hash{$_} / $seq[$current]->length)*100);
	    $data .= "${_}: ".$$count_hash{$_}." (${percent}%) \n"
	    }
	$seqstats_edit->insert(undef,undef,undef,$data)
	}
    $seqstats_edit->thaw();
    
    $seqstats_window->show_all() if (defined($show_me));
}

sub init_dblink_window
{
    $current_dblink = 0;
    
    $dblink_window = new Gtk::Dialog();
    $dblink_window->set_default_size(500,400);
    $dblink_window->set_policy($true,$true,$false);
    $dblink_window->set_title("Database Links");
    $dblink_window->border_width(5);
    
    # Create a scrolled window to pack the CList widget into
    my $scrolled_window = new Gtk::ScrolledWindow( undef, undef );
    $dblink_window->vbox->pack_start( $scrolled_window, $true, $true, 0 );
    $scrolled_window->set_policy( 'automatic', 'always' );

    # Create the CList. For this example we use 2 columns
    $dblink_clist = new_with_titles Gtk::CList( "Primary Id","Database" );

    # When a selection is made, we want to know about it. The callback
    # used is selection_made, and its code can be found further down
    $dblink_handler_id = $dblink_clist->signal_connect( "select_row", 
       sub{ return if (!defined($seq[$current]));
	    my ( $clist, $row ) = @_;
	    &store_current_dblink;
	    $current_dblink = $row;
	    &update_dblink_window;
          } );

    # It isn't necessary to shadow the border, but it looks nice :)
    $dblink_clist->set_shadow_type( 'out' );

    # What however is important, is that we set the column widths as
    # they will never be right otherwise. Note that the columns are
    # numbered from 0 and up (to 1 in this case).
    $dblink_clist->set_column_width( 0, 150 );

    # Add the CList widget to the vertical box
    $scrolled_window->add( $dblink_clist );

    my $bbox = new Gtk::HBox( $false, 5 );
    $bbox->border_width(10);
    my $arrow = new Gtk::Arrow('down','out');
    my $button = new Gtk::Button();
    $button->add($arrow);
    $bbox->pack_end( $button, $false, $false, 0);
    $button->signal_connect
	( "clicked", 
	  # next dblink button handler
	  sub { return if (!defined($seq[$current]));
		&store_current_dblink;
		$current_dblink++
		    if ($current_dblink <((scalar $seq[$current]->annotation->each_DBLink)-1));
		&update_dblink_window;
	      } );

    $arrow = new Gtk::Arrow('up','out');
    $button = new Gtk::Button();
    $button->add($arrow);
    $bbox->pack_end( $button, $false, $false, 0);
    $button->signal_connect( "clicked", 
           # prev comment button handler
	   sub { return if (!defined($seq[$current]));
		 &store_current_dblink;
		 $current_dblink--
		     if ($current_dblink > 0);
		 &update_dblink_window;
	       } );

    $button = new Gtk::Button("Add");
    $bbox->pack_start( $button, $false, $false, 0);
    $button->signal_connect( "clicked",
           # add comment button handler 
           sub { return if (!defined($seq[$current]));
		 &store_current_dblink;
		 my $dblink = new Bio::Annotation::DBLink;
		 $dblink->primary_id("");
		 $seq[$current]->annotation->add_DBLink( $dblink );
		 $current_dblink = $seq[$current]->annotation->each_DBLink - 1;
		 $dblink_clist->append("","");
		 &update_dblink_window;
	       } );

     $button = new Gtk::Button("Delete");
     $bbox->pack_start( $button, $false, $false, 0);
     $button->signal_connect( "clicked", 
           # delete comment button handler
           sub { return if !defined($seq[$current]); 
		 $seq[$current]->annotation->remove_DBLink( $current_dblink );
		 $dblink_clist->remove($current_dblink);
		 $current_dblink-- if ($current_dblink > 0);
		 &update_dblink_window;
	       } );

     $dblink_window->vbox->pack_start( $bbox, $false, $false, 0);

    # horizontal box containing primary_id & optional_id entries
    my $hbox;
    $hbox = new Gtk::HBox( $true, 10 );
    $hbox->border_width( 1 );

    # text entries
    $dblink_entry[0] = new Gtk::Entry();
    my $frame = new Gtk::Frame("primary id");
    $frame->add($dblink_entry[0]);
    $hbox->pack_start( $frame, $true, $true, 0);

    $dblink_entry[1] = new Gtk::Entry();
    $frame = new Gtk::Frame("optional id");
    $frame->add($dblink_entry[1]);
    $hbox->pack_end( $frame, $true, $true, 0);

    $dblink_window->vbox->pack_start( $hbox, $false, $false, 5);

    $dblink_entry[2] = new Gtk::Entry();
    $frame = new Gtk::Frame("Database");
    $frame->add($dblink_entry[2]);
    $dblink_window->vbox->pack_start( $frame, $false, $false, 5);

    $dblink_entry[3] = new Gtk::Entry();
    $frame = new Gtk::Frame("Comment");
    $frame->add($dblink_entry[3]);
    $dblink_window->vbox->pack_end( $frame, $false, $false, 5);

     $bbox = new Gtk::HButtonBox();
     $bbox->set_layout("end");
	
     $button = new Gtk::Button( "Close" );
     $bbox->add( $button );
     $button->signal_connect("clicked",
           # close button handler
           sub{ $dblink_window->hide();
		&store_current_dblink;
	      });

     $dblink_window->action_area->pack_start( $bbox, $true, $true, 0 );
     $dblink_window->signal_connect_after( "delete_event",
           # window delete handler
           sub{ $dblink_window->hide();
		&store_current_dblink;
                return &Gtk::true;
	      });
}

sub store_current_dblink
{
    if ((defined($seq[$current])) && ($seq[$current]->annotation->each_DBLink))
    {
	(($seq[$current]->annotation->each_DBLink)[$current_dblink])->
	    primary_id($dblink_entry[0]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_DBLink)[$current_dblink])->
	    optional_id($dblink_entry[1]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_DBLink)[$current_dblink])->
	    database($dblink_entry[2]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_DBLink)[$current_dblink])->
	    comment($dblink_entry[3]->get_chars(0,-1) );		
    }
}

sub update_dblink_window
{
    my ($show_me) = @_;
    $dblink_window->show_all() if (defined($show_me));

    $dblink_clist->freeze();
    if (!defined($seq[$current]))
    {
	$dblink_clist->clear();
	$dblink_clist->thaw();
	foreach (@dblink_entry) { $_->set_text(""); }
	return;
    }
    my @dblinks = $seq[$current]->annotation->each_DBLink;
    # reset clist if rows are different to links
    if ($dblink_clist->rows != @dblinks) {
	$dblink_clist->clear();
	foreach (@dblinks) { $dblink_clist->append("",""); }
    }
    # redraw references
    for(my $i=0;$i<@dblinks;$i++)
    {
	$dblink_clist->set_text($i,0,$dblinks[$i]->primary_id);
	$dblink_clist->set_text($i,1,$dblinks[$i]->database);
    }
    # redraw text widgets
    foreach (@dblink_entry) { $_->set_text(""); }
    if (@dblinks)
    {
	$dblink_entry[0]->set_text($dblinks[$current_dblink]->primary_id);
	$dblink_entry[1]->set_text($dblinks[$current_dblink]->optional_id);
	$dblink_entry[2]->set_text($dblinks[$current_dblink]->database);
	$dblink_entry[3]->set_text($dblinks[$current_dblink]->comment);
    }

    $dblink_clist->moveto($current_dblink,0,0.3,0.0)
	if ($dblink_clist->row_is_visible($current_dblink) ne 'full');
    $dblink_clist->signal_handler_block($dblink_handler_id);
    $dblink_clist->select_row($current_dblink,0);
    $dblink_clist->signal_handler_unblock($dblink_handler_id);
    Gtk::CList::set_focus_row($dblink_clist,$current_dblink);
    $dblink_clist->thaw();
}

sub init_reference_window
{
    $current_ref = 0;
    
    $ref_window = new Gtk::Dialog();
    $ref_window->set_default_size(620,500);
    $ref_window->set_policy($true,$true,$false);
    $ref_window->set_title("References");
    $ref_window->border_width(5);
    
    # Create a scrolled window to pack the CList widget into
    my $scrolled_window = new Gtk::ScrolledWindow( undef, undef );
    $ref_window->vbox->pack_start( $scrolled_window, $true, $true, 0 );
    $scrolled_window->set_policy( 'automatic', 'always' );

    # Create the CList. For this example we use 2 columns
    $ref_clist = new_with_titles Gtk::CList( "Medline","Title","Authors" );

    # When a selection is made, we want to know about it. The callback
    # used is selection_made, and its code can be found further down
    $ref_handler_id = $ref_clist->signal_connect( "select_row", 
       sub{ return if (!defined($seq[$current]));
	    my ( $clist, $row ) = @_;
	    &store_current_reference;
	    $current_ref = $row;
	    &update_reference_window;
          } );

    # It isn't necessary to shadow the border, but it looks nice :)
    $ref_clist->set_shadow_type( 'out' );

    # What however is important, is that we set the column widths as
    # they will never be right otherwise. Note that the columns are
    # numbered from 0 and up (to 1 in this case).
    $ref_clist->set_column_width( 0, 70 );
    $ref_clist->set_column_width( 1, 350 );
    $ref_clist->set_column_width( 2, 300 );

    # Add the CList widget to the vertical box
    $scrolled_window->add( $ref_clist );

    my $bbox = new Gtk::HBox( $false, 5 );
    $bbox->border_width(10);
    my $arrow = new Gtk::Arrow('down','out');
    my $button = new Gtk::Button();
    $button->add($arrow);
    $bbox->pack_end( $button, $false, $false, 0);
    $button->signal_connect
	( "clicked", 
	  # next ref button handler
	  sub { return if (!defined($seq[$current]));
		&store_current_reference;
		$current_ref++
		    if ($current_ref <((scalar $seq[$current]->annotation->each_Reference)-1));
		&update_reference_window;
	    } );

    $arrow = new Gtk::Arrow('up','out');
    $button = new Gtk::Button();
    $button->add($arrow);
    $bbox->pack_end( $button, $false, $false, 0);
    $button->signal_connect( "clicked", 
           # prev comment button handler
	   sub { return if (!defined($seq[$current]));
		 &store_current_reference;
		 $current_ref--
		     if ($current_ref > 0);
		 &update_reference_window;
	       } );

    $button = new Gtk::Button("Add");
    $bbox->pack_start( $button, $false, $false, 0);
    $button->signal_connect( "clicked",
           # add comment button handler 
           sub { return if (!defined($seq[$current]));
		 &store_current_reference;
		 my $ref = new Bio::Annotation::Reference;
		 $ref->medline("");
		 $seq[$current]->annotation->add_Reference( $ref );
		 $ref_clist->append("","","");
		 $current_ref = ($seq[$current]->annotation->each_Reference)-1;
		 &update_reference_window;
	       } );

     $button = new Gtk::Button("Delete");
     $bbox->pack_start( $button, $false, $false, 0);
     $button->signal_connect( "clicked", 
           # delete comment button handler
           sub { return if !defined($seq[$current]); 
		 $seq[$current]->annotation->remove_Reference( $current_ref );
		 $ref_clist->remove($current_ref);
		 $current_ref-- if ($current_ref > 0);
		 &update_reference_window;
	       } );

     $ref_window->vbox->pack_start( $bbox, $false, $false, 0);

    # horizontal box containing primary_id & optional_id entries
    my $hbox;
    $hbox = new Gtk::HBox( $true, 10 );
    $hbox->border_width( 1 );

    # text entries
    $ref_entry[0] = new Gtk::Entry();
    my $frame = new Gtk::Frame("Title");
    $frame->add($ref_entry[0]);
    $ref_window->vbox->pack_start( $frame, $false, $false, 5);

    $ref_entry[1] = new Gtk::Entry();
    $frame = new Gtk::Frame("Authors");
    $frame->add($ref_entry[1]);
    $ref_window->vbox->pack_start( $frame, $false, $false, 5);

    # horizontal box
    $hbox = new Gtk::HBox( $true, 10 );
    $hbox->border_width( 1 );

    # text entries
    $ref_entry[2] = new Gtk::Entry();
    $frame = new Gtk::Frame("Comment");
    $frame->add($ref_entry[2]);
    $hbox->pack_start( $frame, $true, $true, 0);

    $ref_entry[3] = new Gtk::Entry();
    $frame = new Gtk::Frame("Location");
    $frame->add($ref_entry[3]);
    $hbox->pack_end( $frame, $true, $true, 0);

    $ref_window->vbox->pack_start( $hbox, $false, $false, 5);

    # horizontal box
    $hbox = new Gtk::HBox( $false, 10 );
    $hbox->border_width( 1 );

    # text entries
    $ref_entry[4] = new Gtk::Entry();
    $frame = new Gtk::Frame("Medline");
    $frame->add($ref_entry[4]);
    $hbox->pack_start( $frame, $false, $false, 0);

#    $ref_entry[5] = new Gtk::Entry();
#    $frame = new Gtk::Frame("Start");
#    $frame->add($ref_entry[5]);
#    $hbox->pack_start( $frame, $false, $false, 0);

    $ref_entry[5] = new Gtk::Entry();
    $frame = new Gtk::Frame("Reference Position");
    $frame->add($ref_entry[5]);
    $hbox->pack_end( $frame, $true, $true, 0);

    $ref_window->vbox->pack_start( $hbox, $false, $false, 5);


     $bbox = new Gtk::HButtonBox();
     $bbox->set_layout("end");
	
     $button = new Gtk::Button( "Close" );
     $bbox->add( $button );
     $button->signal_connect("clicked",
           # close button handler
           sub{ $ref_window->hide();
		&store_current_reference;
	      });

     $ref_window->action_area->pack_start( $bbox, $true, $true, 0 );
     $ref_window->signal_connect_after( "delete_event",
           # window delete handler
           sub{ $ref_window->hide();
		&store_current_reference;
                return &Gtk::true;
	      });
}

sub store_current_reference
{
    if ((defined($seq[$current])) && ($seq[$current]->annotation->each_Reference))
    {
	(($seq[$current]->annotation->each_Reference)[$current_ref])->
	    title($ref_entry[0]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_Reference)[$current_ref])->
	    authors($ref_entry[1]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_Reference)[$current_ref])->
	    comment($ref_entry[2]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_Reference)[$current_ref])->
	    location($ref_entry[3]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_Reference)[$current_ref])->
	    medline($ref_entry[4]->get_chars(0,-1) );		
#	(($seq[$current]->annotation->each_Reference)[$current_ref])->
#	    start($ref_entry[5]->get_chars(0,-1) );		
	(($seq[$current]->annotation->each_Reference)[$current_ref])->
	    rp($ref_entry[5]->get_chars(0,-1) );		
    }
}

sub update_reference_window
{
    my ($show_me) = @_;
    $ref_window->show_all() if (defined($show_me));

    $ref_clist->freeze();
    if (!defined($seq[$current]))
    {
	$ref_clist->clear();
	$ref_clist->thaw();
	foreach (@ref_entry) { $_->set_text(""); }
	return;
    }
    my @refs = $seq[$current]->annotation->each_Reference;
    # reset clist if rows are different to references
    if ($ref_clist->rows != @refs) {
	$ref_clist->clear();
	foreach (@refs) { $ref_clist->append("","",""); }
    }
    # redraw references
    for(my $i=0;$i<@refs;$i++)
    {
	$ref_clist->set_text($i,0,$refs[$i]->medline)
	  if ($refs[$i]->medline);
	$ref_clist->set_text($i,1,$refs[$i]->title)
	  if ($refs[$i]->title);
	$ref_clist->set_text($i,2,$refs[$i]->authors)
	  if ($refs[$i]->authors);
    }
    # redraw text widgets
    foreach (@ref_entry) { $_->set_text(""); }
    if (@refs) {
	$ref_entry[0]->set_text($refs[$current_ref]->title);
	$ref_entry[1]->set_text($refs[$current_ref]->authors);
	$ref_entry[2]->set_text($refs[$current_ref]->comment);
	$ref_entry[3]->set_text($refs[$current_ref]->location);
	$ref_entry[4]->set_text($refs[$current_ref]->medline);
#	$ref_entry[5]->set_text($refs[$current_ref]->start);
	$ref_entry[5]->set_text($refs[$current_ref]->rp);
    }

    $ref_clist->moveto($current_ref,0,0.3,0.0)
	if ($ref_clist->row_is_visible($current_ref) ne 'full');
    $ref_clist->signal_handler_block($ref_handler_id);
    $ref_clist->select_row($current_ref,0);
    $ref_clist->signal_handler_unblock($ref_handler_id);
    Gtk::CList::set_focus_row($ref_clist,$current_ref);
    $ref_clist->thaw();
}


sub init_about_dialog {
 	my ($window,$bg,$tbox,$vbox,$hbox,$sep,$butbox,$button,$pixmap);
 	$about_dialog = new Gtk::Window("dialog");
 	$about_dialog->set_title("About gSequence");
 	$about_dialog->signal_connect_after("destroy" => 
					    sub { $about_dialog->hide; 
					          return &Gtk::true; });
 	$about_dialog->set_default_size('350','350');
 	$about_dialog->set_policy(1,1,0);
 	$window = $about_dialog->window;
 	$bg = $about_dialog->style->bg('normal');
 	$vbox= new Gtk::VBox(0,0);
 	$about_dialog->add($vbox);
    	$tbox = new Gtk::Label("\ngSequence\nAuthor: Lorenz Pollak\n\n
gSequence is cool! :-)\n(this text is to be written...)
\n");
 	$vbox->pack_start($tbox,1,1,1);
   
    	$hbox = new Gtk::HBox(0,0);   
    	$vbox->pack_start($hbox,0,0,0);
 	$sep = new Gtk::HSeparator;
   	$sep->set_usize(-1,5);
    	$vbox->pack_start($sep,0,1,0);
    
     	$butbox = new Gtk::HButtonBox;
     	$butbox->set_usize(-1,32);
     	$vbox->pack_start($butbox, 0,1,0); 
 	$button = new_with_label Gtk::Button("OK");
     	$button->set_usize(50,-1);
     	$button->signal_connect('clicked', sub { $about_dialog->hide; });
	$button->can_default(1);
	$button->grab_default;
	$butbox->add($button);
     
  return 1;
}    

sub init_feature_window
{
    $current_feature_item = 0;
    
    $feature_window = new Gtk::Dialog();
    $feature_window->set_default_size(500,400);
    $feature_window->set_policy($true,$true,$false);
    $feature_window->set_title("Sequence Features");
    $feature_window->border_width(5);

    my $pane = new Gtk::HPaned();
    $feature_window->vbox->pack_start( $pane, $true, $true, 0);
    $pane->set_handle_size( 10 );
    $pane->set_gutter_size( 8 );

    # Create a VBox for the Entry and Tree Scrolled Window
    my $vbox = new Gtk::VBox( $false, 0 );
    $pane->add1( $vbox );

    # Create a ScrolledWindow for the tree
    my $tree_scrolled_win = new Gtk::ScrolledWindow( undef, undef );
    $tree_scrolled_win->set_usize( 150, 400 );
    $vbox->pack_start( $tree_scrolled_win, $true, $true, 0 );
    $tree_scrolled_win->set_policy( 'automatic', 'automatic' );

    #my $list_scrolled_win = new Gtk::ScrolledWindow( undef, undef );
    #$list_scrolled_win->set_policy( 'automatic', 'automatic' );
    $vbox = new Gtk::VBox( $false, 0 );
    $pane->add2( $vbox );

    # add stuff to the vbox
    # text entries
    my $hbox = new Gtk::HBox( $true, 10 );

    $feature_entry[0] = new Gtk::Entry();
    my $frame = new Gtk::Frame("Primary Tag");
    $frame->add($feature_entry[0]);
    $hbox->pack_start( $frame, $true, $true, 0);

    $feature_entry[1] = new Gtk::Entry();
    $frame = new Gtk::Frame("Source Tag");
    $frame->add($feature_entry[1]);
    $hbox->pack_end( $frame, $true, $true, 0);

    $vbox->pack_start( $hbox, $false, $false, 5);

    $hbox = new Gtk::HBox( $true, 10 );

    my $adj = new Gtk::Adjustment( 0, 0, 0, 0, 0, 0 );
    $feature_spinner[0] = new Gtk::SpinButton( $adj, 0.0, 0 );
    $feature_spinner[0]->signal_connect( "changed", \&select_feature_region);
    $frame = new Gtk::Frame("Start");
    $frame->add($feature_spinner[0]);
    $hbox->pack_start( $frame, $true, $true, 0);

    $adj = new Gtk::Adjustment( 0, 0, 0, 0, 0, 0 );
    $feature_spinner[1] = new Gtk::SpinButton( $adj, 0.0, 0 );
    $feature_spinner[1]->signal_connect( "changed", \&select_feature_region);
    $frame = new Gtk::Frame("End");
    $frame->add($feature_spinner[1]);
    $hbox->pack_start( $frame, $true, $true, 0);

    $frame = new Gtk::Frame("Strand");
    $hbox->pack_start( $frame, $true, $true, 0);
    $frame = new Gtk::Frame("Score");
    $hbox->pack_start( $frame, $true, $true, 0);

    $vbox->pack_start( $hbox, $false, $false, 5);

    $feature_entry[2] = new Gtk::Entry();
    $frame = new Gtk::Frame("Description");
    $frame->add($feature_entry[2]);

    $vbox->pack_start( $frame, $false, $false, 5);

    my $bbox = new Gtk::HBox( $false, 5 );
    $bbox->border_width(10);
    my $button = new Gtk::Button("Add");
    $bbox->pack_start( $button, $false, $false, 0);
    $button->signal_connect( "clicked",
           # add comment button handler 
           sub { return if (!defined($seq[$current]));
		 &store_current_feature if ($current_feature_item);
		 my $feature = new Bio::SeqFeature::Generic;
		 $feature->primary_tag("");
		 $seq[$current]->add_SeqFeature( $feature );
		 my $item_new = new_with_label Gtk::TreeItem( "" );
		 $item_new->set_user_data( $feature );
		 $item_new->signal_connect( 'select', \&select_feature_item );
		 $current_feature_item->parent->append( $item_new )
		     if ($current_feature_item);
		 $feature_tree->append( $item_new ) if (!$current_feature_item);
		 $item_new->show();
		 $current_feature_item->deselect()
		     if ($current_feature_item);
		 $item_new->select();
	       } );
    $button = new Gtk::Button("Add Subfeature");
    $bbox->pack_start( $button, $false, $false, 0);
    $button->signal_connect( "clicked",
           # add comment button handler 
           sub { return if (!defined($seq[$current])||!$current_feature_item);
		 &store_current_feature;
		 my $feature = new Bio::SeqFeature::Generic;
		 $feature->primary_tag("");
		 $feature->start($current_feature_item->get_user_data->start);
		 $feature->end($current_feature_item->get_user_data->end);
		 $current_feature_item->get_user_data->add_sub_SeqFeature( $feature );
		 my $new_subtree = new Gtk::Tree();
		 $current_feature_item->set_subtree( $new_subtree );
		 my $item_new = new_with_label Gtk::TreeItem( "" );
		 $item_new->set_user_data( $feature );
		 $item_new->signal_connect( 'select', \&select_feature_item );
		 $new_subtree->append( $item_new );
		 $item_new->show();
		 $current_feature_item->deselect();
		 $current_feature_item->expand();
		 $item_new->select();
	       } );
     $button = new Gtk::Button("Delete");
     $bbox->pack_start( $button, $false, $false, 0);
     $button->signal_connect( "clicked", 
           # delete comment button handler
           sub { return if (!$current_feature_item); 
		 &store_current_feature;
		 my $flist = $seq[$current]->{_as_feat};
		 my $pos;
		 for(my $i=0;$i<@$flist;$i++) {
		   $pos=$i if $$flist[$i]==$current_feature_item->get_user_data();
		 }
		 splice @$flist, $pos, 1;
		 $seq[$current]->{_as_feat} = $flist;
		 $current_feature_item->parent->remove_item($current_feature_item);
		 $current_feature_item=0;
	       } );

     $vbox->pack_end( $bbox, $false, $false, 0);

    # Create root tree
    $feature_tree = new Gtk::Tree();
    $tree_scrolled_win->add_with_viewport( $feature_tree );
    $feature_tree->set_selection_mode( 'single' );
    $feature_tree->set_view_mode( 'item' );

    $bbox = new Gtk::HButtonBox();
    $bbox->set_layout("end");
    
    $button = new Gtk::Button( "Close" );
    $bbox->add( $button );
    $button->signal_connect("clicked",
			    # close button handler
			    sub{ $feature_window->hide();
				 &store_current_feature;
			     });
    
    $feature_window->action_area->pack_start( $bbox, $true, $true, 0 );
    $feature_window->signal_connect_after( "delete_event",
					   # window delete handler
					   sub{ $feature_window->hide();
						&store_current_feature;
						return &Gtk::true;
					    });
}

# Callback for expanding tree
sub expand_feature_tree
  {
    my ( $item, $subtree ) = @_;
    my ($feature,$subfeature,$item_new,$new_subtree);
    $feature = $item->get_user_data();

    foreach $subfeature ($feature->sub_SeqFeature)
      {
	  $item_new = new_with_label Gtk::TreeItem( $subfeature->primary_tag );
	  $item_new->set_user_data( $subfeature );
	  $item_new->signal_connect( 'select', \&select_feature_item );
	  $subtree->append( $item_new );
	  $item_new->show();
	  
	  if ( $subfeature->sub_SeqFeature )
	  {
	      $new_subtree = new Gtk::Tree();
	      $item_new->set_subtree( $new_subtree );
	      $item_new->signal_connect( 'expand',
					 \&expand_feature_tree,
					 $new_subtree );
	      $item_new->signal_connect( 'collapse', \&collapse_feature_tree );
	  }
	  $item_new->expand();
      }
  }


# Callback for collapsing tree
sub collapse_feature_tree
  {
    my ( $item ) = @_;

    my $subtree = new Gtk::Tree();

    $item->remove_subtree();
    $item->set_subtree( $subtree );
    $item->signal_connect( 'expand', \&expand_feature_tree, $subtree );
  }


sub store_current_feature
{
  if ((defined($seq[$current])) && ($seq[$current]->top_SeqFeatures) && ($current_feature_item))
  {
    my $current_feature = $current_feature_item->get_user_data();
    $current_feature->primary_tag( $feature_entry[0]->get_chars(0,-1) );		
    $current_feature->source_tag( $feature_entry[1]->get_chars(0,-1) );		
    if ($current_feature->has_tag("description"))
    {
      $current_feature->remove_tag("description");
      $current_feature->add_tag_value("description",
				      $feature_entry[2]->get_chars(0,-1));
    }
    $current_feature->start($feature_spinner[0]->get_value_as_int());
    $current_feature->end($feature_spinner[1]->get_value_as_int());
    # set tree item
    ($current_feature_item->children)[0]->set($current_feature->primary_tag);
  }
}

sub select_feature_item
{
    my ($widget) = @_;
    &store_current_feature;
    $current_feature_item->deselect()
      if $current_feature_item;
    $current_feature_item = $widget;
    &update_feature_paned2;
}

sub update_feature_paned2
{
  $feature_entry[0]->set_text("");
  $feature_entry[1]->set_text("");
  $feature_entry[2]->set_text("");

  return if (!defined($seq[$current])||(!$current_feature_item));
  my $current_feature = $current_feature_item->get_user_data();
  $feature_entry[0]->set_text($current_feature->primary_tag);
  $feature_entry[1]->set_text($current_feature->source_tag)
    if (defined($current_feature->source_tag));
  $feature_entry[2]->set_text(($current_feature->each_tag_value("description"))[0])
    if ($current_feature->has_tag("description"));
  my $adj = new Gtk::Adjustment($current_feature->start,
				0,
				$seq[$current]->length-1,
				1,
				1,
				0
			       );
  $feature_spinner[0]->set_adjustment($adj);
  $feature_spinner[0]->set_value($current_feature->start);
  $feature_spinner[0]->show_all();
  $adj = new Gtk::Adjustment($current_feature->end,
			     0,
			     $seq[$current]->length-1,
			     1,
			     1,
			     0
			    );
  $feature_spinner[1]->set_adjustment($adj);
  $feature_spinner[1]->set_value($current_feature->end);
  $feature_spinner[1]->show_all();
}

sub select_feature_region
{
  $seq_edit[$current]->freeze;
  $seq_edit[$current]->select_region($feature_spinner[0]->get_value_as_int(),
			   $feature_spinner[1]->get_value_as_int()+1);
  $seq_edit[$current]->thaw;
}

sub update_feature_window
{
    my ($show_me) = @_;
    $feature_window->show_all() if (defined($show_me));

    $feature_tree->clear_items(0,-1);
    if (!defined($seq[$current]))
    {
	&update_feature_paned2;
	return;
    }

    my ($item_new,$new_subtree);
    foreach ($seq[$current]->top_SeqFeatures)
      {
	  $item_new = new_with_label Gtk::TreeItem( $_->primary_tag );
	  $item_new->set_user_data( $_ );
	  $item_new->signal_connect( 'select', \&select_feature_item );
	  $feature_tree->append( $item_new );
	  if ( $_->sub_SeqFeature )
	  {
	      $new_subtree = new Gtk::Tree();
	      $item_new->set_subtree( $new_subtree );
	      $item_new->signal_connect( 'expand',
					 \&expand_feature_tree,
					 $new_subtree );
	      $item_new->signal_connect( 'collapse', \&collapse_feature_tree );
	  }
	  $item_new->expand();
      }
    $feature_tree->select_item($current_feature_item) 
      if $current_feature_item;
    $feature_tree->show_all();

    &update_feature_paned2;
}

sub store_prefs
{
}

sub update_pref_window
{
  $pref_window->show_all();
}

sub init_pref_window
{
  $pref_window = new Gtk::Dialog();
  $pref_window->set_default_size(500,400);
  $pref_window->set_policy($true,$true,$false);
  $pref_window->border_width( 5 );

  # Create a new notebook, place the position of the tabs
  my $notebook = new Gtk::Notebook();
  $pref_window->vbox->pack_start( $notebook, $true, $true, 0);
  $notebook->set_tab_pos( 'top' );

  my $main_vbox = new Gtk::VBox($false,10);

  my $label = new Gtk::Label( "Import Options" );
  my $frame = new Gtk::Frame("Flat File Indexes");
  my $vbox = new Gtk::VBox($false,10);
  $frame->add($vbox);
  $main_vbox->pack_start($frame,$false,$false,10);

  $notebook->append_page( $main_vbox, $label );

  my $hbox = new Gtk::HBox($false,0);

  $pref_entry[0] = new Gtk::Entry();
  $frame = new Gtk::Frame("Indexes Directory");
  $frame->add($pref_entry[0]);
  $hbox->pack_start( $frame, $true, $false, 0);

  $pref_entry[1] = new Gtk::Entry();
  $frame = new Gtk::Frame("Index Type");
  $frame->add($pref_entry[1]);
  $hbox->pack_start( $frame, $false, $false, 0);

  $vbox->pack_start( $hbox, $false, $false, 0);

  $pref_entry[2] = new Gtk::Entry();
  $frame = new Gtk::Frame("Fasta Index Name");
  $frame->add($pref_entry[2]);
  $vbox->pack_start( $frame, $false, $false, 0);

  $pref_entry[3] = new Gtk::Entry();
  $frame = new Gtk::Frame("SwissProt Index Name");
  $frame->add($pref_entry[3]);
  $vbox->pack_start( $frame, $false, $false, 0);

  $pref_entry[4] = new Gtk::Entry();
  $frame = new Gtk::Frame("SwissPfam Index Name");
  $frame->add($pref_entry[4]);
  $vbox->pack_start( $frame, $false, $false, 0);

  $frame = new Gtk::Frame("Remote DBs");
  $hbox = new Gtk::HBox($false,10);
  $frame->add($hbox);
  $main_vbox->pack_start($frame,$false,$false,10);

  $pref_entry[5] = new Gtk::Entry();
  $frame = new Gtk::Frame("AceDB host");
  $frame->add($pref_entry[5]);
  $hbox->pack_start( $frame, $true, $false, 0);

  $pref_entry[6] = new Gtk::Entry();
  $frame = new Gtk::Frame("AceDB port");
  $frame->add($pref_entry[6]);
  $hbox->pack_start( $frame, $false, $false, 0);

  $notebook->set_page( 0 );

  my $bbox = new Gtk::HButtonBox();
  $bbox->set_layout("end");

  my $button = new Gtk::Button( "Save" );
  $bbox->add( $button );
  $button->signal_connect("clicked",
			  # close button handler
			  sub{ $pref_window->hide();
			       &store_prefs();
			     });
  
  $button = new Gtk::Button( "Close" );
  $bbox->add( $button );
  $button->signal_connect("clicked",
			  # close button handler
			  sub{ $pref_window->hide();
			     });
  
  $pref_window->action_area->pack_start( $bbox, $true, $true, 0 );
  $pref_window->signal_connect_after( "delete_event",
					 # window delete handler
					 sub{ $pref_window->hide();
					      return &Gtk::true;
					    });
}
BioPerl-1.6.923/examples/tk/hitdisplay.pl000555000765000024       646512254227327 20423 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl
#
# PROGRAM  : hitdisplay.pl
# PURPOSE  : Demonstrate Bio::Tk::HitDisplay
# AUTHOR   : Keith James kdj@sanger.ac.uk
# CREATED  : Nov 1 2000
#
# Requires Bio::Tk::HitDisplay
#
# To use, just pipe Blast output into this script. Try clicking on
# the blue Subject ids with the left button to activate a callback
# or with the right button to show text describing the hit.
# 

use strict;
use Text::Wrap qw(wrap $columns);
use Bio::Tools::BPlite;
BEGIN { 
	print STDERR "This example uses deprecated BioPerl code; feel free to refactor as needed\n";
	exit;
    eval { 
	require 'Tk.pm';
	require 'Bio/Tk/HitDisplay.pm'; 
    };
    if( $@ ) {
	print STDERR "Must have bioperl-gui and Tk installed to run this test, see bioperl website www.bioperl.org for instructions on how to installed bioperl-gui modules\n";    
	exit;
    }

}
use Tk;
    $columns = 80;

my $report = Bio::Tools::BPlite->new(-fh => \*STDIN);

# Normally the code ref below is in a separate package and I do 
# something like:
#
# my $adapter = Bio::PSU::IO::Blast::HitAdapter->new;
#
# while (my $hit = $result->next_hit)
# {
#     my $text     = " ... ";
#     my $callback = sub { ... };
#     push(@hits, $adapter->($sbjct, $text, $callback));
# }
#
# It's easy to roll your own for Fasta, or whatever.

my $adapter = sub
{
    my ($sbjct, $text, $callback) = @_;

    my (@data, $expect, $percent, $length);
    my ($q_id, $s_id, $q_len, $s_len);

    while (my $hsp = $sbjct->nextHSP)
    {
	$q_id ||= $hsp->query->seqname;
	$s_id ||= $hsp->subject->seqname;

	$q_len ||= $hsp->query->seqlength;
	$s_len ||= $hsp->subject->seqlength;

	my $q_x1 = $hsp->query->start;
	my $q_x2 = $hsp->query->end;

	my $s_x1 = $hsp->subject->start;
	my $s_x2 = $hsp->subject->end;

	push(@data, [$q_x1, $q_x2,
		     $s_x1, $s_x2]);

	if (defined $expect)
	{
	    if ($hsp->P < $expect)
	    {
		$expect  = $hsp->P;
		$percent = $hsp->percent;
		$length  = $hsp->length;
	    }
	}
	else
	{
	    $expect  = $hsp->P;
	    $percent = $hsp->percent;
	    $length  = $hsp->length;
	}
    }

    return { q_id     => $q_id,
	     s_id     => $s_id,
	     expect   => $expect,
	     score    => $percent,
	     overlap  => $length,
	     q_len    => $q_len,
	     s_len    => $s_len,
	     data     => \@data,
	     text     => $text,
	     callback => $callback }

};

my @hits;

while (my $sbjct = $report->nextSbjct)
{
    # Make some text to show when the left button is clicked
    my $text = wrap("", "", "Blast hit to: ", $sbjct->name, "\n");

    # Make a callback to actiavte when the right button is clicked
    my $callback = sub { print "Blast hit to ", $sbjct->name, "\n" };

    # Convert Subjct, text and callback into hash
    push(@hits, $adapter->($sbjct, $text, $callback));
}

# Create the main window and HitDisplay
my $mw = MainWindow->new;
my $hds = $mw->Scrolled('HitDisplay',
			-borderwidth => 5,
			-scrollbars  => 'ose',
			-width       => 600,
			-height      => 300,
			-background  => 'white',
			-hitcolours  => {
					 10 => 'pink',
					 20 => 'purple',
					 40 => 'yellow',
					 60 => 'gold',
					 70 => 'orange',
					 90 => 'red'
					},
			-interval    => 15,
			-hitdata     => \@hits);

$hds->pack(-side => 'top', -fill => 'both', -expand => 1);
$hds->waitVisibility;
$hds->configure(-height => 900);
$hds->configure(-scrollregion => [$hds->bbox("all")]);

MainLoop;
BioPerl-1.6.923/examples/tools000755000765000024          012254227327 16263 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/tools/extract_genes.pl000555000765000024       645112254227326 21620 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
=pod

=head1 NAME

extract_genes.pl - extract genomic sequences from NCBI files
using BioPerl

=head1 DESCRIPTION

This script is a simple solution to the problem of
extracting genomic regions corresponding to genes. There are other 
solutions, this particular approach uses genomic sequence 
files from NCBI and gene coordinates from Entrez Gene.

The first time this script is run it will be slow as it will
extract species-specific data from the gene2accession file and create
a storable hash (retrieving the positional data from this hash is
significantly faster than reading gene2accession each time the script
runs). The subsequent runs should be fast.

=head1 INSTALLATION

=head2

Install BioPerl, full instructions at http://bioperl.org.

=head2 Download gene2accession.gz

Download this file from ftp://ftp.ncbi.nlm.nih.gov/gene/DATA into 
your working directory and gunzip it.

=head2 Download sequence files

Create one or more species directories in the working directory, the
directory names do not have to match those at NCBI (e.g. "Sc", "Hs").

Download the nucleotide fasta files for a given species from its CHR*
directories at ftp://ftp.ncbi.nlm.nih.gov/genomes and put these files into a 
species directory. The sequence files will have the suffix ".fna" or 
"fa.gz", gunzip if necessary.

=head2 Determine Taxon id

Determine the taxon id for the given species. This id is the first column
in the gene2accession file. Modify the %species hash in this script
such that name of your species directory is a key and the taxon id is the 
value.

=head2 Command-line options

  -i   Gene id
  -s   Name of species directory
  -h   Help

Example:

  extract_genes.pl -i 850302 -s Sc

=cut

use strict;
use Bio::DB::Fasta;
use Getopt::Long;
use Storable;

my %species = ( "Sc" => 4932,  # Saccharomyces cerevisiae
				     "Ec" => 83333, # Escherichia coli K12
					  "Hs" => 9606   # H. sapiens
				   );

my ($help,$id,$name);

GetOptions( "s=s"  =>  \$name,
            "i=i"  =>  \$id,
				"h"    =>  \$help );

usage() if ($help || !$id || !$name);

my $storedHash = $name . ".dump";

# create index for a directory of fasta files
my $db = Bio::DB::Fasta->new($name, -makeid => \&make_my_id);

# extract species-specific data from gene2accession
unless (-e $storedHash) {
	my $ref;
	# extract species-specific information from gene2accession
	open MYIN,"gene2accession" or die "No gene2accession file\n";
	while () {
		my @arr = split "\t",$_;
		if ($arr[0] == $species{$name} && $arr[9] =~ /\d+/ && $arr[10] =~ /\d+/) {
			($ref->{$arr[1]}->{"start"}, $ref->{$arr[1]}->{"end"}, 
			 $ref->{$arr[1]}->{"strand"}, $ref->{$arr[1]}->{"id"}) =	
				($arr[9], $arr[10], $arr[11], $arr[7]);
		}
	}
	# save species-specific information using Storable
	store $ref, $storedHash;
} 

# retrieve the species-specific data from a stored hash
my $ref = retrieve($storedHash);

# retrieve sequence and sub-sequence
if (defined $ref->{$id}) {
	my $chr = $db->get_Seq_by_id($ref->{$id}->{"id"});
	my $seq = $chr->trunc($ref->{$id}->{"start"},$ref->{$id}->{"end"});
	$seq = $seq->revcom if ($ref->{$id}->{"strand"} eq "-");

	# Insert SeqIO options here...
	print $seq->seq,"\n";
} else {
	print "Cannot find id: $id\n";
}

sub make_my_id {
	my $line = shift;
	$line =~ /ref\|([^|]+)/;
	$1;
}

sub usage {
	system "perldoc $0";
	exit;
}

__END__
BioPerl-1.6.923/examples/tools/gb_to_gff.pl000555000765000024       114612254227312 20670 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl
use strict;

use Bio::Tools::GFF;
use Bio::SeqIO;

my ($seqfile) = @ARGV;
die("must define a valid seqfile to read") unless ( defined $seqfile && -r $seqfile);

my $seqio = new Bio::SeqIO(-format => 'genbank',
			   -file   => $seqfile);
my $count = 0;
while( my $seq = $seqio->next_seq ) {
    $count++;
    # defined a default name
    my $fname = sprintf("%s.gff", $seq->display_id || "seq-$count");
    my $gffout = new Bio::Tools::GFF(-file => ">$fname" ,
				     -gff_version => 1);
    
    foreach my $feature ( $seq->top_SeqFeatures() ) {
	$gffout->write_feature($feature);
    }
}
BioPerl-1.6.923/examples/tools/gff2ps.pl000555000765000024      1320412254227312 20161 0ustar00cjfieldsstaff000000000000#!/usr/local/bin/perl


=head1 NAME

gff2ps - you will want to change this script

=head2 SYNOPSIS

   perl gff2ps < file.gff > file.ps

=head2 DESCRIPTION

This script provides GFF to postscript handling. Due to the ... ummm
... potential for flexible reinterpretation that is GFF, this script
will almost certainly need modifying for anyone elses use (basically,
you need to know what you want to get out of the GFF file and how to
draw it). But it does include code to draw the most challenging thing
out there - genes - and should give you a good example of where to
start

=head2 AUTHOR

Ewan Birney

=cut


use Bio::Tools::GFF;

my $font      = 8;
my $scale     = 200;
my $rotate    = 1;
my $feature_off = 0;

use Getopt::Long;

&GetOptions(
	    "scale=i"   => \$scale,
	    "font=i"    => \$font,
	    "rotate=i"  => \$rotate,
	    "start=i"   => \$feature_off
	    );


my $gffio = Bio::Tools::GFF->new(-fh => \*STDIN, -gff_version => 1);
my $feature;

use Data::Dumper;

my %set;

# loop over the input stream
while( my $f = $gffio->next_feature()) {
    $f->start($f->start - $feature_off);
    $f->end  ($f->end   - $feature_off);

    if( $f->start < 0 ) {
	next;
    }

    if( $f->start > $scale*1000 ) {
      next;
    }
    
    
    if( $f->primary_tag =~ /coding_exon/ ) {
	#print STDERR "Seen ",$f->start," ",$f->end,"\n";
	($group) = $f->each_tag_value('group');
	$group =~ s/\s+//g;

	

	if( !defined $set{$group} ) {
	    $set{$group} = Bio::SeqFeature::Generic->new();
	    $set{$group}->seqname($f->seqname);
	    $set{$group}->primary_tag('transcript');
	    $set{$group}->source_tag($f->source_tag);
	    $set{$group}->add_tag_value('id',$group);
	}
	$set{$group}->add_sub_SeqFeature($f,'EXPAND');
	$set{$group}->strand($f->strand);
    }
}
$gffio->close();


#foreach my $set ( values %set ) {
#    print $set->gff_string,"\n";
#    foreach $sub ( $set->sub_SeqFeature ) {
#	print $sub->gff_string,"\n";
#    }
#}


# sort into forward and reverse strands

my @forward;
my @reverse;

$max = 0;

foreach my $set ( values %set ) {
    if( $set->end > $max ) {
	$max = $set->end;
    }

    if( $set->strand == -1 ) {
	push(@reverse,$set);
    } else {
	push(@forward,$set);
    }
}

@forward = sort { $a->start <=> $b->start } @forward;
@reverse = sort { $a->start <=> $b->start } @reverse;

&print_header(\*STDOUT);

if( $rotate ) {
   print "0 700 translate\n";
   print "-90 rotate\n";
}

print "0 200 moveto 900 200 lineto stroke\n";

my $bp_max = $scale*900;

for(my $bp = 0;$bp < $bp_max ;$bp = $bp + 5000) {
    print STDOUT $bp/$scale," 200 moveto ",$bp/$scale," 197 lineto\n";
    $text = int( $feature_off + ($bp/1000));
    print STDOUT $bp/$scale," 195 moveto ($text) show\n";
}


&draw_gene(\@forward,1,$scale,220,\*STDOUT);
&draw_gene(\@reverse,-1,$scale,180,\*STDOUT);

print "showpage\n";




sub draw_gene {
    my ($gene_array,$strand,$scale,$offset,$fh) = @_;


    my @bump_array;
    my $bump_row_max = 1;
    my $bump_end = int $max/$scale;

    $bump_array[0] = '0' x $bump_end;


    foreach my $f ( @$gene_array ) {

	#
	# Bump it baby!
	#

	# We keep an array of strings for currently draw areas. Do this in pixel
	# coordinates to save on space. If the region has all 0's then we know we
	# can draw here. If so, we set it to 1's. If not, we go up a row and see if
	# we can fit it in there. If we exhausted the rows we make a new row. 

	$bump_start = (int $f->start/$scale)-1;
	$bump_len   = int(($f->end - $f->start)/$scale) +1;

	# text might be longer than gene. Mystic number 5 looks good for 8 point helvetica
	# you will have to change this otherwise.

	my ($gene_id) = $f->each_tag_value('id');
	if( (length $gene_id)*5 > $bump_len ) {
	    $bump_len = (length $gene_id)*5; 
	}

	# figure out the first place to fit in this gene;
	for($i=0;$i<$bump_row_max;$i++) {
	    #print STDERR "Seeing $bump_start $bump_len $i ",substr($bump_array[$i],$bump_start,$bump_len),"\n";
	    
	    if( substr($bump_array[$i],$bump_start,$bump_len) !~ /1/ ) {
		#print STDERR "Going to break with $i\n";
		last;
	    }
	}
	#print STDERR "i is $i\n";
	# if $i == bump_row_max then we need a new bump row
	if( $i == $bump_row_max ) {
	    $bump_array[$bump_row_max] = '0' x $bump_end;
	    $bump_row_max++;
	}
	
	# now blank out this bump row to 1's
	
	substr($bump_array[$i],$bump_start,$bump_len) = '1' x $bump_len;
	
	# now print it out ;)

	
	#
	# Need to be portable between strands. Gene hats go the
	# other way up on reverse strand, but not the text. 
	#

	if( $strand == 1 ) {
	    $text   = $offset+($i*20)+1;
	    $bottom = $offset+($i*20)+10;
	    $top    = $offset+($i*20)+20;
	    $mid    = $offset+($i*20)+15;
	} else {
	    $text   = $offset-($i*20)-19;
	    $bottom = $offset-($i*20);
	    $top    = $offset-($i*20)-10;
	    $mid    = $offset-($i*20)-5;
	}

	print $fh $f->start/$scale," ",$text," moveto\n";
	print $fh "($gene_id) show\n";

	my $prev = undef;
	    
	foreach $exon ( $f->sub_SeqFeature ) {
	    print $fh $exon->start/$scale," ",$bottom," moveto\n";
	    print $fh $exon->end/$scale," ",$bottom," lineto\n";
	    print $fh $exon->end/$scale," ",$top, " lineto\n";
	    print $fh $exon->start/$scale," ",$top," lineto\n";
	    print $fh "closepath stroke\n";

	    # draw the intron hat
	    if( defined $prev ) {
		print $prev->end/$scale," ",$mid," moveto\n";
		my $intron_len = $exon->start - $prev->end;
		
		print $fh ($prev->end+($intron_len/2))/$scale," ",$top," lineto\n";
		print $fh $exon->start/$scale," ",$mid," lineto stroke\n";
	    }
		
	    $prev = $exon;
	}
	
    }
}


sub print_header {
    my $fh = shift;

    print $fh <
0.5 setlinewidth
/Helvetica findfont $font scalefont setfont
EOF

}
BioPerl-1.6.923/examples/tools/parse_codeml.pl000555000765000024       230112254227327 21411 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use Bio::Tools::Phylo::PAML;
use Bio::Root::IO;

my $parser = new Bio::Tools::Phylo::PAML(-file    => shift,
					 -verbose => shift);

my $result = $parser->next_result;
my @otus = $result->get_seqs();
my $MLmatrix = $result->get_MLmatrix();
my $NGmatrix = $result->get_NGmatrix();

# These matrices are length(@otu) x length(@otu) "strict lower
# triangle" 2D-matrices, which means that the diagonal and
# everything above it is undefined.  Each of the defined cells is a
# hashref of estimates for "dN", "dS", "omega" (dN/dS ratio), "t",
# "S" and "N".  If a ML matrix, "lnL" will also be defined.

@otus = $result->get_seqs();
$MLmatrix = $result->get_MLmatrix();
$NGmatrix = $result->get_NGmatrix();
for( my $i=0;$i[$i]}; $j++ ) { 
		printf "The ML omega ratio for sequences %s vs %s was: %g\n",
		  $otus[$i]->id, $otus[$j]->id, $MLmatrix->[$i]->[$j]->{omega};
	}
}

for( my $i=0;$i[$i]}; $j++ ) { 
	
		printf "The NG omega ratio for sequences %s vs %s was: %g\n",
		  $otus[$i]->id, $otus[$j]->id, $NGmatrix->[$i]->[$j]->{'omega'};
	}
}
BioPerl-1.6.923/examples/tools/psw.pl000555000765000024       635312254227312 17572 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

# PROGRAM  : psw.pl
# PURPOSE  : Simple driver for Bio::Tools::pSW
# AUTHOR   : Ewan Birney birney@sanger.ac.uk 
# CREATED  : Tue Oct 27 1998
#
# INSTALLATION
#  
# you almost certainly have to have installed bioperl 
# from the makefile system for this to work. This is
# because this module use XS extensions (C source code
# 'compiled into' perl)
#
# The lib system below is just so that I (ewan) can test it
# on site... 
#

use lib "/nfs/disk100/pubseq/wise/PerlMod/";

# 
# This is a simple example script. We are going
# to make 3 sequences directly from memory and
# then align them once using blosum matrix and once
# using a gonnet matrix. These matrices should
# in the examples directory.
#

use Bio::Tools::pSW;

# redundant, as Bio::Tools::pSW uses them, but useful to say
# precisely what we are using ;)

use Bio::Seq; 
use Bio::SimpleAlign;
use Bio::AlignIO;

# for legibility - write with newlines and then strip them!

$tseq = 'SKSESPKEPEQLRKLFIGGLSFETTDESLRSHFEQWGTLTDCVVMRDPNTKRSRGFGFVT
YATVEEVDAAMNARPHKVDGRVVEPKRAVSREDSQRPGAHLTVKKIFVGGIKEDTEEHHL
RDYFEQYGKIEVIEIMTDRGSGKKRGFAFVTFDDHDSVDKIVIQKYHTVNGHNCEVRKAL
SKQEMASASSSQRGRSGSGNFGGGRGGGFGGNDNFGRGGNFSGRGGFGGSRGGGGYGGSG
DGYNGFGNDGGYGGGGPGYSGGSRGYGSGGQGYGNQGSGYGGSGSYDSYNNGGGRGFGGG
SGSNFGGGGSYNDFGNYNNQSSNFGPMKGGNFGGRSSGPYGGGGQYFAKPRNQGGYGGSS
SSSSYGSGRRF';

$tseq =~ s/[^A-Z]//g;

$seq1 = Bio::Seq->new(-id=>'roa1_human',-seq=>$tseq);

$tseq = 'MVNSNQNQNGNSNGHDDDFPQDSITEPEHMRKLFIGGLDYRTTDENLKAHFEKWGNIVDV
VVMKDPRTKRSRGFGFITYSHSSMIDEAQKSRPHKIDGRVVEPKRAVPRQDIDSPNAGAT
VKKLFVGALKDDHDEQSIRDYFQHFGNIVDINIVIDKETGKKRGFAFVEFDDYDPVDKVV
LQKQHQLNGKMVDVKKALPKQNDQQGGGGGRGGPGGRAGGNRGNMGGGNYGNQNGGGNWN
NGGNNWGNNRGGNDNWGNNSFGGGGGGGGGYGGGNNSWGNNNPWDNGNGGGNFGGGGNNW
NNGGNDFGGYQQNYGGGPQRGGGNFNNNRMQPYQGGGGFKAGGGNQGNYGGNNQGFNNGG
NNRRY';

$tseq =~ s/[^A-Z]//g;

$seq2 = Bio::Seq->new(-id=>'roa1_drome',-seq=>$tseq);

$tseq = 'MHKSEAPNEPEQLRKLFIGGLSFETTDESLREHFEQWGTLTDCVVMRDPNSKRSRGFGFV
TYLSTDEVDAAMTARPHKVDGRVVEPKRAVSREDSSRPGAHLTVKKIFVGGIKEDTEEDH
LREYFEQYGKIEVIEIMTDRGSGKKRGFAFVTFEDHDSVDKIVIQKYHTVNNHNSQVRKA
LSKQEMASVSGSQRERGGSGNYGSRGGFGNDNFGGRGGNFGGNRGGGGGFGNRGYGGDGY
NGDGQLWWQPSLLGWNRGYGAGQGGGYGAGQGGGYGGGGQGGGYGGNGGYDGYNGGGSGF
SGSGGNFGSSGGYNDFGNYNSQSSSNFGPMKGGNYGGGRNSGPYGGGYGGGSASSSSGYG
GGRRF';

$tseq =~ s/[^A-Z]//g;
$seq3 = Bio::Seq->new(-id=>'roa1_xenla',-seq=>$tseq);


#
# Now make an Alignment Factory with blosum62 as a matrix
# gap -12 and ext -2
#

$fac = Bio::Tools::pSW->new(-matrix => 'blosum62.bla',-gap => 12, -ext => 2);


#
# run seq1 vs seq2 and seq1 vs seq3 and write the output direct 
# to stdout using the 'pretty' method
#

$fac->align_and_show($seq1,$seq2,STDOUT);
print "Next alignment\n";
$fac->align_and_show($seq1,$seq3,STDOUT);


#
# a different factory, using gonnet, and now make a simple align and 
# provide MSF format
#

$fac = Bio::Tools::pSW->new(-matrix => 'gon250.bla',-gap => 12, -ext => 2);


# switch on reporting this time and change the amount of memory it is allowed

print STDOUT "Doing the next calculation in limited memory, with a progress report\n";

$fac->report(1);
$fac->kbyte(100);

$al = $fac->pairwise_alignment($seq1,$seq2);


# write out a MSF file
my $out = Bio::AlignIO->newFh('-fh'=> \*STDOUT,  '-format' => 'msf');
my $status = print $out $al;
#$al->write_MSF(\*STDOUT);



BioPerl-1.6.923/examples/tools/reverse-translate.pl000555000765000024       254112254227320 22421 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=head1 NAME

reverse-translate.pl

=head1 DESCRIPTION

Reverse-translates a nucleotide sequence using the most frequent codons.
Requires an input sequence file and a nucleotide sequence file containing 
one sequence comprised of one or more ORFs. This file supplies the codon
frequency data and will be parsed starting at the first triplet in the sequence.

=head1 OPTIONS

  -i   Input sequence, amino acid
  -c   Input sequence, nucleotide ORFs

Example:

 reverse-translate.pl -i ~/bioperl-live/t/data/cysprot.fa -c ~/bioperl-live/t/data/HUMBETGLOA.fa 

=cut

use strict;
use Bio::SeqIO;
use Bio::Tools::CodonTable;
use Bio::Tools::SeqStats;
use Bio::CodonUsage::Table;
use Getopt::Long;

my ($codonFile,$seqFile);

GetOptions( "c=s" => \$codonFile,
            "i=s" => \$seqFile );

die "Need input sequence and file containing coding regions"
  if ( !$codonFile || !$seqFile );

my $codonIn = Bio::SeqIO->new(-file => $codonFile,
										-format => 'fasta');

my $codonSeq = $codonIn->next_seq;

my $codonStats = Bio::Tools::SeqStats->count_codons($codonSeq);

my $codonUsage = Bio::CodonUsage::Table->new(-data => $codonStats );

my $codonTable = Bio::Tools::CodonTable->new;

my $seqIn = Bio::SeqIO->new(-file => $seqFile);

my $seq = $seqIn->next_seq;

my $rvSeq = $codonTable->reverse_translate_best($seq,$codonUsage);

print $rvSeq,"\n";

__END__
BioPerl-1.6.923/examples/tools/run_genscan.pl000555000765000024       452212254227324 21262 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# Brian Osborne
# script to run genscan on all nucleotide sequences in a fasta file
# and save results as the fasta files .gs.pept and .gs.cds,
# and .gs.exons

use Bio::SeqIO;
use Bio::Seq;
use Getopt::Long;
use Bio::Tools::Genscan;
use strict;

# GENSCAN matrix
my $matrix = "/home/bosborne/src/genscan/HumanIso.smat";

my ($file,$i);

GetOptions( "f|file=s" => \$file );
usage() if ( !$file );

my $pept_out = Bio::SeqIO->new(-file   => ">$file.gs.pept",
			       -format => "fasta");
my $cds_out = Bio::SeqIO->new(-file   => ">$file.gs.cds",
			      -format => "fasta");
my $exons_out = Bio::SeqIO->new(-file   => ">$file.gs.exons",
				-format => "fasta");

my $in = Bio::SeqIO->new(-file => $file , -format => 'Fasta');

while ( my $seq = $in->next_seq() ) {
   die "Input sequence is protein\n" if ( $seq->alphabet eq 'protein' );

   # create temp file, input to GENSCAN
   my $temp_out = Bio::SeqIO->new(-file   => ">temp.fa",
				   -format => "fasta");
   $temp_out->write_seq($seq);

   my $file_id = $seq->display_id;
   $file_id =~ s/\|/-/g;

   system "genscan $matrix temp.fa -cds > $file_id.gs.raw";
   unlink "temp.fa";

   my $genscan = Bio::Tools::Genscan->new( -file => "$file_id.gs.raw");
   while ( my $gene = $genscan->next_prediction() ) {
      $i++;
      my $pept = $gene->predicted_protein;
      my $cds = $gene->predicted_cds;
      my @exon_arr = $gene->exons;

      if ( defined $cds  ) {
	 my $cds_seq = Bio::Seq->new(-seq => $cds->seq,
				     -display_id => $cds->display_id);
	 $cds_out->write_seq($cds_seq);
      }

      if ( defined $pept ) {
	 my $pept_seq = Bio::Seq->new(-seq => $pept->seq,
				      -display_id => $pept->display_id);
	 $pept_out->write_seq($pept_seq);
      }

      for my $exon (@exon_arr) {
	 my $desc = $exon->strand . " " . $exon->start . "-" . $exon->end .
	   " " . $exon->primary_tag . " " . "GENSCAN_predicted_$i";
	 my $exon_seq = Bio::Seq->new(-seq => $seq->subseq($exon->start,
							   $exon->end),
				      -display_id => $seq->display_id,
				      -desc => $desc );
	 $exons_out->write_seq($exon_seq);
      }
   }
   $genscan->close();
   unlink "$file_id.gs.raw";
}

sub usage {
    print "
Usage    : $0 -f 
Function : run genscan on all nucleotide sequences in a multiple fasta file
Output   : .gs.pept, .gs.cds, .gs.exons

";
    exit;
}
BioPerl-1.6.923/examples/tools/run_primer3.pl000555000765000024       451312254227312 21222 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=head1 NAME

run_primer3.pl - run primer3 and parse its output

=head1 SYNOPSIS

  ./run_primer3.pl -i test.fa

  #or

  ./run_primer3.pl --input=test.fa

=head1 DESCRIPTION

Example of how to run primer3 and parse its output, essentially taken from an
email written by Paul Wiersma to bioperl-l.

=head1 FEEDBACK

User feedback is an integral part of the evolution of this and other
Bioperl scripts. Send your comments and suggestions to the Bioperl 
mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR

Brian Osborne, bosborne at alum.mit.edu

=cut

use strict;
use Getopt::Long;
use Bio::Tools::Run::Primer3;
use Bio::SeqIO;

my $in_file;

GetOptions("i|input:s" => \$in_file );

usage() unless $in_file;

my $seqio = Bio::SeqIO->new(-file => $in_file);

while (my $seq = $seqio->next_seq) {
	my $primer3 = Bio::Tools::Run::Primer3->new(-seq => $seq);
	$primer3->program_name('primer3_core') unless $primer3->executable;

	$primer3->add_targets('PRIMER_MIN_TM' => 56, 'PRIMER_MAX_TM' => 90);

	my $results = $primer3->run;

	unless ($results->number_of_results) {
		print "No results for ",$seq->display_id;
		next;
	}

	my @out_keys_part = qw(START
								    LENGTH
								    TM
									 GC_PERCENT
									 SELF_ANY
									 SELF_END
									 SEQUENCE );

	print "\n", $seq->display_id, "\n";

	for (my $i = 0 ; $i < $results->number_of_results ; $i++){
		my $result = $results->primer_results($i);
 
		print "\n", $i + 1;	
		for my $key qw(PRIMER_LEFT PRIMER_RIGHT){	
			my ($start, $length) = split /,/, $result->{$key};
			$result->{$key . "_START"} = $start;
			$result->{$key . "_LENGTH"} = $length;
			foreach my $partkey (@out_keys_part) {
				print "\t", $result->{$key . "_" . $partkey};
			} 
			print "\n";
		}
		print "\tPRODUCT SIZE: ", $result->{'PRIMER_PRODUCT_SIZE'}, ", PAIR ANY COMPL: ",
		  $result->{'PRIMER_PAIR_COMPL_ANY'};
		print ", PAIR 3\' COMPL: ", $result->{'PRIMER_PAIR_COMPL_END'}, "\n";
	}
}

sub usage {
   exec('perldoc',$0);
   exit(0);
}

__END__
BioPerl-1.6.923/examples/tools/seq_pattern.pl000555000765000024       765112254227316 21314 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl

#-----------------------------------------------------------------------------
# PROGRAM : seq_pattern.pl 
# PURPOSE : This is a simple driver used to test the Bio::Tools::SeqPattern.pm
#           module for working with sequence patterns (regexps that recognize
#           nucleotide or peptide sequences).
# AUTHOR  : Steve Chervitz (sac@bioperl.org)
# CREATED : 28 Aug 1997
# USAGE   : seq_pattern.pl -h
# COMMENTS: 
#    This is a driver script for the Bio::Tools::SeqPattern.pm Bioperl module
#    that can be used for working with both nucleotide and peptide sequence and 
#    offers features such as:
#    
#      -- generate reverse complement of sequence pattern
#      -- ensuring pattern has no invalid characters
#      -- untainting pattern
#      -- expanding ambiguity codes. 
#    
#     Functionality is not yet complete but it may be of use as-is. 
# 
# INSTALLATION
#    Edit the use lib "...." line to point the directory
#    containing your Bioperl modules.
#
# DOCUMENTATION:
#  http://genome-www.stanford.edu/perlOOP/bioperl/lib/Bio/Tools/SeqPattern.pm.html
#
#-----------------------------------------------------------------------------

use lib "/Users/steve/lib/perl";
use Bio::Tools::SeqPattern ();
use Getopt::Std;

$opt_h = 0;
$opt_n = 0;
$opt_p = 0;
$opt_r = 0;

getopts('hnprv:');
$pat = $ARGV[0] || '';

$opt_h and die <<"QQ_USAGE_QQ";

Usage: seq_pattern.pl [-n|p|r|h] 'REGEXP' 

 regexp : full-regular expression for a nucleotide or peptide sequence.
          Must be listed *after* one of the following options:
 -n     : interpret regexp as a nucleotide pattern.
 -p     : interpret regexp as a peptide pattern.
 -r     : output only the reverse complement of the nucleotide pattern.
 -h     : print usage.
 
QQ_USAGE_QQ


## Nucleotide test patterns (most are based on actual patterns submitted by users):

%nucpat = (1 =>'YR...CG(CCG){5,7}CG[^G]TN{10,}[SA]{4}NN(ACA){2,}GCGTTT.{20,40}GT>',
	   2 =>'cggnnn[ta][ta][ta]n{3,5}[ta][ta][ta]nnnccg',
	   3 =>''cggnnnwwwn{3,5}wwwnnnccg',
	   5 =>'(CCCCT)N{1,200}(agggg)N{1,200}(agggg)', 
	   6 =>'cccct{2,}', 
	   7 =>'(a){10,40}', 
	   8 =>'(cag){36,}', 
	   9 =>'rgaatgx{2,}ygtttca(cag){5,}',
	   10 =>'yattgtt(n){20,80}yattgtt', 
	   11 =>'yattgtt(aca){20,80}yattgtt', 
	   12 =>'TATAAAN{30,100}[AT][CAT][AT]YCAAR[CAT][AT][CAT]', 
	   13 =>'TGACTC[N]{1,300}TGACTC',
	   14 =>'TGACTCN*GAGTCAN*GAGTCAN*TGACTC',
	   15 =>'TGACTC(TCA)*GAGTCA',
	   16 =>'TGACTCN*GAG(TCA)*GAGTCA',
	   17 =>'[at][at]ttcacatgy',
	   );

%peppat = (1 =>'',
	   2 =>'', 
	   );

#----------------------
# Main

if($opt_r) {
    print Bio::Tools::SeqPattern->new(-SEQ =>$pat, -TYPE =>'Dna')->revcom->str,"\n";
    
} else {
    test_nuc($pat) if ($opt_n and !$opt_p);
    test_pep($pat) if ($opt_p and !$opt_n);
    (test_nuc($pat), test_pep($pat)) if !($opt_p or $opt_n);
}
    
exit 0;

#----------------------

sub test_nuc {
# Create nucleotide pattern object:
    my $pat = shift;
    $pat ||= $nucpat{9};

    $npat = new Bio::Tools::SeqPattern(-seq =>$pat, -type =>'Dna');

    print "\nNucleotide Pattern:\n";
    print "-----------------------\n";
    printf "%18s: %s\n", 'Type',    $npat->type;
    printf "%18s: %s\n", 'Original',$npat->str;
    printf "%18s: %s\n", 'Expanded', $npat->expand;
    printf "%18s: %s\n", 'Reverse-Comp', $npat->revcom->str;
    printf "%18s: %s\n", 'Rev-Comp+Expanded', $npat->revcom(1)->str; # Hate this syntax. May change.
    print "\n";
}


sub test_pep {
# Create peptide pattern object:
    my $pat = shift;
    $pat ||= $peppat{1};

    $ppat = new Bio::Tools::SeqPattern(-seq =>$pat, -type =>'Amino');

    print "\nPeptide Pattern:\n";
    print "-----------------------\n";
    printf "%18s: %s\n", 'Type',    $ppat->type;
    printf "%18s: %s\n", 'Original',$ppat->str;
    printf "%18s: %s\n", 'Expanded', $ppat->expand;
    print "\n";
}    






BioPerl-1.6.923/examples/tools/standaloneblast.pl000555000765000024      3524012254227316 22160 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

# PROGRAM  : standaloneblast.pl
# PURPOSE  : Demonstrate possible uses of Bio::Tools::StandAloneBlast.pm
# AUTHOR   : Peter Schattner schattner@alum.mit.edu
# CREATED  : Nov 01 2000
#
# INSTALLATION
#

# You will need to enable Blast to find the Blast program. This can be done
# in (at least) two ways:
#  1. define an environmental variable blastDIR:
#	export BLASTDIR=/home/peter/blast   or
#  2. include a definition of an environmental variable BLASTDIR in every script that will
#     use StandAloneBlast.pm.
#	BEGIN {$ENV{BLASTDIR} = '/home/peter/blast/'; }
#
#  We also need to select the database to be used
my $amino_database = 'swissprot';


# 
#  We are going to demonstrate 3 possible applications of StandAloneBlast.pm:
#	1. Test effect of varying choice of substitution matrices	
#	2. Test effect of varying choice of gap penalty 
#	3. Comparison of results of psiblast depending on whether psiblast itself is used
#	to identify an alignment to use for blasting or whether an external alignment is given to 
#	psiblast
#
use strict;
use Getopt::Long;
use Bio::SimpleAlign;
use Bio::Tools::Run::StandAloneBlast;
use Bio::SearchIO;
use Bio::AlignIO;
use Bio::SeqIO;
use Bio::Root::IO;

# set some default values
my $queryseq = Bio::Root::IO->catfile(qw(t data cysprot1.fa) );
my $executable = 'blastpgp';
my $queryaln = Bio::Root::IO->catfile(qw(t data cysprot.msf) );
my @params = ('database' => $amino_database);
# string listing examples to be executed. Default is to execute
# all tests (ie 1,2 and 3)
my $do_only = ''; 	
my $example1param = 'MATRIX';  # parameter to be varied in example 1
my $example2param = 'GAP';  # parameter to be varied in example 1
my $example1values = [ 'BLOSUM62', 'BLOSUM80', 'PAM70']; # MATRIX values to try
my $example2values = [ 7, 9, 25]; # GAP values to be tried
my $queryalnformat = 'msf';
my $jiter = 2;
# only use pos. specific scoring matrix if > 50% of residues have
# consensus letter (and compare with 25% or 75% cut off)
my  $maskvalues = [50, 25, 75] ; my $helpflag = 0;   # Flag to show usage info.

# get user options
my @argv       = @ARGV;  # copy ARGV before GetOptions() massacres it.
my $paramvalstring;
my $maskvalstring;

&GetOptions("h!"          => \$helpflag, 
				"help!"       => \$helpflag,
				"in=s"        => \$queryseq,
				"inaln=s"     => \$queryaln,
				"alnfmt=s"    => \$queryalnformat,
				"param=s"     => \$example1param,
				"exec=s"      => \$executable,
				"paramvals=s" => \$paramvalstring,
				"do=i"        =>  \$do_only,
				"maskvals=s"  => \$maskvalstring,
				"iter=i"      =>  \$jiter,
	) ;

if ($paramvalstring) { @$example1values = split (":", $paramvalstring); }
if ($maskvalstring)  { @$maskvalues     = split (":", $maskvalstring);  }

if ($helpflag) { &example_usage(); exit 0;}

# create factory & set user-specified global blast parameters
foreach my $argv (@argv) {
	next unless ($argv =~ /^(.*)=>(.*)$/);
	push (@params, $1 => $2);
}
my  $factory = Bio::Tools::Run::StandAloneBlast->new(@params);
	
# If "do" variable not set, do all four examples
if ( ! $do_only)  {
    &vary_params($queryseq, $example1param, $example1values); # ex. 1

    # To compare gap penalties of 7, 9 and 25 we need to set the
    # scoring matrix to BLOSUM62 and extension penalty to 2 (these are
    # limitations of BLAST)

    $factory->MATRIX('BLOSUM62');  

    $factory->EXTENSION(2);  
    &vary_params($queryseq, $example2param, $example2values); # ex. 2
 
    # For the psiblast tests we want to restore gap opening and
    # extension values to their defaults

    $factory->GAP(11);
    $factory->EXTENSION(1);
    # now do the mask comparison example and ..
    &vary_masks($queryseq, $maskvalues); # ex. 3
    # do the jumpstart-align vs multiple iteration examples with the 
    # mask value set to 50%
    &aligned_blast($queryseq, $queryaln, $queryalnformat, 
		   $jiter, $maskvalues->[0]); # ex. 4
} elsif ($do_only  == 1) {
    &vary_params($queryseq,$example1param, $example1values);
} elsif ($do_only  == 3) {
    &vary_masks($queryseq, $maskvalues);
} elsif ($do_only  == 4 ) {
    &aligned_blast($queryseq, $queryaln, $queryalnformat, $jiter, $maskvalues->[0]);
}  else {
    &example_usage();
}

exit 0;

##########
## End of "main"


#################################################
#   compare_runs(): Prints out display of which hits were found by different methods
#	Various methods are labeled by "tags" found in array @runtags
#
#  args: 
#	$typetag  -  label describing type of "tags"
#	$runtags  -  reference to array @runtags
#	$hashhits  - reference to hash of all the hits found by all runs (%hashhits) 
#		value for each hit is string which is the concatenation of all the "tags" of
#		runs that found that hit
#  returns: nothing  

sub compare_runs {
    my $typetag = shift;
    my $runtags = shift;

    my $hashhits = shift;   

    my ($tag, @taghits);

    print "Comparing BLAST results... \n";

# Get total number of hits found by any method
    my $numhits = keys %$hashhits ; # scalar context to get total number of hits by all methods
    print  "Total number of hits found: $numhits \n";

# Get total number of hits found by every method
    my $alltags =  join ( "" ,  @$runtags );
    my  @alltaghits = grep  $$hashhits{$_} =~ /$alltags/  ,  keys %$hashhits;
    print  " Number of hits found by every method / parameter-value: " ,   
    scalar(@alltaghits), "\n";

# If one desires to see the hits found by all methods, uncomment next 2 lines
#print  " Hits were found all methods / parameters: \n";
#print   join ( "\n", @alltaghits ) ,  "\n";

# For each method/parameter-value (labeled by type) display  hits found 
# exclusively by that method
    foreach $tag (@$runtags)  {
		 @taghits = grep  $$hashhits{$_} =~ /^$tag$/  ,  keys %$hashhits;
		 print  " Hits found only when $typetag was $tag: \n";
		 print   join ( "\n", @taghits ) ,  "\n";
    }
    return 1;
}


#################################################
#   vary_params(): Example demonstrating varying of parameter
#
#  args: 
#	$queryseq  - query sequence (can be filename (fasta),  or Bio:Seq object) 
#	$param  - name of parameter to be varied 
#	$values  - reference to array of values to be used for the parameter 
#  returns: nothing  



sub vary_params {

    my $queryseq = shift;   
    my $param = shift;   
    my $values = shift;  


    print "Beginning $param parameter-varying example... \n";

    # Now we'll perform several blasts, 1 for each value of the
    # selected parameter.  In the first default case, we vary the
    # MATRIX substitution parameter, creating 3 BLAST reports, using
    # MATRIX values of BLOSUM62, BLOSUM80 or PAM70.

    # In the second default case, we vary the GAP penalty parameter,
    # creating 3 BLAST reports, using GAP penalties of 7, 9 and 25. In
    # either case we then automatically parse the resulting report to
    # identify which hits are found with any of the parameter values
    # and which with only one of them.

 
    # To test the BLAST results to some other parameter it is only
    # necessary to change the parameters passed to the script on the
    # commandline.  The only tricky part is that the BLAST program
    # itself only supports a limited range of parameters.  See the
    # BLAST documentation.

    my ($report, $sbjct, $paramvalue);

    my $hashhits = { };	# key is hit id, value is string of param values for which hit was found
    
    foreach $paramvalue (@$values)  {
	
	$factory->$param($paramvalue); # set parameter value

	print "Performing BLAST with $param = $paramvalue \n";

	$report = $factory->$executable($queryseq);
	my $r = $report->next_result;
	while( my $hit = $r->next_hit ) {
	    $hashhits->{$hit->name} .= "$paramvalue";
	}
    }

    &compare_runs( $param , $values , $hashhits);  

    return 1;

}

#################################################

#   vary_masks(): Example demonstrating varying of parameter
#
#  args:
#	$queryseq  - query sequence (can be filename (fasta),  or Bio:Seq object)
#	$maskvalues  - reference to array of values to be used for the mask threshold
#  returns: nothing

# Now we'll perform several blasts, 1 for each value of the mask threshold.
# In the default case, we use thresholds of 25%, 50% and 75%. (Recall the threshold is
# % of resudues which must match the consensus residue before deciding to use the
# position specific scoring matrix rather than the default - BLOSUM or PAM - matrix)
# We then automatically parse the resulting reports to identify which hits
# are found with any of the mask threshold values and which with only one of them.
#

sub vary_masks {

my $queryseq = shift;
my $values = shift;


print "Beginning mask-varying example... \n";

my ($report, $sbjct, $maskvalue);

my $hashhits = { };     # key is hit id, value is string of param values for which hit was found

# Get the alignment file
my $str = Bio::AlignIO->new(-file=> "$queryaln", '-format' => "$queryalnformat", );
my $aln = $str->next_aln();

foreach $maskvalue (@$values)  {

    print "Performing BLAST with mask threshold = $maskvalue % \n";

    # Create the proper mask for 'jumpstarting'
    my $mask = &create_mask($aln, $maskvalue);
    my $report2 = $factory->blastpgp($queryseq, $aln, $mask);
    my $r = $report2->next_result;
    while($sbjct = $r->next_hit) {
	$hashhits->{$sbjct->name} .= "$maskvalue";			
    }
}

&compare_runs( 'mask threshold' , $values , $hashhits);

return 1;

}

#################################################
#  aligned_blast ():
#
#
#  args: 
#	$queryseq  - query sequence (can be filename (fasta),  or Bio:Seq object) 
#	$queryaln  - file containing alignment to be used to "jumpstart" psiblast in "-B mode"
#			$queryaln *must contain $queryseq with the same name and length
#				(psiblast is very picky)
#	$queryalnformat  - format of alignment (can = "fasta", "msf", etc)
#	$jiter  - number of iterations in psiblast run
#	$maskvalue  - threshold indicating how similar residues must be at a sequence location
#		before position-specific-scoring matrix is used
#		: "0" => use position specific matrix at all residues,  or
#			"100" => use default (eg BLOSUM) at all residues
#  returns: nothing  


# For this example, we'll compare the results of psiblast depending on whether psiblast itself is 

#  used to identify an alignment to use for blasting or whether an external alignment is given to 
#  psiblast

sub aligned_blast {


my     $queryseq  =  shift; 
my	$queryaln  =  shift; 
my	$queryalnformat  =  shift;
my	$jiter  =  shift;
my	$maskvalue  =  shift;

my $hashhits = { };
my ($sbjct, $id);

print "\nBeginning aligned blast example... \n";


# First we do a  single-iteration psiblast search but with a specified alignment to
#  "jump start" psiblast


print "\nBeginning jump-start psiblast ... \n";


my $tag1 = 'jumpstart';

# $factory->j('1');    # perform single iteration

# Get the alignment file
my $str = Bio::AlignIO->new(-file=> "$queryaln", '-format' => "$queryalnformat", );
my $aln = $str->next_aln();


# Create the proper mask for 'jumpstarting'
my $mask = &create_mask($aln, $maskvalue);


my $report2 = $factory->blastpgp($queryseq, $aln, $mask);
while($sbjct = $report2->next_result) {
		$hashhits->{$sbjct->name} .= "$tag1";			
}

# Then we do a "plain" psiblast multiple-iteration search

print "\nBeginning multiple-iteration psiblast ... \n";

my $undefineB ;
  $factory->B($undefineB);

my $tag2 = 'iterated';
$factory->j($jiter);    # 'j' is blast parameter for # of iterations
my $report1 = $factory->blastpgp($queryseq);
my $total_iterations = $report1->number_of_iterations;
my $last_iteration = $report1->round($total_iterations);


 while($sbjct = $last_iteration->next_result) {
		$hashhits->{$sbjct->name} .= "$tag2";			
	}

# Now we compare the results of the searches

my $tagtype = 'iterated_or_jumpstart'; 
my $values = [ $tag1, $tag2];

&compare_runs( $tagtype , $values , $hashhits);  
 
return 1;

}


#################################################


# create_mask(): creates a mask for the psiblast jumpstart alignment
#                that determines at what residues position-specific
#                scoring matrices (PSSMs) are used and at what
#                residues default scoring matrices (eg BLOSUM) are
#                used. See psiblast documentation for more details,

#  args: 
#	$aln  -  SimpleAlign object with alignment
#	$maskvalue  -  label describing type of "tags"
#  returns: actual mask, ie a string of 0's and 1's which is the 
#           same length as each sequence in the alignment and has 
#           a "1" at locations where (PSSMs) are to be used
#           and a "0" at all other locations.


sub create_mask {
	my $aln = shift;
	my $maskvalue = shift;
	my $mask = "";

	die "psiblast jumpstart requires all sequences to be same length \n"
	  unless $aln->is_flush();
	my $len = $aln->length();

	if ($maskvalue =~ /^(\d){1,3}$/  ) {
		$mask = $aln->consensus_string($maskvalue) ;
		$mask =~ s/[^\?]/1/g ;
		$mask =~ s/\?/0/g ;
	}
	else { die "maskvalue must be an integer between 0 and 100 \n"; }
	return $mask ;
}

#----------------
sub example_usage {
#----------------

#-----------------------
# Prints usage information for general parameters.

    print STDERR <<"QQ_PARAMS_QQ";

 Command-line accessible script variables and commands:
 -------------------------------
 -h 		:  Display this usage info and exit.
 -in 	:  File containing input sequences in fasta format (default = $queryseq) .
 -inaln 	:  File containing input alignment for example 3 (default = $queryaln) .
 -alnfmt 	:  Format of input alignment for example 3, eg "msf", "fasta", "pfam".
		   (default = $queryalnformat) .
 -do 	:  Number of test to be executed ("1" => vary parameters,
		   "3" => compare iterated & jumpstart psiblast.) If omitted,
		   three default tests performed.
 -exec   	:  Blast executable to be used in example 1.  Can be "blastall" or
		   "blastpgp" (default is "blastpgp").
 -param   	:  Parameter to be varied in example 1. Any blast parameter
		   can be varied (default = 'MATRIX')
 -paramvals :  String containing parameter values in example 1, separated
		   by ":"'s. (default = 'BLOSUM62:BLOSUM80:PAM70')
 -iter     :  Maximum number of iterations in psiblast in example 3 (default = 2)
 -maskvals :  String containing mask threshold values (in per-cents) for example 3,
		   separated by ":"'s. (default = '50:75:25')

In addition, any valid Blast parameter can be set using the syntax "parameter=>value" as in "database=>swissprot"

So some typical command lines might be:
 >standaloneblast.pl -do 1 -param expectation -paramvals '1e-10:1e-5'
or
 >standaloneblast.pl -do 1 -exec blastall -param q -paramvals '-1:-7' -in='t/dna1.fa' "pr=>blastn" "d=>ecoli.nt"
or
 >standaloneblast.pl -do 4 -maskvals 0 -iter 3
or
 >standaloneblast.pl -do 3 -maskvals '10:50:90'  -in 't/data/cysprot1.fa' -alnfmt msf -inaln 't/cysprot.msf'



QQ_PARAMS_QQ
}
BioPerl-1.6.923/examples/tree000755000765000024          012254227314 16056 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/examples/tree/paup2phylip.pl000555000765000024       101612254227314 21026 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# Author: Jason Stajich 
# Convert a PAUP tree block to Phylip format

use strict;

my @data;
while(<>) {     
    last if( /Translate/ );
}
while(<>) { 
    last if (/;/);
    my ($num, $taxon) = (/\s+(\d+)\s([A-Za-z\.\_]+),/);
    $data[$num] = substr($taxon,0,10);
}
while(<>) {    
    next unless (s/^\s*tree (\S+) = \[\S+\] //i);
    my $tree = $_;    
    for( my $i=scalar @data; $i > 0; $i-- ) {
	my $taxon = $data[$i];
	$tree =~ s/$i/$taxon/;
    }    
    print $tree;    
}
BioPerl-1.6.923/ide000755000765000024          012254227314 14042 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl.komodo000444000765000024       326312254227314 17051 0ustar00cjfieldsstaff000000000000# $Id: [[%f]],v 0.01 2007-03-27 12:43:27 heikki Exp $
#
# BioPerl module for [[%ask1:Perl class name]]
#
# Cared for by [[%ask2:Caretaker name]] [[%ask3:Caretaker email]]
#
# Copyright [[%ask2]]
#
# You may distribute this module under the same terms as perl itself
#
# POD documentation - main docs before the code

=head1 NAME

[[%ask1]] - DESCRIPTION of Object

=head1 SYNOPSIS

Give standard usage here

=head1 DESCRIPTION

Describe the object here

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
  
=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via
the web:

  https://redmine.open-bio.org/projects/bioperl/
  
=head1 AUTHOR - [[%ask2]]

  Email [[%ask3]]

Describe contact details here

=head1 CONTRIBUTORS

Additional contributors names and emails here

=head1 APPENDIX

The rest of the documentation details each of the object methods.
Internal methods are usually preceded with a _

=cut

# Let the code begin...

package [[%ask1]];

use strict;

# Object preamble - inherits from Bio::Root::Root

use base qw(Bio::Root::Root);

=head2 new

 Title   : new
 Usage   : my $obj = new
 Function: Builds a new [[%ask1]] object 
 Returns : an instance of [[%ask1]]
 Args    : 
 
=cut

sub new {
	my($class,@args) = @_;
	my $self = $class->SUPER::new(@args);
	return $self;
}

1;
BioPerl-1.6.923/ide/bioperl-mode000755000765000024          012254227337 16425 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl-mode/README000555000765000024       172212254227330 17440 0ustar00cjfieldsstaff000000000000$Id$

bioperl-mode : a minor mode for BioPerl documentation and template insertion

Release 0.1

== Description ==

bioperl-mode is an Emacs minor mode that allows rapid browsing of
BioPerl pod and source code. It contains facilities for inserting
coding and documentation templates that save typing and ensure BioPerl
best practice compliance.

See http://www.bioperl.org/wiki/Emacs_bioperl-mode for a full
description and list of features.

== Installation ==

Copy the file dist/bioperl-mode.tar into your Emacs root directory,
often 

 /usr/share/emacs/[version]/ 

in Linux, or 

 C:\Program Files\emacs-[version]\ 

in Windows.

Untar in situ with

 $ tar -xf bioperl-mode.tar

In your .emacs file, add the line

 (require 'bioperl-mode)

and restart.

Source files are available in site-lisp and etc directories.

For more details, see http://www.bioperl.org/wiki/Emacs_bioperl-mode.

== Support == 

Please direct questions to bioperl-l@lists.open-bio.org

Happy coding!BioPerl-1.6.923/ide/bioperl-mode/dist000755000765000024          012254227336 17367 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl-mode/dist/bioperl-mode-xemacs.tar000444000765000024      6347012254227323 24116 0ustar00cjfieldsstaff000000000000‹€poEìZiW»ÏïÛrÎý.KYLœÙ'Âa2™Ú²C7.¥!`J¶fÂÞòÙÿ¶$')a)½÷öyñtÜ{A²%û'ɲ<ƒÈ>ùÏC>¾ëªŸ¦þ)ÿŸž'¦i¹žêõßw}ó	sÿû¥=yr’vÊmÆž,—ÛÇ÷[i6âß±žßüˆìy\/WÒL«\9.Æé?ïÛóMû‰aZžõÇÿ¿åôÜ©üË1ðxÿÛ¶ïüñÿïxn÷ÿ~ÒlÅíZ¦Þ¬Æÿ<áß°e¿éú®ñÇÿ¿ãù	ÿï·ÔL§Ù¬eªI*Î[õÇÍñ€ÿÓ4•ÿ_nÏý–érÿÿ
äŸÿçþÏN±÷kËl*û×4D'©°Ê‘´ÇC¯ï)¯ïI¯ïI¯ïì²9võ×аå0ù/ç2sxZ’ìi…)ó!$1âÂ4WtW
è ázh[5 G
ñúªýèP5 §€Î©ôоj@g€öTzhW5 ça¾H5 §mçTz\ÑNN5 'vUú™¢Í‚j@_ƒ¾‚j@_Á|Žj@ïm©ô' MՀ΂¼«Ð ½§èœ«Ð3ŠöMÕ€~ö7TzôªýäMÕ€þ¦hYoÉ´	ý¾j@[ ßR
hôƒ€v ßS
h쪴ëwTÚ|%Õ€Î|^5 óŠ6Šªm€<,è2è/ªô>ÈUºýyÕ€®>W5 c˜¿¨Ð _P
èC˜?R
è#è·U:}Žj@Q4„úçìªt
äKª]‡ñ¦j@7 ÞLÕ€n‚~C5 [°ž’j@…ñŽj@·A_¤Ð)Ìo©tð†ª}4<@ŸS
è3˜ ÏÁßp@_©ô%È{ªÀüð]€õA€‚ÐE·U:èŒ/©ôKX$Ћ0ôÌ_T
èWÐo©ôkXON5 ßÀx`½øŠª½ò¦j@¯ÂøH5 ×À¿p€^‡þ’j@oÀ|°A€Þ„~HX@o~C5L¦w#£ccÏǦæ2³}Sªka~z|aalAvŒü();'Ÿ]-dæf¯v?õu.¨ÎìÄÞBfvæ…êÛù¡S
~ÿfZ¶ãzW»;¾S2—7Êû~¥*ûæãþNõÌe’/²ïúº¯sL.dlïÛqm¦ÞØñãëÑÑ%ÇÆ®›­¯íéԟœöKr):5~6~¡úN//o¨ÊùBX”:O£Ël¿ZÙ7—¹*½âε”[,öu>—}³W—viéúúä2›}õª_íTföêôõþ›åc©sñÕÊJ¿mçfGv£ÕxíìŪê[_ï뜻R6›Ï^l|9ß”}«[}™‘O;;ó×£ÙËlÎZ_]]]¿Ñ©sz¹¸øjk}}½ÎûÂäW¢ïûì_Cÿ×…ÌŸç—žÇÕÿ¯ýÕsý//}¦w£þ7|ÇúSÿÿŽç§êÿÁÚßÊÌ¢¤ðCõÏ \ˆõV©àâù·€Œ ”sé€¯ä¹X¡Œ"Ã.9.¡cÈ0Jº†xÎðŽJÚSÈ£"êsÈp"“FdžÓE­cGØ‘M…ó¼fX>VÓ(RŠL*mÇ‘#:ë'µÒŠÏgÈð‹Aá_#Ã+æs¨ôJ3t}½‹G2þ'D›—Â
-Û3Î2Ñ5‡³ì!Ãêh¦g ¬z_ £…d WHä;0¬Ð)RaûáMÈ3lœÅD¦´–j–ÖQòqÅb‘ŠyG¨@r{ö@¥2ÜbŽä÷ì+Í!Ã.ÚT1å‘a*±„ïw
TÖ²É@û:‚B[A,Eiº& C^=¼Äßs#ýrÓµuÒÒÈlzÔ³ú6Ñðu|Ñh}²Ç±fèø¨i´.…C¦„h+þ¢®x›œIàZÚûyÿ«¸6¹!È@)‚s,ÛÄÝÐÁYœ‚AÛôE"	wÃ)2ò2δo‚Îð.š·]q¡C*g#–Ëž³Q$èÁÇ•4|íìV*êCQ3,ºÑDhSÚG”tv(³_"Ãrºa‘ÐEzk±„ö(Ú6]»_i{˜tïy଼Cí7.ôŠ6*]ÆN>OyG¸žm£oW1[Fòr:ÖzÎÆYÖ{àˆö¾I÷£MÍ0èB»…àJÒûhõí|ŒÓ·½XGpïáE>Ùã=2ÜÈ¡äø±„ábŒ}Ä¥¦e ¸Ïh1IS1xdû-N+ðÕP>°(¯s`øFùˆvEl·D†Ø&݆GÙäëܘèÂG{p›>ë6%ƒkÑÍ…¨ôJts!ÚtáçmÃD‹}†#ïŽtVfE7>Ð=ønAX¤.3Èȇ½‘z!èl\Ê'½íhO1Ân!p&º…®ã~·¸Ð{?²Qä-–³B
˜@Û´H¯j
(ù6½Ñb¦_ ]YÔÛCg‡¨‡–Ά8´ØKd8aŽÐ.Rœ†²fų¡¨ãb)u½ÿªÂd𦋖Þ.£Ré~2á
†CÞ4
œv•b=gÐṆÞ/¹rf<P‡tVnôb›½½"[=´hmd¸®ôm-Š¼C†æˆö}-ùƒvvDÎþ¨Ñ„ö³N}ú¥ ãÄÐǼàtXäèµ:ç”.ô{Ö`¸QÁ¢€á”׋Ú£œ[‘|;ÆÉ•yýí€wÁaÀLqçÐ
sÈ0$±d8¹²D®œEF¾[ÒÎsJã9zã:­×áP^GpQœN"ÓhqéÏPÄ,äÉ×=,¸°+ÞÝ•»KŽõIcÉpYÅ- È™0ô
¸Ž=\z®–3œN Ÿ–þB;Ê£m‡SHù´	¿Ñž¥SýÎâ6íaÁ OÂ/ÉmŠ"6Ž(*iÞ
Ktƒ«]©Ñz­GhýZ\iN£u
t6Ð:B?D›~à—{®DøûÈ°eõ‰:*Ú/ÑUrC! Åœàˆ6áNk&¥¾CNG¾iép(P¡˜h{DtF}AFQ‚£³A膸jÈÈ…^ˆë¨ë¥kÏ5¡*i4aWªJItT‹SBqèôøŠ¾5ü¢Gg2Ü\žÒVŠiCE:ë¾Gï»Opa…Bž÷´·tÔqF#çÈpC;D´½°D¥—ÈPW@Ü•g¸§Ì¯ÐJ¿ ‘‹:’õ— Hû6¤B±¤ƒÎ§„ò²»Å(
q¥F`Sùµ„öòþü@ðeâ´¯‘!³yî†ï„ôBÃ7C´é
2¬ÐQéªÞ•9šeMÛÃ¥[Ò:2Œî-iCÛCW›=ïÓ½òiÑ ”³­íѧҷ:>t!ð®›Oˆå=å1™>1`>ô8íG½	sÜ
Ÿu8x!½PZ Hv)’2ÔEœ–#íî
šaõK©Ç=ÿLHüd»!ÄÙa£lŒ=gSlŽeØ,›gÓlœM²gìš]±ÝA¡O,Ë&Ø›a/Øûξ1“YÌfs™Ç|–cùA!ƒ•Ù¾©°*‹Ù;dGR$a_ر©±:k
M°&kÉY¾²6KY‡°SvÆÎÙ»d+°…")R’"/Ù"[b¯Økö†-³¶*EÖØ:Û`›ƒB[l›½eïØ{ö}dŸábD¬±Q1&ž‹)1 Tas"#fż˜ãbR<×âJìŠO"+E&Äž˜z!vÄwñM˜Â¶p„+<á‹œXgyaH‘²Ø¿e&Q±86;G"_ı¨‰ºhˆ¦h‰¯¢-ÒA¡Ž8‘³œŠ3q..Ä¥DA„¢(Ö‘(‰—bqPhI¼¯¥Èá±e±"VÅšXbSβ%¶Å[ñnPè½ø E>ŠcöYÆ|«ã†᣼$Æøs>Åçø€P†Ïòs1Ï•+§ù8ŸäÏøž¸æW|ŒïòO<Ë'…&ÙŸá/xÀvøwþ›Üâ6ßw¹Ç}žãùA!ƒ—¥È>_c^å1?à‡üˆ' ’å_ø1¯
]‹:¯±ÏŠ&—ã_y›§¼ÃO@䔟ñóA¡~ɾÎ
<äEñ)^òE¾Ä_ñ×ü
_æ+ƒB«|¯ó
¾É·ø6ßoù;þžàùg¹?ñûå€Ð/l÷Ç<¿&ôká¿ÿÔ’´õïþècþþÓ2
õ÷Ÿ®÷çïÿ~Ës‡ÿÿÕ?ýyÿË«»iIÿ«ßþøÿwf¦ç86³#Ÿ1­Œá1Ëš±Œ#÷‘ÕË_ØèÐÐì¬üÇ–äxvpÒ¨t’f#eÍ6+ *VO’R¤ªÿ‚“ÎQ³=Ô­Y Ø«¸‘Æ
ÕÕËIMV¨Jw¦ÜÉ(E¤±ß.§,SmJÆIJ3®•ÛÖ<`[G1+6+'õ¸¡>\7l­ÝüW:jÐQ§ÓšÉfÏÎÎ!Íöaö,9N²RpïÁ½ž ú§äÃfë¢uØD8	f¸¹h5jë(IY«Ý€è•F¬Æ)Âþ šÊµÕªì¨|KçVâäTb.³Šš»§„»¾«5‡Rî™q–%¬ÑìL³³v"c¥ÓìºTIßâÕi¹+bš¹¦Unפå7;r¼ÔQJ¤þR­ÙlO+ñB3í(‰å€A†ÍÈ”k²íÍ`hhh¢Täîü2íø4`þ¥$1<$ëRµO»zTˆHäÒH7t
Oé”"÷å	Û—Iù8¾¨—[°ïa§’§:3²3£å«ÍJF1åTµXîס§RŠÉÿÇ™´Un§q5±a™šÖTj’Û?žœz:9¤jg¥3K¯ÔÙðÛ$>cåV+nT“óá.”SÉ&9ìzú”±™£¸Ö"ÙÉ‚µµh¥¸ô^¡¬2ÀI-fgrkÆ’’¨Ç2ö«)+C襹©âêä0*“KLÙðßïÜ9é®vªjZ¹N;ÿ`}½·b+F›áÆÒÚÖÒêJ?¼×Þ§÷Á姻—/;›­4IoY»îºuá›VV×6—6µj­ñ¡%ß½\Ù9¸ÒþFçeyŒÆLU‰µÔG¬ðA[Ö;Gw/ãðö5f°óV[Nl%Z<3ͶSYPÊŸq§2	Ù´ÌR¹ûe¸£ôƒÆa]råê—áeÊEé•9 ¯‘)°¿|ZîÌI#}|þXj<”>”ZyNÝj])ËFæ[y®4Ô±ËÓMž°Ã}YQ
QÊ™r¥§©¬ú¬M:´äLÍ}UÒ0Ðp—¡oåÞ Q°¤æ{aÕÊiš¥éïD£n$ë‚»!ÌZµ“T‹÷c½Bq×¾¤uô‚ÿn8ææ–%º
–×yV·«·j¼KOÿƒ€ãÆ€U1"«0Ðý¸hè>¢«¢<+äˆ6ÖÞpÑêD&Ãò>X:jïÙCwïž®ðÄaÜ‘n6…“X™ýšŸÞ6õ¤ªRýA·Ã
FÜc@tTšÒ$1å(x8Ïâpåî;³­J¶XÆaÎ$¢%˾J"W“ÎÀM0ÌTÈúq
WÄžF,;e¥@A¨Ëý#/*É÷ÝõÚq¹ª*É	Éòê!}'˜T
Tnm7ký:T¨TtóL_ÚSÕwvôãÌ(lúȸëÀ˜¼#$†ÿ–øÿ^δ†ÙøÍCï~‰ê-ýÕÓýÒémÒºŠ¹_´|›¨.9ï=¸MsÛý‚õ_¬«Wçã·Fø}Ó…?@¼±¹ï<ýUÁàÁÎâûÅ÷Å!§Þ/µüKRǃR?äñû¥ÿ‘tkPºw4Þ‘tu·ËIí1ìí}y_W¶`ÿ‹>Åíj¿‘ä ˆOã8nlã„io?ƒ§;Ï8N!PI¥T•ŒIº¿ûœõ.µ~“×è©êî÷ܳŸsC+vîMRºŠ~ôÊ Ž€óÓÊ?¶a¿À?ï̲^H.m—q+øù¯Ì•6ëÜ"†ñŒ“¼p¸láP6¾“Ã1˜Ç@3zÿ‹Õ>1p.Ó#ó!¦Õ‹žBAC%ÊÌõFTh æ'Cj‹Ýa‡5EXwž¥³²P½ÆDšQ™åÊ
#6†¶ï›"ž&ŽftâÂtEb&éQw²ÚóGÔåÿÝyÆBòb:Mq“IvŽmü„ÚŒEQfÓ.ö5Î:¨eHãIúK\f³aä3ûÙd&#ž¿ýÖ7ðnŽyÑa!ãâÌè¡"j&uB|…å@”74°3ÛøùiŠÚÜÞ,+
- ¶!Pù7K?¦¿ Bk­²nydx”òä$ùˆGR{–åð02ш”¶‚ºólÎý4½„öŽa`°ÏpèŠÁÜ®#¾ÆfQ²ƒ5¢ßˆ0´™~ßÛ¸ÓdF0€" Ýv·kz²ï#ü'´Dº“8Ü\“Þªïæ§?UÇ“øÄÍ å=mMέ¥R¸á2lcÑ®†n0ˆd|G‹ãã$·«6‚S40@dô©‰°õ—Æ€\æž?ÎfÇ)à÷h¬w„g¶4·øᯠ6–FnSN²2PˆYÁ0–·gå)ì7è¥éN—Ú·vN°Ây‚Ç.@0K·,ÁÙöj#0˜!™è´(	ð‡
š5Z2?ìé0cT™ƒ´…Xl~>nî·üo³r^{PÓÂqpÿ›ç)áD4„àÉm6PêY;žÂ =ŽgÝ’h’%I÷A8=ŽbðyñÌ`@¸e<|ÚÔÈ	Xó‹(œ`SÑhÈ8—£JW¡š;‹­Dõ_|4¡1Dlu4’ŒÍ9â<ŸRö¢€<ì\N-9¬SÃTÉ!lÁWæL{N9‚yBãì¼8<üÕ“sø;+#é|0¢ƒ¾`%€,Z¸fnº½h´}‘ç£tð¿þÆßáæ¾ÜBøè7aú„°øxÝî¥ß;‹"÷¿N2XTzÐÚûèâä+|z¿®3À®k‘ÞÆyú!¹3jXcÇU^ÖYŸŽzMfMfhÉX°=<„…ø
ÌÐä(©¬À®ù]‹Œ¬m:B(Â^I¦–Ð{Š}::×0ˤ:ÆÕ†jkBÞšÊòüá±);9AŽ´Î;׊Ìeö!»’8šYž8µ˜§í€ÃÕ)~Hf)pk¢¸À³ôêå“P©04ÏÉb(ÊjO:gÛdW‡×{‚væ$7ªeÞQ!Ñ77(¶Oòláx‡ás5éŽN“ÑYGØ€{[o7~wxØ?Ò·/àÙÃm÷£ÿ02=v‘žWþ%lôÇ¿ïbñÖjúé}ûÀVò?[L`¾=jE)Ìf­‘¾ÙÚbÖŽ^’ç0€è9à1³˜Ÿä1ÁŸá@Iü2B¨ŒÚÒRùòºÈË%XÇ„õì™;K¢'	ns¡'®:IyAOFwÂs2 3i¿2{TQçxuPén£´€Üáz4£5¿(²‘éº!¸ñ!H
b”C‰ßÅŠT6[ÈæjûÀ'ýF%1fX[…¨Àº¶¦âÄÚåúÒ2Vv¾¦ÐÜÔxôsdºh³œ¥ÀñÂL’øCÒRº¦Ä*²E>j+ýª¦¹ºŒpÒ\üÑÕŠ>nTµ—¾D—¦ü7 Gvb–¯›ÎF	tál²Ÿ$"óX`ºîyV‡|.oFdµ»Ö	@Ê]Ý«„þÿh8FMÉ`"Y5•I¡LJ]^
ºèË"ÔýŠ¾BÕÿÿ þD%C*ô„¸”>è yYÓÛ>Oȃì¤P³
pž í†.¢iœgÙìKË×EßCA‚l:hÒ&IH-·R†®ÚŸéVŸTGg5•Ö>T¨?¶#8l_FÆ<ËŽ•Aê™u­•Q¶ôËnyY»ÓóÊøä²qßU¾2VßôŸâ¡ 
bê©¾¡cxËڂÃP¥Ôà%y¸Qct0¤ç²àÏ/Ìy–ð¤=¯‚AÐ,«ÿ¨¦‹#€“ÁiìO
`-&ñöbô‡k\æÊ*ÈRóµÜE êýðÖž·€¬Œ¼}°|Ά‹@aý°Ü¸«®wÀ€÷¼eÀxz—,tÃùÇ…p¥£ß<"Ûn0û´:ÀŠLEq^;DíËw’'	b©Æ3eÛ4dUî±Ça+ßL8èz÷<ìúóêÀ’ãêLVÆ­-Ú|Û5•Å¬´Îƒª<¬Žˆ¸ˆ«È.cuHêCª4ÏCªÃu¼1.xpªLÌã”dÒüÂ0·u?>šSlºèíÜz÷ö×wA@|~Ùü'ˆˆïIF|ûÏw &n×›Êù>øI3?ÚÊïþòÚ;<üvðíáá7‘6íŸ+†bíaaÿUPà=ì=¿Þ›oàÿo»‡ÊÄ8†ÆµÚüUÄúØÖ :èMÛi‚íûÜV÷íÝw_tq]7m½NiSÑ>Gjädåeõ¢Ã?á¿ÞŽŒÙðŠ¢#CViµÌ‚¬¥ò4Õ·0-œMõ]ð€ïè»
Xê×­ÃÃâcM\˜°zo£…ô›ÚÁúïßyËÛëss:’:ÆóùB*r•ÛÛ
Cò-uiè¸jÃì¯%¥Ùö6¯“â6€]«6ÇžÇyV”²µ£X8°8­€BrÖßZU”y”¡Yo{´:{-M]Ö ,«êžBAƒ"*"(>"›(BúMÞé!Â]?#¼å8Ñ”dľð*r)†´ùâ“4Ž	gŠÂ3ztù©{JîOD¦õJ;Ñ6˜•ºZ
OM™·Í0(Is*2o|t”'‚g¨ÿ5ÍÚÖú²XuÜòÕóÌí¨‡—´ûü¤Hâ|„%žT ˧]ÐdÕô™tvŒÅólJælBöÿä#ê¶{y2àa„ù9:N2ò}{ë/ÿÑ믮þâ?¡ÿƒÌÃÛD[ºïµÂ_Bíü„ÿ}ñVQ<0_Ý^ã;B¡õ™ØžŠ£0××I¹È¡8¼™‘›Âÿ2ÉŒ|±­ç¸ÖJ>Ž@jT}9ð>ÛXÄr'
ÏëÀé(Y­ý¼HQ£/€Î›§Ow_³R²W€|?€~¤)åê-†Uz'Š}ú™Õ§ÁÚ’ãtM[ð£N3²ÍÇûHDT;bzR˜4f³ÏmÁî¢ÚêôÅì'Fß(†ÛÙø’aŠ^2»Aƒì˜U—#–$=*pQp­¨ žºµŸzëøpžŠþ IVa`>‚Æ€vÆcõQäˆá'Wø4ËÎÈY…íÁY"‡NϧÝ'TÌ#¿q'áî-]ÕÁú&,ý®oÛ"5üÇAŸ2[qŸœäñüŽú\Í`Z¥à†ºA8¤ù­õ$+ù“ïàʯ¢p>ìšNцûv½GȆ±nmckkÝÞvy1OÌÇùxj4ÚG•lÄìØ‚ýw6¢÷¢|Ö†Þñ±Õl™!•ïj¯gÆŠb&™hÈ3	;­ ˜·ÀæÙèwªÖÅ&Ó!q~C4¤€™€ò»gT¼çÓóG±|ö„Fë‹l±Ž¢x>L&áTY\©Î2°:I<#Ï7=ròÈôÄ5Ú+0ÒPž?4Ï’²[°o@¶(éÐx¶,À°@©?Â\ÜwÁbeUwŒNOÌ…¾bZÒî!¨D³ýwGõ®þ¹Jü7ažÏÿ½y÷ë»›.þûÞ½MŒÿÞÀûÿnâ¿ûO5þ[ö˜B;¿ª„v~yo{Óÿ&›élævw«†¨·ŒZùC³|ï4>ÿØÿ]…ˆß‡ß‡ÿ›‡sVÜÔ—O^ê3
/BþrtQ²ÙVÞ’C%àÎzQ°z¸÷Â2>|Èï…õ(sôÅ|hóJ^žLhÚ%g䘊*¶Zwç³dBâ:Q¦6dwŽ0¨014ÞÚ}¾óxÿýë—/î ËêI 7+Œü˜!FŽZàTªá¥T¤X?á1#J1$È…Þ¾£„GgiÈ+€
u®‚Ë0ñsï÷'œ‚%Y>eŸ$ióIR¤ #½ÈJÞ‚ù—OXøF –#ŠHbÝÉâöxR™NhÞÅ% -âsW
	×ÁɆr€Ÿsôû£T
mãDää‰ç l1MŽrŒ0ÆǨl@Q>%Uì­Ö}¾ê)Ã’8dÂ7Ô †-bÔL–‘‡
ÐÄ´§³Æïc;e:ZLâC*Ÿ¢»Ü8•Ä WfæÅÎó]:M*-¯ûñQÎì$6'~,íÇ÷
H‘Ðw6–°;ìfŒªæ@z¢+€õ´Õ!Üþ‚„l…§›ÌF‰v²(°)ÔL˜	àÐ	ëßœ¶¢`äK‹$
ór
Ë—#Mˆ(Aˆˆó]ù}èÎÄ%zÏ•j-’ããt”B¿æœr@ÓC$Í´):7™PG¬ïVú€–˜(dŸAˆB֪еV$<ŒâÑ)áÎd60R«ŒÝ™¦
¸Jä2§Ž¶zˆÆ7ïü`1<ÅIÃ:Jжc+>£k€
@ç»8Fd b6ëÍcòsÑøLÜ÷t’–ÚJžÀΠ]ŽZ¢*eSæ‹Q¹.Éa1EECî+¦j0¢ƒYeŨÍÅ-Ã$ƒÝpˆI'ÂEÆÄ9Ô	ú—NÞ3G@1<çg³ìœÖò(.@œ•ÅyÿrAýHl˜\ðyPiI{	Í›Âw?ŠššnyaäÂÝðæ+Wù±[b9)Dž`sAæC4Â(àNV=Cã—å³Ü`¬–Û =I‰!±=äGÈ1Ðq;Bä×(.*¤ 0¢	Ä5%‹äþ}ì6{Ñ©´yËÍÀv]Ài‚#F\SJøkD–ˆ€k#}â|²8Bˆx
ØÜLç\˳ßÃ?;c¯qæ?)#É1€&Ãß¹6ÖS ŒÇ)G¨Ì`Þ4Â>Ñ	TçB#] ðnŒq[v(Ž£övZ:€ïšž³NÁ='ï¦ãéUZRó¬*¿­’šGÚr‘„oòr$Ä8Çl6e¨Wº–‹ÁCa˜·>ôŽf,éL9Na5µªi¢½ctÑ]wÊQ&N`ˆ{ÜØ°óˆ•Dl‡!œª˜ê†™%c³aYá`êº[4#–i‰RÞO6$©Ëïlܤuäï;/R$÷1œ³‰Q
¬ßÀ'Œ?ˆ ƒF­¹à©ª=ÇïªH>ÎÕA“O’Þ~ìËÓ†Öð<£€„–˜ÓaçåŒÎñ:9h#5bÞƒ…]»¢Õ×®yψ£!±Ú¶4°ã>‡ ¯Jë€DëÿrŸÉ¦ºi¬áÍ%Ì5çHóÄѤFÌLa–	Ã+9:Í@î#µ-ÉÑÞÓl[åêÄší÷YvVHf;Ÿ¬y„Tg&Û²›ãŒæB¬y‡ö‘a~žÙœÌdNß@\X± äÉôÉ"ŸK»ÅMØz—øN”wC4O 'sŒù›•®uæú˜š#+'ùtÆØ/Û’•ê£ï™ ˆÎí1·V(áXhÄàùiV$¾KaÈ*B]9¦×e9´ŸÚÖ²ËÓeW*¢M
¨Q6AÎÚ^6îù”ÃÆmWﳺicú6-Žáïp8ìÃW9Èòù–㇆õ€ü¹%Þ'œ0š_im[’L€£ܸVâߺsâ
Oïa)pËŽ¤Ïè…l‹ñ£¶`IzF¾Ê˜K‰Ž•ͲÎUG~ÐW·aTËÇL(‡¸ál†X°i
,èùÑôÈØߘ oE¶ÿö)W&Õ°UóéB¢Øõ!>83àLIízžtsßNgãOÇy
ˆw'¯œz\œgRž˜žCòòÄ£b èºç%Ùº‰…±ù«^9zäzR‚ÔC¨ŠSq’§½BñA ð$Ó›¢›]9˜—YBã¾É´Ž¶|ŽÁpå9bÌyal8[~ß{µÑ*×X_øõF¹‡Nöy•Õi(zËËûÎDh8Ä4þÓzLŠoÃâŒ2êâ‹QŽÑ%=ÔÂ!—_’3
Wçd:‡CøÐÛ)ÒW£«ÝRu\ø¶Ûº
_Ͻ½}+2Qä
ãbˆ£ˆÆÇùÓÀ€*t%š[‚V]'ò@Öš@ŽÆ]Dò¤t€M©Æzp]3tM±Ý¦6­•Fâg¬ŽD¼iÈO'Ç+'†xrÞFÿyâµ;F!-Q‡=kþ(z®]Z*nö}ÀÚì÷m¨½µr«.ðX®œ©Ó·¯9fq¼§B
~T}Y‘w6-æ#<˜’5¿zömå^í°Sœ2gidEÇdbµpqå¸á4è§0ªÕý9Ý$Äð¿oží<Ì àaÌâÓgB<]+y;ŽžþoN&ó™pmeÛ©·é-üA^áO_RfTSzø„´‰~rÔ’!‡
VbsHÜ` /zÉÄ›³üÄ&é>ün6¤Q‚;IսŴ€†’U®Ž¨¦UÇTL‘¸:ãuÜ ÇõÝèËìOâqqèÁ{,…M½×>&%A¬(*]=a½FÊoyÅ/¿JXm”§†œã‹öOÀuÍ%GÂ\ãH=|$–Ñ·ÖC"n²>³Äšès;|ÙñZ‘¼Æâ6QË{0À‚¦ì¡eÈÙs_P5¿l`Å	и®:Û	ÒC›eäE†bì©&®µƒÚAŽ&–Üï‡+êí¼¹Ú2ÀTÔËñ7E\ii‹Ã=Éo[!h-Å¢í°å¡&œÂï=™ñ“?¡È&rNµK±•—ßñºpñê÷˜¤Xìß1`|\xFãK@C3p®®´—p¯f]öuCýß1jÁìýŸ
µüŽ G}tZaGBït\1“¢#©%=ìQpÜ[Ù”ãŸ&yZ«ˆÏñ†vñb»œXª©ÕØ2¡ƒ;²Ø*[2Ÿ«dOHHJ5x‚‡Ux/%¬–/K X-ê !håñkš#4WS›qAO”¸ŽáÇ‚Ìð{Z„W”V´©Bí$}±ü‰æŠ£Ö½,:â1OFšFuÙ;\ëZâ»çh2Ó”½zðà‹zŽ#+»°KŸÍë¿©sâgÛg™1ckâÄô”^‹“cÐDæý‹¬Áõ(Ov­¤øfÐÿ±l“†¼9j¡]v{EªKÂx9\›*3>¼ºÝ(ƒã^y¦¸ÊfZÅúÚépJ3jIí·è•ËS­vƲ£	ì`};Ôúbn³[©OºÒÔv× ú¨LÎñ‹Äcãe)´èeÖéÞïªáH¨œ"*Åû7‰h(Kó-ázWÜ)’iJ³Á$ÂtMÈ.Àž™»N‰½“öXLk¼ÐÎv%†4`m-{ö¹Y,Kˆ¯ÃjáPCÙæN«jêGôaÖUŽÙ*£ò‡@nƒömP“è¥.KjÔ²Ö¼çíAÂËSiÀÖq 6G}«3FveΊşñÈfέ÷Æa«úpYQá£YP®‡%…n¸ +i¡n¬¸À\¥uªÔ¨À‘MÝtŽ›‚V¤7Jl8·8ß,¦@êü„¢þM^6û&Ïÿ¸àË©H¬ìØlÔ¨ê¥ÇÙqpe¦-8I?$6åxň„iV1÷ŽÍÎþ`çÙÞ>K뺠ñ¬ÃC!?ß„ò/ÁEšCöëÒ(/³J˜W…Ñ'.£à·I@HcC@XŒ–IaÞ˜x‚òÔ…&5ZÈî²êÑŪNLhÉPð™›åvA hüú*UD?Ĺ[	oßÄl–¡f²]Hž`ñlƒ­Ç‹jYDß=q«µ9å÷
«ZmÁøËŠ„QwºòدÅ>”=¶S7Ÿ­ÖÝMþ	¨‚äGŽåÊ#aÛêãàÜ<Žª(‘Ñ5õãò^X’XåCd¸Dt-¿½sS5~A
2‘vž}^ÆË%.|í'¯™žÏìU ¤xÈÞJŸÃÜPf‡ÕþHRˆœ-Ò	²üËâ
WÆÒ·‚øƒG¦tÆ™ÉÖi«˜®ºƒtBwFÜgñP¾Ç´–¡‚!R.&MÅ4äuÓãɱ†ˆôÞ‹'»·¤šò.‰Dg†ó){ð“o?s¼¹°6žøá×¢Š°dÕ!¦µEð¹HÔX4¼ÚLLF¬Na3|‹01ß>Øäü¹.kUÇôæ:‘UØtL³{%GE„ÀgWq³DÈø×»Z’÷Ø·ôŒÿö6–H]Nz.Î2¾W.uj-Ñ뚢:P˄̱ã¥B­ö&ÛS®É³ÈS.ã–ÐAáóÿiTSšÑ4¨†Å¿äÏ?ØÕQô³Ê«¨{sÕžì¤6’HOrô9ã3N”D*Ó²žÎf\Ô‰äR‘½K—`1­O*œ(OÏ!f¤×¼`›öiÏ”ŽÊ¸•P@74JV¬Þ 8‘ˆÎ&‰‹3 ‡¸Å‘K7„‰ohL~b†@45¢w
ÕDK_~ófæY¬Ó`£û†Ö)ªˆæ(g#´7!-fˆ
§³a¶å*UY‰=ûΖæYâ}M}ºKJž»un”fEZùy67aÞ¼eÌþI'ê/÷š`tOÔ2¦v¿2¡oü_›Ìºö&¦<#Šò,ǯÀóc?dé9öìZ×i=°Ä]R+Ne¼¥ï[½½׸t·_¢^΂‘ySy½òîÕ«:å‚ÿ¯Ø|X³ù¹²LFQ+c”§y¶89õL'a‡ÖrÂ;Ö˜Œ%˜7EÓ‡ƒ¬MÂñ÷þ)ò\™Q#K@pŽÆ³D}Ýi5œ‹˜RàÚíÖ8®!kM,¦›cWà:ÊÕD¸Cú}­µ¯SIt •~äŠá!š×õûfßÌ•Y½MÑ šD€†#	q)S«êX»†¼µWèؽyõ]y.Š­É;jeÀ“ï-…Ò j/³ú²1!¢×#?S¤rÛ˜)éLØ
8Ôuäy³|ŒwšsD HºÆ¹¨h
òmwö:!ªì®â%$¸‘6	U<à£ê[/~Ü1ÕEå…šçÉ<ÈÂÏbLšÛl!ÙÖq;WiÙmzO9E¥Sé6,‰®9‹”ïeí¨^çRu‹óV±ãÑ¿^}ôÁù”~ÜBÏ¡ÝñªÒ—k¯wIƒ(ví~,éÚeºq£±˜Óy½Èèš@Tù‡t”Ðàe tmI:N8BT”qw¿;xõrŸÃ:2ºW€V	sjcטl^¸vqÌtAZ<ÉEídÎЧÚ°æðMÛ%jË òùåõ.AÒoªjä”òž5¶pL°ã#f…°®Æi¾Œ	UP5ÁöPM˜ÎMÿäsX¡€þ‘±©,õIÇ9v·'ËÛâöISo+1”Òþ,`}½P7^cÝ‘^#3£V›€£[ÌÒŸZ#Œª±aÂØQQ՘蕉UÞY7º¦Õ	؃zaÏdí•Æè(Q­~Ã¥M°¹}EôÓÔà5á;Ú\/·áÌ<«5Ù Ñ#M×D¼ª
ŽŠçêÆš¥¡<¦s™òFFšú&vΧäÿ¨m†mŠRñÀHßWu3ýNK´éïSb}½å¼–¥àZb¼(ÃFñ)6J,; Ó]£a©¾'6¤±]M‰ÃXëhNhúÃaÎ÷)á
@ÓÅÅt’Î浶ãÊVµ£Å	¯½‘ÓÊ’£¹jÆ¥Ü(Sn„6rÍ9GòþË‘¶4yÀgs®•‚>¥\ÇXéOì<ãQÙš@À
áõy3LOÂ;ã~‹?ÿ8oà4]¸GÍ;ò0Ç­u⟤ÖuÖgxŽA¡#Õ`)µîë‹H‰ñ„1Väv\O¼ôøøp‚H¡–Ïìdž©Ó²™O‡ƒÆIE¯wwžm—Ø;¼°Ñb¸s=@§z<ŒôV€kjñ€OÑ
UnÄê+9uB ¶Ñ÷ºUâyÄö6³¾[\~ÄÊx„}á9D)‹.a9;™¢m‹¥¥)ˆÄüEÏÐ"®âê'.×,°ÐM¤nvœÚ*Ñ•ÀûÐ*Ô¸‹wî f÷õ¿ìíïàå]¥Äš`jvôæéÐÔ}2ª)g*–›Žë¿¡eìÄÁñºÂð¦À/‰¼¨»b—ïhî`Œ…\‡"×bQÄ„ºbÐM’ûúœfçÑëƒí»ÊcøNÒì¼yú”ŸÑTøOèáãuû4 ®¼s\‘¾#à.ÌZéÁk¹×Jö&ÓøfŽº(†µ¬ÄI€ä‡fKk7¿<Ô½,ÞQîü	÷[ɇg]à_tAƒ§¯]Ī۽UhëUm-ܯÖôæ@òúXºêU‡äÁ,üÌñf8¼Ëq¦[*Ídgöœö%†A
š—ÇrxÕP¯Ë¼ƒÙ7k÷W¯uØ{¸ýóùÛ÷‡½Ã_ÿñî­9<>,g‡ùá‡wÉ×?ºj£oßõú¿þ³{½k¬ŒŽƒ!G†íEAÏ_Dº_®]t>…Æ>5êEꆰ„GŽ Ìfò$ì»H%ñv(>Ù@U¸äáÓ
ÛÛ+ÁòŠŠ;,¾]ðþüŽÀµ‡J'—5ÂÓã~ó€Rf+$K¦¨ú¼à+×^Ò#XÿDh¿&¼_
âýŽ*+ê¹O€?nà Ð[ÃOƒÁ¾º –ÂN`Ʀ‹òžìwK§Té¼G‡7GÏ®l²
XÌ(xLo“çM ž‡z$ª‚ØÜ)N,ÐûyŽ=-D#ÐcÛ2!ÍzR}õUã;G{²÷zðtïu-­ã¬¦$QÅÎS”Ï\UoøžÝZ[P!-ŽìzÍÎÈlƒÚJï|Ý¿Åó<»Ë¡ˆ&6çIsâ_pÛ¨àoIWIÖ&{„„Ƨñ×Nð)LÕö„ˆÑ­Ë5t-“˧PïÕ¼A}OP&ï=²XY½´&]¶‡DJ¼ßÿÃYUÆÝ	Ù•Y$¯Å,ý˜þ’X£ÎÕÈM0j  %´mdÓ®ûŠ5°
²B–XÉÞP±ÑµÀŸ7šàZëùð$¡(leJn&Ã!V+QPá(p@`#p­7@-”íSFêj«âŠ,¬QßÊ€—3^.¤,^N™ØÛ'žbr8
öE*"‡ÔšMŒ'g1e˜Fdz;å’%ÌrX^bd|¸Jª.Š+&µ˜ÌFt­<]Ýq£ò)Ì÷Hkè‰Ôû˜âªON²°ýUùžkSHÈ»”]&£œe›14æ‰àÚ£ä4þfä3¥d¸×FjÚi§Ì^db#ê\o·³•6Tšr‡µŽ¨Ð°ÓyšÎЄ²®Ì´+7Ïr¹mP¼ø`¯S€ˆÙ_=ή×æèñà(škåkKè&ê4ÑX+e®’žû³QïÏžž[ØRÉXA~u
Xä¦ésåÆO–\ç	Ô—÷z¬7Jœ³~¦Þ­.Δr5jî/ìJ}­mi¶·›
çn±¼
Q`!Ñøír†_=5‚ën˜Þ ñZä-a\$f¤aðEºùËEóËÛ vÕ÷„ÞsËÅÜv·Q[Ï6‘ëy˜­”—Í…º¦y×Q5È}ì©a³•¬5Èfäâ]´i;§’’9h¹0È2ßÚšwsUັlá¹™MZïµ`´•…íW7Ä/'ÈŸ»Ì7Þð²ì2Uòä 
ÿX£5è®)1ÿz÷z×ôò
õ±'œ!^–’t:_¾Ø''{õ€3Í)01±âûƒïªY,«Ï$°ph0¿Iâs^n¹„s À”ŒÅ‰ØqÝ.f?LV8Ö±»—®–Ã6ÏpoªHçY¹j§)±þÀ·å†xåÁÚs}h?ŽýÂöÄIX³?‘Ï¥}Ni{Øvq”L²sIf´z;v6YŒOvEŽOØý×K#Åõ‚('›6ʳùª[4AÂT‚æ:·DÔÜsµsYw0åõÔô…T’Å…
~.[ÿREYË®uxÎë)LÙ,bQ¯ßžëÚ•òï}0Ë^__üVir)bÒ`løüp5x-Ëf’æ
"¤vþÖ.‰NÒV´hÙ_ÒL»ÐùÇ?bº34{®Ù’K
ÿÓܺ[=-
_²ïÀCƒÄú[¾D‹ÖZÚnêiI^é–´ÎWMêܘÞKA¿ñ")ÂÎe¦CÙÕìEn°¤ {É­<æàå“—b«…q°V¡B{jWÍ1)Sy:›sæÎ8¢r¬?äx:/€ª1¥Ð,ƒ6Êü‚ÈÕ>
@Wð†/ëuâÇøàÚ\õbï`oçÙ`ïÅ«7Œ­¬qÇ'Í’çzG¤ ŠkÚvÕ÷|(9¦E¥ïvLàHðÂD?‡õZJ]—V	&е¢§èIûÀ‰öÝûtólB2æ4öí”»Ç[	Y‚‚³þÆ=í%Óá:›ç÷“Ÿ÷^öIZ}ñrðz÷àõ:7¢ì9áP¹v‚
(ã­ éؠ廼¸/Y‡¼ZGq~\çŽãEBDùáŽYúÄz ݺ¤9È.ˆ!§× ÙÁÍW%"·J"St_F]$‰mˆ—5Ô†o‹qJ ÿR5è¹_7©	O'W‘áè6ꊬàý¦ÕXyÚ4ì×ó›p;åΤ6êGHïM’ß¡e­0áåkqŒ¥°óíÕ=6?\ä%¨˜ªGn}µ÷X8Äê–a•b>ˆ^èrzU¯j‡	íb
Üb
4}”–ž©‡¨E.$½‡3²WÇYé4³¡bÍzuû™¼,i(…E;ŠGgf1¯Ê…t]NÝâ3}!G£€O°rÊÛ·ß}q‹ø©5ã±lîÚ Z,tÉq¯ƒ–
W²Â.ä¢Ák´©Ü9öKy‚;™ÈKo²Ë£)ˆy£'²v_9»WóÌéº@¿ËiÓ5ƒËKÖÐ<§æ}àrc¨ŽmS¯÷¼üÞq²#FäbÜ I‹ÅœÕ§§~Íí‹Ž 	îp ÔÕöAVŸëÃ+†DNщù¤N@ú[§ÑàÀõmˆä¡FkÌ'e#.¶$Ê\ˆ©ÚfSÌE¡Rɾ.8†@“0c`§`16”–Vì=ÁB+ ƒ¦§Þ]¬(]ûÑ຅€“Ã]‰ª* 	=:Ügaߪ)›1º=µÓÁòH„…–8$lÅC$ú½à,Y,¤që?•”©MLà†éj¨ªÛ?Í“±¸cà±ïm‚0ωðÛ“ß#`æÖ‹]’¿]ÑWI™@£sçAüÿic*¦•™mÈåpµºðÊsÇŒS´q3B)qœU±z¯…úVÉŽ|õØ7¾¾vV´'½à(¥ªsȬ9ÙE/5>—þð’ÁóñV
\õÎc›Ï&õL%sƒºÚ«õÖŒÛq¥*G4À¢Û`0<–6ŸP9SUÏP½ÉüGÔ²R7Ö1Ô«ZíÎòu¼WñB+¤o¤¿^Ì–B°wÂÃukᬑ²­-¥j¢Áòö,=Ú¶Ö°–k|ñ.³žiÖ_²Cc‹"‡e°+´åO|B`z_ƒÆ²ïò…œ
KWuëãõvr½½}Ëg[Ûð3câ%¨Úɸ8Ê:â'ƒe‚Ùâü‚1N´É"]ÅÃíœ3_		VÑ`Åýÿ2Ù“@n{±e§À4àË ÁtD1äGÙ‡D™`îó€Vá›P•ì†Ø¢á/%]ã?°ûj.¬Ó7v3éïE–\HŒü¨¸‘ìSÂÂ.·ÛE0ôsóa»
1±de'“
®";C±H¶M2G…ÙÚäœ÷F"j³ë†ª£‹º€!í§ú•¾°•|÷£Ëõ‘Õ­›ó$Í}s—äÆ=ʳ¹Î–|`çf0>£À‹Oò˜óŠmm
¢-Àå¡,xºÞš“ZöŠ‹éQ6qè¢:N‡a»ÌÔø×´V×ÆÛB:¸XÔ=cÓ|~qY­¾»UOµø´…¢ÂkÚ4³ZËæ7mÛجе¶VÃWÅ
Í6z¬Tþ²ëTÀ]3Nòªî‰°.u´¦?ëKb$ËØs<g'Z”€417@S&¢ºTÏÑóÕHêè1dÞÚz½,½ì´2Íó¤^^±ªBf{s6°ó²r²ùû.q@Äá:\™$öÝ*yZ–óí;wΓ£á4-‡Éxq§8]”géìÎóxô$.ã÷››[wîÄÇÅx2‹ïoGztç#ñYP>Îù1ÐìFw`gçwE%H(ð‹ðhÃdÒßî ÏÎ
³3Ž§Ž3ÑÐ+”‚Œ1¨l’±ë6*jUªIfƒycvR:„Èg
Ž³ÉØùWØG–u«¨;Ò“Y–'Ì¢iCUð½ö1¦_ë¯Â$PLq—ƹµOðŠÍ)кäª4tÎ~0$MÙ)o“sW’·ñ”É¥}
CÁX)D¹’¾«àÜV¥Þ÷1ì¼	Qüåë ÑôÅÅ'pŠ-Éî2‡÷‚N•ìêÞµ2T„òã--eÆš•.>!Ùdd:rœ„ÞÓ&Kç²FKváêl=@͇$¿ /Ðð¢Cé^ŒÁàé…¤ªÀëhp¬9ðü/¿µ0ëê›/Å«‘˜v9¯—>“Y>|³IoÔéîAcËwûµ·à,EÃáŒÒ€lkátT‘—\œ«}Þ°L™;¬§å¯1;Ž÷à¬HÈRüDźŒ9бªÄ|Hè"^aKíLÉÿ—z§mcF~Pþ$ÖeÇŸå…ÄÍpcœa”l*b°N'Ìk?MˆlœÏ”IóÄp¦Ñác"ï^Al[Ë Ÿ iw‹¬b{%žg_ž7æI®4î2|¨bë÷ò{7Øå	¥,ª°fÖ>[‹¼½éÚ§ò;H‡CÏÓÙq2‚õ¡Äkò–2àÃÌâu±mŽVn±Â<Ï>¤c/t€Ã:Ä#ߧ¤qu#A4þ'9gG9¡T8b|d#VAçO¿ó‡»Ï°YúòÒþ(Î’	¬ê•û؀Ͻ¯¾Â¿›úþ£ç[_om~õ‡ÍÍ/7¾þrãî½-x¾µ¹ñõæÌÆo0ßÚgQ”ppÌžÇùÙ²r/²Yò¯Ï¿øãÖÞxÛTöØl~}÷î†ÙÚØøó`sk°q×lmmoÞÝþrë?Aþû/sKåÒƒx\Tesä©ŠÏo@NŒGÜ°™¦3¾o.‘š;‹ò4Ë·
.¼Ùšÿ“@3|TXˆm곇a;e:;ÊbÆmDu¥ìðPášÇSáqŽv½ì¸<4çåÉ8-$í=f²u'Ë;ìCŸ_à³Ý‹¢ÿ´P+ðw/Þ˜ïXz1¯G“tdž¥#í¥‡†‡ÈôÇ°/c0OIßË(:ÅT–b‰W”’A.Ñ6×Ñv×VFž‹¥-‘@ªãÒU6NÞÍÑ^~
Ëú¢ÒÞŸ}”t8óõñBı¿í|ÿòÍÙyñƒùÛÎë×;/~¸oívɇ„›Ja3ñÊo¨
ËãYyA	$v_?þªì<Ú{¶wðŽÿéÞÁ‹Ýý}óôåk³c^í¼>Ø{üæÙÎkØ7¯_½Üß³Ÿ$—-0ßИcºˆŽDÁÓþ6µ ÷#¶?æÀФ0®
x£ùEûÆae»wÄ:³¡È[Fg?>ÏÓ2QÙ·k7ìêºÙ›†ëæ«M(ÏÎ&°òû(COÓchÿé$Ëòu¬þ(+J¬ñ|ÇŽßÜÒß4oöwh^OùFô‚z%Nœ³´b
Ÿ|ü4Î¥èò
Jöfrl…T“8/”T,$è³/Ê¬tD!ZÈVbÕðHÀQ ÒvÌ«¾cN2`âm‹lÒà~Ï.4¦š˜12¬‰š]ºë„E’L‰/%´„›Ç™Yd€-Vä9`|Ú¥„c9Ès°ùÜ1n?ªÉja¬…Ü•6Æø·yŽiHaÿQš:JŽt&Iü-€hµ¨™.ÑXéO:uˆ+NðfiLrvŒ-ÁTÔsé–}!ý+çñ\bº-*ËigºhÖ†±HC^oP+ŽiƒI^B&²ÙÙâ[ò„â:Īq‹ÛfX{ì	ËGì…!UŠÈVè2«ûA.uè+
6}d=VРQ`Q†­Ø¢ÌæºÑ—øE»8yLhÕÎ릈/Ö?uzM£]:k(LÚM
íˆPC}lPòAž|H	×F×¢ò(Eë(íˆhæ韥­Yt²ƒ«µCbu9ò·Nr&
J›Ú+X!vgšYøG#Š$IHû‹H"Eé–câmQ¯ÆCãNa{ò[rÍöºT#ä©ðöï"q‘Ý]œMˆ.¦ÈÆÔ[ÿòÎ]Ɖ`ÀŠ¢Éƒ“Vñ¡úT±hƒ—ÄbÅAèÉm‚¾Å$%lÁ‚þôºPÀ*ˆ#ì>ü%£`˜—£Ð>ùT´Ê80“M<²Ž{Þ@Њ_šÞa„— ž¿²ø™BñÉø0ê›Vˆ¨4½êˆHMœŽ€SÞè „4ô4T
pý	…õˆ¹ ?y_«]phºP
¥_oXè½£æçER°™¤b1Ç,yìI,ë7:üÉ_<)úÛ¦‘Ô¸"J`
‚ý“ÁÇ’üâBÆY㌚š#ý€ß”ùFNÆ6²Eôfî„kâ­Wùì)POræüL¼¶N\.Ûc™9.8»qZÉä8òáæO˜.Xc_G1€È™oT(»®`ØztŸ¸`eL m=ÝÝ}òhçñ_›ßo™çìØh0UQ+ô¦ÀÛ:@4"·5/s3
ÃsÑáH’Ùd¡¹ i{ø3ä÷,X;e
At‡B¤¡É‚oã3sr¢gƒ?@ôFoÌ2sMaŸ¶9™ùM„7º¬¤ÒtÎðж@•õšCû4æ©ÎÕýà`šÚg`ÕÒ£Eü£’Úëý0x9$DjUûÜ®5úì24¥=¡®’·Ï$]ÀšËØ0ÿ÷sÔA%¡½s¸ŽqÃݶæÉƌDžŠ”…êš‰—z£e?Ï3x4%€ùy‘ŽÎ&®½ß<€åIg£ÉbŒ®ÂH³ÅÉ©x%ÌØÚV]Kl	EzF™ã2†¡ÅȽÒ}š˜÷
yåÞÌavØŒ’¥Âz?ZœÔ·˜_³ëº¬¢‚7ªâ=þgd¾µm/gÿ+Œ·“Ì›„Ì@OÑÆþ?M“ɸÂþ×…í*n«
ÜM€€P0øV¹+ò!žô›Á )Î=ße
B­7ÁÅDúzÚ^lŠQ<‰ó y'ÃS`I¹N[Í•m
dÇ>^7êÒTŸo+ìè~u»éÁDqšã™ü¶zÆ|@|ûkWšéþS+!íD[­V+,-¡vÅ[(Õ_mµC:´ªJÚ‡+èｌ½XŠcú ',‡%óËõZ ì;Açê|¬p	§Û¦Äåñ£K@ñjÊxcªà»ÌÒ ³lPÞWzu(õ×çW@š`µRÿò«…:ÛR÷ŸÿD0å”ö½¦÷ŒûLÐR¯Bk3õõ} QhÀ<~™:öi†àiæÔàéAA™]	B­¡žÛž—A7¾e¥.[µîœ›c$W§<µ“"M;Åß¾3â‘´êÎaÀO¯ÖM­´£y2Í>$M羶±mEƒí
+»~M•IêÐÜ'½dkk;{àaŒ9§2)l»1	üz–YƵ•ôÓ+iSƒŒÊ"]: ˆ`OÙ׉z[Ú
G
§›¼5
Ì.0€;ïwxfŽÏo"G
f6z䛚9œË™›FìÒÂĬXWÛþ6¾#d;ø$7q«&D	v¦*b®²¤
¼„g½

‡¦wLÉBŸ8¦üŒxî’‚y‹ûžÑ›Äô$/ê—ðøþroì>ÞC–M}ï…ãEŽêÏSÃO>A–¦Ð?£ñ2R"´­mX™09¸äϲ¾õ¤ØÑ@ß>ÅPp"aŽ	ª_µWÔ8É…É™4@WÌpà,F{ر;»X‰o8šÄ³3a_^Ð%;¾‰ÚE9ë¿}#J¹öÌԮ⡌ð0|DÒrÇ[7.Øù]î&XrùA:U™zËrGÝêðœèæ mZJðªά? À….¹ÀPöb¨^}v¥ZšƒlÌ7áQ3v<¨•4
"…ás~.tпP
æþ´‚Ú7”¢Åß;ž^gïÅÁîëÇ/_×]BWV¼Àž¥ÄXvìLaùåðowLÍ;½Pû硳ºJ6Ï„´<ÂâPì®”vcŠJ©xV¶ »Ãˆ 5ÙÑ6ÚŽ1AÄK˜¬ä´‡ÑS|‡{(øMzô";g˜éÀ›ªËp8„ZZ£Wí|ÿD*êW¸X}v§Ö´è‡lÑý€êJ¸}ž¡±ãxÂÉbLúÏ¡ù.£Ü¡'§¥tG¯+jÈFÁ}jdåeˆGfÝÿÃå[œ0ç4Æá52œñÆzÁC);ŽÇ6©žy—4ÉÅ^P{.”'ˆ¬;¢pX42Út	
Ã6Æ¿A1ǽ"=AXñ‚Mn‡C ™à$¼´Ô
½“ÉϜǢÞÅ‹.êQ7cGøàÒšêe«ZGD÷\¹B~å®ÅX0ž~³Ë¾x!Týõ¯ëY~óùÔÏ*þÿólüI›Ãþÿ÷Züÿ7ïÞÛÚøÃææÖW_~¹µuïkx¿yoëë»7þÿÿŠúÿó›Í¯7îÝe‡@ô	¼k6¶¶7þ¼ýÕ×êöÏÞéâ¥?r	bX˜+ˆo5ÄqÎézˆ¼çS¾6MÈëÈM5Ö/
o•ÉGõº·÷¥¡£ý]37á7žü7žüÿnžüÖ©äÿ³äâ<ËA¾ ®ØDð,2Y åï–üýRþÞ…¿xU(üQOáÏ™ˆ#²ôÁ_JîÁzÒ÷ýì¾’@NBžE>¶ó^~ê>èö¯´ ‹å
Жh¹Í=‚áß3ø·ÿžÂ¿}ø÷wø÷ŸÕŽ™q#ÜÙ7ßö­égAèm@øOï/êáõb.V;ž”2n™P%Ùõ3{½yŠ÷¤£°T8Ë>º÷ÃoDßÅÌ‚¸àan²d1uœ`YÃ)s‚K½TŒn]Ýyv0h¾Ã×¹æ8Èì1	ëƒðrŒÒ.£XQÒµ¥ÂŽ§
o5SžR€®4sB½‹
¨q)7>ù÷Oqr¹éÜ?ƒ÷
ƒòb®·FÑ¢#S¢²×jø,^™Æßô5týç'mm×]i_rCY	Eû˜/P¶,\…€•SÌÙPÜ–»³ø-ÔÃÐ]¹îO«#;Ÿƒ¸JiØVÎÑ'+úñÖ9<,̇‡½á퇔GÕ¡ÚSŒy/ý˜a¡ª9´¼ðá¥c.ÑN²£¹K΋¬}óh%ÛÚÆàÏïlº¯[‡‡ÿÀñÞöFé¾üÑo7#èâSâÒaH›œ…’úÄÂBö*¶ ØV%y”*×Óe={Ýé ;8­Ñ%}ãL/ã‹8‚=2R4%ï‚’“ ¢Ûöh*_»D®vÚ,'"E
~ž"¥&Ý¢·^cšRÛËGí}ïÖ›C·y¥£.ÅÝÇ>Rv	ŠíN¢·‡¯/¬žå!|ì³¾«ä¡ðúFº`ÔŸŠ´YžÀô΀£à§[ÞÓÊVâÙ®nd /»ŽIN^a|Hÿã«EŒ îÃS¹9¸‹i£ØñnšdÙI¿šˆÏµÒÿ—,¿ùîHˆ‚„o‘>­ÕÄÝAÊBj®riâm³E:»5°‰õ½òÁá$µ´&Ü gˆï=ð×rÓ
Co_|ŸðFø…½&«Íl55cL­c–6óeC3¦±³¬™»õf-Í¨¹Le…CÜ¡‡”°Ý¡iF¶£OpíÖU}ÛH¶˜
É©Ûú¢é$°¨lº\ðGL·Ï2—<Û”kjçb­z$ÖV:
kšï¯úThuãäϹ ¾œïSÁW·X²FUwÿCÓDηžºU&œîðì®…7ŸÞ†?4B¹-¶z8£m@WÄžÎÚšñ¢­
«í Y}W9,
õÛJ$MàOÌY3ô7ÌØ’tä4Ç&‘ñ¶À­rËáÐÛžÌ'ë/fáÎO2ÇÇàÍÙhïð¥z¤ êPwuµ#%éWíÃCS_¥ËqÝ~iCü~C(±Ò¥euW”˜}ŠÞLÏl¹ðäTP•Ã–\à]!BD•ñn.ý¹ä*keõ
­ó%Á©éx}ÎáB!,èøxÿ—D¨ dèæýÐ	Uþ¨.6oŠi¡1C­™&¤Áæðê‡cbÓ)ÄÀàh»^ŠÜÊ)	§[5ž€Ê;}o ‚'¹‘RSáÚ¯UÕ
'',èÒþžó‡ãÈ
H¡áphð$Z…ò$aÊ7«ÂˆõUŠ|æ+ÏÉÉ”¾Þ7v¿#EÊî‹'†mÂd5öÄxòM@/MŒT&³ì¼cmlÞ@ñ£öNïÒ‚^iÉЮ.çÛp¯¶ÙþÒ6hÑ=5‚<+Åbdöã(.Ó)í§ÍîW%ž´¨Ô ØÏzÖûF¡ŒFèDÃ[oèšÓðí6ùLl¿{‡)š¡G$4ý(ýŽÑåÕ™[Cvü®>wÚ†/èÏ]­ÒÐ%_¼»j—‚êzå5FÀÓVo“žYÕJ¯4nËC€;œÕsh€ ÇSIÚ8,?––bûÝ{ÕöNàJR·‡Ta.)G•”ƒsÊþXfÙd0N‹áÇùôšÕ/©Úží3 ¡½ù:uÕV}ºâs¥ºl½_Reé¡þ7L{yó¹ùÜ|n>7Ÿ›ÏÍçæsó¹ùÜ|n>7Ÿ›ÏÍçæsó¹ùÜ|n>7Ÿ›ÏÍçæsó¹ùÜ|n>7Ÿ›ÏÍçæsó¹ùÜ|n>¿ûÏÿ\`P¾¸BioPerl-1.6.923/ide/bioperl-mode/dist/bioperl-mode-xemacs.tar.md5000444000765000024         7212254227336 24513 0ustar00cjfieldsstaff000000000000e62e15190863b4ac52748cb347fe225f *bioperl-mode-xemacs.tar
BioPerl-1.6.923/ide/bioperl-mode/dist/bioperl-mode.tar000444000765000024      6527412254227314 22644 0ustar00cjfieldsstaff000000000000‹€poEì[k[9¬î×ÍóìP´€‰3÷I ð0™L
m¹Co,¥!`JHÒ\¸¶üö#KvBa·Ûݳíùp:b·•lÉ~%Ù–g¨,<øá…OèûêOÛü‰?$×ÏÛv­ÐrBËuPoïø?~jzýZàÁJ­{ò­~«íVú3æó“YHûõœßÇÝ ,l·-×~Åÿg<ÿì´v”ö~TüóøÛíþŠÿÏx¾ŠÿAç´ÝHóýv»™od=yÑ9ý/Æø›ø{¶m߉¿ïºá°þ‹ÁÿîùÿÂ4¼Y_éÂï9tD?«Cýý1
œû*ö1ö1v÷`®Ï=r<ÀŸ¢ö£dá·:(÷#‘óé!^(>*)"~‘xzˆ#ÞUDü¸â©;·OP{Yñ‰?M|QñóćŠˆÏ("~Žx_ñ4^¢ˆøÅ»EEÄ?Q¼WTDüñ¾"â*Þ.+"þ†ì•MãyŠˆß#ÞQDü{âmEÄHßWDü$Ù§Äï+¾è+"~Vñ¡­ˆø§äKñ»dßRDüÒ·ÿYñN ˆx›ÚCEÄ;dßQD¼KöÉÄ{Ô("Þ'ÿÄŠˆhþž"âCÂWUD|‘ôKŠˆ/)Þª("Þ"}š0ñ5²_QDüéW_§ö’"â„ÏWD|JãWHúeEÄÑø‰"â©ÝUD|Föá? žâψ/*"þœÆ§‡øŠ7%ñ—Ä'Šˆ¿"ý@ñOñeš%ñ1Ň_!}Wñ	ñ”ÄW©UñÏh~”Ä/Q
8ñË4~EñÏ©ÝQDüšOQñ/©?	ˆ_!|Eį’¾­ˆø5êŸ("~âKñÔ^UDü&G„ø-j§
‹øm²o)âÍô/žïi”òŒ>‹‹‹cã‹'¦çós·§UÓâÂÌ“ÅʼnElûZ§ÞLL,æçç®÷Þßj\T…ÉýÅüÜìSÕ¶ûU#*~ùl;®ç×{»axW³X²ja½méíFõÍç³Øvss«q'2±ÿù¤9{ÚÚ
Ó›ññ¯5'&nÚOÝ™^¸ÐœÝÖ¨:ýä|áâRµ]]Ý1;J市6Ï’«Âm³Ø6Ÿ¿®>‹Òþ
ê-Un5>ƶ¹ë+·º|s3¸*ž?¿mv:?w}öâàåÊ	Ú\z¾ºzÛ·ósc{ÉZº~þtMµmlÜjœ¿V>[(\n~¼Ø¶µí[ù±÷»»7ã…«BÑÙX[[Û¸Ó¨svµ´ô|{ccãö˜ßJ““}_æ~Ïý_2¿žõüUýÿ_Õþêùvýo»¡Ü©ÿ=?ôÕÿ?ãù®úÿ~íï-pô¦ðUõT®ÐÃå?p½U-û|þ-² ª}}`AP
|®PÆYàV=ŸÐ	XUSC<>„“jÀ‡ö4⤢Oõyx‰­{äÏ銱1Ç=ÜÄÕ…ó‚8!W3¬RMl]Ú>aA\IôY?eŒÆºø|È‚°þ
‚J©ÈF¯ÀÔ×{,ðPÀðß3Ú:ˆ+´ÂÈA<ÊäÐA²Ïgè Ù‘ƒ¸ê}Ê‚rkíjp•H«|!{]Ø~¾	–Ë£ØlÃFp©æÕGqYP©Tt1ƒü‘?ØhÀ¿RÔ
Gþà™YàV\]1•XàT<]bY?:¨fäj˜²4Ú:c© ?ô5x
ø2üÀOŽË!	lßñl¶q¤§'Ú§Ç#pl3?
ÙÆGƒ6Ôþ81“MƒÖ×épÊá3ÚpÅ_1oÛ€³5¸Ž‰~¢£ÿÉ€‹4¸®Ciõœç¸6¯†>â•-½L¬’ 8^
g,(!œ›Øzþð]´äúÜãÒ¤TÑe,W£`³J4‚Ï3-ø&Ø1O¬Z1†Š8úF“°?lô÷¨šÝ¡¬ƒýŒaR8KmTÑo-–Ù×Õ×îçƶ¾÷¼`pNÉÓí—.*.]á^©¤ò*÷ð×åØ®ñn™àåžm¬‚Í£lŒÀ1–M}[߶ŒÀÒÚmWÅè³×wFð9O_rÁ½fA„ÚoXà'žÞß2–8²|αw<õÈv,÷=†¼Î  7AnˆhyXɯ†J‘£÷uA‚Њ“Ñ.²ŠëWµƒÆH`G®­oÃãRûÃÖ×¹	9„ÏþxÌ‚J\ÕÞi”ãª~2/ù
6\êy©á›t˜“úôðBVY`3Üúf¤ö‡£æ		¬²íZúlÃüàeúPê\wõfp#‡{!½–ý}ºÇðK®e³ÇÞ“Àû£>+r˜ìÉ|·Ï‚(®è.³,(ʼn~#õTê³!
Øè®ÔË#X勦òÙøÃÑþ°yêIbéÍÀáQl\Q[—±”qƒáQ<îá–ßäG ×m õþáè}=dø^˜è,,’Àq<Ëa%
¸<,ÄÃt¨± ÇúÜTôÊ:ƒ+Ó¡!ue`Ò!•ú$4/ÅY`
áé¸ÄEÝã˜á‡Ndó(™IÏÒgcñ.¥cÒ!ÑéðiäýB‰a\ÖoP{FéW°}“¾Þ£åÁhÏ8âa!p.‡…Ïã‚á°¸4k?qYåŠ=Vtb0‘ñiE¿ª)³Jºú]`̳ò^•³<ÌîŒÐê³aŽ=öŒ^\Ôh—tžÆX³òÙ0J¶ñœ±T‡ÑÁUñfðrˆV¿\a£~íÂUN‡’m[<ìšÎõ¢¥ÏuŽ~ÕÇ‘ùl`Alé³rs”ë,Ø­}VÙ¡eì°ÀGp<ÓW#´¬òšN\*3Ú7#´ìä·&؉ö;ƒ6Òh?˜­Ï¼¡昗BEýZ]½]˜÷¬‹$𓲣fLè}½¢S{\è­¢c;!t(KæÛ‚ã„™\Xæ0̳ÀBcÉʪåJÃ’vAèm¼¨ß¸Î˜yxz_ÂࢠÑy:Å‚ÑòÔ²Š].iÜŒ°ðÄ®ÅpUr:ì,E¨÷K±Ìó(,~™U&µã ÌóØ穇i9+ô	ê©?5
t¶+tJ…z~!‡‘Õ§úg%Œ\½lÄeK²p~—)«¸Ü£ZŽtIë‰aZr|Jƒ60h6¡å™
Z¯¬Ï=8ŒÙ§–_Öðk£P2ü¸X}²º‰K è†C9ÒJ…>€½yX7²õÖw$ôQ`nZÇ&ʺPÌŒ?}F}dAÁé³QìǼš,(ÆAÌó85S7‘k±@UÒìÂ6ÏT•’¨ŽÐŠ§OO[+¬úl`_,ém«ÇôaÈ*}ëa ßwxbårI'îÙhêlã\'
8?.XàÇnÌh/GiÉF¯X ®€¼*#ÎÑàÊBïü¦ˆ5ZŒ;¹b2Ù|	JLlc](VMÒ…zCy6\b:—x¦Väêòk™ý•"óùAÃÇ,äa_°w¹—¾ë/¾³OWYàÄVÌF×̪,êQÖ?|}KÚ`5¼%m˜Ê`k}}oÐûiÅÒ[ÎŽñG¢?•¾2ùa
×Ãý´ÌXÞè}·ON˜·#ûÎ,Âb™WÓA¬_(-êLöu&K¨/Š<¬`;±¾7U1/¥þÙó¿S’ßIw”,ÂŒÃ<†i˜‡<ÌÁÌÀ˜‚‡p×°w_é=`öažÂ.|Ï`ƒ.xàC!¡t_É‚ JÂ!Á1ªdðNP¥	§Ðº¯4	mèà(Ÿ =èÃÎà.à® ‚2ÄP¹¯” JUžÁ,Ãsx/aVa
UÖa6aë¾Ò6ìÀ+x
oà-¼ƒôBÈE9&×a\NÈÇrZÞSªÃ¼ÌË9¹ gä9%Êy-÷ä{Y@•I¹/gï+=•»ò‹ü,méHWzÒ—eQn@IZ¨R“2’lÈTJŽä±ÌäGy"›òT¶d[vä'Ù•½ûJ}9ÀQÎä¹¼—òJF²,cYÁ‰ud"«ò™\º¯´,ŸË¨òR°"Wåš\—rSná(ÛrG¾’¯ï+½‘oQå<˜Sô­NXrLŒ‹ªœÅ´˜÷”òbN\È¡B9#žˆ)ñPìËq-&Äžx/
bò¾Òì‹YñTD°+¾ˆÏÂŽpŶô„/Š¢(ÝW²D
UÄ:ÔEC¤âP‰c‘‘JA|'¢y_éFžŠ&´DA¶zL|]Ñ}1 •3q..î+]Š+‰
(‹XTD"ªâ™|&–IJx.^ˆ—bE¬ÞWZëbClŠ-±-vÄ|%^‹7â­x'>àúäï—÷”þÅrÿ'Ï¿Súwáda3‰*+ÉþaáÖó7¿ÿ垣¾ÿøÿþ§§~ÿ÷×÷ŸÿŒ/7fSìÀö-p,«”ÇÇAÁ¬ëÍÚö;8­}„ñ\î kwÒn3¯>
áyRƒÓ¬Õø—rÖ^Çvh´ëƒÓ´¥>(µ[Pk5 Ÿžvšµ~
Y«—v•8—ÛL›i­—‚%í\n~*i¯ÞÍ:¤3?g´¬‡v 9­Õ{·Gí×úPk6Ûç=èÖ:Yºø÷¬uíÃœ™O§Ý YôÚƒn=…:jânÛÇ¿àqFpX«gͬŸ¥=¡'Ù:ÊaWeK)
Êêñzµ3œÌeÇtN[½A75ɤ½>tºµz?£ñQ7«µê©Ìå¶ÒŽûýÎl¡p~~.5hÙî㓬@÷¿ò…šb
Íf®qËgjÜf†µá0­õq=Iž]na–7›µ¡kÙ“oøOôíAŠ.œšÍåâvç!á Y3…š+Ü[ªÕ’µúm¸D_êxtÛí>ví¦õ~»{9“köÓärPôº…Þq­›RÕ³°{–v{8‰½6g-x™µ3€x°w<ûÇz·}Ô­BïýA:ù¡Î¬ó:k50Ĉl§Å³^ÖÀyÖ?F+ã „ù‹C¸;ï\n¹ÅÓ–d™ Î@­Ñ Àͬ•¢þd7ý4@,ðä¶þT.§Ü‹EC}6N%e3»×ÎjY³vÐLõ„Ò<Æ¢ÃÉЯÝ“QL´ã'‡þ¯´ÏÒïðþ‚¦~'o¾?¬?r¾ò}|ytžµþ™CoMä'ú•Íwjõþ…[¦
Cç¾Ùí~4ª´›àX·ƒfozÿxQòBÛt:ín׺}·7>
#¦1ní¡'›‹jÁö$r­<
Õ¹ÜR­ƒIÀ[ÏûÿËÂ0UØ¿ùþÿnh©ßÿ÷ÔïüúýÿÿÜŽ¿Iʬ•õeÚüÏÆøvü]ßw‚;ñ÷<×ùUÿýŒgn¨¼{,ý0\ÚNÞ
ÀqfkÖ*kÁ¹9üÁÊ"ëc%ÒªóÖ¦‹@eêV•¦:ªÿ¢Aÿ¸Ýåkˆ$<Ç*)m©ÜO³&V”Êv¾ÖÏ+CXtk=È7Ú(ôôˆëxN¨
g–ÊW%q§U¾µw£âþWŠû#Eõ£ôÕ)ÜÍŽŽû0O‘îNZõÚ>Æ“»£KüëažºçxpÍ©#êX´vSuŒw³ƒªûêˆ*´»Ê:';¼T²A«‘vé¸ì§ÝÓž¨˜g«;ð,m¥ÝZÖͬŽ§v]ÍjÊ!ÐQÂÞqŠu/—
U5‡-=¨¶Ñ0œƒsCWSàª-(%m“
±I¬fé0oSU9…Ó½UéU埂al¨“Z™=FÏsyŒϳfËL¥:è¥X¼Îv†×ËÛKk;Û­¾…×Ñæf´ºývŽJ6¶¦g)›ÊTÅœ6”6ëÖZýK壕d3^B•¨¼üryû­šuy{5ÙÚ‚êÚ¦zémn/Ç;/£MÊÍõµ­ïæªêþÞ©
ö[jçÖlÀ±ªùñlO³3Ä\ûsù×SÊÃØ5ÛxOP ±óÈsB«ÝŸó.îʪP0!UÚÕ\€u9¾½j­¬µ`«ýÑF5;DûÕf»ÝQêåv¯¯4V"°Û¶ò¸åÚ°³år¹ÉFzˆ—!¼;ÜÞòÝô,£dyô¯6‰G9€Gjí¨¡«Ù][°Ô×åpS>I/OkZ÷4Á3”©Æ<6æ>ÞÊòJˆCM6S\¯¹ß&Qð'i¾×©u{iž-Á#sÄåß{45•ûm*§Þ(ãX¤ªn úítòxeÌ×:{9~½òd’FƨœÂ£WYzX£¥­FvñhåÅZ›r¿ý0{œ6;ZGÝC£õõdµ²üF9¡¦v€–¶“ç¸4Sä0§)æ~ƒ‹_¾Þ¤©Gl§ØƒGüñ?í}ëzÛF–`ÿŸ¢íY’ŽH‰²cïÈqܲ-'ÚöEŸ%oOÆt;	I‘€’Õé~÷=·º’RœÌfÚüâˆê^§ÎýœzßØéœØ²Y‹Qó¬y201çmpnÏ÷ž½=8<>xóÚÞʱ;í®~q=k>¼ÌæEZÆ®_~ôÃë7‡GG7µnqÕ›‡/ë#u¸ÿ)2š( U(:áPo0•k9-Ï›Çpc_ײsœ–“dwS½+@ø‚¿ puEgŠw®½r¹˜™Œ¿D¯ÐT°]À(Ð̵4âtVÜÌV¡lèTpuH»¤•OHöE—9X‹`ñu/’¢ŽÁYmièÕ|˜ŽìYE-4-t°—¥@ƒÓ‚–—NkÅ–tß83*˜*µT¥²šO†Åås¡vWNà¾é\Ê8,ð7ÏËT¬4 ¹`/€Vçã`‹ËçbÛ_9¡³d¶bBgÈŒwC´|^R´qD­´JäÌ{ß`‹¼æWÎÀrÙ´4Ô.9CͧÇTîœ%%0¸[ýé2g¶ÞlÖ>6ÓÇŒ@:FTš&yܨD`µª›<R3'DÊW5°ÏÝ}3¶EdËlãLù1¶o”ÂhŠ]’ŸõF²úI!æÝ"³€eŒ
à¦p~@¬¨ßó$&Å|!DØûk¢4ý.6€¸5Ï&nµ&Ǧ&궉Â6åÐOý‰sÓ$£‰`t@"Âü‡¯zóÈ*C5Ñ[^c¨árOËk¡Úš‹Y^5UÕ,çòª§¡ªŒÛ–WœÞªâM§í „/ëî™7ÅÊá^^ñò¶÷=Z¼¼úI½:áÔåµ^ݪÖE½–‡Ç—×>ûEµçõÚ–46 ]Íç}P³t²¢Œb­±s‡lhmE?=TLj#àü4òMØßíðϵ¬’K›eÜ
~þs¥a›EÄ0žq’—-,ÊÆwr8zóhFç±Ú'Îåzz¢.cZ½èTT¢ÌloT±`Ó* Â©[l÷[¬)ºó,•…ÖkK•f…CÛTOK3Zq¡Ú‹-I'í>Èj¯žR—ÿwï%É‹é-·dÆ6~DmÆ¢(³iûg-Ô2¤ñ$ý{\f³~ä2ûÙdÜK>%#ž¿ùÖUðnŽyÑa!ãâB==|õæùþÇýãïaaó¢ì÷û¼ñ°?©9.!0Éì7Ô”Õ¤õm9+ê Hšg3¤GÜÀbkY`Dxˆô8¬ôDu`¥Fqiû8Üûòë—O£.­p¯HæÈ’	OÃE¸ÿ®i¨Ù~OZ"½“8Ü\“Î	ªïæ¾´‡Uz§“øÌΠá=mM΂­.J¥pÃeØÊ ½z£€Aì!ãÓ;Yœž&¹Yµœ¢€ ¥Ÿª[piÈeöqïÕ³lvš~zÀzGxfKu‡þŒ¦%–FvSβ2ëQˆq‡A0–³gå9ì7è¥j£íؼ5s‚ÎD8f¼YÚeñζS›lë3B2h­M‹b‘¨A³@ëCæç==ÌUæ m!›_›ð„ímÿTÎkj8öŽàó<¥!œˆ†<¹Í%¡žuÇSX”A£gñ¬]CÒ¡IÒ#NOãÅ„|^<ÕëîEŸ†z9ak~ùúŒÓy9ªtªÙ³ØHTøâ“	© ¢`êl¢‘d¬®çx¾?x>¥ìu¸ßZM
9¬SÃT“CØ,‚¯Ì™ö$œró¼bw›áðpTÏ®à﬌¤óÞˆú‚•²hþšÙUhw¢Ñî"Ï­“tð¿Ä—g‹›»·ƒðÑ
aúž ÏÊm»—~ÉÆù:É`QéAcï#òùýÚλnDº=Œóô2ÙE™q•«:ëÒQ¯É¬É]hÆ‚í‰à!D(|Êh`Š^ GI`¶@¸æot,brdmÓBöJ20µÔƒÞSrÛi/ƒaR—>â S_Í`l@È[SY;26eggÈ‘Öùá~ËáZ‘¹Ì.Ó±-‰£¹Ìò$䩈‡«S¼Lf)pk¢¸À³tø湯Tè«Wd1ô]3¨=Mèœí’]
^ÿÝ	Ú™“\E¨–ù@…DßP8ìžåÙÂò-ÂçÚ¤;:OF-a7|;;ï·{ÿþa8ìûôí+xöd×þè>‰T‡§¤A‹ç5ÿâ7ú7ö;k¬¦?o›ª@þg‹é	Ì·C­h
3¨5ÒU;;ÌÃÑIò½<¦ó³<&øÓžo;;øe_%´¥¡òêºÈË%XG	„uÌ™»H¢'	ns¡O\t’ò‚ž Œî„çd2¾$3‹öè”Ò¨s¼9¨twQZ@îð’ÆhÍ/Šl¤Úvv|R½åPâw±"Ճ͖²ùµ¶}à“nPÉEŒÖÖBÔG`ÝØÐâÄÆj}i#;ßRh5ý©6Ú¬z)p¼pÄ{“$¾LJ×”XìJÜPú°¦¹ºŒp.þôfŇςª±æÒ+tišÿÆâôÈN̲«MÃÙ(.\Lã³DdL+àž×h}Èwݳowr×@÷f¡û?ŽQG2˜HV¡2)”I©Ë›Aw}Y„ºßÒרúÿÔŸ‚¨¤H…ž—ÒÃ-4ï€ «:»W	y€ªvΤÝÐE4ó,›Ý3|]ô=$Ȧã€&
i’„Ôy+ÍÐUûSíê“ê茦Ò؇ªuÇv‡í^¤ÜÁ³ìX¤>³¶Õ¢2ʆ~yÀ
/«c·zÞ^Ÿ­÷}ÍÀWÆêš^ã³B<ÄAAL=•Á:æ^Ô†(¥(É»Ã|¨£ƒ!=—u­®²€ã3ày¼~dYÝG50]œœôÎ`j0àk1‰gè´£?\p™+«L KÍÔrU€¨÷/À[{ÞR°2òæÁò9ÂøaÙqW\ïÖƒçyÀñô.YèÀùÇ…p¥£‘i×yZ
`E¦¢½8¯¢æå;Ë“±TðL™6Y•;@ìqÀÊw#åºÞ=»þ¼:p€‡ä´‡:“µqk€¶{߶Ue1+­ó *«#".âf#2ËXÒãú*Íó*Ò=–:Íf%ŠÞ¸®€7ÆN+óÅ8%™4¿VÌm]ÃOê\Ã݈ÐEïÿí·÷?xâû¸÷÷½Þ‚ˆø‘dÄ÷ÿübâ@ÙÞ´œï‚Ÿ4ó7Sùß?C{Ãá·½o‡Ão"ÕíŸ-†bí°PÃá? 

¼ÃÎcùë¼ùþÿ~ØF(ã‚kíµùWªˆõ±­^u2Лn'Û¸­öû¿µ?|ÕÆY´í´Eܤ§¢?¨C’QØ#˜ 1 =
†Æ1AŽx~´…ϳ삜UˆIÑþà%rèt|Ú]pBÅ<ò'pbîÞÓN¬oÂÒº¦-R³À -³÷ÉÞYÏÏá¨ÏµÌS«tÜPW#‡4¿µžd%t\ùUäχR)ï¼z¿Ù!dÿX7†¶±vg·¼ž'êÓ|
<5í£JŽzvlÁÆþ;Ñ·e}Ö†>ð±Õl™!•ïÚ^1ΔÅT2)(nžÍ$ì´‚`ÞµÝmU­‹!Ó!qnC4¤€™€òÛgT¼ãÓçbù(ì	Ö×ÙbEñ¼ŸLžÀ©2¸R;ËÀê$ñŒ<ßô‘“Gª#¨ÑA‘†òü‰z™”í‚}²EI‡Æ±e†Jý	æb¿f+«vÇhuÄ\èú!¦%Má‚J4ÛwTïúŸPü7a˜ß*þ{pÿÁýÿ~øp@ñß;ƒ/ñ߿ŧÿ-{O¡_WB;ï=ܸñßd3¢“Í|ÂînÕpí-£­ü¾Y¾sŸÇìþ®BÄ¿‡	ÿ笸©ož¿ÑGLõ(¼ùLgs]²ÙVÞ’C%`ÎzQ°z¸÷Â2>yÂï…õ(8sΓWÂf¬Ò]Ÿë¼@lµi-ÎÉ„Äu¢LmÈîœ`Paš7…ïn+45í
ò È3„»>áÍC[ù™]b9)Dž`sAæC4Â(àNF=Cã—å3öì`Œ–Û =I‰!±äGÈ1Ðr;Bä4®Ñ¸¨J€Âˆ&×p’,’û÷©ØìD§Òæ,7Ûu
§	ŽqM)á¯yX"®ô‰óÉâ!â©ÓPBÃƹ–g€~vÁ^ãÌRF’1b>M†¿rm8¬¦@SIiw Øáv‰N :iõ€wcŒÛ2DáA¢ZÒ+ÐuÃÉéTòòùÆXIÈ‘¤GlWè~{ÑÄèÜ‚´(xt"QãÿžŒûD6?ϧղÔÞL«Uçð]è9ëìsòn
?H¯Òšg]ùmÔ<Ò–$|‡”—#	$vÀ:f³)C{i×r1xØd©õDªŒE"=SŽSXO­„jšèà]t7­rTg0Ä=xŠGn¬ßzÊJ"¶ÃFN«˜ê†™%c3aYþ`êº[4#–i‰RÞ&$©ÍïLܤqäo÷[¯S$÷1œ³‰Q
¬ÛÀ/¿5@ŒZ³ÁSU{ŽÛU‘|škM>Ix»±/7XLZ#Àó’bNû­73:Ç›ä ÔˆyvÍŠV\ÛêY<#Žj„XÄh/ØÒÀJŒG‚@¼*­O*éMß1ÙtB7•1¼¹‘¡ æi~‚8šô±ýˆ™)Ì2¡x%GçÈ}¤¶%9ÚYc:M«\Xp¡ùØ~Ÿe…d¶sÉšCHõ,üd[fs¬Ñ\ˆ5ïÐ2 ÌÏ3û‘“™Ìêˆ+tÂ<9€>Yäsi·è¡)[oß‚ÉæÝÍäÉcþf¥m¹>¦æÈÊI>1æ¶5=q!Y©v?
xÏxEôÜžéÔÐ¥±+WçY‘¸.…>«uå˜b\—áÐ~lZË6O—]©ˆ6(, FÙ9Cj{Ù¸çSgŒÛ¬Þgth¿ÆrüP‘£?»$ÀûøFó+­
`+`C’	pccƒk%®ñ;WØ4ȸ¸e'	ÒgôB¶E¹Q[°$ˆ
#_eÌ¥DÇʆfçª7è«Õò1Ê!n8›!M… =?©ûƒéºFdûoŸreR¨šOoÅ®/È(ñÁ™gJj׫¤»v:ªΫG¼;yåÔãâ´—òDu,’—'6E¯ÉÐ=/ÉÖM,ŒÉ_uhé­—ëIˤÂ@UœŠ•ŒØ8íj‰…'©ÎÝìÊÞ¼ôÌ‚:î›LëhËç[ž#Ƭƶµåwð½S­rÁÚø­7Êí8ô$`?1ÁSY;
Eïyy?¨
‡Ø‚Žÿ4ÞÓ„âÛ°8£Œ€Úøb”ctIµpÀå—äŒÂÕ9™ŽÂá>t¶EŠtµÑÕl©v\ø¶ÛÚ
_Ͻ»{'RQdãbˆ£ˆ‰ÆÇùÓÀ€*´%š[‚Vm'ò@Öš@ŽÆ]Dò¤t€M©Êxp½fèšbºMMZ+‰ã±Ž?ñ¦!?=ž¯œâÉ}¨ýä‰Óî…´D;üèC°áŽ¢cÛ¥Õ¨‚à ëÖ Û5¡öÆÊ­uy„Çr͉‘:}øšSÇ«q*¤àGÕ—ygÓb>¢QÀƒ)Yó«gßTîÔ;Å)s–FVtL&FWŽ{N@?…Qå¨îÇ+6ô[Àþ¾{¹ïñ0=‡Q¯å&
Ž®•¼-KOÿ‡“É|&ÜB[ÙtêMz—…ÿ“À—”Õ”.!
ÑOŽZRä°ÁJl‰ëõô‹N2q&Á,?±É^º·›mi”àNRuDï1- ¢d•ë#ª)…GÕ1S$n„Îx7ÈÀq}·»òûÓñ¸Xôà<–ªÞk“’ V•®>a å7¼bÀ˯ ò"xjXÁ9ö¹h÷ÜæЬ8êGBé3ÁGb}k<$â&Kà£0K¬Š>'±Ã—-§	É7‰šXÞƒ|0e
CΞû‚ªùe£+N€ÊæpÕC1 =4YF^g(ÆžëĵÆcPw£‰%wû¡ÃŠz;§E®¶0µêjüMWº´ÁᎊäW-´–bÑfØrPNá÷žÔšøɉŸÐÈ&²NµK±•{ÇÓ-áâð÷˜¤Xìß1`ü¸pŒÆ+@Cgà\.li'á^ͺìꆺ¿cÔ‚Ùû?jùAöÐi„	½× Càò”™
0î~Ú³ƒT9leÓÿì<ÉÓ²XGx…7°‹ÛåÄRM­Æ†öÜ‘ÅÖ²%ø¹–,ýà		I©Oð°¢
ÏᤄU¢Àre	«E¤cyüšæÍõÔfFÐ%®eø± 3üŽáUJW4©Bí$}1ü‰ÎG­;YtÄ1bžŒ044ê²w¸4ƵÄuÏÑÉtT(y HËçÀ{¡83›×oc)›ß…¬öè,ÀÚBüW<÷i¥ã)¹a„$sš,@Kµ±x”È®³½cΞdž¹Jv<œPÉ`³C

§d

æd²þðâ³ä(`BWØ,§~ÝÕøù(ÝuΨs ͼq¼+RŒ“¯Ç–ÎÈwO¡z<ý8²€qÃﻩX1Z$×ÈýècêÒ­9ßr‚×.^I¬o›à0ˆ\»’;F/ý…Ô0\ÜÆôdc@rÐc£xÅïÄÈ@©O&Žº‘¶ª{5¶Dxž¥»ï¦
ò!aM†ÌÈâU!Ûc¹™gHúÍQ…À!QÙlrÞ'!¼©{˱¨Gr•å^(E½O£Åç/aU„êÜ€_q¹
L‰ýJï+bl7!ò<—Ò[B/tÞEE«ˆ½[ö-zß@íZo !ø+É=[[øN5ÊÊŒ\¿ÐZ=PäÇðšÅc
CudH²•¶(þyš]Ê©2~MX¸ß:8U/ß<Û{I©èû”sYjŠNå
u¯ìì€6^Ó?µE'‰«óHÚ~Ðö¹DÙRÃÕ Dß\«Mª•.F7ì£koª;ÀCëäÛc­Å‡Ü\´É'„ÇŒÖ:$¿Sμ7sq^Ô"8ºìkš&<;þÄæÄÛ=†ãƒVeá¸VKe¿ž°å†(㡆Iu8ýç\Í*í½æ´ Õö^ûMÍ43ƒã²¦L'„2s,NWñR°Æw£Kf’ÈüW¾*Áÿ.‹(ÓCœ©“XEr®`P|÷ÝôaªW5ùGöËŸU$áËÂxPf6ª8—çb°ò2‡œû*à¢)g–KÂI3+ºÑ˜]¾ScàdYrhÙxOš]¿b·ç<‘’YÖ8ʘÚoÍá¨SêŒá%}±”ž—ƒN²Ïh9ëm¹3†f÷‚†ÇÊ4J$H7œšëjy„Éê)Þ?-2 ©µªMæN†BêqP¹¤!UÁWX·k½*ÍúÖ`UR’}ñEŸ#·˜[`¿E¤Kô \n£}›FÙúwUõºsKÝÃW/>WGûÏèÒMÔÊŠ'÷#…K¶‚‘œxb™§PJR芈"Oß.2Ÿ€TˆÆ­i†nGÖWt°+Z’…¨4%êÞΘ¼"±-¶;Ž
ÆW»G¯ö¿óŸ…j•Ê¢#ÖΓQv6È\XŒx@­æuRþ¶„PÛJoJçàL—‚˜nJðdì>±“Ãú(^(Ù¯1DO^YÊ碌%äOàh	
tÕsL	¡áéoM5â_FÉ.%‹:Ñ›Zš"ˆE¦I:§"ÄÑAÖÅÕ¿VòâñcXs¬ªéy”±P=IOÐˤëÙ‡+©†Ì…E~¶ Çðñs™¢7‚7!]pÙE6šÊ†2á (IŸq—3ÜuéÕãÇ_ÕsÙ…]úL^ÿA¤?ÃØ>ãÈ”
Ž-ĉéSz+nLŽAˆÌ»Y!‚#êPžìZIñÍ ÿcÙ†<µÐ,»R ê’0^צʌoîE7Êà¸@ž)®²…¤Ö±¾¶ZœÒŒZÒö[t¢5ÀþõØ0v¾ÛB—z¦‹1Öó:ª‘¿ìÿߟ½y}¼ÿú¸z„Nô´¸¿°:iIÞ ÉDé+(’Q-ÇGJXEBç5Òr:ï{#î‡tøZ?+þE’m¢UæqJ× ª¦èn*&ÔmSBéö¦jSJiüòBTíÍV[–ïågEï¹ÂøMÊœ‹ã&UGÙN®YiBlÊG^¶tØ(²Я¬Š4†Zr¬®A0ÓÚ¢#÷eÄçryªÑÎ¸Ñ @vt;Xßµ¾˜«Å¬DÅEꓶ4µÛVˆ>*“+ü"ñØxY
-z™µÚÚÚp$TŒN•â}‡›D4”ƒ¥ù–ð½+¶ŠdšÒl0Ɇ§0Ýd²
0‚†'Ef¯Sbg/À$E«9–…Ó/´„³]‹!õX[Þ}nËâÛ°Z8T_Eö†¹SĪ:õ#zž3«©¢þpöCç•aLšP
-/Zù5žåÑ…L@‘æ|ì5ì’[ØRΪ«ê¬ò“S;ÊJ€W!É÷rc•ß=¼Bž5]©WþV&ïµ8³%l×uF€‹+ëø¢Ð.¶„ºFLã$Ë.莱ìJ²`h/#§iú¦ÌqZ÷TÏúÈzyAÔþuB]Gç A Cþ˜Rž®Ê‚20<ÌWp•pð½kâ’ègOÅ(‘)³)ÅN.d2ÕM¶é^u궢£Û0ŠS­2¸z¶þ|Ž@pïÌKÙ"wnœ0#[°ºélQM#‡
gr?žœ·B§FHs}ÖyAš÷#™˜%!´¤ƒîÚ|ÌwuTƼ›|Cgfu–JŸ÷оê2	øevLo¬«•[•cB4þtŸ’¥[b<9´dД©”QÛ¹ãÄuZÙLãî±$y©9p
Ö¶;þ‹
ÅŸIò÷Ä¥¬DâeV¡…[rããXýèŒtáðÊ77ðˆ#ŒnY›ÖP~”¯89®›F¡æŸÙM½$î+
QÐiYøଇæѺ9H?qfà>†
Yç‚[tzÈ~sæPR20Ò°éFsê'̺Ê1[gTîÈmмõjò/}£ÔåpIA-kÍ{Þ$¼<•lbuÒ5:cdWæ< XüOLæÜz?~¶V.+*|”'Êõ°¤ÐõT`%-´+.0Wiœ*5*pdR7]Ņ妠é’+Î-Î7‹):?£¨ÿ )ÐÉfòü¾œŠÄÊ–ÉFª^zœzW†`Ú‚³ô21)oÄ+F$Lµ†ˆypªöŽz{/ŽXÊØÔÏZ<òóM(ÿY¤9d¿VFy©u¼*Œ>q_¸MB’(Âb´L
óÆÄ”§®uR£¥ì6«]¬jÅ„†ŸY 0Yn×¼Æo¯REôCœ»ðöMÌf	ª&‹Ñŵä	Ï6Øz¼¨ÆQ7£~Äjä¬s]pðDÛ£¬¯S3^£%É&ekNzuÌ£A¨Q3¶n+ºÖµW1œ¦Ÿáõôä‰ñJÑÇ°µt—¢ú’AWH‹ø5¤Lš:Éô¡ï˲ªÂwÓq·áì‹[“ɡϽMÛ¥ó8`Ò{~ðVk›ðû2t Þè½Ý?~sx¼‹³Ül	NÐKJAï$Êí„W
t9¨ÃŽ†J¶°ä#E†.‹^@J48,ÆËhKšfߎ@ã¥Ýl‰‹˜T1i¬„Y>¿=xý]%\fÛ²î<Ö‡£ÛW·,<.t²$¹5§ÎË4RA`­J+”EuEJ>e&Q]=-·Ôâ• C°k’¤NÈ­†a s'÷Fû­ñÑ›ŒèÁdÖØ´oIBI¨$¾úŒµë™†\ƒÔ‹ŠÝÃlrd%, >
¥pOb|:GÇBâØÁP‘¼že5S4Õ"¾ËëSèÔ›"XY­îÐ^'%Q7ýÆÖ¬I0Y@;r€7Ì­;ñ˜T]´ÂjM9»•¿Aë¸öƒqÔ='7Î]úÔ·†Y‹»0ÎHxèx–“¹Wâ	¨ow3ÚÖ‰gŸ§Bu,*°yN§.]Ñ·w",#Ú¶’ûxЭ—Ò¨›ü¤mlNîúd5|wÄ­Öä”gÜ+¬j}@¦å.+F½Ó•Çn-ö¡ì°Ý˜ºùl½°îÆlrO@m$?Òpd(7	ëÜÖŸàð8ª> DF7´—óÂÄ*"Ã%¢kø
웪ñR‰´õìs2^.qák>yaz>3Wâ K0x#}ösC©=Vû#I!rr²H'Èò·‹4\3”¾Äg<2¥3ÎL¶I[żpդ廃qŸÁ@ùžÑ†
†H¹˜t*¦>¨«OŽ
0D¤^?ßÿCª)ï’Htª?Ÿ²?ùö3Á›kãˆn-ª;@V2±`Z[ŸëDK€†W›é°‘I‰ÕÉo†o&&ãÛÇΟk³VµTW`®…MK…Ý+	8*">»‰›%BÆoïjIÞcßÒ3þÛô‘º9t\œe|‡6uj-Ñ뚢:PÄ̱ã¥B­ö€í)·äYä)—±
C艠ðùÿeTSšÑiP
‹ÉŸ~°«£èg5¯¢Ý›«nôdÇ E°’Dz’£ÏŸq¢$R9˜–õt&ã‚ N$—ÙÛt	Óº´ BÀ‰ðô,bFzÍ60O;ª´TÆØ®„Ú¡Q²b}á
Š‰èl’¸¸V=rˆ[œØtC˜ø†Æä&fðDS%z7¯PM´tå7`fŽåÁ86z¤è`£Š¸§Nòx6B{ÒY`†hÑ°q:f[nÒ¹W••øÑ3ïLiž%Þ×Ô¥»¤ä¹]áFiV¤•Ÿgså÷áÌ[ÆláŸt¢îro¸F÷D-cúh÷«!úûkÀ¼¡ÝhgbšgDQžåø
x~소`¸"5Ç~ƒB×µÚ_,$qW¤´§²ÎÒwÞÞŒë¸t»_¢^΂‘yS9½òîÕ«:å‚ÿ¯X].¼ÙüTÙF&£¨1÷Êó<[œ;¦¿Cc9á&cñæMÑôþ k“°ü½{ŠWf`ÔÈà£ñ,Ѿî4ÎEL)pí‹vk×µN,¦76Ç®ÀuX”«à1èwu­%x’H¢µ¨ô+ PѼ®¿ºîc®Ìê}hŠÕ$4IˆK™õPËØ5Ìà½BÝ™W×–ç¢ØšL°¥­xò¥Ð4¨Úˬ¾lLˆèõÈÍ©¹mÌ”t…&ìê&ò¼Y>Fƒ;Í9"P$]ãŒ\Tt
ò]{öZ>ªì®â
¤€!a£Š§<|T}ëÄ[f¢º¨¼Pó<™{Y˜ãYŒI“a›
$›:vç*-Û Mç)硨t*Ýú%Ñ5g‘òÝ£¬Õ×¹TÝâœUl9ô¯S½w>¥»Ð3Kè}w¼ªôeÛë¬hÅ®ýO%]û±LàB7n4s:¯×]Sˆ*¿LG	-^B×–¤ã„#DE÷lïÙ÷û½Ã7G֑ѽ´J˜S»Æd󵳈£¦ÒâI.j+sú>}ІiÜ3?X€ql+Ô2†AäóËë]‚¤#ÞTÕÈ)Í{2Ô8ØÂ2Á–˜º*«ùRÊWAÕxÓC5a–?7iüŸÃ
tŒIe©Ÿ´¬cwóq2ܹ)nž„z[‹¡”ögë넺ñ£èŽô™mµñ8ºÅ,ý©§kø‘@56L;*ª5&úÊÄ*ï¬7ºë§Õñ؃zaÇdí”ôÆh)Q­~ˆáÒM{°¹}MôjðƆðM®À«m83ÇjcL6HôH“Á5¯jGÅŽsscÍÒPÕZ¥¼‘‘¦®…‰]ó)ùÿzj›~“â†T<0ÒUÝL·ÕmúûT‡_Eg9oe)¸•ƒ/Ê°Qü	%–í‘é.¨GXªïñ‚
il7Sâ°Ö8ššF@¾ÄðC˜ó}J¸Ðtq=¤³‹]][Áqe«ÚÉâŒ×ÎÈieÉQ‡\5ãRn”)H7B¹a#yOåHšÜã³9ו‚>¥\KéOì<ãQÙOÀ
áõy3LOÂ;ã~‹?ÿ8pš6Ü£æ9Ìq'B¤ø'ië:ë3Ç ß‘Žj°”Z÷õÅ@$‡Ä8˜+r;®#^:|¼?A¤PËgö·ÀÔ¼i™Ì'žÃApRÑÛý½ç¯ÐÇbõbòÉŽˆ˜0!é×ÎYº›Í§m…½Ãé[-†=×=tªÇÃHo¸°¦.îñ)ºB•1úJN‡ˆmtn5ñ¼bz›ß­ ‚qRa^8QšE—0œLÑ¿¶ÁÒÊ"1ÑK´ˆëqõ—kXè‰N¤Ýì8µU¢Wï@¨Pã6Þ¹ƒšÝ×ÿ|p´‡—w•k‚©YØ
üé»}U÷ɨ¦œ©XnZšXÿ-ëp`O@¸¸&Ž×†7žxIäEí»tkXѹE®Å¢ˆ	íŠA7IFìësž]=A¯¶ïJ(âwz’êèøÝ‹üŒ¦úØ}B'oš§u啘ãŠt-·aÖš¼•{­do2ßÌQ7Å°–•8	üÐliì櫃AÝ@ÐUñŽrç¿ßš|8ÖþE×<}Í"VÝîB[_EÐÔ£jM7`$¯O¥­^uHîͲÀÏo†Ã‹Q±gº5 ÒLvaÎiWbÔ yy,‡—Q
õºÌ;˜}s±vwýZÃΓݟ®Þß;߇ÿøð^
O‡åp6̇—ž¯tÓFßètþg{}VFÇAŸ#Ãö"¯ç¯"½_A×.:Ÿ”†Æ.5êDêú°„Gž Ìfò$ì»H%ñv(>Ù@UØäáÓ
»»kÁòšŠOÞo>þ~GàÚA¥“Íáèq¿yL
)µã“%Ó¨ú¼à#×Þ
Ò%Xÿ…Ð~Kx¿Ä»UVÔ9r¿þ¸_Îþ2캧j)ìflºî!ïÉ~·tJ5wˆ‡Ö’Û\î1‰¤*ªÉjÖ˜3‘7œHm6k›Ù"¡Fí®_„T§ÂÙé¼É’:)œ£5§NRº{Wø
I»–ÂR`È VåPNqÂLËp2¤D[pÈœ|b•bxi¤ò±b†?‘תÁ?¬>¹íAÿ³P­•j6kbeOõèW’›òV[¯È€µ«eº¡,劻²UÈ*`1G< à1}{˜<¶ê‘h¨
bs§d81@ïæ9v´A Ç¶eB:ëIöµ¯Øa8Úóƒ·½okñh-k5%‰*¶ž¢|†äªzÅ÷ìÖÚj‘¸€Êi±d×ivF¶`ÔVxç›î-Ž˜çÙ^E41œ'ÍŠÞYl¢‚¿&
\'Y›ì—Æß:Á§80UÛ"F·.cÔЭL.¿„z¯ç
êz‚2yïÅÊè¥uÒesH$ Äùý?œ%PQeÜ-™Ýh‘EòZÌÒOéßcÔ¹¹ñFC
x¤„¶lÚu_±Û ë!d‰•ìŠA×wÞh‚k¬ç“„¢°”)‰¿™‡X­´DAGžËk½j¡¶ïMI”¯k¨­Š-²t°J»øV¼œñbp!eñrÊÄÞ>ñ“Ãé°`W¤"rH­™ÄHprS†it<›±S.YÂ‡å$FƇë¤ê¢@±bR‹ÉlD×ÊÓõÐ-;*—òÑÈq´†îH½)®Zñä,ËÛOQ•ï¸6ù„¼MÙe2ÊyP&°}¥ž®=IÎãË4#ŸA(%kà^ƒÔ´ÕL™&ÈÄFÔ¹Þnk-*­‚TšrÃZGT¨ßj½HghBÙÔÌ´-7Ïr¹MP¼ø`oR€ˆŒ¯gŒ7kstxpÍuå[Kè*j…h¬‘2×IÏýÙ¨÷gOÏ-l©ä¬ ¿º,²Ót¹rå&K®óÚ—÷v¬7Jœ³~¦Î­.Ö”r3jî.ìZ}£iivwÆs»XΆh`!ÑøÍr†[Ý“5¼ën«N/x-òŽ0.3R‹°ôø"½ùËEsË› vÕw„ÎsÃÅܵ·QÏ6‘ëy˜­•—Í…ºNó®GûØSÃd+ÙÈfäâ]™´i:§’’9h¹0È2ßƆss•çº±lá¹™­÷†7ÚÊÂv«â¾—äÎ…]æƒ7¼,»L•<9ˆÂ?ÓÑt×”˜{
kzù†úØÎ/ËHIZ­go^‘“½ö€SᘘXñãñÞwÕ,–ÕgXØW˜ß$q¹	'7\ˆ9
`JÆâDl¹n³ï'+ôëØÝK¯–Å6/qoªHçY¹j*«)1þÀwå†x̓5çúÐ	ü8öÛ'aý‰|.ÍsJÛö‹“d’]I2s Õ=ر‹Éb|–°+r|Æî¿N)®çE9™´QŽuh´È{PÝ 	zà§T·¹%¢æž«;—u°×S^O~!¢p€J²8ß¡ÁÍeë^ê QÖ²k^ñúG¦L±¨ÓmÎumK¹÷>¨e	¯o/~kir)bÒ`=Xÿùp¼–e3Ió†@áS;wk—D'éVtѲ»¤™f¡óÄtgh,v*ܲ%›Tî'ܺ]=]&ä¿dß'
‰õÿ6|‰.Zki7ÔÓ’¼Ò
iošÔ9˜ÞKƒ~ð")ÂÎeªEÙÕÌEn°¤ {É­<êøÍó7b«…q°V¡B{jWÍ1)Sy:›sfÎ38¢r¬,?äx:/{€ª1¥Ð,ƒ6ÊüšÈÕ
@Wð†'ëuâÆøàÚ\õúàø`ïeïàõá»cF„FÖØrÉFXòÜl‰TqMÛ
\yχ’cšQTúnÿ¸ÇŽ/Lô3¬×ÒÔuie`<]+z
 Ñžy¹¬hß~D1Ï& $cNc×®A¹{œ•%(8ëoìÑÓNÒ?ëo²yþ(ùéàM—¤Õ×ozo÷ßþ çF”='*×®QP¡…c¼$+´|—×$ëSë$ÎOâÜq¼Hˆ(?Ü)KŸX¤[›4Ù1ätš
Ü\U"r«¾$2E÷eÔE’؆xY‡Úðm1V	ä^ª=wë&5áéä*2Ýv]‘录£MÃ~¿	»SöLêFÝé=$ù

ûh„	'_‹e,…o®î°ùþ"/AÅT=²èj{a}l¡Ý2ŒRÌÃÑk½€^µWµÅ„f±zv±z:}”.=Ó¢¹ôîÏÈ\g¤ÓÌ„Vˆ}Ì7ëÕígò>2¤¡í$]¨Å¼*ê ëŠpjŸé9y|‚‘SÞÿm÷ÃWwˆŸÚPËf¯
¡Å@—÷:h™p%!ìB.¼f@›Ê“~¿”×Á»“‰¼ôø&»¼P:åÑ!gaô‰¬ÝWÎîÕ¼bHä˜Oê¤¿M
\¿­‘<ÔÑóIÄÅfƒDY`Ñ U„b.ª•Jnwõ‚c4	3
v
vcCiiµ¢“½'XhEB´×ôÔ¹‹¥kw8\PX9Ü–¨ªBèÑâ>ûFMÆèúè9¨–C"\(4ÄÉ#ak"ÑïygÉ`i$ËXÿ©¤LíéÄîh˜®úªº£ól1‹;û΄yN„ßœü3_°^lEüfE_%eΞñÿ§©˜Vf¦!›CÂÖF4jÃ(Ï3NÑö£A„Râ8«cím¼áë[%;òÍcßøúÚYÑœô‚£”ªÎ!³p²‹Nªz|.Ýáõ$‚ãã­5pÕ;Mr<“Ô3•Ì
Ú%Ð\­·¡ìˆ“(U9¹¦-ÿØzƒá±4ù„Ê™ªz†ê›ÌðÈB-+ucCªÕî!ÏSÇ;%/4Bú@úÛÅl)p'<\·΂”mc)U
&·—é‰Ð¶ÀZnðÅ»Ìb8¦YwÜðÈ-Š,f”Á®Ñ–S¾¬¢ÁŠûÿ*Å&«4m]YÍÁŠ«(ôù’åê2öJÊða©ªigpÒzo6ÜÔsÍâ”Ùº[ÈS¬³L "¿=ã‘fï
^HÔn‹%•YžM—¶„föÇ•Y‡r—ª„8ÏÀÍx§Ô÷cnY5Z`–—H›òu5óž½/ÎK[±:´Z#²Ë4v
 ‚”M&|sUåF5·ºÜŸ`d,¼12
¶ ,%aêó©1I¸
FNU°\éZ¡}‡Re§@…¸Øp°T»Óaçò>«»òת”¬<0à“‘ý‚ôÇté‚-nÒYeÓ4‚Êd˜<뜱E| ÛËNi¤ v*“o’èé´Oö$ÛÝE,DÙ)ð
øÒ+A0QùIv™èF&˜ûÜ£UøÆW%Û!†B4Ü¥¤kbÜf_ÕµñbúÆl&ý½öÒÂ’‰’7‚}JXØævÛè†~nΡQl·!&–¬ìdRÁ5¢Bdg(É®J¦ñ¨P;Îy_`$¢nvSQutC0¤ýtcX»Ò–¢’¯ñ~t¹>²: Mu•¤¹ËâcܸGy6׳%عêõ€Ï(ð"Ƴ<æ¼b;;½žhpy(^®·æ¤–âzz’M,º¨ŽÓbØ635î5­ÕõC q¶.µÏØ4Ÿ_¯ªÕµ·êi->m¡¨ðB›¦Ök¹Åü¦i›ºÖÔªÿªX£Ù ÇJõà/»ÎÃw^qÆåÔ·Ú¬ŸùiSgÁ¹æ€ò
N¾ÜYÚ’û3•\àÁÞ%ÔMš®^ÀSèì[0<—WûÕ'ÿEÊS‰÷¡{wçµ”¯§·+Ö
êçw#·ˆA
C%cõ¨{“ç³ö•Z–v¨Ú!†ÃîîÝ;^Z³v”såFãw§‡	Š½Îà䦗R+š;6AËŠÄÔ¦‚@’e·eÕ	|ßO6'æ<FwTõX¡L1-£ÌVŽ^=29¬#t$ ×‚úŽ.ÜÊ¿îrózSd¼ç²ˆNŒ]¾ ^íÞÿ᾿ëº42ˆ´ÖÙ
—U½Ù6të\+G¸a*ÂKûHgé“dšVòÎi搜Éãèó:SíW‡Þ.¨²'±[gB˜8™Ž8/Êf]'Ñ'Z1¦â
ù'÷:_>¥Ì8(à6U,rÿ:‘‚ÀbšŒ+ùL餭ÖL¹ûÔÚÀ4êœÈ¬H` Zó¡Ü
e%¯êžKaSGëôg]IŒd{Ž‡ãìD‹&æe"ªKõ=_¤ŽžaAæ­×ËÒËH{ CÑ\€1Ïêå5VÕÙÜœ	ì\UÎ Pö Qÿ±OqE'¸×D&<‰½C·Jž—å|wkë*9éOÓ²ŸŒ[Åù¢¼Hg[¯âÑó¸Œ?;÷O¶âÓbžÌâ-òíHO¶>Ÿåã<‘=Ýhvv¾(*AB_„Gë'“în¸xvQ¨½q«wšMÆÖ¿Â<2¬[EÝ‘žÍ²ú­w^ Š»|m$š¾¸øxN1£%ÙÃmæð®•BÐé ’]ݹV†ŠPþa¼¥¥ÌX³ÒÆ'#$›ŒLG–“Ð÷´ÉÒ٬ђ]¸zOZn7$æ–.¦LtWÅ*©s/Y™'ÉmVG‹>›¬W¹‘ÛZb™Xgõ÷<6\ Pr“ß×.;5Sz.À@.`x;Ãkà‹&U_p/y7¥b‹mbfímr)@ª;§€Žéê¨æК#ØF|åmãÞ±:þ~_b˜ÎЕ]–ÝýËþGÝ=ÊŒpÉ2éÀ‘³#ñ„ŒRáÅP$ôB_"ºÓ#¿:\8kV†[‚F¥æÝ|€W¡¡V˜=­݉怅Ãu9ÉNI™§Ç’j{ˆäç©e‡·ðV«WU©:w¨Ñó܇Lj.<çSŒ°üDDÇF¢V5XýóéðNDL‹m—ÕRZä^$s•MQë
ÍrÈÄn5F8;­³eõ¾Œ.M™ŠXEö‰dú=Ã.[tøqx0(ìrÓÎK=Ǫ»¹âL·ìMËOÈ‘”Bv˜•'Áw”ú„Ñ$“tè¶ßzA’(Ç”F˜;ï«ç¢ÏAPu™ä×äê_t(Ý‹ÑÁ<½Tx½
Ž5Žÿå·fmC]uO¼‰iGszÙîR 1™åý7z£î[¾ß­5¸g)ê÷ûdtd[· ¥Š¼äâ\íò†eÊÜa=-Ù±¼gEB–âG*Öf„È.ˆU%æCBñ
[j§`ÂHþ¿Ô;m«(0òƒò'±.;þ,/$n†ã£dSƒu:a^«pøiBdãìj¦™4GA‡aJ.&rîĶuOä³á5m/`q‘Ul®ÄsìkÞïÆ<É•Æ]úï=UlýÞC~oÛ¢<¡”EÖÌØ`k‘w¢7móT~{épèy:;MF°>”xMÞR|øY|¡.¦ÍÑÚ"V˜çÙe:vB8Ì E<ò#JçY7ÔHã’sv”J‰#ÆG&bqþt[ø—ûô·Š´¤C?ß2ƺ‹d«÷Ùú؆Ïï¿Æ¿ýþ£çÛÛ;v_ÿa0¸·ýàÞöý‡;ð|pÿþ`ðµýÙF°ä³(J88ê¯âübY¹×Ù,ù-Æóà`Ü9ïªÊÞ«Áƒû÷·ÕÎöö¿÷;½íûjggwp÷Þ΂ü÷_ꎖKàqQ•Í‘C¤*¾@¾9id0žrÃjšÎø¾¹Djî-Êó,ßU¸ðj¯¯þO-Ìð
P`!v©#̆í”éì$ŠÝgð`QH#‡qN9FS>ÏF”ÃÓéæÙæ Ô&ŠŠ««¾L³Ÿåg[WéEº?z?ÚŠ4?Ò‚S:¡B_(¿˜g^*Eµ‘þšÐqH¥¬MAùÇÊÖêãyC™âû$½¸HÕËäü2.&qzžéX¥gÙüš-„g]ÚˆêJ™á¡Â5§8ÂÓízÙiyhÎ&Ê“qZHÚ{Ìdk+Ë[ìCŸž^ã³Ý‹¢ÿ´ÐVàï^¿Sß±ô¢'“t¤^¦#í¥‡†‡ÈîhéŽáHÆ ^¾—PtŠ©ž‡W”’A.Ñmn¢í®¬Œ<K
Z"TÇ¥­ÚNÞÎÑ\~Ëú¢ÒÜŸ}’´8óõéBı¿ÿæݱÚ{ýƒúëÞÛ·{¯xdìvÉeÂM¥°™xå7Ô†‰åñ¬¼¦ûoŸ}Uöž¼<8þÇÿâàøõþÑ‘zñæ­ÚS‡{ož½{¹÷–öÝÛÃ7Gû}¥Ž’dÕó
9¦‹(áH<í`Sr?bûcMz‰qUÀͯ›7+›½#Ö™
EÎ2ZûñUtA˦¸¥X;°«›ê`6êoª¯P*ž]L`åP†6^¤§Ðþ‹I–å›XýiV”XãÕžÚÞ¶{€ôêÝÑÍë߈^P¯Ä‰s–VLáñ£‹Ÿz¹m¾AÉÜLŽ­jç%Àƒ’Š}VâE™€•Ž(DÙJ¬êé8
TÚŽyÕ÷ÔYìC¼kƒIZÜïŵŽ©&fŒkâ„f—ö&a‘$SâK	-áæqfÙ`‹5òì1>mS±ä9Ø|î·Õä@µ0ÖBîJcüÛ<Ç4¤°ÿ(M$§:“$¾D ÚA
j¦K4'ú':Ägx³4&9;EŒ–`*ê¹t˾î•óx®{1Ý•å´3m4kÃX¤Ž"¯³¨Ç´Á$/¡Ùììñ-yBqbÕq‹»jX{ì	ËGì…!UŠÈTh3«{)—:t5
6}dü%£`˜—£Ð<ù*Zg˜É&Ç=g èÅ/Ugá%¨W,~D&€P|2F]Õ•¦×©‰ÓQ8å¾ă@ÿ^CU À“Ô6Z'ÛîøxM|X±í¢òhøZÑÿ¢Ç˜bG#æN7RÎKuœ–€]:fRyüŽ²aðcyôBMðQO?´èДÛËÏ
åV•aŒe¤†¯»­èH¯-cÀÁ°lN2N˜kXŽðºµpAXyÑ€í	½×$+òGÅoð¢DŸ£²ò8*Œ
+ìcý–Vw P‰ï”¼ä¿L
{üïùþѳ·‡Ço^ãzCçÆ­ã5xôÃë7‡GGõß'iß‚6
9¦¡9ýV‹|„Q‰ý„¶œåPkU2ªeÃHk²tw{ï€WK“ÆéÃ軡Qq
‚£ú L¼‡ñ‹³¾ñ£V¨#µåø?.=x±Ú³êùÔg3
ÙíëO(¬G@Ì-ýÉùZÍè‚CÓ(}¼a¡ïU?-’‚
`È$‹9fÉc·HbY¿ÑßüÙ‘¢¿
¤ÆÈPkàíèŸ>–ä×2ÎgjŽônSê9m4ÓÈ5Ò
ÌÜ
×Ä[Wùì)PGræüL¼¶V\.Ûc™9.8»qZÉä4ráæO˜.XcWGуÈ™oThv]ƒaãÑý}₵1nëÅþþó§{Ïþ~¿£^±c£ÂtVE­Ð»oëшÜÖœÌÍ(ÏEg„#I.³ÉB炤íEàÏß·°`TXì”ÕÑ
‘†$¾ŒÏÌÙ™>Cü¢7zc–™m
û4ÍÉÈoB!¼Ñee •¦s†„¶ª¬çÐÚ§1Hu®–è{SÕ>=£-
äçiÓy×#Q“ÕTd²ÔÉX‚Íìd:M¦3…ú.ÈV1*©½öу—EB$¡VqPµÏÝZ£/W¡)]Ðê*yËñLÒ¬¹Œ
ó¿BTò	ÚK1‡ë7ÜnkžÌaÌx\¨HYh]“"ñRßèDÙÏóM	`~Z¤£‹ÉµmGßož@Èò¤³Ñd1FWa$‰Ùâì\¼ælM«¶%¶„"=£Ì¿qÃÐbä^é>MÌû†Ž¼rof¿;ìFÉRa½Ÿ.Îê[̯Ùu]VQƒ7Öp	§Û¤Äåñö£ x3e¼RUð]fiг(ï«@½>”ºëó³ !X
CêŸ6PgZjÿ󟦜ҾzϸOy-uº>´†©0¨=Bó¸eêØ'ÀÓ(4Ìiƒ§ev# ðµ†fxv{Þxݸ–•ºlÕ¸svŽ‘l\òÔvNŠ„vŠ¿ÿ Ä#iÝÀŸNlšZkGódš]&¡s_Ûئ¢Þöú•í¿¥Ê$uèì'½dkk;{ì`Œ9§2)L»1	üú,³Œk>Z
П&XëH«dTéÆÐE{ʾúHÔÙÒF8
œnlòÔÈ3»À¶Þ·xf–Ï‘£€Ù£‰¹&…0‡³š¹	b—&f=ÀºÙö7ñ>ÛÁ'9Ä­*%íLUÄ\eI¼„c½ò
‡ªsJÉBŸ8¥üŒxî’‚y‹GŽÑ›Äô$/ê—ð¸þroìÞC–M]ï…ÓEŽêÇSÃM>A–&ß?#x)ÚÆ6¬T?˜\ògßzÒìh ïHŸ¢(8‘0ÇÕ¯ºWÔ8É…É™4@WÌpà,F{˜±ô[ûX‰o8™Ä³a_ZÐ%;®‰ÚFô9ë¿y#J¹öLծ⡌ð—>"i¹ã–©ìü.w,
¹ü ‰ªL{ËrGÝjñœèæ Ý:´”àU#œY~@k½äCÙ‹	£:õÙ•FThi²1ß„G͘ñ .lTÒh(ˆ†Ïù¹ÐAÿZkx0÷ Ôî¼£-îÞñôZ¯÷ßî=;~ó¶î໲°â
öô$%Ʋef
Ë/‡·¥j–Ø鵶­ÕU²É8¾ ¤­àC±»RÚ)*¥âYÙ€î†Aj²“]´c‚ˆ70YÉi7†Ñ|‡;ü¦zô:»b˜iÏ™ªK¿ß‡ZºF§ÚùшTÔ¯p±ú‘߶¦E?d‹ö%ªW(áöU†ÆŽÓ'‹1é?û껌r‡ž—Ò1A¾®(‚ûÔ‘=”—A"q˜uÿ›opÂœÓû×ÈpÆã¥0ì8›¤RxæmÒ${AímÛP/:°îˆÂaÑ4Êh`úmÆ¿M1Ç"=CXñ‚In‡C ™à$œ´ÔÞÇÉä'ÎcQïƒÇâDu¨›–2#|¼r„ª:BÙªÆÑ=W¶[¹m0Œ§vÙ/„ª¿þçö8ÿòY÷ãúÿϳñ¯²	ìÿÿ°ÁÿpÿáÎöƒ¯ïÝÛÙyøÞvîñÿÿ->ÚÿŸ÷^
l?¼Ïèx_mïìnÿûî×´Û?{§‹—þÈ&ˆaa® ¾UÇ9§ë!òBœOùÚ4- ¯#7Õ¿x(¼S&Ÿ´×½¹Ÿ(õíûìšù»	øâÉÿÅ“ÿ_Í“ß8õ‚ü‘\_e9ÈÄ«žE*"¤üÝ‘¿÷äï}ø‹W…Âõþœ‰8"Kü¥äŽ¬'}ÐÏÎà+	ä$ääc:ï1à§öãvW¹JºXŽðPm‰fÐÜSø÷þ½„ûðïü;‚ÿÿþ³Ú‘ 3n„;ûæÛ®1ý,½õÿéû‹:x½˜ÕŽ'¥…[&TIvýÌ€§ï^à=é(,Ö²îýðÑ7E1³ .x˜›,YL€'XVqJÁÅœàR_*F·®î½<î´¿Úãë\ódö˜„õAx9Ei—Q¬(éÚR‹¿áöÇÓú·šižR/]if…sPãRn|rïŸâärÓ¹ûzï58ôÊë¹¾5Š˜ݽV‡Ïâ•iüMß¡†®ÿü ­éº+Ý—ÜPVBÑ.æ˃”-W!`ås&·áî,~õ0ôBO®\÷§«#;Ÿƒ¸JiØV®Ð'+úÛc]g8,ÔWÃa§÷	åÑBu¨î)Ƽ—nÌ°»PÕZNøðÒ1{—h'ÙÉÜ&çEÖ>5øŠâKÖ¨ªrîM$p¾õ©[gBÞéöÏî†óé]øC#”Ûb«‡3Ú%´EÌ鬭/Úz °Þªõ·pCÀÒP·éh‰$þÄœ…¡?0cCÒ‘Ó˜DÊÙ»Ê
‡CßöÜc>Yÿb.p~’ÙØ;>fiÎJ÷_ªG
ªöõ®®w¤$ýª h꫱t9nÛ/mˆÛ¯%Fº´£¬.â:ƒ³KÑý›é™-ž¼‚
ªrØ€qÎÂ>DTïpéÏ ×Y+£Whœ/	N¡ãõ9‡…° åsàü_	£"€’
 ›÷+ Tù£ºØ@¼)¦…Æµjšv›Ã«N‰M§…£m;)r+C¦$œvÕxZÞé:<É”:ž§qZÕºáäŒ=@Úßsþp™ )Ôï÷žD£Pžd£LùfT±~•"_€ùÊsr2儯ÔÓýïH‘²ÿú¹b›0Y1ž|ÐÄK#•É,»j›3Püh{§siALJ´ŠdhV—óíõ¸WÓlwi´èŽAžƒˆ•Îb1²ûq—é”öÓd÷«’GÚGT
jPìf=ë|£¡ŒFééDÃ[gè:§áû]ò™ØýðS4C(Hèô£ô;>E—WknõÙñûú¹Õ6|Eîë*.ùâÝu»T×)o1ž¾·zzfT+RÙ-sqq±ê0d¬U1²ÂñèÞÔþÓß*³qÖ/?•¿†u‰?Ëómoßýïáàþƒ”øÃ6üxðÅþ÷›|¥^¦ÉeæÚmµzèÚª^õæ›ð¿™šÅ—éY¬#Í°pÁWT ¹«Œ›ÛRøºÀ61b£¬xvjmš8Ì͈"FÆÎI§ŠF·Zè„îK¤Ç·ä·-Žj„ÎÞ[ÞÝ)yvUHb‰Öj&®Š­&/AtŽ¦§±ZÌR¾¥ØÒ1qÿ‚™ÿøÓשØÅ>Vøýÿ¾}€ùÿÛ_þ ¾þÇd>ÿâçßì5	ÿgìcýý¿÷àáàæ:ðeÿ‹Oãþ'åèsÁÀ-öÿÁ×÷¿ìÿoñYºÿ®ëÍ/†ìÿÃí{èÿõpçÞö—ýÿ->ëïÿÉœ2—Y6éÓ¢ÿi>]³Úÿ‡Mþ•ýßyð‡í{ƒ¯þßé÷·Ì8žtJC»ýHŸ/ûóý¿áŠßhÿñüßÛÞ¹÷p­ýÿe{Ÿ/ûÞòþ<}Ü„þï¶ÿ½}ÿþÿM>Ë÷ÿó0ëïÿýÁÃÁÒÿû;_øÿßäsƒý·¹*ñ¶·Ä	Üÿ?xûÿÞý‡ÿo®ÏÆyz™l¶0¥W±…»´¥®=¤­q6šçÙm“Ëž7æúåÕÑÙÿ›î¿8â¯ßÇMöÿáöÚÿ{¿ÖþWGÿeÿoºÿ7ÖºÑþ£þöõÿ¿ÊþWGÿeÿ×Ýÿ[‡‡­¿ÿBÿïooöóß4ú/ûÞÿùÅY:;Í>‡pþogç>òÿ_ï<üÂÿýŸ•ûÿjïõÁ‹ý£ã¾{®nÖnðƒû÷›ö¾óýO·>xðÊívî?øbÿý->}|«_o–•°ûñ8žÊ¥mèÐj(vô—ƒÃ¦wPru³ßÈm”·¬¾¢êJ1çVuu¬êmê
ƒr£ºLÜ–TYzšÿeß_>_>_>_>ÿŸÿüªÇ¸BioPerl-1.6.923/ide/bioperl-mode/dist/bioperl-mode.tar.md5000444000765000024         6312254227323 23231 0ustar00cjfieldsstaff00000000000082f272a7b044182e218753a0ccaa31ae *bioperl-mode.tar
BioPerl-1.6.923/ide/bioperl-mode/dist/Changes000555000765000024       147712254227315 21030 0ustar00cjfieldsstaff000000000000$Id$
07 Dec 2009 03:57:00 UTC
   - add parent/base class browse functionality to 
     source view too
06 Dec 2009 22:38:00 UTC
   - new feature : browse the pod of parent/base classes
     (press [B] or [P] in pod view)
04 Dec 2009 22:15:00 UTC
   - fixed a bug that led to borks when 'view-mode' not
     present in minor-mode-alist
   - little template tweak
15 Nov 2009 00:32:00 UTC
   - added bioperl-source-mode for source viewing
     'i' mapped to imenu in bioperl-source-mode
     'q' now quits and closes source viewer
   - when running 'bioperl-view-pod' (RETURN key) in pod
     view mode, the default completion namespace is the 
     namespace of the module that is currently being 
     viewed (rather than plain 'Bio::')
   - added a generic method pod template inserter, accessed 
     with C-c C-k or C-c C-g
   
BioPerl-1.6.923/ide/bioperl-mode/dist/package-me000555000765000024        74212254227325 21425 0ustar00cjfieldsstaff000000000000#!/bin/bash
#$Id$
tar -czvf bioperl-mode.tar  --directory=.. --exclude-tag-all=SKIP --exclude=#*.* --exclude=*.*~ --exclude=.svn --exclude=dist .
find -L ../xemacs -type f > ../xemacs/xemacs-packages/pkginfo/MANIFEST.bioperl-mode
tar -chzvf bioperl-mode-xemacs.tar  --directory=../xemacs --exclude-tag-all=SKIP --exclude=#*.* --exclude=*.*~ --exclude=.svn --exclude=dist .
md5sum bioperl-mode.tar > bioperl-mode.tar.md5
md5sum bioperl-mode-xemacs.tar > bioperl-mode-xemacs.tar.md5

BioPerl-1.6.923/ide/bioperl-mode/dist/SKIP000444000765000024          012254227321 20115 0ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl-mode/etc000755000765000024          012254227337 17200 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl-mode/etc/images000755000765000024          012254227337 20445 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl-mode/etc/images/bpmode-tool-dis.xpm000555000765000024       411112254227337 24326 0ustar00cjfieldsstaff000000000000/* XPM */
static char * bpmode_tool_dis_xpm[] = {
"24 24 85 1",
" 	c None",
".	c #555555",
"+	c #A9A9A9",
"@	c #AAAAAA",
"#	c #A3A3A3",
"$	c #9A9A9A",
"%	c #ABABAB",
"&	c #ACACAC",
"*	c #A8A8A8",
"=	c #A7A7A7",
"-	c #A6A6A6",
";	c #A5A5A5",
">	c #9E9E9E",
",	c #383838",
"'	c #484848",
")	c #454545",
"!	c #1B1B1B",
"~	c #9B9B9B",
"{	c #A4A4A4",
"]	c #A2A2A2",
"^	c #A1A1A1",
"/	c #959595",
"(	c #1A1A1A",
"_	c #858585",
":	c #717171",
"<	c #505050",
"[	c #A0A0A0",
"}	c #818181",
"|	c #262626",
"1	c #878787",
"2	c #727272",
"3	c #545454",
"4	c #767676",
"5	c #4C4C4C",
"6	c #141414",
"7	c #9F9F9F",
"8	c #797979",
"9	c #0D0D0D",
"0	c #181818",
"a	c #4D4D4D",
"b	c #7D7D7D",
"c	c #494949",
"d	c #252525",
"e	c #9D9D9D",
"f	c #7B7B7B",
"g	c #0E0E0E",
"h	c #737373",
"i	c #242424",
"j	c #6A6A6A",
"k	c #8C8C8C",
"l	c #7F7F7F",
"m	c #616161",
"n	c #313131",
"o	c #202020",
"p	c #0F0F0F",
"q	c #343434",
"r	c #6E6E6E",
"s	c #828282",
"t	c #9C9C9C",
"u	c #999999",
"v	c #989898",
"w	c #222222",
"x	c #585858",
"y	c #5E5E5E",
"z	c #969696",
"A	c #888888",
"B	c #626262",
"C	c #434343",
"D	c #939393",
"E	c #979797",
"F	c #4F4F4F",
"G	c #272727",
"H	c #949494",
"I	c #8D8D8D",
"J	c #929292",
"K	c #686868",
"L	c #868686",
"M	c #5D5D5D",
"N	c #919191",
"O	c #8E8E8E",
"P	c #7A7A7A",
"Q	c #8F8F8F",
"R	c #676767",
"S	c #8A8A8A",
"T	c #909090",
"                        ",
"                        ",
"  ....................  ",
"  .++++@@@#$@%%&%*=-;.  ",
"  .*+@@@@>,'@@%@=-;##.  ",
"  .+++@@@)!~%%@-=;{]^.  ",
"  .@++@@/(_@-;:<;{]^[.  ",
"  .@+@@@}|123456{][77.  ",
"  .@++@@890ab7cd][7>e.  ",
"  .@@@@@fgh#=-ij[7>~~.  ",
"  .%%%@%_|kl:mn[7e~$$.  ",
"  .@@@%%~opqr,s7>t$uv.  ",
"  .%+%%@*'w>xy7>t$vzz.  ",
"  .%%%@*-A9BCDe~$vEz/.  ",
"  .@%@*=-{FGAet~vzzHD.  ",
"  .&@*=;{z3FI~~uz//JJ.  ",
"  .%*-;{vKbLMkvEzHJNN.  ",
"  .+=;#]EOePw/yRjxSJNQOT.  ",
"  .-#^[[>~$/z/82QOOOQ.  ",
"  .-#^[7e~$vzHHJTQQQN.  ",
"  ....................  ",
"                        ",
"                        "};
BioPerl-1.6.923/ide/bioperl-mode/etc/images/bpmode-tool.xpm000555000765000024      1371612254227337 23604 0ustar00cjfieldsstaff000000000000/* XPM */
static char * bpmode_tool_xpm[] = {
"24 24 280 2",
"  	c None",
". 	c #000000",
"+ 	c #9DFB57",
"@ 	c #9AF85A",
"# 	c #96F65C",
"$ 	c #93F45F",
"% 	c #90F262",
"& 	c #8EEF66",
"* 	c #8CED68",
"= 	c #84E166",
"- 	c #7AD262",
"; 	c #83E371",
"> 	c #83E274",
", 	c #7FE176",
"' 	c #7CDE7A",
") 	c #7ADC7D",
"! 	c #77DA80",
"~ 	c #76D984",
"{ 	c #76D787",
"] 	c #74D78C",
"^ 	c #99F859",
"/ 	c #96F65D",
"( 	c #93F460",
"_ 	c #92F262",
": 	c #8EEF65",
"< 	c #8BEC68",
"[ 	c #7FDA62",
"} 	c #2C4D24",
"| 	c #386030",
"1 	c #81E173",
"2 	c #7FDF75",
"3 	c #7DDD79",
"4 	c #7ADB7D",
"5 	c #76D980",
"6 	c #75D884",
"7 	c #74D788",
"8 	c #73D38A",
"9 	c #72D48F",
"0 	c #97F65D",
"a 	c #93F360",
"b 	c #90F062",
"c 	c #8DEC69",
"d 	c #89E96B",
"e 	c #365E2C",
"f 	c #152412",
"g 	c #75CE68",
"h 	c #7FDF77",
"i 	c #7ADA7C",
"j 	c #75D77D",
"k 	c #75D984",
"l 	c #73D58C",
"m 	c #71D38F",
"n 	c #6ED494",
"o 	c #90F162",
"p 	c #8EEE65",
"q 	c #89EA6B",
"r 	c #76CA60",
"s 	c #142311",
"t 	c #64B05A",
"u 	c #7EDF76",
"v 	c #79D776",
"w 	c #76D477",
"x 	c #509356",
"y 	c #38683F",
"z 	c #74D787",
"A 	c #73D58B",
"B 	c #71D48F",
"C 	c #6FD393",
"D 	c #6FD299",
"E 	c #91F163",
"F 	c #8CEB69",
"G 	c #87E86D",
"H 	c #64AD55",
"I 	c #1D331A",
"J 	c #64B15E",
"K 	c #529450",
"L 	c #3C6D3D",
"M 	c #549959",
"N 	c #35633C",
"O 	c #0E1A10",
"P 	c #71D38E",
"Q 	c #6FD293",
"R 	c #6ED197",
"S 	c #6ED09D",
"T 	c #8FEE66",
"U 	c #8CEB68",
"V 	c #89E96A",
"W 	c #86E76D",
"X 	c #85E471",
"Y 	c #5CA052",
"Z 	c #0A1209",
"` 	c #112011",
" .	c #376338",
"..	c #59A25F",
"+.	c #70CE7E",
"@.	c #335F3C",
"#.	c #1A3120",
"$.	c #6FD192",
"%.	c #6ED097",
"&.	c #6DCF9C",
"*.	c #6BCFA0",
"=.	c #8AE96B",
"-.	c #86E86D",
";.	c #84E470",
">.	c #82E173",
",.	c #5CA255",
"'.	c #0B130A",
").	c #529454",
"!.	c #74D37C",
"~.	c #76D983",
"{.	c #75D889",
"].	c #19301F",
"^.	c #4A8A5C",
"/.	c #6FD292",
"(.	c #6DCF9B",
"_.	c #6ACD9F",
":.	c #69CEA4",
"<.	c #8BEA6C",
"[.	c #87E76F",
"}.	c #85E472",
"|.	c #82E273",
"1.	c #7EE076",
"2.	c #61AD5E",
"3.	c #1B311C",
"4.	c #63B66B",
"5.	c #59A663",
"6.	c #50925D",
"7.	c #447E52",
"8.	c #22402B",
"9.	c #6DD197",
"0.	c #6CCF9C",
"a.	c #68CCA2",
"b.	c #68CDA9",
"c.	c #88E86D",
"d.	c #83E470",
"e.	c #81E272",
"f.	c #80E076",
"g.	c #6FC872",
"h.	c #172A19",
"i.	c #0B140C",
"j.	c #24442B",
"k.	c #4E8F5D",
"l.	c #274931",
"m.	c #5AAB76",
"n.	c #6DD298",
"o.	c #6CD09C",
"p.	c #6ACE9F",
"q.	c #68CCA4",
"r.	c #67CBA7",
"s.	c #67CAAB",
"t.	c #87E571",
"u.	c #82E172",
"v.	c #7CDD79",
"w.	c #7ADB7C",
"x.	c #77D980",
"y.	c #335E39",
"z.	c #182C1C",
"A.	c #6FCD86",
"B.	c #3E734D",
"C.	c #417B55",
"D.	c #6FD097",
"E.	c #68CCA3",
"F.	c #67CAA8",
"G.	c #64C8AB",
"H.	c #63C9AF",
"I.	c #83E473",
"J.	c #7FE076",
"K.	c #7DDD7A",
"L.	c #77D97F",
"M.	c #60B171",
"N.	c #09110B",
"O.	c #448056",
"P.	c #2F583E",
"Q.	c #66C08B",
"R.	c #6CCF9B",
"S.	c #6ACD9E",
"T.	c #67CAA7",
"U.	c #65C9AA",
"V.	c #63C9AE",
"W.	c #62C9B3",
"X.	c #7FE075",
"Y.	c #7CDE79",
"Z.	c #77DA7F",
"`.	c #74D888",
" +	c #74D58B",
".+	c #376845",
"++	c #1B3424",
"@+	c #5EB280",
"#+	c #6BCD9C",
"$+	c #69CDA3",
"%+	c #64C9AB",
"&+	c #63C9AD",
"*+	c #62C7B1",
"=+	c #60C7B9",
"-+	c #7DDF7A",
";+	c #79DB7D",
">+	c #76D882",
",+	c #69C483",
"'+	c #3A6E4D",
")+	c #36684C",
"!+	c #61B98B",
"~+	c #69CDA1",
"{+	c #67CBA6",
"]+	c #63C8AE",
"^+	c #62C8B2",
"/+	c #60C5B6",
"(+	c #5EC6BD",
"_+	c #78D97F",
":+	c #75D783",
"<+	c #74D687",
"[+	c #6AC786",
"}+	c #48885F",
"|+	c #57A376",
"1+	c #5CB085",
"2+	c #3F7B5F",
"3+	c #5FBA94",
"4+	c #65C9A9",
"5+	c #64C8AE",
"6+	c #62C6B2",
"7+	c #60C5B7",
"8+	c #5EC4BB",
"9+	c #5CC7C1",
"0+	c #78DB7F",
"a+	c #76D883",
"b+	c #73D48B",
"c+	c #69C689",
"d+	c #63BA87",
"e+	c #6DCE9B",
"f+	c #53A17C",
"g+	c #172D24",
"h+	c #366B59",
"i+	c #5FBEA2",
"j+	c #5DC5BB",
"k+	c #5AC5C0",
"l+	c #58C6C7",
"m+	c #73D687",
"n+	c #71D48E",
"o+	c #6ED196",
"p+	c #66C498",
"q+	c #407D64",
"r+	c #458971",
"s+	c #478D78",
"t+	c #3A7667",
"u+	c #5BB9A6",
"v+	c #5AC5C1",
"w+	c #57C5C5",
"x+	c #55C3CB",
"y+	c #75D787",
"z+	c #72D48A",
"A+	c #71D28E",
"B+	c #6FD197",
"C+	c #6ECE99",
"D+	c #6ACD9D",
"E+	c #69CCA0",
"F+	c #64C7A3",
"G+	c #62C8AE",
"H+	c #50A392",
"I+	c #4A9A8D",
"J+	c #5BC4B9",
"K+	c #59C4C0",
"L+	c #57C4C6",
"M+	c #55C1C8",
"N+	c #52C0CD",
"O+	c #74D88D",
"P+	c #72D58F",
"Q+	c #70D393",
"R+	c #6FD298",
"S+	c #6ED19D",
"T+	c #6BD0A1",
"U+	c #69CEA5",
"V+	c #66CAAB",
"W+	c #63C9B0",
"X+	c #61C7B4",
"Y+	c #61C7B8",
"Z+	c #5CC8BC",
"`+	c #5AC6C2",
" @	c #58C5C7",
".@	c #54C4CB",
"+@	c #50C2CE",
"@@	c #50C0D2",
"                                                ",
"                                                ",
"    . . . . . . . . . . . . . . . . . . . .     ",
"    . + @ # $ % & * = - ; > , ' ) ! ~ { ] .     ",
"    . ^ / ( _ : < [ } | 1 2 3 4 5 6 7 8 9 .     ",
"    . 0 a b : c d e f g h 3 i j k 7 l m n .     ",
"    . ( o p < q r s t u v w x y z A B C D .     ",
"    . E p F q G H I J K L M N O A P Q R S .     ",
"    . T U V W X Y Z `  ...+.@.#.P $.%.&.*..     ",
"    . c =.-.;.>.,.'.).!.~.{.].^./.%.(._.:..     ",
"    . <.[.}.|.1.2.3.4.5.6.7.8.Q 9.0._.a.b..     ",
"    . c.d.e.f.3 g.h.i.j.k.l.m.n.o.p.q.r.s..     ",
"    . t.u.1.v.w.x.y.z.A.B.C.D.(.p.E.F.G.H..     ",
"    . I.J.K.w.L.6 M.N.O.P.Q.R.S.q.T.U.V.W..     ",
"    . X.Y.w.Z.k `. +.+++@+0.#+$+F.%+&+*+=+.     ",
"    . -+;+x.>+z A ,+'+)+!+_.~+{+%+]+^+/+(+.     ",
"    . ) _+:+<+A [+}+|+1+2+3+T.4+5+6+7+8+9+.     ",
"    . 0+a+<+b+P c+d+e+f+g+h+i+5+6+/+j+k+l+.     ",
"    . ~.m+l n+/.o+(.p+q+r+s+t+u+/+j+v+w+x+.     ",
"    . y+z+A+Q B+C+D+E+F+G.G+H+I+J+K+L+M+N+.     ",
"    . O+P+Q+R+S+T+U+b.V+W+X+Y+Z+`+ @.@+@@@.     ",
"    . . . . . . . . . . . . . . . . . . . .     ",
"                                                ",
"                                                "};
BioPerl-1.6.923/ide/bioperl-mode/site-lisp000755000765000024          012254227335 20334 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/ide/bioperl-mode/site-lisp/bioperl-init.el000555000765000024      3536412254227313 23442 0ustar00cjfieldsstaff000000000000;; $Id$

;;
;; Init functions for Bioperl minor mode
;; 
;; Author: Mark A. Jensen
;; Email : maj -at- fortinbras -dot- us
;;
;; Part of The Documentation Project
;; http://www.bioperl.org/wiki/The_Documentation_Project
;;
;;

;; Copyright (C) 2009 Mark A. Jensen

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.  See the GNU General Public License for more details.

;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA


(defconst bioperl-init-revision "$Id$"
  "The revision string of bioperl-init.el")


;;
;; menu bar keymaps
;;

(defvar menu-bar-bioperl-doc-menu
  (let (
	(map (make-sparse-keymap "BioPerl Docs"))
	)
    (define-key map [bp-pod-apx]
      '(menu-item "View appendix" bioperl-view-pod-appendix
		  :help "View pod APPENDIX of a module (where most methods are described)"
		  :keys "\\[bioperl-view-pod-appendix]"))
    (define-key map [bp-pod-dsc]
      '(menu-item "View description" bioperl-view-pod-description
		  :help "View pod DESCRIPTION of a module"
		  :keys "\\[bioperl-view-pod-description]"))
    (define-key map [bp-pod-syn]
      '(menu-item "View synopsis" bioperl-view-pod-synopsis
		  :help "View pod SYNOPSIS of a module"
		  :keys "\\[bioperl-view-pod-synopsis]"))
    (define-key map [bp-pod]
      '(menu-item "View pod" bioperl-view-pod
		  :help "Examine entire pod of a module"
		  :keys "\\[bioperl-view-pod]"))
    (define-key map [bp-pod-mth]
      '(menu-item "View method pod" bioperl-view-pod-method
		  :help "View pod (Title:, Usage:, etc) for a single method"
		  :keys "\\[bioperl-view-pod-method]"))
    map)
  "Menu-bar map for doc functions in bioperl-mode.")


(defvar menu-bar-bioperl-ins-menu
  (let (
	(map (make-sparse-keymap "BioPerl Ins"))
	)
    (define-key map [bp-ins-arr]
      '(menu-item "Insert container template" bioperl-insert-array-accessor
		  :help "Insert template functions for an object array"
		  :keys "\\[bioperl-insert-array-accessor]"))
    (define-key map [bp-ins-obj]
      '(menu-item "Insert class/object template" bioperl-insert-class
		  :help "Insert full object template plus std pod"
		  :keys "\\[bioperl-insert-class]"))
    (define-key map [bp-ins-mthpod]
      '(menu-item "Insert method pod template" bioperl-insert-method-pod
		  :help "Insert Bioperl standard method pod template"
		  :keys "\\[bioperl-insert-method-pod]"))
    (define-key map [bp-ins-genpod]
      '(menu-item "Insert generic class pod template" bioperl-insert-generic-class
		  :help "Insert package declaration plus std pod"
		  :keys "\\[bioperl-insert-generic-class]"))
    (define-key map [bp-ins-acc]
      '(menu-item "Insert accessor template" bioperl-insert-accessor
		  :help "Insert accessor (getter/setter) with std pod"
		  :keys "\\[bioperl-insert-accessor]"))
    (define-key map [bp-ins-mod]
      '(menu-item "Insert module identifier" bioperl-insert-module
		  :help "Insert module identifier, with completion"
		  :keys "\\[bioperl-insert-module]"))
    map)
  "Menu-bar map for insertion functions in bioperl-mode")

;;
;; keymap
;;
;; principles: 
;; C-c accesses mode functions
;; meta key commands - documentation reading (pod display, etc.)
;; control key command - documentation writing (template insertions, etc.)
;;


(defvar bioperl-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-c\M-p" 'bioperl-view-pod)
    (define-key map "\C-c\M-d" 'bioperl-view-pod-description)
    (define-key map "\C-c\M-s" 'bioperl-view-pod-synopsis)
    (define-key map "\C-c\M-a" 'bioperl-view-pod-appendix)
    (define-key map "\C-c\M-f" 'bioperl-view-pod-method)
    (define-key map "\C-c\M-m" 'bioperl-view-pod-method)
    (define-key map "\C-cm"   'bioperl-insert-module)
    (define-key map "\C-c\C-a" 'bioperl-insert-accessor)
    (define-key map "\C-c\C-v" 'bioperl-insert-accessor)
    (define-key map "\C-c\C-A" 'bioperl-insert-array-accessor)
    (define-key map "\C-c\C-b" 'bioperl-insert-class)
    (define-key map "\C-c\C-M" 'bioperl-insert-class)
    (define-key map "\C-c\C-k" 'bioperl-insert-generic-class)
    (define-key map "\C-c\C-g" 'bioperl-insert-generic-class)
    (define-key map "\C-c\C-p" 'bioperl-insert-method-pod)
    (define-key map [menu-bar] nil)
    (define-key map [menu-bar bp-ins]
      (list 'menu-item "BP Templs" menu-bar-bioperl-ins-menu))
    (define-key map [menu-bar bp-doc] 
      (list 'menu-item "BP Docs" menu-bar-bioperl-doc-menu))
    map)
  "Keymap for Bioperl minor mode")

;;
;; finders
;;


(defun bioperl-find-module-path (&optional symb val)
  "Find path to Bioperl modules and set `bioperl-module-path'.
This path points to the directory containing Bio; same principle
as 'use lib'. SYMB and VAL are dummies allowing `defcustom' to do
initializaton."
  (let (
	(old-exec-path exec-path) 
	(pth) )
    ;; ask BPMODE_PATH first...
    (setq pth (getenv "BPMODE_PATH"))
    ;; try the environment
    (unless pth
      (let (
	    ( plib (concat (getenv "PERL5LIB") path-separator (getenv "PATH")))
	    ( pths )
	    )
	(if plib
	  (progn
	    (setq pths (split-string plib path-separator))
	    (while (and (not pth) pths)
	    ;; unixize
;;	    (setq pth (replace-regexp-in-string "\\\\" "/" pth))
	      (setq pth (pop pths))
	      (setq pth (if (file-exists-p (concat pth "/" "Bio")) pth nil)))
	    ))))
    ;; then ask Perl...
    (unless pth 
      ;; safe path
      (if (or (not (boundp 'bioperl-mode-safe-flag))
	      bioperl-mode-safe-flag)
	  (setq exec-path bioperl-safe-PATH))
      
      (setq pth
	    (with-temp-buffer
	      (call-process 
	       "perl" nil t t
	       "-MConfig" "-e" "print $Config{sitelib}")
	      (goto-char (point-min))
	      (thing-at-point 'line)
	      ))
      ;; reset exec-path
      (setq exec-path old-exec-path)
      ;; file name port issue - unixize
      (setq pth (replace-regexp-in-string "\\\\" "/" pth))
      (setq pth (if (file-exists-p (concat pth "/" "Bio")) pth nil)))
    ;; fall back to pwd
    (unless pth
      (setq pth (nth 1 (split-string (pwd))))
      ;; unixize
      (setq pth (replace-regexp-in-string "\\\\" "/" pth))
      (setq pth (if (file-exists-p (concat pth "/" "Bio")) pth nil))
      )
    (if pth
	(setq bioperl-module-path pth)
      (message "Can't find Bio modules; defaulting to pwd -- try setting bioperl-module-path manually")
      (setq bioperl-module-path "."))
  pth))

(defun bioperl-set-safe-PATH (&optional symb val)
  "Portably sets the safe-PATH, used when bioperl-mode calls the system.
SYMB and VAL are dummies allowing defcustom to do
initialization."
  (cond
   ( (string-match "windows\\|mingw\\|nt" system-configuration)
     (setq bioperl-safe-PATH '("c:/Perl/bin" "c:/Windows/system32")) )
   ( (string-match "unix\\|linux" system-configuration)
     (setq bioperl-safe-PATH '("/bin" "/usr/bin" "/usr/local/bin")) )
   ( (string-match "cygwin" system-configuration)
     (setq bioperl-safe-PATH '("/bin" "/usr/local/bin" 
			       "/cygdrive/c/Windows/system32") ) )
   ( t
     (setq bioperl-safe-PATH '()))))

(defvar bioperl-enabled-buffer-flag nil
  "Buffer-local flag for enabling/disabling the bioperl-mode toolbar icon.")

(make-local-variable 'bioperl-enabled-buffer-flag)

;;
;; minor mode definition functions
;;

(define-minor-mode bioperl-mode
  "Toggles Bioperl minor mode.
Bioperl mode provides Bioperl-flavored template insertion and
convenient access to POD documentation. More documentation to
come."
  :init-value nil
  :lighter "[bio]"
  :keymap bioperl-mode-map
  :group 'bioperl
  ;; version check
  (if (string-match "\\(2[0-9]\\)\.[0-9]+\\(?:\.[0-9]+\\)?" (emacs-version))
      (if (or (string-match "^XEmacs" (emacs-version))
              (>= (string-to-number (match-string 1 (emacs-version))) 22))
	  t
	(error "Must upgrade to XEmacs 22 to use bioperl-mode"))
    (error "Must upgrade to Emacs 22 to use bioperl-mode"))
  ;; set up mode
  (bioperl-skel-elements))

(define-minor-mode bioperl-view-mode 
  "A derived view mode for bioperl pod."
  :init-value nil
  :lighter "[bio]"
  :keymap ( let* (
		  (vmap (cdr (assoc 'view-mode minor-mode-map-alist)))
		  (map (if vmap (copy-keymap vmap) (make-sparse-keymap)  ))
		  )
	    (if map
		(progn
		  (define-key map [menu-bar] nil)
		  (define-key map [menu-bar bp-doc] (list 'menu-item "BP Docs" menu-bar-bioperl-doc-menu))
		  (define-key map "q" 'View-kill-and-leave)
		  (define-key map "f" 'bioperl-view-source)
		  (define-key map "P" 'bioperl-view-parents)
		  (define-key map "B" 'bioperl-view-parents)
		  (define-key map "\C-m" 'bioperl-view-pod)
		  (define-key map "\C-\M-m" 'bioperl-view-pod-method)))
	    map )
  ;; and now, a total kludge.
    (view-mode))

(define-minor-mode bioperl-source-mode 
  "A derived view mode for bioperl source code."
  :init-value nil
  :lighter "[bio]"
  :keymap ( let ( (map (copy-keymap (cdr (assoc 'view-mode minor-mode-map-alist)))) )
	    (if map
		(progn
		  (define-key map [menu-bar] nil)
		  (define-key map [menu-bar bp-doc] (list 'menu-item "BP Docs" menu-bar-bioperl-doc-menu))
		  (define-key map "q" 'View-kill-and-leave)
		  (define-key map "g" 'goto-line)
		  (define-key map "i" 'imenu)
		  (define-key map "P" 'bioperl-view-parents-this-buffer)
		  (define-key map "B" 'bioperl-view-parents-this-buffer)
		  (define-key map "\C-m" 'bioperl-view-pod)
		  (define-key map "\C-\M-m" 'bioperl-view-pod-method)))
	    map )
  ;; and now, a total kludge.
    (view-mode))

(defface pod-section-face
  '( (t (:weight bold :foreground "maroon3") ) )
  "Highlight for pod section names.")
(defvar pod-section-face 'pod-section-face)

(defface pod-bioperl-identifier-face
  '( (t (:foreground "blue3" :weight bold)))
  "Highlight for bioperl identifiers")
(defvar pod-bioperl-identifier-face 'pod-bioperl-identifier-face)

(defface pod-method-pod-tag-face
  '( (t (:foreground "blue4")) )
  "Highlight for method pod tags (Title, Usage, etc.)")
(defvar pod-method-pod-tag-face 'pod-method-pod-tag-face)

(defface pod-blue-man-face
  '( (t (:background "blue" :foreground "dark blue")))
  "My world is blue.")
(defvar pod-blue-man-face 'pod-blue-man-face)

(defface pod-subsec-header-face
  '( (t (:weight bold :slant italic :foreground "blue4")))
  "Highlight pod subsection headers")
(defvar pod-subsec-header-face 'pod-subsec-header-face)

(defface pod-method-subsec-face
  '( (t (:slant italic :foreground "maroon4")))
  "Highlight for APPENDIX subsections")
(defvar pod-method-subsec-face 'pod-method-subsec-face)

(defface pod-method-name-face
  '( (t (:weight bold) ) )
  "Highlight pod method names")
(defvar pod-method-name-face 'pod-method-name-face)

(defface pod-key-value-arg-face
  '( (t (:slant italic :foreground "green3")) )
  "Highlight for key-value keys (-something)" )
(defvar pod-key-value-arg-face 'pod-key-value-arg-face)

(defface pod-deref-symb-face
  '( (t (:weight bold :foreground "blue4")))
  "Highlight '->' ")
(defvar pod-deref-symb-face 'pod-deref-symb-face)

(defface pod-assoc-symb-face
  '( (t (:weight bold :foreground "green3")))
  "Highlight '=>' ")
(defvar pod-assoc-symb-face 'pod-assoc-symb-face)

(defvar bioperl-pod-font-lock-keywords
  '( 
    ;; rudimentary perl syntax highlighting
    ("[%$][{]?\\([a-zA-Z0-9_]+\\)[}]?" 1 font-lock-variable-name-face)
    ("[^a-zA-Z0-9]@[{]?\\([a-zA-Z0-9_]+\\)[}]?" 1 font-lock-variable-name-face)
    ("\\>->\\<" . pod-deref-symb-face)
    ("\\(?:\\s \\|\\>\\)\\(=>\\)\\(?:\\s \\|\\<\\|[\'\"]\\)" 1 pod-assoc-symb-face)
    ("\\(?:\\W\\|\\s \\)\\(-[a-zA-Z0-9_]+\\)\\>" 1 pod-key-value-arg-face)
;    ("'[^']+'" . 'font-lock-string-face)
    (pod-find-syntactic-string 1 font-lock-string-face)
    ("\#\\s +.*"  0 font-lock-comment-face t)
    ;; headers
    ("^\\(?:[A-Z]+\\s \\)+" . pod-section-face )
    ("^\\s \\{2\\}\\([A-Z][a-z]+\\s \\)+" . (0 pod-subsec-header-face))
    ("^\\s \\{2\\}[a-z_][a-zA-Z0-9_()]+\\s " . pod-method-name-face)
    ("^\\s +[a-zA-Z]+\\s *:\\s " . pod-method-pod-tag-face)
    ("^[A-Z].*" . pod-method-subsec-face)
    ("Bio::\\(?:[a-zA-Z0-9_:]+\\)+" . pod-bioperl-identifier-face) 
    ;; post-header syntax highlights
    ("\\(\\<[a-zA-Z0-9_]+\\>\\)()" 0 font-lock-function-name-face )
    ("\\(\\<[a-zA-Z0-9_]+\\>\\)[\(]" 1 font-lock-function-name-face )
    ("\\>->\\(\\<[a-zA-Z0-9_]+\\>\\)" 1 font-lock-function-name-face)

     )
  "Font lock keywords for highlighting Perl pod."
)

(defconst bioperl-pod-font-lock-defaults
  '(bioperl-pod-font-lock-keywords t nil nil ))

(define-derived-mode pod-mode fundamental-mode "Pod Fundamental"
  "Derived fundamental mode for highlighting BioPerl pod."
  :group 'bioperl
  :syntax-table nil
  :abbrev-table nil
  (set (make-local-variable 'font-lock-defaults)
       bioperl-pod-font-lock-defaults))

(defun pod-find-syntactic-string (bound)
  "String searcher for bioperl-mode font-lock."
  ;; try to infer from symbol context
  (re-search-forward "\\(?:[$@%(),]\\|->\\|=>\\|print\\).*?\\(['][^']+[']\\|[\"][^\"]+[\"]\\)" bound t))

(defun bioperl-pod-synopsis-region (buffer)
  "Return beginning & end of SYNOPSIS region (excluding the header)."
  (unless (bufferp buffer)
    (error "Buffer required at arg BUFFER"))
  (save-excursion
    (goto-char (point-min))
    (let ( (beg) (end) )
      (setq beg 
	    (if (re-search-forward "^SYNOPSIS" (point-max) t)
		(progn (forward-line 1) (if (bolp) (point) nil))
	      nil))
      (setq end
	    (if (re-search-forward "^[A-Z]" (point-max) t)
		(progn (beginning-of-line) (if (bolp) (point) nil))
	    nil))
      (if (not (and beg end))
	  nil
	`(,beg ,end)))))
	  

(defun bioperl-perl-mode-infect ()
  "Add this function to `perl-mode-hook' to associate bioperl-mode with perl-mode."
  (unless (or (key-binding [tool-bar bpmode]) bioperl-this-is-xemacs (not (display-graphic-p)) )
    (define-key (current-local-map) [tool-bar bpmode]
      `(menu-item "bpmode" bioperl-mode 
		  :image [,(find-image (list 
					'(:type xpm :file "bpmode-tool.xpm")))
			  ,(find-image (list 
					'(:type xpm :file "bpmode-tool.xpm")))
			  ,(find-image (list 
					'(:type xpm :file "bpmode-tool-dis.xpm")))
			  ,(find-image (list 
					'(:type xpm :file "bpmode-tool-dis.xpm")))]
		  :enable bioperl-enabled-buffer-flag
		  )))
  ;; do something else in XEmacs...
  (if bioperl-this-is-xemacs 1 0)
  (setq bioperl-enabled-buffer-flag t)
  (if bioperl-mode-active-on-perl-mode-flag (bioperl-mode) nil))

;; where are you, subr.el?

(unless (boundp 'booleanp)
  (defun booleanp (x)
    "Is it boolean? Let's find out."
    (if (or (equal x t) (equal x nil))
	t
      nil)))

(provide 'bioperl-init)

;;; end bioperl-init.elBioPerl-1.6.923/ide/bioperl-mode/site-lisp/bioperl-mode.el000555000765000024     14625412254227312 23443 0ustar00cjfieldsstaff000000000000;; $Id$

;; use multiple paths in bioperl-module-path

;;
;; Bioperl minor (haha!) mode
;; 
;; Author: Mark A. Jensen
;; Email : maj -at- fortinbras -dot- us
;;
;; Part of The Documentation Project
;; http://www.bioperl.org/wiki/The_Documentation_Project

;; Copyright (C) 2009 Mark A. Jensen

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.  See the GNU General Public License for more details.

;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;
;;
;; TODOs
;;
;;  - compile to byte code
;;
;; issues
;; - missing tool in tool-bar??
;; - xemacs support?
;;
;; Installation
;;
;;  The files bioperl-mode.el, bioperl-skel.el, and bioperl-init.el
;;  should be placed in $EMACS_ROOT/site-lisp, and the .xpm image
;;  files in $EMACS_ROOT/etc/images, then add
;;  (require 'bioperl-mode)
;;  to your .emacs file.
;;
;;  See http://www.bioperl.org/wiki/Emacs_bioperl-mode
;;  for more information.
;;
;; Design Notes
;; 
;; POD content is obtained exclusively by accessing the user's installed
;; Bioperl modules -- so it's as up-to-date as the user's installation.
;;
;; Pod is parsed with a homebrew parser found in pod.el.
;;
;; Much of the parsing in this package depends on the standard form of
;; Bioperl pod; particularly on the typical division into NAME,
;; SYNOPSIS, DESCRIPTION, and APPENDIX sections, and on the fact that
;; pod for individual methods is found in the APPENDIX. There is some
;; dependence on the usual head levels for the headers, but this can
;; be hacked out if necessary.
;;
;; Some attempts at efficiency were made. Parsing pod for methods
;; and associated data can take a while, so parse results are cached
;; for the last module so parsed, and the cache is checked when 
;; method information is requested before parsing again.
;;
;; The Bio/ path is parsed to provide a namespace completion facility
;; The relevant path names and structure is stored in an alist tree
;; called bioperl-module-names-cache. The cache is loaded lazily,
;; so that the directory structure is accessed on a desire-to-know 
;; basis.
;;
;; Lazy loading of the name cache necessitated "programmed completion"
;; of namespace names in prompts. See Programmed Completion in the 
;; info (elisp) node, and the function 
;; bioperl-namespace-completion-function.
;;
;; Skeletons (implemented in the emacs standard package skeleton.el)
;; have been used for template insertions. These are very powerful, if
;; cumbersome, offer plug-in interactor functions, and I think allow
;; more modularity and scope for new additions than (insert)ing text
;; 'by hand'. Skeletons and (define-skeleton) declarations are
;; distributed in a separate file 'bioperl-skel.el', which is loaded
;; when the mode is initialized.
;;                                                                        

(require 'skeleton)
(require 'bioperl-skel)
(require 'bioperl-init)
(require 'pod)

(defconst bioperl-mode-revision "$Id$"
  "The revision string of bioperl-mode.el")

;;
;; User customizations
;;

(defgroup bioperl nil
  "BioPerl templates and documentation access")

(defcustom bioperl-mode-active-on-perl-mode-flag t
  "If set, perl-mode will begin with bioperl-mode active.
Boolean."
  :type 'boolean
  :group 'bioperl)

(defcustom bioperl-mode-safe-flag t
  "If set, bioperl-mode with substitute `exec-path' with `bioperl-safe-PATH'.
Nil means use your current `exec-path'."
  :type 'boolean
  :group 'bioperl)

(defcustom bioperl-safe-PATH '()
  "Safe exec-path for bioperl-mode."
  :type 'sexp
  :initialize 'bioperl-set-safe-PATH
  :group 'bioperl)

(defcustom bioperl-module-path nil
  "Local path to Bioperl modules.
On init, set is attempted by `bioperl-find-module-path' Can indicate multiple search paths; define as PATH in your OS. The environment variable BPMODE_PATH will override everything."
;; better type 'choice; do later
  :type 'string
  :initialize 'bioperl-find-module-path
  :group 'bioperl)

;;
;; Hooks
;;

;;
;; bioperl- namespace variables
;;

(defvar bioperl-method-pod-cache nil
  "Stores the alist returned by the last successful `bioperl-slurp-methods-from-pod' call.
The module filepath represented by the cached info is contained
in `bioperl-cached-module'.")

(defvar bioperl-cached-module nil
  "Contains the module name whose method pod information is
  currently stored in `bioperl-method-pod-cache'.
The value is in double colon format.")

(defvar bioperl-cached-pmfile nil
  "Contains the filepath whose method pod information is
  currently stored in `bioperl-method-pod-cache'.")

(defvar bioperl-module-names-cache '( ("Bio" . nil) )
  "Storage for an alist tree structure of available module names.
Structure follows the Bio library tree:
 ( (\"Bio\" \"Seq\" ( \"SeqIO\" \"fasta\" \"msf\" ...) \"PrimarySeqI\" ...  ) )
Use `bioperl-add-module-names-to-cache' to, well, do it.")

(defvar bioperl-source-file nil
  "Contains the source file of pod being viewed. Buffer-local.
Set in `bioperl-view-full-pod'")

(make-variable-buffer-local 'bioperl-source-file)

(defvar bioperl-source-file-path-component nil
  "Contains the path index (from `bioperl-module-path') for the source file of pod being viewed. Buffer-local.
Set in `bioperl-view-full-pod'")

(make-variable-buffer-local 'bioperl-source-file-path-component)

(defvar bioperl-this-is-xemacs (or (string-match "^XEmacs" (emacs-version)))
  "Flag indicating whether we're in XEmacs.")
       
;;
;; User-interface functions
;;

(defun bioperl-insert-module (namespace module &optional dummy beg pt end)
  "Insert BioPerl module declaration interactively, using completion."
  (interactive
   (let* (
	 (mod-at-pt (bioperl-module-at-point))
	 (beg (if mod-at-pt (match-beginning 0) nil))
	 (pt (point))
	 (end (if mod-at-pt (match-end 0) nil))
	 (cr (bioperl-completing-read mod-at-pt nil nil "[insert] " t) )
	 )
     (if (not (member nil (mapcar 'not cr))) (signal 'quit t))
     (append cr (list beg pt end))
     ))
  (if namespace
      (progn
	(setq namespace (replace-regexp-in-string "::$" "" namespace))
	(let ( 
	      ( mod (apply 'concat 
			   namespace 
			   (if module (list "::" module) '(nil))) )
	      )
	  (if (not beg)
	      (insert mod)
	    (string-match (concat 
			   (buffer-substring beg pt)
			   "\\(.*\\)")
			  mod)
	    (delete-region pt end)
	    (insert (substring mod (match-beginning 1) (match-end 1))))))
    nil))

;;
;; pod viewers
;;

;; TODO: refactor bioperl-view-pod to take separate nmspc mod parms...

(defun bioperl-view-pod (module &optional n)
  "View the full pod for a BioPerl module. Use completion facilities to browse interactively.
MODULE is in double-colon format. N is an index associated with a
component of `bioperl-module-path'."
  (interactive
   (let* (
	 (mod-at-pt (bioperl-module-at-point))
	 (mod (bioperl-completing-read 
	       (if mod-at-pt
		   mod-at-pt
		 (if (and (boundp 'bioperl-source-file) bioperl-source-file)
		     ;; in pod view --
		     (elt (bioperl-perl-from-path bioperl-source-file) 0)
		   nil)) nil t "[pod] "))
	 )
     (if (not (member nil (mapcar 'not mod))) (signal 'quit t))     
     (list (apply 'concat 
		  (elt mod 0) 
		  (if (elt mod 1) (list "::" (elt mod 1)) 
		    (signal 'quit t))) (car (last mod)))))
  (bioperl-view-full-pod module n))

(defun bioperl-view-pod-method (namespace module method &optional n)
  "View desired method pod interactively. Use completion facilities to browse interactively.
N is an index associated with a component of `bioperl-module-path'."
  (interactive 
   (let (
	 (cr (bioperl-completing-read (bioperl-module-at-point) t nil "[pod mth] ") )
	 )
     (if (not (member nil (mapcar 'not cr))) (signal 'quit t))
     cr))
  (if (not method) (signal 'quit t))
  (let (
	( cache-pos (if method (bioperl-assoc-string method bioperl-method-pod-cache t) nil) )
	)
    (if (not cache-pos)
	(message "No such method")
      (bioperl-render-method-pod-from-cons cache-pos))
    ))

(defun bioperl-view-pod-synopsis (module &optional n)
  "View the pod synopsis for a Bioperl module.
N is an index associated with a component of `bioperl-module-path'."
  (interactive
   (let (
	 (mod (bioperl-completing-read (bioperl-module-at-point) nil t "[pod syn] "))
	 )
     (if (not (member nil (mapcar 'not mod))) (signal 'quit t))     
     (list (apply 'concat 
		  (elt mod 0) 
		  (if (elt mod 1) (list "::" (elt mod 1)) 
		    (signal 'quit t) )) (car (last mod)))))
  (bioperl-view-pod-section module "SYNOPSIS" n))

(defun bioperl-view-pod-description (module &optional n)
  "View the pod synopsis for a BioPerl module.
N is an index associated with a component of `bioperl-module-path'."
  (interactive
   (let (
	 (mod (bioperl-completing-read (bioperl-module-at-point) nil t "[pod dsc] " ))
	 )
     (if (not (member nil (mapcar 'not mod))) (signal 'quit t))     
     (list (apply 'concat 
		  (elt mod 0) 
		  (if (elt mod 1) (list "::" (elt mod 1)) 
		    (signal 'quit t))) (car (last mod)))))
  (bioperl-view-pod-section module "DESCRIPTION" n))

(defun bioperl-view-pod-appendix (module &optional n)
  "View the pod appendix (containing individual method information) for a Bioperl module.
N is an index associated with a component of `bioperl-module-path'."
  (interactive
   (let (
	 (mod (bioperl-completing-read (bioperl-module-at-point) nil t "[pod apx] "))
	 )
     (if (not (member nil (mapcar 'not mod))) (signal 'quit t)) 
     (list (apply 'concat 
		  (elt mod 0) 
		  (if (elt mod 1) (list "::" (elt mod 1)) 
		    (signal 'quit t))) (car (last mod)))))
  (bioperl-view-pod-section module "APPENDIX" n))


(defun bioperl-view-pod-parents (module)
  "Browse the pod for BioPerl modules from which MODULE inherits.
MODULE is in double-colon format. Most useful when called from a pod view."
  (unless (and module (stringp module))
    (error "String required at arg MODULE"))
  (if (not module)
      nil
    (let* (
	   (pth-comp (if (boundp 'bioperl-source-file-path-component)
			 bioperl-source-file-path-component nil))
	  (pmfile (bioperl-path-from-perl module nil pth-comp))
	  (parents)
	  (mod)
	  )
      (unless pmfile
	(error "Module specified by MODULE not found in installation"))
      (with-temp-buffer
	(insert-file-contents pmfile)
	(setq parents (bioperl-find-class-parents (current-buffer))))
      (if (not parents)
	  (error "Unable to identify module parents")
	;; create a (degenerate) alist
	(setq parents (mapcar 'list parents))
	(setq mod (completing-read "[pod]: " parents nil t 
				   (if (= (length parents) 1) 
				       (elt parents 0)
				     "Bio::")))
	(if mod
	    (bioperl-view-pod mod pth-comp)
	  nil))
      )))


(defun bioperl-view-source ()
  "Display the file in the variable `bioperl-source-file' in view mode in a new buffer.  
When in bioperl-view-mode, `bioperl-source-file' will contain the
path to the source of the module whose pod is being viewed."
  (interactive)
  (if (not (file-exists-p bioperl-source-file))
      nil
    (let ( (fname bioperl-source-file) 
	   (pth-comp bioperl-source-file-path-component) )
      (set-buffer (generate-new-buffer "*BioPerl Src*"))
      (insert-file fname)
      (perl-mode)
      (bioperl-source-mode)
      (pop-to-buffer (current-buffer))
      (setq bioperl-source-file fname)
      (setq bioperl-source-file-path-component pth-comp))))

(defun bioperl-view-parents ()
  "Browse pod of base classes for the file in `bioperl-source-file' by completion menu.  
When in bioperl-view-mode, `bioperl-source-file' will contain the
path to the source of the module whose pod is being viewed."
  (interactive)
  (if (not (file-exists-p bioperl-source-file))
      nil
    (let (
	  (mod)
	  )
      (mapcar (lambda (x) (setq mod (if mod (concat mod "::" x) x)))
	      (bioperl-perl-from-path bioperl-source-file))
      (bioperl-view-pod-parents mod))))

(defun bioperl-view-parents-this-buffer ()
  "Browse the pod for BioPerl modules from which the current source inherits.
Callable from bioperl-source-mode only."
  (interactive)
  (unless bioperl-source-file
    (error "This function current works in bioperl-source-mode only."))
  (let* (
	 (pth-comp (if (boundp 'bioperl-source-file-path-component)
		       bioperl-source-file-path-component nil))
	 (parents)
	 (mod)
	 )
    (setq parents (bioperl-find-class-parents (current-buffer)))
    (if (not parents)
	(error "Unable to identify module parents")
      ;; create a degenerate alist
      (setq parents (mapcar 'list parents))
      (setq mod (completing-read "[pod]: " parents nil t 
				 (if (= (length parents) 1) 
				     (elt parents 0)
				   "Bio::")))
      (if mod
	  (bioperl-view-pod mod pth-comp)
	nil))))


;; "uninstall..."

(defun bioperl-mode-unload-hook &optional local
  "Remove the perl-mode hook.
If LOCAL is set, remove hook from the buffer-local value of perl-mode-hook."
  (remove-hook 'perl-mode-hook 'bioperl-perl-mode-infect local)
  (if bioperl-this-is-xemacs
        (remove-hook 'cperl-mode-hook 'bioperl-perl-mode-infect local)))


;;
;; Internal functions
;;

;;
;; pod slurpers
;;

(defun bioperl-view-full-pod (module &optional n) 
  "Open the Bioperl POD for the MODULE for viewing in another buffer.
MODULE is in double-colon format."
  (unless (and module (stringp module))
    (error "String required at arg MODULE"))
  (unless (or (not n) (numberp n))
    (error "Number required at arg N"))
  (unless n
    (setq n 0))
  (if (not module)
      nil
    (let (
	  (pod-buf (generate-new-buffer "*BioPerl POD*"))
	  (pmfile (bioperl-path-from-perl module nil n))
	  )
      (unless pmfile
	(error "Module specified by MODULE not found in installation"))
      (save-excursion
	(set-buffer pod-buf)
	(pod-mode)
	(setq header-line-format (concat "POD - BioPerl module " module " @ " 
					 (file-name-squish
					  (elt (split-string bioperl-module-path path-separator) n)) ))
	(insert-file-contents pmfile)
	(pod-parse-buffer (current-buffer))
	(goto-char (point-min))
	(bioperl-view-mode)
	(set (make-local-variable 'bioperl-source-file) pmfile)
	(set (make-local-variable 'bioperl-source-file-path-component) nil)
	;; set the path component
	(let (
	      (i 0) (done 0) (pth-comp (parse-colon-path bioperl-module-path))
	      )
	  (while (and (= done 0) (elt pth-comp i))
	    (if (string-match 
		 (regexp-quote (elt pth-comp i)) bioperl-source-file)
		(setq done 1)
	      (setq i (1+ i))))
	  (if (elt pth-comp i)
	      (setq bioperl-source-file-path-component i)))
	(pop-to-buffer pod-buf))
      )
    ;;return val
    t ))

(defun bioperl-view-pod-section (module section &optional n)
  "Open the Bioperl POD for the module PMFILE for viewing in another buffer.
MODULE is in double-colon format. SECTION is a string; one of
SYNOPSIS, DESCRIPTION, or APPENDIX. N is the index of the desired
component of bioperl-module-path."
  (unless (stringp module)
    (error "String required at arg MODULE"))
  (unless (stringp section) 
    (error "String required at arg SECTION"))
  (unless (member (upcase section) '("SYNOPSIS" "DESCRIPTION" "METHODS" "APPENDIX"))
    (error "SECTION not recognized or handled yet"))
  (unless (or (not n) (numberp n))
    (error "Number required at arg N"))
  (unless n
    (setq n 0))
  (let (
	(pod-buf (generate-new-buffer "*BioPerl POD*"))
	(ret nil)
	(pmfile (bioperl-path-from-perl module nil n))
	)
    (unless pmfile
      (error "Module specified by MODULE not found in installation"))
    (save-excursion
      (set-buffer pod-buf)
      (pod-mode)
      (setq header-line-format (concat section " - BioPerl module " module 
				       " @ " (file-name-squish
					      (elt (split-string bioperl-module-path path-separator) n)) ))
      (insert-file-contents pmfile)
      (pod-parse-buffer (current-buffer) t)
      (goto-char (point-min))
      ;; clip to desired section
      (if (search-forward (concat "== " section) (point-max) t)
	  (progn
	    (beginning-of-line)
	    (delete-region (point-min) (point))
	    (forward-line 1)
	    (search-forward "====" (point-max) 1)
	    (beginning-of-line)
	    (delete-region (point) (point-max))
	    (goto-char (point-min))
	    (while (re-search-forward "^====\\s +\\([a-zA-Z0-9_:()]+\\)\\s +==+" (point-max) t)
	      (replace-match "\\1" nil nil))
	    (goto-char (point-min))
	    (while (re-search-forward "^==\\s +\\([a-zA-Z0-9_:()]+\\)\\s +==+" (point-max) t)
	      (replace-match "  \\1" nil nil))
	    (bioperl-view-mode)
	    (set (make-local-variable 'bioperl-source-file) pmfile)
	    (pop-to-buffer pod-buf)
	    (setq ret t))
	(kill-buffer pod-buf)
	)
    )
    ret ))


(defun bioperl-slurp-methods-from-pod (module &optional n) 
  "Parse pod for individual methods for module MODULE.
MODULE is in double-colon format. N is an index corresponding 
to a component of `bioperl-module-path'.

Returns an associative array of the following form:

 ( METHOD_NAME . ( (PODKEY . CONTENT) (PODKEY . CONTENT) ... )
   METHOD_NAME . ( (PODKEY . CONTENT) (PODKEY . CONTENT) ... )
   ... )

where all elements are strings. The alist is sorted by
METHOD_NAME. METHOD_NAME is the name of the method (without
trailing parens), PODKEY is 'Title', 'Usage', 'Function',
'Returns', 'Args' (these keys are read directly from pod and not
standardized), CONTENT is the text that follows the colon
separating the PODKEY heading from the information (including all
text up until the next 'PODKEY :' line. Newlines are converted to
';' in the content, and whitespace is squished to single
spaces/semicolons.

This function, when successful, also sets the cache vars
`bioperl-method-pod-cache' and `bioperl-cached-module'."
  (unless (stringp module) 
    (error "String required at arg MODULE"))
  (let (
	(pmfile (bioperl-path-from-perl module nil n))
	)
    (unless pmfile
      (error (concat "Module specified by MODULE not found in installation at path component " (number-to-string (if n n 0)) ".\nCheck contents of `bioperl-module-path' and call `bioperl-clear-module-cache'.") ))
    (let (
	(method nil)
	(pod-key nil)
	(content nil)
	(bound nil)
	(data '())
	(data-elt '())
	(data-elt-cdr '())
	(old-exec-path exec-path)
	)
      (with-temp-buffer
	(insert-file-contents pmfile)
	(pod-parse-buffer (current-buffer) t)
	;; clip to desired section
	(goto-char (point-min))
	(if (search-forward "= APPENDIX" (point-max) t)
	    (progn
	      (beginning-of-line)
	      (delete-region (point-min) (point))
	      ;; looking down into appendix
	      ;; 
	      (while (re-search-forward "^==\\s +\\([a-zA-Z0-9_]+\\)" 
					(point-max) t)
		(setq method (match-string 1))
		(setq data-elt (cons method '()))
		;; now we have the current method...
		;; find the boundary of this method's pod
		(save-excursion
		  (setq bound (progn (re-search-forward "^=" 
							(point-max) 1)
				     (beginning-of-line)
				     (point))))
		;; now parse out the guts of this method's pod
		;; getting pod-keys and their content...
		(while (re-search-forward 
			"^\\s +\\([A-Za-z]+\\)\\s *:\\s *\\(.*\\)$"
			bound t)
		  (setq pod-key (match-string 1))
		  (setq content (match-string 2))
		  (save-excursion 
		    (setq content 
			  (concat content 
				  (buffer-substring 
				   (point) (if (re-search-forward "^\\s +[A-Za-z]+\\s *:" bound 1)
					       (progn (beginning-of-line) (point))
					     (point)))))
		    )
		  ;; squeeze whitespace from content
		  (setq content (replace-regexp-in-string "\n+" "!!" content))
		  (setq content (replace-regexp-in-string ";$" "" content))
		  (setq content (replace-regexp-in-string "\\s +" " " content))
		;; here we have, for the current method,
		  ;; the current pod-key and its content...
		  (setq data-elt-cdr (cdr data-elt))
		  (setcdr data-elt (push (cons pod-key content) data-elt-cdr )))
		;; copy the data-elt into the data alist...
		(setq data-elt-cdr (cdr data-elt))
		(push (cons (car data-elt) data-elt-cdr) data))
	      ;; set cache vars
	      (setq bioperl-method-pod-cache 
		    (sort data (lambda (a b) (string-lessp (car a) (car b)))))
	      (setq bioperl-cached-module module)
	      (setq bioperl-cached-pmfile pmfile)
	      ;; return the data alist for this module...
	      bioperl-method-pod-cache )
	  ;; the APPENDIX was not found...return nil
	  nil ) ))))

;;
;; list getters
;;

(defun bioperl-method-names (module &optional as-alist n) 

  "Returns a list of method names as given in the pod of MODULE. 
MODULE is in double-colon format. If AS-ALIST is t, return an
alist with elts as (NAME . nil). N is an index associated with a 
component of `bioperl-module-path'.

This function looks first to see if methods for MODULE are
already loaded in `bioperl-method-pod-cache'; if not, calls
`bioperl-slurp-methods-from-pod'."
  (unless (stringp module) 
    (error "String required at arg MODULE"))
  (unless (bioperl-path-from-perl module nil n)
    (error "Module specified by MODULE not found in installation"))
  ;; check the cache; might get lucky...
  (let ( (ret) ) 
    (setq ret 
	  (if (string-equal module bioperl-cached-module)
	      (progn
		(mapcar 'car bioperl-method-pod-cache)
		;; path handling...
		)
	    (mapcar 'car (bioperl-slurp-methods-from-pod module n)))) 
    ;; fix alist for path handling??
    (if as-alist
	(mapcar (lambda (x) (list x nil)) ret)
      ret)))


(defun bioperl-module-names (module-dir &optional retopt as-alist)
  "Returns a list of modules contained in the directory indicated by MODULE-DIR.
MODULE-DIR is in double-colon format.  Optional RETOPT: nil,
return module names only (default); t, return directory names
only; other, return all names as a flat list. Optional AS-ALIST:
if t, return an alist with elts (NAME . PATH_STRING) (when used in 
completing functions). This function checks all paths specified
in `bioperl-module-path'.


 This function is responsible for the lazy loading of the module
names cache: it will look first in `bioperl-module-names-cache';
if the MODULE-DIR is not available,
`bioperl-add-module-names-to-cache' will be called."
  (let* (
	(module-components (split-string module-dir "::" t))
	(unlist (lambda (x) (if (listp x) (car x) x)) )
	(choose-dirs (lambda (x) (if (listp (cdr x)) x nil)) )
	(choose-mods  (lambda (x) (if (listp (cdr x)) nil x)) )
	(ret) (i)
	(pths (split-string bioperl-module-path path-separator))
	(alists) (alist)
	)
    ;; add to cache
    (setq i 0)
    (while (< i (length pths))
      (bioperl-add-module-names-to-cache module-dir i)
      (setq i (1+ i)))
    ;; search
    (setq alists (deep-assoc-all module-components bioperl-module-names-cache))
    ;; here pick the directory alist
    (setq alist (if (stringp (cdr (elt alists 0)))
		    (elt alists 1) (elt alists 0)))
    (if (and alist (cdr alist))
	(cond 
	 ( (not (booleanp retopt))
	   (if (stringp (cdr alist))
	       (setq ret alist)
	     (setq ret (cdr alist))))
	 ((not retopt)
	   (if (stringp (cdr alist))
	       (setq ret alist)
	     (setq ret (delete nil (mapcar choose-mods (cdr alist))))
	     ))
	 ( retopt
	   (if (stringp (cdr alist))
	       (setq ret nil)
	     (setq ret (delete nil (mapcar choose-dirs (cdr alist))))
	     ))))
    (if (not ret)
	nil
      (if (not as-alist) 
	  (if (stringp (cdr ret))
	      (car ret)
	    (mapcar 'car ret))
	ret))))


;;
;; directory slurpers
;;

(defun bioperl-add-module-names-to-cache (module-dir &optional n)
  "Add alists to `bioperl-module-names-cache'.
MODULE-DIR is in double colon format. Allows for lazy build of
the cache.  Returns t if we added anything, nil if not. N is the index
of the desired bioperl-module-path component.

Cache alist format:
 ( \"Bio\" . 
   ( (MODULE_NAME PATH_INDEX_STRING) ...        ; .pm file base names
     (DIRNAME . nil) ...           ; dirname read but not yet followed
     (DIRNAME . ( ... ) ) ... )    ; dirname assoc with >=1 level structure
 )	      
"				     
 
  (unless (and module-dir (stringp module-dir))
    (error "String required at arg MODULE-DIR"))
  (unless (or (not n) (numberp n))
    (error "Number required at arg N"))
  (unless n
    (setq n 0))
  (if (and (> n 0) (> n (1- (length (split-string bioperl-module-path path-separator)))))
      (error "Path index out of bounds at arg N"))
  (let* (
	(pth (bioperl-path-from-perl module-dir 1 n))
	(module-components (split-string module-dir "::" t))
	(module-string)
	(modules)
	(alist)
	(cache (deep-assoc-all module-components bioperl-module-names-cache))
	(cache-pos)
	(keys)
	(this-key)
	(good-keys)
	(ret)
       )
    (if (not pth)
	;; no path returned for module-dir...
	nil
      (setq cache-pos 
	    (cond
	     ((not cache)
	      nil)
	     ((stringp (cdr (car cache)))
	      (elt cache 1))
	     ( t
	       (elt cache 0))))
      (if cache-pos ;; something there
	  ;; easy - a stub
	  (if (null (cdr cache-pos))
	      (progn 
		(setcdr cache-pos (bioperl-slurp-module-names module-dir n))
		(setq ret t))
	      ;; less hard - branch exists
	    (let* ( 
		   (mod-alist (bioperl-slurp-module-names module-dir n))
		   (mod-alist-keys (mapcar 'car mod-alist))
		   (cache-item) (key)
		   )
	      (while (setq key (pop mod-alist-keys))
		(setq alist (assoc-all key cache-pos))
		(setq cache-item (if (stringp (cdr (elt alist 0))) 
				     (elt alist 0) (elt alist 1)))
		(if (null cache-item)
		    (if alist
			nil
		    ;; create a new list member(s)
		      (setcdr cache-pos (append (cdr cache-pos) 
						(assoc-all key mod-alist))))
		  ;; 
		  (if (member n (mapcar 'string-to-number (split-string (cdr cache-item) path-separator)))
		      ;; deja vu
		      (setq mod-alist-keys nil) ;; fall-through
		    (setcdr cache-item (concat (cdr (bioperl-assoc-string key mod-alist t)) path-separator (cdr cache-item)))
		    (setq ret t))))
	      ))

	;; hard - branch dne
	(setq keys module-components)
	(while (
		let ( (da (deep-assoc-all 
			   (append (reverse good-keys) (list (car keys))) 
			   bioperl-module-names-cache) ) )
		 (setq da (if (stringp (elt da 0)) (elt da 1) (elt da 0)))
		 (car da) );; has a member whose cdr is a list 
	  (setq good-keys (push (car keys) good-keys))
	  (setq keys (cdr keys)))
	(push (pop good-keys) keys)
	(setq good-keys (nreverse good-keys))
	;; keys contains the directories we need to add, in order
	;; address for doing additions: cache-pos
	(setq alist (deep-assoc-all good-keys bioperl-module-names-cache))
	(setq cache-pos 
	      (if (stringp (cdr (elt alist 0))) (elt alist 1) (elt alist 0)))
	(setq module-string (pop good-keys))
	;; prep for bioperl-anastomose
	(while good-keys
	  (setq module-string (concat module-string "::" (pop good-keys))))
	;; module-string is suitable for passing to bioperl-slurp-module-names
	(setq ret (bioperl-anastomose keys module-string cache-pos n)))
      )
    ret ))

(defun bioperl-anastomose (keys module-string cache-pos n)
  "Extends `bioperl-module-names-cache' recursively. No user-serviceable parts inside.
Call first CACHE-POS set to node to be extended.
MODULE-STRING must indicate directory corresponding to CACHE-POS."
  (unless cache-pos
    (setq cache-pos bioperl-module-names-cache))
  (if (not keys)
      t ; success
    (let (
	  (this-key (pop keys))
	  (modules)
	  (cache-ins-pos)
	  (alist)
	  )
      (setq alist (assoc-all this-key cache-pos))
      (setq cache-ins-pos (if (stringp (cdr (elt alist 0))) (elt alist 1) (elt alist 0)))
      (setq module-string (if module-string 
			      (concat module-string "::" this-key) 
			    this-key))
      (setq modules (bioperl-slurp-module-names module-string n))
      (if (not modules)
	  nil ; fail
	(let ( (cache-item) (uniq-modules) )
	  (while (setq cache-item (pop modules))
	    (if (or (null (cdr cache-ins-pos)) (not (member cache-item (cdr cache-ins-pos))))
		(push cache-item uniq-modules)))
	  (setcdr cache-ins-pos (append (cdr cache-ins-pos) uniq-modules )))
	(bioperl-anastomose keys module-string (cdr cache-ins-pos) n)
	t))))
	

(defun bioperl-slurp-module-names (module-dir &optional n)
  "Return list of the  basenames for .pm files contained in MODULE-DIR.
MODULE-DIR is in double-colon format. N is the index of the desired 
bioperl-module-path component.

Return is a list of the form

 ( (MODULE_NAME . PATH_INDEX_STRING) ... 
   (DIR_NAME . nil) ... )
"
  (unless (and module-dir (stringp module-dir))
    (error "String required at arg MODULE-DIR"))
  (unless (or (not n) (numberp n))
    (error "Number required at arg N"))
  (unless n
    (setq n 0))
  (let (
	(module-path (split-string bioperl-module-path path-separator))
	(pth (bioperl-path-from-perl module-dir 1 n))
	(modules)
	(fnames)
	(choose-dirs (lambda (x) (if (listp (cdr x)) x nil)) )
	(nmspc-only t)
       )
    (if (and (> n 0) (> n (1- (length module-path))))
	(error "Path index out of bounds at arg N"))
    ;; following (elt ... 0) checks if pth is dir or symlink:
    ;;  possible bug...
    (if (and pth (elt (file-attributes pth) 0))
	(progn
	  (setq fnames (directory-files pth))
	  (while fnames 
 	    (let ( (str (pop fnames)))
	      ;; files - conses with path-index cdr
	      (if (string-match "\\([a-zA-Z0-9_]+\\)\.pm$" str)
		  (progn
		    (push (cons (match-string 1 str) 
				(number-to-string n))  modules)
		    (setq nmspc-only nil)))
	      ;; directories - conses with nil cdr
	      (if (string-match "^\\([a-zA-Z0-9_]+\\)$" str)
		  (if (not (string-equal (match-string 1 str) "README")) (push (cons (match-string 1 str) nil) modules)))
	      ))
;; 	  (if nmspc-only
;; 	      (let ( (dirs (delete nil (mapcar choose-dirs modules)))
;; 		     (module-dir-next) )
;; 		(while dirs
;; 		  (setq module-dir-next (concat module-dir "::" (car (pop dirs))))
;; 		  (append modules (bioperl-slurp-module-names module-dir-next n)))))
	  (if (not modules)
	      nil
	    modules))
      nil)))

;;
;; string converters and finders
;;

(defun bioperl-find-class-parents (buf)
  "Look in the current buffer for parent classes to the displayed module.
Searches for 'use base' and @ISA statements in buffer
BUF. Returns a list of BioPerl modules in double colon
format. Will probably fail (not dismally) if multiple packages
are present in a single module file."
  ;; how? by searching for 
  ;; use base STUFF
  ;; @ISA = STUFF
  ;; push @ISA, STUFF
  (unless (or (bufferp buf) (stringp buf))
    (error "Require buffer or buffer name at BUF"))
  (let (
	(retmods)
	)
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min))
      ;; search for 'use base'...
      (let* (
	     (beg (re-search-forward "use base " (point-max) t))
	     (end (if beg (re-search-forward ";" (point-max) t) nil))
	     (txt (if beg (buffer-substring-no-properties beg (1- end)) nil))
	     (toks)
	     )
	(if (not txt)
	    nil
	  (setq txt (replace-regexp-in-string "\n" " " txt))
	  (setq txt (replace-regexp-in-string "\\(?:qw[\[\(\{\|][ \f\t\n\r\v]?\\)" "" txt))
	  (setq txt (replace-regexp-in-string "[](){}'\"]" "" txt))
	  (setq toks (split-string txt "[ \f\t\n\r\v]+" t))
	  (mapcar (lambda (x) (push x retmods)) toks) ))
      ;; search for @ISA
      ;; ISA set needs to search over multi lines
      ;; look at Bio::
      (goto-char (point-min))
      (let* (
	     (beg (re-search-forward "@ISA\s?[,=]\s?" (point-max) t))
	     (end (if beg (re-search-forward ";" (point-max) t) nil))
	     (txt (if beg (buffer-substring-no-properties beg (1- end)) nil))
	     (toks)
	     (pass 1)
	     )
	(while (<= pass 2)
	  (if (not txt)
	      (setq pass (1+ pass))
	    (setq txt (replace-regexp-in-string "\n" " " txt))
	    (setq txt (replace-regexp-in-string "\\(?:qw[\[\(\{\|][ \f\t\n\r\v]?\\)" "" txt))
	    (setq txt (replace-regexp-in-string "[](){}'\"]" "" txt))
	    (setq toks (split-string txt "[ \f\t\n\r\v]+" t))
	    (mapcar (lambda (x) (push x retmods)) toks) 
	    (setq pass (1+ pass)))
	  (setq beg (re-search-forward "@ISA\s?[,=]\s?" (point-max) t))
	  (setq end (if beg (re-search-forward ";" (point-max) t) nil))
	  (setq txt (if beg (buffer-substring-no-properties beg (1- end)) nil))
	  )))
      ;; filter for fully-qualified Bio:: modules...
      (setq retmods 
	    (delete nil (mapcar 
			 (lambda (x) (if (string-match "^Bio::" x) x nil)) 
		       retmods)))
    (nreverse retmods) ))

(defun bioperl-module-at-point ()
  "Look for something like a module identifier at point, and return it."
  (interactive)
  (let (
	(found (thing-at-point-looking-at "Bio::[a-zA-Z0-9_:]+"))
	(module nil)
	(pth nil)
	)
    (if (not found) 
	nil
      (setq module (apply 'buffer-substring (match-data)))
      module)))

(defun bioperl-find-module-at-point (&optional n)
  "Look for something like a module declaration at point, and return a filepath corresponding to it.
N is the index of the desired bioperl-module-path component."
  (interactive)
  (unless (or (not n) (numberp n))
    (error "Number required at arg N"))
  (unless n
    (setq n 0))
  (unless bioperl-module-path
      (error "bioperl-module-path not yet set; you can set it with bioperl-find-module-path"))
  (let ( 
	(module-path (elt (split-string bioperl-module-path path-separator) n))
	(found) (module) (pth)
	)
    (if (and (> n 0) (> n (1- (length module-path))))
	(error "Path index out of bounds at arg N"))
    (unless (file-exists-p (concat module-path "/Bio"))
      (error (concat "Bio modules not present in path component" module-path )))
    (setq found (thing-at-point-looking-at "Bio::[a-zA-Z0-9_:]+"))
    (if (not found) 
	nil
      (setq module (apply 'buffer-substring (match-data)))
      (setq pth (bioperl-path-from-perl module n)))
    pth))

(defun bioperl-perl-from-path (pth)
  "Return a list (namespace module) represented by the path in PTH.
Returns nil if the path can't be parsed reasonably. namespace is returned
in double colon format."
  (unless pth
    nil)
  (let (
	(pth-components) (nmspc "Bio") (mod) (pc)
	)
    (setq pth (replace-regexp-in-string "\\\\" "/" pth))
    (setq pth-components (split-string pth "/"))
    (while (and pth-components (not (string-equal "Bio" (pop pth-components))))
      nil)
    (if (not pth-components) 
	nil
      (while pth-components
	(setq pc (pop pth-components))
	(if (string-match "\\([a-zA-Z0-9_]+\\)\.pm" pc)
	    (setq mod (match-string 1 pc))
	  (setq nmspc (concat nmspc "::" pc))))
      (list nmspc mod))
    ))

(defun bioperl-path-from-perl (module &optional dir-first n) 
  "Return a path to the module file represented by the perl string MODULE.
Returns nil if no path found. If DIR-FIRST is t, return a
directory over a .pm file if there is a choice. If DIR-FIRST is
not t or nil, return a directory only. N is an integer, indicating the
desired member of bioperl-module-path to search."
  (unless bioperl-module-path
    (error "bioperl-module-path not yet set; you can set it with bioperl-find-module-path"))
  (unless (stringp module)
    (error "string arg required at MODULE"))
  (unless (or (not n) (numberp n))
    (error "number arg required at N"))
  ; default
  (unless n
    (setq n 0))
  (let (
	(module-path (elt (split-string bioperl-module-path path-separator) n))
	(module-components (split-string module "::" t))
	(pth)
	(dir (if (not (boundp 'dir-first)) nil dir-first))
	)
    (if (and (> n 0) (> n (1- (length module-path))))
	(error "Path index out of bounds at arg N"))
    (unless (file-exists-p (concat module-path "/Bio"))
      (error (concat "Bio modules not present in path component " module-path)))
    (setq module-components (split-string module "::" t))
    ;; unixize...
    (setq pth (replace-regexp-in-string "\\\\" "/" module-path))
    
    (while (not (null module-components))
      (setq pth (concat pth "/" (car module-components)))
      (setq module-components (cdr module-components)))
    (if (not (booleanp dir))
	(if (file-exists-p pth)
	    t
	  (setq pth nil))
      (if (and dir (file-exists-p pth))
	  t
	(if (file-exists-p (concat pth ".pm"))
	    (setq pth (concat pth ".pm"))
	  (if (file-exists-p pth)
	      t
	    (setq pth nil)))))
    pth))

(defun bioperl-split-name (module &optional dir-first n)
  "Examine MODULE and return a list splitting the argument into an existing namespace and module name.
MODULE is in double-colon format. This checks existence as well,
and returns nil if no split corresponds to an existing file. The
algorithm uses `bioperl-path-from-perl' to do its tests.  Default
behavior is to return (namespace module) if there is a choice.
If DIR-FIRST is t, return (namespace nil) over (namespace module)
if there is a choice. If DIR-FIRST is not t or nil, return only
\(namespace nil) or nil.

Finally, if the namespace portion of MODULE exists, but the module
 specified by MODULE does not, (namespace nil) is returned.
N specifies the index of the desired bioperl-module-path component. "

  (unless (or (not module) (stringp module))
    (error "String arg required at MODULE"))
  (unless (or (not n) (numberp n))
    (error "Number required at arg N"))
  (unless n
    (setq n 0))
  (if (not module)
      (list nil nil)
    (if (not (string-match "^Bio" module))
	nil
      ( let (
	     (module-path (elt 
			   (split-string bioperl-module-path path-separator) n))
	     (nmspc) (mod) (pmfile) 
	     )
	(if (and (> n 0) (> n (1- (length module-path))))
	    (error "Path index out of bounds at arg N"))
	(if (not (string-match "::\\([a-zA-Z0-9_]+\\)$" module))
	    (setq nmspc module)
	  (setq mod (match-string 1 module))
	  (setq nmspc (substring module 0 (- (match-beginning 1) 2))))
	(cond
	 ( (not (booleanp dir-first))
	   (if (bioperl-path-from-perl module dir-first n)
	       (list module nil)
	     (list (concat "*" module) nil)) )
	 ( t 
	   (setq pmfile (bioperl-path-from-perl module dir-first n))
	   (if pmfile
	       (if (string-match "\.pm$" pmfile)
		   (list nmspc mod)
		 (list module nil))
	     (if dir-first
		 (progn (setq nmspc (concat nmspc "::" mod))
			(setq mod nil)))
	     (if (bioperl-path-from-perl nmspc 1 n)
		 (list nmspc (concat "*" mod))
	       (list (concat "*" nmspc) nil))
	     ))) 
	))))

(defun bioperl-render-method-pod-from-cons (cons)
  "Create a view buffer containing method pod using a member of the `bioperl-method-pod-cache' alist.

CONS has the form 

 ( METHOD_NAME . ( ( POD_TAG . CONTENT) (POD_TAG . CONTENT) ... ) ). 

The module name for this method is assumed to be present in
`bioperl-cached-module'"
  (unless (listp cons)
    (error "List required at arg CONS"))
  (if (not cons) 
      nil
    (let* ( 
	  (module bioperl-cached-module)
	  (method (car cons))
	  (content (cdr cons))
	  ;; reverse below is a sort-of kludge
	  (tags (if content (reverse (mapcar 'car content)) nil))
	  (cur-tag nil)
	  (cur-content nil)
	  (pod-buf (generate-new-buffer "*BioPerl POD*"))
	  )
      (if (not content)
	  (message "No pod available")
	(save-excursion
	  (set-buffer pod-buf)
	  (pod-mode)
	  (setq header-line-format (concat "Method " method 
					   "() - BioPerl module " module
					   " @ " 
					   (file-name-squish
					    (elt (split-string bioperl-module-path path-separator) n))))
	  (insert "  " method)
	  (insert "\n")
	  (while (setq cur-tag (pop tags))
	    (setq cur-content (cdr (bioperl-assoc-string cur-tag content t)))
	    (setq cur-content (replace-regexp-in-string "!!$" "\n" cur-content))
	    (setq cur-content (replace-regexp-in-string "!!" 
							"\n             " cur-content))
	    (insert "    " cur-tag)
	    (insert-char ?  (- 8 (length cur-tag)))
	    (insert ": " cur-content))
	  (goto-char (point-min))
	  (bioperl-view-mode)
	  (set (make-local-variable 'bioperl-source-file) bioperl-cached-pmfile)
	  (pop-to-buffer pod-buf)))
      )))

;; 
;; completion tricks
;;

;; TODO: modularize...
(defun bioperl-completing-read (initial-input &optional get-method dir-first prompt-prefix no-retry)
  "Specialized completing read for bioperl-mode.
INITIAL-INPUT is a namespace/module name in double-colon format,
or nil. Returns a list: (namespace module path-string) if GET-METHOD is nil,
\(namespace module method path-string) if GET-METHOD is t. DIR-FIRST is
passed along to `bioperl-split-name'; controls what is returned
when a namespace name is also a module name (e.g., Bio::SeqIO).
If NO-RETRY is nil, the reader works hard to return a valid entity;
if t, the reader barfs out whatever was finally entered."
  (let ( (parsed (bioperl-split-name initial-input dir-first)) 
	 (nmspc) (mod) (mth) (pthn) (name-list)
	 (done nil))
    (if (not parsed)
	nil
      (setq nmspc (elt parsed 0))
      (setq mod (elt parsed 1)))
    (while (not done)
      ;; namespace completion
      (unless (and nmspc (not (string-match "^\*" nmspc)))
	(cond 
	 ( (not nmspc) nil )
	 ( (string-match "^\*" nmspc)
	   (setq initial-input (replace-regexp-in-string "^\*" "" nmspc))))
	(setq nmspc (completing-read 
		     (concat prompt-prefix "Namespace: ")
		     'bioperl-namespace-completion-function
		     nil (not no-retry) (or initial-input "Bio::")) )
	(if (or (string-equal nmspc "Bio") (not (string-equal nmspc "")))
	    t
	  ;; back up
	  (setq nmspc 
		(if (string-match ":" nmspc)
		    (car (split-string nmspc "::[^:]+$"))
		  nil))
	  (setq done nil)))
      ;; module completion
      (if (or (not nmspc)
		  (and mod (not (string-match "^\*" mod))))
	  (setq done t)
	(let (
	      ;; local vars here
	      )
	  (setq name-list (bioperl-module-names nmspc nil t))
	  (setq mod (completing-read 
		     (concat prompt-prefix nmspc " Module: ")
		     name-list nil (not no-retry)
		     (if mod (replace-regexp-in-string "^\*" "" mod) nil)))
	  ;; allow a backup into namespace completion
	  (if (or no-retry (not (string-equal mod "")))
	      (setq done t)
	    ;; retry setup
	    ;; try again, backing up
	    (setq done nil)
	    (let ( (splt (bioperl-split-name nmspc nil)) )
	      (if (elt splt 1)
		  (progn
		    (setq nmspc (elt splt 0))
		    ;; kludge : "pretend" mod is not found using the "*"
		    (setq mod (concat "*" (elt splt 1))))
		(setq nmspc (concat "*" nmspc))
		(setq mod nil)))
	    (setq initial-input nmspc))))
      ;; path completion
      (unless (or (not (and nmspc mod)) (not done) no-retry)
	(if (not name-list)
	  (setq name-list (bioperl-module-names 
			   nmspc nil t)))
	(setq pthn (cdr (bioperl-assoc-string mod name-list t)))
	(if (not pthn) 
	    (error "Shouldn't be here(1). Check `bioperl-module-path' and try running `bioperl-clear-module-cache'."))
	(if (not (string-match path-separator pthn))
	    ;; single path 
	    (setq pthn (string-to-number pthn))
	  ;; multiple paths (e.g., "0;1") - do completion
	  (let* (
		 (module-path 
		  (split-string bioperl-module-path path-separator))
		 (pthns (mapcar 'string-to-number
				(split-string pthn path-separator)))
		 (i -1)
		 (module-path-list 
		  (mapcar 
		   (lambda (x) (setq i (1+ i)) (list x i) )
		   module-path))
		 )
	    ;; filter list by pthns
	    (setq module-path-list
		  (delete nil (mapcar 
			       (lambda (x) (if (member (elt x 1) pthns) x nil))
			       module-path-list)))
	    (if (not module-path-list)
		(error "Shouldn't be here(2). Run `bioperl-clear-module-cache' and try again"))
	    (setq pthn (completing-read 
			(concat prompt-prefix nmspc "::" mod " Lib: ")
			module-path-list
			nil t (car (car module-path-list))))
	    (if (string-equal pthn "")
		(setq pthn (car (car module-path-list))))
	    (setq pthn (elt (bioperl-assoc-string pthn module-path-list t) 1))
	    )))
      ;; method completion
      (setq nmspc (replace-regexp-in-string "::$" "" nmspc))
      (unless (or (not done) (not (and nmspc mod)) (not get-method))
	;; path completion if necessary
	(if pthn
	    t
	  (setq pthn (cdr (bioperl-module-names nmspc nil t)))
	  (if (not (string-match path-separator pthn))
	      ;; single path
	      (setq pthn (string-to-number pthn))
	    ;; multiple paths (e.g., "0;1") - do completion
	    (let* (
		   (module-path 
		    (split-string bioperl-module-path path-separator))
		   (pthns (mapcar 'string-to-number
				  (split-string pthn path-separator)))
		   (i -1)
		   (module-path-list 
		    (mapcar 
		     (lambda (x) (setq i (1+ i)) (list x i) )
		     module-path))
		   )
	      ;; filter list by pthns
	      (setq module-path-list
		    (delete nil (mapcar 
				 (lambda (x) (if (member (elt x 1) pthns) x nil))
				 module-path-list)))
	      (if (not module-path-list)
		  (error "Shouldn't be here(3). Run `bioperl-clear-module-cache' and try again"))
	      (setq pthn (completing-read 
			  (concat prompt-prefix "Lib: ")
			  module-path-list
			nil t (car (car module-path-list))))
	      (if (string-equal pthn "")
		  (setq pthn (car (car module-path-list))))
	      (setq pthn (elt (bioperl-assoc-string pthn module-path-list t) 1))
	      )
	    ))
	(setq name-list (bioperl-method-names (concat nmspc "::" mod) t pthn))
	(let (
	      ;; local vars here...
	      )
	  (setq mth (completing-read
		     (concat prompt-prefix "Method in " nmspc "::" mod ": ")
		     name-list nil (not no-retry)))
	  (if (or no-retry (not (string-equal mth "")))
	      (setq done t)
	    ;; retry setup
	    ;; allow a backup into module completion
	    (setq done nil)
	    (let ( 
		  (splt (bioperl-split-name (concat nmspc "::" mod) nil pthn))
		  )
	      (setq nmspc (elt splt 0))
	      ;; kludge : "pretend" mod is not found using the "*"
	      (setq mod (concat "*" (elt splt 1))))))
	))
    ;; return values
    (if get-method
	(list nmspc mod mth pthn)
      (list nmspc mod pthn)) ))

(defun bioperl-namespace-completion-function (str pred flag)
  "A custom completion function for bioperl-mode.
Allows the lazy build of the `bioperl-module-names-cache' via `bioperl-make-collection' and `bioperl-module-names'."
  (if (not pred) 
      (setq pred 
	    (lambda (x) (setq x (if (listp x) (car x) x) ) (if (string-match "[a-zA-Z0-9_:]+" x) t nil))
	    ))
  (let (
	( collection (if (string-equal str "") '(("Bio" . nil )) (bioperl-make-collection str t)) )
	)
    ;; offer the right collection:
    ;; if collection was set, the str was complete and valid
    ;; if not, back up to the last :: in str (see str-trunc in above
    ;; let) and try again
   
    (if (not collection) 
	nil
      (setq collection (sort collection (lambda (x y) (string< (car x) (car y)))))
      (cond
       ((not (booleanp flag)) ;; 'lambda' or test-completion option
	;; this is a back-compat issue: emacs 21 will send 'lambda', 
	;; but doesn't have 'test-completion
	;;
	;; Note without test-completion, weird completion bugs can crop
        ;; up -- best upgrade to 22--
	(if (condition-case nil
		(symbol-function 'test-completion)
	      ('error nil))
	    (test-completion str collection pred)
	  collection
	  (try-completion str collection pred))
	)
       ( (not flag) ;; try-completion option
	   (try-completion str collection pred)
	   )
       ( flag ;; all-completion option
	   (all-completions str collection pred)
	   )
       ))))

(defun bioperl-make-collection (module-dir &optional retopt)
  "Create a completion collection for MODULE-DIR.
MODULE-DIR is in double-colon format, possibly with two trailing
colons.  RETOPT is as for `bioperl-module-names'.

This function searches all paths specified in
`bioperl-module-path'."

  ;; handle the boundary
  (if (or (not module-dir) (not (string-match ":" module-dir)))
      '(("Bio") ("Bio::"))
    (setq module-dir (progn (string-match "^\\([a-zA-Z0-9_:]+[^:]\\):*$" module-dir)
			    (match-string 1 module-dir)))
    (let* (
	   ( dirs (bioperl-module-names module-dir retopt t) )
	   ( modules (split-string module-dir "::" t) )
	   ( complet ) 
	   )

      ;; check once and recalc
      (if (not dirs)
	  (progn 
	    ;; trim back to last ::
	    (setq module-dir
		  (progn 
		    (string-match  "^\\(\\(?:[a-zA-Z0-9_]+::\\)+\\)\\(?::*\\|[a-zA-Z0-9_]*\\)$" module-dir) 
		    (match-string 1 module-dir)))
	    (setq dirs (bioperl-module-names module-dir retopt t))
	    (setq modules (split-string module-dir "::" t))
	    ))
      (if (not dirs)
	  ;; fail
	  nil
	(setq complet (let* ( (l modules)
			      (m (list (pop l))) )
			(while l (push (concat (car m) "::" (pop l)) m))
			(mapcar (lambda (x) (cons x nil)) m ) ))
	;; make sure module-dir is trimmed
	(setq module-dir (replace-regexp-in-string "::$" "" module-dir))
	complet
	(append complet (mapcar (lambda (x) 
				  (list
				   (concat module-dir "::" (car x)) 
				   (cdr x))) dirs))
	))
      ))

;;
;; utilities
;;

(defun bioperl-clear-module-cache ()
  (interactive)
  "Clears the variable `bioperl-module-names-cache'. Run if you change `bioperl-module-path'."
  (setq bioperl-module-names-cache nil)
  (setq bioperl-module-names-cache '(("Bio"))))

; XEmacs compability for assoc-string (from http://web.mit.edu/shutkin/MacData_1124b/afs/athena/contrib/xemacs/share/xemacs-packages/lisp/calendar/cal-compat.el):
; thanks Adam
(if (fboundp 'assoc-string)
    (defalias 'bioperl-assoc-string 'assoc-string)
  (defun bioperl-assoc-string (key list case-fold)
    (if case-fold
        (bioperl-assoc-ignore-case key list)
      (assoc key list)))  
  )


;;
;; utilities (out of bioperl- namespace)
;;

    
(defun assoc-all (key alist &optional ret)
  "Return list of *pointers* (like assoc) to all matching conses in the alist.
Uses `bioperl-assoc-string' for case control."
  (let ( (c (bioperl-assoc-string key alist t)) ) 
    (if c 
	(assoc-all key (cdr alist) (if ret (add-to-list 'ret c t) (list c)))
      ret)))

(defun deep-assoc (keys alist)
  "Return the associations of a set of keys in an alist tree.
Uses `bioperl-assoc-string' for case control."
  (cond
   ((not keys) 
    nil)
   ((not (listp alist))
    nil)
   ((= (length keys) 1)
    (bioperl-assoc-string (pop keys) alist t))
   (t
    (let* ( (key (pop keys))
	    (newlist (bioperl-assoc-string key alist t)) ) 
      (if newlist
	  (deep-assoc keys (cdr newlist))
	(deep-assoc nil nil)))
    )))

(defun deep-assoc-all (keys alist)
  "Return all associations AT THE TIP described by the set of KEYS in an alist tree.
So this is not completely general, but is specialized to the structure of `bioperl-module-names-cache'."
  (cond
   ((not keys) 
    nil)
   ((not (listp alist))
    nil)
   ((= (length keys) 1)
    (assoc-all (pop keys) alist))
   (t
    (let* ( (key (pop keys))
	    (newlist (assoc-all key alist)) ) 
      (if newlist
	  (let ( ( i 0 ) (r)  )
	    (while (< i (length newlist))
	      (if (listp (cdr (elt newlist i)))
		  (setq r (deep-assoc-all keys (cdr (elt newlist i)))))
	      (setq i (1+ i)))
	    r)
	(deep-assoc-all nil nil)))
    )))


(defun pm-p (x)
  (not (null (string-match "[.]pm\$" x))))

(defun split-string-compat (str &optional sep omit-nulls)
  "`split-string' for 21"
  (if omit-nulls
      (delete nil (mapcar (lambda (x) (if (string-equal x "") nil x)) (split-st\
ring str sep)))
    (split-string str sep)))

(defun file-name-squish (fname)
  "Squish long file names with central elipses.
FNAME is the file name as string. Doesn't work very hard."
  (let* (
	 (fname-list (split-string fname "/"))
	 (squished)
	 )
    (if (> (length fname-list) 3)
	(concat (elt fname-list 0) "/" 
		(elt fname-list 1) "/"
		(if (= (length fname-list) 4) (elt fname-list 2)  "...")
		"/"
		(car (last fname-list)))
      fname)))

;; XEmacs compatibility

(defun bioperl-assoc-ignore-case (key alist)
  "Like `assoc', but assume KEY is a string and ignores case when comparing.
This version allows alist cars to be strings and not necessarily lists."
  (setq key (downcase key))
  (let (element)
    (while (and alist (not element))
      (if (equal key (downcase
		      (if (listp (car alist)) (car (car alist)) (car alist))))
	  (setq element (car alist)))
      (setq alist (cdr alist)))
    element))

;; hook into perl-mode

(add-hook 'perl-mode-hook 'bioperl-perl-mode-infect)
(if bioperl-this-is-xemacs
    (add-hook 'cperl-mode-hook 'bioperl-perl-mode-infect))

(provide 'bioperl-mode)




;;; end bioperl-mode.el
  
  
;;
;; scratch area
;;
(unless nil






)
BioPerl-1.6.923/ide/bioperl-mode/site-lisp/bioperl-skel.el000555000765000024      2607412254227321 23432 0ustar00cjfieldsstaff000000000000;; $Id$

;;
;; Template insertion skeletons for Bioperl minor mode
;;
;; Author: Mark A. Jensen
;; Email : maj -at- fortinbras -dot- us
;;
;; Part of The Documentation Project
;; http://www.bioperl.org/wiki/The_Documentation_Project
;;
;; This file is loaded upon bioperl-mode initialization
;; 
;; templates based on bioperl.lisp by Heikki Lehvaslaiho
;;

;; Copyright (C) 2009 Mark A. Jensen

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.  See the GNU General Public License for more details.

;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;; For these to work properly, `bioperl-skel-elements' must be called
;; from within the buffer. This is done automatically when
;; bioperl-mode is enabled.

;; A gotcha:
;;
;; There is a funky requirement for `prompt-once', that seems to 
;; have to do with the `skeleton-insert' internals.
;;
;; You appear to need to do a print of str before leaving
;; a skeleton or subskeleton, or you get an infinite loop
;;
;; e.g., in `bioperl-array-accessor-skel', we do
;;
;;    ( (prompt-once "Class name of base object: ")
;;      " Returns : An array of " str " objects"
;;      '(setq v1 str) )
;; 
;; which completes and makes v1 available in the top-level
;; skeleton, rather than, say,
;;
;;    ( (prompt-once "Class name of base object: ")
;;      '(setq v1 str) )
;;    " Returns : An array of " v1 " objects"
;;
;; which hangs.

(defconst bioperl-skel-revision "$Id$"
  "The revision string of bioperl-skel.el")

(make-variable-buffer-local 'prompt-once-alist)
(defvar prompt-once-alist '()
  "An internal var for the skeleton prompt-once facility.")


(define-skeleton bioperl-insert-class
  "Insert a template for a new BioPerl class/method."
  nil
  bioperl-class-pod-skel)

(define-skeleton bioperl-insert-method-pod
  "Insert a standard pod template for BioPerl methods."
  nil
  bioperl-method-pod-skel)

(define-skeleton bioperl-insert-accessor
  "Insert a standard accessor (getter/setter)."
  nil
  bioperl-accessor-skel)

(define-skeleton bioperl-insert-array-accessor
  "Insert a set of standard object array methods."
  nil
  bioperl-array-accessor-skel)

(define-skeleton bioperl-insert-abstract-method
  "Insert an abstract (\"throw_not_implemented\") method."
  nil
  bioperl-abstract-method-skel)

(define-skeleton bioperl-insert-generic-class
  "Insert a generic package pod template."
  nil
  bioperl-generic-class-pod-skel)

(defvar bioperl-method-pod-skel 
      '((prompt-once "Method name:")
	\N 
	\N "=head2 " str "()" 
	\N 
	\N " Title   : " str 
	\N " Usage   : " 
	\N " Function: " - 
	\N " Returns : " 
	\N " Args    : " 
	\N 
	\N "=cut" \N)
"Skeleton for a basic method pod header."
 )

(defvar bioperl-generic-class-pod-skel
  '(
    (prompt-once "Class name: ")
    "package " str ";" \N
    "use strict;" \N
    "use warnings;" \N
    \N
    "=head1 NAME" \N 
    \N 
    str " - " - "DESCRIPTION of Object" \N 
    \N
    "=head1 SYNOPSIS" \N 
    \N
    "Give standard usage here" \N
    \N
    "=head1 DESCRIPTION" \N
    \N
    _ "Describe the object here" \N
    \N
    ( (prompt-once "Author: ")
      "=head1 AUTHOR - " str \N )
    \N
    "=head1 METHODS" \N
    \N
    "=cut" \N
    \N
    "# Let the code begin..." \N
    \N \N \N
    "1;")
  "Skeleton for a generic package template")

(defvar bioperl-class-pod-skel
  '(
    (prompt-once "Class name: ")
    "# $Id" "$" \N
    "#" \N
    "# BioPerl module for " str \N
    "#" \N
    "# Please direct questions and support issues to " \N
    "#" \N
    ( (prompt-once "Caretaker: ")
      "# Cared for by " str '(setq v1 str) )
    ( (prompt-once "Email: ")
      " <" str ">" \N '(setq v2 str))
    "#" \N
    "# Copyright " v1 \N
    "#" \N
    "# You may distribute this module under the same terms as perl itself" \N \N
    "# POD documentation - main docs before the code" \N 
    \N
    "=head1 NAME" \N 
    \N 
    str " - " - "DESCRIPTION of Object" \N 
    \N
    "=head1 SYNOPSIS" \N 
    \N
    "Give standard usage here" \N
    \N
    "=head1 DESCRIPTION" \N
    \N
    "Describe the object here" \N
    \N
    "=head1 FEEDBACK" \N
    \N
    "=head2 Mailing Lists" \N
    \N
    "User feedback is an integral part of the evolution of this and other" \N
    "Bioperl modules. Send your comments and suggestions preferably to" \N
    "the Bioperl mailing list.  Your participation is much appreciated." \N
    \N
    "  bioperl-l@bioperl.org                  - General discussion" \N  
    "http://bioperl.org/wiki/Mailing_lists  - About the mailing lists" \N
    \N
    "=head2 Support" \N
    \N
    "Please direct usage questions or support issues to the mailing list:" \N
    \N
    "L" \N
    \N
    "rather than to the module maintainer directly. Many experienced and" \N
    "reponsive experts will be able look at the problem and quickly" \N
    "address it. Please include a thorough description of the problem" \N
    "with code and data examples if at all possible." \N 
    \N
    "=head2 Reporting Bugs" \N
    \N
    "Report bugs to the Bioperl bug tracking system to help us keep track" \N
    "of the bugs and their resolution. Bug reports can be submitted via" \N
    "the web:" \N
    \N
    "  https://redmine.open-bio.org/projects/bioperl/" \N 
    \N
    "=head1 AUTHOR - " v1 \N
    \N
    "Email " v2 \N
    \N
    "Describe contact details here" \N
    \N
    "=head1 CONTRIBUTORS" \N
    \N
    "Additional contributors names and emails here" \N
    \N
    "=head1 APPENDIX" \N
    \N
    "The rest of the documentation details each of the object methods." \N
    "Internal methods are usually preceded with a _" \N
    \N
    "=cut" \N
    \N
    "# Let the code begin..." \N
    \N \N
    "package " str ";" \n
    "use strict;" \n
    \n
    "# Object preamble - inherits from Bio::Root::Root" \n
    \n
    "use Bio::Root::Root;" \n \n
    \n
    "use base qw(Bio::Root::Root );" \n
    \n
    "=head2 new" \N
    \N 
    " Title   : new" \N 
    " Usage   : my $obj = new " str "();" \N 
    " Function: Builds a new " str " object" \N 
    " Returns : an instance of " str \N 
    " Args    :" \N
    \N
    "=cut" \N
    \N
    "sub new {" \n  
    "my ($class,@args) = @_;" \n
    \n  
    "my $self = $class->SUPER::new(@args);" \n
    "return $self;" \n
    "}" > \n
    \N
    "1;")
  "Skeleton for a BioPerl module template." )

(defvar bioperl-accessor-skel
  '(
    (prompt-once "Field name: ")
    "=head2 " str "()" \N
    \N
    " Title   : " str \N 
    " Usage   : $obj->" str "($newval)" \N 
    " Function: " _ \N 
    " Example : " \N 
    " Returns : value of " str " (a scalar)" \N 
    " Args    : on set, new value (a scalar or undef, optional)" \N
    \N
    "=cut" \N
    \N
    "sub " str " {" \n
    "my $self = shift;" > \n
    \n
    "return $self->{'" str "'} = shift if @_;"
    \n
    "return $self->{'" str "'};" \n
    "}" > \n
    \N)
  "Skeleton for a BioPerl accessor (getter/setter).")

(defvar bioperl-array-accessor-skel
  '(
    (prompt-once "Array base object: ")
    "=head2 get_" str "s" \N
    \N 
    " Title   : get_" str "s" \N
    " Usage   : @arr = get_" str "s()" \N 
    " Function: Get the list of " str "(s) for this object." \N 
    " Example : " \N 
    ( (prompt-once "Class name of base object: ")
      " Returns : An array of " str " objects" \N
      '(setq v1 str) )
    " Args    : " \N
    \N
    "=cut" \N
    \N
    "sub get_" str "s{" > \n
    "my $self = shift;" \n
    \n
    "return @{$self->{'_" str "s'}} if exists($self->{'_" str "s'});" \n 
    "return ();" \n
    "}" \n
    \n
    "=head2 add_" str \N
    \N
    " Title   : add_" str \N 
    " Usage   : " \N 
    " Function: Add one or more " str "(s) to this object." \N 
    " Example : " \N 
    " Returns : " \N
    " Args    : One or more " v1 " objects." \N
    \N
    "=cut" \N
    \N
    "sub add_" str "{" > \n 
    "my $self = shift;" \n
    \n 
    "$self->{'_" str "s'} = [] unless exists($self->{'_" str "s'});" \n 
    "push(@{$self->{'_" str "s'}}, @_);" \n
    "}" \n
    \n
    "=head2 remove_" str "s" \N
    \N
    " Title   : remove_" str "s" \N
    " Usage   : "
    \N
    " Function: Remove all " str "s for this class." \N 
    " Example : " \N
    " Returns : The list of previous " str "s as an array of" \N           
    "          " v1 " objects." \N
    " Args    : " \N
    \N
    "=cut" \N 
    \N
    "sub remove_" str "s{" > \n 
    "my $self = shift;" \n
    \n 
    "my @arr = $self->get_" str "s();" \n
    "$self->{'_" str "s'} = [];" \n 
    "return @arr;" \n
    "}" > \n
    \N)
  "Skeleton for object array get/add/remove methods.")

(defvar bioperl-abstract-method-skel
  '(
    (prompt-once "Method name: ")
    "=head2 " str \N
    \N
    " Title   : " str \N
    " Usage   : " \N
    " Function: " _ \N
    " Example : " \N
    " Returns : " \N
    " Args    : " \N
    \N
    "=cut" \N
    \N
    "sub " str "{" \n
    "my ($self) = @_;" \n
    \n    
    "$self->throw_not_implemented();" \n
    "}" > \n
    \N
    )
  "Skeleton for an abstract BioPerl method (for interface classes).")

;;; skeleton helpers

(defun bioperl-skel-elements ()
  "Set some `skeleton-further-elements' for bioperl-skel in the buffer."
  (interactive)
  (setq skeleton-further-elements '( (\N "\n") )))
  
(defun prompt-once (prom)
  "Use in place of plain interactor string to prompt only once in a skeleton.
Entering a blank value quits the skeleton completely.

The skeleton system default behavior is to recursively insert a
skeleton as long as the user continues to provide input to a
prompt. The recursion ends when an empty string is entered as a
prompt. This is rather irritating when the user expects to make a
single entry and then move on. Using prompt-once as the
INTERACTOR for the skeleton or subskeleton will inhibit the
recursion.

Example:
 (define-skeleton myskel 
  \"Insert a pretend skeleton, with prompts\"
  nil ;; important
  '(
    (prompt-once \"Enter froob:\") ;; NO quote
    \"Froob is \" str \\n
    \"Now do a sub-skeleton with prompts...\" \\n
    ( (prompt-once \"Sklarb:\")
      \"Sklarb is \" str \\n )
    \"You've been a wonderful audience. Good night.\" \\n) )"

  (condition-case nil
      (let ( (flag (assoc prom prompt-once-alist) )
	     (inp) )
	(cond
	 ( (not flag)
	  (setq inp (read-string prom))
	  (if (> (length inp) 0)
	      (add-to-list 'prompt-once-alist (cons prom "1"))
	    (if (> (length prompt-once-alist) 0) 
		(signal 'quit t)))
	  inp)
	 ( flag
	   (setq prompt-once-alist (delq flag prompt-once-alist))
	   nil)))
    ('quit
     (if (= (length prompt-once-alist) 0) 
	 (signal 'quit t)
       (setq prompt-once-alist nil) 
       (signal 'quit 'recursive))
)))

(provide 'bioperl-skel)

;;; end bioperl-skel.elBioPerl-1.6.923/ide/bioperl-mode/site-lisp/pod.el000555000765000024      1465012254227335 21626 0ustar00cjfieldsstaff000000000000;; $Id$
;;

;;
;; Emacs functions for simple Perl pod parsing
;;  parse result format based on pod2text
;;
;; required in bioperl-mode.el
;; 
;; Author: Mark A. Jensen
;; Email : maj -at- fortinbras -dot- us
;;
;; Part of The Documentation Project
;; http://www.bioperl.org/wiki/The_Documentation_Project
;;
;;

;; Copyright (C) 2009 Mark A. Jensen

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3 of
;; the License, or (at your option) any later version.

;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.  See the GNU General Public License for more details.

;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

(defvar pod-keywords 
  '( "pod" "head1" "head2" "head3" "head4" "over" "item" "back" "begin" "end" "for" "encoding" "cut" )
  "Perl pod keywords (sans '=') ")

(defvar pod-format-codes 
  '( "I" "B" "C" "L" "E" "F" "S" "X" "Z" )
  "Perl pod format codes (sans <>)" )

(defun pod-parse-buffer (buf &optional alt-format)
  "Parse the pod in the BUF.
Removes code and leaves pod. Does some simple formatting a la
pod2text as setup for pod-mode. If ALT-FORMAT is true, headers 
are flanked by '='s as in pod2text -a. "
  (save-excursion
    (set-buffer buf)
    (let (
	  (cur-state)
	  (cur-content)
	  (tmp-state)
	  (tmp-content)
	  (encoding-type)
	  (parse-tree '(("Root")))
	  (line)
	  (header-level)
	  (beg (goto-char (point-min)))
	  (end)
	  (tbeg) (tend) ;; text region
	  )
      (goto-char (point-min))
      ;; get encoding if present
      (if (re-search-forward "^=encoding\\s +\\(.*?\\)\\s " (point-max) t)
	  (setq encoding-type (match-string 1)))
      (goto-char (point-min))
      (while (not (eobp))
	(setq end (re-search-forward "^=\\([a-z0-9]+\\)\\(?:$\\|\\s *\\(.*?\\)\\)$" (point-max) 1))
	(if (not end)
	    t ;; done
	  (setq tmp-state (match-string 1))
	  (setq tmp-content (match-string 2))
	  (if (not cur-state)
	      (progn
		(beginning-of-line)
		(pod-do-format "ignore" beg (point))
		(setq end beg)))
	  (setq cur-state tmp-state)
	  (setq cur-content tmp-content)
	  (if (not cur-state)
	      t ;; done
	    ;; otherwise, in a pod region
	    (if (not (member cur-state pod-keywords))
		(error (concat "'" cur-state "' not a pod keyword")))
	    (cond 
	     ( (not cur-state) 
	       nil ;; ????
	       )
	     ( (string-equal cur-state "cut")
	       (forward-line 0)
	       (kill-line 2)
	       (pod-do-format "text" beg (point))
	       (setq cur-state nil) )
	     ( (string-equal cur-state "pod")
	       (forward-line 0)
	       (kill-line 2)
	       (pod-do-format "text" beg (point))
	       )
	     ( (string-match "head\\([1-4]\\)" cur-state)
	       (setq head-level (string-to-number (match-string 1 cur-state)))
	       (forward-line 0)
	       (kill-line 2)
	       (pod-do-format "text" beg (point))
	       (if (not cur-content)
		   nil
		 (if (not alt-format)
		     (progn 
		       (insert-char ?  (* 2 (1- head-level)))
		       (insert cur-content "\n"))
		   (cond 
		    ((= head-level 1)
		     (insert "==== " cur-content " ====\n"))
		    ((= head-level 2)
		     (insert "==   " cur-content "   ==\n"))
		    ((= head-level 3)
		     (insert "=    " cur-content "    =\n"))
		    ((= head-level 4)
		     (insert "-    " cur-content "    -\n"))))
		 ))
	     ( (string-equal cur-state "over") 
	       (let (
		     (indent-level cur-content)
		     (back (save-excursion
			     (re-search-forward "^=back" (point-max) t)))
		     )
		 (unless back
		   (error "=over has no matching =back"))
		 (forward-line 0)
		 (kill-line 2)
		 (pod-do-format "text" beg (point))
		 (setq beg (point))
		 (while (re-search-forward "^=item\\s +\\(.*?\\)$" back t)
		   (let ( (item (match-string 1) ) )
		     (forward-line 0)
		     (kill-line 2)
		     (pod-do-format "text" beg (point))
		     (if (not alt-format)
			 (insert "    * " item "\n")
		       (insert ":   " item "\n")))
		   (setq beg (point)))
		 (re-search-forward "^=back" (point-max))
		 (forward-line 0)
		 (kill-line 2) 
		 (pod-do-format "text" beg (point))
		 ))
	     ( (string-equal cur-state "begin")
	       (let (
		     (format cur-content)
		     (end (save-excursion
			    (re-search-forward (concat "^=end\\s +" format)
					       (point-max) t)))
		     (content-beg) (content-end)
		     )
		 (unless end
		   (error (concat "=begin " format " has no matching end.")))
		 (forward-line 0)
		 (kill-line 2)
		 (setq content-beg (point))
		 (re-search-forward  (concat "^=end\\s +" format))
		 (forward-line 0)
		 (kill-line 2)
		 (setq content-end (point))
		 (pod-do-format format content-beg content-end)
		 ))
	     ( (string-equal cur-state "for")
	       (string-match "\\([a-z]+\\)\\s +\\(.*?\\)$" cur-content)
	       (let (
		     (format (match-string 1 cur-content))
		     (content (match-string 2 cur-content))
		     )
		 (forward-line 0)
		 (kill-line 2)
		 (pod-do-format "text" beg (point))
		 ))
	     ( (string-equal cur-state "encoding")
	       (let (
		     (type cur-content)
		     )
		 (forward-line 0)
		 (kill-line 2)
		 (pod-do-format "text" beg (point))		 
		 t))
	     ))	   
	  ;; movement here?
	  (setq beg (point))
	  (setq cur-content nil) ;; clear means 'moved off pod descr line'
	))
      (pod-do-format (if cur-state "text" "ignore") beg (point-max))
      t)
    ))

(defun pod-do-format (format beg end)
  "Handle pod =begin format ... =end format blocks.
FORMAT is a format identifier (a string); BEG and END define the
text region."
  ;; ignore for now
  (if (= beg end)
      nil
    (cond
     ((string-equal format "ignore")
      (delete-region beg end))
     ((string-equal format "text")
      ;; format ordinary and verbatim lines
      (save-excursion
	(goto-char beg)
	(forward-line 0)
	(while (and (< (point) end) (not (eobp)))
	  (cond
	   ((string-match "[[:blank:]]" (char-to-string (char-after)))
	    (insert-char ?  4)
	    (setq end (+ end 4)))
	   ((string-match "[[:space:]]" (char-to-string (char-after)))
	    t)
	   (t
	    (insert-char ?  4)
	    (setq end (+ end 4))))
	  (forward-line 1)
	  )))
     (t 
      ;; otherwise, remove (ignore)
      (delete-region beg end)) )))

(provide 'pod)BioPerl-1.6.923/maintenance000755000765000024          012254227340 15562 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/maintenance/authors.pl000555000765000024      1273312254227326 17776 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
#
=head1 NAME

authors.pl - check modules and scripts for authors not in AUTHORS file

=head1 SYNOPSIS

B [B<-d|--dir> path ] [B<-v|--verbose>] B<-a|--authorsfile>
    [B<-?|-h|--help>]

=head1 DESCRIPTION

Checks Plain Old Documentation (POD) of all bioperl live modules for
AUTHORS and CONTRIBUTORS tags and prints out any emails missing from
the AUTHORS file

=cut

use Data::Dumper;
use File::Find;
use Getopt::Long;
use strict;

sub findauthors;

#
# command line options
#

my ($verbose, $dir, $authorsfile, $help) = (0, undef, "../AUTHORS", undef);
GetOptions(
           'v|verbose' => \$verbose,
           'dir:s' => \$dir,
           'authorsfile:s' => \$authorsfile,
	   'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
	   );

#
# global variables
#

# known authors from the AUTHORS file are read into
# the hash which is initialized with known synonymes
our %AUTHORS = map {$_=>1} qw{
                              birney@sanger.ac.uk
                              jinsana@gmx.net
                              Insana@ebi.ac.uk
                              fugui@worf.fugu-sg.org
                              cjm@fruitfly.bdgp.berkeley.edu
                              elia@tll.org.sg
                              heikki-at-bioperl-dot-org
                              bioinformatics@dieselwurks.com
                              bioinformatics1@dieselwurks.com
                              bioperl-l@bio.perl.org
                              paul@systemsbiology.org
                              gattiker@isb-sib.ch
                              elia@fugu-sg.org
                              jason@cgt.mc.duke.edu
                              jason@chg.mc.duke.edu
                              jason@open-bio.org
                              hilmar.lapp@pharma.novartis.com
                              richard.adams@ed.ac.uk
                              dblock@gene.pbi.nrc.ca
                              ak@ebi.ac.uk
                              day@cshl.org
                              bala@tll.org.sg
                              mrp@sanger.ac.uk
                              m.w.e.j.fiers@plant.wag-ur.nl
                              cmzmasek@yahoo.com
                              fuguteam@fugu-sg.org
                              shawnh@gmx.net
                          };
our %NEWAUTHORS;     # new authors
our %FIND_OPTIONS = ( wanted => \&findauthors, no_chdir => 1 );


# Directories to check
my @dirs = qw( ../Bio/ ../scripts . );

#print Dumper \%AUTHORS;

#
# Read the AUTHORS file
#


open (F, $authorsfile) || die "can't open file $authorsfile: $!";


while () {
    my ($email) = /([\.\w_-]+ at [\.\w_-]+)/;
    next unless $email;
    #print $email, "\n";
    $email =~ s/ at /@/;
    $AUTHORS{$email} = 1;
}
close F;


#
# run
#

if ($dir) {
    find \%FIND_OPTIONS, $dir;
} else {
    find \%FIND_OPTIONS, @dirs;
}

#
# results
#
print Dumper \%NEWAUTHORS;


#
##
### end main
##
#

#
# this is where the action is
#
sub findauthors {
    return unless /\.PLS$/ or /\.p[ml]$/ ;
    return unless -e $_;
    print "$_\n" if $verbose;
    my $filename = $_;
    #local $/=undef;
    open F, $_ || die "Could not open file $_";
    while () {
        #print;
        last if /=head1 +AUTHOR/;
    }
    my $authorblock;
    while () {
        last if /=head/ and not /CONTRIBUTORS/;
        $authorblock .= $_;
    }
    return unless $authorblock;
    while ( $authorblock =~ /([\.\w_-]+@[\.a-z_-]+)/g) {
        #my $email = $1;
        #$email =~ //
        next if $AUTHORS{$1};
        #print "$filename\t$1\n";

        push @{$NEWAUTHORS{$1}}, $filename;

    }
}



=head1 OPTIONS

=over 3

=item B<-d | --dir> path

Overides the default directories to check by one directory 'path' and
all its subdirectories.

=item B<-a | --authorsfile>

path from working directory the AUTHORS file.

Redundant as this information could be had from --dir option butI am
feeling too lazy to change the code.

=cut

sub blankline {
    return unless /\.PLS$/ or /\.p[ml]$/ ;
    return unless -e $_;
    my $file = $_;
    open (F, $_) or warn "can't open file $_: $!" && return;
    local $/="";
    while () {
        print "$file: +|$1|\n" if /[ \t]\n(=[a-z][^\n]+$)/m and $verbose;
        print "$file: ++|$1|\n" if /\w\n(=[a-z][^\n]+$)/m and $verbose;
        print "$file:|$1|+\n" if /(^=[a-z][^\n]+)\n[\t ]/m;
        #print "$file:|$1|++\n" if /(^=[^\n]+)\n\w/m;
    }
    close F;
}

__END__

=item B<-v | --verbose>

Show the progress through files during the POD checking.

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Heikki Lehvaslaiho

Email heikki-at-bioperl-dot-org

=cut


# find . -name '*.pm' -print | xargs  perl -e '$/=""; while (<>) {$n = $1 if /^package\s+([\w:]+)/; print "$n:|$1|"  if  /(\s\s^=[^\n]+$)/m ; }'  ;

# find . -name '*.pm' -print | xargs  perl -e '$/=""; while (<>) {$n = $1 if /^package\s+([\w:]+)/; print "$n:|$1|\n"  if /(^=[^\n]+\n[\t ])/m ; }'  ;
BioPerl-1.6.923/maintenance/check_NAME.pl000555000765000024       503712254227316 20144 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=head1 NAME

check_NAMEs.pl - check NAME in module POD has fully qualified object name

=head1 SYNOPSIS

B [B<-d|--dir> path] [B<-v|--verbose>] [B<-?|-h|--help>]

=head1 DESCRIPTION

This script is designed to find all Bioperl modules which don't
have the fully qualified object name with correct capitalization
in the "NAME" section of the POD. 

The full name is required for the PDOC POD to HTML script to
correctly render the module documentation.

=cut

use strict;
use File::Find;
use Getopt::Long;

#
# command line options
#

my ($verbose, $dir, $help) = (0, '../Bio/', undef);
GetOptions(
    'v|verbose' => \$verbose,
    'd|dir:s' => \$dir,
    'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
);

#
# globals
#

my $num_found = 0;

#
# find all modules
#

print STDERR "Searching for incorrect NAME POD section of all modules in: $dir\n";
find( \&find_modules, $dir );
print STDERR "$num_found found.\n";

# this is where the action is

sub find_modules {
    # only want files with .pm
    return unless m/\.pm$/;
    return unless -f $_;
    
    my $fname = $_;
    my $pm = $File::Find::name;
    $pm =~ s{.*?/(?=Bio/)}{};  # remove up to first slash before Bio/
    $pm =~ s{\.pm$}{};         # remove .pm suffix
    $pm =~ s{/}{::}g;          # convert / to ::
    
    print STDERR "# $File::Find::name\n" if $verbose;
    
    # slurp in the file
    my $text = do { local( @ARGV, $/ ) = $fname ; <> } ;

    # check if the NAME section has the _full_ module name in it
    if ($text !~ m/^=head1\s+NAME.*?^$pm/xms) {
      print "$pm\n";
      $num_found++;
    }
}


=head1 OPTIONS

=over 3

=item B<-d | --dir> path

Overides the default directory to recursively look for .pm file 
(Default is '../Bio')

=item B<-v | --verbose>

Show the progress through files during the POD checking.

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Torsten Seemann

Email: torsten-dot-seemann-at-infotech-dot-monash-dot-edu-dot-au

=cut
BioPerl-1.6.923/maintenance/check_URLs.pl000555000765000024       707112254227313 20246 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=head1 NAME

check_URLs.pl - validate URLs located in module code and POD

=head1 SYNOPSIS

B [B<-d|--dir> path] [B<-v|--verbose>] [B<-?|-h|--help>]
    [B<-o|--outfile> filename]

=head1 DESCRIPTION

Checks code and POD of all bioperl-live modules for URLs, and validates them.

Output is a series of lines containing two fields, tab separated.
The first field is the file with the bad URL, the second is the URL itself.

The whole URL is not retrieved, only a HTTP "HEAD" request is done
to see if the URL exists on the server. The request is done using 
B so the B environmental variable will be
honoured.

The URL parsing may not be perfect - although I use the B
module, I have to manually clean up some URLs which are embedded in Perl
strings to convert the matched URL to a more probable real world URL,
e.g. most URLs don\'t end in "'," or ")" :-)

=cut

use strict;
use Data::Dumper;
use File::Find;
use Getopt::Long;
use Regexp::Common qw(URI);
use LWP::Simple qw($ua head);

$ua->timeout(15);

#
# command line options
#

my ($verbose, $dir, $help) = (0, '../Bio/', undef);
my $file;
GetOptions(
    'v|verbose' => \$verbose,
    'd|dir:s' => \$dir,
    'o|outfile:s' => \$file,
    'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
);

my $fh;

if (defined $file) {
    open($fh, '>', $file) || die "Can't open file : $!";
} else {
    $fh = \*STDOUT;
}

#
# find all modules
#

find( \&find_modules, $dir );

#
# validate unique URLs and print fail cases to stdout
#

my %cached_urls;

sub check_url {
    my ($url, $file) = @_;
    if (exists $cached_urls{$url}) {
        print STDERR "$url checked in ".$cached_urls{$url}[0].":".$cached_urls{$url}[1]."\n" if $verbose;
        print $fh "$file\t$url\n" if $cached_urls{$url}[1] ne 'ok';
        return;
    }
    print STDERR "Checking $url in $file... " if $verbose;
    my $ok = head($url);
    my $status = $ok ? 'ok' : 'FAIL!';
    print STDERR "$status!\n" if $verbose;
    print $fh "$file\t$url\n" if !$ok;
    $cached_urls{$url} = [$file, $status];
}

close $fh if $file; # don't close STDOUT

#
# this is where the action is
#

sub find_modules {
    # only want files with .pm
    return unless m/\.pm$/;
    return unless -f $_;
    
    my $fname = $_;
    
    # slurp in the file
    my $text = do { local( @ARGV, $/ ) = $fname ; <> } ;
    
    # keep track of URLs
    while ($text =~ m/$RE{URI}{HTTP}{-keep}/g) {
        my $url = $1 or next;
        # remove Perl code if URL was embedded in string and other stuff
        $url =~ s/\s*[.,;'")]*\s*$//;
        check_url($url, $File::Find::name);
    }    
}


=head1 OPTIONS

=over 3

=item B<-d | --dir> path

Overides the default directory to recursively look for .pm file 
(Default is '../Bio')

=item B<-v | --verbose>

Show the progress through files during the POD checking.

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Torsten Seemann

Email: torsten-dot-seemann-at-infotech-dot-monash-dot-edu-dot-au

=cut
BioPerl-1.6.923/maintenance/cvs2cl_by_file.pl000555000765000024     26663112254227320 21220 0ustar00cjfieldsstaff000000000000#!/bin/sh
exec perl -w -x $0 ${1+"$@"} # -*- mode: perl; perl-indent-level: 2; -*-
#!perl -w

###########################################################################
# This is a quick hack version of cvs2cl.pl (see below)
# that simply outputs in a file-centric mannor.
# only CVS::Utils::ChangeLog::EntrySet::Output::output_changelog
# was altered
# 
# Usage:
# cvs2cl_by_file.pl --delta bioperl-release-1-5-1:bioperl-release-1-5-2
# Generates a file called ChangeLog showing, per file, all the commit
# messages since tag bioperl-release-1-5-1 up to tag bioperl-release-1-5-2
# It generates in wikipedia format suitable for immediate pasting into the
# a wiki page for the delta
#
# Sendu Bala 
###########################################################################


##############################################################
###                                                        ###
### cvs2cl.pl: produce ChangeLog(s) from `cvs log` output. ###
###                                                        ###
##############################################################

##

use strict;

use File::Basename qw( fileparse );
use Getopt::Long   qw( GetOptions );
use Text::Wrap     qw( );
use Time::Local    qw( timegm );
use User::pwent    qw( getpwnam );
use File::Spec;

# The Plan:
#
# Read in the logs for multiple files, spit out a nice ChangeLog that
# mirrors the information entered during `cvs commit'.
#
# The problem presents some challenges. In an ideal world, we could
# detect files with the same author, log message, and checkin time --
# each  would be a changelog entry.
# We'd sort them; and spit them out.  Unfortunately, CVS is *not atomic*
# so checkins can span a range of times.  Also, the directory structure
# could be hierarchical.
#
# Another question is whether we really want to have the ChangeLog
# exactly reflect commits. An author could issue two related commits,
# with different log entries, reflecting a single logical change to the
# source. GNU style ChangeLogs group these under a single author/date.
# We try to do the same.
#
# So, we parse the output of `cvs log', storing log messages in a
# multilevel hash that stores the mapping:
#   directory => author => time => message => filelist
# As we go, we notice "nearby" commit times and store them together
# (i.e., under the same timestamp), so they appear in the same log
# entry.
#
# When we've read all the logs, we twist this mapping into
# a time => author => message => filelist mapping for each directory.
#
# If we're not using the `--distributed' flag, the directory is always
# considered to be `./', even as descend into subdirectories.

# Call Tree

# name                         number of lines (10.xii.03)
# parse_options                         192
# derive_changelog                       13
# +-maybe_grab_accumulation_date         38
# +-read_changelog                      277
#   +-maybe_read_user_map_file           94
#     +-run_ext                           9
#   +-read_file_path                     29
#   +-read_symbolic_name                 43
#   +-read_revision                      49
#   +-read_date_author_and_state         25
#     +-parse_date_author_and_state      20
#   +-read_branches                      36
# +-output_changelog                    424
#   +-pretty_file_list                  290
#     +-common_path_prefix               35
#   +-preprocess_msg_text                30
#     +-min                               1
#   +-mywrap                             16
#   +-last_line_len                       5
#   +-wrap_log_entry                    177
#
# Utilities
#
# xml_escape                              6
# slurp_file                             11
# debug                                   5
# version                                 2
# usage                                 142

# -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*-
#
# Note about a bug-slash-opportunity:
# -----------------------------------
#
# There's a bug in Text::Wrap, which affects cvs2cl.  This script
# reveals it:
#
#   #!/usr/bin/perl -w
#
#   use Text::Wrap;
#
#   my $test_text =
#   "This script demonstrates a bug in Text::Wrap.  The very long line
#   following this paragraph will be relocated relative to the surrounding
#   text:
#
#   ====================================================================
#
#   See?  When the bug happens, we'll get the line of equal signs below
#   this paragraph, even though it should be above.";
#
#
#   # Print out the test text with no wrapping:
#   print "$test_text";
#   print "\n";
#   print "\n";
#
#   # Now print it out wrapped, and see the bug:
#   print wrap ("\t", "        ", "$test_text");
#   print "\n";
#   print "\n";
#
# If the line of equal signs were one shorter, then the bug doesn't
# happen.  Interesting.
#
# Anyway, rather than fix this in Text::Wrap, we might as well write a
# new wrap() which has the following much-needed features:
#
# * initial indentation, like current Text::Wrap()
# * subsequent line indentation, like current Text::Wrap()
# * user chooses among: force-break long words, leave them alone, or die()?
# * preserve existing indentation: chopped chunks from an indented line
#   are indented by same (like this line, not counting the asterisk!)
# * optional list of things to preserve on line starts, default ">"
#
# Note that the last two are essentially the same concept, so unify in
# implementation and give a good interface to controlling them.
#
# And how about:
#
# Optionally, when encounter a line pre-indented by same as previous
# line, then strip the newline and refill, but indent by the same.
# Yeah...

# Globals --------------------------------------------------------------------

# In case we have to print it out:
my $VERSION = '$Revision$';
$VERSION =~ s/\S+\s+(\S+)\s+\S+/$1/;

## Vars set by options:

# Print debugging messages?
my $Debug = 0;

# Just show version and exit?
my $Print_Version = 0;

# Just print usage message and exit?
my $Print_Usage = 0;

# What file should we generate (defaults to "ChangeLog")?
my $Log_File_Name = "ChangeLog";

# Grab most recent entry date from existing ChangeLog file, just add
# to that ChangeLog.
my $Cumulative = 0;

# `cvs log -d`, this will repeat the last entry in the old log.  This is OK,
# as it guarantees at least one entry in the update changelog, which means
# that there will always be a date to extract for the next update.  The repeat
# entry can be removed in postprocessing, if necessary.

# MJP 2003-08-02
# I don't think this actually does anything useful
my $Update = 0;

# Expand usernames to email addresses based on a map file?
my $User_Map_File = '';
my $User_Passwd_File;
my $Mail_Domain;

# Output log in chronological order? [default is reverse chronological order]
my $Chronological_Order = 0;

# Grab user details via gecos
my $Gecos = 0;

# User domain for gecos email addresses
my $Domain;

# Output to a file or to stdout?
my $Output_To_Stdout = 0;

# Eliminate empty log messages?
my $Prune_Empty_Msgs = 0;

# Tags of which not to output
my %ignore_tags;

# Show only revisions with Tags
my %show_tags;

# Don't call Text::Wrap on the body of the message
my $No_Wrap = 0;

# Indentation of log messages
my $Indent = "\t";

# Don't do any pretty print processing
my $Summary = 0;

# Separates header from log message.  Code assumes it is either " " or
# "\n\n", so if there's ever an option to set it to something else,
# make sure to go through all conditionals that use this var.
my $After_Header = " ";

# XML Encoding
my $XML_Encoding = '';

# Format more for programs than for humans.
my $XML_Output = 0;
my $No_XML_Namespace = 0;
my $No_XML_ISO_Date = 0;

# Do some special tweaks for log data that was written in FSF
# ChangeLog style.
my $FSF_Style = 0;

# Show times in UTC instead of local time
my $UTC_Times = 0;

# Show times in output?
my $Show_Times = 1;

# Show day of week in output?
my $Show_Day_Of_Week = 0;

# Show revision numbers in output?
my $Show_Revisions = 0;

# Show dead files in output?
my $Show_Dead = 0;

# Hide dead trunk files which were created as a result of additions on a
# branch?
my $Hide_Branch_Additions = 1;

# Show tags (symbolic names) in output?
my $Show_Tags = 0;

# Show tags separately in output?
my $Show_Tag_Dates = 0;

# Show branches by symbolic name in output?
my $Show_Branches = 0;

# Show only revisions on these branches or their ancestors.
my @Follow_Branches;
# Show only revisions on these branches or their ancestors; ignore descendent
# branches.
my @Follow_Only;

# Don't bother with files matching this regexp.
my @Ignore_Files;

# How exactly we match entries.  We definitely want "o",
# and user might add "i" by using --case-insensitive option.
my $Case_Insensitive = 0;

# Maybe only show log messages matching a certain regular expression.
my $Regexp_Gate = '';

# Pass this global option string along to cvs, to the left of `log':
my $Global_Opts = '';

# Pass this option string along to the cvs log subcommand:
my $Command_Opts = '';

# Read log output from stdin instead of invoking cvs log?
my $Input_From_Stdin = 0;

# Don't show filenames in output.
my $Hide_Filenames = 0;

# Don't shorten directory names from filenames.
my $Common_Dir = 1;

# Max checkin duration. CVS checkin is not atomic, so we may have checkin
# times that span a range of time. We assume that checkins will last no
# longer than $Max_Checkin_Duration seconds, and that similarly, no
# checkins will happen from the same users with the same message less
# than $Max_Checkin_Duration seconds apart.
my $Max_Checkin_Duration = 180;

# What to put at the front of [each] ChangeLog.
my $ChangeLog_Header = '';

# Whether to enable 'delta' mode, and for what start/end tags.
my $Delta_Mode = 0;
my $Delta_From = '';
my $Delta_To = '';

my $TestCode;

# Whether to parse filenames from the RCS filename, and if so what
# prefix to strip.
my $RCS_Root;

# Whether to output information on the # of lines added and removed
# by each file modification.
my $Show_Lines_Modified = 0;

## end vars set by options.

# latest observed times for the start/end tags in delta mode
my $Delta_StartTime = 0;
my $Delta_EndTime = 0;

my $No_Ancestors = 0;

my $No_Extra_Indent = 0;

my $GroupWithinDate = 0;

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::EntrySet;

sub new {
  my $class = shift;
  my %self;
  bless \%self, $class;
}

# -------------------------------------

sub output_changelog {
  my $output_type = $XML_Output ? 'XML' : 'Text';
  my $output_class = "CVS::Utils::ChangeLog::EntrySet::Output::${output_type}";
  my $output = $output_class->new(follow_branches => \@Follow_Branches,
                                  follow_only     => \@Follow_Only,
                                  ignore_tags     => \%ignore_tags,
                                  show_tags       => \%show_tags,
                                 );
  $output->output_changelog(@_);
}

# -------------------------------------

sub add_fileentry {
  my ($self, $file_full_path, $time, $revision, $state, $lines,
      $branch_names, $branch_roots, $branch_numbers,
      $symbolic_names, $author, $msg_txt) = @_;

      my $qunk =
        CVS::Utils::ChangeLog::FileEntry->new($file_full_path, $time, $revision,
                                              $state, $lines,
                                              $branch_names, $branch_roots,
                                              $branch_numbers,
                                              $symbolic_names);

      # We might be including revision numbers and/or tags and/or
      # branch names in the output.  Most of the code from here to
      # loop-end deals with organizing these in qunk.

      unless ( $Hide_Branch_Additions
               and
               $msg_txt =~ /file .+ was initially added on branch \S+./ ) {
        # Add this file to the list
        # (We use many spoonfuls of autovivication magic. Hashes and arrays
        # will spring into existence if they aren't there already.)

        &main::debug ("(pushing log msg for ". $qunk->dir_key . $qunk->filename . ")\n");

        # Store with the files in this commit.  Later we'll loop through
        # again, making sure that revisions with the same log message
        # and nearby commit times are grouped together as one commit.
        $self->{$qunk->dir_key}{$author}{$time}{$msg_txt} =
          CVS::Utils::ChangeLog::Message->new($msg_txt)
              unless exists $self->{$qunk->dir_key}{$author}{$time}{$msg_txt};
        $self->{$qunk->dir_key}{$author}{$time}{$msg_txt}->add_fileentry($qunk);
      }

}

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::EntrySet::Output::Text;

use base qw( CVS::Utils::ChangeLog::EntrySet::Output );

use File::Basename qw( fileparse );

sub new {
  my $class = shift;
  my $self = $class->SUPER::new(@_);
}

# -------------------------------------

sub wday {
  my $self = shift; my $class = ref $self;
  my ($wday) = @_;

  return $Show_Day_Of_Week ? ' ' . $class->weekday_en($wday) : '';
}

# -------------------------------------

sub header_line {
  my $self = shift;
  my ($time, $author, $lastdate) = @_;

  my $header_line = '';

  my (undef,$min,$hour,$mday,$mon,$year,$wday)
    = $UTC_Times ? gmtime($time) : localtime($time);

  my $date = $self->fdatetime($time);

  if ($Show_Times) {
    $header_line =
      sprintf "%s  %s\n\n", $date, $author;
  } else {
    if ( ! defined $lastdate or $date ne $lastdate or ! $GroupWithinDate ) {
      if ( $GroupWithinDate ) {
        $header_line = "$date\n\n";
      } else {
        $header_line = "$date  $author\n\n";
      }
    } else {
      $header_line = '';
    }
  }
}

# -------------------------------------

sub preprocess_msg_text {
  my $self = shift;
  my ($text) = @_;

  $text = $self->SUPER::preprocess_msg_text($text);

  unless ( $No_Wrap ) {
    # Strip off lone newlines, but only for lines that don't begin with
    # whitespace or a mail-quoting character, since we want to preserve
    # that kind of formatting.  Also don't strip newlines that follow a
    # period; we handle those specially next.  And don't strip
    # newlines that precede an open paren.
    1 while $text =~ s/(^|\n)([^>\s].*[^.\n])\n([^>\n])/$1$2 $3/g;

    # If a newline follows a period, make sure that when we bring up the
    # bottom sentence, it begins with two spaces.
    1 while $text =~ s/(^|\n)([^>\s].*)\n([^>\n])/$1$2  $3/g;
  }

  return $text;
}

# -------------------------------------

# Here we take a bunch of qunks and convert them into printed
# summary that will include all the information the user asked for.
sub pretty_file_list {
  my $self = shift;

  return ''
    if $Hide_Filenames;

  my $qunksref = shift;

  my @filenames;
  my $beauty = '';          # The accumulating header string for this entry.
  my %non_unanimous_tags;   # Tags found in a proper subset of qunks
  my %unanimous_tags;       # Tags found in all qunks
  my %all_branches;         # Branches found in any qunk
  my $fbegun = 0;           # Did we begin printing filenames yet?

  my ($common_dir, $qunkrefs) =
    $self->_pretty_file_list(\(%unanimous_tags, %non_unanimous_tags, %all_branches), $qunksref);

  my @qunkrefs = @$qunkrefs;

  # Not XML output, so complexly compactify for chordate consumption.  At this
  # point we have enough global information about all the qunks to organize
  # them non-redundantly for output.

  if ($common_dir) {
    # Note that $common_dir still has its trailing slash
    $beauty .= "$common_dir: ";
  }

  if ($Show_Branches)
  {
    # For trailing revision numbers.
    my @brevisions;

    foreach my $branch (keys (%all_branches))
    {
      foreach my $qunkref (@qunkrefs)
      {
        if ((defined ($qunkref->branch))
            and ($qunkref->branch eq $branch))
        {
          if ($fbegun) {
            # kff todo: comma-delimited in XML too?  Sure.
            $beauty .= ", ";
          }
          else {
            $fbegun = 1;
          }
          my $fname = substr ($qunkref->filename, length ($common_dir));
          $beauty .= $fname;
          $qunkref->{'printed'} = 1;  # Just setting a mark bit, basically

          if ( $Show_Tags and defined $qunkref->tags ) {
            my @tags = grep ($non_unanimous_tags{$_}, @{$qunkref->tags});

            if (@tags) {
              $beauty .= " (tags: ";
              $beauty .= join (', ', @tags);
              $beauty .= ")";
            }
          }

          if ($Show_Revisions) {
            # Collect the revision numbers' last components, but don't
            # print them -- they'll get printed with the branch name
            # later.
            $qunkref->revision =~ /.+\.([\d]+)$/;
            push (@brevisions, $1);

            # todo: we're still collecting branch roots, but we're not
            # showing them anywhere.  If we do show them, it would be
            # nifty to just call them revision "0" on a the branch.
            # Yeah, that's the ticket.
          }
        }
      }
      $beauty .= " ($branch";
      if (@brevisions) {
        if ((scalar (@brevisions)) > 1) {
          $beauty .= ".[";
          $beauty .= (join (',', @brevisions));
          $beauty .= "]";
        }
        else {
          # Square brackets are spurious here, since there's no range to
          # encapsulate
          $beauty .= ".$brevisions[0]";
        }
      }
      $beauty .= ")";
    }
  }

  # Okay; any qunks that were done according to branch are taken care
  # of, and marked as printed.  Now print everyone else.

  my %fileinfo_printed;
  foreach my $qunkref (@qunkrefs)
  {
    next if (defined ($qunkref->{'printed'}));   # skip if already printed

    my $b = substr ($qunkref->filename, length ($common_dir));
    # todo: Shlomo's change was this:
    # $beauty .= substr ($qunkref->filename,
    #              (($common_dir eq "./") ? '' : length ($common_dir)));
    $qunkref->{'printed'} = 1;  # Set a mark bit.

    if ($Show_Revisions || $Show_Tags || $Show_Dead)
    {
      my $started_addendum = 0;

      if ($Show_Revisions) {
        $started_addendum = 1;
        $b .= " (";
        $b .= $qunkref->revision;
      }
      if ($Show_Dead && $qunkref->state =~ /dead/)
      {
        # Deliberately not using $started_addendum. Keeping it simple.
        $b .= "[DEAD]";
      }
      if ($Show_Tags && (defined $qunkref->tags)) {
        my @tags = grep ($non_unanimous_tags{$_}, @{$qunkref->tags});
        if ((scalar (@tags)) > 0) {
          if ($started_addendum) {
            $b .= ", ";
          }
          else {
            $b .= " (tags: ";
          }
          $b .= join (', ', @tags);
          $started_addendum = 1;
        }
      }
      if ($started_addendum) {
        $b .= ")";
      }
    }

    unless ( exists $fileinfo_printed{$b} ) {
      if ($fbegun) {
        $beauty .= ", ";
      } else {
        $fbegun = 1;
      }
      $beauty .= $b, $fileinfo_printed{$b} = 1;
    }
  }

  # Unanimous tags always come last.
  if ($Show_Tags && %unanimous_tags)
  {
    $beauty .= " (utags: ";
    $beauty .= join (', ', sort keys (%unanimous_tags));
    $beauty .= ")";
  }

  # todo: still have to take care of branch_roots?

  $beauty = "$beauty:";

  return $beauty;
}

# -------------------------------------

sub output_tagdate {
  my $self = shift;
  my ($fh, $time, $tag) = @_;

  my $fdatetime = $self->fdatetime($time);
  print $fh "$fdatetime  tag $tag\n\n";
  return;
}

# -------------------------------------

sub format_body {
  my $self = shift;
  my ($msg, $files, $qunklist) = @_;

  my $body;

  if ( $No_Wrap and ! $Summary ) {
    $msg = $self->preprocess_msg_text($msg);
    $files = $self->mywrap("\t", "\t  ", "* $files");
    $msg =~ s/\n(.+)/\n$Indent$1/g;
    unless ($After_Header eq " ") {
      $msg =~ s/^(.+)/$Indent$1/g;
    }
    if ( $Hide_Filenames ) {
      $body = $After_Header . $msg;
    } else {
      $body = $files . $After_Header . $msg;
    }
  } elsif ( $Summary ) {
    my ($filelist, $qunk);
    my (@DeletedQunks, @AddedQunks, @ChangedQunks);

    $msg = $self->preprocess_msg_text($msg);
    #
    #     Sort the files (qunks) according to the operation that was
    # performed.  Files which were added have no line change
    # indicator, whereas deleted files have state dead.
    #
    foreach $qunk ( @$qunklist ) {
      if ( "dead" eq $qunk->state) {
        push @DeletedQunks, $qunk;
      } elsif ( ! defined $qunk->lines ) {
        push @AddedQunks, $qunk;
      } else {
        push @ChangedQunks, $qunk;
      }
    }
    #
    #     The qunks list was  originally in tree search order.  Let's
    # get that back.  The lists, if they exist, will be reversed upon
    # processing.
    #

    #
    #     Now write the three sections onto $filelist
    #
    if ( @DeletedQunks ) {
      $filelist .= "\tDeleted:\n";
      foreach $qunk ( @DeletedQunks ) {
        $filelist .= "\t\t" . $qunk->filename;
        $filelist .= " (" . $qunk->revision . ")";
        $filelist .= "\n";
      }
      undef @DeletedQunks;
    }

    if ( @AddedQunks ) {
      $filelist .= "\tAdded:\n";
      foreach $qunk (@AddedQunks) {
        $filelist .= "\t\t" . $qunk->filename;
        $filelist .= " (" . $qunk->revision . ")";
        $filelist .= "\n";
      }
      undef @AddedQunks ;
    }

    if ( @ChangedQunks ) {
      $filelist .= "\tChanged:\n";
      foreach $qunk (@ChangedQunks) {
        $filelist .= "\t\t" . $qunk->filename;
        $filelist .= " (" . $qunk->revision . ")";
        $filelist .= ", \"" . $qunk->state . "\"";
        $filelist .= ", lines: " . $qunk->lines;
        $filelist .= "\n";
      }
      undef @ChangedQunks;
    }

    chomp $filelist;

    if ( $Hide_Filenames ) {
      $filelist = '';
    }

    $msg =~ s/\n(.*)/\n$Indent$1/g;
    unless ( $After_Header eq " " or $FSF_Style ) {
      $msg =~ s/^(.*)/$Indent$1/g;
    }

    unless ( $No_Wrap ) {
      if ( $FSF_Style ) {
        $msg = $self->wrap_log_entry($msg, '', 69, 69);
        chomp($msg);
        chomp($msg);
      } else {
        $msg = $self->mywrap('', $Indent, "$msg");
        $msg =~ s/[ \t]+\n/\n/g;
      }
    }

    $body = $filelist . $After_Header . $msg;
  } else {  # do wrapping, either FSF-style or regular
    my $latter_wrap = $No_Extra_Indent ? $Indent : "$Indent  ";

    if ( $FSF_Style ) {
      $files = $self->mywrap($Indent, $latter_wrap, "* $files");

      my $files_last_line_len = 0;
      if ( $After_Header eq " " ) {
        $files_last_line_len = $self->last_line_len($files);
        $files_last_line_len += 1;  # for $After_Header
      }

      $msg = $self->wrap_log_entry($msg, $latter_wrap, 69-$files_last_line_len, 69);
      $body = $files . $After_Header . $msg;
    } else {  # not FSF-style
      $msg = $self->preprocess_msg_text($msg);
      $body = $files . $After_Header . $msg;
      $body = $self->mywrap($Indent, $latter_wrap, "* $body");
      $body =~ s/[ \t]+\n/\n/g;
    }
  }

  return $body;
}

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::EntrySet::Output::XML;

use base qw( CVS::Utils::ChangeLog::EntrySet::Output );

use File::Basename qw( fileparse );

sub new {
  my $class = shift;
  my $self = $class->SUPER::new(@_);
}

# -------------------------------------

sub header_line {
  my $self = shift;
  my ($time, $author, $lastdate) = @_;

  my $header_line = '';

  my $isoDate;

  my ($y, $m, $d, $H, $M, $S) = (gmtime($time))[5,4,3,2,1,0];

  # Ideally, this would honor $UTC_Times and use +HH:MM syntax
  $isoDate = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
                     $y + 1900, $m + 1, $d, $H, $M, $S);

  my (undef,$min,$hour,$mday,$mon,$year,$wday)
    = $UTC_Times ? gmtime($time) : localtime($time);

  my $date = $self->fdatetime($time);
  $wday = $self->wday($wday);

  $header_line =
    sprintf ("%4u-%02u-%02u\n${wday}\n",
             $year+1900, $mon+1, $mday, $hour, $min);
  $header_line .= "$isoDate\n"
    unless $No_XML_ISO_Date;
  $header_line .= sprintf("%s\n" , $author);
}

# -------------------------------------

sub wday {
  my $self = shift; my $class = ref $self;
  my ($wday) = @_;

  return '' . $class->weekday_en($wday) . "\n";
}

# -------------------------------------

sub escape {
  my $self = shift;

  my $txt = shift;
  $txt =~ s/&/&/g;
  $txt =~ s//>/g;
  return $txt;
}

# -------------------------------------

sub output_header {
  my $self = shift;
  my ($fh) = @_;

  my $encoding    =
    length $XML_Encoding ? qq'encoding="$XML_Encoding"' : '';
  my $version     = 'version="1.0"';
  my $declaration =
    sprintf '', join ' ', grep length, $version, $encoding;
  my $root        =
    $No_XML_Namespace ?
      ''     :
        '';
  print $fh "$declaration\n\n$root\n\n";
}

# -------------------------------------

sub output_footer {
  my $self = shift;
  my ($fh) = @_;

  print $fh "\n";
}

# -------------------------------------

sub preprocess_msg_text {
  my $self = shift;
  my ($text) = @_;

  $text = $self->SUPER::preprocess_msg_text($text);

  $text = $self->escape($text);
  chomp $text;
  $text = "${text}\n";

  return $text;
}

# -------------------------------------

# Here we take a bunch of qunks and convert them into a printed
# summary that will include all the information the user asked for.
sub pretty_file_list {
  my $self = shift;
  my ($qunksref) = @_;

  my $beauty = '';          # The accumulating header string for this entry.
  my %non_unanimous_tags;   # Tags found in a proper subset of qunks
  my %unanimous_tags;       # Tags found in all qunks
  my %all_branches;         # Branches found in any qunk
  my $fbegun = 0;           # Did we begin printing filenames yet?

  my ($common_dir, $qunkrefs) =
    $self->_pretty_file_list(\(%unanimous_tags, %non_unanimous_tags, %all_branches),
      $qunksref);

  my @qunkrefs = @$qunkrefs;

  # If outputting XML, then our task is pretty simple, because we
  # don't have to detect common dir, common tags, branch prefixing,
  # etc.  We just output exactly what we have, and don't worry about
  # redundancy or readability.

  foreach my $qunkref (@qunkrefs)
  {
    my $filename    = $qunkref->filename;
    my $state       = $qunkref->state;
    my $revision    = $qunkref->revision;
    my $tags        = $qunkref->tags;
    my $branch      = $qunkref->branch;
    my $branchroots = $qunkref->roots;
    my $lines       = $qunkref->lines;

    $filename = $self->escape($filename);   # probably paranoia
    $revision = $self->escape($revision);   # definitely paranoia

    $beauty .= "\n";
    $beauty .= "${filename}\n";
    $beauty .= "${state}\n";
    $beauty .= "${revision}\n";

    if ($Show_Lines_Modified
        && $lines && $lines =~ m/\+(\d+)\s+-(\d+)/) {
        $beauty .= "$1\n";
        $beauty .= "$2\n";
    }

    if ($branch) {
      $branch   = $self->escape($branch);     # more paranoia
      $beauty .= "${branch}\n";
    }
    foreach my $tag (@$tags) {
      $tag = $self->escape($tag);  # by now you're used to the paranoia
      $beauty .= "${tag}\n";
    }
    foreach my $root (@$branchroots) {
      $root = $self->escape($root);  # which is good, because it will continue
      $beauty .= "${root}\n";
    }
    $beauty .= "\n";
  }

  # Theoretically, we could go home now.  But as long as we're here,
  # let's print out the common_dir and utags, as a convenience to
  # the receiver (after all, earlier code calculated that stuff
  # anyway, so we might as well take advantage of it).

  if ((scalar (keys (%unanimous_tags))) > 1) {
    foreach my $utag ((keys (%unanimous_tags))) {
      $utag = $self->escape($utag);   # the usual paranoia
      $beauty .= "${utag}\n";
    }
  }
  if ($common_dir) {
    $common_dir = $self->escape($common_dir);
    $beauty .= "${common_dir}\n";
  }

  # That's enough for XML, time to go home:
  return $beauty;
}

# -------------------------------------

sub output_tagdate {
  my $self = shift;
  my ($fh, $time, $tag) = @_;

  my ($y, $m, $d, $H, $M, $S) = (gmtime($time))[5,4,3,2,1,0];

  # Ideally, this would honor $UTC_Times and use +HH:MM syntax
  my $isoDate = sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
                       $y + 1900, $m + 1, $d, $H, $M, $S);

  print $fh "\n";
  print $fh "$isoDate\n";
  print $fh "$tag\n";
  print $fh "\n\n";
  return;
}

# -------------------------------------

sub output_entry {
  my $self = shift;
  my ($fh, $entry) = @_;
  print $fh "\n$entry\n\n";
}

# -------------------------------------

sub format_body {
  my $self = shift;
  my ($msg, $files, $qunklist) = @_;

  $msg = $self->preprocess_msg_text($msg);
  return $files . $msg;
}

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::EntrySet::Output;

use Carp           qw( croak );
use File::Basename qw( fileparse );

# Class Utility Functions -------------

{ # form closure

my @weekdays = (qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday));
sub weekday_en {
  my $class = shift;
  return $weekdays[$_[0]];
}

}

# -------------------------------------

sub new {
  my ($proto, %args) = @_;
  my $class = ref $proto || $proto;

  my $follow_branches = delete $args{follow_branches};
  my $follow_only     = delete $args{follow_only};
  my $ignore_tags     = delete $args{ignore_tags};
  my $show_tags       = delete $args{show_tags};
  die "Unrecognized arg to EntrySet::Output::new: '$_'\n"
    for keys %args;

  bless +{follow_branches => $follow_branches,
          follow_only     => $follow_only,
          show_tags       => $show_tags,
          ignore_tags     => $ignore_tags,
         }, $class;
}

# Abstract Subrs ----------------------

sub wday               { croak "Whoops.  Abtract method call (wday).\n" }
sub pretty_file_list   { croak "Whoops.  Abtract method call (pretty_file_list).\n" }
sub output_tagdate     { croak "Whoops.  Abtract method call (output_tagdate).\n" }
sub header_line        { croak "Whoops.  Abtract method call (header_line).\n" }

# Instance Subrs ----------------------

sub output_header { }

# -------------------------------------

sub output_entry {
  my $self = shift;
  my ($fh, $entry) = @_;
  print $fh "$entry\n";
}

# -------------------------------------

sub output_footer { }

# -------------------------------------

sub escape { return $_[1] }

# -------------------------------------

sub _revision_is_wanted {
  my ($self, $qunk) = @_;

  my ($revision, $branch_numbers) = @{$qunk}{qw( revision branch_numbers )};
  my $follow_branches = $self->{follow_branches};
  my $follow_only     = $self->{follow_only};

  for my $ignore_tag (keys %{$self->{ignore_tags}}) {
    return
      if defined $qunk->{tags} and grep $_ eq $ignore_tag, @{$qunk->{tags}};
  }

  if ( keys %{$self->{show_tags}} ) {
    for my $show_tag (keys %{$self->{show_tags}}) {
      return
        if ! defined $qunk->{tags} or ! grep $_ eq $show_tag, @{$qunk->{tags}};
    }
  }

  return 1
    unless @$follow_branches + @$follow_only; # no follow is follow all

  for my $x (map([$_, 1], @$follow_branches),
             map([$_, 0], @$follow_only    )) {
    my ($branch, $followsub) = @$x;

    # Special case for following trunk revisions
    return 1
      if $branch =~ /^trunk$/i and $revision =~ /^[0-9]+\.[0-9]+$/;

    if ( my $branch_number = $branch_numbers->{$branch} ) {
      # Are we on one of the follow branches or an ancestor of same?

      # If this revision is a prefix of the branch number, or possibly is less
      # in the minormost number, OR if this branch number is a prefix of the
      # revision, then yes.  Otherwise, no.

      # So below, we determine if any of those conditions are met.

      # Trivial case: is this revision on the branch?  (Compare this way to
      # avoid regexps that screw up Emacs indentation, argh.)
      if ( substr($revision, 0, (length($branch_number) + 1))
           eq
           ($branch_number . ".") ) {
        if ( $followsub ) {
          return 1;
#        } elsif ( length($revision) == length($branch_number)+2 ) {
        } elsif ( substr($revision, length($branch_number)+1) =~ /^\d+$/ ) {
          return 1;
        }
      } elsif ( length($branch_number) > length($revision)
                and
                ! $No_Ancestors ) {
        # Non-trivial case: check if rev is ancestral to branch

        # r_left still has the trailing "."
        my ($r_left, $r_end) = ($revision =~ /^((?:\d+\.)+)(\d+)$/);

        # b_left still has trailing "."
        # b_mid has no trailing "."
        my ($b_left, $b_mid) = ($branch_number =~ /^((?:\d+\.)+)(\d+)\.\d+$/);
        return 1
          if $r_left eq $b_left and $r_end <= $b_mid;
      }
    }
  }

  return;
}

# -------------------------------------

sub output_changelog {
my $self = shift; my $class = ref $self;
    my ($grand_poobah) = @_;
    ### Process each ChangeLog
    
    while (my ($dir,$authorhash) = each %$grand_poobah) {
        &main::debug ("DOING DIR: $dir\n");
        
        # Here we twist our hash around, from being
        #   author => time => message => filelist
        # in %$authorhash to
        #   time => author => message => filelist
        # in %changelog.
        #
        # This is also where we merge entries.  The algorithm proceeds
        # through the timeline of the changelog with a sliding window of
        # $Max_Checkin_Duration seconds; within that window, entries that
        # have the same log message are merged.
        #
        # (To save space, we zap %$authorhash after we've copied
        # everything out of it.)
        
        # commit messages matching these will be ignored
        # should probably read these in from a file since they
        # will mostly change each release, but this is a quick hack!
        my @skip = ("Updating mailing lists URL",
                    "Updated bug reporting",
                    "use base, return true",
                    "Removed spurious ",
                    "cleaning unnecessary ",
                    "Updating emails",
                    "Improved POD markup",
                    "Fixed spaces",
                    "I'll be using bioperl.org mail address",
                    "Switched vanilla throw",
                    "regexp madness",
                    "minor edit",
                    "pod",
                    "pdoc",
                    "email address",
                    "typo",
                    "be explicit",
                    "using 'our'",
                    "silly email",
                    "regex clarity",
                    "polishing",
                    "Removed unused \"use vars",
                    "return, not return undef",
                    "lexically scoped file handles",
                    "No setting of own \$VERSION",
                    "do not return directly from sort",
                    "have NAME match module",
                    "Updating URLs",
                    "Changing emails",
                    "Updated doc",
                    "No setting own version",
                    "no log message");
        
        # not interested in these files
        my %files_to_skip = ( AUTHORS => 1,
                              Changes => 1,
                              'INSTALL.PROGRAMS' => 1,
                              README => 1,
                              BUGS => 1,
                              INSTALL => 1,
                              LICENSE => 1,
                              DEPENDENCIES => 1,
                              DEPRECATED => 1,
                              'INSTALL.WIN' => 1,
                              MANIFEST => 1,
                              'MANIFEST.SKIP' => 1,
                              PLATFORMS => 1);
        
        my %changelog;
        while (my ($author,$timehash) = each %$authorhash) {
            foreach my $time (sort {$a <=> $b} (keys %$timehash)) {
                next if ($Delta_Mode && (($time <= $Delta_StartTime) || ($time > $Delta_EndTime && $Delta_EndTime)));
                
                my $msghash = $timehash->{$time};
                MSG: while (my ($msg, $qunklist) = each %$msghash) {
                    foreach my $skip (@skip) {
                        if ($msg =~ /$skip/i) {
                            next MSG;
                        }
                    }
                    if ($msg =~ /merge/i && $msg =~ /head/i) {
                        next MSG;
                    }
                    
                    $msg =~ s/\n/ /g;
                    
                    foreach my $file (@{$qunklist->files}) {
                        $changelog{$file->filename}{$time} = $msg;
                    }
                }
            }
        }
        undef (%$authorhash);
        
        ### Now we can write out the ChangeLog!
        
        my ($logfile_here, $logfile_bak, $tmpfile);
        my $lastdate;
        
        if (! $Output_To_Stdout) {
            $logfile_here =  $dir . $Log_File_Name;
            $logfile_here =~ s/^\.\/\//\//;   # fix any leading ".//" problem
            $tmpfile      = "${logfile_here}.cvs2cl$$.tmp";
            $logfile_bak  = "${logfile_here}.bak";
            
            open (LOG_OUT, ">$tmpfile") or die "Unable to open \"$tmpfile\"";
        }
        else {
            open (LOG_OUT, ">-") or die "Unable to open stdout for writing";
        }
        
        print LOG_OUT $ChangeLog_Header;
        
        print LOG_OUT "These are detailed notes on changes made between $Delta_From and $Delta_To.\n\n";
        
        my %tag_date_printed;
        
        $self->output_header(\*LOG_OUT);
        
        my @file_list = sort {$a cmp $b} (keys %changelog);
        foreach my $file (@file_list) {
            # skip files we don't need to see changes for
            next if exists $files_to_skip{$file};
            next if $file =~ /^t\//;
            
            # convert module filenames to module name
            my $module = $file;
            if ($module =~ /^Bio/) {
                $module = ''.join("::", File::Spec->splitdir($file)).'';
                $module =~ s/\.pm//;
            }
            print LOG_OUT "; $module\n";
            foreach my $time (sort {$a <=> $b} keys %{$changelog{$file}}) {
                my $msg = $changelog{$file}{$time};
                
                # uppercase first letter
                $msg =~ s/^(\w)/\U$1/;
                
                # link bugs to bugzilla
                $msg =~ s/bug.*(\d{4})/{{Bugzilla|$1}}/i;
                
                print LOG_OUT ": $msg\n";
            }
            print LOG_OUT "\n";
        }
        
        $self->output_footer(\*LOG_OUT);
        
        close (LOG_OUT);
        
        if ( ! $Output_To_Stdout ) {
            # If accumulating, append old data to new before renaming.  But
            # don't append the most recent entry, since it's already in the
            # new log due to CVS's idiosyncratic interpretation of "log -d".
            if ($Cumulative && -f $logfile_here) {
              open NEW_LOG, ">>$tmpfile"
                or die "trouble appending to $tmpfile ($!)";
            
              open OLD_LOG, "<$logfile_here"
                or die "trouble reading from $logfile_here ($!)";
                
              my $started_first_entry = 0;
              my $passed_first_entry = 0;
              while () {
                if ( ! $passed_first_entry ) {
                  if ( ( ! $started_first_entry )
                      and /^(\d\d\d\d-\d\d-\d\d\s+(\w+\s+)?\d\d:\d\d)/ ) {
                    $started_first_entry = 1;
                  } elsif ( /^(\d\d\d\d-\d\d-\d\d\s+(\w+\s+)?\d\d:\d\d)/ ) {
                    $passed_first_entry = 1;
                    print NEW_LOG $_;
                  }
                } else {
                  print NEW_LOG $_;
                }
              }
            
              close NEW_LOG;
              close OLD_LOG;
            }
            
            if ( -f $logfile_here ) {
              rename $logfile_here, $logfile_bak;
            }
            rename $tmpfile, $logfile_here;
        }
    }
}

# -------------------------------------

# Don't call this wrap, because with 5.5.3, that clashes with the
# (unconditional :-( ) export of wrap() from Text::Wrap
sub mywrap {
  my $self = shift;
  my ($indent1, $indent2, @text) = @_;
  # If incoming text looks preformatted, don't get clever
  my $text = Text::Wrap::wrap($indent1, $indent2, @text);
  if ( grep /^\s+/m, @text ) {
    return $text;
  }
  my @lines = split /\n/, $text;
  $indent2 =~ s!^((?: {8})+)!"\t" x (length($1)/8)!e;
  $lines[0] =~ s/^$indent1\s+/$indent1/;
  s/^$indent2\s+/$indent2/
    for @lines[1..$#lines];
  my $newtext = join "\n", @lines;
  $newtext .= "\n"
    if substr($text, -1) eq "\n";
  return $newtext;
}

# -------------------------------------

sub preprocess_msg_text {
  my $self = shift;
  my ($text) = @_;

  # Strip out carriage returns (as they probably result from DOSsy editors).
  $text =~ s/\r\n/\n/g;
  # If it *looks* like two newlines, make it *be* two newlines:
  $text =~ s/\n\s*\n/\n\n/g;

  return $text;
}

# -------------------------------------

sub last_line_len {
  my $self = shift;

  my $files_list = shift;
  my @lines = split (/\n/, $files_list);
  my $last_line = pop (@lines);
  return length ($last_line);
}

# -------------------------------------

# A custom wrap function, sensitive to some common constructs used in
# log entries.
sub wrap_log_entry {
  my $self = shift;

  my $text = shift;                  # The text to wrap.
  my $left_pad_str = shift;          # String to pad with on the left.

  # These do NOT take left_pad_str into account:
  my $length_remaining = shift;      # Amount left on current line.
  my $max_line_length  = shift;      # Amount left for a blank line.

  my $wrapped_text = '';             # The accumulating wrapped entry.
  my $user_indent = '';              # Inherited user_indent from prev line.

  my $first_time = 1;                # First iteration of the loop?
  my $suppress_line_start_match = 0; # Set to disable line start checks.

  my @lines = split (/\n/, $text);
  while (@lines)   # Don't use `foreach' here, it won't work.
  {
    my $this_line = shift (@lines);
    chomp $this_line;

    if ($this_line =~ /^(\s+)/) {
      $user_indent = $1;
    }
    else {
      $user_indent = '';
    }

    # If it matches any of the line-start regexps, print a newline now...
    if ($suppress_line_start_match)
    {
      $suppress_line_start_match = 0;
    }
    elsif (($this_line =~ /^(\s*)\*\s+[a-zA-Z0-9]/)
           || ($this_line =~ /^(\s*)\* [a-zA-Z0-9_\.\/\+-]+/)
           || ($this_line =~ /^(\s*)\([a-zA-Z0-9_\.\/\+-]+(\)|,\s*)/)
           || ($this_line =~ /^(\s+)(\S+)/)
           || ($this_line =~ /^(\s*)- +/)
           || ($this_line =~ /^()\s*$/)
           || ($this_line =~ /^(\s*)\*\) +/)
           || ($this_line =~ /^(\s*)[a-zA-Z0-9](\)|\.|\:) +/))
    {
      # Make a line break immediately, unless header separator is set
      # and this line is the first line in the entry, in which case
      # we're getting the blank line for free already and shouldn't
      # add an extra one.
      unless (($After_Header ne " ") and ($first_time))
      {
        if ($this_line =~ /^()\s*$/) {
          $suppress_line_start_match = 1;
          $wrapped_text .= "\n${left_pad_str}";
        }

        $wrapped_text .= "\n${left_pad_str}";
      }

      $length_remaining = $max_line_length - (length ($user_indent));
    }

    # Now that any user_indent has been preserved, strip off leading
    # whitespace, so up-folding has no ugly side-effects.
    $this_line =~ s/^\s*//;

    # Accumulate the line, and adjust parameters for next line.
    my $this_len = length ($this_line);
    if ($this_len == 0)
    {
      # Blank lines should cancel any user_indent level.
      $user_indent = '';
      $length_remaining = $max_line_length;
    }
    elsif ($this_len >= $length_remaining) # Line too long, try breaking it.
    {
      # Walk backwards from the end.  At first acceptable spot, break
      # a new line.
      my $idx = $length_remaining - 1;
      if ($idx < 0) { $idx = 0 };
      while ($idx > 0)
      {
        if (substr ($this_line, $idx, 1) =~ /\s/)
        {
          my $line_now = substr ($this_line, 0, $idx);
          my $next_line = substr ($this_line, $idx);
          $this_line = $line_now;

          # Clean whitespace off the end.
          chomp $this_line;

          # The current line is ready to be printed.
          $this_line .= "\n${left_pad_str}";

          # Make sure the next line is allowed full room.
          $length_remaining = $max_line_length - (length ($user_indent));

          # Strip next_line, but then preserve any user_indent.
          $next_line =~ s/^\s*//;

          # Sneak a peek at the user_indent of the upcoming line, so
          # $next_line (which will now precede it) can inherit that
          # indent level.  Otherwise, use whatever user_indent level
          # we currently have, which might be none.
          my $next_next_line = shift (@lines);
          if ((defined ($next_next_line)) && ($next_next_line =~ /^(\s+)/)) {
            $next_line = $1 . $next_line if (defined ($1));
            # $length_remaining = $max_line_length - (length ($1));
            $next_next_line =~ s/^\s*//;
          }
          else {
            $next_line = $user_indent . $next_line;
          }
          if (defined ($next_next_line)) {
            unshift (@lines, $next_next_line);
          }
          unshift (@lines, $next_line);

          # Our new next line might, coincidentally, begin with one of
          # the line-start regexps, so we temporarily turn off
          # sensitivity to that until we're past the line.
          $suppress_line_start_match = 1;

          last;
        }
        else
        {
          $idx--;
        }
      }

      if ($idx == 0)
      {
        # We bottomed out because the line is longer than the
        # available space.  But that could be because the space is
        # small, or because the line is longer than even the maximum
        # possible space.  Handle both cases below.

        if ($length_remaining == ($max_line_length - (length ($user_indent))))
        {
          # The line is simply too long -- there is no hope of ever
          # breaking it nicely, so just insert it verbatim, with
          # appropriate padding.
          $this_line = "\n${left_pad_str}${this_line}";
        }
        else
        {
          # Can't break it here, but may be able to on the next round...
          unshift (@lines, $this_line);
          $length_remaining = $max_line_length - (length ($user_indent));
          $this_line = "\n${left_pad_str}";
        }
      }
    }
    else  # $this_len < $length_remaining, so tack on what we can.
    {
      # Leave a note for the next iteration.
      $length_remaining = $length_remaining - $this_len;

      if ($this_line =~ /\.$/)
      {
        $this_line .= "  ";
        $length_remaining -= 2;
      }
      else  # not a sentence end
      {
        $this_line .= " ";
        $length_remaining -= 1;
      }
    }

    # Unconditionally indicate that loop has run at least once.
    $first_time = 0;

    $wrapped_text .= "${user_indent}${this_line}";
  }

  # One last bit of padding.
  $wrapped_text .= "\n";

  return $wrapped_text;
}

# -------------------------------------

sub _pretty_file_list {
  my $self = shift;

  my ($unanimous_tags, $non_unanimous_tags, $all_branches, $qunksref) = @_;

  my @qunkrefs =
    grep +( ( ! $_->tags_exists
              or
              ! grep exists $ignore_tags{$_}, @{$_->tags})
            and
            ( ! keys %show_tags
              or
              ( $_->tags_exists
                and
                grep exists $show_tags{$_}, @{$_->tags} )
            )
          ),
    @$qunksref;

  my $common_dir;           # Dir prefix common to all files ('' if none)

  # First, loop over the qunks gathering all the tag/branch names.
  # We'll put them all in non_unanimous_tags, and take out the
  # unanimous ones later.
 QUNKREF:
  foreach my $qunkref (@qunkrefs)
  {
    # Keep track of whether all the files in this commit were in the
    # same directory, and memorize it if so.  We can make the output a
    # little more compact by mentioning the directory only once.
    if ($Common_Dir && (scalar (@qunkrefs)) > 1)
    {
      if (! (defined ($common_dir)))
      {
        my ($base, $dir);
        ($base, $dir, undef) = fileparse ($qunkref->filename);

        if ((! (defined ($dir)))  # this first case is sheer paranoia
            or ($dir eq '')
            or ($dir eq "./")
            or ($dir eq ".\\"))
        {
          $common_dir = '';
        }
        else
        {
          $common_dir = $dir;
        }
      }
      elsif ($common_dir ne '')
      {
        # Already have a common dir prefix, so how much of it can we preserve?
        $common_dir = &main::common_path_prefix ($qunkref->filename, $common_dir);
      }
    }
    else  # only one file in this entry anyway, so common dir not an issue
    {
      $common_dir = '';
    }

    if (defined ($qunkref->branch)) {
      $all_branches->{$qunkref->branch} = 1;
    }
    if (defined ($qunkref->tags)) {
      foreach my $tag (@{$qunkref->tags}) {
        $non_unanimous_tags->{$tag} = 1;
      }
    }
  }

  # Any tag held by all qunks will be printed specially... but only if
  # there are multiple qunks in the first place!
  if ((scalar (@qunkrefs)) > 1) {
    foreach my $tag (keys (%$non_unanimous_tags)) {
      my $everyone_has_this_tag = 1;
      foreach my $qunkref (@qunkrefs) {
        if ((! (defined ($qunkref->tags)))
            or (! (grep ($_ eq $tag, @{$qunkref->tags})))) {
          $everyone_has_this_tag = 0;
        }
      }
      if ($everyone_has_this_tag) {
        $unanimous_tags->{$tag} = 1;
        delete $non_unanimous_tags->{$tag};
      }
    }
  }

  return $common_dir, \@qunkrefs;
}

# -------------------------------------

sub fdatetime {
  my $self = shift;

  my ($year, $mday, $mon, $wday, $hour, $min);

  if ( @_ > 1 ) {
    ($year, $mday, $mon, $wday, $hour, $min) = @_;
  } else {
    my ($time) = @_;
    (undef, $min, $hour, $mday, $mon, $year, $wday) =
      $UTC_Times ? gmtime($time) : localtime($time);

    $year += 1900;
    $mon  += 1;
    $wday  = $self->wday($wday);
  }

  my $fdate = $self->fdate($year, $mon, $mday, $wday);

  if ($Show_Times) {
    my $ftime = $self->ftime($hour, $min);
    return "$fdate $ftime";
  } else {
    return $fdate;
  }
}

# -------------------------------------

sub fdate {
  my $self = shift;

  my ($year, $mday, $mon, $wday);

  if ( @_ > 1 ) {
    ($year, $mon, $mday, $wday) = @_;
  } else {
    my ($time) = @_;
    (undef, undef, undef, $mday, $mon, $year, $wday) =
      $UTC_Times ? gmtime($time) : localtime($time);

    $year += 1900;
    $mon  += 1;
    $wday  = $self->wday($wday);
  }

  return sprintf '%4u-%02u-%02u%s', $year, $mon, $mday, $wday;
}

# -------------------------------------

sub ftime {
  my $self = shift;

  my ($hour, $min);

  if ( @_ > 1 ) {
    ($hour, $min) = @_;
  } else {
    my ($time) = @_;
    (undef, $min, $hour) = $UTC_Times ? gmtime($time) : localtime($time);
  }

  return sprintf '%02u:%02u', $hour, $min;
}

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::Message;

sub new {
  my $class = shift;
  my ($msg) = @_;

  my %self = (msg => $msg, files => []);

  bless \%self, $class;
}

sub add_fileentry {
  my $self = shift;
  my ($fileentry) = @_;

  die "Not a fileentry: $fileentry"
    unless $fileentry->isa('CVS::Utils::ChangeLog::FileEntry');

  push @{$self->{files}}, $fileentry;
}

sub files { wantarray ? @{$_[0]->{files}} : $_[0]->{files} }

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::FileEntry;

use File::Basename qw( fileparse );

# Each revision of a file has a little data structure (a `qunk')
# associated with it.  That data structure holds not only the
# file's name, but any additional information about the file
# that might be needed in the output, such as the revision
# number, tags, branches, etc.  The reason to have these things
# arranged in a data structure, instead of just appending them
# textually to the file's name, is that we may want to do a
# little rearranging later as we write the output.  For example,
# all the files on a given tag/branch will go together, followed
# by the tag in parentheses (so trunk or otherwise non-tagged
# files would go at the end of the file list for a given log
# message).  This rearrangement is a lot easier to do if we
# don't have to reparse the text.
#
# A qunk looks like this:
#
#   {
#     filename    =>    "hello.c",
#     revision    =>    "1.4.3.2",
#     time        =>    a timegm() return value (moment of commit)
#     tags        =>    [ "tag1", "tag2", ... ],
#     branch      =>    "branchname" # There should be only one, right?
#     roots       =>    [ "branchtag1", "branchtag2", ... ]
#     lines       =>    "+x -y" # or undefined; x and y are integers
#   }

# Single top-level ChangeLog, or one per subdirectory?
my $distributed;
sub distributed { $#_ ? ($distributed = $_[1]) : $distributed; }

sub new {
  my $class = shift;
  my ($path, $time, $revision, $state, $lines,
      $branch_names, $branch_roots, $branch_numbers, $symbolic_names) = @_;

  my %self = (time     => $time,
              revision => $revision,
              state    => $state,
              lines    => $lines,
              branch_numbers => $branch_numbers,
             );

  if ( $distributed ) {
    @self{qw(filename dir_key)} = fileparse($path);
  } else {
    @self{qw(filename dir_key)} = ($path, './');
  }

  { # Scope for $branch_prefix
    (my ($branch_prefix) = ($revision =~ /((?:\d+\.)+)\d+/));
    $branch_prefix =~ s/\.$//;
    if ( $branch_names->{$branch_prefix} ) {
      my $branch_name = $branch_names->{$branch_prefix};
      $self{branch}   = $branch_name;
      $self{branches} = [$branch_name];
    }
    while ( $branch_prefix =~ s/^(\d+(?:\.\d+\.\d+)+)\.\d+\.\d+$/$1/ ) {
      push @{$self{branches}}, $branch_names->{$branch_prefix}
        if exists $branch_names->{$branch_prefix};
    }
  }

  # If there's anything in the @branch_roots array, then this
  # revision is the root of at least one branch.  We'll display
  # them as branch names instead of revision numbers, the
  # substitution for which is done directly in the array:
  $self{'roots'} = [ map { $branch_names->{$_} } @$branch_roots ]
    if @$branch_roots;

  if ( exists $symbolic_names->{$revision} ) {
    $self{tags} = delete $symbolic_names->{$revision};
    &main::delta_check($time, $self{tags});
  }

  bless \%self, $class;
}

sub filename       { $_[0]->{filename}       }
sub dir_key        { $_[0]->{dir_key}        }
sub revision       { $_[0]->{revision}       }
sub branch         { $_[0]->{branch}         }
sub state          { $_[0]->{state}          }
sub lines          { $_[0]->{lines}          }
sub roots          { $_[0]->{roots}          }
sub branch_numbers { $_[0]->{branch_numbers} }

sub tags        { $_[0]->{tags}     }
sub tags_exists {
  exists $_[0]->{tags};
}

# This may someday be used in a more sophisticated calculation of what other
# files are involved in this commit.  For now, we don't use it much except for
# delta mode, because the common-commit-detection algorithm is hypothesized to
# be "good enough" as it stands.
sub time     { $_[0]->{time}     }

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::EntrySetBuilder;

use File::Basename qw( fileparse );
use Time::Local    qw( timegm );

use constant MAILNAME => "/etc/mailname";

# In 'cvs log' output, one long unbroken line of equal signs separates files:
use constant FILE_SEPARATOR => '=' x 77;# . "\n";
# In 'cvs log' output, a shorter line of dashes separates log messages within
# a file:
use constant REV_SEPARATOR  => '-' x 28;# . "\n";

use constant EMPTY_LOG_MESSAGE => '*** empty log message ***';

# -------------------------------------

sub new {
  my ($proto) = @_;
  my $class = ref $proto || $proto;

  my $poobah  = CVS::Utils::ChangeLog::EntrySet->new;
  my $self = bless +{ grand_poobah => $poobah }, $class;

  $self->clear_file;
  $self->maybe_read_user_map_file;
  return $self;
}

# -------------------------------------

sub clear_msg {
  my ($self) = @_;

  # Make way for the next message
  undef $self->{rev_msg};
  undef $self->{rev_time};
  undef $self->{rev_revision};
  undef $self->{rev_author};
  undef $self->{rev_state};
  undef $self->{lines};
  $self->{rev_branch_roots} = [];       # For showing which files are branch
                                        # ancestors.
  $self->{collecting_symbolic_names} = 0;
}

# -------------------------------------

sub clear_file {
  my ($self) = @_;
  $self->clear_msg;

  undef $self->{filename};
  $self->{branch_names}   = +{};        # We'll grab branch names while we're
                                        # at it.
  $self->{branch_numbers} = +{};        # Save some revisions for
                                        # @Follow_Branches
  $self->{symbolic_names} = +{};        # Where tag names get stored.
}

# -------------------------------------

sub grand_poobah { $_[0]->{grand_poobah} }

# -------------------------------------

sub read_changelog {
  my ($self, $command) = @_;

  local (*READER, *WRITER);
  my $pid;
  if (! $Input_From_Stdin) {
    pipe(READER, WRITER)
      or die "Couldn't form pipe: $!\n";
    $pid = fork;
    die "Couldn't fork: $!\n"
      if ! defined $pid;
    if ( ! $pid ) { # child
      open STDOUT, '>&=' . fileno WRITER
        or die "Couldn't dup stderr to ", fileno WRITER, "\n";
      # strangely, some perls give spurious warnings about STDIN being opened
      # for output only these close calls precede the STDOUT reopen above.
      # I think they must be reusing fd 1.
      close READER;
      close STDIN;

      exec @$command;
    }

    close WRITER;

    &main::debug ("(run \"@$command\")\n");
  }
  else {
    open READER, '-' or die "unable to open stdin for reading";
  }

  binmode READER;

 XX_Log_Source:
  while () {
    chomp;
    s!\r$!!;

    # If on a new file and don't see filename, skip until we find it, and
    # when we find it, grab it.
    if ( ! defined $self->{filename} ) {
      $self->read_file_path($_);
    } elsif ( /^symbolic names:$/ ) {
      $self->{collecting_symbolic_names} = 1;
    } elsif ( $self->{collecting_symbolic_names} ) {
      $self->read_symbolic_name($_);
    } elsif ( $_ eq FILE_SEPARATOR and ! defined $self->{rev_revision} ) {
      $self->clear_file;
    } elsif ( ! defined $self->{rev_revision} ) {
        # If have file name, but not revision, and see revision, then grab
        # it.  (We collect unconditionally, even though we may or may not
        # ever use it.)
      $self->read_revision($_);
    } elsif ( ! defined $self->{rev_time} ) { # and /^date: /) {
      $self->read_date_author_and_state($_);
    } elsif ( /^branches:\s+(.*);$/ ) {
      $self->read_branches($1);
    } elsif ( ! ( $_ eq FILE_SEPARATOR or $_ eq REV_SEPARATOR ) ) {
      # If have file name, time, and author, then we're just grabbing
      # log message texts:
      $self->{rev_msg} .= $_ . "\n";   # Normally, just accumulate the message...
    } else {
      my $noadd = 0;
      if ( ! $self->{rev_msg}
           or $self->{rev_msg} =~ /^\s*(\.\s*)?$/
           or index($self->{rev_msg}, EMPTY_LOG_MESSAGE) > -1 ) {
        # ... until a msg separator is encountered:
        # Ensure the message contains something:
        $self->clear_msg, $noadd = 1
          if $Prune_Empty_Msgs;
        $self->{rev_msg} = "[no log message]\n";
      }

      $self->add_file_entry
        unless $noadd;

      if ( $_ eq FILE_SEPARATOR ) {
        $self->clear_file;
      } else {
        $self->clear_msg;
      }
    }
  }

  close READER
    or die "Couldn't close pipe reader: $!\n";
  if ( defined $pid ) {
    my $rv;
    waitpid $pid, 0;
    0 == $?
      or $!=1, die sprintf("Problem reading log input (pid/exit/signal/core: %d/%d/%d/%d)\n",
                           $pid, $? >> 8, $? & 127, $? & 128);
  }
  return;
}

# -------------------------------------

sub add_file_entry {
  $_[0]->grand_poobah->add_fileentry(@{$_[0]}{qw(filename rev_time rev_revision
                                                 rev_state lines branch_names
                                                 rev_branch_roots
                                                 branch_numbers
                                                 symbolic_names
                                                 rev_author rev_msg)});
}

# -------------------------------------

sub maybe_read_user_map_file {
  my ($self) = @_;

  my %expansions;
  my $User_Map_Input;

  if ($User_Map_File)
  {
    if ( $User_Map_File =~ m{^([-\w\@+=.,\/]+):([-\w\@+=.,\/:]+)} and
         !-f $User_Map_File )
    {
      my $rsh = (exists $ENV{'CVS_RSH'} ? $ENV{'CVS_RSH'} : 'ssh');
      $User_Map_Input = "$rsh $1 'cat $2' |";
      &main::debug ("(run \"${User_Map_Input}\")\n");
    }
    else
    {
      $User_Map_Input = "<$User_Map_File";
    }

    open (MAPFILE, $User_Map_Input)
        or die ("Unable to open $User_Map_File ($!)");

    while ()
    {
      next if /^\s*#/;  # Skip comment lines.
      next if not /:/;  # Skip lines without colons.

      # It is now safe to split on ':'.
      my ($username, $expansion) = split ':';
      chomp $expansion;
      $expansion =~ s/^'(.*)'$/$1/;
      $expansion =~ s/^"(.*)"$/$1/;

      # If it looks like the expansion has a real name already, then
      # we toss the username we got from CVS log.  Otherwise, keep
      # it to use in combination with the email address.

      if ($expansion =~ /^\s*<{0,1}\S+@.*/) {
        # Also, add angle brackets if none present
        if (! ($expansion =~ /<\S+@\S+>/)) {
          $expansions{$username} = "$username <$expansion>";
        }
        else {
          $expansions{$username} = "$username $expansion";
        }
      }
      else {
        $expansions{$username} = $expansion;
      }
    } # fi ($User_Map_File)

    close (MAPFILE);
  }

  if (defined $User_Passwd_File)
  {
    if ( ! defined $Domain ) {
      if ( -e MAILNAME ) {
        chomp($Domain = slurp_file(MAILNAME));
      } else {
      MAILDOMAIN_CMD:
        for ([qw(hostname -d)], 'dnsdomainname', 'domainname') {
          my ($text, $exit, $sig, $core) = run_ext($_);
          if ( $exit == 0 && $sig == 0 && $core == 0 ) {
            chomp $text;
            if ( length $text ) {
              $Domain = $text;
              last MAILDOMAIN_CMD;
            }
          }
        }
      }
    }

    die "No mail domain found\n"
      unless defined $Domain;

    open (MAPFILE, "<$User_Passwd_File")
        or die ("Unable to open $User_Passwd_File ($!)");
    while ()
    {
      # all lines are valid
      my ($username, $pw, $uid, $gid, $gecos, $homedir, $shell) = split ':';
      my $expansion = '';
      ($expansion) = split (',', $gecos)
        if defined $gecos && length $gecos;

      my $mailname = $Domain eq '' ? $username : "$username\@$Domain";
      $expansions{$username} = "$expansion <$mailname>";
    }
    close (MAPFILE);
  }

 $self->{usermap} = \%expansions;
}

# -------------------------------------

sub read_file_path {
  my ($self, $line) = @_;

  my $path;

  if ( $line =~ /^Working file: (.*)/ ) {
    $path = $1;
  } elsif ( defined $RCS_Root
            and
            $line =~ m|^RCS file: $RCS_Root[/\\](.*),v$| ) {
    $path = $1;
    $path =~ s!Attic/!!;
  } else {
    return;
  }

  if ( @Ignore_Files ) {
    my $base;
    ($base, undef, undef) = fileparse($path);

    my $xpath = $Case_Insensitive ? lc($path) : $path;
    return
      if grep $path =~ /$_/, @Ignore_Files;
  }

  $self->{filename} = $path;
  return;
}

# -------------------------------------

sub read_symbolic_name {
  my ($self, $line) = @_;
  
  # All tag names are listed with whitespace in front in cvs log
  # output; so if see non-whitespace, then we're done collecting.
  if ( /^\S/ ) {
    $self->{collecting_symbolic_names} = 0;
    return;
  } else {
    # we're looking at a tag name, so parse & store it

    # According to the Cederqvist manual, in node "Tags", tag names must start
    # with an uppercase or lowercase letter and can contain uppercase and
    # lowercase letters, digits, `-', and `_'.  However, it's not our place to
    # enforce that, so we'll allow anything CVS hands us to be a tag:
    my ($tag_name, $tag_rev) = ($line =~ /^\s+([^:]+): ([\d.]+)$/);

    # A branch number either has an odd number of digit sections
    # (and hence an even number of dots), or has ".0." as the
    # second-to-last digit section.  Test for these conditions.
    my $real_branch_rev = '';
    if ( $tag_rev =~ /^(\d+\.\d+\.)+\d+$/             # Even number of dots...
         and
         $tag_rev !~ /^(1\.)+1$/ ) {                  # ...but not "1.[1.]1"
      $real_branch_rev = $tag_rev;
    } elsif ($tag_rev =~ /(\d+\.(\d+\.)+)0.(\d+)/) {  # Has ".0."
      $real_branch_rev = $1 . $3;
    }

    # If we got a branch, record its number.
    if ( $real_branch_rev ) {
      $self->{branch_names}->{$real_branch_rev} = $tag_name;
      $self->{branch_numbers}->{$tag_name} = $real_branch_rev;
      $tag_rev =~ s/^(\d+\.\d+).+/$1/;
    }
    
    # regardless if it is a name on a branch, store it as symbolic name so that tag deltas always work
    push @{$self->{symbolic_names}->{$tag_rev}}, $tag_name;
  }

  $self->{collecting_symbolic_names} = 1;
  return;
}

# -------------------------------------

sub read_revision {
  my ($self, $line) = @_;

  my ($revision) = ( $line =~ /^revision (\d+\.[\d.]+)/ );

  return
    unless $revision;

  $self->{rev_revision} = $revision;
  return;
}

# -------------------------------------

{ # Closure over %gecos_warned
my %gecos_warned;
sub read_date_author_and_state {
  my ($self, $line) = @_;

  my ($time, $author, $state) = $self->parse_date_author_and_state($line);

  if ( defined($self->{usermap}->{$author}) and $self->{usermap}->{$author} ) {
    $author = $self->{usermap}->{$author};
  } elsif ( defined $Domain or $Gecos == 1 ) {
    my $email = $author;
    $email = $author."@".$Domain
      if defined $Domain && $Domain ne '';

    my $pw = getpwnam($author);
    my ($fullname, $office, $workphone, $homephone, $gcos);
    if ( defined $pw ) {
      $gcos = (getpwnam($author))[6];
      ($fullname, $office, $workphone, $homephone) =
        split /\s*,\s*/, $gcos;
    } else {
      warn "Couldn't find gecos info for author '$author'\n"
        unless $gecos_warned{$author}++;
      $fullname = '';
    }
    for (grep defined, $fullname, $office, $workphone, $homephone) {
      s/&/ucfirst(lc($pw->name))/ge;
    }
    $author = $fullname . "  <" . $email . ">"
      if $fullname ne '';
  }

  $self->{rev_state}  = $state;
  $self->{rev_time}   = $time;
  $self->{rev_author} = $author;
  return;
}
}

# -------------------------------------

sub read_branches {
  # A "branches: ..." line here indicates that one or more branches
  # are rooted at this revision.  If we're showing branches, then we
  # want to show that fact as well, so we collect all the branches
  # that this is the latest ancestor of and store them in
  # $self->[rev_branch_roots}.  Just for reference, the format of the
  # line we're seeing at this point is:
  #
  #    branches:  1.5.2;  1.5.4;  ...;
  #
  # Okay, here goes:
  my ($self, $line) = @_;

  # Ugh.  This really bothers me.  Suppose we see a log entry
  # like this:
  #
  #    ----------------------------
  #    revision 1.1
  #    date: 1999/10/17 03:07:38;  author: jrandom;  state: Exp;
  #    branches:  1.1.2;
  #    Intended first line of log message begins here.
  #    ----------------------------
  #
  # The question is, how we can tell the difference between that
  # log message and a *two*-line log message whose first line is
  #
  #    "branches:  1.1.2;"
  #
  # See the problem?  The output of "cvs log" is inherently
  # ambiguous.
  #
  # For now, we punt: we liberally assume that people don't
  # write log messages like that, and just toss a "branches:"
  # line if we see it but are not showing branches.  I hope no
  # one ever loses real log data because of this.
  if ( $Show_Branches ) {
    $line =~ s/(1\.)+1;|(1\.)+1$//;  # ignore the trivial branch 1.1.1
    $self->{rev_branch_roots} = [split /;\s+/, $line]
      if length $line;
  }
}

# -------------------------------------

sub parse_date_author_and_state {
  my ($self, $line) = @_;
  # Parses the date/time and author out of a line like:
  #
  # date: 1999/02/19 23:29:05;  author: apharris;  state: Exp;
  #
  # or, in CVS 1.12.9:
  #
  # date: 2004-06-05 16:10:32 +0000; author: somebody; state: Exp;

  my ($year, $mon, $mday, $hours, $min, $secs, $utcOffset, $author, $state, $rest) =
    $line =~
      m!(\d+)[-/](\d+)[-/](\d+)\s+(\d+):(\d+):(\d+)(\s+[+-]\d{4})?;\s+
        author:\s+([^;]+);\s+state:\s+([^;]+);(.*)!x
    or  die "Couldn't parse date ``$line''";
  die "Bad date or Y2K issues"
    unless $year > 1969 and $year < 2258;
  # Kinda arbitrary, but useful as a sanity check
  my $time = timegm($secs, $min, $hours, $mday, $mon-1, $year-1900);
  if ( defined $utcOffset ) {
    my ($plusminus, $hour, $minute) = ($utcOffset =~ m/([+-])(\d\d)(\d\d)/);
    my $offset = (($hour * 60) + $minute) * 60 * ($plusminus eq '+' ? -1 : 1);
    $time += $offset;
  }
  if ( $rest =~ m!\s+lines:\s+(.*)! ) {
    $self->{lines} = $1;
  }

  return $time, $author, $state;
}

# Subrs ----------------------------------------------------------------------

package main;

sub delta_check {
  my ($time, $tags) = @_;

  # If we're in 'delta' mode, update the latest observed times for the
  # beginning and ending tags, and when we get around to printing output, we
  # will simply restrict ourselves to that timeframe...
  return
    unless $Delta_Mode;

  $Delta_StartTime = $time
    if $time > $Delta_StartTime and grep { $_ eq $Delta_From } @$tags;

  $Delta_EndTime = $time
    if $time > $Delta_EndTime and grep { $_ eq $Delta_To } @$tags;
}

sub run_ext {
  my ($cmd) = @_;
  $cmd = [$cmd]
    unless ref $cmd;
  local $" = ' ';
  my $out = qx"@$cmd 2>&1";
  my $rv  = $?;
  my ($sig, $core, $exit) = ($? & 127, $? & 128, $? >> 8);
  return $out, $exit, $sig, $core;
}

# -------------------------------------

# If accumulating, grab the boundary date from pre-existing ChangeLog.
sub maybe_grab_accumulation_date {
  if (! $Cumulative || $Update) {
    return '';
  }

  # else

  open (LOG, "$Log_File_Name")
      or die ("trouble opening $Log_File_Name for reading ($!)");

  my $boundary_date;
  while ()
  {
    if (/^(\d\d\d\d-\d\d-\d\d\s+(\w+\s+)?\d\d:\d\d)/)
    {
      $boundary_date = "$1";
      last;
    }
  }

  close (LOG);

  # convert time from utc to local timezone if the ChangeLog has
  # dates/times in utc
  if ($UTC_Times && $boundary_date)
  {
    # convert the utc time to a time value
    my ($year,$mon,$mday,$hour,$min) = $boundary_date =~
      m#(\d+)-(\d+)-(\d+)\s+(\d+):(\d+)#;
    my $time = timegm(0,$min,$hour,$mday,$mon-1,$year-1900);
    # print the timevalue in the local timezone
    my ($ignore,$wday);
    ($ignore,$min,$hour,$mday,$mon,$year,$wday) = localtime($time);
    $boundary_date=sprintf ("%4u-%02u-%02u %02u:%02u",
                            $year+1900,$mon+1,$mday,$hour,$min);
  }

  return $boundary_date;
}

# -------------------------------------

# Fills up a ChangeLog structure in the current directory.
sub derive_changelog {
  my ($command) = @_;

  # See "The Plan" above for a full explanation.

  # Might be adding to an existing ChangeLog
  my $accumulation_date = maybe_grab_accumulation_date;
  if ($accumulation_date) {
    # Insert -d immediately after 'cvs log'
    my $Log_Date_Command = "-d>${accumulation_date}";

    my ($log_index) = grep $command->[$_] eq 'log', 0..$#$command;
    splice @$command, $log_index+1, 0, $Log_Date_Command;
    &debug ("(adding log msg starting from $accumulation_date)\n");
  }

#  output_changelog(read_changelog($command));
  my $builder = CVS::Utils::ChangeLog::EntrySetBuilder->new;
  $builder->read_changelog($command);
  $builder->grand_poobah->output_changelog;
}

# -------------------------------------

sub min { $_[0] < $_[1] ? $_[0] : $_[1] }

# -------------------------------------

sub common_path_prefix {
  my ($path1, $path2) = @_;

  # For compatibility (with older versions of cvs2cl.pl), we think in UN*X
  # terms, and mould windoze filenames to match.  Is this really appropriate?
  # If a file is checked in under UN*X, and cvs log run on windoze, which way
  # do the path separators slope?  Can we use fileparse as per the local
  # conventions?  If so, we should probably have a user option to specify an
  # OS to emulate to handle stdin-fed logs.  If we did this, we could avoid
  # the nasty \-/ transmogrification below.

  my ($dir1, $dir2) = map +(fileparse($_))[1], $path1, $path2;

  # Transmogrify Windows filenames to look like Unix.
  # (It is far more likely that someone is running cvs2cl.pl under
  # Windows than that they would genuinely have backslashes in their
  # filenames.)
  tr!\\!/!
    for $dir1, $dir2;

  my ($accum1, $accum2, $last_common_prefix) = ('') x 3;

  my @path1 = grep length($_), split qr!/!, $dir1;
  my @path2 = grep length($_), split qr!/!, $dir2;

  my @common_path;
  for (0..min($#path1,$#path2)) {
    if ( $path1[$_] eq $path2[$_]) {
      push @common_path, $path1[$_];
    } else {
      last;
    }
  }

  return join '', map "$_/", @common_path;
}

# -------------------------------------

sub parse_options {
  # Check this internally before setting the global variable.
  my $output_file;

  # If this gets set, we encountered unknown options and will exit at
  # the end of this subroutine.
  my $exit_with_admonishment = 0;

  # command to generate the log
  my @log_source_command = qw( cvs log );

  my (@Global_Opts, @Local_Opts);

  Getopt::Long::Configure(qw( bundling permute no_getopt_compat
                              pass_through no_ignore_case ));
  GetOptions('help|usage|h'   => \$Print_Usage,
             'debug'          => \$Debug,        # unadvertised option, heh
             'version'        => \$Print_Version,

             'file|f=s'       => \$output_file,
             'accum'          => \$Cumulative,
             'update'         => \$Update,
             'fsf'            => \$FSF_Style,
             'rcs=s'          => \$RCS_Root,
             'usermap|U=s'    => \$User_Map_File,
             'gecos'          => \$Gecos,
             'domain=s'       => \$Domain,
             'passwd=s'       => \$User_Passwd_File,
             'window|W=i'     => \$Max_Checkin_Duration,
             'chrono'         => \$Chronological_Order,
             'ignore|I=s'     => \@Ignore_Files,
             'case-insensitive|C' => \$Case_Insensitive,
             'regexp|R=s'     => \$Regexp_Gate,
             'stdin'          => \$Input_From_Stdin,
             'stdout'         => \$Output_To_Stdout,
             'distributed|d'  => sub { CVS::Utils::ChangeLog::FileEntry->distributed(1) },
             'prune|P'        => \$Prune_Empty_Msgs,
             'no-wrap'        => \$No_Wrap,
             'gmt|utc'        => \$UTC_Times,
             'day-of-week|w'  => \$Show_Day_Of_Week,
             'revisions|r'    => \$Show_Revisions,
             'show-dead'      => \$Show_Dead,
             'tags|t'         => \$Show_Tags,
             'tagdates|T'     => \$Show_Tag_Dates,
             'branches|b'     => \$Show_Branches,
             'follow|F=s'     => \@Follow_Branches,
             'follow-only=s'  => \@Follow_Only,
             'xml-encoding=s' => \$XML_Encoding,
             'xml'            => \$XML_Output,
             'noxmlns'        => \$No_XML_Namespace,
             'no-xml-iso-date' => \$No_XML_ISO_Date,
             'no-ancestors'   => \$No_Ancestors,
             'lines-modified' => \$Show_Lines_Modified,

             'no-indent'    => sub {
               $Indent = '';
             },

             'summary'      => sub {
               $Summary = 1;
               $After_Header = "\n\n"; # Summary implies --separate-header
             },

             'no-times'     => sub {
               $Show_Times = 0;
             },

             'no-hide-branch-additions' => sub {
               $Hide_Branch_Additions = 0;
             },

             'no-common-dir'  => sub {
               $Common_Dir = 0;
             },

             'ignore-tag=s'   => sub {
               $ignore_tags{$_[1]} = 1;
             },

             'show-tag=s'     => sub {
               $show_tags{$_[1]} = 1;
             },

             # Deliberately undocumented.  This is not a public interface, and
             # may change/disappear at any time.
             'test-code=s'    => \$TestCode,

             'delta=s'        => sub {
               my $arg = $_[1];
               if ( $arg =~
                    /^([A-Za-z][A-Za-z0-9_\-\]\[]*):([A-Za-z][A-Za-z0-9_\-\]\[]*)$/ ) {
                 $Delta_From = $1;
                 $Delta_To = $2;
                 $Delta_Mode = 1;
               } else {
                 die "--delta FROM_TAG:TO_TAG is what you meant to say.\n";
               }
             },

             'FSF'             => sub {
               $Show_Times = 0;
               $Common_Dir = 0;
               $No_Extra_Indent = 1;
               $Indent = "\t";
             },

             'header=s'        => sub {
               my $narg = $_[1];
               $ChangeLog_Header = &slurp_file ($narg);
               if (! defined ($ChangeLog_Header)) {
                 $ChangeLog_Header = '';
               }
             },

             'global-opts|g=s' => sub {
               my $narg = $_[1];
               push @Global_Opts, $narg;
               splice @log_source_command, 1, 0, $narg;
             },

             'log-opts|l=s' => sub {
               my $narg = $_[1];
               push @Local_Opts, $narg;
               push @log_source_command, $narg;
             },

             'mailname=s'   => sub {
               my $narg = $_[1];
               warn "--mailname is deprecated; please use --domain instead\n";
               $Domain = $narg;
             },

             'separate-header|S' => sub {
               $After_Header = "\n\n";
               $No_Extra_Indent = 1;
             },

             'group-within-date' => sub {
               $GroupWithinDate = 1;
               $Show_Times = 0;
             },

             'hide-filenames' => sub {
               $Hide_Filenames = 1;
               $After_Header = '';
             },
            )
    or die "options parsing failed\n";

  push @log_source_command, map "$_", @ARGV;

  ## Check for contradictions...

  if ($Output_To_Stdout && CVS::Utils::ChangeLog::FileEntry->distributed) {
    print STDERR "cannot pass both --stdout and --distributed\n";
    $exit_with_admonishment = 1;
  }

  if ($Output_To_Stdout && $output_file) {
    print STDERR "cannot pass both --stdout and --file\n";
    $exit_with_admonishment = 1;
  }

  if ($Input_From_Stdin && @Global_Opts) {
    print STDERR "cannot pass both --stdin and -g\n";
    $exit_with_admonishment = 1;
  }

  if ($Input_From_Stdin && @Local_Opts) {
    print STDERR "cannot pass both --stdin and -l\n";
    $exit_with_admonishment = 1;
  }

  if ($XML_Output && $Cumulative) {
    print STDERR "cannot pass both --xml and --accum\n";
    $exit_with_admonishment = 1;
  }

  # Other consistency checks and option-driven logic

  # Bleargh.  Compensate for a deficiency of custom wrapping.
  if ( ($After_Header ne " ") and $FSF_Style ) {
    $After_Header .= "\t";
  }

  @Ignore_Files = map lc, @Ignore_Files
    if $Case_Insensitive;

  # Or if any other error message has already been printed out, we
  # just leave now:
  if ($exit_with_admonishment) {
    &usage ();
    exit (1);
  }
  elsif ($Print_Usage) {
    &usage ();
    exit (0);
  }
  elsif ($Print_Version) {
    &version ();
    exit (0);
  }

  ## Else no problems, so proceed.

  if ($output_file) {
    $Log_File_Name = $output_file;
  }

  return \@log_source_command;
}

# -------------------------------------

sub slurp_file {
  my $filename = shift || die ("no filename passed to slurp_file()");
  my $retstr;

  open (SLURPEE, "<${filename}") or die ("unable to open $filename ($!)");
  local $/ = undef;
  $retstr = ;
  close (SLURPEE);
  return $retstr;
}

# -------------------------------------

sub debug {
  if ($Debug) {
    my $msg = shift;
    print STDERR $msg;
  }
}

# -------------------------------------

sub version {
  print "cvs2cl.pl version ${VERSION}; distributed under the GNU GPL.\n";
}

# -------------------------------------

sub usage {
  &version ();

  eval "use Pod::Usage qw( pod2usage )";

   if ( $@ ) {
    print <<'END';

* Pod::Usage was not found.  The formatting may be suboptimal.  Consider
  upgrading your Perl --- Pod::Usage is standard from 5.6 onwards, and
  versions of perl prior to 5.6 are getting rather rusty, now.  Alternatively,
  install Pod::Usage direct from CPAN.
END

    local $/ = undef;
    my $message = ;
    $message =~ s/^=(head1|item) //gm;
    $message =~ s/^=(over|back).*\n//gm;
    $message =~ s/\n{3,}/\n\n/g;
    print $message;
  } else {
    print "\n";
    pod2usage( -exitval => 'NOEXIT',
               -verbose => 1,
               -output  => \*STDOUT,
             );
  }

  return;
}

# Main -----------------------------------------------------------------------

my $log_source_command = parse_options;
if ( defined $TestCode ) {
  eval $TestCode;
  die "Eval failed: '$@'\n"
    if $@;
} else {
  derive_changelog($log_source_command);
}

__DATA__

=head1 NAME

cvs2cl_by_file.pl - convert cvs log messages to changelogs

=head1 SYNOPSIS

B [I] [I [I ...]]
cvs2cl_by_file.pl --delta bioperl-release-1-5-1:bioperl-release-1-5-2

=head1 DESCRIPTION

This is a quick hack version of cvs2cl.pl that simply outputs in a
file-centric way.
Only CVS::Utils::ChangeLog::EntrySet::Output::output_changelog
was altered

Usage:
cvs2cl_by_file.pl --delta bioperl-release-1-5-1:bioperl-release-1-5-2
Generates a file called ChangeLog showing, per file, all the commit
messages since tag bioperl-release-1-5-1 up to tag bioperl-release-1-5-2

Original cvs2cl docs now follow, but some things may not work because of
the hack!


cvs2cl produces a GNU-style ChangeLog for CVS-controlled sources by
running "cvs log" and parsing the output. Duplicate log messages get
unified in the Right Way.

The default output of cvs2cl is designed to be compact, formally unambiguous,
but still easy for humans to read.  It should be largely self-explanatory; the
one abbreviation that might not be obvious is "utags".  That stands for
"universal tags" -- a universal tag is one held by all the files in a given
change entry.

If you need output that's easy for a program to parse, use the B<--xml> option.
Note that with XML output, just about all available information is included
with each change entry, whether you asked for it or not, on the theory that
your parser can ignore anything it's not looking for.

If filenames are given as arguments cvs2cl only shows log information for the
named files.

=head1 OPTIONS

=over 4

=item B<-h>, B<-help>, B<--help>, B<-?>

Show a short help and exit.

=item B<--version>

Show version and exit.

=item B<-r>, B<--revisions>

Show revision numbers in output.

=item B<-b>, B<--branches>

Show branch names in revisions when possible.

=item B<-t>, B<--tags>

Show tags (symbolic names) in output.

=item B<-T>, B<--tagdates>

Show tags in output on their first occurance.

=item B<--show-dead>

Show dead files.

=item B<--stdin>

Read from stdin, don't run cvs log.

=item B<--stdout>

Output to stdout not to ChangeLog.

=item B<-d>, B<--distributed>

Put ChangeLogs in subdirs.

=item B<-f> I, B<--file> I

Write to I instead of ChangeLog.

=item B<--fsf>

Use this if log data is in FSF ChangeLog style.

=item B<--FSF>

Attempt strict FSF-standard compatible output.

=item B<-W> I, B<--window> I

Window of time within which log entries unify.

=item -B I, B<--usermap> I

Expand usernames to email addresses from I.

=item B<--passwd> I

Use system passwd file for user name expansion.  If no mail domain is provided
(via B<--domain>), it tries to read one from B, output of B, B, or B.  cvs2cl exits with an error if none of
those options is successful. Use a domain of '' to prevent the addition of a
mail domain.

=item B<--domain> I

Domain to build email addresses from.

=item B<--gecos>

Get user information from GECOS data.

=item B<-R> I, B<--regexp> I

Include only entries that match I.  This option may be used multiple
times.

=item B<-I> I, B<--ignore> I

Ignore files whose names match I.  This option may be used multiple
times.  The regexp is a perl regular expression.  It is matched as is; you may
want to prefix with a ^ or suffix with a $ to anchor the match.

=item B<-C>, B<--case-insensitive>

Any regexp matching is done case-insensitively.

=item B<-F> I, B<--follow> I

Show only revisions on or ancestral to I.

=item B<--follow-only> I

Like --follow, but sub-branches are not followed.

=item B<--no-ancestors>

When using B<-F>, only track changes since the I started.

=item B<--no-hide-branch-additions>

By default, entries generated by cvs for a file added on a branch (a dead 1.1
entry) are not shown.  This flag reverses that action.

=item B<-S>, B<--separate-header>

Blank line between each header and log message.

=item B<--summary>

Add CVS change summary information.

=item B<--no-wrap>

Don't auto-wrap log message (recommend B<-S> also).

=item B<--no-indent>

Don't indent log message

=item B<--gmt>, B<--utc>

Show times in GMT/UTC instead of local time.

=item B<--accum>

Add to an existing ChangeLog (incompatible with B<--xml>).

=item B<-w>, B<--day-of-week>

Show day of week.

=item B<--no-times>

Don't show times in output.

=item B<--chrono>

Output log in chronological order (default is reverse chronological order).

=item B<--header> I

Get ChangeLog header from I ("B<->" means stdin).

=item B<--xml>

Output XML instead of ChangeLog format.

=item B<--xml-encoding> I

Insert encoding clause in XML header.

=item B<--noxmlns>

Don't include xmlns= attribute in root element.

=item B<--hide-filenames>

Don't show filenames (ignored for XML output).

=item B<--no-common-dir>

Don't shorten directory names from filenames.

=item B<--rcs> I

Handle filenames from raw RCS, for instance those produced by "cvs rlog"
output, stripping the prefix I.

=item B<-P>, B<--prune>

Don't show empty log messages.

=item B<--lines-modified>

Output the number of lines added and the number of lines removed for
each checkin (if applicable). At the moment, this only affects the
XML output mode.

=item B<--ignore-tag> I

Ignore individual changes that are associated with a given tag.
May be repeated, if so, changes that are associated with any of
the given tags are ignored.

=item B<--show-tag> I

Log only individual changes that are associated with a given
tag.  May be repeated, if so, changes that are associated with
any of the given tags are logged.

=item B<--delta> IB<:>I

Attempt a delta between two tags (since I up to and
including I).  The algorithm is a simple date-based one
(this is a hard problem) so results are imperfect.

=item B<-g> I, B<--global-opts> I

Pass I to cvs like in "cvs I log ...".

=item B<-l> I, B<--log-opts> I

Pass I to cvs log like in "cvs ... log I".

=back

Notes about the options and arguments:

=over 4

=item *

The B<-I> and B<-F> options may appear multiple times.

=item *

To follow trunk revisions, use "B<-F trunk>" ("B<-F TRUNK>" also works).  This is
okay because no would ever, ever be crazy enough to name a branch "trunk",
right?  Right.

=item *

For the B<-U> option, the I should be formatted like CVSROOT/users. That is,
each line of I looks like this:

       jrandom:jrandom@red-bean.com

or maybe even like this

       jrandom:'Jesse Q. Random '

Don't forget to quote the portion after the colon if necessary.

=item *

Many people want to filter by date.  To do so, invoke cvs2cl.pl like this:

       cvs2cl.pl -l "-d'DATESPEC'"

where DATESPEC is any date specification valid for "cvs log -d".  (Note that
CVS 1.10.7 and below requires there be no space between -d and its argument).

=item *

Dates/times are interpreted in the local time zone.

=item *

Remember to quote the argument to `B<-l>' so that your shell doesn't interpret
spaces as argument separators.

=item *

See the 'Common Options' section of the cvs manual ('info cvs' on UNIX-like
systems) for more information.

=item *

Note that the rules for quoting under windows shells are different.

=item *

To run in an automated environment such as CGI or PHP, suidperl may be needed
in order to execute as the correct user to enable /cvsroot read lock files to
be written for the 'cvs log' command.  This is likely just a case of changing
the /usr/bin/perl command to /usr/bin/suidperl, and explicitly declaring the
PATH variable.

=back

=head1 EXAMPLES

Some examples (working on UNIX shells):

      # logs after 6th March, 2003 (inclusive)
      cvs2cl.pl -l "-d'>2003-03-06'"
      # logs after 4:34PM 6th March, 2003 (inclusive)
      cvs2cl.pl -l "-d'>2003-03-06 16:34'"
      # logs between 4:46PM 6th March, 2003 (exclusive) and
      # 4:34PM 6th March, 2003 (inclusive)
      cvs2cl.pl -l "-d'2003-03-06 16:46>2003-03-06 16:34'"

Some examples (on non-UNIX shells):

      # Reported to work on windows xp/2000
      cvs2cl.pl -l  "-d"">2003-10-18;today<"""

=head1 AUTHORS

=over 4

=item Karl Fogel

=item Melissa O'Neill

=item Martyn J. Pearce

=back

Contributions from

=over 4

=item Mike Ayers

=item Tim Bradshaw

=item Richard Broberg

=item Nathan Bryant

=item Oswald Buddenhagen

=item Neil Conway

=item Arthur de Jong

=item Mark W. Eichin

=item Dave Elcock

=item Reid Ellis

=item Simon Josefsson

=item Robin Hugh Johnson

=item Terry Kane

=item Pete Kempf

=item Akos Kiss

=item Claus Klein

=item Eddie Kohler

=item Richard Laager

=item Kevin Lilly

=item Karl-Heinz Marbaise

=item Mitsuaki Masuhara

=item Henrik Nordstrom

=item Joe Orton

=item Peter Palfrader

=item Thomas Parmelan

=item Jordan Russell

=item Jacek Sliwerski

=item Johannes Stezenbach

=item Joseph Walton

=item Ernie Zapata

=back

=head1 BUGS

Please report bugs to C.

=head1 PREREQUISITES

This script requires C, C, and C.  It
also seems to require C or higher.

=head1 OPERATING SYSTEM COMPATIBILITY

Should work on any OS.

=head1 SCRIPT CATEGORIES

Version_Control/CVS

=head1 COPYRIGHT

(C) 2001,2002,2003,2004 Martyn J. Pearce Efluffy@cpan.orgE, under the GNU GPL.

(C) 1999 Karl Fogel Ekfogel@red-bean.comE, under the GNU GPL.

cvs2cl.pl is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

cvs2cl.pl is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You may have received a copy of the GNU General Public License
along with cvs2cl.pl; see the file COPYING.  If not, write to the
Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 SEE ALSO

cvs(1)

BioPerl-1.6.923/maintenance/dependencies.pl000444000765000024      1700412254227321 20723 0ustar00cjfieldsstaff000000000000# $Id: dependencies.pl 10084 2006-07-04 22:23:29Z cjfields $
#
#!/usr/bin/perl

use strict;
use warnings;
use File::Find;
use Perl6::Form;
use Getopt::Long;
use Module::CoreList;
use CPANPLUS::Backend;

my $dep_header = < \$verbose,
        'dir:s' => \$dir,
        'depfile:s' => \$depfile,
        'p|perl:s' => \$version,
        's|skipbio' => \$skipbio,
        'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
	   );

# Directories to check
my @dirs = qw(../Bio/ );

#
# run
#

my %dependencies;
my %bp_packages;
my %core = %{$Module::CoreList::version{$version}};

# pragmas and BioPerl modules not in core (not required)
my %SKIP = map {$_ => 1} qw(base
vars
warnings
strict
constant
overload
Bio::Tools::Run::Ensembl
Bio::Ext::HMM
);

if ($dir) {
    find {wanted => \&parse_core, no_chdir => 1}, $dir;
} else {
    find {wanted => \&parse_core, no_chdir => 1}, @dirs;    
}

#
# process results
#

for my $k (keys %dependencies) {
    if (exists $bp_packages{$k} || exists $core{$k}) {
        delete $dependencies{$k};
    }
}

my $b = CPANPLUS::Backend->new();

# sort by distribution into a hash, keep track of modules

my %distrib;

for my $key (sort keys %dependencies) {
    MODULE:
    for my $m ($b->module_tree($key)) {
        if (!$m) {
            warn "$key not found, skipping";
            next MODULE;
        }
        push @{$distrib{$m->package_name}}, [$m, @{$dependencies{$m->module}}]
    }
}

open (my $dfile, '>', $depfile) || die "Can't open dependency file :$!\n";

print $dfile $dep_header;

for my $d (sort keys %distrib) {
    my $min_ver = 0;
    for my $moddata (@{$distrib{$d}}) {
        my ($mod, @bp) = @$moddata;
        for my $bp (@bp) {
            $min_ver = $bp->{ver} if $bp->{ver} >  $min_ver;
        }
    }
    print $dfile
            form
    {bullet => "* "},
    " ============================================================================== ",
    "| Distribution              | Module used - Description            | Min. ver. |",
    "|---------------------------+--------------------------------------+-----------|",
    "| {<<<<<<<<<<<<<<<<<<<<<<<} | * {[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[} | {|||||||} |",
    $d,
    [
        map {
            $_->[0]->module.' - '.$_->[1]
        } map {
            [$_->[0], $_->[0]->description || 'NA']
        } @{$distrib{$d}}
    ],
    $min_ver eq 0 ? 'None' : $min_ver,
    "|==============================================================================|",
    "| Used by:                                                                     |",
    "|------------------------------------------------------------------------------|",
    "| * {[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[} |",
    [
     map {
        my $md = $_->[0]->module;
        map {join(' - ',( $_->{file}.' - '. $md ))} @{$_}[1..$#{$_}] # obfuscated ain't it!!!
     } @{$distrib{$d}}
    ],
    " ============================================================================== ";
}

close $dfile;

exit;
#
##
### end main
##
#

#
# this is where the action is
#

sub parse_core {
    my $file = $_;
    return unless $file =~ /\.PLS$/ || $file =~ /\.p[ml]$/ ;
    return unless -e $file;
    open my $F, $file || die "Could not open file $file";
    my $pod = '';
    MODULE_LOOP:
    while (my $line = <$F>) {
        # skip POD, starting comments
        next if $line =~ /^\s*\#/xms;
        if ($line =~ /^=(\w+)/) {
            $pod = $1;
        }
        if ($pod) {
            if ($pod eq 'cut') {
                $pod = '';
            } else {
                next MODULE_LOOP;
            }
        }
        # strip off end comments
        $line =~ s/\#[^\n]+//;
        if ($line =~ /^\bpackage\s+(\S+)\s*;/) {
            $bp_packages{$1}++;
        } elsif ($line =~ /(?:['"])?\b(use|require)\s+([A-Za-z0-9:_\.\(\)]+)\s*([^;'"]+)?(?:['"])?\s*;/) {
            my ($use, $mod, $ver) = ($1, $2, $3);
            if ($mod eq 'one') {
                print "$File::Find::name: $. $line";
            }
            if (exists $SKIP{$mod}) {
                next MODULE_LOOP;
            }            
            if ($ver && $ver !~ /^v?[\d\.]+$/) {
                next MODULE_LOOP;
            }
            my $nm = $File::Find::name;
            $nm =~ s{.*(Bio.*)\.pm}{$1};
            $nm =~ s{[\\\/]}{::}g;
            if (!exists $dependencies{$mod} ||
                !(grep {$_->{file} eq $nm} @{$dependencies{$mod}})) {
                push @{ $dependencies{$mod} }, {
                    ver => $ver || 0,
                    file => $nm};
                }
        }
    }
    close $F;
}

__END__

=head1 NAME

dependencies.pl - check modules and scripts for dependencies not in core

=head1 SYNOPSIS

B [B<--dir> path ] [B<-v|--verbose>] [B<--depfile> file]
    [B<-?|-h|--help>] [B<-p|--perl> version]

=head1 DESCRIPTION

Recursively parses directory tree given (defaults to '../Bio') and checks files
for possible dependencies and versions (use/require statements).  Checks that
modules aren't part of perl core (--version, defaults to 5.006001).  Module
information is returned using CPANPLUS and data is output to a table using
Perl6::Form (yes I managed to get perl6 in here somehow).

Requires:

File::Find        - core
Getopt::Long      - core
CPANPLUS::Backend
Perl6::Form
Module::CoreList  

=head1 OPTIONS

=over 3

=item B<--dir> path

Overides the default directories to check by one directory 'path' and
all its subdirectories.

=item B<--depfile> file

The name of the output file for the dependencies table.  Default is
'../DEPENDENCIES.NEW'

=item B<-v | --verbose>

Show the progress through files during the checking.  Not used currently.

=item B<-p | --perl> version

Perl version (in long form, i.e. 5.010, 5.006001).  Used to weed out the
core modules that should be already present (ActiveState, we're staring at
you sternly).

=item B<-s | --skipbio> 

Skips BioPerl-related modules in DEPENDENCIES.

We may add something in the future to allow other forms.

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Chris Fields

Email cjfields-at-bioperl-dot-org

=cut
BioPerl-1.6.923/maintenance/deprecated.pl000444000765000024      1335212254227333 20402 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;

use version;
use Bio::Root::Version;
use File::Find;
use Getopt::Long;
use Perl6::Form;
use Carp;

#
# command line options
#

my ($verbose, $dir, $depfile, $help, $new, $outfile, $write, $version) =
(0, undef, "../DEPRECATED", undef, [], '../DEPRECATED.NEW', 0, $Bio::Root::Version::VERSION);
GetOptions(
        'v|verbose' => \$verbose,
		'b|bp_version:s' => \$version,
        'dir:s' => \$dir,
        'depfile:s' => \$depfile,
        'n|new=s@' => \$new,
        'o|outfile:s' => \$outfile,
        'w|write' => \$write,
        'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
	   );

# Default directories to check
my @dirs = qw(../Bio/ );

# use version to consolidate old vs new versioning schemes
my $base_version = version->new( $version );

print "Version: $base_version\n";

my %deprecated;
my %removed;
my @dep_data;

# parse DEPRECATED file

open my $DFILE, '<', $depfile || die "Can't open $depfile: $!";
my $seen_top;
while (my $data = <$DFILE>) {
    if ($data =~ /^-+$/) {
        $seen_top = 1;
        next;
    }
    next unless $seen_top;
    chomp $data;
    my ($module, $dep, $rem, $note) = split(/\s+/,$data,4);
    next unless $module;
    my $d = version->new($dep);
    my $r = version->new($rem);
	print "$module Dep: $d Rem: $r\n" if $verbose;
    if ($rem <= $base_version) {
        $removed{$module}++;
    } elsif ($dep <= $base_version) {
        $deprecated{$module}++;
    }
    push @dep_data, {module => $module,
                     dep => $dep,
                     remove => $rem,
                     note => $note}
}

close $DFILE;

for my $new (@$new) {
    my ($module, $dep, $rem, $note) = split(',',$new,4);
    last if !$module || !$dep || !$rem;
    if ($module !~ /Bio/) {
        croak "Can only deprecate BioPerl modules, not $module"
    }
    push @dep_data, {module => $module,
                 dep => $dep,
                 remove => $rem,
                 note => $note}
}

# run through all files in core (checks to see if anything is still present)

if ($dir) {
    find {wanted => \&parse_core, no_chdir => 1}, $dir;
} else {
    find {wanted => \&parse_core, no_chdir => 1}, @dirs;
}

#
# results
#

# uses Perl6::Form

if ($write || @$new) {

open (my $NEWDEP, '>', $outfile) || croak "Can't open $outfile :$!";

print $NEWDEP <{$_}} qw (module dep remove note);
    
print $NEWDEP form
"{[[[[[[[[[[[[[[[[[[[[[[[[[[[[[} {|||||}  {|||||}   {[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[}",
    $mod,     $dep,        $rem,       $note;
}

}

#
##
### end main
##
#

#
# this is where the action is
#

sub parse_core {
    my $file = $_;
    return unless $file =~ /\.PLS$/ || $file =~ /\.p[ml]$/ ;
    return unless -e $file;
    open my $F, $file || die "Could not open file $file";
    while (my $line = <$F>) {
        if ($line =~ /(?:['"])?\b(use|require)\s+([A-Za-z0-9:_\.\(\)]+)\s*([^;'"]+)?(?:['"])?\s*;/) {
            my ($use, $mod) = ($1, $2);
			if (exists $removed{$mod}) {
                print "$File::Find::name: Line $.: $mod is removed\n";
            } elsif (exists $deprecated{$mod}) {
                print "$File::Find::name: Line $.: $mod is deprecated\n";
            } 
        }
    }
    close $F;
}

# $Id: deprecated.pl 10084 2006-07-04 22:23:29Z mauricio $
#
=head1 NAME

deprecated.pl - Check modules and scripts for use of deprecated modules and
methods, indicates presence in a file to STDERR. Optionally accepts new modules
and adds them to a newly formatted deprecation file.

=head1 SYNOPSIS

B [B<-d|--dir> path ] [B<-v|--verbose>] [B<-a|--depfile>]
    [B<-n|--new>] [B<-w|--write>] [B<-o|--outfile>]
    [B<-?|-h|--help>]

=head1 OPTIONS

=over 3

=item B<-d | --dir> path

Overides the default directories to check by one directory 'path' and
all its subdirectories.

=item B<-a | --depfile>

path from working directory that contains the DEPRECATED file.

=item B<-n | --new>

New addition to the deprecation list; this should be in the form of
'Module,dep_release,remove_release,notes'. Notes should only be 40 chars long.

=item B<-b | --bp_version>

BioPerl version.  This only appears to work correctly when using numerical
versions (1.5.2 instead of 1.005002)

=item B<-w | --write>

Write out new deprecation file to $outfile.  If --new is used this is assumed.

=item B<-o | --outfile>

Name of output file to write deprecation table to. DEPRECATED.NEW is the default
name

=item B<-v | --verbose>

Show the progress through files during the checking.

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Chris Fields

Email cjfields-at-bioperl-dot-org

=cut
BioPerl-1.6.923/maintenance/find_mod_deps.pl000555000765000024      1320412254227323 21072 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

=head1 NAME

find_mod_deps.pl - inspect B dependencies of sets of perl files

=head1 DESCRIPTION

Inspects the hard-coded dependencies of a set of perl files and prints
a summary of which modules they use (by default not including
inter-dependencies between the modules being inspected).

=head1 USAGE

find_mod_deps.pl [options]  [ path ... ]

If given any paths, inspects only the files in those paths.  Defaults
to inspecting all perl files in the current directory.

=head2 Options

=over 4

=item -i

If set, also print internal dependencies, i.e. the inter-dependencies
between the files we are inspecting.

=item -B

If set, print the dependencies in a format suitable for cutting and
pasting directly into a Build.PL (i.e. Module::Build)

=item -M

If set, print the dependencies in a format suitable for cutting and
pasting directly into a Makefile.PL (i.e. Module::Install)

=item -Z

If set, print the dependencies in a format suitable for cutting and
pasting directly into a dist.ini (i.e. Dist::Zilla).  Although, if
you're using Dist::Zilla, you probably have it configured to be
auto-discovering deps, and it will find the same deps as this script.

=back

=head1 AUTHOR

Robert Buels, rbuels@cpan.org

=cut

use strict;
use warnings;

use File::Find;
use Getopt::Std;
use IO::String;
use List::MoreUtils qw/ first_value all /;
use Module::CoreList;
use Pod::Strip;
use Pod::Usage;

use Data::Dump 'dump';
use Hash::Merge;

my %opt;
getopts('iBMZ', \%opt) or pod2usage();

-d './lib' or -d './bin' or -d './scripts' or die "run this script from the root dir of a distribution\n";

my @paths = @ARGV;

@paths = qw( t lib scripts bin cgi-bin Bio )
   unless @paths;

# expand any dirs into the perl files they contain
my @perl_files = map {
    if( -d ) {
        my @f;
        find( sub { push @f, $File::Find::name if is_perl_file($_) },
              $_,
            );
        @f
    } elsif( -e ) {
        if( is_perl_file($_) ) {
            $_
        } else {
            warn "WARNING: skipping user-specified file $_, since it is not a perl file.\n";
            ()
        }
    } else {
        ()
    }
} @paths;

my %perl_files = map { $_ => 1 } @perl_files;

my %deps;
my $merger = Hash::Merge->new('RETAINMENT_PRECEDENT');
for my $file ( @perl_files ) {
    my $deps = find_deps( $file );
    %deps = %{ $merger->merge( \%deps, $deps ) };
}

# classify the deps
my %classified;
for my $modname ( keys %deps ) {
    if( all { m|^(./)?t/| } @{$deps{$modname}} ) {
        $classified{build_requires}{$modname} = $deps{$modname};
    }
    else {
        $classified{requires}{$modname} = $deps{$modname};
    }
}

# decide which format to print in
if( $opt{B} ) {
    for ( values %classified ) {
        $_ = 0 for values %$_;
    }
    print dump \%classified;
} elsif( $opt{M} ) {
    print "requires      '$_' => 0;\n"
      for sort { lc $a cmp lc $b } keys %{$classified{requires}};
    print "test_requires '$_' => 0;\n"
      for sort { lc $a cmp lc $b } keys %{$classified{build_requires}};
} elsif( $opt{Z} ) {
    print "[Prereqs]\n";
    print "$_  =  0\n"
      for sort { lc $a cmp lc $b } keys %{$classified{requires}};

    print "\n[Prereqs / TestRequires]\n";
    print "$_  =  0\n"
      for sort { lc $a cmp lc $b } keys %{$classified{build_requires}};

} else {
    print dump \%classified;
}

exit;

################## helpers #####################

sub modfile {
    my $modname = shift;
    my $modfile = "$modname.pm";
    $modfile =~ s|::|/|g;
    return first_value {
        $_ =~ /$modfile$/;
    } @perl_files;
}

sub namespace_parent {
    my $modname = shift;
    $modname =~ s/(?:::)?[^:]+$//;
    return $modname;
}

sub find_deps {
    my ( $file ) = @_;

    my $nopod;
    { open my $p, '<', $file or die "$! reading $file\n";
      local $/;
      my $code = <$p>;
      my $strip = Pod::Strip->new;
      $strip->output_string(\$nopod);
      $strip->parse_string_document( $code );
    }
    my $f = IO::String->new( \$nopod );

    my %deps;
    while( my $depline = <$f> ) {
        $depline =~ s/#.+//; #remove comments
        next unless $depline =~ /^\s*(use|require|extends|with)\s+.+;/;
        next unless $depline && $depline =~ /\S/;

        my @toks = $depline =~ /([\w:]{3,})/ig
            or die 'cannot parse: '.$depline;

        #warn "    adding to $k->{name}\n";
        shift @toks;
        if( @toks ) {
            if ( $toks[0] eq 'base' ) {
                shift @toks;
                shift @toks if $toks[0] eq 'qw';
            } else {
                @toks = ($toks[0]);
            }
        }

      MODNAME:
        foreach my $modname (@toks) {

            chomp $depline;
            #warn "'$depline' goes to $modname\n";

            #skip if the module is in the distribution
            my $modfile = modfile($modname);
            next if !$opt{i} && $modfile && -f $modfile;

            #skip if the module is in core before 5.6
            my $rl = Module::CoreList->first_release($modname);
            next if $rl && $rl <= 5.006;

            #skip if the module is actually defined in a parent file
            my $p = $modname;
            while( $p = namespace_parent($p) ) {
                my $p_modfile = modfile($p);
                #warn  "checking $p / $p_modfile\n";

                next unless $p_modfile && -f $p_modfile;

                open my $p, '<', $p_modfile or die "$! opening $p_modfile\n";
                while( <$p> ) {
                    next MODNAME if /^\s*package\s+$p\b/;
                }
            }

            push @{$deps{$modname} ||= []}, $file;
        }
    }

    return \%deps;
}

sub is_perl_file {
    local $_ = shift;
    return -f && ( -x || /\.(pm|t|pl)$/ );
}
BioPerl-1.6.923/maintenance/module_usage.pl000444000765000024      2477112254227333 20762 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
# 
# Counts up all the used and inherited modules in a directory of modules to
# help indicate which the most important modules are, graphs it also
#
# Written by Sendu Bala, using much code directly from
# http://www.perlmonks.org/?displaytype=displaycode;node_id=87329
# and also
# http://search.cpan.org/src/NEILB/pmusage-1.2/pmusage

use strict;
use warnings;

use IO::File;
use File::Find;
use Getopt::Std;
use GraphViz;

sub usage
{
	print <new($opts{l}) or die "can't open -l file $opts{l} : $!\n";
	my @largs = <$lFile>;
	chomp(@largs);
	splice(@ARGV, 0, 0, @largs);
	delete($opts{l});
	getopts($opts, \%opts) || usage(1);
	$lFile->close();
}

my $outfile = defined($opts{f}) ? $opts{f} : "module_usage";
my $format = defined($opts{i}) ? $opts{i} : 'jpeg';

# now filenames are in @ARGV
push(@ARGV, '.') if !@ARGV;

my @files;
my %sections;

sub findPerlFiles {
	-f $_ && /^.*\.p[ml]\z/si && push(@files, $File::Find::name);
}

# process directories
foreach my $top (@ARGV) {
	File::Find::find({wanted => \&findPerlFiles}, $top);
}

my %usage;
my %users;
my %inheritance;
my %packages;

sub store_package_usage {
    my ($package, $used) = @_;
    my %used = %{$used};
    
    STDERR->print("package $package used (".join(' ', keys %used).")\n") if $opts{v};
    
    $packages{$package} = \%used;
    
    foreach my $module (keys %used) {
        $usage{$module}++;
        push (@{$users{$module}}, $package);
    }
}

foreach my $file (@files) {
	$file =~ s#^./##;
	STDERR->print("processing $file\n") if $opts{v};
	my $f = IO::File->new($file) or warn "can't open $file: $!\n", next;
    
	my ($package, %used);
    
	my $pod = 0;
	while (<$f>) {
		if (/^=cut/) {
			$pod=0;
			next;
		}
		if (/^=[a-zA-Z]+/) {
			$pod=1;
			next;
		}
		next if $pod;
        
		if (/^\s*package\s+([[:word:]:]+)\s*;/) {
            if ($package) {
                store_package_usage($package, \%used);
                %used = ();
            }
            
			$package = $1;
			next;
		}
		if (/use base\s*(.*)/) {
			my $tmp = $1;
			while (!/;/)	# accumulate ISA value for multiple lines
			{
				$_ = <$f>;
				$tmp .= $_;
			}
			my @use_base = eval $tmp;
			if ($@) { warn "Unparseable 'use base' line for $package: $tmp"; next }
			
            foreach my $module (@use_base) {
                $used{$module} = 1;
				$inheritance{$package}->{$module} = 1;
            }
		}
		elsif (/^\s*use\s+([^\s;()]+)/ || /^\s*require\s+([^\s;()'"]+)/) {
            $used{$1} = 1;
		}
	}
	$f->close();
    
    if ($package) {
        store_package_usage($package, \%used);
    }
}

# simplify so we can view a graph of usage: we group all packages that have
# identical usage. NB: this doesn't look at external modules at all
my %groups;
while (my ($package, $used_hash) = each %packages) {
    my @used_packages;
    foreach my $used_module (sort keys %{$used_hash}) {
        next unless defined $packages{$used_module};
        push(@used_packages, $used_module);
    }
    @used_packages || next;
    
    push(@{$groups{join('|', @used_packages)}}, $package);
}

# we're going to shade boxes based on usage later, figure out an appropriate
# shade range by ranking
my %counts;
while (my ($group, $pack_list) = each %groups) {
    my @children = @{$pack_list};
    
    @children > 1 || next;
    
    my @parents = split(/\|/, $group);
    foreach my $parent (@parents) {
        my $count = $usage{$parent};
        $counts{$parent} = $count;
    }
}
my %ranks;
my $rank = 0;
my $prev_count;
foreach my $parent (sort { $counts{$a} <=> $counts{$b} } keys %counts) {
    my $this_count = $counts{$parent};
    $ranks{$parent} = $prev_count && $prev_count != $this_count ? ++$rank : $rank;
    $prev_count = $this_count;
}

sub class_to_subdir {
    my $class = shift;
    $class =~ s/::[^:]+$//;
    return $class;
}

my $g = GraphViz->new(concentrate => 1,
                      node => {shape => 'box'},
                      $format eq 'ps' ? (pagewidth => 46.81, pageheight => 33.11) : ()); # A0 for ps output
my $inherited_edge_colour = 'green';
my $used_edge_colour = 'blue';
my $cluster_colour = 'black'; #*** darkgray, 0,0,0.31 don't work, why?!
my $child_id = 0;
my $group_definitions = '';
my %parents;
while (my ($group, $pack_list) = each %groups) {
    my @children = @{$pack_list};
    
    # ignore single child groups (required or graph gets too wide to jpeg)
    @children > 1 || next;
    
    # we'll cluster if all children belong to the same subdirectory
    my %subdirs;
    foreach my $child (@children) {
        $subdirs{class_to_subdir($child)} = 1;
    }
    my $subdir;
    if (keys %subdirs == 1) {
        ($subdir) = keys %subdirs;
        undef $subdir if $subdir eq 'Bio';
    }
    
    my $this_child = 'group'.++$child_id;
    $g->add_node($this_child,
                 style => 'dashed',
                 label => "$this_child:\n".join("\n", @children),
                 $subdir ? (cluster => {name => $subdir, style => 'dotted', color => $cluster_colour}) : ());
    
    my @parents = split(/\|/, $group);
    
    $group_definitions .= "  $this_child consists of ".scalar(@children)." packages: ".join(', ', @children)."\n  $this_child members use ".scalar(@parents)." other packages: ".join(', ', @parents)."\n\n";
    
    foreach my $parent (@parents) {
        # we'll shade the parent box based on how many packages use it
        my $this_rank = $ranks{$parent};
        my $shade = (1 / $rank) * $this_rank;
        
		# we'll colour the edge based on if we inherited this parent or just
		# used it, going by the most common for the group
		my ($inherited, $used) = (0, 0);
		foreach my $child (@children) {
			if (defined $inheritance{$child}->{$parent}) {
				$inherited++;
			}
			else {
				$used++;
			}
		}
		my $edge_colour = $inherited > $used ? $inherited_edge_colour : $used_edge_colour;
		
        # we'll cluster if this isn't a base Bio::x class
        my $subdir = class_to_subdir($parent);
        undef $subdir if $subdir eq 'Bio';
        
        $g->add_node($parent,
                     style => 'filled',
                     fillcolor => "0,$shade,1",
                     $subdir ? (cluster => {name => $subdir, style => 'dotted', color => $cluster_colour}) : ());
        $parents{$parent} = 1;
        $g->add_edge($this_child => $parent, color => $edge_colour);
    }
}

# show links between parents
foreach my $parent (keys %parents) {
    my %used = %{$packages{$parent}};
    
    foreach my $used (keys %used) {
        next unless defined $parents{$used};
        $g->add_edge($parent => $used, color => defined $inheritance{$parent}->{$used} ? $inherited_edge_colour : $used_edge_colour);
    }
}

# write out graph
my $output = IO::File->new($outfile.".$format", 'w') or die "can't open $outfile.$format: $!\n";
$output->print(eval "\$g->as_$format()");
$output->close();


my $package_count = keys %packages;
my $total_used = keys %usage;

my $results_str = "Packages investigated: $package_count\nTotal modules used: $total_used\n\n";


# descriptive text output
# list by popularity
my @internal;
my @external;
foreach my $module (sort { $usage{$b} <=> $usage{$a} || $a cmp $b } keys %usage) {
    my $count = $usage{$module};
    
    if (defined $packages{$module}) {
        push(@internal, "  $module => used $count times");
    }
    else {
        my $by = '';
        if ($count <= 5) {
            $by = " by ".join(", ", @{$users{$module}});
        }
        push(@external, "  $module => used $count times$by");
    }
}

$results_str .= "External module usage:\n".join("\n", @external);
$results_str .= "\n\nPackage usage:\n".join("\n", @internal);

# list the packages that aren't used by any other package
$results_str .= "\n\nPackages not used by any other:\n";
foreach my $package (sort keys %packages) {
    next if $usage{$package};
    $results_str .= "  $package\n";
}

# define the groups referenced in the graph
$results_str .= "\nGroup definitions:\n$group_definitions";

# write out descriptive text file
$output = IO::File->new($outfile.'.txt', 'w') or die "can't open $outfile.txt: $!\n";
$output->print($results_str);
$output->close();

exit;
BioPerl-1.6.923/maintenance/modules.pl000555000765000024      3400112254227326 17751 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
#
=head1 NAME

modules.pl - information about modules in BioPerl core

=head1 SYNOPSIS

B [B<-V|--verbose>] [B<-c|--count>] | [B<-l|--list>] |
  [B<-u|--untested>] | [B<-i|--info> class] | [B<-i|--inherit> |
  [B<-d|--dir> path ] | [B<-v|--version> | [B<-?|-h|--help>]

=head1 DESCRIPTION

This script counts, lists and provides other information about bioperl
modules. It is mainly meant to be run by bioperl maintainers.

The default action is to count modules in the bioperl core
distribution. Based on the class name it tries to classify them into
categories. The following is a tentative glossary of terms used.


=over 4

=item Base

Synonyms: Generic class, parameterized class, generic module.

A class that you don't instantiate in your scripts, but that it's a
template for other classes.

Examples: Bio::Tools::Run::WrapperBase - a base object for wrappers
around executables. Bio::Tools::Analysis::SimpleAnalysisBase - an
abstract superclass for SimpleAnalysis implementations

This are counted with C; They have "Base" in the
beginning or end of the name.

=item Interface

Synonyms: protocol, feature set.

Class that defines a set of features that are common to a group of
classes.

Example: Bio::Tree::NodeI - interface describing a Tree Node.

This are counted with C; They have "I" at the end of the
name.

=item Component

A class that implements a small subset of their superclass. They are in
a directory with an identical name of the superclass. There are plenty
of them. You need only a small number of methods to be overridden.

Example: Bio::SeqIO::fasta.

This is counted with C; Classes are inside their base directory
and all in lowercase.

=item Instance

The rest of them. It is sometimes helpful to divide them into two
types:

=over 2

=item Algorithmic classes

Example: Bio::AlignIO - Handler for AlignIO formats

=item Storage classes

Example: Bio::SimpleAlign - Multiple alignments held as a set of
sequences

=back

=back

=cut

#
# The helper class to store class status;
#
package BioClass;

sub new {
    my $class = shift;
    my $name = shift;
    die unless $name;

    my $self = {};
    $self->{'name'} = $name;
    $self->{'tested'} = 0;
    $self->{'type'} = '';
    $self->{'path'} = '';

    bless $self, $class;
}


sub name {
    my $self = shift;
    return $self->{'name'};
}

sub tested {
    my $self = shift;
    my $value = shift;
    $self->{'tested'} = 1 if defined $value && $value;
    return $self->{'tested'} || 0;
}

sub type {
    my $self = shift;
    my $value = shift;
    $self->{'type'} = $value if defined $value;
    return $self->{'type'};
}

sub path {
    my $self = shift;
    my $value = shift;
    $self->{'path'} = $value if defined $value;
    return $self->{'path'};
}

sub add_superclass {
    my $self = shift;
    my $superclass = shift;
    return unless $superclass;
    $self->{'superclasses'}->{$superclass} = 1 ;
}

sub each_superclass {
    my $self = shift;
    return  keys %{$self->{'superclasses'}};
}

sub add_used_class {
    my $self = shift;
    my $used_class = shift;
    return unless $used_class;
    $self->{'used_classes'}->{$used_class} = 1 ;
}

sub each_used_class {
    my $self = shift;
    return  keys %{$self->{'used_classes'}};
}

package main;

use File::Find;
use Getopt::Long;
use Data::Dumper;
use strict;


# declare subroutines
sub dir;
sub modules;
sub count;
sub list_all;
sub untested;
sub info;
sub inherit;
sub synopsis;
sub version;

# command line options
my ($dir, $count,$list, $verbose,$info,$untested, $inherit, $synopsis,
    $version);
GetOptions(
	   'dir:s'      => \$dir,
	   'count'    => \$count,
	   'list'     => \$list,
           'test_BioClass' => \&_test_BioClass,
           'V|verbose'  => \$verbose,
           'untested' => \$untested,
           'info:s' =>  \$info,
           'inherit' => \$inherit,
           'synopsis' => \$synopsis,
           'version' => \$version,
	   'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
	   );


our %MODULES; # storage structure

# find modules
my $pwd = $ENV{PWD};
my $seachdir = "$pwd/../Bio"; #default
my %FIND_OPTIONS = ( wanted => \&modules );

$seachdir = "$pwd/$dir" if $dir;
find \%FIND_OPTIONS, $seachdir;


# call subroutines
if    ($list)     { list_all }
elsif ($untested) { untested }
elsif ($info)     { info($info) }
elsif ($inherit)  { inherit }
elsif ($synopsis) { synopsis }
elsif ($version)   { version }
else              { count }


################# end main ####################


#
# subroutines;
#

sub _test_BioClass {
    $a = new BioClass('Bio::Test');
    print "Class name: ", $a->name(), "\n";
    $a->add_superclass('Bio::Super');
    $a->add_superclass('Bio::Super2');
    $a->tested(1);
    $a->type('instance');
    print Dumper [$a->each_superclass] if $a->tested;
    print Dumper $a;
    exit;
}

sub modules {
    return unless /\.pm$/ ;
    #return unless -e $_;
    #print "file: $_\n" if $verbose;
    open (F, $_) or warn "can't open file $_: $!" && return;
    my $class;
    while () {
        if (/^package\s+([\w:]+)\s*;/) {
            #print $1, "\n" if $verbose;
            $_ = $1;
            $class = new BioClass($_);
            $MODULES{$_} = $class;
            if (/.*:[a-z]/) {
                $class->type('component');
            } elsif (/:Base/ | /Base$/) {
                $class->type('base');
            } elsif (/[^A-Z]I$/) {
                $class->type('interface');
            } else {
                $class->type('instance');
            }
            $class->path($File::Find::name);
        }
        if (/^\w*use/ && /(Bio[\w:]+)\W*;/ && not /base/) {
	    next unless $class;
            #print "\t$1\n" if $verbose;
            $class->add_used_class($1);
        }
        if ((/\@ISA/ || /use base/) && /Bio/) {
            next unless $class;
            my $line = $_;
            while ( $line =~ /(Bio[\w:]+)/g) {
                #print "\t$1\n" if $verbose;
                $class->add_superclass($1);
            }
        }
        if (/\@ISA/ && /Bio/) {
            next unless $class;
            my $line = $_;
            while ( $line =~ /(Bio[\w:]+)/g) {
                #print "\t$1\n" if $verbose;
                $class->add_superclass($1);
            }
        }
    }
    close F;
}

=head1 OPTIONS

Only one option is processed on each run of the script. The --verbose
is an exception, it modifies the amount of output.

=over 4

=item B<-V | --verbose>

B

Set this option if you want to see more verbose output. Often that
will mean seeing warnings normally going into STDERR.

=cut

=item B<-d | --dir> path

Overides the default directories to check by one directory 'path' and
all its subdirectories.

=item B<-c | --count>

The default action if no other option is given. Gives the count of
modules broken to B ("usable"), B ( (abstract)?
superclass) , B (the "I" files) and B (used from
instantiable parent) modules, in addition to total number of modules.

Note that abstract superclass in bioperl is not an enforced concept and
they are not clearly indicateded in the class name.

=cut

sub count {
    printf "Instance : %3d\n",
        scalar (grep $MODULES{$_}->type =~ /instance/ , keys %MODULES);
    printf "Base     : %3d\n",
        scalar (grep $MODULES{$_}->type =~ /base/ , keys %MODULES);
    printf "Interface: %3d\n",
        scalar (grep $MODULES{$_}->type =~ /interface/ , keys %MODULES);
    printf "Component: %3d\n",
        scalar (grep $MODULES{$_}->type =~ /component/ , keys %MODULES);
    print  "--------------\n";
    printf "Total    : %3d\n", scalar (keys %MODULES);

}

=item B<-l | --list>

Prints all the module names in alphabetical order. The output is a tab
separated list of category (see above) and module name per line. The
output can be processed with standard UNIX command line tools.

=cut

sub list_all {
    foreach ( sort keys %MODULES) {
        print $MODULES{$_}->type. "\t$_\n";
    }
}

=item B<-u | --untested>

Prints a list of instance modules which are I explicitly used by
test files in the directory. Superclasess or any classes used by others
are not reported, either, since their methods are assumed to be tested
by subclass tests.


=cut

sub _used_and_super {
    my $name = shift;
#    print "-:$name\n" if /Locati/; 
    foreach ($MODULES{$name}->each_superclass) {
        next unless defined $MODULES{$_};
#        print "-^$_\n" if /Locati/; 
#        unless (defined $MODULES{$_} or $MODULES{$_}->tested) {
        if (not  $MODULES{$_}->tested) {
            $MODULES{$_}->tested(1);
            _used_and_super($_);
        }
    }
    foreach ($MODULES{$name}->each_used_class) {
        next unless defined $MODULES{$_};
#        print "--$_\n" if /Locati/; 
#        unless (defined $MODULES{$_} or $MODULES{$_}->tested) {
        if (not  $MODULES{$_}->tested) {
            $MODULES{$_}->tested(1);
            _used_and_super($_);
        }
#        $MODULES{$_}->tested(1) && _used_and_super($_)
#            unless defined $MODULES{$_} or $MODULES{$_}->tested;
    }
    return 1;
}

sub untested {
    foreach (`find ../t -name "*.t" -print | xargs grep -hs "[ur][se][eq]"`) {
        s/.*use +//;
        s/.*require +//;
        next unless /^Bio/;

        s/[\W;]+$//;
        s/([\w:]+).*/$1/;
        my $name = $_;

        next unless $MODULES{$_};
        $MODULES{$_}->tested(1) 
            unless defined $MODULES{$_} and $MODULES{$_}->tested;

        next if $MODULES{$name}->name eq "Bio::SeqIO::abi"; # exception: requires bioperl ext package
        next if $MODULES{$name}->name eq "Bio::SeqIO::ctf"; # exception: requires bioperl ext package
        next if $MODULES{$name}->name eq "Bio::SeqIO::exp"; # exception: requires bioperl ext package
        next if $MODULES{$name}->name eq "Bio::SeqIO::pln"; # exception: requires bioperl ext package
        next if $MODULES{$name}->name eq "Bio::SeqIO::ztr"; # exception: requires bioperl ext package
#        print $MODULES{$name}->name, "\n";
#        print Dumper $MODULES{$name};

        _used_and_super($name);

    }

    foreach ( sort keys %MODULES) {

        # skip some name spaces 
        next  if /^Bio::Search/; # Bio::Search and Bio::SearchIO are extensively tested 
                                 # but classes are used by attribute naming 

        print "$_\n" if
            $MODULES{$_}->type eq 'instance' and ($MODULES{$_}->tested == 0) ;
    }

}

=item B<-i | --info> class

Dumps information about a class given as an argument.

=cut

sub info {
    my $class = shift;
    die "" unless $class;
    #print Dumper $MODULES{$class};
    my $c = $MODULES{$class};
    print $c->name, "\n";
    printf "  Type:\n\t%s\n", $c->type;
    print "  Superclasses:\n";
    foreach (sort $c->each_superclass) {
        print "\t$_\n";
    }
    print "  Used classes:\n";
    foreach (sort $c->each_used_class) {
        print "\t$_\n";
    }
}


=item B<-i | --inherit>

Finds interface modules which inherit from an instantiable class.

Could be extended to check other bad inheritance patterns.

=cut

sub inherit {
    foreach ( sort keys %MODULES) {
        my $c=$MODULES{$_};
        next unless $c->type =~ /interface/;
        foreach my $super ($c->each_superclass) {
            next if $super =~ /I$/;
            print "Check this inheritance: ", $c->name, " <-- $super\n";
        }
    }
}

=item B<-s | --synopsis>

Test SYNOPSIS section of bioperl modules for runnability

=cut

sub synopsis {
    foreach ( sort keys %MODULES) {
        my $c=$MODULES{$_};

        next unless $c->type eq "instance";
        next if $c->name eq 'Bio::Root::Version';
        next if $c->name eq 'Bio::Tools::HMM';

        my $synopsis = '';
        open (F, $c->path) or warn "can't open file ".$c->name.": $!" && return;

        my $flag = 0;
        while () {
            last if $flag && /^=/;
            $synopsis .= $_ if $flag;
            $flag = 1 if /^=head1 +SYNOPSIS/;
        }

        # remove comments
        $synopsis =~ s/[^\$]#[^\n]*//g;
        # allow linking to an other Bio module, e.g.: See L.
        $synopsis =~ s/[^\n]*L&1 `;
        next if $res =~ /syntax OK/;
        print $c->path, "\n";
        print $synopsis;
        print $res;
        print "-" x 70, "\n"; 
        # print "SYNOPSIS not runnable\n";
        close F;
    }
}

=item B<-v | --version>

Test the VERSION of the module against the global one set in
Bio::Root::Variation. Print out the different ones.

=cut

sub version {

    use Bio::Root::Version;
    my $version =  $Bio::Root::Version::VERSION;

    my %skip = ( # these are defined together with an other module
                 # and can not be use independently
                'Bio::AnalysisI::JobI' => 1,
                'Bio::PrimarySeq::Fasta' => 1,
                'Bio::DB::Fasta::Stream' => 1,
                'Bio::DB::GFF::ID_Iterator' => 1,
                'Bio::DB::GFF::Adaptor::dbi::faux_dbh' =>1,
                'Bio::LiveSeq::IO::SRS' =>1 # tries to call an external module
               );

    foreach ( sort keys %MODULES) {
        my $n=$MODULES{$_}->name;
        next if $skip{$n};
        my $vv= "\$${n}::VERSION";
        my $v = `perl -we 'use $n; print $vv;'`;
        printf "%50s %-3s\n", $n, $v unless $version eq $v;
    }
}

__END__

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR

Heikki Lehvaslaiho, heikki-at-bioperl-dot-org

=head1 Contributors

Albert Vilella, avilella-AT-gmail-DOT-com

=cut



BioPerl-1.6.923/maintenance/ncbi_blast_switches.pl000555000765000024       100312254227326 22266 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

# This script determines all the valid command line switches
# from the four main NCBI BLAST tools, and produces Perl code
# to put into Bio/Tools/Run/StandAloneBlast.pm
#
# Torsten Seemann
# 27 June 2006


my @exe = qw(blastall blastpgp rpsblast bl2seq);

for my $exe (@exe) {
  open(HELP, "$exe - |") or die $!;
  my @switch;
  while () {
    next unless m/^\s*-(\w)\s/;
    push @switch, $1;
  }
  close(HELP);
  print "\t\@",uc($exe),"_PARAMS = qw(", join(q{ }, sort @switch), ");\n";
}

BioPerl-1.6.923/maintenance/perltidy.conf000444000765000024        62112254227320 20377 0ustar00cjfieldsstaff000000000000# A declarative version of PDD07 for perl.

# Must apply...

-l=100 # Source line width is limited to 100 characters.
-i=4   # must be indented four columns (no tabs)
-ola   # Labels (including case labels) must be outdented two columns
-ci=4  # Long lines, when split, must use at least one extra level of indentation on the continued line.
-ce   # Cuddled elses are forbidden: i.e. avoid } else { .
BioPerl-1.6.923/maintenance/pod.pl000555000765000024      1066412254227314 17071 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
#
=head1 NAME

pod.pl - check the POD documentation syntax in modules and scripts

=head1 SYNOPSIS

B [B<-d|--dir> path ] [B<-v|--verbose>] B<-b|--blankline>
    [B<-?|-h|--help>]

=head1 DESCRIPTION

Checks Plain Old Documentation (POD) with highest possible stringency
in every bioperl module and script in CVS modules 'core' and 'run'.

Amounts to same as running

  podchecker -warnings -warnings

on every file.

=head2 Results

The results are written into file '/tmp/bioperl_pod_check' and
displayed after the run. The output is filtered not to show
confirmations of correct syntax. The result file is not removed.

The aim is to have as few warnings, and no errors, as possible.  Links
to web URLs give a warning but that seems to be spurious, so they are
filtered out.  Currently there are a few cases of "multiple occurrence
of link target" in several modules which are harmless.

=head1 SEE ALSO

L, L

=cut

use File::Find;
use Pod::Checker;
use Getopt::Long;
use strict;

sub podcheck;
sub blankline;

#
## Directories to check
#
my @dirs = qw( ../Bio/ ../scripts . );

# command line options
my ($verbose, $blankline, $dir, $help) = (0, undef, undef, undef);
GetOptions(
           'v|verbose' => \$verbose,
           'dir:s' => \$dir,
           'blankline' => \$blankline,
	   'h|help|?' => sub{ exec('perldoc',$0); exit(0) }
	   );

# setup
my $tmpfile = '/tmp/bioperl_pod_check';
our %POD_CHECKER_OPTIONS = ( '-warnings' => 2 );
our %FIND_OPTIONS = ( wanted => \&podcheck, no_chdir => 1 );

# run
open (F, ">$tmpfile") || die "can't open file $tmpfile: $!";
$FIND_OPTIONS{wanted} = \&blankline if $blankline;

if ($dir) {
    find \%FIND_OPTIONS, $dir;
} else {
    find \%FIND_OPTIONS, @dirs;
}
close F;
open (F, "grep -v OK $tmpfile|") || die "can't open file $tmpfile: $!";
while () { print unless /http/ and /non-escaped/ }


# this is where the action is
sub podcheck {
    return unless /\.PLS$/ or /\.p[ml]$/ ;
    return unless -e $_;
    print "$_\n" if $verbose;
    my $checker = Pod::Checker->new( %POD_CHECKER_OPTIONS );
    $checker->parse_from_file($_, \*F);
    print "$_\tno POD\n" if $checker->num_errors() < 0;
}

=head1 OPTIONS

=over 3

=item B<-d | --dir> path

Overides the default directories to check by one directory 'path' and
all its subdirectories.

=item B<-b | --blankline>

Checks POD command paragraphs (lines starting with '=' character) for
preceding nonblank lines. These lines are printed out with '++'.

Also, if verbose is turned on, it will report on lines whitespace
characters which prevent paragrafs to be recognised by older POD
parsers (marked with '+'). Modern perlpod parsers (5.6.0 and later, I
suppose) allow for whitespace lines surrounding command lines, but
since bioperl still supports older versions, these lines should be
cleaned to contain only '\n' and no space or tab characters.


See: L


=cut

sub blankline {
    return unless /\.PLS$/ or /\.p[ml]$/ ;
    return unless -e $_;
    my $file = $_;
    open (F, $_) or warn "can't open file $_: $!" && return;
    local $/="";
    while () {
        print "$file: +|$1|\n" if /[ \t]\n(=[a-z][^\n]+$)/m and $verbose;
        print "$file: ++|$1|\n" if /\w\n(=[a-z][^\n]+$)/m and $verbose;
        print "$file:|$1|+\n" if /(^=[a-z][^\n]+)\n[\t ]/m;
        #print "$file:|$1|++\n" if /(^=[^\n]+)\n\w/m;
    }
    close F;
}

__END__

=item B<-v | --verbose>

Show the progress through files during the POD checking.

=item B<-? | -h  | --help>

This help text.

=back

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Heikki Lehvaslaiho

Email heikki-at-bioperl-dot-org

=cut


# find . -name '*.pm' -print | xargs  perl -e '$/=""; while (<>) {$n = $1 if /^package\s+([\w:]+)/; print "$n:|$1|"  if  /(\s\s^=[^\n]+$)/m ; }'  ;

# find . -name '*.pm' -print | xargs  perl -e '$/=""; while (<>) {$n = $1 if /^package\s+([\w:]+)/; print "$n:|$1|\n"  if /(^=[^\n]+\n[\t ])/m ; }'  ;
BioPerl-1.6.923/maintenance/README000444000765000024       111312254227340 16573 0ustar00cjfieldsstaff000000000000
The scripts in this directory are meant for bioperl maintainers.  They
count and test modules that make up the bioperl core library.

The scripts are not expected to run under any other than UNIXy
operating systems.

Run them from this directory.

Dependencies (not required for bioperl):
========================================

Module                         Script
------------------------------------------------
Data::Dumper                   authors.pl
                               modules.pl
Regexp::Common                 check_URLs.pl
Pod::Checker                   pod.pl

BioPerl-1.6.923/maintenance/symlink_script.pl000555000765000024       520112254227312 21326 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
use Module::Build;
use strict;
use warnings;

my $build = Module::Build->current;

my %symlink_scripts = ('bp_bulk_load_gff.pl' => 'bp_pg_bulk_load_gff.pl');

#my $blib_dir = File::Spec->catdir($build->blib, 'script');
# using blib prior to installation, post build, always 'works', but the
# installation process installs the symlink as the actual file, so we may as
# well have just done a copy

my $install_dir = $build->install_destination('script');
$build->log_info("Will try to install symlinks to $install_dir\n");
my $orig_dir = $build->cwd;
chdir($install_dir);

while (my ($source, $destination) = each %symlink_scripts) {
	if ($^O !~ /Win32/) {
		eval { symlink($source, $destination) };
		$build->log_warn("Cannot create symbolic link named $destination on your system for $source in $install_dir\n") if $@;
	} else {
		# Win32 perl does not implement symlink(), as it would not work on all filesystems.
		require File::Copy;
		eval { File::Copy::copy($source, $destination) };
		$build->log_warn("Cannot create copy of script named $destination on your system for $source in $install_dir\n") if $@;
	}
}

chdir($orig_dir);

exit;

__END__

=head1 NAME

symlink_script.pl - install script to create symbolic links

=head1 SYNOPSIS

  perl Build.pl
  ./Build install

=head1 DESCRIPTION

Used during "./Build install". Only works if the script installation directory
used during "perl Build.pl" matches that used for the actual installation during
"./Build install". So if you install to a special place, do

  perl Build.pl --install_base /home/me
  ./Build install

not

  perl Build.pl
  ./Build install --install_base /home/me

This script will create a symlink to a script in that same directory. It was
written to create a symlink with the name 'bp_pg_bulk_load_gff.pl' that targeted
'bp_bulk_load_gff.pl' but can be extended by adding files to the
%symlink_scripts hash.

Perl function 'symlink' is used to keep the script from crashing on systems
that don't allow symbolic linking.

=head1 SEE ALSO

=cut

=head1 FEEDBACK

=head2 Mailing Lists

User feedback is an integral part of the evolution of this and other
Bioperl modules. Send your comments and suggestions preferably to
the Bioperl mailing list.  Your participation is much appreciated.

  bioperl-l@bioperl.org                  - General discussion
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists

=head2 Reporting Bugs

Report bugs to the Bioperl bug tracking system to help us keep track
of the bugs and their resolution. Bug reports can be submitted via the
web:

  https://redmine.open-bio.org/projects/bioperl/

=head1 AUTHOR - Sendu Bala

Email bix@sendu.me.uk

=cut
BioPerl-1.6.923/maintenance/version.pl000555000765000024       223312254227315 17746 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
#
=head1 version

This script is to add or modify version declaration for each bioperl pm.

[Currently, it just add version. Later I will update it to modify version.]

=head1 USAGE

  perl version.pl  

=cut

use strict;

if(@ARGV < 2) {
    die "USAGE: perl version.pl  \n";
}
my $dir=shift || "$ENV{HOME}/src/bioperl-live/";
my $version=shift || '1.4';

sub traveral_dir {
    my ($dir, )=@_;
    opendir DIR, $dir;
    my @allfiles= grep{$_ ne '.' and $_ ne '..'}readdir DIR;
    closedir DIR;
    my @full_path = map{"$dir/$_"} @allfiles;
    my @out = grep -f, @full_path;
    foreach(grep -d, @full_path){
        push @out, traveral_dir($_);
    }
    return @out;
}

my @pm=sort grep /\.pm$/, traveral_dir($dir);

use ExtUtils::MakeMaker;

map {
    my $f=$_; 
    my $v = MM->parse_version($f);
    print "$v\t$f\n";
    my $ep ='s/^(package\s+[\w:]+;\r?)$/$1\nour \$VERSION="'. $version.'";/';

    if((not defined $v) or $v eq 'undef'){ # This is strange on parse_version. 
    # It return scalar 'undef', not the undef can be detected by defined.
        `perl -p -i -e '$ep' $f`;
    }

} @pm;

BioPerl-1.6.923/maintenance/big_split000755000765000024          012254227331 17536 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/maintenance/big_split/file_classification.csv000444000765000024     21142212254227313 24444 0ustar00cjfieldsstaff000000000000,"AUTHORS"
"Bio-Analysis","Bio/AnalysisI.pm"
,"Bio/Draw/Pictogram.pm"
"Bio-Taxonomy","Bio/Taxonomy/Tree.pm"
"Bio-Taxonomy","Bio/Taxonomy/FactoryI.pm"
"Bio-Taxonomy","Bio/Taxonomy/Node.pm"
"Bio-Taxonomy","Bio/Taxonomy/Taxon.pm"
,"Bio/HandlerBaseI.pm"
,"Bio/DescribableI.pm"
,"Bio/Nexml/Factory.pm"
,"Bio/MapIO/mapmaker.pm"
,"Bio/MapIO/fpc.pm"
"Bio-SeqEvolution","Bio/SeqEvolution/DNAPoint.pm"
"Bio-SeqEvolution","Bio/SeqEvolution/EvolutionI.pm"
"Bio-SeqEvolution","Bio/SeqEvolution/Factory.pm"
"Bio-SeqIO","Bio/SeqIO.pm"
,"Bio/OntologyIO.pm"
,"Bio/PhyloNetwork.pm"
,"Bio/DBLinkContainerI.pm"
"Bio-Map","Bio/Map/Contig.pm"
"Bio-Map","Bio/Map/CytoMap.pm"
"Bio-Map","Bio/Map/MapI.pm"
"Bio-Map","Bio/Map/Gene.pm"
"Bio-Map","Bio/Map/SimpleMap.pm"
"Bio-Map","Bio/Map/LinkagePosition.pm"
"Bio-Map","Bio/Map/CytoMarker.pm"
"Bio-Map","Bio/Map/PositionI.pm"
"Bio-Map","Bio/Map/Microsatellite.pm"
"Bio-Map","Bio/Map/OrderedPositionWithDistance.pm"
"Bio-Map","Bio/Map/Prediction.pm"
"Bio-Map","Bio/Map/Physical.pm"
"Bio-Map","Bio/Map/PositionHandler.pm"
"Bio-Map","Bio/Map/Position.pm"
"Bio-Map","Bio/Map/PositionWithSequence.pm"
"Bio-Map","Bio/Map/GenePosition.pm"
"Bio-Map","Bio/Map/MarkerI.pm"
"Bio-Map","Bio/Map/RelativeI.pm"
"Bio-Map","Bio/Map/MappableI.pm"
"Bio-Map","Bio/Map/GeneMap.pm"
"Bio-Map","Bio/Map/TranscriptionFactor.pm"
"Bio-Map","Bio/Map/Clone.pm"
"Bio-Map","Bio/Map/Mappable.pm"
"Bio-Map","Bio/Map/OrderedPosition.pm"
"Bio-Map","Bio/Map/Marker.pm"
"Bio-Map","Bio/Map/LinkageMap.pm"
"Bio-Map","Bio/Map/GeneRelative.pm"
"Bio-Map","Bio/Map/Relative.pm"
"Bio-Map","Bio/Map/CytoPosition.pm"
"Bio-Map","Bio/Map/FPCMarker.pm"
"Bio-Map","Bio/Map/PositionHandlerI.pm"
"Bio-Map","Bio/Map/EntityI.pm"
"Bio-Restriction","Bio/Restriction/EnzymeCollection.pm"
"Bio-Restriction","Bio/Restriction/IO/withrefm.pm"
"Bio-Restriction","Bio/Restriction/IO/itype2.pm"
"Bio-Restriction","Bio/Restriction/IO/prototype.pm"
"Bio-Restriction","Bio/Restriction/IO/bairoch.pm"
"Bio-Restriction","Bio/Restriction/IO/base.pm"
"Bio-Restriction","Bio/Restriction/Enzyme/MultiSite.pm"
"Bio-Restriction","Bio/Restriction/Enzyme/MultiCut.pm"
"Bio-Restriction","Bio/Restriction/IO.pm"
"Bio-Restriction","Bio/Restriction/Analysis.pm"
"Bio-Restriction","Bio/Restriction/Enzyme.pm"
"Bio-Restriction","Bio/Restriction/EnzymeI.pm"
,"Bio/LocationI.pm"
"Bio-Tree","Bio/TreeIO/phyloxml.pm"
"Bio-Tree","Bio/TreeIO/pag.pm"
"Bio-Tree","Bio/TreeIO/lintree.pm"
"Bio-Tree","Bio/TreeIO/svggraph.pm"
"Bio-Tree","Bio/TreeIO/nexml.pm"
"Bio-Tree","Bio/TreeIO/nhx.pm"
"Bio-Tree","Bio/TreeIO/nexus.pm"
"Bio-Tree","Bio/TreeIO/tabtree.pm"
"Bio-Tree","Bio/TreeIO/newick.pm"
"Bio-Tree","Bio/TreeIO/cluster.pm"
"Bio-Tree","Bio/TreeIO/TreeEventBuilder.pm"
"Bio-Analysis","Bio/AnalysisResultI.pm"
,"Bio/Range.pm"
"Bio-Tree","Bio/TreeIO.pm"
,"Bio/IdentifiableI.pm"
"Bio-Das","Bio/Das/SegmentI.pm"
"Bio-Das","Bio/Das/FeatureTypeI.pm"
,"Bio/PullParserI.pm"
"Bio-Analysis","Bio/Factory/AnalysisI.pm"
,"Bio/Factory/SequenceProcessorI.pm"
,"Bio/Factory/SequenceStreamI.pm"
,"Bio/Factory/ObjectFactoryI.pm"
,"Bio/Factory/TreeFactoryI.pm"
,"Bio/Factory/SeqAnalysisParserFactoryI.pm"
,"Bio/Factory/MapFactoryI.pm"
,"Bio/Factory/SequenceFactoryI.pm"
,"Bio/Factory/SeqAnalysisParserFactory.pm"
,"Bio/Factory/ObjectBuilderI.pm"
,"Bio/Factory/ApplicationFactoryI.pm"
,"Bio/Factory/FTLocationFactory.pm"
,"Bio/Factory/ObjectFactory.pm"
,"Bio/Factory/DriverFactory.pm"
,"Bio/Factory/LocationFactoryI.pm"
,"Bio/Species.pm"
,"Bio/NexmlIO.pm"
"Bio-Cluster","Bio/Cluster/UniGene.pm"
"Bio-Cluster","Bio/Cluster/UniGeneI.pm"
"Bio-Cluster","Bio/Cluster/FamilyI.pm"
"Bio-Cluster","Bio/Cluster/SequenceFamily.pm"
"Bio-Cluster","Bio/Cluster/ClusterFactory.pm"
,"Bio/SimpleAlign.pm"
"Bio-Cluster","Bio/ClusterI.pm"
"Bio-Coordinate","Bio/Coordinate/Graph.pm"
"Bio-Coordinate","Bio/Coordinate/GeneMapper.pm"
"Bio-Coordinate","Bio/Coordinate/Chain.pm"
"Bio-Coordinate","Bio/Coordinate/Collection.pm"
"Bio-Coordinate","Bio/Coordinate/Result.pm"
"Bio-Coordinate","Bio/Coordinate/ResultI.pm"
"Bio-Coordinate","Bio/Coordinate/Pair.pm"
"Bio-Coordinate","Bio/Coordinate/MapperI.pm"
"Bio-Coordinate","Bio/Coordinate/ExtrapolatingPair.pm"
"Bio-Coordinate","Bio/Coordinate/Utils.pm"
"Bio-Coordinate","Bio/Coordinate/Result/Gap.pm"
"Bio-Coordinate","Bio/Coordinate/Result/Match.pm"
,"Bio/Seq.pm"
"Bio-Tree","Bio/Tree/Draw/Cladogram.pm"
"Bio-Tree","Bio/Tree/DistanceFactory.pm"
"Bio-Tree","Bio/Tree/Compatible.pm"
"Bio-Tree","Bio/Tree/TreeI.pm"
"Bio-Tree","Bio/Tree/Tree.pm"
"Bio-Tree","Bio/Tree/AnnotatableNode.pm"
"Bio-Tree","Bio/Tree/NodeI.pm"
"Bio-Tree","Bio/Tree/AlleleNode.pm"
"Bio-Tree","Bio/Tree/Statistics.pm"
"Bio-Tree","Bio/Tree/RandomFactory.pm"
"Bio-Tree","Bio/Tree/Node.pm"
"Bio-Tree","Bio/Tree/TreeFunctionsI.pm"
"Bio-Tree","Bio/Tree/NodeNHX.pm"
,"Bio/Structure/IO/pdb.pm"
"Bio-Structure","Bio/Structure/Atom.pm"
"Bio-Structure","Bio/Structure/Residue.pm"
"Bio-Structure","Bio/Structure/StructureI.pm"
"Bio-Structure","Bio/Structure/Chain.pm"
"Bio-Structure","Bio/Structure/IO.pm"
"Bio-Structure","Bio/Structure/Model.pm"
"Bio-Structure","Bio/Structure/Entry.pm"
"Bio-Structure","Bio/Structure/SecStr/DSSP/Res.pm"
"Bio-Structure","Bio/Structure/SecStr/STRIDE/Res.pm"
"Bio-SeqFeature-Annotated","Bio/SeqFeature/Annotated.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/ExonI.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/UTR.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/Exon.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/Transcript.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/GeneStructure.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/GeneStructureI.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/Poly_A_site.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/NC_Feature.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/Promoter.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/Intron.pm"
"Bio-SeqFeature-Gene","Bio/SeqFeature/Gene/TranscriptI.pm"
,"Bio/SeqFeature/Generic.pm"
,"Bio/SeqFeature/SiRNA/Pair.pm"
,"Bio/SeqFeature/SiRNA/Oligo.pm"
,"Bio/SeqFeature/FeaturePair.pm"
,"Bio/SeqFeature/Similarity.pm"
,"Bio/SeqFeature/Computation.pm"
,"Bio/SeqFeature/Collection.pm"
,"Bio/SeqFeature/Primer.pm"
,"Bio/SeqFeature/SimilarityPair.pm"
,"Bio/SeqFeature/AnnotationAdaptor.pm"
,"Bio/SeqFeature/PositionProxy.pm"
,"Bio/SeqFeature/TypedSeqFeatureI.pm"
,"Bio/SeqFeature/Lite.pm"
,"Bio/SeqFeature/CollectionI.pm"
,"Bio/SeqFeature/Tools/Unflattener.pm"
,"Bio/SeqFeature/Tools/IDHandler.pm"
,"Bio/SeqFeature/Tools/FeatureNamer.pm"
,"Bio/SeqFeature/Tools/TypeMapper.pm"
"Bio-Variation","Bio/Variation/AAReverseMutate.pm"
"Bio-Variation","Bio/Variation/IO/flat.pm"
"Bio-Variation","Bio/Variation/IO/xml.pm"
"Bio-Variation","Bio/Variation/AAChange.pm"
"Bio-Variation","Bio/Variation/SNP.pm"
"Bio-Variation","Bio/Variation/README"
"Bio-Variation","Bio/Variation/SeqDiff.pm"
"Bio-Variation","Bio/Variation/IO.pm"
"Bio-Variation","Bio/Variation/RNAChange.pm"
"Bio-Variation","Bio/Variation/DNAMutation.pm"
"Bio-Variation","Bio/Variation/Allele.pm"
"Bio-Variation","Bio/Variation/VariantI.pm"
,"Bio/AnnotationCollectionI.pm"
,"Bio/Perl.pm"
,"Bio/MolEvol/CodonModel.pm"
"Bio-Align","Bio/AlignIO/proda.pm"
"Bio-Align","Bio/AlignIO/stockholm.pm"
"Bio-Align","Bio/AlignIO/clustalw.pm"
"Bio-Align","Bio/AlignIO/xmfa.pm"
"Bio-Align","Bio/AlignIO/selex.pm"
"Bio-Align","Bio/AlignIO/fasta.pm"
"Bio-Align","Bio/AlignIO/bl2seq.pm"
"Bio-Align","Bio/AlignIO/emboss.pm"
"Bio-Align","Bio/AlignIO/arp.pm"
"Bio-Align","Bio/AlignIO/prodom.pm"
"Bio-Align","Bio/AlignIO/po.pm"
"Bio-Align","Bio/AlignIO/nexml.pm"
"Bio-Align","Bio/AlignIO/meme.pm"
"Bio-Align","Bio/AlignIO/mega.pm"
"Bio-Align","Bio/AlignIO/pfam.pm"
"Bio-Align","Bio/AlignIO/largemultifasta.pm"
"Bio-Align","Bio/AlignIO/maf.pm"
"Bio-Align","Bio/AlignIO/nexus.pm"
"Bio-Align","Bio/AlignIO/msf.pm"
"Bio-Align","Bio/AlignIO/psi.pm"
"Bio-Align","Bio/AlignIO/phylip.pm"
"Bio-Align","Bio/AlignIO/Handler/GenericAlignHandler.pm"
"Bio-Align","Bio/AlignIO/mase.pm"
"Bio-Align","Bio/AlignIO/metafasta.pm"
,"Bio/SeqFeatureI.pm"
"Bio-Align","Bio/Align/DNAStatistics.pm"
"Bio-Align","Bio/Align/ProteinStatistics.pm"
"Bio-Align","Bio/Align/AlignI.pm"
"Bio-Align","Bio/Align/PairwiseStatistics.pm"
"Bio-Align","Bio/Align/Utilities.pm"
"Bio-Align","Bio/Align/Graphics.pm"
"Bio-Align","Bio/Align/StatisticsI.pm"
,"Bio/UpdateableSeqI.pm"
,"Bio/CodonUsage/IO.pm"
,"Bio/CodonUsage/Table.pm"
,"Bio/ClusterIO/unigene.pm"
,"Bio/ClusterIO/dbsnp.pm"
,"Bio/PrimarySeq.pm"
,"Bio/SearchIO.pm"
"Bio-Seq-Meta","Bio/Seq/MetaI.pm"
"Bio-Seq","Bio/Seq/LargeSeqI.pm"
"Bio-Seq","Bio/Seq/EncodedSeq.pm"
"Bio-Seq","Bio/Seq/LargeSeq.pm"
"Bio-Seq","Bio/Seq/QualI.pm"
"Bio-Seq","Bio/Seq/SeqWithQuality.pm"
"Bio-Seq","Bio/Seq/LargeLocatableSeq.pm"
"Bio-Seq","Bio/Seq/Quality.pm"
"Bio-Seq","Bio/Seq/TraceI.pm"
"Bio-Seq","Bio/Seq/SequenceTrace.pm"
"Bio-Seq-Meta","Bio/Seq/Meta.pm"
"Bio-Seq","Bio/Seq/PrimedSeq.pm"
"Bio-Seq","Bio/Seq/SeqFastaSpeedFactory.pm"
"Bio-Seq","Bio/Seq/SeqBuilder.pm"
"Bio-Seq","Bio/Seq/RichSeqI.pm"
"Bio-Seq","Bio/Seq/BaseSeqProcessor.pm"
"Bio-Seq","Bio/Seq/PrimaryQual.pm"
"Bio-Seq-Meta","Bio/Seq/Meta/Array.pm"
"Bio-Seq","Bio/Seq/LargePrimarySeq.pm"
"Bio-Seq","Bio/Seq/SeqFactory.pm"
"Bio-Seq","Bio/Seq/RichSeq.pm"
,"Bio/IdCollectionI.pm"
"Bio-Analysis","Bio/AnalysisParserI.pm"
"Bio-Ontology","Bio/Ontology/GOterm.pm"
"Bio-Ontology","Bio/Ontology/DocumentRegistry.pm"
"Bio-Ontology","Bio/Ontology/RelationshipFactory.pm"
"Bio-Ontology","Bio/Ontology/Ontology.pm"
"Bio-Ontology","Bio/Ontology/InterProTerm.pm"
"Bio-Ontology","Bio/Ontology/TermI.pm"
"Bio-Ontology","Bio/Ontology/Path.pm"
"Bio-Ontology","Bio/Ontology/TermFactory.pm"
"Bio-Ontology","Bio/Ontology/SimpleGOEngine/GraphAdaptor02.pm"
"Bio-Ontology","Bio/Ontology/SimpleGOEngine/GraphAdaptor.pm"
"Bio-Ontology","Bio/Ontology/Relationship.pm"
"Bio-Ontology","Bio/Ontology/RelationshipI.pm"
"Bio-Ontology","Bio/Ontology/Term.pm"
"Bio-Ontology","Bio/Ontology/OBOEngine.pm"
"Bio-Ontology","Bio/Ontology/OntologyEngineI.pm"
"Bio-Ontology","Bio/Ontology/OntologyI.pm"
"Bio-Ontology","Bio/Ontology/PathI.pm"
"Bio-Ontology","Bio/Ontology/SimpleOntologyEngine.pm"
"Bio-Ontology","Bio/Ontology/OBOterm.pm"
"Bio-Ontology","Bio/Ontology/RelationshipType.pm"
"Bio-Ontology","Bio/Ontology/OntologyStore.pm"
,"Bio/AnnotatableI.pm"
"Bio-Assembly","Bio/Assembly/Contig.pm"
"Bio-Assembly","Bio/Assembly/IO/maq.pm"
"Bio-Assembly","Bio/Assembly/IO/ace.pm"
"Bio-Assembly","Bio/Assembly/IO/phrap.pm"
"Bio-Assembly","Bio/Assembly/IO/sam.pm"
"Bio-Assembly","Bio/Assembly/IO/tigr.pm"
"Bio-Assembly","Bio/Assembly/IO/bowtie.pm"
"Bio-Assembly","Bio/Assembly/ScaffoldI.pm"
"Bio-Assembly","Bio/Assembly/IO.pm"
"Bio-Assembly","Bio/Assembly/Singlet.pm"
"Bio-Assembly","Bio/Assembly/ContigAnalysis.pm"
"Bio-Assembly","Bio/Assembly/Scaffold.pm"
"Bio-Assembly","Bio/Assembly/Tools/ContigSpectrum.pm"
,"Bio/Symbol/DNAAlphabet.pm"
,"Bio/Symbol/README.Symbol"
,"Bio/Symbol/Symbol.pm"
,"Bio/Symbol/AlphabetI.pm"
,"Bio/Symbol/ProteinAlphabet.pm"
,"Bio/Symbol/Alphabet.pm"
,"Bio/Symbol/SymbolI.pm"
,"Bio/MapIO.pm"
,"Bio/WebAgent.pm"
"Bio-Annotation","Bio/Annotation/SimpleValue.pm"
"Bio-Annotation","Bio/Annotation/Relation.pm"
"Bio-Annotation","Bio/Annotation/OntologyTerm.pm"
"Bio-Annotation","Bio/Annotation/TypeManager.pm"
"Bio-Annotation","Bio/Annotation/Tree.pm"
"Bio-Annotation","Bio/Annotation/AnnotationFactory.pm"
"Bio-Annotation","Bio/Annotation/Collection.pm"
"Bio-Annotation","Bio/Annotation/StructuredValue.pm"
"Bio-Annotation","Bio/Annotation/Reference.pm"
"Bio-Annotation","Bio/Annotation/TagTree.pm"
"Bio-Annotation","Bio/Annotation/DBLink.pm"
"Bio-Annotation","Bio/Annotation/Target.pm"
"Bio-Annotation","Bio/Annotation/Comment.pm"
"Bio-Phenotype","Bio/Phenotype/PhenotypeI.pm"
"Bio-Phenotype","Bio/Phenotype/MeSH/Twig.pm"
"Bio-Phenotype","Bio/Phenotype/MeSH/Term.pm"
"Bio-Phenotype","Bio/Phenotype/Phenotype.pm"
"Bio-Phenotype","Bio/Phenotype/Measure.pm"
"Bio-Phenotype","Bio/Phenotype/Correlate.pm"
"Bio-Phenotype","Bio/Phenotype/OMIM/MiniMIMentry.pm"
"Bio-Phenotype","Bio/Phenotype/OMIM/OMIMentry.pm"
"Bio-Phenotype","Bio/Phenotype/OMIM/OMIMparser.pm"
"Bio-Phenotype","Bio/Phenotype/OMIM/OMIMentryAllelicVariant.pm"
"Bio-Index","Bio/Index/BlastTable.pm"
"Bio-Index","Bio/Index/Qual.pm"
"Bio-HMMER","Bio/Index/Hmmer.pm"
"Bio-Index","Bio/Index/Swissprot.pm"
"Bio-Index","Bio/Index/Fasta.pm"
"Bio-Index","Bio/Index/SwissPfam.pm"
"Bio-Index","Bio/Index/AbstractSeq.pm"
"Bio-Index","Bio/Index/Stockholm.pm"
"Bio-Index","Bio/Index/EMBL.pm"
"Bio-Index","Bio/Index/Blast.pm"
"Bio-Index","Bio/Index/Abstract.pm"
"Bio-Index","Bio/Index/GenBank.pm"
"Bio-Index","Bio/Index/Fastq.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/TreeFactoryMulti.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/TreeFactoryX.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/TreeFactory.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/FactoryX.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/RandomFactory.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/GraphViz.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/muVector.pm"
"Bio-PhyloNetwork","Bio/PhyloNetwork/Factory.pm"
"Bio-Matrix","Bio/Matrix/IO/mlagan.pm"
"Bio-Matrix","Bio/Matrix/IO/phylip.pm"
"Bio-Matrix","Bio/Matrix/IO/scoring.pm"
"Bio-Matrix","Bio/Matrix/Generic.pm"
"Bio-Matrix","Bio/Matrix/Scoring.pm"
"Bio-Matrix","Bio/Matrix/IO.pm"
"Bio-Matrix","Bio/Matrix/PhylipDist.pm"
"Bio-Matrix","Bio/Matrix/Mlagan.pm"
"Bio-Matrix","Bio/Matrix/MatrixI.pm"
"Bio-Matrix","Bio/Matrix/PSM/IO/mast.pm"
"Bio-Matrix","Bio/Matrix/PSM/IO/psiblast.pm"
"Bio-Matrix","Bio/Matrix/PSM/IO/masta.pm"
"Bio-Matrix","Bio/Matrix/PSM/IO/meme.pm"
"Bio-Matrix","Bio/Matrix/PSM/IO/transfac.pm"
"Bio-Matrix","Bio/Matrix/PSM/SiteMatrixI.pm"
"Bio-Matrix","Bio/Matrix/PSM/SiteMatrix.pm"
"Bio-Matrix","Bio/Matrix/PSM/ProtMatrix.pm"
"Bio-Matrix","Bio/Matrix/PSM/IO.pm"
"Bio-Matrix","Bio/Matrix/PSM/ProtPsm.pm"
"Bio-Matrix","Bio/Matrix/PSM/InstanceSiteI.pm"
"Bio-Matrix","Bio/Matrix/PSM/Psm.pm"
"Bio-Matrix","Bio/Matrix/PSM/PsmHeaderI.pm"
"Bio-Matrix","Bio/Matrix/PSM/InstanceSite.pm"
"Bio-Matrix","Bio/Matrix/PSM/PsmHeader.pm"
"Bio-Matrix","Bio/Matrix/PSM/PsmI.pm"
,"Bio/RangeI.pm"
"Bio-Search","Bio/SearchIO/axt.pm"
"Bio-Search","Bio/SearchIO/rnamotif.pm"
"Bio-Search","Bio/SearchIO/SearchResultEventBuilder.pm"
"Bio-HMMER","Bio/SearchIO/hmmer_pull.pm"
"Bio-Search","Bio/SearchIO/fasta.pm"
"Bio-Search","Bio/SearchIO/SearchWriterI.pm"
"Bio-Search","Bio/SearchIO/psl.pm"
"Bio-Search","Bio/SearchIO/erpin.pm"
"Bio-Search","Bio/SearchIO/IteratedSearchResultEventBuilder.pm"
"Bio-Search","Bio/SearchIO/cross_match.pm"
"Bio-Search","Bio/SearchIO/EventHandlerI.pm"
"Bio-Search","Bio/SearchIO/exonerate.pm"
"Bio-Search","Bio/SearchIO/gmap_f9.pm"
"Bio-HMMER","Bio/SearchIO/hmmer3.pm"
"Bio-Search","Bio/SearchIO/infernal.pm"
"Bio-Search","Bio/SearchIO/Writer/GbrowseGFF.pm"
"Bio-Search","Bio/SearchIO/Writer/HSPTableWriter.pm"
"Bio-Search","Bio/SearchIO/Writer/BSMLResultWriter.pm"
"Bio-Search","Bio/SearchIO/Writer/HitTableWriter.pm"
"Bio-Search","Bio/SearchIO/Writer/HTMLResultWriter.pm"
"Bio-Search","Bio/SearchIO/Writer/TextResultWriter.pm"
"Bio-Search","Bio/SearchIO/Writer/ResultTableWriter.pm"
"Bio-Search","Bio/SearchIO/megablast.pm"
"Bio-Search","Bio/SearchIO/blastxml.pm"
"Bio-Search","Bio/SearchIO/FastHitEventBuilder.pm"
"Bio-Search","Bio/SearchIO/wise.pm"
"Bio-Search","Bio/SearchIO/blast_pull.pm"
"Bio-Search","Bio/SearchIO/waba.pm"
"Bio-HMMER","Bio/SearchIO/hmmer.pm"
"Bio-Search","Bio/SearchIO/blasttable.pm"
"Bio-Search","Bio/SearchIO/blast.pm"
"Bio-Search","Bio/SearchIO/sim4.pm"
"Bio-Search","Bio/SearchIO/XML/BlastHandler.pm"
"Bio-Search","Bio/SearchIO/XML/PsiBlastHandler.pm"
"Bio-FeatureIO","Bio/FeatureIO/gtf.pm"
"Bio-FeatureIO","Bio/FeatureIO/interpro.pm"
"Bio-FeatureIO","Bio/FeatureIO/bed.pm"
"Bio-FeatureIO","Bio/FeatureIO/gff.pm"
"Bio-FeatureIO","Bio/FeatureIO/vecscreen_simple.pm"
"Bio-FeatureIO","Bio/FeatureIO/ptt.pm"
,"Bio/ParameterBaseI.pm"
"Bio-Search","Bio/Search/Tiling/MapTiling.pm"
"Bio-Search","Bio/Search/Tiling/MapTileUtils.pm"
"Bio-Search","Bio/Search/Tiling/TilingI.pm"
"Bio-Search","Bio/Search/SearchUtils.pm"
"Bio-Search","Bio/Search/GenericDatabase.pm"
"Bio-Search","Bio/Search/Iteration/GenericIteration.pm"
"Bio-Search","Bio/Search/Iteration/IterationI.pm"
"Bio-Search","Bio/Search/BlastStatistics.pm"
"Bio-Search","Bio/Search/Processor.pm"
"Bio-Search","Bio/Search/Hit/BlastHit.pm"
"Bio-Search","Bio/Search/Hit/GenericHit.pm"
"Bio-Search","Bio/Search/Hit/Fasta.pm"
"Bio-Search","Bio/Search/Hit/ModelHit.pm"
"Bio-Search","Bio/Search/Hit/HitI.pm"
"Bio-HMMER","Bio/Search/Hit/hmmer3Hit.pm"
"Bio-HMMER","Bio/Search/Hit/HMMERHit.pm"
"Bio-Search","Bio/Search/Hit/PsiBlastHit.pm"
"Bio-Search","Bio/Search/Hit/BlastPullHit.pm"
"Bio-Search","Bio/Search/Hit/HitFactory.pm"
"Bio-Search","Bio/Search/Hit/PullHitI.pm"
"Bio-Search","Bio/Search/Hit/HmmpfamHit.pm"
"Bio-Search","Bio/Search/BlastUtils.pm"
"Bio-Search","Bio/Search/GenericStatistics.pm"
"Bio-Search","Bio/Search/StatisticsI.pm"
"Bio-Search","Bio/Search/HSP/GenericHSP.pm"
"Bio-Search","Bio/Search/HSP/HSPI.pm"
"Bio-Search","Bio/Search/HSP/FastaHSP.pm"
"Bio-Search","Bio/Search/HSP/BlastHSP.pm"
"Bio-Search","Bio/Search/HSP/WABAHSP.pm"
"Bio-Search","Bio/Search/HSP/HmmpfamHSP.pm"
"Bio-Search","Bio/Search/HSP/BlastPullHSP.pm"
"Bio-Search","Bio/Search/HSP/ModelHSP.pm"
"Bio-Search","Bio/Search/HSP/HSPFactory.pm"
"Bio-HMMER","Bio/Search/HSP/HMMERHSP.pm"
"Bio-HMMER","Bio/Search/HSP/hmmer3HSP.pm"
"Bio-Search","Bio/Search/HSP/PSLHSP.pm"
"Bio-Search","Bio/Search/HSP/PsiBlastHSP.pm"
"Bio-Search","Bio/Search/HSP/PullHSPI.pm"
"Bio-HMMER","Bio/Search/Result/hmmer3Result.pm"
"Bio-Search","Bio/Search/Result/BlastResult.pm"
"Bio-Search","Bio/Search/Result/ResultFactory.pm"
"Bio-Search","Bio/Search/Result/CrossMatchResult.pm"
"Bio-Search","Bio/Search/Result/WABAResult.pm"
"Bio-Search","Bio/Search/Result/ResultI.pm"
"Bio-Search","Bio/Search/Result/BlastPullResult.pm"
"Bio-Search","Bio/Search/Result/HmmpfamResult.pm"
"Bio-HMMER","Bio/Search/Result/HMMERResult.pm"
"Bio-Search","Bio/Search/Result/GenericResult.pm"
"Bio-Search","Bio/Search/Result/PullResultI.pm"
"Bio-Search","Bio/Search/DatabaseI.pm"
,"Bio/PrimarySeqI.pm"
,"Bio/FeatureHolderI.pm"
,"Bio/AnnotationI.pm"
"Bio-Biblio","Bio/Biblio/Organisation.pm"
"Bio-Biblio","Bio/Biblio/Ref.pm"
"Bio-Biblio","Bio/Biblio/PubmedArticle.pm"
"Bio-Biblio","Bio/Biblio/IO/pubmed2ref.pm"
"Bio-Biblio","Bio/Biblio/IO/pubmedxml.pm"
"Bio-Biblio","Bio/Biblio/IO/medline2ref.pm"
"Bio-Biblio","Bio/Biblio/IO/medlinexml.pm"
"Bio-Biblio","Bio/Biblio/WebResource.pm"
"Bio-Biblio","Bio/Biblio/TechReport.pm"
"Bio-Biblio","Bio/Biblio/Service.pm"
"Bio-Biblio","Bio/Biblio/Journal.pm"
"Bio-Biblio","Bio/Biblio/MedlineArticle.pm"
"Bio-Biblio","Bio/Biblio/Patent.pm"
"Bio-Biblio","Bio/Biblio/IO.pm"
"Bio-Biblio","Bio/Biblio/JournalArticle.pm"
"Bio-Biblio","Bio/Biblio/BookArticle.pm"
"Bio-Biblio","Bio/Biblio/Thesis.pm"
"Bio-Biblio","Bio/Biblio/MedlineJournalArticle.pm"
"Bio-Biblio","Bio/Biblio/Article.pm"
"Bio-Biblio","Bio/Biblio/Book.pm"
"Bio-Biblio","Bio/Biblio/MedlineBookArticle.pm"
"Bio-Biblio","Bio/Biblio/Proceeding.pm"
"Bio-Biblio","Bio/Biblio/Person.pm"
"Bio-Biblio","Bio/Biblio/PubmedJournalArticle.pm"
"Bio-Biblio","Bio/Biblio/Provider.pm"
"Bio-Biblio","Bio/Biblio/BiblioBase.pm"
"Bio-Biblio","Bio/Biblio/PubmedBookArticle.pm"
"Bio-Biblio","Bio/Biblio/MedlineBook.pm"
"Bio-Biblio","Bio/Biblio/MedlineJournal.pm"
"Bio-DB","Bio/DB/HIV.pm"
,"Bio/DB/RandomAccessI.pm"
,"Bio/DB/Taxonomy/flatfile.pm"
,"Bio/DB/Taxonomy/entrez.pm"
,"Bio/DB/Taxonomy/list.pm"
,"Bio/DB/QueryI.pm"
,"Bio/DB/SwissProt.pm"
,"Bio/DB/EntrezGene.pm"
,"Bio/DB/Registry.pm"
,"Bio/DB/MeSH.pm"
,"Bio/DB/HIV/HIVQueryHelper.pm"
,"Bio/DB/HIV/HIVAnnotProcessor.pm"
,"Bio/DB/HIV/lanl-schema.xml"
,"Bio/DB/CUTG.pm"
,"Bio/DB/Flat.pm"
,"Bio/DB/InMemoryCache.pm"
,"Bio/DB/BiblioI.pm"
,"Bio/DB/LocationI.pm"
,"Bio/DB/Qual.pm"
,"Bio/DB/WebDBSeqI.pm"
,"Bio/DB/TFBS.pm"
,"Bio/DB/Fasta.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/NormalizedFeature.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Segment.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/NormalizedFeatureI.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/berkeleydb.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/LoadHelper.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/GFF2Loader.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/Loader.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/DBI/Iterator.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/DBI/mysql.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/DBI/SQLite.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/DBI/Pg.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/berkeleydb3.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/GFF3Loader.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/FeatureFileLoader.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/bdb.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store/memory.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/Store.pm"
"Bio-DB-SeqFeature","Bio/DB/SeqFeature/NormalizedTableFeatureI.pm"
"AcePerl","Bio/DB/Ace.pm"
,"Bio/DB/GenPept.pm"
,"Bio/DB/SeqHound.pm"
,"Bio/DB/Flat/BDB.pm"
,"Bio/DB/Flat/BinarySearch.pm"
,"Bio/DB/Flat/BDB/swiss.pm"
,"Bio/DB/Flat/BDB/fasta.pm"
,"Bio/DB/Flat/BDB/genbank.pm"
,"Bio/DB/Flat/BDB/embl.pm"
,"Bio/DB/SeqVersion.pm"
,"Bio/DB/NCBIHelper.pm"
,"Bio/DB/BioFetch.pm"
,"Bio/DB/DBFetch.pm"
"Bio-DB-GFF","Bio/DB/GFF/Homol.pm"
"Bio-DB-GFF","Bio/DB/GFF/Feature.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/berkeleydb.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/memory/feature_serializer.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/memory/iterator.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/berkeleydb/iterator.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/ace.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/mysqlopt.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/mysqlcmap.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/caching_handle.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/mysql.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/pg.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/oracleace.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/pg_fts.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/oracle.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/mysqlace.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/dbi/iterator.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/biofetch_oracle.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/memory.pm"
"Bio-DB-GFF","Bio/DB/GFF/Adaptor/biofetch.pm"
"Bio-DB-GFF","Bio/DB/GFF/Typename.pm"
"Bio-DB-GFF","Bio/DB/GFF/Segment.pm"
"Bio-DB-GFF","Bio/DB/GFF/Util/Binning.pm"
"Bio-DB-GFF","Bio/DB/GFF/Util/Rearrange.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_sanger22pseudo.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/coding.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_twinscan.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/none.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/clone.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/gene.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/transcript.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/processed_transcript.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_acembly.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/orf.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/alignment.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_ensgene.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_refgene.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_genscan.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_softberry.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_sanger22.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/ucsc_unigene.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/match.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator/so_transcript.pm"
"Bio-DB-GFF","Bio/DB/GFF/RelSegment.pm"
"Bio-DB-GFF","Bio/DB/GFF/Aggregator.pm"
"Bio-DB-GFF","Bio/DB/GFF/Featname.pm"
,"Bio/DB/UpdateableSeqI.pm"
,"Bio/DB/GenericWebAgent.pm"
,"Bio/DB/SeqFeature.pm"
,"Bio/DB/RefSeq.pm"
,"Bio/DB/Failover.pm"
,"Bio/DB/EMBL.pm"
,"Bio/DB/Query/WebQuery.pm"
,"Bio/DB/Query/GenBank.pm"
,"Bio/DB/Query/HIVQuery.pm"
,"Bio/DB/Expression/geo.pm"
,"Bio/DB/Biblio/eutils.pm"
,"Bio/DB/Biblio/soap.pm"
,"Bio/DB/Biblio/biofetch.pm"
,"Bio/DB/SeqI.pm"
,"Bio/DB/FileCache.pm"
,"Bio/DB/GenBank.pm"
,"Bio/DB/TFBS/transfac_pro.pm"
,"Bio/DB/Universal.pm"
,"Bio/DB/Expression.pm"
,"Bio/DB/EUtilities.pm"
,"Bio/DB/SeqVersion/gi.pm"
,"Bio/DB/ReferenceI.pm"
,"Bio/DB/Taxonomy.pm"
,"Bio/DB/GFF.pm"
,"Bio/SeqI.pm"
"Bio-PopGen","Bio/PopGen/HtSNP.pm"
"Bio-PopGen","Bio/PopGen/TagHaplotype.pm"
"Bio-PopGen","Bio/PopGen/GenotypeI.pm"
"Bio-PopGen","Bio/PopGen/PopStats.pm"
"Bio-PopGen","Bio/PopGen/IO/phase.pm"
"Bio-PopGen","Bio/PopGen/IO/hapmap.pm"
"Bio-PopGen","Bio/PopGen/IO/csv.pm"
"Bio-PopGen","Bio/PopGen/IO/prettybase.pm"
"Bio-PopGen","Bio/PopGen/PopulationI.pm"
"Bio-PopGen","Bio/PopGen/IO.pm"
"Bio-PopGen","Bio/PopGen/IndividualI.pm"
"Bio-PopGen","Bio/PopGen/Statistics.pm"
"Bio-PopGen","Bio/PopGen/Population.pm"
"Bio-PopGen","Bio/PopGen/Individual.pm"
"Bio-PopGen","Bio/PopGen/MarkerI.pm"
"Bio-PopGen","Bio/PopGen/Simulation/Coalescent.pm"
"Bio-PopGen","Bio/PopGen/Simulation/GeneticDrift.pm"
"Bio-PopGen","Bio/PopGen/Utilities.pm"
"Bio-PopGen","Bio/PopGen/Marker.pm"
"Bio-PopGen","Bio/PopGen/Genotype.pm"
"Bio-Cluster","Bio/ClusterIO.pm"
"Bio-Align","Bio/AlignIO.pm"
"Bio-Biblio","Bio/Biblio.pm"
"Bio-FeatureIO","Bio/FeatureIO.pm"
"Bio-Location","Bio/Location/Split.pm"
"Bio-Location","Bio/Location/NarrowestCoordPolicy.pm"
"Bio-Location","Bio/Location/FuzzyLocationI.pm"
"Bio-Location","Bio/Location/SplitLocationI.pm"
"Bio-Location","Bio/Location/Simple.pm"
"Bio-Location","Bio/Location/CoordinatePolicyI.pm"
"Bio-Location","Bio/Location/WidestCoordPolicy.pm"
"Bio-Location","Bio/Location/Atomic.pm"
"Bio-Location","Bio/Location/Fuzzy.pm"
"Bio-Location","Bio/Location/AvWithinCoordPolicy.pm"
,"Bio/LocatableSeq.pm"
"Bio-LiveSeq","Bio/LiveSeq/DNA.pm"
"Bio-LiveSeq","Bio/LiveSeq/Exon.pm"
"Bio-LiveSeq","Bio/LiveSeq/IO/README"
"Bio-LiveSeq","Bio/LiveSeq/IO/Loader.pm"
"Bio-LiveSeq","Bio/LiveSeq/IO/BioPerl.pm"
"Bio-LiveSeq","Bio/LiveSeq/Gene.pm"
"Bio-LiveSeq","Bio/LiveSeq/Range.pm"
"Bio-LiveSeq","Bio/LiveSeq/Transcript.pm"
"Bio-LiveSeq","Bio/LiveSeq/Mutation.pm"
"Bio-LiveSeq","Bio/LiveSeq/Chain.pm"
"Bio-LiveSeq","Bio/LiveSeq/ChainI.pm"
"Bio-LiveSeq","Bio/LiveSeq/AARange.pm"
"Bio-LiveSeq","Bio/LiveSeq/Repeat_Unit.pm"
"Bio-LiveSeq","Bio/LiveSeq/Repeat_Region.pm"
"Bio-LiveSeq","Bio/LiveSeq/Mutator.pm"
"Bio-LiveSeq","Bio/LiveSeq/Prim_Transcript.pm"
"Bio-LiveSeq","Bio/LiveSeq/SeqI.pm"
"Bio-LiveSeq","Bio/LiveSeq/Intron.pm"
"Bio-LiveSeq","Bio/LiveSeq/Translation.pm"
,"Bio/Taxon.pm"
"Bio-Ontology","Bio/OntologyIO/obo.pm"
"Bio-Ontology","Bio/OntologyIO/InterProParser.pm"
"Bio-Ontology","Bio/OntologyIO/Handlers/InterProHandler.pm"
"Bio-Ontology","Bio/OntologyIO/Handlers/InterPro_BioSQL_Handler.pm"
"Bio-Ontology","Bio/OntologyIO/Handlers/BaseSAXHandler.pm"
"Bio-Ontology","Bio/OntologyIO/soflat.pm"
"Bio-Ontology","Bio/OntologyIO/dagflat.pm"
"Bio-Ontology","Bio/OntologyIO/simplehierarchy.pm"
"Bio-Ontology","Bio/OntologyIO/goflat.pm"
,"Bio/Event/EventHandlerI.pm"
,"Bio/Event/EventGeneratorI.pm"
,"Bio/Root/Test/Warn.pm"
,"Bio/Root/Root.pm"
,"Bio/Root/Exception.pm"
,"Bio/Root/Version.pm"
,"Bio/Root/RootI.pm"
,"Bio/Root/IO.pm"
,"Bio/Root/Build.pm"
,"Bio/Root/HTTPget.pm"
,"Bio/Root/Utilities.pm"
,"Bio/Root/Test.pm"
,"Bio/Root/Storable.pm"
,"Bio/SimpleAnalysisI.pm"
,"Bio/SearchDist.pm"
,"Bio/SeqAnalysisParserI.pm"
,"Bio/DasI.pm"
"Bio-SeqIO","Bio/SeqIO/lasergene.pm"
"Bio-SeqIO","Bio/SeqIO/bsml_sax.pm"
"Bio-SeqIO","Bio/SeqIO/agave.pm"
"Bio-SeqIO","Bio/SeqIO/interpro.pm"
"Bio-SeqIO","Bio/SeqIO/gbxml.pm"
"Bio-SeqIO","Bio/SeqIO/swiss.pm"
"Bio-SeqIO","Bio/SeqIO/fasta.pm"
"Bio-SeqIO","Bio/SeqIO/chadoxml.pm"
"Bio-SeqIO","Bio/SeqIO/MultiFile.pm"
"Bio-SeqIO","Bio/SeqIO/kegg.pm"
"Bio-SeqIO","Bio/SeqIO/bsml.pm"
"Bio-SeqIO","Bio/SeqIO/game.pm"
"Bio-SeqIO","Bio/SeqIO/tinyseq/tinyseqHandler.pm"
"Bio-SeqIO","Bio/SeqIO/game/gameHandler.pm"
"Bio-SeqIO","Bio/SeqIO/game/featHandler.pm"
"Bio-SeqIO","Bio/SeqIO/game/gameWriter.pm"
"Bio-SeqIO","Bio/SeqIO/game/gameSubs.pm"
"Bio-SeqIO","Bio/SeqIO/game/seqHandler.pm"
"Bio-SeqIO","Bio/SeqIO/FTHelper.pm"
"Bio-SeqIO","Bio/SeqIO/ace.pm"
"Bio-SeqIO","Bio/SeqIO/tinyseq.pm"
"Bio-SeqIO","Bio/SeqIO/entrezgene.pm"
"Bio-SeqIO","Bio/SeqIO/qual.pm"
"Bio-SeqIO","Bio/SeqIO/tigrxml.pm"
"Bio-SeqIO","Bio/SeqIO/largefasta.pm"
"Bio-SeqIO","Bio/SeqIO/tab.pm"
"Bio-SeqIO","Bio/SeqIO/nexml.pm"
"Bio-SeqIO","Bio/SeqIO/ctf.pm"
"Bio-SeqIO","Bio/SeqIO/genbank.pm"
"Bio-SeqIO","Bio/SeqIO/msout.pm"
"Bio-SeqIO","Bio/SeqIO/excel.pm"
"Bio-SeqIO","Bio/SeqIO/gbdriver.pm"
"Bio-SeqIO","Bio/SeqIO/ztr.pm"
"Bio-SeqIO","Bio/SeqIO/pln.pm"
"Bio-SeqIO","Bio/SeqIO/embl.pm"
"Bio-SeqIO","Bio/SeqIO/fastq.pm"
"Bio-SeqIO","Bio/SeqIO/pir.pm"
"Bio-SeqIO","Bio/SeqIO/raw.pm"
"Bio-SeqIO","Bio/SeqIO/asciitree.pm"
"Bio-SeqIO","Bio/SeqIO/seqxml.pm"
"Bio-SeqIO","Bio/SeqIO/chaos.pm"
"Bio-SeqIO","Bio/SeqIO/gcg.pm"
"Bio-SeqIO","Bio/SeqIO/tigr.pm"
"Bio-SeqIO","Bio/SeqIO/scf.pm"
"Bio-SeqIO","Bio/SeqIO/embldriver.pm"
"Bio-SeqIO","Bio/SeqIO/table.pm"
"Bio-SeqIO","Bio/SeqIO/locuslink.pm"
"Bio-SeqIO","Bio/SeqIO/chaosxml.pm"
"Bio-SeqIO","Bio/SeqIO/exp.pm"
"Bio-SeqIO","Bio/SeqIO/abi.pm"
"Bio-SeqIO","Bio/SeqIO/Handler/GenericRichSeqHandler.pm"
"Bio-SeqIO","Bio/SeqIO/strider.pm"
"Bio-SeqIO","Bio/SeqIO/alf.pm"
"Bio-SeqIO","Bio/SeqIO/swissdriver.pm"
"Bio-SeqIO","Bio/SeqIO/phd.pm"
"Bio-SeqIO","Bio/SeqIO/metafasta.pm"
"Bio-SeqIO","Bio/SeqIO/flybase_chadoxml.pm"
"Bio-Taxonomy","Bio/Taxonomy.pm"
,"Bio/Tools/CodonTable.pm"
,"Bio/Tools/Prints.pm"
,"Bio/Tools/Eponine.pm"
,"Bio/Tools/Glimmer.pm"
"Bio-HMMER","Bio/Tools/HMMER/Results.pm"
"Bio-HMMER","Bio/Tools/HMMER/Set.pm"
"Bio-HMMER","Bio/Tools/HMMER/Domain.pm"
,"Bio/Tools/Lucy.pm"
,"Bio/Tools/SeqWords.pm"
,"Bio/Tools/GuessSeqFormat.pm"
,"Bio/Tools/TargetP.pm"
,"Bio/Tools/SeqPattern.pm"
,"Bio/Tools/pSW.pm"
,"Bio/Tools/Hmmpfam.pm"
,"Bio/Tools/Genewise.pm"
,"Bio/Tools/QRNA.pm"
,"Bio/Tools/Profile.pm"
,"Bio/Tools/Primer/Feature.pm"
,"Bio/Tools/Primer/AssessorI.pm"
,"Bio/Tools/Primer/Pair.pm"
,"Bio/Tools/Primer/Assessor/Base.pm"
,"Bio/Tools/Run/ParametersI.pm"
,"Bio/Tools/Run/RemoteBlast.pm"
,"Bio/Tools/Run/WrapperBase/CommandExts.pm"
,"Bio/Tools/Run/README"
"Bio-HMMER","Bio/Tools/Run/hmmer3.pm"
,"Bio/Tools/Run/WrapperBase.pm"
,"Bio/Tools/Run/GenericParameters.pm"
,"Bio/Tools/Run/StandAloneWUBlast.pm"
,"Bio/Tools/Run/StandAloneBlast.pm"
,"Bio/Tools/Run/StandAloneNCBIBlast.pm"
,"Bio/Tools/Signalp/ExtendedSignalp.pm"
,"Bio/Tools/SiRNA/Ruleset/tuschl.pm"
,"Bio/Tools/SiRNA/Ruleset/saigo.pm"
,"Bio/Tools/Genscan.pm"
,"Bio/Tools/Genemark.pm"
,"Bio/Tools/OddCodes.pm"
,"Bio/Tools/ipcress.pm"
,"Bio/Tools/Est2Genome.pm"
,"Bio/Tools/Sim4/Results.pm"
,"Bio/Tools/Sim4/Exon.pm"
,"Bio/Tools/SeqStats.pm"
,"Bio/Tools/ERPIN.pm"
,"Bio/Tools/RNAMotif.pm"
,"Bio/Tools/dpAlign.pm"
,"Bio/Tools/Alignment/Trim.pm"
,"Bio/Tools/Alignment/Consed.pm"
,"Bio/Tools/Primer3.pm"
,"Bio/Tools/AnalysisResult.pm"
,"Bio/Tools/Match.pm"
,"Bio/Tools/Phylo/Molphy/Result.pm"
,"Bio/Tools/Phylo/Gumby.pm"
,"Bio/Tools/Phylo/PAML/Codeml.pm"
,"Bio/Tools/Phylo/PAML/ModelResult.pm"
,"Bio/Tools/Phylo/PAML/Result.pm"
,"Bio/Tools/Phylo/Phylip/ProtDist.pm"
,"Bio/Tools/Phylo/Molphy.pm"
,"Bio/Tools/Phylo/Gerp.pm"
,"Bio/Tools/Phylo/PAML.pm"
,"Bio/Tools/Gel.pm"
,"Bio/Tools/Genomewise.pm"
,"Bio/Tools/Signalp.pm"
,"Bio/Tools/Infernal.pm"
,"Bio/Tools/EUtilities/Summary/DocSum.pm"
,"Bio/Tools/EUtilities/Summary/ItemContainerI.pm"
,"Bio/Tools/EUtilities/Summary/Item.pm"
,"Bio/Tools/EUtilities/Info/LinkInfo.pm"
,"Bio/Tools/EUtilities/Info/FieldInfo.pm"
,"Bio/Tools/EUtilities/HistoryI.pm"
,"Bio/Tools/EUtilities/Info.pm"
,"Bio/Tools/EUtilities/EUtilParameters.pm"
,"Bio/Tools/EUtilities/EUtilDataI.pm"
,"Bio/Tools/EUtilities/History.pm"
,"Bio/Tools/EUtilities/Cookie.pm"
,"Bio/Tools/EUtilities/Link.pm"
,"Bio/Tools/EUtilities/Summary.pm"
,"Bio/Tools/EUtilities/Query/GlobalQuery.pm"
,"Bio/Tools/EUtilities/Query.pm"
,"Bio/Tools/EUtilities/Link/LinkSet.pm"
,"Bio/Tools/EUtilities/Link/UrlLink.pm"
,"Bio/Tools/FootPrinter.pm"
,"Bio/Tools/TandemRepeatsFinder.pm"
,"Bio/Tools/Analysis/SimpleAnalysisBase.pm"
,"Bio/Tools/Analysis/DNA/ESEfinder.pm"
,"Bio/Tools/Analysis/Protein/Domcut.pm"
,"Bio/Tools/Analysis/Protein/Mitoprot.pm"
,"Bio/Tools/Analysis/Protein/Sopma.pm"
,"Bio/Tools/Analysis/Protein/NetPhos.pm"
,"Bio/Tools/Analysis/Protein/Scansite.pm"
,"Bio/Tools/Analysis/Protein/ELM.pm"
,"Bio/Tools/Analysis/Protein/GOR4.pm"
,"Bio/Tools/Analysis/Protein/HNN.pm"
,"Bio/Tools/AlignFactory.pm"
,"Bio/Tools/Promoterwise.pm"
,"Bio/Tools/Geneid.pm"
,"Bio/Tools/Sigcleave.pm"
,"Bio/Tools/IUPAC.pm"
,"Bio/Tools/SiRNA.pm"
,"Bio/Tools/pICalculator.pm"
,"Bio/Tools/SeqPattern/Backtranslate.pm"
,"Bio/Tools/Blat.pm"
,"Bio/Tools/ECnumber.pm"
,"Bio/Tools/tRNAscanSE.pm"
,"Bio/Tools/Fgenesh.pm"
,"Bio/Tools/Prediction/Exon.pm"
,"Bio/Tools/Prediction/Gene.pm"
,"Bio/Tools/Pseudowise.pm"
,"Bio/Tools/RepeatMasker.pm"
,"Bio/Tools/Tmhmm.pm"
,"Bio/Tools/Grail.pm"
,"Bio/Tools/MZEF.pm"
,"Bio/Tools/Protparam.pm"
,"Bio/Tools/isPcr.pm"
,"Bio/Tools/EPCR.pm"
,"Bio/Tools/Coil.pm"
,"Bio/Tools/Spidey/Results.pm"
,"Bio/Tools/Spidey/Exon.pm"
,"Bio/Tools/EMBOSS/Palindrome.pm"
,"Bio/Tools/EUtilities.pm"
,"Bio/Tools/Seg.pm"
,"Bio/Tools/PrositeScan.pm"
,"Bio/Tools/RandomDistFunctions.pm"
,"Bio/Tools/ESTScan.pm"
,"Bio/Tools/GFF.pm"
,"Bio/SeqUtils.pm"
,"BioPerl.pm"
,"BUGS"
,"Build.PL"
,"Changes"
,"DEPENDENCIES"
,"DEPRECATED"
,"doc/README"
,"doc/makedoc.PL"
,"doc/Deobfuscator/excluded_modules.txt"
,"doc/Deobfuscator/t/00.load.t"
,"doc/Deobfuscator/t/pod.t"
,"doc/Deobfuscator/LICENSE"
,"doc/Deobfuscator/META.yml"
,"doc/Deobfuscator/README"
,"doc/Deobfuscator/bin/deob_index.pl"
,"doc/Deobfuscator/Makefile.PL"
,"doc/Deobfuscator/Build.PL"
,"doc/Deobfuscator/lib/Deobfuscator.pm"
,"doc/Deobfuscator/cgi-bin/deob_detail.cgi"
,"doc/Deobfuscator/cgi-bin/deob_interface.cgi"
,"doc/Deobfuscator/cgi-bin/deob_help.html"
,"doc/Deobfuscator/cgi-bin/deob_flowchart.png"
,"doc/Deobfuscator/Changes"
,"doc/Deobfuscator/MANIFEST"
,"examples/bioperl.pl"
,"examples/subsequence.cgi"
,"examples/searchio/resultwriter.pl"
,"examples/searchio/waba2gff3.pl"
,"examples/searchio/custom_writer.pl"
,"examples/searchio/psiblast_iterations.pl"
,"examples/searchio/psiblast_features.pl"
,"examples/searchio/waba2gff.pl"
,"examples/searchio/htmlwriter.pl"
,"examples/searchio/blast_example.pl"
,"examples/searchio/hitwriter.pl"
,"examples/searchio/hspwriter.pl"
,"examples/searchio/rawwriter.pl"
,"examples/root/exceptions3.pl"
,"examples/root/README"
,"examples/root/exceptions1.pl"
,"examples/root/exceptions2.pl"
,"examples/root/lib/TestInterface.pm"
,"examples/root/lib/TestObject.pm"
,"examples/root/exceptions4.pl"
,"examples/sirna/rnai_finder.cgi"
,"examples/sirna/TAG"
,"examples/cluster/dbsnp.pl"
,"examples/quality/svgtrace.pl"
,"examples/longorf.pl"
,"examples/revcom_dir.pl"
,"examples/align/simplealign.pl"
,"examples/align/clustalw.pl"
,"examples/align/aligntutorial.pl"
,"examples/align/align_on_codons.pl"
,"examples/biblio/biblio-eutils-example.pl"
,"examples/biblio/biblio_soap.pl"
,"examples/biblio/biblio-soap-example.pl"
,"examples/generate_random_seq.pl"
,"examples/rev_and_trans.pl"
,"examples/liveseq/change_gene.pl"
,"examples/structure/structure-io.pl"
,"examples/tools/run_genscan.pl"
,"examples/tools/extract_genes.pl"
,"examples/tools/standaloneblast.pl"
,"examples/tools/gff2ps.pl"
,"examples/tools/parse_codeml.pl"
,"examples/tools/gb_to_gff.pl"
,"examples/tools/seq_pattern.pl"
,"examples/tools/run_primer3.pl"
,"examples/tools/psw.pl"
,"examples/tools/reverse-translate.pl"
,"examples/contributed/nmrpdb_parse.pl"
,"examples/contributed/rebase2list.pl"
,"examples/contributed/prosite2perl.pl"
,"examples/Bio-DB-GFF/load_ucsc.pl"
,"examples/make_primers.pl"
,"examples/db/get_seqs.pl"
,"examples/db/use_registry.pl"
,"examples/db/getGenBank.pl"
,"examples/db/est_tissue_query.pl"
,"examples/db/gb2features.pl"
,"examples/db/rfetch.pl"
,"examples/db/dbfetch"
,"examples/tk/hitdisplay.pl"
,"examples/tk/gsequence.pl"
,"examples/popgen/parse_calc_stats.pl"
,"examples/tree/paup2phylip.pl"
,"ide/bioperl-mode/dist/bioperl-mode-xemacs.tar.md5"
,"ide/bioperl-mode/dist/bioperl-mode-xemacs.tar"
,"ide/bioperl-mode/dist/SKIP"
,"ide/bioperl-mode/dist/bioperl-mode.tar"
,"ide/bioperl-mode/dist/package-me"
,"ide/bioperl-mode/dist/bioperl-mode.tar.md5"
,"ide/bioperl-mode/dist/Changes"
,"ide/bioperl-mode/site-lisp/bioperl-mode.el"
,"ide/bioperl-mode/site-lisp/pod.el"
,"ide/bioperl-mode/site-lisp/bioperl-skel.el"
,"ide/bioperl-mode/site-lisp/bioperl-init.el"
,"ide/bioperl-mode/README"
,"ide/bioperl-mode/etc/images/bpmode-tool-dis.xpm"
,"ide/bioperl-mode/etc/images/bpmode-tool.xpm"
,"ide/bioperl.komodo"
,"ide/bioperl.lisp"
,"INSTALL"
,"INSTALL.SKIP"
,"INSTALL.WIN"
,"LICENSE"
,"maintenance/modules.pl"
,"maintenance/pod.pl"
,"maintenance/split"
,"maintenance/deprecated.pl"
,"maintenance/version.pl"
,"maintenance/authors.pl"
,"maintenance/perltidy.conf"
,"maintenance/README"
,"maintenance/symlink_script.pl"
,"maintenance/dependencies.pl"
,"maintenance/all_files"
,"maintenance/ncbi_blast_switches.pl"
,"maintenance/cvs2cl_by_file.pl"
,"maintenance/check_URLs.pl"
,"maintenance/check_NAME.pl"
,"maintenance/module_usage.pl"
,"MANIFEST"
,"MANIFEST.SKIP"
,"models/map_proposal.txt"
,"models/popgen.dia"
,"models/biblio.dia"
,"models/bioperl.dia"
,"models/README"
,"models/maps_and_markers.dia"
,"models/bio_liveseq_variation.dia"
,"models/bio_restriction.dia"
,"models/bio_map.dia"
,"models/coordinatemapper.dia"
,"models/population_proposal.txt"
,"README"
,"scripts/searchio/parse_hmmsearch.PLS"
,"scripts/searchio/filter_search.PLS"
"Bio-HMMER","scripts/searchio/hmmer_to_table.PLS"
,"scripts/searchio/README"
,"scripts/searchio/fastam9_to_table.PLS"
,"scripts/searchio/search2table.PLS"
,"scripts/searchio/TAG"
,"scripts/utilities/search2tribe.PLS"
,"scripts/utilities/bp_mrtrans.PLS"
,"scripts/utilities/mutate.PLS"
,"scripts/utilities/dbsplit.PLS"
,"scripts/utilities/remote_blast.PLS"
,"scripts/utilities/README"
,"scripts/utilities/mask_by_search.PLS"
,"scripts/utilities/bp_sreformat.PLS"
,"scripts/utilities/revtrans-motif.PLS"
,"scripts/utilities/seq_length.PLS"
,"scripts/utilities/search2alnblocks.PLS"
,"scripts/utilities/bp_nrdb.PLS"
,"scripts/utilities/search2BSML.PLS"
,"scripts/utilities/pairwise_kaks.PLS"
,"scripts/utilities/TAG"
,"scripts/utilities/search2gff.PLS"
,"scripts/utilities/download_query_genbank.PLS"
,"scripts/taxa/classify_hits_kingdom.PLS"
,"scripts/taxa/taxonomy2tree.PLS"
,"scripts/taxa/query_entrez_taxa.PLS"
,"scripts/taxa/taxid4species.PLS"
,"scripts/taxa/local_taxonomydb_query.PLS"
,"scripts/taxa/TAG"
,"scripts/index/bp_index.PLS"
,"scripts/index/bp_seqret.PLS"
,"scripts/index/bp_fetch.PLS"
,"scripts/index/TAG"
,"scripts/README"
,"scripts/das/das_server.pl"
,"scripts/das/README"
,"scripts/das/TAG"
,"scripts/biblio/biblio.PLS"
,"scripts/biblio/TAG"
,"scripts/bioperl_netinstall.pl"
"Bio-DB-GFF","scripts/Bio-DB-GFF/generate_histogram.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/genbank2gff3.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/process_sgd.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/genbank2gff.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/process_gadfly.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/meta_gff.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/README"
"Bio-DB-GFF","scripts/Bio-DB-GFF/process_wormbase.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/fast_load_gff.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/load_gff.PLS"
"Bio-DB-GFF","scripts/Bio-DB-GFF/bulk_load_gff.PLS"
,"scripts/DB/biofetch_genbank_proxy.PLS"
,"scripts/DB/biogetseq.PLS"
,"scripts/DB/flanks.PLS"
,"scripts/DB/bioflat_index.PLS"
,"scripts/DB/TAG"
,"scripts/popgen/composite_LD.PLS"
,"scripts/popgen/heterogeneity_test.PLS"
,"scripts/Bio-DB-EUtilities/einfo.PLS"
,"scripts/tree/blast2tree.PLS"
,"scripts/tree/tree2pag.PLS"
,"scripts/tree/nexus2nh.PLS"
,"scripts/tree/TAG"
,"scripts/seqstats/aacomp.PLS"
,"scripts/seqstats/oligo_count.PLS"
,"scripts/seqstats/gccalc.PLS"
,"scripts/seqstats/chaos_plot.PLS"
,"scripts/seqstats/TAG"
,"scripts/Bio-SeqFeature-Store/bp_seqfeature_delete.PLS"
,"scripts/Bio-SeqFeature-Store/bp_seqfeature_gff3.PLS"
,"scripts/Bio-SeqFeature-Store/bp_seqfeature_load.PLS"
,"scripts/DB-HIV/hivq.PLS"
,"scripts/seq/split_seq.PLS"
,"scripts/seq/seqconvert.PLS"
,"scripts/seq/unflatten_seq.PLS"
,"scripts/seq/translate_seq.PLS"
,"scripts/seq/make_mrna_protein.PLS"
,"scripts/seq/extract_feature_seq.PLS"
,"scripts/seq/seqretsplit.PLS"
,"scripts/seq/TAG"
,"t/Draw/Pictogram.t"
,"t/Perl.t"
,"t/Map/MicrosatelliteMarker.t"
,"t/Map/Map.t"
,"t/Map/Linkage.t"
,"t/Map/MapIO.t"
,"t/Map/Physical.t"
,"t/Map/Cyto.t"
,"t/TaxonTree.t"
,"t/Restriction/Analysis.t"
,"t/Restriction/Analysis-refac.t"
,"t/Restriction/Gel.t"
,"t/Restriction/IO.t"
,"t/SearchDist.t"
,"t/Symbol.t"
,"t/Coordinate/CoordinateGraph.t"
,"t/Coordinate/CoordinateMapper.t"
,"t/Coordinate/GeneCoordinateMapper.t"
,"t/Tree/TreeStatistics.t"
,"t/Tree/TreeIO/newick.t"
,"t/Tree/TreeIO/svggraph.t"
,"t/Tree/TreeIO/nhx.t"
,"t/Tree/TreeIO/nexus.t"
,"t/Tree/TreeIO/lintree.t"
,"t/Tree/TreeIO/tabtree.t"
,"t/Tree/TreeIO/nexml.t"
,"t/Tree/TreeIO/phyloxml.t"
,"t/Tree/Node.t"
,"t/Tree/Compatible.t"
,"t/Tree/TreeIO.t"
,"t/Tree/PhyloNetwork/RandomFactory.t"
,"t/Tree/PhyloNetwork/TreeFactory.t"
,"t/Tree/PhyloNetwork/GraphViz.t"
,"t/Tree/PhyloNetwork/Factory.t"
,"t/Tree/PhyloNetwork/PhyloNetwork.t"
,"t/Tree/PhyloNetwork/MuVector.t"
,"t/Tree/RandomTreeFactory.t"
,"t/Tree/Tree.t"
,"t/Structure/IO.t"
,"t/Structure/Structure.t"
,"t/SeqFeature/SeqFeaturePrimer.t"
,"t/SeqFeature/SeqFeatCollection.t"
,"t/SeqFeature/SeqFeatAnnotated.t"
,"t/SeqFeature/LocationFactory.t"
,"t/SeqFeature/Location.t"
,"t/SeqFeature/FeatureIO.t"
,"t/SeqFeature/RangeI.t"
,"t/SeqFeature/SeqFeature.t"
,"t/SeqFeature/Unflattener2.t"
,"t/SeqFeature/Primer.t"
,"t/SeqFeature/Range.t"
,"t/SeqFeature/SeqAnalysisParser.t"
,"t/SeqFeature/Clone.t"
,"t/SeqFeature/Unflattener.t"
,"t/Variation/RNAChange.t"
,"t/Variation/DNAMutation.t"
,"t/Variation/Variation_IO.t"
,"t/Variation/Allele.t"
,"t/Variation/SeqDiff.t"
,"t/Variation/AAReverseMutate.t"
,"t/Variation/SNP.t"
,"t/Variation/AAChange.t"
,"t/SeqIO.t"
,"t/AlignIO/phylip.t"
,"t/AlignIO/pfam.t"
,"t/AlignIO/psi.t"
,"t/AlignIO/mega.t"
,"t/AlignIO/largemultifasta.t"
,"t/AlignIO/fasta.t"
,"t/AlignIO/mase.t"
,"t/AlignIO/AlignIO.t"
,"t/AlignIO/arp.t"
,"t/AlignIO/po.t"
,"t/AlignIO/prodom.t"
,"t/AlignIO/xmfa.t"
,"t/AlignIO/nexus.t"
,"t/AlignIO/bl2seq.t"
,"t/AlignIO/selex.t"
,"t/AlignIO/nexml.t"
,"t/AlignIO/stockholm.t"
,"t/AlignIO/clustalw.t"
,"t/AlignIO/metafasta.t"
,"t/AlignIO/emboss.t"
,"t/AlignIO/maf.t"
,"t/AlignIO/msf.t"
,"t/AlignIO/meme.t"
,"t/Align/Utilities.t"
,"t/Align/AlignUtil.t"
,"t/Align/Graphics.t"
,"t/Align/AlignStats.t"
,"t/Align/TreeBuild.t"
,"t/Align/SimpleAlign.t"
,"t/ClusterIO/SequenceFamily.t"
,"t/ClusterIO/unigene.t"
,"t/ClusterIO/ClusterIO.t"
,"t/Seq/LargePSeq.t"
,"t/Seq/PrimarySeq.t"
,"t/Seq/LocatableSeq.t"
,"t/Seq/DBLink.t"
,"t/Seq/LargeLocatableSeq.t"
,"t/Seq/Seq.t"
,"t/Seq/WithQuality.t"
,"t/Seq/EncodedSeq.t"
,"t/Seq/PrimedSeq.t"
,"t/Seq/Quality.t"
,"t/Seq/MetaSeq.t"
,"t/Seq/PrimaryQual.t"
,"t/Ontology/OntologyStore.t"
,"t/Ontology/IO/obo.t"
,"t/Ontology/IO/go.t"
,"t/Ontology/IO/interpro.t"
,"t/Ontology/GOterm.t"
,"t/Ontology/Relationship.t"
,"t/Ontology/Term.t"
,"t/Ontology/RelationshipType.t"
,"t/Ontology/Ontology.t"
,"t/Ontology/GraphAdaptor.t"
,"t/Ontology/OntologyEngine.t"
,"t/Assembly/IO/sam.t"
,"t/Assembly/IO/bowtie.t"
,"t/Assembly/ContigSpectrum.t"
,"t/Assembly/core.t"
,"t/Annotation/Annotation.t"
,"t/Annotation/AnnotationAdaptor.t"
,"t/Phenotype/OMIMentry.t"
,"t/Phenotype/Correlate.t"
,"t/Phenotype/Phenotype.t"
,"t/Phenotype/Measure.t"
,"t/Phenotype/OMIMparser.t"
,"t/Phenotype/MeSH.t"
,"t/Phenotype/MiniMIMentry.t"
,"t/Phenotype/OMIMentryAllelicVariant.t"
,"t/SeqTools/SeqPattern.t"
,"t/SeqTools/OddCodes.t"
,"t/SeqTools/SeqUtils.t"
,"t/SeqTools/CodonTable.t"
,"t/SeqTools/Backtranslate.t"
,"t/SeqTools/GuessSeqFormat.t"
,"t/SeqTools/SeqStats.t"
,"t/SeqTools/ECnumber.t"
,"t/SeqTools/SeqWords.t"
,"t/SeqEvolution.t"
,"t/Matrix/IO/psm.t"
,"t/Matrix/IO/masta.t"
,"t/Matrix/ProtPsm.t"
,"t/Matrix/InstanceSite.t"
,"t/Matrix/Matrix.t"
,"t/Matrix/ProtMatrix.t"
,"t/Matrix/SiteMatrix.t"
,"t/Alphabet.t"
,"t/SearchIO/gmap_f9.t"
,"t/SearchIO/SearchIO.t"
,"t/SearchIO/fasta.t"
,"t/SearchIO/sim4.t"
,"t/SearchIO/psl.t"
,"t/SearchIO/cross_match.t"
,"t/SearchIO/waba.t"
,"t/SearchIO/erpin.t"
"Bio-HMMER","t/SearchIO/hmmer.t"
,"t/SearchIO/Tiling.t"
,"t/SearchIO/exonerate.t"
,"t/SearchIO/blast_pull.t"
,"t/SearchIO/Writer/GbrowseGFF.t"
,"t/SearchIO/Writer/HTMLWriter.t"
,"t/SearchIO/Writer/HSPTableWriter.t"
,"t/SearchIO/Writer/HitTableWriter.t"
,"t/SearchIO/wise.t"
,"t/SearchIO/rnamotif.t"
,"t/SearchIO/CigarString.t"
,"t/SearchIO/blastxml.t"
,"t/SearchIO/SimilarityPair.t"
,"t/SearchIO/blasttable.t"
,"t/SearchIO/blast.t"
,"t/SearchIO/infernal.t"
"Bio-HMMER","t/SearchIO/hmmer3.t"
"Bio-HMMER","t/SearchIO/hmmer_pull.t"
,"t/SearchIO/megablast.t"
,"t/Species.t"
,"t/Biblio/Biblio.t"
,"t/Biblio/References.t"
,"t/Biblio/biofetch.t"
,"t/Biblio/eutils.t"
,"t/nexml.t"
,"t/lib/Error.pm"
,"t/lib/Test/Harness.pm"
,"t/lib/Test/Harness/Iterator.pm"
,"t/lib/Test/Harness/Results.pm"
,"t/lib/Test/Harness/Util.pm"
,"t/lib/Test/Harness/Point.pm"
,"t/lib/Test/Harness/Assert.pm"
,"t/lib/Test/Harness/Straps.pm"
,"t/lib/Test/Harness/TAP.pod"
,"t/lib/Test/Builder.pm"
,"t/lib/Test/Exception.pm"
,"t/lib/Test/More.pm"
,"t/lib/Test/Simple.pm"
,"t/lib/Test/Builder/Module.pm"
,"t/lib/Test/Builder/Tester/Color.pm"
,"t/lib/Test/Builder/Tester.pm"
,"t/lib/Test/Warn.pm"
,"t/lib/Test/Tutorial.pod"
,"t/lib/Sub/Uplevel.pm"
,"t/lib/Tree/DAG_Node.pm"
,"t/lib/Array/Compare.pm"
,"t/PopGen/TagHaplotype.t"
,"t/PopGen/HtSNP.t"
,"t/PopGen/PopGen.t"
,"t/PopGen/Coalescent.t"
,"t/PopGen/PopGenSims.t"
,"t/PopGen/MK.t"
,"t/PodSyntax.t"
,"t/data/test_badlf.gcg"
,"t/data/cysprot1.FASTA"
,"t/data/U71225.gb.win"
,"t/data/contigspectrumtest.tigr"
,"t/data/worm_fam_2785.cdna"
,"t/data/traittree.nexus"
,"t/data/mixedmast.dat"
,"t/data/test.genbank"
,"t/data/testaln.selex"
,"t/data/test.waba"
,"t/data/U71225.gb"
,"t/data/no_FH.embl"
,"t/data/mus.bls.xml"
,"t/data/signalp.hmm.summary"
,"t/data/test.mase"
,"t/data/pictogram.fa"
,"t/data/hybrid1.gff3"
,"t/data/omim_genemap_test_nolinebreak"
,"t/data/barns-combined.nex"
,"t/data/blastp2215.blast"
,"t/data/protpars.phy"
,"t/data/ecolitst.noseqs.wublastp"
,"t/data/hmmpfam_cs.out"
,"t/data/02_mackerel_rdfa_2_cdao_lsid_taxrefs.xml"
,"t/data/2008.blasttable"
,"t/data/bug2901.fa"
,"t/data/compLD_test.prettybase"
,"t/data/tblastn.out"
,"t/data/alnfile.fasta"
,"t/data/char-interleave.nex"
,"t/data/pseudowise.out"
,"t/data/gmap_f9-multiple_results.txt"
,"t/data/yn00.mlc"
,"t/data/characters+trees.nexml.xml"
,"t/data/BOSS_DROME.FASTP_v35_04"
,"t/data/myco_sites.gff"
,"t/data/cysprot1b.hmmsearch"
,"t/data/bug2399.tblastn"
,"t/data/ecoli_domains.rps.xml"
,"t/data/test.fastq"
,"t/data/test.interpro-go.xml"
,"t/data/AF165282.gb"
,"t/data/primedseq.fa"
,"t/data/no-genes.genscan"
,"t/data/testaln.phylip"
,"t/data/bl2seq.bug940.out"
,"t/data/branchSite.mlc"
,"t/data/BK000016-tpa.gbk"
,"t/data/lucy.info"
,"t/data/sbay_c127.fas"
,"t/data/ecolitst.wublastp"
,"t/data/fgenesh.out"
,"t/data/503384.MEGABLAST.0"
,"t/data/HUMBETGLOA.fa"
,"t/data/aaml.mlc"
,"t/data/02_dogfish_no_taxrefs.xml"
,"t/data/roa1.dat"
,"t/data/crypto.sim4-0"
,"t/data/frac_problems2.blast"
,"t/data/ECAPAH02.embl"
,"t/data/acefile.singlets"
,"t/data/HUMBETGLOA.FASTA"
,"t/data/test.genbank.noseq"
,"t/data/mutations.dat"
,"t/data/baseml.pairwise"
,"t/data/Glimmer3.detail"
,"t/data/hs_owlmonkey.fasta"
,"t/data/cysprot1b.fa"
,"t/data/c200-vs-yeast.BLASTN"
,"t/data/map_hem/HEM12-HEM13.fa"
,"t/data/map_hem/HEM12-HEM14.fa"
,"t/data/map_hem/HEM3-HEM14.meme.txt"
,"t/data/map_hem/HEM2-HEM13.fa"
,"t/data/map_hem/HEM4-HEM14.meme.txt"
,"t/data/map_hem/HEM14.ups.fa_.revcom"
,"t/data/map_hem/HEM2.ups.fa_.revcom"
,"t/data/map_hem/HEM14-HEM15.meme.txt"
,"t/data/map_hem/HEM3-HEM4.meme.txt"
,"t/data/map_hem/HEM13-HEM15.meme.txt"
,"t/data/map_hem/HEM1.ups.fa_"
,"t/data/map_hem/HEM15.ups.fa_.revcom"
,"t/data/map_hem/HEM1-HEM12.fa.revcom"
,"t/data/map_hem/HEM3-HEM15.fa"
,"t/data/map_hem/HEM12-HEM14.meme.txt"
,"t/data/map_hem/HEM4.ups.fa_.revcom"
,"t/data/map_hem/HEM1-HEM4.fa"
,"t/data/map_hem/HEM3-HEM12.meme.txt"
,"t/data/map_hem/HEM12-HEM15.fa"
,"t/data/map_hem/HEM3.ups.fa_.revcom"
,"t/data/map_hem/HEM2-HEM15.meme.txt"
,"t/data/map_hem/HEM4-HEM12.fa"
,"t/data/map_hem/HEM1-HEM4.meme.txt"
,"t/data/map_hem/HEM15.ups.fa_"
,"t/data/map_hem/HEM1-HEM2.meme.txt"
,"t/data/map_hem/HEM14-HEM15.fa"
,"t/data/map_hem/HEM2-HEM4.fa"
,"t/data/map_hem/HEM1.ups.fa_.revcom"
,"t/data/map_hem/HEM13.ups.fa_"
,"t/data/map_hem/HEM4-HEM13.fa"
,"t/data/map_hem/HEM2-HEM14.meme.txt"
,"t/data/map_hem/HEM4-HEM15.fa"
,"t/data/map_hem/HEM12-HEM15.meme.txt"
,"t/data/map_hem/HEM2-HEM12.fa"
,"t/data/map_hem/HEM4-HEM12.meme.txt"
,"t/data/map_hem/HEM1-HEM14.fa"
,"t/data/map_hem/HEM1-HEM2.fa.revcom"
,"t/data/map_hem/HEM1-HEM12.fa"
,"t/data/map_hem/HEM2-HEM3.fa"
,"t/data/map_hem/HEM2-HEM4.meme.txt"
,"t/data/map_hem/HEM1-HEM3.meme.txt"
,"t/data/map_hem/HEM3-HEM12.fa"
,"t/data/map_hem/HEM2-HEM3.meme.txt"
,"t/data/map_hem/HEM3-HEM15.meme.txt"
,"t/data/map_hem/HEM13-HEM15.fa"
,"t/data/map_hem/HEM1-HEM13.fa"
,"t/data/map_hem/HEM13-HEM14.meme.txt"
,"t/data/map_hem/HEM1-HEM12.meme.txt"
,"t/data/map_hem/HEM4.ups.fa_"
,"t/data/map_hem/HEM1-HEM2.fa"
,"t/data/map_hem/HEM3-HEM4.fa"
,"t/data/map_hem/HEM1-HEM14.meme.txt"
,"t/data/map_hem/HEM1-HEM15.fa"
,"t/data/map_hem/HEM2.ups.fa_"
,"t/data/map_hem/HEM2-HEM15.fa"
,"t/data/map_hem/HEM13.ups.fa_.revcom"
,"t/data/map_hem/HEM1-HEM3.fa"
,"t/data/map_hem/HEM3-HEM14.fa"
,"t/data/map_hem/HEM2-HEM12.meme.txt"
,"t/data/map_hem/yeast.nc.1.freq"
,"t/data/map_hem/HEM4-HEM13.meme.txt"
,"t/data/map_hem/HEM4-HEM14.fa"
,"t/data/map_hem/HEM2-HEM13.meme.txt"
,"t/data/map_hem/HEM1-HEM13.meme.txt"
,"t/data/map_hem/HEM14.ups.fa_"
,"t/data/map_hem/HEM4-HEM15.meme.txt"
,"t/data/map_hem/HEM3.ups.fa_"
,"t/data/map_hem/HEM12.ups.fa_.revcom"
,"t/data/map_hem/HEM13-HEM14.fa"
,"t/data/map_hem/HEM3-HEM13.meme.txt"
,"t/data/map_hem/HEM2-HEM14.fa"
,"t/data/map_hem/HEM1-HEM15.meme.txt"
,"t/data/map_hem/HEM12.ups.fa_"
,"t/data/map_hem/HEM3-HEM13.fa"
,"t/data/map_hem/HEM12-HEM13.meme.txt"
,"t/data/04_labeled_ancestors.xml"
,"t/data/testaln.metafasta"
,"t/data/codeml_lysozyme/lysozymeSmall.ctl"
,"t/data/codeml_lysozyme/lysozymeSmall.trees"
,"t/data/codeml_lysozyme/mlc"
,"t/data/codeml_lysozyme/2NG.tt"
,"t/data/codeml_lysozyme/2NG.dS"
,"t/data/codeml_lysozyme/4fold.nuc"
,"t/data/codeml_lysozyme/lnf"
,"t/data/codeml_lysozyme/rst1"
,"t/data/codeml_lysozyme/rst"
,"t/data/codeml_lysozyme/lysozymeSmall.txt"
,"t/data/codeml_lysozyme/2NG.dN"
,"t/data/codeml_lysozyme/rub"
,"t/data/transfac.dat"
,"t/data/test_singlets.cns.fastq"
,"t/data/exonerate.output.works"
,"t/data/ZABJ4EA7014.CH878695.1.blast.txt"
,"t/data/omim_text_test"
,"t/data/SwissProt.dat"
,"t/data/biofpc.fpc"
,"t/data/bug2982.embl"
,"t/data/phylipdist.out"
,"t/data/repeatmasker.fa.out"
,"t/data/AE003528_ecoli.bls"
,"t/data/multi.phd"
,"t/data/fastq/tricky.fastq"
,"t/data/fastq/error_double_seq.fastq"
,"t/data/fastq/error_qual_del.fastq"
,"t/data/fastq/error_double_qual.fastq"
,"t/data/fastq/error_trunc_at_plus.fastq"
,"t/data/fastq/test3_illumina.fastq"
,"t/data/fastq/error_long_qual.fastq"
,"t/data/fastq/error_qual_null.fastq"
,"t/data/fastq/example.fasta"
,"t/data/fastq/evil_wrapping.fastq"
,"t/data/fastq/error_trunc_at_qual.fastq"
,"t/data/fastq/sanger_93.fastq"
,"t/data/fastq/error_qual_vtab.fastq"
,"t/data/fastq/sanger_faked.fastq"
,"t/data/fastq/error_diff_ids.fastq"
,"t/data/fastq/test2_solexa.fastq"
,"t/data/fastq/error_trunc_in_qual.fastq"
,"t/data/fastq/solexa_example.fastq"
,"t/data/fastq/error_qual_escape.fastq"
,"t/data/fastq/error_no_qual.fastq"
,"t/data/fastq/error_trunc_in_title.fastq"
,"t/data/fastq/solexa_faked.fastq"
,"t/data/fastq/error_trunc_in_plus.fastq"
,"t/data/fastq/error_qual_unit_sep.fastq"
,"t/data/fastq/error_trunc_in_seq.fastq"
,"t/data/fastq/error_qual_tab.fastq"
,"t/data/fastq/error_spaces.fastq"
,"t/data/fastq/test1_sanger.fastq"
,"t/data/fastq/example.qual"
,"t/data/fastq/wrapping_issues.fastq"
,"t/data/fastq/illumina_faked.fastq"
,"t/data/fastq/error_tabs.fastq"
,"t/data/fastq/error_qual_space.fastq"
,"t/data/fastq/bug2335.fastq"
,"t/data/fastq/error_short_qual.fastq"
,"t/data/fastq/error_trunc_at_seq.fastq"
,"t/data/fastq/example.fastq"
,"t/data/genomic-seq.mzef"
,"t/data/mapmaker.txt"
,"t/data/hmmsearch3.out"
,"t/data/HUMBETGLOA.grailexp"
,"t/data/interpro_ebi.xml"
,"t/data/T7.aln"
,"t/data/BEL16-LTR_AG.embl"
,"t/data/revcomp_mrna.gb"
,"t/data/test.locuslink"
,"t/data/mutations.old.xml"
,"t/data/tmp.fst"
,"t/data/test2.infernal"
,"t/data/hmmpfam.out"
,"t/data/bl2seq.blastn.rev"
,"t/data/footprinter.out"
,"t/data/component.ontology.test2"
,"t/data/bug3021.gmap"
,"t/data/503384.MEGABLAST.2"
,"t/data/characters.nexml.old.xml"
,"t/data/test.ref.fas"
,"t/data/dna1.fa"
,"t/data/test.metafasta"
,"t/data/neighbor.dist"
,"t/data/test.txt"
,"t/data/lysozyme6.protml"
,"t/data/knownGene.gff3"
,"t/data/tree_nonewline.nexus"
,"t/data/test.exp"
,"t/data/ecoli-trna-qrna.out"
,"t/data/pfam_tests.stk"
,"t/data/plague_yeast.bls.xml"
,"t/data/test_clear_range.fastq"
,"t/data/PAM250"
,"t/data/U83300.bsml"
,"t/data/BAB68554.gb"
,"t/data/test.interpro"
,"t/data/BC000007.gbk"
,"t/data/quoted-strings2.nex"
,"t/data/blast_plus.blastp"
,"t/data/cysprot1a.fa"
,"t/data/genewise.out"
,"t/data/singleNSsite.mlc"
,"t/data/humts1.pal"
,"t/data/testaln.aln"
,"t/data/testaln.pfam"
,"t/data/spidey.noalignment"
,"t/data/AF305198.gb"
,"t/data/1.bed"
,"t/data/interpro.xml"
,"t/data/directives.gff3"
,"t/data/sim4.for.rev"
,"t/data/dq519393.gb"
,"t/data/tandem_repeats_finder_no_desc.dat"
,"t/data/assembly_with_singlets.ace"
,"t/data/nei_gojobori_test.aln"
,"t/data/cysprot1.fa"
,"t/data/tricky.wublast"
,"t/data/crab.nj"
,"t/data/test.tigrxml"
,"t/data/msout_infile1"
,"t/data/bug3086.embl"
,"t/data/testaln.xmfa"
,"t/data/phi.out"
,"t/data/radical-whitespace.nex"
,"t/data/targetp.out"
,"t/data/purine_v081.infernal"
,"t/data/sim4.for.for"
,"t/data/sofa.ontology"
,"t/data/long-names.nex"
,"t/data/baseml.usertree"
,"t/data/testaln.stockholm"
,"t/data/spaces.nex"
,"t/data/contig-by-hand.wublastp"
,"t/data/test.gcgblast"
,"t/data/ENr111.mfa.example.elems"
,"t/data/testaln.msf"
,"t/data/cysprot.needle"
,"t/data/X98338_Adh-mRNA.gb"
,"t/data/amino.fa"
,"t/data/GlimmerM.out"
,"t/data/polymorphism.dat"
,"t/data/dbfa/3.fa"
,"t/data/dbfa/2.fa"
,"t/data/dbfa/7.fa"
,"t/data/dbfa/6.fa"
,"t/data/dbfa/4.fa"
,"t/data/dbfa/5.fa"
,"t/data/dbfa/1.fa"
,"t/data/03_bootstraps.xml"
,"t/data/cds-266.fas"
,"t/data/quoted-strings1.nex"
,"t/data/newblast.xml"
,"t/data/stress_test_medline.xml"
,"t/data/hemoglobinA.meg"
,"t/data/testaln.list"
,"t/data/yeast.tRNAscanSE"
,"t/data/masta.dat"
,"t/data/BN000066-tpa.embl"
,"t/data/exonerate.output.dontwork"
,"t/data/test.swiss"
,"t/data/P39765.gb"
,"t/data/HUMBETGLOA.mzef"
,"t/data/primer3_outfile.txt"
,"t/data/popgen_saureus.dat"
,"t/data/dnaEbsub_ecoli.wutblastn"
,"t/data/test2.raw"
,"t/data/mini-AE001405.gb"
,"t/data/multiseq.bls"
,"t/data/P35527.gb"
,"t/data/M12730.gb"
,"t/data/Genscan.FastA"
,"t/data/characters.nexml.xml"
,"t/data/bug2391.megablast"
,"t/data/genomic-seq.genscan"
,"t/data/test.pln"
,"t/data/test_singlets.maq"
,"t/data/testaln.arp"
,"t/data/tandem_repeats_finder.dat"
,"t/data/Treebase-chlamy-dna.nex"
,"t/data/MSGEFTUA.gb"
,"t/data/crypto.sim4-3"
,"t/data/27-contig_Newbler.ace"
,"t/data/biodbgff/test.gff3"
,"t/data/biodbgff/test.gff"
,"t/data/sbay_c545-yeast.BLASTZ.PSL"
,"t/data/multifa.seq.qual"
,"t/data/pre_rel9.swiss"
,"t/data/frac_problems.blast"
,"t/data/cysprot1b.newick"
,"t/data/bug2120.phd"
,"t/data/seqxml.xml"
,"t/data/Bird_Ovomucoids.nex"
,"t/data/O_sat.wgs"
,"t/data/LittleChrY.dbsnp.xml"
,"t/data/CG11099.fasaln"
,"t/data/signalp.positive.out"
,"t/data/SPAN_Family8a.nex"
,"t/data/testdata.crossmatch"
,"t/data/catalase-webblast.BLASTP"
,"t/data/test.gcg"
,"t/data/rebase.withrefm"
,"t/data/unigene.data"
,"t/data/bug2473.fasta"
,"t/data/blat.psLayout3"
,"t/data/intrablock-comment.nex"
,"t/data/match.output"
,"t/data/dnaE-bsub.fa"
,"t/data/hmmscan.out"
,"t/data/testaln.mase"
,"t/data/longnames.dnd"
,"t/data/ecolitst.fa"
,"t/data/gf-s71.needle"
,"t/data/D12555.gbk"
,"t/data/msout_infile2.gz"
,"t/data/mutations.xml"
,"t/data/seqfile.pir"
,"t/data/test.maq"
,"t/data/phyloxml_examples.xml"
,"t/data/02_dogfish_rdfa_tdwg_lsid_taxrefs.xml"
,"t/data/01_basic.xml"
,"t/data/AF032047.gbk"
,"t/data/mini-align.aln"
,"t/data/sprintf.rnamotif"
,"t/data/bootstrap.tre"
,"t/data/dcr1_sp.WUBLASTP"
,"t/data/testaln.fastq"
,"t/data/prints.out"
,"t/data/consed_project/edit_dir/test_project.fasta.screen"
,"t/data/consed_project/edit_dir/test_project_to_alu.cross"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.problems"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.ace.2"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.contigs.qual"
,"t/data/consed_project/edit_dir/test_project.fasta"
,"t/data/consed_project/edit_dir/test_project.phrap.out"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.problems.qual"
,"t/data/consed_project/edit_dir/test_projectNewChromats.fof"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.qual"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.singlets"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.log"
,"t/data/consed_project/edit_dir/test_project.fasta.log"
,"t/data/consed_project/edit_dir/test_project.newtags"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.ace.1"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.contigs"
,"t/data/consed_project/edit_dir/test_project.screen.out"
,"t/data/consed_project/edit_dir/test_project.contigs"
,"t/data/consed_project/edit_dir/test_project.fasta.screen.view"
,"t/data/consed_project/phd_dir/ML4924R.phd.1"
,"t/data/consed_project/phd_dir/ML4947F.phd.1"
,"t/data/consed_project/phd_dir/ML4924F.phd.1"
,"t/data/consed_project/phd_dir/ML4922R.phd.1"
,"t/data/factor7.embl"
,"t/data/D10483.gbk"
,"t/data/omim_genemap_test"
,"t/data/Mcjanrna_rdbII.gbk"
,"t/data/no_hsps.blastp"
,"t/data/LOAD_Ccd1.dnd"
,"t/data/glimmer3-fragment.detail"
,"t/data/cysprot.msf"
,"t/data/rpsblast.bls"
,"t/data/AY095303S1.gbk"
,"t/data/spidey.test1"
,"t/data/test.xls"
,"t/data/mpath.ontology.test"
,"t/data/msout_infile2"
,"t/data/test.lasergene"
,"t/data/test.pir"
,"t/data/seg.out"
,"t/data/cysprot1b.msf"
,"t/data/multi_1.fa"
,"t/data/mapmaker.out"
,"t/data/testaln.psi"
,"t/data/a_thaliana.blastn"
,"t/data/urease.tre.nexus"
,"t/data/compLD_missingtest.prettybase"
,"t/data/bl2seq.out"
,"t/data/CG2865.fasaln"
,"t/data/Glimmer3.predict"
,"t/data/promoterwise.out"
,"t/data/signalp.short"
,"t/data/testaln.nexus"
,"t/data/test.meme2"
,"t/data/short.blx"
,"t/data/ay149291.gb"
,"t/data/traits.tab"
,"t/data/AAC12660.fa"
,"t/data/testaln.po"
,"t/data/genomewise.out"
,"t/data/DQ018368.gb"
,"t/data/tandem_repeats_finder.noresults"
,"t/data/test.infernal"
,"t/data/test.pfam"
,"t/data/meme.dat"
,"t/data/codeml43.mlc"
,"t/data/rfam_tests.stk"
,"t/data/megablast_output.paracel_btk"
,"t/data/ay007676.gb"
,"t/data/no_semicolon.newick"
,"t/data/chad100.scf"
,"t/data/sim4.rev"
,"t/data/radical-whitespace_02.nex"
,"t/data/phipsi.out"
,"t/data/crab.dat.cn"
,"t/data/cysprot.tblastn"
,"t/data/test.embl2sq"
,"t/data/humor.maf"
,"t/data/blast_no_hit_desc.txt"
,"t/data/sv40_small.xml"
,"t/data/hs_est.est2genome"
,"t/data/ATF14F8.gbk"
,"t/data/example.phase"
,"t/data/component.ontology.test"
,"t/data/hmmsearch.out"
,"t/data/P33897"
,"t/data/popgen_saureus.multidat"
,"t/data/sample_dataset.tigr"
,"t/data/test.nhx"
,"t/data/transfac_pro/reference.dat"
,"t/data/transfac_pro/matrix.dat"
,"t/data/transfac_pro/site.dat"
,"t/data/transfac_pro/gene.dat"
,"t/data/transfac_pro/fragment.dat"
,"t/data/transfac_pro/readme.txt"
,"t/data/transfac_pro/factor.dat"
,"t/data/swiss.dat"
,"t/data/psiblast.xml"
,"t/data/ctgdemo.fpc"
,"t/data/test.tab"
,"t/data/test.fasta"
,"t/data/AnnIX-v003.gbk"
,"t/data/headerless.psl"
,"t/data/alleles.fas"
,"t/data/hsinsulin.blastcl3.blastn"
,"t/data/signalp.nn.summary"
,"t/data/gmap_f9.txt"
,"t/data/rel9.swiss"
,"t/data/AE003644_Adh-genomic.gb"
,"t/data/NC_006346.gb"
,"t/data/rebase.itype2"
,"t/data/bug2862.pmr"
,"t/data/empty.bl2seq"
,"t/data/1A3I.pdb"
,"t/data/cys1_dicdi.water"
,"t/data/M0.mlc"
,"t/data/singlet_w_CT.ace"
,"t/data/ribosome-slippage.gb"
,"t/data/withrefm.906"
,"t/data/SPAN_Family7n.nex"
,"t/data/tab1part.mif"
,"t/data/lucy.stderr"
,"t/data/AB077698.gb"
,"t/data/new_blastn.txt"
,"t/data/bug1986.blastp"
,"t/data/AHCYL1.kegg"
,"t/data/02_mackerel_rdfa_tdwg_lsid_taxrefs.xml"
,"t/data/genomic-seq.epcr"
,"t/data/codeml_nan.mlc"
,"t/data/dnaE-bsub-prot.fa"
,"t/data/1ZZ19XR301R-Alignment.tblastn"
,"t/data/bug1986.blast2"
,"t/data/test.ace"
,"t/data/codeml.mlc"
,"t/data/genewise_output.paracel_btk"
,"t/data/test.embl"
,"t/data/tmhmm.out"
,"t/data/trna.strict.rnamotif"
,"t/data/dbqual/3.qual"
,"t/data/dbqual/2.qual"
,"t/data/dbqual/1.qual"
,"t/data/hs_owlmonkey.fas"
,"t/data/Glimmer2.out"
,"t/data/bl2seq.blastn"
,"t/data/mast.dat"
,"t/data/phylipdist-36.out"
,"t/data/hg16_chroms.gff"
,"t/data/signalp.negative.out"
,"t/data/insulin.water"
,"t/data/psiblastreport.out"
,"t/data/swisspfam.data"
,"t/data/AY763288.gb"
,"t/data/puzzle.tre"
,"t/data/test.meme"
,"t/data/dnaEbsub_ecoli.wublastx"
,"t/data/genomic-seq.fasta"
,"t/data/test.gcgfasta"
,"t/data/qualfile.qual"
,"t/data/qrna-relloc.out"
,"t/data/trees.nexml.xml"
,"t/data/testaln2.fasta"
,"t/data/test.game"
,"t/data/GlimmerHMM.out"
,"t/data/bug2246.blast"
,"t/data/Primate_mtDNA.nex"
,"t/data/codeml4.mlc"
,"t/data/Rab1.chaos-xml"
,"t/data/NC_001284.gbk"
,"t/data/dna2.fa"
,"t/data/protpars_longid.phy"
,"t/data/cds_sample.embl"
,"t/data/SPAN_Family4nl.nex"
,"t/data/testdbaccnums.out"
,"t/data/longnames.aln"
,"t/data/tab2part.mif"
,"t/data/gmap_f9-reverse-strand.txt"
,"t/data/test1.wublastp"
,"t/data/genemark-fragment.out"
,"t/data/Q8GBD3.swiss"
,"t/data/stress_test_pubmed.xml"
,"t/data/dnaEbsub_ecoli.wutblastx"
,"t/data/U71225.gb.unix"
,"t/data/test.raw"
,"t/data/codeml315.mlc"
,"t/data/cysprot_vs_gadfly.FASTA"
,"t/data/02_mackerel_dict_cdao_lsid_taxrefs.xml"
,"t/data/hs_owlmonkey.aln"
,"t/data/testdat.exonerate"
,"t/data/taxdump/names.dmp"
,"t/data/taxdump/nodes.dmp"
,"t/data/test.nh"
,"t/data/seqdatabase.ini"
,"t/data/GO.defs.test"
,"t/data/test.ztr"
,"t/data/HUMBETGLOA.grail"
,"t/data/EG352462.gbxml"
,"t/data/testfile.erpin"
,"t/data/multifa.seq"
,"t/data/eutils/elink_multidb_corr.xml"
,"t/data/eutils/elink_acheck_corr.xml"
,"t/data/eutils/elink_llinks_corr.xml"
,"t/data/eutils/elink_lcheck_corr.xml"
,"t/data/eutils/elink_ncheck.xml"
,"t/data/eutils/elink_dball.xml"
,"t/data/eutils/elink_multidb.xml"
,"t/data/eutils/elink_lcheck.xml"
,"t/data/eutils/elink_llinks.xml"
,"t/data/eutils/egquery.xml"
,"t/data/eutils/einfo.xml"
,"t/data/eutils/elink_scores.xml"
,"t/data/eutils/epost.xml"
,"t/data/eutils/espell.xml"
,"t/data/eutils/einfo_dbs.xml"
,"t/data/eutils/elink_nhist_corr.xml"
,"t/data/eutils/elink_neighbor_corr.xml"
,"t/data/eutils/esearch1.xml"
,"t/data/eutils/elink_acheck.xml"
,"t/data/eutils/elink_ncheck_corr.xml"
,"t/data/eutils/esummary1.xml"
,"t/data/eutils/elink_nhist.xml"
,"t/data/eutils/esearch2.xml"
,"t/data/eutils/elink_neighbor.xml"
,"t/data/eutils/esummary2.xml"
,"t/data/echofilter.wublastn"
,"t/data/expected.blast.out"
,"t/data/lucy.qual"
,"t/data/multiseq_tags.phd"
,"t/data/multi_blast.bls"
,"t/data/1A11.pdb"
,"t/data/cysprot.fa"
,"t/data/ssp160.embl.1"
,"t/data/acefile.ace.1"
,"t/data/in.fasta"
,"t/data/multiline-intrablock-comment.nex"
,"t/data/13-pilE-F.scf"
,"t/data/signalp.hmm.short"
,"t/data/trees.nexml.old.xml"
,"t/data/bl2seq.tblastx.out"
,"t/data/03_bootstraps_in_tag.xml"
,"t/data/02_mackerel_no_taxrefs.xml"
,"t/data/seqfeaturedb/test.gff3"
,"t/data/test 2.txt"
,"t/data/biofpc.cor"
,"t/data/pep-266.aln"
,"t/data/test.ctf"
,"t/data/test.bowtie"
,"t/data/test.bam"
,"t/data/U58726.gb"
"Bio-HMMER","t/data/L77119.hmmer"
,"t/data/testfuzzy.genbank"
,"t/data/hmmpfam_fake.out"
,"t/data/bug2869.tree"
,"t/data/sparsealn.needle"
,"t/data/interpro_short.xml"
,"t/data/little.largemultifasta"
,"t/data/primer3_output.txt"
,"t/data/regulation_test.obo"
,"t/data/hmmscan_multi_domain.out"
,"t/data/hybrid2.gff3"
,"t/data/roa1.swiss"
,"t/data/testaln.fasta"
,"t/data/test.tsv"
,"t/data/bug2453.maf"
,"t/data/8HVP.pdb"
,"t/data/exsignalp.out"
,"t/data/codeml_nssites.mlc"
,"t/data/msout_infile1.gz"
,"t/data/frac_problems3.blast"
,"t/data/test.tseq"
,"t/data/bug2937.fasta"
,"t/data/version2.scf"
,"t/data/NT_021877.gbk"
,"t/data/codeml43_nssites.mlc"
,"t/data/example.hap"
,"t/data/1BPT.pdb"
,"t/data/02_dogfish_rdfa_2_cdao_lsid_taxrefs.xml"
,"t/data/psi_xml.dat"
,"t/data/BLOSUM50"
,"t/data/multi_2.fa"
,"t/data/basic-ladder.nex"
,"t/data/primer3_infile.txt"
,"t/data/lucy.seq"
,"t/data/test.abi"
,"t/data/ecolitst.bls"
,"t/data/semicolon.newick"
,"t/data/polymorphism.old.xml"
,"t/data/NC_008536.gb"
,"t/data/registry/bdb/seqdatabase.ini"
,"t/data/registry/flat/seqdatabase.ini"
,"t/data/vecscreen_simple.test_output"
,"t/data/test1.blasttab3"
,"t/data/testaln.prodom"
,"t/data/testaln2.arp"
,"t/data/HUMBETGLOA.tblastx"
,"t/data/ar.embl"
,"t/data/NM_002254.gb"
,"t/data/genemark.out"
,"t/data/ecoli_domains.rpsblast"
,"t/data/crypto.sim4-4"
,"t/data/test.ptt"
,"t/data/basic-bush.nex"
,"t/data/char-matrix-spaces.nex"
,"t/data/5X_1895.FASTXY"
,"t/data/test.cns.fastq"
,"t/data/Kingdoms_DNA.nex"
,"t/data/test.phd"
,"t/data/Fang_2003.xml"
,"t/data/adh.mb_tree.nexus"
,"t/data/bug2982.gb"
,"t/data/UnaSmithHIV-both.nex"
,"t/data/seqs.fas"
,"t/data/c200-vs-yeast.BLASTN.m8"
,"t/data/entrezgene.dat"
,"t/data/cysprot.water"
,"t/data/05_ancestral_states.xml"
,"t/data/reference_ace.ace"
,"t/data/roa1.gbxml"
,"t/data/roa1_v2.dat"
,"t/data/hs_fugu.newick"
,"t/data/atp1.matrix"
,"t/data/calm.swiss"
,"t/data/tab3part.mif"
,"t/data/popstats.prettybase"
,"t/data/multi.blast.m8"
,"t/data/crab.njb"
,"t/data/brassica_ATH.WUBLASTN"
,"t/data/PX1CG.gb"
,"t/data/no_cds_example.gb"
,"t/data/lysozyme6.simple.protml"
,"t/data/bl2seq.blastx.out"
,"t/data/signalp.nn.short"
,"t/data/bug2942.blastx"
,"t/data/nucmatrix.txt"
,"t/data/mutations.old.dat"
,"t/data/roa1.genbank"
,"t/data/NC_006511-short.gbk"
,"t/data/MmCT"
,"t/data/dmel_2Lchunk.gb"
,"t/data/polymorphism.xml"
,"t/data/geneid_1.0.out"
,"t/data/so.obo"
,"t/data/aaml_pairwise.mlc"
,"t/data/ay116458.gb"
,"t/data/blast.report"
,"t/data/multi.blast.m9"
,"t/data/blosum62.bla"
,"t/data/sequencefamily.dat"
,"t/data/noninterleaved.phy"
,"t/data/GO.defs.test2"
,"t/data/signalp.summary"
,"t/data/cysprot1a.msf"
,"t/data/02_dogfish_dict_cdao_lsid_taxrefs.xml"
,"t/data/HUMBETGLOA.gff"
,"t/data/glimmer3-fragment.predict"
,"t/data/version3.scf"
,"t/LocalDB/DBQual.t"
,"t/LocalDB/Registry.t"
,"t/LocalDB/transfac_pro.t"
,"t/LocalDB/Index/Blast.t"
,"t/LocalDB/Index/BlastTable.t"
,"t/LocalDB/Index/Index.t"
,"t/LocalDB/Flat.t"
,"t/LocalDB/BioDBGFF.t"
,"t/LocalDB/SeqFeature.t"
,"t/LocalDB/DBFasta.t"
,"t/LiveSeq/Mutation.t"
,"t/LiveSeq/LiveSeq.t"
,"t/LiveSeq/Chain.t"
,"t/LiveSeq/Mutator.t"
,"t/Root/Utilities.t"
,"t/Root/HTTPget.t"
,"t/Root/Exception.t"
,"t/Root/Tempfile.t"
,"t/Root/RootI.t"
,"t/Root/Storable.t"
,"t/Root/RootIO.t"
,"t/RemoteDB/Taxonomy.t"
,"t/RemoteDB/HIV/HIVAnnotProcessor.t"
,"t/RemoteDB/HIV/HIVQuery.t"
,"t/RemoteDB/HIV/HIV.t"
,"t/RemoteDB/HIV/HIVQueryHelper.t"
,"t/RemoteDB/EMBL.t"
,"t/RemoteDB/GenPept.t"
,"t/RemoteDB/EUtilities.t"
,"t/RemoteDB/EntrezGene.t"
,"t/RemoteDB/BioFetch.t"
,"t/RemoteDB/SeqHound.t"
,"t/RemoteDB/CUTG.t"
,"t/RemoteDB/Query/GenBank.t"
,"t/RemoteDB/SeqVersion.t"
,"t/RemoteDB/MeSH.t"
,"t/RemoteDB/SwissProt.t"
,"t/RemoteDB/SeqRead_fail.t"
,"t/RemoteDB/RefSeq.t"
,"t/RemoteDB/GenBank.t"
,"t/SeqIO/agave.t"
,"t/SeqIO/tinyseq.t"
,"t/SeqIO/abi.t"
,"t/SeqIO/ctf.t"
,"t/SeqIO/Multiple_fasta.t"
,"t/SeqIO/chaos.t"
,"t/SeqIO/fasta.t"
,"t/SeqIO/fastq.t"
,"t/SeqIO/seqxml.t"
,"t/SeqIO/strider.t"
,"t/SeqIO/table.t"
,"t/SeqIO/genbank.t"
,"t/SeqIO/ztr.t"
,"t/SeqIO/MultiFile.t"
,"t/SeqIO/flybase_chadoxml.t"
,"t/SeqIO/pln.t"
,"t/SeqIO/tigrxml.t"
,"t/SeqIO/embl.t"
,"t/SeqIO/excel.t"
,"t/SeqIO/Handler.t"
,"t/SeqIO/phd.t"
,"t/SeqIO/entrezgene.t"
,"t/SeqIO/locuslink.t"
,"t/SeqIO/tigr.t"
,"t/SeqIO/gbxml.t"
,"t/SeqIO/swiss.t"
,"t/SeqIO/game.t"
,"t/SeqIO/chadoxml.t"
,"t/SeqIO/Splicedseq.t"
,"t/SeqIO/tab.t"
,"t/SeqIO/ace.t"
,"t/SeqIO/kegg.t"
,"t/SeqIO/scf.t"
,"t/SeqIO/exp.t"
,"t/SeqIO/pir.t"
,"t/SeqIO/nexml.t"
,"t/SeqIO/alf.t"
,"t/SeqIO/lasergene.t"
,"t/SeqIO/chaosxml.t"
,"t/SeqIO/qual.t"
,"t/SeqIO/raw.t"
,"t/SeqIO/metafasta.t"
,"t/SeqIO/bsml.t"
,"t/SeqIO/largefasta.t"
,"t/SeqIO/interpro.t"
,"t/SeqIO/bsml_sax.t"
,"t/SeqIO/gcg.t"
,"t/SeqIO/msout.t"
,"t/SeqIO/asciitree.t"
,"t/SeqIO/SeqBuilder.t"
,"t/Tools/Sigcleave.t"
,"t/Tools/QRNA.t"
,"t/Tools/FootPrinter.t"
,"t/Tools/Lucy.t"
,"t/Tools/Sim4.t"
,"t/Tools/Run/Dummy/Config.pm"
,"t/Tools/Run/Dummy.pm"
,"t/Tools/Run/RemoteBlast_rpsblast.t"
,"t/Tools/Run/RemoteBlast.t"
,"t/Tools/Run/StandAloneBlast.t"
,"t/Tools/Run/WBCommandExts.t"
,"t/Tools/Run/WrapperBase.t"
,"t/Tools/Signalp/ExtendedSignalp.t"
,"t/Tools/SiRNA.t"
,"t/Tools/Promoterwise.t"
,"t/Tools/Match.t"
"Bio-HMMER","t/Tools/Hmmer.t"
,"t/Tools/Alignment/Consed.t"
,"t/Tools/Primer3.t"
,"t/Tools/Phylo/PAML.t"
,"t/Tools/Phylo/Molphy.t"
,"t/Tools/Phylo/Phylip/ProtDist.t"
,"t/Tools/Phylo/Gerp.t"
,"t/Tools/RandDistFunctions.t"
,"t/Tools/pICalculator.t"
,"t/Tools/GFF.t"
,"t/Tools/EUtilities/elink_acheck.t"
,"t/Tools/EUtilities/elink_scores.t"
,"t/Tools/EUtilities/EUtilParameters.t"
,"t/Tools/EUtilities/elink_neighbor_history.t"
,"t/Tools/EUtilities/elink_lcheck.t"
,"t/Tools/EUtilities/espell.t"
,"t/Tools/EUtilities/elink_neighbor.t"
,"t/Tools/EUtilities/esearch.t"
,"t/Tools/EUtilities/elink_llinks.t"
,"t/Tools/EUtilities/einfo.t"
,"t/Tools/EUtilities/esummary.t"
,"t/Tools/EUtilities/epost.t"
,"t/Tools/EUtilities/elink_ncheck.t"
,"t/Tools/EUtilities/egquery.t"
,"t/Tools/Analysis/DNA/ESEfinder.t"
,"t/Tools/Analysis/Protein/Sopma.t"
,"t/Tools/Analysis/Protein/Mitoprot.t"
,"t/Tools/Analysis/Protein/GOR4.t"
,"t/Tools/Analysis/Protein/Scansite.t"
,"t/Tools/Analysis/Protein/ELM.t"
,"t/Tools/Analysis/Protein/HNN.t"
,"t/Tools/Analysis/Protein/NetPhos.t"
,"t/Tools/Analysis/Protein/Domcut.t"
,"t/Tools/TargetP.t"
,"t/Tools/ePCR.t"
,"t/Tools/rnamotif.t"
,"t/Tools/Pseudowise.t"
,"t/Tools/RepeatMasker.t"
,"t/Tools/Geneid.t"
,"t/Tools/Est2Genome.t"
,"t/Tools/Genewise.t"
,"t/Tools/Genpred.t"
,"t/Tools/TandemRepeatsFinder.t"
,"t/Tools/Tmhmm.t"
,"t/Tools/IUPAC.t"
,"t/Tools/tRNAscanSE.t"
,"t/Tools/Signalp.t"
,"t/Tools/Spidey/Spidey.t"
,"t/Tools/Genomewise.t"
,"t/Tools/EMBOSS/Palindrome.t"
,"t/Tools/Seg.t"
BioPerl-1.6.923/maintenance/big_split/rbuels_notes.txt000444000765000024        20212254227331 23112 0ustar00cjfieldsstaff000000000000


make a dist skel
fill in its build conf, with dependencies







group modules according to function (tags) and dependencies

BioPerl-1.6.923/models000755000765000024          012254227337 14571 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/models/biblio.dia000444000765000024       672312254227331 16647 0ustar00cjfieldsstaff000000000000‹íKoÛHÇïù†s•Êý~˜“&{XÌbdg±Ç€¶[;²hPtsØϾÝ$Ù–dQj¶(: 	$—YúS¬ú±»‹Õ?ýüõvzò9+æ“|öæ”9ýùí«Ÿ®&é¹û{]¤·'Î`6÷¯ÞœÞ”åÝùÙÙ—/_`úmž–yÓÉ=̳³ÿ¥ÓizæŒÎNß¾:9yx€«´Lý{Í»iY“‹û2;™¥·Ù›Ó‹ôòÏë"¿Ÿ]ÖVÝe>Í‹“ÏéôÍéëOÕŸÓ³æ0gŽó̱ïÒ»¬xzØÛ»|>q&å·»“
Çñÿ>°i¬æÎhvýöõ/âuý‘š7–ÇZ÷A7:)oÓâz2[õSdé´>[œ…Ý\Äv0í ˆí`2ÿx—e‘NÊU'y>ÍÒYí§,î³ýýÌ/Ó©»TžB÷?ú§IYæ[>ÿ§t:o# ~û{Ôì×Åäêù|d±á(_&WåÍǯ‘NW}ôo‘Žþy2Ÿ\L³uŸ~2+;;ü·ÀÇ~Ï÷“«l¾å›~l³áH7ÙÙ6áOíÚ*¨ßz§ÊÅ4ý–Íáß-±tÒœã&蜅üâ¿ÙeÙÈû÷oÿ<ŸümšÎç§K¢’Ó“ÉÕ›Ó÷äñ¹yªÆÉež•“s—ÿ-¡	1PZhúT÷êºÉÍÅÅS/…‘ή§Ù“¶'æ<%L€‘z$À²½gÓìöãe^ÌVaÛµÆÊUÓ«:¿Ç³£“M®oÊÍÇgÀö;ú“;G÷ïÜE8ÉÏÏ}~~wq›]±"û´öÞc—ó2+²Ü_Ãëï¥#½p¿œ^®œ¢ç´Ó‡¾¿»+²ùüã÷Ì£»ÊÝbZº¨Žæj‘Ì[Šz|²£–’öwô)/²:~¬n蟺yx—Oª?ûùYŽ"¶ûy<šØñº^~3gÏgÚå™}Þ°Ìnï¦i™Åº¦ÇŸ?>ÕèÚe4”ec)=[Ĉ ÜŠˆ0«\içŠZ°ÆŠd,(ÿsIÚìë»ϺÑÙ
hôPyö¾¸Ng“y-H3¤Òiv@š±Pš9 0¥¥Oò.Ù«ˆ0óžhíIj¡é²¾ô¯™GšŠ‰²ND¶"!†Š²ß‹ü2Ë®Ü{2‚Av@ñPQép2ân|‘aÞ‰÷¡eÂ	P>∌‰®PY-'9,µªÉÄ_Šrr9Í\.‚ë€àÁó‰L%%@Yܵ±Ê“ôžˆ_¡JÆ”€f|$ëÈ‹cˆ|ñ,[.Ž}½"ËeÈ2dÙY&ƒY¦ü‹É0å\Þ	•‰£üô¡ˆ:ÒÔ
YnpG‡‡,Ç«·ÞåùŸˆ+Äâ
qu@\©P\qªš\Ó‰åxÊ‹¸‘׈s°Q‰*«´¬4uœõ[v5̲ä÷Å,âÜ!†;<Àtðx‹[PÂÒªFOpsàå]YçÊ×"Zn“1³Î§÷írµÝ×wË1X':[q€”CåÚ¿²âóäI†$C’!ÉI2J2M@/ªeÔ:DçI5Å€’•÷Ú4uˆ$nb'"ÛPÌ!š
bÜdóɆC†!ÃÈ0Ê0ÃA.Èb¢2Ì{Z€„;†Y÷š7ãq։ȗΰßÝ•9+‘aÈ0d2ìO7·ê0.ïVù]§q!æ<ÑÚSb”p ÆŒ˜q„‰±.D¶|´™v™ì?ÙŇlžß8¥ˆ(C”!Ê‹²àNøÈ@ÌŠzL:D&n8¤íˆàQK;‚$½ø'˜ëÿߥsäò
y…¼:(¯‚{q°Emû¾í­˜Åªzv‘p嫪Ü
¬`M/¾hË‘XH,$VÄ
nºÁ—ÝXÎb>õåýx7Æ0–]=÷¥Æ¢Öч«{ñý|±†!†Cˆõ±ð¦i±¤ãBÌù1Õƒ`bΧ©ž‹Ì°ĵb˜aþ8˜Š9†CŽ!ÇzàXpó
?P	
4êì¡ßO¥ò’Ê9äµ
}¨ªVôrÃn€ˆã0äòùÕ¿‚»qÐj¥Èñ%î0ŒzÚÁ¨ªýD"‰<Wöâk
qð…ðBx!¼z‚Wx'ßxvT5Ø9…è½ÈÊM2vc"ãéw°P]/ž\f‘\H.$’ëä2lœ"ê*idܽSD冘j÷QÕp0bbîÅ×p4ÃáB!†ëbÁ­7ÆÂwÂ0tä†Jɨ›2{W¦qE¥¨!râß`©Œ;ëDgË®ôÔx+ËÏ“«¬@–!ËeȲCîÈÜC*Ðu{¥¨ë`²~þËó„±Di?ÍÇB—¨¶,\Ü‹ ¬)å@v!»]È®C²+¸å†O¼Br?<á:j÷(çIØÆóÝ£(æ_K÷ÜîQˆlƒ1d°{Y~È>!Á`H0$Ø!	܄ïùzó}3o+xU5í¬I­êé90Y¡ªZ
º9ì*z¬BDx!¼^=Á‹‡ï¿†0kF4W&î>ÌFÖž”Q&1`¸&lä@c”‰»s[ñL‚´CåÙ¯ïÏÏoëºVàPi†4Cš–fÁ9¤€ªE»‰¼&ªAU­}%Ê‚¤#fÆ^	V÷£&â‚2†ëaÁM9Æ~wc¹¯y`ÂF-Lô»™ðÚµV$cê·7±U]‡°6nab':_ü¾`îËg2‚AvH©pY „Æ4“ÌF™s%kWÚ¹JÆŒ‚toLh—c]Èlñ°·{ž\D„!Âaˆ°C"Lwñ˜váÀöÇHëgÄñž¨vžÀ$hÁG„Ž
°.D¾ø™ÅËc_oqfi†4Cš”fÁ};´Ùìa,mÔR{ï©Ù¨Y
¡ãw¼ô¯
·Ô¾‘/~ßË?²Ë›Ù]^”H2$’IdÏ\ªN§“¿*!ëÜÅCQ°ºÞ“2nɇsDÙwG‰b`Xh©IQÞ|¬´ì£p³¥p4z›¥ÙÁ0Xe^L²ÙJ2Ïf÷·
KW>Äòg䙟Ѯ	yÖ/óÙÌ]r>âWrÏâ''7éìjšUTæu뀓åÝ÷µr®Öü2]ü²xüË+'så#uúœ„//HàÄOñW3$<ò:9•KWɘjÆÏÖ̵ŠÿÍ27ÛRJª×5iÕ`¹ÙÁ2\*&HI@$^sRàþ±ñ‡9€ù*Ðйá>s€SÄô.–áR1a`ºÏ$üü­»5öUdÚ!:j;Z燘…Ÿ„ñj?F
&fäoжÑЀ Ôn3¤rË@‰ñq"žš€ˆç}|ð3‹Ô
\ÙˆˆÉ{ß.S{'Ì…IBTu`šV¿NÛF+
tK{Cåïv0
‰!)äiäiŸ1¾å2b«i°¨ñnXOk/‰/ŠAû³´»·_'l³™²%Ž­v²”ˆá'Üe@´Ó^oéå@¢€M´kPäξÏõ9Á‡0‚÷嵪ÁsáhêÇ·q+o:À»OÍt{ÃPyåÇ7|§²Ï(`]Vó×1¡î.V9©‰.ãGúZa›Í0ÖXWƒuÙE
}Uí-AÆÝvuL€
¹pä+é%u×çØ…ôk>cê«·¯­[¹ƒe LŒüHÏË…”Ò÷ùj8‘O9hºô”øY2]…„ÃýfŽ¯½e¨NŒý#Œ}Úë
nð
²‰þýw[ÿžl_3:Ð Œ–»˜†kÅp„9 ×`†›RsQFnš'4
¶Ú[†+Åø?Æø'}&;Ü %hÖÄ…â=€ t»°0
׊9às@ŸE;’7ãþ_ qˆ)À`íRÀÂ4\+¦€#L¶Ï@œ(܆¾Ï@A·œ	X˜†kÅpŒ#^oØps€uñ ëÚœ1x„É]Lõb8Æ>gä0šé¹k
­ü,›é)%Å5Ó“ÚêçÛà:«ØÅ6X&Fý¶Ó£½Þý‡·Óû~yJ0û_žíb_‚¶KW‰÷MüÌ·àá6êùu>g«Ý͉¥Ûl¹»Ù†ëÅT)Ø€TÐg«=)‡”	„ÄXŸ	¸Ç™	Èó½ñ(­½¨lÃõb&8ÂLÐg‹]©}OÀ(0më²`q¬™`癯û³|'Ûp½˜	Ž0°àáúõ4ý–o_Õ/Üßë"½}ûêÿM«Ç:BioPerl-1.6.923/models/bio_liveseq_variation.dia000444000765000024      3306712254227321 22004 0ustar00cjfieldsstaff000000000000‹í_sÛ8Ò¯ï÷S¸œ­Ê… ’Ö;óVfòž=S•ùSÉÌžs§¢$Xæ„"’Š“½8Ÿý¤¬Ø²$S¢ ˆòÏ[;Žhˆ­tèFã¿þûë4¹ø"ó"ÎÒ.)q.ÿûÇü×8Ž®Õÿ'y4½P
ÒB¿úáò¶,g×oÞÜÝÝ‘ä[•YN’xN
ùæÿEI½QÞ\þø‹‹‡7Ge¤¯-®Fe™ÇÃy)/Òh*¸F£O“<›§ã˺բÝ(K²üâK”üpùê¦ú¹|³¸Í›G÷ÙrïY4“ùêm§³¬ˆU“òÛìI“
÷Ñÿ}ÐfѪPÒɯÞòWõGZ\ø~¯ut£rå“8}*'—QRŒŒ±ûïawCó"ó"ró"âb0Ëò2âò©˜a–%2JkI7QRÈý£(QÌlÓÅ!”òУû¹‰Ë2;õåe/ÚµGNòx¼½C>j±á.wñ¸¼|Ýö­µøºê»3t÷/q¹îÓÇiy°Ûkyû¶ÏyeñÌ“~ÜfÃnÍÞ<§øj»¦Ô—VœU%"‰¾É|qûŸ¾»©‹Åw¬Lv>¿÷Õ²áßrT.Ôûë×÷½‹÷ÊVÉ?Ô›£‰¼üîhË‹xüÃåïÎã¯hU)uCeˆž|G³lù,{ ÂaîUϧ$ðÜUýŸ>ØMr†ÃU1¹R&J'‰|"Ê%ÂsûL½äW=ê{b?É2‘ÓÁ(ËÓ§^øàZV²ªÞýTÓûž„„9¢€[OnËÍ„úºŸï'ae$òhòSœ]_ÿ;Êã¨TŒ­“ì"ª(e.3ÍòzÛ?}±î›zÈGE×8ÊǪ›ü”}]Ó;èa{óÃãtZ–êêŒ×ŽØ=öV³aÿàfûGÈ	
„·Ÿ„a–eþœ”ðСLöœ`?1qªÈ š¢¬Jy8o‘žþß~"ŠÛìn°fr´nðVù¡öý±‘Çbmû$
ˆ(·á‡Ä	ýÀ`¼—8$P’ú”zê‚{årâ
—™ì‘Q²I	Ã씺„jÈ_½¿Èòó9x+÷ =#¬ ¡Ê<îîB’GYÕ3·êœºñžÑVÉF=Ã'4äæ{†²êB~N¢¢XÓCxÛââø‚‡+³Ê©Á¢%±Zåœöƒ@
¬®zžºÌ÷ܬƒDÇ&„ªù›YϘu××ÿ’©´ì:6Ü4ª7G£rk§[YtÛéCÏg³\Å`ù‡¢mÿ~NR6“y5µ,L)u¿xe\§{A
UÚ_ÐM–ËÚú>oêêgÏyÏÒÊ?/çq4eG¬7>™ÕÕ½ù4Y6~ºùl„e¥Û¿~÷ÛÛ×Â,[–H7…Z÷õ'Ò&H}áó-’Þ´º·f8NâòÛ:2OñƒËVbÖ²†„Ýeô¸aPŒ²õgoqk—‚EîŸy”£<ž•Á]%8©ý$ÂDø¾‚]°ÛMvIËô‚ÞnÒûAÎdTþJcŒp—þ 'âŽBüGOX‹ÆÝÆX7º@·ƒèÞ¨AÄ<—°¼À·‹øNçIÏ’x¤žÂDx>ê9轤wœÝ¥àüvv}-—ë`wá~’ß.À=$¸;¥®oÌW]Ãý²q{îSyw$ìãq`ÜX1%W¿K™Okì`rˆÞ å@çùât%É9qHÁag8Ô‡
{6Ø»€?ðgƒ¿‰rÁï~{ü€Ÿ-üd®C`hÃÅVpmq¸šÍÁ¢-føƒCph™ÃEš>H‰¶H\ìØ‚@ЂՆgm®W«‡ 
©¾ÀøÙÀo™« 
gêW	?-sø(éB+ÞX&êó~þ
A 
¿È|˜H ~Vð»‹òì½[OJ9%Q)MÕ~¿¿ñø˜×6ÇMxm›àŽ>½çÊ!Âu}ƒ‡Mh9\Ëñ×ï{.	Ô+F‚`_©ÍNš8€zΙp‰oð”	F˜éc&êxšhr(Ã!DᤉÝñIošî‰|snL´õ`¡G<‡U‡		³&)IÜ«%ùúÀ$Jâ}#Üð‘IѲ‘+ó£¬ÛÎìçÛ(†/;5_ÖÞÃÀ•“+;r°|0ÒVÕ°R€•[As€íל˜ÏΚEÔè˜QL¢¡LÎ-åR@xþøü(„'î…EåHa|Và“H%zvЫ¼î@~ìïƒgÁz_«’1Ènê‘ `Œ–æÃ@(žŒ],æÃj¥zÈtRÞ‚E°hÉ,‚DxJñ»lž–X.„6 ŒÓ/2/ë2!´:m®ŽDÕ¤0F‹Óf OcÚã‰Ì›"P<…‡‡ba$Z­aAâ	,&."VA ' žÄ:b†I
`´¾Žâ©šÏ™Gøé‹Uý–qZè°36ЃÃSà0Êóè0†v0Œ`â	€˜%@ˆ§dá™Áá)Dpí-àhƒxÎ0bõ¦C0Žr•²Þ20Ðõ‚eZb-4Ú‹ù- „{ƒ–B} ž@„ï1„3î†q± Q]‘Ñ‚C+›š‹ÁyBŸÜ)ç3 í!8º•£O¨í­ÎL’8ýT‘ˆá ´Â ‚BPx
k4àZÞ)ÿG‚@hÀ¡>ÍA‹3cÔƒ–ÍàßYœ",ž‹Å,‰GK…`вO^œc;ø"óaVH°-¥tGàx²gÎHiÈ,Vl$PŠ¶P|b#`´g#p<‘ÃÀõo†e0hÁj³2‚kÜpóõO]NgIT>TâYö¹ÿòs×oΆËQ¹¸òý¢³üõëû‹ÞÅÏú+¾¼P³òBuMÇE<þáòwÿr«Du']ˆqU¡Y§e­ŽK‰ëW>q}w?­´ŒápUD®4ˆÒI"—bXP‰anŸ{ħÁãD°=…êxÖ`”å©Ì*Wɹ‹ÇåíS£d‡âJJ‹ÛßÊxr[n¹¿OØ~·_1ÌæOqv}ý>þ"?ÊÏ××oß~POkýrÏ.Õ-e¶b>×™Î]nºÆ–´_óÙ,—Ê„-ÿPlUæó¶’–þ¯0¥Tågi^§{A
UÚ_ÐM–ËI®S{TÏO²'¿ºXyåT?ûÉF£OMåÜT?ûÉÙüdÖ˜–Û˜^òóë#
•~|u0AUéÊlÊvê”Ü2ÊK°v;È®LÇ ävÒêæ༄W³[$Õăà¬] ÛAtDzåñÆw”ài–èû‚^ÐÛAz'2º@÷°èîÞ2›’Ê;$ƒ ÄÊ6³,ËÇqªKØWá
p­äÅ%I}+ÎVTšÅcÀølÀ§£þS¯ýWP Z¥°Ž@C`h©ôŦì^ÐúÌsë;BPhÂj. Åí²óa!?ƒ>Ðg…> ô,ù^Â}vG~€ðÙœü‚?ðg%!
üYåO¦ˆƒ>;…mSeþ0ï~–ânàüYM?Hì{/¬(^ж(žÏH@ùUÏ'®ë1ƒeñ” _Ô‚õƒ8¿¢Œ¸”&+ãBÃFµñaÌdm¼ÓµñžÉ"Dy<”Çk åñ.:RO~U	»&1@ëb©&”v¹¨Ó‚A°M‚e¤Æ|à£òV±âx¼ïÿ£'oÚ:FUý[FSý@¡½³¥Á DÊ5àCÊ5øØhô°Ñô>”çM`–Œ¢Ô0´;ý‚@Ђq:¸»G·UDB<}/o0A Eû‡Ê€Ï|(»ô,¡7ˆÓ"ËÁ9Fâ(8쇣[9ú$Ï-'^àxd`¸ƒ%ËD} Ê‚A>Ù cm€x£?à|/«.Rض.
IŠ+‡„TøË"i9\Ë	„ðûnH\*®\BžR›E:€zj")}|ƒ5‘a¦K"ý‘ÇÓê"íVé¢PiwAg\éMÓ-àoÎÍ—Q§u‘?—]Äñi`²ÊŸKÔ·ÿ6Hä™Àü‚âw"ê¯a¯%
’ƒ@T‚‚@ExAß‹2€8‘ôÙ;‘u¹]‚@+S•ý.àZ9s¹a‚@Žn£t‚²k Ïê¡À Z^‚@Ðb%èYÉ8-äyLƒBÐ]+Fü€jáƒÁÉàt^F0ÀÏ~J3,>œŠ	ø^|8èY³{ºøè}6è[To~ÀÏJôw¥ü
8‡Ö"p€ðÙLBàÏÊÁ—Y’dwØü¬ŒI´à ¾Á¡
uG°öl°§¬DøZPÿì=+û¿×ñ‚@ÐJ¸*Ä	ú@Ÿ¨SŸ¿ÿ ÐJêiUøYÁï.Ê1ô{v–Ÿoóìð>KY÷£Oý}ËÁx>Cph™C [4/åt¦ƒ¹«åÌ·)°Ïý—Ÿ»~s6ü[ŽÊÅ•ïå¯_ß_ô.~Ö_ñå…šëèÒošŽ‹xüÃåï”^n¯Ñ>ü{ ¾UfYœ–µ>Ü#¡^„zt?µ´ŒápUD®TˆÒI"¿‹a•‡ö'Ô
¯¨C¸³§P™Èé`”å©Ì*Wɹ‹ÇåíS£d±QUÝ¿Ííoe<¹-7ߟ¶ßÝWLç#³ùSœ]_¿¿Èòóõõ9“Q9ø '›V²w‘[¨Î)³#ºÎ€îrÓ5í ½³˜Ïf¹T†lù‡Â¸¨ÍG(JTånÙT©2Ÿ·ÔP¥ýÝd¹œäÙ<«þŸdùÓÃ'ÔÅZÈ+§úÙOÎP
+šÊ¹©~ö“óàɼizÞÆ›³óc¬­óñïŠ
â #ÓrÜZŽ+úAH¸’êê‹Â¤';€z\™ gЕ©ûsÓ¾ìÏER<™q£GG¶Î‘ù(Jù¡a‘¡ƒÇù•ß]Á]%¸JÀ¸ƒGÑ ×å“ð~;ÈovsSH_ÀûòN%’_ñµ´á²ü¹ú‚BPˆ@ßË,>
A!N@‚/¼
̇¢ƒ@[9Ð@èYò¿2”· ôY9
=IÕ5(A N>|/pòøŠƒ¿¸ñÇ~>ûô^Öœ÷>c@›UïÕÍe4Lxˆö¦¿Å|ˆð´Uý¾J¿} ï…rÛlð|âòðÊ!Âu}ƒ”j9^àú}’À
¯8aÁ¾R›l8€z
60¹Á‚
.¦ë5üÏWj@¡j8ÿB
Ø,Œ±Y§7[êsÖ€.Ð}q[-±ß
ÓÝSØu‰c.ÁÞ‹[jám—ZBŸ0æ]õ|âº3¸Ö¢Q¿x¬O8zÍô/fr¹å*6Zo¡$0YëÙ3_ëùÝoo±Ü‚å,·œûrËPNbÔÄÐ•0OÀ<YÉ€›qAèÃVHÀ‡õ¹Ã­Ïym×ç\J\!®z¾G(
\ƒtZ]HÛçñ¹zíù$ûJn¶Bw%-Ñqâº&Ï°ñͯÑý:/£2˱N‡u:¬Óù:ÝÅë©îíúI½¾ÀjjÝË‹ºI¢ô“š|b±ø"­èÝc¡«ÄPêƒ_ðÛA~¿}Á/øí.¿Àøvßw¿½¹ ·ƒä~¹ ·“äŽU‹9vÀÞ.›§Q}Øø¿<îøßÎâ+¿b©ìbKRK‘ZŠ²`ïìÙ[Æw ´Rm~<üºrA0hå°
5i„€Ð*„Sðþ,ò·©lÐz†Ñûô€žôê`9è}6è[F» ´sÖøW^t¼ð>ðÕ¦o€ð´…àà~ÕOÉ`Õq“çD"‰Ý!±åàÝooÏ1;Ä¡š¿½¹‘£RŽÁ ´feaÁ çiuœ¡.&	Cí@¨î]¦‚—YzW´-½ËáAxÕó9ñô©[= g½D¢¼гƒÞ¹mî|Ýï>¼	þÀŸ
þªø$à|Væ‹#ø–æ»%€§¾Ì
Ü~Û
Ü¡G„ϯzBrjp·–ÄjI.ç´O©CBW\õ#‚ï+ºÙîƒhÙh·Ge·ps—Ó[¸¾âôlàn²Ùù¢°ƒ;¸<™7H%Áø
üñüê7i·Á •“ò<ú ÕzîqÊêW`Z9O*»K Úq>†Àð¤|òà‹Ì‡YD°x¾@ÈòÑÀ8ZÍÒK€åk8`ЃÕYr C½2Ź̠ÐÞH±J™BÊ<´56€ÐfP9ÊဟsÁÓ1ÐzÖ6êä׸(á{Á '²TÅÍQ9À¾]phsã‰Ìˆ"P<‰¹18‡§âŸ#`<ÿâÉÍŸQú$žÆH$‚D«6±^Û†o‡Ö—q€"P<™åmÀOÁ?«Û²ŒÁ¡uÿâÉøgÀmÃ8ËeœzƒvÔƒÃSà°*¹¡#ØC€x fE	â)YDxfpx
‚C»«7(äí.fƒ@hõèÃ6„ꥌ¦€Z‚p>‚@Ðf!X9ú„Úr@Ðr-âA"ÓIyÁ •ý³$IØA0huPgÓ`b
í.ÍD€x"ëÔ@(žÀèp>Ä$žFY°O£ªH‰öI\Œ
±AüYÎe‚@ÐzJ „«n¸ùú§.§³$**ñ¬ûÜù¹ë7gÿå¨\\ù~aÑ]þúõýEïâgý_^|QJ«n£é¸ˆÇ?\þNƒË­"Õ­ôBÒªF³,NËZǯz>q]í§˜–2®
É•Q:IäwA¬x¬/(¡¡zÉ	ö•«ûý`”å©Ì
kXIº‹ÇåíS-£¤–C]%§Åíoe<¹-7ߟ‘`¿»¯ØÐGöó§8»¾~‘åçëëêy­?ìqy…ê›2[±¡ëìç.7]cÐÚ9‹ùl–KeÇ–(Œ‹ZúAc¢*o“ȦJ•ù¼¥ †*í/è&Ëå$ÏæéXõü${Òñ«‹µWNõ³Ÿœa4úÔTÎMõ³ŸœOæÍv#»ñ›5;ÂJåÆUWç¸êœÉt,ÓÑ·uƒ«°íàÊ¥Äâª'âÐÀ58ºêyÄq•$ß'ïó¾’ÌikÉyy;¨ÔÙKÉÍM}ABõ)·5UC/Ø­©ðˆ¨ßB×,ÕùËæ÷íò™Æyt§wÌew†œé¶‘áH<ËŽ²4U¼kç÷Ä÷Ýÿåâ6Jlj¬ºo™éîë]^|ÿ³š<}BkÞMïöüÇï~2qxò™du˜ÓÖê¨.ãøÁUÏÄ95huhH8KI}%™²àÊ!!¾I›³QÅ-MÕL“…ᶦJ »4m­),N«Y¡=ëÂWŒ‹ØŸ„ßìͶÐÖ¶Å%‚ò«^µ¨Bƒ¶%$žï±ª‹‡Žïõµd¡%»ê!7j]6)¹¹©ú”Žú”[M†±…F۶צ£†:­ÄóÆ]11âh&†µ51Ôa$Tça†Ç/JsõÚ0#\`¨ãª/´“ÝÈÊlÖs[[=â¢ü¹¶"wk»ø`g^ Y™éÐ]쌰efÜÖ#Õ£”ç¦Ênr #(ñ…Ë®¸25®ß×rÕ8†rîok6ŠÙ àæ–ê>üHO
u/ªTiÞ²Vfå噕à±eðv±*Ô5gV6…ÒoJwîU/pUï&Ç-Z­%¹Ž }ê×TÍ,ö•Ü0š~%…Ó)Ùw~Ù0œÎ…Ó?dYYÿ÷ÄÒKG,ý”céoÎ-%Œy­ý˜ ‚»W4 ¾c4#L/ÞWr„Ns‰§¤2gÿqqCÖ^½FþKÀë¤ÿúž¦f`Q9ø+K82828282Žì_RÙë(‰ÿS'¬­ñh¢­GóÔd%Љ'œxf³œ™O\ÿ»¤¾Ç	Õ)/æCâuÜÒ”‘gV†”:œíÔòÜ"âç³Ìl\SÙ9`M¸ó|÷÷Qb
c³¥@õ>Î%*$¾Oƒ*¢äS%›†$|1Qz¢ç¶¶ŽêÚÛ£DZ©°Rj—¶õKpòŸ,ÁjTš‡Gµí÷;i÷òz­Ôì*­[e®|Õçq-Û÷5œ•»YÏ-m}Ÿ8Ï$Ûj¥<׶­õ…-0coc<›Ã‚°;³×'Œ±àɬ@OÜœxÎÖ±¾VÇ×ê4oÚVSôÿœø»¿ëth$À]eõ`$à1ÕtòÕ‡ðX'GZ‡Ê¨íÔ¶µ¾°§86MAû¬öP‡+ì© ÜlZ»v³Õ¸…¨¾’zZv«
Í2Â6ª¹­-#ÏåÈa‡¦­•…8NÖùnf °iXw&Êr÷A˜@§KêQ‡ˆvé’vÂ÷ÙžÍ[¶Výÿ'«y›Çíÿnwú?÷õÜuaÂNö¥«Ê4n‰þŽýßæz Ë;4ð¼¢Î` T
='Ø©)fç8°:	hýz§ùaJu¾KÒ6 ¨^â¨	ؤ㖦ÏnùÒ-g»´l«(ºÿQöní6`6»¿èò @çä8axÒƒŸ‰çÒŠîÖÀ³\ä6
ÅŸ_Q‡¸5½Xb÷Kúe›í7Í—Öh¸¥%%ôÙ5×ñvhØVKt}C]Ÿ¶èúÌêB@ÐÝ8Àý: šxôÄ–++á71Í[¶Õ½ÿ£Ô\ïß´ëÕm
È5Šª?xÄß¿àZ£µ5š®,ä}ªF×:_Wzcû
n¸óõ*6ÚúÊÕü¾“[_ÿ̲¤¸¾þ9géŸÑ0ÁaØ÷Š}¯Ø÷jbßëû(ŸÈ?Ô7MäÆ['¸2_—P­Ê˜òPxfw½V’<5…U’t:‹šþyÕê’šÓujѲ‰WsÕPÙ÷M–tp•c㜚.ëðËï–½Zûáoò©÷&q=âÄ÷87»
,kIÃyßÓB½jƒdèp£}ã J6,vâ·êæÏu
5¤Ì÷õ"‹Æ2ǨÏì	ƒ>úÖ
úž?ØjÙ¸ýÁV¯o£âöõ‘ζúñÕÁ©o|ŽS´¬Ÿ¢µó©·‡Dw"Sy#£r®¬(ÂD8‰†2¼€·‹ðªo/-Fy<+A0î$Á¥o€^ÐÛEz‹»¸(ôü
ƒàN,¿f)Ø»]ew,‹ø¿]ä7NËÖôv™^Ø_ÜU‚gy<`	
wã¼>'—“£	@|n¢iœ|Ë`¹»,ÏÓc
 Üy„aŒAr·SÔºø¿Ýã÷ŸŸä7€p»gx?Ï£$¾‰eŽ10î"À4Ý®&µg£jïð¾]\}ˆÒ	L/Øí²éÕ7Â@ø ïTbãð5=`Ù¸}i™cIüEòó‘:°<–ÄÍ¢\ý.ÕTÿQ}¾]Íð!Ô«¾`Úd°”EY§—%@Ú@PoMƒƒÖÔþ@V«IÙM”çÑ70­Œõ0°Úk;ÊeuOm8Ëõ‘ºnÁ,ÏJP
­Q(§CÌŒ µÂð>ð-Ëam Úµ‚å`	# „6 ÜÄéøa%ás‘Äî€8º•£O
Õìøkß]½¦Äõ\³gáBɆç}&OÂã„ã´/uå™'8î-ç}]˜?äõ¨C¯$‹ÆX“ÃËÆ°_‡f… -Ï}¾	1ßl0ßtÛÎ7¹O€c¾©%¹ìû|S0â
õšúÆç›Q²Ñ|“×58ßŽ3ßüøá#暘kb®‰¹&æš^a®	_2€÷%[XµS‚BŽÆÅÄï‡Ò€FÐhƒÆ¿ÕìZŽaÁ"²Ô! |µÜ2‹©
(DX,",f<,öNÎd:V [ãmcc®GüЫ2"¹Ùؘ ¾u|Š;^ßÕ¿•`ʉOC±§à¼¼TÚì¥ãæ¦Ô#üѧzÚÔ'ŒŠ]Z.4o¡i–Ç2}ÚÀ½Íªl~ß.ŸiœGwƒ(ϳ;C!ͽ7ÖÂu£,MØ:<ñÄëÝÿåâ6Jlj¬úi™Õ9Óßÿ¬ú“‡±æÍtñfÏÝøæ{Ó·ò‘e]¼¶ÖÅã„ó:þmغP‡„®'–¢úZt¨E«Oà5/•ÜÒ”ÇñÃmM)%nP)´KÛ¶ÊÂÂtÕ¸m,}üfz4#º3~¡Œ8¡Ç–¢º?‚Qy\k´SÛ€Ä`³«‰aæ1ÿ’©Ì£$þO½À°ÆÌø­S9	<«’Ðã&íŒîÀÚ¬,$õ¹zíT¢[¥/6²3›ÕÜÖ6 N@Y£´KÓÖÚž˜¡9;@[ØU#Bj‚Ù®ÇýD-g4¶÷óŸ]šÂœ¥pÍÙ·E‘âF <˜Pÿð 2žP³Nû#ÔÑ[¸Kèþ²w³OôÜÒÖS…t[[¥ƒãivj[°›æ1q^w—Ë&Jì´k#oÎÄ~6f“«I”¡€Útž”ñ,‰GBj±:14ÚŠ&“\N¢R&6Ø0>‹§×¥§g܃Ó<¸¹	ývî9m¸*'ʵcSãPŸ¸¥ü÷Cß´lAøþ²9ðÍznië9êú[½ÒÁaÁ®máÀáÀáàÀ;üôè‰9pêÎûtà›öò{´µë&AÝjènä·±=ÂCGô© Âñ®5îâ?€zMöðDƒ[øa‡ßÂÿñÃÇ]!îâí¿`ç>vîcçþ)ïÜsneh¼ÖeOâ…U
‡³wþDÏ¥ÄðZŒçõ©.HS%møžgÒqµW®‰ß
	»æ·ªÒ3ï~º¾þŸ_zÇÇÇÇuLÇÕ¾~š²º´Ús£®K	âA¡£œ%~õZ§9FÝ×!TlâÀ|Â;é¿>ÊÏ¿üççççeÀy½ò‰üC}³ÑD®óa­÷9ö|N¨ø%Ì
©A'¶”Ôsˆ'œ°ß㌄•hA¼½e7ócQ³‰#sé¾¾¦‘'£q
¹²GyZÖu@-»´ŒîZïÑÓÙ]\ø:åZ\“‹êZ”GïE¢ßc.ñ¿Þ®âÂh×8ˆžMúsˆ0Y!WÀ|ßxûöƒÔ´É_祲éû™&a臡ߺ¡ßó•U–ÛWVyE:Éæõ‘ª©üøê`‚Ôw>GÝëu[v.t`x§óðÞÂ;ÊÆY
ã~;Ío©ñÁ%x§uK‡G¤ò5QƒÐF=ÌzÒú@Ÿ%úÔ¬ô>+FÜO› ´`5ï‚@ÐÊÙaÑèvPEîRøa0øÂŽöZ—í.	|~Õqà 4™¡D…¬Åyö{" лãõ¶ 4šq=ŠÎ'@$‰L÷€¼ä=œ}ÞC\ry£:j:Bø£µ.à’8ýtnÑÍåLFå`žÆÈÞÁ]$¸ŸA.Èí®í©Á=Œ/~y‰;ƒX
;b}jÀYp( ìLçáê8`ÐJÏx{‡cþ»Þã µÓ1Á ´lÿ%S¬Bƒ?{6@kàzÃ+ð~¶ð›Î1ü~öVaý€Ÿ=ü`ý€Ÿ­É/Œè³Ilè³µ	N~Άƒ>ÐgÅö%ñ$JÄ=`«º	¥œÎ’èQ
gØçþËÏ]¿YYN9*W¾_Xt•¿~}Ñ»øYÅ—_”ÒªËh:.âñ—¿{ÁåöRÿêYÕh–ÅiYëÓó<"<\õ\Ÿ0ß÷öÓMWåäJ($ò»,ßYÈr™ïõ{n@üJ:Sƒí+]&r:ey*sóªVÂîâqyûTÝ(©EQA‚6·¿•ñä¶ÜrJÄ~·_1¦éOqv}]ŵa¾¾þðÛÛŸoÕó[OÙEj¡º«ÌVÌê:“ºËM×ظƒö×b>›åR™¶åŠ­¢Ê|ÞVÒæÒ-‡Rªò?‰4¯Ó½ †*í/è&Ëå$ÏæéX™€$ËŸ½Qk!¯œêg?9Ãhô©©œ›êg?9›ŸŒÙÂU¯£$QÖ§x}êU²uð„®lœ¥¨z	~;Í/
_‚ß.ó«$€_ðÛY~ËHÍZ@0î Áï~{û뼬fÛ wà·‹Gà|;ˆ¯üš¥Å`šã›Xâ´Z@ÜɃäÀÛÑI\]	ô‚ÞÒ›DC™€]°‹Ãc¾‡ô½ã ·Œ@h@ì߀VT ´`z‚@Ђb§@Ú@ðí¶íàü™®Ÿö(z	
A¡•:.Uøô>œ¤ü^~Uð>ð
FÕôcp–Ë ¢ Æó5ÂÖ5'.£W½0Ïl9
-ɯ$¹Ž.¦áQ¸êµCÇp)C(Ù¨#œ,¤n¾ŽÆ/¿£€
h €Æ™Ðx]ÈÏq†ì=̽‡I+æ
Gš´&Y4(6J»˜ŸW
¦­ÝA1•_‘Âö¬±7PPðþlðw—«;>Àg
>X?hm2™ëÕÇz‚é ´á~ùíOX@À÷²B¶Âi²õñÇ;ÊJ–p²ê3¼€p¦¯°Ðü‡QµQè6 ”ÝúÇ8á¹]!ˆá"†‹îùÄpqÆl® ´<³yà°À.Ø=^þ×·B·½ `XzÄÒãqÐûyö/ ô¬Äý{ƒÊy"èm¸ýŒ^˜@ˆë€ïlýoÚè[ÎD¸áXú~/,û†¶Î¾q	„_§¤PW˜L¾Q¢Bz/*ýÄ«”0šzs=eÞ˜ÁÌ0ó™7[‹a"íi7H»AÚ
‚g¬!íü‚_¤Ý€ÝÊ®úýy7Ày7XtÄ¢#BÏ¡gÀøÌÂw?êàï……üXëŸÇ‰ïðàª'<â®’®eyY´ª“î„»ú
çD˜®”~UO!ìÇœcK¯þ™–¿t8îw€`Â~û½€Šé÷Q?¬Üa¸Ö½…縸¯
€p®Íï Ëc€»ðt^`Üż™NÊ[Àx;ï|¦þ)£i!?ƒ`ÜA‚Ç)Á®9UFåh€·‹ðÎò,»»`·ƒìær‚…_ÀÛexëÊU@wáq\`íw‘`õ †Rÿü‚ßò;—ƒša€»¸v&?¿‹o°z;:ŽÓO@èvrî6U;G¸À/oÏ~<ƦAl´±i5o«œIm(£Ñ-‚ü¾m‚@+nx¹ï‚@‹Nç%VŠ7U;_@è³Aß|ö±Jüÿ(?A hÁq
 
(¾zdZµs	ô>ôU[à³_»ú@Ÿ=úÎïØz0Ø9õî m ¸Ü~ 
¿ïŸ Ðë
0ÀøÙÊF}÷Óû8ýA µlT m΄õ¿Fúf÷›¢€"P´â —_´„³
	SØeúŸoÓó2€àïgê-ÏÔ{'g2ËtômÝÁznëƒõ¨ NÈ®zœ‘  ¾Ésõ”(ʵ(—x~ÈûÔ!Ü÷ÔOÁž²óòvPi´Ÿž[Úºa>×Ó¶J‡y;¶]|-ôÍòX¦OΔÛ`C¶
°6¿o—Ï4Σ»A”çÙ¡óÓ6ŸøÆÚI£,Me5/žø¼û¿\¨ñù8‘U-3Õc=ÿòâûŸ¸ôž<Œ5o¦‹7»áã7‹Õ/óÉG:”á­íóIàSzÕ£á®0ig”¨iQOM+ÙÍìÌF=·µ…¡¡9´¡ñÛ
¿†Ækmh8'\øÞ1ÇõÄUψa¿NÂ)÷|£¦f£¦Ï´
}°5}¥N õÚ©ñâK€±±ÙiTã	[ÆF´?–\Ã(OfúTò€W‹bºS:^ß'Bˆ–’›šZnkK©²8ÌÝÖØ'ŒŠ]Z.T‡‰y&feHBw21®-ãn<ÃafÇ3\õoîU?¾ï=Ï0J¼£gV5}®ísC?¬ôÚ©qý%ÀØ`<ãìdlsÆæg½à¾ÎÎííŒC˜„W=_7Ø{Ñ ™¡Q²¼…,ßc	ýê
'ÔÝWºLät0ÊòTææU­„ÝÅãòö©ºQ²è©”РÅíoe<¹-7ß_Ù³CwÕ_ýg×ײ¬¬ÿûËÚàÚÑ;rƒ8×Ac6Å|6ËeQ–(Œ‹Ú\_ôP¢ª d"›*µ¿/¸ÔP¥ýÝd¹œäÙ<«žŸdùÓʬêb-ä•Sýì'g>5•sSýì'çÁ“yÓ´í›®F77ú³°µ?!	\vw¦Eì7ó<Âõúû1œÙAôläË8qÝNú²:_óç,-£X}›]vhûÛIø3ø3ø3KþÌwÚ/5{„ú^p‡¦d1¶U{4WÍÏœêÊ\ÚaTmäÓ„R´“>í£üü¿dTÎsy}ý/©¾Ðx„yüüüÚ1ýmí×FÂjþ'FÝšÔ¢¨+”Wó™šÒèžšC	³Ní z6òiñ¼Nú´?òxåß6Õ·„+ƒ+ƒ+ƒ+kçʪÁr”Äÿ©· ­ñi¬},­Š!ë\N„á¼ Î\º”ÕïqŸ„\Kw}Â|ùA›UÝÚØ!¡†[+Å\¿Rl—Æíu>±¨ýÙÕÛ>¨.œé?­ƒêÏ[„öÛ¬'Ž,ÖO¯Þø:SPgä.dõ{ÂÕo%]xÄm—£û¼Eجê¶ÆB
‹¹Û0Õx·Æ­u†E0dÂa5mø¸¡ý†(W¨I(óŽb”,5ñõX5Id:Fu±ÿ¶Ïfa³¦Û_}2¶}<¡´pÝpǶ­5†90d‚6æÀ·i¼NMxH «ßc‚¸Ô¯‡ÏÔðIs3­…ðéŽ[«{pŠjÓˆŽÛƒ.,!P5sx¦/sùwjŒ%„³´«yùǵ~§&œ‘=ZBp=5a¨ÆåžêJ†-Âþ3†gÍ#_­
ìÔ¸µÎ°'8gX5'쨡ý–j¡ÏåuüÚpìÜ	Èê÷|ŸøÕ•c,*nVu[cªy€Ûp™p—¶XR«V/nPâÌ_HêkÉT¿f‚„†Oޠ㶦!q½g›
WëÓ¼i[UqÜgG7n‹
¡knÀvóÒ¾è˜Ð¹ë.«²ñÍš!ˆ£·ä×’úZ2կ͛—M:nk’Ð
Ÿmª‹ìÐæ奚—6U‹Bj˼ˆ.™¾”¤F/>ñüS6/Ï
Iâ°…yiØææeóâØ2/~‡Ì‹Ï‰C9{8zñ´¹9YóÁöJF.ñß­-ÌÆj•ö5Ö<]óKæÀôI.‹AÌBT5Šñ]%»MfKÃ5˜MZniËTS7hd’vhÚVWI0c¼6ES«F ì’ðBÂÝà¡pˆçú6÷‹¶;4…8G#à¿RJx€jñÑjôÛÌû+9^-Guz—èòË,$Ìhji{嚤–ú„wí*ë?Žò±r_ÚÒ¬ó^í7QJ‚ ¬ÎÊnšô_ŒjWz*ĘýÓÇsT¢õë}¿Ù¯ås5VÚl4ÁÚÐnÛÓø¸èÈÅÁv7ÞdéÚ}úú¢Éÿ–ÉYÆ£¨÷S–ŒÛí×{â+×ùË–[A·x{íx\17LÛ^Û8“x’Nåúçµû.ù]6IÈd´Þ<†ÄcW½€’;
)q\%H?YHûÔñI(*ÁúuGÌÅûø‹ü(?ÃX´1›ƒ©ØßTÔóâ·E‘âMtaë­@œ/ÎÛhà4J+Q!q<æöÕÙÓã
ᶿèF)t›ÕÜÖÖׇˆmÍíW*ð Ü­i­=’è6¥ÿÇykvÙD‰"ÒñæòVÏš‹\Í4•¸˜Î“2ž%ñhC‘‹ˆXÝOa¬ØD4™¨Éìã©Z‹j
K¤àéuéé<ý•®žõî’ÿJWOL€}Æû‡sàqŽåÀ¡!§}_ÊÔk/ üh|UÍ-m½¸Ïxe¥‚ãïÖt¡ýKpà?¾šÎËhC(8u¸8u<½c9uNwqêüñ›]¶³O¯_'Ñ7™ÿøú…úÿ$¦?þãÿÔ®Óz·BioPerl-1.6.923/models/bio_map.dia000444000765000024       536312254227335 17020 0ustar00cjfieldsstaff000000000000‹í]moÛ8þÞ_a¸ß.Íw‘õ6‹íp8 Å.®Øý(¶êèV±Iišûp¿ýF/‰ãÉ’)*µ]´XÙc>Yœg†œÿôó÷»hô-HÒ0^}„Ç?_½ùiúïáï2ñïF °Jó«ãÛ,[¿ŸNPô˜úYœ (¼Gi0ý¯Eþ„¦ã«7£ÑË~æç¯U¯úY–„7÷Y0ZùwÁ‡ñ?ÿk™Ä÷«Å¸”ªäæq'£o~ôaüökñg<­†™nÓ0öÚ_Éî°wë8
A${\ï‰ÔŒ“ÿûB¦’JAhµ¼zû[N©za3Ö¡‰Ö‚dw~²Wû8IàGå HQJŸîCwˆû‘}ˆÄ>D˜^¯ã$Kü0Û‡¹‰ã(ðW%R–ܧã¤s?‚G¦Irúè_Ã,‹Ìÿ«¥m(_~^=]Wâ2	ÍqK¢f”‡p‘Ý^·t»ÊÑ-þ-LÛ(84ûp•õ6ü£áð¦ßó}¸Ò#ßô¶LÍH·•Øô˜â»rm5(_Ú!©"òƒ¤þ㆞FÕ=®ý‹»ßü;˜g•z|þ4z7ú6*ø>ì/ƒñ†`ñx.>ŒÃÛ·hW)ÐÞ=ZÇÏßå;Á‚LÒ»ºï©u77»	(⯖Q°C™q<¡ê4° 
î®çq²Ú'Û^•*pŠ…¼¯ØÓ"æ%ŠÀm.o³zÊ9møOcËÏøÆïßö×½. i$Aœ?­‡¡šg^¾X>òukàžF(…GE	¥„å5 *(P3á!)¨œ0‰°G¤ía®f›U!"Œ)‹«‚
‘Ô;
!\Áº.‚‚]„—‘ÂBåÿ‘ÞÆבãnßÉë¤äŠ_#?M,ÚÃ"ÁÌ#`½á‰åJÙ]$XUPB+5ãH3ªô„j¤´²M=¨Ùf‘h¤©MÞ@´ÚøΓø‹ŸQîÐ+“GÍ þ
|ØŸgkn'Té4éûõ:	ÒôúùÔ:T¼?ƒm
êÉço©T›u¨¥J§}“ ´¾ÇM=.þœ†³±òÇq¶7Ÿ:>×›ofÚlc7w¶Y0îÖ,f[ÏÔÓøéön›	1S*Áà8Àb¼¬
© 1B’
Ab½(Ù†Ã<ÄÏÂ~}ÌâÏ~òW8úrôåèËÑ×€ôÅMéƒA÷¤ò&„!O1›[hëŠ11HxžÔ"!DbÂ&õ£f«
<¤ÔÙEaŽ¾}9úrô54}	Súq¢å„bˆ…´´È^€Äd…„µœ	´—_S$±¶ºÏÞ‹’m¸+?{:ÏðkíÈË‘—#/G^’—4Þ:ˆK:@䕺‰»À+:DØÕ‡†­Î‡‘çq}	á‰u9êrÔå¨Ëuý#ûìGá
Ep˜gÌa
	¥'¢!Ëæy=å¦56
ü’ìöºPæë%’
«&É|ú¦ßAÔ\Ó8	ƒÕžAV÷w‡Rp·ßÃ
ïõžN8}5œÇ«4¾2yr_¹Fœés݇ε¹6íEÝ>ô%îCƒ+9¼ûJÍ‹¯ b|Âò Û-¾ú	‰á¢øÊ£ŠM8F’aËÅW=(ÙÆ}U³só_‹¾ÿ‚/*ø§s`ëXçÀ˜HŒË‡ßaD	§ROòžž´Ú°d…¥`Í$ø²Âcu2vË>ý(z©Ù€ŸýõÚCäX̱˜c1Çb6XìïÁ:X-‚Õüñ•ñÞŽ­ç³S$(ÑyþŒ¢DÎâÅ%GœŸjù; îªØ,º5«C¢Ú#$KÅ/gf‘ø×»Ù	}Ú­K=¡$öxê7ˆŒ÷xšm‹0·-Ń¯´k˜¬”1ÅL+.òàÒ®i9¬aƒ$ÞšÒAARN¾­$hmƒ8ÃrƆe×8t³,Ìže©½¥yï.ðF€p$<‚¨\²¸å­}hx©…ãeÓo»xÛÅÛ.Þt×ظêŽh$8UP q] •ÜEeî«!È«%/u¿ø÷<ž*Ç_Ž¿9þ²Á_ͤDõÅbö+HâœjÂTS=£a¡Ô¤µ:6‰ê|–5á9)ëN’®~ÔÕºúQW?ê¾½áêG™ÉébU÷ÀáŠ
9À¡/ y^…”w1£²($¢Y/J¶‹D	?×HÔ¢.u¨D‡N\¢ÆEÐy	rÑPÈ~âX`¢Õsæeˆ×"SÆ­æÔ)Ù(ʶfuXTæ
tuÉKÿ·9Ú$ÇÀ>Ç€š×¥V
¼ìŸÔäH¼@*OjÎ×›⤦%ÛøÇÎ0³ßÒ8ßØùÆÎ7Þ7¦}õU°ß£^!"‰|v¹F¸¸6BîÔXá¸gü$I€ï¨<")I>ý¢Î1vºûÅ»}å});ŸÆƒï0â\¼hÝë½èDøãvä¼Ñr€FL=YºÈºîƒØ}ß¾…šWÇ©è>HÒ²BÊ»2y4¿¶ß}°%Ûµo‘ò½Í ¹ ÙÉ.H~…L|j\˜J€H0¢. IÁ6
tÒXlŸÂzQ²
…A,ĹqØoÉxgáhÌј£1Gc¯ÙG—ÊÞr!ìÿAžÞ ÍCS5D'ÝZ%D!ºÒ^c‚(€E^×^ÔõÒ=—T…n›1ÜÞnÌqà¯
 q­åùÚ€BT‘.¢Î\¦
¯iŒkóò^ÓdÎÚ‚¨¨FŠ+5Óˆ2säV6 VÉQŽˆb¤ÍÏ¥5VòbOi«:u§´Î•u®¬se_Õ•¥½œÐ(bèdµ>¡Ù •'4Š’3_§dƒ¨G[ëc¢BˆN¢.cþGue…Á	
#ÃçÌ3ãz‰St€|C‰à™§Ïé†$ÿmˆüÚ~ºa*ºlCçÇ:?Öù±ÎµèÇòóÉ4"qÆèùdyÓÆnÁ Êj/ê2.2Óˆ1S?¶¼ŽüÇ ¹zS^Àßeâß]½ù¼*û£…ÉBioPerl-1.6.923/models/bio_restriction.dia000444000765000024     12570112254227315 20645 0ustar00cjfieldsstaff000000000000
#A4####Bio::Restriction##Analysis######Enzyme######EnzymeCollection######IO########Bio::Restriction::Enzyme##MultiSite######MultiCut########Bio::Restriction::IO##base######itype2######withrefm######EnzymeI##############################creates##########contains##########uses##########Bio::PrimarySeqI######cuts#########
BioPerl-1.6.923/models/bioperl.dia000444000765000024      4664612254227331 17073 0ustar00cjfieldsstaff000000000000‹í}[sG’îûü
…üv,ÕýBìxC²Ç³ŠÇ
Ësö¼9 ¦p$h[ûp~ûɬH‘D7ºQ]Ýh(7b¥i:…I òË{ýÇþy=ñïér5[Üüõ¥`üå~û—ÿ¸œMÎáÿ¯–“ë p³Â§¿¾ü´^ßž¿zõÇ°ùçÕd½X²ù쎭¦¯þßd>Ÿ¼¡W/¿ýË‹_¾Àåd=ÁŸm~:Y¯—³wëé‹›Éõô¯/?N.þuµ\ÜÝ\¾,¤6r‹ùbùâß“ù__~ó[ü¿—¯6/óêÑëT¼öíävº|ú²×·‹ÕDÖŸoŸ‰”¼þù…ÌFjB7Wß~óZS¼¥Í^k×-Y_O–W³›ç8Ëéd^ü"$órû[hð17À<7À27Àlõëíb¹^Nfëç ‹ùtrSଗwÓÃqV“9|Uª‡¿úo³õz±çýÿ6™¯ê(PüøþÔ4=WËÙeõ|$Qò*Ì.ן~ý3Ó¯«xõÏ™^ýß³Õìã|ºëÝÏnÖ­½üçÄ—Oýœïf—ÓÕžOú±LÉ+}Úˆ½Ú§øS¹º?zBNb>ù<]n^þÍ-½ØüŽ7‡þ‹ßÂâãÿ^¬7êýóÇw/Î^¼5}ÿxr5}ù@¬üå‹Ùå__þÄÿŠž*/èÙïèvqÿY*Å„·#i÷N>ÕþùÇZ†òñãS%¨2¹¹šO)&hlA„‘±Ì+£žÎ§×¿^,–7Ï)·e#R<ØÏÕ¼§
Ï87!àÓtvõi]Ž sڋÞ8\Ž7³Åùù»ÅÅd
ß®ÞG¤Õzºœ.ð[¼¯úí?,ŽBÒÙ©gÃZfw#áY2d<÷HŽ	@€ä”dö`äz§£%ë#˜’Vg<B1—él|˜þþÃt²¾[NOåtÈÔÓ¡%sܺg\Jø²ÚŒçc‹uйàÇN1?š9)sž–Ô¬sB?ôû[ïxèœÇãíO§r2TêÉ‚oFžpOÅGf„ΰLJ?'Á(‘Õ£jAÁZ•fV«¬ŒÁ™Ze'óó¿Oo†CßÍ'«ÕŽ“¡SOxûÚI´ã‚!MÆÃPre¥[†˜µ‡B×;í¨Y爀ðˆd2Óáøy±X¾íù\”¼èä#üãÉų_NEÚ®Ñ{¾»½]NW«_ïÿêéI‚í ¨ÅítC¼lPÛôQM¥ÿõmjªt8Ðo‹å´HÜüKOa¾¬+ðø‡á<Ô-öã<®_4üZ?|2¯ª­ìÃo¶Zp=½¾OÖÓ\ß©íë¯lRˆÌ$§Sܪљcœ[®sæ“fejì$¸EøðçÍÁØ5³­èY‡É“aÀDÖ{øC,F,F,öU±˜Me1q
aSVëœÕDÒ’¤±„`LÂ3Äbâ`äzÖŠ’§‹½_ή'ËϘÅ####ëŽÅ\2‹A€¤¥ÀZP2ÉÉbŠ‰P yà’±TÌGdÇ„ÕY±V”¬Åbœ3p0‰µA-ÄbÄbÄbݲ˜Oe1©™2¡0ð6+‹!÷T2V·¸YLŠ¼,ÖŠ’uXÌ2çIbƒ{{{uË^¡ö²Ö‡‘ä!›—½¬Ø icÇŠ3oðY2­ÍÌ^éJÖc/¡‡Ê^{{{{e`/ì¡\Næ³ÿ‰ŠìšøH‡²’q[4	:!MÖ0 ”÷PcÀ°ÓªqËõ§_£B‡©Y!+1fsU¢¨’G•ê‹¦+»XΦ7Ïûôæîz×´âãÿÆ+þ[ëcV¯zcËÅÍ
|ùðô?³CÛÿòâÓäæ‡á0­±Ù÷ÅÃ…¯Á³_ÕŽ+6ÿÖ>þ·âùTå“7Ô¦HžûÚ~73¹ËâžiëÄiÈmBZ)£–	(U²\T(f\¥­}Œ}H&kJç?Ïù·	çßõyþåpοLª$l‹ÑZé0	©Ø¬çßT
›-&ëI§¿ëÓßÁ	NžÀÃö²xŽR
óõN°e>< %ð>§%Âêà2%+D=n¯¤ò¡dº¦t†óœaŸÀà!ƒ—%¡Eúx¡bVi3Ì+/sf¡Éøˆä< á:ŽÏþ:¹æpaJÖÉBƒ/2Ø*McPš²Ð”…î°†*’‡
µcÒJ;ò`àóÒ"‰ˆd"}Q <μ÷YwG´¢dúÒL®õ·Éj=¡
*qqqW—Ü•¡‰dº¦dŽÐˆ>/?R|@À3ç®@ eýuŸÀ3/ƒl"š®+Ù€c´}J(ÌZ¹ÓHX#Üg  ðFÕF¢éº’
8FÐç%¨Jȼœl8‘€èÝìµÂ7¥Xà4“ºO †k,Çì˜Oœ•èÑ€Ê)ßD4]W²ÇhTŸ6@Ø(ˆ
”M\TÑc,€
P hº®dŽÑˆ>m€°
°@ŠÞ%n·Îh‚®ò`[&(Ð@4]W²ǘð}Ú;`€¹r‘¸$¸O€uÑ@2]S2Çhz¸S]%7ZìÈ5¸Æ¸`²îèÆËÔ$	Hxî­g¼ßï`äšëâÚP²ÞÒç†6<óãÝ|=ûm6§¡¡¡é|„F¥w¶fŒ‘hßs;¯€Äi;Bc53Ú‡Dú¬ç½–)Y.Zc.àh š®+Ðœˆƒ¬›8ÈÊõà 'wÌjŒÖ¤IË”=Ô»«×0‡—×l„scƒ{•ñe‘äWîŸ.oCÉ:r`apW¼™-ÎÏß-."	¿°—|¸#'™œdr’{Ú¢“›¾u`Js?R‚y¯²6}&ÃI);OT	|ÖL(e³rXJž*‡ýp÷?ÿó™8Œ8Œ8Œ8¬KZP¸Dj4ïAñœ·’ñ’÷\5 ã•lÈažgÝòÕŠ’§Êanç³5qqqqX–S<å²(—E¹¬›	Mò—–ŒKkF†3¯œÌ»Lœ¼ˆä¼“±™0>+ƽ˺m®%kñ˜bƒÛ6÷úßÿJÍn"ŸTFe¢2¢2¢².©L¶°SÃ+	ÑŠg\d]œ
HÎ#’cÁââTÁl€gà ™y§Fº’'’“MWk"2"2"2"²žˆLµ°X#péÅç%2@ò¦@rHdð·Åg 2ž™ÈZQòTc²ÄݧDeÍ©¬…D&11uÊ=¢´ôq/°òÒ9¬Yñ̵2Ë‚{@
çBbTX¯J^¦d…¨c\ëÊö7T€£
D“u¥*yž*¹á	UrÓg§Œ1õp,>§92Ú¯…Ý'*Bh"š®+Ù€c´}Ž|; ³ú¹	H‹©{tPŸÐPÒ“pz V¹äIgðZö‘Àåã!g“,i¤
~ì-&¶FR0cCÖaÏ64¬Y—~v|˜þþÃt²¾[N©SŽª2”Ë¢\V—U™äA/ÇÁó
j$sYg=m`!l€¤±XŽàNʬwNµ¡a
¦\gAŒfT„!æ"æ"æê¥
“<«è€Y¸V1ʆÆk36HcÏ™3:‘ÆwŸ±É£‹A2!µÅ/©9Yâ®rÖ‡ç¯5å6«3Û††§zoRÍp3.(C.-¹´äÒöåÒZ1 —60nÆWp¥h-¾û&riJR%ñ=WÛÃæX›<ååá;+ã7R“ñ¸{É‚‹nk0f‹¾«É鵶 ]§Õ³¤+Uú¹ô¤¨¾ŸÌ–”…%—•\VrY;¬Úä©./¢iÌš¬~ªç‘¸V
ÁK…§ïÿàyû_ZPïd¯Iž]Ïæ“ålý™È‹È‹È‹È«·|Kò —Ç¥Ã.†B™ã/ÍŒµv‹„œaÃk‡óg­„K™Šå’Ž™=iÐÆâ
Ç&¢ÉšRÖ%OÖÅÊ”¬‹êq€Ãšáæ[ñ°™„ÌO×­±h"™¨)€cL»ÊÒ®¶…§mQï0¹'8lØ aëœ{[Ï>Ñ®d(Ö1=Ü –X
`)€¥¶—Ö
ÈõàÆy±«Öga35Áz¦¹ò
EýWÄ~Õ]°6ã%^¯W«ÅŬÔ"ø¡fàLH.BL,´¸•\cmFæÎhíÖ°TÞ¨÷ºÖùn Z¨ýu˜‚O“Õ‹I²1¸œ-‹3S®ó¡Å°›ËÕsåÊìá_–þë%8
/¿”Úm¢*ÞTéK_ßÍ׳Ûùìrˆo¿;¹‡ ÆU‹» ªü¡ƒ€®®À5}ìxíû¦V líê³mx¦¤s÷‡Ù~êúIö™§¼í"s•<ô&¸bÂǤŽ=x€ºÁG$‘Œ‘8ìââ2iÀ	Î;ºÝŠ’õ®š—fh©«¿ý¹¸¡)JZQÒŠ’V¶:Þu)£,á´ÈL]ÒHR .l·ðx=»–Z䦮d%ëPP£"uQ½…¨‹¨‹¨«Kê-,Ò…¨ýÝ© .\öØ	uµ¢d½®w½d€8Œ8Œ8Œ8¬ž—×LÕ‚”Eå®Ï›
œJϽh”ŠÉûÜe͸¿GÖ0‡Ïù©’¢–ù=ÿ(jL#Q²ÇjBŠ
à}µ¹6®,Þ<Ü»¬×I’$Q˱³Ì¨H¡Ög¿­h·Ž¢D«/ Ù\…ÐLRPkµQkµчÙOkP9U×X‚û¤wXuÇóÉ­J0!ƒ	ìÕ:ç•d‚q‡HàóZ‰ó!úýœ	‘·¸TÇJQoeÉ’I×?Ï·úÞ‰ç‰ççü¡³#ž²¯^wš–³ÃÝ?SU~s-“<Âé=)kåïšH&4LSNîXGõB÷û'œKOÇ&yâé«—L˜âÛïäXÇd‘œNæíƒL×ðTwÿþ²œÜ¬.–³Û5õñS#	5’P#I—;
òRÆb•“»Üä¥x$‘¼,óð¨8S2;y¥jx¢‹“¸‹š ‰»ˆ»ˆ»zi‚LŸ£’	«c$”7‚)±SŒãc
yÖë†*Ñ°BÒÖ’,.<¬+™ª'e]òd]\JÖÅù»!=pÚŽ…z°i×­¥h"™¦(ÿ#̺>5mžÿŸ§xø§»bWŸ<ȧD”Ú”fBš9¬×a™6Hc噈Ïž³vG”©X!j˜Tf¿¨ÑD5¥“Ÿçäk‘pòµìçä'O=ßJ!ðXp¯lÆ“o83Š»-ÒØXpñ90éxÖ³_ªd…èþE¹n$š¬ë€z£fèN¯áÝ®¼0U§LGiÕ×d„W-LF˜ ÂH+f}»sLFH‚i8c<,‹~z®²ŒFìV²BT2_ó´7-t§¦IŽHî³{EuSúô¨-²!ÛNtÉÓŠV2n¥æ„49ÇŒgœÛ¨1`ØS\\8›“—Ë­…7huåx3*el#Ñ6Ô¥ˆ=“ožàšË>3õf@†À
&ÅPã qÕ	Å®ptf@1®•KI$D BÙtuÉŸȸ¾äÝdy5}?¹ø×äjºË$OIœ	U#eÐï‘D“Çžy­d1Ó¨uΖ³Vt¬ÓsºH/sö	ˬÂé7³ÅùùÛ›ËéŸ=çÙÚ;É“gÖ0ÁÿÍy“·¤uu&°‡ÅÏ„fðI‹úϺ²%EëÙ&ëŠJɼ×>ÓùþÍ`ÎGY—²OîR>óL:iäË yIÃc?rDâðÍCÐÅ=>[¦|’)ß(ÚP²Î‘À;œ‡ÖªüzÓ
L36Ô§L}ÊÔ§ÜÝŒOnO>38¯	†=àJ±¬ìe°A/"id/Lz8íG¸ÜìÕ†’§:$ºe¯Ó߉ÀˆÀˆÀˆÀz´	|@ü3Á0׳J^RÚ0oφÊâh$ƒo"š¬+%ï/yïmE¼ Zpf%ß$D2;³x+÷Ò…å.Õ®eJ•¬õO²6;Oµ5®™h²®d2í*ó)6 ‡EG!¹ëþLIf•S#»¹6"ùˆdŠ,¬Ò„g\ÛŸ9ŽmCÉS½óâWÚrD,°Àv˜
Éc!gZ|"|B"´u”S¨è¶*Ë pÃÛ\e&¯Vô¬UVgFðÚÇ7“›Ñ®#b0b0b°.L§Ç^`q7–Ýç¾LmHç	6–=üjCÏf°÷SÚÖGFFÖ-ƒ™tÓL!­xQ2 ù)F`Ò­GNá,äŽÀÚв^§sC£¯ÿž~üþ
剿ˆ¿ˆ¿:æ¯ôÁ5ðŽ<9*{å·­ÉJ˜`6þÀÄ‚X^kCÏݘþïÞ¼ý¯é
QQQQX}œ®l¢r>ÉÍež/ÕjŒ’‰\–T‹«×ÇUªg•¬«!J)Tª‰l²¾ÔË•§—+Ø„^® úìçôƒ2–Iù5Æ^+çejQ£gS€ûëš‚­l²¾d
ŽÑè>MAúœ¢â,ó¤Þg¯1êh

¨Xc±“¢ëš¦ LÏ*YÁ‚¶¶žÙh"›¬/™‚L¦À¤˜‚>§<çmØ/‹ŽëÜ^`ÖÝ#Ïd`ŸC'†`§’¢~ïÎå{“ÑL”Bƒ£42Ř^€°èpÖë #@³^dŽwÖ<é6òÔ¢g‚çŽbJ°ðÇ9:ÎMÜ (:è8lAÑ:¯ÀdZÅëgø:/®__\LW+êÛ ¢½¨èÕGÑKpÕŠ;«t$•ÜYTÄ´ølR뻳»”¬ÕOöŒTx¾D-¹³Çè΢w˜ÔÊ>üYÝÆá×ÜúNÚ·ÊPEû–tLYüAí[mèYkù8ƒófÿÞû:ež!'–œØ¯Ö‰5ƒ*Ò
æùT\Ãã­ðƒ.Òâ*!!|3Y*Òžb‘ÝÊ|ÙôQi™äfN€P[_¶¨Ì¦üÆ—Í=L׊ž§:M÷áÙjõ~¹ qpòhÉ£%¶Ëq:ÁÓg€H¸é†ÄJðG$fº#±Vô<Õ’ûñÍ;â/â/â/â¯~22~Ø	‘‹H%Ñž32’yY7#³•MÖ—22G™‘é·o>ÚÇD°Ã6 ƒÔÖ7“%cpšÆÀõž¼ô¬Âp3ÿ²iD2R×â…%Åéá$g“µ¬×5ÖþóöÖ	(´îŒâ[Šo)¾í+¾Cž“x^¤?Ì)0‰·FˆÒ–˜Ó›C·²_6}ŽžsÜÅËæóàèm¡áÕzñ¸«çõf[Ñ“ª4T¥!/–¼Xòb[â¯f¾˜³²°ë‡sHMï•y±Ò@!cÎŒr!n>t63}µ¢fúÒLš¡ÑדÕzBüEüEüEüÕ)%-J¼É$¨Â/‰÷–l0úr,è
{å¾ZQ’n­$ú"ú"ú"új¾LéC]ÄD–9‘;}¨íÊbøu&˜	ñž›=}Ø‚ž'=©tK“JDbDbDb]“Xú¸­`º(Lå'1€rî3LT'ÖŠš§=mûÛäš8Œ8Œ8Œ8¬Ÿn®Æn7Û¦…ˆ=Ã9ÉÌ1xÃH(bӞ̙[½±J•»¡«TÏ*Y¹¿ûË1n£RMd“²·ÔÔ•¯©ëévî†M]²Ïi%á‡d$3|eŸÁÒ˜²jcêË&ëKÆà(êÕ„ƒè&Š0w¸Ž¨ £

DÉ-8MKÐç=€Bò!YøÛ#$%ÛòšÉE¥,(%·1BmÙd}É¥1èõ0)†ìHÆyl:b[°GV°`\=·à^”,ÁiZ‚^w›ÈäY0ÇÑJ7:ðý<´¼f+}`!½…tÍãpd^KPªf…¨‚¿mpÕc£ “Fš· 0ƒ<Æ@§\
˜q³É»Éòjú~rñ¯ÉÕt§!Hª	†Y¥ð»©47:£!Ø árk‚ÛgÎXdSn…ÍYoEÉZ÷¨x†ŸI¾z8x4J:Ó~MüÍlq~þz>»ºyûSÏeñEdr³¾à†oFðûöZä$Ȉ¤"’¤±€ÏØh3Rð=¹Þ¹hEÉSmÖ?ŽÃ@="Ô#B="_YŸ£LnÖŽ.:>Ú…œn ©ˆd< —`ìÕÈ1ïF®éÖµ¡d½Aiï‡F_çr5ý؋؋؋ثSö²éÁ—„Ho9%kð%‘§Iì ‚×È^*3{µ¢d½}¡‡Æ^ó»Õz2ÿƒø‹ø‹ø‹ø«Sþréü˜VL»ÑYù¯pD$$¢ÇB(,yY0r]þjAÉS]Sõ­©"ò"ò"òꜼ’I„ÐÌ*»	‰lNò$ãIYY /×Py90rMòjCÉS]|=YM‰»ˆ»ˆ»ˆ»:å®ä¹§`Wjâb&o3SðHÐ8Æ]¼-÷ÄmhX«“‰…08ÞZýF´E´E´E´Õ%m)ÞJ³¡2#Ýx*s¯¡÷grÞøi
ò–ÌÌ[m¨xª­·ËÅå‚–QuuuuK]"=[(p‘w œG î#uYDDêR>3uµ â©Ö¹Vý'1111W§Ì%Óƒ.]w,D$îõ}¶PpˆR¸î"]ØŠ’§Z纥ÀÄ]Ä]Ä]]s—Jº,ÓÞb0"³†]€¤ì&o'ãÔ>öh`Ê0{ÜÕ‚’§ºÃ~µ^\üëÓbNFFFÖÏ{Õž
Ïœ)‚ʼfÃ1¶@qÐË„´Š[­Te
–Jj=³nŸ¤r¦‰h²¢´z*Ïê)ÜU“°ˆNñ>Ñ)3 óoX0ú©H1íÑXÆy#ÑtMÉ¥	½î¢Tv0& œznRV¤ôh8ãR5M×”,ÀqZ€^÷R+7Ø /°Åuƒ³X?²
$ÓÆ‘éüïùw½ž?Üóo™©£Ž=xûÚ6M×”LÀqšß«	Ã5šq‘Ö¾˜Íø½§Z±`H&«I§ÿ8³€¢ÏÓ¯ùpO`AŠÄ:z@`Þ‰&¢éš’	8NÐë••ZÈH0Ï
im ý¹¸ER7M×”LÀqš€^¯°Ör8…Ç´óðÎk#«$qºô
$éüŸj ôzþUË—ÒåÜ›i“â¨hœÖ©ar+®{-0¼úÒIÐÁnn¥«+Û‚¾d
ŽïR:¼…,›-(ml×Éí€J3|¼m™+ŸÓ ’öñ²ê®óXK&>k GŸusn+JÖil÷Œ«¡5¶Ç‹è~†júvÀ­í‡wLSg;u¶Sg{_£YÚ´À`Z»0Â]¶*¨¼¦B$}Pc-˜ÇgÉ!¼*3ƒ¥+Y‡Á P.ÑhX/£Y:¹/[y&„*"¢Ì±˜cÒ> µÃ¿ÉãÞe-Ë–*Y!jØãõôÏEAáA¢éºR&SVV§dbzÏÒn¸FC|Nr¤³¢AìNrÑd]É£À¸²O3àTšÁ³ ¬z(ÍvÀZ	™ÙŒ•x{Î	¿ï|{Ô©lººdº.Ì$Ÿåw“åÕô=DL“«éΓœÜh}<+$|o-69Û, $Ó5)çÔ(pf93Tí¨Y'Ee,˺¶Õ2ŵ͔§úß“å,ÒFϹªöNˆInF†ÏSãjaÏ™Ïy<¶8.0gÃÁjä±ïÇd­?¶ `ƒ!8Ëy…6r­sŒóó·?çáÀ¤Úí#؃œC#ž¾§ýGfG?	Á8;²¾ÌOÚÐvÿ¢ê݇‡3ZØŽ%ó:¾\£m}ÂØé)6Ò¸BX>{wÏ…e¡[3éV4æ4V»ÕŽã—³Ñ»{rdwŸŸ¦/ºó`öÒ;]É¥‘Uå«’—~n¨vÙÆÑ?SÌ-õÈxà“Î>Z½äpö³jsOy»ù3§Ê;‰ô9•‚b>äŸV—CÛ<žÛ¢èb±.þÜÝÚÓãá­Q$­Qüi¬@e©4'àÎêbÀʲéþzæ¡pµÕKƒ«(¡Ö(¢6E«(¤Ö(¥6>;Ê©
ªõKª¾uÏ
«;}èWOœèæô™Üñ~QŸ
Al`|¸œÉ˜`PΙ0>ÃÎ~à$ã΄¬Ù˜Vô¬·ËY®c(Æš7kêw¥v!j¢v¡.û]N¯'H0¹H#Ž¹Ì†P¡€²‘¤fÜâp³cf
kEÏSÚøþ¯¼[C%º^‰ÆˆÆ¾63鑘gÊk‡æÝäŽÄ|\ĉPz‰‹?(B³¼‘Xzžê­:?ÿãõwŸhtƒHŒHŒH¬sKžØ83À#Aš e&1ìØ@$1ˆÜÅnŸ›ÃZQóT³‰¯‰ÂˆÂˆÂˆÂú °äy£3)˜–ZŽL`"3…!”+ xŒÃž­À+ÓòRX+jÖê´LÊAÎИþþÃt²¾[NÏÏcãì‚8888­—‰zãÓ“ŒÀ0œ›Ør‘›Ü<3Ò†-Ôø‡[
7‰uºZctåzVÉš'ïkkz`lTª‰l²¾4G—i¦Ö¨”™Z£ûœ©5aHÖ@àå§P¬9Jk`™QÕ+’Q–ãšÉ&ëKÖà8­A¯ö–ÚHfŒò©yãž}fyÔ¡‰l²¾d
ŽÓôz'²mX®MLEå7>Ü#EÏ@À³ã8;•¬}Ú?^a4Òzê[<Ü_évI¸ýåV¦§¯áKg¼ŒS¹#üÀ/ î»aƒ„8‘¿¶=ëä¯ñb£Á•`çs§d5%«)YMÉêÉê׫ÕâbVî¦&âÚ!#tä’Ü=‘öéµPÚ'‹r\R@i:	(ÓÇ+ã:X3²6{@	PaJÍŒà
ž}þx²5k­k¥†O~˜þþýì·ß( ¤€’J
({(“ç+!¶³~Ã%¹iL2o„ÛB!²
¡˜ÈN–jY.Šu/]u0	qШ©,•6)(¥ †BЯ4!ÕmÖ4u‹!è>OŸ-•ˆEÇÏìa€2”+2Âx/Žv#/$ÔÍ—éY!‹ïkoFx³x¡‰¬_Mïò·ßÌVïf7ÿš^þ²Ht‰Üû£‡§+U)½LÞ¨ýé4Kê>6R{úÌ­@J²©tS/8G€Â™[÷HtAí¥zVÈÖ¡ëí>Š&²îXº‰Ú‰Ú‰ÚéÃ;aj7IÔnû(û6öò*×Í"
€Ú.³(iH$óŽ6i´¢gÍûÌŒä&÷ËÙõdùùÃôw*!S	™JÈTBîe†M™—Æv1'c
×>ÆIÇdüAÈ¿@£TÏ*Y‹höÉ
®}3Ù@4ŽtÆÜÄ„zÔÓ†ÊNfì\ò¤<^†g¸ÆAï̃òˆÄIÇȱPÌX|KÙ­mEÉ:^-xÏvhNmï7ò’K~,ù±_ÙrS—¼ÕAHæШ{“»Î‚H¼@Š­ü>»ì­ü­(Y¹Bsýy='ê"ê"ê"êꔺ’›xf
΂!¡ä¥.@â¤x±ð‰’\!uå¾X¢%ëP—‚×uý_Jâ.â.â.â®^ÊNµÅL¹‹™üœ$˜ó^˜-’X,&¤Ñg½´2%ËE½ÚÛ·˜W¨PQCË5´nàxJÝÀÉ>—k:=3 DQ2¼7šqémb¨G3 Î75T>
—±/(}B]@äÉmyË„
>뮿Þ@‰àÇgHŸ=Ó"ø¼«ÒÚPódÞ_¿þyŠß®éwëÉš–pSÆš2Ö”±îagšsí\£\„&3!|1—
D†ÏÞ1w8tƒk`v©Y%+Wïη&²_ÕÆ•Õ,~nî.æ@q³Ëé‹p¯¦+
Z)h¥ •‚ÖnƒÖò;ÛØÀb;	Z“Ç´ãV+ÓÁ”6 ‰
RÒ–¡u3Ú­(Y'buLr@ûÃôwši¡P•BU
Uûj®
-TTƒºƒÑl¬Uª$l®òøœVË­[QÝ­d…¨gVVGŸÛŒ¢éºRWE.?6i(ûi馓¡lÏÛØÌ ¼ô#c˜0ZeÞÌ ÕŠk¯,æþ?»îŧmèY«ú¢™Rƒôf¿ƒÛþ¾[ܬ'3øm¾°c{¸¿D~-ùµä×fökž¢S;ÝÍi"Ó$³6ðhadÖóц’µR@XšÍx:XeTÞÓq~Þ{i³iòÄ™ÑàTW¯³™‘ø	¾¨c˜ô&^ˆªµÎڜފ’uŽœv?´äèwŸ&³›·Tæ§t(¥C)Úåþ/Ÿ<\e,óÇmëUÎê>"é
’Ral9.]v8Z”ÊÚ§ÖŠ’§ºÿëo.nˆ»ˆ»ˆ»ˆ»:å®ä9*#pùq'ÜH_rŠ“qWJžjäõöf½$ö"ö"ö"ö꘽|)uÙ
{!Ò—ì¥Õ&ÊÏ^­(y²;-ðþÆ_YNnVËÙ-ma&##ë–Ç’çƒ,Ní¨.x¸W_d“BuÂc­(Y‡Ç<ト6G„(Œ(Œ(Œ(¬K
ÉCnÊ2qgÅ,svƒC1¼äŸeþP¬
%ëP˜aFp» .H"ú"ú"ú"úꔾDˆN‹‘ÙË`šÙPÅ*˜cμ3"{¬
OõêÑïÿñšh‹h‹h‹h«SÚ’-$5×­º3ÚæM*³AâÚŽ­g>>ã~‘C‘k'Ó•<ÑyTù"##ë‰À’g†5ß47&ó^ˆ¤7H1m¨™‰È
'y³†^­(Y¯ÿP®ƒ’†D^D^D^Ý“—n!ièq˜Ø	D椡3·al<Ó5^
’9i˜¬á©}ábrâ-â-â-â­NyË´5”\v±n{þŒ|X·a
39ÿºV”<Õ +®Û ò"ò"ò"òÊ@^ßOo§7—Ó›‹Ï;,}å†gRZ<¢2/ŒòL¸¤±ÅgÖŒg.\q«µs´TÉrQxWüÑ»ÚÁ‹Ø Q(PW4í·|„ûF/—“?~}zç\›Æë„ššÒÏk,4
ožÛqOp-¬ö‘‡.쌻ò€„aŸ“rKõÌL™Žå¢`;ü£í§»EUDSU¥­Æf[ƒîáÚžà[Xb•€’³ÀλÅøɣDzrÏ
¢g£3¯FIWò´¯ìù\‚Õùw‹ËÅÍ/}(l¦°™Âf
›;Íù&˜kœŽ³]Œ˜’÷ö‹E_Ý»NFÌ[Q²›ðƒ×h3½NÖ¿þ<½¢!s"1"1"±nILòä!s혰]4Ü ø¢á“4Ü´¡á©6Ü`Âx‹x‹x‹x«SÞJž.WŽŒK0±—·ŒHÚo°áF+@´±áFen¸iEÉS]ŽòãÝz²^,‰¾ˆ¾ˆ¾ˆ¾:¥¯ä)sm˜4R eW.ëÅžˆÄ7HR™±Lk[`¬LºnsäÕ†’uè[aI_”6$þ"þ"þêš¿Ò/¦À&›þ
›³‘€¤Û	iCc6}"kGÖ¼uWøAvqü¼X¬‹?ihHŒHŒH,‰ííI–èêj9½zÜ‚½ï{X²µœÏ>%úôzüôDÚ§wd“k¸©=Ûµ}û˜»›N„ÒqpÛå]¶HÜHç×´aŠo¶枎/S²BÔ1óhª®bb#QNãñÄÞÄÞÄÞ_駗a±Å“v{´ØBuÇÞ²½+^$³¹;õòöLâ…»,E
˼›-ÊT¬äL9aë°|Ñæ_uûÍ5n0N¿>†èœèœè¼óRB>`WëlO•LŸ¹LÇOö™˜ñ*Ž¡ã}ócDVªd…¨dnOvÜrÆ*Ô@ôÔ*i´ªêà¡“T±—]¬ª’é³<œ!b]Êq-rF¸X½@²Flâ¸ÚÝy<ó"몪6”¬³ªJ²0¸K?üüVTÑŠ*ZQE+ªº¼“D¦ßI¢™Ñ¼ê$øÔÅ™à¼êjEÉS½òÍlñ~ºœ}}}}uJ_º…¹á±†¡|î9ß )¬ÓLûX/—ŒÉäU!*0Á]Üca2×Â<“æi¬!"$6‘Ôjr.U²BÔ`ã¢Ø3Š¤4*Ð@4YWZ”iÎA¦Ü/‚íÀ=n
“a@fÀ2«ýƒäÍÂPÍ*|3Q2'jTo[ÃT{ÓËÙ·†	P&¶¦X®¦—qï^7ÓË{·†ÝK*&á=VŠ‚:Õi$Êý×2½¡ø寳_¦X_¦O¯ßñåf»Äžzº³ñe%ZX%VÄœž…ÌCœ)/Ìé>²OëPª»Jl·’增3…¼…šˆ&ëJã˃dRÌ`ò/ï±1²µA0‡«2ÛíuŒ²97cÉÀõ²e:Vˆ°FfÙªP§®dR¿˜A•²ƒEÚÞŒ–ÑEaÝZ,´»…áÆî3>v
4-t'C6¦©qùö<íK|¦ÏBø‚Y9çOfíæ$‘,Ó*è1^1ê­ÙÀ¸4YSŸ¥JVŠ*x—ûîHU¨@ѤÕÖË}^,§´¹‘’g”ú¤O¯ók¬NZÄ,ò-bÞßÑ ÒÇ$sàÐò´ÎHê€àB¸GK‘ Kβ†
¥VˆzV)/åu¨/—¨"u1ä9ú>%©2^€XÚ’¯’çÊ„`V¦}%kvÁŒ+`¸ËØGO’zH½^ütíê4âÉô`[ñÏÏž]|žü·äž‰ Ž|êȧŽü¾FÊTòH™0,Db1yù`dƒü~œÂ'—›¿’µ«Å_‚y1xþ¢‰2â/â/â¯^&ÊTòDÙ}nb¢œDfY˜±E“DyÖJ¹ìÖ­BN³êîxãÛZêʸcùôiÖ¤aÎÅõ9>¦BÉVåC<Áä¼*ÏA<éRL¶zD6ù“­;5¬ÕõN>ûÁûp¬‡¾4PÕÉcb"0‹µ¥˜2'Ç¢Ž¢p®Jâæ'_f¬Ì¬¶ áWn}7Y^M)^¥x•âUŠWóÄ«{Zÿtò”÷Q¸¢†.òv	x¦íÒ<:-ÐKÌî2׋ZË”¬
ðîd¥gªq9th ‰µË4MÔø÷i²:›PßuŽQß߉zâÈúþ\BLú$žåD¤ÉSˆgœÙ€³;ÒÁåIÉé
‡˜TX&¹ñ#œ€Î“¶¢c­ Ô2o”¾_ή'ËÏ›RlJ±)ŦýĦɳ¯`‰…ÙKÞD+ñ{ 1ÄiqCŸÒ	lZ/0-Ñ°BRàê¾êv›½m š’Ê^`ú‚Ól¡Í·ßˆ¿\ŠSéä°µªƒBËÒòÅTÍó…®û;(´θš„/< =ÔUSI0×ÀZµgoŸûF’_ÛMckO
€ì֤ϫâ·S„Q`ÎFVwŸãÕ1z‹4Æ{Ò Ùg­D•*Y.ŠM{bÐÇ‚>õ%Ó5%Ç”wQfL@'Ïžžákîà+¨˜ÄÉùŒh„2”p\ŒÏ´€ `˜v\dMB·¢ç©^Ëûý›¦ë‹O”r¦”3¥œ)åÜåø©N?=3‚9äÏœäÜå¤0€ò=»g“›Èªà]™Ò,ø‚È\öX¬
=ë™]†Fd?ÌæS"1"1"1"±þ–)èäÁê3\Í.Yæ•É¹OáL!‹I½AŸÉÁ {æÝá³)ÐÌp©·Pcı“*µmÁn=«dÅ“ò®®™6¨TÙd}Éd2&Éô±íÚ¤¼iËB¬Äû„LSMPf%7àh]ç2w–«
=ëd¹4ؘ¡e¹~žþF3n”⢥¸úJq•Ne[Ë0»yÎ0Å €Ê³ñI4ZÏ-Õ³JÖ2[GÖº†²Éú’;›k&i“¨‘}ø³:½ýÈÕL”cª×~䋪-@ÉXµ5†	?pL$VRk´µ¡g›\ÕhŠ¼YòfÉ›%o¶oÖ´R¦QZŽpJÞܬqŒãàGT”i< ëŽÊ4»´¬Õ5J/—úGvl"›ª.¹²y\YÁ“ê4F÷áʦƒYŒÝ\œGä™S³Ë3¨ÏÀŽ
ˆš©Ü©ÙVô¬×IéÊžŸÿôæû·7—Ó?É©%§–œZrj»l¥7-Ì„Æ‹sŸ}& 6cYE+½‘LD&©ìR#)Ó†ž'ÛJ™ìÍ÷oˆÄˆÄˆÄˆÄúÉ̤†m	%;›ý5Fl¡“cÂz¹™R=+dýÓÒÇn–ÔMeÓõ¥äL¦:ãÓôJÃäŒíµ‰6Êàm ¬aÆÉT¿ºgk`˜ÝÌÖ4õÔQ’Ö «múLÁöŸXCpÙ@]®è:Ð)^Ìü]mèY¯‹Vîòˆÿó·ß¼£à–‚[
n)¸í%¸µbHm‚%O«í@0í¥n(ë¨íàÛ,ï×MŸ“¿½
¾˜FÛƒ¯Ù¬eJÊ¥@ÏÚŽSÛ.Œ]Ó—mEÏzÅ1¸Û¹˜Ìæøz‘;Kî,¹³äÎöãΪ¹³J0ëï‘ÀUŒ›H/!F3º³òñÛÚÅðz<ªÐDÖ$ªKîìqº³}„Ùô0͙ٸy!³;PV>œñ™RÌ™èÎzÛmEÏSí=úçÍ¿\“9ù³äÏ’?Kþl?þì¦Â”c v¥gÓŸ{}TPIx£ʦ¸
äϯ?ÛÇT˜µm´xôóp‘\°6s«A(mÁŸÕb\üA×æn5H×óTÓ³ofº#ŒÜYrgÉíÑuCÚ@ks1;7ÐN¤y7Ð>"Ù]$	¯‡Y×F²Éú’G{ŒhmÆNúדùü=˜ÙÉÕt§)háº%…&(¼SYj™÷º%U¤J±ý H¼nÉ2%áÈIÏly[h[ѳŽ_¬Î¹‰V0}()ý¹~NÑ×ðý˜Lñµ{"SzTñ@>’{î(ŸŸÿæüüï?ü°ÓY®xó~ÍÍz(þ|#òÝâŒäòËÜçÙ'°ãS£žòøX–}ec›©œNÃ{ê¡Õòßåêæzºû£*!¤
”­
Ý|O+¿øõ
ëëÕjq1+w±Z¸ø'€kÌH*¼%5ë„
Pcü6~qüá6½¦‹U¦g•¬f/“EšÈ&qØé»X—³eሼ¬£D#溹\•rË^“±„¨«œM’¬ÑõÝ|=»Ï.fëÏ™ &Ëåâ]¯]Mtuýã°µ}ËJŸÞ?½Öƒ#ï’‚£Œ·v½›,¯¦Á‘Kž/tšYëìH2Åõ9|‹Ä™A¤qð?|±=ǘ¬‘Q+JÖ	Œ¶ã𜡑gÎdIúC³œÜ~š]¬zÎü·PsÉÃJÂvãÁÝbÖd>€Ä¤x,¼`AøØÜ™ø]Ý,ÚP²Î±0̈Á)L'ë»%]ÎLe0*ƒQ¬Óµˆ.yÒÎ&
Rñ™½:@â‡8é+0ÈøãÌôÕŠ’§º1âïóÏ·ÔÃAäEäEäÕ-y%OÖ¹]÷L䎽6äHE쥘ð>öRhž9%ц’uÈË3®{ý0›SüEFFÖ-…éâ/ÄâR’xuã¯o9æ·ñ—3…‰ÌYõV”<ÕøëýäfJ#¡D^D^D^9ÈkOw—Kžu	¡°åsGaŽYîï‘ÆwÄÐ($ ×jí*U²\Ô>­!ï•ÍDÓbÝAµu}ûͧÉêl’ÌÔéUÚš|ÓZ?25~õþa
ú0;êþ‘„F0§ò5‚í£ûäáo/˜·¾ºG$ñ%Ý{f¼C
t<3Ý—*Y.j™Ù+ê@ÕH4-/00º¿[MWÄöÄöÄö_5Û‹cg{׌íulŸ<ïq“Š]:¹óÓ–y#ì°e{…Ï¡èÏÊöeJV‰úºÞ@ô+b{šÙ"n'n?ý®ã#ó¤m9É|ï—o¡aÊë GÊ1ïµËÛ0U YÆiÓžµÏ™¦Ò•¬Sm–‚ÙœåfÁ3­m;?3û8Ÿ-3¿õÅz÷‰H^MàÜæ˘VyO„c.H
Oú·NÀ‰Lä>m(Ykª‘3ídÖ}/îø÷½|˜N_ìüøj9¹¦­/‡m}qž‰Èœ9héK‹K_J{Ú|ò¤¸žY°l†Y-³.ÔC$cÉ@)™ôx
­#׳©­(YǦ*fåÐzÚ®!0 –6ji£–6jiëe-¬OÞë ¸g/†5^““Ã8²Õ(}èTò¬•ö.S±TRãfÊêͱñíËF¢éšÒ.ØL·H’+ó¼·Â—OŒ×’9n¸’ÊI.3éÀÃa„—}hƈl90kµ–9-@©’å¢1§C•(*ä@¡f¢‰º¨Íåv¹¸¼»˜®^¼Â㱺»¦®*¦P)Œ>½®KaéY5!÷'{Þu‡e0Ÿ¼7@H;rGR2
´“Ó¹ß"ñHæca±Ë%–ÅœâY“þ­(Y+A…u6Ÿsu€ÐLZ«2ÕÂ>L'ËÞo1jñxèôãa˜4¸Óï|ÖàwuÆá»*$Æ¿6Æ£#þ¦öyS¸­èYëˆx¦°X™ñˆ8„Ád="oÌ!Ù&=
­™–ißÒz'ëÃÂm‘ÆÂÀsˆ«àùáÜU/?T¢c¹¤8Òëjɘíª/™ÆÑÖ‰E†Ò§W]]úšCŸ–÷U=ÜjëmºÛkwS’>sTH<"Á¯¢BÅ™äÀ‚ôI¡Z
Ÿ·%OuÏGør­©oú¨oúºÜ#ç“çô„»îdfòB$~Ï @^xÑX$/—›¼ÚPòT¯cäõç5­’#þ"þ"þê–¿|zðb„·"羉G¤Mð….[ÓÎ|µ dþ
L†¡ñ×1ˆÄˆÄˆÄ¾6éA˜ÃÖÍ.2ˆˆôeQËu‘AlCÉSÍ þ1M>yyyõ3ùÒÇw•fœˆ\öPÌ3¡î‘ƈìHäÏz½-eJ–‹Ú§âîžKቦëJÓO¹ªà>©
nóUÁk˜1 3 f—H©eä3AÖÒ6MוÌÀqš׫C6ͪ!{ €÷DÉ8U3zè‰é“R&®¤Å.ì dÎõ¿ˆäMDòp\ÆÂj Dx6à&ˬ׃·¢d½¶熖Ñú¯ïÏÏá·”Õ¢¬eµ(«ÕeI&è6úâÒŠbÒç%0Dâ’BÓ¯jC3*3µ¡dÍýžfp5™Ÿ§«»ùúü¼ø›xŒxŒxŒx¬[kaÞØ2kîÙ%ëÀ1 <&b fÓ.ò˜Îˆµ¡äÉb3à0øƒŒŒŒ¬[KŸ®5œi¡GÈ…«5“È™²ˆd 挎wyŒ\7“Ø‚’§Úà]ôvÿ÷rôC$F$F$F$Ö-‰¥OÙâ\ˆ…„)*d-†#’ŒH@$:’˜äÀ?¹nÖ‚’µ²‰–ùÁeþÚf™€=*~DŒFŒFŒFŒÖO×wú®1Œ›€QRöøL0a¶@c<$rj½6¯2ËE‘¢T¨îÝ}d}Át=©Å+S‹W°)-^ÁõÑâÚHÌX¥G‚G×2sb&®öåñ¬Œ…Ì[xƾÏü‰™d%kù´x›çàJ¿üø®ðgÉ•%W–\YreûseçCre5“<<ø²Àh¼`¸p0£eõeáVŠ¢À“
DÓu%¶{6›Gª¸hc”…S¤8“FËÌ» Ð-D$®å÷ØsðH•d†k™{T²’µ[`ú´"yæþÛ‰ƒ"‡;kYÇÿj,8K­GÛ¹Ék	Jõ¬UŒk竇g@t#Ùô%KǤd»…T½Ú1h[ 5Ón„£ßÞºö'«)K*‰>ª ›ˆ¶ -‚ã3Òë’Þ"}AðÕ
.\ÐAåÌy#’°’VvŒ78ÏÎŽÊšñnEÉZ	oÉ’®¿î/áýz>»ºÙüE›8)çM9oÊyw: TTæ	Ï$2c^*ó<"	/d¤2îåHr¦½¹©,YÉ“ÝZ©ìÃ¾ÓÈdDdDdDdDd½oEú8BlÒ!’ÍœIÍŒ¿Gi™Ägí|y·•)Y!Š+°uØ+ªe#Ñ$¿3ù3ø©$TnEÆíëÕjq1+·é	X@°a$$SVfõjIs½E£«©}ÌÏn|Ꙁ2+DqËw•¢Û¬O#Q‘¦ë`LÀ·ßÜ.—wÓÕ‹Wp:®Ww×ÓU²¿|9[ée-7—«çŽË5žÙÿ,ý×Kð^~)µÛrU¼©Ò—¾¾›¯g·óÙÅlý9Äd¹\ü±ëµ«ü ƒ€®®À%}ìpíû¢V l­ë³O‰>½á~z­±»(cwÕ"?¿›,¯¦ï!š\Mwtú¼WL3ÒqA`V'}‹Ä™¤±Ð‚q1²
wbä- ´¡c¬“rxkuδg6WÞi½¼»Xß-§=gÚHƦ_‹$e¼·ÕDŸ2oè*ãå´€¤Œ.BW%ÍÈ
œEÍ{,ÚP²Ö±`V-ûz½¸¦ü+å_)ÿJù×N‰¾eÓͺÅ6ó²iÁ#’ˆÜ¥
?Ëx\Ïis/›NV²wi&7úݧɌŠ‡D^D^D^Ý’WúÝ];Œ!TÇ‘«ÌäH@^û¥càe
F‰»½2“WJž*yýíf½üLäEäEäEäÕ%yIÞFäe

qù#/Ã#’ÝF^È(FF2Ëy%+yªäõãâr:'ò"ò"ò"òꔼÒï¨Sš¹"y2“"ñˆä#yiΔˆ%/‘›¼ÚP²yfį¨›]ÞM‰¾ˆ¾ˆ¾ˆ¾:¥¯V&ÁæÔTöª"ñˆ$¶1‘hòW½ÚP²}96¸9ðûþ%šÿ&##ë–ÀÒ翹em»Æ™µ¼¸€Ä#’ŒÆ=îþiËLnkCÉ:†£8Cc°·?ssssuÊ\ésÞ\ã!{Ù‘xD*Ê^‚3.ÌȈüe¯6”<ÕÌáÛŸÎÏo/?}}}}õ²¯D¶°«À1©Š8(¦ü=RŒÀ¸OeКË
J”¬uOÞU‰¨h"™¬)m+É´­D&Ýž&uoÛJdú04°-Ùkà*fòa>ZåÁïÓ8‹™Ý”)Y)º÷\ãì³h"™Ôg0°e%Ÿ&«³IëIÄW¹žäÛoÄÎ_.í»ä‡ys²¦8’å%«ÉücºÖÍÈ^ôGö®õ„8½ª}þnmST=|,ÛÙK¦6k«Ü\_¦c…hx²eƒf}É´†xâzâzZfE«ÈˆÍ÷²yHbsÞ›û666…È42ÿ¦ ¶@‘Ë9<ºÇçåòÝ–Kj\¼—Ÿe#ɤ¥"ÄäÄäÄäÄäÄäM™¼áÊpß“‡á2yw)ø,T^¤ÕëK~=	øW´œ²íDã”m4«÷˜mWé»Q6™`™¿²Î™Q[ .ãó
Ë%)>'R§pŽXœ>½ã¦í§‰ñÁãJˆ¶èKÚî°.oS0N¼MÁ8Ñ8ã§Éê}ã²µ]oá	?eȱ»âJˆ	xÝrY™pëW]^/Q²\ÔòýC1…RD©fN5s¢{¢{¢û.é^仦sÿtªJß$UÑDnº¸’Pò{¤1"žz'GÍÂx‰’¢–Y£\"zÉdMi:5×1–I¹¸ÐŸ×ޞϴˆ‡#÷Ý8€¤lÜ3YdãD(ö®Ø”x¡æ|z‰’•¢rß¹Þ.Îl ª¾¢ùÔÛåâòîbºzñ
Çêîzºê‡§R9íôé
÷ÓË¿|¢á‹Lõñ‹çùäótùí_Šøÿ«åäúÛ¿ü>ÎSYBioPerl-1.6.923/models/coordinatemapper.dia000444000765000024     17414712254227321 21010 0ustar00cjfieldsstaff000000000000
#A4####Bio::Coordinate##MapperI######map########swap########test########Pair##########Collection####################ExtrapolatingPair##########Result######Result::Match######Result::Gap######Bio::Location::Simple################################2##create##########Chain##########GeneMapper##########Bio::Location::Split####################Utils######from_align########ResultI##########Bio::Location::Simple##############Graph######shortest path#########
BioPerl-1.6.923/models/map_proposal.txt000444000765000024      1313712254227321 20201 0ustar00cjfieldsstaff000000000000
Map data is a critical component in many aspects of genetics and
biological research.   Well defined toolkits for manipulating map data
do not exist at this point, we propose to build a system for
manipulating most types of map data (Genetic, RH, RFLP, Sequence, and
LD).  

Map Proposal

This document proposes an object heirarchy for maps, markers, and
their manipulation. 

Key Points
* A Map is an object which contains mapable elements.
* A Map can be defined for a given organism or population of individuals.
* A Mappable element is an element with a position within a map.

Background information
 Maps are made up of elements which are mappable.  This includes
 genetic and physical markers.  

 A genetic map consists of markers which have a given recombination
 distance between them.  This distance is usually given as
 centi-morgans or 1% recombination between them.  Other distances
 include ... Examples of these are the publicly available
 Marshfield and Genethon maps.  

 Radiation hybrid maps consist of markers which have been mapped to
 radiation hybrid panels.  Typically these markers are STSes which
 have been processed on RH panels.  The distance between markers is
 calculated in centi-Rads which represent .  Examples of these include
 Whitehead STS, GeneMap '99.

 Restriction Enzyme (RE) maps are used to describe RE cut points in a
 given sequence and can be used to "fingerprint" sections of DNA
 (typically BAC clones).  Clones which share a statitistically (based
 on known frequency of RE cutting) signifigant collection fingerprints
 are likely to overlap.  Additionally 

 Physical maps or BAC/PAC/YAC maps represent clone fragment overlap.
 These maps are used to to represent how clones overlap and form a
 consensus sequence of a genomic or cDNA region.
 
 Sequence maps represent the known consensus sequence for a given
 region of typically genomic DNA.

 LD and Haplotype maps ...
 
 Comparisions between maps from different organisms can yield useful
 observations about trends in evolution.  Additionally comparisons of
 maps for the same species can provide insight into information such
 as recombination hot spots and DNA stability.

Object proposal
 Maps are objects which are made up of mappable elements.  A mappable
 element has a position on a map and can be tested for equality and
 relative position to other mappable element positions. 
 
 These are some baseline interface and object definitions.  Other work
 has been done by Philip Lijnzaad, Emmanuel Barillot and OMG folks to
 create definitions for maps.

 Interfaces
  Bio::IdentifiableI 
    string    getID // unique identifier -- this goes with Juha's
                    // identifiable property?
   
  Bio::NameableI
    string    getName
    
  Bio::AliasableI isa Bio::NameableI
    string    getAliases


  Bio::Map::MapI isa Bio::NameableI isa Bio::Identifiable
    MapIterator	       getAllElements // for in-order iterator access)
    ?Bio::ChromosomeI? chromosome     // Should maps be build one per
                                      // chromosome aggregated for
				      // a whole report set.
    Bio::SpeciesI      species        // use existing BP species object
				      // which may need to be more robust
    numeric	       length         // not sure what to return for
                                      // relative or RFLP maps
    string	       units          // Map units
    string	       name	      // Map Name


  Bio::Map::MappableI 
   // Where to handle the fact that RFLP 
   // Markers have multiple Map positions
    PositionI position(MapI) 
    boolean   equals(MappableI)
    boolean   less_than(MappableI)
    boolean   greater_than(MappableI)

    Bio::Map::PositionI 
     // may be undef to handle relative maps [RE].  
     // This is where a known position for a marker can be retrieved  
     // Multiple positions are possible for RE on a sequence map
     Array  positionValues  
  
  Bio::MarkerI isa Bio::MappableI isa Bio::AliasableI

  // heikki to help fill in Variant and Allele information
  Bio::LiveSeq::AlleleI

  Bio::LiveSeq::VariantI isa Bio::MarkerI
    Bio::PrimarySeqI getFwdPrimer()
    Bio::PrimarySeqI getRevPrimer()
    // I assume there should always be a primary set of 
    // of markers which defined start/end points 
    // should this be hidden inside more methods to 
    // handle RFLP, etc?
    Bio::LiveSeq::AlleleI getAlleles()
     
 Implementations
   Bio::Marker::RestrictionEnzyme isa Bio::MarkerI
   Bio::Marker::STS isa Bio::MarkerI
   Bio::Marker::Microsat isa Bio::LiveSeq::VariantI
   Bio::Marker::CytogeneticBand isa Bio::MarkerI
   Bio::Marker::VLTR isa Bio::MarkerI
   Bio::Marker::SNP
   Bio::Bin 
   
   Bio::Map::Cytogenetic isa Bio::Map::MapI 
     
   Bio::Map::RadiationHybrid
   Bio::Map::Genetic
   Bio::Map::GeneticMap 
     string	       getSex         // code as a string? - only 
   Bio::Map::RFLP
   Bio::Map::Sequence // Should probably be Bio::Assembly or these two
                      // need to work together Sequence Map could be 
		      // be built with Bio::Assemblies
   Bio::Map::Haplotype // what would this entail -- SNP components?
   

Caveats, questions, etc
-----------------------
Namespace is very flexible here.  

An important useful result of this toolkit will be the ability to
programatically go from one map to another.  So Querying Maps for a
marker - perhaps based on that marker's unique id will allow on to
compare distances on different maps or go from genetic to sequence
maps very easily.  

Not sure if we should be doing a Bio::ChromosomeI or can just code
with a string/numeric?  Does Polyploidy cause any problems in maps or
just in population/allele issues?
BioPerl-1.6.923/models/maps_and_markers.dia000444000765000024      1452512254227335 20740 0ustar00cjfieldsstaff000000000000‹í]]sÛF²}ϯP)UûDµç«çÃÜx+ɭͦ*ÙMŹ{]°˼K‘
IÙqîo¿3iI”
8P¤;)'&ÔÂa“˜>Ý=Ý=ýÛWÓ“åb9™Ï¾9åÀNÿöê«¿^LŠ—þÏ墸:ñ³exõÍéûÕêúå‹?~„é§e±š/`:¹eùâÿŠé´xá…^œ¾úêääî
.ŠU®­¯«ÕbòöfUžÌŠ«ò›Ó·Åù.ó›ÙÅi-µ–;ŸOç‹“Åô›Ó¯ßUÿœ¾XßæŽû´Üûº¸.Û·½ºž/'^dõéúHÃ}ÂïȬ¥–^hvùêëoÕ×õ[Z_¸½×co´duU,.'³‡8‹²˜Ö„+6ŸBw€·¹¦¹¹&Ë7×óÅjQLVAÞÎçÓ²˜Õ8«ÅM¹;Îò¼˜úG¥M¾ûÝßMV«ùïÿ]1]Æ(P_þ¼jº®ÀËÅä¢}Þ“h¸ËÇÉÅêý›?2}\õÝ?eºû‡ÉròvZ>öî'³Uo·ÿ”xûÔïùfrQ.Ÿø¦ïË4ÜéýZìÅSŠoËÅjP_Ú"§
bZ|*ëÛwKK'ëÏx½èï|
ó·ÿ[ž¯Öêý÷Ï?œüä-Tù‹ÿåâ²<½%Vvz2¹øæô_ìþG´­”¿¡7@>£ëùçïòÌ—\‰‘Pà¬QÛú?üb›p޾݆YxeŠÙå´Ü†’À=ÔXX`ŠóZ0ùnÐå´¼zs>_ÌÒnïjVXÕò~¨êfiKn&¼/'—ïW-Œ5f7„-×ãžãñÝdþòåOóób埱G}.HËU¹(çáY~¯ýí×ë‘´Bxê
P+qÿ˜rs…|†ÐC‚«/€Û:n…ô£fÌ
áTÆåÁl¦µñkùÎ?Ó³óòÇkÿ`]‹¿B¾›ÿñÈÂ},»ybTö…!7P.,í©Ã›s¿0¬Î¿0ÒÕŒ]Ì™ÌkCîvÿÉÌLoª(zûþwCëþÝ
bù~þñÍ#ñûÓñR^
‘©+…KÿÅr7â Qh—q¡lÎpe$EVÐ4ì¥-£\,φ9	‡"—õsq}ì¡z\Š£Ê»&$VHè<ÒÑ? Õ‚ð/Z»«³ ”î,Ϲ&±FGÖÀäÐ\ Áµ~LfÚøåyƒU¼a@¿H0‰&kdÞ‹–Q´áí€Ó:¯{%võ¯"ˆcñŸrqÜ¡û\cùÕá±ÆB{Ìêh®3óH/ŠÆ,ô³6"'‘T™ñ\i¬-.‹Ùdyu\bnè5–aõ±¬^ È,ϱÙ'2Ù&“ï§ÅrùÈ"q©‹Ä€÷u´¡h…ÊépyÿÊm ÐCƒSíBh"ãÎØqk¤=c–ˆÉº"@ôÏ?Î.&&7ÅtÏÄÑpÓâ­ÿåâ|ÕºÞ¶êT:½é›ëëE¹\¾ùüƒev¨ùu¹¨¶c³Am
>"•Š°WOEª´;лù¢¬-ïÓfžUÿì†skáŸÆ¹_qØñ¹¾ýf^´Û×ÛO¶]pU^]O‹U™ë™ÚÜy¿Ä2…Âxz¥çÀ¤Åw ¥Èêç([C¡8>3àœ-8X+òºy½¨CaÂëthöúŸ¿yyyy
I^<=K!Á媡dNRøØÇCipZ‹ñ÷X¸à@h-ò&)úÐ3†½8qhìõóä|1íŸÍét²*‰ÈˆÈˆÈˆÈ†$2‘…)BÙÀ.FJ™5
óP¦†ÒVÊq„
,8»+vlÖ‡žG†ýöšØ‹Ø‹Ø‹ØkHö’}tËq'd)ÄÌÝrz
eâøL‚RÕÜ!æn—K×3ªôôÁ…a¿þý'Ê"}}}
J_É=¡„B	æƒRå­›õPn
%\U7«Ð8ú.ÐåmDêGͨŽ=ˆ‡F_ßZÍ/ËY¹šœWÌ.ˆÉˆÉˆÉˆÉ†d²ôÞ(Ž>0|&P®†ª˜ìÌ[}iÃ…¨¬=£jvù¡1Ù¿‹Å¤˜­ˆÁˆÁˆÁˆÁ†d0ÝC*« E‡À3ÞB·†b&0XhÇ
,f23X/zFuÁƒµWÑñšz‰ÀˆÀˆÀ¾0Kî,–7r`µU9·Â«‘¸GK2 sÜ_ÈÉ^½(G^âà‰¿þcÿÃŒˆ»ˆ»ˆ»¾0îJnú¡hN£7ëÆ"ç9'Wz$U#I4³ët?&Âd¥¬óczQòXKéïl‚‰‰‰‰
LbÉC9ªisZŒxH|aNHräIk,h^‡©úyI¬%£J9$Ué硫¾üý&Ì#÷vò—ßoæ«ñw“ù/åbZ¿ Z#Z#Z#ZÖDòœÞÒ; 2ç’¬‘ª¼¢°>ñ¯ž–ì{:6ëCÉcí£€Œ˜‹˜‹˜k`æJÒÁmh/bHb@’êvF¢§ÎÔ #{Q2†¹4shÌõËûrV‘ññññ×ü%Ò§üJd–ÎB^Ïìz@ä”_É6PB83ù=eæf¸´³"¦üö¡ç‘Nùýe~}3}'€‡‡‡'‡ýPz]L'VŠ›ùG.,ùÆgó““÷Åì"œ)ïWÐj^'âOnìÃéŸÕ#¿Ì׿ÌÍý_~ða>xK}®}u@k?ô„ŠÛµ/,ð`Òöäó­}ïöbë¡ÏTtMוlÀs´nŸ6—ÿ76 ­¸4Ÿ
@éîÅÖ ZùѢ麒
xŽ6Àæ³ß.—óóI£Hn°aŸB$f0çœYöbôH€
û0NV64né7¨×"Ù¾’×	Ñbœÿ–Û]Lõº8Q¢Sjpv±|˜„¸ò‹arû›¿½ð±ÿé]©ÇUmyS·¾º™®&×ÓÉùdõ)D±XÌ?>vﶜÆN@——‹òò~òä©ç°ec,|Kôíî·×;U[}ŸmUªÞæy9U'·WGVi;òž´Á¼…¬RÂÓ—vá4ïê ®€lAîŽEØJ6‹êV!¯ŠóªD	­õ%º&º&ƒOtMtÝ]£Ýg‚,ýàs%°¥s Ò L
…Æ…“X”ÿK¸6G?Šw›õl‘u Â}RV+ÙI6]_Ê“åYÍ\§äÉä>MKŸ¦*ÁXeª‰¦™§©
Žsw¨ñàdÀN:Ù0Î4êÙ&‹ÞxµgÁ+¥TPª‹l²¾d
2™L1|¦@²Ãô
*¨1¥l8" i¦s>§ÀÓZ´Ëúwî*:ˆ&kKvà9ºjŸv€’ðLkƒ°±·ÑÁá‚[÷¡‹,™‚£4¸OS ):à
´¼…ª¢k1ñ´Ø¼Áíà`'ÑdmÉ<ÇÐ@ìÓȃ¶‡áðK->Ï,Aûâö*èJ…¢ÉÚ’!xŽ†€íÓ¨ƒ6Òô“IÏh,Æít‘¥ƒ£4wš:Åerq½´`…Ó¡ý+g—¸‡1¦†cÒ…þE˜ú/²ÎüOVîH[àyÉÔN­áÔ¾×Öp©·5L‰Ð6!RxsO}áª:k'Z,QArUŸa3˜Ä=¸ªéµåŒóñSuj¯´˜·¸Ü¨
”µ81›
,0k³”íG͸¹|üð†•“ËEIcùÈo%¿•üÖ~k{”´=ð˜äZÔòrçcî.Ô8`‡ó>Î$؄ɶqmRz¶Ér@lO¤°ª³lÚ$_j›¢¶)j¼¡oo¿ßfmSB$Ä [3‰Ø`MÎ2ý¸.YÊñÁ —V霨46 iôHa¸.¯‡ ïF-[d
Œ¶“(‘7‘7™"o"ïþÈ[šþÈ[FÞŠõ@ÞÂr=DôÈ;Œ>ãÖ[±·­)ÕìžÀŽeï5Ÿ’56Šé;É&%쉿‰¿‰¿éÛ#þn¾M§
`³¯i ª·³Ù˜Üg³ÉPÔÂOÁ«àÛz«ÏfË|7)Ù&*yd<ÝIÔPèMÔMÔMÔMãÆú¢nÞ8à³sè­(ÝRéÇ"ôÎk•Ø;–H›J¸ªñA»pA:Ìz¤j?zÆÔn…“:­vëÛéÔƒSåUnQåUn
^¹¥zè›7ÀyݹÆr·Ëz( ê"§ŠÆ¬<ИÎ=J§QÏvYõD5VÐÁ© C7YF£t(¥†"PŠ@û‰@•H8Ÿb»K~¸ó)T/”
®y2×n,©î`gp^W_gÏ ·hÚ&ìUP-Hdâobâoâïù['lþº|ôݘAƦآЊÑý°Ìg¬ÐþË@k‰nˆößž=ÖþßÊY•ú¥,2e‘)‹LYäYäFÓ}lƒ²°=l»ÈLbËl°l•AG‡+\nëGÓ83æÐXìÅõ”hŒhŒhŒhlO›¡&ÌÀ29PDÆX•Jåj½*À`…nAgî¥iÑ´UX†¦]ŒË»vNò(¥J)UJÊÑ·Gý4÷RªÍ3ŸN©nçclˆµ½5Uã”òǤJð¥k7 ³Ãx£šm²ø$+X©ÐIV‡“†i®*888í‰æØíDàÛÝ´ƒlŠ¦ŸöíÀ­7*`nîþœÑõXU>YÇÝTæ¬	å~T=Ö„òßåï7åìü%”)¡L	eJ(žPÆôë
0.µ|$”êŸÍ<–å"Љõ,ØLƒÓ5º†™ƒÑfU[…=ÏFËZ±ŽÂ4¡‰R
i( ¥€41 ýœv3'…‘÷–¢MÆ€
®ŸÛdBzT꺥Ô
Ñêú¨¢-²*0k„lh‹í$œ6ƒh˜h˜9}{´±Û–î4èx»Qv¸]ýhå?§ `á]¬a{]›5m®JÉÚ…ït±v‘¥ŽWbqbqbq
¦s•gégÞñŠ²‡9ÇÖbµß©QºœsŽ=’¬‘“n,˜Á*)¬Ø®È‘‡Ýö¡ä±öºþVü1ŸÍ¯hO—ötiO—öt‡ìuÅäIKÉéU©+ç:ç¨Ä€$×HZ«±ÀªZj¬ÖYçýö¢ä±Ò×÷“Uµ<ˆ¾ˆ¾ˆ¾ˆ¾†¤¯äyCÊøhŠN32WDŒcØð"'a¥ªÃUa'õиê×Ò?“åÏÅ5ÑÑÑÑUºú¡ôÖ¹˜NþlÜôK1$ªBN1R µU9Kh…eo‘ÆÈ™Ó)œµÙרa³¨Þ&æß¹BÿÎ#Å<î½½^Èo·S•XÂb¾TÓÃPLéÊ‘ä ò¼31•ZC¡A>Æ°g ÌHJ°fWè葘=¨ãºrüàŽUz]·~•?ÍÏ)ßB,9°äÀžoIžBb½o…BŒ¼Wi0멾‰m˜RcŽ ú×SY·zQòX[˜7ôõ#ññññWþú¯òºœ]„9	‘Xú<è˜fˆ€ŒV–°à0eµMÄŽ+¸nV´U˜…~c×zî<÷"A‰xѵþÇ“’¹Xßl„öiÃŽ&çƒ&aæwZ³õg69Ê:}J‚_pNÈ‘’ 
Ï;ñŒZ#	Žc	B3RèW<Ï;ì§õí×O48žœdr’ÉI~Îæ=zÉlf/™{îRRo Æ¸A­äHZ0Œë¼ämE[…ý”°Q»
ài:Sc"5&Rc"}{4^ )íTv`¶~™
‚&Ð`¸6b€$—­×HUÑ7à”öD¦C‡bÖ¢ƒ^”|5
T¾zYª9 p”ÂÑCG›Ü—5gÜ\M?Ÿ>ÉÕ[¦áy˜•¬5	»8[F¡Oç¦z'Óï©»Ëo‡²¹Qçöß,Ïçh}Ã]ÿo¼—÷üž8×9˳÷¶Ëž>zúöñô]L–Þ=§çž¿.¡ç±ÔPèô±7˜Ó|€à’3@{[?0dýD£’-¢¡ BbtíDœ(ÕN|±µZZíDòLnª!Ï#ÅüSo³ŽÔÒàì‰Y7ŒVþµÍlÞ‘Z}(•¸b Î˜¹’ ûÏ\ý\\SÒŠ’V”´¢¤Õ–ex7«%n¸í#qà¦w“V•o¼’7”@ çðHþ}òЦp´·U<±Î)2w dÄë±ð¯1¼v ‘ë¬þ}JÆø÷a.ÕÁƒzó矟Ž¡“pw¿‘ü{òï©Fz_¦Óû{ ³¡÷Eäîï Uú{ªÓ@mèïÁìý==èCa^~hö—ßoæ«ñëkïV×¥4ÑÑÑØ4–<šL…ýnFÊÚ¬4æ‘äIzã¬
óX™—ÇzQ2²FØ‘}?Ÿ/.&3ÿdþ2ŸNÎ?Q8FO…™>B#y™,@™5”
Tæ@	4&P™ÉLeý¨y¬aÙ?«b³îlÖC*“ȌȌîºÇjÉSñœ\œ3aÛÊäÝ0³`ðRØ0ó¯Sè¾ÇF%›E‘Ó¦½™Ñ+ ‚D“u¥c¼2µ%¦ÌÓÒ.ß1^OÛqÀ6€JÝäÈfB:É>!)¸Ô]$“5¥õÿ׿Ýçú—‡³þ9Hg®úŒJÙŽ¢IɲÏÔ–Ï´Æ6ª·åŸ½fÎsRºªÖÛ„åÏs©Âªä»#w3ÛJ¶ˆj°ZËvQt:ýu­uÿÀ«¯ßË“"9?1[Ð|lšMßÞÁ~{ÙÙ¼Ó˜!ƒÃ2ÉmÈaÖÐb€#š<ß …..€yè!ÎhêEɸ3šd2mGQqíGÑ~ÔÐ38î¡TPI>qÌ¢¬Æf0®ÃYÜZ`êᆱ#8Õ±Y’ƒVBµJz®2!`]kN8{áÝêhÄ+ÿq,Ÿùîä1o;½¢S|³éãH¸>Ž(‹=8Yl°ªá=Á
	ÔCïéIÑÈñœˆ‡w¸iø¢h€yÐäA“½7:¹m”TÒ±!r@„« 6N´g„PC8ÑÍj¶Ér@‡­Þ±•
ñ¢äH¹Æ,%Ålò9ÌíFÆ¥
c`„TƒÌ
óPFªÇŒŒÈldšÕl“
–ÃDÛC&†LL›‰Ñ‡hb,K/IYKdwc$0sg‘h•ŽY’Ò d‹(ù0d`r&ýžiJúÙ䎗3®Á‘ÐÀ‘‰œî‚à(ÆÄXeB`8ÿJ1&²¦üzQóXvWsN)ßGù>Ê÷Q¾o_ù>+ÒCñ°q­1œè¨4ãYCqoæ‘WÜ%=ŸŒýV]HÃŽŒÅ›ôl‘Þk¶R>!«L¥TÙú wùËq—7¯÷>‡÷xÓ϶U€šáˆû‡\ÝmTì¿°Æ#ñI9´cFýûׂƒq»"GŽàêCÉwד‡æî~7™¿|ù«ÿ¢Ê©<”œ]rvÉÙÜÙM?FY‚æV…„†Ùýðð(“žK’§-Ï%cnË:•bÒŽ-º>´IÉQ	Ι֭$n@Û @ÑZwòr¿¼¤ðö)ë*A½»šÍE~r‚ÅjЙÔ6y.³‘aÀí-Rð•™K=$>¶ýq›Ee(÷q®M4¼¥:H¦kJ£†1݆¡¨|£cäôóïÂf¨g=@fPæÌ£y @¯ üÿäXúÕ‚#åÉ~gØÈý Œ	½ßrpS=.®¯ßPpLÁ1Ç›ª”@fGº"•·ªA™¥@K:>óž¬a‚©D𸭠FE[d0¼ÓVÙПU)ÑIØ3w‚Ã@aò{É<¥8Óê=ì$ÙôýæÐ?,ýÚ“]Þíæ0‡> 	ã‘Æg>RŽlðžÏ{LtJƸÊœ;¼¤9Éä$““LNòàNrK˜ÆAèKçø¨‹œ‚Y-Õ f³(9Èä ÷î [ûLäö‰ºŽõeglH¹bgÖHã3
Æ	ñr
afhÙ,ö¼$kÙ
 Zk-kA'æŽ{+)b‚.£	º4A—¾½ý}{ü™Mе)›ÀÛ¹1 ½åÒ[¹ÎiáÎûí"ïd¥k(´!Bå\Ê_¬˜7ÃÕ‡ž1).¯ÓÁõþû§ß~¥å¸(ÇE9®“=êèDñ§±ÊŒB!³Ê»fç"Ó(ÏcœØI>®g›,‚pâ‰V?¯Ju‘MÖ—Ê3mÔb‚'ëxj9cýzZ|*¯¾ª_ø?—‹âêÕWÿôSoï0BioPerl-1.6.923/models/popgen.dia000444000765000024     50403112254227320 16730 0ustar00cjfieldsstaff000000000000

  
    
      
    
    
      
    
    
      
        
          #A4#
        
        
          
        
        
          
        
        
          
        
        
          
        
        
          
        
        
          
        
        
          
        
        
          
        
        
          
        
      
    
    
      
        
          
        
        
          
        
        
          
        
        
          
        
        
      
    
    
      
    
    
      
        
        
      
    
  
  
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        ##
      
      
        #Bio::PopGen#
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::Population#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
          
            #self#
          
          
            ##
          
          
            ##
          
          
            ##
          
          
            
          
          
            
          
          
            
          
        
      
      
        
          
            #new#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #name#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #description#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #source#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #set_Allele_Frequency#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #add_Individual#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #remove_Individuals#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Individuals#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Genotypes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_marker_names#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Marker#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_number_individuals#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #set_number_individuals#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Frequency_Homozygotes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Frequency_Heterozygotes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::Statistics#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
        
          
            #fu_and_li_D#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #fu_and_li_D_star#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #fu_and_li_F#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #fu_and_li_F_star#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #tajima_D#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #pi#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #theta#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #singleton_count#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #segregating_sites_count#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #heterozygosity#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #derived_mutations#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #composite_LD#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::Marker#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
          
            #self#
          
          
            ##
          
          
            ##
          
          
            ##
          
          
            
          
          
            
          
          
            
          
        
      
      
        
          
            #new#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #name#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #description#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #type#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #unique_id#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Alleles#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Allele_Frequencies#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #add_Allele_Frequency#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #reset_alleles#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::Individual#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
          
            #self#
          
          
            ##
          
          
            ##
          
          
            ##
          
          
            
          
          
            
          
          
            
          
        
      
      
        
          
            #new#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #unique_id#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #num_of_results#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #add_Genotype#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #reset_Genotypes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #remove_Genotype#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Genotypes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #has_Marker#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_marker_names#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::PopStats#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
          
            #self#
          
          
            ##
          
          
            ##
          
          
            ##
          
          
            
          
          
            
          
          
            
          
        
      
      
        
          
            #new#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #haploid_status#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #Fst#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::GenotypeI#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
        
          
            #marker_name#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #individual_id#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Alleles#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::MarkerI#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
        
          
            #name#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #description#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #type#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #unique_id#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #annotation#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Alleles#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Allele_Frequencies#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::IO#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
          
            #self#
          
          
            ##
          
          
            ##
          
          
            ##
          
          
            
          
          
            
          
          
            
          
        
      
      
        
          
            #new#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #_initialize#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #next_individual#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #next_population#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #write_individual#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #write_population#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #newFh#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #fh#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #_load_format_module#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #_guess_format#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #close#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #DESTROY#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #TIEHANDLE#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #READLINE#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #PRINT#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::PopulationI#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
        
          
            #name#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #description#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #source#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Individuals#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Genotypes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Marker#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_marker_names#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Markers#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_number_individuals#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::IndividualI#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
        
          
            #unique_id#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #num_genotypes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #num_of_results#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Genotypes#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #has_Marker#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_marker_names#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::PopGen::Genotype#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
          
            #self#
          
          
            ##
          
          
            ##
          
          
            ##
          
          
            
          
          
            
          
          
            
          
        
      
      
        
          
            #new#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #marker_name#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #individual_id#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #get_Alleles#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #add_Allele#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
        
          
            #reset_Alleles#
          
          
            ##
          
          
            ##
          
          
            
          
          
            ##
          
          
            
          
          
            
          
          
            
          
          
            
          
          
        
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::AnnotatableI#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        #Bio::Root::IO#
      
      
        ##
      
      
        ##
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
        
      
      
      
      
        
      
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        
      
      
        ##
      
      
        ##
      
      
        
        
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        
      
      
        ##
      
      
        ##
      
      
        
        
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        ##
      
      
        
      
      
        
          
            ##
          
          
            ##
          
          
            
          
          
            
          
        
        
          
            ##
          
          
            ##
          
          
            
          
          
            
          
        
      
      
        
        
      
    
    
      
        
      
      
        
      
      
        
          
            #Bio::PopGen#
          
          
            
          
          
            
          
          
            
          
          
            
          
          
            
          
        
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        
      
      
        ##
      
      
        ##
      
      
        
        
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        
      
      
        ##
      
      
        ##
      
      
        
        
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        
      
      
        ##
      
      
        ##
      
      
        
        
      
    
    
      
        
      
      
        
      
      
        
        
        
        
      
      
        
        
        
      
      
        
      
      
        ##
      
      
        ##
      
      
        
        
      
    
  

BioPerl-1.6.923/models/population_proposal.txt000444000765000024       215012254227337 21576 0ustar00cjfieldsstaff000000000000A toolkit for manipulating population data is critical for population
geneticists, epidemiologists, evo-devo and others.


This proposal will outline basic set of objects which are useful for
manipulating population data.  Our primary driving force will be to
process the data generated from the SNP haplotype project.


Population Objects

Bio::Population namespace

Bio::Population::HaplotypeCohortI  a collection (likely) co-inherited
			             markers
Bio::Population::HaplotypeI  -- a score for a particular haplotype
			        cohort or an individual
Bio::Population::GenotypeI   -- a score value for a marker for an individual 
Bio::Population::FrequencyI  -- an allele frequency in a Population
Bio::Population::PopulationI -- group of unrelated individuals
Bio::Population::PedigreeI   -- group of related individuals w/ relationships
Bio::Population::IndividualI -- a single identifiable entity with distinct
				genotypes for markers
Bio::Population::PhenotypeI  -- a trait associated with an individual 

Relationships
--------------- 
A PedigreeI isa PopulationI
A PopulationI can contain other PopulationIs
BioPerl-1.6.923/models/README000444000765000024       130012254227337 15600 0ustar00cjfieldsstaff000000000000# $Id$

This is the README file for the BioPerl models directory.

o What the models/ directory is about.

This directory is for files about schemas and plans in BioPerl.


o Are any of these files important?

It is definitely worth having a look at file bioperl.dia - if you can
open it. It gives you an overview of most important BioPerl modules.


o How do I open these files?

Most files in this directory are XML files for a program dia (with
extension .dia) which is a free GTK-library based diagram editor. It
is part of the GNOME desktop and is included in most GNU/LINUX
distributions (or see http://www.lysator.liu.se/~alla/dia).


o Are these up-to-date?

These are Bioperl version 1.0 models.BioPerl-1.6.923/scripts000755000765000024          012254227337 14775 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/scripts/README000555000765000024       134612254227337 16021 0ustar00cjfieldsstaff000000000000These scripts have been contributed by the developers and users of
Bioperl. The scripts in scripts/ are production quality scripts that 
have POD documentation and accept command-line arguments, and all of 
these scripts have the PLS suffix.

You can install the scripts in the scripts/ directory if you'd like,
simply follow the instructions on 'make install'. The installation
directory is specified by the INSTALLSCRIPT variable in the Makefile,
the default directory is /usr/bin. Installation will copy the scripts
to the specified directory, change the 'PLS' suffix to 'pl' and
prepend 'bp_' to the script name if it isn't so named already.

Please contact bioperl-l at bioperl.org if you are interested in
contributing your own script.
BioPerl-1.6.923/scripts/Bio-DB-GFF000755000765000024          012254227334 16366 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_bulk_load_gff.pl000444000765000024      5064712254227315 22352 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;
# use lib './blib/lib';
use DBI;
use IO::File;
use File::Spec;
use Getopt::Long;
use Bio::DB::GFF;
use Bio::DB::GFF::Util::Binning 'bin';

use constant MYSQL => 'mysql';
use constant FDATA      => 'fdata';
use constant FTYPE      => 'ftype';
use constant FGROUP     => 'fgroup';
use constant FDNA       => 'fdna';
use constant FATTRIBUTE => 'fattribute';
use constant FATTRIBUTE_TO_FEATURE => 'fattribute_to_feature';

=head1 NAME

bp_bulk_load_gff.pl - Bulk-load a Bio::DB::GFF database from GFF files.

=head1 SYNOPSIS

  % bp_bulk_load_gff.pl -d testdb dna1.fa dna2.fa features1.gff features2.gff ...

=head1 DESCRIPTION

This script loads a Bio::DB::GFF database with the features contained
in a list of GFF files and/or FASTA sequence files.  You must use the
exact variant of GFF described in L.  Various
command-line options allow you to control which database to load and
whether to allow an existing database to be overwritten.

This script differs from bp_load_gff.pl in that it is hard-coded to use
MySQL and cannot perform incremental loads.  See L for an
incremental loader that works with all databases supported by
Bio::DB::GFF, and L for a MySQL loader that supports
fast incremental loads.

=head2 NOTES

If the filename is given as "-" then the input is taken from standard
input. Compressed files (.gz, .Z, .bz2) are automatically
uncompressed.

FASTA format files are distinguished from GFF files by their filename
extensions.  Files ending in .fa, .fasta, .fast, .seq, .dna and their
uppercase variants are treated as FASTA files.  Everything else is
treated as a GFF file.  If you wish to load -fasta files from STDIN,
then use the -f command-line swith with an argument of '-', as in 

    gunzip my_data.fa.gz | bp_fast_load_gff.pl -d test -f -

The nature of the bulk load requires that the database be on the local
machine and that the indicated user have the "file" privilege to load
the tables and have enough room in /usr/tmp (or whatever is specified
by the \$TMPDIR environment variable), to hold the tables transiently.

Local data may now be uploaded to a remote server via the --local option
with the database host specified in the dsn, e.g. dbi:mysql:test:db_host

The adaptor used is dbi::mysqlopt.  There is currently no way to
change this.

About maxfeature: the default value is 100,000,000 bases.  If you have
features that are close to or greater that 100Mb in length, then the
value of maxfeature should be increased to 1,000,000,000. This value
must be a power of 10.

Note that Windows users must use the --create option.

If the list of GFF or fasta files exceeds the kernel limit for the 
maximum number of command-line arguments, use the 
--long_list /path/to/files option. 


=head1 COMMAND-LINE OPTIONS

Command-line options can be abbreviated to single-letter options.
e.g. -d instead of --database.

   --database       Database name (default dbi:mysql:test)
   --adaptor             Adaptor name (default mysql)
   --create              Reinitialize/create data tables without asking
   --user                Username to log in as
   --fasta               File or directory containing fasta files to load
   --long_list           Directory containing a very large number of 
                         GFF and/or FASTA files
   --password            Password to use for authentication
                           (Does not work with Postgres, password must be
                           supplied interactively or be left empty for
                           ident authentication)
   --maxbin              Set the value of the maximum bin size
   --local               Flag to indicate that the data source is local
   --maxfeature          Set the value of the maximum feature size (power of 10)
   --group               A list of one or more tag names (comma or space separated)
                         to be used for grouping in the 9th column.
   --gff3_munge          Activate GFF3 name munging (see Bio::DB::GFF)
   --summary             Generate summary statistics for drawing coverage histograms.
                           This can be run on a previously loaded database or during
                           the load.
   --Temporary           Location of a writable scratch directory

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Lincoln Stein, lstein@cshl.org

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

package Bio::DB::GFF::Adaptor::fauxmysql;

use Bio::DB::GFF::Adaptor::dbi::mysqlopt;
use vars '@ISA';
@ISA = 'Bio::DB::GFF::Adaptor::dbi::mysqlopt';

sub insert_sequence {
  my $self = shift;
  my ($id,$offset,$seq) = @_;
  print join("\t",$id,$offset,$seq),"\n";
};

package Bio::DB::GFF::Adaptor::fauxmysqlcmap;

use Bio::DB::GFF::Adaptor::dbi::mysqlcmap;
use vars '@ISA';
@ISA = 'Bio::DB::GFF::Adaptor::dbi::mysqlcmap';

sub insert_sequence {
  my $self = shift;
  my ($id,$offset,$seq) = @_;
  print join("\t",$id,$offset,$seq),"\n";
};

package Bio::DB::GFF::Adaptor::fauxpg;

use Bio::DB::GFF::Adaptor::dbi::pg;
use vars '@ISA';
@ISA = 'Bio::DB::GFF::Adaptor::dbi::pg';

#these two subs are to separate the table creation from the
#index creation
sub do_initialize {
  my $self = shift;
  my $erase = shift;
  $self->drop_all if $erase;
                                                                                
  my $dbh = $self->features_db;
  my $schema = $self->schema;
  foreach my $table_name ($self->tables) {
    my $create_table_stmt = $schema->{$table_name}{table} ;
    $dbh->do($create_table_stmt) ||  warn $dbh->errstr;
  #  $self->create_other_schema_objects(\%{$schema->{$table_name}});
  }
  1;
}

sub _create_indexes_etc {
  my $self = shift;

  my $dbh = $self->features_db;
  my $schema = $self->schema;
  foreach my $table_name ($self->tables) {
    $self->create_other_schema_objects(\%{$schema->{$table_name}});
  }
}

sub insert_sequence {
  my $self = shift;
  my ($id,$offset,$seq) = @_;
  print "$id\t$offset\t$seq\n";
}

package main;

eval "use Time::HiRes"; undef $@;
my $timer = defined &Time::HiRes::time;

my $bWINDOWS = 0;    # Boolean: is this a MSWindows operating system?
if ($^O =~ /MSWin32/i) {
    $bWINDOWS = 1;
}

my ($DSN,$ADAPTOR,$FORCE,$USER,$PASSWORD,$FASTA,$LOCAL,$MAX_BIN,$GROUP_TAG,$LONG_LIST,$MUNGE,$TMPDIR);

GetOptions ('database:s'    => \$DSN,
	    'adaptor:s'     => \$ADAPTOR,
	    'create'        => \$FORCE,
	    'user:s'        => \$USER,
	    'password:s'    => \$PASSWORD,
	    'fasta:s'       => \$FASTA,
	    'local'         => \$LOCAL,
	    'maxbin|maxfeature:s'    => \$MAX_BIN,
	    'group:s'       => \$GROUP_TAG,
	    'long_list:s'   => \$LONG_LIST,
	    'gff3_munge'    => \$MUNGE,
	    'Temporary:s'   => \$TMPDIR,
	   ) or (system('pod2text', $0), exit -1);

# If called as pg_bulk_load_gff.pl behave as that did.
if ($0 =~/pg_bulk_load_gff.pl/){
    $ADAPTOR ||= 'Pg';
    $DSN     ||= 'test';
}
$DSN     ||= 'dbi:mysql:test';
$MAX_BIN ||= 1_000_000_000; # to accomodate human-sized chromosomes


if ($bWINDOWS && not $FORCE) {
  die "Note that Windows users must use the --create option.\n";
}

unless ($FORCE) {
  die "This will delete all existing data in database $DSN.  If you want to do this, rerun with the --create option.\n"
    if $bWINDOWS;
  open (TTY,"/dev/tty") or die "/dev/tty: $!\n";  #TTY use removed for win compatability
  print STDERR "This operation will delete all existing data in database $DSN.  Continue? ";
  my $f = ;
  die "Aborted\n" unless $f =~ /^[yY]/;
  close TTY;
}

# postgres DBD::Pg allows 'database', but also 'dbname', and 'db':
# and it must be Pg (not pg)
$DSN=~s/pg:database=/Pg:/i;
$DSN=~s/pg:dbname=/Pg:/i;
$DSN=~s/pg:db=/Pg:/i;

# leave these lines for mysql
$DSN=~s/database=//i;
$DSN=~s/;host=/:/i; #cater for dsn in the form of "dbi:mysql:database=$dbname;host=$host"


my($DBI,$DBD,$DBNAME,$HOST)=split /:/,$DSN;
$DBNAME=$DSN unless $DSN=~/:/;
$ADAPTOR ||= $DBD; 
$ADAPTOR ||= 'mysql';

if ($DBD eq 'Pg') {
        # rebuild DSN, DBD::Pg requires full dbname= format
        $DSN = "dbi:Pg:dbname=$DBNAME";
        if ($HOST) { $DSN .= ";host=$HOST"; }
}

my ($use_mysql,$use_mysqlcmap,$use_pg) = (0,0,0);
if ( $ADAPTOR eq 'mysqlcmap' ) {
  $use_mysqlcmap = 1;
}
elsif ( $ADAPTOR =~ /^mysql/ ) {
  $use_mysql = 1;
}
elsif ( $ADAPTOR eq "Pg" ) {
  $use_pg = 1;
}
else{
    die "$ADAPTOR is not an acceptable database adaptor.";
}


my (@auth,$AUTH);
if (defined $USER) {
  push @auth,(-user=>$USER);
  if ( $use_mysql or $use_mysqlcmap ) {
    $AUTH .= " -u$USER";
  }
  elsif ( $use_pg ) {
    $AUTH .= " -U $USER ";
  }
}
if (defined $PASSWORD) {
  push @auth,(-pass=>$PASSWORD);
  if ( $use_mysql or $use_mysqlcmap ) {
    $AUTH .= " -p$PASSWORD";
  }
#  elsif ( $use_pg ) {
#    $AUTH .= " -W $PASSWORD ";
#  }
}

if (defined $HOST) {
  $AUTH .= " -h$HOST";  
}
if (defined $DBNAME) {
  if ( $use_mysql or $use_mysqlcmap ) {
    $AUTH .= " -D$DBNAME ";
  }
}
if (defined $LOCAL) {
  $LOCAL='local';
  $AUTH.=' --local-infile=1';
}else {
  $LOCAL='';
}

my $faux_adaptor;
if ( $use_mysqlcmap ) {
  $faux_adaptor = "fauxmysqlcmap";
}
elsif ( $use_mysql ) {
  $faux_adaptor = "fauxmysql";
}
elsif ( $use_pg ) {
  $faux_adaptor = "fauxpg";
}

my $db = Bio::DB::GFF->new(-adaptor=>$faux_adaptor,-dsn => $DSN,@auth)
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";

$db->gff3_name_munging(1) if $MUNGE;

$MAX_BIN ? $db->initialize(-erase=>1,-MAX_BIN=>$MAX_BIN) : $db->initialize(1);
$MAX_BIN ||= $db->meta('max_bin') || 100_000_000;

# deal with really long lists of files
if ($LONG_LIST) {
  -d $LONG_LIST or die "The --long_list argument must be a directory\n";
  opendir GFFDIR,$LONG_LIST or die "Could not open $LONG_LIST for reading: $!";
  @ARGV = map { "$LONG_LIST\/$_" } readdir GFFDIR;
  closedir GFFDIR;

  if (defined $FASTA && -d $FASTA) {
    opendir FASTA,$FASTA or die "Could not open $FASTA for reading: $!";
    push @ARGV, map { "$FASTA\/$_" } readdir FASTA;
    closedir FASTA;
  }
  elsif (defined $FASTA && -f $FASTA) {
    push @ARGV, $FASTA;
  }
}

foreach (@ARGV) {
  $_ = "gunzip -c $_ |" if /\.gz$/;
  $_ = "uncompress -c $_ |" if /\.Z$/;
  $_ = "bunzip2 -c $_ |" if /\.bz2$/;
}

my (@gff,@fasta);
foreach (@ARGV) {
  if (/\.(fa|fasta|dna|seq|fast)(?:$|\.)/i) {
    push @fasta,$_;
  } else {
    push @gff,$_;
  }
}
@ARGV = @gff;
push @fasta,$FASTA if defined $FASTA;

# drop everything that was there before
my %FH;
my $tmpdir = File::Spec->tmpdir() || '/tmp';
$tmpdir =~ s!\\!\\\\!g if $bWINDOWS; #eliminates backslash mis-interpretation
-d $tmpdir or die <new(">$tmpdir/$_.$$") or die $_,": $!";
  $FH{$_}->autoflush;
}

if ( $use_pg ) {
  $FH{FDATA()                }->print("COPY fdata (fid, fref, fstart, fstop, fbin, ftypeid, fscore, fstrand, fphase, gid, ftarget_start, ftarget_stop) FROM stdin;\n");
  $FH{FTYPE()                }->print("COPY ftype (ftypeid, fmethod, fsource) FROM stdin;\n");
  $FH{FGROUP()               }->print("COPY fgroup (gid, gclass, gname) FROM stdin;\n");
  $FH{FATTRIBUTE()           }->print("COPY fattribute (fattribute_id, fattribute_name) FROM stdin;\n");
  $FH{FATTRIBUTE_TO_FEATURE()}->print("COPY fattribute_to_feature (fid, fattribute_id, fattribute_value) FROM stdin;\n");
}
my $FID     = 1;
my $GID     = 1;
my $FTYPEID = 1;
my $ATTRIBUTEID = 1;
my %GROUPID     = ();
my %FTYPEID     = ();
my %ATTRIBUTEID = ();
my %DONE        = ();
my $FEATURES    = 0;

my %tmpfiles; # keep track of temporary fasta files
my $count;
my $fasta_sequence_id;
my $gff3;
my $current_file; #used to reset GFF3 flag in mix of GFF and GFF3 files

$db->preferred_groups(split (/[,\s]+/,$GROUP_TAG)) if defined $GROUP_TAG;

my $last  = Time::HiRes::time() if $timer;
my $start = $last;

  # avoid hanging on standalone --fasta load
if (!@ARGV) {
    $FH{NULL} = IO::File->new(">$tmpdir/null");
    push @ARGV, "$tmpdir/null";
}

my ($cmap_db);
if ($use_mysqlcmap){
  my $options = {
		 AutoCommit       => 1,
		 FetchHashKeyName => 'NAME_lc',
		 LongReadLen      => 3000,
		 LongTruncOk      => 1,
		 RaiseError       => 1,
		};

  $cmap_db = DBI->connect( $DSN, $USER, $PASSWORD, $options );
}
# Only load CMap::Utils if using cmap
unless (!$use_mysqlcmap or
	eval {
	  require Bio::GMOD::CMap::Utils;
	  Bio::GMOD::CMap::Utils->import('next_number');
	  1;
	} 
       ) {
  print STDERR "Error loading Bio::GMOD::CMap::Utils\n";
}


while (<>) {

  $current_file ||= $ARGV;

  # reset GFF3 flag if new filehandle
  unless($current_file eq $ARGV){
    undef $gff3;
    $current_file = $ARGV;
  }

  chomp;
  my ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group);

  # close sequence filehandle if required
  if ( /^\#|\s+|^$|^>|\t/ && defined $FH{FASTA}) {
    $FH{FASTA}->close;
    delete $FH{FASTA};
  }

  # print to fasta file if the handle is open
  if ( defined $FH{FASTA} ) {
    $FH{FASTA}->print("$_\n");
    next;
  }

  elsif (/^>(\S+)/) {  # uh oh, sequence coming
    $FH{FASTA} = IO::File->new(">$tmpdir/$1\.fa") or die "FASTA: $!\n";
    $FH{FASTA}->print("$_\n");
    print STDERR "Preparing embedded sequence $1\n";
    push @fasta, "$tmpdir/$1\.fa";
    push @fasta_files_to_be_unlinked,"$tmpdir/$1\.fa";
    $tmpfiles{"$tmpdir/$1\.fa"}++;
    next;
  }

  elsif (/^\#\#\s*gff-version\s+(\d+)/) {
    $gff3 = ($1 >= 3);
    $db->print_gff3_warning() if $gff3;
    next;
  }

  elsif (/^\#\#\s*group-tags\s+(.+)/) {
    $db->preferred_groups(split(/\s+/,$1));
    next;
  }

  elsif (/^\#\#\s*sequence-region\s+(\S+)\s+(\d+)\s+(\d+)/i) { # header line
    ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) =
	($1,'reference','Component',$2,$3,'.','.','.',$gff3 ? "ID=Sequence:$1": qq(Sequence "$1"));
  }

  elsif (/^\#/) {
    next;
  }

  else {
    ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) = split "\t";
  }
  if ( not defined( $ref ) or length ($ref) == 0) {
    warn "\$ref is null.  source = $source, method = $method, group = $group\n";
    next;
  }
  $FEATURES++;
  my $size = $stop-$start+1;
  warn "Feature $group ($size) is larger than $MAX_BIN. You will have trouble retrieving this feature.\nRerun script with --maxfeature set to a higher power of 10.\n" if $size > $MAX_BIN;

  $source = '\N' unless defined $source;
  $score  = '\N' if $score  eq '.';
  $strand = '\N' if $strand eq '.';
  $phase  = '\N' if $phase  eq '.';

  my ($group_class,$group_name,$target_start,$target_stop,$attributes) = $db->split_group($group,$gff3);

  # GFF2/3 transition
  $group_class = [$group_class] unless ref $group_class;
  $group_name  = [$group_name]  unless ref $group_name;

  for (my $i=0; $i < @$group_name; $i++) {
    $group_class->[$i]  ||= '\N';
    $group_name->[$i]   ||= '\N';
    $target_start ||= '\N';
    $target_stop  ||= '\N';
    $method       ||= '\N';
    $source       ||= '\N';

    my $fid     = $FID++;
    my $gid     = $GROUPID{lc join('',$group_class->[$i],$group_name->[$i])}  ||= $GID++;
    my $ftypeid = $FTYPEID{lc join('',$source,$method)}                       ||= $FTYPEID++;

    my $bin = bin($start,$stop,$db->min_bin);
    $FH{ FDATA()  }->print(    join("\t",$fid,$ref,$start,$stop,$bin,$ftypeid,$score,$strand,$phase,$gid,$target_start,$target_stop),"\n"   );
    if ($use_mysqlcmap){
      my $feature_id    = next_number(
				      db         => $cmap_db,
				      table_name => 'cmap_feature',
				      id_field   => 'feature_id',
				     )
	or die 'No feature id';
      my $direction = $strand eq '-' ? -1:1;
      $FH{ FGROUP() }->print(    
			     join("\t",$feature_id,$feature_id,'NULL',0, $group_name->[$i],0,0,'NULL',1,$direction, $group_class->[$i],)
			     ,"\n"
			    ) unless $DONE{"G$gid"}++;
    }
    else {
      $FH{ FGROUP() }->print(    join("\t",$gid,$group_class->[$i],$group_name->[$i]),"\n") unless $DONE{"G$gid"}++;
    }
    $FH{ FTYPE()  }->print(    join("\t",$ftypeid,$method,$source),"\n"                   ) unless $DONE{"T$ftypeid"}++;

    foreach (@$attributes) {
      my ($key,$value) = @$_;
      my $attributeid = $ATTRIBUTEID{$key}   ||= $ATTRIBUTEID++;
      $FH{ FATTRIBUTE() }->print( join("\t",$attributeid,$key),"\n"                       ) unless $DONE{"A$attributeid"}++;
      $FH{ FATTRIBUTE_TO_FEATURE() }->print( join("\t",$fid,$attributeid,$value),"\n");
    }

    if ( $fid % 1000 == 0) {
      my $now    = Time::HiRes::time() if $timer;
      my $elapsed = $timer ? sprintf(" in %5.2fs",$now - $last) : '';
      $last = $now;
      print STDERR "$fid features parsed$elapsed...";
      print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n";
    }
  }
}

$FH{FASTA}->close if exists $FH{FASTA};

for my $file (@fasta) {
  warn "Preparing DNA file $file....\n";
  if ($use_pg){
    $FH{FDNA() }->print("COPY fdna (fref, foffset, fdna) FROM stdin;\n");
  }
  my $old = select($FH{FDNA()});
  $db->load_fasta($file) or warn "Couldn't load fasta file $file: $!";
  if ($use_pg){
    $FH{FDNA() }->print("\\.\n\n");
  }
  warn "done...\n";
  select $old;
  unlink $file if $tmpfiles{$file};
}

if ($use_pg) { 
  $FH{FDATA()                }->print("\\.\n\n");
  $FH{FTYPE()                }->print("\\.\n\n");
  $FH{FGROUP()               }->print("\\.\n\n");
  $FH{FATTRIBUTE()           }->print("\\.\n\n");
  $FH{FATTRIBUTE_TO_FEATURE()}->print("\\.\n\n");
}


$_->close foreach values %FH;
printf STDERR "Total parse time %5.2fs\n",(Time::HiRes::time() - $start) if $timer;
warn "Loading feature data and analyzing tables.  You may see RDBMS messages here...\n";

if ($use_pg){
  warn "Loading feature data.  You may see Postgres comments...\n";

  foreach (@files) {
    my $file = "$tmpdir/$_.$$";

    $AUTH ? system("psql $AUTH -f $file $DBNAME")
          : system('psql','-f', $file, $DBNAME);

    unlink $file;
  }

  warn "Updating sequences ...\n";
  $db->update_sequences();

  warn "Creating indexes ...\n";
  $db->_create_indexes_etc();

  warn "done...\n";

}

elsif( $use_mysql or $use_mysqlcmap ) {
  $start = time();

  my $success = 1;
  my $TERMINATEDBY = $bWINDOWS ? q( LINES TERMINATED BY '\r\n') : ''; 
  for my $f (@files) {
    my $table = function_to_table($f,$ADAPTOR);
    my $sql = join ('; ',
		    "lock tables $table write",
		    "delete from $table",
		    "load data $LOCAL infile '$tmpdir/$f.$$' replace into table $table $TERMINATEDBY",
		    "unlock tables");
    my $command = MYSQL . qq[$AUTH -s -e "$sql"];
    $command =~ s/\n/ /g;
    $success &&= system($command) == 0;
    unlink "$tmpdir/$f.$$";
  }
  printf STDERR "Total load time %5.2fs\n",(time() - $start) if $timer;
  print STDERR "done...\n";

  print STDERR "Analyzing/optimizing tables. You will see database messages...\n";
  $start = time();
  my $sql = '';
  for my $f (@files) {
    my $table = function_to_table($f,$ADAPTOR);
    $sql       .= "analyze table $table;";
  }
  my $command = MYSQL . qq[$AUTH -N -s -e "$sql"];
  $success &&= system($command) == 0;
  printf STDERR "Optimization time time %5.2fs\n",(time() - $start);

  if ($success) {
    print "$FEATURES features successfully loaded\n";
  } else {
    print "FAILURE: Please see standard error for details\n";
    exit -1;
  }
}

foreach (@fasta_files_to_be_unlinked) {
  unlink "$tmpdir/$_.$$";
}

warn "Building summary statistics for coverage histograms...\n";
my (@args,$AUTH);
if (defined $USER) {
  push @args,(-user=>$USER);
  $AUTH .= " -u$USER";
}
if (defined $PASSWORD) {
  push @args,(-pass=>$PASSWORD);
  $AUTH .= " -p$PASSWORD";
}
push @args,(-preferred_groups=>[split(/[,\s+]+/,$GROUP_TAG)]) if defined $GROUP_TAG;
my $db = Bio::DB::GFF->new(-adaptor=>"dbi::$ADAPTOR",-dsn => $DSN,@args)
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";
$db->build_summary_statistics;

exit 0;

sub function_to_table {
    my $function = shift;
    my $adaptor  = shift;

    if ($function eq 'fdata'){
        return 'fdata';
    }
    elsif ($function eq 'ftype'){
        return 'ftype';
    }
    elsif ($function eq 'fgroup'){
        return 'cmap_feature' if ($adaptor eq 'mysqlcmap');
        return 'fgroup';
    }
    elsif ($function eq 'fdna'){
        return 'fdna';
    }
    elsif ($function eq 'fattribute'){
        return 'fattribute';
    }
    elsif ($function eq 'fattribute_to_feature'){
        return 'fattribute_to_feature';
    }
    return '';
}

__END__
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_fast_load_gff.pl000444000765000024      3641512254227320 22343 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;
# use lib './blib/lib';
use DBI;
use IO::File;
use Getopt::Long;
use Bio::DB::GFF::Util::Binning 'bin';
use Bio::DB::GFF::Adaptor::dbi::mysqlopt;

use constant MYSQL => 'mysql';

use constant FDATA      => 'fdata';
use constant FTYPE      => 'ftype';
use constant FGROUP     => 'fgroup';
use constant FDNA       => 'fdna';
use constant FATTRIBUTE => 'fattribute';
use constant FATTRIBUTE_TO_FEATURE => 'fattribute_to_feature';

my $DO_FAST = eval "use POSIX 'WNOHANG'; 1;";

=head1 NAME

bp_fast_load_gff.pl - Fast-load a Bio::DB::GFF database from GFF files.

=head1 SYNOPSIS

  % bp_fast_load_gff.pl -d testdb dna1.fa dna2.fa features1.gff features2.gff ...

=head1 DESCRIPTION

This script loads a Bio::DB::GFF database with the features contained
in a list of GFF files and/or FASTA sequence files.  You must use the
exact variant of GFF described in L.  Various
command-line options allow you to control which database to load and
whether to allow an existing database to be overwritten.

This script is similar to load_gff.pl, but is much faster.  However,
it is hard-coded to use MySQL and probably only works on Unix
platforms due to its reliance on pipes.  See L for an
incremental loader that works with all databases supported by
Bio::DB::GFF, and L for a fast MySQL loader that
supports all platforms.

=head2 NOTES

If the filename is given as "-" then the input is taken from
standard input. Compressed files (.gz, .Z, .bz2) are automatically
uncompressed.

FASTA format files are distinguished from GFF files by their filename
extensions.  Files ending in .fa, .fasta, .fast, .seq, .dna and their
uppercase variants are treated as FASTA files.  Everything else is
treated as a GFF file.  If you wish to load -fasta files from STDIN,
then use the -f command-line swith with an argument of '-', as in 

    gunzip my_data.fa.gz | bp_fast_load_gff.pl -d test -f -

The nature of the load requires that the database be on the local
machine and that the indicated user have the "file" privilege to load
the tables and have enough room in /usr/tmp (or whatever is specified
by the \$TMPDIR environment variable), to hold the tables transiently.
If your MySQL is version 3.22.6 and was compiled using the "load local
file" option, then you may be able to load remote databases with local
data using the --local option.

About maxfeature: the default value is 100,000,000 bases.  If you have
features that are close to or greater that 100Mb in length, then the
value of maxfeature should be increased to 1,000,000,000. This value
must be a power of 10.

If the list of GFF or fasta files exceeds the kernel limit for the
maximum number of command-line arguments, use the
--long_list /path/to/files option.

The adaptor used is dbi::mysqlopt.  There is currently no way to
change this.

=head1 COMMAND-LINE OPTIONS

Command-line options can be abbreviated to single-letter options.
e.g. -d instead of --database.

   --database       Mysql database name
   --create              Reinitialize/create data tables without asking
   --local               Try to load a remote database using local data.
   --user                Username to log in as
   --fasta               File or directory containing fasta files to load
   --password            Password to use for authentication
   --long_list           Directory containing a very large number of
                         GFF and/or FASTA files
   --maxfeature          Set the value of the maximum feature size (default 100Mb; must be a power of 10)
   --group               A list of one or more tag names (comma or space separated)
                         to be used for grouping in the 9th column.
   --gff3_munge          Activate GFF3 name munging (see Bio::DB::GFF)
   --summary             Generate summary statistics for drawing coverage histograms.
                           This can be run on a previously loaded database or during
                           the load.
   --Temporary           Location of a writable scratch directory

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Lincoln Stein, lstein@cshl.org

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

package Bio::DB::GFF::Adaptor::faux;

use Bio::DB::GFF::Adaptor::dbi::mysqlopt;
use vars '@ISA';
@ISA = 'Bio::DB::GFF::Adaptor::dbi::mysqlopt';

sub insert_sequence {
  my $self = shift;
  my ($id,$offset,$seq) = @_;
  print join "\t",$id,$offset,$seq,"\n";
}

package main;

eval "use Time::HiRes"; undef $@;
my $timer = defined &Time::HiRes::time;

my ($DSN,$CREATE,$USER,$PASSWORD,$FASTA,$FAILED,$LOCAL,%PID,$MAX_BIN,$GROUP_TAG,$LONG_LIST,$MUNGE,$TMPDIR,$SUMMARY_STATS);

if ($DO_FAST) {
  $SIG{CHLD} = sub {
    while ((my $child = waitpid(-1,&WNOHANG)) > 0) {
      delete $PID{$child} or next;
      $FAILED++ if $? != 0;
    }
  }
};

$SIG{INT} = $SIG{TERM} = sub {cleanup(); exit -1};

GetOptions ('database:s'    => \$DSN,
	    'create'        => \$CREATE,
	    'user:s'        => \$USER,
            'local'         => \$LOCAL,
	    'password:s'    => \$PASSWORD,
	    'fasta:s'       => \$FASTA,
	    'group:s'       => \$GROUP_TAG,
	    'long_list:s'   => \$LONG_LIST,
            'maxbin|maxfeature:s'    => \$MAX_BIN,
	    'gff3_munge'    => \$MUNGE,
	    'summary'       => \$SUMMARY_STATS,
	    'Temporary:s'   => \$TMPDIR,
	   ) or (system('pod2text',$0), exit -1);

$DSN ||= 'test';
$MAX_BIN ||= 1_000_000_000; # to accomodate human-sized chromosomes

my (@args,$AUTH);
if (defined $USER) {
  push @args,(-user=>$USER);
  $AUTH .= " -u$USER";
}
if (defined $PASSWORD) {
  push @args,(-pass=>$PASSWORD);
  $AUTH .= " -p$PASSWORD";
}
push @args,(-preferred_groups=>[split(/[,\s+]+/,$GROUP_TAG)]) if defined $GROUP_TAG;

my $db = Bio::DB::GFF->new(-adaptor=>'faux',-dsn => $DSN,@args)
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";

$db->gff3_name_munging(1) if $MUNGE;

if ($CREATE) {
  $SUMMARY_STATS++;
  $MAX_BIN ? $db->initialize(-erase=>1,-MAX_BIN=>$MAX_BIN) : $db->initialize(1);
}

$MAX_BIN ||= $db->meta('max_bin') || 100_000_000;

# deal with really long lists of files
if ($LONG_LIST) {
  -d $LONG_LIST or die "The --long_list argument must be a directory\n";
  opendir GFFDIR,$LONG_LIST or die "Could not open $LONG_LIST for reading: $!";
  @ARGV = map { "$LONG_LIST\/$_" } readdir GFFDIR;
  closedir GFFDIR;
  
  if (defined $FASTA && -d $FASTA) {
    opendir FASTA,$FASTA or die "Could not open $FASTA for reading: $!";
    push @ARGV, map { "$FASTA\/$_" } readdir FASTA;
    closedir FASTA;
  }
}

foreach (@ARGV) {
  $_ = "gunzip -c $_ |" if /\.gz$/;
  $_ = "uncompress -c $_ |" if /\.Z$/;
  $_ = "bunzip2 -c $_ |" if /\.bz2$/;
}
my(@fasta,@gff);
foreach (@ARGV) {
  if (/\.(fa|fasta|dna|seq|fast)(?:\.|$)/i) {
    push @fasta,$_;
  } else {
    push @gff,$_;
  }
}
@ARGV = @gff;
push @fasta,$FASTA if defined $FASTA;

# initialize state variables
my $FID     = 1;
my $GID     = 1;
my $FTYPEID = 1;
my $ATTRIBUTEID = 1;
my %GROUPID     = ();
my %FTYPEID     = ();
my %ATTRIBUTEID = ();
my %DONE        = ();
my $FEATURES    = 0;

load_tables($db->dbh) unless $CREATE;
my ($major,$minor,$sub) = split /\./,$db->dbh->get_info(18); # SQL_DBMS_VER
my $can_disable_indexes = ($major >= 4 and $minor >= 0);

# open up pipes to the database
my (%FH,%COMMAND);
my $MYSQL  = MYSQL;
my $tmpdir = $TMPDIR || $ENV{TMPDIR} || $ENV{TMP} || File::Spec->tmpdir();
-d $tmpdir or die <new($file,'>') or die $_,": $!";
  print STDERR "ok\n";
  $FH{$_}->autoflush;
}

print STDERR "Fast loading enabled\n"    if $DO_FAST;

my ($count,$gff3,$last,$start,$beginning,$current_file);

$last  = Time::HiRes::time() if $timer;
$beginning = $start = $last;

# avoid hanging on standalone --fasta load
if (!@ARGV) {
    $FH{NULL} = IO::File->new(">$tmpdir/null");
    push @ARGV, "$tmpdir/null";
}

while (<>) {

  # reset GFF3 flag if new filehandle
  $current_file ||= $ARGV;
  unless ($current_file eq $ARGV) {
    undef $gff3;
    $current_file = $ARGV;
  }

  chomp;
  my ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group);

  # close sequence filehandle if required
  if ( /^\#|\s+|^$|^>|\t/ && defined $FH{FASTA}) {
      $FH{FASTA}->close;
      delete $FH{FASTA};
  }

  # print to fasta file if the handle is open
  if ( defined $FH{FASTA} ) {
      $FH{FASTA}->print("$_\n");
      next;
  }

  elsif (/^>(\S+)/) {  # uh oh, sequence coming
      $FH{FASTA} = IO::File->new(">$tmpdir/$1\.fa") or die "FASTA: $!\n";
      $FH{FASTA}->print("$_\n");
      push @fasta, "$tmpdir/$1\.fa";
      push @fasta_files_to_be_unlinked,"$tmpdir/$1\.fa";
      print STDERR "Processing embedded sequence $1\n";
      next;
  }

  elsif (/^\#\#\s*group-tags\s+(.+)/) {
    $db->preferred_groups(split(/\s+/,$1));
    next;
  }

  elsif (/^\#\#\s*gff-version\s+(\d+)/) {
    $gff3 = ($1 >= 3);
    $db->print_gff3_warning() if $gff3;
    next;
  }

  elsif (/^\#\#\s*sequence-region\s+(\S+)\s+(\d+)\s+(\d+)/i) { # header line
    ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) = 
      ($1,'reference','Component',$2,$3,'.','.','.',$gff3 ? "ID=Sequence:$1": qq(Sequence "$1"));
  }

  elsif (/^\#/) {
    next;
  }

  else {
    ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) = split "\t";
  }
  next unless defined $ref;
  $FEATURES++;

  warn "Feature $group is larger than $MAX_BIN. You will have trouble retrieving this feature.\nRerun script with --maxfeature set to a higher power of 10.\n" if $stop-$start+1 > $MAX_BIN;

  $source = '\N' unless defined $source;
  $score  = '\N' if $score  eq '.';
  $strand = '\N' if $strand eq '.';
  $phase  = '\N' if $phase  eq '.';

  my ($gclass,$gname,$target_start,$target_stop,$attributes) = $db->split_group($group,$gff3);
  # GFF2/3 transition
  $gclass = [$gclass] unless ref $gclass;
  $gname  = [$gname]  unless ref $gname;

  for (my $i=0; $i < @$gname; $i++) {
    my $group_class = $gclass->[$i];
    my $group_name  = $gname->[$i];
    $group_class  ||= '\N';
    $group_name   ||= '\N';
    $target_start ||= '\N';
    $target_stop  ||= '\N';
    $method       ||= '\N';
    $source       ||= '\N';

    my $fid     = $FID++;
    my $gid     = $GROUPID{lc join($;,$group_class,$group_name)} ||= $GID++;
    my $ftypeid = $FTYPEID{lc join($;,$source,$method)}          ||= $FTYPEID++;

    my $bin = bin($start,$stop,$db->min_bin);
    $FH{ FDATA()  }->print(    join("\t",$fid,$ref,$start,$stop,$bin,$ftypeid,$score,$strand,$phase,$gid,$target_start,$target_stop),"\n"   );
    $FH{ FGROUP() }->print(    join("\t",$gid,$group_class,$group_name),"\n"              ) unless $DONE{"fgroup$;$gid"}++;
    $FH{ FTYPE()  }->print(    join("\t",$ftypeid,$method,$source),"\n"                   ) unless $DONE{"ftype$;$ftypeid"}++;

    foreach (@$attributes) {
      my ($key,$value) = @$_;
      my $attributeid = $ATTRIBUTEID{lc $key}   ||= $ATTRIBUTEID++;
      $FH{ FATTRIBUTE() }->print( join("\t",$attributeid,$key),"\n"                       ) unless $DONE{"fattribute$;$attributeid"}++;
      $FH{ FATTRIBUTE_TO_FEATURE() }->print( join("\t",$fid,$attributeid,$value),"\n");
    }

    if ( $FEATURES % 1000 == 0) {
      my $now    = Time::HiRes::time() if $timer;
      my $elapsed = $timer ? sprintf(" in %5.2fs",$now - $last) : '';
      $last = $now;
      print STDERR "$fid features parsed$elapsed...";
      print STDERR -t STDOUT && !$ENV{EMACS} ? "\r" : "\n";
    }
  }
}

$FH{FASTA}->close if exists $FH{FASTA};

printf STDERR "Feature load time %5.2fs\n",(Time::HiRes::time() - $start) if $timer;
$start = time();

for my $fasta (@fasta) {
  warn "Loading fasta ",(-d $fasta?"directory":"file"), " $fasta\n";
  my $old = select($FH{FDNA()});
  my $loaded = $db->load_fasta($fasta);
  warn "$fasta: $loaded records loaded\n";
  select $old;
}

printf STDERR "Fasta load time %5.2fs\n",(Time::HiRes::time() - $start) if $timer;
$start = time();

my $success = 1;
if ($DO_FAST) {
  warn "Indexing and analyzing tables.  This may take some time (you may see database messages during the process)...\n";
}

$_->close foreach values %FH;

if (!$DO_FAST) {
  warn "Loading feature data and analyzing tables.  You may see database messages here...\n";
  $success &&= system($COMMAND{$_}) == 0 foreach @files;
}

# wait for children
while (%PID) {
  sleep;
}
$success &&= !$FAILED;

cleanup();

printf STDERR "Total parse & load time %5.2fs\n",(Time::HiRes::time() - $beginning) if $timer;

if ($success) {
  print "SUCCESS: $FEATURES features successfully loaded\n";
  exit 0;
} else {
  print "FAILURE: Please see standard error for details\n";
  exit -1;
}

if ($SUMMARY_STATS) {
    warn "Building summary statistics for coverage histograms...\n";
    $db->build_summary_statistics;
}

exit 0;

sub cleanup {
  foreach (@files,@fasta_files_to_be_unlinked) {
    unlink "$tmpdir/$_.$$";
  }
}

# load copies of some of the tables into memory
sub load_tables {
  my $dbh = shift;
  print STDERR "loading normalized group, type and attribute information...";
  $FID         = 1 + get_max_id($dbh,'fdata','fid');
  $GID         = 1 + get_max_id($dbh,'fgroup','gid');
  $FTYPEID     = 1 + get_max_id($dbh,'ftype','ftypeid');
  $ATTRIBUTEID = 1 + get_max_id($dbh,'fattribute','fattribute_id');
  get_ids($dbh,\%DONE,\%GROUPID,'fgroup','gid','gclass','gname');
  get_ids($dbh,\%DONE,\%FTYPEID,'ftype','ftypeid','fsource','fmethod');
  get_ids($dbh,\%DONE,\%ATTRIBUTEID,'fattribute','fattribute_id','fattribute_name');
  print STDERR "ok\n";
}

sub get_max_id {
  my $dbh = shift;
  my ($table,$id) = @_;
  my $sql = "select max($id) from $table";
  my $result = $dbh->selectcol_arrayref($sql) or die $dbh->errstr;
  $result->[0];
}

sub get_ids {
  my $dbh = shift;
  my ($done,$idhash,$table,$id,@columns) = @_;
  my $columns = join ',',$id,@columns;
  my $sql = "select $columns from $table";
  my $sth = $dbh->prepare($sql) or die $dbh->errstr;
  $sth->execute or die $dbh->errstr;
  while (my($id,@cols) = $sth->fetchrow_array) {
    my $key = lc join $;,@cols;
    $idhash->{$key} = $id;
    $done->{$table,$id}++;
  }
}

__END__
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_genbank2gff.pl000444000765000024      2406612254227326 21744 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use lib '.';

use strict;
use warnings;
use Bio::DB::GFF;
use Getopt::Long;

=head1 NAME

bp_genbank2gff.pl - Load a Bio::DB::GFF database from GENBANK files.

=head1 SYNOPSIS

  % bp_genbank2gff.pl -d genbank -f localfile.gb
  % bp_genbank2gff.pl -d genbank --accession AP003256
  % bp_genbank2gff.pl --accession AP003256 --stdout

=head1 DESCRIPTION

This script loads a Bio::DB::GFF database with the features contained
in a either a local genbank file or an accession that is fetched from
genbank.  Various command-line options allow you to control which
database to load and whether to allow an existing database to be
overwritten.

The database must already have been created and the current user must
have appropriate INSERT and UPDATE privileges.  The --create option
will initialize a new database with the appropriate schema, deleting
any tables that were already there.

=head1 COMMAND-LINE OPTIONS

Command-line options can be abbreviated to single-letter options.
e.g. -d instead of --database.

   --create                 Force creation and initialization of database
   --dsn               Data source (default dbi:mysql:test)
   --user             Username for mysql authentication
   --pass         Password for mysql authentication
   --proxy           Proxy server to use for remote access
   --stdout                 direct output to STDOUT
   --adaptor       adaptor to use (eg dbi::mysql, dbi::pg, dbi::oracle)   --viral                  the genome you are loading is viral (changes tag
                                 choices)
   --source         source field for features ['genbank']
    EITHER --file           Arguments that follow are Genbank/EMBL file names
    OR --gb_folder          What follows is a folder full of gb files to process    OR --accession          Arguments that follow are genbank accession numbers
                                 (not gi!)
    OR --acc_file           Accession numbers (not gi!) in a file (one per line,                                 no punc.)
    OR --acc_pipe           Accession numbers (not gi!) from a STDIN pipe (one
                                 per line)


=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Scott Cain, cain@cshl.org

Copyright (c) 2003 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

package Bio::DB::GFF::Adaptor::biofetch_to_stdout;
use CGI 'escape';
use Bio::DB::GFF::Util::Rearrange;
use Bio::DB::GFF::Adaptor::biofetch;
use vars '@ISA';
@ISA = 'Bio::DB::GFF::Adaptor::biofetch';

sub load_gff_line {
  my ($self,$options) = @_;
  # synthesize GFF3-compatible line
  my @attributes;
  if (my $id = $options->{gname}) {
    my $parent = $id;
    $parent    =~ s/\..\d+$//                  if     $options->{method} =~ /^(mRNA|transcript|exon|gene)$/;
    push @attributes,"Parent=".escape($parent) if     $options->{method} =~ /^(variation|exon|CDS|transcript|mRNA|coding)$/;
    push @attributes,"ID=".escape($id)         unless $options->{method} =~ /^(exon|CDS)$/;
  }
  if (my $tstart = $options->{tstart}) {
    my $tstop    = $options->{tstop};
    my $target   = escape($options->{gname});
    push @attributes,"Target=$target+$tstart+$tstop";
  }
  my %a;
  if (my $attributes = $options->{attributes}) {
    for my $a (@$attributes) {
      my ($tag,$value) = @$a;
      push @{$a{escape($tag)}},escape($value);
    }
    for my $a (keys %a) {
       push @attributes,"$a=".join(',',@{$a{$a}});
    }
  }
  ${$options}{'score'} = "." unless ${$options}{'score'};
  ${$options}{'strand'} = "." unless ${$options}{'strand'};
  ${$options}{'phase'} = "." unless ${$options}{'phase'};
  my $last_column = join ';',@attributes;
  if ($options->{method} eq 'origin') {
     print "##sequence-region $options->{gname} $options->{start} $options->{stop}\n";
  }
  print join("\t",@{$options}{qw(ref source method start stop score strand phase)},$last_column),"\n";
}

sub load_sequence_string {
  my $self = shift;
  my ($acc,$seq)  = @_;
  return unless $seq;
  $seq =~ s/(.{1,60})/$1\n/g;
  print ">$acc\n\L$seq\U\n";
}

sub setup_load {
   my $self = shift;
   print "##gff-version 3\n";
}

sub finish_load { }

1;

package main;

my $USAGE = < ] ...
Load a Bio::DB::GFF database from GFF files.

 Options:
   --create                 Force creation and initialization of database
   --dsn               Data source (default dbi:mysql:test)
   --user             Username for mysql authentication
   --pass         Password for mysql authentication
   --proxy           Proxy server to use for remote access
   --stdout                 direct output to STDOUT
   --adaptor       adaptor to use (eg dbi::mysql, dbi::pg, dbi::oracle)
   --viral                  the genome you are loading is viral (changes tag
                                 choices)
   --source         source field for features ['genbank']
    EITHER --file           Arguments that follow are Genbank/EMBL file names
    OR --gb_folder          What follows is a folder full of gb files to process
    OR --accession          Arguments that follow are genbank accession numbers
                                 (not gi!)
    OR --acc_file           Accession numbers (not gi!) in a file (one per line,
                                 no punc.) 
    OR --acc_pipe           Accession numbers (not gi!) from a STDIN pipe (one
                                 per line)   


This script loads a Bio::DB::GFF database with the features contained
in a either a local genbank file or an accession that is fetched from
genbank.  Various command-line options allow you to control which
database to load and whether to allow an existing database to be
overwritten.

USAGE
;

my ($DSN,$ADAPTOR,$CREATE,$USER,$VIRAL,$PASSWORD,$gbFOLDER,
    $FASTA,$ACC,$accFILE, $accPIPE, $FILE,$PROXY,$STDOUT,$SOURCE);


GetOptions (
            'dsn:s'       => \$DSN,
            'user:s'      => \$USER,
            'password:s'  => \$PASSWORD,
            'adaptor:s'   => \$ADAPTOR,
            'accession'   => \$ACC,
            'file'        => \$FILE,
            'viral'       => \$VIRAL,
            'acc_file'    => \$accFILE,
            'acc_pipe'    => \$accPIPE,
	    'source:s'    => \$SOURCE,
            'gb_folder=s' => \$gbFOLDER,
            'proxy:s'     => \$PROXY,
            'stdout'      => \$STDOUT,
            'create'      => \$CREATE) or die $USAGE;


die $USAGE unless ($DSN || $STDOUT);  # at a minimum we need to have a place to write to!

# some local defaults
$DSN     ||= 'dbi:mysql:test';
$ADAPTOR ||= $STDOUT ? 'memory' : 'dbi::mysql';

# Ensure that biofetch inherits from the "right" adaptor.
# This is a horrible hack and should be fixed.
eval "use Bio::DB::GFF::Adaptor::${ADAPTOR}";
local @Bio::DB::GFF::Adaptor::biofetch::ISA = "Bio::DB::GFF::Adaptor::${ADAPTOR}";

my $biofetch = $STDOUT ? 'biofetch_to_stdout' : 'biofetch';
my @dsn      = $STDOUT ? () : (-dsn => $DSN);

my @auth;
push @auth,(-user=>$USER)     if defined $USER;
push @auth,(-pass=>$PASSWORD) if defined $PASSWORD;
push @auth,(-proxy=>$PROXY)   if defined $PROXY;

my %preferred_tags = (
		      strain        => 10,
		      organism      => 20,
		      protein_id    => 40,
		      locus_tag     => 50,
		      locus         => 60,
		      gene          => 70,
		      standard_name => 80,
                     );
$preferred_tags{'product'} = 90 if $VIRAL; # added this to the default list for viral genomes
       # since most functions come from post-translational processing, so the default labels are c**p!

my $db = Bio::DB::GFF->new(-adaptor=>$biofetch,
			   @dsn,
			   @auth,
			   -preferred_tags => \%preferred_tags,
			   -source=> $SOURCE || 'Genbank')
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";

if ($CREATE) {
  $db->initialize(1);
}

die "you must specify either an accession to retrieve from\nembl or a local file containing data in embl format\n" if (($FILE || $ACC) && !scalar(@ARGV));

if ($ACC) {
  while ($_ = shift) {
    status(loading => $_);
    my $result = $db->load_from_embl(/^NC_/?'refseq':'embl' => $_);
    status(done    => $result);
  }
  exit 1;
}

elsif ($FILE) {
  while ($_ = shift) {
    status('loading' => $_);
    my $result = $db->load_from_file($_);
    status (done => $result);
  }
  exit 1;
}

elsif ($accFILE){
    my $filename = shift;
    die "you must supply a filename after the --accFILE command line flag\n" unless $filename;
    die "file $filename does not exist\n" unless (-e $filename && !(-d $filename));
    open IN, "$filename" || die "Can't open file $filename for reading accession numbers: $!\n";
    while (){
        chomp;
	status(loading => $_);
        my $result = $db->load_from_embl(/^NC_/?'refseq':'embl' => $_);
	status(done => $result);
    }
    exit 1;
}

elsif ($gbFOLDER){
    my $dir = $gbFOLDER;
    die "folder $dir does not exist\n" unless (-e $dir && -d $dir);
    opendir DIR, "$dir" || die "can't open directory $dir for reading: $!\n";
    my @files = readdir DIR;
    foreach my $file(@files){
        if (!(-e "$gbFOLDER/$file") || (-d "$gbFOLDER/$file")){
            print STDERR " $gbFOLDER/$file is not a filename!  Skipping...\n";
            next
        }
        my $result = $db->load_from_file("$gbFOLDER/$file");
        print STDERR $result ? "ok\n" : "failed\n";        
    }
} elsif ($accPIPE){
    my @accessions = ;
    chomp @accessions;
    foreach (@accessions){
      status(loading => $_);
      my $result = $db->load_from_embl(/^NC_/?'refseq':'embl' => $_);
      status(done => $result);
    }
    exit 1;
}

else {
  my $done;
  while ($_ = shift) {
    $done = 1;
    status(loading => $_);
    my $result = $db->load_from_file($_);
    status(done => $result);
  }

  $done || die "\n\nno source of data provided\n\n";
  exit 1;
}

sub status {
  my ($state,$msg) = @_;
  return if $STDOUT;
  if ($state eq 'loading') {
    print STDERR "Loading $msg...";
  } elsif ($state eq 'done') {
    print STDERR $msg ? "ok\n" : "failed\n";
  }
}
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_genbank2gff3.pl000444000765000024     23377612254227317 22061 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl



=pod

=head1 NAME 

bp_genbank2gff3.pl -- Genbank-Egbrowse-friendly GFF3

=head1 SYNOPSIS

  bp_genbank2gff3.pl [options] filename(s)

  # process a directory containing GenBank flatfiles
  perl bp_genbank2gff3.pl --dir path_to_files --zip

  # process a single file, ignore explicit exons and introns
  perl bp_genbank2gff3.pl --filter exon --filter intron file.gbk.gz

  # process a list of files 
  perl bp_genbank2gff3.pl *gbk.gz

  # process data from URL, with Chado GFF model (-noCDS), and pipe to database loader
  curl ftp://ftp.ncbi.nih.gov/genomes/Saccharomyces_cerevisiae/CHR_X/NC_001142.gbk \
  | perl bp_genbank2gff3.pl -noCDS -in stdin -out stdout \
  | perl gmod_bulk_load_gff3.pl -dbname mychado -organism fromdata

    Options:
        --noinfer  -r  don't infer exon/mRNA subfeatures
        --conf     -i  path to the curation configuration file that contains user preferences
                       for Genbank entries (must be YAML format)
                       (if --manual is passed without --ini, user will be prompted to 
                        create the file if any manual input is saved)
        --sofile  -l  path to to the so.obo file to use for feature type mapping
                       (--sofile live will download the latest online revision)
        --manual   -m  when trying to guess the proper SO term, if more than
                       one option matches the primary tag, the converter will 
                       wait for user input to choose the correct one
                       (only works with --sofile)
        --dir      -d  path to a list of genbank flatfiles
        --outdir   -o  location to write GFF files (can be 'stdout' or '-' for pipe)
        --zip      -z  compress GFF3 output files with gzip
        --summary  -s  print a summary of the features in each contig
        --filter   -x  genbank feature type(s) to ignore
        --split    -y  split output to separate GFF and fasta files for
                       each genbank record
        --nolump   -n  separate file for each reference sequence
                       (default is to lump all records together into one 
                       output file for each input file)
        --ethresh  -e  error threshold for unflattener
                       set this high (>2) to ignore all unflattener errors
        --[no]CDS  -c  Keep CDS-exons, or convert to alternate gene-RNA-protein-exon 
                       model. --CDS is default. Use --CDS to keep default GFF gene model, 
                       use --noCDS to convert to g-r-p-e.
        --format   -f  Input format (SeqIO types): GenBank, Swiss or Uniprot, EMBL work
                       (GenBank is default)
        --GFF_VERSION  3 is default, 2 and 2.5 and other Bio::Tools::GFF versions available
        --quiet        don't talk about what is being processed 
        --typesource   SO sequence type for source (e.g. chromosome; region; contig)
        --help     -h  display this message


=head1 DESCRIPTION

This script uses Bio::SeqFeature::Tools::Unflattener and
Bio::Tools::GFF to convert GenBank flatfiles to GFF3 with gene
containment hierarchies mapped for optimal display in gbrowse.

The input files are assumed to be gzipped GenBank flatfiles for refseq
contigs.  The files may contain multiple GenBank records.  Either a
single file or an entire directory can be processed.  By default, the
DNA sequence is embedded in the GFF but it can be saved into separate
fasta file with the --split(-y) option.

If an input file contains multiple records, the default behaviour is
to dump all GFF and sequence to a file of the same name (with .gff
appended).  Using the 'nolump' option will create a separate file for
each genbank record.  Using the 'split' option will create separate
GFF and Fasta files for each genbank record.


=head2 Notes

=head3 'split' and 'nolump' produce many files

In cases where the input files contain many GenBank records (for
example, the chromosome files for the mouse genome build), a very
large number of output files will be produced if the 'split' or
'nolump' options are selected.  If you do have lists of files E 6000,
use the --long_list option in bp_bulk_load_gff.pl or
bp_fast_load_gff.pl to load the gff and/ or fasta files.

=head3 Designed for RefSeq

This script is designed for RefSeq genomic sequence entries.  It may
work for third party annotations but this has not been tested.
But see below, Uniprot/Swissprot works, EMBL and possibly EMBL/Ensembl
if you don't mind some gene model unflattener errors (dgg).

=head3 G-R-P-E Gene Model

Don Gilbert worked this over with needs to produce GFF3 suited to
loading to GMOD Chado databases.  Most of the changes I believe are
suited for general use.  One main chado-specific addition is the
  --[no]cds2protein  flag

My favorite GFF is to set the above as ON by default (disable with --nocds2prot)
For general use it probably should be OFF, enabled with --cds2prot.

This writes GFF with an alternate, but useful Gene model,
instead of the consensus model for GFF3 

  [ gene > mRNA> (exon,CDS,UTR) ]

This alternate is

  gene > mRNA > polypeptide > exon 

means the only feature with dna bases is the exon.  The others
specify only location ranges on a genome.  Exon of course is a child
of mRNA and protein/peptide.   

The protein/polypeptide feature is an important one, having all the
annotations of the GenBank CDS feature, protein ID, translation, GO
terms, Dbxrefs to other proteins.

UTRs, introns, CDS-exons are all inferred from the primary exon bases
inside/outside appropriate higher feature ranges.   Other special gene
model features remain the same.

Several other improvements and bugfixes, minor but useful are included

  * IO pipes now work:
    curl ftp://ncbigenomes/... | bp_genbank2gff3 --in stdin --out stdout | gff2chado ...

  * GenBank main record fields are added to source feature, e.g. organism, date,
    and the sourcetype, commonly chromosome for  genomes, is used.

  * Gene Model handling for ncRNA, pseudogenes are added.

  * GFF header is cleaner, more informative.
    --GFF_VERSION flag allows choice of v2 as well as default v3

  * GFF ##FASTA inclusion is improved, and
    CDS translation sequence is moved to FASTA records.

  * FT -> GFF attribute mapping is improved.

  * --format choice of SeqIO input formats (GenBank default). 
    Uniprot/Swissprot and EMBL work and produce useful GFF.

  * SeqFeature::Tools::TypeMapper has a few FT -> SOFA additions
      and more flexible usage.

=head1 TODO

=head2 Are these additions desired?

 * filter input records by taxon (e.g. keep only organism=xxx or taxa level = classYYY
 * handle Entrezgene, other non-sequence SeqIO structures (really should change
    those parsers to produce consistent annotation tags).

=head2 Related bugfixes/tests

These items from Bioperl mail were tested (sample data generating
errors), and found corrected:

 From: Ed Green  eva.mpg.de>
 Subject: genbank2gff3.pl on new human RefSeq
 Date: 2006-03-13 21:22:26 GMT 
   -- unspecified errors (sample data works now).

 From: Eric Just  northwestern.edu>
 Subject: genbank2gff3.pl
 Date: 2007-01-26 17:08:49 GMT
   -- bug fixed in genbank2gff3 for multi-record handling

This error is for a /trans_splice gene that is hard to handle, and
unflattner/genbank2 doesn't

 From: Chad Matsalla  dieselwurks.com> 
 Subject: genbank2gff3.PLS and the unflatenner - Inconsistent order?
 Date: 2005-07-15 19:51:48 GMT 

=head1 AUTHOR 

Sheldon McKay (mckays@cshl.edu)

Copyright (c) 2004 Cold Spring Harbor Laboratory.

=head2 AUTHOR of hacks for GFF2Chado loading

Don Gilbert (gilbertd@indiana.edu)


=cut

use strict;
use warnings;

use lib "$ENV{HOME}/bioperl-live";
# chad put this here to enable situations when this script is tested
# against bioperl compiled into blib along with other programs using blib
BEGIN {
        unshift(@INC,'blib/lib');
};
use Pod::Usage;
use Bio::Root::RootI;
use Bio::SeqIO;
use File::Spec;
use Bio::SeqFeature::Tools::Unflattener;
use Bio::SeqFeature::Tools::TypeMapper;
use Bio::SeqFeature::Tools::IDHandler;
use Bio::Location::SplitLocationI;
use Bio::Location::Simple;
use Bio::Tools::GFF;
use Getopt::Long;
use List::Util qw(first);
use Bio::OntologyIO;
use YAML qw(Dump LoadFile DumpFile);
use File::Basename; 

use vars qw/$split @filter $zip $outdir $help $ethresh
            $ONTOLOGY %FEATURES %DESCENDANTS @RETURN $MANUAL @GFF_LINE_FEAT
            $CONF $YAML $TYPE_MAP $SYN_MAP $noinfer $SO_FILE 
            $file @files $dir $summary $nolump 
            $source_type %proteinfa %exonpar $didheader $verbose $DEBUG $GFF_VERSION 
            $gene_id $rna_id $tnum $ncrna_id $rnum %method %id %seen/;

use constant SO_URL => 
    'http://song.cvs.sourceforge.net/viewvc/*checkout*/song/ontology/so.obo';
use constant ALPHABET => [qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)];
use constant ALPHABET_TO_NUMBER => {
    a => 0, b => 1, c => 2, d => 3, e => 4, f => 5, g => 6, h => 7, i => 8, 
    j => 9, k => 10, l => 11, m => 12, n => 13, o => 14, p => 15, q => 16,
    r => 17, s => 18, t => 19, u => 20, v => 21, w => 22, x => 23, y => 24,
    z => 25,
    };
use constant ALPHABET_DIVISOR => 26;
use constant GM_NEW_TOPLEVEL => 2;
use constant GM_NEW_PART => 1;
use constant GM_DUP_PART => 0;
use constant GM_NOT_PART => -1;

# Options cycle in multiples of 2 because of left side/right side pairing. 
# You can make this number odd, but displayed matches will still round up
use constant OPTION_CYCLE => 6; 

$GFF_VERSION = 3; # allow v2 ...
$verbose = 1; # right default? -nov to turn off

# dgg: change the gene model to  Gene/mRNA/Polypeptide/exons...
my $CDSkeep= 1; # default should be ON (prior behavior), see gene_features()
my $PROTEIN_TYPE = 'polypeptide'; # for noCDSkeep; 
  # protein = flybase chado usage; GMOD Perls use 'polypeptide' with software support

my $FORMAT="GenBank"; # swiss ; embl; genbank ; ** guess from SOURCEID **
my $SOURCEID= $FORMAT; # "UniProt" "GenBank"  "EMBL" should work  
   # other Bio::SeqIO formats may work.  TEST: EntrezGene < problematic tags; InterPro  KEGG 


my %TAG_MAP = (
  db_xref => 'Dbxref',
  name => 'Name',
  note => 'Note', # also pull GO: ids into Ontology_term
  synonym => 'Alias',
  symbol => 'Alias',  # is symbol still used?
  # protein_id => 'Dbxref', also seen Dbxref tags: EC_number 
  # translation: handled in gene_features
);


$| = 1;
my $quiet= !$verbose;
my $ok= GetOptions( 'd|dir|input:s'   => \$dir,
            'z|zip'     => \$zip, 
            'h|help'    => \$help,
            's|summary' => \$summary,
            'r|noinfer' => \$noinfer,
            'i|conf=s' => \$CONF,
            'sofile=s' => \$SO_FILE,
            'm|manual' => \$MANUAL,
            'o|outdir|output:s'=> \$outdir,
            'x|filter:s'=> \@filter,
            'y|split'   => \$split,
            "ethresh|e=s"=>\$ethresh,
            'c|CDS!'    => \$CDSkeep,
            'f|format=s' => \$FORMAT,
            'typesource=s' => \$source_type,
            'GFF_VERSION=s' => \$GFF_VERSION,
            'quiet!'    => \$quiet, # swap quiet to verbose
            'DEBUG!'    => \$DEBUG,
            'n|nolump'  => \$nolump);

my $lump = 1 unless $nolump || $split;
$verbose= !$quiet;

# look for help request
pod2usage(2) if $help || !$ok;

# keep SOURCEID as-is and change FORMAT for SeqIO types; 
# note SeqIO uses file.suffix to guess type; not useful here
$SOURCEID= $FORMAT; 
$FORMAT  = "swiss" if $FORMAT =~/UniProt|trembl/;
$verbose =1 if($DEBUG);

# initialize handlers
my $unflattener = Bio::SeqFeature::Tools::Unflattener->new; # for ensembl genomes (-trust_grouptag=>1);
$unflattener->error_threshold($ethresh) if $ethresh;
$unflattener->verbose(1) if($DEBUG);
# $unflattener->group_tag('gene') if($FORMAT =~ /embl/i) ; #? ensembl only? 
# ensembl parsing is still problematic, forget this

my $tm  = Bio::SeqFeature::Tools::TypeMapper->new;
my $idh = Bio::SeqFeature::Tools::IDHandler->new;

# dgg
$source_type ||= "region"; # should really parse from FT.source contents below

#my $FTSOmap = $tm->FT_SO_map();
my $FTSOmap;
my $FTSOsynonyms;

if (defined($SO_FILE) && $SO_FILE eq 'live') {
    print "\nDownloading the latest SO file from ".SO_URL."\n\n";
    use LWP::UserAgent;
    my $ua = LWP::UserAgent->new(timeout => 30);
    my $request = HTTP::Request->new(GET => SO_URL);
    my $response = $ua->request($request);


    if ($response->status_line =~ /200/) {
        use File::Temp qw/ tempfile /;
        my ($fh, $fn) = tempfile();
        print $fh $response->content;
        $SO_FILE = $fn;
    } else {
        print "Couldn't download SO file online...skipping validation.\n" 
            . "HTTP Status was " . $response->status_line . "\n" 
            and undef $SO_FILE
    }
}

if ($SO_FILE) {


    my (%terms, %syn);

    my $parser = Bio::OntologyIO->new( -format => "obo", -file => $SO_FILE );
    $ONTOLOGY = $parser->next_ontology();

    for ($ONTOLOGY->get_all_terms) { 
        my $feat = $_;

        $terms{$feat->name} = $feat->name;
        #$terms{$feat->name} = $feat;

        my @syn = $_->each_synonym;

        push @{$syn{$_}}, $feat->name for @syn;
        #push @{$syn{$_}}, $feat for @syn;
    }

    $FTSOmap = \%terms;
    $FTSOsynonyms = \%syn;

    my %hardTerms = %{ $tm->FT_SO_map() };
    map { $FTSOmap->{$_} ||= $hardTerms{$_} } keys %hardTerms;

} else { 
    my %terms = %{ $tm->FT_SO_map() };
    while (my ($k,$v) = each %terms) {
        $FTSOmap->{$k} = ref($v) ? shift @$v : $v;
    }
}

$TYPE_MAP = $FTSOmap;
$SYN_MAP = $FTSOsynonyms;


# #convert $FTSOmap undefined to valid SO : moved to TypeMapper->map_types( -undefined => "region")

# stringify filter list if applicable
my $filter = join ' ', @filter  if @filter;

# determine input files
my $stdin=0; # dgg: let dir == stdin == '-' for pipe use
if ($dir && ($dir eq '-' || $dir eq 'stdin')) {
  $stdin=1;  $dir=''; @files=('stdin');
  
} elsif ( $dir ) {
    if ( -d $dir ) {
        opendir DIR, $dir or die "could not open $dir for reading: $!";
        @files = map { "$dir/$_";} grep { /\.gb.*/ } readdir DIR;  
        closedir DIR;
    }
    else {
        die "$dir is not a directory\n";
    }
}
else {
    @files = @ARGV;
    $dir = '';
}

# we should have some files by now
pod2usage(2) unless @files;


my $stdout=0; # dgg: let outdir == stdout == '-' for pipe use
if($outdir && ($outdir eq '-' || $outdir eq 'stdout')) {
  warn("std. output chosen: cannot split\n") if($split);
  warn("std. output chosen: cannot zip\n") if($zip);
  warn("std. output chosen: cannot nolump\n") if($nolump);
  $stdout=1; $lump=1; $split= 0; $zip= 0; # unless we pipe stdout thru gzip
  
} elsif ( $outdir && !-e $outdir ) {
    mkdir($outdir) or die "could not create directory $outdir: $!\n";        
}
elsif ( !$outdir ) {
    $outdir = $dir || '.';
}

for my $file ( @files ) {
    # dgg ; allow 'stdin' / '-' input ?
    chomp $file;
    die "$! $file" unless($stdin || -e $file);
    print "# Input: $file\n" if($verbose);

    my ($lump_fh, $lumpfa_fh, $outfile, $outfa);
    if ($stdout) {
      $lump_fh= *STDOUT; $lump="stdout$$";
      $outfa= "stdout$$.fa";  # this is a temp file ... see below
      open $lumpfa_fh, ">$outfa" or die "Could not create a lump outfile called ($outfa) because ($!)\n";

    } elsif ( $lump ) {
        my ($vol,$dirs,$fileonly) = File::Spec->splitpath($file); 
        $lump = File::Spec->catfile($outdir, $fileonly.'.gff');
        ($outfa = $lump) =~ s/\.gff/\.fa/;
        open $lump_fh, ">$lump" or die "Could not create a lump outfile called ($lump) because ($!)\n";
        open $lumpfa_fh, ">$outfa" or die "Could not create a lump outfile called ($outfa) because ($!)\n";

    }
    
    # open input file, unzip if req'd
    if ($stdin) {
       *FH= *STDIN;   
    } elsif ( $file =~ /\.gz/ ) {
        open FH, "gunzip -c $file |";
    }
    else {
        open FH, "<$file";
    }

    my $in = Bio::SeqIO->new(-fh => \*FH, -format => $FORMAT, -debug=>$DEBUG);
    my $gffio = Bio::Tools::GFF->new( -noparse => 1, -gff_version => $GFF_VERSION );

    while ( my $seq = $in->next_seq() ) {
        my $seq_name = $seq->accession_number;
        my $end = $seq->length;
        my @to_print;

        # arrange disposition of GFF output
        $outfile = $lump || File::Spec->catfile($outdir, $seq_name.'.gff');
        my $out;

        if ( $lump ) {
            $outfile = $lump;
            $out = $lump_fh;
        }
        else {
            $outfile = File::Spec->catfile($outdir, $seq_name.'.gff');
            open $out, ">$outfile";
        }

        # filter out unwanted features
        my $source_feat= undef;
        my @source= filter($seq); $source_feat= $source[0];

        ($source_type,$source_feat)= 
          getSourceInfo( $seq, $source_type, $source_feat ) ;
          # always; here we build main prot $source_feat; # if @source;
          
        # abort if there are no features
        warn "$seq_name has no features, skipping\n" and next
            if !$seq->all_SeqFeatures;


        $FTSOmap->{'source'} = $source_type;
        ## $FTSOmap->{'CDS'}= $PROTEIN_TYPE; # handle this in gene_features

        # construct a GFF header
        # add: get source_type from attributes of source feature? chromosome=X tag
        # also combine 1st ft line here with source ft from $seq ..
        my($header,$info)= gff_header($seq_name, $end, $source_type, $source_feat);
        print $out $header;
        print "# working on $info\n" if($verbose);
        
        # unflatten gene graphs, apply SO types, etc; this also does TypeMapper ..
        unflatten_seq($seq);

        # Note that we use our own get_all_SeqFeatures function 
        # to rescue cloned exons

        @GFF_LINE_FEAT = ();
        for my $feature ( get_all_SeqFeatures($seq) ) {
            
            my $method = $feature->primary_tag;
            next if($SOURCEID =~/UniProt|swiss|trembl/i && $method ne $source_type);
            
            $feature->seq_id($seq->id) unless($feature->seq_id);
            $feature->source_tag($SOURCEID);
            
            # dgg; need to convert some Genbank to GFF tags: note->Note; db_xref->Dbxref;
            ## also, pull any GO:000 ids from /note tag and put into Ontology_term
            maptags2gff($feature);
            
            # current gene name.  The unflattened gene features should be in order so any
            # exons, CDSs, etc that follow will belong to this gene
            my $gene_name;
            if ( $method eq 'gene' || $method eq 'pseudogene' ) {
              @to_print= print_held($out, $gffio, \@to_print);
              $gene_id = $gene_name= gene_name($feature); 
            } else {
              $gene_name= gene_name($feature);
            }
        
            #?? should gene_name from /locus_tag,/gene,/product,/transposon=xxx
            # be converted to or added as  Name=xxx (if not ID= or as well)
            ## problematic: convert_to_name ($feature); # drops /locus_tag,/gene, tags
            convert_to_name($feature); 
            
            ## dgg: extended to protein|polypeptide
            ## this test ($feature->has_tag('gene') ||) is not good: repeat_regions over genes
            ## in yeast have that genbank tag; why?
            ## these include pseudogene ...
            
            ## Note we also have mapped types to SO, so these RNA's are now transcripts:
            # pseudomRNA => "pseudogenic_transcript", 
            # pseudotranscript" => "pseudogenic_transcript", 
            # misc_RNA=>'processed_transcript',

            warn "#at: $method $gene_id/$gene_name\n" if $DEBUG;

            if ( $method =~ /(gene|RNA|CDS|exon|UTR|protein|polypeptide|transcript)/ 
               || ( $gene_id && $gene_name eq $gene_id ) ) {
               
                my $action = gene_features($feature, $gene_id, $gene_name);  # -1, 0, 1, 2 result
                if ($action == GM_DUP_PART) {
                  # ignore, this is dupl. exon with new parent ...
                  
                } elsif ($action == GM_NOT_PART) {
                  add_generic_id( $feature, $gene_name, "nocount");
                  my $gff = $gffio->gff_string($feature);
                  push @GFF_LINE_FEAT, $feature;
                  #print $out "$gff\n" if $gff;

                } elsif ($action > 0) {
                 # hold off print because exon etc. may get 2nd, 3rd parents
                  @to_print= print_held($out, $gffio, \@to_print) if ($action == GM_NEW_TOPLEVEL);
                  push(@to_print, $feature);
                }

            }
            
            # otherwise handle as generic feats with IDHandler labels 
            else {
                add_generic_id( $feature, $gene_name, "");
                my $gff= $gffio->gff_string($feature);
                push @GFF_LINE_FEAT, $feature;
                #print $out "$gff\n" if $gff;
            }
        }

        # don't like doing this after others; do after each new gene id?
        @to_print= print_held($out, $gffio, \@to_print);

        gff_validate(@GFF_LINE_FEAT);

        for my $feature (@GFF_LINE_FEAT) {
            my $gff= $gffio->gff_string($feature);
            print $out "$gff\n" if $gff;
        }

        # deal with the corresponding DNA
        my ($fa_out,$fa_outfile);
        my $dna = $seq->seq;
        if($dna || %proteinfa) {
          $method{'RESIDUES'} += length($dna);
          $dna    =~ s/(\S{60})/$1\n/g;
          $dna   .= "\n";
          
          if ($split) {
              $fa_outfile = $outfile;
              $fa_outfile =~ s/gff$/fa/;
              open $fa_out, ">$fa_outfile" or die $!; 
              print $fa_out ">$seq_name\n$dna" if $dna;
              foreach my $aid (sort keys %proteinfa) { 
                my $aa= delete $proteinfa{$aid}; 
                $method{'RESIDUES(tr)'} += length($aa);
                $aa =~ s/(\S{60})/$1\n/g; 
                print $fa_out ">$aid\n$aa\n"; 
                }
               
          }
          else {
          ## problem here when multiple GB Seqs in one file; all FASTA needs to go at end of $out
          ## see e.g. Mouse: mm_ref_chr19.gbk has NT_082868 and NT_039687 parts in one .gbk
          ## maybe write this to temp .fa then cat to end of lumped gff $out
              print $lumpfa_fh ">$seq_name\n$dna" if $dna;
              foreach my $aid (sort keys %proteinfa) { 
                my $aa= delete $proteinfa{$aid}; 
                $method{'RESIDUES(tr)'} += length($aa);
                $aa =~ s/(\S{60})/$1\n/g; 
                print $lumpfa_fh ">$aid\n$aa\n"; 
                }
          }
          
        %proteinfa=();
        }
     
        if ( $zip && !$lump ) {
            system "gzip -f $outfile";
            system "gzip -f $fa_outfile" if($fa_outfile);
            $outfile .= '.gz';
            $fa_outfile .= '.gz' if $split;
        }

        # print "\n>EOF\n" if($stdout); #?? need this if summary goes to stdout after FASTA
        print "# GFF3 saved to $outfile" unless( !$verbose || $stdout || $lump);
        print ($split ? "; DNA saved to $fa_outfile\n" : "\n") unless($stdout|| $lump);
        
        # dgg: moved to after all inputs; here it prints cumulative sum for each record
        #if ( $summary ) {
        #      print "# Summary:\n# Feature\tCount\n# -------\t-----\n";
        #  
        #      for ( keys %method ) {
        #          print "# $_  $method{$_}\n";
        #      }
        #      print "# \n";
        #  }       
    
    }

    print "# GFF3 saved to $outfile\n" if( $verbose && $lump);
    if ( $summary ) {
        print "# Summary:\n# Feature\tCount\n# -------\t-----\n";
        for ( keys %method ) {
            print "# $_  $method{$_}\n";
        }
        print "# \n";
    }
    
    ## FIXME for piped output w/ split FA files ...
    close($lumpfa_fh) if $lumpfa_fh;
    if (!$split && $outfa && $lump_fh) {     
        print $lump_fh "##FASTA\n"; # GFF3 spec
        open $lumpfa_fh, $outfa or warn "reading FA $outfa: $!";
        while( <$lumpfa_fh>) {
            print $lump_fh $_;
        } # is $lump_fh still open?
        close($lumpfa_fh);
        unlink($outfa);
    }
        

    if ( $zip && $lump ) {
        system "gzip -f $lump";
    }
    
    close FH;
}





sub typeorder {
  return 1 if ($_[0] =~ /gene/);
  return 2 if ($_[0] =~ /RNA|transcript/);
  return 3 if ($_[0] =~ /protein|peptide/);
  return 4 if ($_[0] =~ /exon|CDS/);
  return 3; # default before exon (smallest part)
}

sub sort_by_feattype {
  my($at,$bt)= ($a->primary_tag, $b->primary_tag);
  return (typeorder($at) <=> typeorder($bt))  
    or ($at cmp $bt);
    ## or ($a->name() cmp $b->name());
}

sub print_held {  
  my($out,$gffio,$to_print)= @_;
  return unless(@$to_print);
  @$to_print = sort sort_by_feattype  @$to_print; # put exons after mRNA, otherwise chado loader chokes
  while ( my $feature = shift @$to_print) {
    my $gff= $gffio->gff_string($feature); # $gff =~ s/\'/./g; # dang bug in encode
    push @GFF_LINE_FEAT, $feature;
    #print $out "$gff\n";
    }
  return (); # @to_print
}

sub maptags2gff {
  my $f = shift;
  ## should copy/move locus_tag to Alias, if not ID/Name/Alias already
  # but see below /gene /locus_tag usage
  foreach my $tag (keys %TAG_MAP) {
    if ($f->has_tag($tag)) {
      my $newtag= $TAG_MAP{$tag};
      my @v= $f->get_tag_values($tag);
      $f->remove_tag($tag);
      $f->add_tag_value($newtag,@v);
      
      ## also, pull any GO:000 ids from /note tag and put into Ontology_term
      ## ncbi syntax in CDS /note is now '[goid GO:0005886]' OR '[goid 0005624]'
      if ($tag eq 'note') {  
        map { s/\[goid (\d+)/\[goid GO:$1/g; } @v; 
        my @go= map { m/(GO:\d+)/g } @v; 
        $f->add_tag_value('Ontology_term',@go) if(@go);
        }
      
      }
    }    
}


sub getSourceInfo {
  my ($seq, $source_type, $sf) = @_;  
  
  my $is_swiss= ($SOURCEID =~/UniProt|swiss|trembl/i);
  my $is_gene = ($SOURCEID =~/entrezgene/i);
  my $is_rich = (ref($seq) =~ /RichSeq/);
  my $seq_name= $seq->accession_number();
  
  unless($sf) { # make one
    $source_type=  $is_swiss ? $PROTEIN_TYPE 
        : $is_gene ? "eneg" # "gene"  # "region" # 
        : $is_rich ? $seq->molecule : $source_type;
    $sf = Bio::SeqFeature::Generic->direct_new();
    
    my $len = $seq->length(); $len=1 if($len<1); my $start = 1; ##$start= $len if ($len<1);
    my $loc= $seq->can('location') ? $seq->location() 
            :  new Bio::Location::Simple( -start => $start, -end => $len);
    $sf->location( $loc ); 
    $sf->primary_tag($source_type);
    $sf->source_tag($SOURCEID);
    $sf->seq_id( $seq_name);
    #? $sf->display_name($seq->id()); ## Name or Alias ?
    $sf->add_tag_value( Alias => $seq->id()); # unless id == accession
    $seq->add_SeqFeature($sf);
    ## $source_feat= $sf;
  }
  
  if ($sf->has_tag("chromosome")) {
    $source_type= "chromosome"; 
    my ($chrname) = $sf->get_tag_values("chromosome");
    ## PROBLEM with Name <> ID, RefName for Gbrowse; use Alias instead
    ## e.g. Mouse chr 19 has two IDs in NCBI genbank now
    $sf->add_tag_value( Alias => $chrname );
  }

  # pull GB Comment, Description for source ft ...
  # add reference - can be long, not plain string...             
  warn "# $SOURCEID:$seq_name fields = ", join(",", $seq->annotation->get_all_annotation_keys()),"\n" if $DEBUG;
  # GenBank   fields: keyword,comment,reference,date_changed
  # Entrezgene fields 850293 =ALIAS_SYMBOL,RefSeq status,chromosome,SGD,dblink,Entrez Gene Status,OntologyTerm,LOCUS_SYNONYM

  # is this just for main $seq object or for all seqfeatures ?
  my %AnnotTagMap= ( 
      'gene_name' => 'Alias',   
      'ALIAS_SYMBOL' => 'Alias',  # Entrezgene
      'LOCUS_SYNONYM' => 'Alias', #?
      'symbol' => 'Alias',   
      'synonym' => 'Alias',   
      'dblink' => 'Dbxref',   
      'product' => 'product',
      'Reference' => 'reference',
      'OntologyTerm' => 'Ontology_term',
      'comment'  => 'Note',
      'comment1' => 'Note',
      # various map-type locations
      # gene accession tag is named per source db !??
      # 'Index terms' => keywords ??
      );
  
  
  my ($desc)= $seq->annotation->get_Annotations("desc") || ( $seq->desc() );
  my ($date)= $seq->annotation->get_Annotations("dates") 
      || $seq->annotation->get_Annotations("update-date")
      || $is_rich ? $seq->get_dates() : ();
  my ($comment)= $seq->annotation->get_Annotations("comment");
  my ($species)= $seq->annotation->get_Annotations("species");
  if (!$species 
       && $seq->can('species') 
       && defined $seq->species() 
       && $seq->species()->can('binomial') ) {
    $species= $seq->species()->binomial();
  }

  # update source feature with main GB fields
  $sf->add_tag_value( ID => $seq_name ) unless $sf->has_tag('ID');
  $sf->add_tag_value( Note => $desc ) if($desc && ! $sf->has_tag('Note'));
  $sf->add_tag_value( organism => $species ) if($species && ! $sf->has_tag('organism'));
  $sf->add_tag_value( comment1 => $comment ) if(!$is_swiss && $comment && ! $sf->has_tag('comment1'));
  $sf->add_tag_value( date => $date ) if($date && ! $sf->has_tag('date'));

  $sf->add_tag_value( Dbxref => $SOURCEID.':'.$seq_name ) if $is_swiss || $is_gene;

  foreach my $atag (sort keys %AnnotTagMap) {
      my $gtag= $AnnotTagMap{$atag}; next unless($gtag);
      my @anno = map{ 
          if (ref $_ && $_->can('get_all_values')) { 
              split( /[,;] */, join ";", $_->get_all_values) 
          }
          elsif (ref $_ && $_->can('display_text')) { 
              split( /[,;] */, $_->display_text) 
          }
          elsif (ref $_ && $_->can('value')) { 
              split( /[,;] */, $_->value) 
          } 
          else {
             ();
          }
      } $seq->annotation->get_Annotations($atag);  
      foreach(@anno) { $sf->add_tag_value( $gtag => $_ ); }
  }
    
  #my @genes = map{ split( /[,;] */, "$_"); } $seq->annotation->get_Annotations('gene_name');  
  #$sf->add_tag_value( Alias => $_ ) foreach(@genes);
  # 
  #my @dblink= map { "$_"; } $seq->annotation->get_Annotations("dblink"); # add @all 
  #$sf->add_tag_value( Dbxref => $_ ) foreach(@dblink);
  
  return (wantarray)? ($source_type,$sf) : $source_type; #?
}


sub gene_features {
    my ($f, $gene_id, $genelinkID) = @_;
    local $_ = $f->primary_tag;
    $method{$_}++;
    
    if ( /gene/ ) {
        $f->add_tag_value( ID => $gene_id ) unless($f->has_tag('ID')); # check is same value!? 
        $tnum = $rnum= 0; $ncrna_id= $rna_id  = '';
        return GM_NEW_TOPLEVEL;
        
    } elsif ( /mRNA/ ) {  
        return GM_NOT_PART unless $gene_id;
        return GM_NOT_PART if($genelinkID && $genelinkID ne $gene_id);
        ($rna_id  = $gene_id ) =~ s/gene/mRNA/;
        $rna_id   .= '.t0' . ++$tnum;
        $f->add_tag_value( ID => $rna_id );
        $f->add_tag_value( Parent => $gene_id );
        
    } elsif ( /RNA|transcript/) { 
        ## misc_RNA here; missing exons ... flattener problem?
        #  all of {t,nc,sn}RNA can have gene models now
        ## but problem in Worm chr: mRNA > misc_RNA > CDS with same locus tag
        ## CDS needs to use mRNA, not misc_RNA, rna_id ...
        ## also need to fix cases where tRNA,... lack a 'gene' parent: make this one top-level

        if($gene_id) {
          return GM_NOT_PART if($genelinkID && $genelinkID ne $gene_id);
          ($ncrna_id = $gene_id) =~ s/gene/ncRNA/;
          $ncrna_id .= '.r0' . ++$rnum;
          $f->add_tag_value( Parent => $gene_id );
          $f->add_tag_value( ID => $ncrna_id );
        } else {
          unless ($f->has_tag('ID')) {
            if($genelinkID) {
              $f->add_tag_value( ID => $genelinkID  ) ;
            } else {
              $idh->generate_unique_persistent_id($f);
            }
          }
         ($ncrna_id)= $f->get_tag_values('ID'); 
         return GM_NEW_TOPLEVEL;
          # this feat now acts as gene-top-level; need to print @to_print to flush prior exons?
        }
        
    } elsif ( /exon/ ) { # can belong to any kind of RNA
        return GM_NOT_PART unless ($rna_id||$ncrna_id);
        return GM_NOT_PART if($genelinkID && $genelinkID ne $gene_id);
        ## we are getting duplicate Parents here, which chokes chado loader, with reason...
        ## problem is when mRNA and ncRNA have same exons, both ids are active, called twice
        ## check all Parents
        for my $expar ($rna_id, $ncrna_id) { 
          next unless($expar);
          if ( $exonpar{$expar} and $f->has_tag('Parent') ) {
            my @vals = $f->get_tag_values('Parent');
            next if (grep {$expar eq $_} @vals);
            }
          $exonpar{$expar}++;
          $f->add_tag_value( Parent => $expar); 
          # last; #? could be both
        }
        # now we can skip cloned exons
        # dgg note: multiple parents get added and printed for each unique exon
        return GM_DUP_PART if ++$seen{$f} > 1;
        
    } elsif ( /CDS|protein|polypeptide/ ) {
        return GM_NOT_PART unless $rna_id; ## ignore $ncrna_id ??
        return GM_NOT_PART if($genelinkID && $genelinkID ne $gene_id); #??
        (my $pro_id = $rna_id) =~ s/\.t/\.p/;
        
        if( ! $CDSkeep && /CDS/) {  
          $f->primary_tag($PROTEIN_TYPE); 
        
          ## duplicate problem is Location ..
          if ($f->location->isa("Bio::Location::SplitLocationI")) {
            # my($b,$e)=($f->start, $f->end); # is this all we need?
            my($b,$e)=(-1,0);
            foreach my $l ($f->location->each_Location) {
               $b = $l->start if($b<0 || $b > $l->start);
               $e = $l->end if($e < $l->end);
               }
            $f->location( Bio::Location::Simple->new(
                -start => $b, -end => $e, -strand => $f->strand) );
            }

            $f->add_tag_value( Derives_from => $rna_id ); 
          }
          else {
            $f->add_tag_value( Parent => $rna_id );
          }

        $f->add_tag_value( ID => $pro_id );
        
        move_translation_fasta($f, $pro_id);
        #if( $f->has_tag('translation')) {
        #   my ($aa) = $f->get_tag_values("translation");
        #    $proteinfa{$pro_id}= $aa;
        #    $f->remove_tag("translation");
        #    $f->add_tag_value("translation","length.".length($aa)); # hack for odd chado gbl problem
        #}
    } elsif ( /region/ ) {       
        $f->primary_tag('gene_component_region');
        $f->add_tag_value( Parent => $gene_id ); 
    } else {
        return GM_NOT_PART unless $gene_id;
        $f->add_tag_value( Parent => $gene_id );  
    }
    
    ## return GM_DUP_PART if /exon/ && ++$seen{$f} > 1;
    
    return GM_NEW_PART;
}

## was generic_features >  add_generic_id
sub add_generic_id {
    my ($f, $ft_name, $flags) = @_;
    my $method = $f->primary_tag;
    $method{$method}++ unless($flags =~ /nocount/); ## double counts GM_NOT_PART from above
     
    if ($f->has_tag('ID')) {
    
    }
    elsif ( $f->has_tag($method) ) {
        my ($name) = $f->get_tag_values($method);
        $f->add_tag_value( ID => "$method:$name" );
    }
    elsif($ft_name) { # is this unique ?
        $f->add_tag_value( ID => $ft_name ); 
    }
    else {
        $idh->generate_unique_persistent_id($f);
    }

    move_translation_fasta( $f, ($f->get_tag_values("ID"))[0] )
      if($method =~ /CDS/);

    # return $io->gff_string($f);
}

sub move_translation_fasta {
    my ($f, $ft_id) = @_;
    if( $ft_id && $f->has_tag('translation') ) {
      my ($aa) = $f->get_tag_values("translation");
      if($aa && $aa !~ /^length/) {
        $proteinfa{$ft_id}= $aa;
        $f->remove_tag("translation");
        $f->add_tag_value("translation","length.".length($aa)); # hack for odd chado gbl problem
        }
    }
}

sub gff_header {
    my ($name, $end, $source_type, $source_feat) = @_;
    $source_type ||= "region";

    my $info = "$source_type:$name";
    my $head = "##gff-version $GFF_VERSION\n".
               "##sequence-region $name 1 $end\n".
               "# conversion-by bp_genbank2gff3.pl\n";
    if ($source_feat) {
        ## dgg: these header comment fields are not useful when have multi-records, diff organisms
        for my $key (qw(organism Note date)) {
            my $value;
            if ($source_feat->has_tag($key)) { 
                ($value) = $source_feat->get_tag_values($key);
            }
            if ($value) {
                $head .= "# $key $value\n";
                $info .= ", $value";
            }
        }
        $head = "" if $didheader;
    } else {
        $head .= "$name\t$SOURCEID\t$source_type\t1\t$end\t.\t.\t.\tID=$name\n";
    }
    $didheader++;
    return (wantarray) ? ($head,$info) : $head;
}

sub unflatten_seq {
    my $seq = shift;

    ## print "# working on $source_type:", $seq->accession, "\n"; 
    my $uh_oh = "Possible gene unflattening error with" .  $seq->accession_number .
                ": consult STDERR\n";
    
    eval {
        $unflattener->unflatten_seq( -seq => $seq, 
                                     -noinfer => $noinfer,
                                     -use_magic => 1 );
    };
    
    # deal with unflattening errors
    if ( $@ ) {
        warn $seq->accession_number . " Unflattening error:\n";
        warn "Details: $@\n";
        print "# ".$uh_oh;
    }

    return 0 if !$seq || !$seq->all_SeqFeatures;

    # map feature types to the sequence ontology
    ## $tm->map_types_to_SO( -seq => $seq );
    #$tm->map_types( -seq => $seq, -type_map => $FTSOmap, -undefined => "region" ); #dgg

    map_types( 
        $tm, 
        -seq => $seq, 
        -type_map  => $FTSOmap, 
        -syn_map  => $FTSOsynonyms, 
        -undefined => "region" 
    ); #nml

}

sub filter {
    my $seq = shift;
    ## return unless $filter;
    my @feats;
    my @sources; # dgg; pick source features here; only 1 always?
    if ($filter) {
      for my $f ( $seq->remove_SeqFeatures ) {
        my $m = $f->primary_tag;
        push @sources, $f if ($m eq 'source'); # dgg? but leave in @feats ?
        push @feats, $f unless $filter =~ /$m/i;
      }
      $seq->add_SeqFeature($_) foreach @feats;
    } else {
      for my $f ( $seq->get_SeqFeatures ){
        my $m = $f->primary_tag;
        push @sources, $f if ($m eq 'source'); # dgg? but leave in @feats ?
        }
    }

    return @sources;
}


# The default behaviour of Bio::FeatureHolderI:get_all_SeqFeatures
# changed to filter out cloned features.  We have to implement the old
# method.  These two subroutines were adapted from the v1.4 Bio::FeatureHolderI
sub get_all_SeqFeatures  {
    my $seq = shift;
    my @flatarr;

    foreach my $feat ( $seq->get_SeqFeatures ){
        push(@flatarr,$feat);
        _add_flattened_SeqFeatures(\@flatarr,$feat);
    }
    return @flatarr;
}

sub gene_name {
    my $g = shift;
    my $gene_id = ''; # zero it;

    if ($g->has_tag('locus_tag')) {
        ($gene_id) = $g->get_tag_values('locus_tag');
    }

    elsif ($g->has_tag('gene')) {
        ($gene_id) = $g->get_tag_values('gene'); 
    }
    elsif ($g->has_tag('ID')) { # for non-Genbank > Entrezgene
        ($gene_id) = $g->get_tag_values('ID');
    }

    ## See Unflattener comment:
    # on rare occasions, records will have no /gene or /locus_tag
    # but it WILL have /product tags. These serve the same purpose
    # for grouping. For an example, see AY763288 (also in t/data)
    # eg. product=tRNA-Asp ;  product=similar to crooked neck protein
    elsif ($g->has_tag('product')) {
        my ($name)= $g->get_tag_values('product');
        ($gene_id) = $name unless($name =~ / /); # a description not name
    }

    ## dgg; also handle transposon=xxxx ID/name
    # ID=GenBank:repeat_region:NC_004353:1278337:1281302;transposon=HeT-A{}1685;Dbxref=FLYBASE:FBti0059746
    elsif ($g->has_tag('transposon')) {
        my ($name)= $g->get_tag_values('transposon');
        ($gene_id) = $name unless($name =~ / /); # a description not name
    }
  
    return $gene_id;
}

# same list as gene_name .. change tag to generic Name
sub convert_to_name {
    my $g = shift;
    my $gene_id = ''; # zero it;
    
    if ($g->has_tag('gene')) {
        ($gene_id) = $g->get_tag_values('gene'); 
        $g->remove_tag('gene');
        $g->add_tag_value('Name', $gene_id);
    }
    elsif ($g->has_tag('locus_tag')) {
        ($gene_id) = $g->get_tag_values('locus_tag');
        $g->remove_tag('locus_tag');
        $g->add_tag_value('Name', $gene_id);
    }

    elsif ($g->has_tag('product')) {
        my ($name)= $g->get_tag_values('product');
        ($gene_id) = $name unless($name =~ / /); # a description not name
        ## $g->remove_tag('product');
        $g->add_tag_value('Name', $gene_id);
    }

    elsif ($g->has_tag('transposon')) {
        my ($name)= $g->get_tag_values('transposon');
        ($gene_id) = $name unless($name =~ / /); # a description not name
        ## $g->remove_tag('transposon');
        $g->add_tag_value('Name', $gene_id);
    }
    elsif ($g->has_tag('ID')) { 
        my ($name)= $g->get_tag_values('ID');
        $g->add_tag_value('Name', $name);
    }    
    return $gene_id;
}


sub _add_flattened_SeqFeatures  {
    my ($arrayref,$feat) = @_;
    my @subs = ();

    if ($feat->isa("Bio::FeatureHolderI")) {
        @subs = $feat->get_SeqFeatures;
    } 
    elsif ($feat->isa("Bio::SeqFeatureI")) {
        @subs = $feat->sub_SeqFeature;
    }
    else {
        warn ref($feat)." is neither a FeatureHolderI nor a SeqFeatureI. ".
            "Don't know how to flatten.";
    }

    for my $sub (@subs) {
        push(@$arrayref,$sub);
        _add_flattened_SeqFeatures($arrayref,$sub);
    }

}

sub map_types {

    my ($self, @args) = @_;

    my($sf, $seq, $type_map, $syn_map, $undefmap) =
        $self->_rearrange([qw(FEATURE
                    SEQ
                    TYPE_MAP
                    SYN_MAP
                    UNDEFINED
                    )],
                @args);

    if (!$sf && !$seq) {
        $self->throw("you need to pass in either -feature or -seq");
    }

    my @sfs = ($sf);
    if ($seq) {
        $seq->isa("Bio::SeqI") || $self->throw("$seq NOT A SeqI");
        @sfs = $seq->get_all_SeqFeatures;
    }
    $type_map = $type_map || $self->typemap; # dgg: was type_map;
    foreach my $feat (@sfs) {

        $feat->isa("Bio::SeqFeatureI") || $self->throw("$feat NOT A SeqFeatureI");
        $feat->isa("Bio::FeatureHolderI") || $self->throw("$feat NOT A FeatureHolderI");

        my $primary_tag = $feat->primary_tag;

        #if ($primary_tag =~ /^pseudo(.*)$/) {
        #    $primary_tag = $1;
        #    $feat->primary_tag($primary_tag);
        #}

        my $mtype = $type_map->{$primary_tag};
        if ($mtype) {
            if (ref($mtype)) {
                if (ref($mtype) eq 'ARRAY') {
                    my $soID;
                    ($mtype, $soID) = @$mtype;

                    if ($soID && ref($ONTOLOGY)) {
                        my ($term) = $ONTOLOGY->find_terms(-identifier => $soID);
                        $mtype = $term->name if $term;
                    } 
                    # if SO ID is undefined AND we have an ontology to search, we want to delete 
                    # the feature type hash entry in order to force a fuzzy search
                    elsif (! defined $soID && ref($ONTOLOGY)) {
                        undef $mtype;
                        delete $type_map->{$primary_tag};
                    } 
                    elsif ($undefmap && $mtype eq 'undefined') { # dgg
                        $mtype= $undefmap;
                    }

                    $type_map->{$primary_tag} = $mtype if $mtype;
                }
                elsif (ref($mtype) eq 'CODE') {
                    $mtype = $mtype->($feat);
                }
                else {
                    $self->throw('must be scalar or CODE ref');
                }
            }
            elsif ($undefmap && $mtype eq 'undefined') { # dgg
                $mtype= $undefmap;
            }
            $feat->primary_tag($mtype);
        }

        if ($CONF) {
            conf_read(); 
            my %perfect_matches;
            while (my ($p_tag,$rules) = each %$YAML) {
                RULE:
                for my $rule (@$rules) {
                    for my $tags (@$rule) {
                        while (my ($tag,$values) = each %$tags) {
                            for my $value (@$values) {
                                if ($feat->has_tag($tag)) {
                                    for ($feat->get_tag_values($tag)) {
                                        next RULE unless $_ =~ /\Q$value\E/;
                                    }
                                } elsif ($tag eq 'primary_tag') {
                                    next RULE unless $value eq
                                        $feat->primary_tag; 
                                } elsif ($tag eq 'location') {
                                    next RULE unless $value eq
                                        $feat->start.'..'.$feat->end;
                                } else { next RULE }
                            }
                        }
                    }
                    $perfect_matches{$p_tag}++;
                }
            }
            if (scalar(keys %perfect_matches) == 1) {
                $mtype = $_ for keys %perfect_matches;
            } elsif (scalar(keys %perfect_matches) > 1) {
                warn "There are conflicting rules in the config file for the" .
                     " following types: ";
                warn "\t$_\n" for keys %perfect_matches;
                warn "Until conflict resolution is built into the converter," .
                     " you will have to manually edit the config file to remove the" .
                     " conflict. Sorry :(. Skipping user preference for this entry";
                sleep(2);
            }
        } 

        if ( ! $mtype  && $syn_map) {
            if ($feat->has_tag('note')) {

                my @all_matches;

                my @note = $feat->each_tag_value('note');

                for my $k (keys %$syn_map) {

                    if ($k =~ /"(.+)"/) {

                        my $syn = $1;

                        for my $note (@note) {

                            # look through the notes to see if the description
                            # is an exact match for synonyms
                            if ( $syn eq $note ) { 

                                my @map = @{$syn_map->{$k}};

                                
                                my $best_guess = $map[0];

                                unshift @{$all_matches[-1]}, [$best_guess];

                                $mtype = $MANUAL
                                    ? manual_curation($feat, $best_guess, \@all_matches)
                                    : $best_guess;

                                print '#' x 78 . "\nGuessing the proper SO term for GenBank"
                                    . " entry:\n\n" . GenBank_entry($feat) . "\nis:\t$mtype\n" 
                                    . '#' x 78 . "\n\n";

                            } else {
                                # check both primary tag and and note against
                                # SO synonyms for best matching description

                                SO_fuzzy_match( $k, $primary_tag, $note, $syn, \@all_matches); 
                            }

                        }
                    } 
                }

                #unless ($mtype) {
                for my $note (@note) {
                    for my $name (values %$type_map) {
                    # check primary tag against SO names for best matching
                    # descriptions //NML also need to check against
                    # definition && camel case split terms

                        SO_fuzzy_match($name, $primary_tag, $note, $name, \@all_matches);
                    }
                }
                #}

                if (scalar(@all_matches) && !$mtype) {

                    my $top_matches = first { defined $_ } @{$all_matches[-1]}; 

                    my $best_guess = $top_matches->[0];



                    # if guess has quotes, it is a synonym term. we need to 
                    # look up the corresponding name term
                    # otherwise, guess is a name, so we can use it directly
                    if ($best_guess =~ /"(.+)"/) {

                        $best_guess = $syn_map->{$best_guess}->[0];

                    } 

                    @RETURN = @all_matches;
                    $mtype = $MANUAL
                        ? manual_curation($feat, $best_guess, \@all_matches)
                        : $best_guess;

                    print '#' x 78 . "\nGuessing the proper SO term for GenBank"
                        . " entry:\n\n" . GenBank_entry($feat) . "\nis:\t$mtype\n" 
                        . '#' x 78 . "\n\n";

                }
            }
            $mtype ||= $undefmap;
            $feat->primary_tag($mtype);
        } 
    }


}

sub SO_fuzzy_match {

    my $candidate = shift;
    my $primary_tag = shift;
    my $note = shift;
    my $SO_terms = shift;
    my $best_matches_ref = shift;
    my $modifier = shift; 

    $modifier ||= '';

        my @feat_terms;

    for ( split(" |_", $primary_tag) ) {
        #my @camelCase = /(?:[A-Z]|[a-z])(?:[A-Z]+|[a-z]*)(?=$|[A-Z])/g;
        my @camelCase = /(?:[A-Z]|[a-z])(?:[A-Z]+|[a-z]*)(?=$|[A-Z]|[;:.,])/g;
        push @feat_terms, @camelCase;
    }

    for ( split(" |_", $note) ) {
        #my @camelCase = /(?:[A-Z]|[a-z])(?:[A-Z]+|[a-z]*)(?=$|[A-Z])/g;
        #my @camelCase = /(?:[A-Z]|[a-z])(?:[A-Z]+|[a-z]*)(?=$|[A-Z]|[;:.,])/g;
        (my $word = $_) =~ s/[;:.,]//g;
        push @feat_terms, $word;
    }


    my @SO_terms = split(" |_", $SO_terms);

    # fuzzy match works on a simple point system. When 2 words match,
    # the $plus counter adds one. When they don't, the $minus counter adds
    # one. This is used to sort similar matches together. Better matches
    # are found at the end of the array, near the top.

    # NML: can we improve best match by using synonym tags
    # EXACT,RELATED,NARROW,BROAD?

    my ($plus, $minus) = (0, 0); 
    my %feat_terms;
    my %SO_terms;

    #unique terms
    map {$feat_terms{$_} = 1} @feat_terms;
    map {$SO_terms{$_} = 1} @SO_terms;

    for my $st (keys %SO_terms) {
        for my $ft (keys %feat_terms) {

            ($st =~ m/$modifier\Q$ft\E/) ? $plus++ : $minus++;

        }
    }

    push @{$$best_matches_ref[$plus][$minus]}, $candidate if $plus;

}

sub manual_curation {

    my ($feat, $default_opt,  $all_matches) = @_; 

    my @all_matches = @$all_matches;

    # convert all SO synonyms into names and filter
    # all matches into unique term list because
    # synonyms can map to multiple duplicate names

    my (@unique_SO_terms, %seen);
    for (reverse @all_matches) {
        for (@$_) {
            for (@$_) {
                #my @names;
                if ($_ =~ /"(.+)"/) {
                    for (@{$SYN_MAP->{$_}}) {
                        push @unique_SO_terms, $_ unless $seen{$_};
                        $seen{$_}++;
                    }
                } else { 
                    push @unique_SO_terms, $_ unless $seen{$_};
                    $seen{$_}++;
                }
            }
        }
    }

    my $s = scalar(@unique_SO_terms);

    my $choice = 0;

    my $more = 
        "[a]uto   : automatic input (selects best guess for remaining entries)\r" .
        "[f]ind   : search for other SO terms matching your query (e.g. f gene)\r" . 
        "[i]nput  : add a specific term\r" .
        "[r]eset  : reset to the beginning of matches\r" .
        "[s]kip   : skip this entry (selects best guess for this entry)\r"
    ;

    $more .= 
        "[n]ext   : view the next ".OPTION_CYCLE." terms\r" .
        "[p]rev   : view the previous ".OPTION_CYCLE." terms" if ($s > OPTION_CYCLE);

    my $msg = #"\n\n" . '-' x 156 . "\n"
         "The converter found $s possible matches for the following GenBank entry: ";

    my $directions = 
        "Type a number to select the SO term that best matches"
        . " the genbank entry, or use any of the following options:\r" . '_' x 76 . "\r$more"; 


    # lookup filtered list to pull out definitions
    my @options = map { 
        my $term = $_;
        my %term;
        for (['name', 'name'], ['def', 'definition'], ['synonym',
                'each_synonym']) {
            my ($label, $method) = @$_;
            $term{$label} = \@{[$term->$method]};
        }
        [++$choice, $_->name, ($_->definition || 'none'), \%term, $_->each_synonym ];
    }  map { $ONTOLOGY->find_terms(-name => $_) } @unique_SO_terms;


    my $option = options_cycle(0, OPTION_CYCLE, $msg, $feat, $directions,
            $default_opt, @options);

    if ($option eq 'skip') { return $default_opt 
    } elsif ($option eq 'auto') {
        $MANUAL = 0;
        return $default_opt;
    } else { return $option }

}

sub options_cycle {

    my ($start, $stop, $msg, $feat, $directions, $best_guess, @opt) = @_;

    #NML: really should only call GenBank_entry once. Will need to change
    #method to return array & shift off header
    my $entry = GenBank_entry($feat, "\r");

    my $total = scalar(@opt);

    ($start,$stop) = (0, OPTION_CYCLE) 
        if ( ($start < 0) && ($stop > 0) );

    ($start,$stop) = (0, OPTION_CYCLE) 
        if ( ( ($stop - $start) < OPTION_CYCLE ) && $stop < $total);

    ($start,$stop) = ($total - OPTION_CYCLE, $total) if $start < 0;
    ($start,$stop) = (0, OPTION_CYCLE) if $start >= $total;

    $stop = $total if $stop > $total;

    my $dir_copy = $directions;
    my $msg_copy = $msg;
    my $format = "format STDOUT = \n" .
        '-' x 156 . "\n" . 
        '^' . '<' x 77 .  '| Available Commands:' . "\n" .
        '$msg_copy' . "\n" .
        '-' x 156 . "\n" . 
        ' ' x 78 . "|\n" .
        '^' . '<' x 77 . '| ^' . '<' x 75 . '~' . "\n" .
        '$entry' . ' ' x 74 . '$dir_copy,' . "\n" .
        (' ' x 20 . '^' . '<' x 57 . '| ^' . '<' x 75 . '~' . "\n" .
        ' ' x 20 . '$entry,' . ' ' x 53 . '$dir_copy,' . "\n") x 1000  . ".\n";

    {
        # eval throws redefined warning that breaks formatting. 
        # Turning off warnings just for the eval to fix this.
        no warnings 'redefine';
        eval $format;
    }

    write;

    print '-' x 156 . "\n" .
        'Showing results ' . ( $stop ? ( $start + 1 ) : $start ) . 
        " - $stop of possible SO term matches: (best guess is \"$best_guess\")" .
        "\n" . '-' x 156 . "\n"; 

    for  (my $i = $start; $i < $stop; $i+=2) {

        my ($left, $right) = @opt[$i,$i+1];

        my ($nL, $nmL, $descL, $termL, @synL) = @$left;

        #odd numbered lists can cause fatal undefined errors, so check
        #to make sure we have data
        
        my ($nR, $nmR, $descR, $termR, @synR) = ref($right) ? @$right : (undef, undef, undef);


        my $format = "format STDOUT = \n";

        $format .=
            ' ' x 78 . "|\n" .

            '@>>: name: ^' . '<' x 64 . '~' . ' |' .
                ( ref($right) ? ('@>>: name: ^' . '<' x 64 . '~' ) : '' ) .  "\n" .
            '$nL,' . ' ' x 7 . '$nmL,' .
                ( ref($right) ? (' ' x 63 . '$nR,' .  ' ' x 7 .  "\$nmR,") : '' ) . "\n" .

            ' ' x 11 . '^' . '<' x 61 . '...~' . ' |' . 
                (ref($right) ? ('           ^' . '<' x 61 .  '...~') : '') . "\n" .
            ' ' x 11 . '$nmL,' . 
                (ref($right) ? (' ' x 74 . '$nmR,') : '') . "\n" .
            #' ' x 78 . '|' . "\n" .


            '     def:  ^' . '<' x 65 . ' |' . 
                (ref($right) ? ('     def:  ^' . '<' x 64 . '~') : '') . "\n" .
            ' ' x 11 . '$descL,' . 
                (ref($right) ? (' ' x 72 . '$descR,') : '') . "\n" .


            ('           ^' . '<' x 65 . ' |' . 
                (ref($right) ? ('           ^' . '<' x 64 . '~') : '') . "\n" .
            ' ' x 11 . '$descL,' . 
                (ref($right) ? (' ' x 72 . '$descR,') : '') . "\n") x 5 .


            '           ^' . '<' x 61 . '...~ |' . 
                (ref($right) ? ('           ^' . '<' x 61 . '...~') : '') . "\n" .
            ' ' x 11 . '$descL,' . 
                (ref($right) ? (' ' x 72 . '$descR,') : '') . "\n" .

            ".\n";

        {
            # eval throws redefined warning that breaks formatting. 
            # Turning off warnings just for the eval to fix this.
            no warnings 'redefine';
            eval $format;
        }
        write;

    }   
    print '-' x 156 . "\nenter a command:";

    while () {

        (my $input = $_) =~ s/\s+$//;

        if ($input =~ /^\d+$/) {
            if ( $input && defined $opt[$input-1] ) {
                return $opt[$input-1]->[1]
            } else {
                print "\nThat number is not an option. Please enter a valid number.\n:";
            }
        } elsif ($input =~ /^n/i | $input =~ /next/i ) {
            return options_cycle($start + OPTION_CYCLE, $stop + OPTION_CYCLE, $msg, 
                    $feat, $directions, $best_guess, @opt)
        } elsif ($input =~ /^p/i | $input =~ /prev/i ) {
            return options_cycle($start - OPTION_CYCLE, $stop - OPTION_CYCLE, $msg,
                    $feat, $directions, $best_guess, @opt)
        } elsif ( $input =~ /^s/i || $input =~ /skip/i ) { return 'skip' 
        } elsif ( $input =~ /^a/i || $input =~ /auto/i ) { return 'auto' 
        } elsif ( $input =~ /^r/i || $input =~ /reset/i ) { 
            return manual_curation($feat, $best_guess, \@RETURN );
        } elsif ( $input =~ /^f/i || $input =~ /find/i ) {

            my ($query, @query_results);

            if ($input =~ /(?:^f|find)\s+?(.*?)$/) { $query = $1;
            } else {

                #do a SO search
                print "Type your search query\n:";
                while () { chomp($query = $_); last }
            }

            for (keys(%$TYPE_MAP), keys(%$SYN_MAP)) {
                SO_fuzzy_match($_, $query, '', $_, \@query_results, '(?i)');
            }

            return manual_curation($feat, $best_guess, \@query_results);

        } elsif ( $input =~ /^i/i || $input =~ /input/i ) {

            #NML fast input for later
            #my $query;
            #if ($input =~ /(?:^i|input)\s+?(.*?)$/) { $query = $1 };

            #manual input
            print "Type the term you want to use\n:";
            while () {
                chomp(my $input = $_);

                if (! $TYPE_MAP->{$input}) {

                    print "\"$input\" doesn't appear to be a valid SO term. Are ".
                        "you sure you want to use it? (y or n)\n:";

                    while () {

                        chomp(my $choice = $_);

                        if ($choice eq 'y') {
                            print 
                                "\nWould you like to save your preference for " .
                                "future use (so you don't have to redo manual " .
                                "curation for this feature everytime you run " . 
                                "the converter)? (y or n)\n";

                            #NML: all these while loops are a mess. Really should condense it.
                            while () {

                                chomp(my $choice = $_);

                                if ($choice eq 'y') {
                                    curation_save($feat, $input);
                                    return $input;
                                } elsif ($choice eq 'n') {
                                    return $input
                                } else {
                                    print "\nDidn't recognize that command. Please " . 
                                        "type y or n.\n:" 
                                }
                            }

                                
                        } elsif ($choice eq 'n') {
                            return options_cycle($start, $stop, $msg, $feat,
                                    $directions, $best_guess, @opt)
                        } else {
                            print "\nDidn't recognize that command. Please " . 
                                "type y or n.\n:" 
                        }
                    }

                } else { 
                    print 
                        "\nWould you like to save your preference for " .
                        "future use (so you don't have to redo manual " .
                        "curation for this feature everytime you run  " . 
                        "the converter)? (y or n)\n";

                    #NML: all these while loops are a mess. Really should condense it.
                    while () {

                        chomp(my $choice = $_);

                        if ($choice eq 'y') {
                            curation_save($feat, $input);
                            return $input;
                        } elsif ($choice eq 'n') {
                            return $input
                        } else {
                            print "\nDidn't recognize that command. Please " . 
                                "type y or n.\n:" 
                        }
                    }

                } 

            }
        } else { 
            print "\nDidn't recognize that command. Please re-enter your choice.\n:" 
        }
    }

}

sub GenBank_entry {
    my ($f, $delimiter, $num) = @_;

    $delimiter ||= "\n";


    my $entry  = 

        ($num ? ' [1] ' : ' ' x 5) . $f->primary_tag 
        . ($num 
            ? ' ' x (12 - length $f->primary_tag ) . ' [2] '
            : ' ' x (15 - length $f->primary_tag) 
          )
        . $f->start.'..'.$f->end

        . "$delimiter";

    if ($num) {
        words_tag($f, \$entry);
    } else {
        for my $tag ($f->all_tags) {
            for my $val ( $f->each_tag_value($tag) ) {
                $entry .= ' ' x 20;
                #$entry .= "/$tag=\"$val\"$delimiter";
                $entry .= $val eq '_no_value'
                    ? "/$tag$delimiter"
                    : "/$tag=\"$val\"$delimiter";
            }
        }

    }

    return $entry;
}


sub gff_validate {
    warn "Validating GFF file\n" if $DEBUG;
    my @feat = @_;

    my (%parent2child, %all_ids, %descendants, %reserved);

    for my $f (@feat) {
        for my $aTags (['Parent', \%parent2child], ['ID', \%all_ids]) {
            map { push @{$$aTags[1]->{$_}}, $f } $f->get_tag_values($$aTags[0])
                if $f->has_tag($$aTags[0]); 
        }
    }

    if ($SO_FILE) {
        while (my ($parentID, $aChildren) = each %parent2child) {
            parent_validate($parentID, $aChildren, \%all_ids, \%descendants, \%reserved);
        }
    }

    id_validate(\%all_ids, \%reserved);        
}

sub parent_validate {
    my ($parentID, $aChildren, $hAll, $hDescendants, $hReserved) = @_;

    my $aParents = $hAll->{$parentID};

    map { 
        my $child = $_;
        $child->add_tag_value( validation_error => 
        "feature tried to add Parent tag, but no Parent found with ID $parentID"
        );
        my %parents;
        map { $parents{$_} = 1 } $child->get_tag_values('Parent');
        delete $parents{$parentID};
        my @parents = keys %parents;

        $child->remove_tag('Parent');

        unless ($child->has_tag('ID')) {
            my $id = gene_name($child);
            $child->add_tag_value('ID', $id);
            push @{$hAll->{$id}}, $child
        }

        $child->add_tag_value('Parent', @parents) if @parents;

    } @$aChildren and return unless scalar(@$aParents);

    my $par = join(',', map { $_->primary_tag } @$aParents);
    warn scalar(@$aParents)." POSSIBLE PARENT(S): $par" if $DEBUG;

    #NML manual curation needs to happen here


    my %parentsToRemove;

    CHILD:
    for my $child (@$aChildren) {
        my $childType  = $child->primary_tag;

        warn "WORKING ON $childType at ".$child->start.' to '.$child->end 
            if $DEBUG;

        for (my $i = 0; $i < scalar(@$aParents); $i++) {
            my $parent = $aParents->[$i];
            my $parentType = $parent->primary_tag;

            warn "CHECKING $childType against $parentType" if $DEBUG;

            #cache descendants so we don't have to do repeat searches
            unless ($hDescendants->{$parentType}) {

                for my $term ($ONTOLOGY->find_terms(
                        -name => $parentType
                    ) ) {
                    
                    map {
                        $hDescendants->{$parentType}{$_->name}++
                    } $ONTOLOGY->get_descendant_terms($term);

                }

                # NML: hopefully temporary fix.
                # SO doesn't consider exon/CDS to be a child of mRNA
                # even though common knowledge dictates that they are
                # This cheat fixes the false positives for now
                if ($parentType eq 'mRNA') {
                    $hDescendants->{$parentType}{'exon'} = 1;
                    $hDescendants->{$parentType}{'CDS'} = 1;
                }

            }

            warn "\tCAN $childType at " . $child->start . ' to ' . $child->end .
                " be a child of $parentType?" if $DEBUG;
            if ($hDescendants->{$parentType}{$childType}) {
                warn "\tYES, $childType can be a child of $parentType" if $DEBUG;

                #NML need to deal with multiple children matched to multiple different
                #parents. This model only assumes the first parent id that matches a child will
                #be the reserved feature. 

                $hReserved->{$parentID}{$parent}{'parent'} = $parent;
                push @{$hReserved->{$parentID}{$parent}{'children'}}, $child;

                #mark parent for later removal from all IDs 
                #so we don't accidentally change any parents

                $parentsToRemove{$i}++;

                next CHILD;
            } 
        }


        
        #NML shouldn't have to check this; somehow child can lose Parent
        #it's happening W3110
        #need to track this down
        if ( $child->has_tag('Parent') ) {

            warn "\tNO, @{[$child->primary_tag]} cannot be a child of $parentID"
                if $DEBUG;

            my %parents;

            map { $parents{$_} = 1 } $child->get_tag_values('Parent');

            delete $parents{$parentID};
            my @parents = keys %parents;

            warn 'VALIDATION ERROR '.$child->primary_tag." at ".$child->start .
                ' to ' . $child->end . " cannot be a child of ID $parentID"
                if $DEBUG;

            $child->add_tag_value( validation_error => 
                    "feature cannot be a child of $parentID");

            $child->remove_tag('Parent');

            unless ($child->has_tag('ID')) {
                my $id = gene_name($child);
                $child->add_tag_value('ID', $id);
                push @{$hAll->{$id}}, $child
            }

            $child->add_tag_value('Parent', @parents) if @parents;
        }

    }
    
    #delete $aParents->[$_] for keys %parentsToRemove;
    splice(@$aParents, $_, 1) for keys %parentsToRemove;
}

sub id_validate {
    my ($hAll, $hReserved) = @_;


    for my $id (keys %$hAll) {

        #since 1 feature can have this id, 
        #let's just shift it off and uniquify
        #the rest (unless it's reserved)

        shift @{$hAll->{$id}} unless $hReserved->{$id};
        for my $feat (@{$hAll->{$id}}) {
            id_uniquify(0, $id, $feat, $hAll);
        }
    }

    for my $parentID (keys %$hReserved) {

        my @keys = keys %{$hReserved->{$parentID}};

        shift @keys;

        for my $k (@keys) {
            my $parent = $hReserved->{$parentID}{$k}{'parent'};
            my $aChildren= $hReserved->{$parentID}{$k}{'children'};

            my $value = id_uniquify(0, $parentID, $parent, $hAll);
            for my $child (@$aChildren) {

                my %parents;
                map { $parents{$_}++ } $child->get_tag_values('Parent');
                $child->remove_tag('Parent');
                delete $parents{$parentID};
                $parents{$value}++;
                my @parents = keys %parents;
                $child->add_tag_value('Parent', @parents);
            }

        }
    }
}

sub id_uniquify {
    my ($count, $value, $feat, $hAll) = @_;

    warn "UNIQUIFYING $value" if $DEBUG;

    if (! $count) {
        $feat->add_tag_value(Alias => $value);
        $value .= ('.' . $feat->primary_tag) 
    } elsif ($count == 1) {
        $value .= ".$count" 
    } else { 
        chop $value;
        $value .= $count 
    }
    $count++;

    warn "ENDED UP WITH $value" if $DEBUG;
    if ( $hAll->{$value} ) { 
        warn "$value IS ALREADY TAKEN" if $DEBUG;
        id_uniquify($count, $value, $feat, $hAll);
    } else { 
        #warn "something's breaking ".$feat->primary_tag.' at '.$feat->start.' to '.$feat->end;
        $feat->remove_tag('ID');
        $feat->add_tag_value('ID', $value);
        push @{$hAll->{$value}}, $value;
    }

    $value;
}

sub conf_read {

    print "\nCannot read $CONF. Change file permissions and retry, " .
        "or enter another file\n" and conf_locate() unless -r $CONF;

    print "\nCannot write $CONF. Change file permissions and retry, " .
        "or enter another file\n" and conf_locate() unless -w $CONF;

    $YAML = LoadFile($CONF);

}

sub conf_create {

    my ($path, $input) = @_;

    print "Cannot write to $path. Change directory permissions and retry " .
        "or enter another save path\n" and conf_locate() unless -w $path;

    $CONF = $input;

    open(FH, '>', $CONF);
    close(FH);
    conf_read();


}

sub conf_write { DumpFile($CONF, $YAML) }

sub conf_locate {

    print "\nEnter the location of a previously saved config, or a new " .
        "path and file name to create a new config (this step is " .
        "necessary to save any preferences)";

    print "\n\nenter a command:";

    while () {
        chomp(my $input = $_);
        my ($fn, $path, $suffix) = fileparse($input, qr/\.[^.]*/);

        if (-e $input && (! -d $input)) {

            print "\nReading $input...\n";
            $CONF = $input;

            conf_read(); 
            last;

        } elsif (! -d $input && $fn.$suffix) {

            print "Creating $input...\n";
            conf_create($path, $input);
            last;

        } elsif (-e $input && -d $input) {
            print "You only entered a directory. " .
                "Please enter BOTH a directory and filename\n";
        } else { 
            print "$input does not appear to be a valid path. Please enter a " .
                "valid directory and filename\n";
        }
        print "\nenter a command:";
    }
}

sub curation_save {

    my ($feat, $input) = @_;

    #my $error = "Enter the location of a previously saved config, or a new " .
    #    "path and file name to create a new config (this step is " .
    #    "necessary to save any preferences)\n";

    if (!$CONF) {
        print "\n\n"; 
        conf_locate();
    } elsif (! -e $CONF) {
        print "\n\nThe config file you have chosen doesn't exist.\n";
        conf_locate();
    } else { conf_read() }

    my $entry = GenBank_entry($feat, "\r", 1);

    my $msg = "Term entered: $input";
    my $directions = "Please select any/all tags that provide evidence for the term you
have entered. You may enter multiple tags by separating them by commas/dashes
(e.g 1,3,5-7). For tags with more than one word value (i.e 'note'), you have
the option of either selecting the entire note as evidence, or specific
keywords. If a tag has multiple keywords, they will be tagged alphabetically
for selection. To select a specific keyword in a tag field, you must enter the
tag number followed by the keyword letter (e.g 3a). Multiple keywords may be
selected by entering each letter separated by commas/dashes (e.g 3b,f,4a-c). The more tags you select, the more specific the GenBank entry will have
to be to match your curation. To match the GenBank entry exactly as it
appears, type every number (start-end), or just type 'all'. Remember, once the converter saves your
preference, you will no longer be prompted to choose a feature type for any
matching entries until you edit the curation.ini file.";
    my $msg_copy = $msg;
    my $dir_copy = $directions;

    my $format = "format STDOUT = \n" .
        '-' x 156 . "\n" . 
        '^' . '<' x 77 .  '| Directions:' . "\n" .
        '$msg_copy' . "\n" .
        '-' x 156 . "\n" . 
        ' ' x 78 . "|\n" .
        '^' . '<' x 77 . '| ^' . '<' x 75 . '~' . "\n" .
        '$entry' . ' ' x 74 . '$dir_copy,' . "\n" .
        (' ' x 15 . '^' . '<' x 62 . '| ^' . '<' x 75 . '~' . "\n" .
        ' ' x 15 . '$entry,' . ' ' x 58 . '$dir_copy,' . "\n") x 20  . ".\n";

    {
        # eval throws redefined warning that breaks formatting. 
        # Turning off warnings just for the eval to fix this.
        no warnings 'redefine';
        eval $format;
    }

    write;
    print '-' x 156 . "\nenter a command:";

    my @tags = words_tag($feat); 

    my $final = {};
    my $choices;
    while () {

        chomp(my $choice = $_);

        if (scalar(keys %$final) && $choice =~ /^y/i) { last 

        } elsif (scalar(keys %$final) && $choice =~ /^n/i) { curation_save($feat, $input) 

        } elsif (scalar(keys %$final)) { print "\nInvalid selection. Please try again\n";

        } elsif ($choice eq 'all') {

            $choice = '';
            for (my $i=1; $i < scalar(@tags); $i++) {
                $choice .= "$i,";
            }
            chop $choice;
        } 
        #print "CHOICE [$choice]";

        my @selections;
        for (split(/(?<=\w)[^[:alnum:]\-]+(?=\d)/, $choice)) {
            if ($_ =~ /(\d+)(?:\D*)-(\d+)(.*)/) { 

                for ($1..$2) { push @selections, $_ }

                my $dangling_alphas = $3;
                alpha_expand($dangling_alphas, \@selections);

            } else { 
                alpha_expand($_, \@selections);
            }
        }

        foreach my $numbers (@selections) {

            my @c = split(/(?=[\w])/, $numbers);
            s/\W+//g foreach @c;
            my $num;
            
            {
                $^W = 0;
                $num = 0 + shift @c;
            }

            my $tag = $tags[$num];
            if (ref $tag && scalar(@c)) {
                my $no_value;
                foreach (@c) {
                    if (defined $tag->{$_}) {
                        $choices .= "${num}[$_] ";
                        my ($t,$v) = @{$tag->{$_}};
                        push @{${$final->{$input}}[0]{$t}}, $v;

                    } else { $no_value++ }
                    }

                if ($no_value) { 
                    _selection_add($tag,$final,$input,\$choices,$num);
                    #my ($t,$v) = @{$tag->{'all'}};
                    #unless (defined ${$final->{$input}}[0]{$t}) {
                        #$choices .= "$num, ";
                        #push @{${$final->{$input}}[0]{$t}}, $v
                    #}
                }

                $choices = substr($choices, 0, -2);
                $choices .= ', ';

            } elsif (ref $tag) { 
                _selection_add($tag,$final,$input,\$choices,$num);
                #my ($t,$v) = @{$tag->{'all'}};
                #unless (defined ${$final->{$input}}[0]{$t}) {
                    #$choices .= "$num, ";
                    #push @{${$final->{$input}}[0]{$t}}, $v
                #}
            } 
        }
        $choices = substr($choices, 0, -2) if $choices;
        if ($final) {
            print "\nYou have chosen the following tags:\n$choices\n";
            print "This will be written to the config file as:\n";
            print Dump $final;
            print "\nIs this correct? (y or n)\n";
        } else { print "\nInvalid selection. Please try again\n" }
    }
    push @{$YAML->{$input}}, $final->{$input};
    conf_write();
}

#  words_tag() splits each tag value string into multiple words so that the 
#  user can select the parts he/she wants to use for curation
#  it can tag 702 (a - zz) separate words; this should be enough

sub words_tag {

    my ($feat, $entry) = @_;

    my @tags;

    @tags[1,2] = ({'all' => ['primary_tag', $feat->primary_tag]}, {'all' => ['location', $feat->start.'..'.$feat->end]});
    my $i = 3;
    foreach my $tag ($feat->all_tags) {
        foreach my $value ($feat->each_tag_value($tag)) {

            my ($string, $tagged_string);

            my @words = split(/(?=\w+?)/, $value);

            my $pos = 0;


            foreach my $word (@words) {

                (my $sanitized_word = $word) =~ s/\W+?//g;
                $string .= $word;

                my $lead = int($pos/ALPHABET_DIVISOR);
                my $lag = $pos % ALPHABET_DIVISOR;

                my $a =  $lead ? ${(ALPHABET)}[$lead-1] : '';
                $a .= $lag ? ${(ALPHABET)}[$lag] : 'a';

                $tagged_string .= " ($a) $word";

                $tags[$i]{$a} = [$tag, $sanitized_word];
                $pos++;
            }

            $value = $tagged_string if scalar(@words) > 1;

            $$entry .= "[$i] /$tag=\"$value\"\r";

            $tags[$i]{'all'} = [$tag, $string];
        }
        $i++;
    }

    return @tags;
    
}

sub alpha_expand {

    my ($dangling_alphas, $selections) = @_;

    if (defined($dangling_alphas) && $dangling_alphas =~ /(\d)*([[:alpha:]]+)-([[:alpha:]]+)/) {

        my $digit = $1;
        push @$selections, $digit if $digit;

        my $start = $2;
        my $stop = $3;

        my @starts = split('', $start);
        my @stops = split('', $stop);

        my ($final_start, $final_stop);

        for ([\$final_start, \@starts], [\$final_stop, \@stops]) {

            my ($final, $splits) = @$_;

            my $int = ${(ALPHABET_TO_NUMBER)}{$$splits[0]};
            my $rem;


            if ($$splits[1]) {
                $rem = ${(ALPHABET_TO_NUMBER)}{$$splits[1]};
                $int++
            } else {
                $rem = $int;
                $int = 0;
            }


            $$final = $int * ALPHABET_DIVISOR;
            $$final += $rem;

        }

        my $last_number = pop @$selections;
        for my $pos ($final_start..$final_stop) {
            my $lead = int($pos/ALPHABET_DIVISOR);
            my $lag = $pos % ALPHABET_DIVISOR;
            my $alpha =  $lead ? ${(ALPHABET)}[$lead-1] : '';
            $alpha .= $lag ? ${(ALPHABET)}[$lag] : 'a';
            push @$selections, $last_number.$alpha;        
        }

    } elsif (defined($dangling_alphas)) { 
        if ($dangling_alphas =~ /^\d/) {
            push @$selections, $dangling_alphas;
        } elsif ($dangling_alphas =~ /^\D/) {
            #print "$dangling_alphas ".Dumper @$selections;
            my $last_number = pop @$selections;
            $last_number ||= '';
            push @$selections, $last_number.$dangling_alphas;
            #$$selections[-1] .= $dangling_alphas;
        }
    }

}

sub _selection_add {

    my ($tag, $final, $input, $choices, $num) = @_;
    my ($t,$v) = @{$tag->{'all'}};
    unless (defined ${$final->{$input}}[0]{$t}) {
        $$choices .= "$num, ";
        push @{${$final->{$input}}[0]{$t}}, $v
    }

}
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_generate_histogram.pl000444000765000024       711312254227321 23406 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;
use lib '.','./blib','../../blib/lib';
use Bio::DB::GFF;
use Getopt::Long;

my $usage = <       Data source (default dbi:mysql:test)
   --adaptor       Schema adaptor (default dbi::mysqlopt)
   --user             Username for mysql authentication
   --pass         Password for mysql authentication
   --bin                Bin size in base pairs.
   --aggregator       Comma-separated list of aggregators
   --sort                   Sort the resulting list by type and bin
   --merge                  Merge features with same method but different sources
USAGE
;

my ($DSN,$ADAPTOR,$AGG,$USER,$PASSWORD,$BINSIZE,$SORT,$MERGE);
GetOptions ('dsn:s'         => \$DSN,
	    'adaptor:s'     => \$ADAPTOR,
	    'user:s'        => \$USER,
	    'password:s'    => \$PASSWORD,
            'aggregators:s' => \$AGG,
            'bin:i'         => \$BINSIZE,
	    'sort'          => \$SORT,
	    'merge'         => \$MERGE,
	   ) or die $usage;

my @types = @ARGV or die $usage;

# some local defaults
$DSN     ||= 'dbi:mysql:test';
$ADAPTOR ||= 'dbi::mysqlopt';
$BINSIZE ||= 1_000_000;   # 1 megabase bins

my @options;
push @options,(-user=>$USER)     if defined $USER;
push @options,(-pass=>$PASSWORD) if defined $PASSWORD;
push @options,(-aggregator=>[split /\s+/,$AGG]) if defined $AGG;

my $db = Bio::DB::GFF->new(-adaptor=>$ADAPTOR,-dsn => $DSN,@options)
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";

my @features = $db->features(-binsize=>$BINSIZE,-types=>\@types);

if ($MERGE) {
  my %MERGE;
  for my $f (@features) {
    my $name  = $f->name;
    my $class = $name->class;
    $name =~ s/^(.+:.+):.+$/$1/;
    $f->group(Bio::DB::GFF::Featname->new($class,$name));
    my $source = $f->source;
    $source =~ s/:.+$//;
    $f->source($source);
    if (my $already_there = $MERGE{$f->source,$f->abs_ref,$f->abs_start}) {
      $already_there->score($already_there->score + $f->score);
    } else {
      $MERGE{$f->source,$f->abs_ref,$f->abs_start} = $f;
    }
  }
  @features = values %MERGE;
}

# sort features by type, ref and start if requested
if ($SORT) {
  @features = sort {
    $a->type cmp $b->type
      || $a->abs_ref cmp $b->abs_ref
	|| $a->start <=> $b->start
      }
    @features;
}

for my $f (@features) {
  print $f->gff_string,"\n";
}


__END__

=head1 NAME

bp_generate_histogram.pl -- Generate a histogram of Bio::DB::GFF features

=head1 SYNOPSIS

  bp_generate_histogram.pl -d gadfly variation gene:curated

=head1 DESCRIPTION

Use this utility to generate feature density histograms from
Bio::DB::GFF databases.  The result is a GFF data file that is
suitable for loading with load_gff.pl.

=head2 OPTIONS

The following options are recognized:

  Option        Description
  ------        -----------

   --dsn               Data source (default dbi:mysql:test)
   --adaptor       Schema adaptor (default dbi::mysqlopt)
   --user             Username for mysql authentication
   --pass         Password for mysql authentication
   --aggregator       Comma-separated list of aggregators

=head1 BUGS

Please report them.

=head1 SEE ALSO

L

=head1 AUTHOR

Lincoln Stein Elstein@cshl.orgE

Copyright (c) 2001 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_load_gff.pl000444000765000024      1403612254227316 21326 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;
use lib '../blib/lib';
use Bio::DB::GFF;
use Getopt::Long;

=head1 NAME

bp_load_gff.pl - Load a Bio::DB::GFF database from GFF files.

=head1 SYNOPSIS

  % bp_load_gff.pl -d testdb -u user -p pw
     --dsn 'dbi:mysql:database=dmel_r5_1;host=myhost;port=myport'
        dna1.fa dna2.fa features1.gff features2.gff ...

=head1 DESCRIPTION

This script loads a Bio::DB::GFF database with the features contained
in a list of GFF files and/or FASTA sequence files.  You must use the
exact variant of GFF described in L.  Various
command-line options allow you to control which database to load and
whether to allow an existing database to be overwritten.

This script uses the Bio::DB::GFF interface, and so works with all
database adaptors currently supported by that module (MySQL, Oracle,
PostgreSQL soon).  However, it is slow.  For faster loading, see the
MySQL-specific L and L scripts.

=head2 NOTES

If the filename is given as "-" then the input is taken from standard
input. Compressed files (.gz, .Z, .bz2) are automatically
uncompressed.

FASTA format files are distinguished from GFF files by their filename
extensions.  Files ending in .fa, .fasta, .fast, .seq, .dna and their
uppercase variants are treated as FASTA files.  Everything else is
treated as a GFF file.  If you wish to load -fasta files from STDIN,
then use the -f command-line swith with an argument of '-', as in 

    gunzip my_data.fa.gz | bp_fast_load_gff.pl -d test -f -

On the first load of a database, you will see a number of "unknown
table" errors.  This is normal.

About maxfeature: the default value is 100,000,000 bases.  If you have
features that are close to or greater that 100Mb in length, then the
value of maxfeature should be increased to 1,000,000,000, or another
power of 10.

=head1 COMMAND-LINE OPTIONS

Command-line options can be abbreviated to single-letter options.
e.g. -d instead of --database.

   --dsn            Data source (default dbi:mysql:test)
   --adaptor    Schema adaptor (default dbi::mysqlopt)
   --user          Username for mysql authentication
   --pass      Password for mysql authentication
   --fasta         Fasta file or directory containing fasta files for the DNA
   --create              Force creation and initialization of database
   --maxfeature          Set the value of the maximum feature size (default 100 Mb; must be a power of 10)
   --group               A list of one or more tag names (comma or space separated)
                          to be used for grouping in the 9th column.
   --upgrade             Upgrade existing database to current schema
   --gff3_munge          Activate GFF3 name munging (see Bio::DB::GFF)
   --quiet               No progress reports
   --summary             Generate summary statistics for drawing coverage histograms.
                           This can be run on a previously loaded database or during
                           the load.

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Lincoln Stein, lstein@cshl.org

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

my ($DSN,$ADAPTOR,$CREATE,$USER,$PASSWORD,$FASTA,$UPGRADE,$MAX_BIN,$GROUP_TAG,$MUNGE,$QUIET,$SUMMARY_STATS);

GetOptions ('dsn:s'                  => \$DSN,
	    'adaptor:s'              => \$ADAPTOR,
	    'u|user:s'               => \$USER,
	    'p|password:s'           => \$PASSWORD,
            'fasta:s'                => \$FASTA,
            'upgrade'                => \$UPGRADE,
            'maxbin|maxfeature:s'    => \$MAX_BIN,
	    'group:s'                => \$GROUP_TAG,
	    'gff3_munge'             => \$MUNGE,
	    'quiet'                  => \$QUIET,
	    'summary'                => \$SUMMARY_STATS,
	    'create'                 => \$CREATE) or (system('pod2text',$0), exit -1);

# some local defaults
$DSN     ||= 'dbi:mysql:test';
$ADAPTOR ||= 'dbi::mysqlopt';
$MAX_BIN ||= 1_000_000_000; # to accomodate human-sized chromosomes

my @args;
push @args,(-user=>$USER)     if defined $USER;
push @args,(-pass=>$PASSWORD) if defined $PASSWORD;
push @args,(-preferred_groups=>[split(/[,\s+]+/,$GROUP_TAG)]) if defined $GROUP_TAG;
push @args,(-create=>1)       if $CREATE;
push @args,(-write=>1);

my $db = Bio::DB::GFF->new(-adaptor=>$ADAPTOR,-dsn => $DSN,@args)
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";

$db->gff3_name_munging(1) if $MUNGE;

if ($CREATE) {
    $SUMMARY_STATS++;
    $MAX_BIN ? $db->initialize(-erase=>1,-MAX_BIN=>$MAX_BIN) :
               $db->initialize(1);
} elsif ($UPGRADE) {
  warn qq(expect to see several "table already exists" messages\n);
  $db->initialize(0);
  my $dbi = $db->dbh;  # get the raw database handle
  my ($count) = $dbi->selectrow_array('SELECT COUNT(*) FROM fnote');
  if (defined($count) && $count > 0) {
    warn qq(fnote table detected.  Translating into fattribute table.  This may take a while.\n);
    $dbi->do("INSERT INTO fattribute VALUES (1,'Note')") or die "failed: ",$dbi->errstr;
    $dbi->do("INSERT INTO fattribute_to_feature (fid,fattribute_id,fattribute_value) SELECT fnote.fid,1,fnote FROM fnote") or die "failed: ",$dbi->errstr;
    warn qq(Schema successfully upgraded.  You might want to drop the fnote table when you're sure everything's working.\n);
  }
}

my (@gff,@fasta);
foreach (@ARGV) {
  if (/\.(fa|fasta|dna|seq|fast)$/i) {
    push @fasta,$_;
  } else {
    push @gff,$_;
  }
}

for my $file (@gff) {
  warn "$file: loading...\n";
  my $loaded = $db->load_gff($file,!$QUIET);
  warn "$file: $loaded records loaded\n";
}

unshift @fasta,$FASTA if defined $FASTA;

for my $file (@fasta) {
  warn "Loading fasta ",(-d $file?"directory":"file"), " $file\n";
  my $loaded = $db->load_fasta($file,!$QUIET);
  warn "$file: $loaded records loaded\n";
}

if ($SUMMARY_STATS) {
    warn "Building summary statistics for coverage histograms...\n";
    $db->build_summary_statistics;
}
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_meta_gff.pl000444000765000024       426612254227324 21320 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;
use DBI;
use Getopt::Long;
use Bio::DB::GFF;

=head1 NAME

bp_meta_gff.pl - Get/set Bio::DB::GFF meta-data

=head1 SYNOPSIS

  # set the following meta data values
  % bp_meta_gff.pl -d testdb tag1=value1 tag2=value2

  # get the indicated meta data value
  % bp_meta_gff.pl -d testdb tag1 tag2

=head1 DESCRIPTION

This script gets or sets metadata in a Bio::DB::GFF database.  Not all
adaptors support this operation!  To set a series of tags, pass a set
of tag=value pairs to the script.  To get the contents of a series of
tags, pass the bare tag names.

The output from the get operation will be an easily parseable set of
tag=value pairs, one per line.

=head1 COMMAND-LINE OPTIONS

Command-line options can be abbreviated to single-letter options.
e.g. -d instead of --database.

   --database       Mysql database name (default dbi:mysql:test)
   --adaptor    Mysql adaptor (default dbi::mysqlopt)
   --user          Username for mysql authentication
   --pass      Password for mysql authentication

=head1 SEE ALSO

L

=head1 AUTHOR

Lincoln Stein, lstein@cshl.org

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

my ($DSN,$ADAPTOR,$USER,$PASSWORD);

GetOptions ('database:s'    => \$DSN,
	    'adaptor:s'     => \$ADAPTOR,
	    'user:s'      => \$USER,
	    'password:s'  => \$PASSWORD,
	   ) or (system('pod2text', $0), exit -1);

$DSN     ||= 'dbi:mysql:test';
$ADAPTOR ||= 'dbi::mysqlopt';

my @args;
push @args,(-user=>$USER)     if defined $USER;
push @args,(-pass=>$PASSWORD) if defined $PASSWORD;

my $db = Bio::DB::GFF->new(-adaptor=>$ADAPTOR,-dsn => $DSN,@args)
  or die "Can't open database: ",Bio::DB::GFF->error,"\n";

for my $pair (@ARGV) {
  my ($tag,$value) = split /=/,$pair;
  if ($value) {  # set operation
    $db->meta($tag,$value);
    unless ($db->meta($tag) eq $value) {
      print STDERR "value for '$tag' not set; perhaps this adaptor does not support meta data?\n";
    }
  } else {
    print "$tag=",$db->meta($tag),"\n";
  }
}

__END__
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_process_gadfly.pl000444000765000024      1566612254227332 22601 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl
if ($ARGV[0]=~/^-?-h/ || @ARGV < 1) {
die <<'USAGE';

This script massages the RELEASE 3 Flybase/Gadfly GFF files located at
http://www.fruitfly.org/sequence/release3download.shtml into the
"correct" version of the GFF format.

To use this script, download the whole genome FASTA file and save it
to disk.  (The downloaded file will be called something like
"na_whole-genome_genomic_dmel_RELEASE3.FASTA", but the link on the
HTML page doesn't give the filename.)  Do the same for the whole
genome GFF annotation file (the saved file will be called something
like "whole-genome_annotation-feature-region_dmel_RELEASE3.GFF".)  If
you wish you can download the ZIP compressed versions of these files.

Next run this script on the two files, indicating the name of the
downloaded FASTA file first, followed by the gff file:

 % process_gadfly.pl na_whole-genome_genomic_dmel_RELEASE3.FASTA whole-genome_annotation-feature-region_dmel_RELEASE3.GFF > fly.gff

The gadfly.gff file and the fasta file can now be loaded into a Bio::DB::GFF database
using the following command:

  % bulk_load_gff.pl -d fly -fasta na_whole-genome_genomic_dmel_RELEASE3.FASTA fly.gff 

(Where "fly" is the name of the database.  Change it as appropriate.
The database must already exist and be writable by you!)

The resulting database will have the following feature types
(represented as "method:source"):

  Component:arm              A chromosome arm
  Component:scaffold	     A chromosome scaffold (accession #)
  Component:gap	             A gap in the assembly
  clone:clonelocator         A BAC clone
  gene:gadfly                A gene accession number
  transcript:gadfly          A transcript accession number
  translation:gadfly         A translation
  codon:gadfly               Significance unknown
  exon:gadfly                An exon
  symbol:gadfly              A classical gene symbol
  similarity:blastn          A BLASTN hit
  similarity:blastx          A BLASTX hit
  similarity:sim4            EST->genome using SIM4
  similarity:groupest        EST->genome using GROUPEST
  similarity:repeatmasker    A repeat

IMPORTANT NOTE: This script will *only* work with the RELEASE3 gadfly
files and will not work with earlier releases.

USAGE
;
}

use strict;
use warnings;

foreach (@ARGV) {
  $_ = "gunzip -c $_ |" if /\.gz$/;
}

if ($ARGV[0] =~ /fasta/i) {
  process_fasta();
} else {
  die "call as process_gadfly.pl \"release3_dna.FASTA\" \"release3_features.GFF\"";
}

while (<>) {
  next if /^\#/;
  chomp;
  my ($ref,$csource,$cmethod,$start,$stop,$cscore,$strand,$cphase,$cgroup) = split "\t";
  next if $start > $stop;  # something wrong. Don't bother fixing it.

  my $fixed_group = fix_group($csource,$cmethod,$cgroup);
  print join("\t",$ref,$csource,$cmethod,$start,$stop,$cscore,$strand,$cphase,$fixed_group),"\n";
  dump_symbol($ref,$csource,$cmethod,$start,$stop,$cscore,$strand,$cphase,$cgroup) if $cgroup =~ /symbol/i;
}

sub fix_group {
  my ($source,$method,$group) = @_;
  my (@group,$gene);
  push @group,"Transcript $1" if $group =~ /transgrp=([^; ]+)/;
  push @group,"Gene $1"       if $method eq 'gene' && $group =~ /genegrp=([^; ]+)/;

  $gene ||= qq(Note "FlyBase $1")  if $group =~ /dbxref=FlyBase:(\w+)/;
  $gene ||= qq(Note "GadFly $1")   if $group =~ /genegrp=([^; ]+)/;
  push @group,qq(Note "Symbol $1") if $group =~ /symbol=([^; ]+)/ && "Gene $1" ne $group[0];
  push @group,$gene;
  return join ' ; ',@group;
}

# called when we encounter a gene symbol
sub dump_symbol {
  my ($ref,$csource,$cmethod,$start,$stop,$cscore,$strand,$cphase,$cgroup) = @_;
  my ($symbol) = $cgroup=~/symbol=([^;]+)/;
  my ($gene)   = $cgroup=~/genegrp=([^;]+)/;
  return if $symbol eq $gene;
  $cmethod = 'symbol';
  print join("\t",$ref,$csource,$cmethod,$start,$stop,$cscore,$strand,$cphase,qq(Symbol "$symbol")),"\n";
}

sub process_fasta {
  my $file = shift @ARGV;
  open F,$file or die "Can't open $file: $!";
  print STDERR "Reading big FASTA file, please be patient...\n";
  my ($current_id,%lengths);
  while () {
    if (/^>(\S+)/) {
      $current_id = $1;
      next;
    }
    die "this doesn't look like a fasta file to me" unless $current_id;
    chomp;
    $lengths{$current_id} += length;
  }
  foreach (sort keys %lengths) {
    print join("\t",$_,'arm','Component',1,$lengths{$_},'.','+','.',qq(Sequence "$_")),"\n";
  }
}

__END__

=head1 NAME

bp_process_gadfly.pl - Massage Gadfly/FlyBase GFF files into a version suitable for the Generic Genome Browser

=head1 SYNOPSIS

  % bp_process_gadfly.pl ./RELEASE2 > gadfly.gff

=head1 DESCRIPTION

This script massages the RELEASE 3 Flybase/Gadfly GFF files located at
http://www.fruitfly.org/sequence/release3download.shtml into the "correct"
version of the GFF format.

To use this script, download the whole genome FASTA file and save it
to disk.  (The downloaded file will be called something like
"na_whole-genome_genomic_dmel_RELEASE3.FASTA", but the link on the
HTML page doesn't give the filename.)  Do the same for the whole
genome GFF annotation file (the saved file will be called something
like "whole-genome_annotation-feature-region_dmel_RELEASE3.GFF".)  If
you wish you can download the ZIP compressed versions of these files.

Next run this script on the two files, indicating the name of the
downloaded FASTA file first, followed by the gff file:

 % bp_process_gadfly.pl na_whole-genome_genomic_dmel_RELEASE3.FASTA whole-genome_annotation-feature-region_dmel_RELEASE3.GFF > fly.gff

The gadfly.gff file and the fasta file can now be loaded into a Bio::DB::GFF database
using the following command:

  % bulk_load_gff.pl -d fly -fasta na_whole-genome_genomic_dmel_RELEASE3.FASTA fly.gff 

(Where "fly" is the name of the database.  Change it as appropriate.
The database must already exist and be writable by you!)

The resulting database will have the following feature types
(represented as "method:source"):

  Component:arm              A chromosome arm
  Component:scaffold	     A chromosome scaffold (accession #)
  Component:gap	             A gap in the assembly
  clone:clonelocator         A BAC clone
  gene:gadfly                A gene accession number
  transcript:gadfly          A transcript accession number
  translation:gadfly         A translation
  codon:gadfly               Significance unknown
  exon:gadfly                An exon
  symbol:gadfly              A classical gene symbol
  similarity:blastn          A BLASTN hit
  similarity:blastx          A BLASTX hit
  similarity:sim4            EST->genome using SIM4
  similarity:groupest        EST->genome using GROUPEST
  similarity:repeatmasker    A repeat

IMPORTANT NOTE: This script will *only* work with the RELEASE3 gadfly
files and will not work with earlier releases.

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Lincoln Stein, lstein@cshl.org

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut
BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_process_sgd.pl000444000765000024       710712254227313 22056 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

# This script will convert from SGD format to GFF format
# See http://db.yeastgenome.org/schema/Schema.html

use strict;
use warnings;

# hard-coded length data that I couldn't get directly
my %CHROMOSOMES = (I => 230_203,
		   II => 813_139,
		   III => 316_613,
		   IV  => 1_531_929,
		   V   => 576_869,
		   VI => 270_148,
		   VII => 1_090_937,
		   VIII => 562_639,
		   IX => 439_885,
		   X => 745_444,
		   XI => 666_445,
		   XII => 1_078_173,
		   XIII => 924_430,
		   XIV => 784_328,
		   XV  => 1_091_284,
		   XVI => 948_061,
		   Mit => 85_779);
my @ROMAN = qw(I II III IV V VI VII VIII IX X
	       XI XII XIII XIV XV XVI Mit);

if ($ARGV[0] =~ /^--?h/) {
  die <

This script massages the SGD sequence annotation flat files located at
ftp://genome-ftp.stanford.edu/pub/yeast/data_dump/feature/chromosomal_features.tab
into a version of the GFF format suitable for display by the generic
genome browser.

To use this script, get the SGD chromosomal_features.tab file from the
FTP site listed above, and run the following command:

  % process_sgd.pl chromosomal_features.tab > yeast.gff

The yeast.gff file can then be loaded into a Bio::DB::GFF database
using the following command:

  % bulk_load_gff.pl -d  yeast.gff

USAGE
;
}

# first print out chromosomes
# We hard coded the lengths because they are not available in the features table.
for my $chrom (sort keys %CHROMOSOMES) {
  print join("\t",$chrom,'chromosome','Component',1,$CHROMOSOMES{$chrom},'.','.','.',qq(Sequence "$chrom")),"\n";
}

# this is hard because the SGD idea of a feature doesn't really map onto the GFF idea.
while (<>) {
  chomp;
  my($id,$gene,$aliases,$type,$chromosome,$start,$stop,$strand,$sgdid,$sgdid2,$description,$date) = split "\t";
  my $ref = $ROMAN[$chromosome-1];
  $description =~ s/"/\\"/g;
  $description =~ s/;/\\;/g;

  $strand = $strand eq 'W' ? '+' : '-';
  ($start,$stop) = ($stop,$start) if $strand eq '-';
  die "Strand logic is messed up" if $stop < $start;

  if ($gene) {
     my @aliases = split(/\|/,$aliases);
     my $aliases = join " ; ",map {qq(Alias "$_")} @aliases;
     my $group = qq(Gene "$gene" ; Note "$description");
     $group .= " ; $aliases" if $aliases;
     print join("\t",$ref,'sgd','gene',$start,$stop,'.',$strand,'.',$group),"\n";
     $description .= "\\; AKA @aliases" if @aliases;
  }

  print join("\t",$ref,'sgd',$type,$start,$stop,'.',$strand,'.',qq($type "$id" ; Note "$description")),"\n";
}

__END__

=head1 NAME

bp_process_sgd.pl - Massage SGD annotation flat files into a version suitable for the Generic Genome Browser

=head1 SYNOPSIS

  % bp_process_sgd.pl chromosomal_features.tab > yeast.gff

=head1 DESCRIPTION

This script massages the SGD sequence annotation flat files located at
ftp://genome-ftp.stanford.edu/pub/yeast/data_dump/feature/chromosomal_features.tab
into a version of the GFF format suitable for display by the generic
genome browser.

To use this script, get the SGD chromosomal_features.tab file from the
FTP site listed above, and run the following command:

  % bp_process_sgd.pl chromosomal_features.tab > yeast.gff

The yeast.gff file can then be loaded into a Bio::DB::GFF database
using the following command:

  % bulk_load_gff.pl -d  yeast.gff

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Lincoln Stein, lstein@cshl.org

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut


BioPerl-1.6.923/scripts/Bio-DB-GFF/bp_process_wormbase.pl000444000765000024      1676512254227334 23155 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use constant ACEDB => 'sace://aceserver.cshl.org:2005'; 
use strict;
use warnings;
use Ace;

my @framework = qw(mex-3 spe-15 lin-17 unc-11 dhc-1 unc-40 smg-5
		   unc-13 unc-29 eat-16 lin-11 spe-9 par-6 unc-59 unc-54 mab-9 lin-42
		   sri-71 smu-2 vab-1 bli-2 dpy-10 him-14 mig-5 unc-4 bli-1 sqt-1 rol-1
		   his-14 unc-52 unc-45 par-2 let-805 sel-8 mab-21 daf-4 sma-3 lin-39
		   unc-32 tax-4 ced-9 tra-1 nob-1 daf-1 ced-2 lin-1 unc-17 dpy-13 unc-5
		   smg-7 dif-1 lin-49 elt-1 daf-14 dpy-20 dpy-26 unc-30 tra-3 sup-24
		   rho-1 egl-8 unc-60 srh-36 apx-1 unc-62 let-418 dpy-11 let-413 sel-9
		   unc-42 egl-9 sma-1 sqt-3 odr-3 hda-1 unc-76 gcy-20 skr-5 par-4 unc-51
		   egl-17 lim-6 fox-1 fax-1 lon-2 unc-97 unc-6 unc-18 mec-10 sop-1 mab-18
		   sdc-2 odr-7 unc-9 unc-3 gas-1 ace-1);
my %framework = map {$_=>1} @framework;
my %framework_seen = ();

my $USAGE = < wormbase.gff

It may take a while before you see output from this script, since it
must first fetch gene and protein database from the remote AceDB
running at www.wormbase.org.
The wormbase.gff file can then be loaded into a Bio::DB::GFF database
using the following command:

  % bulk_load_gff.pl -d  wormbase.gff
USAGE
;
#'

die $USAGE if $ARGV[0]=~/^-?-h/i;

my $db = Ace->connect(-url=>ACEDB,
		      -query_timeout=>500) or die "Can't open ace database:",Ace->error;

if (-d $ARGV[0]) {
  @ARGV = <$ARGV[0]/*.gff.gz>;
}

@ARGV || die $USAGE;

foreach (@ARGV) { # GFF FILES
  $_ = "gunzip -c $_ |" if /\.gz$/;
}

my (%NOTES,%LOCUS,%GENBANK,%CONFIRMED,%ORFEOME);
get_confirmed($db,\%CONFIRMED);
get_genbank($db,\%GENBANK);
get_loci($db,\%LOCUS);
get_notes($db,\%NOTES);
get_orfeome($db,\%ORFEOME);

while (<>) {
  chomp;
  next if /^\#/;
  my ($ref,$source,$method,$start,$stop,$score,$strand,$phase,$group) = split /\t/;
  next if $source eq 'assembly_tag';  # don't want 'em, don't need 'em
  $ref    =~ s/^CHROMOSOME_//;
  $group  =~ s/CHROMOSOME_//;

  $source ='' if $source eq '*UNKNOWN*';

  if ($method eq 'Sequence' && ($source eq 'curated' || $source eq 'RNA') && $group =~ /Sequence "(\w+\.\d+[a-z]?)"/) {
    my @notes;
    push @notes,map { qq(Note "$_")        } @{$NOTES{$1}}     if $NOTES{$1};
    push @notes,map { qq(Note "$_")        } @{$LOCUS{$1}}     if $LOCUS{$1};
    push @notes,qq(Confirmed_by "$CONFIRMED{$1}")              if $CONFIRMED{$1};
    $group = join ' ; ',$group,@notes;
    if (my $loci = $LOCUS{$1}) {
      foreach (@$loci) {
        print join("\t",$ref,$source,'gene',$start,$stop,$score,$strand,$phase,"Locus $_"),"\n";
        print join("\t",$ref,'framework','gene',$start,$stop,$score,$strand,$phase,"Locus $_"),"\n" 
          if $framework{$_} && !$framework_seen{$_}++;
      }
    }
  }

  if ($method eq 'Sequence' && $source eq 'Genomic_canonical' && $group =~ /Sequence "(\w+)"/) {
    if (my $accession = $GENBANK{$1}) {
      $group .= qq( ; Note "Genbank $accession");
      print join("\t",$ref,'Genbank',$method,$start,$stop,$score,$strand,$phase,"Genbank \"$accession\""),"\n";
    }
  }

  if ($method eq 'reagent' && $source eq 'Orfeome_project' && $group =~ /PCR_product "([^\"]+)"/) {
    my $amp = $ORFEOME{$1};
    $group .= qq( ; Amplified $amp) if defined $amp;
  }

  # fix variant fields: Variant "T" => Note "T"
  $group =~ s/(?:Variant|Insert) "(\w+)"/Note "$1"/;

  # fix UTR fields
  if ($group =~ /UTR "([35])_UTR:(\S+)"/) {
    $method = 'UTR';
    $source = "$1_UTR";
    $group = qq(Sequence "$2");
  }

  print join("\t",$ref,$source,$method,$start,$stop,$score,$strand,$phase,$group),"\n";
}

sub get_loci {
  my ($db,$hash) = @_;  # hash keys are predicted gene names, values are one or more loci names
  my @genes = $db->fetch(-query=>'find Locus Genomic_sequence',-filltag=>'Genomic_sequence');
  foreach my $obj (@genes) {
    my @genomic = $obj->Genomic_sequence or next;
    foreach (@genomic) {
      push @{$hash->{$_}},$obj;
    }
  }
}

sub get_notes {
  my ($db,$hash) = @_;  # hash keys are predicted gene names, values are one or more brief identifications
  my @genes = $db->fetch(-query=>'find Sequence Brief_identification',-filltag=>'Brief_identification');
  foreach my $obj (@genes) {
    my @notes = $obj->Brief_identification or next;
    $hash->{$obj} = \@notes;
  }
}

sub get_genbank {
  my ($db,$hash) = @_;   # hash keys are cosmid names, values are genbank accessions (1 to 1)
  my @cosmids = $db->fetch(-query=>'find Genome_Sequence Database',-filltag=>'Database');
  for my $cosmid (@cosmids) {
    my ($database,undef,$accession) = $cosmid->Database(1)->row;
    next unless $accession;
    $hash->{$cosmid} = $accession;
  }
}

sub get_confirmed {
  my ($db,$hash) = @_;  # hash keys are predicted gene names, values are confirmation type
  my @confirmed = $db->fetch(-query=>'find Sequence Confirmed_by',-filltag=>'Confirmed_by');
  foreach my $obj (@confirmed) {
    my $confirmed_by = $obj->Confirmed_by || 'Unknown';
    $hash->{$obj} = $confirmed_by;
  }
}

sub get_orfeome {
  my ($db,$hash) = @_;
  my @mv_primers = $db->fetch(-query=>'find PCR_Product mv*',-filltag=>'Amplified');
  for my $obj (@mv_primers) {
    my $amplified = $obj->Amplified;
    $hash->{$obj} = $amplified;
  }
}

__END__

=head1 NAME

bp_process_wormbase.pl - Massage WormBase GFF files into a version suitable for the Generic Genome Browser

=head1 SYNOPSIS

  % bp_process_wormbase.pl ./WS61 > wormbase.gff

=head1 DESCRIPTION

This script massages the Wormbase GFF files located at
ftp://www.wormbase.org/pub/wormbase/GENE_DUMPS into a version of the
GFF format suitable for display by the generic genome browser.  It
mainly adds comments to the annotations and designates certain
well-spaced genetic loci as framework landmarks.

This script requires the AcePerl distribution, which is available on
CPAN (look for the "Ace" module).

To use this script, get the WormBase GFF files from the FTP site
listed above and place them in a directory.  It might be a good idea
to name the directory after the current release, such as WS61.  You do
not need to uncompress the files.

Then give that directory as the argument to this script and capture
the script's output to a file:

  % bp_process_wormbase.pl ./WS61 > wormbase.gff

It may take a while before you see output from this script, since it
must first fetch gene and protein database from the remote AceDB
running at www.wormbase.org.
The wormbase.gff file can then be loaded into a Bio::DB::GFF database
using the following command:

  % bulk_load_gff.pl -d  wormbase.gff

=head1 SEE ALSO

L, L, L

=head1 AUTHOR

Lincoln Stein Elstein@cshl.orgE

Copyright (c) 2002 Cold Spring Harbor Laboratory

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut

BioPerl-1.6.923/scripts/Bio-DB-GFF/README000444000765000024        30612254227332 17360 0ustar00cjfieldsstaff000000000000These are scripts that go with the Bio::DB::GFF module, a basic
seqfeature database.  Install these scripts if you wish to use the
LDAS distributed annotation server or the Generic Genome Browser.

BioPerl-1.6.923/scripts/Bio-DB-SeqFeature-Store000755000765000024          012254227334 21122 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/scripts/Bio-DB-SeqFeature-Store/bp_seqfeature_delete.pl000444000765000024      1107112254227323 26001 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;

use Getopt::Long;
use File::Spec;
use Bio::DB::SeqFeature::Store;

my $DSN      = 'dbi:mysql:test';
my $USER     = '';
my $PASS     = '';
my $ADAPTOR  = 'DBI::mysql';
my $NAME     = 0;
my $TYPE     = 0;
my $ID       = 0;
my $VERBOSE  = 1;
my $TEST     = 0;
my $FAST     = 0;

GetOptions(
	   'dsn|d=s'       => \$DSN,
	   'adaptor=s'   => \$ADAPTOR,
	   'verbose!'    => \$VERBOSE,
           'dryrun|dry-run' => \$TEST,
           'name|n'      => \$NAME,
           'type|t'      => \$TYPE,
           'id'          => \$ID,
           'fast|f'          => \$FAST,
	   'user=s'      => \$USER,
	   'password=s'  => \$PASS,
	   ) || die <  
  Options:
          -d --dsn        The database name ($DSN)
          -a --adaptor    The storage adaptor to use ($ADAPTOR)
          -n --name       Delete features based on name or wildcard pattern (default)
          -t --type       Delete features based on type
          -i --id         Delete features based on primary id
          -v --verbose    Turn on verbose progress reporting (default)
             --noverbose  Turn off verbose progress reporting
          --dryrun        Dry run; report features to be deleted without actually deleting them
          -u --user       User to connect to database as
          -p --password   Password to use to connect to database
          -f --fast       Deletes each item instantly not atomic for full dataset (mainly for deleting massive datasets linked to a type)

Examples:
  
 Delete from mysql database volvox features named f08 f09 f10
     $0 -d volvox -n f08 f09 f10

 Delete features whose names start with f  
     $0 -d volvox -n 'f*'

 Delete all features of type remark, source example
     $0 -d volvox -t remark:example

 Delete all remark features, regardless of source
     $0 -d volvox -t 'remark:*'

 Delete the feature with ID 1234
     $0 -d volvox -i 1234

 Delete all features named f* from a berkeleydb database
     $0 -a berkeleydb -d /usr/local/share/db/volvox -n 'f*'

Remember to protect wildcards against shell interpretation by putting
single quotes around them!
END
    ;

if ($NAME+$TYPE+$ID > 1) {
    die "Please provide only one of the --name, --type or --id options.\nRun \"$0 --help\" for usage.\n";
}

unless (@ARGV) {
    die "Please provide a list of feature names, types or ids.\n Run \"$0 --help\" for usage.\n";
}

my $mode = $ID   ? 'id'
          :$TYPE ? 'type'
          :$NAME ? 'name'
          :'name';


my @options;
@options = ($USER,$PASS) if $USER || $PASS;

my $store = Bio::DB::SeqFeature::Store->new(
					    -dsn     => $DSN,
					    -adaptor => $ADAPTOR,
					    -user    => $USER,
					    -pass    => $PASS,
					    -write    => 1,
    )
  or die "Couldn't create connection to the database";

my @features = retrieve_features($store,$mode,\@ARGV);

if ($VERBOSE || $TEST) {
    print scalar (@features)," feature(s) match.\n\n";
    my $heading;
    foreach (@features) {
	printf "%-20s %-20s %-12s\n%-20s %-20s %-12s\n",
	       'Name','Type','Primary ID',
	       '----','----','----------'
		   unless $heading++;
	printf "%-20s %-20s %-12d\n",$_->display_name,$_->type,$_->primary_id;
    }
    print "\n";
}

if (@features && !$TEST) {
    if($FAST) {
      my $del = 0;
      foreach my $feat(@features) {
        my @tmp_feat = ($feat);
        my $deleted = $store->delete(@tmp_feat);
        $del++ if($deleted);
        if ($VERBOSE && $deleted) {
          print 'Feature ',$del," successfully deleted.\n";
        } elsif (!$deleted) {
          die "An error occurred. Some or all of the indicated features could not be deleted.";
        }
      }
    }
    else {
        my $deleted = $store->delete(@features);
        if ($VERBOSE && $deleted) {
	        print scalar(@features)," features successfully deleted.\n";
        } elsif (!$deleted) {
	        die "An error occurred. Some or all of the indicated features could not be deleted.";
        }
    }
}

exit 0;

sub retrieve_features {
    my($db,$mode,$list) = @_;
    my @features;
    if ($mode eq 'name') {
	@features = map {$db->get_features_by_alias($_)} @$list;
    }
    elsif ($mode eq 'type') {
	my $regexp = glob2regexp(@$list);
	my @types  = grep {/$regexp/} $db->types;
	@features  = $db->get_features_by_type(@types) if @types;
    }
    elsif ($mode eq 'id') {
	@features  = grep {defined $_} map {$db->get_feature_by_primary_id($_)} @$list;
    }
    return @features;
}

sub glob2regexp {
    my @globs = map {
	$_ = quotemeta($_);
	s/\\\*/.*/g;
	s/\?/./g;
	$_ } @_;
    return '^(?:'.join('|',@globs).')$';
 }
BioPerl-1.6.923/scripts/Bio-DB-SeqFeature-Store/bp_seqfeature_gff3.pl000444000765000024       454012254227334 25351 0ustar00cjfieldsstaff000000000000#!/usr/bin/env perl
# AUTHOR: malcolm.cook@stowers-institute.org

use strict;
use warnings;

use Carp;
use Getopt::Long;
use File::Spec;
use Bio::DB::SeqFeature::Store;

#use Carp::Always;

my $DSN;
my $ADAPTOR;
my $VERBOSE  = 1;
my $USER     = '';
my $PASS     = '';
my @gff3opt;

GetOptions(
	   'dsn=s'       => \$DSN,
	   'adaptor=s'   => \$ADAPTOR,
	   'user=s'      => \$USER,
	   'password=s'  => \$PASS,
	   'gff3opt=i{,}'    => \@gff3opt,
	  ) || die <features().

END

$ADAPTOR     ||= 'DBI::mysql';
$DSN         ||= $ADAPTOR eq 'DBI::mysql' ? "mysql_read_default_file=$ENV{HOME}/.my.cnf" : '';

my $store = Bio::DB::SeqFeature::Store->new(
					    -dsn     => $DSN,
					    -adaptor => $ADAPTOR,
					    -user    => $USER,
					    -pass    => $PASS,
					   )
  or die "Couldn't create connection to the database";

# on signals, give objects a chance to call their DESTROY methods
$SIG{TERM} = $SIG{INT} = sub {   undef $store; die "Aborted..."; };

my $seq_stream = $store->get_seq_stream(@ARGV)  or die "failed to get_seq_stream(@ARGV)"; 
while (my $seq = $seq_stream->next_seq) {
  ### 20100725 // genehack
  # Try to call a gff3_string() method, but fall back to gff_string() if $seq
  # doesn't support that. Note that gff_string() is required per
  # Bio::SeqFeatureI, while gff3_string() is not. Currently, only
  # Bio::SeqFeature::Lite implements gff3_string().
  if ( $seq->can( 'gff3_string' )) {
    print $seq->gff3_string(@gff3opt) . "\n";
  }
  elsif ( $seq->can( 'gff_string' )) {
    # since we intend on getting a GFF3 string, make sure to pass the version
    $seq->gff_format->gff_version(3);
    print $seq->gff_string() . "\n";
  }
  else {
    confess "sequence object $seq does not support gff3_string() or gff_string() methods!"
  }
}

exit 0;
BioPerl-1.6.923/scripts/Bio-DB-SeqFeature-Store/bp_seqfeature_load.pl000444000765000024      1516412254227314 25465 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

use strict;
use warnings;

## Used to output the 'usage' message
use Pod::Usage;

## Used to parse command line options
use Getopt::Long;

## Used to create temporary files, if necessary
use File::Spec;

## BioPerl!
use Bio::DB::SeqFeature::Store;
use Bio::DB::SeqFeature::Store::GFF3Loader;



## The available options. Note, these defaults are 'hard coded' into
## the USAGE POD, so if you change one of the defaults (you shouldn't),
## you should update the USAGE.

my $DSN			= 'dbi:mysql:test';
my $SFCLASS		= 'Bio::DB::SeqFeature';
my $ADAPTOR		= 'DBI::mysql';
my $NAMESPACE;
my $VERBOSE		= 1;
my $FAST		= 0;
my $TMP			= File::Spec->tmpdir();
my $IGNORE_SEQREGION	= 0;
my $CREATE		= 0;
my $USER 		= '';
my $PASS 		= '';
my $COMPRESS		= 0;
my $INDEX_SUB		= 1;
my $NOALIAS_TARGET	= 0;
my $SUMMARY_STATS	= 0;
my $NOSUMMARY_STATS  = 0;

## Two flags based on http://stackoverflow.com/questions/1232116
## how-to-create-pod-and-use-pod2usage-in-perl
my $opt_help;
my $opt_man;

GetOptions( 'd|dsn=s'			=> \$DSN,
	    's|seqfeature=s'		=> \$SFCLASS,
	    'n|namespace=s'		=> \$NAMESPACE,
	    'a|adaptor=s'		=> \$ADAPTOR,
	    'v|verbose!'		=> \$VERBOSE,
	    'f|fast'			=> \$FAST,
	    'T|temporary-directory=s'	=> \$TMP,
	    'i|ignore-seqregion'	=> \$IGNORE_SEQREGION,
	    'c|create'			=> \$CREATE,
	    'u|user=s'			=> \$USER,
	    'p|password=s'		=> \$PASS,
	    'z|zip'			=> \$COMPRESS,
	    'S|subfeatures!'		=> \$INDEX_SUB,

	    ## Any good single letter choices here?
	    'noalias-target'		=> \$NOALIAS_TARGET,
	    'summary'			=> \$SUMMARY_STATS,
        'N|nosummary'    => \$NOSUMMARY_STATS,

	    ## I miss '--help' when it isn't there!
	    'h|help!'			=> \$opt_help,
	    'm|man!'			=> \$opt_man,
	  )
  or pod2usage( -message =>
		"\nTry 'bp_seqfeature_load.pl --help' for more information\n",
		-verbose => 0,
		-exitval => 2,
	      );

## Should we output usage information?
pod2usage( -verbose => 1 ) if $opt_help;
pod2usage( -verbose => 2 ) if $opt_man;

## Did we get any files to process?
@ARGV
  or pod2usage( -message =>
		"\nYou need to pass some GFF or fasta files to load\n",
		-verbose => 0,
		-exitval => 2,
	      );



## POD

=head1 NAME

bp_seqfeature_load.pl - Load GFF into a SeqFeature database

=head1 DESCRIPTION

Pass any number of GFF or fasta format files (or GFF with embedded
fasta) to load the features and sequences into a SeqFeature
database. The database (and adaptor) to use is specified on the
command line. Use the --create flag to create a new SeqFeature
database.

=head1 SYNOPSIS

 bp_seqfeature_load.pl [options] gff_or_fasta_file1 [gff_or_fasta_file2 [...]]

Try 'bp_seqfeature_load.pl --help' or '--man' for more information.

=head1 OPTIONS

=over 4

=item -d, --dsn

DBI data source (default dbi:mysql:test)

=item -n, --namespace

The table prefix to use (default undef) Allows several independent
sequence feature databases to be stored in a single database

=item -s, --seqfeature

The type of SeqFeature to create... RTSC (default Bio::DB::SeqFeature)

=item -a, --adaptor

The storage adaptor (class) to use (default DBI::mysql)

=item -v, --verbose

Turn on verbose progress reporting (default true) Use --noverbose to
switch this off.

=item -f, --fast

Activate fast loading. (default 0) Only available for some adaptors.

=item -T, --temporary-directory

Specify temporary directory for fast loading (default
File::Spec->tmpdir())

=item -i, --ignore-seqregion

If true, then ignore ##sequence-region directives in the GFF3 file
(default, create a feature for each region)

=item -c, --create

Create the database and reinitialize it (default false) Note, this
will erase previous database contents, if any.

=item -u, --user

User to connect to database as

=item -p, --password

Password to use to connect to database

=item -z, --zip

Compress database tables to save space (default false)

=item -S, --subfeatures

Turn on indexing of subfeatures (default true) Use --nosubfeatures to
switch this off.

=item --summary

Generate summary statistics for coverage graphs (default false) This
can be run on a previously loaded database or during the load. It will
default to true if --create is used.

=item -N, --nosummary

Do not generate summary statistics to save some space and load time (default if
--create is not specified, use this option to explicitly turn off summary
statistics when --create is specified)

=item --noalias-target

Don't create an Alias attribute whose value is the target_id in a
Target attribute (if the feature contains a Target attribute, the
default is to create an Alias attribute whose value is the target_id
in the Target attribute)

=back

Please see http://www.sequenceontology.org/gff3.shtml for information
about the GFF3 format. BioPerl extends the format slightly by adding a
##index-subfeatures directive. Set this to a true value if you wish
the database to be able to retrieve a feature's individual parts (such
as the exons of a transcript) independently of the top level feature:

  ##index-subfeatures 1

It is also possible to control the indexing of subfeatures on a
case-by-case basis by adding "index=1" or "index=0" to the feature's
attribute list. This should only be used for subfeatures.

Subfeature indexing is true by default. Set to false (0) to save lots
of database space and speed performance. You may use --nosubfeatures
to force this.

=cut





if ($FAST) {
  -d $TMP && -w $TMP
    or die "Fast loading is requested, but I cannot write into the directory $TMP";
  $DSN .= ";mysql_local_infile=1" if $ADAPTOR =~ /mysql/i && $DSN !~ /mysql_local_infile/;
}

my @options;
@options = ($USER,$PASS) if $USER || $PASS;

my $store = Bio::DB::SeqFeature::Store->new
(
    -dsn        => $DSN,
    -namespace  => $NAMESPACE,
    -adaptor    => $ADAPTOR,
    -tmpdir     => $TMP,
    -user       => $USER,
    -pass       => $PASS,
    -write      => 1,
    -create     => $CREATE,
    -compress   => $COMPRESS,
)
or die "Couldn't create connection to the database";

$store->init_database('erase') if $CREATE;
$SUMMARY_STATS++               if $CREATE; # this is a good thing

my $loader = Bio::DB::SeqFeature::Store::GFF3Loader->new
(
    -store              => $store,
    -sf_class           => $SFCLASS,
    -verbose            => $VERBOSE,
    -tmpdir             => $TMP,
    -fast               => $FAST,
    -ignore_seqregion   => $IGNORE_SEQREGION,
    -index_subfeatures  => $INDEX_SUB,
    -noalias_target     => $NOALIAS_TARGET,
    -summary_stats      => $NOSUMMARY_STATS ? 0 : $SUMMARY_STATS,
)
or die "Couldn't create GFF3 loader";

# on signals, give objects a chance to call their DESTROY methods
$SIG{TERM} = $SIG{INT} = sub {  undef $loader; undef $store; die "Aborted..."; };

$loader->load(@ARGV);

exit 0;
BioPerl-1.6.923/scripts/das000755000765000024          012254227330 15535 5ustar00cjfieldsstaff000000000000BioPerl-1.6.923/scripts/das/bp_das_server.pl000444000765000024      3477712254227330 21107 0ustar00cjfieldsstaff000000000000#!/usr/bin/perl

# minimal annotation server

use strict;
use warnings;
use Apache::DBI;
use Bio::DB::GFF;
use CGI qw/header path_info param url request_method/;
use Digest::MD5 'md5_hex';
use Carp;

my $VERSION = 'DAS/1.00';
(my $BASENAME = url(-absolute=>1)) =~ s!http://[^/]+/!!;

use vars qw($DB %ERRCODES %CATEGORIES $HEADER
	    %DSN %TYPE2CATEGORY %TYPEOBJECTS
	    %EXCLUDE
	   );

#         dsn          description              db server    map master
%DSN = (
	'chr22_transcripts'     => [q(EST-predicted transcripts on chr22 from Jean Thierry-Mieg),
				    'dbi:mysql:database=tm_chr22;host=brie3.cshl.org',
				    'http://servlet.sanger.ac.uk:8080/das/ensembl110']
	);
########################################################################################

%ERRCODES = (
	     200 => 'OK',
	     400 => 'Bad command',
	     401 => 'Bad data source',
	     402 => 'Bad command arguments',
	     403 => 'Bad reference object',
	     404 => 'Bad stylesheet',
	     405 => 'Coordinate error',
	     500 => 'Internal server error (oops)',
	     501 => 'Unimplemented feature',
	     );

%CATEGORIES = (
	       component     => [qw(Sequence:Contig Sequence:Link Sequence:Genomic_canonical 
				    static_golden_path_contig:ensembl ensembl_contig:ensembl)],
	       transcription => [qw(Sequence:curated polyA_site stop CpG misc_signal intron exon transcript CDS)],
	       homology      => [qw(similarity)],
	       repeat        => [qw(Alu repeat repeat_region repeat_unit misc_feature)],
	       structural    => [qw(Clone cosmid OLIGO PCR_product structural compression Comment Conflict)],
	       experimental  => [qw(experimental RNAi)],
);

%EXCLUDE = (
	    'static_golden_path_contig:ensembl' => 1,
	    'ensembl_contig:ensembl' => 1,
	    'Sequence:Contig' => 1,
	    );

while (my($c,$v) = each %CATEGORIES) { # invert nicely
  for my $typename (@$v) {
    my $typeobj      = Bio::DB::GFF::Typename->new($typename);
    $TYPE2CATEGORY{$typeobj} = $c;
    $TYPEOBJECTS{$typeobj}   = $typeobj;
  }
}

$HEADER = 0;
my ($junk,$DSN,$OPERATION) = split '/',path_info();

do { error_header('invalid request',400); exit 0 } unless $DSN;
do { list_dsns();   exit 0 } if $DSN eq 'dsn' or $OPERATION eq 'dsn';
do { error_header('invalid data source, use the dsn command to get list',401); exit 0 } unless $DSN{$DSN};

do { error_header('Could not open database',500); exit 0 }
     unless $DB = openDB($DSN);

do { entry_points(); exit 0 } if $OPERATION eq 'entry_points';
do { types();        exit 0 } if $OPERATION eq 'types';
do { features();     exit 0 } if $OPERATION eq 'features';
do { stylesheet();   exit 0 } if $OPERATION eq 'stylesheet';

error_header('invalid request',400);
exit 0;

# -----------------------------------------------------------------
sub openDB {
  my $name = shift;
  my $db = Bio::DB::GFF->new(-adaptor=>'dbi::mysqlopt',-dsn=>$DSN{$name}[1]);
  $db->automerge(0);
  $db->debug(0);
  return $db;
}

# -----------------------------------------------------------------
sub list_dsns {
  my $j = ' 'x3;
  ok_header();
  print qq(\n\n);
  print "\n";

  for my $dsn (sort keys %DSN) {
    print "$j\n";
    print qq($j$j$DSN{$dsn}[0]\n);
    print qq($j$j$DSN{$dsn}[2]/\n);
    print qq($j$jThis is the $DSN{$dsn}[0] database\n);
    print "$j\n";
  }
  print "\n";
}

# -----------------------------------------------------------------
sub entry_points {
  my $segments = get_segments();

  my @parts;
  if ($segments) {
    @parts = map { get_segment_obj(@$_) } @$segments;
    @parts = map { $_->contained_features(-types=>['Sequence:Link','Sequence:Contig','Sequence:Genomic_canonical'],-merge=>0) } @parts;
  } else {
    @parts = grep {$_->name =~ /^CHR/i} $DB->features(-types=>['Sequence:Link','Sequence:Contig','Sequence:Genomic_canonical'],-merge=>0);
  }

  my $url = get_url();

  ok_header();
  print <



END
;

  for my $part (@parts) {
    $part->absolute(1);
    my $name  = $part->name;
    my $st    = $part->start;
    my $en    = $part->stop;
    my $class = $part->class;
    my $length = $part->length;
    my $orientation = $part->strand > 0 ? '+' : '-';
    my $subparts = $part->source =~ /Link|Chromosome|Contig/ ? 'yes' : 'no';
    print qq($name\n);
  }
  print "\n\n";
}

# -----------------------------------------------------------------
# get the features for the segment indicated
sub features {
  my @segments = get_segments() or return;

  my $summary = param('summary');
  my $url = get_url();
  my @filter = param('type');
  my @category = param('category');
  push @filter,make_categories(@category);


  ok_header();
  print <



END
;

  foreach (@segments) {
    my ($reference,$refclass,$start,$stop) = @$_;
    my $seq = get_segment_obj($reference,$refclass,$start,$stop);
    unless ($seq) {
      print qq(\n);
      next;
    }

    if (lc(param('category')) eq 'component') {
      dump_framework($seq);
      next;
    }

    my $r = $seq->refseq;
    my $s = $seq->start;
    my $e = $seq->stop;
    ($s,$e) = ($e,$s) if $s > $e;

    print qq(\n);

    my $iterator = $seq->features(-types=>\@filter,-merge=>0,-iterator=>1);

    while (my $f = $iterator->next_seq) {
      my $type        = $f->type;
      next if $EXCLUDE{$type};

      my $flabel      = $f->info || $f->type;
      my $source      = $f->source;
      my $method      = $f->method;
      my $start       = $f->start;
      my $end         = $f->stop;
      my $score       = $f->score;
      my $orientation = $f->strand;
      my $phase       = $f->phase;
      my $group       = $f->group;
      my $id          = $f->id;

      $phase       ||= 0;
      $orientation ||= 0;
      $score       ||= '-';
      $orientation = $orientation >= 0 ? '+' : '-';

      # hack hack hack
      my $category = transmute($type);
      ($start,$end) = ($end,$start) if $start > $end;

      # group stuff
      my $hash       = $group;
#      my @notes      = $f->notes;
      my @notes;
      my $info       = $f->info;
      my $group_info;

      if (ref($info)) {
	my $class = $info->class;
	$id = "$class:$info";
	if ($DSN eq 'elegans') {
	  $group_info = qq($info);
	}
      } else {
	$hash       = md5_hex($group);
	$group_info = join "\n",map {qq($_)} @notes;
      }

      my ($target,$target_info);
      if (($target = $f->target) && $target->can('start')) {
	my $start = $target->start;
	my $stop  = $target->stop;
	$target_info = qq();
      }

      if ($category eq 'component') {
	my $strt = 1;
	my $stp  = $stop - $start + 1;
	$target_info = qq();
      }

    my $map;
    if ($type =~ /Segment|Link|Genomic_canonical|Contig/i) { $map = qq( reference="yes") } else { $map = qq() }
    $map .= qq( subparts="yes") if $type =~ /Segment|Link/i;

    ## Need not print feature for map in annotation services
    ## The next 2 lines are ucommented at Wash U:
    # if (($DSN ne "welegans") && ($c eq "structural")) {
    # } else {

      print <
      $type
      $method
      $start
      $end
      $score
      $orientation
      $phase
END
;
      if ($hash) {
	print qq(      \n);
	print qq(        $group_info\n)  if $group_info;
	print qq(        $target_info\n) if $target_info;
	print qq(      \n);
      }
      print <
END
      ;
      # }  # End Wash U if statement
    }

    print qq(\n);
  }

print <

END
}

sub dump_framework {
  my $seq = shift;
  my $start = $seq->start;
  my $stop  = $seq->stop;

  my @parts = $seq->contained_features(-type=>['Sequence:Link','Sequence:Genomic_canonical','Sequence:Contig'],-merge=>0);

  print qq(\n);

  for my $part (@parts) {
    my ($st,$en)    = ($part->start,$part->stop);
    my $orientation = $part->strand >= 0 ? '+1' : '-1';
    my $length = $part->length;
    my $type   = $part->type;
    my $method = $type->method;
    my $description = qq(category="component" reference="yes");
    $description .= qq( subparts="yes") unless $part->source eq 'Genomic_canonical';

    print <
   $part
   $method
   $st
   $en
   -
   $orientation
   -
   
      $part
   

END
  ;
  }
  print qq(\n);
}

sub types {
  return all_types() unless param('ref') or param('segment');

  my $type    = param('entry_type') || 'Sequence';
  my $summary = param('summary');
  my $url     = get_url();
  my @filter  = param('type');

  my @segments = get_segments() or return;

  ok_header();

  print <



END
;

  foreach (@segments) {
    my ($reference,$class,$start,$stop) = @$_;
    next unless $reference;
    my $seq = get_segment_obj($reference,$class,$start,$stop) or next;
    unless ($seq) {  #empty section
      print qq(\n);
      print qq(\n);
      next;
    }

    my $s = $seq->start;
    my $e = $seq->stop;

    # use absolute coordinates -- people expect it
    my $name = $seq->refseq;

    print qq(\n);

    my @args = (-enumerate=>1);
    push @args,(-types=>\@filter) if @filter;
    my %histogram = $seq->types(@args);
    foreach (keys %histogram) {
      my ($method,$source) = split ':';
      my $count = $histogram{$_};
      my $category  = transmute($_);
      print qq(\t$count\n)
	unless $EXCLUDE{$_};
    }
    print qq(\n);
  }
print <

END
}

# list of all the types
sub all_types {
  my @methods = $DB->types;

  ok_header();
  my $url = get_url();
  print <




END
    ;

  for my $id (@methods) {
    next if $EXCLUDE{$id};
    my $category = transmute($id);
    my $method   = $id->method;
    my $source   = $id->source;
    print qq(\t\n);
  }

  print <


END
    ;

}

# Big time kludge -- just outputs the prebuilt stylesheet in this
# directory.  Used primarily for testing.
sub stylesheet {
  ok_header();
  open(STYLE, "style.xml");
  while(
Method Class Returns Usage
", join( "", @columns ), "